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) 2022 Sina Hazratpour. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
----------------
# Cats: Universal Properties
😺 🐈 😼 🐈⬛ 😸 🐈 🙀 😻 🐈 😹
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

/-
The most important concept in category theory is that of __universal property__. We already have seen an example of univeral property in construction of fake integers from fake natural numbers by __quotient__ in lecture 15. The quotient construction in the category of types. We will generalize the quotient construction to any category.

The further you go in mathematics, especially pure mathematics, the more universal properties you will meet. We will spend most of our time studying different manifestations of this concept.
-/

-- import tactic.basic
import ..prooflab
import lectures.lec16_categories_basic

open PROOFS.STR

/-! # Terminal Object
-/

/-
Product
-/

#check prod


/-
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