/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.monad.adjunction
! leanprover-community/mathlib commit ea3009f6c1a37dc031f741382dbb3ed93c965620
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Adjunction.Reflective
import Mathbin.CategoryTheory.Monad.Algebra

/-!
# Adjunctions and monads

We develop the basic relationship between adjunctions and monads.

Given an adjunction `h : L ⊣ R`, we have `h.to_monad : monad C` and `h.to_comonad : comonad D`.
We then have
`monad.comparison (h : L ⊣ R) : D ⥤ h.to_monad.algebra`
sending `Y : D` to the Eilenberg-Moore algebra for `L ⋙ R` with underlying object `R.obj X`,
and dually `comonad.comparison`.

We say `R : D ⥤ C` is `monadic_right_adjoint`, if it is a right adjoint and its `monad.comparison`
is an equivalence of categories. (Similarly for `monadic_left_adjoint`.)

Finally we prove that reflective functors are `monadic_right_adjoint`.
-/

namespace CategoryTheory

open Category

universe v₁ v₂ u₁ u₂

-- morphism levels before object levels. See note [category_theory universes].
variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D]

variable {L : C ⥤ D} {R : D ⥤ C}

namespace Adjunction

/-- For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a monad on
the category `C`.
-/
@[simps]
def toMonad (h : L ⊣ R) : Monad C where
  toFunctor := L ⋙ R
  η' := h.Unit
  μ' := whiskerRight (whiskerLeft L h.counit) R
  assoc' X := by
    dsimp
    rw [← R.map_comp]
    simp
  right_unit' X := by
    dsimp
    rw [← R.map_comp]
    simp
#align category_theory.adjunction.to_monad CategoryTheory.Adjunction.toMonad

/-- For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a comonad on
the category `D`.
-/
@[simps]
def toComonad (h : L ⊣ R) : Comonad D
    where
  toFunctor := R ⋙ L
  ε' := h.counit
  δ' := whiskerRight (whiskerLeft R h.Unit) L
  coassoc' X := by
    dsimp
    rw [← L.map_comp]
    simp
  right_counit' X := by
    dsimp
    rw [← L.map_comp]
    simp
#align category_theory.adjunction.to_comonad CategoryTheory.Adjunction.toComonad

/-- The monad induced by the Eilenberg-Moore adjunction is the original monad.  -/
@[simps]
def adjToMonadIso (T : Monad C) : T.adj.toMonad ≅ T :=
  MonadIso.mk (NatIso.ofComponents (fun X => Iso.refl _) (by tidy))
    (fun X => by
      dsimp
      simp)
    fun X => by
    dsimp
    simp
#align category_theory.adjunction.adj_to_monad_iso CategoryTheory.Adjunction.adjToMonadIso

/-- The comonad induced by the Eilenberg-Moore adjunction is the original comonad. -/
@[simps]
def adjToComonadIso (G : Comonad C) : G.adj.toComonad ≅ G :=
  ComonadIso.mk (NatIso.ofComponents (fun X => Iso.refl _) (by tidy))
    (fun X => by
      dsimp
      simp)
    fun X => by
    dsimp
    simp
#align category_theory.adjunction.adj_to_comonad_iso CategoryTheory.Adjunction.adjToComonadIso

end Adjunction

/-- Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.monad.comparison R`
sending objects `Y : D` to Eilenberg-Moore algebras for `L ⋙ R` with underlying object `R.obj X`.

We later show that this is full when `R` is full, faithful when `R` is faithful,
and essentially surjective when `R` is reflective.
-/
@[simps]
def Monad.comparison (h : L ⊣ R) : D ⥤ h.toMonad.Algebra
    where
  obj X :=
    { a := R.obj X
      a := R.map (h.counit.app X)
      assoc' := by
        dsimp
        rw [← R.map_comp, ← adjunction.counit_naturality, R.map_comp]
        rfl }
  map X Y f :=
    { f := R.map f
      h' := by
        dsimp
        rw [← R.map_comp, adjunction.counit_naturality, R.map_comp] }
#align category_theory.monad.comparison CategoryTheory.Monad.comparison

/-- The underlying object of `(monad.comparison R).obj X` is just `R.obj X`.
-/
@[simps]
def Monad.comparisonForget (h : L ⊣ R) : Monad.comparison h ⋙ h.toMonad.forget ≅ R
    where
  Hom := { app := fun X => 𝟙 _ }
  inv := { app := fun X => 𝟙 _ }
#align category_theory.monad.comparison_forget CategoryTheory.Monad.comparisonForget

theorem Monad.left_comparison (h : L ⊣ R) : L ⋙ Monad.comparison h = h.toMonad.free :=
  rfl
#align category_theory.monad.left_comparison CategoryTheory.Monad.left_comparison

instance [Faithful R] (h : L ⊣ R) : Faithful (Monad.comparison h)
    where map_injective' X Y f g w := R.map_injective (congr_arg Monad.Algebra.Hom.f w : _)

instance (T : Monad C) : Full (Monad.comparison T.adj)
    where preimage X Y f := ⟨f.f, by simpa using f.h⟩

instance (T : Monad C) : EssSurj (Monad.comparison T.adj)
    where mem_essImage X :=
    ⟨{  a := X.a
        a := X.a
        unit' := by simpa using X.unit
        assoc' := by simpa using X.assoc }, ⟨Monad.Algebra.isoMk (Iso.refl _) (by simp)⟩⟩

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.comonad.comparison L`
sending objects `X : C` to Eilenberg-Moore coalgebras for `L ⋙ R` with underlying object
`L.obj X`.
-/
@[simps]
def Comonad.comparison (h : L ⊣ R) : C ⥤ h.toComonad.Coalgebra
    where
  obj X :=
    { a := L.obj X
      a := L.map (h.Unit.app X)
      coassoc' := by
        dsimp
        rw [← L.map_comp, ← adjunction.unit_naturality, L.map_comp]
        rfl }
  map X Y f :=
    { f := L.map f
      h' := by
        dsimp
        rw [← L.map_comp]
        simp }
#align category_theory.comonad.comparison CategoryTheory.Comonad.comparison

/-- The underlying object of `(comonad.comparison L).obj X` is just `L.obj X`.
-/
@[simps]
def Comonad.comparisonForget {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R) :
    Comonad.comparison h ⋙ h.toComonad.forget ≅ L
    where
  Hom := { app := fun X => 𝟙 _ }
  inv := { app := fun X => 𝟙 _ }
#align category_theory.comonad.comparison_forget CategoryTheory.Comonad.comparisonForget

theorem Comonad.left_comparison (h : L ⊣ R) : R ⋙ Comonad.comparison h = h.toComonad.cofree :=
  rfl
#align category_theory.comonad.left_comparison CategoryTheory.Comonad.left_comparison

instance Comonad.comparison_faithful_of_faithful [Faithful L] (h : L ⊣ R) :
    Faithful (Comonad.comparison h)
    where map_injective' X Y f g w := L.map_injective (congr_arg Comonad.Coalgebra.Hom.f w : _)
#align category_theory.comonad.comparison_faithful_of_faithful CategoryTheory.Comonad.comparison_faithful_of_faithful

instance (G : Comonad C) : Full (Comonad.comparison G.adj)
    where preimage X Y f := ⟨f.f, by simpa using f.h⟩

