/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis

! This file was ported from Lean 3 source module ring_theory.witt_vector.structure_polynomial
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.FieldTheory.Finite.Polynomial
import Mathbin.NumberTheory.Basic
import Mathbin.RingTheory.WittVector.WittPolynomial

/-!
# Witt structure polynomials

In this file we prove the main theorem that makes the whole theory of Witt vectors work.
Briefly, consider a polynomial `Φ : mv_polynomial idx ℤ` over the integers,
with polynomials variables indexed by an arbitrary type `idx`.

Then there exists a unique family of polynomials `φ : ℕ → mv_polynomial (idx × ℕ) Φ`
such that for all `n : ℕ` we have (`witt_structure_int_exists_unique`)
```
bind₁ φ (witt_polynomial p ℤ n) = bind₁ (λ i, (rename (prod.mk i) (witt_polynomial p ℤ n))) Φ
```
In other words: evaluating the `n`-th Witt polynomial on the family `φ`
is the same as evaluating `Φ` on the (appropriately renamed) `n`-th Witt polynomials.

N.b.: As far as we know, these polynomials do not have a name in the literature,
so we have decided to call them the “Witt structure polynomials”. See `witt_structure_int`.

## Special cases

With the main result of this file in place, we apply it to certain special polynomials.
For example, by taking `Φ = X tt + X ff` resp. `Φ = X tt * X ff`
we obtain families of polynomials `witt_add` resp. `witt_mul`
(with type `ℕ → mv_polynomial (bool × ℕ) ℤ`) that will be used in later files to define the
addition and multiplication on the ring of Witt vectors.

## Outline of the proof

The proof of `witt_structure_int_exists_unique` is rather technical, and takes up most of this file.

We start by proving the analogous version for polynomials with rational coefficients,
instead of integer coefficients.
In this case, the solution is rather easy,
since the Witt polynomials form a faithful change of coordinates
in the polynomial ring `mv_polynomial ℕ ℚ`.
We therefore obtain a family of polynomials `witt_structure_rat Φ`
for every `Φ : mv_polynomial idx ℚ`.

If `Φ` has integer coefficients, then the polynomials `witt_structure_rat Φ n` do so as well.
Proving this claim is the essential core of this file, and culminates in
`map_witt_structure_int`, which proves that upon mapping the coefficients
of `witt_structure_int Φ n` from the integers to the rationals,
one obtains `witt_structure_rat Φ n`.
Ultimately, the proof of `map_witt_structure_int` relies on
```
dvd_sub_pow_of_dvd_sub {R : Type*} [comm_ring R] {p : ℕ} {a b : R} :
    (p : R) ∣ a - b → ∀ (k : ℕ), (p : R) ^ (k + 1) ∣ a ^ p ^ k - b ^ p ^ k
```

## Main results

* `witt_structure_rat Φ`: the family of polynomials `ℕ → mv_polynomial (idx × ℕ) ℚ`
  associated with `Φ : mv_polynomial idx ℚ` and satisfying the property explained above.
* `witt_structure_rat_prop`: the proof that `witt_structure_rat` indeed satisfies the property.
* `witt_structure_int Φ`: the family of polynomials `ℕ → mv_polynomial (idx × ℕ) ℤ`
  associated with `Φ : mv_polynomial idx ℤ` and satisfying the property explained above.
* `map_witt_structure_int`: the proof that the integral polynomials `with_structure_int Φ`
  are equal to `witt_structure_rat Φ` when mapped to polynomials with rational coefficients.
* `witt_structure_int_prop`: the proof that `witt_structure_int` indeed satisfies the property.
* Five families of polynomials that will be used to define the ring structure
  on the ring of Witt vectors:
  - `witt_vector.witt_zero`
  - `witt_vector.witt_one`
  - `witt_vector.witt_add`
  - `witt_vector.witt_mul`
  - `witt_vector.witt_neg`
  (We also define `witt_vector.witt_sub`, and later we will prove that it describes subtraction,
  which is defined as `λ a b, a + -b`. See `witt_vector.sub_coeff` for this proof.)

## References

* [Hazewinkel, *Witt Vectors*][Haze09]

* [Commelin and Lewis, *Formalizing the Ring of Witt Vectors*][CL21]
-/

open MvPolynomial

open Set

open Finset (range)

open Finsupp (single)

-- This lemma reduces a bundled morphism to a "mere" function,
-- and consequently the simplifier cannot use a lot of powerful simp-lemmas.
-- We disable this locally, and probably it should be disabled globally in mathlib.
attribute [-simp] coe_eval₂_hom

variable {p : ℕ} {R : Type _} {idx : Type _} [CommRing R]

open Witt

open BigOperators

section PPrime

variable (p) [hp : Fact p.Prime]

include hp

/-- `witt_structure_rat Φ` is a family of polynomials `ℕ → mv_polynomial (idx × ℕ) ℚ`
that are uniquely characterised by the property that
```
bind₁ (witt_structure_rat p Φ) (witt_polynomial p ℚ n) =
bind₁ (λ i, (rename (prod.mk i) (witt_polynomial p ℚ n))) Φ
```
In other words: evaluating the `n`-th Witt polynomial on the family `witt_structure_rat Φ`
is the same as evaluating `Φ` on the (appropriately renamed) `n`-th Witt polynomials.

See `witt_structure_rat_prop` for this property,
and `witt_structure_rat_exists_unique` for the fact that `witt_structure_rat`
gives the unique family of polynomials with this property.

These polynomials turn out to have integral coefficients,
but it requires some effort to show this.
See `witt_structure_int` for the version with integral coefficients,
and `map_witt_structure_int` for the fact that it is equal to `witt_structure_rat`
when mapped to polynomials over the rationals. -/
noncomputable def wittStructureRat (Φ : MvPolynomial idx ℚ) (n : ℕ) : MvPolynomial (idx × ℕ) ℚ :=
  bind₁ (fun k => bind₁ (fun i => rename (Prod.mk i) (W_ ℚ k)) Φ) (xInTermsOfW p ℚ n)
#align witt_structure_rat wittStructureRat

theorem wittStructureRat_prop (Φ : MvPolynomial idx ℚ) (n : ℕ) :
    bind₁ (wittStructureRat p Φ) (W_ ℚ n) = bind₁ (fun i => rename (Prod.mk i) (W_ ℚ n)) Φ :=
  calc
    bind₁ (wittStructureRat p Φ) (W_ ℚ n) =
        bind₁ (fun k => bind₁ (fun i => (rename (Prod.mk i)) (W_ ℚ k)) Φ)
          (bind₁ (xInTermsOfW p ℚ) (W_ ℚ n)) :=
      by
      rw [bind₁_bind₁]
      exact eval₂_hom_congr (RingHom.ext_rat _ _) rfl rfl
    _ = bind₁ (fun i => rename (Prod.mk i) (W_ ℚ n)) Φ := by
      rw [bind₁_xInTermsOfW_wittPolynomial p _ n, bind₁_X_right]

#align witt_structure_rat_prop wittStructureRat_prop

theorem witt_structure_rat_existsUnique (Φ : MvPolynomial idx ℚ) :
    ∃! φ : ℕ → MvPolynomial (idx × ℕ) ℚ,
      ∀ n : ℕ, bind₁ φ (W_ ℚ n) = bind₁ (fun i => rename (Prod.mk i) (W_ ℚ n)) Φ :=
  by
  refine' ⟨wittStructureRat p Φ, _, _⟩
  · intro n
    apply wittStructureRat_prop
  · intro φ H
    funext n
    rw [show φ n = bind₁ φ (bind₁ (W_ ℚ) (xInTermsOfW p ℚ n)) by
        rw [bind₁_wittPolynomial_xInTermsOfW p, bind₁_X_right]]
    rw [bind₁_bind₁]
    exact eval₂_hom_congr (RingHom.ext_rat _ _) (funext H) rfl
#align witt_structure_rat_exists_unique witt_structure_rat_existsUnique

theorem wittStructureRat_rec_aux (Φ : MvPolynomial idx ℚ) (n : ℕ) :
    wittStructureRat p Φ n * C (p ^ n : ℚ) =
      bind₁ (fun b => rename (fun i => (b, i)) (W_ ℚ n)) Φ -
        ∑ i in range n, C (p ^ i : ℚ) * wittStructureRat p Φ i ^ p ^ (n - i) :=
  by
  have := xInTermsOfW_aux p ℚ n
  replace := congr_arg (bind₁ fun k : ℕ => bind₁ (fun i => rename (Prod.mk i) (W_ ℚ k)) Φ) this
  rw [AlgHom.map_mul, bind₁_C_right] at this
  rw [wittStructureRat, this]; clear this
  conv_lhs => simp only [AlgHom.map_sub, bind₁_X_right]
  rw [sub_right_inj]
  simp only [AlgHom.map_sum, AlgHom.map_mul, bind₁_C_right, AlgHom.map_pow]
  rfl
#align witt_structure_rat_rec_aux wittStructureRat_rec_aux

/-- Write `witt_structure_rat p φ n` in terms of `witt_structure_rat p φ i` for `i < n`. -/
theorem wittStructureRat_rec (Φ : MvPolynomial idx ℚ) (n : ℕ) :
    wittStructureRat p Φ n =
      C (1 / p ^ n : ℚ) *
        (bind₁ (fun b => rename (fun i => (b, i)) (W_ ℚ n)) Φ -
          ∑ i in range n, C (p ^ i : ℚ) * wittStructureRat p Φ i ^ p ^ (n - i)) :=
  by
  calc
    wittStructureRat p Φ n = C (1 / p ^ n : ℚ) * (wittStructureRat p Φ n * C (p ^ n : ℚ)) := _
    _ = _ := by rw [wittStructureRat_rec_aux]

  rw [mul_left_comm, ← C_mul, div_mul_cancel, C_1, mul_one]
  exact pow_ne_zero _ (Nat.cast_ne_zero.2 hp.1.NeZero)
#align witt_structure_rat_rec wittStructureRat_rec

/-- `witt_structure_int Φ` is a family of polynomials `ℕ → mv_polynomial (idx × ℕ) ℤ`
that are uniquely characterised by the property that
```
bind₁ (witt_structure_int p Φ) (witt_polynomial p ℤ n) =
bind₁ (λ i, (rename (prod.mk i) (witt_polynomial p ℤ n))) Φ
```
In other words: evaluating the `n`-th Witt polynomial on the family `witt_structure_int Φ`
is the same as evaluating `Φ` on the (appropriately renamed) `n`-th Witt polynomials.

See `witt_structure_int_prop` for this property,
and `witt_structure_int_exists_unique` for the fact that `witt_structure_int`
gives the unique family of polynomials with this property. -/
noncomputable def wittStructureInt (Φ : MvPolynomial idx ℤ) (n : ℕ) : MvPolynomial (idx × ℕ) ℤ :=
  Finsupp.mapRange Rat.num (Rat.coe_int_num 0) (wittStructureRat p (map (Int.castRingHom ℚ) Φ) n)
#align witt_structure_int wittStructureInt

variable {p}

theorem bind₁_rename_expand_wittPolynomial (Φ : MvPolynomial idx ℤ) (n : ℕ)
    (IH :
      ∀ m : ℕ,
        m < n + 1 →
          map (Int.castRingHom ℚ) (wittStructureInt p Φ m) =
            wittStructureRat p (map (Int.castRingHom ℚ) Φ) m) :
    bind₁ (fun b => rename (fun i => (b, i)) (expand p (W_ ℤ n))) Φ =
      bind₁ (fun i => expand p (wittStructureInt p Φ i)) (W_ ℤ n) :=
  by
  apply MvPolynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective
  simp only [map_bind₁, map_rename, map_expand, rename_expand, map_wittPolynomial]
  have key := (wittStructureRat_prop p (map (Int.castRingHom ℚ) Φ) n).symm
  apply_fun expand p  at key
  simp only [expand_bind₁] at key
  rw [key]; clear key
  apply eval₂_hom_congr' rfl _ rfl
  rintro i hi -
  rw [wittPolynomial_vars, Finset.mem_range] at hi
  simp only [IH i hi]
#align bind₁_rename_expand_witt_polynomial bind₁_rename_expand_wittPolynomial

theorem c_p_pow_dvd_bind₁_rename_wittPolynomial_sub_sum (Φ : MvPolynomial idx ℤ) (n : ℕ)
    (IH :
      ∀ m : ℕ,
        m < n →
          map (Int.castRingHom ℚ) (wittStructureInt p Φ m) =
            wittStructureRat p (map (Int.castRingHom ℚ) Φ) m) :
    C ↑(p ^ n) ∣
      bind₁ (fun b : idx => rename (fun i => (b, i)) (wittPolynomial p ℤ n)) Φ -
        ∑ i in range n, C (↑p ^ i) * wittStructureInt p Φ i ^ p ^ (n - i) :=
  by
  cases n
  · simp only [isUnit_one, Int.ofNat_zero, Int.ofNat_succ, zero_add, pow_zero, C_1, IsUnit.dvd]
  -- prepare a useful equation for rewriting
  have key := bind₁_rename_expand_wittPolynomial Φ n IH
  apply_fun map (Int.castRingHom (ZMod (p ^ (n + 1))))  at key
  conv_lhs at key => simp only [map_bind₁, map_rename, map_expand, map_wittPolynomial]
  -- clean up and massage
  rw [Nat.succ_eq_add_one, C_dvd_iff_zmod, RingHom.map_sub, sub_eq_zero, map_bind₁]
  simp only [map_rename, map_wittPolynomial, wittPolynomial_zMod_self]
  rw [key]; clear key IH
  rw [bind₁, aeval_wittPolynomial, RingHom.map_sum, RingHom.map_sum, Finset.sum_congr rfl]
  intro k hk
  rw [Finset.mem_range, Nat.lt_succ_iff] at hk
  simp only [← sub_eq_zero, ← RingHom.map_sub, ← C_dvd_iff_zmod, C_eq_coe_nat, ← mul_sub, ←
    Nat.cast_pow]
  rw [show p ^ (n + 1) = p ^ k * p ^ (n - k + 1) by rw [← pow_add, ← add_assoc]; congr 2;
      rw [add_comm, ← tsub_eq_iff_eq_add_of_le hk]]
  rw [Nat.cast_mul, Nat.cast_pow, Nat.cast_pow]
  apply mul_dvd_mul_left
  rw [show p ^ (n + 1 - k) = p * p ^ (n - k) by rw [← pow_succ, ← tsub_add_eq_add_tsub hk]]
  rw [pow_mul]
  -- the machine!
  apply dvd_sub_pow_of_dvd_sub
  rw [← C_eq_coe_nat, C_dvd_iff_zmod, RingHom.map_sub, sub_eq_zero, map_expand, RingHom.map_pow,
    MvPolynomial.expand_zMod]
#align C_p_pow_dvd_bind₁_rename_witt_polynomial_sub_sum c_p_pow_dvd_bind₁_rename_wittPolynomial_sub_sum

variable (p)

