open Classical

theorem const_func_ext [Nonempty α] {a b : β} : (fun _ : α => a) = (fun _ => b) → (a = b) := by
  intro h
  have ha : (fun _ : α => a) (choice inferInstance) = a := rfl
  have hb : (fun _ : α => b) (choice inferInstance) = b := rfl
  rw [←ha, ←hb, h]

def Vector (α : Type) (n : Nat) := Fin n → α

infix:95 "⋆" => Vector

def Vector.ε : α⋆0 := (nomatch ·)

def Vector.ε' (h : n = 0) : α⋆n :=
  fun ⟨_, h'⟩ => by simp [h] at h'; contradiction

def Vector.prefix (as : α⋆(n + 1)) : α⋆n :=
  fun i => as ⟨i.val, Nat.lt_succ_of_le $ Nat.le_of_lt i.isLt⟩

def Vector.all (v : α⋆n) (p : α → Prop) : Prop :=
  ∀ i, p (v i)

def Vector.map (v : α⋆n) (f : α → β) : β⋆n :=
  (f $ v ·)

abbrev Op (α : Type) (n : Nat) := α⋆n → α

instance : CoeHead (Op α 0) α where
  coe op := op Vector.ε

abbrev BinOp (α : Type) := α → α → α

instance : Coe (Op α 2) (BinOp α) where
  coe op a₁ a₂ := op fun | 0 => a₁ | 1 => a₂

instance : CoeTail (BinOp α) (Op α 2) where
  coe op as := op (as 0) (as 1)

def ExistsUnique (p : α → Prop) := ∃ x, p x ∧ ∀ y, p y → y = x

open Lean TSyntax.Compat in
macro "∃! " xs:explicitBinders ", " b:term : term => expandExplicitBinders ``ExistsUnique xs b

class Fintype (α : Type)

def Set (α : Type _) := α → Prop

instance : Membership α (Set α) where
  mem a s := s a

