/-
Copyright (c) 2020 Johan Commelin, Robert Y. Lewis. 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 data.mv_polynomial.monad
! leanprover-community/mathlib commit 5120cf49cb659e2499edd7e4d336a04efd598f2f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.MvPolynomial.Rename
import Mathbin.Data.MvPolynomial.Variables

/-!

# Monad operations on `mv_polynomial`

This file defines two monadic operations on `mv_polynomial`. Given `p : mv_polynomial σ R`,

* `mv_polynomial.bind₁` and `mv_polynomial.join₁` operate on the variable type `σ`.
* `mv_polynomial.bind₂` and `mv_polynomial.join₂` operate on the coefficient type `R`.

- `mv_polynomial.bind₁ f φ` with `f : σ → mv_polynomial τ R` and `φ : mv_polynomial σ R`,
  is the polynomial `φ(f 1, ..., f i, ...) : mv_polynomial τ R`.
- `mv_polynomial.join₁ φ` with `φ : mv_polynomial (mv_polynomial σ R) R` collapses `φ` to
  a `mv_polynomial σ R`, by evaluating `φ` under the map `X f ↦ f` for `f : mv_polynomial σ R`.
  In other words, if you have a polynomial `φ` in a set of variables indexed by a polynomial ring,
  you evaluate the polynomial in these indexing polynomials.
- `mv_polynomial.bind₂ f φ` with `f : R →+* mv_polynomial σ S` and `φ : mv_polynomial σ R`
  is the `mv_polynomial σ S` obtained from `φ` by mapping the coefficients of `φ` through `f`
  and considering the resulting polynomial as polynomial expression in `mv_polynomial σ R`.
- `mv_polynomial.join₂ φ` with `φ : mv_polynomial σ (mv_polynomial σ R)` collapses `φ` to
  a `mv_polynomial σ R`, by considering `φ` as polynomial expression in `mv_polynomial σ R`.

These operations themselves have algebraic structure: `mv_polynomial.bind₁`
and `mv_polynomial.join₁` are algebra homs and
`mv_polynomial.bind₂` and `mv_polynomial.join₂` are ring homs.

They interact in convenient ways with `mv_polynomial.rename`, `mv_polynomial.map`,
`mv_polynomial.vars`, and other polynomial operations.
Indeed, `mv_polynomial.rename` is the "map" operation for the (`bind₁`, `join₁`) pair,
whereas `mv_polynomial.map` is the "map" operation for the other pair.

## Implementation notes

We add an `is_lawful_monad` instance for the (`bind₁`, `join₁`) pair.
The second pair cannot be instantiated as a `monad`,
since it is not a monad in `Type` but in `CommRing` (or rather `CommSemiRing`).

-/

open BigOperators

noncomputable section

namespace MvPolynomial

open Finsupp

variable {σ : Type _} {τ : Type _}

variable {R S T : Type _} [CommSemiring R] [CommSemiring S] [CommSemiring T]

/--
`bind₁` is the "left hand side" bind operation on `mv_polynomial`, operating on the variable type.
Given a polynomial `p : mv_polynomial σ R` and a map `f : σ → mv_polynomial τ R` taking variables
in `p` to polynomials in the variable type `τ`, `bind₁ f p` replaces each variable in `p` with
its value under `f`, producing a new polynomial in `τ`. The coefficient type remains the same.
This operation is an algebra hom.
-/
def bind₁ (f : σ → MvPolynomial τ R) : MvPolynomial σ R →ₐ[R] MvPolynomial τ R :=
  aeval f
#align mv_polynomial.bind₁ MvPolynomial.bind₁

/-- `bind₂` is the "right hand side" bind operation on `mv_polynomial`,
operating on the coefficient type.
Given a polynomial `p : mv_polynomial σ R` and
a map `f : R → mv_polynomial σ S` taking coefficients in `p` to polynomials over a new ring `S`,
`bind₂ f p` replaces each coefficient in `p` with its value under `f`,
producing a new polynomial over `S`.
The variable type remains the same. This operation is a ring hom.
-/
def bind₂ (f : R →+* MvPolynomial σ S) : MvPolynomial σ R →+* MvPolynomial σ S :=
  eval₂Hom f X
#align mv_polynomial.bind₂ MvPolynomial.bind₂

/--
`join₁` is the monadic join operation corresponding to `mv_polynomial.bind₁`. Given a polynomial `p`
with coefficients in `R` whose variables are polynomials in `σ` with coefficients in `R`,
`join₁ p` collapses `p` to a polynomial with variables in `σ` and coefficients in `R`.
This operation is an algebra hom.
-/
def join₁ : MvPolynomial (MvPolynomial σ R) R →ₐ[R] MvPolynomial σ R :=
  aeval id
#align mv_polynomial.join₁ MvPolynomial.join₁

/--
`join₂` is the monadic join operation corresponding to `mv_polynomial.bind₂`. Given a polynomial `p`
with variables in `σ` whose coefficients are polynomials in `σ` with coefficients in `R`,
`join₂ p` collapses `p` to a polynomial with variables in `σ` and coefficients in `R`.
This operation is a ring hom.
-/
def join₂ : MvPolynomial σ (MvPolynomial σ R) →+* MvPolynomial σ R :=
  eval₂Hom (RingHom.id _) X
#align mv_polynomial.join₂ MvPolynomial.join₂

@[simp]
theorem aeval_eq_bind₁ (f : σ → MvPolynomial τ R) : aeval f = bind₁ f :=
  rfl
#align mv_polynomial.aeval_eq_bind₁ MvPolynomial.aeval_eq_bind₁

@[simp]
theorem eval₂Hom_c_eq_bind₁ (f : σ → MvPolynomial τ R) : eval₂Hom C f = bind₁ f :=
  rfl
#align mv_polynomial.eval₂_hom_C_eq_bind₁ MvPolynomial.eval₂Hom_c_eq_bind₁

@[simp]
theorem eval₂Hom_eq_bind₂ (f : R →+* MvPolynomial σ S) : eval₂Hom f X = bind₂ f :=
  rfl
#align mv_polynomial.eval₂_hom_eq_bind₂ MvPolynomial.eval₂Hom_eq_bind₂

section

variable (σ R)

@[simp]
theorem aeval_id_eq_join₁ : aeval id = @join₁ σ R _ :=
  rfl
#align mv_polynomial.aeval_id_eq_join₁ MvPolynomial.aeval_id_eq_join₁

theorem eval₂Hom_c_id_eq_join₁ (φ : MvPolynomial (MvPolynomial σ R) R) :
    eval₂Hom C id φ = join₁ φ :=
  rfl
#align mv_polynomial.eval₂_hom_C_id_eq_join₁ MvPolynomial.eval₂Hom_c_id_eq_join₁

@[simp]
theorem eval₂Hom_id_x_eq_join₂ : eval₂Hom (RingHom.id _) X = @join₂ σ R _ :=
  rfl
#align mv_polynomial.eval₂_hom_id_X_eq_join₂ MvPolynomial.eval₂Hom_id_x_eq_join₂

end

-- In this file, we don't want to use these simp lemmas,
-- because we first need to show how these new definitions interact
-- and the proofs fall back on unfolding the definitions and call simp afterwards
attribute [-simp]
  aeval_eq_bind₁ eval₂_hom_C_eq_bind₁ eval₂_hom_eq_bind₂ aeval_id_eq_join₁ eval₂_hom_id_X_eq_join₂

@[simp]
theorem bind₁_x_right (f : σ → MvPolynomial τ R) (i : σ) : bind₁ f (X i) = f i :=
  aeval_X f i
#align mv_polynomial.bind₁_X_right MvPolynomial.bind₁_x_right

@[simp]
theorem bind₂_x_right (f : R →+* MvPolynomial σ S) (i : σ) : bind₂ f (X i) = X i :=
  eval₂Hom_X' f X i
#align mv_polynomial.bind₂_X_right MvPolynomial.bind₂_x_right

@[simp]
theorem bind₁_x_left : bind₁ (X : σ → MvPolynomial σ R) = AlgHom.id R _ :=
  by
  ext1 i
  simp
#align mv_polynomial.bind₁_X_left MvPolynomial.bind₁_x_left

variable (f : σ → MvPolynomial τ R)

@[simp]
theorem bind₁_c_right (f : σ → MvPolynomial τ R) (x) : bind₁ f (C x) = C x := by
  simp [bind₁, algebra_map_eq]
#align mv_polynomial.bind₁_C_right MvPolynomial.bind₁_c_right

@[simp]
theorem bind₂_c_right (f : R →+* MvPolynomial σ S) (r : R) : bind₂ f (C r) = f r :=
  eval₂Hom_C f X r
#align mv_polynomial.bind₂_C_right MvPolynomial.bind₂_c_right

@[simp]
theorem bind₂_c_left : bind₂ (C : R →+* MvPolynomial σ R) = RingHom.id _ := by ext : 2 <;> simp
#align mv_polynomial.bind₂_C_left MvPolynomial.bind₂_c_left

@[simp]
theorem bind₂_comp_c (f : R →+* MvPolynomial σ S) : (bind₂ f).comp C = f :=
  RingHom.ext <| bind₂_c_right _
#align mv_polynomial.bind₂_comp_C MvPolynomial.bind₂_comp_c

@[simp]
theorem join₂_map (f : R →+* MvPolynomial σ S) (φ : MvPolynomial σ R) :
    join₂ (map f φ) = bind₂ f φ := by simp only [join₂, bind₂, eval₂_hom_map_hom, RingHom.id_comp]
#align mv_polynomial.join₂_map MvPolynomial.join₂_map

@[simp]
theorem join₂_comp_map (f : R →+* MvPolynomial σ S) : join₂.comp (map f) = bind₂ f :=
  RingHom.ext <| join₂_map _
#align mv_polynomial.join₂_comp_map MvPolynomial.join₂_comp_map

theorem aeval_id_rename (f : σ → MvPolynomial τ R) (p : MvPolynomial σ R) :
    aeval id (rename f p) = aeval f p := by rw [aeval_rename, Function.comp.left_id]
#align mv_polynomial.aeval_id_rename MvPolynomial.aeval_id_rename

@[simp]
theorem join₁_rename (f : σ → MvPolynomial τ R) (φ : MvPolynomial σ R) :
    join₁ (rename f φ) = bind₁ f φ :=
  aeval_id_rename _ _
#align mv_polynomial.join₁_rename MvPolynomial.join₁_rename

@[simp]
theorem bind₁_id : bind₁ (@id (MvPolynomial σ R)) = join₁ :=
  rfl
#align mv_polynomial.bind₁_id MvPolynomial.bind₁_id

@[simp]
theorem bind₂_id : bind₂ (RingHom.id (MvPolynomial σ R)) = join₂ :=
  rfl
#align mv_polynomial.bind₂_id MvPolynomial.bind₂_id

theorem bind₁_bind₁ {υ : Type _} (f : σ → MvPolynomial τ R) (g : τ → MvPolynomial υ R)
    (φ : MvPolynomial σ R) : (bind₁ g) (bind₁ f φ) = bind₁ (fun i => bind₁ g (f i)) φ := by
  simp [bind₁, ← comp_aeval]
#align mv_polynomial.bind₁_bind₁ MvPolynomial.bind₁_bind₁

theorem bind₁_comp_bind₁ {υ : Type _} (f : σ → MvPolynomial τ R) (g : τ → MvPolynomial υ R) :
    (bind₁ g).comp (bind₁ f) = bind₁ fun i => bind₁ g (f i) :=
  by
  ext1
  apply bind₁_bind₁
#align mv_polynomial.bind₁_comp_bind₁ MvPolynomial.bind₁_comp_bind₁

theorem bind₂_comp_bind₂ (f : R →+* MvPolynomial σ S) (g : S →+* MvPolynomial σ T) :
    (bind₂ g).comp (bind₂ f) = bind₂ ((bind₂ g).comp f) := by ext : 2 <;> simp
#align mv_polynomial.bind₂_comp_bind₂ MvPolynomial.bind₂_comp_bind₂

theorem bind₂_bind₂ (f : R →+* MvPolynomial σ S) (g : S →+* MvPolynomial σ T)
    (φ : MvPolynomial σ R) : (bind₂ g) (bind₂ f φ) = bind₂ ((bind₂ g).comp f) φ :=
  RingHom.congr_fun (bind₂_comp_bind₂ f g) φ
#align mv_polynomial.bind₂_bind₂ MvPolynomial.bind₂_bind₂

theorem rename_comp_bind₁ {υ : Type _} (f : σ → MvPolynomial τ R) (g : τ → υ) :
    (rename g).comp (bind₁ f) = bind₁ fun i => rename g <| f i :=
  by
  ext1 i
  simp
#align mv_polynomial.rename_comp_bind₁ MvPolynomial.rename_comp_bind₁

theorem rename_bind₁ {υ : Type _} (f : σ → MvPolynomial τ R) (g : τ → υ) (φ : MvPolynomial σ R) :
    rename g (bind₁ f φ) = bind₁ (fun i => rename g <| f i) φ :=
  AlgHom.congr_fun (rename_comp_bind₁ f g) φ
#align mv_polynomial.rename_bind₁ MvPolynomial.rename_bind₁

theorem map_bind₂ (f : R →+* MvPolynomial σ S) (g : S →+* T) (φ : MvPolynomial σ R) :
    map g (bind₂ f φ) = bind₂ ((map g).comp f) φ :=
  by
  simp only [bind₂, eval₂_comp_right, coe_eval₂_hom, eval₂_map]
  congr 1 with : 1
  simp only [Function.comp_apply, map_X]
#align mv_polynomial.map_bind₂ MvPolynomial.map_bind₂

theorem bind₁_comp_rename {υ : Type _} (f : τ → MvPolynomial υ R) (g : σ → τ) :
    (bind₁ f).comp (rename g) = bind₁ (f ∘ g) :=
  by
  ext1 i
  simp
#align mv_polynomial.bind₁_comp_rename MvPolynomial.bind₁_comp_rename

theorem bind₁_rename {υ : Type _} (f : τ → MvPolynomial υ R) (g : σ → τ) (φ : MvPolynomial σ R) :
    bind₁ f (rename g φ) = bind₁ (f ∘ g) φ :=
  AlgHom.congr_fun (bind₁_comp_rename f g) φ
#align mv_polynomial.bind₁_rename MvPolynomial.bind₁_rename