instance (G : Comonad C) : EssSurj (Comonad.comparison G.adj)
    where mem_essImage X :=
    ⟨{  a := X.a
        a := X.a
        counit' := by simpa using X.counit
        coassoc' := by simpa using X.coassoc }, ⟨Comonad.Coalgebra.isoMk (Iso.refl _) (by simp)⟩⟩

/-- A right adjoint functor `R : D ⥤ C` is *monadic* if the comparison functor `monad.comparison R`
from `D` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class MonadicRightAdjoint (R : D ⥤ C) extends IsRightAdjoint R where
  eqv : IsEquivalence (Monad.comparison (Adjunction.ofRightAdjoint R))
#align category_theory.monadic_right_adjoint CategoryTheory.MonadicRightAdjoint

/--
A left adjoint functor `L : C ⥤ D` is *comonadic* if the comparison functor `comonad.comparison L`
from `C` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class ComonadicLeftAdjoint (L : C ⥤ D) extends IsLeftAdjoint L where
  eqv : IsEquivalence (Comonad.comparison (Adjunction.ofLeftAdjoint L))
#align category_theory.comonadic_left_adjoint CategoryTheory.ComonadicLeftAdjoint

noncomputable instance (T : Monad C) : MonadicRightAdjoint T.forget :=
  ⟨(Equivalence.ofFullyFaithfullyEssSurj _ : IsEquivalence (Monad.comparison T.adj))⟩

noncomputable instance (G : Comonad C) : ComonadicLeftAdjoint G.forget :=
  ⟨(Equivalence.ofFullyFaithfullyEssSurj _ : IsEquivalence (Comonad.comparison G.adj))⟩

-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
instance μ_iso_of_reflective [Reflective R] : IsIso (Adjunction.ofRightAdjoint R).toMonad.μ :=
  by
  dsimp
  infer_instance
#align category_theory.μ_iso_of_reflective CategoryTheory.μ_iso_of_reflective

attribute [instance] monadic_right_adjoint.eqv

attribute [instance] comonadic_left_adjoint.eqv

namespace Reflective

instance [Reflective R] (X : (Adjunction.ofRightAdjoint R).toMonad.Algebra) :
    IsIso ((Adjunction.ofRightAdjoint R).Unit.app X.a) :=
  ⟨⟨X.a,
      ⟨X.Unit, by
        dsimp only [functor.id_obj]
        rw [← (adjunction.of_right_adjoint R).unit_naturality]
        dsimp only [functor.comp_obj, adjunction.to_monad_coe]
        rw [unit_obj_eq_map_unit, ← functor.map_comp, ← functor.map_comp]
        erw [X.unit]
        simp⟩⟩⟩

instance comparison_essSurj [Reflective R] :
    EssSurj (Monad.comparison (Adjunction.ofRightAdjoint R)) :=
  by
  refine' ⟨fun X => ⟨(left_adjoint R).obj X.a, ⟨_⟩⟩⟩
  symm
  refine' monad.algebra.iso_mk _ _
  · exact as_iso ((adjunction.of_right_adjoint R).Unit.app X.A)
  dsimp only [functor.comp_map, monad.comparison_obj_a, as_iso_hom, functor.comp_obj,
    monad.comparison_obj_A, monad_to_functor_eq_coe, adjunction.to_monad_coe]
  rw [← cancel_epi ((adjunction.of_right_adjoint R).Unit.app X.A), adjunction.unit_naturality_assoc,
    adjunction.right_triangle_components, comp_id]
  apply (X.unit_assoc _).symm
#align category_theory.reflective.comparison_ess_surj CategoryTheory.Reflective.comparison_essSurj

instance comparisonFull [Full R] [IsRightAdjoint R] :
    Full (Monad.comparison (Adjunction.ofRightAdjoint R)) where preimage X Y f := R.preimage f.f
#align category_theory.reflective.comparison_full CategoryTheory.Reflective.comparisonFull

end Reflective

-- It is possible to do this computably since the construction gives the data of the inverse, not
-- just the existence of an inverse on each object.
-- see Note [lower instance priority]
/-- Any reflective inclusion has a monadic right adjoint.
    cf Prop 5.3.3 of [Riehl][riehl2017] -/
noncomputable instance (priority := 100) monadicOfReflective [Reflective R] : MonadicRightAdjoint R
    where eqv := Equivalence.ofFullyFaithfullyEssSurj _
#align category_theory.monadic_of_reflective CategoryTheory.monadicOfReflective

end CategoryTheory


import algebra.module.basic data.nat.factorization.basic

/-!
# Additive maps

Given a commutative additive monoid `M`, we define an **additive map** `f : ℕ → M` as
  a map such that `f(0) = f(1) = 0` and `f(xy) = f(x) + f(y)` for all `x y : ℕ` non-zero.
The set of additive maps form an additive monoid under pointwise addition.

## Implementation details

We mimic the implementation from some files in `mathlib` such as `nat.arithmetic_function`.
-/

namespace IMOSL
namespace IMO2020N5

structure additive_map (M : Type*) [has_zero M] [has_add M] :=
  (to_fun : ℕ → M) (map_zero' : to_fun 0 = 0) (map_one' : to_fun 1 = 0)
  (map_mul' : ∀ {x y : ℕ}, x ≠ 0 → y ≠ 0 → to_fun (x * y) = to_fun x + to_fun y)

namespace additive_map

section basic

variables {M : Type*} [has_zero M] [has_add M]

instance : has_coe_to_fun (additive_map M) (λ _, ℕ → M) := ⟨additive_map.to_fun⟩

@[simp] theorem to_fun_eq_coe (f : additive_map M) : f.to_fun = f := rfl

@[simp] theorem map_zero (f : additive_map M) : f 0 = 0 := f.map_zero'

@[simp] theorem map_one (f : additive_map M) : f 1 = 0 := f.map_one'

@[simp] theorem map_mul (f : additive_map M) {x y : ℕ} (hx : x ≠ 0) (hy : y ≠ 0) :
  f (x * y) = f x + f y := f.map_mul' hx hy

instance fun_like {M : out_param Type*} [has_zero M] [has_add M] :
  fun_like (additive_map M) ℕ (λ _, M) :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; simp only []; exact h }

theorem coe_inj {f g : additive_map M} : (f : ℕ → M) = g ↔ f = g :=
⟨(λ h, fun_like.coe_injective h), (λ h, by rw h)⟩

@[ext] theorem ext {f g : additive_map M} (h : ∀ x, f x = g x) : f = g := fun_like.ext _ _ h

theorem ext_iff {f g : additive_map M} : f = g ↔ ∀ x, f x = g x := ⟨λ h x, by rw h, ext⟩

theorem ext_iff_primes {f g : additive_map M} : f = g ↔ ∀ p : ℕ, p.prime → f p = g p :=
begin
  refine ⟨λ h _ _, by rw h, λ h, ext (nat.rec_on_mul _ _ h (λ a b ha hb, _))⟩,
  rw [map_zero, map_zero],
  rw [map_one, map_one],
  rcases eq_or_ne a 0 with rfl | ha0,
  rw [zero_mul, ha],
  rcases eq_or_ne b 0 with rfl | hb0,
  rw [mul_zero, hb],
  rw [f.map_mul ha0 hb0, g.map_mul ha0 hb0, ha, hb]
end

end basic

section add_comm_monoid

variables {M : Type*} [add_comm_monoid M]

instance : has_zero (additive_map M) := ⟨⟨(λ _, 0), rfl, rfl, (λ _ _ _ _, by rw add_zero)⟩⟩

@[simp] theorem zero_apply {x : ℕ} : (0 : additive_map M) x = 0 := rfl

instance : has_add (additive_map M) :=
⟨λ f g, ⟨(λ n, f n + g n),
  by rw [map_zero, map_zero, add_zero],
  by rw [map_one, map_one, add_zero],
  λ x y hx hy, by rw [f.map_mul hx hy, g.map_mul hx hy, add_add_add_comm]⟩⟩

@[simp] theorem add_apply {f g : additive_map M} {n : ℕ} : (f + g) n = f n + g n := rfl

instance : add_comm_monoid (additive_map M) :=
{ add_comm := λ f g, by ext; rw [add_apply, add_apply, add_comm],
  add_assoc := λ f g h, by ext; iterate 4 { rw add_apply }; rw add_assoc,
  zero_add := λ f, by ext; rw [add_apply, zero_apply, zero_add],
  add_zero := λ f, by ext; rw [add_apply, zero_apply, add_zero],
  .. additive_map.has_zero, .. additive_map.has_add }

@[simp] theorem map_pow (f : additive_map M) : ∀ x n : ℕ, f (x ^ n) = n • f x
| _ 0 := by rw [pow_zero, zero_nsmul, map_one]
| 0 (n+1) := by rw [zero_pow n.succ_pos, map_zero, nsmul_zero]
| (x+1) (n+1) := by rw [pow_succ', succ_nsmul', ← map_pow,
  f.map_mul (pow_ne_zero _ x.succ_ne_zero) x.succ_ne_zero]

theorem map_prod_finset (f : additive_map M) {α : Type*} [decidable_eq α] {S : finset α} {g : α → ℕ}
  (hS : ∀ x, x ∈ S → g x ≠ 0) : f (S.prod g) = S.sum (λ x, f (g x)) :=
begin
  induction S using finset.induction with a S h h0,
  rw [finset.prod_empty, finset.sum_empty, additive_map.map_one],
  replace hS : g a ≠ 0 ∧ ∀ x : α, x ∈ S → g x ≠ 0 :=
    ⟨hS a (S.mem_insert_self a), λ x hx, hS x (finset.mem_insert_of_mem hx)⟩,
  rw [finset.prod_insert h, finset.sum_insert h, ← h0 hS.2, additive_map.map_mul f hS.1],
  rw finset.prod_ne_zero_iff; exact hS.2
end

theorem map_factorization (f : additive_map M) :
  ∀ n : ℕ, f n = n.factorization.sum (λ p k, k • f p) :=
begin
  refine nat.rec_on_mul _ _ (λ p hp, _) (λ a b ha hb, _),
  rw [nat.factorization_zero, finsupp.sum_zero_index, map_zero],
  rw [nat.factorization_one, finsupp.sum_zero_index, map_one],
  rw [hp.factorization, finsupp.sum_single_index, one_nsmul],
  rw zero_nsmul,
  rcases eq_or_ne a 0 with rfl | ha0,
  rw [zero_mul, ha],
  rcases eq_or_ne b 0 with rfl | hb0,
  rw [mul_zero, hb],
  rw [f.map_mul ha0 hb0, nat.factorization_mul ha0 hb0, finsupp.sum_add_index, ← ha, ← hb],
  rintros c -; exact zero_nsmul (f c),
  rintros c - d1 d2; rw add_nsmul
end

theorem zero_iff_primes {f : additive_map M} : f = 0 ↔ ∀ p : ℕ, p.prime → f p = 0 :=
  by rw ext_iff_primes; simp_rw additive_map.zero_apply

end add_comm_monoid

section mul_action

variables {M : Type*} [add_comm_monoid M] {α : Type*} [monoid α] [distrib_mul_action α M]

instance : has_smul α (additive_map M) :=
⟨λ a f, ⟨λ x, a • f x,
  by rw [map_zero, smul_zero],
  by rw [map_one, smul_zero],
  λ x y hx hy, by rw [f.map_mul hx hy, smul_add]⟩⟩

@[simp] theorem smul_def {a : α} {f : additive_map M} {x : ℕ} : (a • f) x = a • f x := rfl

instance : mul_action α (additive_map M) :=
{ one_smul := λ f, by ext; rw [smul_def, one_smul],
  mul_smul := λ x y f, by ext; iterate 3 { rw smul_def }; rw mul_smul }

instance : distrib_mul_action α (additive_map M) :=
{ smul_add := λ x f g, by ext; rw [smul_def, add_apply, add_apply, smul_add, smul_def, smul_def],
  smul_zero := λ x, by ext; rw [smul_def, zero_apply, smul_zero] }

end mul_action

section add_comm_group

variables {G : Type*} [add_comm_group G]

instance : has_neg (additive_map G) :=
⟨λ f, ⟨(λ n, -(f n)),
  by rw [map_zero, neg_zero],
  by rw [map_one, neg_zero],
  λ x y hx hy, by rw [f.map_mul hx hy, neg_add]⟩⟩

@[simp] theorem neg_apply {f : additive_map G} {n : ℕ} : (-f) n = -(f n) := rfl

instance : has_sub (additive_map G) :=
⟨λ f g, ⟨(λ n, f n - g n),
  by rw [map_zero, map_zero, sub_zero],
  by rw [map_one, map_one, sub_zero],
  λ x y hx hy, by rw [f.map_mul hx hy, g.map_mul hx hy, add_sub_add_comm]⟩⟩

@[simp] theorem sub_apply {f g : additive_map G} {n : ℕ} : (f - g) n = f n - g n := rfl

instance : add_comm_group (additive_map G) :=
{ add_left_neg := λ f, by ext; rw [add_apply, neg_apply, neg_add_self, zero_apply],
  .. additive_map.add_comm_monoid, .. additive_map.has_neg }

end add_comm_group

end additive_map

end IMO2020N5
end IMOSL


namespace set

universes u v

variables {α : Type u} {ι : Type v}

variables {A B C D X Y : set α}
variables {a b c : α}

theorem ext (h : ∀ a, a ∈ A ↔ a ∈ B) : A = B :=
funext (λ a, propext (h a))

lemma pair₁ : a ∈ ({a,b} : set α) := begin apply or.inr, apply or.inl, refl end
lemma pair₂ : b ∈ ({a,b} : set α) := begin apply or.inl, refl end

@[refl] theorem subset.refl : A ⊆ A := λ _ m, m
@[trans] theorem subset.trans (s₁ : A ⊆ B) (s₂ : B ⊆ C) : A ⊆ C := λ _ ma, s₂ $ s₁ ma
theorem subset.antisymm (l : A ⊆ B) (r : B ⊆ A) : A = B := ext (λ _, ⟨λ m, l m, λ m, r m⟩)
theorem union.empty : ⋃₀(∅ : set (set α)) = ∅ := ext $ λ a, ⟨λ ⟨_,o,_⟩, false.rec_on _ o, λ o, false.rec_on _ o⟩
theorem inter.π₁ : A ∩ B ⊆ A := λ x a, a.1
theorem inter.π₂ : A ∩ B ⊆ B := λ x a, a.2
theorem union.ι {ℱ : set $ set α} {U : set α} : U ∈ ℱ →  U ⊆ ⋃₀ ℱ := λ Uℱ a aU, ⟨U, Uℱ, aU⟩
/--Universality of intersection-/
theorem subset.inter : X ⊆ A → X ⊆ B → X ⊆ A ∩ B
:= λ a b x h, ⟨a h, b h⟩
theorem subset.inter_subset_inter : A ⊆ B → C ⊆ D → A ∩ C ⊆ B ∩ D
:= λ ab cd _ ⟨hA,hC⟩, ⟨ab hA, cd hC⟩
theorem subset.empty : ∅ ⊆ A := λ o oh, false.rec_on _ oh
theorem subset.univ : A ⊆ univ := λ _ _, ⟨⟩
theorem inter.empty : ∅ ∩ A = ∅ := ext (λ x, ⟨λ ⟨a,_⟩, a, λ x, false.rec_on _ x⟩)
theorem inter.univ : univ ∩ A = A := ext (λ x, ⟨λ ⟨_,a⟩, a, λ mA, ⟨⟨⟩,mA⟩⟩)
theorem inter_comm (X Y : set α) : X ∩ Y = Y ∩ X := ext $ λ a, and.comm
theorem inter_assoc (A B C : set α): (A ∩ B) ∩ C = A ∩ (B ∩ C) := ext $ λ a, and.assoc
instance inter_is_assoc : is_associative (set α) (∩) := ⟨inter_assoc⟩
instance inter_is_comm : is_commutative (set α) (∩) := ⟨inter_comm⟩

def sInter (G : set (set α)) : set α := {x | ∀ A ∈ G, x ∈ A}
prefix `⋂₀`:110 := sInter
/- indexed intersection -/
def Inter  (s : ι → set α) : set α :=  {x : α | ∀i : ι, x ∈ s i}

/-- Indexed union of a family of sets -/
@[reducible] def Union {β} (s : ι → set β) : set β := {a : β | ∃ i : ι, a ∈ s i}

notation `⋃` binders `, ` r:(scoped f, Union f) := r
notation `⋂` binders `, ` r:(scoped f, Inter f) := r
def triv_insert {α : Type*} {a : α} : a ∈ ({a} : set α) := or.inl rfl

def sInter.univ_singleton : ⋂₀ {(univ : set α)} = (univ : set α) :=
ext $ λ a, ⟨λ h, h univ $ or.inl rfl, λ h A H, or.rec_on H (λ p, eq.symm p ▸ h) (λ o, false.rec_on _ o)⟩

def Inter_compl {s : ι → set α} : (⋂ i, s i) = - (⋃ i, - (s i))
:= set.ext $ λ a, ⟨λ h₁ ⟨i,h₂⟩, h₂ (h₁ i),λ h₁ i, classical.by_contradiction (λ h₂, h₁ ⟨i,h₂⟩)⟩

def function (dom : set α) (cod : set α) : Type u := {x // x ∈ dom} → {y // y ∈ cod}

end set


lemma and_symm (P Q : Prop) : (P ∧ Q) → (Q ∧ P) :=
begin
    intro h,
    cases h with p q,
    split,
    {
        exact q,
    },
    {
        exact p,
    },
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Scott Morrison
-/
import data.list.basic

namespace list

open nat

/- bag_inter -/
universe u

variables {α : Type u} [decidable_eq α]

@[simp] theorem nil_bag_inter (l : list α) : [].bag_inter l = [] :=
by cases l; refl

@[simp] theorem bag_inter_nil (l : list α) : l.bag_inter [] = [] :=
by cases l; refl

@[simp] theorem cons_bag_inter_of_pos {a} (l₁ : list α) {l₂} (h : a ∈ l₂) :
  (a :: l₁).bag_inter l₂ = a :: l₁.bag_inter (l₂.erase a) :=
by cases l₂; exact if_pos h

@[simp] theorem cons_bag_inter_of_neg {a} (l₁ : list α) {l₂} (h : a ∉ l₂) :
  (a :: l₁).bag_inter l₂ = l₁.bag_inter l₂ :=
begin
  cases l₂, {simp only [bag_inter_nil]},
  simp only [erase_of_not_mem h, list.bag_inter, if_neg h]
end

@[simp] theorem mem_bag_inter {a : α} : ∀ {l₁ l₂ : list α}, a ∈ l₁.bag_inter l₂ ↔ a ∈ l₁ ∧ a ∈ l₂
| []      l₂ := by simp only [nil_bag_inter, not_mem_nil, false_and]
| (b::l₁) l₂ := begin
    by_cases b ∈ l₂,
    { rw [cons_bag_inter_of_pos _ h, mem_cons_iff, mem_cons_iff, mem_bag_inter],
      by_cases ba : a = b,
      { simp only [ba, h, eq_self_iff_true, true_or, true_and] },
      { simp only [mem_erase_of_ne ba, ba, false_or] } },
    { rw [cons_bag_inter_of_neg _ h, mem_bag_inter, mem_cons_iff, or_and_distrib_right],
      symmetry, apply or_iff_right_of_imp,
      rintro ⟨rfl, h'⟩, exact h.elim h' }
  end

@[simp] theorem count_bag_inter {a : α} :
  ∀ {l₁ l₂ : list α}, count a (l₁.bag_inter l₂) = min (count a l₁) (count a l₂)
| []         l₂ := by simp
| l₁         [] := by simp
| (h₁ :: l₁) (h₂ :: l₂) :=
begin
  simp only [list.bag_inter, list.mem_cons_iff],
  by_cases p₁ : h₂ = h₁; by_cases p₂ : h₁ = a,
  { simp only [p₁, p₂, count_bag_inter, min_succ_succ, erase_cons_head, if_true, mem_cons_iff,
               count_cons_self, true_or, eq_self_iff_true] },
  { simp only [p₁, ne.symm p₂, count_bag_inter, count_cons, erase_cons_head, if_true, mem_cons_iff,
               true_or, eq_self_iff_true, if_false] },
  { rw p₂ at p₁,
    by_cases p₃ : a ∈ l₂,
    { simp only [p₁, ne.symm p₁, p₂, p₃, erase_cons, count_bag_inter, eq.symm (min_succ_succ _ _),
                 succ_pred_eq_of_pos (count_pos.2 p₃), if_true, mem_cons_iff, false_or,
                 count_cons_self, eq_self_iff_true, if_false, ne.def, not_false_iff,
                 count_erase_self, list.count_cons_of_ne] },
    { simp [ne.symm p₁, p₂, p₃] } },
  { by_cases p₄ : h₁ ∈ l₂; simp only [ne.symm p₁, ne.symm p₂, p₄, count_bag_inter, if_true,
      if_false, mem_cons_iff, false_or, eq_self_iff_true, ne.def, not_false_iff,count_erase_of_ne,
      count_cons_of_ne] }
end

theorem bag_inter_sublist_left : ∀ l₁ l₂ : list α, l₁.bag_inter l₂ <+ l₁
| []      l₂ := by simp [nil_sublist]
| (b::l₁) l₂ := begin
  by_cases b ∈ l₂; simp [h],
  { apply cons_sublist_cons, apply bag_inter_sublist_left },
  { apply sublist_cons_of_sublist, apply bag_inter_sublist_left }
end

theorem bag_inter_nil_iff_inter_nil : ∀ l₁ l₂ : list α, l₁.bag_inter l₂ = [] ↔ l₁ ∩ l₂ = []
| []      l₂ := by simp
| (b::l₁) l₂ :=
begin
  by_cases h : b ∈ l₂; simp [h],
  exact bag_inter_nil_iff_inter_nil l₁ l₂
end

end list


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Finite types.
-/
import data.finset algebra.big_operators data.array.lemmas data.vector2
universes u v

variables {α : Type*} {β : Type*} {γ : Type*}

/-- `fintype α` means that `α` is finite, i.e. there are only
  finitely many distinct elements of type `α`. The evidence of this
  is a finset `elems` (a list up to permutation without duplicates),
  together with a proof that everything of type `α` is in the list. -/
class fintype (α : Type*) :=
(elems : finset α)
(complete : ∀ x : α, x ∈ elems)

namespace finset
variable [fintype α]

/-- `univ` is the universal finite set of type `finset α` implied from
  the assumption `fintype α`. -/
def univ : finset α := fintype.elems α

@[simp] theorem mem_univ (x : α) : x ∈ (univ : finset α) :=
fintype.complete x

@[simp] theorem mem_univ_val : ∀ x, x ∈ (univ : finset α).1 := mem_univ

@[simp] lemma coe_univ : ↑(finset.univ : finset α) = (set.univ : set α) :=
by ext; simp

theorem subset_univ (s : finset α) : s ⊆ univ := λ a _, mem_univ a

theorem eq_univ_iff_forall {s : finset α} : s = univ ↔ ∀ x, x ∈ s :=
by simp [ext]

end finset

open finset function

namespace fintype

instance decidable_pi_fintype {α} {β : α → Type*} [fintype α] [∀a, decidable_eq (β a)] :
  decidable_eq (Πa, β a) :=
assume f g, decidable_of_iff (∀ a ∈ fintype.elems α, f a = g a)
  (by simp [function.funext_iff, fintype.complete])

instance decidable_forall_fintype [fintype α] {p : α → Prop} [decidable_pred p] :
  decidable (∀ a, p a) :=
decidable_of_iff (∀ a ∈ @univ α _, p a) (by simp)

instance decidable_exists_fintype [fintype α] {p : α → Prop} [decidable_pred p] :
  decidable (∃ a, p a) :=
decidable_of_iff (∃ a ∈ @univ α _, p a) (by simp)

instance decidable_eq_equiv_fintype [fintype α] [decidable_eq β] :
  decidable_eq (α ≃ β) :=
λ a b, decidable_of_iff (a.1 = b.1) ⟨λ h, equiv.ext _ _ (congr_fun h), congr_arg _⟩

/-- Construct a proof of `fintype α` from a universal multiset -/
def of_multiset [decidable_eq α] (s : multiset α)
  (H : ∀ x : α, x ∈ s) : fintype α :=
⟨s.to_finset, by simpa using H⟩

/-- Construct a proof of `fintype α` from a universal list -/
def of_list [decidable_eq α] (l : list α)
  (H : ∀ x : α, x ∈ l) : fintype α :=
⟨l.to_finset, by simpa using H⟩

theorem exists_univ_list (α) [fintype α] :
  ∃ l : list α, l.nodup ∧ ∀ x : α, x ∈ l :=
let ⟨l, e⟩ := quotient.exists_rep (@univ α _).1 in
by have := and.intro univ.2 mem_univ_val;
   exact ⟨_, by rwa ← e at this⟩

/-- `card α` is the number of elements in `α`, defined when `α` is a fintype. -/
def card (α) [fintype α] : ℕ := (@univ α _).card

/-- There is (computably) a bijection between `α` and `fin n` where
  `n = card α`. Since it is not unique, and depends on which permutation
  of the universe list is used, the bijection is wrapped in `trunc` to
  preserve computability.  -/
def equiv_fin (α) [fintype α] [decidable_eq α] : trunc (α ≃ fin (card α)) :=
by unfold card finset.card; exact
quot.rec_on_subsingleton (@univ α _).1
  (λ l (h : ∀ x:α, x ∈ l) (nd : l.nodup), trunc.mk
   ⟨λ a, ⟨_, list.index_of_lt_length.2 (h a)⟩,
    λ i, l.nth_le i.1 i.2,
    λ a, by simp,
    λ ⟨i, h⟩, fin.eq_of_veq $ list.nodup_iff_nth_le_inj.1 nd _ _
      (list.index_of_lt_length.2 (list.nth_le_mem _ _ _)) h $ by simp⟩)
  mem_univ_val univ.2

theorem exists_equiv_fin (α) [fintype α] : ∃ n, nonempty (α ≃ fin n) :=
by haveI := classical.dec_eq α; exact ⟨card α, nonempty_of_trunc (equiv_fin α)⟩

instance (α : Type*) : subsingleton (fintype α) :=
⟨λ ⟨s₁, h₁⟩ ⟨s₂, h₂⟩, by congr; simp [finset.ext, h₁, h₂]⟩

protected def subtype {p : α → Prop} (s : finset α)
  (H : ∀ x : α, x ∈ s ↔ p x) : fintype {x // p x} :=
⟨⟨multiset.pmap subtype.mk s.1 (λ x, (H x).1),
  multiset.nodup_pmap (λ a _ b _, congr_arg subtype.val) s.2⟩,
λ ⟨x, px⟩, multiset.mem_pmap.2 ⟨x, (H x).2 px, rfl⟩⟩

theorem subtype_card {p : α → Prop} (s : finset α)
  (H : ∀ x : α, x ∈ s ↔ p x) :
  @card {x // p x} (fintype.subtype s H) = s.card :=
multiset.card_pmap _ _ _

theorem card_of_subtype {p : α → Prop} (s : finset α)
  (H : ∀ x : α, x ∈ s ↔ p x) [fintype {x // p x}] :
  card {x // p x} = s.card :=
by rw ← subtype_card s H; congr

/-- If `f : α → β` is a bijection and `α` is a fintype, then `β` is also a fintype. -/
def of_bijective [fintype α] (f : α → β) (H : function.bijective f) : fintype β :=
⟨univ.map ⟨f, H.1⟩,
λ b, let ⟨a, e⟩ := H.2 b in e ▸ mem_map_of_mem _ (mem_univ _)⟩

/-- If `f : α → β` is a surjection and `α` is a fintype, then `β` is also a fintype. -/
def of_surjective [fintype α] [decidable_eq β] (f : α → β) (H : function.surjective f) : fintype β :=
⟨univ.image f, λ b, let ⟨a, e⟩ := H b in e ▸ mem_image_of_mem _ (mem_univ _)⟩

/-- If `f : α ≃ β` and `α` is a fintype, then `β` is also a fintype. -/
def of_equiv (α : Type*) [fintype α] (f : α ≃ β) : fintype β := of_bijective _ f.bijective

theorem of_equiv_card [fintype α] (f : α ≃ β) :
  @card β (of_equiv α f) = card α :=
multiset.card_map _ _

theorem card_congr {α β} [fintype α] [fintype β] (f : α ≃ β) : card α = card β :=
by rw ← of_equiv_card f; congr

theorem card_eq {α β} [F : fintype α] [G : fintype β] : card α = card β ↔ nonempty (α ≃ β) :=
⟨λ e, match F, G, e with ⟨⟨s, nd⟩, h⟩, ⟨⟨s', nd'⟩, h'⟩, e' := begin
  change multiset.card s = multiset.card s' at e',
  revert nd nd' h h' e',
  refine quotient.induction_on₂ s s' (λ l₁ l₂
    (nd₁ : l₁.nodup) (nd₂ : l₂.nodup)
    (h₁ : ∀ x, x ∈ l₁) (h₂ : ∀ x, x ∈ l₂)
    (e' : l₁.length = l₂.length), _),
  haveI := classical.dec_eq α,
  refine ⟨equiv.of_bijective ⟨_, _⟩⟩,
  { refine λ a, l₂.nth_le (l₁.index_of a) _,
    rw ← e', exact list.index_of_lt_length.2 (h₁ a) },
  { intros a b h, simpa [h₁] using congr_arg l₁.nth
      (list.nodup_iff_nth_le_inj.1 nd₂ _ _ _ _ h) },
  { have := classical.dec_eq β,
    refine λ b, ⟨l₁.nth_le (l₂.index_of b) _, _⟩,
    { rw e', exact list.index_of_lt_length.2 (h₂ b) },
    { simp [nd₁] } }
end end, λ ⟨f⟩, card_congr f⟩

end fintype

instance (n : ℕ) : fintype (fin n) :=
⟨⟨list.pmap fin.mk (list.range n) (λ a, list.mem_range.1),
  list.nodup_pmap (λ a _ b _, congr_arg fin.val) (list.nodup_range _)⟩,
λ ⟨m, h⟩, list.mem_pmap.2 ⟨m, list.mem_range.2 h, rfl⟩⟩

@[simp] theorem fintype.card_fin (n : ℕ) : fintype.card (fin n) = n :=
by rw [fin.fintype]; simp [fintype.card, card, univ]

instance : fintype empty := ⟨∅, empty.rec _⟩

@[simp] theorem fintype.univ_empty : @univ empty _ = ∅ := rfl

@[simp] theorem fintype.card_empty : fintype.card empty = 0 := rfl

instance : fintype pempty := ⟨∅, pempty.rec _⟩

@[simp] theorem fintype.univ_pempty : @univ pempty _ = ∅ := rfl

@[simp] theorem fintype.card_pempty : fintype.card pempty = 0 := rfl

instance : fintype unit := ⟨⟨()::0, by simp⟩, λ ⟨⟩, by simp⟩

@[simp] theorem fintype.univ_unit : @univ unit _ = {()} := rfl

@[simp] theorem fintype.card_unit : fintype.card unit = 1 := rfl

instance : fintype punit := ⟨⟨punit.star::0, by simp⟩, λ ⟨⟩, by simp⟩

@[simp] theorem fintype.univ_punit : @univ punit _ = {punit.star} := rfl

@[simp] theorem fintype.card_punit : fintype.card punit = 1 := rfl

instance : fintype bool := ⟨⟨tt::ff::0, by simp⟩, λ x, by cases x; simp⟩

@[simp] theorem fintype.univ_bool : @univ bool _ = {ff, tt} := rfl

instance units_int.fintype : fintype (units ℤ) :=
⟨{1, -1}, λ x, by cases int.units_eq_one_or x; simp *⟩

@[simp] theorem fintype.card_units_int : fintype.card (units ℤ) = 2 := rfl

@[simp] theorem fintype.card_bool : fintype.card bool = 2 := rfl

def finset.insert_none (s : finset α) : finset (option α) :=
⟨none :: s.1.map some, multiset.nodup_cons.2
  ⟨by simp, multiset.nodup_map (λ a b, option.some.inj) s.2⟩⟩

@[simp] theorem finset.mem_insert_none {s : finset α} : ∀ {o : option α},
  o ∈ s.insert_none ↔ ∀ a ∈ o, a ∈ s
| none     := iff_of_true (multiset.mem_cons_self _ _) (λ a h, by cases h)
| (some a) := multiset.mem_cons.trans $ by simp; refl

theorem finset.some_mem_insert_none {s : finset α} {a : α} :
  some a ∈ s.insert_none ↔ a ∈ s := by simp

instance {α : Type*} [fintype α] : fintype (option α) :=
⟨univ.insert_none, λ a, by simp⟩

@[simp] theorem fintype.card_option {α : Type*} [fintype α] :
  fintype.card (option α) = fintype.card α + 1 :=
(multiset.card_cons _ _).trans (by rw multiset.card_map; refl)

instance {α : Type*} (β : α → Type*)
  [fintype α] [∀ a, fintype (β a)] : fintype (sigma β) :=
⟨univ.sigma (λ _, univ), λ ⟨a, b⟩, by simp⟩

@[simp] theorem fintype.card_sigma {α : Type*} (β : α → Type*)
  [fintype α] [∀ a, fintype (β a)] :
  fintype.card (sigma β) = univ.sum (λ a, fintype.card (β a)) :=
card_sigma _ _

instance (α β : Type*) [fintype α] [fintype β] : fintype (α × β) :=
⟨univ.product univ, λ ⟨a, b⟩, by simp⟩

@[simp] theorem fintype.card_prod (α β : Type*) [fintype α] [fintype β] :
  fintype.card (α × β) = fintype.card α * fintype.card β :=
card_product _ _

def fintype.fintype_prod_left {α β} [decidable_eq α] [fintype (α × β)] [nonempty β] : fintype α :=
⟨(fintype.elems (α × β)).image prod.fst,
  assume a, let ⟨b⟩ := ‹nonempty β› in by simp; exact ⟨b, fintype.complete _⟩⟩

def fintype.fintype_prod_right {α β} [decidable_eq β] [fintype (α × β)] [nonempty α] : fintype β :=
⟨(fintype.elems (α × β)).image prod.snd,
  assume b, let ⟨a⟩ := ‹nonempty α› in by simp; exact ⟨a, fintype.complete _⟩⟩

instance (α : Type*) [fintype α] : fintype (ulift α) :=
fintype.of_equiv _ equiv.ulift.symm

@[simp] theorem fintype.card_ulift (α : Type*) [fintype α] :
  fintype.card (ulift α) = fintype.card α :=
fintype.of_equiv_card _

instance (α : Type u) (β : Type v) [fintype α] [fintype β] : fintype (α ⊕ β) :=
@fintype.of_equiv _ _ (@sigma.fintype _
    (λ b, cond b (ulift α) (ulift.{(max u v) v} β)) _
    (λ b, by cases b; apply ulift.fintype))
  ((equiv.sum_equiv_sigma_bool _ _).symm.trans
    (equiv.sum_congr equiv.ulift equiv.ulift))

@[simp] theorem fintype.card_sum (α β : Type*) [fintype α] [fintype β] :
  fintype.card (α ⊕ β) = fintype.card α + fintype.card β :=
by rw [sum.fintype, fintype.of_equiv_card]; simp

lemma fintype.card_le_of_injective [fintype α] [fintype β] (f : α → β)
  (hf : function.injective f) : fintype.card α ≤ fintype.card β :=
by haveI := classical.prop_decidable; exact
finset.card_le_card_of_inj_on f (λ _ _, finset.mem_univ _) (λ _ _ _ _ h, hf h)

lemma fintype.card_eq_one_iff [fintype α] : fintype.card α = 1 ↔ (∃ x : α, ∀ y, y = x) :=
by rw [← fintype.card_unit, fintype.card_eq]; exact
⟨λ ⟨a⟩, ⟨a.symm (), λ y, a.bijective.1 (subsingleton.elim _ _)⟩,
  λ ⟨x, hx⟩, ⟨⟨λ _, (), λ _, x, λ _, (hx _).trans (hx _).symm,
    λ _, subsingleton.elim _ _⟩⟩⟩

lemma fintype.card_eq_zero_iff [fintype α] : fintype.card α = 0 ↔ (α → false) :=
⟨λ h a, have e : α ≃ empty := classical.choice (fintype.card_eq.1 (by simp [h])), (e a).elim,
  λ h, have e : α ≃ empty := ⟨λ a, (h a).elim, λ a, a.elim, λ a, (h a).elim, λ a, a.elim⟩,
    by simp [fintype.card_congr e]⟩

lemma fintype.card_pos_iff [fintype α] : 0 < fintype.card α ↔ nonempty α :=
⟨λ h, classical.by_contradiction (λ h₁,
  have fintype.card α = 0 := fintype.card_eq_zero_iff.2 (λ a, h₁ ⟨a⟩),
  lt_irrefl 0 $ by rwa this at h),
λ ⟨a⟩, nat.pos_of_ne_zero (mt fintype.card_eq_zero_iff.1 (λ h, h a))⟩

lemma fintype.card_le_one_iff [fintype α] : fintype.card α ≤ 1 ↔ (∀ a b : α, a = b) :=
let n := fintype.card α in
have hn : n = fintype.card α := rfl,
match n, hn with
| 0 := λ ha, ⟨λ h, λ a, (fintype.card_eq_zero_iff.1 ha.symm a).elim, λ _, ha ▸ nat.le_succ _⟩
| 1 := λ ha, ⟨λ h, λ a b, let ⟨x, hx⟩ := fintype.card_eq_one_iff.1 ha.symm in
  by rw [hx a, hx b],
    λ _, ha ▸ le_refl _⟩
| (n+2) := λ ha, ⟨λ h, by rw ← ha at h; exact absurd h dec_trivial,
  (λ h, fintype.card_unit ▸ fintype.card_le_of_injective (λ _, ())
    (λ _ _ _, h _ _))⟩
end

lemma fintype.injective_iff_surjective [fintype α] {f : α → α} : injective f ↔ surjective f :=
by haveI := classical.prop_decidable; exact
have ∀ {f : α → α}, injective f → surjective f,
from λ f hinj x,
  have h₁ : image f univ = univ := eq_of_subset_of_card_le (subset_univ _)
    ((card_image_of_injective univ hinj).symm ▸ le_refl _),
  have h₂ : x ∈ image f univ := h₁.symm ▸ mem_univ _,
  exists_of_bex (mem_image.1 h₂),
⟨this,
  λ hsurj, injective_of_has_left_inverse
    ⟨surj_inv hsurj, left_inverse_of_surjective_of_right_inverse
      (this (injective_surj_inv _)) (right_inverse_surj_inv _)⟩⟩

lemma fintype.injective_iff_bijective [fintype α] {f : α → α} : injective f ↔ bijective f :=
by simp [bijective, fintype.injective_iff_surjective]

lemma fintype.surjective_iff_bijective [fintype α] {f : α → α} : surjective f ↔ bijective f :=
by simp [bijective, fintype.injective_iff_surjective]

lemma fintype.injective_iff_surjective_of_equiv [fintype α] {f : α → β} (e : α ≃ β) :
  injective f ↔ surjective f :=
have injective (e.symm ∘ f) ↔ surjective (e.symm ∘ f), from fintype.injective_iff_surjective,
⟨λ hinj, by simpa [function.comp] using
  surjective_comp e.bijective.2 (this.1 (injective_comp e.symm.bijective.1 hinj)),
λ hsurj, by simpa [function.comp] using
  injective_comp e.bijective.1 (this.2 (surjective_comp e.symm.bijective.2 hsurj))⟩

instance list.subtype.fintype [decidable_eq α] (l : list α) : fintype {x // x ∈ l} :=
fintype.of_list l.attach l.mem_attach

instance multiset.subtype.fintype [decidable_eq α] (s : multiset α) : fintype {x // x ∈ s} :=
fintype.of_multiset s.attach s.mem_attach

instance finset.subtype.fintype (s : finset α) : fintype {x // x ∈ s} :=
⟨s.attach, s.mem_attach⟩

instance finset_coe.fintype (s : finset α) : fintype (↑s : set α) :=
finset.subtype.fintype s

@[simp] lemma fintype.card_coe (s : finset α) :
  fintype.card (↑s : set α) = s.card := card_attach

instance plift.fintype (p : Prop) [decidable p] : fintype (plift p) :=
⟨if h : p then finset.singleton ⟨h⟩ else ∅, λ ⟨h⟩, by simp [h]⟩

instance Prop.fintype : fintype Prop :=
⟨⟨true::false::0, by simp [true_ne_false]⟩,
 classical.cases (by simp) (by simp)⟩

def set_fintype {α} [fintype α] (s : set α) [decidable_pred s] : fintype s :=
fintype.subtype (univ.filter (∈ s)) (by simp)

instance pi.fintype {α : Type*} {β : α → Type*}
  [fintype α] [decidable_eq α] [∀a, fintype (β a)] : fintype (Πa, β a) :=
@fintype.of_equiv _ _
  ⟨univ.pi $ λa:α, @univ (β a) _,
    λ f, finset.mem_pi.2 $ λ a ha, mem_univ _⟩
  ⟨λ f a, f a (mem_univ _), λ f a _, f a, λ f, rfl, λ f, rfl⟩

@[simp] lemma fintype.card_pi {β : α → Type*} [fintype α] [decidable_eq α]
  [f : Π a, fintype (β a)] : fintype.card (Π a, β a) = univ.prod (λ a, fintype.card (β a)) :=
by letI f' : fintype (Πa∈univ, β a) :=
  ⟨(univ.pi $ λa, univ), assume f, finset.mem_pi.2 $ assume a ha, mem_univ _⟩;
exact calc fintype.card (Π a, β a) = fintype.card (Π a ∈ univ, β a) : fintype.card_congr
  ⟨λ f a ha, f a, λ f a, f a (mem_univ a), λ _, rfl, λ _, rfl⟩
... = univ.prod (λ a, fintype.card (β a)) : finset.card_pi _ _

@[simp] lemma fintype.card_fun [fintype α] [decidable_eq α] [fintype β] :
  fintype.card (α → β) = fintype.card β ^ fintype.card α :=
by rw [fintype.card_pi, finset.prod_const, nat.pow_eq_pow]; refl

instance d_array.fintype {n : ℕ} {α : fin n → Type*}
  [∀n, fintype (α n)] : fintype (d_array n α) :=
fintype.of_equiv _ (equiv.d_array_equiv_fin _).symm

instance array.fintype {n : ℕ} {α : Type*} [fintype α] : fintype (array n α) :=
d_array.fintype

instance vector.fintype {α : Type*} [fintype α] {n : ℕ} : fintype (vector α n) :=
fintype.of_equiv _ (equiv.vector_equiv_fin _ _).symm

instance quotient.fintype [fintype α] (s : setoid α)
  [decidable_rel ((≈) : α → α → Prop)] : fintype (quotient s) :=
fintype.of_surjective quotient.mk (λ x, quotient.induction_on x (λ x, ⟨x, rfl⟩))

instance finset.fintype [fintype α] : fintype (finset α) :=
⟨univ.powerset, λ x, finset.mem_powerset.2 (finset.subset_univ _)⟩

instance subtype.fintype [fintype α] (p : α → Prop) [decidable_pred p] : fintype {x // p x} :=
set_fintype _

instance set.fintype [fintype α] [decidable_eq α] : fintype (set α) :=
pi.fintype

instance pfun_fintype (p : Prop) [decidable p] (α : p → Type*)
  [Π hp, fintype (α hp)] : fintype (Π hp : p, α hp) :=
if hp : p then fintype.of_equiv (α hp) ⟨λ a _, a, λ f, f hp, λ _, rfl, λ _, rfl⟩
          else ⟨singleton (λ h, (hp h).elim), by simp [hp, function.funext_iff]⟩

def quotient.fin_choice_aux {ι : Type*} [decidable_eq ι]
  {α : ι → Type*} [S : ∀ i, setoid (α i)] :
  ∀ (l : list ι), (∀ i ∈ l, quotient (S i)) → @quotient (Π i ∈ l, α i) (by apply_instance)
| []     f := ⟦λ i, false.elim⟧
| (i::l) f := begin
  refine quotient.lift_on₂ (f i (list.mem_cons_self _ _))
    (quotient.fin_choice_aux l (λ j h, f j (list.mem_cons_of_mem _ h)))
    _ _,
  exact λ a l, ⟦λ j h,
    if e : j = i then by rw e; exact a else
    l _ (h.resolve_left e)⟧,
  refine λ a₁ l₁ a₂ l₂ h₁ h₂, quotient.sound (λ j h, _),
  by_cases e : j = i; simp [e],
  { subst j, exact h₁ },
  { exact h₂ _ _ }
end

theorem quotient.fin_choice_aux_eq {ι : Type*} [decidable_eq ι]
  {α : ι → Type*} [S : ∀ i, setoid (α i)] :
  ∀ (l : list ι) (f : ∀ i ∈ l, α i), quotient.fin_choice_aux l (λ i h, ⟦f i h⟧) = ⟦f⟧
| []     f := quotient.sound (λ i h, h.elim)
| (i::l) f := begin
  simp [quotient.fin_choice_aux, quotient.fin_choice_aux_eq l],
  refine quotient.sound (λ j h, _),
  by_cases e : j = i; simp [e],
  subst j, refl
end

def quotient.fin_choice {ι : Type*} [fintype ι] [decidable_eq ι]
  {α : ι → Type*} [S : ∀ i, setoid (α i)]
  (f : ∀ i, quotient (S i)) : @quotient (Π i, α i) (by apply_instance) :=
quotient.lift_on (@quotient.rec_on _ _ (λ l : multiset ι,
    @quotient (Π i ∈ l, α i) (by apply_instance))
    finset.univ.1
    (λ l, quotient.fin_choice_aux l (λ i _, f i))
    (λ a b h, begin
      have := λ a, quotient.fin_choice_aux_eq a (λ i h, quotient.out (f i)),
      simp [quotient.out_eq] at this,
      simp [this],
      let g := λ a:multiset ι, ⟦λ (i : ι) (h : i ∈ a), quotient.out (f i)⟧,
      refine eq_of_heq ((eq_rec_heq _ _).trans (_ : g a == g b)),
      congr' 1, exact quotient.sound h,
    end))
  (λ f, ⟦λ i, f i (finset.mem_univ _)⟧)
  (λ a b h, quotient.sound $ λ i, h _ _)

theorem quotient.fin_choice_eq {ι : Type*} [fintype ι] [decidable_eq ι]
  {α : ι → Type*} [∀ i, setoid (α i)]
  (f : ∀ i, α i) : quotient.fin_choice (λ i, ⟦f i⟧) = ⟦f⟧ :=
begin
  let q, swap, change quotient.lift_on q _ _ = _,
  have : q = ⟦λ i h, f i⟧,
  { dsimp [q],
    exact quotient.induction_on
      (@finset.univ ι _).1 (λ l, quotient.fin_choice_aux_eq _ _) },
  simp [this], exact setoid.refl _
end

section equiv

open list equiv equiv.perm

variables [decidable_eq α] [decidable_eq β]

def perms_of_list : list α → list (perm α)
| []       := [1]
| (a :: l) := perms_of_list l ++ l.bind (λ b, (perms_of_list l).map (λ f, swap a b * f))

lemma length_perms_of_list : ∀ l : list α, length (perms_of_list l) = l.length.fact
| []       := rfl
| (a :: l) := by rw [length_cons, nat.fact_succ];
  simp [perms_of_list, length_bind, length_perms_of_list, function.comp, nat.succ_mul]

lemma mem_perms_of_list_of_mem : ∀ {l : list α} {f : perm α} (h : ∀ x, f x ≠ x → x ∈ l), f ∈ perms_of_list l
| []     f h := list.mem_singleton.2 $ equiv.ext _ _$ λ x, by simp [imp_false, *] at *
| (a::l) f h :=
if hfa : f a = a
then
  mem_append_left _ $ mem_perms_of_list_of_mem
    (λ x hx, mem_of_ne_of_mem (λ h, by rw h at hx; exact hx hfa) (h x hx))
else
have hfa' : f (f a) ≠ f a, from mt (λ h, f.bijective.1 h) hfa,
have ∀ (x : α), (swap a (f a) * f) x ≠ x → x ∈ l,
  from λ x hx, have hxa : x ≠ a, from λ h, by simpa [h, mul_apply] using hx,
    have hfxa : f x ≠ f a, from mt (λ h, f.bijective.1 h) hxa,
    list.mem_of_ne_of_mem hxa
      (h x (λ h, by simp [h, mul_apply, swap_apply_def] at hx; split_ifs at hx; cc)),
suffices f ∈ perms_of_list l ∨ ∃ (b : α), b ∈ l ∧ ∃ g : perm α, g ∈ perms_of_list l ∧ swap a b * g = f,
  by simpa [perms_of_list],
(@or_iff_not_imp_left _ _ (classical.prop_decidable _)).2
  (λ hfl, ⟨f a,
    if hffa : f (f a) = a then mem_of_ne_of_mem hfa (h _ (mt (λ h, f.bijective.1 h) hfa))
      else this _ $ by simp [mul_apply, swap_apply_def]; split_ifs; cc,
    ⟨swap a (f a) * f, mem_perms_of_list_of_mem this,
      by rw [← mul_assoc, mul_def (swap a (f a)) (swap a (f a)), swap_swap, ← one_def, one_mul]⟩⟩)

lemma mem_of_mem_perms_of_list : ∀ {l : list α} {f : perm α}, f ∈ perms_of_list l → ∀ {x}, f x ≠ x → x ∈ l
| []     f h := have f = 1 := by simpa [perms_of_list] using h, by rw this; simp
| (a::l) f h :=
(mem_append.1 h).elim
  (λ h x hx, mem_cons_of_mem _ (mem_of_mem_perms_of_list h hx))
  (λ h x hx,
    let ⟨y, hy, hy'⟩ := list.mem_bind.1 h in
    let ⟨g, hg₁, hg₂⟩ := list.mem_map.1 hy' in
    if hxa : x = a then by simp [hxa]
    else if hxy : x = y then mem_cons_of_mem _ $ by rwa hxy
    else mem_cons_of_mem _ $
    mem_of_mem_perms_of_list hg₁ $
      by rw [eq_inv_mul_iff_mul_eq.2 hg₂, mul_apply, swap_inv, swap_apply_def];
        split_ifs; cc)

lemma mem_perms_of_list_iff {l : list α} {f : perm α} : f ∈ perms_of_list l ↔ ∀ {x}, f x ≠ x → x ∈ l :=
⟨mem_of_mem_perms_of_list, mem_perms_of_list_of_mem⟩

lemma nodup_perms_of_list : ∀ {l : list α} (hl : l.nodup), (perms_of_list l).nodup
| []     hl := by simp [perms_of_list]
| (a::l) hl :=
have hl' : l.nodup, from nodup_of_nodup_cons hl,
have hln' : (perms_of_list l).nodup, from nodup_perms_of_list hl',
have hmeml : ∀ {f : perm α}, f ∈ perms_of_list l → f a = a,
  from λ f hf, not_not.1 (mt (mem_of_mem_perms_of_list hf) (nodup_cons.1 hl).1),
by rw [perms_of_list, list.nodup_append, list.nodup_bind, pairwise_iff_nth_le]; exact
⟨hln', ⟨λ _ _, nodup_map (λ _ _, (mul_left_inj _).1) hln',
  λ i j hj hij x hx₁ hx₂,
    let ⟨f, hf⟩ := list.mem_map.1 hx₁ in
    let ⟨g, hg⟩ := list.mem_map.1 hx₂ in
    have hix : x a = nth_le l i (lt_trans hij hj),
      by rw [← hf.2, mul_apply, hmeml hf.1, swap_apply_left],
    have hiy : x a = nth_le l j hj,
      by rw [← hg.2, mul_apply, hmeml hg.1, swap_apply_left],
    absurd (hf.2.trans (hg.2.symm)) $
      λ h, ne_of_lt hij $ nodup_iff_nth_le_inj.1 hl' i j (lt_trans hij hj) hj $
        by rw [← hix, hiy]⟩,
  λ f hf₁ hf₂,
    let ⟨x, hx, hx'⟩ := list.mem_bind.1 hf₂ in
    let ⟨g, hg⟩ := list.mem_map.1 hx' in
    have hgxa : g⁻¹ x = a, from f.bijective.1 $
      by rw [hmeml hf₁, ← hg.2]; simp,
    have hxa : x ≠ a, from λ h, (list.nodup_cons.1 hl).1 (h ▸ hx),
    (list.nodup_cons.1 hl).1 $
      hgxa ▸ mem_of_mem_perms_of_list hg.1 (by rwa [apply_inv_self, hgxa])⟩

def perms_of_finset (s : finset α) : finset (perm α) :=
quotient.hrec_on s.1 (λ l hl, ⟨perms_of_list l, nodup_perms_of_list hl⟩)
  (λ a b hab, hfunext (congr_arg _ (quotient.sound hab))
    (λ ha hb _, heq_of_eq $ finset.ext.2 $
      by simp [mem_perms_of_list_iff,mem_of_perm hab]))
  s.2

lemma mem_perms_of_finset_iff : ∀ {s : finset α} {f : perm α},
  f ∈ perms_of_finset s ↔ ∀ {x}, f x ≠ x → x ∈ s :=
by rintros ⟨⟨l⟩, hs⟩ f; exact mem_perms_of_list_iff

lemma card_perms_of_finset : ∀ (s : finset α),
  (perms_of_finset s).card = s.card.fact :=
by rintros ⟨⟨l⟩, hs⟩; exact length_perms_of_list l

def fintype_perm [fintype α] : fintype (perm α) :=
⟨perms_of_finset (@finset.univ α _), by simp [mem_perms_of_finset_iff]⟩

instance [fintype α] [fintype β] : fintype (α ≃ β) :=
if h : fintype.card β = fintype.card α
then trunc.rec_on_subsingleton (fintype.equiv_fin α)
  (λ eα, trunc.rec_on_subsingleton (fintype.equiv_fin β)
    (λ eβ, @fintype.of_equiv _ (perm α) fintype_perm
      (equiv_congr (equiv.refl α) (eα.trans (eq.rec_on h eβ.symm)) : (α ≃ α) ≃ (α ≃ β))))
else ⟨∅, λ x, false.elim (h (fintype.card_eq.2 ⟨x.symm⟩))⟩

lemma fintype.card_perm [fintype α] : fintype.card (perm α) = (fintype.card α).fact :=
subsingleton.elim (@fintype_perm α _ _) (@equiv.fintype α α _ _ _ _) ▸
card_perms_of_finset _

lemma fintype.card_equiv [fintype α] [fintype β] (e : α ≃ β) :
  fintype.card (α ≃ β) = (fintype.card α).fact :=
fintype.card_congr (equiv_congr (equiv.refl α) e) ▸ fintype.card_perm

end equiv


/-
Copyright (c) 2020 Johan Commelin, Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Damiano Testa
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.basic
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Initial lemmas to work with the `order_dual`

## Definitions
`to_dual` and `of_dual` the order reversing identity maps, bundled as equivalences.

## Basic Lemmas to convert between an order and its dual

This file is similar to algebra/group/type_tags.lean
-/

namespace order_dual

protected instance nontrivial {α : Type u} [nontrivial α] : nontrivial (order_dual α) :=
  id _inst_1

/-- `to_dual` is the identity function to the `order_dual` of a linear order.  -/
def to_dual {α : Type u} : α ≃ order_dual α :=
  equiv.mk id id sorry sorry

/-- `of_dual` is the identity function from the `order_dual` of a linear order.  -/
def of_dual {α : Type u} : order_dual α ≃ α :=
  equiv.symm to_dual

@[simp] theorem to_dual_symm_eq {α : Type u} : equiv.symm to_dual = of_dual :=
  rfl

@[simp] theorem of_dual_symm_eq {α : Type u} : equiv.symm of_dual = to_dual :=
  rfl

@[simp] theorem to_dual_of_dual {α : Type u} (a : order_dual α) : coe_fn to_dual (coe_fn of_dual a) = a :=
  rfl

@[simp] theorem of_dual_to_dual {α : Type u} (a : α) : coe_fn of_dual (coe_fn to_dual a) = a :=
  rfl

@[simp] theorem to_dual_inj {α : Type u} {a : α} {b : α} : coe_fn to_dual a = coe_fn to_dual b ↔ a = b :=
  iff.rfl

@[simp] theorem to_dual_le_to_dual {α : Type u} [HasLessEq α] {a : α} {b : α} : coe_fn to_dual a ≤ coe_fn to_dual b ↔ b ≤ a :=
  iff.rfl

@[simp] theorem to_dual_lt_to_dual {α : Type u} [HasLess α] {a : α} {b : α} : coe_fn to_dual a < coe_fn to_dual b ↔ b < a :=
  iff.rfl

@[simp] theorem of_dual_inj {α : Type u} {a : order_dual α} {b : order_dual α} : coe_fn of_dual a = coe_fn of_dual b ↔ a = b :=
  iff.rfl

@[simp] theorem of_dual_le_of_dual {α : Type u} [HasLessEq α] {a : order_dual α} {b : order_dual α} : coe_fn of_dual a ≤ coe_fn of_dual b ↔ b ≤ a :=
  iff.rfl

@[simp] theorem of_dual_lt_of_dual {α : Type u} [HasLess α] {a : order_dual α} {b : order_dual α} : coe_fn of_dual a < coe_fn of_dual b ↔ b < a :=
  iff.rfl

theorem le_to_dual {α : Type u} [HasLessEq α] {a : order_dual α} {b : α} : a ≤ coe_fn to_dual b ↔ b ≤ coe_fn of_dual a :=
  iff.rfl

theorem lt_to_dual {α : Type u} [HasLess α] {a : order_dual α} {b : α} : a < coe_fn to_dual b ↔ b < coe_fn of_dual a :=
  iff.rfl

theorem to_dual_le {α : Type u} [HasLessEq α] {a : α} {b : order_dual α} : coe_fn to_dual a ≤ b ↔ coe_fn of_dual b ≤ a :=
  iff.rfl

theorem to_dual_lt {α : Type u} [HasLess α] {a : α} {b : order_dual α} : coe_fn to_dual a < b ↔ coe_fn of_dual b < a :=
  iff.rfl