@[simp]
theorem map_wittStructureInt (Φ : MvPolynomial idx ℤ) (n : ℕ) :
    map (Int.castRingHom ℚ) (wittStructureInt p Φ n) =
      wittStructureRat p (map (Int.castRingHom ℚ) Φ) n :=
  by
  apply Nat.strong_induction_on n
  clear n
  intro n IH
  rw [wittStructureInt, map_map_range_eq_iff, Int.coe_castRingHom]
  intro c
  rw [wittStructureRat_rec, coeff_C_mul, mul_comm, mul_div_assoc', mul_one]
  have sum_induction_steps :
    map (Int.castRingHom ℚ) (∑ i in range n, C (p ^ i : ℤ) * wittStructureInt p Φ i ^ p ^ (n - i)) =
      ∑ i in range n,
        C (p ^ i : ℚ) * wittStructureRat p (map (Int.castRingHom ℚ) Φ) i ^ p ^ (n - i) :=
    by
    rw [RingHom.map_sum]
    apply Finset.sum_congr rfl
    intro i hi
    rw [Finset.mem_range] at hi
    simp only [IH i hi, RingHom.map_mul, RingHom.map_pow, map_C]
    rfl
  simp only [← sum_induction_steps, ← map_wittPolynomial p (Int.castRingHom ℚ), ← map_rename, ←
    map_bind₁, ← RingHom.map_sub, coeff_map]
  rw [show (p : ℚ) ^ n = ((p ^ n : ℕ) : ℤ) by norm_cast]
  rw [← Rat.den_eq_one_iff, eq_intCast, Rat.den_div_cast_eq_one_iff]
  swap
  · exact_mod_cast pow_ne_zero n hp.1.NeZero
  revert c
  rw [← C_dvd_iff_dvd_coeff]
  exact c_p_pow_dvd_bind₁_rename_wittPolynomial_sub_sum Φ n IH
#align map_witt_structure_int map_wittStructureInt

variable (p)

theorem wittStructureInt_prop (Φ : MvPolynomial idx ℤ) (n) :
    bind₁ (wittStructureInt p Φ) (wittPolynomial p ℤ n) =
      bind₁ (fun i => rename (Prod.mk i) (W_ ℤ n)) Φ :=
  by
  apply MvPolynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective
  have := wittStructureRat_prop p (map (Int.castRingHom ℚ) Φ) n
  simpa only [map_bind₁, ← eval₂_hom_map_hom, eval₂_hom_C_left, map_rename, map_wittPolynomial,
    AlgHom.coe_toRingHom, map_wittStructureInt]
#align witt_structure_int_prop wittStructureInt_prop

theorem eq_wittStructureInt (Φ : MvPolynomial idx ℤ) (φ : ℕ → MvPolynomial (idx × ℕ) ℤ)
    (h : ∀ n, bind₁ φ (wittPolynomial p ℤ n) = bind₁ (fun i => rename (Prod.mk i) (W_ ℤ n)) Φ) :
    φ = wittStructureInt p Φ := by
  funext k
  apply MvPolynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective
  rw [map_wittStructureInt]
  refine' congr_fun _ k
  apply ExistsUnique.unique (witt_structure_rat_existsUnique p (map (Int.castRingHom ℚ) Φ))
  · intro n
    specialize h n
    apply_fun map (Int.castRingHom ℚ)  at h
    simpa only [map_bind₁, ← eval₂_hom_map_hom, eval₂_hom_C_left, map_rename, map_wittPolynomial,
      AlgHom.coe_toRingHom] using h
  · intro n
    apply wittStructureRat_prop
#align eq_witt_structure_int eq_wittStructureInt

theorem witt_structure_int_existsUnique (Φ : MvPolynomial idx ℤ) :
    ∃! φ : ℕ → MvPolynomial (idx × ℕ) ℤ,
      ∀ n : ℕ,
        bind₁ φ (wittPolynomial p ℤ n) = bind₁ (fun i : idx => rename (Prod.mk i) (W_ ℤ n)) Φ :=
  ⟨wittStructureInt p Φ, wittStructureInt_prop _ _, eq_wittStructureInt _ _⟩
#align witt_structure_int_exists_unique witt_structure_int_existsUnique

theorem witt_structure_prop (Φ : MvPolynomial idx ℤ) (n) :
    aeval (fun i => map (Int.castRingHom R) (wittStructureInt p Φ i)) (wittPolynomial p ℤ n) =
      aeval (fun i => rename (Prod.mk i) (W n)) Φ :=
  by
  convert congr_arg (map (Int.castRingHom R)) (wittStructureInt_prop p Φ n) using 1 <;>
      rw [hom_bind₁] <;>
    apply eval₂_hom_congr (RingHom.ext_int _ _) _ rfl
  · rfl
  · simp only [map_rename, map_wittPolynomial]
#align witt_structure_prop witt_structure_prop

theorem wittStructureInt_rename {σ : Type _} (Φ : MvPolynomial idx ℤ) (f : idx → σ) (n : ℕ) :
    wittStructureInt p (rename f Φ) n = rename (Prod.map f id) (wittStructureInt p Φ n) :=
  by
  apply MvPolynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective
  simp only [map_rename, map_wittStructureInt, wittStructureRat, rename_bind₁, rename_rename,
    bind₁_rename]
  rfl
#align witt_structure_int_rename wittStructureInt_rename

@[simp]
theorem constantCoeff_wittStructureRat_zero (Φ : MvPolynomial idx ℚ) :
    constantCoeff (wittStructureRat p Φ 0) = constantCoeff Φ := by
  simp only [wittStructureRat, bind₁, map_aeval, xInTermsOfW_zero, constant_coeff_rename,
    constantCoeff_wittPolynomial, aeval_X, constant_coeff_comp_algebra_map, eval₂_hom_zero'_apply,
    RingHom.id_apply]
#align constant_coeff_witt_structure_rat_zero constantCoeff_wittStructureRat_zero

theorem constantCoeff_wittStructureRat (Φ : MvPolynomial idx ℚ) (h : constantCoeff Φ = 0) (n : ℕ) :
    constantCoeff (wittStructureRat p Φ n) = 0 := by
  simp only [wittStructureRat, eval₂_hom_zero'_apply, h, bind₁, map_aeval, constant_coeff_rename,
    constantCoeff_wittPolynomial, constant_coeff_comp_algebra_map, RingHom.id_apply,
    constantCoeff_xInTermsOfW]
#align constant_coeff_witt_structure_rat constantCoeff_wittStructureRat

@[simp]
theorem constantCoeff_wittStructureInt_zero (Φ : MvPolynomial idx ℤ) :
    constantCoeff (wittStructureInt p Φ 0) = constantCoeff Φ :=
  by
  have inj : Function.Injective (Int.castRingHom ℚ) :=
    by
    intro m n
    exact int.cast_inj.mp
  apply inj
  rw [← constant_coeff_map, map_wittStructureInt, constantCoeff_wittStructureRat_zero,
    constant_coeff_map]
#align constant_coeff_witt_structure_int_zero constantCoeff_wittStructureInt_zero

theorem constantCoeff_wittStructureInt (Φ : MvPolynomial idx ℤ) (h : constantCoeff Φ = 0) (n : ℕ) :
    constantCoeff (wittStructureInt p Φ n) = 0 :=
  by
  have inj : Function.Injective (Int.castRingHom ℚ) :=
    by
    intro m n
    exact int.cast_inj.mp
  apply inj
  rw [← constant_coeff_map, map_wittStructureInt, constantCoeff_wittStructureRat, RingHom.map_zero]
  rw [constant_coeff_map, h, RingHom.map_zero]
#align constant_coeff_witt_structure_int constantCoeff_wittStructureInt

variable (R)

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
-- we could relax the fintype on `idx`, but then we need to cast from finset to set.
-- for our applications `idx` is always finite.
theorem wittStructureRat_vars [Fintype idx] (Φ : MvPolynomial idx ℚ) (n : ℕ) :
    (wittStructureRat p Φ n).vars ⊆ Finset.univ ×ˢ Finset.range (n + 1) :=
  by
  rw [wittStructureRat]
  intro x hx
  simp only [Finset.mem_product, true_and_iff, Finset.mem_univ, Finset.mem_range]
  obtain ⟨k, hk, hx'⟩ := mem_vars_bind₁ _ _ hx
  obtain ⟨i, -, hx''⟩ := mem_vars_bind₁ _ _ hx'
  obtain ⟨j, hj, rfl⟩ := mem_vars_rename _ _ hx''
  rw [wittPolynomial_vars, Finset.mem_range] at hj
  replace hk := xInTermsOfW_vars_subset p _ hk
  rw [Finset.mem_range] at hk
  exact lt_of_lt_of_le hj hk
#align witt_structure_rat_vars wittStructureRat_vars

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
-- we could relax the fintype on `idx`, but then we need to cast from finset to set.
-- for our applications `idx` is always finite.
theorem wittStructureInt_vars [Fintype idx] (Φ : MvPolynomial idx ℤ) (n : ℕ) :
    (wittStructureInt p Φ n).vars ⊆ Finset.univ ×ˢ Finset.range (n + 1) :=
  by
  have : Function.Injective (Int.castRingHom ℚ) := Int.cast_injective
  rw [← vars_map_of_injective _ this, map_wittStructureInt]
  apply wittStructureRat_vars
#align witt_structure_int_vars wittStructureInt_vars

end PPrime


import  .Sup_fin data.finsupp order.lattice data.nat.cast .euclidean_domain unique_factorization_domain
import .to_finsupp poly .to_multiset poly_over_UFD to_field
--import data.multiset
universes u v w

local notation a`~ᵤ`b := associated a b

noncomputable theory

open classical set function finsupp lattice
local attribute [instance] prop_decidable
local attribute [instance] finsupp.to_comm_semiring
local attribute [instance] finsupp.to_semiring
local infix ^ := monoid.pow

namespace polynomial
open associated
variables {α : Type u}

section field

--Naming is incorrect --Belongs in poly over field
lemma leading_coeff_inv_mul_monic_of_ne_zero [field α ] {x : polynomial α} (h : x ≠ 0) : monic ((C (leading_coeff x)⁻¹) * x) :=
begin
  unfold monic,
  rw [leading_coeff_mul_eq_mul_leading_coef],
  simp,
  simp at h,
  rw [←leading_coef_eq_zero_iff_eq_zero] at h,
  exact inv_mul_cancel h
end

lemma leading_coeff_dvd [field α ] {x : polynomial α} : (C (leading_coeff x)) ∣ x :=
begin
  by_cases h1 : (x = 0),
  {
    simp *
  },
  {
    simp [has_dvd.dvd],
    fapply exists.intro,
    exact (C (leading_coeff x)⁻¹)*x,
    rw [←leading_coef_eq_zero_iff_eq_zero, ←ne.def] at h1,
    rw [←mul_assoc, ←C_mul_C, mul_inv_cancel h1],
    simp
  }

end

open associated

def make_monic [field α] (f : polynomial α) := if (f = 0) then 0 else (C (f.leading_coeff)⁻¹ * f)

lemma monic_make_monic_of_ne_zero [field α] (f : polynomial α) (h : f ≠ 0) : monic f.make_monic :=
begin
  simp [make_monic, if_neg, *],
  exact leading_coeff_inv_mul_monic_of_ne_zero h,
end

def monic_out [field α] (a : quot (polynomial α)) : polynomial α :=
quot.lift_on a make_monic (assume f p h,
  begin
    have h1: associated f p,
      from h,
    rcases h1 with ⟨u, hu⟩,
    have hu2: is_unit ↑u,
      from is_unit_unit u,
    by_cases hf : f = 0,
    {
      subst hf,
      have hu3 := hu.symm,
      rw mul_eq_zero_iff_eq_zero_or_eq_zero at hu3,
      cases hu3,
      {
        simp [hu3] at *,
        contradiction,
      },
      {
        subst hu3,
      }
    },
    {
      by_cases hp : p = 0,
      {
        subst hp,
        simp * at *,
      },
      {
        have hp2 : ↑u * p ≠  0,
        {
          rw [ne.def, mul_eq_zero_iff_eq_zero_or_eq_zero],
          rw not_or_distrib,
          exact ⟨ne_zero_of_is_unit zero_ne_one hu2, hp⟩,
        },
        simp [make_monic, if_neg, *],
        rw [leading_coeff_mul_eq_mul_leading_coef, mul_inv_eq, C_mul_C, mul_assoc],
        rw [eq_C_leading_coeff_of_is_unit hu2] {occs := occurrences.pos [2]},
        rw [←mul_assoc (C (leading_coeff ↑u)⁻¹), ←C_mul_C, inv_mul_cancel],
        simp,
        rw [ne.def, leading_coef_eq_zero_iff_eq_zero],
        rw [ne.def, mul_eq_zero_iff_eq_zero_or_eq_zero, not_or_distrib] at hp2,
        exact hp2.1,
        rw [ne.def, leading_coef_eq_zero_iff_eq_zero],
        exact hp,
        rw [ne.def, leading_coef_eq_zero_iff_eq_zero],
        rw [ne.def, mul_eq_zero_iff_eq_zero_or_eq_zero, not_or_distrib] at hp2, --Duplication
        simp *,
      }
    }
  end)

lemma monic_monic_out_of_ne_zero [field α] (f : quot (polynomial α)) (h : f ≠ 0) : monic (monic_out f) :=
begin
  revert h,
  apply quot.induction_on f,
  intros a h,
  apply monic_make_monic_of_ne_zero,
  rw [ne.def, ←mk_eq_zero_iff_eq_zero],
  exact h,
end

/-@[simp] theorem quot.out_eq {r : α → α → Prop} (q : quot r) : quot.mk r q.out = q :=
classical.some_spec (quot.exists_rep q)-/

lemma polynomial_fac [field α] (x : polynomial α) : ∃ c :  α, ∃ p : multiset (polynomial α), x = C c * p.prod ∧ (∀x∈p, irreducible x ∧ monic x)  :=
begin
  by_cases h1 : (x = 0),
  {
    fapply exists.intro,
    exact 0,
    fapply exists.intro,
    exact 0,
    simp [C_0, h1],
  },
  {
    by_cases h2 : (is_unit x),
    {
      have h3: ∃c : α, x =  C c,
      from is_constant_of_is_unit h2,
      let c := some h3,
      fapply exists.intro,
      exact c,
      fapply exists.intro,
      exact 0,
      simp,
      exact some_spec h3
    },
    {
      let f := some (unique_factorization_domain.fac h1 h2),
      have h3 : x = f.prod ∧ (∀x∈f, irreducible x),
      from some_spec (unique_factorization_domain.fac h1 h2),
      have h3a : x = multiset.prod f,
      from and.elim_left h3,
      have h3b : ∀ (x : polynomial α), x ∈ f → irreducible x,
      from and.elim_right h3,
      fapply exists.intro,
      exact (f.map leading_coeff).prod,
      fapply exists.intro,
      exact (f.map (λ y, (C (leading_coeff y)⁻¹ )*y) ),
      constructor,
      {
        rw h3a,
        rw [C_prod_eq_map_C_prod, multiset.map_map],--, ←multiset.prod_add

        have h4 : ∀ g : multiset (polynomial α), (∀ (y : polynomial α), y ∈ g → irreducible y) → multiset.prod g =
    C (multiset.prod (multiset.map leading_coeff g)) *
      multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) g),
      {
        apply @multiset.induction _ (λ (g : multiset (polynomial α)),
    (∀ (y : polynomial α), y ∈ g → irreducible y) →
    multiset.prod g =
      C (multiset.prod (multiset.map leading_coeff g)) *
        multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) g)),
        {
          simp [multiset.map_zero, multiset.map_zero, multiset.zero_add (0 : multiset (polynomial α))]
        },
        {
          intros a s h4 h5,
          have h5a : ∀ (y : polynomial α), y ∈ s → irreducible y,
          {
            intros y h6,
            have : y ∈ a::s,
            {simp *},
            exact h5 y this,
          },
          have h4a : multiset.prod s =
    C (multiset.prod (multiset.map leading_coeff s)) *
      multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s),
          from h4 h5a,
          have h6 : irreducible a,
          {
            apply h5 a,
            simp,
          },
          have h7 : leading_coeff a ≠ 0,
          {
            have : a ≠ 0,
            from and.elim_left h6,
            rw [ne.def, leading_coef_eq_zero_iff_eq_zero],
            assumption
          },
          clear h4,
          simp only [multiset.map_cons, multiset.prod_cons, C_prod_eq_map_C_prod],
          apply eq.symm,
          calc C (leading_coeff a * multiset.prod (multiset.map leading_coeff s)) *
      (C (leading_coeff a)⁻¹ * a *
         multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s)) =
         (C (leading_coeff a) * C (multiset.prod (multiset.map leading_coeff s)) ) *
      (C (leading_coeff a)⁻¹) * a *
         multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s) : by simp [C_mul_C, mul_assoc]
         ... = (C (leading_coeff a) * (C (multiset.prod (multiset.map leading_coeff s))  *
      (C (leading_coeff a)⁻¹))) * a *
         multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s) : by simp [mul_assoc]
          ... = (C (leading_coeff a) * ( (C (leading_coeff a)⁻¹) *
      C (multiset.prod (multiset.map leading_coeff s)) )) * a *
         multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s) : by rw [mul_comm (C (leading_coeff a)⁻¹) _]
        ... = C (leading_coeff a) *  (C (leading_coeff a)⁻¹) *
              (C (multiset.prod (multiset.map leading_coeff s))  * a) *
                multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s) : by simp only [mul_assoc]
        ... = C (leading_coeff a) *  (C (leading_coeff a)⁻¹) *
              (a  * C (multiset.prod (multiset.map leading_coeff s))) *
                multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s) : by rw [mul_comm _ a]
         ... = C (leading_coeff a) *  (C (leading_coeff a)⁻¹) *
              a  * (C (multiset.prod (multiset.map leading_coeff s)) *
                multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) s)) : by simp only [mul_assoc]
          ... = C (leading_coeff a) *  (C (leading_coeff a)⁻¹) *
              a  * (multiset.prod s) : by rw ←h4a
          ... = C ((leading_coeff a) * ((leading_coeff a)⁻¹)) *
              a  * (multiset.prod s) : by simp [C_mul_C, mul_assoc]
          ... = C 1 * a * (multiset.prod s) : by rw [mul_inv_cancel h7]
         ... = _ : by simp,
        }
      },
      have : multiset.prod f =
      C (multiset.prod (multiset.map leading_coeff f)) *
        multiset.prod (multiset.map (λ (y : polynomial α), C (leading_coeff y)⁻¹ * y) f),
      from h4 f h3b,
      rw [C_prod_eq_map_C_prod, multiset.map_map] at this,
      exact this,
      },
      intros y h1,
      constructor,
      {
         --Must make lemmas for irreducible
         rw multiset.mem_map at h1,
         let a := some h1,
         have h4 : a ∈ f ∧ C (leading_coeff a)⁻¹ * a = y,
         from some_spec h1,
         have h4a : a ∈ f,
         from and.elim_left h4,
         have h5 : irreducible a,
         from h3b a h4a,
         have h4b : C (leading_coeff a)⁻¹ * a = y,
         from and.elim_right h4,
         have h6 : is_unit (C (leading_coeff a)⁻¹),
         {
           apply is_unit_of_is_unit,
           apply for_all_is_unit_of_not_zero,
           apply inv_ne_zero,
           rw [ne.def, leading_coef_eq_zero_iff_eq_zero],
           exact h5.1,
         },
         have h7 : (y ~ᵤ a),
         {
           rcases h6 with ⟨u, hu⟩,
           exact ⟨u, by simp * at *⟩,

         },
         have h8 : (a ~ᵤ y),
         from associated.symm h7,
         exact irreducible_of_associated h5 h8
      },
      {
        rw multiset.mem_map at h1,
        let a := some h1,
        have h4 : a ∈ f ∧ C (leading_coeff a)⁻¹ * a = y,
        from some_spec h1,
        have h4a : C (leading_coeff a)⁻¹ * a = y,
        from and.elim_right h4,
        rw ←h4a,
        apply leading_coeff_inv_mul_monic_of_ne_zero,
        have h4b : a ∈ f,
        from and.elim_left h4,
        exact and.elim_left (h3b a h4b)
      }
    }

  }
