--  An abstract formalization of "isomorphism is equality up to relabeling"
-- -------------------------------------------------------------------------
--
-- See `README.md` for more info.
--
-- This file contains some definitions related to truncation and quotients.

import Structure.Basic

open Morphisms
open HasStructure
open Structure
open StructureFunctor

set_option autoBoundImplicitLocal false

-- A functor between two structures induces functors between their setoid and skeleton structures. More
-- specifically, we have the following commutative diagram (modulo equivalence defined on functors), where
-- `S_≈` stands for `setoidStructure S` and `S/≃` stands for `skeletonStructure S`.
--
--    `S` ----> `S_≈` ---> `S/≃`
--     |          |          |
-- `F` |          |          |
--     v          v          v
--    `T` ----> `T_≈` ---> `T/≃`
--
-- The horizontal functors can be "philosophically" regarded as equivalences: Although they cannot be
-- proved to be equivalences, we can see that all structural properties have an analogue in the setoid
-- and skeleton structures. (Also, we can prove certain idempotence properties.)
--
-- This can be understood as the reason why isomorphism can generally be identified with equality: In all
-- operations that preserve structure, in theory we can take the quotient with respect to equivalence/
-- isomorphism and work on the quotient structures.

namespace Forgetfulness

section Setoid

-- TODO: Use `propFunctor` as in the past.
def makeToSetoidStructureFunctor {S T : Structure} (map : S → T) (mapEquiv : ∀ {a b : S}, a ≃ b → map a ≈ map b) :
  StructureFunctor S (setoidStructure T) :=
{ map     := map,
  functor := { mapEquiv  := mapEquiv,
               isFunctor := { respectsEquiv := λ _   => proofIrrel _ _,
                              respectsComp  := λ _ _ => proofIrrel _ _,
                              respectsId    := λ _   => proofIrrel _ _,
                              respectsInv   := λ _   => proofIrrel _ _ } } }

def makeToSetoidStructureFunctorEquiv' {S T : Structure} {F G : StructureFunctor S (setoidStructure T)} (ext : ∀ a, F a ≃ G a) :
  F ≃ G :=
{ ext := ext,
  nat := λ _ => proofIrrel _ _ }

def makeToSetoidStructureFunctorEquiv {S T : Structure} {F G : StructureFunctor S (setoidStructure T)} (ext : ∀ a, F a ≈ G a) :
  F ≃ G :=
makeToSetoidStructureFunctorEquiv' (λ a => let ⟨e⟩ := ext a; e)

def toSetoidFunctor (S : Structure) : StructureFunctor S (setoidStructure S) :=
makeToSetoidStructureFunctor id (structureSetoidEquiv S)

@[reducible] def SetoidStructureFunctor (S T : Structure) := StructureFunctor (setoidStructure S) (setoidStructure T)

namespace SetoidStructureFunctor

def makeSetoidStructureFunctor {S T : Structure} (map : S → T) (mapEquiv : ∀ {a b : S}, a ≈ b → map a ≈ map b) :
  SetoidStructureFunctor S T :=
makeToSetoidStructureFunctor map mapEquiv

def makeSetoidStructureFunctorInverse {S T : Structure} {F : SetoidStructureFunctor S T} {G : SetoidStructureFunctor T S}
                                      (leftInv : LeftInv F G) (rightInv : LeftInv G F) :
  IsInverse F G :=
{ leftInv  := leftInv,
  rightInv := rightInv,
  lrCompat := λ _ => proofIrrel _ _,
  rlCompat := λ _ => proofIrrel _ _ }

def setoidIdempotenceFunctor (S : Structure) : SetoidStructureFunctor (setoidStructure S) S :=
makeSetoidStructureFunctor id (λ ⟨e⟩ => e)

def setoidIdempotence (S : Structure) : setoidStructure (setoidStructure S) ≃ setoidStructure S :=
{ toFun  := setoidIdempotenceFunctor S,
  invFun := toSetoidFunctor (setoidStructure S),
  isInv  := makeSetoidStructureFunctorInverse (makeToSetoidStructureFunctorEquiv Setoid.refl)
                                              (makeToSetoidStructureFunctorEquiv Setoid.refl) }

def setoidFunctor {S T : Structure} (F : StructureFunctor S T) : SetoidStructureFunctor S T :=
makeSetoidStructureFunctor F.map (λ ⟨e⟩ => ⟨F.functor e⟩)

namespace setoidFunctor

theorem respectsEquivalence {S T : Structure} {F₁ F₂ : StructureFunctor S T} :
  F₁ ≃ F₂ → setoidFunctor F₁ ≃ setoidFunctor F₂ :=
λ e => makeToSetoidStructureFunctorEquiv (λ a : S => ⟨⟨e.ext a⟩⟩)

theorem respectsComp {S T U : Structure} (F : StructureFunctor S T) (G : StructureFunctor T U) :
  setoidFunctor (G ⊙ F) ≃ setoidFunctor G ⊙ setoidFunctor F :=
makeToSetoidStructureFunctorEquiv (λ a : S => ⟨⟨HasRefl.refl (G (F a))⟩⟩)

theorem respectsId (S : Structure) :
  setoidFunctor (@idFun S) ≃ @idFun (setoidStructure S) :=
makeToSetoidStructureFunctorEquiv (λ a : S => ⟨⟨HasRefl.refl a⟩⟩)

end setoidFunctor

def setoidSquare {S T : Structure} (F : StructureFunctor S T) :
  toSetoidFunctor T ⊙ F ≃ setoidFunctor F ⊙ toSetoidFunctor S :=
makeToSetoidStructureFunctorEquiv (λ a => Setoid.refl ((setoidFunctor F) a))

def setoidIdempotenceSquare {S T : Structure} (F : SetoidStructureFunctor S T) :
  F ⊙ setoidIdempotenceFunctor S ≃ setoidIdempotenceFunctor T ⊙ setoidFunctor F :=
sorry

def setoidFunctorStructure (S T : Structure) := functorStructure (setoidStructure S) (setoidStructure T)

theorem congr' {S T : Structure} {F₁ F₂ : SetoidStructureFunctor S T} {a b : S} :
  F₁ ≃ F₂ → a ≃ b → F₁ a ≃ F₂ b :=
λ η e => StructureFunctor.congr η ⟨e⟩

theorem congr {S T : Structure} {F₁ F₂ : SetoidStructureFunctor S T} {a b : S} :
  F₁ ≃ F₂ → a ≈ b → F₁ a ≈ F₂ b :=
λ η ⟨e⟩ => ⟨congr' η e⟩

end SetoidStructureFunctor

open SetoidStructureFunctor

@[reducible] def SetoidStructureEquiv (S T : Structure) := StructureEquiv (setoidStructure S) (setoidStructure T)

namespace SetoidStructureEquiv

def makeSetoidStructureEquivEquiv' {S T : Structure} {e₁ e₂ : SetoidStructureEquiv S T}
                                   (toFunEquiv : e₁.toFun ≃ e₂.toFun) (invFunEquiv : e₁.invFun ≃ e₂.invFun) :
  e₁ ≃ e₂ :=
{ toFunEquiv    := toFunEquiv,
  invFunEquiv   := invFunEquiv,
  leftInvEquiv  := λ _ => proofIrrel _ _,
  rightInvEquiv := λ _ => proofIrrel _ _ }

def makeSetoidStructureEquivEquiv {S T : Structure} {e₁ e₂ : SetoidStructureEquiv S T}
                                  (toFunEquiv : ∀ a, e₁.toFun a ≈ e₂.toFun a) (invFunEquiv : ∀ a, e₁.invFun a ≈ e₂.invFun a) :
  e₁ ≃ e₂ :=
makeSetoidStructureEquivEquiv' (makeToSetoidStructureFunctorEquiv toFunEquiv) (makeToSetoidStructureFunctorEquiv invFunEquiv)

-- We can convert any equivalence to one between setoid structures.

def toSetoidStructureEquiv {S T : Structure} (e : StructureEquiv S T) : SetoidStructureEquiv S T :=
{ toFun  := setoidFunctor e.toFun,
  invFun := setoidFunctor e.invFun,
  isInv  := makeSetoidStructureFunctorInverse (makeToSetoidStructureFunctorEquiv (λ a => ⟨⟨e.isInv.leftInv.ext  a⟩⟩))
                                              (makeToSetoidStructureFunctorEquiv (λ a => ⟨⟨e.isInv.rightInv.ext a⟩⟩)) }

namespace toSetoidStructureEquiv

theorem respectsEquiv {S T : Structure} {e₁ e₂ : StructureEquiv S T} :
  e₁ ≈ e₂ → toSetoidStructureEquiv e₁ ≈ toSetoidStructureEquiv e₂ :=
λ ⟨η⟩ => ⟨makeSetoidStructureEquivEquiv' (setoidFunctor.respectsEquivalence η.toFunEquiv) (setoidFunctor.respectsEquivalence η.invFunEquiv)⟩

theorem respectsComp {S T U : Structure} (e : S ≃ T) (f : T ≃ U) :
  toSetoidStructureEquiv (StructureEquiv.trans e f) ≈ StructureEquiv.trans (toSetoidStructureEquiv e) (toSetoidStructureEquiv f) :=
⟨makeSetoidStructureEquivEquiv' (setoidFunctor.respectsComp e.toFun f.toFun) (setoidFunctor.respectsComp f.invFun e.invFun)⟩

theorem respectsId (S : Structure) :
  toSetoidStructureEquiv (StructureEquiv.refl S) ≈ StructureEquiv.refl (setoidStructure S) :=
⟨makeSetoidStructureEquivEquiv' (setoidFunctor.respectsId S) (setoidFunctor.respectsId S)⟩

theorem respectsInv {S T : Structure} (e : S ≃ T) :
  toSetoidStructureEquiv (StructureEquiv.symm e) ≈ StructureEquiv.symm (toSetoidStructureEquiv e) :=
⟨makeSetoidStructureEquivEquiv' (HasRefl.refl (setoidFunctor e.invFun)) (HasRefl.refl (setoidFunctor e.toFun))⟩

def genFun : GeneralizedFunctor.Functor (S := universeStructure) (T := universeStructure) setoidStructure :=
{ mapEquiv  := toSetoidStructureEquiv,
  isFunctor := { respectsEquiv := respectsEquiv,
                 respectsComp  := respectsComp,
                 respectsId    := respectsId,
                 respectsInv   := respectsInv } }

end toSetoidStructureEquiv

end SetoidStructureEquiv

open SetoidStructureEquiv

-- An `InstanceEquiv` of a `SetoidStructureEquiv` is the same as a regular `InstanceEquiv` with `≃`
-- replaced by `≈`.

@[reducible] def SetoidInstanceEquiv {S T : Structure} (e : S ≃ T) (a : S) (b : T) : Prop :=
InstanceEquiv (toSetoidStructureEquiv e) a b

namespace SetoidInstanceEquiv

notation:25 a:26 " ≈[" e:0 "] " b:26 => SetoidInstanceEquiv e a b

theorem fromEquiv (S : Structure) {a b : S} : a ≈ b → a ≈[id_ S] b := id
theorem toEquiv   (S : Structure) {a b : S} : a ≈[id_ S] b → a ≈ b := id

theorem refl  (S     : Structure)                         (a : S)                 :
  a ≈[id_ S] a :=
fromEquiv S (Setoid.refl a)

theorem symm  {S T   : Structure} (e : S ≃ T)             (a : S) (b : T)         :
  a ≈[e] b → b ≈[e⁻¹] a :=
InstanceEquiv.symm (toSetoidStructureEquiv e) a b

theorem trans {S T U : Structure} (e : S ≃ T) (f : T ≃ U) (a : S) (b : T) (c : U) :
  a ≈[e] b → b ≈[f] c → a ≈[f • e] c :=
λ h i => let j : f.toFun (e.toFun a) ≈ c := InstanceEquiv.trans (toSetoidStructureEquiv e) (toSetoidStructureEquiv f) a b c h i;
         j

theorem setoidInstanceEquiv' {S T : Structure} (e : SetoidStructureEquiv S T) (a : S) (b : T) :
  a ≃[e] b ↔ e.toFun a ≈ b :=
⟨λ φ => ⟨φ⟩, λ ⟨φ⟩ => φ⟩

theorem setoidInstanceEquiv {S T : Structure} (e : S ≃ T) (a : S) (b : T) :
  a ≈[e] b ↔ e.toFun a ≈ b :=
Iff.rfl

theorem mapEquiv' {S T : Structure} {e₁ e₂ : SetoidStructureEquiv S T} (h : e₁ ≈ e₂) (a : S) (b : T) :
  a ≃[e₁] b → a ≃[e₂] b :=
let ⟨η⟩ := h;
InstanceEquiv.mapEquiv η a b

theorem mapEquiv {S T : Structure} {e₁ e₂ : S ≃ T} (h : e₁ ≈ e₂) (a : S) (b : T) :
  a ≈[e₁] b → a ≈[e₂] b :=
mapEquiv' (toSetoidStructureEquiv.respectsEquiv h) a b

end SetoidInstanceEquiv

end Setoid

open SetoidStructureFunctor

section Skeleton

def makeToSkeletonStructureFunctor {S T : Structure} (map : S → StructureQuotient T) (mapEquiv : ∀ {a b : S}, a ≃ b → map a = map b) :
  StructureFunctor S (skeletonStructure T) :=
{ map     := map,
  functor := { mapEquiv  := mapEquiv,
               isFunctor := propFunctor } }

def makeToSkeletonStructureFunctorEquiv' {S T : Structure} {F G : StructureFunctor S (skeletonStructure T)} (ext : ∀ a, F a ≃ G a) :
  F ≃ G :=
{ ext := ext,
  nat := λ _ => proofIrrel _ _ }

def makeToSkeletonStructureFunctorEquiv {S T : Structure} {F G : StructureFunctor S (skeletonStructure T)} (ext : ∀ a, F a = G a) :
  F ≃ G :=
makeToSkeletonStructureFunctorEquiv' ext

def setoidToSkeletonFunctor (S : Structure) : StructureFunctor (setoidStructure S) (skeletonStructure S) :=
makeToSkeletonStructureFunctor (λ a => Quotient.mk a) (λ e => Quotient.sound e)

def toSkeletonFunctor (S : Structure) : StructureFunctor S (skeletonStructure S) :=
setoidToSkeletonFunctor S ⊙ toSetoidFunctor S

@[reducible] def SkeletonStructureFunctor (S T : Structure) := StructureFunctor (skeletonStructure S) (skeletonStructure T)

def makeSkeletonStructureFunctor {S T : Structure} (map : StructureQuotient S → StructureQuotient T) :
  SkeletonStructureFunctor S T :=
makeToSkeletonStructureFunctor map (_root_.congrArg map)

def makeSkeletonStructureFunctorInverse {S T : Structure} {F : SkeletonStructureFunctor S T} {G : SkeletonStructureFunctor T S}
                                        (leftInv : LeftInv F G) (rightInv : LeftInv G F) :
  IsInverse F G :=
{ leftInv  := leftInv,
  rightInv := rightInv,
  lrCompat := λ _ => proofIrrel _ _,
  rlCompat := λ _ => proofIrrel _ _ }

def skeletonSetoidIdempotenceFunctor (S : Structure) : StructureFunctor (setoidStructure (skeletonStructure S)) (skeletonStructure S) :=
makeToSkeletonStructureFunctor id (λ ⟨e⟩ => e)

def skeletonSetoidIdempotence (S : Structure) : setoidStructure (skeletonStructure S) ≃ skeletonStructure S :=
{ toFun  := skeletonSetoidIdempotenceFunctor S,
  invFun := toSetoidFunctor (skeletonStructure S),
  isInv  := { leftInv  := makeToSetoidStructureFunctorEquiv Setoid.refl,
              rightInv := makeToSkeletonStructureFunctorEquiv Eq.refl,
              lrCompat := λ _ => proofIrrel _ _,
              rlCompat := λ _ => proofIrrel _ _ } }