theorem bind₂_map (f : S →+* MvPolynomial σ T) (g : R →+* S) (φ : MvPolynomial σ R) :
    bind₂ f (map g φ) = bind₂ (f.comp g) φ := by simp [bind₂]
#align mv_polynomial.bind₂_map MvPolynomial.bind₂_map

@[simp]
theorem map_comp_c (f : R →+* S) : (map f).comp (C : R →+* MvPolynomial σ R) = C.comp f :=
  by
  ext1
  apply map_C
#align mv_polynomial.map_comp_C MvPolynomial.map_comp_c

-- mixing the two monad structures
theorem hom_bind₁ (f : MvPolynomial τ R →+* S) (g : σ → MvPolynomial τ R) (φ : MvPolynomial σ R) :
    f (bind₁ g φ) = eval₂Hom (f.comp C) (fun i => f (g i)) φ := by
  rw [bind₁, map_aeval, algebra_map_eq]
#align mv_polynomial.hom_bind₁ MvPolynomial.hom_bind₁

theorem map_bind₁ (f : R →+* S) (g : σ → MvPolynomial τ R) (φ : MvPolynomial σ R) :
    map f (bind₁ g φ) = bind₁ (fun i : σ => (map f) (g i)) (map f φ) :=
  by
  rw [hom_bind₁, map_comp_C, ← eval₂_hom_map_hom]
  rfl
#align mv_polynomial.map_bind₁ MvPolynomial.map_bind₁

@[simp]
theorem eval₂Hom_comp_c (f : R →+* S) (g : σ → S) : (eval₂Hom f g).comp C = f :=
  by
  ext1 r
  exact eval₂_C f g r
#align mv_polynomial.eval₂_hom_comp_C MvPolynomial.eval₂Hom_comp_c

theorem eval₂Hom_bind₁ (f : R →+* S) (g : τ → S) (h : σ → MvPolynomial τ R) (φ : MvPolynomial σ R) :
    eval₂Hom f g (bind₁ h φ) = eval₂Hom f (fun i => eval₂Hom f g (h i)) φ := by
  rw [hom_bind₁, eval₂_hom_comp_C]
#align mv_polynomial.eval₂_hom_bind₁ MvPolynomial.eval₂Hom_bind₁

theorem aeval_bind₁ [Algebra R S] (f : τ → S) (g : σ → MvPolynomial τ R) (φ : MvPolynomial σ R) :
    aeval f (bind₁ g φ) = aeval (fun i => aeval f (g i)) φ :=
  eval₂Hom_bind₁ _ _ _ _
#align mv_polynomial.aeval_bind₁ MvPolynomial.aeval_bind₁

theorem aeval_comp_bind₁ [Algebra R S] (f : τ → S) (g : σ → MvPolynomial τ R) :
    (aeval f).comp (bind₁ g) = aeval fun i => aeval f (g i) :=
  by
  ext1
  apply aeval_bind₁
#align mv_polynomial.aeval_comp_bind₁ MvPolynomial.aeval_comp_bind₁

theorem eval₂Hom_comp_bind₂ (f : S →+* T) (g : σ → T) (h : R →+* MvPolynomial σ S) :
    (eval₂Hom f g).comp (bind₂ h) = eval₂Hom ((eval₂Hom f g).comp h) g := by ext : 2 <;> simp
#align mv_polynomial.eval₂_hom_comp_bind₂ MvPolynomial.eval₂Hom_comp_bind₂

theorem eval₂Hom_bind₂ (f : S →+* T) (g : σ → T) (h : R →+* MvPolynomial σ S)
    (φ : MvPolynomial σ R) : eval₂Hom f g (bind₂ h φ) = eval₂Hom ((eval₂Hom f g).comp h) g φ :=
  RingHom.congr_fun (eval₂Hom_comp_bind₂ f g h) φ
#align mv_polynomial.eval₂_hom_bind₂ MvPolynomial.eval₂Hom_bind₂

theorem aeval_bind₂ [Algebra S T] (f : σ → T) (g : R →+* MvPolynomial σ S) (φ : MvPolynomial σ R) :
    aeval f (bind₂ g φ) = eval₂Hom ((↑(aeval f : _ →ₐ[S] _) : _ →+* _).comp g) f φ :=
  eval₂Hom_bind₂ _ _ _ _
#align mv_polynomial.aeval_bind₂ MvPolynomial.aeval_bind₂

theorem eval₂Hom_c_left (f : σ → MvPolynomial τ R) : eval₂Hom C f = bind₁ f :=
  rfl
#align mv_polynomial.eval₂_hom_C_left MvPolynomial.eval₂Hom_c_left

theorem bind₁_monomial (f : σ → MvPolynomial τ R) (d : σ →₀ ℕ) (r : R) :
    bind₁ f (monomial d r) = C r * ∏ i in d.support, f i ^ d i := by
  simp only [monomial_eq, AlgHom.map_mul, bind₁_C_right, Finsupp.prod, AlgHom.map_prod,
    AlgHom.map_pow, bind₁_X_right]
#align mv_polynomial.bind₁_monomial MvPolynomial.bind₁_monomial

theorem bind₂_monomial (f : R →+* MvPolynomial σ S) (d : σ →₀ ℕ) (r : R) :
    bind₂ f (monomial d r) = f r * monomial d 1 := by
  simp only [monomial_eq, RingHom.map_mul, bind₂_C_right, Finsupp.prod, RingHom.map_prod,
    RingHom.map_pow, bind₂_X_right, C_1, one_mul]
#align mv_polynomial.bind₂_monomial MvPolynomial.bind₂_monomial

@[simp]
theorem bind₂_monomial_one (f : R →+* MvPolynomial σ S) (d : σ →₀ ℕ) :
    bind₂ f (monomial d 1) = monomial d 1 := by rw [bind₂_monomial, f.map_one, one_mul]
#align mv_polynomial.bind₂_monomial_one MvPolynomial.bind₂_monomial_one

section

open Classical

theorem vars_bind₁ (f : σ → MvPolynomial τ R) (φ : MvPolynomial σ R) :
    (bind₁ f φ).vars ⊆ φ.vars.bunionᵢ fun i => (f i).vars :=
  by
  calc
    (bind₁ f φ).vars = (φ.support.sum fun x : σ →₀ ℕ => (bind₁ f) (monomial x (coeff x φ))).vars :=
      by rw [← AlgHom.map_sum, ← φ.as_sum]
    _ ≤ φ.support.bUnion fun i : σ →₀ ℕ => ((bind₁ f) (monomial i (coeff i φ))).vars :=
      (vars_sum_subset _ _)
    _ = φ.support.bUnion fun d : σ →₀ ℕ => (C (coeff d φ) * ∏ i in d.support, f i ^ d i).vars := by
      simp only [bind₁_monomial]
    _ ≤ φ.support.bUnion fun d : σ →₀ ℕ => d.support.bUnion fun i => (f i).vars := _
    -- proof below
        _ ≤
        φ.vars.bUnion fun i : σ => (f i).vars :=
      _

  -- proof below
  · apply Finset.bunionᵢ_mono
    intro d hd
    calc
      (C (coeff d φ) * ∏ i : σ in d.support, f i ^ d i).vars ≤
          (C (coeff d φ)).vars ∪ (∏ i : σ in d.support, f i ^ d i).vars :=
        vars_mul _ _
      _ ≤ (∏ i : σ in d.support, f i ^ d i).vars := by
        simp only [Finset.empty_union, vars_C, Finset.le_iff_subset, Finset.Subset.refl]
      _ ≤ d.support.bUnion fun i : σ => (f i ^ d i).vars := (vars_prod _)
      _ ≤ d.support.bUnion fun i : σ => (f i).vars := _

    apply Finset.bunionᵢ_mono
    intro i hi
    apply vars_pow
  · intro j
    simp_rw [Finset.mem_bunionᵢ]
    rintro ⟨d, hd, ⟨i, hi, hj⟩⟩
    exact ⟨i, (mem_vars _).mpr ⟨d, hd, hi⟩, hj⟩
#align mv_polynomial.vars_bind₁ MvPolynomial.vars_bind₁

end

theorem mem_vars_bind₁ (f : σ → MvPolynomial τ R) (φ : MvPolynomial σ R) {j : τ}
    (h : j ∈ (bind₁ f φ).vars) : ∃ i : σ, i ∈ φ.vars ∧ j ∈ (f i).vars := by
  simpa only [exists_prop, Finset.mem_bunionᵢ, mem_support_iff, Ne.def] using vars_bind₁ f φ h
#align mv_polynomial.mem_vars_bind₁ MvPolynomial.mem_vars_bind₁

instance monad : Monad fun σ => MvPolynomial σ R
    where
  map α β f p := rename f p
  pure _ := X
  bind _ _ p f := bind₁ f p
#align mv_polynomial.monad MvPolynomial.monad

instance lawfulFunctor : LawfulFunctor fun σ => MvPolynomial σ R
    where
  id_map := by intros <;> simp [(· <$> ·)]
  comp_map := by intros <;> simp [(· <$> ·)]
#align mv_polynomial.is_lawful_functor MvPolynomial.lawfulFunctor

instance lawfulMonad : LawfulMonad fun σ => MvPolynomial σ R
    where
  pure_bind := by intros <;> simp [pure, bind]
  bind_assoc := by intros <;> simp [bind, ← bind₁_comp_bind₁]
#align mv_polynomial.is_lawful_monad MvPolynomial.lawfulMonad

/-
Possible TODO for the future:
Enable the following definitions, and write a lot of supporting lemmas.

def bind (f : R →+* mv_polynomial τ S) (g : σ → mv_polynomial τ S) :
  mv_polynomial σ R →+* mv_polynomial τ S :=
eval₂_hom f g

def join (f : R →+* S) : mv_polynomial (mv_polynomial σ R) S →ₐ[S] mv_polynomial σ S :=
aeval (map f)

def ajoin [algebra R S] : mv_polynomial (mv_polynomial σ R) S →ₐ[S] mv_polynomial σ S :=
join (algebra_map R S)

-/
end MvPolynomial


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro
-/
import data.option.defs
import logic.basic
import tactic.cache
/-!
## Definitions on lists

This file contains various definitions on lists. It does not contain
proofs about these definitions, those are contained in other files in `data/list`
-/

namespace list

open function nat native (rb_map mk_rb_map rb_map.of_list)
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}

instance [decidable_eq α] : has_sdiff (list α) :=
⟨ list.diff ⟩

/-- Split a list at an index.

     split_at 2 [a, b, c] = ([a, b], [c]) -/
def split_at : ℕ → list α → list α × list α
| 0        a         := ([], a)
| (succ n) []        := ([], [])
| (succ n) (x :: xs) := let (l, r) := split_at n xs in (x :: l, r)

/-- An auxiliary function for `split_on_p`. -/
def split_on_p_aux {α : Type u} (P : α → Prop) [decidable_pred P] :
  list α → (list α → list α) → list (list α)
| [] f       := [f []]
| (h :: t) f :=
  if P h then f [] :: split_on_p_aux t id
  else split_on_p_aux t (λ l, f (h :: l))

/-- Split a list at every element satisfying a predicate. -/
def split_on_p {α : Type u} (P : α → Prop) [decidable_pred P] (l : list α) : list (list α) :=
split_on_p_aux P l id

/-- Split a list at every occurrence of an element.

    [1,1,2,3,2,4,4].split_on 2 = [[1,1],[3],[4,4]] -/
def split_on {α : Type u} [decidable_eq α] (a : α) (as : list α) : list (list α) :=
as.split_on_p (=a)

/-- Concatenate an element at the end of a list.

     concat [a, b] c = [a, b, c] -/
@[simp] def concat : list α → α → list α
| []     a := [a]
| (b::l) a := b :: concat l a

/-- `head' xs` returns the first element of `xs` if `xs` is non-empty;
it returns `none` otherwise -/
@[simp] def head' : list α → option α
| []       := none
| (a :: l) := some a

/-- Convert a list into an array (whose length is the length of `l`). -/
def to_array (l : list α) : array l.length α :=
{data := λ v, l.nth_le v.1 v.2}

/-- "inhabited" `nth` function: returns `default` instead of `none` in the case
  that the index is out of bounds. -/
@[simp] def inth [h : inhabited α] (l : list α) (n : nat) : α := (nth l n).iget

/-- Apply a function to the nth tail of `l`. Returns the input without
  using `f` if the index is larger than the length of the list.

     modify_nth_tail f 2 [a, b, c] = [a, b] ++ f [c] -/
@[simp] def modify_nth_tail (f : list α → list α) : ℕ → list α → list α
| 0     l      := f l
| (n+1) []     := []
| (n+1) (a::l) := a :: modify_nth_tail n l

/-- Apply `f` to the head of the list, if it exists. -/
@[simp] def modify_head (f : α → α) : list α → list α
| []     := []
| (a::l) := f a :: l

/-- Apply `f` to the nth element of the list, if it exists. -/
def modify_nth (f : α → α) : ℕ → list α → list α :=
modify_nth_tail (modify_head f)

/-- Apply `f` to the last element of `l`, if it exists. -/
@[simp] def modify_last (f : α → α) : list α → list α
| [] := []
| [x] := [f x]
| (x :: xs) := x :: modify_last xs

/-- `insert_nth n a l` inserts `a` into the list `l` after the first `n` elements of `l`
 `insert_nth 2 1 [1, 2, 3, 4] = [1, 2, 1, 3, 4]`-/
def insert_nth (n : ℕ) (a : α) : list α → list α := modify_nth_tail (list.cons a) n

section take'
variable [inhabited α]

/-- Take `n` elements from a list `l`. If `l` has less than `n` elements, append `n - length l`
elements `default α`. -/
def take' : ∀ n, list α → list α
| 0     l := []
| (n+1) l := l.head :: take' n l.tail

end take'

/-- Get the longest initial segment of the list whose members all satisfy `p`.

     take_while (λ x, x < 3) [0, 2, 5, 1] = [0, 2] -/
def take_while (p : α → Prop) [decidable_pred p] : list α → list α
| []     := []
| (a::l) := if p a then a :: take_while l else []

/-- Fold a function `f` over the list from the left, returning the list
  of partial results.

     scanl (+) 0 [1, 2, 3] = [0, 1, 3, 6] -/
def scanl (f : α → β → α) : α → list β → list α
| a []     := [a]
| a (b::l) := a :: scanl (f a b) l