instance : CoeSort (Set α) Type where
  coe s := { a : α // s a }

abbrev Set.empty : Set α := fun _ => False

instance : EmptyCollection (Set α) := ⟨Set.empty⟩

def Set.Nonempty (s : Set α) : Prop := s ≠ ∅

def Set.Nonempty.iff_exists_mem : Set.Nonempty s ↔ ∃ a, a ∈ s := by
  sorry

abbrev Set.univ : Set α := fun _ => True

abbrev Set.singleton (a : α) : Set α := (· = a)

theorem Set.mem_univ : a ∈ Set.univ := .intro

def Set.image (f : α → β) : Set β :=
  (∃ a, f a = ·)

theorem Set.mem_image_iff : (b ∈ Set.image f) ↔ (∃ a, f a = b) := ⟨id, id⟩

theorem Set.image_choose {b : β} : (h : b ∈ Set.image f) → (f $ choose h) = b :=
  choose_spec

def Set.union (s₁ s₂ : Set α) := fun a => a ∈ s₁ ∨ a ∈ s₂

def Set.bUnion (s : Set (Set α)) : Set α :=
  fun a => ∃ m, m ∈ s ∧ a ∈ m

def Set.Subset (s₁ s₂ : Set α) : Prop :=
  ∀ a, a ∈ s₁ → a ∈ s₂

infix:50 " ⊆ " => Set.Subset

theorem Set.mem_ext {s₁ s₂ : Set α} : (∀ a, a ∈ s₁ ↔ a ∈ s₂) → s₁ = s₂ :=
  fun h => funext (fun a => propext (h a))

abbrev Vector.lift {s : Set α} (v : s⋆n) : α⋆n := (v ·)

abbrev Word (α : Type) := List α

postfix:95 "⋆" => Word

abbrev Word.ε : α⋆ := []

@[match_pattern]
abbrev Word.prepend : α → α⋆ → α⋆ := List.cons

abbrev Word.append (u : α⋆) (i : α) : α⋆ := u ++ [i]

infixl:70 "⬝" => Word.prepend

infixl:70 "•" => Word.append

def Word.prefixes : α⋆ → Set (α⋆)
  | .ε => Set.singleton .ε
  | i⬝v => fun u => (u = i⬝v) ∨ (u ∈ prefixes v)

@[simp]
theorem Set.mem_singleton : a ∈ Set.singleton a := by
  simp [singleton, Membership.mem]

theorem Word.ε_mem_prefixes (u : Word α) : .ε ∈ u.prefixes := by
  induction u
  case nil => simp [prefixes, Set.mem_singleton]
  case cons i v hi =>
    simp [prefixes]
    simp [Membership.mem] at *
    exact hi

def Vector.word : {n : Nat} → α⋆n → α⋆
  | 0,     _ => []
  | n + 1, as => as.prefix.word ++ [as ⟨n, Nat.lt_succ_self _⟩]

def Vector.prefixes : {n : Nat} → (α⋆n) → Set (α⋆)
  | 0,     _  => Set.singleton .ε
  | _ + 1, as => fun u => (u = as.word) ∨ (u ∈ as.prefix.prefixes)

def Function.Injective (f : α → β) : Prop :=
  ∀ a₁ a₂, (f a₁ = f a₂) → a₁ = a₂

def Function.Surjective (f : α → β) : Prop :=
  ∀ b, ∃ a, f a = b

structure Function.Bijective (f : α → β) : Prop where
  inj : Function.Injective f
  surj : Function.Surjective f

-----------------------------------------------------------------------------------------

class Alphabet (α : Type) where
  [nonempty : Nonempty α]
  [finite : Fintype α]

structure RankedAlphabet where
  alphabet : Type
  rank : alphabet → Nat
  [isAlphabet : Alphabet alphabet]

instance : CoeSort RankedAlphabet Type where
  coe Δ := Δ.alphabet

structure Algebra (Δ : RankedAlphabet) where
  carrier : Type
  θ : (σ : Δ) → Op carrier (Δ.rank σ)

def Algebra.ops (alg : Algebra Δ) : Set (Σ k : Nat, Op alg.carrier k) :=
  fun ⟨k, op⟩ => ∃ (σ : Δ) (h : Δ.rank σ = k), (alg.θ σ = h ▸ op)

def Closed (alg : Algebra Δ) (sub : Set alg.carrier) : Prop :=
  ∀ σ (cs : Vector sub $ Δ.rank σ), (alg.θ σ cs.lift) ∈ sub

theorem Algebra.carrier_closed (alg : Algebra Δ) : Closed alg Set.univ := by
  simp [Closed, Set.mem_univ]

-- Note that this defines a `Set`.
inductive Closure (sub : Set α) (ops : Set (Σ k : Nat, Op α k)) : α → Prop
  | root : (a ∈ sub) → Closure sub ops a
  | app {v : Vector α k} : (⟨k, op⟩ ∈ ops) → (∀ i, Closure sub ops $ v i) → Closure sub ops (op v)

abbrev closure (sub : Set α) (ops : Set (Σ k : Nat, Op α k)) : Set α :=
  Closure sub ops

structure Subalgebra (alg : Algebra Δ) where
  carrier : Set alg.carrier
  θ : (σ : Δ) → Op alg.carrier (Δ.rank σ)
  restricted : ∀ σ cs, cs.all (· ∈ carrier) → θ σ cs = alg.θ σ cs
  closed : Closed alg carrier

def Subalgebra.algebra {alg : Algebra Δ} (s : Subalgebra alg) : Algebra Δ where
  carrier := s.carrier
  θ σ cs := {
    val := s.θ σ cs.lift
    property := by
      have h : cs.lift.all (· ∈ s.carrier) := by
        simp [Vector.all, Vector.lift]
        intro i
        exact (cs i).property
      rw [s.restricted _ _ h]
      apply s.closed
  }

instance {alg : Algebra Δ} : Coe (Subalgebra alg) (Algebra Δ) where
  coe := Subalgebra.algebra

structure Hom (alg₁ alg₂ : Algebra Δ) where
  hom : alg₁.carrier → alg₂.carrier
  property : ∀ σ cs, hom (alg₁.θ σ cs) = (alg₂.θ σ) (hom ∘ cs)

theorem Hom.ext (hom₁ hom₂ : Hom alg₁ alg₂) : hom₁.hom = hom₂.hom → hom₁ = hom₂ := by
  intro h
  cases hom₁ <;> cases hom₂
  simp at h
  simp [h]

instance : CoeFun (Hom alg₁ alg₂) (fun _ => alg₁.carrier → alg₂.carrier) where
  coe h := h.hom

theorem lemma_2_6_2 (hom : Hom alg₁ alg₂) : Closed alg₂ (Set.image hom) := by
  intro σ cs₂
  simp [Closed, Set.mem_image_iff]
  let cs₁ := (cs₂ · |>.property |> choose)
  have h := hom.property σ cs₁
  exists alg₁.θ σ cs₁
  rw [h]
  congr
  funext i
  apply Set.image_choose

-- Lemma 2.6.3
def Hom.compose (hom₁₂ : Hom alg₁ alg₂) (hom₂₃ : Hom alg₂ alg₃) : Hom alg₁ alg₃ where
  hom := hom₂₃ ∘ hom₁₂
  property := by
    intro σ cs₁
    simp [hom₁₂.property σ cs₁, hom₂₃.property σ $ hom₁₂ ∘ cs₁]
    rfl

infixr:90 " ∘ " => Hom.compose

structure Iso (alg₁ alg₂ : Algebra Δ) extends Hom alg₁ alg₂ where
  bij : Function.Bijective hom

def Isomorphic (alg₁ alg₂ : Algebra Δ) : Prop :=
  Nonempty (Iso alg₁ alg₂)

infix:50 " ≅ " => Isomorphic

structure FreelyGenerated (alg : Algebra Δ) (gen : Set alg.carrier) (k : Set $ Algebra Δ) : Prop where
  mem : alg ∈ k
  generated : ∀ c, c ∈ closure gen alg.ops
  free : ∀ (alg' : Algebra Δ) (f : gen → alg'.carrier), (alg' ∈ k) →
         ∃! hom : Hom alg alg', ∀ c : gen, f c = hom c

-- Note, we immediately restrict this definition to the set of all algebras,
-- as this is the only one we ever need.
noncomputable def FreelyGenerated.hom {alg : Algebra Δ} {H}
  (h : FreelyGenerated alg H Set.univ) (target : Algebra Δ) (f : H → target.carrier) :
  Hom alg target :=
  choose (h.free target f Set.mem_univ)

theorem FreelyGenerated.hom_extends (h : FreelyGenerated alg gen Set.univ) {f}:
  ∀ c : gen, f c = (h.hom target f) c :=
  (choose_spec (h.free target f Set.mem_univ) |>.left ·)

-----------------------------------------------------------------------------------------

def BinOp.Associative (op : BinOp α) : Prop :=
  ∀ a b c, op (op a b) c = op a (op b c)

def BinOp.Commutative (op : BinOp α) : Prop :=
  ∀ a b, op a b = op b a

def BinOp.Idempotent (op : BinOp α) : Prop :=
  ∀ a, op a a = a

structure BinOp.Identity (op : BinOp α) (e : α) : Prop where
  left  : ∀ a, op e a = a
  right : ∀ a, op a e = a

theorem BinOp.Identity.unique (op : BinOp α) : (Identity op e) → (Identity op e') → e = e' := by
  intro h h'
  rw [←h'.left e, h.right e']

structure BinOp.Inverse (op : BinOp α) (a a' : α) : Prop where
  left  : ∀ {e}, (Identity op e) → op a a' = e
  right : ∀ {e}, (Identity op e) → op a' a = e

def BinOp.RightDistrib (mul add : BinOp α) : Prop :=
  ∀ a b c, mul (add a b) c = add (mul a c) (mul b c)

def BinOp.LeftDistrib (mul add : BinOp α) : Prop :=
  ∀ a b c, mul a (add b c) = add (mul a b) (mul a c)

structure BinOp.Distrib (mul add : BinOp α) : Prop where
  right : RightDistrib mul add
  left : LeftDistrib mul add

structure Semigroup where
  carrier : Type
  op : BinOp carrier
  assoc : BinOp.Associative op

protected inductive Semigroup.Alphabet
  | «⊙»

abbrev Semigroup.ranked : RankedAlphabet where
  alphabet := Semigroup.Alphabet
  rank | .«⊙» => 2
  isAlphabet := sorry

def Semigroup.algebra (s : Semigroup) : Algebra ranked where
  carrier := s.carrier
  θ | .«⊙» => s.op

structure Monoid extends Semigroup where
  id : Op carrier 0
  idIsIdentity : BinOp.Identity op id

protected inductive Monoid.Alphabet
  | «⊙»
  | e

abbrev Monoid.ranked : RankedAlphabet where
  alphabet := Monoid.Alphabet
  rank
    | .«⊙» => 2
    | .e   => 0
  isAlphabet := sorry

def Monoid.algebra (m : Monoid) : Algebra Monoid.ranked where
  carrier := m.carrier
  θ
    | .«⊙» => m.op
    | .e   => m.id

def Monoid.Commutative (m : Monoid) : Prop :=
  BinOp.Commutative m.op

structure StrongBimonoid where
  carrier : Type
  add  : BinOp carrier
  mul  : BinOp carrier
  zero : Op carrier 0
  one  : Op carrier 0
  addComm : BinOp.Commutative add
  zeroNeOne : zero ≠ one
  leftAbsorption : ∀ c, mul zero c = zero
  rightAbsorption : ∀ c, mul c zero = zero

protected inductive StrongBimonoid.Alphabet
  | «⊕»
  | «⊗»
  | «𝟘»
  | «𝟙»

abbrev StrongBimonoid.ranked : RankedAlphabet where
  alphabet := StrongBimonoid.Alphabet
  rank
    | .«⊕» => 2
    | .«⊗» => 2
    | .«𝟘» => 0
    | .«𝟙» => 0
  isAlphabet := sorry

def StrongBimonoid.algebra (s : StrongBimonoid) : Algebra StrongBimonoid.ranked where
  carrier := s.carrier
  θ
    | .«⊕» => s.add
    | .«⊗» => s.mul
    | .«𝟘» => s.zero
    | .«𝟙» => s.one

structure Semiring extends StrongBimonoid where
  distributive : BinOp.Distrib mul add

-----------------------------------------------------------------------------------------

namespace Term

inductive TermSymbol (Δ : RankedAlphabet) (H : Type)
  | alph (sym : Δ)
  | var (v : H)
  | «(»
  | «)»
  | «,»

-- Note, we have to use the raw representation of a vector for `v` here.
inductive _root_.Term (Δ : RankedAlphabet) (H : Type)
  | var (h : H)
  | app (σ : Δ) (v : Fin (Δ.rank σ) → (Term Δ H))

-- Note, we could replace this with a coercion from H to a set of terms,
-- but that would have to be a `CoeDep` which isn't reliable enough.
def Vars (Δ : RankedAlphabet) (H : Type) : Set (Term Δ H)
  | .var .. => True
  | .app .. => False

protected def algebra (Δ : RankedAlphabet) (H : Type) : Algebra Δ where
  carrier := Term Δ H
  θ := app

-- Implementation detail of `Term.algebraHom`.
private def algebraHomImpl (target : Algebra Δ) (f : Vars Δ H → target.carrier) : (Term.algebra Δ H).carrier → target.carrier
  | .var c => f ⟨.var c, by simp [Vars]⟩
  | .app σ cs => target.θ σ (algebraHomImpl target f $ cs ·)

-- Implementation detail of `Term.algebra_freelyGenerated`.
private def algebraHom (target : Algebra Δ) (f : Vars Δ H → target.carrier) : Hom (Term.algebra Δ H) target where
  hom := algebraHomImpl target f
  property := fun _ _ => by simp [algebraHomImpl, Function.comp]

-- Theorem 2.9.3
theorem algebra_freelyGenerated : FreelyGenerated (Term.algebra Δ H) (Vars Δ H) Set.univ where
  mem := Set.mem_univ
  generated := by
    intro c
    simp [closure]
    induction c
    case var h =>
      apply Closure.root
      simp [Membership.mem, Vars]
    case app σ v hi =>
      refine Closure.app ?_ hi
      simp [Term.algebra, Algebra.ops, Membership.mem]
      exists σ, rfl
  free := by
    intro target f _
    simp [ExistsUnique]
    exists algebraHom target f
    constructor
    case left =>
      intro ⟨v, hv⟩
      cases v
      case app => contradiction
      case var => simp [algebraHom, algebraHomImpl]
    case right =>
      intro hom h
      apply Hom.ext
      funext c
      induction c
      case a.h.var => simp [algebraHom, algebraHomImpl, h _]
      case a.h.app σ cs hi =>
        simp [algebraHom, algebraHomImpl]
        have h := hom.property σ cs
        simp [Term.algebra] at h
        simp [h]
        congr
        funext i
        exact hi i

protected noncomputable def algebra.hom (target : Algebra Δ) (f : Vars Δ H → target.carrier) :
  Hom (Term.algebra Δ H) target :=
  (algebra_freelyGenerated).hom target f

theorem algebra.hom_extends (target) (f : _ → target.carrier) :
  ∀ v : Vars Δ H, f v = (Term.algebra.hom target f) v.val :=
  Term.algebra_freelyGenerated.hom_extends

-----------------------------------------------------------------------------------------

abbrev posAlgebra (Δ) : Algebra Δ where
  carrier := Set (Nat⋆)
  θ σ cs
    | .ε => True
    | i ⬝ tl => ∃ h : i < Δ.rank σ, tl ∈ cs ⟨i, h⟩

noncomputable def pos {Δ H} :=
  Term.algebra.hom (H := H) (posAlgebra Δ) (fun _ => Set.singleton .ε)

theorem pos_var : (@pos Δ H) (var v) = Set.singleton [] :=
  Eq.symm <| Term.algebra.hom_extends (posAlgebra Δ) (fun _ => Set.singleton .ε) ⟨var v, by simp [Vars]⟩

theorem pos_app (σ cs) : (@pos Δ H) (app σ cs) =
  (fun | .ε => True | i ⬝ tl => ∃ h : i < Δ.rank σ, tl ∈ pos (cs ⟨i, h⟩)) :=
  pos.property σ cs

theorem pos_zero (h : Δ.rank σ = 0) : (@pos Δ H) (app σ $ Vector.ε' h) = Set.singleton .ε := by
  simp [pos_app (H := H) σ (Vector.ε' h)]
  refine Set.mem_ext ?_
  intro w
  constructor
  all_goals
    intro h'
    simp [Set.singleton, Membership.mem] at *
  case mpr => simp [h']
  case mp =>
    split at h'
    · rfl
    · have ⟨h', _⟩ := h'
      rw [h] at h'
      contradiction

theorem mem_pos : (i ⬝ w) ∈ (@pos Δ H) (app σ cs) → ∃ h : i < Δ.rank σ, (w ∈ pos (cs ⟨i, h⟩)) := by
  intro h
  rw [pos_app] at h
  simp [Membership.mem] at h
  exact h

theorem ε_mem_pos : .ε ∈ (@pos Δ H) ξ := by
  sorry

structure TP (Δ H) where
  ξ : Term Δ H
  w : { w // w ∈ pos ξ }

def label : TP Δ H → (Sum Δ H)
  | ⟨var v, _⟩ => .inr v
  | ⟨app σ _, ⟨.ε, _⟩⟩ => .inl σ
  | ⟨app σ ξs, ⟨i ⬝ w', h⟩⟩ => label {
      ξ := ξs ⟨i, choose $ mem_pos h⟩,
      w := ⟨w', choose_spec $ mem_pos h⟩
    }
termination_by label tp => tp.w.val.length

-- TODO: Figure out if this is ok.
notation ξ "°" w => Term.label (TP.mk ξ w)

def subtree : TP Δ H → Term Δ H
  | ⟨var v, _⟩ => var v
  | ⟨ξ, ⟨.ε, _⟩⟩ => ξ
  | ⟨app σ ξs, ⟨i ⬝ w', h⟩⟩ => subtree {
      ξ := ξs ⟨i, choose $ mem_pos h⟩,
      w := ⟨w', choose_spec $ mem_pos h⟩
    }
termination_by subtree tp => tp.w.val.length

-- TODO: Figure out if this is ok.
notation ξ "∣" w => Term.subtree (TP.mk ξ w)

def replacement (tp : TP Δ H) (ζ : Term Δ H) : Term Δ H :=
  match tp with
  | ⟨var _, _⟩ | ⟨_, ⟨.ε, _⟩⟩ => ζ
  | ⟨app σ ξs, ⟨i ⬝ w', h⟩⟩ =>
    let tp' := { ξ := ξs ⟨i, choose $ mem_pos h⟩, w := ⟨w', choose_spec $ mem_pos h⟩ }
    app σ (fun j => if i = j then replacement tp' ζ else ξs j)
termination_by replacement tp _ => tp.w.val.length

-- TODO: Figure out if this is ok.
notation ξ "[" ζ "]" w => Term.replacement (TP.mk ξ w) ζ

end Term

-----------------------------------------------------------------------------------------

def RankedAlphabet.lift (Γ : Type) [Alphabet Γ] : RankedAlphabet where
  alphabet := Option Γ
  rank
    | some _ => 1
    | none => 0
  isAlphabet := {
    nonempty := inferInstance
    finite := sorry
  }

def stringAlgebra (Γ : Type) [Alphabet Γ] : Algebra (RankedAlphabet.lift Γ) where
  carrier := (Γ⋆)
  θ
    | some σ => fun ws => σ ⬝ (ws ⟨0, by simp [RankedAlphabet.lift]⟩)
    | none => fun _ => .ε

def treeₑ [Alphabet Γ] : Γ⋆ → Term (RankedAlphabet.lift Γ) Empty
  | .ε => (Term.algebra (RankedAlphabet.lift Γ) Empty).θ none (nomatch ·)
  | σ⬝w => .app (some σ) (fun _ => treeₑ w)

theorem Term.algebra_iso_stringAlgebra (Γ : Type) [Alphabet Γ] :
  Isomorphic (stringAlgebra Γ) (Term.algebra (RankedAlphabet.lift Γ) Empty) := by
  unfold Isomorphic
  apply Nonempty.intro
  exact {
    hom := treeₑ
    property := by
      intro σ w
      cases σ
      all_goals simp [Term.algebra, stringAlgebra]
      case none =>
        simp [Function.comp, treeₑ, Term.algebra]
        funext ⟨_, h⟩
        simp [RankedAlphabet.lift] at h
        contradiction
      case some σ =>
        simp [stringAlgebra, RankedAlphabet.lift] at w
        generalize hw : w ⟨0, stringAlgebra.proof_1⟩ = w'
        simp [treeₑ, Function.comp]
        funext ⟨i, hi⟩
        have hi : i = 0 := by
          simp [RankedAlphabet.lift] at hi
          cases i
          case zero => rfl
          case succ => contradiction
        simp [hw, hi]
    bij := {
      inj := by
        simp [Function.Injective]
        intro σ₁ σ₂ h
        induction σ₁ generalizing σ₂ <;> cases σ₂ <;> simp [treeₑ, Term.algebra] at *
        case cons.cons σ _ hi _ _ =>
          have ⟨h₁, h₂⟩ := h
          injection h₁ with h₁
          have : Nonempty (Fin $ (RankedAlphabet.lift Γ).rank $ some σ) :=
            .intro ⟨0, by simp [RankedAlphabet.lift]⟩
          simp [h₁, hi _ (const_func_ext h₂)]
      surj := by
        simp [Function.Surjective]
        intro a
        induction a
        case var => contradiction
        case app σ w hi =>
          cases σ
          case none =>
            exists .ε
            simp [treeₑ, Term.algebra]
            funext ⟨_, h⟩
            simp [RankedAlphabet.lift] at h
            contradiction
          case some σ =>
            have ⟨a, h⟩ := hi ⟨0, by simp [RankedAlphabet.lift]⟩
            exists σ⬝a
            simp [h, treeₑ]
            refine congrArg _ ?_
            funext ⟨i, hi⟩
            have hi : i = 0 := by
              simp [RankedAlphabet.lift] at hi
              cases i
              case zero => rfl
              case succ => contradiction
            simp [hi]
    }
  }

-----------------------------------------------------------------------------------------

-- TODO: Change W to be a Finset.
structure TreeDomain (W : Set (Nat⋆)) : Prop where
  nonempty : Set.Nonempty W
  prefixClosed : Set.bUnion (Set.image Word.prefixes) ⊆ W
  leftClosed : ∀ u i, (u•i ∈ W) → u•(i - 1) ∈ W

theorem TreeDomain.ε_mem : TreeDomain W → .ε ∈ W := by
  intro h
  apply h.prefixClosed .ε
  simp [Set.bUnion, Membership.mem]
  have ⟨m, _⟩ := Set.Nonempty.iff_exists_mem.mp h.nonempty
  exists m.prefixes
  constructor
  case left => exists m
  case right => apply Word.ε_mem_prefixes

theorem Term.pos_treeDomain (ξ : Term Δ H) : TreeDomain (pos ξ) where
  nonempty := Set.Nonempty.iff_exists_mem.mpr ⟨_, Term.ε_mem_pos⟩
  prefixClosed := sorry
  leftClosed := sorry

-- TEMPORARY
def Set.size : Set α → Nat := sorry

structure TreeMapping {Δ : RankedAlphabet} {W : Set (Nat⋆)} (t : W → Δ) where
  domain : TreeDomain W
  rankPreservation : ∀ w, Set.size (fun j => w.val•j ∈ W) = Δ.rank (t w)


import data.vector
import data.equiv.denumerable
import data.list.sort
import ring_theory.tensor_product
import algebra.category.Module.basic

@[derive has_reflect] inductive type (cT : Type) : Type
| const : cT → type
| arrow : type → type → type

variables {cT : Type}

inductive term2 (ct : type cT → Type) : Π (A : type cT), Type
| const {T : type cT} (t : ct T) : term2 T
| app {T₁ T₂ : type cT} (f : term2 (T₁.arrow T₂)) (x : term2 T₁) : term2 T₂
| id {T₁ : type cT} : term2 (T₁.arrow T₁)
| comp {T₁ T₂ T₃ : type cT} : term2 ((T₁.arrow T₂).arrow
  ((T₂.arrow T₃).arrow (T₁.arrow T₃)))
| swap {T₁ T₂ T₃ : type cT} : term2 ((T₁.arrow (T₂.arrow T₃)).arrow
  (T₂.arrow (T₁.arrow T₃)))

-- def term2.reflect (ct : type cT → Type) [Π A, has_reflect (ct A)] [reflected cT] [reflected ct] :
--   Π {A : type cT}, term2 ct A → expr
-- | _ (term2.const t) := _
-- | _ (term2.app f x) := _

-- def simplify {ct : type cT → Type} : Π {T₁ : type cT}, term2 ct T₁ → term2 ct T₁
-- | _ (term2.app term2.comp term2.id) := term2.id
-- | _ (term2.app term2.id x) := x
-- | _ (term2.app term2.swap (term2.app term2.swap f)) := f
-- | _ (term2.app (term2.app (term2.app term2.comp f) g) x) := term2.app g (term2.app f x)
-- | _ (term2.app (term2.app term2.comp f) term2.id) := f
-- | _ (term2.app (term2.app term2.swap term2.comp) term2.id) := term2.id
-- | _ x := x

namespace term2

variables {ct : type cT → Type} {T₁ T₂ T₃ : type cT}

-- def app' : Π {T₁ T₂ : type cT} (f : term2 ct (T₁.arrow T₂)) (x : term2 ct T₁), term2 ct T₂
-- | _ _ (const f) x := (const f).app x
-- | _ _ (app f x) y := (app f x).app y
-- | _ _ term2.id  x := x
-- | _ _ (term2.app (term2.app term2.comp f) g) x := app' g (app' f x)
-- | _ _ f x := f.app x
-- using_well_founded { dec_tac := `[admit] }

end term2

@[reducible] def context (cT : Type) : Type := list (string × type cT)

inductive term (ct : type cT → Type) : Π (Γ : context cT) (A : type cT), Type
| const {T : type cT} (t : ct T) : term [] T
| var (a : string) (T : type cT) : term [(a, T)] T
| app (Γ₁ Γ₂ : context cT) {T₁ T₂ : type cT} (f : term Γ₁ (T₁.arrow T₂)) (x : term Γ₂ T₁) : term (Γ₂ ++ Γ₁) T₂
| lambda {Γ : context cT} (a : string) (T₁ : type cT) {T₂ : type cT}
    (t : term ((a, T₁) :: Γ) T₂) : term Γ (T₁.arrow T₂)

def presheaf (ct : type cT → Type) : Type 1 :=
Σ (F : type cT → Type), Π {A B : type cT}, term2 ct (A.arrow B) → F A → F B

namespace presheaf

variable {ct : type cT → Type}

def hom (F G : presheaf ct) : Type :=
Π (A : type cT), F.1 A → G.1 A

def hom.comp {F G H : presheaf ct} (f : hom F G) (g : hom G H) : hom F H :=
λ A, g A ∘ f A

def hom.id (F : presheaf ct) : hom F F := λ _, id

variable (ct)

def yoneda (A : type cT) : presheaf ct :=
⟨λ B, term2 ct (A.arrow B), λ B C f g, (term2.comp.app g).app f⟩

variable {ct}

def yoneda_map {A B : type cT} (f : term2 ct (A.arrow B)) :
  hom (yoneda ct B) (yoneda ct A) :=
λ C, term2.app (term2.app term2.comp f)

def yoneda_full {A B : type cT} (f : hom (yoneda ct A) (yoneda ct B)) : term2 ct (B.arrow A) :=
f A term2.id

def alpha {A B C D X : type cT}
  (f : term2 ct (A.arrow (B.arrow X)))
  (g : term2 ct (X.arrow (C.arrow D))) :
  Σ Y : type cT,
    term2 ct (B.arrow (C.arrow Y)) × term2 ct (A.arrow (Y.arrow D)) :=
begin
  have h : term2 ct (A.arrow (B.arrow (C.arrow D))),
  { refine (term2.comp.app f).app _,
    refine (term2.swap.app term2.comp).app g },
  have h' : term2 ct (B.arrow (C.arrow (A.arrow D))),
  { refine (term2.comp.app _).app term2.swap,
    refine term2.swap.app h },
  use (A.arrow D),
  use h',
  use term2.swap.app term2.id
end

infix ` => `: 50 := type.arrow

def tensor (F G : presheaf ct) : presheaf ct :=
⟨λ c : type cT, Σ c₁ c₂, F.1 c₁ × G.1 c₂ ×
    term2 ct (c₁.arrow (c₂.arrow c)),
  -- Strictly speaking should be a colimit or something.
  λ A B f x,
  -- begin
  --   rcases x with ⟨c₁, c₂, Fc₁, Gc₂, f⟩,
  --   use [c₁, c₂, Fc₁, Gc₂],

  -- end
  ⟨x.1, x.2.1, x.2.2.1, x.2.2.2.1,
     term2.app (term2.app term2.comp x.2.2.2.2)
      (term2.app (term2.app term2.swap term2.comp) f)⟩
      ⟩

def tensor_map_left {F₁ G F₂ : presheaf ct} (f : hom F₁ F₂)  :
  hom (tensor F₁ G) (tensor F₂ G) :=
λ A a, ⟨a.1, a.2.1, f _ a.2.2.1, a.2.2.2.1, a.2.2.2.2⟩

def tensor_map_right {F G₁ G₂ : presheaf ct} (f : hom G₁ G₂)  :
  hom (tensor F G₁) (tensor F G₂) :=
λ A a, ⟨a.1, a.2.1, a.2.2.1, f _ a.2.2.2.1, a.2.2.2.2⟩

def tensor_comm {F G : presheaf ct} : hom (tensor F G) (tensor G F) :=
λ A x, ⟨x.2.1, x.1, x.2.2.2.1, x.2.2.1, term2.swap.app x.2.2.2.2⟩

def id : presheaf ct :=
⟨λ c, term2 ct c, λ A B, term2.app⟩

def rid₁ (F : presheaf ct) : hom (F.tensor id) F :=
begin
  dsimp [tensor, hom, id],
  intros A a,
  exact F.2 ((term2.swap.app a.2.2.2.2).app a.2.2.2.1) a.2.2.1
end

def rid₂ (F : presheaf ct) : hom F (F.tensor id) :=
begin
  dsimp [tensor, hom, id],
  intros A a,
  refine ⟨A, A.arrow A, a, term2.id, term2.swap.app term2.id⟩,
end

def lid₁ (F : presheaf ct) : hom (tensor id F) F :=
begin
  dsimp [tensor, hom, id],
  intros A a,
  exact F.2 (a.2.2.2.2.app a.2.2.1) a.2.2.2.1
end

def lid₂ (F : presheaf ct) : hom F (tensor id F) :=
begin
  dsimp [tensor, hom, id],
  intros A a,
  refine ⟨A.arrow A, A, term2.id, a, term2.id⟩,
end

def homp (F G : presheaf ct) : presheaf ct :=
⟨λ c, Π c₁ c₂ : type cT, term2 ct (c.arrow (c₁.arrow c₂)) → F.1 c₁ → G.1 c₂,
begin
  intros A B f x c₁ c₂ g Fc,
  specialize x c₁ c₂ ((term2.comp.app f).app g) Fc,
  exact x
end⟩

def comp {F G H : presheaf ct} : hom (homp G H) (homp (homp F G) (homp F H)) :=
begin
  intros A x,
  dsimp [homp] at *,
  intros c₁ c₂ f h c₃ c₄ g Fc₃,
  have := alpha f g,
  apply x _ _ this.2.2,
  apply h,
  apply this.2.1,
  exact Fc₃
end

def scomp {F G H : presheaf ct} : hom (homp F G) (homp (homp G H) (homp F H)) :=
begin
  intros A x,
  dsimp [homp] at *,
  intros c₁ c₂ f h c₃ c₄ g Fc₃,
  have := alpha (term2.swap.app f) g,
  apply h _ _ this.2.2,
  apply x,
  apply this.2.1,
  exact Fc₃
end

def tensor_mk {F G : presheaf ct} : hom F (homp G (F.tensor G)) :=
begin
  intros A FA c₁ c₂ f Gc₁,
  dsimp [homp, tensor],
  exact ⟨_, _, FA, Gc₁, f⟩
end

def curry {F G H : presheaf ct} : (F.tensor G).hom H → F.hom (G.homp H) :=
begin
  intros x A FA c₁ c₂ f Gc₁,
  dsimp [homp, tensor, hom] at *,
  apply x,
  refine ⟨_, _, _, _, f⟩,
  exact FA,
  exact Gc₁
end

def thing {A B C D : presheaf ct} (f : hom A (homp B C)) :
  hom (homp C D) (homp A (homp B D)) :=
begin
  intros c₁ x c₂ c₃ h Ac₂ c₄ c₅ i Bc₄,
  dsimp [homp] at x,
  have := alpha h i,
  apply x,
  exact this.2.2,
  apply f,
  exact Ac₂,
  exact this.2.1,
  exact Bc₄
end

def lcurry {F G H : presheaf ct} : hom (homp (tensor F G) H) (homp F (homp G H)) :=
begin
  apply thing,
  exact tensor_mk
end

def uncurry {F G H : presheaf ct} : F.hom (G.homp H) → (F.tensor G).hom H :=
begin
  intros x A FGA,
  dsimp [homp, tensor, hom] at *,
  apply x _ FGA.2.2.1 _ _ _ FGA.2.2.2.1,
  exact FGA.2.2.2.2
end

def assoc₁ {F G H : presheaf ct} : hom ((F.tensor G).tensor H) (F.tensor (G.tensor H)) :=
uncurry (uncurry (hom.comp tensor_mk lcurry))

def assoc₂ {F G H : presheaf ct} : hom (F.tensor (G.tensor H)) ((F.tensor G).tensor H) :=
begin
  rintros A ⟨B, C, fb, ⟨D, E, gd, he, dec⟩, bca⟩,
  refine ⟨E.arrow A, E, ⟨B, D, fb, gd, _⟩, he, term2.id⟩,
  refine (term2.comp.app bca).app _,
  refine (term2.comp.app _).app (term2.comp.app dec),
  refine term2.swap.app term2.comp
end

end presheaf

section dpresheaf

variable (ct : type cT → Type)

def dpresheaf : Type 2 :=
Σ F : presheaf ct → Type 1, Π {A B : presheaf ct}, A.hom B → F A → F B

namespace dpresheaf

variable {ct}

def hom (F G : dpresheaf ct) : Type 1 :=
Π (A : presheaf ct), F.1 A → G.1 A

def hom.comp {F G H : dpresheaf ct} (f : hom F G) (g : hom G H) : hom F H :=
λ A, g A ∘ f A

def hom.id (F : dpresheaf ct) : hom F F := λ _, id

variable (ct)

def yoneda (A : presheaf ct) : dpresheaf ct :=
⟨λ B, ulift (A.hom B), λ B C f ⟨g⟩, ⟨g.comp f⟩⟩

variable {ct}

def yoneda_map {A B : presheaf ct} (f : A.hom B) : hom (yoneda ct B) (yoneda ct A) :=
λ C g, ⟨f.comp g.1⟩

def yoneda_full {A B : presheaf ct} (f : hom (yoneda ct A) (yoneda ct B)) : B.hom A :=
(f A ⟨presheaf.hom.id _⟩).1

def tensor (F G : dpresheaf ct) : dpresheaf ct :=
⟨λ c, Σ c₁ c₂, F.1 c₁ × G.1 c₂ × (c₁.tensor c₂).hom c,
  -- Strictly speaking should be a colimit or something.
  λ A B f x, ⟨x.1, x.2.1, x.2.2.1, x.2.2.2.1,
     begin
        refine presheaf.hom.comp x.2.2.2.2 f,
     end⟩⟩

def tensor_map_left {F₁ G F₂ : dpresheaf ct} (f : hom F₁ F₂)  :
  hom (tensor F₁ G) (tensor F₂ G) :=
λ A a, ⟨a.1, a.2.1, f _ a.2.2.1, a.2.2.2.1, a.2.2.2.2⟩

def tensor_map_right {F G₁ G₂ : dpresheaf ct} (f : hom G₁ G₂)  :
  hom (tensor F G₁) (tensor F G₂) :=
λ A a, ⟨a.1, a.2.1, a.2.2.1, f _ a.2.2.2.1, a.2.2.2.2⟩

def tensor_comm {F G : dpresheaf ct} : hom (tensor F G) (tensor G F) :=
begin
  intro A,
  rintro ⟨c₁, c₂, Fc₁, Gc₂, f⟩,
  exact ⟨c₂, c₁, Gc₂, Fc₁, presheaf.hom.comp presheaf.tensor_comm f⟩
end

def assoc₁ {F G H : dpresheaf ct} : hom ((F.tensor G).tensor H) (F.tensor (G.tensor H))  :=
begin
  intro A,
  rintros ⟨E, D, ⟨B, C, fb, gc, bce⟩, hd, eda⟩,
  refine ⟨B, C.tensor D, fb, ⟨C, D, gc, hd, presheaf.hom.id _⟩, _⟩,
  refine presheaf.assoc₂.comp _,
  refine (presheaf.tensor_map_left _).comp eda,
  exact bce
end

def assoc₂ {F G H : dpresheaf ct} : hom (F.tensor (G.tensor H)) ((F.tensor G).tensor H) :=
begin
  intro A,
  rintros ⟨B, C, fb, ⟨D, E, gd, he, dec⟩, bca⟩,
  refine ⟨_, _, ⟨_, _, fb, gd, presheaf.hom.id _⟩, he, _⟩,
  refine presheaf.hom.comp _ bca,
  refine presheaf.hom.comp presheaf.assoc₁ _,
  refine presheaf.tensor_map_right dec
end

def id : dpresheaf ct := yoneda _ presheaf.id

def rid₁ (F : dpresheaf ct) : hom (F.tensor id) F :=
begin
  dsimp [hom, tensor],
  intros A x,
  apply F.2 _ x.2.2.1,
  dsimp [id, yoneda] at x,
  have := x.2.2.2.1.1,
  have := presheaf.hom.comp
    (presheaf.tensor_map_right this) x.2.2.2.2,
  exact presheaf.hom.comp (presheaf.rid₂ _) this,
end

def lid₁ (F : dpresheaf ct) : hom (id.tensor F) F :=
begin
  dsimp [hom, tensor],
  intros A x,
  apply F.2 _ x.2.2.2.1,
  dsimp [id, yoneda] at x,
  have := x.2.2.1.1,
  have := presheaf.hom.comp
    (presheaf.tensor_map_left this) x.2.2.2.2,
  exact presheaf.hom.comp (presheaf.lid₂ _) this,
end

def rid₂ (F : dpresheaf ct) : hom F (F.tensor id)  :=
begin
  dsimp [tensor, hom, id, yoneda],
  intros A a,
  use [A, presheaf.id, a, ⟨presheaf.hom.id _⟩],
  refine presheaf.rid₁ _
end

def lid₂ (F : dpresheaf ct) : hom F (tensor id F) :=
begin
 dsimp [tensor, hom, id, yoneda],
  intros A a,
  use [presheaf.id, A, ⟨presheaf.hom.id _⟩, a],
  refine presheaf.lid₁ _
end

def homp (F G : dpresheaf ct) : dpresheaf ct :=
⟨λ c, hom (tensor (yoneda ct c) F) G, begin
  intros A B f x,
  refine hom.comp _ x,
  refine tensor_map_left _,
  refine yoneda_map _,
  exact f
end⟩

def curry {F G H : dpresheaf ct} : hom (tensor F G) H → hom F (homp G H) :=
begin
  dsimp [homp, hom] at *,
  intros x A fA B y,
  apply x B,
  dsimp [tensor, yoneda] at *,
  use [y.1, y.2.1],
  use F.2 y.2.2.1.1 fA,
  use y.2.2.2.1,
  use y.2.2.2.2
end

def uncurry {F G H : dpresheaf ct} : hom F (homp G H) → hom (tensor F G) H :=
begin
  dsimp [tensor, hom, homp, yoneda] at *,
  intros x A y,
  refine x _ y.2.2.1 A _,
  refine ⟨y.1, y.2.1, _, y.2.2.2.1, y.2.2.2.2⟩,
  constructor,
  exact presheaf.hom.id _
end

def lcurry_aux {A F G H : dpresheaf ct} : (hom A (homp (tensor F G) H)) → (hom A (homp F (homp G H))) :=
begin
  intro f,
  refine curry _,
  refine curry _,
  refine assoc₁.comp _,
  refine uncurry _,
  exact f
end

def lcurry {F G H : dpresheaf ct} : hom (homp (tensor F G) H) (homp F (homp G H)) :=
lcurry_aux (hom.id _)

def luncurry_aux {A F G H : dpresheaf ct} : (hom A (homp F (homp G H))) → (hom A (homp (tensor F G) H)) :=
begin
  intro f,
  refine curry _,
  refine assoc₂.comp _,
  refine uncurry _,
  refine uncurry _,
  exact f,
end

def luncurry {F G H : dpresheaf ct} : hom (homp F (homp G H)) (homp (tensor F G) H) :=
luncurry_aux (hom.id _)

def lcomp {F G H : dpresheaf ct} : hom (homp F G) (homp (homp G H) (homp F H)) :=
begin
  refine curry _,
  refine curry _,
  refine (tensor_map_left tensor_comm).comp _,
  refine assoc₁.comp _,
  refine (tensor_map_right (uncurry (hom.id _))).comp _,
  refine uncurry _,
  exact hom.id _
end

def homp_map_left {F G H : dpresheaf ct} (f : hom G H) : hom (homp H F) (homp G F) :=
begin
  intros A,
  dsimp [homp],
  intro g,
  refine hom.comp (tensor_map_right f) g,
end

def homp_map_right {F G H : dpresheaf ct} (f : hom G H) : hom (homp F G) (homp F H) :=
begin
  intros A,
  dsimp [homp],
  intro g,
  refine hom.comp g f,
end

variable (ct)

-- Should not be using dyoneda
def dyoneda (T : type cT) : dpresheaf ct := yoneda ct (presheaf.yoneda ct T)

def eval (T : type cT) : dpresheaf ct :=
⟨λ F, ulift (F.1 T), λ A B f x, ⟨f _ x.1⟩⟩

def eval_full (T₁ T₂ : type cT) (f : hom (eval ct T₁) (eval ct T₂)) :
  term2 ct (T₁.arrow T₂) :=
begin
  dsimp [hom, eval] at f,
  have := f (presheaf.yoneda ct T₁),
  dsimp [presheaf.yoneda] at this,
  refine (this _).1,
  exact ⟨term2.id⟩
end

variable {ct}

def dyoneda_full (T₁ T₂ : type cT) (f : hom (dyoneda ct T₁) (dyoneda ct T₂)) :
  term2 ct (T₁.arrow T₂) := presheaf.yoneda_full $ yoneda_full f

def tensor_hom (A B : type cT) : presheaf ct :=
⟨λ C, term2 ct (A.arrow (B.arrow C)),
  λ C D f g,begin
    refine (term2.comp.app g).app _,
    refine (term2.swap.app term2.comp).app f,
  end⟩

def eval_tensor₁ (T₁ T₂ T₃ : type cT) :
  hom (tensor (eval ct T₁) (eval ct T₂)) (eval ct T₃) →
  term2 ct (T₁.arrow (T₂.arrow T₃)) :=
begin
  dsimp [eval, yoneda, hom, tensor] at *,
  intros x,
  refine (x (tensor_hom T₁ T₂) _).1,
  dsimp [presheaf.hom],
  use [presheaf.yoneda ct T₁, presheaf.yoneda ct T₂, ⟨term2.id⟩, ⟨term2.id⟩],
  dsimp [presheaf.yoneda, presheaf.tensor, tensor_hom],
  intros A y,
  refine (term2.comp.app ((term2.comp.app y.2.2.1).app y.2.2.2.2)).app _,
  refine term2.comp.app y.2.2.2.1
end

def eval_tensor₂ (T₁ T₂ T₃ : type cT) :
  term2 ct (T₁.arrow (T₂.arrow T₃)) →
  hom (tensor (eval ct T₁) (eval ct T₂)) (eval ct T₃) :=
begin
  dsimp [eval, yoneda, hom, tensor] at *,
  intros f A y,
  dsimp [presheaf.tensor, presheaf.hom] at *,
  split,
  apply y.2.2.2.2,
  use [T₁, T₂, y.2.2.1.1, y.2.2.2.1.1, f]
end

def thing (A : presheaf ct) (B : type cT) : presheaf ct :=
⟨λ C, A.1 (B.arrow C),
  λ C D f g,begin
    refine A.2 _ g,
    refine (term2.swap.app term2.comp).app f
  end⟩

def eval_homp₁ (T₁ T₂ : type cT) :
  hom (homp (eval ct T₁) (eval ct T₂)) (eval ct (T₁.arrow T₂)) :=
begin
  intro A,
  dsimp [homp, eval, yoneda, tensor, hom],
  intro x,
  refine x (thing _ _) _,
  use A,
  use (presheaf.yoneda ct T₁),
  use ⟨presheaf.hom.id _⟩,
  use ⟨term2.id⟩,
  dsimp [presheaf.tensor, presheaf.yoneda, thing, presheaf.hom],
  rintros B ⟨c₁, c₂, Ac₁, g, f⟩,
  have h : term2 ct (c₁.arrow (T₁.arrow B)),
  { refine (term2.comp.app f).app _,
    refine term2.comp.app _,
    exact g },
  exact A.2 h Ac₁
end

def eval_homp₂ (T₁ T₂ : type cT) :
  hom (eval ct (T₁.arrow T₂)) (homp (eval ct T₁) (eval ct T₂)) :=
begin
  refine curry _,
  refine eval_tensor₂ _ _ _ _,
  exact term2.id
end

open category_theory

def contexti : context cT → dpresheaf ct
| []       := dpresheaf.id
| (T :: l) := tensor (contexti l) (eval ct T.2)

def lift {T : dpresheaf ct} : hom T (homp id T) :=
curry (hom.comp (rid₁ _) (hom.id _))

def drop {T : dpresheaf ct} : hom (homp id T) T :=
hom.comp (rid₂ _) (uncurry (hom.id _))

def contexti_append₁ : Π (Γ₁ Γ₂ : context cT), hom
  (contexti (Γ₂ ++ Γ₁))  ((contexti Γ₁).tensor (@contexti _ ct Γ₂))
| Γ₁      [] := rid₂ _
| Γ₁ (T::Γ₂) := hom.comp (tensor_map_left (contexti_append₁ _ _)) assoc₁

def contexti_append₂ : Π (Γ₁ Γ₂ : context cT), hom
  ((contexti Γ₁).tensor (contexti Γ₂)) (@contexti _ ct (Γ₂ ++ Γ₁))
| Γ₁      [] := rid₁ _
| Γ₁ (T::Γ₂) := hom.comp assoc₂ (tensor_map_left (contexti_append₂ _ _))

open dpresheaf

def termi : Π {Γ : context cT} {A : type cT}
  (t : term ct Γ A),
  hom (@contexti _ ct Γ) (eval ct A)
| _ A (term.const t) := λ F x, ⟨x.1 _ (term2.const t)⟩
| _ _ (term.var _ A) := lid₁ _
| _ T₂ (@term.app  _ _ Γ₁ Γ₂ T₁ _ f x) :=
hom.comp (contexti_append₁ _ _) (uncurry (hom.comp (termi f)
   ((eval_homp₂ _ _).comp $ homp_map_left (termi x))))
| Γ (type.arrow _ T₂) (term.lambda a T₁ t) :=
  hom.comp (curry (termi t)) (eval_homp₁ _ _)

end dpresheaf

end dpresheaf

open term

open category_theory
open_locale tensor_product

variable {ct : type cT → Type}

def term_to_term2 {A : type cT} (t : term ct [] A) : term2 ct A :=
(dpresheaf.termi t (presheaf.id) ⟨presheaf.hom.id _⟩).1

variables {R : Type} [comm_ring R]

def typei (cTi : cT → Module.{0 0} R) : type cT → Module R
| (type.const T)     := cTi T
| (type.arrow T₁ T₂) := Module.of R (typei T₁ →ₗ[R] typei T₂)

-- inductive term2 (ct : type cT → Type) : Π (A : type cT), Type
-- | const {T : type cT} (t : ct T) : term2 T
-- | app {T₁ T₂ : type cT} (f : term2 (T₁.arrow T₂)) (x : term2 T₁) : term2 T₂
-- | id {T₁ : type cT} : term2 (T₁.arrow T₁)
-- | comp {T₁ T₂ T₃ : type cT} : term2 ((T₁.arrow T₂).arrow ((T₂.arrow T₃).arrow (T₁.arrow T₃)))
-- | swap {T₁ T₂ T₃ : type cT} : term2 ((T₁.arrow (T₂.arrow T₃)).arrow (T₂.arrow (T₁.arrow T₃)))

def linear_map.swap {R M N P : Type*} [comm_semiring R] [add_comm_monoid M]
  [add_comm_monoid N] [add_comm_monoid P] [module R M] [module R N] [module R P]
  : (M →ₗ[R] N →ₗ[R] P) →ₗ[R] (N →ₗ[R] M →ₗ[R] P) :=
{ to_fun := λ f,
  { to_fun := λ n,
    { to_fun := λ m, f m n,
      map_add' := λ _ _, by rw [f.map_add]; refl,
      map_smul' := λ _ _, by rw [f.map_smul]; refl, },
    map_add' := λ _ _, by simp only [(f _).map_add]; refl,
    map_smul' := λ _ _, by simp only [(f _).map_smul]; refl },
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl }

local attribute [reducible] typei

def termi (cTi : cT → Module.{0 0} R) (const_term : Π {A}, ct A → typei cTi A) :
  Π {A : type cT}, term2 ct A → typei cTi A
| T (term2.const x) := const_term x
| _ (term2.app f x) := begin
  have := termi f,
  dsimp [typei] at this,
  exact this (termi x),
end
| _ (term2.id) := linear_map.id
| _ (term2.comp) := linear_map.swap (linear_map.llcomp _ _ _ _)
| _ (term2.swap) := linear_map.swap

def const_term : type unit → Type
| (type.arrow (type.const ()) (type.arrow (type.const ()) (type.const ()))) := unit
| _ := empty

variables (M : Module.{0 0} R) (op : M →ₗ[R] M →ₗ[R] M)

def cTi : unit → Module R := λ _, M

include op

def const_termi {T : type unit} (t : const_term T) : typei (@cTi R _ M) T :=
begin
  cases T with _ T₁ T₂; try { apply empty.elim t },
  cases T₁ with _ T₂ T₃; try { apply empty.elim t },
  cases T₁,
  cases T₂ with _ T₁ T₂; try { apply empty.elim t },
  cases T₁ with _ T₁ T₂; try { apply empty.elim t },
  cases T₁,
  cases T₂ with _ T₁ T₂; try { apply empty.elim t },
  exact op
end

omit op

def mult : const_term (type.arrow (type.const ()) (type.arrow (type.const ()) (type.const ()))) := ()

notation `T` := type.const ()

def exmpl₁ : @term unit const_term []
  ((type.const ()).arrow ((type.const ()).arrow ((type.const ()).arrow (type.const ())))) :=
lambda "a" T $
lambda "b" T $
lambda "c" T $
  app [("a", T), ("b", T)].reverse [("c", T)]
  (app [] [("a", T), ("b", T)].reverse (const mult)
    (app [("a", T)] [("b", T)]
      (app [] [("a", T)] (const mult) (var "a" (type.const ())))
        (var "b" (type.const ()))) : _)
    (var "c" (type.const ()))

example (p q r : M) :
  (((termi (@cTi R _ M) (@const_termi _ _ _ op) (term_to_term2 exmpl₁)).to_fun p).to_fun q).to_fun r =
  op (op p q) r :=
begin
  refl,
end

def exmpl₂ : @term unit const_term []
  ((type.const ()).arrow ((type.const ()).arrow ((type.const ()).arrow (type.const ())))) :=
lambda "a" T $
lambda "b" T $
lambda "c" T $
  (app [("a", T)] [("b", T), ("c", T)].reverse
  (app [] [("a", T)] (const mult) (var "a" (type.const ())) : _)
    (app [("b", T)] [("c", T)]
      (app [] [("b", T)] (const mult) (var "b" (type.const ())))
        (var "c" (type.const ())))  : _)

#reduce term_to_term2 exmpl₂

example (p q r : M) :
  (((termi (@cTi R _ M) (@const_termi _ _ _ op) (term_to_term2 exmpl₂)).to_fun p).to_fun q).to_fun r =
  op p (op q r) :=
begin
  refl,
end

notation ` bin_op ` :=  ((type.const ()).arrow ((type.const ()).arrow (type.const ())))

def exmpl₃ : @term unit const_term []
  (type.arrow bin_op ((type.const ()).arrow ((type.const ()).arrow ((type.const ()).arrow (type.const ()))))) :=
lambda "o" bin_op $
lambda "a" T $
lambda "b" T $
lambda "c" T $
  app [("o", bin_op), ("a", T), ("b", T)].reverse [("c", T)]
  (app [("o", bin_op)] [("a", T), ("b", T)].reverse (var "o" bin_op)
    (app [("a", T)] [("b", T)]
      (app [] [("a", T)] (const mult) (var "a" (type.const ())))
        (var "b" (type.const ()))) : _)
    (var "c" (type.const ()))

example (p q r : M) (op1 : M →ₗ[R] M →ₗ[R] M):
  ((((termi (@cTi R _ M) (@const_termi _ _ _ op) (term_to_term2 exmpl₃)).to_fun op1).to_fun p).to_fun q).to_fun r =
  op1 (op p q) r :=
begin
refl,

  -- dsimp [termi, const_termi, cTi, term_to_term2, dpresheaf.termi, exmpl₃, dpresheaf.eval, dpresheaf.eval_homp₁,
  --   dpresheaf.eval_homp₂, dpresheaf.contexti, dpresheaf.contexti_append₂, dpresheaf.contexti_append₁,
  --   dpresheaf.eval_tensor₁, dpresheaf.eval_tensor₂, presheaf.alpha, typei, context, list.reverse, list.append, list.reverse_core,

  --   dpresheaf.tensor, dpresheaf.tensor_map_left, dpresheaf.yoneda, dpresheaf.id, dpresheaf.thing,
  --   dpresheaf.tensor_map_right, dpresheaf.tensor_comm, dpresheaf.homp, dpresheaf.rid₁, dpresheaf.lid₁,
  --   dpresheaf.lid₂, dpresheaf.rid₂, dpresheaf.curry, dpresheaf.uncurry, dpresheaf.hom, dpresheaf.hom.id,
  --   dpresheaf.hom.comp, dpresheaf.homp_map_left, dpresheaf.homp_map_right, dpresheaf.assoc₁, dpresheaf.assoc₂,

  --   presheaf.tensor, presheaf.tensor_map_left, presheaf.yoneda, presheaf.id, presheaf.thing,
  --   presheaf.tensor_map_right, presheaf.tensor_comm, presheaf.homp, presheaf.rid₁, presheaf.lid₁,
  --   presheaf.lid₂, presheaf.rid₂, presheaf.curry, presheaf.uncurry, presheaf.hom, presheaf.hom.id,
  --   presheaf.hom.comp, presheaf.assoc₁, presheaf.assoc₂,

  --   linear_map.swap, linear_map.comp, linear_map.llcomp, linear_map.lcomp, linear_map.id],
  -- simp,
end


/-
Copyright (c) 2021 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno

! This file was ported from Lean 3 source module category_theory.bicategory.basic
! leanprover-community/mathlib commit 3e32bc908f617039c74c06ea9a897e30c30803c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Isomorphism
import Mathbin.Tactic.Slice

/-!
# Bicategories

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

In this file we define typeclass for bicategories.

A bicategory `B` consists of
* objects `a : B`,
* 1-morphisms `f : a ⟶ b` between objects `a b : B`, and
* 2-morphisms `η : f ⟶ g` beween 1-morphisms `f g : a ⟶ b` between objects `a b : B`.

We use `u`, `v`, and `w` as the universe variables for objects, 1-morphisms, and 2-morphisms,
respectively.

A typeclass for bicategories extends `category_theory.category_struct` typeclass. This means that
we have
* a composition `f ≫ g : a ⟶ c` for each 1-morphisms `f : a ⟶ b` and `g : b ⟶ c`, and
* a identity `𝟙 a : a ⟶ a` for each object `a : B`.

For each object `a b : B`, the collection of 1-morphisms `a ⟶ b` has a category structure. The
2-morphisms in the bicategory are implemented as the morphisms in this family of categories.

The composition of 1-morphisms is in fact a object part of a functor
`(a ⟶ b) ⥤ (b ⟶ c) ⥤ (a ⟶ c)`. The definition of bicategories in this file does not
require this functor directly. Instead, it requires the whiskering functions. For a 1-morphism
`f : a ⟶ b` and a 2-morphism `η : g ⟶ h` between 1-morphisms `g h : b ⟶ c`, there is a
2-morphism `whisker_left f η : f ≫ g ⟶ f ≫ h`. Similarly, for a 2-morphism `η : f ⟶ g`
between 1-morphisms `f g : a ⟶ b` and a 1-morphism `f : b ⟶ c`, there is a 2-morphism
`whisker_right η h : f ≫ h ⟶ g ≫ h`. These satisfy the exchange law
`whisker_left f θ ≫ whisker_right η i = whisker_right η h ≫ whisker_left g θ`,
which is required as an axiom in the definition here.
-/

namespace CategoryTheory

universe w v u

open Category Iso

#print CategoryTheory.Bicategory /-
/- ./././Mathport/Syntax/Translate/Command.lean:401:24: unsupported: (notation) in structure -/
/- ./././Mathport/Syntax/Translate/Command.lean:401:24: unsupported: (notation) in structure -/
/- ./././Mathport/Syntax/Translate/Command.lean:401:24: unsupported: (notation) in structure -/
/- ./././Mathport/Syntax/Translate/Command.lean:401:24: unsupported: (notation) in structure -/
/- ./././Mathport/Syntax/Translate/Command.lean:401:24: unsupported: (notation) in structure -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«exprλ_» -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«exprλ_» -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprρ_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprρ_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprα_ -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ◁ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«exprλ_» -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ▷ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `exprρ_ -/
-- intended to be used with explicit universe parameters
/-- In a bicategory, we can compose the 1-morphisms `f : a ⟶ b` and `g : b ⟶ c` to obtain
a 1-morphism `f ≫ g : a ⟶ c`. This composition does not need to be strictly associative,
but there is a specified associator, `α_ f g h : (f ≫ g) ≫ h ≅ f ≫ (g ≫ h)`.
There is an identity 1-morphism `𝟙 a : a ⟶ a`, with specified left and right unitor
isomorphisms `λ_ f : 𝟙 a ≫ f ≅ f` and `ρ_ f : f ≫ 𝟙 a ≅ f`.
These associators and unitors satisfy the pentagon and triangle equations.

See https://ncatlab.org/nlab/show/bicategory.
-/
@[nolint check_univs]
class Bicategory (B : Type u) extends CategoryStruct.{v} B where
  -- category structure on the collection of 1-morphisms:
  homCategory : ∀ a b : B, Category.{w} (a ⟶ b) := by infer_instance
  -- left whiskering:
  whiskerLeft {a b c : B} (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h) : f ≫ g ⟶ f ≫ h
  -- right whiskering:
  whiskerRight {a b c : B} {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c) : f ≫ h ⟶ g ≫ h
  -- associator:
  associator {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) : (f ≫ g) ≫ h ≅ f ≫ g ≫ h
  -- left unitor:
  leftUnitor {a b : B} (f : a ⟶ b) : 𝟙 a ≫ f ≅ f
  -- right unitor:
  rightUnitor {a b : B} (f : a ⟶ b) : f ≫ 𝟙 b ≅ f
  -- axioms for left whiskering:
  whiskerLeft_id : ∀ {a b c} (f : a ⟶ b) (g : b ⟶ c), «expr ◁ » f (𝟙 g) = 𝟙 (f ≫ g) := by obviously
  whiskerLeft_comp :
    ∀ {a b c} (f : a ⟶ b) {g h i : b ⟶ c} (η : g ⟶ h) (θ : h ⟶ i),
      «expr ◁ » f (η ≫ θ) = «expr ◁ » f η ≫ «expr ◁ » f θ := by
    obviously
  id_whiskerLeft :
    ∀ {a b} {f g : a ⟶ b} (η : f ⟶ g),
      «expr ◁ » (𝟙 a) η = ((«exprλ_») f).Hom ≫ η ≫ ((«exprλ_») g).inv := by
    obviously
  comp_whiskerLeft :
    ∀ {a b c d} (f : a ⟶ b) (g : b ⟶ c) {h h' : c ⟶ d} (η : h ⟶ h'),
      «expr ◁ » (f ≫ g) η =
        ((exprα_) f g h).Hom ≫ «expr ◁ » f («expr ◁ » g η) ≫ ((exprα_) f g h').inv := by
    obviously
  -- axioms for right whiskering:
  id_whiskerRight : ∀ {a b c} (f : a ⟶ b) (g : b ⟶ c), «expr ▷ » (𝟙 f) g = 𝟙 (f ≫ g) := by obviously
  comp_whiskerRight :
    ∀ {a b c} {f g h : a ⟶ b} (η : f ⟶ g) (θ : g ⟶ h) (i : b ⟶ c),
      «expr ▷ » (η ≫ θ) i = «expr ▷ » η i ≫ «expr ▷ » θ i := by
    obviously
  whiskerRight_id :
    ∀ {a b} {f g : a ⟶ b} (η : f ⟶ g),
      «expr ▷ » η (𝟙 b) = ((exprρ_) f).Hom ≫ η ≫ ((exprρ_) g).inv := by
    obviously
  whiskerRight_comp :
    ∀ {a b c d} {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c) (h : c ⟶ d),
      «expr ▷ » η (g ≫ h) =
        ((exprα_) f g h).inv ≫ «expr ▷ » («expr ▷ » η g) h ≫ ((exprα_) f' g h).Hom := by
    obviously
  -- associativity of whiskerings:
  whisker_assoc :
    ∀ {a b c d} (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g') (h : c ⟶ d),
      «expr ▷ » («expr ◁ » f η) h =
        ((exprα_) f g h).Hom ≫ «expr ◁ » f («expr ▷ » η h) ≫ ((exprα_) f g' h).inv := by
    obviously
  -- exchange law of left and right whiskerings:
  whisker_exchange :
    ∀ {a b c} {f g : a ⟶ b} {h i : b ⟶ c} (η : f ⟶ g) (θ : h ⟶ i),
      «expr ◁ » f θ ≫ «expr ▷ » η i = «expr ▷ » η h ≫ «expr ◁ » g θ := by
    obviously
  -- pentagon identity:
  pentagon :
    ∀ {a b c d e} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e),
      «expr ▷ » ((exprα_) f g h).Hom i ≫
          ((exprα_) f (g ≫ h) i).Hom ≫ «expr ◁ » f ((exprα_) g h i).Hom =
        ((exprα_) (f ≫ g) h i).Hom ≫ ((exprα_) f g (h ≫ i)).Hom := by
    obviously
  -- triangle identity:
  triangle :
    ∀ {a b c} (f : a ⟶ b) (g : b ⟶ c),
      ((exprα_) f (𝟙 b) g).Hom ≫ «expr ◁ » f ((«exprλ_») g).Hom = «expr ▷ » ((exprρ_) f).Hom g := by
    obviously
#align category_theory.bicategory CategoryTheory.Bicategory
-/

-- mathport name: bicategory.whisker_left
-- The precedence of the whiskerings is higher than that of the composition `≫`.
scoped[Bicategory] infixr:81 " ◁ " => Bicategory.whiskerLeft

-- mathport name: bicategory.whisker_right
scoped[Bicategory] infixl:81 " ▷ " => Bicategory.whiskerRight

-- mathport name: bicategory.associator
scoped[Bicategory] notation "α_" => Bicategory.associator

-- mathport name: bicategory.left_unitor
scoped[Bicategory] notation "λ_" => Bicategory.leftUnitor

-- mathport name: bicategory.right_unitor
scoped[Bicategory] notation "ρ_" => Bicategory.rightUnitor

namespace Bicategory

/-!
### Simp-normal form for 2-morphisms

Rewriting involving associators and unitors could be very complicated. We try to ease this
complexity by putting carefully chosen simp lemmas that rewrite any 2-morphisms into simp-normal
form defined below. Rewriting into simp-normal form is also useful when applying (forthcoming)
`coherence` tactic.

The simp-normal form of 2-morphisms is defined to be an expression that has the minimal number of
parentheses. More precisely,
1. it is a composition of 2-morphisms like `η₁ ≫ η₂ ≫ η₃ ≫ η₄ ≫ η₅` such that each `ηᵢ` is
  either a structural 2-morphisms (2-morphisms made up only of identities, associators, unitors)
  or non-structural 2-morphisms, and
2. each non-structural 2-morphism in the composition is of the form `f₁ ◁ f₂ ◁ f₃ ◁ η ▷ f₄ ▷ f₅`,
  where each `fᵢ` is a 1-morphism that is not the identity or a composite and `η` is a
  non-structural 2-morphisms that is also not the identity or a composite.

Note that `f₁ ◁ f₂ ◁ f₃ ◁ η ▷ f₄ ▷ f₅` is actually `f₁ ◁ (f₂ ◁ (f₃ ◁ ((η ▷ f₄) ▷ f₅)))`.
-/

restate_axiom whisker_left_id'

restate_axiom whisker_left_comp'

restate_axiom id_whisker_left'

restate_axiom comp_whisker_left'

restate_axiom id_whisker_right'

restate_axiom comp_whisker_right'

restate_axiom whisker_right_id'

restate_axiom whisker_right_comp'

restate_axiom whisker_assoc'

restate_axiom whisker_exchange'

restate_axiom pentagon'

restate_axiom triangle'

attribute [simp] pentagon triangle

attribute [reassoc.1]
  whisker_left_comp id_whisker_left comp_whisker_left comp_whisker_right whisker_right_id whisker_right_comp whisker_assoc whisker_exchange pentagon triangle

/-
The following simp attributes are put in order to rewrite any 2-morphisms into normal forms. There
are associators and unitors in the RHS in the several simp lemmas here (e.g. `id_whisker_left`),
which at first glance look more complicated than the LHS, but they will be eventually reduced by the
pentagon or the triangle identities, and more generally, (forthcoming) `coherence` tactic.
-/
attribute [simp]
  whisker_left_id whisker_left_comp id_whisker_left comp_whisker_left id_whisker_right comp_whisker_right whisker_right_id whisker_right_comp whisker_assoc

attribute [instance] hom_category

variable {B : Type u} [Bicategory.{w, v} B] {a b c d e : B}

#print CategoryTheory.Bicategory.hom_inv_whiskerLeft /-
@[simp, reassoc.1]
theorem hom_inv_whiskerLeft (f : a ⟶ b) {g h : b ⟶ c} (η : g ≅ h) :
    f ◁ η.Hom ≫ f ◁ η.inv = 𝟙 (f ≫ g) := by rw [← whisker_left_comp, hom_inv_id, whisker_left_id]
#align category_theory.bicategory.hom_inv_whisker_left CategoryTheory.Bicategory.hom_inv_whiskerLeft
-/

#print CategoryTheory.Bicategory.hom_inv_whiskerRight /-
@[simp, reassoc.1]
theorem hom_inv_whiskerRight {f g : a ⟶ b} (η : f ≅ g) (h : b ⟶ c) :
    η.Hom ▷ h ≫ η.inv ▷ h = 𝟙 (f ≫ h) := by rw [← comp_whisker_right, hom_inv_id, id_whisker_right]
#align category_theory.bicategory.hom_inv_whisker_right CategoryTheory.Bicategory.hom_inv_whiskerRight
-/

#print CategoryTheory.Bicategory.inv_hom_whiskerLeft /-
@[simp, reassoc.1]
theorem inv_hom_whiskerLeft (f : a ⟶ b) {g h : b ⟶ c} (η : g ≅ h) :
    f ◁ η.inv ≫ f ◁ η.Hom = 𝟙 (f ≫ h) := by rw [← whisker_left_comp, inv_hom_id, whisker_left_id]
#align category_theory.bicategory.inv_hom_whisker_left CategoryTheory.Bicategory.inv_hom_whiskerLeft
-/

#print CategoryTheory.Bicategory.inv_hom_whiskerRight /-
@[simp, reassoc.1]
theorem inv_hom_whiskerRight {f g : a ⟶ b} (η : f ≅ g) (h : b ⟶ c) :
    η.inv ▷ h ≫ η.Hom ▷ h = 𝟙 (g ≫ h) := by rw [← comp_whisker_right, inv_hom_id, id_whisker_right]
#align category_theory.bicategory.inv_hom_whisker_right CategoryTheory.Bicategory.inv_hom_whiskerRight
-/

#print CategoryTheory.Bicategory.whiskerLeftIso /-
/-- The left whiskering of a 2-isomorphism is a 2-isomorphism. -/
@[simps]
def whiskerLeftIso (f : a ⟶ b) {g h : b ⟶ c} (η : g ≅ h) : f ≫ g ≅ f ≫ h
    where
  Hom := f ◁ η.Hom
  inv := f ◁ η.inv
#align category_theory.bicategory.whisker_left_iso CategoryTheory.Bicategory.whiskerLeftIso
-/

#print CategoryTheory.Bicategory.whiskerLeft_isIso /-
instance whiskerLeft_isIso (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h) [IsIso η] : IsIso (f ◁ η) :=
  IsIso.of_iso (whiskerLeftIso f (asIso η))
#align category_theory.bicategory.whisker_left_is_iso CategoryTheory.Bicategory.whiskerLeft_isIso
-/

#print CategoryTheory.Bicategory.inv_whiskerLeft /-
@[simp]
theorem inv_whiskerLeft (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h) [IsIso η] : inv (f ◁ η) = f ◁ inv η :=
  by
  ext
  simp only [← whisker_left_comp, whisker_left_id, is_iso.hom_inv_id]
#align category_theory.bicategory.inv_whisker_left CategoryTheory.Bicategory.inv_whiskerLeft
-/

#print CategoryTheory.Bicategory.whiskerRightIso /-
/-- The right whiskering of a 2-isomorphism is a 2-isomorphism. -/
@[simps]
def whiskerRightIso {f g : a ⟶ b} (η : f ≅ g) (h : b ⟶ c) : f ≫ h ≅ g ≫ h
    where
  Hom := η.Hom ▷ h
  inv := η.inv ▷ h
#align category_theory.bicategory.whisker_right_iso CategoryTheory.Bicategory.whiskerRightIso
-/

#print CategoryTheory.Bicategory.whiskerRight_isIso /-
instance whiskerRight_isIso {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c) [IsIso η] : IsIso (η ▷ h) :=
  IsIso.of_iso (whiskerRightIso (asIso η) h)
#align category_theory.bicategory.whisker_right_is_iso CategoryTheory.Bicategory.whiskerRight_isIso
-/

#print CategoryTheory.Bicategory.inv_whiskerRight /-
@[simp]
theorem inv_whiskerRight {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c) [IsIso η] :
    inv (η ▷ h) = inv η ▷ h := by
  ext
  simp only [← comp_whisker_right, id_whisker_right, is_iso.hom_inv_id]
#align category_theory.bicategory.inv_whisker_right CategoryTheory.Bicategory.inv_whiskerRight
-/

#print CategoryTheory.Bicategory.pentagon_inv /-
@[simp, reassoc.1]
theorem pentagon_inv (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    f ◁ (α_ g h i).inv ≫ (α_ f (g ≫ h) i).inv ≫ (α_ f g h).inv ▷ i =
      (α_ f g (h ≫ i)).inv ≫ (α_ (f ≫ g) h i).inv :=
  eq_of_inv_eq_inv (by simp)
#align category_theory.bicategory.pentagon_inv CategoryTheory.Bicategory.pentagon_inv
-/

#print CategoryTheory.Bicategory.pentagon_inv_inv_hom_hom_inv /-
@[simp, reassoc.1]
theorem pentagon_inv_inv_hom_hom_inv (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    (α_ f (g ≫ h) i).inv ≫ (α_ f g h).inv ▷ i ≫ (α_ (f ≫ g) h i).Hom =
      f ◁ (α_ g h i).Hom ≫ (α_ f g (h ≫ i)).inv :=
  by
  rw [← cancel_epi (f ◁ (α_ g h i).inv), ← cancel_mono (α_ (f ≫ g) h i).inv]
  simp
#align category_theory.bicategory.pentagon_inv_inv_hom_hom_inv CategoryTheory.Bicategory.pentagon_inv_inv_hom_hom_inv
-/

#print CategoryTheory.Bicategory.pentagon_inv_hom_hom_hom_inv /-
@[simp, reassoc.1]
theorem pentagon_inv_hom_hom_hom_inv (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    (α_ (f ≫ g) h i).inv ≫ (α_ f g h).Hom ▷ i ≫ (α_ f (g ≫ h) i).Hom =
      (α_ f g (h ≫ i)).Hom ≫ f ◁ (α_ g h i).inv :=
  eq_of_inv_eq_inv (by simp)
#align category_theory.bicategory.pentagon_inv_hom_hom_hom_inv CategoryTheory.Bicategory.pentagon_inv_hom_hom_hom_inv
-/

#print CategoryTheory.Bicategory.pentagon_hom_inv_inv_inv_inv /-
@[simp, reassoc.1]
theorem pentagon_hom_inv_inv_inv_inv (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    f ◁ (α_ g h i).Hom ≫ (α_ f g (h ≫ i)).inv ≫ (α_ (f ≫ g) h i).inv =
      (α_ f (g ≫ h) i).inv ≫ (α_ f g h).inv ▷ i :=
  by simp [← cancel_epi (f ◁ (α_ g h i).inv)]
#align category_theory.bicategory.pentagon_hom_inv_inv_inv_inv CategoryTheory.Bicategory.pentagon_hom_inv_inv_inv_inv
-/

#print CategoryTheory.Bicategory.pentagon_hom_hom_inv_hom_hom /-
@[simp, reassoc.1]
theorem pentagon_hom_hom_inv_hom_hom (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    (α_ (f ≫ g) h i).Hom ≫ (α_ f g (h ≫ i)).Hom ≫ f ◁ (α_ g h i).inv =
      (α_ f g h).Hom ▷ i ≫ (α_ f (g ≫ h) i).Hom :=
  eq_of_inv_eq_inv (by simp)
#align category_theory.bicategory.pentagon_hom_hom_inv_hom_hom CategoryTheory.Bicategory.pentagon_hom_hom_inv_hom_hom
-/

#print CategoryTheory.Bicategory.pentagon_hom_inv_inv_inv_hom /-
@[simp, reassoc.1]
theorem pentagon_hom_inv_inv_inv_hom (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    (α_ f g (h ≫ i)).Hom ≫ f ◁ (α_ g h i).inv ≫ (α_ f (g ≫ h) i).inv =
      (α_ (f ≫ g) h i).inv ≫ (α_ f g h).Hom ▷ i :=
  by
  rw [← cancel_epi (α_ f g (h ≫ i)).inv, ← cancel_mono ((α_ f g h).inv ▷ i)]
  simp
#align category_theory.bicategory.pentagon_hom_inv_inv_inv_hom CategoryTheory.Bicategory.pentagon_hom_inv_inv_inv_hom
-/

#print CategoryTheory.Bicategory.pentagon_hom_hom_inv_inv_hom /-
@[simp, reassoc.1]
theorem pentagon_hom_hom_inv_inv_hom (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    (α_ f (g ≫ h) i).Hom ≫ f ◁ (α_ g h i).Hom ≫ (α_ f g (h ≫ i)).inv =
      (α_ f g h).inv ▷ i ≫ (α_ (f ≫ g) h i).Hom :=
  eq_of_inv_eq_inv (by simp)
#align category_theory.bicategory.pentagon_hom_hom_inv_inv_hom CategoryTheory.Bicategory.pentagon_hom_hom_inv_inv_hom
-/

#print CategoryTheory.Bicategory.pentagon_inv_hom_hom_hom_hom /-
@[simp, reassoc.1]
theorem pentagon_inv_hom_hom_hom_hom (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    (α_ f g h).inv ▷ i ≫ (α_ (f ≫ g) h i).Hom ≫ (α_ f g (h ≫ i)).Hom =
      (α_ f (g ≫ h) i).Hom ≫ f ◁ (α_ g h i).Hom :=
  by simp [← cancel_epi ((α_ f g h).Hom ▷ i)]
#align category_theory.bicategory.pentagon_inv_hom_hom_hom_hom CategoryTheory.Bicategory.pentagon_inv_hom_hom_hom_hom
-/

#print CategoryTheory.Bicategory.pentagon_inv_inv_hom_inv_inv /-
@[simp, reassoc.1]
theorem pentagon_inv_inv_hom_inv_inv (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e) :
    (α_ f g (h ≫ i)).inv ≫ (α_ (f ≫ g) h i).inv ≫ (α_ f g h).Hom ▷ i =
      f ◁ (α_ g h i).inv ≫ (α_ f (g ≫ h) i).inv :=
  eq_of_inv_eq_inv (by simp)
#align category_theory.bicategory.pentagon_inv_inv_hom_inv_inv CategoryTheory.Bicategory.pentagon_inv_inv_hom_inv_inv
-/

#print CategoryTheory.Bicategory.triangle_assoc_comp_left /-
theorem triangle_assoc_comp_left (f : a ⟶ b) (g : b ⟶ c) :
    (α_ f (𝟙 b) g).Hom ≫ f ◁ (λ_ g).Hom = (ρ_ f).Hom ▷ g :=
  triangle f g
#align category_theory.bicategory.triangle_assoc_comp_left CategoryTheory.Bicategory.triangle_assoc_comp_left
-/

#print CategoryTheory.Bicategory.triangle_assoc_comp_right /-
@[simp, reassoc.1]
theorem triangle_assoc_comp_right (f : a ⟶ b) (g : b ⟶ c) :
    (α_ f (𝟙 b) g).inv ≫ (ρ_ f).Hom ▷ g = f ◁ (λ_ g).Hom := by rw [← triangle, inv_hom_id_assoc]
#align category_theory.bicategory.triangle_assoc_comp_right CategoryTheory.Bicategory.triangle_assoc_comp_right
-/

#print CategoryTheory.Bicategory.triangle_assoc_comp_right_inv /-
@[simp, reassoc.1]
theorem triangle_assoc_comp_right_inv (f : a ⟶ b) (g : b ⟶ c) :
    (ρ_ f).inv ▷ g ≫ (α_ f (𝟙 b) g).Hom = f ◁ (λ_ g).inv := by simp [← cancel_mono (f ◁ (λ_ g).Hom)]
#align category_theory.bicategory.triangle_assoc_comp_right_inv CategoryTheory.Bicategory.triangle_assoc_comp_right_inv
-/

#print CategoryTheory.Bicategory.triangle_assoc_comp_left_inv /-
@[simp, reassoc.1]
theorem triangle_assoc_comp_left_inv (f : a ⟶ b) (g : b ⟶ c) :
    f ◁ (λ_ g).inv ≫ (α_ f (𝟙 b) g).inv = (ρ_ f).inv ▷ g := by simp [← cancel_mono ((ρ_ f).Hom ▷ g)]
#align category_theory.bicategory.triangle_assoc_comp_left_inv CategoryTheory.Bicategory.triangle_assoc_comp_left_inv
-/

#print CategoryTheory.Bicategory.associator_naturality_left /-
@[reassoc.1]
theorem associator_naturality_left {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c) (h : c ⟶ d) :
    η ▷ g ▷ h ≫ (α_ f' g h).Hom = (α_ f g h).Hom ≫ η ▷ (g ≫ h) := by simp
#align category_theory.bicategory.associator_naturality_left CategoryTheory.Bicategory.associator_naturality_left
-/

#print CategoryTheory.Bicategory.associator_inv_naturality_left /-
@[reassoc.1]
theorem associator_inv_naturality_left {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c) (h : c ⟶ d) :
    η ▷ (g ≫ h) ≫ (α_ f' g h).inv = (α_ f g h).inv ≫ η ▷ g ▷ h := by simp
#align category_theory.bicategory.associator_inv_naturality_left CategoryTheory.Bicategory.associator_inv_naturality_left
-/

#print CategoryTheory.Bicategory.whiskerRight_comp_symm /-
@[reassoc.1]
theorem whiskerRight_comp_symm {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c) (h : c ⟶ d) :
    η ▷ g ▷ h = (α_ f g h).Hom ≫ η ▷ (g ≫ h) ≫ (α_ f' g h).inv := by simp
#align category_theory.bicategory.whisker_right_comp_symm CategoryTheory.Bicategory.whiskerRight_comp_symm
-/

#print CategoryTheory.Bicategory.associator_naturality_middle /-
@[reassoc.1]
theorem associator_naturality_middle (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g') (h : c ⟶ d) :
    (f ◁ η) ▷ h ≫ (α_ f g' h).Hom = (α_ f g h).Hom ≫ f ◁ η ▷ h := by simp
#align category_theory.bicategory.associator_naturality_middle CategoryTheory.Bicategory.associator_naturality_middle
-/

#print CategoryTheory.Bicategory.associator_inv_naturality_middle /-
@[reassoc.1]
theorem associator_inv_naturality_middle (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g') (h : c ⟶ d) :
    f ◁ η ▷ h ≫ (α_ f g' h).inv = (α_ f g h).inv ≫ (f ◁ η) ▷ h := by simp
#align category_theory.bicategory.associator_inv_naturality_middle CategoryTheory.Bicategory.associator_inv_naturality_middle
-/

#print CategoryTheory.Bicategory.whisker_assoc_symm /-
@[reassoc.1]
theorem whisker_assoc_symm (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g') (h : c ⟶ d) :
    f ◁ η ▷ h = (α_ f g h).inv ≫ (f ◁ η) ▷ h ≫ (α_ f g' h).Hom := by simp
#align category_theory.bicategory.whisker_assoc_symm CategoryTheory.Bicategory.whisker_assoc_symm
-/

#print CategoryTheory.Bicategory.associator_naturality_right /-
@[reassoc.1]
theorem associator_naturality_right (f : a ⟶ b) (g : b ⟶ c) {h h' : c ⟶ d} (η : h ⟶ h') :
    (f ≫ g) ◁ η ≫ (α_ f g h').Hom = (α_ f g h).Hom ≫ f ◁ g ◁ η := by simp
#align category_theory.bicategory.associator_naturality_right CategoryTheory.Bicategory.associator_naturality_right
-/

#print CategoryTheory.Bicategory.associator_inv_naturality_right /-
@[reassoc.1]
theorem associator_inv_naturality_right (f : a ⟶ b) (g : b ⟶ c) {h h' : c ⟶ d} (η : h ⟶ h') :
    f ◁ g ◁ η ≫ (α_ f g h').inv = (α_ f g h).inv ≫ (f ≫ g) ◁ η := by simp
#align category_theory.bicategory.associator_inv_naturality_right CategoryTheory.Bicategory.associator_inv_naturality_right
-/

#print CategoryTheory.Bicategory.comp_whiskerLeft_symm /-
@[reassoc.1]
theorem comp_whiskerLeft_symm (f : a ⟶ b) (g : b ⟶ c) {h h' : c ⟶ d} (η : h ⟶ h') :
    f ◁ g ◁ η = (α_ f g h).inv ≫ (f ≫ g) ◁ η ≫ (α_ f g h').Hom := by simp
#align category_theory.bicategory.comp_whisker_left_symm CategoryTheory.Bicategory.comp_whiskerLeft_symm
-/

#print CategoryTheory.Bicategory.leftUnitor_naturality /-
@[reassoc.1]
theorem leftUnitor_naturality {f g : a ⟶ b} (η : f ⟶ g) : 𝟙 a ◁ η ≫ (λ_ g).Hom = (λ_ f).Hom ≫ η :=
  by simp
#align category_theory.bicategory.left_unitor_naturality CategoryTheory.Bicategory.leftUnitor_naturality
-/

#print CategoryTheory.Bicategory.leftUnitor_inv_naturality /-
@[reassoc.1]
theorem leftUnitor_inv_naturality {f g : a ⟶ b} (η : f ⟶ g) :
    η ≫ (λ_ g).inv = (λ_ f).inv ≫ 𝟙 a ◁ η := by simp
#align category_theory.bicategory.left_unitor_inv_naturality CategoryTheory.Bicategory.leftUnitor_inv_naturality
-/

#print CategoryTheory.Bicategory.id_whiskerLeft_symm /-
theorem id_whiskerLeft_symm {f g : a ⟶ b} (η : f ⟶ g) : η = (λ_ f).inv ≫ 𝟙 a ◁ η ≫ (λ_ g).Hom := by
  simp
#align category_theory.bicategory.id_whisker_left_symm CategoryTheory.Bicategory.id_whiskerLeft_symm
-/

#print CategoryTheory.Bicategory.rightUnitor_naturality /-
@[reassoc.1]
theorem rightUnitor_naturality {f g : a ⟶ b} (η : f ⟶ g) : η ▷ 𝟙 b ≫ (ρ_ g).Hom = (ρ_ f).Hom ≫ η :=
  by simp
#align category_theory.bicategory.right_unitor_naturality CategoryTheory.Bicategory.rightUnitor_naturality
-/

#print CategoryTheory.Bicategory.rightUnitor_inv_naturality /-
@[reassoc.1]
theorem rightUnitor_inv_naturality {f g : a ⟶ b} (η : f ⟶ g) :
    η ≫ (ρ_ g).inv = (ρ_ f).inv ≫ η ▷ 𝟙 b := by simp
#align category_theory.bicategory.right_unitor_inv_naturality CategoryTheory.Bicategory.rightUnitor_inv_naturality
-/

#print CategoryTheory.Bicategory.whiskerRight_id_symm /-
theorem whiskerRight_id_symm {f g : a ⟶ b} (η : f ⟶ g) : η = (ρ_ f).inv ≫ η ▷ 𝟙 b ≫ (ρ_ g).Hom := by
  simp
#align category_theory.bicategory.whisker_right_id_symm CategoryTheory.Bicategory.whiskerRight_id_symm
-/

#print CategoryTheory.Bicategory.whiskerLeft_iff /-
theorem whiskerLeft_iff {f g : a ⟶ b} (η θ : f ⟶ g) : 𝟙 a ◁ η = 𝟙 a ◁ θ ↔ η = θ := by simp
#align category_theory.bicategory.whisker_left_iff CategoryTheory.Bicategory.whiskerLeft_iff
-/

#print CategoryTheory.Bicategory.whiskerRight_iff /-
theorem whiskerRight_iff {f g : a ⟶ b} (η θ : f ⟶ g) : η ▷ 𝟙 b = θ ▷ 𝟙 b ↔ η = θ := by simp
#align category_theory.bicategory.whisker_right_iff CategoryTheory.Bicategory.whiskerRight_iff
-/

#print CategoryTheory.Bicategory.leftUnitor_whiskerRight /-
/-- We state it as a simp lemma, which is regarded as an involved version of
`id_whisker_right f g : 𝟙 f ▷ g = 𝟙 (f ≫ g)`.
-/
@[reassoc.1, simp]
theorem leftUnitor_whiskerRight (f : a ⟶ b) (g : b ⟶ c) :
    (λ_ f).Hom ▷ g = (α_ (𝟙 a) f g).Hom ≫ (λ_ (f ≫ g)).Hom := by
  rw [← whisker_left_iff, whisker_left_comp, ← cancel_epi (α_ _ _ _).Hom, ←
      cancel_epi ((α_ _ _ _).Hom ▷ _), pentagon_assoc, triangle, ← associator_naturality_middle, ←
      comp_whisker_right_assoc, triangle, associator_naturality_left] <;>
    infer_instance
#align category_theory.bicategory.left_unitor_whisker_right CategoryTheory.Bicategory.leftUnitor_whiskerRight
-/

#print CategoryTheory.Bicategory.leftUnitor_inv_whiskerRight /-
@[reassoc.1, simp]
theorem leftUnitor_inv_whiskerRight (f : a ⟶ b) (g : b ⟶ c) :
    (λ_ f).inv ▷ g = (λ_ (f ≫ g)).inv ≫ (α_ (𝟙 a) f g).inv :=
  eq_of_inv_eq_inv (by simp)
#align category_theory.bicategory.left_unitor_inv_whisker_right CategoryTheory.Bicategory.leftUnitor_inv_whiskerRight
-/

#print CategoryTheory.Bicategory.whiskerLeft_rightUnitor /-
@[reassoc.1, simp]
theorem whiskerLeft_rightUnitor (f : a ⟶ b) (g : b ⟶ c) :
    f ◁ (ρ_ g).Hom = (α_ f g (𝟙 c)).inv ≫ (ρ_ (f ≫ g)).Hom := by
  rw [← whisker_right_iff, comp_whisker_right, ← cancel_epi (α_ _ _ _).inv, ←
      cancel_epi (f ◁ (α_ _ _ _).inv), pentagon_inv_assoc, triangle_assoc_comp_right, ←
      associator_inv_naturality_middle, ← whisker_left_comp_assoc, triangle_assoc_comp_right,
      associator_inv_naturality_right] <;>
    infer_instance
#align category_theory.bicategory.whisker_left_right_unitor CategoryTheory.Bicategory.whiskerLeft_rightUnitor
-/

#print CategoryTheory.Bicategory.whiskerLeft_rightUnitor_inv /-
@[reassoc.1, simp]
theorem whiskerLeft_rightUnitor_inv (f : a ⟶ b) (g : b ⟶ c) :
    f ◁ (ρ_ g).inv = (ρ_ (f ≫ g)).inv ≫ (α_ f g (𝟙 c)).Hom :=
  eq_of_inv_eq_inv (by simp)
#align category_theory.bicategory.whisker_left_right_unitor_inv CategoryTheory.Bicategory.whiskerLeft_rightUnitor_inv
-/

#print CategoryTheory.Bicategory.leftUnitor_comp /-
/-
It is not so obvious whether `left_unitor_whisker_right` or `left_unitor_comp` should be a simp
lemma. Our choice is the former. One reason is that the latter yields the following loop:
[id_whisker_left]   : 𝟙 a ◁ (ρ_ f).hom ==> (λ_ (f ≫ 𝟙 b)).hom ≫ (ρ_ f).hom ≫ (λ_ f).inv
[left_unitor_comp]  : (λ_ (f ≫ 𝟙 b)).hom ==> (α_ (𝟙 a) f (𝟙 b)).inv ≫ (λ_ f).hom ▷ 𝟙 b
[whisker_right_id]  : (λ_ f).hom ▷ 𝟙 b ==> (ρ_ (𝟙 a ≫ f)).hom ≫ (λ_ f).hom ≫ (ρ_ f).inv
[right_unitor_comp] : (ρ_ (𝟙 a ≫ f)).hom ==> (α_ (𝟙 a) f (𝟙 b)).hom ≫ 𝟙 a ◁ (ρ_ f).hom
-/
@[reassoc.1]
theorem leftUnitor_comp (f : a ⟶ b) (g : b ⟶ c) :
    (λ_ (f ≫ g)).Hom = (α_ (𝟙 a) f g).inv ≫ (λ_ f).Hom ▷ g := by simp
#align category_theory.bicategory.left_unitor_comp CategoryTheory.Bicategory.leftUnitor_comp
-/

#print CategoryTheory.Bicategory.leftUnitor_comp_inv /-
@[reassoc.1]
theorem leftUnitor_comp_inv (f : a ⟶ b) (g : b ⟶ c) :
    (λ_ (f ≫ g)).inv = (λ_ f).inv ▷ g ≫ (α_ (𝟙 a) f g).Hom := by simp
#align category_theory.bicategory.left_unitor_comp_inv CategoryTheory.Bicategory.leftUnitor_comp_inv
-/

#print CategoryTheory.Bicategory.rightUnitor_comp /-
@[reassoc.1]
theorem rightUnitor_comp (f : a ⟶ b) (g : b ⟶ c) :
    (ρ_ (f ≫ g)).Hom = (α_ f g (𝟙 c)).Hom ≫ f ◁ (ρ_ g).Hom := by simp
#align category_theory.bicategory.right_unitor_comp CategoryTheory.Bicategory.rightUnitor_comp
-/

#print CategoryTheory.Bicategory.rightUnitor_comp_inv /-
@[reassoc.1]
theorem rightUnitor_comp_inv (f : a ⟶ b) (g : b ⟶ c) :
    (ρ_ (f ≫ g)).inv = f ◁ (ρ_ g).inv ≫ (α_ f g (𝟙 c)).inv := by simp
#align category_theory.bicategory.right_unitor_comp_inv CategoryTheory.Bicategory.rightUnitor_comp_inv
-/

#print CategoryTheory.Bicategory.unitors_equal /-
@[simp]
theorem unitors_equal : (λ_ (𝟙 a)).Hom = (ρ_ (𝟙 a)).Hom := by
  rw [← whisker_left_iff, ← cancel_epi (α_ _ _ _).Hom, ← cancel_mono (ρ_ _).Hom, triangle, ←
      right_unitor_comp, right_unitor_naturality] <;>
    infer_instance
#align category_theory.bicategory.unitors_equal CategoryTheory.Bicategory.unitors_equal
-/

#print CategoryTheory.Bicategory.unitors_inv_equal /-
@[simp]
theorem unitors_inv_equal : (λ_ (𝟙 a)).inv = (ρ_ (𝟙 a)).inv := by simp [iso.inv_eq_inv]
#align category_theory.bicategory.unitors_inv_equal CategoryTheory.Bicategory.unitors_inv_equal
-/

end Bicategory

end CategoryTheory


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.natural_isomorphism
import category_theory.equivalence
import category_theory.eq_to_hom

/-!
# Quotient category

Constructs the quotient of a category by an arbitrary family of relations on its hom-sets,
by introducing a type synonym for the objects, and identifying homs as necessary.

This is analogous to 'the quotient of a group by the normal closure of a subset', rather
than 'the quotient of a group by a normal subgroup'. When taking the quotient by a congruence
relation, `functor_map_eq_iff` says that no unnecessary identifications have been made.
-/

/-- A `hom_rel` on `C` consists of a relation on every hom-set. -/
@[derive inhabited]
def hom_rel (C) [quiver C] := Π ⦃X Y : C⦄, (X ⟶ Y) → (X ⟶ Y) → Prop

namespace category_theory

variables {C : Type*} [category C] (r : hom_rel C)

include r

/-- A `hom_rel` is a congruence when it's an equivalence on every hom-set, and it can be composed
from left and right. -/
class congruence : Prop :=
(is_equiv : ∀ {X Y}, is_equiv _ (@r X Y))
(comp_left : ∀ {X Y Z} (f : X ⟶ Y) {g g' : Y ⟶ Z}, r g g' → r (f ≫ g) (f ≫ g'))
(comp_right : ∀ {X Y Z} {f f' : X ⟶ Y} (g : Y ⟶ Z), r f f' → r (f ≫ g) (f' ≫ g))

attribute [instance] congruence.is_equiv

/-- A type synonym for `C`, thought of as the objects of the quotient category. -/
@[ext]
structure quotient := (as : C)

instance [inhabited C] : inhabited (quotient r) := ⟨ { as := default } ⟩

namespace quotient

/-- Generates the closure of a family of relations w.r.t. composition from left and right. -/
inductive comp_closure ⦃s t : C⦄ : (s ⟶ t) → (s ⟶ t) → Prop
| intro {a b} (f : s ⟶ a) (m₁ m₂ : a ⟶ b) (g : b ⟶ t) (h : r m₁ m₂) :
  comp_closure (f ≫ m₁ ≫ g) (f ≫ m₂ ≫ g)

lemma comp_closure.of {a b} (m₁ m₂ : a ⟶ b) (h : r m₁ m₂) : comp_closure r m₁ m₂ :=
by simpa using comp_closure.intro (𝟙 _) m₁ m₂ (𝟙 _) h

lemma comp_left {a b c : C} (f : a ⟶ b) : Π (g₁ g₂ : b ⟶ c) (h : comp_closure r g₁ g₂),
  comp_closure r (f ≫ g₁) (f ≫ g₂)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro (f ≫ x) m₁ m₂ y h

lemma comp_right {a b c : C} (g : b ⟶ c) : Π (f₁ f₂ : a ⟶ b) (h : comp_closure r f₁ f₂),
  comp_closure r (f₁ ≫ g) (f₂ ≫ g)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro x m₁ m₂ (y ≫ g) h

/-- Hom-sets of the quotient category. -/
def hom (s t : quotient r) := quot $ @comp_closure C _ r s.as t.as

instance (a : quotient r) : inhabited (hom r a a) := ⟨quot.mk _ (𝟙 a.as)⟩

/-- Composition in the quotient category. -/
def comp ⦃a b c : quotient r⦄ : hom r a b → hom r b c → hom r a c :=
λ hf hg, quot.lift_on hf ( λ f, quot.lift_on hg (λ g, quot.mk _ (f ≫ g))
  (λ g₁ g₂ h, quot.sound $ comp_left r f g₁ g₂ h) )
  (λ f₁ f₂ h, quot.induction_on hg $ λ g, quot.sound $ comp_right r g f₁ f₂ h)

@[simp]
lemma comp_mk {a b c : quotient r} (f : a.as ⟶ b.as) (g : b.as ⟶ c.as) :
  comp r (quot.mk _ f) (quot.mk _ g) = quot.mk _ (f ≫ g) := rfl

instance category : category (quotient r) :=
{ hom := hom r,
  id := λ a, quot.mk _ (𝟙 a.as),
  comp := comp r }

/-- The functor from a category to its quotient. -/
@[simps]
def functor : C ⥤ quotient r :=
{ obj := λ a, { as := a },
  map := λ _ _ f, quot.mk _ f }

noncomputable instance : full (functor r) :=
{ preimage := λ X Y f, quot.out f, }

instance : ess_surj (functor r) :=
{ mem_ess_image := λ Y, ⟨Y.as, ⟨eq_to_iso (by { ext, refl, })⟩⟩ }

protected lemma induction {P : Π {a b : quotient r}, (a ⟶ b) → Prop}
  (h : ∀ {x y : C} (f : x ⟶ y), P ((functor r).map f)) :
  ∀ {a b : quotient r} (f : a ⟶ b), P f :=
by { rintros ⟨x⟩ ⟨y⟩ ⟨f⟩, exact h f, }

protected lemma sound {a b : C} {f₁ f₂ : a ⟶ b} (h : r f₁ f₂) :
  (functor r).map f₁ = (functor r).map f₂ :=
by simpa using quot.sound (comp_closure.intro (𝟙 a) f₁ f₂ (𝟙 b) h)

variables {D : Type*} [category D]
  (F : C ⥤ D)
  (H : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂)
include H

/-- The induced functor on the quotient category. -/
@[simps]
def lift : quotient r ⥤ D :=
{ obj := λ a, F.obj a.as,
  map := λ a b hf, quot.lift_on hf (λ f, F.map f)
    (by { rintros _ _ ⟨_, _, _, _, _, _, h⟩, simp [H _ _ _ _ h], }),
  map_id' := λ a, F.map_id a.as,
  map_comp' := by { rintros a b c ⟨f⟩ ⟨g⟩, exact F.map_comp f g, } }

/-- The original functor factors through the induced functor. -/
def lift.is_lift : (functor r) ⋙ lift r F H ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma lift.is_lift_hom (X : C) : (lift.is_lift r F H).hom.app X = 𝟙 (F.obj X) :=
rfl
@[simp]
lemma lift.is_lift_inv (X : C) : (lift.is_lift r F H).inv.app X = 𝟙 (F.obj X) :=
rfl

lemma lift_map_functor_map {X Y : C} (f : X ⟶ Y) :
  (lift r F H).map ((functor r).map f) = F.map f :=
by { rw ←(nat_iso.naturality_1 (lift.is_lift r F H)), dsimp, simp, }

end quotient

end category_theory


open Function

def Set (α : Type u) := α → Prop

example {α : Type u}
  (f : α → Type (max u v))
  (U : α) (hU : f U = Set (Sigma f)) :
    let g : Set (Sigma f) → Sigma f := fun (s : Set (Sigma f)) => ⟨U, cast hU.symm s⟩
    ∀ ⦃s t : Set (Sigma f)⦄,
        g s = g t → cast hU (g s).snd = cast hU (g t).snd :=
by
  intros g s t h
  congr -- reduces to `(g s).snd = (g t).snd`, not `g s = g t`