import M4R.Set.Finite.UnorderedList

namespace M4R

  structure Finset (α : Type _) where
    elems : UnorderedList α
    nodup : elems.nodup

  class Fintype (α : Type _) where
    (elems    : Finset α)
    (complete : ∀ x : α, x ∈ elems.elems)

  namespace Finset
    instance FinsetCoe : Coe (Finset α) (UnorderedList α) where coe := Finset.elems

    instance FinsetMem : Mem α (Finset α) where mem := fun x f => x ∈ f.elems

    instance FinsetToSubtype {α : Type u} : CoeSort (Finset α) (Type u) where coe := fun f => {x // x ∈ f}

    instance FinsetSizeOf : SizeOf (Finset α) where sizeOf := fun f => f.elems.sizeOf

    def length (f : Finset α) : Nat := f.elems.length

    theorem val_nodup (f : Finset α) : f.elems.nodup := f.nodup

    protected def toSet (f : Finset α) : Set α := Set.toSet f
    protected def ext_toSet {f : Finset α} {x : α} : x ∈ f ↔ x ∈ f.toSet := ⟨id, id⟩

    @[simp] theorem val_inj {s t : Finset α} : s.elems = t.elems ↔ s = t :=
      ⟨match s, t with | ⟨_, _⟩, ⟨_, _⟩ => by rw [Finset.mk.injEq]; exact id, congrArg _⟩

    theorem ext_iff {s₁ s₂ : Finset α} : s₁ = s₂ ↔ ∀ a, a ∈ s₁ ↔ a ∈ s₂ :=
      val_inj.symm.trans (UnorderedList.nodup_ext s₁.nodup s₂.nodup)

    protected theorem ext {s₁ s₂ : Finset α} : (∀ a, a ∈ s₁ ↔ a ∈ s₂) → s₁ = s₂ :=
      ext_iff.mpr

    theorem antisymm {s₁ s₂ : Finset α} (H₁ : s₁ ⊆ s₂) (H₂ : s₂ ⊆ s₁) : s₁ = s₂ :=
      Finset.ext fun a => ⟨@H₁ a, @H₂ a⟩

    protected def Empty : Finset α := ⟨0, Pairwise.nil⟩
    protected def Universal [Fintype α] : Finset α := Fintype.elems

    instance EmptyFinsetEmptyCollection : EmptyCollection (Finset α) where
      emptyCollection := Finset.Empty

    def length_empty (α : Type _) : (∅ : Finset α).length = 0 := rfl

    theorem empty_subset (f : Finset α) : (∅ : Finset α) ⊆ f :=
      fun _ _ => by contradiction

    theorem eq_empty_of_forall_not_mem {s : Finset α} (h : ∀ x, x ∉ s) : s = ∅ :=
      Finset.ext fun a => ⟨fun ha => absurd ha (h a), fun _ => by contradiction⟩

    theorem eq_empty_of_subset_empty {s : Finset α} (h : s ⊆ ∅) : s = ∅ :=
      eq_empty_of_forall_not_mem fun x hx => h hx

    theorem mem_empty {a : α} : a ∈ (∅ : Finset α) ↔ False := Iff.rfl
    theorem empty_val (α : Type _) : (∅ : Finset α).elems = 0 := rfl
    theorem empty_toSet (α : Type _) : (∅ : Finset α).toSet = ∅ := rfl

    theorem eq_empty_of_length_eq_zero {s : Finset α} (hs : s.length = 0) : s = ∅ :=
      val_inj.mp (UnorderedList.eq_nil_of_length_eq_zero hs)

    protected def singleton (a : α) : Finset α := ⟨UnorderedList.singleton a, Pairwise.singleton _ a⟩

    protected theorem in_singleton {a a' : α} : a' ∈ Finset.singleton a → a' = a :=
      UnorderedList.in_singleton

    protected theorem self_singleton (a : α) : a ∈ Finset.singleton a :=
      UnorderedList.self_singleton a

    protected theorem mem_singleton {a a' : α} : a' ∈ Finset.singleton a ↔ a' = a :=
      ⟨Finset.in_singleton, fun h => h.symm ▸ Finset.self_singleton a⟩

    theorem singleton_toSet (a : α) : (Finset.singleton a).toSet = Set.singleton a :=
      Set.ext.mp fun _ => Iff.trans Finset.mem_singleton Iff.rfl

    theorem length.eq_one {s : Finset α} : s.length = 1 ↔ ∃ a, s = Finset.singleton a :=
      Iff.trans UnorderedList.length.eq_one
        ⟨fun ⟨a, ha⟩ => ⟨a, val_inj.mp ha⟩, fun ⟨a, ha⟩ => ⟨a, val_inj.mpr ha⟩⟩

    section map
      protected def map (f : α → β) (s : Finset α) : UnorderedList β := s.elems.map f
      protected def map_inj {f : α → β} (hf : Function.injective f) (s : Finset α) : Finset β :=
        ⟨s.elems.map f, s.elems.nodup_map hf s.nodup⟩

      protected theorem map_mem {f : α → β} {b : β} {s : Finset α} : b ∈ s.map f ↔ ∃ a, a ∈ s ∧ f a = b :=
        UnorderedList.map.mem_map
      protected theorem map_inj_mem {f : α → β} {hf : Function.injective f} {b : β} {s : Finset α} :
        b ∈ s.map_inj hf ↔ ∃ a, a ∈ s ∧ f a = b  :=
          UnorderedList.map.mem_map
      protected theorem map_inj_mem' {f : α → β} {hf : Function.injective f} {b : β} {s : Finset α} :
        b ∈ s.map_inj hf ↔ ∃ a, a ∈ s ∧ f a = b ∧ ∀ a', f a' = b → a' = a :=
          ⟨fun h => by cases Finset.map_inj_mem.mp h with | intro a ha =>
            exact ⟨a, ha.left, ha.right, fun a' ha' => by rw [←ha.right] at ha'; exact hf ha'⟩,
          fun ⟨a, b, c, _⟩ => Finset.map_inj_mem.mpr ⟨a, b, c⟩⟩

      protected theorem mem_map_inj {f : α → β} {hf : Function.injective f} {a : α} {s : Finset α} : a ∈ s ↔ f a ∈ s.map_inj hf :=
        ⟨fun h => Finset.map_inj_mem.mpr ⟨a, h, rfl⟩,
        fun h => let ⟨b, hb, _, hu⟩ := Finset.map_inj_mem'.mp h; hu a rfl ▸ hb⟩
      protected theorem not_mem_map_inj {f : α → β} {hf : Function.injective f} {a : α} {s : Finset α} :
        a ∉ s ↔ f a ∉ s.map_inj hf := not_iff_not.mpr Finset.mem_map_inj

      protected theorem map_empty (f : α → β) : Finset.map f ∅ = 0 := rfl
      protected theorem map_inj_empty {f : α → β} (hf : Function.injective f) : Finset.map_inj hf ∅ = ∅ := rfl
    end map

    @[simp] theorem val_le_iff {s₁ s₂ : Finset α} : s₁.elems ≤ s₂.elems ↔ s₁ ⊆ s₂ :=
      UnorderedList.le.le_iff_subset s₁.nodup

    noncomputable def union (s₁ s₂ : Finset α) : Finset α :=
      ⟨s₁.elems.ndunion s₂.elems, UnorderedList.nodup_ndunion s₁.elems s₂.nodup⟩

    noncomputable instance FinsetUnion : Union (Finset α) where union := union

    @[simp] theorem union_val (s₁ s₂ : Finset α) : (s₁ ∪ s₂).elems = s₁.elems ∪ s₂.elems :=
      UnorderedList.ndunion_eq_union s₁.nodup

    @[simp] theorem mem_union {a : α} {s₁ s₂ : Finset α} : a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
      UnorderedList.mem_ndunion

    theorem mem_union_left {a : α} {s₁ : Finset α} (s₂ : Finset α) (h : a ∈ s₁) : a ∈ s₁ ∪ s₂ :=
      mem_union.mpr (Or.inl h)

    theorem mem_union_right {a : α} {s₂ : Finset α} (s₁ : Finset α) (h : a ∈ s₂) : a ∈ s₁ ∪ s₂ :=
      mem_union.mpr (Or.inr h)

    theorem union_subset {s₁ s₂ s₃ : Finset α} (h₁ : s₁ ⊆ s₃) (h₂ : s₂ ⊆ s₃) : s₁ ∪ s₂ ⊆ s₃ :=
      val_le_iff.mp (UnorderedList.ndunion_le.2 ⟨h₁, val_le_iff.mpr h₂⟩)

    theorem subset_union_left (s₁ s₂ : Finset α) : s₁ ⊆ s₁ ∪ s₂ := fun x => mem_union_left _

    theorem subset_union_right (s₁ s₂ : Finset α) : s₂ ⊆ s₁ ∪ s₂ := fun x => mem_union_right _

    theorem union_subset_union {s₁ t₁ s₂ t₂ : Finset α} (h₁ : s₁ ⊆ t₁) (h₂ : s₂ ⊆ t₂) :
        s₁ ∪ s₂ ⊆ t₁ ∪ t₂ := by
          intro x hx; rw [mem_union] at hx ⊢
          exact Or.elim hx (fun h => Or.inl (h₁ h)) (fun h => Or.inr (h₂ h))

    theorem union_comm (s₁ s₂ : Finset α) : s₁ ∪ s₂ = s₂ ∪ s₁ := by
      apply Finset.ext; intro _; simp only [mem_union, Or.comm']; exact Iff.rfl

    theorem union_assoc (s₁ s₂ s₃ : Finset α) : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) := by
      apply Finset.ext; intro _; simp only [mem_union, Or.assoc]; exact Iff.rfl

    theorem union_self (s : Finset α) : s ∪ s = s :=
      Finset.ext fun a => by rw [Finset.mem_union, or_self]; exact Iff.rfl

    theorem union_toSet (s t : Finset α) : (s ∪ t).toSet = s.toSet ∪ t.toSet :=
      Set.ext.mp fun _ => by rw [←Finset.ext_toSet, mem_union]; exact Iff.rfl

    theorem union_empty_right (s : Finset α) : s ∪ ∅ = s :=
      Finset.ext fun x => by rw [mem_union, mem_empty, or_false]; exact Iff.rfl

    theorem union_empty_left (s : Finset α) : ∅ ∪ s = s :=
      union_comm ∅ s ▸ union_empty_right s

    noncomputable def intersection (s₁ s₂ : Finset α) : Finset α :=
      ⟨s₁.elems.ndinter s₂.elems, UnorderedList.nodup_ndinter s₂.elems s₁.nodup⟩

    noncomputable instance FinsetIntersection : Intersection (Finset α) where intersection := intersection

    @[simp] theorem inter_val (s₁ s₂ : Finset α) : (s₁ ∩ s₂).elems = s₁.elems ∩ s₂.elems :=
      UnorderedList.ndinter_eq_inter s₁.nodup

    @[simp] theorem mem_inter {a : α} {s₁ s₂ : Finset α} : a ∈ s₁ ∩ s₂ ↔ a ∈ s₁ ∧ a ∈ s₂ :=
      UnorderedList.mem_ndinter

    theorem inter_comm (s₁ s₂ : Finset α) : s₁ ∩ s₂ = s₂ ∩ s₁ := by
      apply Finset.ext; intro _; simp only [mem_inter, And.comm']; exact Iff.rfl

    theorem inter_assoc (s₁ s₂ s₃ : Finset α) : (s₁ ∩ s₂) ∩ s₃ = s₁ ∩ (s₂ ∩ s₃) := by
      apply Finset.ext; intro _; simp only [mem_inter, And.assoc]; exact Iff.rfl

    def disjoint (s₁ s₂ : Finset α) : Prop := s₁ ∩ s₂ = ∅

    theorem singleton_disjoint {a b : α} : disjoint (Finset.singleton a) (Finset.singleton b) ↔ a ≠ b := by
      simp only [disjoint, Finset.ext_iff, Finset.mem_empty, iff_false, Finset.mem_inter, not_and_iff_or_not,
        Finset.mem_singleton]
      exact ⟨fun h => (h a).resolve_left (iff_not_not.mpr rfl), fun h x => by
        byCases hx : x = a
        { exact hx.symm ▸ Or.inr h }
        { exact Or.inl hx }⟩

    noncomputable def filter (p : α → Prop) (s : Finset α) : Finset α := ⟨UnorderedList.filter p s.elems,
      UnorderedList.nodup_filter p s.nodup⟩

    @[simp] theorem filter_val (p : α → Prop) (s : Finset α) : (s.filter p).elems = s.elems.filter p := rfl

    @[simp] theorem mem_filter {s : Finset α} {a : α} : a ∈ s.filter p ↔ a ∈ s ∧ p a := UnorderedList.mem_filter

    theorem filter_empty (p : α → Prop) : (∅ : Finset α).filter p = ∅ := rfl

    noncomputable instance sdiff_SetMinus : SetMinus (Finset α) :=
      ⟨fun s₁ s₂ => ⟨s₁.elems - s₂.elems, @UnorderedList.le.nodup_of_le α (s₁.elems - s₂.elems) s₁.elems
        (UnorderedList.le.sub_le_self _ _) s₁.nodup⟩⟩

    @[simp] theorem sdiff_val (s₁ s₂ : Finset α) : (s₁ ∖ s₂).elems = s₁.elems - s₂.elems := rfl

    @[simp] theorem mem_sdiff {s t : Finset α} {a : α}: a ∈ s ∖ t ↔ a ∈ s ∧ a ∉ t :=
      UnorderedList.sub.mem_sub_of_nodup s.nodup

    theorem union_sdiff_of_subset {s₁ s₂ : Finset α} (h : s₁ ⊆ s₂) : s₁ ∪ (s₂ ∖ s₁) = s₂ := by
      apply Finset.ext; intro x
      simp only [Finset.mem_union, Finset.mem_sdiff]
      exact ⟨fun h' => Or.elim h' (h ·) And.left,
        fun h' => Or.elim (Classical.em (x ∈ s₁)) Or.inl (Or.inr ⟨h', ·⟩)⟩

    theorem sdiff_union_of_subset {s₁ s₂ : Finset α} (h : s₁ ⊆ s₂) : (s₂ ∖ s₁) ∪ s₁ = s₂ :=
      (union_comm _ _).trans (union_sdiff_of_subset h)

    theorem inter_sdiff (s t u : Finset α) : s ∩ (t ∖ u) = (s ∩ t) ∖ u := by
      apply Finset.ext; intro x; simp only [mem_inter, mem_sdiff, And.assoc]; exact Iff.rfl

    @[simp] theorem inter_sdiff_self (s₁ s₂ : Finset α) : s₁ ∩ (s₂ ∖ s₁) = ∅ :=
      eq_empty_of_forall_not_mem (by simp only [mem_inter, mem_sdiff]; exact fun x ⟨h, _, hn⟩ => absurd h hn)

    theorem union_sdiff (s₁ s₂ : Finset α) : s₁ ∪ s₂ ∖ s₁ = s₁ ∪ s₂ :=
      Finset.ext fun _ => by
        simp only [Finset.mem_union, Finset.mem_sdiff]
        exact ⟨Or.imp_right And.left, (Or.elim · Or.inl (fun h => or_iff_not_imp_left.mpr (And.intro h)))⟩

    theorem disjoint_sdiff (s₁ s₂ : Finset α) : disjoint s₁ (s₂ ∖ s₁) :=
      inter_sdiff_self s₁ s₂

    theorem sdiff_empty_left (s : Finset α) : ∅ ∖ s = ∅ :=
      Finset.ext fun _ => by simp only [Finset.mem_sdiff, Finset.mem_empty, false_and]

    theorem sdiff_empty_right (s : Finset α) : s ∖ ∅ = s :=
      Finset.ext fun _ => by simp only [Finset.mem_sdiff, Finset.mem_empty, and_true]; exact Iff.rfl

    section cons

      def cons (a : α) (s : Finset α) (h : a ∉ s) : Finset α :=
        ⟨s.elems.cons a, UnorderedList.nodup_cons.mpr ⟨h, s.nodup⟩⟩

      @[simp] theorem mem_cons {a : α} {s : Finset α} {h : a ∉ s} {b : α} : b ∈ @cons α a s h ↔ b = a ∨ b ∈ s :=
        UnorderedList.mem_cons

      @[simp] theorem mem_cons_self {a : α} (s : Finset α) (h : a ∉ s) : a ∈ cons a s h :=
        mem_cons.mpr (Or.inl rfl)

      @[simp] theorem mem_cons_self' {a : α} {s : Finset α} (h : a ∉ s) {b : α} (hb : b ∈ s) : b ∈ cons a s h :=
        mem_cons.mpr (Or.inr hb)

      @[simp] theorem cons_val {a : α} {s : Finset α} (h : a ∉ s) : (cons a s h).elems = s.elems.cons a := rfl

      @[simp] theorem mk_cons {a : α} {s : UnorderedList α} (h : (s.cons a).nodup) :
        (⟨s.cons a, h⟩ : Finset α) = cons a ⟨s, (UnorderedList.nodup_cons.mp h).right⟩ (UnorderedList.nodup_cons.mp h).left := rfl

      theorem cons_subset {a : α} (s : Finset α) (h : a ∉ s) : s ⊆ s.cons a h :=
        fun _ => UnorderedList.mem_cons_of_mem

      theorem cons_subsetneq {a : α} (s : Finset α) (h : a ∉ s) : s ⊊ s.cons a h :=
        ⟨cons_subset s h, a, h, mem_cons_self s h⟩

      theorem length_cons {a : α} (s : Finset α) (h : a ∉ s) : (s.cons a h).length = s.length + 1 :=
        UnorderedList.length.cons a s

      theorem cons_toSet {a : α} {s : Finset α} (h : a ∉ s) : (s.cons a h).toSet = s.toSet.insert a :=
        Set.ext.mp fun _ => Finset.mem_cons

    end cons

    protected theorem map_cons (f : α → β) (s : Finset α) {a : α} (ha : a ∉ s) : (s.cons a ha).map f = (s.map f).cons (f a) :=
      UnorderedList.map.cons f a s
    protected theorem map_inj_cons {f : α → β} (hf : Function.injective f) (s : Finset α) {a : α} (ha : a ∉ s) :
      (s.cons a ha).map_inj hf = (s.map_inj hf).cons (f a) (Finset.not_mem_map_inj.mp ha) := by
        apply Finset.ext; intro x; rw [mem_cons]
        exact ⟨fun h =>
          let ⟨b, hb, he⟩ := Finset.map_inj_mem.mp h
          Or.imp (· ▸ he.symm : _) (he ▸ Finset.mem_map_inj.mp ·) (mem_cons.mp hb),
        fun h =>
          Or.elim h (· ▸ Finset.mem_map_inj.mp (mem_cons_self s ha)) (fun h =>
            let ⟨b, hb, he⟩ := Finset.map_inj_mem.mp h
            Finset.map_inj_mem.mpr ⟨b, mem_cons.mpr (Or.inr hb), he⟩)⟩

    @[simp] theorem length_map (f : α → β) (s : Finset α) : (s.map f).length = s.length :=
      UnorderedList.map.length_map f s.elems

    @[simp] theorem filter_cons_of_pos (p : α → Prop) {a : α} {s : Finset α} (ha : a ∉ s) (hpa : p a) : filter p (s.cons a ha) = (filter p s).cons a (fun h =>
      absurd (mem_filter.mp h).left ha) :=
        Finset.ext fun x => by
          simp only [Finset.mem_cons, Finset.mem_filter]
          exact ⟨fun ⟨h₁, h₂⟩ => h₁.imp_right (fun h => ⟨h, h₂⟩), fun h => h.elim (fun h => ⟨Or.inl h, h ▸ hpa⟩) (And.imp_left Or.inr)⟩

    @[simp] theorem filter_cons_of_neg (p : α → Prop) {a : α} {s : Finset α} (ha : a ∉ s) (hpa : ¬p a) : filter p (s.cons a ha) = filter p s :=
      Finset.ext fun x => by
        simp only [Finset.mem_filter, Finset.mem_cons]
        exact ⟨fun ⟨h₁, h₂⟩ => ⟨h₁.resolve_left (fun h => absurd (h ▸ h₂) hpa), h₂⟩, And.imp_left Or.inr⟩

    section insert

      noncomputable def insert (a : α) (s : Finset α) : Finset α :=
        ⟨s.elems.ndinsert a, UnorderedList.nodup_ndinsert a s.nodup⟩

      theorem insert_def (a : α) (s : Finset α) : insert a s = ⟨s.elems.ndinsert a, UnorderedList.nodup_ndinsert a s.nodup⟩ := rfl

      @[simp] theorem insert_val (a : α) (s : Finset α) : (insert a s).elems = s.elems.ndinsert a := rfl

      theorem insert_val_of_not_mem {a : α} {s : Finset α} (h : a ∉ s) : (insert a s).elems = s.elems.cons a := by
        rw [insert_val, UnorderedList.ndinsert_of_not_mem h]

      @[simp] theorem mem_insert {a b : α} {s : Finset α} : a ∈ insert b s ↔ a = b ∨ a ∈ s := UnorderedList.mem_ndinsert

      theorem mem_insert_self (a : α) (s : Finset α) : a ∈ insert a s := UnorderedList.mem_ndinsert_self a s.elems

      theorem mem_insert_of_mem {a b : α} {s : Finset α} (h : a ∈ s) : a ∈ insert b s :=
        UnorderedList.mem_ndinsert_of_mem h

      theorem mem_of_mem_insert_of_ne {a b : α} {s : Finset α} (h : b ∈ insert a s) : b ≠ a → b ∈ s :=
        (mem_insert.mp h).resolve_left

      @[simp] theorem cons_eq_insert (a : α) (s : Finset α) (h : a ∉ s) : @cons α a s h = insert a s := by
        apply Finset.ext; intro x; rw [mem_cons, mem_insert]; exact Iff.rfl

      @[simp] theorem insert_eq_of_mem {a : α} {s : Finset α} (h : a ∈ s) : insert a s = s :=
        val_inj.mp (UnorderedList.ndinsert_of_mem h)

      theorem insert.comm (a b : α) (s : Finset α) : insert a (insert b s) = insert b (insert a s) := by
        apply Finset.ext; intro x; rw [mem_insert, mem_insert, mem_insert, mem_insert,
          Or.left_comm']; exact Iff.rfl

    end insert

    theorem cons_induction {p : Finset α → Prop} (h₁ : p ∅)
      (h₂ : ∀ ⦃a : α⦄ {s : Finset α} (h : a ∉ s), p s → p (cons a s h)) : ∀ s, p s
    | ⟨s, nd⟩ =>
      @UnorderedList.induction_on α (fun l => (h : l.nodup) → p ⟨l, h⟩) s
        (fun _ => h₁) (fun a s ih nd => by
          let ⟨m, nd'⟩ := UnorderedList.nodup_cons.mp nd
          rw [(val_inj.mp rfl : ⟨s.cons a, nd⟩ = cons a (Finset.mk s nd') m)]
          exact h₂ m (ih nd')) nd

    theorem cons_induction_on {p : Finset α → Prop} (s : Finset α) (h₁ : p ∅)
      (h₂ : ∀ ⦃a : α⦄ {s : Finset α} (h : a ∉ s), p s → p (cons a s h)) : p s :=
        cons_induction h₁ h₂ s

    protected theorem induction (p : Finset α → Prop) (h₁ : p ∅)
      (h₂ : ∀ ⦃a : α⦄ {s : Finset α}, a ∉ s → p s → p (insert a s)) : ∀ s, p s :=
        cons_induction h₁ fun a s ha => (s.cons_eq_insert a ha).symm ▸ h₂ ha

    protected theorem induction_on (p : Finset α → Prop) (s : Finset α) (h₁ : p ∅)
      (h₂ : ∀ ⦃a : α⦄ {s : Finset α}, a ∉ s → p s → p (insert a s)) : p s :=
        Finset.induction p h₁ h₂ s

    theorem strong_induction (p : Finset α → Prop) (ih : ∀ f : Finset α, (∀ f' : Finset α, f'.length < f.length → p f') → p f)
      (f : Finset α) : p f :=
        ih f (@cons_induction _ (fun f : Finset α => ∀ f' : Finset α, f'.length < f.length → p f')
          (fun f h => absurd h f.length.not_lt_zero)
          (fun x f hx ih' f' hf' => by
            rw [Finset.length_cons] at hf'
            exact (Nat.lt_or_eq_of_le (Nat.le_of_succ_le_succ hf')).elim
              (ih' f') (fun h => ih f' (h ▸ ih'))) f)

    section erase

      noncomputable def erase (s : Finset α) (a : α) : Finset α := ⟨_, UnorderedList.erase.nodup_erase_of_nodup a s.nodup⟩

      @[simp] theorem erase_val (s : Finset α) (a : α) : (erase s a).elems = s.elems.erase a := rfl

      @[simp] theorem mem_erase {a b : α} {s : Finset α} : a ∈ erase s b ↔ a ≠ b ∧ a ∈ s :=
        UnorderedList.erase.mem_erase_iff_of_nodup s.nodup

      theorem not_mem_erase (a : α) (s : Finset α) : a ∉ erase s a := UnorderedList.erase.mem_erase_of_nodup s.nodup

      @[simp] theorem erase_empty (a : α) : erase ∅ a = ∅ := rfl

      theorem erase_insert {a : α} {s : Finset α} (h : a ∉ s) : erase (insert a s) a = s := by
        apply Finset.ext; intro x
        simp only [mem_erase, mem_insert, and_or_distrib_left, false_and, not_and_self, false_or]
        exact ⟨And.right, fun h' => ⟨fun h'' => by rw [h''] at h'; exact absurd h' h, h'⟩⟩

      theorem erase_cons {a : α} (s : Finset α) (hs : a ∈ s) : s = (s.erase a).cons a (not_mem_erase a s) :=
        Finset.ext fun x => by
          byCases hx : x = a
          { simp only [hx, hs, true_iff]; exact mem_cons_self _ _ }
          { simp only [mem_cons, hx, false_or, mem_erase, ne_eq, true_and]; exact Iff.rfl }

    end erase
  end Finset

  namespace Set

    def to_finset (s : Set α) [Fintype s] : Finset α :=
      ⟨(@Finset.Universal s).elems.map Subtype.val, by
        apply UnorderedList.nodup_map; apply Set.elementExt; exact Finset.Universal.nodup⟩

    @[simp] theorem mem_to_finset {s : Set α} [Fintype s] {a : α} : a ∈ s.to_finset ↔ a ∈ s :=
      ⟨fun h => by let ⟨⟨x, hx⟩, _, h'⟩ := UnorderedList.map.mem_map.mp h; rw [←h']; exact hx,
      fun h => UnorderedList.map.mem_map.mpr ⟨⟨a, h⟩, Fintype.complete _, rfl⟩⟩

    @[simp] theorem mem_to_finset_val {s : Set α} [Fintype s] {a : α} : a ∈ s.to_finset.elems ↔ a ∈ s :=
      mem_to_finset

  end Set

  namespace UnorderedList

    noncomputable def to_finset (l : UnorderedList α) : Finset α := ⟨l.dedup, UnorderedList.nodup_dedup l⟩

    @[simp] theorem to_finset_val (l : UnorderedList α) : l.to_finset.elems = l.dedup := rfl

    @[simp] theorem mem_to_finset {a : α} {s : UnorderedList α} : a ∈ s.to_finset ↔ a ∈ s := UnorderedList.mem_dedup

    @[simp] theorem to_finset_zero : to_finset (0 : UnorderedList α) = ∅ := rfl

    theorem to_finset_toSet (l : UnorderedList α) : l.toSet = l.to_finset.toSet :=
      Set.ext.mp fun _ => mem_to_finset.symm

    theorem to_finset_ext {s t : UnorderedList α} : s.to_finset = t.to_finset ↔ ∀ a, a ∈ s ↔ a ∈ t := by
      rw [Finset.ext_iff]; apply forall_congr'; intro
      rw [mem_to_finset, mem_to_finset]; exact Iff.rfl

    theorem to_finset_cons_of_pos {l : UnorderedList α} {a : α} (ha : a ∈ l) : (l.cons a).to_finset = l.to_finset := by
      apply to_finset_ext.mpr; intro; rw [UnorderedList.mem_cons]
      exact ⟨fun h => Or.elim h (· ▸ ha) id, Or.inr⟩
    theorem to_finset_cons_of_neg {l : UnorderedList α} {a : α} (ha : a ∉ l) :
      (l.cons a).to_finset = l.to_finset.cons a (mt mem_to_finset.mp ha) := by
        apply Finset.ext; intro
        rw [mem_to_finset, UnorderedList.mem_cons, Finset.mem_cons, mem_to_finset]
        exact Iff.rfl

    theorem to_finset_length_le (l : UnorderedList α) : l.to_finset.length ≤ l.length :=
      length.le_of_le l.dedup_le

  end UnorderedList

  namespace Fintype

    protected instance Empty : Fintype (∅ : Set α) where
      elems := ∅
      complete := fun ⟨x, hx⟩ => by contradiction

    protected def subtype {p : α → Prop} (s : Finset α) (H : ∀ x : α, x ∈ s ↔ p x) : Fintype {x // p x} :=
      ⟨⟨UnorderedList.pmap Subtype.mk s.elems fun x => (H x).mp,
        UnorderedList.nodup_pmap (fun a _ b _ => congrArg Subtype.val) s.nodup⟩,
      fun ⟨x, px⟩ => UnorderedList.mem_pmap.mpr ⟨x, (H x).mpr px, rfl⟩⟩

    protected def of_finset {p : Set α} (s : Finset α) (H : ∀ x, x ∈ s ↔ x ∈ p) : Fintype p :=
      Fintype.subtype s H

    protected noncomputable instance union (s t : Set α) [Fintype s] [Fintype t] : Fintype (s ∪ t : Set α) :=
      Fintype.of_finset (s.to_finset ∪ t.to_finset) (fun x =>
        ⟨fun h => by
          have := UnorderedList.mem_ndunion.mp h
          simp only [Set.mem_to_finset_val] at this
          exact this,
        fun h =>
          Finset.mem_union.mpr (Or.elim h
            (fun h' => Or.inl (Set.mem_to_finset.mpr h'))
            (fun h' => Or.inr (Set.mem_to_finset.mpr h')))⟩)

    protected noncomputable instance sep (s : Set α) (p : α → Prop) [Fintype s] :
      Fintype (Subtype ({a ∈ s | p a} : Set α)) :=
        Fintype.of_finset (s.to_finset.filter p) (fun _ => by
          simp only [Finset.mem_filter, Set.mem_to_finset]; exact Iff.rfl)

    protected noncomputable instance intersection (s t : Set α) [Fintype s] : Fintype (s ∩ t : Set α) :=
      Fintype.sep s t

    protected noncomputable instance subset {s t : Set α} [Fintype t] (h : s ⊆ t) : Fintype s := by
      rw [←Set.intersection.inter_eq_self_of_subset_right h]
      exact Fintype.intersection t s

  end Fintype

  inductive finite (s : Set α) : Prop
  | intro : Fintype s → finite s

  def infinite (s : Set α) : Prop := ¬ finite s

  def Finset.to_finite (f : Finset α) : finite (f.toSet) :=
    finite.intro (Fintype.of_finset f (fun _ => Finset.ext_toSet))

  namespace finite

    theorem empty (α : Type _) : finite (∅ : Set α) := ⟨Fintype.Empty⟩

    theorem iff_exists_fintype {s : Set α} : finite s ↔ Nonempty (Fintype s) :=
      ⟨fun ⟨h⟩ => ⟨h⟩, fun ⟨h⟩ => ⟨h⟩⟩

    noncomputable def to_fintype {s : Set α} (h : finite s) : Fintype s :=
      Classical.choice (iff_exists_fintype.mp h)

    noncomputable def to_finset {s : Set α} (h : finite s) : Finset α :=
      @Set.to_finset _ s h.to_fintype

    @[simp] theorem mem_to_finset {s : Set α} (hs : finite s) {a : α} : a ∈ hs.to_finset ↔ a ∈ s :=
      ⟨fun h => by let ⟨⟨x, hx⟩, _, h'⟩ := UnorderedList.map.mem_map.mp h; rw [←h']; exact hx,
      fun h => UnorderedList.map.mem_map.mpr ⟨⟨a, h⟩, hs.to_fintype.complete _, rfl⟩⟩

    @[simp] theorem to_finset_toSet {s : Set α} (hs : finite s) : hs.to_finset.toSet = s :=
      Set.ext.mp fun _ => by rw [←hs.mem_to_finset]; exact Iff.rfl

    @[simp] theorem mem_to_finset_val {s : Set α} (hs : finite s) {a : α} : a ∈ hs.to_finset.elems ↔ a ∈ s :=
      mem_to_finset hs

    theorem to_finset_ext {s t : Set α} {hs : finite s} {ht : finite t} : hs.to_finset = ht.to_finset ↔ ∀ a, a ∈ s ↔ a ∈ t := by
      rw [Finset.ext_iff]; apply forall_congr'; intro
      rw [mem_to_finset, mem_to_finset]; exact Iff.rfl

    theorem subset {s t : Set α} (ht : finite t) (h : s ⊆ t) : finite s :=
      finite.intro (@Fintype.subset _ s t ht.to_fintype h)

    theorem union {s t : Set α} (hs : finite s) (ht : finite t) : finite (s ∪ t) :=
      finite.intro (@Fintype.union _ s t hs.to_fintype ht.to_fintype)

    theorem intersection {s : Set α} (hs : finite s) (t : Set α) : finite (s ∩ t) :=
      finite.intro (@Fintype.intersection _ s t hs.to_fintype)

    theorem intersection' (s : Set α) {t : Set α} (ht : finite t) : finite (s ∩ t) := by
      rw [Set.intersection.comm]; exact intersection ht s

  end finite
  namespace infinite
    variable {s : Set α} (hs : infinite s)
    open Classical

    theorem nonempty : ∃ x, x ∈ s :=
      byContradiction fun h => hs (by
        simp only [not_exists] at h
        exact Set.empty.mpr h ▸ finite.empty α)

    theorem not_in_finset (f : Finset α) : ∃ x ∈ s, x ∉ f :=
      byContradiction fun h => hs (by
        simp only [not_exists, not_and, iff_not_not] at h
        exact f.to_finite.subset h)

    noncomputable def choose_finset : Nat → Finset α
    | 0   => Finset.singleton (choose (hs.not_in_finset ∅))
    | n+1 => have := hs.not_in_finset (choose_finset n)
      (choose_finset n).cons (choose this) (choose_spec this).right

    theorem choose_finset_subset_succ (n : Nat) : hs.choose_finset n ⊊ hs.choose_finset n.succ :=
      Finset.cons_subsetneq _ (choose_spec (hs.not_in_finset (hs.choose_finset n))).right

    theorem choose_finset_subset_add (m n : Nat) : hs.choose_finset m ⊆ hs.choose_finset (m + n) := by
      induction n with
      | zero      => exact Subset.refl _
      | succ n ih => exact Subset.trans ih (hs.choose_finset_subset_succ (m + n)).left

    theorem choose_finset_subset_le {m n : Nat} (h : m ≤ n) : hs.choose_finset m ⊆ hs.choose_finset n :=
      let ⟨k, hk⟩ := Nat.le.dest h
      hk ▸ hs.choose_finset_subset_add m k

    noncomputable def nat_inclusion : Nat → s
    | 0   =>
      have := hs.not_in_finset ∅
      ⟨choose this, (choose_spec this).left⟩
    | n+1 =>
      have := hs.not_in_finset (hs.choose_finset n)
      ⟨choose this, (choose_spec this).left⟩

    theorem nat_inclusion_notin (n : Nat) : (hs.nat_inclusion (n+1)).val ∉ hs.choose_finset n :=
      (choose_spec (hs.not_in_finset (hs.choose_finset n))).right

    theorem nat_inclusion_notin_lt {m n: Nat} (h : m < n) : (hs.nat_inclusion n).val ∉ hs.choose_finset m :=
      match n with
      | 0   => absurd h (Nat.not_lt_zero m)
      | n+1 => fun h' => absurd (hs.choose_finset_subset_le (Nat.le_of_succ_le_succ h) h')
        (hs.nat_inclusion_notin n)

    theorem nat_inclusion_cons (n : Nat) : hs.choose_finset (n+1) = (hs.choose_finset n).cons
      (hs.nat_inclusion (n+1)).val (hs.nat_inclusion_notin n) := rfl

    theorem nat_inclusion_in : (n : Nat) → (hs.nat_inclusion n).val ∈ hs.choose_finset n
    | 0   => Finset.mem_singleton.mpr rfl
    | n+1 => hs.nat_inclusion_cons n ▸ Finset.mem_cons_self _ _

    theorem nat_inclusion_le_injective {m n : Nat} (h₁ : m ≤ n) (h₂ : hs.nat_inclusion m = hs.nat_inclusion n) : m = n :=
      (Nat.lt_or_eq_of_le h₁).resolve_left (fun h₁ => absurd (h₂ ▸ hs.nat_inclusion_in m)
        (hs.nat_inclusion_notin_lt h₁))

    theorem nat_inclusion_injective : Function.injective hs.nat_inclusion :=
      fun m n h => Or.elim (Nat.le_total m n) (hs.nat_inclusion_le_injective · h)
        (fun h' => (hs.nat_inclusion_le_injective h' h.symm).symm)

  end infinite
end M4R


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

! This file was ported from Lean 3 source module combinatorics.simple_graph.regularity.equitabilise
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Partition.Equipartition

/-!
# Equitabilising a partition

This file allows to blow partitions up into parts of controlled size. Given a partition `P` and
`a b m : ℕ`, we want to find a partition `Q` with `a` parts of size `m` and `b` parts of size
`m + 1` such that all parts of `P` are "as close as possible" to unions of parts of `Q`. By
"as close as possible", we mean that each part of `P` can be written as the union of some parts of
`Q` along with at most `m` other elements.

## Main declarations

* `Finpartition.equitabilise`: `P.equitabilise h` where `h : a * m + b * (m + 1)` is a partition
  with `a` parts of size `m` and `b` parts of size `m + 1` which almost refines `P`.
* `Finpartition.exists_equipartition_card_eq`: We can find equipartitions of arbitrary size.
-/

open Finset Nat

namespace Finpartition

variable {α : Type _} [DecidableEq α] {s t : Finset α} {m n a b : ℕ} {P : Finpartition s}

/-- Given a partition `P` of `s`, as well as a proof that `a * m + b * (m + 1) = s.card`, we can
find a new partition `Q` of `s` where each part has size `m` or `m + 1`, every part of `P` is the
union of parts of `Q` plus at most `m` extra elements, there are `b` parts of size `m + 1` and
(provided `m > 0`, because a partition does not have parts of size `0`) there are `a` parts of size
`m` and hence `a + b` parts in total. -/
theorem equitabilise_aux (hs : a * m + b * (m + 1) = s.card) :
    ∃ Q : Finpartition s,
      (∀ x : Finset α, x ∈ Q.parts → x.card = m ∨ x.card = m + 1) ∧
        (∀ x, x ∈ P.parts → (x \ (Q.parts.filter fun y => y ⊆ x).bunionᵢ id).card ≤ m) ∧
          (Q.parts.filter fun i => card i = m + 1).card = b := by
  -- Get rid of the easy case `m = 0`
  obtain rfl | m_pos := m.eq_zero_or_pos
  · refine' ⟨⊥, by simp, _, by simpa using hs.symm⟩
    simp only [le_zero_iff, card_eq_zero, mem_bunionᵢ, exists_prop, mem_filter, id.def, and_assoc,
      sdiff_eq_empty_iff_subset, subset_iff]
    exact fun x hx a ha =>
      ⟨{a}, mem_map_of_mem _ (P.le hx ha), singleton_subset_iff.2 ha, mem_singleton_self _⟩
  -- Prove the case `m > 0` by strong induction on `s`
  induction' s using Finset.strongInduction with s ih generalizing a b
  -- If `a = b = 0`, then `s = ∅` and we can partition into zero parts
  by_cases hab : a = 0 ∧ b = 0
  · simp only [hab.1, hab.2, add_zero, zero_mul, eq_comm, card_eq_zero, Finset.bot_eq_empty] at hs
    subst hs
    -- Porting note: to synthesize `Finpartition ∅`, `have` is required
    have : P = Finpartition.empty _ := Unique.eq_default (α := Finpartition ⊥) P
    exact ⟨Finpartition.empty _, by simp, by simp [this], by simp [hab.2]⟩
  simp_rw [not_and_or, ← Ne.def, ← pos_iff_ne_zero] at hab
  -- `n` will be the size of the smallest part
  set n := if 0 < a then m else m + 1 with hn
  -- Some easy facts about it
  obtain ⟨hn₀, hn₁, hn₂, hn₃⟩ :
    0 < n ∧ n ≤ m + 1 ∧ n ≤ a * m + b * (m + 1) ∧
      ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = s.card - n :=
    by
    rw [hn, ← hs]
    split_ifs with h <;> rw [tsub_mul, one_mul]
    · refine' ⟨m_pos, le_succ _, le_add_right (le_mul_of_pos_left ‹0 < a›), _⟩
      rw [tsub_add_eq_add_tsub (le_mul_of_pos_left h)]
    · refine' ⟨succ_pos', le_rfl, le_add_left (le_mul_of_pos_left <| hab.resolve_left ‹¬0 < a›), _⟩
      rw [← add_tsub_assoc_of_le (le_mul_of_pos_left <| hab.resolve_left ‹¬0 < a›)]
  /- We will call the inductive hypothesis on a partition of `s \ t` for a carefully chosen `t ⊆ s`.
    To decide which, however, we must distinguish the case where all parts of `P` have size `m` (in
    which case we take `t` to be an arbitrary subset of `s` of size `n`) from the case where at
    least one part `u` of `P` has size `m + 1` (in which case we take `t` to be an arbitrary subset
    of `u` of size `n`). The rest of each branch is just tedious calculations to satisfy the
    induction hypothesis. -/
  by_cases h : ∀ u ∈ P.parts, card u < m + 1
  · obtain ⟨t, hts, htn⟩ := exists_smaller_set s n (hn₂.trans_eq hs)
    have ht : t.Nonempty := by rwa [← card_pos, htn]
    have hcard : ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = (s \ t).card := by
      rw [card_sdiff ‹t ⊆ s›, htn, hn₃]
    obtain ⟨R, hR₁, _, hR₃⟩ :=
      @ih (s \ t) (sdiff_ssubset hts ‹t.Nonempty›) (if 0 < a then a - 1 else a)
        (if 0 < a then b else b - 1) (P.avoid t) hcard
    refine' ⟨R.extend ht.ne_empty sdiff_disjoint (sdiff_sup_cancel hts), _, _, _⟩
    · simp only [extend_parts, mem_insert, forall_eq_or_imp, and_iff_left hR₁, htn, hn]
      exact ite_eq_or_eq _ _ _
    · exact fun x hx => (card_le_of_subset <| sdiff_subset _ _).trans (lt_succ_iff.1 <| h _ hx)
    simp_rw [extend_parts, filter_insert, htn, hn, m.succ_ne_self.symm.ite_eq_right_iff]
    split_ifs with ha
    · rw [hR₃, if_pos ha]
    rw [card_insert_of_not_mem, hR₃, if_neg ha, tsub_add_cancel_of_le]
    · exact hab.resolve_left ha
    · intro H; exact ht.ne_empty (le_sdiff_iff.1 <| R.le <| filter_subset _ _ H)
  push_neg  at h
  obtain ⟨u, hu₁, hu₂⟩ := h
  obtain ⟨t, htu, htn⟩ := exists_smaller_set _ _ (hn₁.trans hu₂)
  have ht : t.Nonempty := by rwa [← card_pos, htn]
  have hcard : ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = (s \ t).card := by
    rw [card_sdiff (htu.trans <| P.le hu₁), htn, hn₃]
  obtain ⟨R, hR₁, hR₂, hR₃⟩ :=
    @ih (s \ t) (sdiff_ssubset (htu.trans <| P.le hu₁) ht) (if 0 < a then a - 1 else a)
      (if 0 < a then b else b - 1) (P.avoid t) hcard
  refine' ⟨R.extend ht.ne_empty sdiff_disjoint (sdiff_sup_cancel <| htu.trans <| P.le hu₁), _, _, _⟩
  · simp only [mem_insert, forall_eq_or_imp, extend_parts, and_iff_left hR₁, htn, hn]
    exact ite_eq_or_eq _ _ _
  · conv in _ ∈ _ => rw [← insert_erase hu₁]
    simp only [and_imp, mem_insert, forall_eq_or_imp, Ne.def, extend_parts]
    refine' ⟨_, fun x hx => (card_le_of_subset _).trans <| hR₂ x _⟩
    · simp only [filter_insert, if_pos htu, bunionᵢ_insert, mem_erase, id.def]
      obtain rfl | hut := eq_or_ne u t
      · rw [sdiff_eq_empty_iff_subset.2 (subset_union_left _ _)]
        exact bot_le
      refine'
        (card_le_of_subset fun i => _).trans
          (hR₂ (u \ t) <| P.mem_avoid.2 ⟨u, hu₁, fun i => hut <| i.antisymm htu, rfl⟩)
      -- Porting note: `not_and` required because `∃ x ∈ s, p x` is defined diferently
      simp only [not_exists, not_and, mem_bunionᵢ, and_imp, mem_union, mem_filter, mem_sdiff,
        id.def, not_or]
      exact fun hi₁ hi₂ hi₃ =>
        ⟨⟨hi₁, hi₂⟩, fun x hx hx' => hi₃ _ hx <| hx'.trans <| sdiff_subset _ _⟩
    · apply sdiff_subset_sdiff Subset.rfl (bunionᵢ_subset_bunionᵢ_of_subset_left _ _)
      exact filter_subset_filter _ (subset_insert _ _)
    simp only [avoid, ofErase, mem_erase, mem_image, bot_eq_empty]
    exact
      ⟨(nonempty_of_mem_parts _ <| mem_of_mem_erase hx).ne_empty, _, mem_of_mem_erase hx,
        (disjoint_of_subset_right htu <|
            P.disjoint (mem_of_mem_erase hx) hu₁ <| ne_of_mem_erase hx).sdiff_eq_left⟩
  simp only [extend_parts, filter_insert, htn, hn, m.succ_ne_self.symm.ite_eq_right_iff]
  split_ifs with h
  · rw [hR₃, if_pos h]
  · rw [card_insert_of_not_mem, hR₃, if_neg h, Nat.sub_add_cancel (hab.resolve_left h)]
    intro H; exact ht.ne_empty (le_sdiff_iff.1 <| R.le <| filter_subset _ _ H)
#align finpartition.equitabilise_aux Finpartition.equitabilise_aux

variable (h : a * m + b * (m + 1) = s.card)

/-- Given a partition `P` of `s`, as well as a proof that `a * m + b * (m + 1) = s.card`, build a
new partition `Q` of `s` where each part has size `m` or `m + 1`, every part of `P` is the union of
parts of `Q` plus at most `m` extra elements, there are `b` parts of size `m + 1` and (provided
`m > 0`, because a partition does not have parts of size `0`) there are `a` parts of size `m` and
hence `a + b` parts in total. -/
noncomputable def equitabilise : Finpartition s :=
  (P.equitabilise_aux h).choose
#align finpartition.equitabilise Finpartition.equitabilise

variable {h}

theorem card_eq_of_mem_parts_equitabilise :
    t ∈ (P.equitabilise h).parts → t.card = m ∨ t.card = m + 1 :=
  (P.equitabilise_aux h).choose_spec.1 _
#align finpartition.card_eq_of_mem_parts_equitabilise Finpartition.card_eq_of_mem_parts_equitabilise

theorem equitabilise_isEquipartition : (P.equitabilise h).IsEquipartition :=
  Set.equitableOn_iff_exists_eq_eq_add_one.2 ⟨m, fun _ => card_eq_of_mem_parts_equitabilise⟩
#align finpartition.equitabilise_is_equipartition Finpartition.equitabilise_isEquipartition

variable (P h)

theorem card_filter_equitabilise_big :
    ((P.equitabilise h).parts.filter fun u : Finset α => u.card = m + 1).card = b :=
  (P.equitabilise_aux h).choose_spec.2.2
#align finpartition.card_filter_equitabilise_big Finpartition.card_filter_equitabilise_big

theorem card_filter_equitabilise_small (hm : m ≠ 0) :
    ((P.equitabilise h).parts.filter fun u : Finset α => u.card = m).card = a := by
  refine' (mul_eq_mul_right_iff.1 <| (add_left_inj (b * (m + 1))).1 _).resolve_right hm
  rw [h, ← (P.equitabilise h).sum_card_parts]
  have hunion :
    (P.equitabilise h).parts =
      ((P.equitabilise h).parts.filter fun u => u.card = m) ∪
        (P.equitabilise h).parts.filter fun u => u.card = m + 1 := by
    rw [← filter_or, filter_true_of_mem]
    exact fun x => card_eq_of_mem_parts_equitabilise
  nth_rw 2 [hunion]
  rw [sum_union, sum_const_nat fun x hx => (mem_filter.1 hx).2,
    sum_const_nat fun x hx => (mem_filter.1 hx).2, P.card_filter_equitabilise_big]
  refine' disjoint_filter_filter' _ _ _
  intro x ha hb i h
  apply succ_ne_self m _
  exact (hb i h).symm.trans (ha i h)
#align finpartition.card_filter_equitabilise_small Finpartition.card_filter_equitabilise_small

theorem card_parts_equitabilise (hm : m ≠ 0) : (P.equitabilise h).parts.card = a + b := by
  rw [← filter_true_of_mem fun x => card_eq_of_mem_parts_equitabilise, filter_or, card_union_eq,
    P.card_filter_equitabilise_small _ hm, P.card_filter_equitabilise_big]
  -- Porting note: was `infer_instance`
  exact disjoint_filter.2 fun x _ h₀ h₁ => Nat.succ_ne_self m <| h₁.symm.trans h₀
#align finpartition.card_parts_equitabilise Finpartition.card_parts_equitabilise

variable (s)

/-- We can find equipartitions of arbitrary size. -/
theorem exists_equipartition_card_eq (hn : n ≠ 0) (hs : n ≤ s.card) :
    ∃ P : Finpartition s, P.IsEquipartition ∧ P.parts.card = n := by
  rw [← pos_iff_ne_zero] at hn
  have : (n - s.card % n) * (s.card / n) + s.card % n * (s.card / n + 1) = s.card := by
    rw [tsub_mul, mul_add, ← add_assoc,
      tsub_add_cancel_of_le (Nat.mul_le_mul_right _ (mod_lt _ hn).le), mul_one, add_comm,
      mod_add_div]
  refine'
    ⟨(indiscrete (card_pos.1 <| hn.trans_le hs).ne_empty).equitabilise this,
      equitabilise_isEquipartition, _⟩
  rw [card_parts_equitabilise _ _ (Nat.div_pos hs hn).ne', tsub_add_cancel_of_le (mod_lt _ hn).le]
#align finpartition.exists_equipartition_card_eq Finpartition.exists_equipartition_card_eq

end Finpartition


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

! This file was ported from Lean 3 source module order.category.LinOrd
! 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.Lat

/-!
# Category of linear orders

This defines `LinOrd`, the category of linear orders with monotone maps.
-/

open CategoryTheory

universe u

/-- The category of linear orders. -/
def LinOrd :=
  Bundled LinearOrder
#align LinOrd LinOrd

namespace LinOrd

instance : BundledHom.ParentProjection @LinearOrder.toPartialOrder :=
  ⟨⟩

deriving instance LargeCategory, ConcreteCategory for LinOrd

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

/-- Construct a bundled `LinOrd` from the underlying type and typeclass. -/
def of (α : Type _) [LinearOrder α] : LinOrd :=
  Bundled.of α
#align LinOrd.of LinOrd.of

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

instance : Inhabited LinOrd :=
  ⟨of PUnit⟩

instance (α : LinOrd) : LinearOrder α :=
  α.str

instance hasForgetToLat : HasForget₂ LinOrd Lat
    where forget₂ :=
    { obj := fun X => Lat.of X
      map := fun X Y f => (OrderHomClass.toLatticeHom X Y f : LatticeHom X Y) }
#align LinOrd.has_forget_to_Lat LinOrd.hasForgetToLat

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

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

/-- The equivalence between `LinOrd` and itself induced by `order_dual` both ways. -/
@[simps Functor inverse]
def dualEquiv : LinOrd ≌ LinOrd :=
  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 LinOrd.dual_equiv LinOrd.dualEquiv

end LinOrd

theorem linOrd_dual_comp_forget_to_lat :
    LinOrd.dual ⋙ forget₂ LinOrd Lat = forget₂ LinOrd Lat ⋙ Lat.dual :=
  rfl
#align LinOrd_dual_comp_forget_to_Lat linOrd_dual_comp_forget_to_lat


import power_quandle

universe u

section pre_free_pq

inductive pre_free_pq (S : Type u) : Type u
| unit : pre_free_pq
| incl (x : S) : pre_free_pq
| rhd (x y : pre_free_pq) : pre_free_pq
| pow (x : pre_free_pq) (n : ℤ) : pre_free_pq

open pre_free_pq

inductive pre_free_pq_rel' (S : Type u) : pre_free_pq S → pre_free_pq S → Type u
| refl {x : pre_free_pq S} : pre_free_pq_rel' x x
| symm {a b : pre_free_pq S} (hab : pre_free_pq_rel' a b) : pre_free_pq_rel' b a
| trans {a b c : pre_free_pq S}
  (hab : pre_free_pq_rel' a b) (hbc : pre_free_pq_rel' b c) : pre_free_pq_rel' a c
| congr_rhd {a b a' b' : pre_free_pq S}
  (ha : pre_free_pq_rel' a a') (hb : pre_free_pq_rel' b b') :
  pre_free_pq_rel' (rhd a b) (rhd a' b')
| congr_pow {a a' : pre_free_pq S} {n : ℤ} (ha : pre_free_pq_rel' a a') :
  pre_free_pq_rel' (pow a n) (pow a' n)
| rhd_dist (a b c : pre_free_pq S) : pre_free_pq_rel' (rhd a (rhd b c)) (rhd (rhd a b) (rhd a c))
| rhd_idem (a : pre_free_pq S) : pre_free_pq_rel' (rhd a a) (a)
| pow_one (a : pre_free_pq S) : pre_free_pq_rel' (pow a (1 : ℤ)) (a)
| pow_zero (a : pre_free_pq S) : pre_free_pq_rel' (pow a (0 : ℤ)) (unit)
| pow_comp (a : pre_free_pq S) (n m : ℤ) : pre_free_pq_rel' (pow (pow a n) m) (pow a (n * m))
| rhd_one (a : pre_free_pq S) : pre_free_pq_rel' (rhd a unit) (unit)
| one_rhd (a : pre_free_pq S) : pre_free_pq_rel' (rhd unit a) (a)
| pow_rhd (a b : pre_free_pq S) (n : ℤ) : pre_free_pq_rel' (pow (rhd a b) n) (rhd a (pow b n))
| rhd_pow_add (a b : pre_free_pq S) (n m : ℤ) : pre_free_pq_rel' (rhd (pow a n) (rhd (pow a m) b)) (rhd (pow a (n + m)) b)

inductive pre_free_pq_rel (S : Type u) : pre_free_pq S → pre_free_pq S → Prop
| rel {a b : pre_free_pq S} (r : pre_free_pq_rel' S a b) : pre_free_pq_rel a b

variables {S : Type*}

lemma pre_free_pq_rel'.rel {a b : pre_free_pq S} : pre_free_pq_rel' S a b → pre_free_pq_rel S a b := pre_free_pq_rel.rel

@[refl]
lemma pre_free_pq_rel.refl {a : pre_free_pq S} : pre_free_pq_rel S a a :=
pre_free_pq_rel'.rel pre_free_pq_rel'.refl

@[symm]
lemma pre_free_pq_rel.symm {a b : pre_free_pq S} : pre_free_pq_rel S a b → pre_free_pq_rel S b a
| ⟨r⟩ := r.symm.rel

@[trans]
lemma pre_free_pq_rel.trans {a b c : pre_free_pq S} :
pre_free_pq_rel S a b → pre_free_pq_rel S b c → pre_free_pq_rel S a c
| ⟨rab⟩ ⟨rbc⟩ := (rab.trans rbc).rel

instance pre_free_pq.setoid (S : Type*) : setoid (pre_free_pq S) :=
{
    r := pre_free_pq_rel S,
    iseqv := begin
        split, apply pre_free_pq_rel.refl,
        split, apply pre_free_pq_rel.symm,
        apply pre_free_pq_rel.trans,
    end
}

def free_pq (S : Type*) := quotient (pre_free_pq.setoid S)

instance free_pq_rhd : has_rhd (free_pq S) := ⟨λ a b, quotient.lift_on₂ a b (λ a b, ⟦rhd a b⟧) begin
  intros a1 b1 a2 b2,
  intros ha hb,
  cases ha,
  cases hb,
  apply quotient.sound,
  exact (pre_free_pq_rel'.congr_rhd ha_r hb_r).rel,
end⟩

instance free_pq_pow : has_pow (free_pq S) ℤ := ⟨λ a n, quotient.lift_on a (λ a, ⟦pow a n⟧) begin
  intros a b hab,
  cases hab,
  apply quotient.sound,
  exact (pre_free_pq_rel'.congr_pow hab_r).rel,
end⟩

instance free_pq_one : has_one (free_pq S) := ⟨quotient.mk unit⟩

instance free_pq_is_pq : power_quandle (free_pq S) := {
  rhd_dist := (λ a b c, quotient.induction_on₃ a b c (λ a b c, quotient.sound (pre_free_pq_rel'.rhd_dist a b c).rel)),
  rhd_idem := (λ a, quotient.induction_on a (λ a, quotient.sound (pre_free_pq_rel'.rhd_idem a).rel)),
  pow_one := (λ a, quotient.induction_on a (λ a, quotient.sound (pre_free_pq_rel'.pow_one a).rel)),
  pow_zero := (λ a, quotient.induction_on a (λ a, quotient.sound (pre_free_pq_rel'.pow_zero a).rel)),
  pow_comp := (λ a n m, quotient.induction_on a (λ a, quotient.sound (pre_free_pq_rel'.pow_comp a n m).rel)),
  rhd_one := (λ a, quotient.induction_on a (λ a, quotient.sound (pre_free_pq_rel'.rhd_one a).rel)),
  one_rhd := (λ a, quotient.induction_on a (λ a, quotient.sound (pre_free_pq_rel'.one_rhd a).rel)),
  pow_rhd := (λ a b n, quotient.induction_on₂ a b (λ a b, quotient.sound (pre_free_pq_rel'.pow_rhd a b n).rel)),
  rhd_pow_add := (λ a b n m, quotient.induction_on₂ a b (λ a b, quotient.sound (pre_free_pq_rel'.rhd_pow_add a b n m).rel)),
  ..free_pq_rhd,
  ..free_pq_pow,
  ..free_pq_one }

def free_pq_of (s : S) : free_pq S := ⟦incl s⟧

lemma free_pq_of_def (s : S) : free_pq_of s = ⟦incl s⟧ := rfl

lemma free_pq_rhd_def (x y : pre_free_pq S) : ⟦rhd x y⟧ = (⟦x⟧ ▷ ⟦y⟧ : free_pq S) := rfl

lemma free_pq_pow_def (x : pre_free_pq S) (n : ℤ) : ⟦pow x n⟧ = (⟦x⟧ ^ n : free_pq S) := rfl

lemma free_pq_one_def : ⟦(unit : pre_free_pq S)⟧ = (1 : free_pq S) := rfl

lemma quot_mk_helper_free_pq (a : pre_free_pq S) : quot.mk setoid.r a = ⟦a⟧ := rfl

variables {Q : Type*} [power_quandle Q]

def free_pq_adjoint_pre (f : S → Q) : pre_free_pq S → Q :=
begin
  intro x,
  induction x,
  {
    exact 1,
  },
  {
    exact f x,
  },
  {
    exact x_ih_x ▷ x_ih_y,
  },
  {
    exact x_ih ^ x_n,
  },
end

lemma free_pq_adjoint_pre_of (f : S → Q) (x : S) : free_pq_adjoint_pre f (incl x) = f x := rfl

lemma free_pq_adjoint_pre_rhd (f : S → Q) (x y : pre_free_pq S) : free_pq_adjoint_pre f (x.rhd y) = free_pq_adjoint_pre f x ▷ free_pq_adjoint_pre f y := rfl

lemma free_pq_adjoint_pre_pow (f : S → Q) (x : pre_free_pq S) (n : ℤ) : free_pq_adjoint_pre f (x.pow n) = (free_pq_adjoint_pre f x) ^ n := rfl

lemma free_pq_adjoint_pre_one (f : S → Q) : free_pq_adjoint_pre f (unit : pre_free_pq S) = 1 := rfl

def free_pq_adjoint (f : S → Q) : free_pq S → Q :=
begin
  intro x,
  induction x,
  {
    exact free_pq_adjoint_pre f x,
  },
  {
    simp only [eq_rec_constant],
    induction x_p,
    induction x_p_r,
    {
      refl,
    },
    {
      apply eq.symm,
      assumption,
    },
    {
      apply eq.trans,
      assumption,
      assumption,
    },
    {
      rw free_pq_adjoint_pre_rhd,
      rw free_pq_adjoint_pre_rhd,
      rw x_p_r_ih_ha,
      rw x_p_r_ih_hb,
    },
    {
      rw free_pq_adjoint_pre_pow,
      rw free_pq_adjoint_pre_pow,
      rw x_p_r_ih,
    },
    {
      repeat {rw free_pq_adjoint_pre_rhd},
      apply power_quandle.rhd_dist,
    },
    {
      repeat {rw free_pq_adjoint_pre_rhd},
      apply power_quandle.rhd_idem,
    },
    {
      repeat {rw free_pq_adjoint_pre_pow},
      apply power_quandle.pow_one,
    },
    {
      repeat {rw free_pq_adjoint_pre_pow},
      apply power_quandle.pow_zero,
    },
    {
      repeat {rw free_pq_adjoint_pre_pow},
      apply power_quandle.pow_comp,
    },
    {
      repeat {rw free_pq_adjoint_pre_rhd},
      repeat {rw free_pq_adjoint_pre_one},
      apply power_quandle.rhd_one,
    },
    {
      repeat {rw free_pq_adjoint_pre_rhd},
      repeat {rw free_pq_adjoint_pre_one},
      apply power_quandle.one_rhd,
    },
    {
      repeat {rw free_pq_adjoint_pre_rhd},
      repeat {rw free_pq_adjoint_pre_pow},
      apply power_quandle.pow_rhd,
    },
    {
      repeat {rw free_pq_adjoint_pre_rhd},
      repeat {rw free_pq_adjoint_pre_pow},
      apply power_quandle.rhd_pow_add,
    },
  },
end

lemma free_pq_adjoint_is_pq_morphism {f : S → Q} : is_pq_morphism (free_pq_adjoint f : free_pq S → Q) :=
begin
  split,
  {
    intros a b,
    induction a,
    induction b,
    {
      refl,
    },
    {refl,},
    {refl,},
  },
  {
    intros a n,
    induction a,
    {
      refl,
    },
    {refl,},
  },
end

lemma free_pq_adjoint_comm_of {f : S → Q} (x : S) : free_pq_adjoint f (free_pq_of x) = f x := rfl

end pre_free_pq


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.types
import Mathlib.category_theory.currying
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# The morphism comparing a colimit of limits with the corresponding limit of colimits.

For `F : J × K ⥤ C` there is always a morphism $\colim_k \lim_j F(j,k) → \lim_j \colim_k F(j, k)$.
While it is not usually an isomorphism, with additional hypotheses on `J` and `K` it may be,
in which case we say that "colimits commute with limits".

The prototypical example, proved in `category_theory.limits.filtered_colimit_commutes_finite_limit`,
is that when `C = Type`, filtered colimits commute with finite limits.

## References
* Borceux, Handbook of categorical algebra 1, Section 2.13
* [Stacks: Filtered colimits](https://stacks.math.columbia.edu/tag/002W)
-/

namespace category_theory.limits

theorem map_id_left_eq_curry_map {J : Type v} {K : Type v} [small_category J] [small_category K]
    {C : Type u} [category C] (F : J × K ⥤ C) {j : J} {k : K} {k' : K} {f : k ⟶ k'} :
    functor.map F (𝟙, f) = functor.map (functor.obj (functor.obj curry F) j) f :=
  rfl

theorem map_id_right_eq_curry_swap_map {J : Type v} {K : Type v} [small_category J]
    [small_category K] {C : Type u} [category C] (F : J × K ⥤ C) {j : J} {j' : J} {f : j ⟶ j'}
    {k : K} :
    functor.map F (f, 𝟙) = functor.map (functor.obj (functor.obj curry (prod.swap K J ⋙ F)) k) f :=
  rfl

/--
The universal morphism
$\colim_k \lim_j F(j,k) → \lim_j \colim_k F(j, k)$.
-/
def colimit_limit_to_limit_colimit {J : Type v} {K : Type v} [small_category J] [small_category K]
    {C : Type u} [category C] (F : J × K ⥤ C) [has_limits_of_shape J C]
    [has_colimits_of_shape K C] :
    colimit (functor.obj curry (prod.swap K J ⋙ F) ⋙ lim) ⟶ limit (functor.obj curry F ⋙ colim) :=
  limit.lift (functor.obj curry F ⋙ colim)
    (cone.mk (cocone.X (colimit.cocone (functor.obj curry (prod.swap K J ⋙ F) ⋙ lim)))
      (nat_trans.mk
        fun (j : J) =>
          colimit.desc (functor.obj curry (prod.swap K J ⋙ F) ⋙ lim)
            (cocone.mk (cocone.X (colimit.cocone (functor.obj (functor.obj curry F) j)))
              (nat_trans.mk
                fun (k : K) =>
                  limit.π (functor.obj (functor.obj curry (prod.swap K J ⋙ F)) k) j ≫
                    colimit.ι (functor.obj (functor.obj curry F) j) k))))

/--
Since `colimit_limit_to_limit_colimit` is a morphism from a colimit to a limit,
this lemma characterises it.
-/
@[simp] theorem ι_colimit_limit_to_limit_colimit_π {J : Type v} {K : Type v} [small_category J]
    [small_category K] {C : Type u} [category C] (F : J × K ⥤ C) [has_limits_of_shape J C]
    [has_colimits_of_shape K C] (j : J) (k : K) :
    colimit.ι (functor.obj curry (prod.swap K J ⋙ F) ⋙ lim) k ≫
          colimit_limit_to_limit_colimit F ≫ limit.π (functor.obj curry F ⋙ colim) j =
        limit.π (functor.obj (functor.obj curry (prod.swap K J ⋙ F)) k) j ≫
          colimit.ι (functor.obj (functor.obj curry F) j) k :=
  sorry

@[simp] theorem ι_colimit_limit_to_limit_colimit_π_apply {J : Type v} {K : Type v}
    [small_category J] [small_category K] (F : J × K ⥤ Type v) (j : J) (k : K)
    (f : functor.obj (functor.obj curry (prod.swap K J ⋙ F) ⋙ lim) k) :
    limit.π (functor.obj curry F ⋙ colim) j
          (colimit_limit_to_limit_colimit F
            (colimit.ι (functor.obj curry (prod.swap K J ⋙ F) ⋙ lim) k f)) =
        colimit.ι (functor.obj (functor.obj curry F) j) k
          (limit.π (functor.obj (functor.obj curry (prod.swap K J ⋙ F)) k) j f) :=
  sorry

end Mathlib


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import init.logic init.data.nat.basic init.data.bool.basic init.propext
open decidable list

universes u v w

instance (α : Type u) : inhabited (list α) :=
⟨list.nil⟩

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

namespace list

protected def has_dec_eq [s : decidable_eq α] : decidable_eq (list α)
| []      []      := is_true rfl
| (a::as) []      := is_false (λ h, list.no_confusion h)
| []      (b::bs) := is_false (λ h, list.no_confusion h)
| (a::as) (b::bs) :=
  match s a b with
  | is_true hab  :=
    match has_dec_eq as bs with
    | is_true habs  := is_true (eq.subst hab (eq.subst habs rfl))
    | is_false nabs := is_false (λ h, list.no_confusion h (λ _ habs, absurd habs nabs))
    end
  | is_false nab := is_false (λ h, list.no_confusion h (λ hab _, absurd hab nab))
  end

instance [decidable_eq α] : decidable_eq (list α) :=
list.has_dec_eq

@[simp] protected def append : list α → list α → list α
| []       l := l
| (h :: s) t := h :: (append s t)

instance : has_append (list α) :=
⟨list.append⟩

protected def mem : α → list α → Prop
| a []       := false
| a (b :: l) := a = b ∨ mem a l

instance : has_mem α (list α) :=
⟨list.mem⟩

instance decidable_mem [decidable_eq α] (a : α) : ∀ (l : list α), decidable (a ∈ l)
| []     := is_false not_false
| (b::l) :=
  if h₁ : a = b then is_true (or.inl h₁)
  else match decidable_mem l with
  | is_true  h₂ := is_true (or.inr h₂)
  | is_false h₂ := is_false (not_or h₁ h₂)
  end

instance : has_emptyc (list α) :=
⟨list.nil⟩

protected def erase {α} [decidable_eq α] : list α → α → list α
| []     b := []
| (a::l) b := if a = b then l else a :: erase l b

protected def bag_inter {α} [decidable_eq α] : list α → list α → list α
| []      _   := []
| _       []  := []
| (a::l₁) l₂  := if a ∈ l₂ then a :: bag_inter l₁ (l₂.erase a) else bag_inter l₁ l₂

protected def diff {α} [decidable_eq α] : list α → list α → list α
| l      []      := l
| l₁     (a::l₂) := if a ∈ l₁ then diff (l₁.erase a) l₂ else diff l₁ l₂

@[simp] def length : list α → nat
| []       := 0
| (a :: l) := length l + 1

def empty : list α → bool
| []       := tt
| (_ :: _) := ff

open option nat

@[simp] def nth : list α → nat → option α
| []       n     := none
| (a :: l) 0     := some a
| (a :: l) (n+1) := nth l n

@[simp] def nth_le : Π (l : list α) (n), n < l.length → α
| []       n     h := absurd h n.not_lt_zero
| (a :: l) 0     h := a
| (a :: l) (n+1) h := nth_le l n (le_of_succ_le_succ h)

@[simp] def head [inhabited α] : list α → α
| []       := default
| (a :: l) := a

@[simp] def tail : list α → list α
| []       := []
| (a :: l) := l

def reverse_core : list α → list α → list α
| []     r := r
| (a::l) r := reverse_core l (a::r)

def reverse : list α → list α :=
λ l, reverse_core l []

@[simp] def map (f : α → β) : list α → list β
| []       := []
| (a :: l) := f a :: map l

@[simp] def map₂ (f : α → β → γ) : list α → list β → list γ
| []      _       := []
| _       []      := []
| (x::xs) (y::ys) := f x y :: map₂ xs ys

def map_with_index_core (f : ℕ → α → β) : ℕ → list α → list β
| k []      := []
| k (a::as) := f k a::(map_with_index_core (k+1) as)

/-- Given a function `f : ℕ → α → β` and `as : list α`, `as = [a₀, a₁, ...]`, returns the list
`[f 0 a₀, f 1 a₁, ...]`. -/
def map_with_index (f : ℕ → α → β) (as : list α) : list β :=
map_with_index_core f 0 as

def join : list (list α) → list α
| []        := []
| (l :: ls) := l ++ join ls

def filter_map (f : α → option β) : list α → list β
| []     := []
| (a::l) :=
  match f a with
  | none   := filter_map l
  | some b := b :: filter_map l
  end

def filter (p : α → Prop) [decidable_pred p] : list α → list α
| []     := []
| (a::l) := if p a then a :: filter l else filter l

def partition (p : α → Prop) [decidable_pred p] : list α → list α × list α
| []     := ([], [])
| (a::l) := let (l₁, l₂) := partition l in if p a then (a :: l₁, l₂) else (l₁, a :: l₂)

def drop_while (p : α → Prop) [decidable_pred p] : list α → list α
| []     := []
| (a::l) := if p a then drop_while l else a::l

/-- `after p xs` is the suffix of `xs` after the first element that satisfies
  `p`, not including that element.

  ```lean
  after      (eq 1)       [0, 1, 2, 3] = [2, 3]
  drop_while (not ∘ eq 1) [0, 1, 2, 3] = [1, 2, 3]
  ```
-/
def after (p : α → Prop) [decidable_pred p] : list α → list α
| [] := []
| (x :: xs) := if p x then xs else after xs

def span (p : α → Prop) [decidable_pred p] : list α → list α × list α
| []      := ([], [])
| (a::xs) := if p a then let (l, r) := span xs in (a :: l, r) else ([], a::xs)

def find_index (p : α → Prop) [decidable_pred p] : list α → nat
| []     := 0
| (a::l) := if p a then 0 else succ (find_index l)

def index_of [decidable_eq α] (a : α) : list α → nat := find_index (eq a)

def remove_all [decidable_eq α] (xs ys : list α) : list α :=
filter (∉ ys) xs

def update_nth : list α → ℕ → α → list α
| (x::xs) 0     a := a :: xs
| (x::xs) (i+1) a := x :: update_nth xs i a
| []      _     _ := []

def remove_nth : list α → ℕ → list α
| []      _     := []
| (x::xs) 0     := xs
| (x::xs) (i+1) := x :: remove_nth xs i

@[simp] def drop : ℕ → list α → list α
| 0        a      := a
| (succ n) []     := []
| (succ n) (x::r) := drop n r

@[simp] def take : ℕ → list α → list α
| 0        a        := []
| (succ n) []       := []
| (succ n) (x :: r) := x :: take n r

@[simp] def foldl (f : α → β → α) : α → list β → α
| a []       := a
| a (b :: l) := foldl (f a b) l

@[simp] def foldr (f : α → β → β) (b : β) : list α → β
| []       := b
| (a :: l) := f a (foldr l)

def any (l : list α) (p : α → bool) : bool :=
foldr (λ a r, p a || r) ff l

def all (l : list α) (p : α → bool) : bool :=
foldr (λ a r, p a && r) tt l

def bor  (l : list bool) : bool := any l id

def band (l : list bool) : bool := all l id

def zip_with (f : α → β → γ) : list α → list β → list γ
| (x::xs) (y::ys) := f x y :: zip_with xs ys
| _       _       := []

def zip : list α → list β → list (prod α β) :=
zip_with prod.mk

def unzip : list (α × β) → list α × list β
| []            := ([], [])
| ((a, b) :: t) := match unzip t with (al, bl) := (a::al, b::bl) end

protected def insert [decidable_eq α] (a : α) (l : list α) : list α :=
if a ∈ l then l else a :: l

instance [decidable_eq α] : has_insert α (list α) :=
⟨list.insert⟩

instance : has_singleton α (list α) := ⟨λ x, [x]⟩

instance [decidable_eq α] : is_lawful_singleton α (list α) :=
⟨λ x, show (if x ∈ ([] : list α) then [] else [x]) = [x], from if_neg not_false⟩

protected def union [decidable_eq α] (l₁ l₂ : list α) : list α :=
foldr insert l₂ l₁

instance [decidable_eq α] : has_union (list α) :=
⟨list.union⟩

protected def inter [decidable_eq α] (l₁ l₂ : list α) : list α :=
filter (∈ l₂) l₁

instance [decidable_eq α] : has_inter (list α) :=
⟨list.inter⟩

@[simp] def repeat (a : α) : ℕ → list α
| 0 := []
| (succ n) := a :: repeat n

def range_core : ℕ → list ℕ → list ℕ
| 0        l := l
| (succ n) l := range_core n (n :: l)

def range (n : ℕ) : list ℕ :=
range_core n []

def iota : ℕ → list ℕ
| 0        := []
| (succ n) := succ n :: iota n

def enum_from : ℕ → list α → list (ℕ × α)
| n [] := nil
| n (x :: xs) := (n, x) :: enum_from (n + 1) xs

def enum : list α → list (ℕ × α) := enum_from 0

@[simp] def last : Π l : list α, l ≠ [] → α
| []        h := absurd rfl h
| [a]       h := a
| (a::b::l) h := last (b::l) (λ h, list.no_confusion h)

def ilast [inhabited α] : list α → α
| []        := arbitrary α
| [a]       := a
| [a, b]    := b
| (a::b::l) := ilast l

def init : list α → list α
| []     := []
| [a]    := []
| (a::l) := a::init l

def intersperse (sep : α) : list α → list α
| []      := []
| [x]     := [x]
| (x::xs) := x::sep::intersperse xs

def intercalate (sep : list α) (xs : list (list α)) : list α :=
join (intersperse sep xs)

@[inline] protected def bind {α : Type u} {β : Type v} (a : list α) (b : α → list β) : list β :=
join (map b a)

@[inline] protected def ret {α : Type u} (a : α) : list α :=
[a]

protected def lt [has_lt α] : list α → list α → Prop
| []      []      := false
| []      (b::bs) := true
| (a::as) []      := false
| (a::as) (b::bs) := a < b ∨ (¬ b < a ∧ lt as bs)

instance [has_lt α] : has_lt (list α) :=
⟨list.lt⟩

instance has_decidable_lt [has_lt α] [h : decidable_rel ((<) : α → α → Prop)] : Π l₁ l₂ : list α, decidable (l₁ < l₂)
| []      []      := is_false not_false
| []      (b::bs) := is_true trivial
| (a::as) []      := is_false not_false
| (a::as) (b::bs) :=
  match h a b with
  | is_true h₁  := is_true (or.inl h₁)
  | is_false h₁ :=
    match h b a with
    | is_true h₂  := is_false (λ h, or.elim h (λ h, absurd h h₁) (λ ⟨h, _⟩, absurd h₂ h))
    | is_false h₂ :=
      match has_decidable_lt as bs with
      | is_true h₃  := is_true (or.inr ⟨h₂, h₃⟩)
      | is_false h₃ := is_false (λ h, or.elim h (λ h, absurd h h₁) (λ ⟨_, h⟩, absurd h h₃))
      end
    end
  end

@[reducible] protected def le [has_lt α] (a b : list α) : Prop :=
¬ b < a

instance [has_lt α] : has_le (list α) :=
⟨list.le⟩

instance has_decidable_le [has_lt α] [h : decidable_rel ((<) : α → α → Prop)] : Π l₁ l₂ : list α, decidable (l₁ ≤ l₂) :=
λ a b, not.decidable

lemma le_eq_not_gt [has_lt α] : ∀ l₁ l₂ : list α, (l₁ ≤ l₂) = ¬ (l₂ < l₁) :=
λ l₁ l₂, rfl

lemma lt_eq_not_ge [has_lt α] [decidable_rel ((<) : α → α → Prop)] : ∀ l₁ l₂ : list α, (l₁ < l₂) = ¬ (l₂ ≤ l₁) :=
λ l₁ l₂,
  show (l₁ < l₂) = ¬ ¬ (l₁ < l₂), from
  eq.subst (propext (not_not_iff (l₁ < l₂))).symm rfl

/--  `is_prefix_of l₁ l₂` returns `tt` iff `l₁` is a prefix of `l₂`. -/
def is_prefix_of [decidable_eq α] : list α → list α → bool
| []      _       := tt
| _       []      := ff
| (a::as) (b::bs) := to_bool (a = b) && is_prefix_of as bs

/--  `is_suffix_of l₁ l₂` returns `tt` iff `l₁` is a suffix of `l₂`. -/
def is_suffix_of [decidable_eq α] (l₁ l₂ : list α) : bool :=
is_prefix_of l₁.reverse l₂.reverse

end list

namespace bin_tree
private def to_list_aux : bin_tree α → list α → list α
| empty      as := as
| (leaf a)   as := a::as
| (node l r) as := to_list_aux l (to_list_aux r as)

def to_list (t : bin_tree α) : list α :=
to_list_aux t []
end bin_tree


open tactic
open smt_tactic

def pointwise_attribute : user_attribute := {
  name := `pointwise,
  descr := "A lemma that proves things are equal using the fact they are pointwise equal."
}

run_command attribute.register `pointwise_attribute

/- Try to apply one of the given lemas, it succeeds if one of them succeeds. -/
meta def any_apply : list name → tactic unit
| []      := failed
| (c::cs) := (mk_const c >>= fapply) <|> any_apply cs

meta def smt_simp   : tactic unit := using_smt $ intros >> try simp
meta def smt_eblast : tactic unit := using_smt $ intros >> try simp >> try eblast
meta def smt_ematch : tactic unit := using_smt $ intros >> add_lemmas_from_facts >> try ematch

meta def pointwise (and_then : tactic unit) : tactic unit :=
do cs ← attribute.get_instances `pointwise,
   try (seq (any_apply cs) and_then)

attribute [pointwise] funext

meta def blast        : tactic unit := smt_eblast >> pointwise blast

-- In a timing test on 2017-02-18, I found that using `abstract { blast }` instead of just `blast` resulted in a 5x speed-up!
notation `♮` := by abstract { blast }

@[pointwise] lemma {u v} pair_equality {α : Type u} {β : Type v} { X: α × β }: (X^.fst, X^.snd) = X := begin induction X, blast end
@[pointwise] lemma {u v} pair_equality_1 {α : Type u} {β : Type v} { X: α × β } { A : α } ( p : A = X^.fst ) : (A, X^.snd) = X := begin induction X, blast end
@[pointwise] lemma {u v} pair_equality_2 {α : Type u} {β : Type v} { X: α × β } { B : β } ( p : B = X^.snd ) : (X^.fst, B) = X := begin induction X, blast end
attribute [pointwise] subtype.eq

def {u} auto_cast {α β : Type u} {h : α = β} (a : α) := cast h a
@[simp] lemma {u} auto_cast_identity {α : Type u} (a : α) : @auto_cast α α (by smt_ematch) a = a := ♮
notation `⟦` p `⟧` := @auto_cast _ _ (by smt_ematch) p
universe variables u v

structure Category :=
  (Obj : Type u)
  (Hom : Obj → Obj → Type v)
  (identity : Π X : Obj, Hom X X)
  (compose  : Π { X Y Z : Obj }, Hom X Y → Hom Y Z → Hom X Z)

  (left_identity  : ∀ { X Y : Obj } (f : Hom X Y), compose (identity _) f = f)
  (right_identity : ∀ { X Y : Obj } (f : Hom X Y), compose f (identity _) = f)
  (associativity  : ∀ { W X Y Z : Obj } (f : Hom W X) (g : Hom X Y) (h : Hom Y Z),
    compose (compose f g) h = compose f (compose g h))

attribute [simp] Category.left_identity
attribute [simp] Category.right_identity
attribute [ematch] Category.associativity

definition CategoryOfTypes : Category :=
{
    Obj := Type u,
    Hom := λ a b, a → b,

    identity := λ a, id,
    compose  := λ _ _ _ f g, g ∘ f,

    left_identity  := ♮,
    right_identity := ♮,
    associativity  := ♮
}

universe variables u1 v1 u2 v2 u3 v3

structure Functor (C : Category.{ u1 v1 }) (D : Category.{ u2 v2 }) :=
  (onObjects   : C^.Obj → D^.Obj)
  (onMorphisms : Π { X Y : C^.Obj },
                C^.Hom X Y → D^.Hom (onObjects X) (onObjects Y))
  (identities : ∀ (X : C^.Obj),
    onMorphisms (C^.identity X) = D^.identity (onObjects X))
  (functoriality : ∀ { X Y Z : C^.Obj } (f : C^.Hom X Y) (g : C^.Hom Y Z),
    onMorphisms (C^.compose f g) = D^.compose (onMorphisms f) (onMorphisms g))

attribute [simp] Functor.identities
attribute [simp] Functor.functoriality
attribute [ematch] Functor.functoriality

-- We define a coercion so that we can write `F X` for the functor `F` applied to the object `X`.
-- One can still write out `onObjects F X` when needed.
instance Functor_to_onObjects { C D : Category }: has_coe_to_fun (Functor C D) :=
{ F   := λ f, C^.Obj -> D^.Obj,
  coe := Functor.onObjects }

definition IdentityFunctor ( C: Category ) : Functor C C :=
{
  onObjects     := id,
  onMorphisms   := λ _ _ f, f,
  identities    := ♮,
  functoriality := ♮
}

definition FunctorComposition { C D E : Category } ( F : Functor C D ) ( G : Functor D E ) : Functor C E :=
{
  onObjects     := λ X, G (F X),
  onMorphisms   := λ _ _ f, G^.onMorphisms (F^.onMorphisms f),
  identities    := ♮,
  functoriality := ♮
}

-- namespace Functor
--   notation F `∘` G := FunctorComposition F G
-- end Functor

structure NaturalTransformation { C D : Category } ( F G : Functor C D ) :=
  (components: Π X : C^.Obj, D^.Hom (F X) (G X))
  (naturality: ∀ { X Y : C^.Obj } (f : C^.Hom X Y),
     D^.compose (F^.onMorphisms f) (components Y) = D^.compose (components X) (G^.onMorphisms f))

attribute [ematch] NaturalTransformation.naturality

-- This defines a coercion so we can write `α X` for `components α X`.
instance NaturalTransformation_to_components { C D : Category } { F G : Functor C D } : has_coe_to_fun (NaturalTransformation F G) :=
{ F   := λ f, Π X : C^.Obj, D^.Hom (F X) (G X),
  coe := NaturalTransformation.components }

-- We'll want to be able to prove that two natural transformations are equal if they are componentwise equal.
@[pointwise] lemma NaturalTransformations_componentwise_equal
  { C D : Category }
  { F G : Functor C D }
  ( α β : NaturalTransformation F G )
  ( w : ∀ X : C^.Obj, α X = β X ) : α = β :=
  begin
    induction α with αc,
    induction β with βc,
    have hc : αc = βc, from funext w,
    by subst hc
  end

definition IdentityNaturalTransformation { C D : Category } (F : Functor C D) : NaturalTransformation F F :=
  {
    components := λ X, D^.identity (F X),
    naturality := ♮
  }

definition vertical_composition_of_NaturalTransformations
  { C D : Category }
  { F G H : Functor C D }
  ( α : NaturalTransformation F G )
  ( β : NaturalTransformation G H ) : NaturalTransformation F H :=
  {
    components := λ X, D^.compose (α X) (β X),
    naturality := ♮
  }

definition horizontal_composition_of_NaturalTransformations
  { C D E : Category }
  { F G : Functor C D }
  { H I : Functor D E }
  ( α : NaturalTransformation F G )
  ( β : NaturalTransformation H I ) : NaturalTransformation (FunctorComposition F H) (FunctorComposition G I) :=
  {
    components := λ X : C^.Obj, E^.compose (β (F X)) (I^.onMorphisms (α X)),
    naturality := begin
                    blast,
                    unfold FunctorComposition,
                    blast
                  end
  }

definition whisker_on_left
  { C D E : Category }
  ( F : Functor C D )
  { G H : Functor D E }
  ( α : NaturalTransformation G H ) :
  NaturalTransformation (FunctorComposition F G) (FunctorComposition F H) :=
  horizontal_composition_of_NaturalTransformations (IdentityNaturalTransformation F) α

definition whisker_on_right
  { C D E : Category }
  { F G : Functor C D }
  ( α : NaturalTransformation F G )
  ( H : Functor D E ) :
  NaturalTransformation (FunctorComposition F H) (FunctorComposition G H) :=
  horizontal_composition_of_NaturalTransformations α (IdentityNaturalTransformation H)

definition ProductCategory (C : Category.{u1 v1}) (D : Category.{u2 v2}) : Category :=
{
  Obj      := C^.Obj × D^.Obj,
  Hom      := (λ X Y : C^.Obj × D^.Obj, C^.Hom (X^.fst) (Y^.fst) × D^.Hom (X^.snd) (Y^.snd)),
  identity := λ X, (C^.identity (X^.fst), D^.identity (X^.snd)),
  compose  := λ _ _ _ f g, (C^.compose (f^.fst) (g^.fst), D^.compose (f^.snd) (g^.snd)),

  left_identity  := ♮,
  right_identity := ♮,
  associativity  := ♮
}

namespace ProductCategory
  notation C `×` D := ProductCategory C D
end ProductCategory

definition ProductFunctor { A B C D : Category } ( F : Functor A B ) ( G : Functor C D ) : Functor (A × C) (B × D) :=
{
  onObjects     := λ X, (F X^.fst, G X^.snd),
  onMorphisms   := λ _ _ f, (F^.onMorphisms f^.fst, G^.onMorphisms f^.snd),
  identities    := begin
                     blast,
                     unfold ProductCategory,
                     blast,
                   end,
  functoriality := begin
                     blast,
                     unfold ProductCategory,
                     blast
                   end
}

namespace ProductFunctor
  notation F `×` G := ProductFunctor F G
end ProductFunctor

definition ProductNaturalTransformation { A B C D : Category } { F G : Functor A B } { H I : Functor C D } (α : NaturalTransformation F G) (β : NaturalTransformation H I) : NaturalTransformation (F × H) (G × I) :=
{
  components := λ X, (α X^.fst, β X^.snd),
  naturality := begin
                  blast,
                  unfold ProductFunctor,
                  blast,
                  unfold ProductCategory,
                  blast
                end
}

namespace ProductNaturalTransformation
  notation α `×` β := ProductNaturalTransformation α β
end ProductNaturalTransformation

definition ProductCategoryAssociator
  ( C : Category.{ u1 v1 } )
  ( D : Category.{ u2 v2 } )
  ( E : Category.{ u3 v3 } )
  : Functor ((C × D) × E) (C × (D × E)) :=
{
  onObjects     := λ X, (X^.fst^.fst, (X^.fst^.snd, X^.snd)),
  onMorphisms   := λ _ _ f, (f^.fst^.fst, (f^.fst^.snd, f^.snd)),
  identities    := ♮,
  functoriality := ♮
}

@[reducible] definition TensorProduct ( C: Category ) := Functor ( C × C ) C

definition left_associated_triple_tensor ( C : Category.{ u v } ) ( tensor : TensorProduct C ) : Functor ((C × C) × C) C :=
  FunctorComposition (tensor × IdentityFunctor C) tensor
definition right_associated_triple_tensor ( C : Category.{ u v } ) ( tensor : TensorProduct C ) : Functor (C × (C × C)) C :=
  FunctorComposition (IdentityFunctor C × tensor) tensor

@[reducible] definition Associator { C : Category.{ u v } } ( tensor : TensorProduct C ) :=
  NaturalTransformation
    (left_associated_triple_tensor C tensor)
    (FunctorComposition (ProductCategoryAssociator C C C) (right_associated_triple_tensor C tensor))

definition Pentagon { C : Category } { tensor : TensorProduct C } ( associator : Associator tensor ) :=
  let α ( X Y Z : C^.Obj ) := associator ((X, Y), Z) in
  let tensorObjects ( X Y : C^.Obj ) := tensor^.onObjects (X, Y) in
  let tensorMorphisms { W X Y Z : C^.Obj } ( f : C^.Hom W X ) ( g : C^.Hom Y Z ) : C^.Hom (tensorObjects W Y) (tensorObjects X Z) := tensor^.onMorphisms (f, g) in
  ∀ W X Y Z : C^.Obj,
    C^.compose (α (tensorObjects W X) Y Z) (α W X (tensorObjects Y Z))
  = C^.compose (C^.compose (tensorMorphisms (α W X Y) (C^.identity Z)) (α W (tensorObjects X Y) Z)) (tensorMorphisms (C^.identity W) (α X Y Z))

structure MonoidalCategory
  extends carrier : Category :=
  (tensor                    : TensorProduct carrier)
  (associator_transformation : Associator tensor)
  (pentagon                  : Pentagon associator_transformation)

instance MonoidalCategory_coercion : has_coe MonoidalCategory.{u v} Category.{u v} :=
  ⟨MonoidalCategory.to_Category⟩

@[reducible] definition MonoidalCategory.tensorObjects   ( C : MonoidalCategory ) ( X Y : C^.Obj )                                           : C^.Obj := C^.tensor (X, Y)
@[reducible] definition MonoidalCategory.tensorMorphisms ( C : MonoidalCategory ) { W X Y Z : C^.Obj } ( f : C^.Hom W X ) ( g : C^.Hom Y Z ) : C^.Hom (C^.tensor (W, Y)) (C^.tensor (X, Z)) := C^.tensor^.onMorphisms (f, g)
@[ematch] definition MonoidalCategory.interchange
  ( C : MonoidalCategory )
  { U V W X Y Z: C^.Obj }
  ( f : C^.Hom U V )( g : C^.Hom V W )( h : C^.Hom X Y )( k : C^.Hom Y Z ) :
  @Functor.onMorphisms _ _ C^.tensor (U, X) (W, Z) ((C^.compose f g), (C^.compose h k)) = C^.compose (@Functor.onMorphisms _ _ C^.tensor (U, X) (V, Y) (f, h)) (@Functor.onMorphisms _ _ C^.tensor (V, Y) (W, Z) (g, k)) :=
  @Functor.functoriality (C × C) C C^.tensor (U, X) (V, Y) (W, Z) (f, h) (g, k)

definition TensorProductOfTypes : TensorProduct CategoryOfTypes :=
{
  onObjects     := λ p, prod p.1 p.2,
  onMorphisms   := λ _ _ p, λ q, (p.1 q.1, p.2 q.2),
  identities    := ♮,
  functoriality := ♮
}

definition MonoidalCategoryOfTypes : MonoidalCategory :=
{
  CategoryOfTypes with
  tensor := TensorProductOfTypes,
  associator_transformation := {
    components := λ p, λ t, (t.1.1,(t.1.2, t.2)),
    naturality := ♮
  },
  pentagon := begin
                blast,
                unfold Pentagon,
                blast
              end
}

local attribute [reducible] lift_t coe_t coe_b

@[simp] lemma bifunctor_identities
  { C D E : Category }
  ( X : C^.Obj ) ( Y : D^.Obj )
  ( F : Functor (C × D) E ) : @Functor.onMorphisms _ _ F (X, Y) (X, Y) (C^.identity X, D^.identity Y) = E^.identity (F^.onObjects (X, Y)) :=
  begin
    blast,
    assert p : (C^.identity X, D^.identity Y) = (C × D)^.identity (X, Y), blast,
    rewrite p,
    blast
  end

set_option pp.implicit true

definition tensor_on_left { C: MonoidalCategory.{u v} } ( Z: C^.Obj ) : Functor.{u v u v} C C :=
{
  onObjects := λ X, C^.tensorObjects Z X,
  onMorphisms := λ X Y f, C^.tensorMorphisms (C^.identity Z) f,
  identities := ♮,
  functoriality := begin
                      blast,
                      -- TODO I'd hope the blast could just do these steps: interchange has [ematch], and left_identity has [simp].
                      rewrite - C^.interchange,
                      rewrite C^.left_identity
                    end
}

-- @[reducible] definition pentagon_3step_1 ( C : MonoidalCategory.{ u v } ) :=
--   let α := C^.associator_transformation in
--   whisker_on_right
--     (α × IdentityNaturalTransformation (IdentityFunctor C))
--     C^.tensor

-- @[reducible] definition pentagon_3step_2 ( C : MonoidalCategory.{ u v } ) :=
--   let α := C^.associator_transformation in
--   whisker_on_left
--     (FunctorComposition
--       (ProductCategoryAssociator C C C × IdentityFunctor C)
--       ((IdentityFunctor C × C^.tensor) × IdentityFunctor C))
--     α

-- @[reducible] definition pentagon_3step_3 ( C : MonoidalCategory.{ u v } ) :=
--   let α := C^.associator_transformation in
--   whisker_on_left
--     (FunctorComposition
--       (ProductCategoryAssociator C C C × IdentityFunctor C)
--       (ProductCategoryAssociator C (C × C) C))
--     (whisker_on_right
--       (IdentityNaturalTransformation (IdentityFunctor C) × α)
--       C^.tensor)

-- @[reducible] definition pentagon_3step ( C : MonoidalCategory.{ u v } ) :=
--   vertical_composition_of_NaturalTransformations
--     (vertical_composition_of_NaturalTransformations
--       (pentagon_3step_1 C)
--       (pentagon_3step_2 C))
--     (pentagon_3step_3 C)

-- @[reducible] definition pentagon_2step_1 ( C : MonoidalCategory.{ u v } ) :=
--   let α := C^.associator_transformation in
--   whisker_on_left
--     ((C^.tensor × IdentityFunctor C) × IdentityFunctor C)
--     α

-- @[reducible] definition pentagon_2step_2 ( C : MonoidalCategory.{ u v } ) :=
--   let α := C^.associator_transformation in
--   whisker_on_left
--     (FunctorComposition
--       (ProductCategoryAssociator (C × C) C C)
--       (IdentityFunctor (C × C) × C^.tensor))
--     α

-- @[reducible] definition pentagon_2step ( C : MonoidalCategory.{ u v } ) :=
--   vertical_composition_of_NaturalTransformations
--     (pentagon_2step_1 C)
--     (pentagon_2step_2 C)

-- -- adding these attributes increased compile time from 1.5 minutes to 13 minutes. :-(
-- -- attribute [simp] MonoidalCategory.left_identity
-- -- attribute [simp] MonoidalCategory.right_identity

-- lemma pentagon_in_terms_of_natural_transformations
--   ( C : MonoidalCategory ) :
--   pentagon_2step C = pentagon_3step C :=
--   begin
--     blast,
--     induction X with PQR S,
--     induction PQR with PQ R,
--     induction PQ with P Q,
--     pose p := C^.pentagon P Q R S,
--     -- notice that the hypothesis p is gross, until we blast!
--     blast,
--     -- I don't understand why this isn't being done by blast automatically: Functor.identities has [simp].
--     -- Moreover, I don't understand why `rewrite bifunctor_identities` doesn't apply here.
--     repeat { rewrite C^.tensor^.identities <|> rewrite C^.left_identity <|> rewrite C^.right_identity },
--     blast
--   end