def skeletonIdempotenceFunctor (S : Structure) : SkeletonStructureFunctor (skeletonStructure S) S :=
makeSkeletonStructureFunctor (Quotient.lift id (λ a b ⟨e⟩ => e))

def skeletonIdempotence (S : Structure) : skeletonStructure (skeletonStructure S) ≃ skeletonStructure S :=
{ toFun  := skeletonIdempotenceFunctor S,
  invFun := toSkeletonFunctor (skeletonStructure S),
  isInv  := makeSkeletonStructureFunctorInverse (makeToSkeletonStructureFunctorEquiv
                                                   (λ a => let r := Quotient.existsRep a;
                                                           let h₁ : (skeletonIdempotenceFunctor S) (Quotient.mk r.1) = r.1 := rfl;
                                                           let h₂ := congrArg Quotient.mk h₁;
                                                           Eq.subst (motive := λ b => Quotient.mk ((skeletonIdempotenceFunctor S) b) = b) r.2 h₂))
                                                (makeToSkeletonStructureFunctorEquiv Eq.refl) }

variable {S T : Structure}

def skeletonMap (F : SetoidStructureFunctor S T) : skeletonStructure S → skeletonStructure T :=
Quotient.lift (Quotient.mk ∘ F.map) (λ _ _ => Quotient.sound ∘ F.functor.mapEquiv)

def skeletonFromSetoidFunctor (F : SetoidStructureFunctor S T) : SkeletonStructureFunctor S T :=
makeSkeletonStructureFunctor (skeletonMap F)

def skeletonSetoidIdempotenceSquare {S T : Structure} (F : SkeletonStructureFunctor S T) :
  F ⊙ skeletonSetoidIdempotenceFunctor S ≃ skeletonSetoidIdempotenceFunctor T ⊙ setoidFunctor F :=
sorry

def skeletonFunctor (F : StructureFunctor S T) : SkeletonStructureFunctor S T :=
skeletonFromSetoidFunctor (setoidFunctor F)

def setoidToSkeletonSquare {S T : Structure} (F : StructureFunctor S T) :
  setoidToSkeletonFunctor T ⊙ setoidFunctor F ≃ skeletonFunctor F ⊙ setoidToSkeletonFunctor S :=
makeToSkeletonStructureFunctorEquiv (λ _ => rfl)

def skeletonSquare {S T : Structure} (F : StructureFunctor S T) :
  toSkeletonFunctor T ⊙ F ≃ skeletonFunctor F ⊙ toSkeletonFunctor S :=
makeToSkeletonStructureFunctorEquiv (λ _ => rfl)

def skeletonIdempotenceSquare {S T : Structure} (F : SkeletonStructureFunctor S T) :
  F ⊙ skeletonIdempotenceFunctor S ≃ skeletonIdempotenceFunctor T ⊙ skeletonFunctor F :=
sorry

end Skeleton

end Forgetfulness


import Qpf.Qpf.Multivariate.Basic
import Qpf.Qpf.Multivariate.ofPolynomial
import Qpf.PFunctor.Multivariate.Constructions.Basic
import Qpf.Macro.Tactic.FinDestr

namespace MvQPF
namespace Prod

open PFin2 (fz fs)

def P : MvPFunctor 2
  := .mk' [
    ![1, 1]
  ]

def P' : MvPFunctor 2
  := ⟨PFin2 1,
      fun | _ => ![PFin2 1, PFin2 1]
   ⟩

def Pfin : MvPFunctor 2
    := ⟨Fin 1,
        fun | _ => ![Fin 1, Fin 1]
    ⟩

-- `Nat` lives in `Type`, so both functors are fine
#check (P.Obj ![Nat, Nat] : Type)
#check (Pfin.Obj ![Nat, Nat] : Type)

-- Now assume some `X` that lives in a higher universe, say `Type 1`
variable (X : Type 1)

-- `P` is able to adjust
#check (P.Obj ![X, X] : Type 1)

-- `Pfin` is not
-- #check Pfin.Obj ![X, X]
-- application type mismatch
--   Vec.append1 Vec.nil X
-- argument
--   X
-- has type
--   Type 1 : Type 2
-- but is expected to have type
--   Type : Type 1

-- #check P.Obj ![Nat, X]

abbrev QpfProd' := P.Obj
abbrev QpfProd  := QpfProd'.curried

/--
  An uncurried version of the root `Prod`
-/
abbrev Prod' : TypeFun 2
  := @TypeFun.ofCurried 2 Prod

/--
  Constructor for `QpfProd'`
-/
def mk (a : Γ 1) (b : Γ 0) : QpfProd' Γ
  := ⟨
      fz,
      fun
      | 1, _ => a
      | 0, _ => b
  ⟩

def box : Prod' Γ → QpfProd' Γ
  | ⟨a, b⟩ => mk a b

def unbox : QpfProd' Γ → Prod' Γ
  | ⟨fz, f⟩ => (f 1 fz, f 0 fz)