/-- Auxiliary definition used to define `scanr`. If `scanr_aux f b l = (b', l')`
then `scanr f b l = b' :: l'` -/
def scanr_aux (f : α → β → β) (b : β) : list α → β × list β
| []     := (b, [])
| (a::l) := let (b', l') := scanr_aux l in (f a b', b' :: l')

/-- Fold a function `f` over the list from the right, returning the list
  of partial results.

     scanr (+) 0 [1, 2, 3] = [6, 5, 3, 0] -/
def scanr (f : α → β → β) (b : β) (l : list α) : list β :=
let (b', l') := scanr_aux f b l in b' :: l'

/-- Product of a list.

     prod [a, b, c] = ((1 * a) * b) * c -/
def prod [has_mul α] [has_one α] : list α → α := foldl (*) 1

/-- Sum of a list.

     sum [a, b, c] = ((0 + a) + b) + c -/
-- Later this will be tagged with `to_additive`, but this can't be done yet because of import
-- dependencies.
def sum [has_add α] [has_zero α] : list α → α := foldl (+) 0

/-- The alternating sum of a list. -/
def alternating_sum {G : Type*} [has_zero G] [has_add G] [has_neg G] : list G → G
| [] := 0
| (g :: []) := g
| (g :: h :: t) := g + -h + alternating_sum t

/-- The alternating product of a list. -/
def alternating_prod {G : Type*} [has_one G] [has_mul G] [has_inv G] : list G → G
| [] := 1
| (g :: []) := g
| (g :: h :: t) := g * h⁻¹ * alternating_prod t

/-- Given a function `f : α → β ⊕ γ`, `partition_map f l` maps the list by `f`
  whilst partitioning the result it into a pair of lists, `list β × list γ`,
  partitioning the `sum.inl _` into the left list, and the `sum.inr _` into the right list.
  `partition_map (id : ℕ ⊕ ℕ → ℕ ⊕ ℕ) [inl 0, inr 1, inl 2] = ([0,2], [1])`    -/
def partition_map (f : α → β ⊕ γ) : list α → list β × list γ
| [] := ([],[])
| (x::xs) :=
match f x with
| (sum.inr r) := prod.map id (cons r) $ partition_map xs
| (sum.inl l) := prod.map (cons l) id $ partition_map xs
end

/-- `find p l` is the first element of `l` satisfying `p`, or `none` if no such
  element exists. -/
def find (p : α → Prop) [decidable_pred p] : list α → option α
| []     := none
| (a::l) := if p a then some a else find l

/-- `mfind tac l` returns the first element of `l` on which `tac` succeeds, and
fails otherwise. -/
def mfind {α} {m : Type u → Type v} [monad m] [alternative m] (tac : α → m punit) : list α → m α :=
list.mfirst $ λ a, tac a $> a

/-- `mbfind' p l` returns the first element `a` of `l` for which `p a` returns
true. `mbfind'` short-circuits, so `p` is not necessarily run on every `a` in
`l`. This is a monadic version of `list.find`. -/
def mbfind' {m : Type u → Type v} [monad m] {α : Type u} (p : α → m (ulift bool)) :
  list α → m (option α)
| [] := pure none
| (x :: xs) := do
  ⟨px⟩ ← p x,
  if px then pure (some x) else mbfind' xs

section

variables {m : Type → Type v} [monad m]

/-- A variant of `mbfind'` with more restrictive universe levels. -/
def mbfind {α} (p : α → m bool) (xs : list α) : m (option α) :=
xs.mbfind' (functor.map ulift.up ∘ p)

/-- `many p as` returns true iff `p` returns true for any element of `l`.
`many` short-circuits, so if `p` returns true for any element of `l`, later
elements are not checked. This is a monadic version of `list.any`. -/
-- Implementing this via `mbfind` would give us less universe polymorphism.
def many {α : Type u} (p : α → m bool) : list α → m bool
| [] := pure false
| (x :: xs) := do px ← p x, if px then pure tt else many xs

/-- `mall p as` returns true iff `p` returns true for all elements of `l`.
`mall` short-circuits, so if `p` returns false for any element of `l`, later
elements are not checked. This is a monadic version of `list.all`. -/
def mall {α : Type u} (p : α → m bool) (as : list α) : m bool :=
bnot <$> many (λ a, bnot <$> p a) as

/-- `mbor xs` runs the actions in `xs`, returning true if any of them returns
true. `mbor` short-circuits, so if an action returns true, later actions are
not run. This is a monadic version of `list.bor`. -/
def mbor : list (m bool) → m bool :=
many id

/-- `mband xs` runs the actions in `xs`, returning true if all of them return
true. `mband` short-circuits, so if an action returns false, later actions are
not run. This is a monadic version of `list.band`. -/
def mband : list (m bool) → m bool :=
mall id

end

/-- Auxiliary definition for `foldl_with_index`. -/
def foldl_with_index_aux (f : ℕ → α → β → α) : ℕ → α → list β → α
| _ a [] := a
| i a (b :: l) := foldl_with_index_aux (i + 1) (f i a b) l

/-- Fold a list from left to right as with `foldl`, but the combining function
also receives each element's index. -/
def foldl_with_index (f : ℕ → α → β → α) (a : α) (l : list β) : α :=
foldl_with_index_aux f 0 a l

/-- Auxiliary definition for `foldr_with_index`. -/
def foldr_with_index_aux (f : ℕ → α → β → β) : ℕ → β → list α → β
| _ b [] := b
| i b (a :: l) := f i a (foldr_with_index_aux (i + 1) b l)

/-- Fold a list from right to left as with `foldr`, but the combining function
also receives each element's index. -/
def foldr_with_index (f : ℕ → α → β → β) (b : β) (l : list α) : β :=
foldr_with_index_aux f 0 b l

/-- `find_indexes p l` is the list of indexes of elements of `l` that satisfy `p`. -/
def find_indexes (p : α → Prop) [decidable_pred p] (l : list α) : list nat :=
foldr_with_index (λ i a is, if p a then i :: is else is) [] l

/-- Returns the elements of `l` that satisfy `p` together with their indexes in
`l`. The returned list is ordered by index. -/
def indexes_values (p : α → Prop) [decidable_pred p] (l : list α) : list (ℕ × α) :=
foldr_with_index (λ i a l, if p a then (i , a) :: l else l) [] l

/-- `indexes_of a l` is the list of all indexes of `a` in `l`. For example:
```
indexes_of a [a, b, a, a] = [0, 2, 3]
```
-/
def indexes_of [decidable_eq α] (a : α) : list α → list nat := find_indexes (eq a)

section mfold_with_index

variables {m : Type v → Type w} [monad m]

/-- Monadic variant of `foldl_with_index`. -/
def mfoldl_with_index {α β} (f : ℕ → β → α → m β) (b : β) (as : list α) : m β :=
as.foldl_with_index (λ i ma b, do a ← ma, f i a b) (pure b)

/-- Monadic variant of `foldr_with_index`. -/
def mfoldr_with_index {α β} (f : ℕ → α → β → m β) (b : β) (as : list α) : m β :=
as.foldr_with_index (λ i a mb, do b ← mb, f i a b) (pure b)

end mfold_with_index

section mmap_with_index

variables {m : Type v → Type w} [applicative m]

/-- Auxiliary definition for `mmap_with_index`. -/
def mmap_with_index_aux {α β} (f : ℕ → α → m β) : ℕ → list α → m (list β)
| _ [] := pure []
| i (a :: as) := list.cons <$> f i a <*> mmap_with_index_aux (i + 1) as

/-- Applicative variant of `map_with_index`. -/
def mmap_with_index {α β} (f : ℕ → α → m β) (as : list α) : m (list β) :=
mmap_with_index_aux f 0 as

/-- Auxiliary definition for `mmap_with_index'`. -/
def mmap_with_index'_aux {α} (f : ℕ → α → m punit) : ℕ → list α → m punit
| _ [] := pure ⟨⟩
| i (a :: as) := f i a *> mmap_with_index'_aux (i + 1) as

/-- A variant of `mmap_with_index` specialised to applicative actions which
return `unit`. -/
def mmap_with_index' {α} (f : ℕ → α → m punit) (as : list α) : m punit :=
mmap_with_index'_aux f 0 as

end mmap_with_index

/-- `lookmap` is a combination of `lookup` and `filter_map`.
  `lookmap f l` will apply `f : α → option α` to each element of the list,
  replacing `a → b` at the first value `a` in the list such that `f a = some b`. -/
def lookmap (f : α → option α) : list α → list α
| []     := []
| (a::l) :=
  match f a with
  | some b := b :: l
  | none   := a :: lookmap l
  end

/-- `countp p l` is the number of elements of `l` that satisfy `p`. -/
def countp (p : α → Prop) [decidable_pred p] : list α → nat
| []      := 0
| (x::xs) := if p x then succ (countp xs) else countp xs

/-- `count a l` is the number of occurrences of `a` in `l`. -/
def count [decidable_eq α] (a : α) : list α → nat := countp (eq a)

/-- `is_prefix l₁ l₂`, or `l₁ <+: l₂`, means that `l₁` is a prefix of `l₂`,
  that is, `l₂` has the form `l₁ ++ t` for some `t`. -/
def is_prefix (l₁ : list α) (l₂ : list α) : Prop := ∃ t, l₁ ++ t = l₂

/-- `is_suffix l₁ l₂`, or `l₁ <:+ l₂`, means that `l₁` is a suffix of `l₂`,
  that is, `l₂` has the form `t ++ l₁` for some `t`. -/
def is_suffix (l₁ : list α) (l₂ : list α) : Prop := ∃ t, t ++ l₁ = l₂

/-- `is_infix l₁ l₂`, or `l₁ <:+: l₂`, means that `l₁` is a contiguous
  substring of `l₂`, that is, `l₂` has the form `s ++ l₁ ++ t` for some `s, t`. -/
def is_infix (l₁ : list α) (l₂ : list α) : Prop := ∃ s t, s ++ l₁ ++ t = l₂

infix ` <+: `:50 := is_prefix
infix ` <:+ `:50 := is_suffix
infix ` <:+: `:50 := is_infix

/-- `inits l` is the list of initial segments of `l`.

     inits [1, 2, 3] = [[], [1], [1, 2], [1, 2, 3]] -/
@[simp] def inits : list α → list (list α)
| []     := [[]]
| (a::l) := [] :: map (λt, a::t) (inits l)

/-- `tails l` is the list of terminal segments of `l`.

     tails [1, 2, 3] = [[1, 2, 3], [2, 3], [3], []] -/
@[simp] def tails : list α → list (list α)
| []     := [[]]
| (a::l) := (a::l) :: tails l

def sublists'_aux : list α → (list α → list β) → list (list β) → list (list β)
| []     f r := f [] :: r
| (a::l) f r := sublists'_aux l f (sublists'_aux l (f ∘ cons a) r)

/-- `sublists' l` is the list of all (non-contiguous) sublists of `l`.
  It differs from `sublists` only in the order of appearance of the sublists;
  `sublists'` uses the first element of the list as the MSB,
  `sublists` uses the first element of the list as the LSB.

     sublists' [1, 2, 3] = [[], [3], [2], [2, 3], [1], [1, 3], [1, 2], [1, 2, 3]] -/
def sublists' (l : list α) : list (list α) :=
sublists'_aux l id []

def sublists_aux : list α → (list α → list β → list β) → list β
| []     f := []
| (a::l) f := f [a] (sublists_aux l (λys r, f ys (f (a :: ys) r)))

/-- `sublists l` is the list of all (non-contiguous) sublists of `l`; cf. `sublists'`
  for a different ordering.

     sublists [1, 2, 3] = [[], [1], [2], [1, 2], [3], [1, 3], [2, 3], [1, 2, 3]] -/
def sublists (l : list α) : list (list α) :=
[] :: sublists_aux l cons

def sublists_aux₁ : list α → (list α → list β) → list β
| []     f := []
| (a::l) f := f [a] ++ sublists_aux₁ l (λys, f ys ++ f (a :: ys))

section forall₂
variables {r : α → β → Prop} {p : γ → δ → Prop}

/-- `forall₂ R l₁ l₂` means that `l₁` and `l₂` have the same length,
  and whenever `a` is the nth element of `l₁`, and `b` is the nth element of `l₂`,
  then `R a b` is satisfied. -/
inductive forall₂ (R : α → β → Prop) : list α → list β → Prop
| nil : forall₂ [] []
| cons {a b l₁ l₂} : R a b → forall₂ l₁ l₂ → forall₂ (a::l₁) (b::l₂)

attribute [simp] forall₂.nil

end forall₂

/-- Auxiliary definition used to define `transpose`.
  `transpose_aux l L` takes each element of `l` and appends it to the start of
  each element of `L`.

  `transpose_aux [a, b, c] [l₁, l₂, l₃] = [a::l₁, b::l₂, c::l₃]` -/
def transpose_aux : list α → list (list α) → list (list α)
| []     ls      := ls
| (a::i) []      := [a] :: transpose_aux i []
| (a::i) (l::ls) := (a::l) :: transpose_aux i ls

/-- transpose of a list of lists, treated as a matrix.

     transpose [[1, 2], [3, 4], [5, 6]] = [[1, 3, 5], [2, 4, 6]] -/
def transpose : list (list α) → list (list α)
| []      := []
| (l::ls) := transpose_aux l (transpose ls)

/-- List of all sections through a list of lists. A section
  of `[L₁, L₂, ..., Lₙ]` is a list whose first element comes from
  `L₁`, whose second element comes from `L₂`, and so on. -/
def sections : list (list α) → list (list α)
| []     := [[]]
| (l::L) := bind (sections L) $ λ s, map (λ a, a::s) l

section permutations

def permutations_aux2 (t : α) (ts : list α) (r : list β) : list α → (list α → β) → list α × list β
| []      f := (ts, r)
| (y::ys) f := let (us, zs) := permutations_aux2 ys (λx : list α, f (y::x)) in
               (y :: us, f (t :: y :: us) :: zs)