end

/-
--The more general setting, avoids problem with the roots of the zero polynomial
axiom monic_irr (p : polynomial β) : polynomial β →₀ ℕ
axiom irr_poly_irreducible (p : polynomial β) : ∀x ∈ (monic_irr p).support, irreducible x
axiom irr_poly_monic (p : polynomial β) : ∀x ∈ (monic_irr p).support, monic x
axiom unique_factorization (p : polynomial β) : ∃ c : β , p = C c * ((finsupp.prod (monic_irr p) (λ k n, k ^n) ) )
def c_fac (p : polynomial β) : β := some ( unique_factorization p)
axiom c_fac_unit (p : polynomial β) :  is_unit (c_fac p)
-/

lemma polynomial_fac_finsupp [field α] (x : polynomial α) : ∃ c :  α, ∃ p :(polynomial α) →₀ ℕ, x = C c * ((finsupp.prod (p) (λ k n, k ^n) ) ) ∧ (∀x∈p.support, irreducible x ∧ monic x)  :=
begin
  have h1 : ∃ c :  α, ∃ p : multiset (polynomial α), x = C c * p.prod ∧ (∀x∈p, irreducible x ∧ monic x),
  from polynomial_fac _,
  rcases h1 with ⟨c, p, h2⟩,
  exact ⟨c, p.to_finsupp,
    begin
      rw ←multiset.to_finsupp_prod,
      constructor,
      exact h2.1,
      intros y h3,
      rw multiset.to_finsupp_support at h3,
      let h4 := h2.2,
      rw multiset.mem_to_finset at h3,
      exact h4 _ h3,
      end
  ⟩
end

variable [field α]

lemma is_unit_C_of_ne_zero {c : α} (h : c ≠ 0) : is_unit (C c) :=
begin
  have : (C c) * (C c⁻¹) = 1,
  {
    rw ←C_mul_C,
    have : c *c⁻¹ = 1,
      from mul_inv_cancel h,
    simp *,
  },
  exact is_unit_of_mul_eq_one_left this,
end

lemma is_constant_iff_eq_zero_or_is_unit (a : polynomial α) : is_constant a ↔ a = 0 ∨ is_unit a :=
begin
  split,
  {
    intro h,
    by_cases h1 : a = 0,
    {
      simp *,
    },
    {
      rcases h with ⟨c, hc⟩,
      subst hc,
      rw C_eq_zero_iff_eq_zero at h1,
      have : is_unit (C c),
        from is_unit_C_of_ne_zero h1,
      simp *,
    }
  },
  {
    intro h,
    cases h,
    {
      subst h,
      simp,
    },
    {
      exact is_constant_of_is_unit h,
    }
  }
end

lemma degree_ne_zero_of_irreducible (a : polynomial α) (h : irreducible a) : (degree a) ≠ 0:=
begin
  rw [ne.def, ←is_constant_iff_degree_eq_zero, is_constant_iff_eq_zero_or_is_unit, not_or_distrib],
  exact ⟨h.1, h.2.1⟩,
end

open associated

lemma setoid_r_eq_associated {α : Type*} [unique_factorization_domain α] (p q : α) :
  @setoid.r α (associated.setoid α) p q = associated p q :=
rfl

lemma make_monic_associated [field α] (a : polynomial α) : (make_monic a) ~ᵤ (a) :=
begin
  simp [make_monic],
  by_cases h1 : a = 0,
  {
    simp * at *,
  },
  {
    simp [if_neg, *],
    have : is_unit (C (leading_coeff a)),
    {
      have : is_constant (C (leading_coeff a)),
        from ⟨_, rfl⟩,
      rw is_constant_iff_eq_zero_or_is_unit at this,
      cases this with h,
      {
        rw [C_eq_zero_iff_eq_zero, leading_coef_eq_zero_iff_eq_zero] at h,
        contradiction,
      },
      {
        simp *,
      }
    },
    rw mul_comm,
    apply associated_of_mul_is_unit this,
    rw ←leading_coef_eq_zero_iff_eq_zero at h1,
    rw [mul_assoc, ←C_mul_C, inv_mul_cancel h1],
    simp,
  }

end

lemma monic_out_eq [field α] (q : associated.quot (polynomial α)): associated.mk (monic_out q) = q :=
begin
  apply quot.induction_on q,
  intro a,
  apply quot.sound,
  dsimp [setoid_r_eq_associated, monic_out],
  change (make_monic a ~ᵤ a),
  exact make_monic_associated _,
end

lemma monic_out_mk_associated [field α] (p : polynomial α): (monic_out (associated.mk p) ~ᵤ p) :=
associated.complete (monic_out_eq (associated.mk p))

lemma monic_out_mk_eq [field α] (p : polynomial α) (h : monic p) : (monic_out (associated.mk p) = p) :=
begin
  have : (monic_out (associated.mk p) ~ᵤ p),
    from monic_out_mk_associated p,
  rwa [associated_iff_eq_of_monic_of_monic _ h] at this,
  apply monic_monic_out_of_ne_zero,
  rw [ne.def, associated.mk_eq_zero_iff_eq_zero],
  by_contradiction hp,
  subst hp,
  simp [not_monic_zero, *] at *,
end

@[simp] lemma monic_out_one : monic_out (1 : quot (polynomial α)) = 1 :=
begin
  have : mk 1 = (1 : quot (polynomial α)),
  {
    rw mk_eq_one_iff_is_unit,
    simp,
  },
  rw ←this,
  rw monic_out_mk_eq,
  simp,
end

@[simp] lemma monic_out_zero : monic_out (0 : quot (polynomial α)) = 0 :=
begin
  rw [zero_def, ←mk_def, ←associated_zero_iff_eq_zero],
  apply monic_out_mk_associated,
end

open multiset

#check monic_out_mk_associated

lemma monic_out_mul_eq_monic_out_mul_monic_out (a b : quot (polynomial α)): monic_out (a * b) = monic_out a * monic_out b :=
begin
  apply quot.induction_on a,
  apply quot.induction_on b,
  intros a b,
  rw [←mk_def', ←mk_def'] at *,
  rw [←mul_mk],
  by_cases ha : a = 0,
  {
    simp * at *,
  },
  {
    by_cases hb : b = 0,
    {
      simp * at *,
    },
    {
      have hab : a * b ≠ 0,
        from mul_ne_zero ha hb,
      rw ←associated_iff_eq_of_monic_of_monic,
      have h1 : ((b * a) ~ᵤ (monic_out (mk (b * a)))),
        from (monic_out_mk_associated (b * a)).symm,
      have h2 : ((b * a) ~ᵤ (monic_out (mk b) * monic_out (mk a))),
      {
        apply mul_associated_mul_of_associated_of_associated,
        exact (monic_out_mk_associated b).symm,
        exact (monic_out_mk_associated a).symm,
      },
      exact associated.trans h1.symm h2,
      {
        rw mul_comm at hab,
        apply monic_monic_out_of_ne_zero,
        simp [mk_eq_zero_iff_eq_zero, *],
      },
      rw ←mk_eq_zero_iff_eq_zero at *,
      apply monic_mul_of_monic_of_monic,
      exact monic_monic_out_of_ne_zero _ hb,
      exact monic_monic_out_of_ne_zero _ ha,
    }
  }
end

lemma prod_map_monic_out_eq_monic_out_prod (s : multiset (quot (polynomial α))) : (map monic_out s).prod = monic_out s.prod :=
begin
  apply multiset.induction_on s,
  {
    simp [monic_out_one],
  },
  {
    intros a s h,
    simp * at *,
    simp only [monic_out_mul_eq_monic_out_mul_monic_out],
  }
end

lemma irreducible_monic_out_of_irred {a : quot (polynomial α)} (h : irred a) : irreducible (monic_out a) :=
begin
  revert h,
  apply quot.induction_on a,
  intros a h,
  have h1 : (monic_out (mk a) ~ᵤ a),
    from monic_out_mk_associated _,
  have h2 : irreducible a,
    from h,
  exact irreducible_of_associated h2 h1.symm,
end

lemma eq_of_rel_multiset_associated_of_forall_mem_monic_of_forall_mem_monic
  (s t : multiset (polynomial α)) (h : rel_multiset associated s t)
  (hs : ∀ x ∈ s, monic x) (ht : ∀ x ∈ t, monic x) : s = t :=
begin
  induction h,
  case rel_multiset.nil { refl },
  case rel_multiset.cons : a b xs ys hr hst ih h2 h3 {
    have h1 : a = b,
    {
      rw ←associated_iff_eq_of_monic_of_monic,
      exact hr,
      {
        apply h2,
        rw mem_cons,
        simp *,
      },
      {
        apply h3,
        rw mem_cons,
        simp *,
      }
    },
    subst h1,
    have h2 : xs = ys,
    {
      apply ih,
      {
        intros x h,
        apply h2,
        rw mem_cons,
        simp *,
      },
      {
        intros y h,
        apply h3,
        rw mem_cons,
        simp *,
      }
    },
    subst h2,
  }
end

--the normal form of a polynomial f = u p_1 p_2 ... p_n, with u a unit, and p_i monic and irreducible

def c_fac (p : polynomial α) : α :=
if (p = 0) then 0 else some (polynomial_fac p)

def factors (p : polynomial α) : multiset (polynomial α) :=
if (p = 0) then 0 else classical.some (some_spec $ polynomial_fac p)

lemma factors_irred (p : polynomial α) : ∀x ∈ (p.factors), irreducible x := --The x argument should be implicit
begin
  intros x h,
  rw [polynomial.factors] at h,
  by_cases h1: p = 0,
  {
    simp * at *,
  },
  {
    simp * at *,
    exact ((some_spec $ some_spec $ polynomial_fac p).2 x h).1,
  }
end

lemma factors_monic (p : polynomial α) : ∀x ∈ (p.factors), monic x :=
begin
  intros x h,
  rw [polynomial.factors] at h,
  by_cases h1: p = 0,
  {
    simp * at *,
  },
  {
    simp * at *,
    exact ((some_spec $ some_spec $ polynomial_fac p).2 x h).2,
  }
end

lemma factors_eq (p : polynomial α) : p = C (p.c_fac) * p.factors.prod :=
begin
  by_cases h1: p = 0,
  {
    simp [polynomial.c_fac,*] at *,
  },
  {
    simp [polynomial.c_fac, polynomial.factors, *] at *,
    exact (some_spec (some_spec ( polynomial_fac p))).1,
  }
end

@[simp] lemma c_fac_zero : (0 : polynomial α).c_fac = 0 :=
begin
  simp [polynomial.c_fac],
end

@[simp] lemma factors_zero : (0 : polynomial α).factors = 0 :=
begin
  simp [polynomial.factors],
end

lemma c_fac_ne_zero_of_ne_zero (f : polynomial α) (h : f ≠ 0) : f.c_fac ≠ 0 :=
begin
  by_contradiction h1,
  simp at h1,
  rw f.factors_eq at h,
  simp * at *,
end

end field

end polynomial


variable (p q : Prop)