theorem unbox_box_id (x : Prod' Γ) :
  unbox (box x) = x :=
by
  rfl

theorem box_unbox_id (x : QpfProd' Γ) :
  box (unbox x) = x :=
by
  rcases x with ⟨i, f⟩;
  fin_destr i;
  simp[box, unbox, mk];
  apply congrArg;
  fin_destr
  <;> rfl

instance : MvQPF Prod' := .ofPolynomial P box unbox box_unbox_id

end Prod

export Prod (QpfProd QpfProd')

end MvQPF


import Math.CategoryTheory.Site.Sieve

open SetTheory

namespace CategoryTheory

structure GrothendieckTopology (C : Category) where
  cov : (X : C.obj) → Set (Sieve X)
  max : ∀ X, Sieve.max X ∈ cov X
  pullback : ∀ {X Y S} (_ : S ∈ cov X) (f : C.hom Y X), S.pullback f ∈ cov Y
  other : ∀ {X R S} (_ : S ∈ cov X) (_ : ∀ {Y} {f : C.hom Y X} (_ : f ∈ S.maps), R.pullback f ∈ cov Y), R ∈ cov X

namespace GrothendieckTopology

theorem subsieve (J : GrothendieckTopology C) (hR : R ∈ J.cov X) {S : Sieve X} (hRS : R.subsieve S) : S ∈ J.cov X := by {
  apply J.other hR;
  intro _ f hf;
  have q : S.pullback f = Sieve.max _ := by {
    unfold Sieve.pullback, Sieve.max;
    congr;
    funext _;
    apply Set.ext;
    intro g;
    constructor;
    exact λ _ => trivial;
    exact λ _ => S.comp (hRS hf) g;
  };
  rw [q];
  exact J.max _;
}

theorem intersection (J : GrothendieckTopology C) (hR : R ∈ J.cov X) (hS : S ∈ J.cov X) : R.intersection S ∈ J.cov X := by {
  apply J.other hR;
  intro _ f hf;
  have q : (R.intersection S).pullback f = S.pullback f := by {
    unfold Sieve.pullback, Sieve.intersection;
    congr;
    funext Y;
    apply Set.ext;
    exact λ g => ⟨λ hg => hg.2, λ hg => ⟨R.comp hf _, hg⟩⟩;
  };
  rw [q];
  exact J.pullback hS _;
}

def smallest (C : Category) : GrothendieckTopology C := {
  cov := λ X S => S = Sieve.max X,
  max := λ X => by trivial,
  pullback := λ hS f => by simp [hS, Sieve.pullback, Sieve.max]; rfl,
  other := λ {X R S} hS h => by {
    have q : (C.id X) ∈ S.maps := by simp [hS, Sieve.max, Set.univ];
    specialize h q;
    simp at h;
    exact h;
  }
}

def biggest (C : Category) : GrothendieckTopology C := {
  cov := λ X _ => True,
  max := λ _ => by simp,
  pullback := by simp,
  other := by simp,
}

end GrothendieckTopology

end CategoryTheory


/-
Copyright (c) 2021 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky
-/
import data.multiset.sort
import data.fintype.list
import data.list.rotate

/-!
# Cycles of a list

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

Lists have an equivalence relation of whether they are rotational permutations of one another.
This relation is defined as `is_rotated`.

Based on this, we define the quotient of lists by the rotation relation, called `cycle`.

We also define a representation of concrete cycles, available when viewing them in a goal state or
via `#eval`, when over representatble types. For example, the cycle `(2 1 4 3)` will be shown
as `c[2, 1, 4, 3]`. Two equal cycles may be printed differently if their internal representation
is different.

-/

namespace list

variables {α : Type*} [decidable_eq α]

/-- Return the `z` such that `x :: z :: _` appears in `xs`, or `default` if there is no such `z`. -/
def next_or : Π (xs : list α) (x default : α), α
| [] x default := default
| [y] x default := default -- Handles the not-found and the wraparound case
| (y :: z :: xs) x default := if x = y then z else next_or (z :: xs) x default

@[simp] lemma next_or_nil (x d : α) : next_or [] x d = d := rfl

@[simp] lemma next_or_singleton (x y d : α) : next_or [y] x d = d := rfl

@[simp] lemma next_or_self_cons_cons (xs : list α) (x y d : α) :
  next_or (x :: y :: xs) x d = y :=
if_pos rfl

lemma next_or_cons_of_ne (xs : list α) (y x d : α) (h : x ≠ y) :
  next_or (y :: xs) x d = next_or xs x d :=
begin
  cases xs with z zs,
  { refl },
  { exact if_neg h }
end

/-- `next_or` does not depend on the default value, if the next value appears. -/
lemma next_or_eq_next_or_of_mem_of_ne (xs : list α) (x d d' : α)
  (x_mem : x ∈ xs) (x_ne : x ≠ xs.last (ne_nil_of_mem x_mem)) :
  next_or xs x d = next_or xs x d' :=
begin
  induction xs with y ys IH,
  { cases x_mem },
  cases ys with z zs,
  { simp at x_mem x_ne, contradiction },
  by_cases h : x = y,
  { rw [h, next_or_self_cons_cons, next_or_self_cons_cons] },
  { rw [next_or, next_or, IH];
      simpa [h] using x_mem }
end

lemma mem_of_next_or_ne {xs : list α} {x d : α} (h : next_or xs x d ≠ d) :
  x ∈ xs :=
begin
  induction xs with y ys IH,
  { simpa using h },
  cases ys with z zs,
  { simpa using h },
  { by_cases hx : x = y,
    { simp [hx] },
    { rw [next_or_cons_of_ne _ _ _ _ hx] at h,
      simpa [hx] using IH h } }
end

lemma next_or_concat {xs : list α} {x : α} (d : α) (h : x ∉ xs) :
  next_or (xs ++ [x]) x d = d :=
begin
  induction xs with z zs IH,
  { simp },
  { obtain ⟨hz, hzs⟩ := not_or_distrib.mp (mt (mem_cons_iff _ _ _).mp h),
    rw [cons_append, next_or_cons_of_ne _ _ _ _ hz, IH hzs] }
end

lemma next_or_mem {xs : list α} {x d : α} (hd : d ∈ xs) :
  next_or xs x d ∈ xs :=
begin
  revert hd,
  suffices : ∀ (xs' : list α) (h : ∀ x ∈ xs, x ∈ xs') (hd : d ∈ xs'), next_or xs x d ∈ xs',
  { exact this xs (λ _, id) },
  intros xs' hxs' hd,
  induction xs with y ys ih,
  { exact hd },
  cases ys with z zs,
  { exact hd },
  rw next_or,
  split_ifs with h,
  { exact hxs' _ (mem_cons_of_mem _ (mem_cons_self _ _)) },
  { exact ih (λ _ h, hxs' _ (mem_cons_of_mem _ h)) },
end

/--
Given an element `x : α` of `l : list α` such that `x ∈ l`, get the next
element of `l`. This works from head to tail, (including a check for last element)
so it will match on first hit, ignoring later duplicates.

For example:
 * `next [1, 2, 3] 2 _ = 3`
 * `next [1, 2, 3] 3 _ = 1`
 * `next [1, 2, 3, 2, 4] 2 _ = 3`
 * `next [1, 2, 3, 2] 2 _ = 3`
 * `next [1, 1, 2, 3, 2] 1 _ = 1`
-/
def next (l : list α) (x : α) (h : x ∈ l) : α :=
next_or l x (l.nth_le 0 (length_pos_of_mem h))

/--
Given an element `x : α` of `l : list α` such that `x ∈ l`, get the previous
element of `l`. This works from head to tail, (including a check for last element)
so it will match on first hit, ignoring later duplicates.

 * `prev [1, 2, 3] 2 _ = 1`
 * `prev [1, 2, 3] 1 _ = 3`
 * `prev [1, 2, 3, 2, 4] 2 _ = 1`
 * `prev [1, 2, 3, 4, 2] 2 _ = 1`
 * `prev [1, 1, 2] 1 _ = 2`
-/
def prev : Π (l : list α) (x : α) (h : x ∈ l), α
| []             _ h := by simpa using h
| [y]            _ _ := y
| (y :: z :: xs) x h := if hx : x = y then (last (z :: xs) (cons_ne_nil _ _)) else
  if x = z then y else prev (z :: xs) x (by simpa [hx] using h)

variables (l : list α) (x : α) (h : x ∈ l)

@[simp] lemma next_singleton (x y : α) (h : x ∈ [y]) :
  next [y] x h = y := rfl

@[simp] lemma prev_singleton (x y : α) (h : x ∈ [y]) :
  prev [y] x h = y := rfl

lemma next_cons_cons_eq' (y z : α) (h : x ∈ (y :: z :: l)) (hx : x = y) :
  next (y :: z :: l) x h = z :=
by rw [next, next_or, if_pos hx]

@[simp] lemma next_cons_cons_eq (z : α) (h : x ∈ (x :: z :: l)) :
  next (x :: z :: l) x h = z :=
next_cons_cons_eq' l x x z h rfl

lemma next_ne_head_ne_last (y : α) (h : x ∈ (y :: l)) (hy : x ≠ y)
  (hx : x ≠ last (y :: l) (cons_ne_nil _ _)) :
  next (y :: l) x h = next l x (by simpa [hy] using h) :=
begin
  rw [next, next, next_or_cons_of_ne _ _ _ _ hy, next_or_eq_next_or_of_mem_of_ne],
  { rwa last_cons at hx },
  { simpa [hy] using h }
end

lemma next_cons_concat (y : α) (hy : x ≠ y) (hx : x ∉ l)
  (h : x ∈ y :: l ++ [x] := mem_append_right _ (mem_singleton_self x)) :
  next (y :: l ++ [x]) x h = y :=
begin
  rw [next, next_or_concat],
  { refl },
  { simp [hy, hx] }
end

lemma next_last_cons (y : α) (h : x ∈ (y :: l)) (hy : x ≠ y)
  (hx : x = last (y :: l) (cons_ne_nil _ _)) (hl : nodup l) :
  next (y :: l) x h = y :=
begin
  rw [next, nth_le, ←init_append_last (cons_ne_nil y l), hx, next_or_concat],
  subst hx,
  intro H,
  obtain ⟨_ | k, hk, hk'⟩ := nth_le_of_mem H,
  { simpa [init_eq_take, nth_le_take', hy.symm] using hk' },
  suffices : k.succ = l.length,
  { simpa [this] using hk },
  cases l with hd tl,
  { simpa using hk },
  { rw nodup_iff_nth_le_inj at hl,
    rw [length, nat.succ_inj'],
    apply hl,
    simpa [init_eq_take, nth_le_take', last_eq_nth_le] using hk' }
end

lemma prev_last_cons' (y : α) (h : x ∈ (y :: l)) (hx : x = y) :
  prev (y :: l) x h = last (y :: l) (cons_ne_nil _ _) :=
begin
  cases l;
  simp [prev, hx]
end

@[simp] lemma prev_last_cons (h : x ∈ (x :: l)) :
  prev (x :: l) x h = last (x :: l) (cons_ne_nil _ _) :=
prev_last_cons' l x x h rfl

lemma prev_cons_cons_eq' (y z : α) (h : x ∈ (y :: z :: l)) (hx : x = y) :
  prev (y :: z :: l) x h = last (z :: l) (cons_ne_nil _ _) :=
by rw [prev, dif_pos hx]

@[simp] lemma prev_cons_cons_eq (z : α) (h : x ∈ (x :: z :: l)) :
  prev (x :: z :: l) x h = last (z :: l) (cons_ne_nil _ _) :=
prev_cons_cons_eq' l x x z h rfl

lemma prev_cons_cons_of_ne' (y z : α) (h : x ∈ (y :: z :: l)) (hy : x ≠ y) (hz : x = z) :
  prev (y :: z :: l) x h = y :=
begin
  cases l,
  { simp [prev, hy, hz] },
  { rw [prev, dif_neg hy, if_pos hz] }
end

lemma prev_cons_cons_of_ne (y : α) (h : x ∈ (y :: x :: l)) (hy : x ≠ y) :
  prev (y :: x :: l) x h = y :=
prev_cons_cons_of_ne' _ _ _ _ _ hy rfl

lemma prev_ne_cons_cons (y z : α) (h : x ∈ (y :: z :: l)) (hy : x ≠ y) (hz : x ≠ z) :
  prev (y :: z :: l) x h = prev (z :: l) x (by simpa [hy] using h) :=
begin
  cases l,
  { simpa [hy, hz] using h },
  { rw [prev, dif_neg hy, if_neg hz] }
end

include h

lemma next_mem : l.next x h ∈ l :=
next_or_mem (nth_le_mem _ _ _)

lemma prev_mem : l.prev x h ∈ l :=
begin
  cases l with hd tl,
  { simpa using h },
  induction tl with hd' tl hl generalizing hd,
  { simp },
  { by_cases hx : x = hd,
    { simp only [hx, prev_cons_cons_eq],
      exact mem_cons_of_mem _ (last_mem _) },
    { rw [prev, dif_neg hx],
      split_ifs with hm,
      { exact mem_cons_self _ _ },
      { exact mem_cons_of_mem _ (hl _ _) } } }
end

lemma next_nth_le (l : list α) (h : nodup l) (n : ℕ) (hn : n < l.length) :
  next l (l.nth_le n hn) (nth_le_mem _ _ _) = l.nth_le ((n + 1) % l.length)
    (nat.mod_lt _ (n.zero_le.trans_lt hn)) :=
begin
  cases l with x l,
  { simpa using hn },
  induction l with y l hl generalizing x n,
  { simp },
  { cases n,
    { simp },
    { have hn' : n.succ ≤ l.length.succ,
      { refine nat.succ_le_of_lt _,
        simpa [nat.succ_lt_succ_iff] using hn },
      have hx': (x :: y :: l).nth_le n.succ hn ≠ x,
      { intro H,
        suffices : n.succ = 0,
        { simpa },
        rw nodup_iff_nth_le_inj at h,
        refine h _ _ hn nat.succ_pos' _,
        simpa using H },
      rcases hn'.eq_or_lt with hn''|hn'',
      { rw [next_last_cons],
        { simp [hn''] },
        { exact hx' },
        { simp [last_eq_nth_le, hn''] },
        { exact h.of_cons } },
      { have : n < l.length := by simpa [nat.succ_lt_succ_iff] using hn'' ,
        rw [next_ne_head_ne_last _ _ _ _ hx'],
        { simp [nat.mod_eq_of_lt (nat.succ_lt_succ (nat.succ_lt_succ this)),
                hl _ _ h.of_cons, nat.mod_eq_of_lt (nat.succ_lt_succ this)] },
        { rw last_eq_nth_le,
          intro H,
          suffices : n.succ = l.length.succ,
          { exact absurd hn'' this.ge.not_lt },
          rw nodup_iff_nth_le_inj at h,
          refine h _ _ hn _ _,
          { simp },
          { simpa using H } } } } }
end

lemma prev_nth_le (l : list α) (h : nodup l) (n : ℕ) (hn : n < l.length) :
  prev l (l.nth_le n hn) (nth_le_mem _ _ _) = l.nth_le ((n + (l.length - 1)) % l.length)
    (nat.mod_lt _ (n.zero_le.trans_lt hn)) :=
begin
  cases l with x l,
  { simpa using hn },
  induction l with y l hl generalizing n x,
  { simp },
  { rcases n with _|_|n,
    { simpa [last_eq_nth_le, nat.mod_eq_of_lt (nat.succ_lt_succ l.length.lt_succ_self)] },
    { simp only [mem_cons_iff, nodup_cons] at h,
      push_neg at h,
      simp [add_comm, prev_cons_cons_of_ne, h.left.left.symm] },
    { rw [prev_ne_cons_cons],
      { convert hl _ _ h.of_cons _ using 1,
        have : ∀ k hk, (y :: l).nth_le k hk = (x :: y :: l).nth_le (k + 1) (nat.succ_lt_succ hk),
        { intros,
          simpa },
        rw [this],
        congr,
        simp only [nat.add_succ_sub_one, add_zero, length],
        simp only [length, nat.succ_lt_succ_iff] at hn,
        set k := l.length,
        rw [nat.succ_add, ←nat.add_succ, nat.add_mod_right, nat.succ_add, ←nat.add_succ _ k,
            nat.add_mod_right, nat.mod_eq_of_lt, nat.mod_eq_of_lt],
        { exact nat.lt_succ_of_lt hn },
        { exact nat.succ_lt_succ (nat.lt_succ_of_lt hn) } },
      { intro H,
        suffices : n.succ.succ = 0,
        { simpa },
        rw nodup_iff_nth_le_inj at h,
        refine h _ _ hn nat.succ_pos' _,
        simpa using H },
      { intro H,
        suffices : n.succ.succ = 1,
        { simpa },
        rw nodup_iff_nth_le_inj at h,
        refine h _ _ hn (nat.succ_lt_succ nat.succ_pos') _,
        simpa using H } } }
end

lemma pmap_next_eq_rotate_one (h : nodup l) :
  l.pmap l.next (λ _ h, h) = l.rotate 1 :=
begin
  apply list.ext_le,
  { simp },
  { intros,
    rw [nth_le_pmap, nth_le_rotate, next_nth_le _ h] }
end

lemma pmap_prev_eq_rotate_length_sub_one (h : nodup l) :
  l.pmap l.prev (λ _ h, h) = l.rotate (l.length - 1) :=
begin
  apply list.ext_le,
  { simp },
  { intros n hn hn',
    rw [nth_le_rotate, nth_le_pmap, prev_nth_le _ h] }
end

lemma prev_next (l : list α) (h : nodup l) (x : α) (hx : x ∈ l) :
  prev l (next l x hx) (next_mem _ _ _) = x :=
begin
  obtain ⟨n, hn, rfl⟩ := nth_le_of_mem hx,
  simp only [next_nth_le, prev_nth_le, h, nat.mod_add_mod],
  cases l with hd tl,
  { simp },
  { have : n < 1 + tl.length := by simpa [add_comm] using hn,
    simp [add_left_comm, add_comm, add_assoc, nat.mod_eq_of_lt this] }
end

lemma next_prev (l : list α) (h : nodup l) (x : α) (hx : x ∈ l) :
  next l (prev l x hx) (prev_mem _ _ _) = x :=
begin
  obtain ⟨n, hn, rfl⟩ := nth_le_of_mem hx,
  simp only [next_nth_le, prev_nth_le, h, nat.mod_add_mod],
  cases l with hd tl,
  { simp },
  { have : n < 1 + tl.length := by simpa [add_comm] using hn,
    simp [add_left_comm, add_comm, add_assoc, nat.mod_eq_of_lt this] }
end

lemma prev_reverse_eq_next (l : list α) (h : nodup l) (x : α) (hx : x ∈ l) :
  prev l.reverse x (mem_reverse.mpr hx) = next l x hx :=
begin
  obtain ⟨k, hk, rfl⟩ := nth_le_of_mem hx,
  have lpos : 0 < l.length := k.zero_le.trans_lt hk,
  have key : l.length - 1 - k < l.length :=
    (nat.sub_le _ _).trans_lt (tsub_lt_self lpos nat.succ_pos'),
  rw ←nth_le_pmap l.next (λ _ h, h) (by simpa using hk),
  simp_rw [←nth_le_reverse l k (key.trans_le (by simp)), pmap_next_eq_rotate_one _ h],
  rw ←nth_le_pmap l.reverse.prev (λ _ h, h),
  { simp_rw [pmap_prev_eq_rotate_length_sub_one _ (nodup_reverse.mpr h), rotate_reverse,
             length_reverse, nat.mod_eq_of_lt (tsub_lt_self lpos nat.succ_pos'),
             tsub_tsub_cancel_of_le (nat.succ_le_of_lt lpos)],
    rw ←nth_le_reverse,
    { simp [tsub_tsub_cancel_of_le (nat.le_pred_of_lt hk)] },
    { simpa using (nat.sub_le _ _).trans_lt (tsub_lt_self lpos nat.succ_pos') } },
  { simpa using (nat.sub_le _ _).trans_lt (tsub_lt_self lpos nat.succ_pos') }
end

lemma next_reverse_eq_prev (l : list α) (h : nodup l) (x : α) (hx : x ∈ l) :
  next l.reverse x (mem_reverse.mpr hx) = prev l x hx :=
begin
  convert (prev_reverse_eq_next l.reverse (nodup_reverse.mpr h) x (mem_reverse.mpr hx)).symm,
  exact (reverse_reverse l).symm
end

lemma is_rotated_next_eq {l l' : list α} (h : l ~r l') (hn : nodup l) {x : α} (hx : x ∈ l) :
  l.next x hx = l'.next x (h.mem_iff.mp hx) :=
begin
  obtain ⟨k, hk, rfl⟩ := nth_le_of_mem hx,
  obtain ⟨n, rfl⟩ := id h,
  rw [next_nth_le _ hn],
  simp_rw ←nth_le_rotate' _ n k,
  rw [next_nth_le _ (h.nodup_iff.mp hn), ←nth_le_rotate' _ n],
  simp [add_assoc]
end

lemma is_rotated_prev_eq {l l' : list α} (h : l ~r l') (hn : nodup l) {x : α} (hx : x ∈ l) :
  l.prev x hx = l'.prev x (h.mem_iff.mp hx) :=
begin
  rw [←next_reverse_eq_prev _ hn, ←next_reverse_eq_prev _ (h.nodup_iff.mp hn)],
  exact is_rotated_next_eq h.reverse (nodup_reverse.mpr hn) _
end

end list

open list

/--
`cycle α` is the quotient of `list α` by cyclic permutation.
Duplicates are allowed.
-/
def cycle (α : Type*) : Type* := quotient (is_rotated.setoid α)

namespace cycle

variables {α : Type*}

instance : has_coe (list α) (cycle α) := ⟨quot.mk _⟩

@[simp] lemma coe_eq_coe {l₁ l₂ : list α} : (l₁ : cycle α) = l₂ ↔ (l₁ ~r l₂) :=
@quotient.eq _ (is_rotated.setoid _) _ _

@[simp] lemma mk_eq_coe (l : list α) : quot.mk _ l = (l : cycle α) :=
rfl

@[simp] lemma mk'_eq_coe (l : list α) : quotient.mk' l = (l : cycle α) :=
rfl

lemma coe_cons_eq_coe_append (l : list α) (a : α) : (↑(a :: l) : cycle α) = ↑(l ++ [a]) :=
quot.sound ⟨1, by rw [rotate_cons_succ, rotate_zero]⟩

/-- The unique empty cycle. -/
def nil : cycle α := ([] : list α)

@[simp] lemma coe_nil : ↑([] : list α) = @nil α :=
rfl

@[simp] lemma coe_eq_nil (l : list α) : (l : cycle α) = nil ↔ l = [] :=
coe_eq_coe.trans is_rotated_nil_iff

/-- For consistency with `list.has_emptyc`. -/
instance : has_emptyc (cycle α) := ⟨nil⟩

@[simp] lemma empty_eq : ∅ = @nil α :=
rfl

instance : inhabited (cycle α) := ⟨nil⟩

/-- An induction principle for `cycle`. Use as `induction s using cycle.induction_on`. -/
@[elab_as_eliminator] lemma induction_on {C : cycle α → Prop} (s : cycle α) (H0 : C nil)
  (HI : ∀ a (l : list α), C ↑l → C ↑(a :: l)) : C s :=
quotient.induction_on' s $ λ l, by { apply list.rec_on l; simp, assumption' }

/-- For `x : α`, `s : cycle α`, `x ∈ s` indicates that `x` occurs at least once in `s`. -/
def mem (a : α) (s : cycle α) : Prop :=
quot.lift_on s (λ l, a ∈ l) (λ l₁ l₂ e, propext $ e.mem_iff)

instance : has_mem α (cycle α) := ⟨mem⟩

@[simp] lemma mem_coe_iff {a : α} {l : list α} : a ∈ (l : cycle α) ↔ a ∈ l :=
iff.rfl

@[simp] lemma not_mem_nil : ∀ a, a ∉ @nil α :=
not_mem_nil

instance [decidable_eq α] : decidable_eq (cycle α) :=
λ s₁ s₂, quotient.rec_on_subsingleton₂' s₁ s₂ (λ l₁ l₂, decidable_of_iff' _ quotient.eq')

instance [decidable_eq α] (x : α) (s : cycle α) : decidable (x ∈ s) :=
quotient.rec_on_subsingleton' s (λ l, list.decidable_mem x l)

/-- Reverse a `s : cycle α` by reversing the underlying `list`. -/
def reverse (s : cycle α) : cycle α :=
quot.map reverse (λ l₁ l₂, is_rotated.reverse) s

@[simp] lemma reverse_coe (l : list α) : (l : cycle α).reverse = l.reverse :=
rfl

@[simp] lemma mem_reverse_iff {a : α} {s : cycle α} : a ∈ s.reverse ↔ a ∈ s :=
quot.induction_on s (λ _, mem_reverse)

@[simp] lemma reverse_reverse (s : cycle α) : s.reverse.reverse = s :=
quot.induction_on s (λ _, by simp)

@[simp] lemma reverse_nil : nil.reverse = @nil α :=
rfl

/-- The length of the `s : cycle α`, which is the number of elements, counting duplicates. -/
def length (s : cycle α) : ℕ :=
quot.lift_on s length (λ l₁ l₂ e, e.perm.length_eq)

@[simp] lemma length_coe (l : list α) : length (l : cycle α) = l.length :=
rfl

@[simp] lemma length_nil : length (@nil α) = 0 :=
rfl

@[simp] lemma length_reverse (s : cycle α) : s.reverse.length = s.length :=
quot.induction_on s length_reverse

/-- A `s : cycle α` that is at most one element. -/
def subsingleton (s : cycle α) : Prop :=
s.length ≤ 1

lemma subsingleton_nil : subsingleton (@nil α) :=
zero_le_one

lemma length_subsingleton_iff {s : cycle α} : subsingleton s ↔ length s ≤ 1 :=
iff.rfl

@[simp] lemma subsingleton_reverse_iff {s : cycle α} : s.reverse.subsingleton ↔ s.subsingleton :=
by simp [length_subsingleton_iff]

lemma subsingleton.congr {s : cycle α} (h : subsingleton s) :
  ∀ ⦃x⦄ (hx : x ∈ s) ⦃y⦄ (hy : y ∈ s), x = y :=
begin
  induction s using quot.induction_on with l,
  simp only [length_subsingleton_iff, length_coe, mk_eq_coe, le_iff_lt_or_eq, nat.lt_add_one_iff,
             length_eq_zero, length_eq_one, nat.not_lt_zero, false_or] at h,
  rcases h with rfl|⟨z, rfl⟩;
  simp
end

/-- A `s : cycle α` that is made up of at least two unique elements. -/
def nontrivial (s : cycle α) : Prop := ∃ (x y : α) (h : x ≠ y), x ∈ s ∧ y ∈ s

@[simp] lemma nontrivial_coe_nodup_iff {l : list α} (hl : l.nodup) :
  nontrivial (l : cycle α) ↔ 2 ≤ l.length :=
begin
  rw nontrivial,
  rcases l with (_ | ⟨hd, _ | ⟨hd', tl⟩⟩),
  { simp },
  { simp },
  { simp only [mem_cons_iff, exists_prop, mem_coe_iff, list.length, ne.def, nat.succ_le_succ_iff,
               zero_le, iff_true],
    refine ⟨hd, hd', _, by simp⟩,
    simp only [not_or_distrib, mem_cons_iff, nodup_cons] at hl,
    exact hl.left.left }
end

@[simp] lemma nontrivial_reverse_iff {s : cycle α} : s.reverse.nontrivial ↔ s.nontrivial :=
by simp [nontrivial]

lemma length_nontrivial {s : cycle α} (h : nontrivial s) : 2 ≤ length s :=
begin
  obtain ⟨x, y, hxy, hx, hy⟩ := h,
  induction s using quot.induction_on with l,
  rcases l with (_ | ⟨hd, _ | ⟨hd', tl⟩⟩),
  { simpa using hx },
  { simp only [mem_coe_iff, mk_eq_coe, mem_singleton] at hx hy,
    simpa [hx, hy] using hxy },
  { simp [bit0] }
end

/-- The `s : cycle α` contains no duplicates. -/
def nodup (s : cycle α) : Prop :=
quot.lift_on s nodup (λ l₁ l₂ e, propext $ e.nodup_iff)

@[simp] lemma nodup_nil : nodup (@nil α) :=
nodup_nil

@[simp] lemma nodup_coe_iff {l : list α} : nodup (l : cycle α) ↔ l.nodup :=
iff.rfl

@[simp] lemma nodup_reverse_iff {s : cycle α} : s.reverse.nodup ↔ s.nodup :=
quot.induction_on s (λ _, nodup_reverse)

lemma subsingleton.nodup {s : cycle α} (h : subsingleton s) : nodup s :=
begin
  induction s using quot.induction_on with l,
  cases l with hd tl,
  { simp },
  { have : tl = [] := by simpa [subsingleton, length_eq_zero] using h,
    simp [this] }
end

lemma nodup.nontrivial_iff {s : cycle α} (h : nodup s) : nontrivial s ↔ ¬ subsingleton s :=
begin
  rw length_subsingleton_iff,
  induction s using quotient.induction_on',
  simp only [mk'_eq_coe, nodup_coe_iff] at h,
  simp [h, nat.succ_le_iff]
end

/--
The `s : cycle α` as a `multiset α`.
-/
def to_multiset (s : cycle α) : multiset α :=
quotient.lift_on' s coe (λ l₁ l₂ h, multiset.coe_eq_coe.mpr h.perm)

@[simp] lemma coe_to_multiset (l : list α) : (l : cycle α).to_multiset = l :=
rfl

@[simp] lemma nil_to_multiset : nil.to_multiset = (0 : multiset α) :=
rfl

@[simp] lemma card_to_multiset (s : cycle α) : s.to_multiset.card = s.length :=
quotient.induction_on' s (by simp)

@[simp] lemma to_multiset_eq_nil {s : cycle α} : s.to_multiset = 0 ↔ s = cycle.nil :=
quotient.induction_on' s (by simp)

/-- The lift of `list.map`. -/
def map {β : Type*} (f : α → β) : cycle α → cycle β :=
quotient.map' (list.map f) $ λ l₁ l₂ h, h.map _

@[simp] lemma map_nil {β : Type*} (f : α → β) : map f nil = nil :=
rfl

@[simp] lemma map_coe {β : Type*} (f : α → β) (l : list α) : map f ↑l = list.map f l :=
rfl

@[simp] lemma map_eq_nil {β : Type*} (f : α → β) (s : cycle α) : map f s = nil ↔ s = nil :=
quotient.induction_on' s (by simp)

@[simp] lemma mem_map {β : Type*} {f : α → β} {b : β} {s : cycle α} :
  b ∈ s.map f ↔ ∃ a, a ∈ s ∧ f a = b :=
quotient.induction_on' s (by simp)

/-- The `multiset` of lists that can make the cycle. -/
def lists (s : cycle α) : multiset (list α) :=
quotient.lift_on' s
  (λ l, (l.cyclic_permutations : multiset (list α))) $
  λ l₁ l₂ h, by simpa using h.cyclic_permutations.perm

@[simp] lemma lists_coe (l : list α) : lists (l : cycle α) = ↑l.cyclic_permutations :=
rfl

@[simp] lemma mem_lists_iff_coe_eq {s : cycle α} {l : list α} : l ∈ s.lists ↔ (l : cycle α) = s :=
quotient.induction_on' s $ λ l, by { rw [lists, quotient.lift_on'_mk'], simp }

@[simp] lemma lists_nil : lists (@nil α) = [([] : list α)] :=
by rw [nil, lists_coe, cyclic_permutations_nil]

section decidable

variable [decidable_eq α]

/--
Auxiliary decidability algorithm for lists that contain at least two unique elements.
-/
def decidable_nontrivial_coe : Π (l : list α), decidable (nontrivial (l : cycle α))
| []            := is_false (by simp [nontrivial])
| [x]           := is_false (by simp [nontrivial])
| (x :: y :: l) := if h : x = y
  then @decidable_of_iff' _ (nontrivial ((x :: l) : cycle α))
    (by simp [h, nontrivial])
    (decidable_nontrivial_coe (x :: l))
  else is_true ⟨x, y, h, by simp, by simp⟩

instance {s : cycle α} : decidable (nontrivial s) :=
quot.rec_on_subsingleton s decidable_nontrivial_coe

instance {s : cycle α} : decidable (nodup s) :=
quot.rec_on_subsingleton s list.nodup_decidable

instance fintype_nodup_cycle [fintype α] : fintype {s : cycle α // s.nodup} :=
fintype.of_surjective (λ (l : {l : list α // l.nodup}), ⟨l.val, by simpa using l.prop⟩)
  (λ ⟨s, hs⟩, by { induction s using quotient.induction_on', exact ⟨⟨s, hs⟩, by simp⟩ })

instance fintype_nodup_nontrivial_cycle [fintype α] :
  fintype {s : cycle α // s.nodup ∧ s.nontrivial} :=
fintype.subtype (((finset.univ : finset {s : cycle α // s.nodup}).map
  (function.embedding.subtype _)).filter cycle.nontrivial)
  (by simp)

/-- The `s : cycle α` as a `finset α`. -/
def to_finset (s : cycle α) : finset α :=
s.to_multiset.to_finset

@[simp] theorem to_finset_to_multiset (s : cycle α) : s.to_multiset.to_finset = s.to_finset :=
rfl

@[simp] lemma coe_to_finset (l : list α) : (l : cycle α).to_finset = l.to_finset :=
rfl

@[simp] lemma nil_to_finset : (@nil α).to_finset = ∅ :=
rfl

@[simp] lemma to_finset_eq_nil {s : cycle α} : s.to_finset = ∅ ↔ s = cycle.nil :=
quotient.induction_on' s (by simp)

/-- Given a `s : cycle α` such that `nodup s`, retrieve the next element after `x ∈ s`. -/
def next : Π (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s), α :=
λ s, quot.hrec_on s (λ l hn x hx, next l x hx)
  (λ l₁ l₂ h,
  function.hfunext (propext h.nodup_iff) (λ h₁ h₂ he, function.hfunext rfl
    (λ x y hxy, function.hfunext (propext (by simpa [eq_of_heq hxy] using h.mem_iff))
    (λ hm hm' he', heq_of_eq (by simpa [eq_of_heq hxy] using is_rotated_next_eq h h₁ _)))))

/-- Given a `s : cycle α` such that `nodup s`, retrieve the previous element before `x ∈ s`. -/
def prev : Π (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s), α :=
λ s, quot.hrec_on s (λ l hn x hx, prev l x hx)
  (λ l₁ l₂ h,
  function.hfunext (propext h.nodup_iff) (λ h₁ h₂ he, function.hfunext rfl
    (λ x y hxy, function.hfunext (propext (by simpa [eq_of_heq hxy] using h.mem_iff))
    (λ hm hm' he', heq_of_eq (by simpa [eq_of_heq hxy] using is_rotated_prev_eq h h₁ _)))))

@[simp] lemma prev_reverse_eq_next (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s) :
  s.reverse.prev (nodup_reverse_iff.mpr hs) x (mem_reverse_iff.mpr hx) = s.next hs x hx :=
(quotient.induction_on' s prev_reverse_eq_next) hs x hx

@[simp] lemma next_reverse_eq_prev (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s) :
  s.reverse.next (nodup_reverse_iff.mpr hs) x (mem_reverse_iff.mpr hx) = s.prev hs x hx :=
by simp [←prev_reverse_eq_next]

@[simp] lemma next_mem (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s) : s.next hs x hx ∈ s :=
by { induction s using quot.induction_on, apply next_mem }

lemma prev_mem (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s) : s.prev hs x hx ∈ s :=
by { rw [←next_reverse_eq_prev, ←mem_reverse_iff], apply next_mem }

@[simp] lemma prev_next (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s) :
  s.prev hs (s.next hs x hx) (next_mem s hs x hx) = x :=
(quotient.induction_on' s prev_next) hs x hx

@[simp] lemma next_prev (s : cycle α) (hs : nodup s) (x : α) (hx : x ∈ s) :
  s.next hs (s.prev hs x hx) (prev_mem s hs x hx) = x :=
(quotient.induction_on' s next_prev) hs x hx

end decidable

/--
We define a representation of concrete cycles, available when viewing them in a goal state or
via `#eval`, when over representable types. For example, the cycle `(2 1 4 3)` will be shown
as `c[2, 1, 4, 3]`. Two equal cycles may be printed differently if their internal representation
is different.
-/
meta instance [has_repr α] : has_repr (cycle α) :=
⟨λ s, "c[" ++ string.intercalate ", " ((s.map repr).lists.unquot).head ++ "]"⟩

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

`chain R ([a, b, c] : cycle α) ↔ R a b ∧ R b c ∧ R c a` -/
def chain (r : α → α → Prop) (c : cycle α) : Prop :=
quotient.lift_on' c (λ l, match l with
  | [] := true
  | (a :: m) := chain r a (m ++ [a]) end) $
λ a b hab, propext $ begin
  cases a with a l;
  cases b with b m,
  { refl },
  { have := is_rotated_nil_iff'.1 hab,
    contradiction },
  { have := is_rotated_nil_iff.1 hab,
    contradiction },
  { unfold chain._match_1,
    cases hab with n hn,
    induction n with d hd generalizing a b l m,
    { simp only [rotate_zero] at hn,
      rw [hn.1, hn.2] },
    { cases l with c s,
      { simp only [rotate_singleton] at hn,
        rw [hn.1, hn.2] },
      { rw [nat.succ_eq_one_add, ←rotate_rotate, rotate_cons_succ, rotate_zero, cons_append] at hn,
        rw [←hd c _ _ _ hn],
        simp [and.comm] } } }
end

@[simp] lemma chain.nil (r : α → α → Prop) : cycle.chain r (@nil α) :=
by trivial

@[simp] lemma chain_coe_cons (r : α → α → Prop) (a : α) (l : list α) :
  chain r (a :: l) ↔ list.chain r a (l ++ [a]) :=
iff.rfl

@[simp] lemma chain_singleton (r : α → α → Prop) (a : α) : chain r [a] ↔ r a a :=
by rw [chain_coe_cons, nil_append, chain_singleton]

lemma chain_map {β : Type*} {r : α → α → Prop} (f : β → α) {s : cycle β} :
  chain r (s.map f) ↔ chain (λ a b, r (f a) (f b)) s :=
quotient.induction_on' s $ λ l, begin
  cases l with a l,
  refl,
  convert list.chain_map f,
  rw map_append f l [a],
  refl
end

theorem chain_range_succ (r : ℕ → ℕ → Prop) (n : ℕ) :
  chain r (list.range n.succ) ↔ r n 0 ∧ ∀ m < n, r m m.succ :=
by rw [range_succ, ←coe_cons_eq_coe_append, chain_coe_cons, ←range_succ, chain_range_succ]

variables {r : α → α → Prop} {s : cycle α}

theorem chain_of_pairwise : (∀ (a ∈ s) (b ∈ s), r a b) → chain r s :=
begin
  induction s using cycle.induction_on with a l _,
  exact λ _, cycle.chain.nil r,
  intro hs,
  have Ha : a ∈ ((a :: l) : cycle α) := by simp,
  have Hl : ∀ {b} (hb : b ∈ l), b ∈ ((a :: l) : cycle α) := λ b hb, by simp [hb],
  rw cycle.chain_coe_cons,
  apply pairwise.chain,
  rw pairwise_cons,
  refine ⟨λ b hb, _, pairwise_append.2 ⟨pairwise_of_forall_mem_list
    (λ b hb c hc, hs b (Hl hb) c (Hl hc)), pairwise_singleton r a, λ b hb c hc, _⟩⟩,
  { rw mem_append at hb,
    cases hb,
    { exact hs a Ha b (Hl hb) },
    { rw mem_singleton at hb,
      rw hb,
      exact hs a Ha a Ha } },
  { rw mem_singleton at hc,
    rw hc,
    exact hs b (Hl hb) a Ha }
end

theorem chain_iff_pairwise [is_trans α r] : chain r s ↔ ∀ (a ∈ s) (b ∈ s), r a b :=
⟨begin
  induction s using cycle.induction_on with a l _,
  exact λ _ b hb, hb.elim,
  intros hs b hb c hc,
  rw [cycle.chain_coe_cons, chain_iff_pairwise] at hs,
  simp only [pairwise_append, pairwise_cons, mem_append, mem_singleton, list.not_mem_nil,
    is_empty.forall_iff, implies_true_iff, pairwise.nil, forall_eq, true_and] at hs,
  simp only [mem_coe_iff, mem_cons_iff] at hb hc,
  rcases hb with rfl | hb;
  rcases hc with rfl | hc,
  { exact hs.1 c (or.inr rfl) },
  { exact hs.1 c (or.inl hc) },
  { exact hs.2.2 b hb },
  { exact trans (hs.2.2 b hb) (hs.1 c (or.inl hc)) }
end, cycle.chain_of_pairwise⟩

theorem forall_eq_of_chain [is_trans α r] [is_antisymm α r]
  (hs : chain r s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) : a = b :=
by { rw chain_iff_pairwise at hs, exact antisymm (hs a ha b hb) (hs b hb a ha) }

end cycle


/-
Copyright © 2019, Oracle and/or its affiliates. All rights reserved.
-/

import lib.attributed.probability_theory
import lib.attributed.dvector lib.attributed.to_mathlib
import measure_theory.giry_monad
import measure_theory.measure_space
import data.complex.exponential

local attribute [instance] classical.prop_decidable

universes u v

open nnreal measure_theory nat list measure_theory.measure to_integration probability_measure set dfin lattice ennreal

variables {α : Type u} {β : Type u} {γ : Type v}[measurable_space α]

infixl ` >>=ₐ `:55 := measure.bind
infixl ` <$>ₐ `:55 := measure.map

local notation `doₐ` binders ` ←ₐ ` m ` ; ` t:(scoped p, m >>=ₐ p) := t

local notation `ret` := measure.dirac

lemma split_set {α β : Type u} (Pa : α → Prop) (Pb : β → Prop) : {m : α × β | Pa m.fst} = {x : α | Pa x}.prod univ := by ext1; cases x; dsimp at *; simp at *

instance has_zero_dfin {n} : has_zero $ dfin (n+1) := ⟨dfin.fz⟩

lemma vec.split_set {n : ℕ} (P : α → Prop) (μ : probability_measure α) :
{x : vec α (n+2)| P (kth_projn x 1)} = set.prod univ {x : vec α (n+1) | P (kth_projn x 0)} :=
begin
ext1, cases x, cases x_snd, dsimp at *, simp at *, refl,
end

lemma vec.prod_measure_univ' {n : ℕ} [nonempty α] [ne : ∀ n, nonempty (vec α n)](μ : probability_measure α) : (vec.prod_measure μ n : measure (vec α (n))) (univ) = 1
:=
by exact measure_univ _

noncomputable def vec.prob_measure (n : ℕ) [nonempty α] (μ : probability_measure α) : probability_measure (vec α n) :=
⟨ vec.prod_measure μ n , vec.prod_measure_univ' μ ⟩

lemma vec.prob_measure_apply (n : ℕ) [nonempty α] {μ : probability_measure α} {S : set (vec α n)} (hS : is_measurable S) : (vec.prob_measure n μ) S = ((vec.prod_measure μ n) S) := rfl

lemma measure_kth_projn' {n : ℕ} [nonempty α]  {P : α → Prop} (μ : probability_measure α) (hP : is_measurable {x : α | P x}) (hp' : is_measurable {x : vec α (n + 1) | P (kth_projn x 0)}) :
(vec.prod_measure μ (n+2) : probability_measure (vec α (n+2))) {x : vec α (n + 2) | P (kth_projn x 1)} = μ {x : α | P x} :=
begin
  rw vec.split_set _ μ,
  rw vec.prod_measure_eq,
  rw prod.prob_measure_apply _ _ is_measurable.univ _, rw prob_univ,rw one_mul,
  have h: {x : vec α (n + 1) | P (kth_projn x 0)} = {x : vec α (n + 1) | P (x.fst)}, {
  ext1, cases x, refl,
  },
  rw h, clear h,
  induction n with k ih, rw vec.prod_measure_eq,
  have h₁: {x : vec α (0 + 1) | P (x.fst)} = set.prod {x:α | P(x)} univ,by ext1; cases x; dsimp at *;simp at *,
  rw h₁, rw vec.prod_measure,rw prod.prob_measure_apply _ _ _ is_measurable.univ, rw prob_univ, rw mul_one, assumption,assumption, exact hP,
  have h₂ : {x : vec α (succ k + 1) | P (x.fst)} = {x : vec α (k + 2) | P (x.fst)},by refl,
  rw h₂, clear h₂,
  have h₃ : {x : vec α (k + 2) | P (x.fst)} = set.prod {x : α | P(x)} univ, {
  ext1, cases x, dsimp at *, simp at *,
  },
  rw h₃, rw vec.prod_measure_eq,rw prod.prob_measure_apply _ _ _ is_measurable.univ, rw prob_univ, rw mul_one, assumption, apply nonempty.vec, exact hP, assumption, apply nonempty.vec, assumption,
end

@[simp] lemma measure_kth_projn {n : ℕ} [nonempty α] {P : α → Prop} (μ : probability_measure α) (hP : is_measurable {x : α | P x}) (hp' : ∀ n i, is_measurable {x : vec α n | P (kth_projn x i)}) : ∀ (i : dfin (n+1)),
(vec.prod_measure μ n : probability_measure (vec α n)) {x : vec α n | P (kth_projn x i)} = μ {x : α | P x} :=
begin
  intros i,
  induction n with n b dk ih, rw vec.prod_measure,
  have g : {x : vec α 0 | P (kth_projn x i)} = {x | P x}, by tidy, rw g, refl,
  have h: {x : vec α (n + 1) | P (kth_projn x fz)} = {x : vec α (n + 1) | P (x.fst)}, {
  ext1, cases x, refl,
  },
  cases i,
  rw h, clear h,
have h₃ : {x : vec α (n + 1) | P (x.fst)} = set.prod {x : α | P(x)} univ, {
  ext1, cases x, dsimp at *, simp at *,
  },
  rw h₃, rw vec.prod_measure_eq, rw prod.prob_measure_apply _ _ hP is_measurable.univ, rw prob_univ, rw mul_one, exact (nonempty.vec n), rw vec.prod_measure_eq,
  have h₄ : {x : vec α (succ n) | P (kth_projn x (fs i_a))} = set.prod univ {x : vec α n | P (kth_projn x i_a)}, {
  ext1, cases x, dsimp at *, simp at *,
  },
  rw h₄, rw prod.prob_measure_apply _ _ is_measurable.univ _, rw prob_univ, rw one_mul, rw b,
  assumption, exact (nonempty.vec n),
  apply hp',
end

lemma dfin_succ_prop_iff_fst_and_rst {α : Type u} (P : α → Prop) {k : ℕ} (x : vec α (succ k)) : (∀ (i : dfin (succ k + 1)), P (kth_projn x i)) ↔ P (x.fst) ∧ ∀ (i : dfin (succ k)), P (kth_projn (x.snd) i) :=
begin
  fsplit,
  intros h, split, have := h fz, have : kth_projn x 0 = x.fst, cases x, refl, rw ←this, assumption,
  intro i₀, cases x, have := h (fs i₀), rwa kth_projn at this,
  intros g i₁, cases g with l r, cases i₁ with ifz ifs, have : kth_projn x fz = x.fst, cases x, refl, rw this, assumption,
  cases x, rw kth_projn, exact r i₁_a,
end

 lemma independence {n : ℕ} [nonempty α] {P : α → Prop} (μ : probability_measure α) (hP : is_measurable {x : α | P x}) (hp' : ∀ n, is_measurable {x : vec α n | ∀ i, P (kth_projn x i)}) :
 (vec.prod_measure μ n : probability_measure (vec α n)) {x : vec α n | ∀ (i : dfin (n + 1)), P (kth_projn x i)} = μ {x : α | P x} ^ (n+1) :=
 begin
  induction n with k ih,
  simp only [nat.pow_zero, nat_zero_eq_zero],
  have g : {x : vec α 0 | ∀ i : dfin 1, P (kth_projn x i)} = {x | P x}, {
  ext1, dsimp at *, fsplit, intros a, exact (a fz), intros a i, assumption,
  },
  rw g, simp, refl,
  have h₂ : {x : vec α (succ k) | ∀ (i : dfin (succ k + 1)), P (kth_projn x i)} = set.prod {x | P x} {x : vec α k | ∀ (i : dfin (succ k)), P (kth_projn x i)},{
  ext1, apply dfin_succ_prop_iff_fst_and_rst,
  },
  rw [h₂],
  rw vec.prod_measure_eq, rw vec.prod_measure_apply _ _ hP (hp' k),rw ih,refl,
end

@[simp] lemma prob_independence {n : ℕ} [nonempty α] {P : α → Prop} (μ : probability_measure α) (hP : is_measurable {x : α | P x}) (hp' : ∀ n, is_measurable {x : vec α n | ∀ i, P (kth_projn x i)}) :
 (vec.prob_measure n μ : probability_measure (vec α n)) {x : vec α n | ∀ (i : dfin (succ n)), P (kth_projn x i)} = (μ {x : α | P x}) ^ (n+1) :=
 begin
  induction n with k ih,
  simp only [nat.pow_zero, nat_zero_eq_zero],
  have g : {x : vec α 0 | ∀ i : dfin 1, P (kth_projn x i)} = {x | P x}, {
  ext1, dsimp at *, fsplit, intros a, exact (a fz), intros a i, assumption,
  },
  rw g, rw vec.prob_measure, simp, refl,
  have h₂ : {x : vec α (succ k) | ∀ (i : dfin (succ (succ k))), P (kth_projn x i)} = set.prod {x | P x} {x : vec α k | ∀ (i : dfin (succ k)), P (kth_projn x i)},{
  ext1, apply dfin_succ_prop_iff_fst_and_rst,
  },
  rw h₂,
  rw vec.prob_measure_apply _ _,
  rw [vec.prod_measure_eq], rw vec.prod_measure_apply _ _ hP, rw pow_succ', rw ←ih, rw mul_comm, rw vec.prob_measure_apply, exact hp' k, exact hp' k, exact is_measurable_set_prod hP (hp' k),
end

noncomputable def point_indicators {f h: α → bool} {n : ℕ} (hf : measurable f) (hh : measurable h) (i : dfin (succ n)) := χ ⟦{x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)}⟧

lemma integral_point_indicators {f h: α → bool} {n : ℕ} [ne : nonempty (vec α n)] (hf : measurable f) (hh : measurable h) (hA : ∀ n i, is_measurable ({x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)})) (μ : measure (vec α n)) :
∀ i : dfin (succ n),
 (∫ χ ⟦{x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)}⟧ ðμ) = μ ({x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)}) := assume i, integral_char_fun μ (hA n i)

lemma finally {f h : α → bool} {n : ℕ} [nonempty α] (hf : measurable f) (hh : measurable h) (hA : ∀ n i, is_measurable ({x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)})) (hB : is_measurable {x : α | h x ≠ f x}) (μ : probability_measure α) : let η := (vec.prod_measure μ n).to_measure in
∀ i, (∫ (χ ⟦{x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)}⟧) ðη) = μ.to_measure {x : α | h x ≠ f x} :=
begin
  intros η i₀,
  rw [integral_point_indicators hf hh hA (vec.prod_measure μ n).to_measure i₀], rw ←coe_eq_to_measure, rw ←coe_eq_to_measure,
  rw measure_kth_projn μ hB,
  intro n₀, apply hA,
end

lemma integral_char_fun_finset_sum {f h : α → bool} {n : ℕ} [nonempty α] (hf : measurable f) (hh : measurable h) (hA : ∀ n i, is_measurable ({x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)})) (hB : is_measurable {x : α | h x ≠ f x}) (μ : probability_measure α) (m : finset(dfin (succ n))):
(∫finset.sum m (λ (i : dfin (succ n)), ⇑χ⟦{x : vec α n | h (kth_projn x i) ≠ f (kth_projn x i)}⟧)ð((vec.prod_measure μ n).to_measure)) = m.sum (λ i, ((vec.prod_measure μ n)) ({x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)})) :=
begin
  rw integral,
  refine finset.induction_on m _ _,
  { simp, erw lintegral_zero },
  { assume a s has ih, simp [has], erw [lintegral_add],
  erw simple_func.lintegral_eq_integral,unfold char_fun,
  erw simple_func.restrict_const_integral, dsimp, rw ←ih, rw one_mul, rw coe_eq_to_measure, refl, exact(hA n a),
  exact measurable.comp (simple_func.measurable _) measurable_id,
  refine measurable.comp _ measurable_id,
  refine finset.induction_on s _ _,
    {simp, exact simple_func.measurable 0,},
    {intros a b c d, simp [c], apply measure_theory.measurable_add, exact simple_func.measurable _, exact d,}
  },
end

lemma integral_sum_dfin {f h : α → bool} {n : ℕ} [nonempty α] (hf : measurable f) (hh : measurable h) (hA : ∀ n i, is_measurable ({x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)})) (hB : is_measurable {x : α | h x ≠ f x}) (μ : probability_measure α) (m : finset(dfin (succ n))) : let η := (vec.prod_measure μ n) in
(∫ m.sum (λ i, χ ⟦{x : vec α n | h(kth_projn x i) ≠ f (kth_projn x i)}⟧) ðη.to_measure )= m.sum (λ i, (μ.to_measure : measure α)  {x : α | h x ≠ f x}) :=
begin
  intros η,
  rw [integral_char_fun_finset_sum hf hh hA hB],
  congr, funext, rw measure_kth_projn μ hB hA, rw coe_eq_to_measure,
end

lemma measure_sum_const {f h : α → bool} {n : ℕ} (hf : measurable f) (hh : measurable h) (m : finset (fin n)) (μ : probability_measure α) :
m.sum (λ i, (μ : measure α)  {x : α | h x ≠ f x}) = (m.card : ℕ) * ((μ : measure α)  {x : α | h x ≠ f x}) :=
begin
  apply finset.induction_on m, simp,
  intros a b c d,
  simp [c], rw add_monoid.add_smul, rw [add_monoid.smul],
  simp [monoid.pow], rw right_distrib, rw monoid.one_mul, rw ←d,
  simp,
end

namespace hoeffding
open complex real

noncomputable def exp_fun (f : α → ennreal) : α → ℝ := λ x, exp $ (f x).to_real

local notation  `∫` f `𝒹`m := integral m.to_measure f

lemma integral_char_rect [measurable_space α] [measurable_space β] [n₁ : nonempty α] [n₂ : nonempty β](μ : probability_measure α) (ν : probability_measure β)  {A : set α} {B : set β} (hA : is_measurable A) (hB : is_measurable B) :
(∫ χ ⟦ A.prod B ⟧ 𝒹(μ ⊗ₚ ν)) = (μ A) * (ν B) :=
begin
  haveI := (nonempty_prod.2 (and.intro n₁ n₂)),
  rw [integral_char_fun _ (is_measurable_set_prod hA hB),←coe_eq_to_measure,
  (prod.prob_measure_apply _ _ hA hB)], simp,
end

end hoeffding


import prelim.collections prelim.embed prelim.size prelim.induction prelim.minmax
import .rankfun matroid.submatroid.minor_iso matroid.submatroid.projection

noncomputable theory
open_locale classical

open set
namespace matroid

/-
This file is a mess. This mostly stems from the awkwardness of defining 'parallel'. Should it be defined for all pairs
e,f, or just for pairs of nonloops? Should a parallel class be a set of nonloops, or a set of elements?

Going with the 'bundled nonloop' approach leads to forever folding and unfolding coercions, although it is nicer that parallel is an
equivalence relation, as setoid stuff in the API becomes available.

Going with the unbundled approach leads to constantly passing around is_nonloop proof terms, but the computations are flatter
and often more pleasant.

The problem is that loops are there, and so can't be completely ignored, but can still be mostly ignored. The current approach
is unbundled, but I'm not convinced it's the best one.
-/

variables {α β : Type} [fintype α][fintype β]

/-- equivalence relation of being parallel for nonloops  -/
def parallel_nl (M : matroid α) (e f : nonloop M) : Prop :=
  M.r ({e,f}) = 1

/-- relation of being both nonloops and having a rank-one union. Irreflexive at loops;
    an equivalence relation when restricted to nonloops -/
def parallel (M : matroid α) (e f : α) : Prop :=
  M.is_nonloop e ∧ M.is_nonloop f ∧ M.r {e,f} = 1

--lemma rank_of_parallel {M : matroid α} {e f : α} (h )

lemma rank_eq_rank_of_parallel_ext {M : matroid α} {X Y : set α} (hXY : X ⊆ Y)
(hY : ∀ y : Y, M.is_nonloop y → ∃ x : X, M.parallel x y) :
M.r X = M.r Y :=
begin
  refine rank_eq_of_rank_all_insert_eq hXY (λ y, _),
  rcases M.loop_or_nonloop y with (hy | hy), rw rank_eq_rank_insert_loop _ hy,
  obtain ⟨⟨x,hx⟩, ⟨hxnl,hznl,hr⟩⟩ := hY y hy,
  dsimp only [subtype.coe_mk] at *, rw nonloop_iff_r at *,
  have hr' := rank_eq_of_union_eq_rank_subset X (singleton_subset_pair_left x y) (by rw [hr, hxnl]),
  rw [subset_iff_union_eq_left.mp (singleton_subset_iff.mpr hx)] at hr',
  rw [hr', eq_comm, union_comm],
  apply rank_eq_of_union_eq_rank_subset,
    apply singleton_subset_pair_right,
  rw [hznl, hr],
end

lemma parallel_nl_of_parallel {M : matroid α} {e f : α} (h : M.parallel e f ) :
  ∃ (he : M.is_nonloop e) (hf : M.is_nonloop f), M.parallel_nl ⟨e,he⟩ ⟨f,hf⟩ :=
⟨h.1,h.2.1,h.2.2⟩

lemma parallel_of_parallel_nl {M : matroid α} {e f : M.nonloop} (h : M.parallel_nl e f) :
  M.parallel e.1 f.1 :=
⟨e.2,f.2,h⟩

lemma parallel_iff_parallel_nl {M : matroid α} {e f : α} :
  M.parallel e f ↔ ∃ (he : M.is_nonloop e) (hf : M.is_nonloop f), M.parallel_nl ⟨e,he⟩ ⟨f,hf⟩:=
by tidy

/-- parallel_nl in dual -/
def series (M : matroid α) (e f : nonloop (dual M)) : Prop :=
  (dual M).parallel_nl e f

lemma parallel_nl_refl (M : matroid α) :
  reflexive M.parallel_nl:=
λ e, by {unfold parallel_nl, rw pair_eq_singleton, exact e.property}

lemma parallel_nl_symm (M : matroid α) :
  symmetric M.parallel_nl:=
λ x y, by {simp_rw [parallel_nl, pair_comm], tauto,}

lemma parallel_nl_iff_dep {M: matroid α} {e f : nonloop M} :
  M.parallel_nl e f ↔ (e = f ∨ M.is_dep {e,f}) :=
begin
  unfold parallel_nl, rw dep_iff_r,  refine ⟨λ h, ((or_iff_not_imp_left.mpr (λ hne, _))), λ h, _ ⟩,
  have := size_pair (λ h', hne (subtype.ext h')) ,
  rw h, unfold_coes at *, linarith,
  cases h, rw [h, pair_eq_singleton], exact f.property,
  have := rank_two_nonloops_lb e f,
  have := size_pair_ub e.1 f.1,
  unfold_coes at *, rw ←int.le_sub_one_iff at h, linarith,
end

lemma parallel_nl_iff_cct {M: matroid α} {e f : nonloop M} :
  M.parallel_nl e f ↔ (e = f ∨ M.is_circuit {e,f}) :=
begin
  refine ⟨λ h, _, λ h, (parallel_nl_iff_dep.mpr (or.imp_right _ h : (e = f) ∨ is_dep M ({e,f})))⟩,
  replace h := parallel_nl_iff_dep.mp h, cases h, exact or.inl h, apply or_iff_not_imp_left.mpr, intro h',
  refine ⟨h,λ Y hY, _⟩, rcases ssubset_pair hY,
  rw h_1, exact empty_indep M,  unfold_coes at h_1,  cases h_1;
  {rw h_1, apply coe_nonloop_indep,},
  apply circuit_dep,
end

lemma parallel_nl_trans (M : matroid α) :
  transitive M.parallel_nl :=
begin
  intros e f g hef hfg, unfold parallel_nl at *,
  have := M.rank_submod ({e,f}) ({f,g}), rw [hef, hfg] at this,
  have h1 : 1 ≤ M.r (({e,f}) ∩ ({f,g})),
  {rw ←rank_coe_nonloop f, refine M.rank_mono (subset_inter _ _ ); simp, },
  have h2 := M.rank_mono (_ : ({e,g} : set α)  ⊆ {e,f} ∪ {f,g}), swap,
  {intro x, simp, tauto,  },
  linarith [(rank_two_nonloops_lb e g)],
end

lemma parallel_refl_nonloop {M : matroid α} {e : α} (h : M.is_nonloop e) :
  M.parallel e e :=
⟨h,h,by rwa [pair_eq_singleton]⟩

lemma parallel_iff_dep {M : matroid α} {e f : α} (he : M.is_nonloop e) (hf : M.is_nonloop f) :
  M.parallel e f ↔ (e = f) ∨ M.is_dep {e,f} :=
begin
  split,
  { rintros ⟨-,-,hef⟩,
    by_contra hn, push_neg at hn, cases hn with hne hef',
    rw [←indep_iff_not_dep, indep_iff_r, hef, size_pair hne] at hef',
    norm_num at hef', },
  rintros (heq | hef), rw heq, exact parallel_refl_nonloop hf,
  rw [dep_iff_r, ←int.le_sub_one_iff] at hef,
  refine ⟨he,hf,_⟩,
  linarith [nonloop_iff_r.mp he, M.rank_mono (by tidy: {e} ⊆ {e,f}), size_pair_ub e f],
end

lemma parallel_iff_cct {M: matroid α} {e f : α} (he : M.is_nonloop e) (hf : M.is_nonloop f) :
  M.parallel e f ↔ (e = f ∨ M.is_circuit {e,f}) :=
begin
  rw parallel_iff_dep he hf, split,
  { rintros (heq | hdep), left, assumption, right,
    rw circuit_iff_i,
    refine ⟨dep_iff_not_indep.mp hdep, λ Y hY, _⟩,
    rcases ssubset_pair hY with (rfl | rfl | rfl), apply M.empty_indep,
    all_goals {rwa ←nonloop_iff_indep}, },
  rintros (heq | hef), left, assumption, right,
  apply circuit_dep hef,
end

lemma parallel_of_nonloop_dep {M : matroid α} {e f : α} (he : M.is_nonloop e) (hf : M.is_nonloop f) (h : M.is_dep {e,f}) :
  M.parallel e f :=
by {rw parallel_iff_dep he hf,right, assumption,  }

lemma parallel_of_circuit {M : matroid α} {e f : α} (hef : e ≠ f) (h : M.is_circuit {e,f}) :
  M.parallel e f :=
begin
  rw parallel_iff_cct, right, assumption, all_goals
  { rw [nonloop_iff_not_loop, loop_iff_circuit], by_contra hn,
    apply circuit_not_ssubset_circuit hn h,},
  apply singleton_ssubset_pair_left hef,
  apply singleton_ssubset_pair_right hef,
end

lemma parallel_trans (M : matroid α) :
  transitive M.parallel :=
begin
  rintros e f g ⟨he,hf,hef⟩ ⟨-,hg,hfg⟩,-- unfold parallel at *,
  refine ⟨he,hg,_⟩,
  have hef' : M.parallel_nl ⟨e,he⟩ ⟨f,hf⟩:= hef,
  have hfg' : M.parallel_nl ⟨f,hf⟩ ⟨g,hg⟩ := hfg,
  exact parallel_nl_trans M hef' hfg',
end

lemma parallel_symm (M : matroid α) :
  symmetric M.parallel :=
by {rintros e f ⟨he,hf,hef⟩, refine ⟨hf,he,_⟩, rwa pair_comm}

@[symm] lemma parallel_symm' {M : matroid α} {e f : α} (hef : M.parallel e f) :
  M.parallel f e :=
parallel_symm M hef

lemma parallel_comm {M : matroid α} {e f : α} :
  M.parallel e f ↔ M.parallel f e :=
⟨λ h, by {symmetry, exact h}, λ h, by {symmetry, exact h}⟩

@[trans] lemma parallel_trans' {M : matroid α} {e f g : α} (hef : M.parallel e f) (hfg : M.parallel f g) :
  M.parallel e g :=
parallel_trans M hef hfg

lemma parallel_nl_is_equivalence (M : matroid α) :
  equivalence M.parallel_nl :=
  ⟨M.parallel_nl_refl, M.parallel_nl_symm, M.parallel_nl_trans⟩

lemma series_is_equivalence (M : matroid α) :
  equivalence M.series :=
parallel_nl_is_equivalence M.dual

/-- the parallel class containing e. Empty if e is a loop -/
def parallel_cl (M : matroid α) (e : α) : set α :=
  {a : α | M.parallel a e}

lemma parallel_cl_loop_empty {M : matroid α} {e : α} (he : M.is_loop e) :
  M.parallel_cl e = ∅ :=
by {ext, simp [parallel_cl, parallel, loop_iff_not_nonloop.mp he]}

lemma parallel_cl_nonempty_of_nonloop {M : matroid α} {e : α} (he : M.is_nonloop e) :
  (M.parallel_cl e).nonempty :=
⟨e, by {rw [parallel_cl, mem_set_of_eq], exact parallel_refl_nonloop he,  }⟩

lemma mem_parallel_cl {M : matroid α} {e f : α} :
  e ∈ M.parallel_cl f ↔ M.parallel e f :=
by simp_rw [parallel_cl, mem_set_of_eq]

lemma parallel_cl_eq_empty_iff_loop {M : matroid α} {e : α} :
  M.parallel_cl e = ∅ ↔ M.is_loop e :=
begin
  refine ⟨λ h, by_contra (λ hn, _), λ h, parallel_cl_loop_empty h⟩,
  rw ← nonloop_iff_not_loop at hn,
  rw empty_iff_has_no_mem at h,
  apply h e,
  rw mem_parallel_cl,
  apply parallel_refl_nonloop hn,
end

def is_parallel_class (M : matroid α) (P : set α)  :=
  ∃ e,  M.is_nonloop e ∧ P = M.parallel_cl e

def parallel_class (M : matroid α) : Type := {X : set α // M.is_parallel_class X}

/-- function taking a nonloop to its parallel class -/
def parallel_cl' {M : matroid α} (e : M.nonloop) : M.parallel_class :=
  ⟨M.parallel_cl e, ⟨e,⟨e.property, rfl⟩⟩⟩

lemma parallel_cl_eq_of_parallel {M : matroid α} {e f : α} (hef : M.parallel e f) :
   M.parallel_cl e = M.parallel_cl f :=
begin
  ext, rw [mem_parallel_cl, mem_parallel_cl],
  have := parallel_symm' hef,
  split; {intro, transitivity; assumption,},
end

lemma parallel_of_parallel_cl_eq_left {M : matroid α} {e f : α} (he : M.is_nonloop e)
(hef : M.parallel_cl e = M.parallel_cl f) :
  M.parallel e f :=
by {rw [← mem_parallel_cl, ← hef, mem_parallel_cl], apply parallel_refl_nonloop he}

lemma parallel_iff_parallel_cl'_eq {M : matroid α} {e f : M.nonloop} :
  M.parallel e f ↔ parallel_cl' e = parallel_cl' f  :=
begin
  simp_rw [parallel_cl', parallel_cl, subtype.mk_eq_mk, ext_iff, mem_set_of_eq],
  refine ⟨λ h x, (have h' : _ := parallel_symm M h, ⟨λ hxe, _, λ hxf, _⟩), λ h, _⟩,
  repeat {transitivity, assumption, assumption, },
  { apply (h e).mp, apply parallel_refl_nonloop e.property},
end

instance coe_parallel_class_to_set {M : matroid α} : has_coe (M.parallel_class) (set α) := ⟨subtype.val⟩
instance parallel_class_fintype {M : matroid α} : fintype M.parallel_class :=
by {unfold parallel_class, apply_instance}

lemma parallel_of_mems_parallel_class {M : matroid α} {P : M.parallel_class} {e f : α}
(he : e ∈ (P : set α)) (hf : f ∈ (P : set α)) :
M.parallel e f :=
begin
  cases P with P hP,
  obtain ⟨x, ⟨hx, rfl⟩⟩ := hP,
  rw [subtype.coe_mk, mem_parallel_cl] at he hf,
  transitivity, assumption, symmetry, assumption,
end

lemma nonloop_of_mem_parallel_class {M : matroid α} {P : set α} {e : α} (heP : e ∈ P) (h : M.is_parallel_class P) :
  M.is_nonloop e :=
by {rcases h with ⟨f, ⟨hf,rfl⟩⟩, rw mem_parallel_cl at heP, exact heP.1}

lemma parallel_cl_eq_cl_minus_loops (M : matroid α) (e : α) :
  M.parallel_cl e = M.cl {e} \ M.loops :=
begin
  by_cases he: M.is_nonloop e, swap,
  { ext x, rw [mem_diff, mem_parallel_cl],
    refine ⟨λ h, false.elim (he h.2.1), λ h, false.elim _⟩,
    rw [←loop_iff_not_nonloop, loop_iff_r] at he,
    rw [mem_cl_iff_r,he, ←nonloop_iff_not_mem_loops, nonloop_iff_r] at h,
    linarith[h.1, h.2, M.rank_mono_union_right {e} {x}], },
  ext x,
  simp only [mem_diff, mem_set_of_eq, mem_cl_iff_r, rank_nonloop he, union_singleton, ←nonloop_iff_not_mem_loops],
  split, { rintros ⟨hx,he,hxe⟩, split; assumption,  },
  rintros ⟨hxe,hx⟩, exact ⟨hx,he,hxe⟩,
end

lemma rank_parallel_cl {M : matroid α} {e : α} (he : M.is_nonloop e) :
  M.r (M.parallel_cl e) = 1 :=
by rwa [parallel_cl_eq_cl_minus_loops, rank_eq_rank_diff_rank_zero _ M.rank_loops, rank_cl, ←nonloop_iff_r]

lemma parallel_class_eq_cl_nonloop_diff_loops {M : matroid α} {P : set α} :
  M.is_parallel_class P ↔ P.nonempty ∧ (∀ e ∈ P, P = M.cl {e} \ M.loops ) :=
begin
  simp_rw [←parallel_cl_eq_cl_minus_loops, is_parallel_class],
  split,
  { rintros ⟨e,he,rfl⟩, refine ⟨⟨e,_⟩, _⟩, apply parallel_refl_nonloop, assumption,
    intros f hf, ext x, simp only [mem_parallel_cl] at *, have := parallel_symm' hf,
    split; {intro h, transitivity; assumption}, },
  rintros ⟨⟨e,he⟩,hP⟩,
  specialize hP e he, rw [hP, mem_parallel_cl] at he,
  exact ⟨e, he.1, hP⟩,
end

/-- the natural equivalence between points and parallel classes in a matroid -/
def parallel_class_point_equiv {M : matroid α} :
  M.parallel_class ≃ M.point :=
{ to_fun := λ P, ⟨P.val ∪ M.loops,
  let ⟨e,he,h⟩ := P.property in by
  { simp_rw [h, point_iff_cl_nonloop, parallel_cl_eq_cl_minus_loops, diff_union_self, union_comm,
    subset_iff_union_eq_left.mp (M.loops_subset_cl {e})],
    exact ⟨e,he,rfl⟩, }⟩,
inv_fun := λ P, ⟨P.val \ M.loops,
  let ⟨e,he,hP⟩ := point_iff_cl_nonloop.mp P.2 in by
  { rw [hP, ← parallel_cl_eq_cl_minus_loops],
    refine ⟨e, he, rfl⟩,}⟩,
left_inv := λ P, let ⟨e,he,h⟩ := P.2 in by
  { simp_rw [h, union_diff_right, parallel_cl_eq_cl_minus_loops, diff_diff, union_self,
    ← parallel_cl_eq_cl_minus_loops, ← h], simp, },
right_inv := λ P, let ⟨e,he,hP⟩ := point_iff_cl_nonloop.mp P.2 in by
  { dsimp only, simp_rw [hP, diff_union_self, union_comm,
    subset_iff_union_eq_left.mp (M.loops_subset_cl {e}), ←hP],simp, }}

lemma parallel_class_nonempty {M : matroid α} (P : M.parallel_class) :
  set.nonempty (P : set α) :=
(parallel_class_eq_cl_nonloop_diff_loops.mp P.property).1

lemma nonloop_of_parallel_cl_is_parallel_class {M : matroid α} {e : α} {P : M.parallel_class} (h : (P : set α) = (M.parallel_cl e)) :
  M.is_nonloop e :=
begin
  by_contra hn,
  rw parallel_cl_loop_empty (loop_iff_not_nonloop.mpr hn) at h,
  exact nonempty.ne_empty (parallel_class_nonempty P) h,
end

lemma parallel_class_eq_parallel_cl_of_mem {M : matroid α} {P : M.parallel_class} {e : α} (he : e ∈ (P : set α)) :
  (P : set α) = M.parallel_cl e :=
begin
  obtain ⟨-, h'⟩ := parallel_class_eq_cl_nonloop_diff_loops.mp P.property,
  simp_rw [←parallel_cl_eq_cl_minus_loops, subtype.val_eq_coe] at h',
  rwa ←(h' e he),
end

lemma parallel_class_is_cl_diff_loops {M : matroid α} (P : M.parallel_class) :
  ∃ e ∈ (P : set α), M.is_nonloop e ∧ (P : set α) = M.cl {e} \ M.loops :=
begin
  rcases parallel_class_eq_cl_nonloop_diff_loops.mp P.property with ⟨⟨e,he⟩,hP⟩,
  exact ⟨e,he,nonloop_of_mem_parallel_class he P.property, hP e he⟩,
end

lemma parallel_class_is_parallel_cl_nonloop {M : matroid α} (P : M.parallel_class) :
  ∃ e ∈ (P : set α), M.is_nonloop e ∧ (P : set α) = M.parallel_cl e :=
by {have := parallel_class_is_cl_diff_loops P, simp_rw ←parallel_cl_eq_cl_minus_loops at this, assumption}

lemma parallel_class_is_parallel_cl {M : matroid α} (P : M.parallel_class) :
  ∃ e, (P : set α) = M.parallel_cl e :=
by {obtain ⟨e,he,he'⟩ := parallel_class_is_parallel_cl_nonloop P, use ⟨e,he'.2⟩,   }

lemma mem_parallel_class_iff_parallel_cl {M : matroid α} {e : α} {P : M.parallel_class} :
  e ∈ (P : set α) ↔ (P : set α) = M.parallel_cl e :=
begin
  refine ⟨λ h, parallel_class_eq_parallel_cl_of_mem h, λ h, _⟩,
  rw [h, parallel_cl, mem_set_of_eq],
  exact parallel_refl_nonloop (nonloop_of_parallel_cl_is_parallel_class h),
end

lemma rank_parallel_class (M : matroid α) (P : M.parallel_class ) :
  M.r P = 1 :=
by {obtain ⟨e,heP,he, hP⟩ := parallel_class_is_parallel_cl_nonloop P, rw hP, apply rank_parallel_cl he}

lemma parallel_class_eq_of_nonempty_inter {M : matroid α} {P₁ P₂ : M.parallel_class} (h : set.nonempty (P₁ ∩ P₂ : set α)) :
  P₁ = P₂ :=
begin
  rcases h with ⟨x,hx⟩,
  rcases parallel_class_is_parallel_cl_nonloop P₁ with ⟨e₁,he₁P,⟨he₁,h₁⟩⟩,
  rcases parallel_class_is_parallel_cl_nonloop P₂ with ⟨e₂,he₂P,⟨he₂,h₂⟩⟩,

  rw [mem_inter_iff, h₁,h₂] at hx,
  have h₁₂ : M.parallel e₁ e₂, {transitivity x, symmetry, exact hx.1, exact hx.2},
  have h₂₁ := parallel_symm' h₁₂,
  rcases P₁ with ⟨P₁, hP₁⟩, rcases P₂ with ⟨P₂, hP₂⟩, rw subtype.mk_eq_mk,
  rw subtype.coe_mk at *, subst h₁, subst h₂,
  ext y, simp only [mem_parallel_cl],
  split; {intro h, symmetry, transitivity, assumption, symmetry, assumption,},
end

lemma disj_of_distinct_parallel_classes {M : matroid α} {P₁ P₂ : M.parallel_class} (h : P₁ ≠ P₂) :
  disjoint (P₁ : set α) (P₂ : set α) :=
begin
  by_contra hn, rcases not_disjoint_iff.mp hn with ⟨e,⟨h₁,h₂⟩⟩,
  exact h (parallel_class_eq_of_nonempty_inter ⟨e,mem_inter h₁ h₂⟩),
end

lemma parallel_class_eq_of_mem_both {M : matroid α} {P₁ P₂ : M.parallel_class} {x : α}
  (h₁ : x ∈ (P₁ : set α)) (h₂ : x ∈ (P₂ : set α)) :
  P₁ = P₂ :=
parallel_class_eq_of_nonempty_inter ⟨x,mem_inter h₁ h₂⟩

/-- the set of parallel classes of M -/
def parallel_classes_set (M : matroid α) : set (set α) :=
  range (coe : M.parallel_class → set α)

lemma parallel_class_set_disjoint (M : matroid α) :
  pairwise_disjoint M.parallel_classes_set :=
begin
  rintros S hS T hT hST,
  rcases mem_range.mp hS with ⟨P₁,rfl⟩,
  rcases mem_range.mp hT with ⟨P₂,rfl⟩,
  have h : P₁ ≠ P₂ := λ hP₁P₂, by {rw hP₁P₂ at hST, tauto, },
  apply disj_of_distinct_parallel_classes h,
end

/-- the union of a set of parallel classes of M -/
def union_parallel_classes {M : matroid α} (S : set M.parallel_class) : set α :=
  ⋃₀ (coe '' S)

lemma mem_union_parallel_classes {M : matroid α} {S : set M.parallel_class} {e : α} :
  e ∈ union_parallel_classes S ↔ ∃ (he : M.is_nonloop e), (parallel_cl' ⟨e,he⟩) ∈ S  :=
begin
  simp_rw [union_parallel_classes, mem_sUnion], split,
  { rintros ⟨X, hX, heX⟩,
    obtain ⟨P,hP₁,rfl⟩ := (mem_image _ _ _).mp hX,
    use nonloop_of_mem_parallel_class heX P.property, convert hP₁,
    unfold parallel_cl', simp only [subtype.coe_mk],
    cases P, simp only [subtype.mk_eq_mk],
    rw ←(parallel_class_eq_parallel_cl_of_mem heX), simp},
  rintros ⟨he, heP⟩,
  refine ⟨M.parallel_cl e, _,_⟩,
  { simp only [mem_image], exact ⟨_, heP,by simp [parallel_cl']⟩},
  simp [parallel_cl, mem_set_of_eq, parallel_refl_nonloop he],
end

lemma union_union_parallel_classes {M : matroid α} (S₁ S₂ : set M.parallel_class) :
  union_parallel_classes (S₁ ∪ S₂) = union_parallel_classes S₁ ∪ union_parallel_classes S₂ :=
by simp_rw [union_parallel_classes, image_union, sUnion_union]

lemma inter_union_parallel_classes {M : matroid α} (S₁ S₂ : set M.parallel_class) :
  union_parallel_classes (S₁ ∩ S₂) = union_parallel_classes S₁ ∩ union_parallel_classes S₂ :=
begin
  simp_rw [union_parallel_classes, ←image_inter (subtype.coe_injective)],
  apply pairwise_disjoint_inter_sUnion (parallel_class_set_disjoint M);
  apply image_subset_range,
end

--lemma intersecting_parallel_nl_classes_eq {M : matroid α} (S : set M.parallel_nl_class) : set α :=

/- property that a map sends parallel classes to representatives -/
def is_transversal {M : matroid α} (f : M.parallel_class → α) :=
  ∀ P, M.parallel_cl (f P) = (P : set α)

def transversal (M : matroid α) :=
  { f : M.parallel_class → α // is_transversal f}

instance coe_transversal {M : matroid α} : has_coe_to_fun M.transversal := { F := _, coe := subtype.val }

lemma transversal_def {M : matroid α} (f : M.transversal) (P : M.parallel_class) :
  M.parallel_cl (f P) = (P : set α) :=
(f.property P)

lemma transversal_def' {M : matroid α} (f : M.transversal){P : set α} (hP : M.is_parallel_class P) :
  M.parallel_cl (f ⟨P,hP⟩) = P :=
f.property ⟨P,hP⟩

lemma nonloop_of_range_transversal {M : matroid α} (f : M.transversal) (P : M.parallel_class) :
  M.is_nonloop (f P) :=
nonloop_of_parallel_cl_is_parallel_class (f.property P).symm

lemma exists_transversal (M : matroid α) :
  ∃ (f : M.parallel_class → α), is_transversal f :=
⟨λ P, (classical.some (parallel_class_is_parallel_cl P)),
 λ P, (classical.some_spec (parallel_class_is_parallel_cl P)).symm ⟩

def choose_transversal (M : matroid α) : M.transversal  :=
classical.indefinite_description _ (M.exists_transversal)

lemma transversal_subset_union {M : matroid α} (f : M.transversal) (S : set M.parallel_class) :
  f '' S ⊆ union_parallel_classes S :=
begin
  intros x hx,
  obtain ⟨P, hP, rfl⟩ := (mem_image _ _ _).mp hx,
  rw mem_union_parallel_classes,
  refine ⟨nonloop_of_range_transversal f _,_⟩,

  simp_rw [parallel_cl', subtype.coe_mk, transversal_def f P],
  convert hP, cases P, simp,
end

lemma eq_of_parallel_range_transversal {M : matroid α} {P Q : M.parallel_class} (f : M.transversal)
(h : M.parallel (f P) (f Q)) :
  P = Q :=
begin
  cases P with P hP, cases Q with Q hQ,
  rw [subtype.mk_eq_mk, ←transversal_def' f hP, ←transversal_def' f hQ],
  have := parallel_symm' h,
  ext, simp_rw mem_parallel_cl,
  split; {intro h', transitivity, assumption, assumption,},
end

lemma transversal_inj {M : matroid α} (f : M.transversal) :
  function.injective f :=
begin
  intros P Q hPQ,
  apply eq_of_parallel_range_transversal f, rw hPQ,
  apply parallel_refl_nonloop (nonloop_of_range_transversal _ _),
end

lemma size_image_transversal {M : matroid α} (f : M.transversal)
(S : set M.parallel_class) :
  size (f '' S) = size S :=
size_image_inj (transversal_inj f) S

lemma rank_img_transversal {M : matroid α} (f : M.transversal)
(S : set M.parallel_class) :
  M.r (union_parallel_classes S) = M.r (f '' S) :=
begin
  refine (rank_eq_rank_of_parallel_ext (transversal_subset_union f _) (λ y hy, _)).symm,
  rcases y with ⟨y,hy'⟩,
  rcases mem_union_parallel_classes.mp hy' with ⟨hy_nl,hP⟩,
  set PY := parallel_cl' ⟨y,hy_nl⟩ with hPY,
  refine ⟨ ⟨f PY, _ ⟩, _⟩, apply mem_image_of_mem _ hP,
  simp_rw [subtype.coe_mk, parallel_comm, ←mem_parallel_cl, transversal_def f PY, hPY, parallel_cl', subtype.coe_mk, mem_parallel_cl],
  apply parallel_refl_nonloop hy_nl,
end

end matroid


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

! This file was ported from Lean 3 source module order.category.CompleteLat
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Category.BddLat
import Mathbin.Order.Hom.CompleteLattice

/-!
# The category of complete lattices

This file defines `CompleteLat`, the category of complete lattices.
-/

universe u

open CategoryTheory

/-- The category of complete lattices. -/
def CompleteLat :=
  Bundled CompleteLattice
#align CompleteLat CompleteLat

namespace CompleteLat

instance : CoeSort CompleteLat (Type _) :=
  Bundled.hasCoeToSort

instance (X : CompleteLat) : CompleteLattice X :=
  X.str

/-- Construct a bundled `CompleteLat` from a `complete_lattice`. -/
def of (α : Type _) [CompleteLattice α] : CompleteLat :=
  Bundled.of α
#align CompleteLat.of CompleteLat.of

@[simp]
theorem coe_of (α : Type _) [CompleteLattice α] : ↥(of α) = α :=
  rfl
#align CompleteLat.coe_of CompleteLat.coe_of

instance : Inhabited CompleteLat :=
  ⟨of PUnit⟩

instance : BundledHom @CompleteLatticeHom
    where
  toFun _ _ _ _ := coeFn
  id := @CompleteLatticeHom.id
  comp := @CompleteLatticeHom.comp
  hom_ext X Y _ _ := FunLike.coe_injective

instance : LargeCategory.{u} CompleteLat :=
  BundledHom.category CompleteLatticeHom

instance : ConcreteCategory CompleteLat :=
  BundledHom.concreteCategory CompleteLatticeHom

instance hasForgetToBddLat : HasForget₂ CompleteLat BddLat
    where
  forget₂ :=
    { obj := fun X => BddLat.of X
      map := fun X Y => CompleteLatticeHom.toBoundedLatticeHom }
  forget_comp := rfl
#align CompleteLat.has_forget_to_BddLat CompleteLat.hasForgetToBddLat

/-- Constructs an isomorphism of complete lattices from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : CompleteLat.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := e
  inv := e.symm
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align CompleteLat.iso.mk CompleteLat.Iso.mk

/-- `order_dual` as a functor. -/
@[simps]
def dual : CompleteLat ⥤ CompleteLat where
  obj X := of Xᵒᵈ
  map X Y := CompleteLatticeHom.dual
#align CompleteLat.dual CompleteLat.dual

/-- The equivalence between `CompleteLat` and itself induced by `order_dual` both ways. -/
@[simps Functor inverse]
def dualEquiv : CompleteLat ≌ CompleteLat :=
  Equivalence.mk dual dual
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
#align CompleteLat.dual_equiv CompleteLat.dualEquiv

end CompleteLat

theorem completeLat_dual_comp_forget_to_bddLat :
    CompleteLat.dual ⋙ forget₂ CompleteLat BddLat = forget₂ CompleteLat BddLat ⋙ BddLat.dual :=
  rfl
#align CompleteLat_dual_comp_forget_to_BddLat completeLat_dual_comp_forget_to_bddLat


def myid (a : α) := a -- works
set_option relaxedAutoImplicit false
#check myid 10
#check myid true

theorem ex1 (a : α) : myid a = a := rfl

def cnst (b : β) : α → β := fun _ => b -- works

theorem ex2 (b : β) (a : α) : cnst b a = b := rfl

def Vec (α : Type) (n : Nat) := { a : Array α // a.size = n }

def mkVec : Vec α 0 := ⟨ #[], rfl ⟩

def Vec.map (xs : Vec α n) (f : α → β) : Vec β n :=
  ⟨ xs.val.map f, sorry ⟩

/- unbound implicit locals must be greek or lower case letters followed by numerical digits -/
def Vec.map2 (xs : Vec α size /- error: unknown identifier size -/) (f : α → β) : Vec β n :=
  ⟨ xs.val.map f, sorry ⟩

set_option autoImplicit false in
def Vec.map3 (xs : Vec α n) (f : α → β) : Vec β n := -- Errors, unknown identifiers 'α', 'n', 'β'
  ⟨ xs.val.map f, sorry ⟩

def double [Add α] (a : α) := a + a

variable (xs : Vec α n) -- works

def f := xs

#check f

#check f mkVec

#check f (α := Nat) mkVec

def g (a : α) := xs.val.push a

theorem ex3 : g ⟨#[0], rfl⟩ 1 = #[0, 1] :=
  rfl

inductive Tree (α β : Type) :=
  | leaf1 : α → Tree α β
  | leaf2 : β → Tree α β
  | node : Tree α β → Tree α β → Tree α β

inductive TreeElem1 : α → Tree α β → Prop
  | leaf1     : (a : α) → TreeElem1 a (Tree.leaf1 (β := β) a)
  | nodeLeft  : (a : α) → (left : Tree α β) → (right : Tree α β) → TreeElem1 a left  → TreeElem1 a (Tree.node left right)
  | nodeRight : (a : α) → (left : Tree α β) → (right : Tree α β) → TreeElem1 a right → TreeElem1 a (Tree.node left right)

inductive TreeElem2 : β → Tree α β → Prop
  | leaf2     : (b : β) → TreeElem2 b (Tree.leaf2 (α := α) b)
  | nodeLeft  : (b : β) → (left : Tree α β) → (right : Tree α β) → TreeElem2 b left  → TreeElem2 b (Tree.node left right)
  | nodeRight : (b : β) → (left : Tree α β) → (right : Tree α β) → TreeElem2 b right → TreeElem2 b (Tree.node left right)

namespace Ex1

def findSomeRevM? [Monad m] (as : Array α) (f : α → m (Option β)) : m (Option β) :=
  pure none

def findSomeRev? (as : Array α) (f : α → Option β) : Option β :=
  Id.run <| findSomeRevM? as f

end Ex1

def apply {α : Type u₁} {β : α → Type u₂} (f : (a : α) → β a) (a : α) : β a :=
  f a

def pair (a : α₁) := (a, a)


namespace SciLean

-- This is like `ExactSolution` but it is intended to be used in automation.
inductive AutoExactSolution {α : Type _} : (α → Prop) → Type _ where
| exact {spec : α → Prop} (a : α) (h : spec a) : AutoExactSolution spec

def AutoImpl {α} (a : α) := AutoExactSolution λ x => x = a

@[inline]
def AutoImpl.val {α} {a : α} (x : AutoImpl a) : α :=
match x with
| .exact val _ => val

def AutoImpl.finish {α} {a : α} : AutoImpl a := .exact a rfl

theorem AutoImpl.impl_eq_spec (x : AutoImpl a) : a = x.val :=
by
  cases x; rename_i a' h;
  simp[AutoImpl.val, val, h]
  done

-- I don't think think this can be proven. Can it lead to contradiction?
axiom AutoImpl.injectivity_axiom {α} (a b : α) : (AutoImpl a = AutoImpl b) → (a = b)

-- Do we really need AutoImpl.injectivity_axiom?
@[simp] theorem AutoImpl.normalize_val {α : Type u} (a b : α) (h : (AutoImpl a = AutoImpl b))
  : AutoImpl.val (Eq.mpr h (AutoImpl.finish (a:=b))) = b :=
by
  have h' : a = b := by apply AutoImpl.injectivity_axiom; apply h
  revert h; rw[h']
  simp[val,finish,Eq.mpr]
  done

-- This is a new version of `AutoImpl.normalize_val`, some tactic uses `cast` instead of `Eq.mpr` now
-- TODO: clean this up
@[simp] theorem AutoImpl.normalize_val' {α : Type u} (a b : α) (h : (AutoImpl a = AutoImpl b))
  : AutoImpl.val (cast h (AutoImpl.finish (a:=a))) = a :=
by sorry
  -- have h' : a = b := by apply AutoImpl.injectivity_axiom; apply h
  -- revert h; rw[h']
  -- simp[val,finish,Eq.mpr]
  -- done

example {α : Type} (a b : α) (A : (Σ' x, x = a)) (h : (Σ' x, x = a) = (Σ' x, x = b))
  : (a = b) ↔ (h ▸ A).1 = A.1 :=
by
  constructor
  {
    intro eq; rw[A.2]; conv => rhs; rw [eq]
    apply (h ▸ A).2
  }
  {
    intro eq; rw[← A.2]; rw[← eq]
    apply (h ▸ A).2
  }

open Lean.Parser.Tactic.Conv

-- TODO: turn `rewrite_by` to an elaborator and do not use `AutoImpl`
syntax term:max "rewrite_by" convSeq : term

macro_rules
  | `($x rewrite_by $rw:convSeq) =>
    `((by (conv => enter[1]; ($rw)); (apply AutoImpl.finish) : AutoImpl $x).val)


lemma bool.eq_iff : ∀ (x y : bool), x = y ↔ (x = tt ∧ y = tt) ∨ (x = ff ∧ y = ff)
| ff ff := ⟨(λ _, or.inr ⟨rfl,rfl⟩),(λ _, rfl)⟩
| ff tt :=
  {
    mp := λ h, bool.no_confusion h,
    mpr := λ h, or.elim h (λ k, k.left) (λ k, k.right.symm)
  }
| tt ff :=
  {
    mp := λ h, bool.no_confusion h,
    mpr := λ h, or.elim h (λ k, k.right.symm) (λ k, k.left)
  }
| tt tt := ⟨(λ _, or.inl ⟨rfl,rfl⟩),(λ _, rfl)⟩

lemma bool.neq_iff : ∀ (x y : bool), x ≠ y ↔ (x = tt ∧ y = ff) ∨ (x = ff ∧ y = tt)
| ff ff :=
  {
    mp := λ h, false.elim (h rfl),
    mpr := λ h, or.elim h
             (λ k, bool.no_confusion k.left)
             (λ k, bool.no_confusion k.right)
  }
| ff tt := ⟨(λ _, or.inr ⟨rfl,rfl⟩),(λ _ h, bool.no_confusion h)⟩
| tt ff := ⟨(λ _, or.inl ⟨rfl,rfl⟩),(λ _ h, bool.no_confusion h)⟩
| tt tt :=
  {
    mp := λ h, false.elim (h rfl),
    mpr := λ h, or.elim h
             (λ k, bool.no_confusion k.right)
             (λ k, bool.no_confusion k.left)
  }

lemma eq_tt_of_not_eq_ff_safe : ∀ (x : bool), x ≠ ff → x = tt
| ff h := false.elim $ h rfl
| tt h := rfl

lemma eq_ff_of_not_eq_tt_safe : ∀ (x : bool), x ≠ tt → x = ff
| ff h := rfl
| tt h := false.elim $ h rfl

lemma neq_tt_iff : ∀ (x : bool), x ≠ tt ↔ x = ff
| ff := ⟨(λ _, rfl),(λ _ h, bool.no_confusion h)⟩
| tt := ⟨(λ h, false.elim (h rfl)),(λ h, bool.no_confusion h)⟩

lemma neq_ff_iff : ∀ (x : bool), x ≠ ff ↔ x = tt
| ff := ⟨(λ h, false.elim (h rfl)),(λ h, bool.no_confusion h)⟩
| tt := ⟨(λ _, rfl),(λ _ h, bool.no_confusion h)⟩

/- Lemmas on `bnot` -/
lemma eq_tt_of_bnot_eq_ff_safe : ∀ (x : bool), bnot x = ff → x = tt
| tt h := rfl
| ff h := bool.no_confusion h

lemma eq_ff_of_bnot_eq_tt_safe : ∀ (x : bool), bnot x = tt → x = ff
| tt h := bool.no_confusion h
| ff h := rfl

lemma bnot_eq_tt_iff : ∀ (x : bool), bnot x = tt ↔ x = ff
| tt := ⟨λ h, bool.no_confusion h, λ h, bool.no_confusion h⟩
| ff := ⟨λ _, rfl, λ _, rfl⟩

lemma bnot_eq_ff_iff : ∀ (x : bool), bnot x = ff ↔ x = tt
| tt := ⟨λ _, rfl, λ _, rfl⟩
| ff := ⟨λ h, bool.no_confusion h, λ h, bool.no_confusion h⟩

/- Lemmas on `bxor` -/
@[simp]
 lemma ff_bxor_safe : ∀ (a : bool), bxor ff a = a
| ff := rfl
| tt := rfl

@[simp]
lemma bxor_ff_safe : ∀ (a : bool), bxor a ff = a
| ff := rfl
| tt := rfl

@[simp]
lemma tt_bxor_safe : ∀ (a : bool), bxor tt a = bnot a
| tt := rfl
| ff := rfl

@[simp]
lemma bxor_tt_safe : ∀ (a : bool), bxor a tt = bnot a
| tt := rfl
| ff := rfl

@[simp]
lemma bxor_self_safe : ∀ (a : bool), bxor a a = ff
| ff := rfl
| tt := rfl

@[simp] lemma bxor_comm : ∀ a b, bxor a b = bxor b a :=
  by intros; cases b; cases a; refl

@[simp] lemma bxor_assoc : ∀ a b c, bxor (bxor a b) c = bxor a (bxor b c) :=
  by intros; cases c; cases b; cases a; refl

lemma bxor_eq_tt_iff : ∀ a b, bxor a b = tt ↔ a ≠ b
| ff ff := ⟨(λ h, bool.no_confusion h), (λ h, false.elim (h rfl))⟩
| ff tt := ⟨(λ _ h, bool.no_confusion h), (λ _, rfl)⟩
| tt ff := ⟨(λ _ h, bool.no_confusion h), (λ _, rfl)⟩
| tt tt := ⟨(λ h, bool.no_confusion h), (λ h, false.elim (h rfl))⟩

lemma bxor_eq_ff_iff : ∀ a b, bxor a b = ff ↔ a = b
| ff ff := ⟨(λ _, rfl), (λ _, rfl)⟩
| ff tt := ⟨(λ h, bool.no_confusion h), (λ h, bool.no_confusion h)⟩
| tt ff := ⟨(λ h, bool.no_confusion h), (λ h, bool.no_confusion h)⟩
| tt tt := ⟨(λ _, rfl), (λ _, rfl)⟩


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import group_theory.group_action.defs

/-!
# Sigma instances for additive and multiplicative actions

This file defines instances for arbitrary sum of additive and multiplicative actions.

## See also

* `group_theory.group_action.pi`
* `group_theory.group_action.prod`
* `group_theory.group_action.sum`
-/

variables {ι : Type*} {M N : Type*} {α : ι → Type*}

namespace sigma

section has_scalar
variables [Π i, has_scalar M (α i)] [Π i, has_scalar N (α i)] (a : M) (i : ι) (b : α i)
  (x : Σ i, α i)

@[to_additive sigma.has_vadd] instance : has_scalar M (Σ i, α i) := ⟨λ a, sigma.map id $ λ i, (•) a⟩

@[to_additive]

instance [has_scalar M N] [Π i, is_scalar_tower M N (α i)] : is_scalar_tower M N (Σ i, α i) :=
⟨λ a b x, by { cases x, rw [smul_mk, smul_mk, smul_mk, smul_assoc] }⟩

@[to_additive] instance [Π i, smul_comm_class M N (α i)] : smul_comm_class M N (Σ i, α i) :=
⟨λ a b x, by { cases x, rw [smul_mk, smul_mk, smul_mk, smul_mk, smul_comm] }⟩

instance [Π i, has_scalar Mᵐᵒᵖ (α i)] [Π i, is_central_scalar M (α i)] :
  is_central_scalar M (Σ i, α i) :=
⟨λ a x, by { cases x, rw [smul_mk, smul_mk, op_smul_eq_smul] }⟩

/-- This is not an instance because `i` becomes a metavariable. -/
@[to_additive "This is not an instance because `i` becomes a metavariable."]
protected lemma has_faithful_smul' [has_faithful_smul M (α i)] : has_faithful_smul M (Σ i, α i) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : α i, heq_iff_eq.1 (ext_iff.1 $ h $ mk i a).2⟩

@[to_additive] instance [nonempty ι] [Π i, has_faithful_smul M (α i)] :
  has_faithful_smul M (Σ i, α i) :=
nonempty.elim ‹_› $ λ i, sigma.has_faithful_smul' i

end has_scalar

@[to_additive] instance {m : monoid M} [Π i, mul_action M (α i)] : mul_action M (Σ i, α i) :=
{ mul_smul := λ a b x, by { cases x, rw [smul_mk, smul_mk, smul_mk, mul_smul] },
  one_smul := λ x, by { cases x, rw [smul_mk, one_smul] } }

end sigma


import data.matrix.notation
import tactic.dec_trivial

import chess.playfield
import chess.piece
import chess.utils

/-!

# Definitions and theorems about a chess board

## Summary

The chess board is a set of indexed `piece`s on a `playfield`. A board is valid,
and can only be constructed, if all the pieces are present on the board, and no two
distinct (by index) pieces share the same position on the board.

## Main definitions

1. The `board` itself, which requires an indexed vector of `piece`s,
and the `playfield` which will serve as the where those pieces are placed.
Additionally, all pieces must be present on the playfield, and no two distinct (by index)
pieces can share a position on the playfield.

2. A way to reduce the board, following the indices to just the pieces. This allows
comparison of boards that are equivalent modulo permutation of indices that point to
equivalent pieces.

3. `board.piece_at`, which extracts the piece which sits on a given square.

## Implementation notes

1. A `board` requires finite dimensions for the `playfield`, finite indices, and a
finite piece set. Ideally, this should be generizable to potentially infinite types.
However, since `playfield`s are usually provided by `matrix`, which is restricted
to finite dimensions, it is easiest to define the board as finite.

2. The requirement of `decidable_eq` on the dimensions and index allows use of
`dec_trivial` to automatically infer proofs for board constraint propositions.
That means instantiation of a `board` will not require explicit proofs for the propositions.

3. The board does not define what are valid position comparisons -- the geometry of
the space is not defined other than what the `playfield` provides.

4. Currently, all pieces are constrained by the definition of a board to be present
on the playfield. That means no capturing moves and no piece introduction moves are possible.

-/

namespace chess

-- The dimensions of the board, finite and decidably equal
variables (m n : Type*) [fintype n] [decidable_eq n] [fintype m] [decidable_eq m]
-- The index associated to pieces on a playfield
variables (ι : Type*) [fintype ι] [decidable_eq ι]
-- The piece type
variables (K : Type*)

/--
A board is axiomatized as a set of indexable (ergo distinguishable) pieces
which are placed on distinct squares of a `playfield`.

No inhabited instance because the index type can be larger than the
cardinality of the playfield dimensions.
-/
@[nolint has_inhabited_instance]
structure board :=
-- The pieces the board holds, provided as an indexed vector
(pieces : ι → K)
-- The playfield on which the pieces are placed
(contents : playfield m n ι)
-- All the pieces in `pieces` are on the `contents`
-- See "Implementation details" for info about `dec_trivial`
(contains : function.surjective contents.index_at . tactic.exact_dec_trivial)
-- Different positions hold different indices
(injects : contents.some_injective . tactic.exact_dec_trivial)

namespace board

variables {m n ι K}
/-- The width of the board. Explicit argument for projection notation. -/
@[nolint unused_arguments]
def width (b : board m n ι K) : ℕ := fintype.card n
/-- The height of the board. Explicit argument for projection notation. -/
@[nolint unused_arguments]
def height (b : board m n ι K) : ℕ := fintype.card m

/-- The state of the board, where pieces of the same type are equivalent -/
def reduce (b : board m n ι K) : playfield m n K :=
λ pos, option.map b.pieces (b.contents pos)

-- Allows saying that `b b' : board m n ι K` are `b ≈ b'`.
instance : has_equiv (board m n ι K) := ⟨λ b b', reduce b = reduce b'⟩

-- An indexed piece is on the board if it is in the board's `playfield`.
instance : has_mem ι (board m n ι K) :=
⟨λ ix b, ix ∈ b.contents⟩

/--
A board contains all of the `ix : ι` indices that it knows of,
stated explicitly. Uses the `board.contains` constraint.
-/
lemma retains_pieces (b : board m n ι K) (ix : ι) : ix ∈ b.contents :=
exists.elim (b.contains ix) (λ pos h, h ▸ playfield.index_at_in pos)

/--
A board maps each index `ix : ι` to a unique position `pos : m × n`,
stated explicitly. Uses the `board.injects` constraint.
-/
lemma no_superimposed (b : board m n ι K) (pos pos' : m × n) (hne : pos ≠ pos')
  (h : b.contents.occupied_at pos) : b.contents pos ≠ b.contents pos' :=
λ H, hne (b.injects h H)

/--
Given that the board is `occupied_at` some `pos : m × n`,
then the index at some `pos' : m × n` is equal to the index at `pos`,
iff that `pos'` is equal `pos' = pos`.
-/
protected lemma inj_iff (b : board m n ι K) :
  ∀ {pos pos' : m × n}, b.contents.occupied_at pos → (b.contents pos = b.contents pos' ↔ pos = pos') :=
λ _ _ H, playfield.inj_iff b.contents b.injects H

section repr

-- A board can be represented if the pieces themselves can be represented
variables [has_repr K]
variables {n' m' ix : ℕ}

/--
A board's `pieces` is a "vector", so `vec_repr` is used to represent it.
-/
def board_repr_pieces (b : board (fin m') (fin n') (fin ix) K) : string :=
chess.utils.vec_repr b.pieces

/--
A board's `contents` can be represented by reducing the board according to
the indexed vector at `pieces`, and placing the pieces on the `playfield`.
We override the default `option K` representation by using `option_wrap`,
and supply an underscore to represent empty positions.
-/
def board_repr_contents (b : board (fin m') (fin n') (fin ix) K) : string :=
chess.utils.matrix_repr (λ x y, chess.utils.option_wrap (b.reduce ⟨x, y⟩) "\uFF3F")

/--
A board's representation is just the concatentation of the representations
of the `pieces` and `contents` via `board_repr_pieces` and `board_repr_contents`,
respectively, with newlines inserted for clarity.
-/
def board_repr {K : Type*} [has_repr K] {n m ix : ℕ}
  (b : board (fin m) (fin n) (fin ix) K) : string :=
b.board_repr_pieces ++ ";\n\n" ++ b.board_repr_contents

/-- A board's representation is provided by `board_repr`. -/
instance board_repr_instance : has_repr (board (fin m') (fin n') (fin ix) K) := ⟨board_repr⟩

end repr

/-- The (colored) `piece` on a given square. -/
def piece_at
  (b : board m n ι K)
  (pos : m × n)
  (h : b.contents.occupied_at pos . tactic.exact_dec_trivial) : K :=
b.pieces (b.contents.index_at ⟨pos, h⟩)

end board

end chess