private def meas : (Σ'_:list α, list α) → ℕ × ℕ | ⟨l, i⟩ := (length l + length i, length l)

local infix ` ≺ `:50 := inv_image (prod.lex (<) (<)) meas

@[elab_as_eliminator] def permutations_aux.rec {C : list α → list α → Sort v}
  (H0 : ∀ is, C [] is)
  (H1 : ∀ t ts is, C ts (t::is) → C is [] → C (t::ts) is) : ∀ l₁ l₂, C l₁ l₂
| []      is := H0 is
| (t::ts) is :=
  have h1 : ⟨ts, t :: is⟩ ≺ ⟨t :: ts, is⟩, from
    show prod.lex _ _ (succ (length ts + length is), length ts) (succ (length ts) + length is,
      length (t :: ts)),
    by rw nat.succ_add; exact prod.lex.right _ (lt_succ_self _),
  have h2 : ⟨is, []⟩ ≺ ⟨t :: ts, is⟩, from prod.lex.left _ _ (nat.lt_add_of_pos_left (succ_pos _)),
  H1 t ts is (permutations_aux.rec ts (t::is)) (permutations_aux.rec is [])
using_well_founded {
  dec_tac := tactic.assumption,
  rel_tac := λ _ _, `[exact ⟨(≺), @inv_image.wf _ _ _ meas (prod.lex_wf lt_wf lt_wf)⟩] }

def permutations_aux : list α → list α → list (list α) :=
@@permutations_aux.rec (λ _ _, list (list α)) (λ is, [])
  (λ t ts is IH1 IH2, foldr (λy r, (permutations_aux2 t ts r y id).2) IH1 (is :: IH2))

/-- List of all permutations of `l`.

     permutations [1, 2, 3] =
       [[1, 2, 3], [2, 1, 3], [3, 2, 1],
        [2, 3, 1], [3, 1, 2], [1, 3, 2]] -/
def permutations (l : list α) : list (list α) :=
l :: permutations_aux l []

end permutations

/-- `erasep p l` removes the first element of `l` satisfying the predicate `p`. -/
def erasep (p : α → Prop) [decidable_pred p] : list α → list α
| []     := []
| (a::l) := if p a then l else a :: erasep l

/-- `extractp p l` returns a pair of an element `a` of `l` satisfying the predicate
  `p`, and `l`, with `a` removed. If there is no such element `a` it returns `(none, l)`. -/
def extractp (p : α → Prop) [decidable_pred p] : list α → option α × list α
| []     := (none, [])
| (a::l) := if p a then (some a, l) else
  let (a', l') := extractp l in (a', a :: l')

/-- `revzip l` returns a list of pairs of the elements of `l` paired
  with the elements of `l` in reverse order.

`revzip [1,2,3,4,5] = [(1, 5), (2, 4), (3, 3), (4, 2), (5, 1)]`
 -/
def revzip (l : list α) : list (α × α) := zip l l.reverse

/-- `product l₁ l₂` is the list of pairs `(a, b)` where `a ∈ l₁` and `b ∈ l₂`.

     product [1, 2] [5, 6] = [(1, 5), (1, 6), (2, 5), (2, 6)] -/
def product (l₁ : list α) (l₂ : list β) : list (α × β) :=
l₁.bind $ λ a, l₂.map $ prod.mk a

/-- `sigma l₁ l₂` is the list of dependent pairs `(a, b)` where `a ∈ l₁` and `b ∈ l₂ a`.

     sigma [1, 2] (λ_, [(5 : ℕ), 6]) = [(1, 5), (1, 6), (2, 5), (2, 6)] -/
protected def sigma {σ : α → Type*} (l₁ : list α) (l₂ : Π a, list (σ a)) : list (Σ a, σ a) :=
l₁.bind $ λ a, (l₂ a).map $ sigma.mk a

/-- Auxliary definition used to define `of_fn`.

  `of_fn_aux f m h l` returns the first `m` elements of `of_fn f`
  appended to `l` -/
def of_fn_aux {n} (f : fin n → α) : ∀ m, m ≤ n → list α → list α
| 0        h l := l
| (succ m) h l := of_fn_aux m (le_of_lt h) (f ⟨m, h⟩ :: l)

/-- `of_fn f` with `f : fin n → α` returns the list whose ith element is `f i`
  `of_fun f = [f 0, f 1, ... , f(n - 1)]` -/
def of_fn {n} (f : fin n → α) : list α :=
of_fn_aux f n (le_refl _) []

/-- `of_fn_nth_val f i` returns `some (f i)` if `i < n` and `none` otherwise. -/
def of_fn_nth_val {n} (f : fin n → α) (i : ℕ) : option α :=
if h : i < n then some (f ⟨i, h⟩) else none

/-- `disjoint l₁ l₂` means that `l₁` and `l₂` have no elements in common. -/
def disjoint (l₁ l₂ : list α) : Prop := ∀ ⦃a⦄, a ∈ l₁ → a ∈ l₂ → false

section pairwise
variables (R : α → α → Prop)

/-- `pairwise R l` means that all the elements with earlier indexes are
  `R`-related to all the elements with later indexes.

     pairwise R [1, 2, 3] ↔ R 1 2 ∧ R 1 3 ∧ R 2 3

  For example if `R = (≠)` then it asserts `l` has no duplicates,
  and if `R = (<)` then it asserts that `l` is (strictly) sorted. -/
inductive pairwise : list α → Prop
| nil : pairwise []
| cons : ∀ {a : α} {l : list α}, (∀ a' ∈ l, R a a') → pairwise l → pairwise (a::l)

variables {R}
@[simp] theorem pairwise_cons {a : α} {l : list α} :
  pairwise R (a::l) ↔ (∀ a' ∈ l, R a a') ∧ pairwise R l :=
⟨λ p, by cases p with a l n p; exact ⟨n, p⟩, λ ⟨n, p⟩, p.cons n⟩

attribute [simp] pairwise.nil

instance decidable_pairwise [decidable_rel R] (l : list α) : decidable (pairwise R l) :=
by induction l with hd tl ih; [exact is_true pairwise.nil,
  exactI decidable_of_iff' _ pairwise_cons]

end pairwise

/-- `pw_filter R l` is a maximal sublist of `l` which is `pairwise R`.
  `pw_filter (≠)` is the erase duplicates function (cf. `erase_dup`), and `pw_filter (<)` finds
  a maximal increasing subsequence in `l`. For example,

     pw_filter (<) [0, 1, 5, 2, 6, 3, 4] = [0, 1, 2, 3, 4] -/
def pw_filter (R : α → α → Prop) [decidable_rel R] : list α → list α
| []        := []
| (x :: xs) := let IH := pw_filter xs in if ∀ y ∈ IH, R x y then x :: IH else IH

section chain
variable (R : α → α → Prop)

/-- `chain R a l` means that `R` holds between adjacent elements of `a::l`.

     chain R a [b, c, d] ↔ R a b ∧ R b c ∧ R c d -/
inductive chain : α → list α → Prop
| nil {a : α} : chain a []
| cons : ∀ {a b : α} {l : list α}, R a b → chain b l → chain a (b::l)

/-- `chain' R l` means that `R` holds between adjacent elements of `l`.

     chain' R [a, b, c, d] ↔ R a b ∧ R b c ∧ R c d -/
def chain' : list α → Prop
| [] := true
| (a :: l) := chain R a l

variable {R}
@[simp] theorem chain_cons {a b : α} {l : list α} :
  chain R a (b::l) ↔ R a b ∧ chain R b l :=
⟨λ p, by cases p with _ a b l n p; exact ⟨n, p⟩, λ ⟨n, p⟩, p.cons n⟩

attribute [simp] chain.nil

instance decidable_chain [decidable_rel R] (a : α) (l : list α) : decidable (chain R a l) :=
by induction l generalizing a; simp only [chain.nil, chain_cons]; resetI; apply_instance

instance decidable_chain' [decidable_rel R] (l : list α) : decidable (chain' R l) :=
by cases l; dunfold chain'; apply_instance

end chain

/-- `nodup l` means that `l` has no duplicates, that is, any element appears at most
  once in the list. It is defined as `pairwise (≠)`. -/
def nodup : list α → Prop := pairwise (≠)

instance nodup_decidable [decidable_eq α] : ∀ l : list α, decidable (nodup l) :=
list.decidable_pairwise

/-- `erase_dup l` removes duplicates from `l` (taking only the first occurrence).
  Defined as `pw_filter (≠)`.

     erase_dup [1, 0, 2, 2, 1] = [0, 2, 1] -/
def erase_dup [decidable_eq α] : list α → list α := pw_filter (≠)

/-- `range' s n` is the list of numbers `[s, s+1, ..., s+n-1]`.
  It is intended mainly for proving properties of `range` and `iota`. -/
@[simp] def range' : ℕ → ℕ → list ℕ
| s 0     := []
| s (n+1) := s :: range' (s+1) n

/-- Drop `none`s from a list, and replace each remaining `some a` with `a`. -/
def reduce_option {α} : list (option α) → list α :=
list.filter_map id

/-- `ilast' x xs` returns the last element of `xs` if `xs` is non-empty;
it returns `x` otherwise -/
@[simp] def ilast' {α} : α → list α → α
| a []     := a
| a (b::l) := ilast' b l

/-- `last' xs` returns the last element of `xs` if `xs` is non-empty;
it returns `none` otherwise -/
@[simp] def last' {α} : list α → option α
| []     := none
| [a]    := some a
| (b::l) := last' l

/-- `rotate l n` rotates the elements of `l` to the left by `n`

     rotate [0, 1, 2, 3, 4, 5] 2 = [2, 3, 4, 5, 0, 1] -/
def rotate (l : list α) (n : ℕ) : list α :=
let (l₁, l₂) := list.split_at (n % l.length) l in l₂ ++ l₁

/-- rotate' is the same as `rotate`, but slower. Used for proofs about `rotate`-/
def rotate' : list α → ℕ → list α
| []     n     := []
| l      0     := l
| (a::l) (n+1) := rotate' (l ++ [a]) n

section choose
variables (p : α → Prop) [decidable_pred p] (l : list α)

/-- Given a decidable predicate `p` and a proof of existence of `a ∈ l` such that `p a`,
choose the first element with this property. This version returns both `a` and proofs
of `a ∈ l` and `p a`. -/
def choose_x : Π l : list α, Π hp : (∃ a, a ∈ l ∧ p a), { a // a ∈ l ∧ p a }
| [] hp := false.elim (exists.elim hp (assume a h, not_mem_nil a h.left))
| (l :: ls) hp := if pl : p l then ⟨l, ⟨or.inl rfl, pl⟩⟩ else
let ⟨a, ⟨a_mem_ls, pa⟩⟩ := choose_x ls (hp.imp
  (λ b ⟨o, h₂⟩, ⟨o.resolve_left (λ e, pl $ e ▸ h₂), h₂⟩)) in
⟨a, ⟨or.inr a_mem_ls, pa⟩⟩

/-- Given a decidable predicate `p` and a proof of existence of `a ∈ l` such that `p a`,
choose the first element with this property. This version returns `a : α`, and properties
are given by `choose_mem` and `choose_property`. -/
def choose (hp : ∃ a, a ∈ l ∧ p a) : α := choose_x p l hp

end choose

/-- Filters and maps elements of a list -/
def mmap_filter {m : Type → Type v} [monad m] {α β} (f : α → m (option β)) :
  list α → m (list β)
| []       := return []
| (h :: t) := do b ← f h, t' ← t.mmap_filter, return $
  match b with none := t' | (some x) := x::t' end

/--
`mmap_upper_triangle f l` calls `f` on all elements in the upper triangular part of `l × l`.
That is, for each `e ∈ l`, it will run `f e e` and then `f e e'`
for each `e'` that appears after `e` in `l`.

Example: suppose `l = [1, 2, 3]`. `mmap_upper_triangle f l` will produce the list
`[f 1 1, f 1 2, f 1 3, f 2 2, f 2 3, f 3 3]`.
-/
def mmap_upper_triangle {m} [monad m] {α β : Type u} (f : α → α → m β) : list α → m (list β)
| [] := return []
| (h::t) := do v ← f h h, l ← t.mmap (f h), t ← t.mmap_upper_triangle, return $ (v::l) ++ t

/--
`mmap'_diag f l` calls `f` on all elements in the upper triangular part of `l × l`.
That is, for each `e ∈ l`, it will run `f e e` and then `f e e'`
for each `e'` that appears after `e` in `l`.

Example: suppose `l = [1, 2, 3]`. `mmap'_diag f l` will evaluate, in this order,
`f 1 1`, `f 1 2`, `f 1 3`, `f 2 2`, `f 2 3`, `f 3 3`.
-/
def mmap'_diag {m} [monad m] {α} (f : α → α → m unit) : list α → m unit
| [] := return ()
| (h::t) := f h h >> t.mmap' (f h) >> t.mmap'_diag

protected def traverse {F : Type u → Type v} [applicative F] {α β : Type*} (f : α → F β) :
  list α → F (list β)
| [] := pure []
| (x :: xs) := list.cons <$> f x <*> traverse xs

/-- `get_rest l l₁` returns `some l₂` if `l = l₁ ++ l₂`.
  If `l₁` is not a prefix of `l`, returns `none` -/
def get_rest [decidable_eq α] : list α → list α → option (list α)
| l      []      := some l
| []     _       := none
| (x::l) (y::l₁) := if x = y then get_rest l l₁ else none

/--
`list.slice n m xs` removes a slice of length `m` at index `n` in list `xs`.
-/
def slice {α} : ℕ → ℕ → list α → list α
| 0 n xs := xs.drop n
| (succ n) m [] := []
| (succ n) m (x :: xs) := x :: slice n m xs

/--
Left-biased version of `list.map₂`. `map₂_left' f as bs` applies `f` to each
pair of elements `aᵢ ∈ as` and `bᵢ ∈ bs`. If `bs` is shorter than `as`, `f` is
applied to `none` for the remaining `aᵢ`. Returns the results of the `f`
applications and the remaining `bs`.

```
map₂_left' prod.mk [1, 2] ['a'] = ([(1, some 'a'), (2, none)], [])

map₂_left' prod.mk [1] ['a', 'b'] = ([(1, some 'a')], ['b'])
```
-/
@[simp] def map₂_left' (f : α → option β → γ) : list α → list β → (list γ × list β)
| [] bs := ([], bs)
| (a :: as) [] :=
  ((a :: as).map (λ a, f a none), [])
| (a :: as) (b :: bs) :=
  let rec := map₂_left' as bs in
  (f a (some b) :: rec.fst, rec.snd)

/--
Right-biased version of `list.map₂`. `map₂_right' f as bs` applies `f` to each
pair of elements `aᵢ ∈ as` and `bᵢ ∈ bs`. If `as` is shorter than `bs`, `f` is
applied to `none` for the remaining `bᵢ`. Returns the results of the `f`
applications and the remaining `as`.

```
map₂_right' prod.mk [1] ['a', 'b'] = ([(some 1, 'a'), (none, 'b')], [])

map₂_right' prod.mk [1, 2] ['a'] = ([(some 1, 'a')], [2])
```
-/
def map₂_right' (f : option α → β → γ) (as : list α) (bs : list β) : (list γ × list α) :=
map₂_left' (flip f) bs as

/--
Left-biased version of `list.zip`. `zip_left' as bs` returns the list of
pairs `(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `bs` is shorter than `as`, the
remaining `aᵢ` are paired with `none`. Also returns the remaining `bs`.

```
zip_left' [1, 2] ['a'] = ([(1, some 'a'), (2, none)], [])

zip_left' [1] ['a', 'b'] = ([(1, some 'a')], ['b'])

zip_left' = map₂_left' prod.mk

```
-/
def zip_left' : list α → list β → list (α × option β) × list β :=
map₂_left' prod.mk

/--
Right-biased version of `list.zip`. `zip_right' as bs` returns the list of
pairs `(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `as` is shorter than `bs`, the
remaining `bᵢ` are paired with `none`. Also returns the remaining `as`.

```
zip_right' [1] ['a', 'b'] = ([(some 1, 'a'), (none, 'b')], [])

zip_right' [1, 2] ['a'] = ([(some 1, 'a')], [2])

zip_right' = map₂_right' prod.mk
```
-/
def zip_right' : list α → list β → list (option α × β) × list α :=
map₂_right' prod.mk

/--
Left-biased version of `list.map₂`. `map₂_left f as bs` applies `f` to each pair
`aᵢ ∈ as` and `bᵢ ∈ bs`. If `bs` is shorter than `as`, `f` is applied to `none`
for the remaining `aᵢ`.

```
map₂_left prod.mk [1, 2] ['a'] = [(1, some 'a'), (2, none)]

map₂_left prod.mk [1] ['a', 'b'] = [(1, some 'a')]

map₂_left f as bs = (map₂_left' f as bs).fst
```
-/
@[simp] def map₂_left (f : α → option β → γ) : list α → list β → list γ
| [] _ := []
| (a :: as) [] := (a :: as).map (λ a, f a none)
| (a :: as) (b :: bs) := f a (some b) :: map₂_left as bs

/--
Right-biased version of `list.map₂`. `map₂_right f as bs` applies `f` to each
pair `aᵢ ∈ as` and `bᵢ ∈ bs`. If `as` is shorter than `bs`, `f` is applied to
`none` for the remaining `bᵢ`.

```
map₂_right prod.mk [1, 2] ['a'] = [(some 1, 'a')]

map₂_right prod.mk [1] ['a', 'b'] = [(some 1, 'a'), (none, 'b')]

map₂_right f as bs = (map₂_right' f as bs).fst
```
-/
def map₂_right (f : option α → β → γ) (as : list α) (bs : list β) :
  list γ :=
map₂_left (flip f) bs as

/--
Left-biased version of `list.zip`. `zip_left as bs` returns the list of pairs
`(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `bs` is shorter than `as`, the
remaining `aᵢ` are paired with `none`.

```
zip_left [1, 2] ['a'] = [(1, some 'a'), (2, none)]

zip_left [1] ['a', 'b'] = [(1, some 'a')]

zip_left = map₂_left prod.mk
```
-/
def zip_left : list α → list β → list (α × option β) :=
map₂_left prod.mk

/--
Right-biased version of `list.zip`. `zip_right as bs` returns the list of pairs
`(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `as` is shorter than `bs`, the
remaining `bᵢ` are paired with `none`.

```
zip_right [1, 2] ['a'] = [(some 1, 'a')]

zip_right [1] ['a', 'b'] = [(some 1, 'a'), (none, 'b')]

zip_right = map₂_right prod.mk
```
-/
def zip_right : list α → list β → list (option α × β) :=
map₂_right prod.mk

/--
If all elements of `xs` are `some xᵢ`, `all_some xs` returns the `xᵢ`. Otherwise
it returns `none`.

```
all_some [some 1, some 2] = some [1, 2]
all_some [some 1, none  ] = none
```
-/
def all_some : list (option α) → option (list α)
| [] := some []
| (some a :: as) := cons a <$> all_some as
| (none :: as) := none

/--
`fill_nones xs ys` replaces the `none`s in `xs` with elements of `ys`. If there
are not enough `ys` to replace all the `none`s, the remaining `none`s are
dropped from `xs`.

```
fill_nones [none, some 1, none, none] [2, 3] = [2, 1, 3]
```
-/
def fill_nones {α} : list (option α) → list α → list α
| [] _ := []
| (some a :: as) as' := a :: fill_nones as as'
| (none :: as) [] := as.reduce_option
| (none :: as) (a :: as') := a :: fill_nones as as'

/--
`take_list as ns` extracts successive sublists from `as`. For `ns = n₁ ... nₘ`,
it first takes the `n₁` initial elements from `as`, then the next `n₂` ones,
etc. It returns the sublists of `as` -- one for each `nᵢ` -- and the remaining
elements of `as`. If `as` does not have at least as many elements as the sum of
the `nᵢ`, the corresponding sublists will have less than `nᵢ` elements.

```
take_list ['a', 'b', 'c', 'd', 'e'] [2, 1, 1] = ([['a', 'b'], ['c'], ['d']], ['e'])
take_list ['a', 'b'] [3, 1] = ([['a', 'b'], []], [])
```
-/
def take_list {α} : list α → list ℕ → list (list α) × list α
| xs [] := ([], xs)
| xs (n :: ns) :=
  let ⟨xs₁, xs₂⟩ := xs.split_at n in
  let ⟨xss, rest⟩ := take_list xs₂ ns in
  (xs₁ :: xss, rest)

/--
`to_rbmap as` is the map that associates each index `i` of `as` with the
corresponding element of `as`.

```
to_rbmap ['a', 'b', 'c'] = rbmap_of [(0, 'a'), (1, 'b'), (2, 'c')]
```
-/
def to_rbmap : list α → rbmap ℕ α :=
foldl_with_index (λ i mapp a, mapp.insert i a) (mk_rbmap ℕ α)

/--
`to_rb_map as` is the map that associates each index `i` of `as` with the
corresponding element of `as`.

```
to_rb_map ['a', 'b', 'c'] = rb_map.of_list [(0, 'a'), (1, 'b'), (2, 'c')]
```
-/
meta def to_rb_map {α : Type} : list α → rb_map ℕ α :=
foldl_with_index (λ i mapp a, mapp.insert i a) mk_rb_map

/--
`xs.to_chunks n` splits the list into sublists of size at most `n`,
such that `(xs.to_chunks n).join = xs`.

TODO: make non-meta; currently doesn't terminate, e.g.
```
#eval [0].to_chunks 0
```
-/
meta def to_chunks {α} (n : ℕ) : list α → list (list α)
| [] := []
| xs :=
  xs.take n :: (xs.drop n).to_chunks

/--
Asynchronous version of `list.map`.
-/
meta def map_async_chunked {α β} (f : α → β) (xs : list α) (chunk_size := 1024) : list β :=
((xs.to_chunks chunk_size).map (λ xs, task.delay (λ _, list.map f xs))).bind task.get

end list


/-
Copyright (c) 2021 Apurva Nakade. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Apurva Nakade
-/
import algebra.algebra.basic
import group_theory.monoid_localization
import set_theory.surreal.basic

/-!
# Dyadic numbers
Dyadic numbers are obtained by localizing ℤ away from 2. They are the initial object in the category
of rings with no 2-torsion.

## Dyadic surreal numbers
We construct dyadic surreal numbers using the canonical map from ℤ[2 ^ {-1}] to surreals.
As we currently do not have a ring structure on `surreal` we construct this map explicitly. Once we
have the ring structure, this map can be constructed directly by sending `2 ^ {-1}` to `half`.

## Embeddings
The above construction gives us an abelian group embedding of ℤ into `surreal`. The goal is to
extend this to an embedding of dyadic rationals into `surreal` and use Cauchy sequences of dyadic
rational numbers to construct an ordered field embedding of ℝ into `surreal`.
-/

universes u

local infix ` ≈ ` := pgame.equiv

namespace pgame

/-- For a natural number `n`, the pre-game `pow_half (n + 1)` is recursively defined as
`{ 0 | pow_half n }`. These are the explicit expressions of powers of `half`. By definition, we have
 `pow_half 0 = 0` and `pow_half 1 = half` and we prove later on that
`pow_half (n + 1) + pow_half (n + 1) ≈ pow_half n`.-/
def pow_half : ℕ → pgame
| 0       := mk punit pempty 0 pempty.elim
| (n + 1) := mk punit punit 0 (λ _, pow_half n)

@[simp] lemma pow_half_left_moves {n} : (pow_half n).left_moves = punit :=
by cases n; refl

@[simp] lemma pow_half_right_moves {n} : (pow_half (n + 1)).right_moves = punit :=
by cases n; refl

@[simp] lemma pow_half_move_left {n i} : (pow_half n).move_left i = 0 :=
by cases n; cases i; refl

@[simp] lemma pow_half_move_right {n i} : (pow_half (n + 1)).move_right i = pow_half n :=
by cases n; cases i; refl

lemma pow_half_move_left' (n) :
  (pow_half n).move_left (equiv.cast (pow_half_left_moves.symm) punit.star) = 0 :=
by simp only [eq_self_iff_true, pow_half_move_left]

lemma pow_half_move_right' (n) :
  (pow_half (n + 1)).move_right (equiv.cast (pow_half_right_moves.symm) punit.star) = pow_half n :=
by simp only [pow_half_move_right, eq_self_iff_true]

/-- For all natural numbers `n`, the pre-games `pow_half n` are numeric. -/
theorem numeric_pow_half {n} : (pow_half n).numeric :=
begin
  induction n with n hn,
  { exact numeric_one },
  { split,
    { rintro ⟨ ⟩ ⟨ ⟩,
      dsimp only [pi.zero_apply],
      rw ← pow_half_move_left' n,
      apply hn.move_left_lt },
    { exact ⟨λ _, numeric_zero, λ _, hn⟩ } }
end

theorem pow_half_succ_lt_pow_half {n : ℕ} : pow_half (n + 1) < pow_half n :=
(@numeric_pow_half (n + 1)).lt_move_right punit.star

theorem pow_half_succ_le_pow_half {n : ℕ} : pow_half (n + 1) ≤ pow_half n :=
le_of_lt numeric_pow_half numeric_pow_half pow_half_succ_lt_pow_half

theorem zero_lt_pow_half {n : ℕ} : 0 < pow_half n :=
by cases n; rw lt_def_le; use ⟨punit.star, pgame.le_refl 0⟩

theorem zero_le_pow_half {n : ℕ} : 0 ≤ pow_half n :=
le_of_lt numeric_zero numeric_pow_half zero_lt_pow_half

theorem add_pow_half_succ_self_eq_pow_half {n} : pow_half (n + 1) + pow_half (n + 1) ≈ pow_half n :=
begin
  induction n with n hn,
  { exact half_add_half_equiv_one },
  { split; rw le_def_lt; split,
    { rintro (⟨⟨ ⟩⟩ | ⟨⟨ ⟩⟩),
      { calc 0 + pow_half (n.succ + 1) ≈ pow_half (n.succ + 1) : zero_add_equiv _
                                   ... < pow_half n.succ       : pow_half_succ_lt_pow_half },
      { calc pow_half (n.succ + 1) + 0 ≈ pow_half (n.succ + 1) : add_zero_equiv _
                                   ... < pow_half n.succ       : pow_half_succ_lt_pow_half } },
    { rintro ⟨ ⟩,
      rw lt_def_le,
      right,
      use sum.inl punit.star,
      calc pow_half (n.succ) + pow_half (n.succ + 1)
          ≤ pow_half (n.succ) + pow_half (n.succ) : add_le_add_left pow_half_succ_le_pow_half
      ... ≈ pow_half n                            : hn },
    { rintro ⟨ ⟩,
      calc 0 ≈ 0 + 0                                        : (add_zero_equiv _).symm
        ... ≤ pow_half (n.succ + 1) + 0                     : add_le_add_right zero_le_pow_half
        ... < pow_half (n.succ + 1) + pow_half (n.succ + 1) : add_lt_add_left zero_lt_pow_half },
    { rintro (⟨⟨ ⟩⟩ | ⟨⟨ ⟩⟩),
      { calc pow_half n.succ
            ≈ pow_half n.succ + 0                           : (add_zero_equiv _).symm
        ... < pow_half (n.succ) + pow_half (n.succ + 1)     : add_lt_add_left zero_lt_pow_half },
      { calc pow_half n.succ
            ≈ 0 + pow_half n.succ                           : (zero_add_equiv _).symm
        ... < pow_half (n.succ + 1) + pow_half (n.succ)     : add_lt_add_right zero_lt_pow_half }}}
end

end pgame

namespace surreal
open pgame

/-- The surreal number `half`. -/
def half : surreal := ⟦⟨pgame.half, pgame.numeric_half⟩⟧

/-- Powers of the surreal number `half`. -/
def pow_half (n : ℕ) : surreal := ⟦⟨pgame.pow_half n, pgame.numeric_pow_half⟩⟧

@[simp] lemma pow_half_zero : pow_half 0 = 1 := rfl

@[simp] lemma pow_half_one : pow_half 1 = half := rfl

@[simp] theorem add_half_self_eq_one : half + half = 1 :=
quotient.sound pgame.half_add_half_equiv_one

lemma double_pow_half_succ_eq_pow_half (n : ℕ) : 2 • pow_half n.succ = pow_half n :=
begin
  rw two_nsmul,
  apply quotient.sound,
  exact pgame.add_pow_half_succ_self_eq_pow_half,
end

lemma nsmul_pow_two_pow_half (n : ℕ) : 2 ^ n • pow_half n = 1 :=
begin
  induction n with n hn,
  { simp only [nsmul_one, pow_half_zero, nat.cast_one, pow_zero] },
  { rw [← hn, ← double_pow_half_succ_eq_pow_half n, smul_smul (2^n) 2 (pow_half n.succ),
        mul_comm, pow_succ] }
end

lemma nsmul_pow_two_pow_half' (n k : ℕ) : 2 ^ n • pow_half (n + k) = pow_half k :=
begin
  induction k with k hk,
  { simp only [add_zero, surreal.nsmul_pow_two_pow_half, nat.nat_zero_eq_zero, eq_self_iff_true,
               surreal.pow_half_zero] },
  { rw [← double_pow_half_succ_eq_pow_half (n + k), ← double_pow_half_succ_eq_pow_half k,
        smul_algebra_smul_comm] at hk,
    rwa ← (zsmul_eq_zsmul_iff' two_ne_zero) }
end

lemma zsmul_pow_two_pow_half (m : ℤ) (n k : ℕ) :
  (m * 2 ^ n) • pow_half (n + k) = m • pow_half k :=
begin
  rw mul_zsmul,
  congr,
  norm_cast,
  exact nsmul_pow_two_pow_half' n k,
end

lemma dyadic_aux {m₁ m₂ : ℤ} {y₁ y₂ : ℕ} (h₂ : m₁ * (2 ^ y₁) = m₂ * (2 ^ y₂)) :
  m₁ • pow_half y₂ = m₂ • pow_half y₁ :=
begin
  revert m₁ m₂,
  wlog h : y₁ ≤ y₂,
  intros m₁ m₂ h₂,
  obtain ⟨c, rfl⟩ := le_iff_exists_add.mp h,
  rw [add_comm, pow_add, ← mul_assoc, mul_eq_mul_right_iff] at h₂,
  cases h₂,
  { rw [h₂, add_comm, zsmul_pow_two_pow_half m₂ c y₁] },
  { have := nat.one_le_pow y₁ 2 nat.succ_pos',
    linarith },
end

/-- The map `dyadic_map` sends ⟦⟨m, 2^n⟩⟧ to m • half ^ n. -/
def dyadic_map (x : localization (submonoid.powers (2 : ℤ))) : surreal :=
localization.lift_on x (λ x y, x • pow_half (submonoid.log y)) $
begin
  intros m₁ m₂ n₁ n₂ h₁,
  obtain ⟨⟨n₃, y₃, hn₃⟩, h₂⟩ := localization.r_iff_exists.mp h₁,
  simp only [subtype.coe_mk, mul_eq_mul_right_iff] at h₂,
  cases h₂,
  { simp only,
    obtain ⟨a₁, ha₁⟩ := n₁.prop,
    obtain ⟨a₂, ha₂⟩ := n₂.prop,
    have hn₁ : n₁ = submonoid.pow 2 a₁ := subtype.ext ha₁.symm,
    have hn₂ : n₂ = submonoid.pow 2 a₂ := subtype.ext ha₂.symm,
    have h₂ : 1 < (2 : ℤ).nat_abs, from dec_trivial,
    rw [hn₁, hn₂, submonoid.log_pow_int_eq_self h₂, submonoid.log_pow_int_eq_self h₂],
    apply dyadic_aux,
    rwa [ha₁, ha₂] },
  { have := nat.one_le_pow y₃ 2 nat.succ_pos',
    linarith }
end

/-- We define dyadic surreals as the range of the map `dyadic_map`. -/
def dyadic : set surreal := set.range dyadic_map

-- We conclude with some ideas for further work on surreals; these would make fun projects.

-- TODO show that the map from dyadic rationals to surreals is a group homomorphism, and injective

-- TODO map the reals into the surreals, using dyadic Dedekind cuts
-- TODO show this is a group homomorphism, and injective

-- TODO show the maps from the dyadic rationals and from the reals
-- into the surreals are multiplicative

end surreal


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.group.action
import measure_theory.group.pointwise
import measure_theory.integral.set_integral

/-!
# Fundamental domain of a group action

A set `s` is said to be a *fundamental domain* of an action of a group `G` on a measurable space `α`
with respect to a measure `μ` if

* `s` is a measurable set;

* the sets `g • s` over all `g : G` cover almost all points of the whole space;

* the sets `g • s`, are pairwise a.e. disjoint, i.e., `μ (g₁ • s ∩ g₂ • s) = 0` whenever `g₁ ≠ g₂`;
  we require this for `g₂ = 1` in the definition, then deduce it for any two `g₁ ≠ g₂`.

In this file we prove that in case of a countable group `G` and a measure preserving action, any two
fundamental domains have the same measure, and for a `G`-invariant function, its integrals over any
two fundamental domains are equal to each other.

We also generate additive versions of all theorems in this file using the `to_additive` attribute.
-/

open_locale ennreal pointwise topological_space nnreal ennreal measure_theory
open measure_theory measure_theory.measure set function topological_space filter

namespace measure_theory

/-- A measurable set `s` is a *fundamental domain* for an additive action of an additive group `G`
on a measurable space `α` with respect to a measure `α` if the sets `g +ᵥ s`, `g : G`, are pairwise
a.e. disjoint and cover the whole space. -/
@[protect_proj] structure is_add_fundamental_domain (G : Type*) {α : Type*} [has_zero G]
  [has_vadd G α] [measurable_space α] (s : set α) (μ : measure α . volume_tac) : Prop :=
(measurable_set : measurable_set s)
(ae_covers : ∀ᵐ x ∂μ, ∃ g : G, g +ᵥ x ∈ s)
(ae_disjoint : ∀ g ≠ (0 : G), μ ((g +ᵥ s) ∩ s) = 0)

/-- A measurable set `s` is a *fundamental domain* for an action of a group `G` on a measurable
space `α` with respect to a measure `α` if the sets `g • s`, `g : G`, are pairwise a.e. disjoint and
cover the whole space. -/
@[protect_proj, to_additive is_add_fundamental_domain]
structure is_fundamental_domain (G : Type*) {α : Type*} [has_one G] [has_scalar G α]
  [measurable_space α] (s : set α) (μ : measure α . volume_tac) : Prop :=
(measurable_set : measurable_set s)
(ae_covers : ∀ᵐ x ∂μ, ∃ g : G, g • x ∈ s)
(ae_disjoint : ∀ g ≠ (1 : G), μ ((g • s) ∩ s) = 0)

namespace is_fundamental_domain

variables {G α E : Type*} [group G] [mul_action G α] [measurable_space α]
  [normed_group E] {s t : set α} {μ : measure α}

/-- If for each `x : α`, exactly one of `g • x`, `g : G`, belongs to a measurable set `s`, then `s`
is a fundamental domain for the action of `G` on `α`. -/
@[to_additive "If for each `x : α`, exactly one of `g +ᵥ x`, `g : G`, belongs to a measurable set
`s`, then `s` is a fundamental domain for the additive action of `G` on `α`."]
lemma mk' (h_meas : measurable_set s) (h_exists : ∀ x : α, ∃! g : G, g • x ∈ s) :
  is_fundamental_domain G s μ :=
{ measurable_set := h_meas,
  ae_covers := eventually_of_forall $ λ x, (h_exists x).exists,
  ae_disjoint := λ g hne,
    begin
      suffices : g • s ∩ s = ∅, by rw [this, measure_empty],
      refine eq_empty_iff_forall_not_mem.2 _, rintro _ ⟨⟨x, hx, rfl⟩, hgx⟩,
      rw ← one_smul G x at hx,
      exact hne ((h_exists x).unique hgx hx)
    end }

@[to_additive] lemma Union_smul_ae_eq (h : is_fundamental_domain G s μ) :
  (⋃ g : G, g • s) =ᵐ[μ] univ :=
eventually_eq_univ.2 $ h.ae_covers.mono $
  λ x ⟨g, hg⟩, mem_Union.2 ⟨g⁻¹, _, hg, inv_smul_smul _ _⟩

@[to_additive] lemma mono (h : is_fundamental_domain G s μ) {ν : measure α} (hle : ν ≪ μ) :
  is_fundamental_domain G s ν :=
⟨h.1, hle h.2, λ g hg, hle (h.3 g hg)⟩

variables [measurable_space G] [has_measurable_smul G α]

@[to_additive]
lemma measurable_set_smul (h : is_fundamental_domain G s μ) (g : G) : measurable_set (g • s) :=
h.measurable_set.const_smul g

variables [smul_invariant_measure G α μ]

@[to_additive] lemma pairwise_ae_disjoint (h : is_fundamental_domain G s μ) :
  pairwise (λ g₁ g₂ : G, μ (g₁ • s ∩ g₂ • s) = 0) :=
λ g₁ g₂ hne,
calc μ (g₁ • s ∩ g₂ • s) = μ (g₂ • ((g₂⁻¹ * g₁) • s ∩ s)) :
  by rw [smul_set_inter, ← mul_smul, mul_inv_cancel_left]
... = μ ((g₂⁻¹ * g₁) • s ∩ s) : measure_smul_set _ _ _
... = 0 : h.ae_disjoint _ $ mt inv_mul_eq_one.1 hne.symm

variables [encodable G] {ν : measure α}

@[to_additive] lemma sum_restrict_of_ac (h : is_fundamental_domain G s μ) (hν : ν ≪ μ) :
  sum (λ g : G, ν.restrict (g • s)) = ν :=
by rw [← restrict_Union_ae (h.pairwise_ae_disjoint.mono $ λ i j h, hν h) h.measurable_set_smul,
  restrict_congr_set (hν h.Union_smul_ae_eq), restrict_univ]

@[to_additive] lemma lintegral_eq_tsum_of_ac (h : is_fundamental_domain G s μ) (hν : ν ≪ μ)
  (f : α → ℝ≥0∞) : ∫⁻ x, f x ∂ν = ∑' g : G, ∫⁻ x in g • s, f x ∂ν :=
by rw [← lintegral_sum_measure, h.sum_restrict_of_ac hν]

@[to_additive] lemma set_lintegral_eq_tsum' (h : is_fundamental_domain G s μ) (f : α → ℝ≥0∞)
  (t : set α) : ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in t ∩ g • s, f x ∂μ :=
calc ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in g • s, f x ∂(μ.restrict t) :
  h.lintegral_eq_tsum_of_ac restrict_le_self.absolutely_continuous _
... = ∑' g : G, ∫⁻ x in t ∩ g • s, f x ∂μ :
  by simp only [restrict_restrict, h.measurable_set_smul, inter_comm]

@[to_additive] lemma set_lintegral_eq_tsum (h : is_fundamental_domain G s μ) (f : α → ℝ≥0∞)
  (t : set α) :
  ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in g • t ∩ s, f (g⁻¹ • x) ∂μ :=
calc ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in t ∩ g • s, f x ∂μ :
  h.set_lintegral_eq_tsum' f t
... = ∑' g : G, ∫⁻ x in t ∩ g⁻¹ • s, f x ∂μ : ((equiv.inv G).tsum_eq _).symm
... = ∑' g : G, ∫⁻ x in g⁻¹ • (g • t ∩ s), f (x) ∂μ :
  by simp only [smul_set_inter, inv_smul_smul]
... = ∑' g : G, ∫⁻ x in g • t ∩ s, f (g⁻¹ • x) ∂μ :
  tsum_congr $ λ g, ((measure_preserving_smul g⁻¹ μ).set_lintegral_comp_emb
    (measurable_embedding_const_smul _) _ _).symm

@[to_additive] lemma measure_eq_tsum_of_ac (h : is_fundamental_domain G s μ) (hν : ν ≪ μ)
  (t : set α) :
  ν t = ∑' g : G, ν (t ∩ g • s) :=
by simpa only [set_lintegral_one, pi.one_def, measure.restrict_apply (h.measurable_set_smul _),
  inter_comm]
  using h.lintegral_eq_tsum_of_ac (measure.restrict_le_self.absolutely_continuous.trans hν) 1

@[to_additive] lemma measure_eq_tsum' (h : is_fundamental_domain G s μ) (t : set α) :
  μ t = ∑' g : G, μ (t ∩ g • s) :=
h.measure_eq_tsum_of_ac absolutely_continuous.rfl t

@[to_additive] lemma measure_eq_tsum (h : is_fundamental_domain G s μ) (t : set α) :
  μ t = ∑' g : G, μ (g • t ∩ s) :=
by simpa only [set_lintegral_one] using h.set_lintegral_eq_tsum (λ _, 1) t

@[to_additive] protected lemma set_lintegral_eq (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) (f : α → ℝ≥0∞) (hf : ∀ (g : G) x, f (g • x) = f x) :
  ∫⁻ x in s, f x ∂μ = ∫⁻ x in t, f x ∂μ :=
calc ∫⁻ x in s, f x ∂μ = ∑' g : G, ∫⁻ x in s ∩ g • t, f x ∂μ :
  ht.set_lintegral_eq_tsum' _ _
... = ∑' g : G, ∫⁻ x in g • t ∩ s, f (g⁻¹ • x) ∂μ :
  by simp only [hf, inter_comm]
... = ∫⁻ x in t, f x ∂μ :
  (hs.set_lintegral_eq_tsum _ _).symm

/-- If `s` and `t` are two fundamental domains of the same action, then their measures are equal. -/
@[to_additive] protected lemma measure_eq (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) : μ s = μ t :=
by simpa only [set_lintegral_one] using hs.set_lintegral_eq ht (λ _, 1) (λ _ _, rfl)

@[to_additive] protected lemma ae_measurable_on_iff {β : Type*} [measurable_space β]
  (hs : is_fundamental_domain G s μ) (ht : is_fundamental_domain G t μ) {f : α → β}
  (hf : ∀ (g : G) x, f (g • x) = f x) :
  ae_measurable f (μ.restrict s) ↔ ae_measurable f (μ.restrict t) :=
calc ae_measurable f (μ.restrict s)
    ↔ ae_measurable f (measure.sum $ λ g : G, (μ.restrict (g • t ∩ s))) :
  by simp only [← restrict_restrict (ht.measurable_set_smul _),
    ht.sum_restrict_of_ac restrict_le_self.absolutely_continuous]
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g • (g⁻¹ • s ∩ t))) :
  by simp only [smul_set_inter, inter_comm, smul_inv_smul, ae_measurable_sum_measure_iff]
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g⁻¹ • (g⁻¹⁻¹ • s ∩ t))) : inv_surjective.forall
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g⁻¹ • (g • s ∩ t))) : by simp only [inv_inv]
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g • s ∩ t)) :
  begin
    refine forall_congr (λ g, _),
    have he : measurable_embedding ((•) g⁻¹ : α → α) := measurable_embedding_const_smul _,
    rw [← image_smul,
      ← ((measure_preserving_smul g⁻¹ μ).restrict_image_emb he _).ae_measurable_comp_iff he],
    simp only [(∘), hf]
  end
... ↔ ae_measurable f (μ.restrict t) :
  by simp only [← ae_measurable_sum_measure_iff, ← restrict_restrict (hs.measurable_set_smul _),
    hs.sum_restrict_of_ac restrict_le_self.absolutely_continuous]

@[to_additive] protected lemma has_finite_integral_on_iff (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) {f : α → E} (hf : ∀ (g : G) x, f (g • x) = f x) :
  has_finite_integral f (μ.restrict s) ↔ has_finite_integral f (μ.restrict t) :=
begin
  dunfold has_finite_integral,
  rw hs.set_lintegral_eq ht,
  intros g x, rw hf
end

variables [measurable_space E]

@[to_additive] protected lemma integrable_on_iff (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) {f : α → E} (hf : ∀ (g : G) x, f (g • x) = f x) :
  integrable_on f s μ ↔ integrable_on f t μ :=
and_congr (hs.ae_measurable_on_iff ht hf) (hs.has_finite_integral_on_iff ht hf)

variables [normed_space ℝ E] [borel_space E] [complete_space E] [second_countable_topology E]

@[to_additive] protected lemma set_integral_eq (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) {f : α → E} (hf : ∀ (g : G) x, f (g • x) = f x) :
  ∫ x in s, f x ∂μ = ∫ x in t, f x ∂μ :=
begin
  by_cases hfs : integrable_on f s μ,
  { have hft : integrable_on f t μ, by rwa ht.integrable_on_iff hs hf,
    have hac : ∀ {u}, μ.restrict u ≪ μ := λ u, restrict_le_self.absolutely_continuous,
    calc ∫ x in s, f x ∂μ = ∫ x in ⋃ g : G, g • t, f x ∂(μ.restrict s) :
      by rw [restrict_congr_set (hac ht.Union_smul_ae_eq), restrict_univ]
    ... = ∑' g : G, ∫ x in g • t, f x ∂(μ.restrict s) :
      integral_Union_of_null_inter (λ g, (ht.measurable_set_smul g).null_measurable_set)
        (ht.pairwise_ae_disjoint.mono $ λ i j h, hac h) hfs.integrable.integrable_on
    ... = ∑' g : G, ∫ x in s ∩ g • t, f x ∂μ :
      by simp only [restrict_restrict (ht.measurable_set_smul _), inter_comm]
    ... = ∑' g : G, ∫ x in s ∩ g⁻¹ • t, f x ∂μ : ((equiv.inv G).tsum_eq _).symm
    ... = ∑' g : G, ∫ x in g⁻¹ • (g • s ∩ t), f x ∂μ :
      by simp only [smul_set_inter, inv_smul_smul]
    ... = ∑' g : G, ∫ x in g • s ∩ t, f (g⁻¹ • x) ∂μ :
      tsum_congr $ λ g, (measure_preserving_smul g⁻¹ μ).set_integral_image_emb
        (measurable_embedding_const_smul _) _ _
    ... = ∑' g : G, ∫ x in g • s, f x ∂(μ.restrict t) :
      by simp only [hf, restrict_restrict (hs.measurable_set_smul _)]
    ... = ∫ x in ⋃ g : G, g • s, f x ∂(μ.restrict t) :
      (integral_Union_of_null_inter (λ g, (hs.measurable_set_smul g).null_measurable_set)
        (hs.pairwise_ae_disjoint.mono $ λ i j h, hac h) hft.integrable.integrable_on).symm
    ... = ∫ x in t, f x ∂μ :
      by rw [restrict_congr_set (hac hs.Union_smul_ae_eq), restrict_univ] },
  { rw [integral_undef hfs, integral_undef],
    rwa [hs.integrable_on_iff ht hf] at hfs }
end

end is_fundamental_domain

end measure_theory


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

import algebra.associated
import algebra.big_operators.basic
import data.finsupp.basic

/-!
# Products of associated, prime, and irreducible elements.

This file contains some theorems relating definitions in `algebra.associated`
and products of multisets, finsets, and finsupps.

-/

variables {α β γ δ : Type*}

-- the same local notation used in `algebra.associated`
local infix ` ~ᵤ ` : 50 := associated
open_locale big_operators

namespace prime

variables [comm_monoid_with_zero α] {p : α} (hp : prime p)

lemma exists_mem_multiset_dvd {s : multiset α} :
  p ∣ s.prod → ∃ a ∈ s, p ∣ a :=
multiset.induction_on s (λ h, (hp.not_dvd_one h).elim) $
λ a s ih h,
  have p ∣ a * s.prod, by simpa using h,
  match hp.dvd_or_dvd this with
  | or.inl h := ⟨a, multiset.mem_cons_self a s, h⟩
  | or.inr h := let ⟨a, has, h⟩ := ih h in ⟨a, multiset.mem_cons_of_mem has, h⟩
  end

include hp

lemma exists_mem_multiset_map_dvd {s : multiset β} {f : β → α} :
  p ∣ (s.map f).prod → ∃ a ∈ s, p ∣ f a :=
λ h, by simpa only [exists_prop, multiset.mem_map, exists_exists_and_eq_and]
  using hp.exists_mem_multiset_dvd h

lemma exists_mem_finset_dvd {s : finset β} {f : β → α} :
  p ∣ s.prod f → ∃ i ∈ s, p ∣ f i :=
hp.exists_mem_multiset_map_dvd

end prime

lemma exists_associated_mem_of_dvd_prod [cancel_comm_monoid_with_zero α] {p : α}
  (hp : prime p) {s : multiset α} : (∀ r ∈ s, prime r) → p ∣ s.prod → ∃ q ∈ s, p ~ᵤ q :=
multiset.induction_on s (by simp [mt is_unit_iff_dvd_one.2 hp.not_unit])
  (λ a s ih hs hps, begin
    rw [multiset.prod_cons] at hps,
    cases hp.dvd_or_dvd hps with h h,
    { use [a, by simp],
      cases h with u hu,
      cases (((hs a (multiset.mem_cons.2 (or.inl rfl))).irreducible)
        .is_unit_or_is_unit hu).resolve_left hp.not_unit with v hv,
      exact ⟨v, by simp [hu, hv]⟩ },
    { rcases ih (λ r hr, hs _ (multiset.mem_cons.2 (or.inr hr))) h with ⟨q, hq₁, hq₂⟩,
      exact ⟨q, multiset.mem_cons.2 (or.inr hq₁), hq₂⟩ }
  end)

namespace associates

section comm_monoid

variables [comm_monoid α]

theorem prod_mk {p : multiset α} : (p.map associates.mk).prod = associates.mk p.prod :=
multiset.induction_on p (by simp; refl) $ assume a s ih, by simp [ih]; refl

theorem rel_associated_iff_map_eq_map {p q : multiset α} :
  multiset.rel associated p q ↔ p.map associates.mk = q.map associates.mk :=
by { rw [← multiset.rel_eq, multiset.rel_map], simp only [mk_eq_mk_iff_associated] }

theorem prod_eq_one_iff {p : multiset (associates α)} :
  p.prod = 1 ↔ (∀a ∈ p, (a:associates α) = 1) :=
multiset.induction_on p
  (by simp)
  (by simp [mul_eq_one_iff, or_imp_distrib, forall_and_distrib] {contextual := tt})

theorem prod_le_prod {p q : multiset (associates α)} (h : p ≤ q) : p.prod ≤ q.prod :=
begin
  haveI := classical.dec_eq (associates α),
  haveI := classical.dec_eq α,
  suffices : p.prod ≤ (p + (q - p)).prod, { rwa [add_tsub_cancel_of_le h] at this },
  suffices : p.prod * 1 ≤ p.prod * (q - p).prod, { simpa },
  exact mul_mono (le_refl p.prod) one_le
end

end comm_monoid

section cancel_comm_monoid_with_zero

variables [cancel_comm_monoid_with_zero α]

lemma exists_mem_multiset_le_of_prime {s : multiset (associates α)} {p : associates α}
  (hp : prime p) :
  p ≤ s.prod → ∃a∈s, p ≤ a :=
multiset.induction_on s (assume ⟨d, eq⟩, (hp.ne_one (mul_eq_one_iff.1 eq.symm).1).elim) $
assume a s ih h,
  have p ≤ a * s.prod, by simpa using h,
  match prime.le_or_le hp this with
  | or.inl h := ⟨a, multiset.mem_cons_self a s, h⟩
  | or.inr h := let ⟨a, has, h⟩ := ih h in ⟨a, multiset.mem_cons_of_mem has, h⟩
  end

end cancel_comm_monoid_with_zero

end associates

namespace multiset

lemma prod_ne_zero_of_prime [cancel_comm_monoid_with_zero α] [nontrivial α]
 (s : multiset α) (h : ∀ x ∈ s, prime x) : s.prod ≠ 0 :=
multiset.prod_ne_zero (λ h0, prime.ne_zero (h 0 h0) rfl)

end multiset

open finset finsupp

section comm_monoid_with_zero

variables {M : Type*} [comm_monoid_with_zero M]

lemma prime.dvd_finset_prod_iff {S : finset α} {p : M} (pp : prime p) (g : α → M) :
  p ∣ S.prod g ↔ ∃ a ∈ S, p ∣ g a :=
⟨pp.exists_mem_finset_dvd, λ ⟨a, ha1, ha2⟩, dvd_trans ha2 (dvd_prod_of_mem g ha1)⟩

lemma prime.dvd_finsupp_prod_iff  {f: α →₀ M} {g : α → M → ℕ} {p : ℕ} (pp : prime p) :
  p ∣ f.prod g ↔ ∃ a ∈ f.support, p ∣ g a (f a) :=
prime.dvd_finset_prod_iff pp _

end comm_monoid_with_zero


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Algdata.Init.Sigma
import Algdata.Data.List.Ascending

universe u v

/-!
  List of key-value pairs with values dependent on keys
  The elements are stored as the dependent pair `Sigma β` and sorted so that they form a chain of the given relation.
  Hence, it is implicitly assumed that the paramter `r : α → α → Prop` is an instance of `StrictLinearOrder` class defined in `Init.Order` in this library.
-/
structure KVChain {α : Type u} (r : α → α → Prop) (β : α → Type v) : Type (max u v) where
  toList : List (Sigma β)
  ascend : toList.Ascending (Sigma.relOnFst r)

attribute [unbox] KVChain
attribute [inline,reducible] KVChain.toList

namespace KVChain

variable {α : Type u} {r : α → α → Prop} {β : α → Type v}

@[reducible]
def boundLeft (a : α) (xs : KVChain r β) : Prop :=
  xs.toList.predHead (r a ∘ Sigma.fst)

@[reducible]
def boundRight (a : α) (xs : KVChain r β) : Prop :=
  xs.toList.predHead (flip r a ∘ Sigma.fst)

@[match_pattern, inline, reducible]
protected
def nil : KVChain r β :=
  {toList := [], ascend := List.Ascending.nil}

@[match_pattern, inline, reducible]
protected
def cons (a : α) (b : β a) (tail : KVChain r β) : tail.boundLeft a → KVChain r β :=
  λ hatail =>
    {toList := ⟨a,b⟩::tail.toList, ascend := tail.ascend.cons_of_head_tail hatail}

@[inline, reducible]
protected
def singleton (a : α) (b : β a) : KVChain r β := {
  toList := [⟨a,b⟩]
  ascend := List.Ascending.singleton _
}

def find? [DecidableEq α] (xs : KVChain r β) (a : α) : Option (β a) :=
  let rec loop : List (Sigma β) → Option (β a)
  | [] => none
  | (x::xs) => if h : (x.1=a) then some (h ▸ x.2) else loop xs
  loop xs.toList

@[inline, reducible]
def drop : Nat → KVChain r β → KVChain r β
| 0, x => x
| Nat.succ _, mk [] _ => KVChain.nil
| Nat.succ n, mk (_::as) ascend => KVChain.drop n ⟨as, ascend.tail⟩

@[inline, reducible]
def reverse : KVChain r β → KVChain (flip r) β
| mk toList ascend => {toList:=toList.reverse, ascend:=ascend.reverse}

--- `map` on key-value pairs with order-preserving operation on keys
--- @remark We do not provide `map` operation with non-order-preserving functions. Just use `List.map` together with `KVChain.fromList` defined in `Data.KVChain.MergeWith` module.
def mapKV {α₁ : Type _} {r₁ : α₁ → α₁ → Prop} {β₁ : α₁ → Type _} (f : α → α₁) (g : (a : α) → β a → β₁ (f a)) (f_rel : ∀ a b, r a b → r₁ (f a) (f b)) : KVChain r β → KVChain r₁ β₁
| mk toList ascend => {
  toList := toList.map (λ x => ⟨f x.1, g x.1 x.2⟩)
  ascend := ascend.map (Sigma.relOnFst r₁) (λ x => ⟨f x.1, g x.1 x.2⟩) $
    λ x y => f_rel x.1 y.1
}

def filterMapKV.{u₁, v₁} [Trans r r r] {α₁ : Type u₁} {r₁ : α₁ → α₁ → Prop} {β₁ : α₁ → Type v₁} (f : α → α₁) (g : (a : α) → β a → Option (β₁ (f a))) (f_rel : ∀ a b, r a b → r₁ (f a) (f b)) : KVChain r β → KVChain r₁ β₁
| mk toList ascend => {
  toList := toList.filterMap (λ x => match g x.1 x.2 with | none => none | some bg => some ⟨f x.1, bg⟩)
  ascend := by
    apply ascend.filterMap (Sigma.relOnFst r₁)
    intro x y hxy
    cases g x.1 x.2 <;> cases g y.1 y.2
      <;> dsimp [Functor.map, Option.bind, Option.map]
      <;> intro b₁ b₂ h₁ h₂
      <;> try {cases h₁} <;> try {cases h₂}
    cases Option.some.inj h₁; cases Option.some.inj h₂
    exact f_rel _ _ hxy
}

--- `map` on the same keys
def mapVal {γ : α → Type _} (f : (a : α) → β a → γ a) : KVChain r β → KVChain r γ :=
  mapKV id f (λ _ _ => id)

@[inline]
def foldl {γ : Type _} (f : γ → (a : α) → β a → γ) (init : γ) (xs : KVChain r β) : γ :=
  xs.toList.foldl (λ c x => f c x.1 x.2) init

@[reducible]
def hingeable (xs : KVChain (flip r) β) (ys : KVChain r β) : Prop :=
  xs.toList.relHead (Sigma.relOnFst r) ys.toList

--- `(reverseAppend xs ys).toList = xs.toList.reverse ++ ys.toList`
def hinge (xs : KVChain (flip r) β) (ys : KVChain r β) : xs.hingeable ys → KVChain r β :=
  λ hhinge => {
    toList := List.reverseAux xs.toList ys.toList
    ascend := List.Ascending.reverseAux hhinge xs.ascend ys.ascend
  }

@[inline, reducible, elab_as_elim]
def recOnList
  {motive : KVChain r β → Sort _}
  (nil : motive KVChain.nil)
  (cons : (a : α) → (b : β a) → (xs : KVChain r β) → (haxs : xs.boundLeft a) → motive xs → motive (xs.cons a b haxs))
  (xs : KVChain r β)
  : motive xs :=
  let rec loop : (as : List (Sigma β)) → (ascend : as.Ascending (Sigma.relOnFst r)) → motive ⟨as, ascend⟩
  | [], _ => nil
  | (x::xs), ascend =>
    cons x.1 x.2 ⟨xs, ascend.tail⟩ ascend.head $
      loop xs ascend.tail
  loop xs.toList xs.ascend

@[inline, reducible, elab_as_elim]
def recOnListOn
  {motive : KVChain r β → Sort _}
  (xs : KVChain r β)
  (nil : motive KVChain.nil)
  (cons : (a : α) → (b : β a) → (xs : KVChain r β) → (haxs : xs.boundLeft a) → motive xs → motive (xs.cons a b haxs))
  : motive xs :=
  recOnList nil cons xs

theorem eq_of_toList_eq {x y : KVChain r β} : x.toList = y.toList → x = y :=
  match x, y with
  | mk xs xascend, mk ys _ =>
    λ h => by cases h; rw [proofIrrel xascend _]

@[simp]
theorem toList_nil : KVChain.nil.toList (r:=r) (β:=β) = [] :=
  rfl

@[simp]
theorem toList_cons {a : α} (b : β a) {xs : KVChain r β} {haxs : xs.boundLeft a} : (xs.cons a b haxs).toList = ⟨a,b⟩ :: xs.toList :=
  rfl

@[simp]
theorem boundLeft_descend {xs : KVChain r β} {a a₁ : α} : (∀ a', r a₁ a' → r a a') → xs.boundLeft a₁ → xs.boundLeft a :=
  λ haa₁ => List.predHead_of_predHead (λ _=> haa₁ _)

@[simp]
theorem cons_hingeable {a : α} {b : β a} {xs : KVChain (flip r) β} {haxs : xs.boundLeft a} {ys : KVChain r β} : (xs.cons a b haxs).hingeable ys = ys.boundLeft a := by
  unfold hingeable
  rw [List.relHead_cons_left]
  rfl

@[simp]
theorem hingeable_cons {xs : KVChain (flip r) β} {a : α} {b : β a} {ys : KVChain r β} {hay : ys.boundLeft a} : xs.hingeable (ys.cons a b hay) = xs.boundLeft a := by
  unfold hingeable
  rw [List.relHead_cons_right]
  rfl

@[simp]
theorem cons_hingeable_cons {a₁ : α} {b₁ : β a₁} {xs : KVChain (flip r) β} {ha₁xs: xs.boundLeft a₁} {a₂ : α} {b₂ : β a₂} {ys : KVChain r β} {ha₂ys : ys.boundLeft a₂} : (xs.cons a₁ b₁ ha₁xs).hingeable (ys.cons a₂ b₂ ha₂ys) = r a₁ a₂ := rfl

@[simp]
theorem hingeable_skip_right [Trans r r r] {xs : KVChain (flip r) β} {a : α} {b : β a} {ys : KVChain r β} {hays : ys.boundLeft a} : xs.hingeable (ys.cons a b hays) → xs.hingeable ys :=
  xs.recOnListOn
    id
    (λ a₁ _ _ _ _ => by
      rw [cons_hingeable, cons_hingeable]
      dsimp [boundLeft, List.predHead]
      dsimp [boundLeft, List.predHead] at hays
      cases hys : ys.toList
      case nil => intros; exact True.intro
      case cons => intro h; rw [hys] at hays; exact trans (t:=r) h hays
    )

@[simp]
theorem toList_hinge_eq_reverseAux {xs : KVChain (flip r) β} {ys : KVChain r β} {hxy : xs.hingeable ys} : (hinge xs ys hxy).toList = List.reverseAux xs.toList ys.toList := rfl

instance instCoeKVChainList : Coe (KVChain r β) (List (Sigma β)) :=
  Coe.mk KVChain.toList

instance instReprKVChain [Repr α] [(a : α) → Repr (β a)] : Repr (KVChain r β) where
  reprPrec xs prec := reprPrec xs.toList prec

instance instInhabitedKVChain : Inhabited (KVChain r β) :=
  Inhabited.mk KVChain.nil

protected
instance hasDecidableEq [DecidableEq α] [(a : α) → DecidableEq (β a)] : DecidableEq (KVChain r β) :=
  λ xs ys =>
    if h : xs.toList = ys.toList then
      isTrue $ eq_of_toList_eq h
    else
      isFalse $ λ hcontra => h (congrArg KVChain.toList hcontra)

--- Lexicographical order with respect to both keys and values
protected
def kvlex (s : (a : α) → β a → β a → Prop) : KVChain r β → KVChain r β → Prop :=
  InvImage (List.lex $ Sigma.lex r s) KVChain.toList

--- Lexicographical order with the opposite order on keys; which is equivalent to the lex-order considered with a virtual entry `(a,-∞)` for each absent key `a : α`.
protected
def rklex (s : (a : α) → β a → β a → Prop) : KVChain r β → KVChain r β → Prop :=
  InvImage (List.lex $ Sigma.lex (flip r) s) KVChain.toList

section lex

variable {s : (a : α) → β a → β a → Prop}

instance [Trans r r r] [(a : α) → Trans (s a) (s a) (s a)] : Trans (KVChain.kvlex (r:=r) s) (KVChain.kvlex s) (KVChain.kvlex s) :=
  instTransInvImage _ KVChain.toList

instance [Irreflective r] [(a : α) → Irreflective (s a)] : Irreflective (KVChain.kvlex (r:=r) s) :=
  instIrreflectiveInvImage _ KVChain.toList

instance [Asymmetry r] [(a : α) → Asymmetry (s a)] : Asymmetry (KVChain.kvlex (r:=r) s) :=
  instAsymmetryInvImage _ KVChain.toList

instance [Trichotomous r] [(a : α) → Trichotomous (s a)] : Trichotomous (KVChain.kvlex (r:=r) s) :=
  mkInstTrichotomousInvImage _ KVChain.toList $ @KVChain.eq_of_toList_eq _ _ _

instance [DecidableEq α] [DecidableRel r] [(a : α) → DecidableEq (β a)] [(a : α) → DecidableRel (s a)] : DecidableRel (KVChain.kvlex (r:=r) s) :=
  inferInstanceAs (DecidableRel (InvImage _ KVChain.toList))

protected
theorem kvlex.nil {a : α} {b : β a} {xs : KVChain r β} {haxs : xs.boundLeft a} : KVChain.kvlex s KVChain.nil (xs.cons a b haxs) :=
  List.lex.nil _ _

protected
theorem kvlex.headFst {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} {xs ys : KVChain r β} {haxs : xs.boundLeft a₁} {hays : ys.boundLeft a₂} : r a₁ a₂ → KVChain.kvlex s (xs.cons a₁ b₁ haxs) (ys.cons a₂ b₂ hays) :=
  λ h => List.lex.head (Sigma.lex.fst h)

protected
theorem kvlex.headSnd {a : α} {b₁ b₂ : β a} {xs ys : KVChain r β} {haxs : xs.boundLeft a} {hays : ys.boundLeft a} : s a b₁ b₂ → KVChain.kvlex s (xs.cons a b₁ haxs) (ys.cons a b₂ hays) :=
  λ h => List.lex.head (Sigma.lex.snd h)

protected
theorem kvlex.tail {a : α} {b : β a} {xs ys : KVChain r β} {haxs : xs.boundLeft a} {hays : ys.boundLeft a} : KVChain.kvlex s xs ys → KVChain.kvlex s (xs.cons a b haxs) (ys.cons a b hays) :=
  List.lex.tail

instance [Trans r r r] [(a : α) → Trans (s a) (s a) (s a)] : Trans (KVChain.rklex (r:=r) s) (KVChain.rklex s) (KVChain.rklex s) :=
  instTransInvImage _ KVChain.toList

instance [Irreflective r] [(a : α) → Irreflective (s a)] : Irreflective (KVChain.rklex (r:=r) s) :=
  instIrreflectiveInvImage _ KVChain.toList

instance [Asymmetry r] [(a : α) → Asymmetry (s a)] : Asymmetry (KVChain.rklex (r:=r) s) :=
  instAsymmetryInvImage _ KVChain.toList

instance [Trichotomous r] [(a : α) → Trichotomous (s a)] : Trichotomous (KVChain.rklex (r:=r) s) :=
  mkInstTrichotomousInvImage _ KVChain.toList $ @KVChain.eq_of_toList_eq _ _ _

instance [DecidableEq α] [DecidableRel r] [(a : α) → DecidableEq (β a)] [(a : α) → DecidableRel (s a)] : DecidableRel (KVChain.rklex (r:=r) s) :=
  inferInstanceAs (DecidableRel (InvImage _ KVChain.toList))

protected
theorem rklex.nil {a : α} {b : β a} {xs : KVChain r β} {haxs : xs.boundLeft a} : KVChain.rklex s KVChain.nil (xs.cons a b haxs) :=
  List.lex.nil _ _

protected
theorem rklex.headFst {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} {xs ys : KVChain r β} {haxs : xs.boundLeft a₁} {hays : ys.boundLeft a₂} : r a₂ a₁ → KVChain.rklex s (xs.cons a₁ b₁ haxs) (ys.cons a₂ b₂ hays) :=
  λ h => List.lex.head (Sigma.lex.fst h)

protected
theorem rklex.headSnd {a : α} {b₁ b₂ : β a} {xs ys : KVChain r β} {haxs : xs.boundLeft a} {hays : ys.boundLeft a} : s a b₁ b₂ → KVChain.rklex s (xs.cons a b₁ haxs) (ys.cons a b₂ hays) :=
  λ h => List.lex.head (Sigma.lex.snd h)

protected
theorem rklex.tail {a : α} {b : β a} {xs ys : KVChain r β} {haxs : xs.boundLeft a} {hays : ys.boundLeft a} : KVChain.rklex s xs ys → KVChain.rklex s (xs.cons a b haxs) (ys.cons a b hays) :=
  List.lex.tail

theorem rklex_not_nil_right {xs : KVChain r β} : ¬ KVChain.rklex s xs KVChain.nil :=
  λ hcontra => by cases xs; cases hcontra

@[elab_as_elim]
protected
theorem rklex.rec
  {motive : (xs ys : KVChain r β) → KVChain.rklex s xs ys → Prop}
  (nil : (a : α) → (b : β a) → (xs : KVChain r β) → (haxs : xs.boundLeft a) → motive KVChain.nil (xs.cons a b haxs) KVChain.rklex.nil)
  (headFst : (a₁ a₂ : α) → (b₁ : β a₁) → (b₂ : β a₂) → (xs ys : KVChain r β) → (haxs : xs.boundLeft a₁) → (hays : ys.boundLeft a₂) → (ha₂a₁ : r a₂ a₁) → motive (xs.cons a₁ b₁ haxs) (ys.cons a₂ b₂ hays) (KVChain.rklex.headFst ha₂a₁))
  (headSnd : (a : α) → (b₁ b₂ : β a) → (xs ys : KVChain r β) → (haxs : xs.boundLeft a) → (hays : ys.boundLeft a) → (hb₁b₂ : s a b₁ b₂) → motive (xs.cons a b₁ haxs) (ys.cons a b₂ hays) (KVChain.rklex.headSnd hb₁b₂))
  (tail : (a : α) → (b : β a) → (xs ys : KVChain r β) → (haxs : xs.boundLeft a) → (hays : ys.boundLeft a) → (htail : KVChain.rklex s xs ys) → motive xs ys htail → motive (xs.cons a b haxs) (ys.cons a b hays) (KVChain.rklex.tail htail)) :
  ∀ {xs ys : KVChain r β} (h : KVChain.rklex s xs ys), motive xs ys h :=
  λ {xs ys} =>
    ys.recOnListOn
      (λ _ h => absurd h rklex_not_nil_right)
      (λ a₂ b₂ ys hays h_ind_ys xs =>
        xs.recOnListOn
          (λ _ => nil _ _ _ _)
          (λ a₁ b₁ xs haxs _ => by
            intro h
            dsimp [KVChain.rklex, InvImage] at h
            cases h
            case head hhead =>
              cases hhead
              case fst hheadFst => exact headFst _ _ _ _ _ _ _ _ hheadFst
              case snd hheadSnd => exact headSnd _ _ _ _ _ _ _ hheadSnd
            case tail htail =>
              have := h_ind_ys xs htail
              exact tail _ _ _ _ _ _ htail this
          )
      )
      xs

@[elab_as_elim]
protected
theorem rklex.recOn
  {motive : (xs ys : KVChain r β) → KVChain.rklex s xs ys → Prop}
  {xs ys : KVChain r β} (h : KVChain.rklex s xs ys)
  (nil : (a : α) → (b : β a) → (xs : KVChain r β) → (haxs : xs.boundLeft a) → motive KVChain.nil (xs.cons a b haxs) KVChain.rklex.nil)
  (headFst : (a₁ a₂ : α) → (b₁ : β a₁) → (b₂ : β a₂) → (xs ys : KVChain r β) → (haxs : xs.boundLeft a₁) → (hays : ys.boundLeft a₂) → (ha₂a₁ : r a₂ a₁) → motive (xs.cons a₁ b₁ haxs) (ys.cons a₂ b₂ hays) (KVChain.rklex.headFst ha₂a₁))
  (headSnd : (a : α) → (b₁ b₂ : β a) → (xs ys : KVChain r β) → (haxs : xs.boundLeft a) → (hays : ys.boundLeft a) → (hb₁b₂ : s a b₁ b₂) → motive (xs.cons a b₁ haxs) (ys.cons a b₂ hays) (KVChain.rklex.headSnd hb₁b₂))
  (tail : (a : α) → (b : β a) → (xs ys : KVChain r β) → (haxs : xs.boundLeft a) → (hays : ys.boundLeft a) → (htail : KVChain.rklex s xs ys) → motive xs ys htail → motive (xs.cons a b haxs) (ys.cons a b hays) (KVChain.rklex.tail htail)) :
  motive xs ys h :=
  KVChain.rklex.rec nil headFst headSnd tail h

end lex

end KVChain