example : ¬(p ↔ ¬p) := by
  intro h
  have hnp := λ hp => (h.mp hp) hp
  have hp := h.mpr hnp
  contradiction


/-
Copyright (c) 2019 Reid Barton, Johan Commelin, Jesse Han, Chris Hughes, Robert Y. Lewis,
Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Johan Commelin, Jesse Han, Chris Hughes, Robert Y. Lewis, Patrick Massot
-/

import tactic.fin_cases
import tactic.apply_fun
import linear_algebra.finite_dimensional
import linear_algebra.dual
import analysis.normed_space.basic
import data.real.sqrt

/-!
# Huang's sensitivity theorem

A formalization of Hao Huang's sensitivity theorem: in the hypercube of
dimension n ≥ 1, if one colors more than half the vertices then at least one
vertex has at least √n colored neighbors.

A fun summer collaboration by
Reid Barton, Johan Commelin, Jesse Han, Chris Hughes, Robert Y. Lewis, and Patrick Massot,
based on Don Knuth's account of the story
(https://www.cs.stanford.edu/~knuth/papers/huang.pdf),
using the Lean theorem prover (https://leanprover.github.io/),
by Leonardo de Moura at Microsoft Research, and his collaborators
(https://leanprover.github.io/people/),
and using Lean's user maintained mathematics library
(https://github.com/leanprover-community/mathlib).

The project was developed at https://github.com/leanprover-community/lean-sensitivity and is now
archived at https://github.com/leanprover-community/mathlib/blob/master/archive/sensitivity.lean
-/

/-! The next two lines assert we do not want to give a constructive proof,
but rather use classical logic. -/
noncomputable theory
open_locale classical

/-! We also want to use the notation `∑` for sums. -/
open_locale big_operators

notation `√` := real.sqrt

open function bool linear_map fintype finite_dimensional dual_pair

/-!
### The hypercube

Notations:
- `ℕ` denotes natural numbers (including zero).
- `fin n` = {0, ⋯ , n - 1}.
- `bool` = {`tt`, `ff`}.
-/

/-- The hypercube in dimension `n`. -/
@[derive [inhabited, fintype]] def Q (n : ℕ) := fin n → bool

/-- The projection from `Q (n + 1)` to `Q n` forgetting the first value
(ie. the image of zero). -/
def π {n : ℕ} : Q (n + 1) → Q n := λ p, p ∘ fin.succ

namespace Q
/-! `n` will always denote a natural number. -/
variable (n : ℕ)

/-- `Q 0` has a unique element. -/
instance : unique (Q 0) :=
⟨⟨λ _, tt⟩, by { intro, ext x, fin_cases x }⟩

/-- `Q n` has 2^n elements. -/
lemma card : card (Q n) = 2^n :=
by simp [Q]

/-! Until the end of this namespace, `n` will be an implicit argument (still
a natural number). -/
variable {n}

lemma succ_n_eq (p q : Q (n+1)) : p = q ↔ (p 0 = q 0 ∧ π p = π q) :=
begin
  split,
  { rintro rfl, exact ⟨rfl, rfl⟩, },
  { rintros ⟨h₀, h⟩,
    ext x,
    by_cases hx : x = 0,
    { rwa hx },
    { rw ← fin.succ_pred x hx,
      convert congr_fun h (fin.pred x hx) } }
end

/-- The adjacency relation defining the graph structure on `Q n`:
`p.adjacent q` if there is an edge from `p` to `q` in `Q n`. -/
def adjacent {n : ℕ} (p : Q n) : set (Q n) := λ q, ∃! i, p i ≠ q i

/-- In `Q 0`, no two vertices are adjacent. -/
lemma not_adjacent_zero (p q : Q 0) : ¬ p.adjacent q :=
by rintros ⟨v, _⟩; apply fin_zero_elim v

/-- If `p` and `q` in `Q (n+1)` have different values at zero then they are adjacent
iff their projections to `Q n` are equal. -/
lemma adj_iff_proj_eq {p q : Q (n+1)} (h₀ : p 0 ≠ q 0) :
  p.adjacent q ↔ π p = π q :=
begin
  split,
  { rintros ⟨i, h_eq, h_uni⟩,
    ext x, by_contradiction hx,
    apply fin.succ_ne_zero x,
    rw [h_uni _ hx, h_uni _ h₀] },
  { intro heq,
    use [0, h₀],
    intros y hy,
    contrapose! hy,
    rw ←fin.succ_pred _ hy,
    apply congr_fun heq }
end

/-- If `p` and `q` in `Q (n+1)` have the same value at zero then they are adjacent
iff their projections to `Q n` are adjacent. -/
lemma adj_iff_proj_adj {p q : Q (n+1)} (h₀ : p 0 = q 0) :
  p.adjacent q ↔ (π p).adjacent (π q) :=
begin
  split,
  { rintros ⟨i, h_eq, h_uni⟩,
    have h_i : i ≠ 0, from λ h_i, absurd h₀ (by rwa h_i at h_eq),
    use [i.pred h_i,
         show p (fin.succ (fin.pred i _)) ≠ q (fin.succ (fin.pred i _)),
           by rwa fin.succ_pred],
    intros y hy,
    simp [eq.symm (h_uni _ hy)] },
  { rintros ⟨i, h_eq, h_uni⟩,
    use [i.succ, h_eq],
    intros y hy,
    rw [←fin.pred_inj, fin.pred_succ],
    { apply h_uni,
      change p (fin.pred _ _).succ ≠ q (fin.pred _ _).succ,
      simp [hy] },
    { contrapose! hy,
      rw [hy, h₀] },
    { apply fin.succ_ne_zero } }
end

@[symm] lemma adjacent.symm {p q : Q n} : p.adjacent q ↔ q.adjacent p :=
by simp only [adjacent, ne_comm]

end Q

/-! ### The vector space -/

/-- The free vector space on vertices of a hypercube, defined inductively. -/
def V : ℕ → Type
| 0 := ℝ
| (n+1) := V n × V n

namespace V
variables (n : ℕ)

/-! `V n` is a real vector space whose equality relation is computable. -/

instance : decidable_eq (V n) :=
by { induction n ; { dunfold V, resetI, apply_instance } }

instance : add_comm_group (V n) :=
by { induction n ; { dunfold V, resetI, apply_instance } }

instance : module ℝ (V n) :=
by { induction n ; { dunfold V, resetI, apply_instance } }
end V

/-- The basis of `V` indexed by the hypercube, defined inductively. -/
noncomputable def e : Π {n}, Q n → V n
| 0     := λ _, (1:ℝ)
| (n+1) := λ x, cond (x 0) (e (π x), 0) (0, e (π x))

@[simp] lemma e_zero_apply (x : Q 0) : e x = (1 : ℝ) := rfl

/-- The dual basis to `e`, defined inductively. -/
noncomputable def ε : Π {n : ℕ} (p : Q n), V n →ₗ[ℝ] ℝ
| 0 _ := linear_map.id
| (n+1) p := cond (p 0) ((ε $ π p).comp $ linear_map.fst _ _ _)
               ((ε $ π p).comp $ linear_map.snd _ _ _)

variable {n : ℕ}

lemma duality (p q : Q n) : ε p (e q) = if p = q then 1 else 0 :=
begin
  induction n with n IH,
  { rw (show p = q, from subsingleton.elim p q),
    dsimp [ε, e],
    simp },
  { dsimp [ε, e],
    cases hp : p 0 ; cases hq : q 0,
    all_goals
    { repeat {rw cond_tt},
      repeat {rw cond_ff},
      simp only [linear_map.fst_apply, linear_map.snd_apply, linear_map.comp_apply, IH],
      try { congr' 1, rw Q.succ_n_eq, finish },
      try
      { erw (ε _).map_zero,
        have : p ≠ q, { intro h, rw p.succ_n_eq q at h, finish },
        simp [this] } } }
end

/-- Any vector in `V n` annihilated by all `ε p`'s is zero. -/
lemma epsilon_total {v : V n} (h : ∀ p : Q n, (ε p) v = 0) : v = 0 :=
begin
  induction n with n ih,
  { dsimp [ε] at h, exact h (λ _, tt) },
  { cases v with v₁ v₂,
    ext ; change _ = (0 : V n) ; simp only ; apply ih ; intro p ;
    [ let q : Q (n+1) := λ i, if h : i = 0 then tt else p (i.pred h),
      let q : Q (n+1) := λ i, if h : i = 0 then ff else p (i.pred h)],
    all_goals
    { specialize h q,
      rw [ε, show q 0 = tt, from rfl, cond_tt] at h <|>
        rw [ε, show q 0 = ff, from rfl, cond_ff] at h,
      rwa show p = π q, by { ext, simp [q, fin.succ_ne_zero, π] } } }
end

/-- `e` and `ε` are dual families of vectors. It implies that `e` is indeed a basis
and `ε` computes coefficients of decompositions of vectors on that basis. -/
def dual_pair_e_ε (n : ℕ) : dual_pair (@e n) (@ε n) :=
{ eval := duality,
  total := @epsilon_total _ }

/-! We will now derive the dimension of `V`, first as a cardinal in `dim_V` and,
since this cardinal is finite, as a natural number in `finrank_V` -/

lemma dim_V : module.rank ℝ (V n) = 2^n :=
have module.rank ℝ (V n) = (2^n : ℕ),
  by { rw [dim_eq_card_basis (dual_pair_e_ε _).basis, Q.card]; apply_instance },
by assumption_mod_cast

instance : finite_dimensional ℝ (V n) :=
finite_dimensional.of_fintype_basis (dual_pair_e_ε _).basis

lemma finrank_V : finrank ℝ (V n) = 2^n :=
have _ := @dim_V n,
by rw ←finrank_eq_dim at this; assumption_mod_cast

/-! ### The linear map -/

/-- The linear operator $f_n$ corresponding to Huang's matrix $A_n$,
defined inductively as a ℝ-linear map from `V n` to `V n`. -/
noncomputable def f : Π n, V n →ₗ[ℝ] V n
| 0 := 0
| (n+1) := linear_map.prod
             (linear_map.coprod (f n) linear_map.id)
             (linear_map.coprod linear_map.id (-f n))

/-! The preceding definition uses linear map constructions to automatically
get that `f` is linear, but its values are somewhat buried as a side-effect.
The next two lemmas unbury them. -/

@[simp] lemma f_zero : f 0 = 0 := rfl

lemma f_succ_apply (v : V (n+1)) :
  f (n+1) v = (f n v.1 + v.2, v.1 - f n v.2) :=
begin
  cases v,
  rw f,
  simp only [linear_map.id_apply, linear_map.prod_apply, prod.mk.inj_iff,
    linear_map.neg_apply, sub_eq_add_neg, linear_map.coprod_apply],
  exact ⟨rfl, rfl⟩
end

/-! In the next statement, the explicit conversion `(n : ℝ)` of `n` to a real number
is necessary since otherwise `n • v` refers to the multiplication defined
using only the addition of `V`. -/

lemma f_squared : ∀ v : V n, (f n) (f n v) = (n : ℝ) • v :=
begin
  induction n with n IH; intro,
  { simpa only [nat.cast_zero, zero_smul] },
  { cases v, simp [f_succ_apply, IH, add_smul, add_assoc], abel }
end

/-! We now compute the matrix of `f` in the `e` basis (`p` is the line index,
`q` the column index). -/

lemma f_matrix :
  ∀ p q : Q n, |ε q (f n (e p))| = if q.adjacent p then 1 else 0 :=
begin
  induction n with n IH,
  { intros p q,
    dsimp [f],
    simp [Q.not_adjacent_zero] },
  { intros p q,
    have ite_nonneg : ite (π q = π p) (1 : ℝ) 0 ≥ 0,
    { split_ifs ; norm_num },
    have f_map_zero := (show (V (n+0)) →ₗ[ℝ] (V n), from f n).map_zero,
    dsimp [e, ε, f], cases hp : p 0 ; cases hq : q 0,
    all_goals
    { repeat {rw cond_tt}, repeat {rw cond_ff},
      simp [f_map_zero, hp, hq, IH, duality, abs_of_nonneg ite_nonneg, Q.adj_iff_proj_eq,
            Q.adj_iff_proj_adj] } }
end

/-- The linear operator $g_m$ corresponding to Knuth's matrix $B_m$. -/
noncomputable def g (m : ℕ) : V m →ₗ[ℝ] V (m+1) :=
linear_map.prod (f m + √(m+1) • linear_map.id) linear_map.id

/-! In the following lemmas, `m` will denote a natural number. -/
variables {m : ℕ}

/-! Again we unpack what are the values of `g`. -/
lemma g_apply : ∀ v, g m v = (f m v + √(m+1) • v, v) :=
by delta g; simp

lemma g_injective : injective (g m) :=
begin
  rw g,
  intros x₁ x₂ h,
  simp only [linear_map.prod_apply, linear_map.id_apply, prod.mk.inj_iff] at h,
  exact h.right
end

lemma f_image_g (w : V (m + 1)) (hv : ∃ v, g m v = w) :
  f (m + 1) w = √(m + 1) • w :=
begin
  rcases hv with ⟨v, rfl⟩,
  have : √(m+1) * √(m+1) = m+1 :=
    real.mul_self_sqrt (by exact_mod_cast zero_le _),
  simp [this, f_succ_apply, g_apply, f_squared, smul_add, add_smul, smul_smul],
  abel
end

/-!
### The main proof

In this section, in order to enforce that `n` is positive, we write it as
`m + 1` for some natural number `m`. -/

/-! `dim X` will denote the dimension of a subspace `X` as a cardinal. -/
notation `dim` X:70 := module.rank ℝ ↥X
/-! `fdim X` will denote the (finite) dimension of a subspace `X` as a natural number. -/
notation `fdim` := finrank ℝ

/-! `Span S` will denote the ℝ-subspace spanned by `S`. -/
notation `Span` := submodule.span ℝ

/-! `Card X` will denote the cardinal of a subset of a finite type, as a
natural number. -/
notation `Card` X:70 := X.to_finset.card

/-! In the following, `⊓` and `⊔` will denote intersection and sums of ℝ-subspaces,
equipped with their subspace structures. The notations come from the general
theory of lattices, with inf and sup (also known as meet and join). -/

/-- If a subset `H` of `Q (m+1)` has cardinal at least `2^m + 1` then the
subspace of `V (m+1)` spanned by the corresponding basis vectors non-trivially
intersects the range of `g m`. -/
lemma exists_eigenvalue (H : set (Q (m + 1))) (hH : Card H ≥ 2^m + 1) :
  ∃ y ∈ Span (e '' H) ⊓ (g m).range, y ≠ (0 : _) :=
begin
  let W := Span (e '' H),
  let img := (g m).range,
  suffices : 0 < dim (W ⊓ img),
  { simp only [exists_prop],
    exact_mod_cast exists_mem_ne_zero_of_dim_pos this },
  have dim_le : dim (W ⊔ img) ≤ 2^(m + 1),
  { convert ← dim_submodule_le (W ⊔ img),
    apply dim_V },
  have dim_add : dim (W ⊔ img) + dim (W ⊓ img) = dim W + 2^m,
  { convert ← dim_sup_add_dim_inf_eq W img,
    rw ← dim_eq_of_injective (g m) g_injective,
    apply dim_V },
  have dimW : dim W = card H,
  { have li : linear_independent ℝ (set.restrict e H),
    { convert (dual_pair_e_ε _).basis.linear_independent.comp _ subtype.val_injective,
      rw (dual_pair_e_ε _).coe_basis },
    have hdW := dim_span li,
    rw set.range_restrict at hdW,
    convert hdW,
    rw [← (dual_pair_e_ε _).coe_basis, cardinal.mk_image_eq (dual_pair_e_ε _).basis.injective,
        cardinal.mk_fintype] },
  rw ← finrank_eq_dim ℝ at ⊢ dim_le dim_add dimW,
  rw [← finrank_eq_dim ℝ, ← finrank_eq_dim ℝ] at dim_add,
  norm_cast at ⊢ dim_le dim_add dimW,
  rw pow_succ' at dim_le,
  rw set.to_finset_card at hH,
  linarith
end

/-- **Huang sensitivity theorem** also known as the **Huang degree theorem** -/
theorem huang_degree_theorem (H : set (Q (m + 1))) (hH : Card H ≥ 2^m + 1) :
  ∃ q, q ∈ H ∧ √(m + 1) ≤ Card (H ∩ q.adjacent) :=
begin
  rcases exists_eigenvalue H hH with ⟨y, ⟨⟨y_mem_H, y_mem_g⟩, y_ne⟩⟩,
  have coeffs_support : ((dual_pair_e_ε (m+1)).coeffs y).support ⊆ H.to_finset,
  { intros p p_in,
    rw finsupp.mem_support_iff at p_in,
    rw set.mem_to_finset,
    exact (dual_pair_e_ε _).mem_of_mem_span y_mem_H p p_in },
  obtain ⟨q, H_max⟩ : ∃ q : Q (m+1), ∀ q' : Q (m+1), |(ε q' : _) y| ≤ |ε q y|,
    from fintype.exists_max _,
  have H_q_pos : 0 < |ε q y|,
  { contrapose! y_ne,
    exact epsilon_total (λ p, abs_nonpos_iff.mp (le_trans (H_max p) y_ne)) },
  refine ⟨q, (dual_pair_e_ε _).mem_of_mem_span y_mem_H q (abs_pos.mp H_q_pos), _⟩,
  let s := √(m+1),
  suffices : s * |ε q y| ≤ ↑(_) * |ε q y|,
    from (mul_le_mul_right H_q_pos).mp ‹_›,

  let coeffs := (dual_pair_e_ε (m+1)).coeffs,
  calc
    s * |ε q y|
        = |ε q (s • y)| :
      by rw [map_smul, smul_eq_mul, abs_mul, abs_of_nonneg (real.sqrt_nonneg _)]
    ... = |ε q (f (m+1) y)| : by rw [← f_image_g y (by simpa using y_mem_g)]
    ... = |ε q (f (m+1) (lc _ (coeffs y)))| : by rw (dual_pair_e_ε _).lc_coeffs y
    ... = |(coeffs y).sum (λ (i : Q (m + 1)) (a : ℝ), a • ((ε q) ∘ (f (m + 1)) ∘
            λ (i : Q (m + 1)), e i) i)| :
      by erw [(f $ m + 1).map_finsupp_total, (ε q).map_finsupp_total, finsupp.total_apply]
    ... ≤ ∑ p in (coeffs y).support, |(coeffs y p) * (ε q $ f (m+1) $ e p)| :
      norm_sum_le _ $ λ p, coeffs y p * _
    ... = ∑ p in (coeffs y).support, |coeffs y p| * ite (q.adjacent p) 1 0 :
      by simp only [abs_mul, f_matrix]
    ... = ∑ p in (coeffs y).support.filter (Q.adjacent q), |coeffs y p| :
      by simp [finset.sum_filter]
    ... ≤ ∑ p in (coeffs y).support.filter (Q.adjacent q), |coeffs y q| :
      finset.sum_le_sum (λ p _, H_max p)
    ... = (((coeffs y).support.filter (Q.adjacent q)).card : ℝ) * |coeffs y q| :
      by rw [finset.sum_const, nsmul_eq_mul]
    ... = (((coeffs y).support ∩ (Q.adjacent q).to_finset).card : ℝ) * |coeffs y q| :
      by { congr' with x, simp, refl }
    ... ≤ (finset.card ((H ∩ Q.adjacent q).to_finset )) * |ε q y| :
      begin
        refine (mul_le_mul_right H_q_pos).2 _,
        norm_cast,
        apply finset.card_le_of_subset,
        rw set.to_finset_inter,
        convert finset.inter_subset_inter_right coeffs_support
      end
end


import Mathlib.Algebra.Abs
import Mathlib.Data.Rat.Order
import Mathlib.Tactic.Positivity

/-! # Tests for the `positivity` tactic

This tactic proves goals of the form `0 ≤ a` and `0 < a`.
-/

open Function

variable {ι α β : Type _}

/- ## Numeric goals -/

example : 0 ≤ 0 := by positivity

example : 0 ≤ 3 := by positivity

example : 0 < 3 := by positivity

/- ## Goals working directly from a hypothesis -/
-- set_option trace.Meta.debug true
-- sudo set_option trace.Tactic.positivity true
example {a : ℤ} (ha : 0 < a) : 0 < a := by positivity
example {a : ℤ} (ha : 0 < a) : 0 ≤ a := by positivity
example {a : ℤ} (ha : 0 < a) : a ≠ 0 := by positivity
example {a : ℤ} (ha : 0 ≤ a) : 0 ≤ a := by positivity
example {a : ℤ} (ha : a ≠ 0) : a ≠ 0 := by positivity
example {a : ℤ} (ha : a = 0) : 0 ≤ a := by positivity

/- ### Reversing hypotheses -/

example {a : ℤ} (ha : a > 0) : 0 < a := by positivity
example {a : ℤ} (ha : a > 0) : 0 ≤ a := by positivity
example {a : ℤ} (ha : a > 0) : a ≠ 0 := by positivity
example {a : ℤ} (ha : a ≥ 0) : 0 ≤ a := by positivity
example {a : ℤ} (ha : 0 ≠ a) : a ≠ 0 := by positivity
example {a : ℤ} (ha : 0 < a) : a > 0 := by positivity
example {a : ℤ} (ha : 0 < a) : a ≥ 0 := by positivity
example {a : ℤ} (ha : 0 < a) : 0 ≠ a := by positivity
example {a : ℤ} (ha : 0 ≤ a) : a ≥ 0 := by positivity
example {a : ℤ} (ha : a ≠ 0) : 0 ≠ a := by positivity
example {a : ℤ} (ha : a = 0) : a ≥ 0 := by positivity
example {a : ℤ} (ha : 0 = a) : 0 ≤ a := by positivity
example {a : ℤ} (ha : 0 = a) : a ≥ 0 := by positivity

/- ### Calling `norm_num` -/

example {a : ℤ} (ha : 3 = a) : 0 ≤ a := by positivity
example {a : ℤ} (ha : 3 = a) : a ≠ 0 := by positivity
example {a : ℤ} (ha : 3 = a) : 0 < a := by positivity
example {a : ℤ} (ha : a = -1) : a ≠ 0 := by positivity

example {a : ℤ} (ha : 3 ≤ a) : 0 ≤ a := by positivity
example {a : ℤ} (ha : 3 ≤ a) : a ≠ 0 := by positivity
example {a : ℤ} (ha : 3 ≤ a) : 0 < a := by positivity

example {a : ℤ} (ha : 3 < a) : 0 ≤ a := by positivity
example {a : ℤ} (ha : 3 < a) : a ≠ 0 := by positivity
example {a : ℤ} (ha : 3 < a) : 0 < a := by positivity

example {a b : ℤ} (h : 0 ≤ a + b) : 0 ≤ a + b := by positivity

example {a : ℤ} (hlt : 0 ≤ a) (hne : a ≠ 0) : 0 < a := by positivity

section

variable [LinearOrderedField α]

example : (1/4 - 2/3 : ℚ) ≠ 0 := by positivity
example : (1/4 - 2/3 : α) ≠ 0 := by positivity

end

/- ## Tests of the @[positivity] plugin tactics (addition, multiplication, division) -/

-- example [Nonempty ι] [Zero α] {a : α} (ha : a ≠ 0) : const ι a ≠ 0 := by positivity
-- example [Zero α] [PartialOrder α] {a : α} (ha : 0 < a) : 0 ≤ const ι a := by positivity
-- example [Zero α] [PartialOrder α] {a : α} (ha : 0 ≤ a) : 0 ≤ const ι a := by positivity
-- example [Nonempty ι] [Zero α] [PartialOrder α] {a : α} (ha : 0 < a) : 0 < const ι a := by positivity

example {a b : ℚ} (ha : 0 < a) (hb : 0 < b) : 0 < min a b := by positivity
example {a b : ℚ} (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ min a b := by positivity
example {a b : ℚ} (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ min a b := by positivity
example {a b : ℚ} (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ min a b := by positivity
example {a b : ℚ} (ha : 0 < a) (hb : b ≠ 0) : min a b ≠ 0 := by positivity
example {a b : ℚ} (ha : a ≠ 0) (hb : 0 < b) : min a b ≠ 0 := by positivity
example {a b : ℚ} (ha : a ≠ 0) (hb : b ≠ 0) : min a b ≠ 0 := by positivity

example {a b : ℚ} (ha : 0 < a) : 0 < max a b := by positivity
example {a b : ℚ} (hb : 0 < b) : 0 < max a b := by positivity
example {a b : ℚ} (ha : 0 ≤ a) : 0 ≤ max a b := by positivity
example {a b : ℚ} (hb : 0 ≤ b) : 0 ≤ max a b := by positivity
example {a b : ℚ} (ha : a ≠ 0) (hb : b ≠ 0) : max a b ≠ 0 := by positivity

example {a b : ℚ} (ha : 0 < a) (hb : 0 < b) : 0 < a * b := by positivity
example {a b : ℚ} (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a * b := by positivity
example {a b : ℚ} (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a * b := by positivity
example {a b : ℚ} (ha : 0 < a) (hb : b ≠ 0) : a * b ≠ 0 := by positivity
example {a b : ℚ} (ha : a ≠ 0) (hb : 0 < b) : a * b ≠ 0 := by positivity
example {a b : ℚ} (ha : a ≠ 0) (hb : b ≠ 0) : a * b ≠ 0 := by positivity

example {a b : ℚ} (ha : 0 < a) (hb : 0 < b) : 0 < a / b := by positivity
example {a b : ℚ} (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a / b := by positivity
example {a b : ℚ} (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a / b := by positivity
example {a b : ℚ} (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a / b := by positivity
example {a b : ℚ} (ha : 0 < a) (hb : b ≠ 0) : a / b ≠ 0 := by positivity
example {a b : ℚ} (ha : a ≠ 0) (hb : 0 < b) : a / b ≠ 0 := by positivity
example {a b : ℚ} (ha : a ≠ 0) (hb : b ≠ 0) : a / b ≠ 0 := by positivity

example {a b : ℤ} (ha : 0 < a) (hb : 0 < b) : 0 ≤ a / b := by positivity
example {a : ℤ} (ha : 0 < a) : 0 < a / a := by positivity
example {a b : ℤ} (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a / b := by positivity
example {a b : ℤ} (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a / b := by positivity
example {a b : ℤ} (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a / b := by positivity

example {a : ℚ} (ha : 0 < a) : 0 < a⁻¹ := by positivity
example {a : ℚ} (ha : 0 ≤ a) : 0 ≤ a⁻¹ := by positivity
example {a : ℚ} (ha : a ≠ 0) : a⁻¹ ≠ 0 := by positivity

example {a : ℚ} (n : ℕ) (ha : 0 < a) : 0 < a ^ n := by positivity
example {a : ℚ} (n : ℕ) (ha : 0 ≤ a) : 0 ≤ a ^ n := by positivity
example {a : ℚ} (n : ℕ) (ha : a ≠ 0) : a ^ n ≠ 0 := by positivity
example {a : ℚ} : 0 ≤ a ^ 18 := by positivity
example {a : ℚ} (ha : a ≠ 0) : 0 < a ^ 18 := by positivity

example {a : ℚ} (ha : 0 < a) : 0 < |a| := by positivity
example {a : ℚ} (ha : a ≠ 0) : 0 < |a| := by positivity
example (a : ℚ) : 0 ≤ |a| := by positivity

-- example {a : ℤ} {b : ℚ} (ha : 0 < a) (hb : 0 < b) : 0 < a • b := by positivity
-- example {a : ℤ} {b : ℚ} (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a • b := by positivity
-- example {a : ℤ} {b : ℚ} (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a • b := by positivity
-- example {a : ℤ} {b : ℚ} (ha : 0 < a) (hb : b ≠ 0) : a • b ≠ 0 := by positivity
-- example {a : ℤ} {b : ℚ} (ha : a ≠ 0) (hb : 0 < b) : a • b ≠ 0 := by positivity
-- example {a : ℤ} {b : ℚ} (ha : a ≠ 0) (hb : b ≠ 0) : a • b ≠ 0 := by positivity

example {a : ℤ} (ha : 3 < a) : 0 ≤ a + a := by positivity

example {a b : ℤ} (ha : 3 < a) (hb : 4 ≤ b) : 0 ≤ 3 + a + b + b + 14 := by positivity

-- example {H : Type _} [LinearOrderedAddCommGroup H] {a b : H} (ha : 0 < a) (hb : 0 ≤ b) :
--   0 ≤ a + a + b :=
-- by positivity

example {a : ℤ} (ha : 3 < a) : 0 < a + a := by positivity

example {a b : ℚ} (ha : 3 < a) (hb : 4 ≤ b) : 0 < 3 + a * b / 7 + b + 7 + 14 := by positivity

example {a b : ℤ} (ha : 3 < a) (hb : 4 ≤ b) : 0 < 3 + a * b / 7 + b + 7 + 14 := by positivity

-- example {a : ℤ} (ha : 0 < a) : 0 < a / a := by positivity

/-! ### Exponentiation -/

example [OrderedSemiring α] [Nontrivial α] (a : α) : 0 < a ^ 0 := by positivity
example [LinearOrderedRing α] (a : α) : 0 ≤ a ^ 18 := by positivity
example [OrderedSemiring α] {a : α} {n : ℕ} (ha : 0 ≤ a) : 0 ≤ a ^ n := by positivity
example [StrictOrderedSemiring α] {a : α} {n : ℕ} (ha : 0 < a) : 0 < a ^ n := by positivity

example [LinearOrderedSemifield α] (a : α) : 0 < a ^ (0 : ℤ) := by positivity
-- example [LinearOrderedField α] (a : α) (n : ℤ) : 0 ≤ a ^ bit0 n := by positivity
-- example [LinearOrderedSemifield α] {a : α} {n : ℤ} (ha : 0 ≤ a) : 0 ≤ a ^ n := by positivity
-- example [LinearOrderedSemifield α] {a : α} {n : ℤ} (ha : 0 < a) : 0 < a ^ n := by positivity

-- example {a b : Cardinal.{u}} (ha : 0 < a) : 0 < a ^ b := by positivity
-- example {a b : Ordinal.{u}} (ha : 0 < a) : 0 < a ^ b := by positivity

-- example {a b : ℝ} (ha : 0 ≤ a) : 0 ≤ a ^ b := by positivity
-- example {a b : ℝ} (ha : 0 < a) : 0 < a ^ b := by positivity
-- example {a : ℝ≥0} {b : ℝ} (ha : 0 < a) : 0 < a ^ b := by positivity
-- example {a : ℝ≥0∞} {b : ℝ} (ha : 0 < a) (hb : 0 ≤ b) : 0 < a ^ b := by positivity
-- example {a : ℝ≥0∞} {b : ℝ} (ha : 0 < a) (hb : 0 < b) : 0 < a ^ b := by positivity

-- example {a : ℝ} (ha : 0 < a) : 0 ≤ ⌊a⌋ := by positivity
-- example {a : ℝ} (ha : 0 ≤ a) : 0 ≤ ⌊a⌋ := by positivity

-- example {a : ℝ} (ha : 0 < a) : 0 < ⌈a⌉₊ := by positivity
-- example {a : ℝ} (ha : 0 < a) : 0 < ⌈a⌉ := by positivity
-- example {a : ℝ} (ha : 0 ≤ a) : 0 ≤ ⌈a⌉ := by positivity

example {a : ℤ} (ha : 3 < a) : 0 ≤ a ^ 2 + a := by positivity

example {a : ℤ} (ha : 3 < a) : 0 ≤ a ^ 3 + a := by positivity

example {a : ℤ} (ha : 3 < a) : 0 < a ^ 2 + a := by positivity

example {a b : ℤ} (ha : 3 < a) (hb : b ≥ 4) : 0 ≤ 3 * a ^ 2 * b + b * 7 + 14 := by positivity

example {a b : ℤ} (ha : 3 < a) (hb : b ≥ 4) : 0 < 3 * a ^ 2 * b + b * 7 + 14 := by positivity

example {a : ℤ} : 0 ≤ |a| := by positivity

example {a : ℤ} : 0 < |a| + 3 := by positivity

example {n : ℤ} (hn : 0 < n) : 0 < n.natAbs := by positivity
example {n : ℤ} (hn : n ≠ 0) : 0 < n.natAbs := by positivity
example {n : ℤ} : 0 ≤ n.natAbs := by positivity

example {a : ℤ} (ha : 1 < a) : 0 < |(3:ℤ) + a| := by positivity

-- example {a : ℝ} (ha : 0 ≤ a) : 0 ≤ real.sqrt a := by positivity

-- example {a : ℝ} (ha : 0 ≤ a) : 0 < real.sqrt (a + 3) := by positivity

example {a b : ℤ} (ha : 3 < a) : 0 ≤ min a (b ^ 2) := by positivity

-- -- test that the tactic can ignore arithmetic operations whose associated extension tactic requires
-- -- more typeclass assumptions than are available
-- example {R : Type _} [Zero R] [Div R] [LinearOrder R] {a b c : R} (h1 : 0 < a) (h2 : 0 < b)
--   (h3 : 0 < c) :
--   0 < max (a / b) c :=
-- by positivity

example : 0 ≤ max 3 4 := by positivity

example {b : ℤ} : 0 ≤ max (-3) (b ^ 2) := by positivity

example {b : ℤ} : 0 ≤ max (b ^ 2) 0 := by positivity

example : 0 ≤ max (0:ℤ) (-3) := by positivity

example : 0 ≤ max (-3 : ℤ) 5 := by positivity

-- example [OrderedSemiring α] [OrderedAddCommMonoid β] [SMulWithZero α β]
--   [OrderedSMul α β] {a : α} (ha : 0 < a) {b : β} (hb : 0 < b) : 0 ≤ a • b := by positivity

example (n : ℕ) : 0 < n.succ := by positivity
-- example (n : ℕ) : 0 < n! := by positivity
-- example (n k : ℕ) : 0 < n.asc_factorial k := by positivity

-- example {α : Type _} (s : Finset α) (hs : s.Nonempty) : 0 < s.card := by positivity
-- example {α : Type _} [Fintype α] [Nonempty α] : 0 < Fintype.card α := by positivity

-- example {r : ℝ} : 0 < Real.exp r := by positivity

-- example {V : Type _} [NormedAddCommGroup V] (x : V) : 0 ≤ ∥x∥ := by positivity

-- example [MetricSpace α] (x y : α) : 0 ≤ dist x y := by positivity
-- example [MetricSpace α] {s : Set α} : 0 ≤ metric.diam s := by positivity

-- example {E : Type _} [AddGroup E] {p : AddGroupSeminorm E} {x : E} : 0 ≤ p x := by positivity
-- example {E : Type _} [Group E] {p : GroupSeminorm E} {x : E} : 0 ≤ p x := by positivity

-- example {r : α → β → Prop} [∀ a, DecidablePred (r a)] {s : Finset α} {t : Finset β} :
--   0 ≤ Rel.edgeDensity r s t := by positivity
-- example {G : SimpleGraph α} [DecidableRel G.adj] {s t : finset α} :
--   0 ≤ G.edgeDensity s t := by positivity

/- ### Canonical orders -/

example {a : ℕ} : 0 ≤ a := by positivity
-- example {a : ℚ≥0} : 0 ≤ a := by positivity
-- example {a : ℝ≥0} : 0 ≤ a := by positivity
-- example {a : ℝ≥0∞} : 0 ≤ a := by positivity

/- ### Coercions -/

example {a : ℕ} : (0 : ℤ) ≤ a := by positivity
example {a : ℕ} : (0 : ℚ) ≤ a := by positivity
example {a : ℕ} (ha : 0 < a) : (0 : ℤ) < a := by positivity
example {a : ℕ} (ha : 0 < a) : (0 : ℚ) < a := by positivity
example {a : ℤ} (ha : a ≠ 0) : (a : ℚ) ≠ 0 := by positivity
example {a : ℤ} (ha : 0 ≤ a) : (0 : ℚ) ≤ a := by positivity
example {a : ℤ} (ha : 0 < a) : (0 : ℚ) < a := by positivity
-- example {a : ℚ} (ha : a ≠ 0) : (a : ℝ) ≠ 0 := by positivity
-- example {a : ℚ} (ha : 0 ≤ a) : (0 : ℝ) ≤ a := by positivity
-- example {a : ℚ} (ha : 0 < a) : (0 : ℝ) < a := by positivity
-- example {r : ℝ≥0} : (0 : ℝ) ≤ r := by positivity
-- example {r : ℝ≥0} (hr : 0 < r) : (0 : ℝ) < r := by positivity
-- example {r : ℝ≥0} (hr : 0 < r) : (0 : ℝ≥0∞) < r := by positivity
-- -- example {r : ℝ≥0} : (0 : ereal) ≤ r := by positivity -- TODO: Handle `coe_trans`
-- -- example {r : ℝ≥0} (hr : 0 < r) : (0 : ereal) < r := by positivity
-- example {r : ℝ} (hr : 0 ≤ r) : (0 : ereal) ≤ r := by positivity
-- example {r : ℝ} (hr : 0 < r) : (0 : ereal) < r := by positivity
-- example {r : ℝ} (hr : 0 ≤ r) : (0 : hyperreal) ≤ r := by positivity
-- example {r : ℝ} (hr : 0 < r) : (0 : hyperreal) < r := by positivity
-- example {r : ℝ≥0∞} : (0 : ereal) ≤ r := by positivity
-- example {r : ℝ≥0∞} (hr : 0 < r) : (0 : ereal) < r := by positivity

-- example {α : Type _} [ordered_ring α] {n : ℤ} : 0 ≤ ((n ^ 2 : ℤ) : α) := by positivity
-- example {r : ℝ≥0} : 0 ≤ ((r : ℝ) : ereal) := by positivity
-- example {r : ℝ≥0} : 0 < ((r + 1 : ℝ) : ereal) := by positivity

/- ## Tests that the tactic is agnostic on reversed inequalities -/

example {a : ℤ} (ha : a > 0) : 0 ≤ a := by positivity

example {a : ℤ} (ha : 0 < a) : a ≥ 0 := by positivity

example {a : ℤ} (ha : a > 0) : a ≥ 0 := by positivity

/-
## Test for meta-variable instantiation

Reported on
https://leanprover.zulipchat.com/#narrow/stream/239415-metaprogramming-.2F-tactics/topic/New.20tactic.3A.20.60positivity.60/near/300639970
-/

example : 0 ≤ 0 := by apply le_trans _ (le_refl _); positivity


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

! This file was ported from Lean 3 source module algebra.order.nonneg.ring
! leanprover-community/mathlib commit 8631e2d5ea77f6c13054d9151d82b83069680cb1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Nat.Cast.Basic
-- import Mathlib.Algebra.Group.Defs
import Mathlib.Algebra.Order.Ring.Defs
import Mathlib.Algebra.Order.Ring.InjSurj
import Mathlib.Algebra.GroupPower.Order
import Mathlib.Order.CompleteLatticeIntervals
import Mathlib.Order.LatticeIntervals
import Mathlib.Order.Basic

/-!
# The type of nonnegative elements

This file defines instances and prove some properties about the nonnegative elements
`{x : α // 0 ≤ x}` of an arbitrary type `α`.

Currently we only state instances and states some `simp`/`norm_cast` lemmas.

When `α` is `ℝ`, this will give us some properties about `ℝ≥0`.

## Main declarations

* `{x : α // 0 ≤ x}` is a `canonically_linear_ordered_add_monoid` if `α` is a `linear_ordered_ring`.

## Implementation Notes

Instead of `{x : α // 0 ≤ x}` we could also use `set.Ici (0 : α)`, which is definitionally equal.
However, using the explicit subtype has a big advantage: when writing and element explicitly
with a proof of nonnegativity as `⟨x, hx⟩`, the `hx` is expected to have type `0 ≤ x`. If we would
use `Ici 0`, then the type is expected to be `x ∈ Ici 0`. Although these types are definitionally
equal, this often confuses the elaborator. Similar problems arise when doing cases on an element.

The disadvantage is that we have to duplicate some instances about `set.Ici` to this subtype.
-/

open Set

variable {α : Type _}

namespace Nonneg

/-- This instance uses data fields from `subtype.partial_order` to help type-class inference.
The `set.Ici` data fields are definitionally equal, but that requires unfolding semireducible
definitions, so type-class inference won't see this. -/
instance orderBot [Preorder α] {a : α} : OrderBot { x : α // a ≤ x } :=
  { Set.Ici.orderBot with }
#align nonneg.order_bot Nonneg.orderBot

theorem bot_eq [Preorder α] {a : α} : (⊥ : { x : α // a ≤ x }) = ⟨a, le_rfl⟩ :=
  rfl
#align nonneg.bot_eq Nonneg.bot_eq

instance noMaxOrder [PartialOrder α] [NoMaxOrder α] {a : α} : NoMaxOrder { x : α // a ≤ x } :=
  {
    exists_gt := λ x =>
      have ⟨ a' , a'p ⟩ := x
      have ⟨ b' , b'p ⟩ := exists_gt a'
      ⟨ ⟨ b' , le_of_lt (trans a'p b'p) ⟩ , by simp [b'p] ⟩
  }
#align nonneg.no_max_order Nonneg.noMaxOrder

instance semilatticeSup [SemilatticeSup α] {a : α} : SemilatticeSup { x : α // a ≤ x } :=
  Set.Ici.semilatticeSup
#align nonneg.semilattice_sup Nonneg.semilatticeSup

instance semilatticeInf [SemilatticeInf α] {a : α} : SemilatticeInf { x : α // a ≤ x } :=
  Set.Ici.semilatticeInf
#align nonneg.semilattice_inf Nonneg.semilatticeInf

instance distribLattice [DistribLattice α] {a : α} : DistribLattice { x : α // a ≤ x } :=
  Set.Ici.distribLattice
#align nonneg.distrib_lattice Nonneg.distribLattice

instance denselyOrdered [Preorder α] [DenselyOrdered α] {a : α} : DenselyOrdered { x : α // a ≤ x } where
  dense (a₁ a₂ : { x // a ≤ x }) (p1 : a₁ < a₂) : ∃ a_2, a₁ < a_2 ∧ a_2 < a₂
   := have ⟨ a_2' , p2 ⟩ := DenselyOrdered.dense a₁.val a₂.val (by assumption)
      have P2 : a ≤ a_2' := Trans.trans a₁.property (le_of_lt p2.1)
      ⟨ ⟨ a_2' , P2 ⟩ , ⟨ p2.1 , p2.2 ⟩ ⟩

  -- show DenselyOrdered (Ici a) from Set.denselyOrdered
#align nonneg.densely_ordered Nonneg.denselyOrdered

/-- If `Sup ∅ ≤ a` then `{x : α // a ≤ x}` is a `conditionally_complete_linear_order`. -/
@[reducible]
protected noncomputable def conditionallyCompleteLinearOrder [ConditionallyCompleteLinearOrder α]
    {a : α} : ConditionallyCompleteLinearOrder { x : α // a ≤ x } :=
  { @ordConnectedSubsetConditionallyCompleteLinearOrder α (Set.Ici a) _ ⟨⟨a, le_rfl⟩⟩ _ with }
#align nonneg.conditionally_complete_linear_order Nonneg.conditionallyCompleteLinearOrder

/-- If `Sup ∅ ≤ a` then `{x : α // a ≤ x}` is a `conditionally_complete_linear_order_bot`.

This instance uses data fields from `subtype.linear_order` to help type-class inference.
The `set.Ici` data fields are definitionally equal, but that requires unfolding semireducible
definitions, so type-class inference won't see this. -/
@[reducible]
protected noncomputable def conditionallyCompleteLinearOrderBot [ConditionallyCompleteLinearOrder α]
    {a : α} (h : supₛ ∅ ≤ a) : ConditionallyCompleteLinearOrderBot { x : α // a ≤ x } :=
  { Nonneg.orderBot, Nonneg.conditionallyCompleteLinearOrder with
    csupₛ_empty :=
      (Function.funext_iff.1 (@subset_supₛ_def α (Set.Ici a) _ ⟨⟨a, le_rfl⟩⟩) ∅).trans <|
        Subtype.eq <| by
          rw [bot_eq]
          cases' h.lt_or_eq with h2 h2
          · simp [h2.not_le]
          simp [h2] }
#align nonneg.conditionally_complete_linear_order_bot Nonneg.conditionallyCompleteLinearOrderBot

instance inhabited [Preorder α] {a : α} : Inhabited { x : α // a ≤ x } :=
  ⟨⟨a, le_rfl⟩⟩
#align nonneg.inhabited Nonneg.inhabited

instance hasZero [Zero α] [Preorder α] : Zero { x : α // 0 ≤ x } :=
  ⟨⟨0, le_rfl⟩⟩
#align nonneg.has_zero Nonneg.hasZero

@[simp, norm_cast]
protected theorem coe_zero [Zero α] [Preorder α] : ((0 : { x : α // 0 ≤ x }) : α) = 0 :=
  rfl
#align nonneg.coe_zero Nonneg.coe_zero

@[simp]
theorem mk_eq_zero [Zero α] [Preorder α] {x : α} (hx : 0 ≤ x) :
    (⟨x, hx⟩ : { x : α // 0 ≤ x }) = 0 ↔ x = 0 :=
  Subtype.ext_iff
#align nonneg.mk_eq_zero Nonneg.mk_eq_zero

instance hasAdd [AddZeroClass α] [Preorder α] [CovariantClass α α (· + ·) (· ≤ ·)] :
    Add { x : α // 0 ≤ x } :=
  ⟨fun x y => ⟨x + y, add_nonneg x.2 y.2⟩⟩
#align nonneg.has_add Nonneg.hasAdd

@[simp]
theorem mk_add_mk [AddZeroClass α] [Preorder α] [CovariantClass α α (· + ·) (· ≤ ·)] {x y : α}
    (hx : 0 ≤ x) (hy : 0 ≤ y) :
    (⟨x, hx⟩ : { x : α // 0 ≤ x }) + ⟨y, hy⟩ = ⟨x + y, add_nonneg hx hy⟩ :=
  rfl
#align nonneg.mk_add_mk Nonneg.mk_add_mk

@[simp, norm_cast]
protected theorem coe_add [AddZeroClass α] [Preorder α] [CovariantClass α α (· + ·) (· ≤ ·)]
    (a b : { x : α // 0 ≤ x }) : ((a + b : { x : α // 0 ≤ x }) : α) = a + b :=
  rfl
#align nonneg.coe_add Nonneg.coe_add

instance hasNsmul [AddMonoid α] [Preorder α] [CovariantClass α α (· + ·) (· ≤ ·)] :
    SMul ℕ { x : α // 0 ≤ x } :=
  ⟨fun n x => ⟨n • x.val, nsmul_nonneg x.property n⟩⟩
#align nonneg.has_nsmul Nonneg.hasNsmul

@[simp]
theorem nsmul_mk [AddMonoid α] [Preorder α] [CovariantClass α α (· + ·) (· ≤ ·)] (n : ℕ) {x : α}
    (hx : 0 ≤ x) : (n • ⟨x, hx⟩ : { x : α // 0 ≤ x }) = ⟨n • x, nsmul_nonneg hx n⟩ :=
  rfl
#align nonneg.nsmul_mk Nonneg.nsmul_mk

@[simp, norm_cast]
protected theorem coe_nsmul [AddMonoid α] [Preorder α] [CovariantClass α α (· + ·) (· ≤ ·)] (n : ℕ)
    (a : { x : α // 0 ≤ x }) : ((n • a : { x : α // 0 ≤ x }) : α) = n • (a : α) :=
  rfl
#align nonneg.coe_nsmul Nonneg.coe_nsmul

instance orderedAddCommMonoid [OrderedAddCommMonoid α] : OrderedAddCommMonoid { x : α // 0 ≤ x } :=
  Subtype.coe_injective.orderedAddCommMonoid _ rfl (fun x y => rfl) fun _ _ => rfl
#align nonneg.ordered_add_comm_monoid Nonneg.orderedAddCommMonoid

instance linearOrderedAddCommMonoid [LinearOrderedAddCommMonoid α] :
    LinearOrderedAddCommMonoid { x : α // 0 ≤ x } :=
  Subtype.coe_injective.linearOrderedAddCommMonoid _ rfl (fun x y => rfl) (fun _ _ => rfl)
    (fun _ _ => rfl) fun _ _ => rfl
#align nonneg.linear_ordered_add_comm_monoid Nonneg.linearOrderedAddCommMonoid

instance orderedCancelAddCommMonoid [OrderedCancelAddCommMonoid α] :
    OrderedCancelAddCommMonoid { x : α // 0 ≤ x } :=
  Subtype.coe_injective.orderedCancelAddCommMonoid _ rfl (fun x y => rfl) fun _ _ => rfl
#align nonneg.ordered_cancel_add_comm_monoid Nonneg.orderedCancelAddCommMonoid

instance linearOrderedCancelAddCommMonoid [LinearOrderedCancelAddCommMonoid α] :
    LinearOrderedCancelAddCommMonoid { x : α // 0 ≤ x } :=
  Subtype.coe_injective.linearOrderedCancelAddCommMonoid _ rfl (fun x y => rfl) (fun _ _ => rfl)
    (fun _ _ => rfl) fun _ _ => rfl
#align nonneg.linear_ordered_cancel_add_comm_monoid Nonneg.linearOrderedCancelAddCommMonoid

/-- Coercion `{x : α // 0 ≤ x} → α` as a `add_monoid_hom`. -/
def coeAddMonoidHom [OrderedAddCommMonoid α] : { x : α // 0 ≤ x } →+ α where
  toFun := Subtype.val
  map_zero' := Nonneg.coe_zero
  map_add' := Nonneg.coe_add
  -- ⟨Subtype.val, Nonneg.coe_zero, Nonneg.coe_add⟩
#align nonneg.coe_add_monoid_hom Nonneg.coeAddMonoidHom

@[norm_cast]
theorem nsmul_coe [OrderedAddCommMonoid α] (n : ℕ) (r : { x : α // 0 ≤ x }) :
    ↑(n • r) = n • (r : α) :=
  Nonneg.coeAddMonoidHom.map_nsmul _ _
#align nonneg.nsmul_coe Nonneg.nsmul_coe

instance hasOne [OrderedSemiring α] : One { x : α // 0 ≤ x } where one := ⟨1, zero_le_one⟩
#align nonneg.has_one Nonneg.hasOne

@[simp, norm_cast]
protected theorem coe_one [OrderedSemiring α] : ((1 : { x : α // 0 ≤ x }) : α) = 1 :=
  rfl
#align nonneg.coe_one Nonneg.coe_one

@[simp]
theorem mk_eq_one [OrderedSemiring α] {x : α} (hx : 0 ≤ x) :
    (⟨x, hx⟩ : { x : α // 0 ≤ x }) = 1 ↔ x = 1 :=
  Subtype.ext_iff
#align nonneg.mk_eq_one Nonneg.mk_eq_one

instance hasMul [OrderedSemiring α] : Mul { x : α // 0 ≤ x }
    where mul x y := ⟨x * y, mul_nonneg x.2 y.2⟩
#align nonneg.has_mul Nonneg.hasMul

@[simp, norm_cast]
protected theorem coe_mul [OrderedSemiring α] (a b : { x : α // 0 ≤ x }) :
    ((a * b : { x : α // 0 ≤ x }) : α) = a * b :=
  rfl
#align nonneg.coe_mul Nonneg.coe_mul

@[simp]
theorem mk_mul_mk [OrderedSemiring α] {x y : α} (hx : 0 ≤ x) (hy : 0 ≤ y) :
    (⟨x, hx⟩ : { x : α // 0 ≤ x }) * ⟨y, hy⟩ = ⟨x * y, mul_nonneg hx hy⟩ :=
  rfl
#align nonneg.mk_mul_mk Nonneg.mk_mul_mk

instance addMonoidWithOne [P: OrderedSemiring α] : AddMonoidWithOne { x : α // 0 ≤ x } :=
  { Nonneg.hasOne,
    Nonneg.orderedAddCommMonoid
      with
    natCast := fun n => ⟨n, Nat.cast_nonneg n⟩
    natCast_zero := by simp [P.natCast_zero]
    -- sorry -- by simp [Nat.cast, natCast_zero]
    -- natCast_zero := by simp [Nat.cast]
    natCast_succ := fun _ => by simp [P.natCast_succ] ; rfl
  }
#align nonneg.add_monoid_with_one Nonneg.addMonoidWithOne

@[simp, norm_cast]
protected theorem coe_nat_cast [OrderedSemiring α] (n : ℕ) : ((↑n : { x : α // 0 ≤ x }) : α) = n :=
  rfl
#align nonneg.coe_nat_cast Nonneg.coe_nat_cast

@[simp]
theorem mk_nat_cast [OrderedSemiring α] (n : ℕ) : (⟨n, n.cast_nonneg⟩ : { x : α // 0 ≤ x }) = n :=
  rfl
#align nonneg.mk_nat_cast Nonneg.mk_nat_cast

instance hasPow [OrderedSemiring α] : Pow { x : α // 0 ≤ x } ℕ
    where pow x n := ⟨x.val ^ n, pow_nonneg x.2 n⟩
#align nonneg.has_pow Nonneg.hasPow

@[simp, norm_cast]
protected theorem coe_pow [OrderedSemiring α] (a : { x : α // 0 ≤ x }) (n : ℕ) :
    (↑(a ^ n) : α) = a.val ^ n :=
  rfl
#align nonneg.coe_pow Nonneg.coe_pow

@[simp]
theorem mk_pow [OrderedSemiring α] {x : α} (hx : 0 ≤ x) (n : ℕ) :
    (⟨x, hx⟩ : { x : α // 0 ≤ x }) ^ n = ⟨x ^ n, pow_nonneg hx n⟩ :=
  rfl
#align nonneg.mk_pow Nonneg.mk_pow

instance orderedSemiring [OrderedSemiring α] : OrderedSemiring { x : α // 0 ≤ x } :=
  Subtype.coe_injective.orderedSemiring _ rfl rfl (fun x y => rfl) (fun x y => rfl) (fun _ _ => rfl)
    (fun _ _ => rfl) fun _ => rfl
#align nonneg.ordered_semiring Nonneg.orderedSemiring

instance strictOrderedSemiring [StrictOrderedSemiring α] :
    StrictOrderedSemiring { x : α // 0 ≤ x } :=
  Subtype.coe_injective.strictOrderedSemiring _ rfl rfl (fun x y => rfl) (fun x y => rfl)
    (fun _ _ => rfl) (fun _ _ => rfl) fun _ => rfl
#align nonneg.strict_ordered_semiring Nonneg.strictOrderedSemiring

instance orderedCommSemiring [OrderedCommSemiring α] : OrderedCommSemiring { x : α // 0 ≤ x } :=
  Subtype.coe_injective.orderedCommSemiring _ rfl rfl (fun x y => rfl) (fun x y => rfl)
    (fun _ _ => rfl) (fun _ _ => rfl) fun _ => rfl
#align nonneg.ordered_comm_semiring Nonneg.orderedCommSemiring

instance strictOrderedCommSemiring [StrictOrderedCommSemiring α] :
    StrictOrderedCommSemiring { x : α // 0 ≤ x } :=
  Subtype.coe_injective.strictOrderedCommSemiring _ rfl rfl (fun x y => rfl) (fun x y => rfl)
    (fun _ _ => rfl) (fun _ _ => rfl) fun _ => rfl
#align nonneg.strict_ordered_comm_semiring Nonneg.strictOrderedCommSemiring

-- These prevent noncomputable instances being found, as it does not require `linear_order` which
-- is frequently non-computable.
instance monoidWithZero [OrderedSemiring α] : MonoidWithZero { x : α // 0 ≤ x } := by infer_instance
#align nonneg.monoid_with_zero Nonneg.monoidWithZero

instance commMonoidWithZero [OrderedCommSemiring α] : CommMonoidWithZero { x : α // 0 ≤ x } := by
  infer_instance
#align nonneg.comm_monoid_with_zero Nonneg.commMonoidWithZero

instance semiring [OrderedSemiring α] : Semiring { x : α // 0 ≤ x } :=
  inferInstance
#align nonneg.semiring Nonneg.semiring

instance commSemiring [OrderedCommSemiring α] : CommSemiring { x : α // 0 ≤ x } :=
  inferInstance
#align nonneg.comm_semiring Nonneg.commSemiring

instance nontrivial [LinearOrderedSemiring α] : Nontrivial { x : α // 0 ≤ x } :=
  ⟨⟨0, 1, fun h => zero_ne_one (congr_arg Subtype.val h)⟩⟩
#align nonneg.nontrivial Nonneg.nontrivial

instance linearOrderedSemiring [LinearOrderedSemiring α] :
    LinearOrderedSemiring { x : α // 0 ≤ x } :=
  Subtype.coe_injective.linearOrderedSemiring _ rfl rfl (fun x y => rfl) (fun x y => rfl)
    (fun _ _ => rfl) (fun _ _ => rfl) (fun _ => rfl) (fun _ _ => rfl) fun _ _ => rfl
#align nonneg.linear_ordered_semiring Nonneg.linearOrderedSemiring

-- set_option maxHeartbeats 20000000
-- set_option trace.Meta.synthInstance true
instance linearOrderedCommMonoidWithZero [LinearOrderedCommRing α] :
    LinearOrderedCommMonoidWithZero { x : α // 0 ≤ x } :=
  { Nonneg.linearOrderedSemiring, Nonneg.orderedCommSemiring with
    mul_le_mul_left := fun a b h c => mul_le_mul_of_nonneg_left h c.2 }
#align nonneg.linear_ordered_comm_monoid_with_zero Nonneg.linearOrderedCommMonoidWithZero

/-- Coercion `{x : α // 0 ≤ x} → α` as a `ring_hom`. -/
def coeRingHom [OrderedSemiring α] : { x : α // 0 ≤ x } →+* α where
  toFun := Subtype.val
  map_one' := Nonneg.coe_one
  map_mul' := Nonneg.coe_mul
  map_zero' := Nonneg.coe_zero
  map_add' := Nonneg.coe_add
#align nonneg.coe_ring_hom Nonneg.coeRingHom

instance canonicallyOrderedAddMonoid [OrderedRing α] :
    CanonicallyOrderedAddMonoid { x : α // 0 ≤ x } :=
  { Nonneg.orderedAddCommMonoid,
    Nonneg.orderBot with
    le_self_add := fun a b => le_add_of_nonneg_right b.2
    exists_add_of_le := fun {a} {b} h =>
      ⟨⟨b - a, sub_nonneg_of_le h⟩, Subtype.ext (add_sub_cancel'_right _ _).symm⟩ }
#align nonneg.canonically_ordered_add_monoid Nonneg.canonicallyOrderedAddMonoid

instance canonicallyOrderedCommSemiring [OrderedCommRing α] [NoZeroDivisors α] :
    CanonicallyOrderedCommSemiring { x : α // 0 ≤ x } :=
  { Nonneg.canonicallyOrderedAddMonoid, Nonneg.orderedCommSemiring with
    eq_zero_or_eq_zero_of_mul_eq_zero :=
      by
      rintro ⟨a, ha⟩ ⟨b, hb⟩
      simp }
#align nonneg.canonically_ordered_comm_semiring Nonneg.canonicallyOrderedCommSemiring

instance canonicallyLinearOrderedAddMonoid [LinearOrderedRing α] :
    CanonicallyLinearOrderedAddMonoid { x : α // 0 ≤ x } :=
  { Subtype.linearOrder _, Nonneg.canonicallyOrderedAddMonoid with }
#align nonneg.canonically_linear_ordered_add_monoid Nonneg.canonicallyLinearOrderedAddMonoid

section LinearOrder

variable [Zero α] [LinearOrder α]

/-- The function `a ↦ max a 0` of type `α → {x : α // 0 ≤ x}`. -/
def toNonneg (a : α) : { x : α // 0 ≤ x } :=
  ⟨max a 0, le_max_right _ _⟩
#align nonneg.to_nonneg Nonneg.toNonneg

@[simp]
theorem coe_toNonneg {a : α} : (toNonneg a : α) = max a 0 :=
  rfl
#align nonneg.coe_to_nonneg Nonneg.coe_toNonneg

@[simp]
theorem toNonneg_of_nonneg {a : α} (h : 0 ≤ a) : toNonneg a = ⟨a, h⟩ := by simp [toNonneg, h]
#align nonneg.to_nonneg_of_nonneg Nonneg.toNonneg_of_nonneg

@[simp]
theorem toNonneg_coe {a : { x : α // 0 ≤ x }} : toNonneg (a : α) = a :=
  by
  cases' a with a ha
  exact toNonneg_of_nonneg ha
#align nonneg.to_nonneg_coe Nonneg.toNonneg_coe

@[simp]
theorem toNonneg_le {a : α} {b : { x : α // 0 ≤ x }} : toNonneg a ≤ b ↔ a ≤ b :=
  by
  cases' b with b hb
  simp [toNonneg, hb]
#align nonneg.to_nonneg_le Nonneg.toNonneg_le

@[simp]
theorem toNonneg_lt {a : { x : α // 0 ≤ x }} {b : α} : a < toNonneg b ↔ ↑a < b :=
  by
  cases' a with a ha
  simp [toNonneg, ha.not_lt]
#align nonneg.to_nonneg_lt Nonneg.toNonneg_lt

instance hasSub [Sub α] : Sub { x : α // 0 ≤ x } :=
  ⟨fun x y => toNonneg (x - y)⟩
#align nonneg.has_sub Nonneg.hasSub

@[simp]
theorem mk_sub_mk [Sub α] {x y : α} (hx : 0 ≤ x) (hy : 0 ≤ y) :
    (⟨x, hx⟩ : { x : α // 0 ≤ x }) - ⟨y, hy⟩ = toNonneg (x - y) :=
  rfl
#align nonneg.mk_sub_mk Nonneg.mk_sub_mk

end LinearOrder

instance hasOrderedSub [LinearOrderedRing α] : OrderedSub { x : α // 0 ≤ x } :=
  ⟨by
    rintro ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩
    simp only [sub_le_iff_le_add, Subtype.mk_le_mk, mk_sub_mk, mk_add_mk, toNonneg_le,
      Subtype.coe_mk]⟩
#align nonneg.has_ordered_sub Nonneg.hasOrderedSub

end Nonneg


/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Sean Leather

Generating fresh atoms.

An atom (or inhabitant) of type `α` that is not a member of a given finite set
`s : finset α` is called “fresh.”

The set `s` is called the “avoidance set” since it contains the atoms to be
avoided when generating the fresh atom.

The `fresh` structure specifies a fresh atom generator given an avoidance
set.

The type `α` is countably infinite since a fresh atom must not be a member of
any given finite set.
-/
import data.finset

variables {α : Type*}

/-- Fresh atom generator -/
structure fresh (α : Type*) :=
/- Generate an atom from an avoidance set -/
(gen : finset α → α)
/- The atom is fresh. -/
(gen_not_mem : ∀ (s : finset α), gen s ∉ s)

namespace fresh
variables [decidable_eq α]

/- gen -/

theorem gen_ne_of_mem (F : fresh α) {a} {s : finset α} (h : a ∈ s) : a ≠ F.gen s :=
λ h', F.gen_not_mem s (h' ▸ h : F.gen s ∈ s)

@[simp] theorem gen_not_mem_of_subset (F : fresh α) {s s' : finset α} (h : s ⊆ s') :
  F.gen s' ∉ s :=
λ h', F.gen_not_mem s' (h h')

theorem gen_not_mem_singleton (F : fresh α) (a : α) :
  F.gen (finset.singleton a) ≠ a :=
finset.not_mem_singleton.mp $ F.gen_not_mem _

theorem gen_not_mem_insert (F : fresh α) (a : α) (s : finset α) :
  F.gen (insert a s) ≠ a ∧ F.gen (insert a s) ∉ s :=
not_or_distrib.mp $ mt finset.mem_insert.mpr $ F.gen_not_mem _

theorem gen_not_mem_union (F : fresh α) (s₁ s₂ : finset α) :
  F.gen (s₁ ∪ s₂) ∉ s₁ ∧ F.gen (s₁ ∪ s₂) ∉ s₂ :=
finset.not_mem_union.mp $ F.gen_not_mem _

theorem gen_ssubset_insert (F : fresh α) (s : finset α) : s ⊂ insert (F.gen s) s :=
finset.ssubset_insert (F.gen_not_mem s)

@[simp] theorem gen_insert_ne (F : fresh α) (s : finset α) :
  F.gen (insert (F.gen s) s) ≠ F.gen s :=
have h₁ : F.gen (insert (F.gen s) s) ∉ insert (F.gen s) s :=
  F.gen_not_mem (insert (F.gen s) s),
have F.gen s ∈ insert (F.gen s) s :=
  finset.mem_insert_self _ _,
λ h₂, by rw h₂ at h₁; contradiction

/- pgen -/

/-- Generate a pair of a fresh atom and a new avoidance set. -/
def pgen (F : fresh α) (s : finset α) : α × finset α :=
let a := F.gen s in ⟨a, insert a s⟩

theorem pgen_not_mem (F : fresh α) :
  ∀ (s : finset α), (F.pgen s).1 ∉ s :=
F.gen_not_mem

theorem pgen_subset (F : fresh α) (s : finset α) : s ⊆ (F.pgen s).2 :=
finset.subset_insert _ _

theorem pgen_ne_of_mem {a} (F : fresh α) (s : finset α) (h : a ∈ s) : a ≠ (F.pgen s).1 :=
F.gen_ne_of_mem h

/- pgenl -/

/-- Generate a pair of a fresh atom list of the given length and a new
avoidance set. -/
def pgenl (F : fresh α) (s : finset α) : ℕ → list α × finset α
| 0     := ⟨[], s⟩
| (n+1) :=
  have ih : list α × finset α := pgenl n,
  have a : α := F.gen ih.2,
  ⟨a :: ih.1, insert a ih.2⟩

@[simp] theorem pgenl_zero (F : fresh α) (s : finset α) :
  F.pgenl s 0 = prod.mk [] s :=
rfl

@[simp] theorem pgenl_succ (F : fresh α) (s : finset α) (n : ℕ) :
  F.pgenl s (n+1) =
  prod.mk (F.gen (F.pgenl s n).2 :: (F.pgenl s n).1)
          (insert (F.gen (F.pgenl s n).2) (F.pgenl s n).2) :=
by simp [pgenl]

theorem pgenl_length_eq (F : fresh α) (s : finset α) :
  ∀ n, (F.pgenl s n).1.length = n
| 0     := rfl
| (n+1) := by simp *

theorem pgenl_subset (F : fresh α) (s : finset α) :
  ∀ n, s ⊆ (F.pgenl s n).2
| 0     := by simp
| (n+1) :=
  begin
    rcases finset.ssubset_iff.mp (F.gen_ssubset_insert (F.pgenl s n).2) with ⟨a, _, h₃⟩,
    have h₁ : s ⊆ (F.pgenl s n).2 := pgenl_subset _,
    have h₂ : (F.pgenl s n).2 ⊆ insert a (F.pgenl s n).2 := finset.subset_insert _ _,
    exact finset.subset.trans h₁ (finset.subset.trans h₂ h₃)
  end

theorem pgenl_list_subset (F : fresh α) (s : finset α) :
  ∀ n, ∀ a ∈ (F.pgenl s n).1, a ∈ (F.pgenl s n).2
| 0     := by simp
| (n+1) := λ a h, by simp at h; cases h; [simp [h], simp [pgenl_list_subset _ _ h]]

@[simp] theorem gen_pgenl_not_mem (F : fresh α) (s : finset α) (n : ℕ) :
  F.gen (F.pgenl s n).2 ∉ s :=
mt (λ p, F.pgenl_subset s n p) (F.gen_not_mem _)

@[simp] theorem gen_pgenl_not_mem_list (F : fresh α) (s : finset α) (n : ℕ) :
  F.gen (F.pgenl s n).2 ∉ (F.pgenl s n).1 :=
mt (F.pgenl_list_subset s n _) (F.gen_not_mem (F.pgenl s n).2)

theorem pgenl_not_mem (F : fresh α) {s : finset α} {a} :
  ∀ {n}, a ∈ (F.pgenl s n).1 → a ∉ s
| 0     h := by cases h
| (n+1) h := by simp at h; cases h; [simp [h], simp [pgenl_not_mem h]]

theorem pgenl_nodup (F : fresh α) (s : finset α) :
  ∀ n, (F.pgenl s n).1.nodup
| 0     := list.nodup_nil
| (n+1) := list.nodup_cons_of_nodup (by simp) (pgenl_nodup n)

@[simp] theorem gen_pgenl_ne_of_mem (F : fresh α) {s : finset α} {a n} (h : a ∈ s) :
  a ≠ F.gen (F.pgenl s n).2 :=
F.gen_ne_of_mem $ F.pgenl_subset s n h

theorem pgenl_not_mem_singleton_self (F : fresh α) (a) (n) :
  a ∉ (F.pgenl (finset.singleton a) n).1 :=
by induction n; simp *

theorem pgenl_mem_singleton (F : fresh α) {a b n}
  (h : a ∈ (F.pgenl (finset.singleton b) n).1) : a ≠ b :=
λ h', F.pgenl_not_mem_singleton_self b n (by simpa [h'] using h)

theorem pgenl_mem_union (F : fresh α) {s₁ s₂ : finset α} {n a}
  (h : a ∈ (F.pgenl (s₁ ∪ s₂) n).1) : a ∉ s₁ ∧ a ∉ s₂ :=
finset.not_mem_union.mp $ F.pgenl_not_mem h

/- pgenf -/

/-- Generate a pair of a fresh atom set of the given cardinality and a new
avoidance set. -/
def pgenf (F : fresh α) (s : finset α) (n : ℕ) : finset α × finset α :=
⟨⟨(F.pgenl s n).1, F.pgenl_nodup s n⟩, (F.pgenl s n).2⟩

@[simp] theorem pgenf_zero (F : fresh α) (s : finset α) :
  F.pgenf s 0 = prod.mk ∅ s :=
rfl

@[simp] theorem pgenf_succ (F : fresh α) (s : finset α) (n : ℕ) :
  F.pgenf s (n+1) =
  prod.mk (insert (F.gen (F.pgenf s n).2) (F.pgenf s n).1)
          (insert (F.gen (F.pgenf s n).2) (F.pgenf s n).2) :=
by simp [pgenf]; congr; exact (list.insert_of_not_mem (F.gen_pgenl_not_mem_list s n)).symm

theorem pgenf_subset (F : fresh α) (s : finset α) (n : ℕ) :
  ∀ a ∈ (F.pgenf s n).1, a ∈ (F.pgenf s n).2 :=
F.pgenl_list_subset s n

theorem pgenf_not_mem (F : fresh α) (s : finset α) (n : ℕ) :
  F.gen (F.pgenf s n).2 ∉ (F.pgenf s n).1 :=
F.gen_pgenl_not_mem_list s n

end fresh

/-- Fresh atom list generator -/
structure freshL (α : Type*) :=
/- Generate an atom list from an avoidance set -/
(gen : finset α → list α)
/- The list has no duplicates. -/
(gen_nodup : ∀ (s : finset α), (gen s).nodup)
/- The list is fresh. -/
(gen_not_mem : ∀ {s : finset α} {a : α}, a ∈ gen s → a ∉ s)

namespace freshL
variables [decidable_eq α]

/- gen -/

@[simp] theorem gen_not_mem_of_subset (F : freshL α) {s s' : finset α} (ss : s ⊆ s')
  {a : α} (h : a ∈ s) : a ∉ F.gen s' :=
λ h', F.gen_not_mem h' (ss h)

/- pgen -/

/-- Generate a pair of a fresh atom list and a new avoidance set. -/
def pgen (F : freshL α) (s : finset α) : list α × finset α :=
let l := F.gen s in ⟨l, l.foldr insert s⟩

theorem pgen_nodup (F : freshL α) (s : finset α) : (F.pgen s).1.nodup :=
F.gen_nodup s

theorem pgen_not_mem (F : freshL α) :
  ∀ {s : finset α} {a : α}, a ∈ (F.pgen s).1 → a ∉ s :=
F.gen_not_mem

theorem pgen_mem_union (F : freshL α) {s₁ s₂ : finset α} {a}
  (h : a ∈ (F.pgen (s₁ ∪ s₂)).1) : a ∉ s₁ ∧ a ∉ s₂ :=
finset.not_mem_union.mp $ F.pgen_not_mem h

end freshL

/- infinite nat -/

namespace finset

/-- Successor of the maximum: the minimum nat not a member of a finite set -/
def max_succ (s : finset ℕ) : ℕ :=
match s.max with
| none   := 0
| some m := m + 1
end

@[simp] theorem max_succ_empty : max_succ ∅ = 0 :=
rfl

@[simp] theorem max_succ_of_ne_empty {s : finset ℕ} (h : s ≠ ∅) :
  s.max_succ = s.max.iget + 1 :=
let ⟨m, hm⟩ := finset.max_of_ne_empty h in
by simp [option.mem_def.mp hm, max_succ, option.iget]

theorem max_succ_not_mem (s : finset ℕ) : s.max_succ ∉ s :=
λ h, if p : s = ∅ then
  by simpa [p] using h
else
  let ⟨m, hm⟩ := finset.max_of_ne_empty p in
  have hms : m+1 ∈ s := by simpa [max_succ, option.mem_def.mp hm] using h,
  m.not_succ_le_self $ le_max_of_mem hms hm

end finset

/-- A simple fresh nat generator -/
protected def fresh.nat : fresh ℕ :=
⟨finset.max_succ, finset.max_succ_not_mem⟩

/-- Tagged pair: a value and a natural number. This is useful for associating
strings with numbers and printing uniquely tagged strings. -/
@[derive decidable_eq]
structure tagged (α : Type*) :=
(val : α)
(tag : ℕ)

namespace tagged

instance [has_repr α] : has_repr (tagged α) :=
⟨λ ⟨a, t⟩, repr a ++ "_" ++ repr t⟩

def zero (a : α) : tagged α :=
⟨a, 0⟩

def succ : tagged α → tagged α
| ⟨a, t⟩ := ⟨a, t.succ⟩

variables [_root_.decidable_eq α]

/-- All tags for a given value. -/
def tags (s : finset (tagged α)) (a : α) : finset ℕ :=
(s.filter (λ (b : tagged α), a = b.val)).image tag

def fresh (s : finset (tagged α)) (a : α) : tagged α :=
mk a (tags s a).max_succ

theorem fresh_not_mem (s : finset (tagged α)) (a : α) : fresh s a ∉ s :=
have p : (tags s a).max_succ ∉ tags s a := finset.max_succ_not_mem _,
by simp [tags] at p; exact λ h, p _ h rfl rfl

theorem fresh_inj (s : finset (tagged α)) : function.injective (fresh s) :=
λ a₁ a₂ h, by simp [fresh] at h; exact h.1

def freshL (s : finset (tagged α)) : list α → list (tagged α) :=
list.map (fresh s)

theorem freshL_nodup (s : finset (tagged α)) {l : list α} (nd : l.nodup) : (freshL s l).nodup :=
list.nodup_map (fresh_inj s) nd

theorem freshL_not_mem {s : finset (tagged α)} :
  ∀ {l : list α} {a : tagged α}, a ∈ freshL s l → a ∉ s
| []      a h := by cases h
| (a'::_) a h := by
  simp [freshL] at h;
  cases h;
  [{subst h}, {rcases h with ⟨a', _, h⟩, induction h}];
  exact fresh_not_mem s a'

end tagged

section fresh_tagged
variables [decidable_eq α] {l : list α}

/-- A fresh tagged pair generator for a particular atom. -/
protected def fresh.tagged (a : α) : fresh (tagged α) :=
⟨λ s, tagged.fresh s a, λ s, tagged.fresh_not_mem s a⟩

/-- A fresh tagged list pair generator for a particular list of atoms. -/
protected def freshL.tagged (nd : l.nodup) : freshL (tagged α) :=
⟨λ s, tagged.freshL s l, λ s, tagged.freshL_nodup s nd, λ _ _, tagged.freshL_not_mem⟩

theorem freshL.tagged_length_eq (s : finset (tagged α)) (nd : l.nodup) :
  ((freshL.tagged nd).pgen s).1.length = l.length :=
by simp [freshL.pgen, freshL.tagged, tagged.freshL]

end fresh_tagged