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

/-!
# Bicategories

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 category_theory

universes w v u

open category iso

/--
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] -- intended to be used with explicit universe parameters
class bicategory (B : Type u) extends category_struct.{v} B :=
-- category structure on the collection of 1-morphisms:
(hom_category : ∀ (a b : B), category.{w} (a ⟶ b) . tactic.apply_instance)
-- left whiskering:
(whisker_left {a b c : B} (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h) : f ≫ g ⟶ f ≫ h)
(infixr ` ◁ `:70 := whisker_left)
-- functoriality of left whiskering:
(whisker_left_id' : ∀ {a b c} (f : a ⟶ b) (g : b ⟶ c), f ◁ 𝟙 g = 𝟙 (f ≫ g) . obviously)
(whisker_left_comp' :
  ∀ {a b c} (f : a ⟶ b) {g h i : b ⟶ c} (η : g ⟶ h) (θ : h ⟶ i),
  f ◁ (η ≫ θ) = (f ◁ η) ≫ (f ◁ θ) . obviously)
-- right whiskering:
(whisker_right {a b c : B} {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c) : f ≫ h ⟶ g ≫ h)
(infixr ` ▷ `:70 := whisker_right)
-- functoriality of right whiskering:
(whisker_right_id' : ∀ {a b c} (f : a ⟶ b) (g : b ⟶ c), 𝟙 f ▷ g = 𝟙 (f ≫ g) . obviously)
(whisker_right_comp' :
  ∀ {a b c} {f g h : a ⟶ b} (η : f ⟶ g) (θ : g ⟶ h) (i : b ⟶ c),
  (η ≫ θ) ▷ i = (η ▷ i) ≫ (θ ▷ i) . 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),
  (f ◁ θ) ≫ (η ▷ i) = (η ▷ h) ≫ (g ◁ θ) . obviously)
-- associator:
(associator {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) :
  (f ≫ g) ≫ h ≅ f ≫ (g ≫ h))
(notation `α_` := associator)
(associator_naturality_left' :
  ∀ {a b c d} {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c) (h : c ⟶ d),
  ((η ▷ g) ▷ h) ≫ (α_ f' g h).hom = (α_ f g h).hom ≫ (η ▷ (g ≫ h)) . obviously)
(associator_naturality_middle' :
  ∀ {a b c d} (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g') (h : c ⟶ d),
  ((f ◁ η) ▷ h) ≫ (α_ f g' h).hom = (α_ f g h).hom ≫ (f ◁ (η ▷ h)) . obviously)
(associator_naturality_right' :
  ∀ {a b c d} (f : a ⟶ b) (g : b ⟶ c) {h h' : c ⟶ d} (η : h ⟶ h'),
  ((f ≫ g) ◁ η) ≫ (α_ f g h').hom = (α_ f g h).hom ≫ (f ◁ (g ◁ η)) . obviously)
--left unitor:
(left_unitor {a b : B} (f : a ⟶ b) : 𝟙 a ≫ f ≅ f)
(notation `λ_` := left_unitor)
(left_unitor_naturality' : ∀ {a b} {f f' : a ⟶ b} (η : f ⟶ f'),
  (𝟙 a ◁ η) ≫ (λ_ f').hom = (λ_ f ).hom ≫ η . obviously)
-- right unitor:
(right_unitor {a b : B} (f : a ⟶ b) : f ≫ 𝟙 b ≅ f)
(notation `ρ_` := right_unitor)
(right_unitor_naturality' : ∀ {a b} {f f' : a ⟶ b} (η : f ⟶ f'),
  (η ▷ 𝟙 b) ≫ (ρ_ f').hom = (ρ_ f ).hom ≫ η . obviously)
-- pentagon identity:
(pentagon' : ∀ {a b c d e} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) (i : d ⟶ e),
  ((α_ f g h).hom ▷ i) ≫ (α_ f (g ≫ h) i).hom ≫ (f ◁ (α_ g h i).hom) =
    (α_ (f ≫ g) h i).hom ≫ (α_ f g (h ≫ i)).hom . obviously)
-- triangle identity:
(triangle' : ∀ {a b c} (f : a ⟶ b) (g : b ⟶ c),
  (α_ f (𝟙 b) g).hom ≫ (f ◁ (λ_ g).hom) = (ρ_ f).hom ▷ g . obviously)

restate_axiom bicategory.whisker_left_id'
restate_axiom bicategory.whisker_left_comp'
restate_axiom bicategory.whisker_right_id'
restate_axiom bicategory.whisker_right_comp'
restate_axiom bicategory.whisker_exchange'
restate_axiom bicategory.associator_naturality_left'
restate_axiom bicategory.associator_naturality_middle'
restate_axiom bicategory.associator_naturality_right'
restate_axiom bicategory.left_unitor_naturality'
restate_axiom bicategory.right_unitor_naturality'
restate_axiom bicategory.pentagon'
restate_axiom bicategory.triangle'
attribute [simp]
  bicategory.whisker_left_id bicategory.whisker_right_id
  bicategory.whisker_exchange bicategory.triangle
attribute [reassoc]
  bicategory.whisker_left_comp bicategory.whisker_right_comp
  bicategory.whisker_exchange bicategory.associator_naturality_left
  bicategory.associator_naturality_middle bicategory.associator_naturality_right
  bicategory.left_unitor_naturality bicategory.right_unitor_naturality
  bicategory.pentagon bicategory.triangle
attribute [simp] bicategory.whisker_left_comp bicategory.whisker_right_comp
attribute [instance] bicategory.hom_category

localized "infixr ` ◁ `:70 := bicategory.whisker_left" in bicategory
localized "infixr ` ▷ `:70 := bicategory.whisker_right" in bicategory
localized "notation `α_` := bicategory.associator" in bicategory
localized "notation `λ_` := bicategory.left_unitor" in bicategory
localized "notation `ρ_` := bicategory.right_unitor" in bicategory

namespace bicategory

section

variables {B : Type u} [bicategory.{w v} B] {a b c d e : B}

@[simp, reassoc]
lemma hom_inv_whisker_left (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]

@[simp, reassoc]
lemma hom_inv_whisker_right {f g : a ⟶ b} (η : f ≅ g) (h : b ⟶ c) :
  (η.hom ▷ h) ≫ (η.inv ▷ h) = 𝟙 (f ≫ h) :=
by rw [←whisker_right_comp, hom_inv_id, whisker_right_id]

@[simp, reassoc]
lemma inv_hom_whisker_left (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]

@[simp, reassoc]
lemma inv_hom_whisker_right {f g : a ⟶ b} (η : f ≅ g) (h : b ⟶ c) :
  (η.inv ▷ h) ≫ (η.hom ▷ h) = 𝟙 (g ≫ h) :=
by rw [←whisker_right_comp, inv_hom_id, whisker_right_id]

/-- The left whiskering of a 2-isomorphism is a 2-isomorphism. -/
@[simps]
def whisker_left_iso (f : a ⟶ b) {g h : b ⟶ c} (η : g ≅ h) :
  f ≫ g ≅ f ≫ h :=
{ hom := f ◁ η.hom,
  inv := f ◁ η.inv,
  hom_inv_id' := by simp only [hom_inv_whisker_left],
  inv_hom_id' := by simp only [inv_hom_whisker_left] }

instance whisker_left_is_iso (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h) [is_iso η] :
  is_iso (f ◁ η) :=
is_iso.of_iso (whisker_left_iso f (as_iso η))

@[simp]
lemma inv_whisker_left (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h) [is_iso η] :
  inv (f ◁ η) = f ◁ (inv η) :=
by { ext, simp only [←whisker_left_comp, whisker_left_id, is_iso.hom_inv_id] }

/-- The right whiskering of a 2-isomorphism is a 2-isomorphism. -/
@[simps]
def whisker_right_iso {f g : a ⟶ b} (η : f ≅ g) (h : b ⟶ c) :
  f ≫ h ≅ g ≫ h :=
{ hom := η.hom ▷ h,
  inv := η.inv ▷ h,
  hom_inv_id' := by simp only [hom_inv_whisker_right],
  inv_hom_id' := by simp only [inv_hom_whisker_right] }

instance whisker_right_is_iso {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c) [is_iso η] :
  is_iso (η ▷ h) :=
is_iso.of_iso (whisker_right_iso (as_iso η) h)

@[simp]
lemma inv_whisker_right {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c) [is_iso η] :
  inv (η ▷ h) = (inv η) ▷ h :=
by { ext, simp only [←whisker_right_comp, whisker_right_id, is_iso.hom_inv_id] }

@[reassoc]
lemma left_unitor_inv_naturality {f f' : a ⟶ b} (η : f ⟶ f') :
  η ≫ (λ_ f').inv = (λ_ f).inv ≫ (𝟙 a ◁ η) :=
begin
  apply (cancel_mono (λ_ f').hom).1,
  simp only [assoc, comp_id, inv_hom_id, left_unitor_naturality, inv_hom_id_assoc]
end

@[reassoc]
lemma right_unitor_inv_naturality {f f' : a ⟶ b} (η : f ⟶ f') :
  η ≫ (ρ_ f').inv = (ρ_ f ).inv ≫ (η ▷ 𝟙 b) :=
begin
  apply (cancel_mono (ρ_ f').hom).1,
  simp only [assoc, comp_id, inv_hom_id, right_unitor_naturality, inv_hom_id_assoc]
end

@[simp]
lemma right_unitor_conjugation {f g : a ⟶ b} (η : f ⟶ g) :
  (ρ_ f).inv ≫ (η ▷ 𝟙 b) ≫ (ρ_ g).hom = η :=
by rw [right_unitor_naturality, inv_hom_id_assoc]

@[simp]
lemma left_unitor_conjugation {f g : a ⟶ b} (η : f ⟶ g) :
  (λ_ f).inv ≫ (𝟙 a ◁ η) ≫ (λ_ g).hom = η :=
by rw [left_unitor_naturality, inv_hom_id_assoc]

@[simp]
lemma whisker_left_iff {f g : a ⟶ b} (η θ : f ⟶ g) :
  (𝟙 a ◁ η = 𝟙 a ◁ θ) ↔ (η = θ) :=
by rw [←cancel_mono (λ_ g).hom, left_unitor_naturality, left_unitor_naturality,
    cancel_iso_hom_left]

@[simp]
lemma whisker_right_iff {f g : a ⟶ b} (η θ : f ⟶ g) :
  (η ▷ 𝟙 b = θ ▷ 𝟙 b) ↔ (η = θ) :=
by rw [←cancel_mono (ρ_ g).hom, right_unitor_naturality, right_unitor_naturality,
    cancel_iso_hom_left]

@[reassoc]
lemma left_unitor_comp' (f : a ⟶ b) (g : b ⟶ c) :
  (α_ (𝟙 a) f g).hom ≫ (λ_ (f ≫ g)).hom = (λ_ f).hom ▷ g :=
by rw [←whisker_left_iff, whisker_left_comp, ←cancel_epi (α_ (𝟙 a) (𝟙 a ≫ f) g).hom,
    ←cancel_epi ((α_ (𝟙 a) (𝟙 a) f).hom ▷ g), pentagon_assoc, triangle,
    ←associator_naturality_middle, ←whisker_right_comp_assoc, triangle,
    associator_naturality_left, cancel_iso_hom_left]

-- We state it as a `@[simp]` lemma. Generally, we think the component index of a natural
-- transformation "weighs more" in considering the complexity of an expression than
-- does a structural isomorphism (associator, etc).
@[reassoc, simp]
lemma left_unitor_comp (f : a ⟶ b) (g : b ⟶ c) :
  (λ_ (f ≫ g)).hom = (α_ (𝟙 a) f g).inv ≫ ((λ_ f).hom ▷ g) :=
by { rw [←left_unitor_comp', inv_hom_id_assoc] }

lemma left_unitor_comp_inv' (f : a ⟶ b) (g : b ⟶ c) :
  (λ_ (f ≫ g)).inv ≫ (α_ (𝟙 a) f g).inv = ((λ_ f).inv ▷ g) :=
eq_of_inv_eq_inv (by simp only [left_unitor_comp, inv_whisker_right,
  is_iso.iso.inv_inv, hom_inv_id_assoc, is_iso.inv_comp])

@[reassoc, simp]
lemma left_unitor_comp_inv (f : a ⟶ b) (g : b ⟶ c) :
  (λ_ (f ≫ g)).inv = ((λ_ f).inv ▷ g) ≫ (α_ (𝟙 a) f g).hom :=
by { rw [←left_unitor_comp_inv'], simp only [inv_hom_id, assoc, comp_id] }

@[reassoc, simp]
lemma right_unitor_comp (f : a ⟶ b) (g : b ⟶ c) :
  (ρ_ (f ≫ g)).hom = (α_ f g (𝟙 c)).hom ≫ (f ◁ (ρ_ g).hom) :=
by rw [←whisker_right_iff, whisker_right_comp, ←cancel_mono (α_ f g (𝟙 c)).hom,
    assoc, associator_naturality_middle, ←triangle_assoc, ←triangle,
    whisker_left_comp, pentagon_assoc, ←associator_naturality_right]

@[reassoc, simp]
lemma right_unitor_comp_inv (f : a ⟶ b) (g : b ⟶ c) :
  (ρ_ (f ≫ g)).inv = (f ◁ (ρ_ g).inv) ≫ (α_ f g (𝟙 c)).inv :=
eq_of_inv_eq_inv (by simp only [inv_whisker_left, right_unitor_comp,
  is_iso.iso.inv_inv, is_iso.inv_comp])

@[reassoc]
lemma whisker_left_right_unitor_inv (f : a ⟶ b) (g : b ⟶ c) :
  f ◁ (ρ_ g).inv = (ρ_ (f ≫ g)).inv ≫ (α_ f g (𝟙 c)).hom :=
by simp only [right_unitor_comp_inv, comp_id, inv_hom_id, assoc]

@[reassoc]
lemma whisker_left_right_unitor (f : a ⟶ b) (g : b ⟶ c) :
  f ◁ (ρ_ g).hom = (α_ f g (𝟙 c)).inv ≫ (ρ_ (f ≫ g)).hom :=
by simp only [right_unitor_comp, inv_hom_id_assoc]

@[reassoc]
lemma left_unitor_inv_whisker_right (f : a ⟶ b) (g : b ⟶ c) :
  (λ_ f).inv ▷ g = (λ_ (f ≫ g)).inv ≫ (α_ (𝟙 a) f g).inv :=
by simp only [left_unitor_comp_inv, assoc, comp_id, hom_inv_id]

@[reassoc]
lemma left_unitor_whisker_right (f : a ⟶ b) (g : b ⟶ c) :
  (λ_ f).hom ▷ g = (α_ (𝟙 a) f g).hom ≫ (λ_ (f ≫ g)).hom :=
by simp only [left_unitor_comp, hom_inv_id_assoc]

@[reassoc]
lemma 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 rw [comp_inv_eq, assoc, associator_naturality_left, inv_hom_id_assoc]

@[reassoc]
lemma associator_conjugation_left {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c) (h : c ⟶ d) :
  (α_ f g h).hom ≫ (η ▷ (g ≫ h)) ≫ (α_ f' g h).inv = (η ▷ g) ▷ h :=
by rw [associator_inv_naturality_left, hom_inv_id_assoc]

@[reassoc]
lemma associator_inv_conjugation_left {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c) (h : c ⟶ d) :
  (α_ f g h).inv ≫ ((η ▷ g) ▷ h) ≫ (α_ f' g h).hom = η ▷ (g ≫ h) :=
by rw [associator_naturality_left, inv_hom_id_assoc]

@[reassoc]
lemma 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 rw [comp_inv_eq, assoc, associator_naturality_middle, inv_hom_id_assoc]

@[reassoc]
lemma associator_conjugation_middle (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g') (h : c ⟶ d) :
  (α_ f g h).hom ≫ (f ◁ (η ▷ h)) ≫ (α_ f g' h).inv = (f ◁ η) ▷ h :=
by rw [associator_inv_naturality_middle, hom_inv_id_assoc]

@[reassoc]
lemma associator_inv_conjugation_middle (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g') (h : c ⟶ d) :
  (α_ f g h).inv ≫ ((f ◁ η) ▷ h) ≫ (α_ f g' h).hom = f ◁ (η ▷ h) :=
by rw [associator_naturality_middle, inv_hom_id_assoc]

@[reassoc]
lemma 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 rw [comp_inv_eq, assoc, associator_naturality_right, inv_hom_id_assoc]

@[reassoc]
lemma associator_conjugation_right (f : a ⟶ b) (g : b ⟶ c) {h h' : c ⟶ d} (η : h ⟶ h') :
  (α_ f g h).hom ≫ (f ◁ (g ◁ η)) ≫ (α_ f g h').inv = (f ≫ g) ◁ η :=
by rw [associator_inv_naturality_right, hom_inv_id_assoc]

@[reassoc]
lemma associator_inv_conjugation_right (f : a ⟶ b) (g : b ⟶ c) {h h' : c ⟶ d} (η : h ⟶ h') :
  (α_ f g h).inv ≫ ((f ≫ g) ◁ η) ≫ (α_ f g h').hom = f ◁ (g ◁ η) :=
by rw [associator_naturality_right, inv_hom_id_assoc]

@[reassoc]
lemma 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 only [pentagon, inv_whisker_left, inv_whisker_right,
  is_iso.iso.inv_inv, is_iso.inv_comp, assoc])

@[reassoc]
lemma 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 :=
begin
  rw ←((eq_comp_inv _).mp (pentagon_inv f g h i)),
  slice_rhs 1 2 { rw [←whisker_left_comp, hom_inv_id] },
  simp only [assoc, id_comp, whisker_left_id]
end

@[reassoc]
lemma 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 only [pentagon_inv_inv_hom_hom_inv, inv_whisker_left,
  is_iso.iso.inv_hom, inv_whisker_right, is_iso.iso.inv_inv, is_iso.inv_comp, assoc])

@[reassoc]
lemma 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) :=
begin
  rw ←((eq_comp_inv _).mp (pentagon_inv f g h i)),
  slice_lhs 1 2 { rw [←whisker_left_comp, hom_inv_id] },
  simp only [assoc, id_comp, whisker_left_id, comp_id, hom_inv_id]
end

@[reassoc]

@[reassoc]
lemma 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) :=
begin
  have pent := pentagon f g h i,
  rw ←inv_comp_eq at pent,
  rw ←pent,
  simp only [hom_inv_whisker_left_assoc, assoc, comp_id, hom_inv_id]
end

@[reassoc]
lemma 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 only [pentagon_hom_inv_inv_inv_hom, inv_whisker_left,
  is_iso.iso.inv_hom, inv_whisker_right, is_iso.iso.inv_inv, is_iso.inv_comp, assoc])

@[reassoc]
lemma 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 { rw ←pentagon f g h i, simp only [inv_hom_whisker_right_assoc] }

@[reassoc]
lemma 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 only [pentagon_inv_hom_hom_hom_hom, inv_whisker_left,
  is_iso.iso.inv_hom, inv_whisker_right, is_iso.iso.inv_inv, is_iso.inv_comp, assoc])

lemma triangle_assoc_comp_left (f : a ⟶ b) (g : b ⟶ c) :
  (α_ f (𝟙 b) g).hom ≫ (f ◁ (λ_ g).hom) = (ρ_ f).hom ▷ g :=
triangle f g

@[simp, reassoc]
lemma 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]

@[simp, reassoc]
lemma triangle_assoc_comp_right_inv (f : a ⟶ b) (g : b ⟶ c) :
  ((ρ_ f).inv ▷ g) ≫ (α_ f (𝟙 b) g).hom = f ◁ (λ_ g).inv :=
begin
  apply (cancel_mono (f ◁ (λ_ g).hom)).1,
  simp only [inv_hom_whisker_left, inv_hom_whisker_right, assoc, triangle]
end

@[simp, reassoc]
lemma triangle_assoc_comp_left_inv (f : a ⟶ b) (g : b ⟶ c) :
  (f ◁ (λ_ g).inv) ≫ (α_ f (𝟙 b) g).inv = (ρ_ f).inv ▷ g :=
begin
  apply (cancel_mono ((ρ_ f).hom ▷ g)).1,
  simp only [triangle_assoc_comp_right, inv_hom_whisker_left, inv_hom_whisker_right, assoc]
end

lemma unitors_equal : (λ_ (𝟙 a)).hom = (ρ_ (𝟙 a)).hom :=
by rw [←whisker_left_iff, ←cancel_epi (α_ (𝟙 a) (𝟙 _) (𝟙 _)).hom,
       ←cancel_mono (ρ_ (𝟙 a)).hom, triangle, ←right_unitor_comp, right_unitor_naturality]

lemma unitors_inv_equal : (λ_ (𝟙 a)).inv = (ρ_ (𝟙 a)).inv :=
by { ext, rw [←unitors_equal], simp only [hom_inv_id] }

end

end bicategory

end category_theory


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

import data.fun_like.embedding

/-!
# Typeclass for a type `F` with an injective map to `A ≃ B`

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

This typeclass is primarily for use by isomorphisms like `monoid_equiv` and `linear_equiv`.

## Basic usage of `equiv_like`

A typical type of morphisms should be declared as:
```
structure my_iso (A B : Type*) [my_class A] [my_class B]
  extends equiv A B :=
(map_op' : ∀ {x y : A}, to_fun (my_class.op x y) = my_class.op (to_fun x) (to_fun y))

namespace my_iso

variables (A B : Type*) [my_class A] [my_class B]

-- This instance is optional if you follow the "Isomorphism class" design below:
instance : equiv_like (my_iso A B) A (λ _, B) :=
{ coe := my_iso.to_equiv.to_fun,
  inv := my_iso.to_equiv.inv_fun,
  left_inv := my_iso.to_equiv.left_inv,
  right_inv := my_iso.to_equiv.right_inv,
  coe_injective' := λ f g h, by cases f; cases g; congr' }

/-- Helper instance for when there's too many metavariables to apply `equiv_like.coe` directly. -/
instance : has_coe_to_fun (my_iso A B) := to_fun.to_coe_fn

@[simp] lemma to_fun_eq_coe {f : my_iso A B} : f.to_fun = (f : A → B) := rfl

@[ext] theorem ext {f g : my_iso A B} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

/-- Copy of a `my_iso` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : my_iso A B) (f' : A → B) (f_inv : B → A) (h : f' = ⇑f) : my_iso A B :=
{ to_fun := f',
  inv_fun := f_inv,
  left_inv := h.symm ▸ f.left_inv,
  right_inv := h.symm ▸ f.right_inv,
  map_op' := h.symm ▸ f.map_op' }

end my_iso
```

This file will then provide a `has_coe_to_fun` instance and various
extensionality and simp lemmas.

## Isomorphism classes extending `equiv_like`

The `equiv_like` design provides further benefits if you put in a bit more work.
The first step is to extend `equiv_like` to create a class of those types satisfying
the axioms of your new type of isomorphisms.
Continuing the example above:

```
section
set_option old_structure_cmd true

/-- `my_iso_class F A B` states that `F` is a type of `my_class.op`-preserving morphisms.
You should extend this class when you extend `my_iso`. -/
class my_iso_class (F : Type*) (A B : out_param $ Type*) [my_class A] [my_class B]
  extends equiv_like F A (λ _, B), my_hom_class F A B.

end

-- You can replace `my_iso.equiv_like` with the below instance:
instance : my_iso_class (my_iso A B) A B :=
{ coe := my_iso.to_fun,
  inv := my_iso.inv_fun,
  left_inv := my_iso.left_inv,
  right_inv := my_iso.right_inv,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := my_iso.map_op' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

The second step is to add instances of your new `my_iso_class` for all types extending `my_iso`.
Typically, you can just declare a new class analogous to `my_iso_class`:

```
structure cooler_iso (A B : Type*) [cool_class A] [cool_class B]
  extends my_iso A B :=
(map_cool' : to_fun cool_class.cool = cool_class.cool)

section
set_option old_structure_cmd true

class cooler_iso_class (F : Type*) (A B : out_param $ Type*) [cool_class A] [cool_class B]
  extends my_iso_class F A B :=
(map_cool : ∀ (f : F), f cool_class.cool = cool_class.cool)

end

@[simp] lemma map_cool {F A B : Type*} [cool_class A] [cool_class B] [cooler_iso_class F A B]
  (f : F) : f cool_class.cool = cool_class.cool :=
my_iso_class.map_op

-- You can also replace `my_iso.equiv_like` with the below instance:
instance : cool_iso_class (cool_iso A B) A B :=
{ coe := cool_iso.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := cool_iso.map_op',
  map_cool := cool_iso.map_cool' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : my_iso A B) : sorry := sorry
lemma do_something {F : Type*} [my_iso_class F A B] (f : F) : sorry := sorry
```

This means anything set up for `my_iso`s will automatically work for `cool_iso_class`es,
and defining `cool_iso_class` only takes a constant amount of effort,
instead of linearly increasing the work per `my_iso`-related declaration.

-/

/-- The class `equiv_like E α β` expresses that terms of type `E` have an
injective coercion to bijections between `α` and `β`.

This typeclass is used in the definition of the homomorphism typeclasses,
such as `zero_equiv_class`, `mul_equiv_class`, `monoid_equiv_class`, ....
-/
class equiv_like (E : Sort*) (α β : out_param Sort*) :=
(coe : E → α → β)
(inv : E → β → α)
(left_inv  : ∀ e, function.left_inverse (inv e) (coe e))
(right_inv : ∀ e, function.right_inverse (inv e) (coe e))
-- The `inv` hypothesis makes this easier to prove with `congr'`
(coe_injective' : ∀ e g, coe e = coe g → inv e = inv g → e = g)

namespace equiv_like

variables {E F α β γ : Sort*} [iE : equiv_like E α β] [iF : equiv_like F β γ]
include iE

lemma inv_injective : function.injective (equiv_like.inv : E → (β → α)) :=
λ e g h, coe_injective' e g ((right_inv e).eq_right_inverse (h.symm ▸ left_inv g)) h

@[priority 100]
instance to_embedding_like : embedding_like E α β :=
{ coe := (coe : E → α → β),
  coe_injective' := λ e g h, coe_injective' e g h
    ((left_inv e).eq_right_inverse (h.symm ▸ right_inv g)),
  injective' := λ e, (left_inv e).injective }

protected lemma injective (e : E) : function.injective e := embedding_like.injective e
protected lemma surjective (e : E) : function.surjective e := (right_inv e).surjective
protected lemma bijective (e : E) : function.bijective (e : α → β) :=
⟨equiv_like.injective e, equiv_like.surjective e⟩

theorem apply_eq_iff_eq (f : E) {x y : α} : f x = f y ↔ x = y := embedding_like.apply_eq_iff_eq f

@[simp] lemma injective_comp (e : E) (f : β → γ) :
  function.injective (f ∘ e) ↔ function.injective f :=
function.injective.of_comp_iff' f (equiv_like.bijective e)

@[simp] lemma surjective_comp (e : E) (f : β → γ) :
  function.surjective (f ∘ e) ↔ function.surjective f :=
(equiv_like.surjective e).of_comp_iff f

@[simp] lemma bijective_comp (e : E) (f : β → γ) :
  function.bijective (f ∘ e) ↔ function.bijective f :=
(equiv_like.bijective e).of_comp_iff f

/-- This lemma is only supposed to be used in the generic context, when working with instances
of classes extending `equiv_like`.
For concrete isomorphism types such as `equiv`, you should use `equiv.symm_apply_apply`
or its equivalent.

TODO: define a generic form of `equiv.symm`. -/
@[simp]

/-- This lemma is only supposed to be used in the generic context, when working with instances
of classes extending `equiv_like`.
For concrete isomorphism types such as `equiv`, you should use `equiv.apply_symm_apply`
or its equivalent.

TODO: define a generic form of `equiv.symm`. -/
@[simp] lemma apply_inv_apply (e : E) (b : β) : e (equiv_like.inv e b) = b := right_inv _ _

omit iE
include iF

lemma comp_injective (f : α → β) (e : F) :
  function.injective (e ∘ f) ↔ function.injective f :=
embedding_like.comp_injective f e

@[simp] lemma comp_surjective (f : α → β) (e : F) :
  function.surjective (e ∘ f) ↔ function.surjective f :=
function.surjective.of_comp_iff' (equiv_like.bijective e) f

@[simp] lemma comp_bijective (f : α → β) (e : F) :
  function.bijective (e ∘ f) ↔ function.bijective f :=
(equiv_like.bijective e).of_comp_iff' f

/-- This is not an instance to avoid slowing down every single `subsingleton` typeclass search.-/
lemma subsingleton_dom [subsingleton β] : subsingleton F :=
⟨λ f g, fun_like.ext f g $ λ x, (right_inv f).injective $ subsingleton.elim _ _⟩

end equiv_like


/-
Copyright (c) 2019 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.sums.basic
import Mathlib.PostPort

universes u v

namespace Mathlib

/-#
The associator functor `((C ⊕ D) ⊕ E) ⥤ (C ⊕ (D ⊕ E))` and its inverse form an equivalence.
-/

namespace category_theory.sum

/--
The associator functor `(C ⊕ D) ⊕ E ⥤ C ⊕ (D ⊕ E)` for sums of categories.
-/
def associator (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] : (C ⊕ D) ⊕ E ⥤ C ⊕ D ⊕ E :=
  functor.mk (fun (X : (C ⊕ D) ⊕ E) => sorry) fun (X Y : (C ⊕ D) ⊕ E) (f : X ⟶ Y) => sorry

@[simp] theorem associator_obj_inl_inl (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] (X : C) : functor.obj (associator C D E) (sum.inl (sum.inl X)) = sum.inl X :=
  rfl

@[simp] theorem associator_obj_inl_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] (X : D) : functor.obj (associator C D E) (sum.inl (sum.inr X)) = sum.inr (sum.inl X) :=
  rfl

@[simp] theorem associator_obj_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] (X : E) : functor.obj (associator C D E) (sum.inr X) = sum.inr (sum.inr X) :=
  rfl

@[simp] theorem associator_map_inl_inl (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] {X : C} {Y : C} (f : sum.inl (sum.inl X) ⟶ sum.inl (sum.inl Y)) : functor.map (associator C D E) f = f :=
  rfl

@[simp] theorem associator_map_inl_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] {X : D} {Y : D} (f : sum.inl (sum.inr X) ⟶ sum.inl (sum.inr Y)) : functor.map (associator C D E) f = f :=
  rfl

@[simp] theorem associator_map_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] {X : E} {Y : E} (f : sum.inr X ⟶ sum.inr Y) : functor.map (associator C D E) f = f :=
  rfl

/--
The inverse associator functor `C ⊕ (D ⊕ E) ⥤ (C ⊕ D) ⊕ E` for sums of categories.
-/
def inverse_associator (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] : C ⊕ D ⊕ E ⥤ (C ⊕ D) ⊕ E :=
  functor.mk (fun (X : C ⊕ D ⊕ E) => sorry) fun (X Y : C ⊕ D ⊕ E) (f : X ⟶ Y) => sorry

@[simp] theorem inverse_associator_obj_inl (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] (X : C) : functor.obj (inverse_associator C D E) (sum.inl X) = sum.inl (sum.inl X) :=
  rfl

@[simp] theorem inverse_associator_obj_inr_inl (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] (X : D) : functor.obj (inverse_associator C D E) (sum.inr (sum.inl X)) = sum.inl (sum.inr X) :=
  rfl

@[simp] theorem inverse_associator_obj_inr_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] (X : E) : functor.obj (inverse_associator C D E) (sum.inr (sum.inr X)) = sum.inr X :=
  rfl

@[simp] theorem inverse_associator_map_inl (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] {X : C} {Y : C} (f : sum.inl X ⟶ sum.inl Y) : functor.map (inverse_associator C D E) f = f :=
  rfl

@[simp] theorem inverse_associator_map_inr_inl (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] {X : D} {Y : D} (f : sum.inr (sum.inl X) ⟶ sum.inr (sum.inl Y)) : functor.map (inverse_associator C D E) f = f :=
  rfl

@[simp] theorem inverse_associator_map_inr_inr (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] {X : E} {Y : E} (f : sum.inr (sum.inr X) ⟶ sum.inr (sum.inr Y)) : functor.map (inverse_associator C D E) f = f :=
  rfl

/--
The equivalence of categories expressing associativity of sums of categories.
-/
def associativity (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] : (C ⊕ D) ⊕ E ≌ C ⊕ D ⊕ E :=
  equivalence.mk (associator C D E) (inverse_associator C D E)
    (nat_iso.of_components (fun (X : (C ⊕ D) ⊕ E) => eq_to_iso sorry) sorry)
    (nat_iso.of_components (fun (X : C ⊕ D ⊕ E) => eq_to_iso sorry) sorry)

protected instance associator_is_equivalence (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] : is_equivalence (associator C D E) :=
  is_equivalence.of_equivalence (associativity C D E)

protected instance inverse_associator_is_equivalence (C : Type u) [category C] (D : Type u) [category D] (E : Type u) [category E] : is_equivalence (inverse_associator C D E) :=
  is_equivalence.of_equivalence_inverse (associativity C D E)


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro

Injective functions.
-/
import data.equiv.basic data.option.basic

universes u v w x

namespace function

structure embedding (α : Sort*) (β : Sort*) :=
(to_fun : α → β)
(inj    : injective to_fun)

infixr ` ↪ `:25 := embedding

instance {α : Sort u} {β : Sort v} : has_coe_to_fun (α ↪ β) := ⟨_, embedding.to_fun⟩

end function

protected def equiv.to_embedding {α : Sort u} {β : Sort v} (f : α ≃ β) : α ↪ β :=
⟨f, f.injective⟩

@[simp] theorem equiv.to_embedding_coe_fn {α : Sort u} {β : Sort v} (f : α ≃ β) :
  (f.to_embedding : α → β) = f := rfl

namespace function
namespace embedding

@[simp] theorem to_fun_eq_coe {α β} (f : α ↪ β) : to_fun f = f := rfl

@[simp] theorem coe_fn_mk {α β} (f : α → β) (i) :
  (@mk _ _ f i : α → β) = f := rfl

theorem inj' {α β} : ∀ (f : α ↪ β), injective f
| ⟨f, hf⟩ := hf

@[refl] protected def refl (α : Sort*) : α ↪ α :=
⟨id, injective_id⟩

@[trans] protected def trans {α β γ} (f : α ↪ β) (g : β ↪ γ) : α ↪ γ :=
⟨_, injective_comp g.inj' f.inj'⟩

@[simp] theorem refl_apply {α} (x : α) : embedding.refl α x = x := rfl

@[simp] theorem trans_apply {α β γ} (f : α ↪ β) (g : β ↪ γ) (a : α) :
  (f.trans g) a = g (f a) := rfl

protected def congr {α : Sort u} {β : Sort v} {γ : Sort w} {δ : Sort x}
  (e₁ : α ≃ β) (e₂ : γ ≃ δ) (f : α ↪ γ) : (β ↪ δ) :=
(equiv.to_embedding e₁.symm).trans (f.trans e₂.to_embedding)

protected noncomputable def of_surjective {α β} {f : β → α} (hf : surjective f) :
  α ↪ β :=
⟨surj_inv hf, injective_surj_inv _⟩

protected noncomputable def equiv_of_surjective {α β} (f : α ↪ β) (hf : surjective f) :
  α ≃ β :=
equiv.of_bijective ⟨f.inj, hf⟩

protected def of_not_nonempty {α β} (hα : ¬ nonempty α) : α ↪ β :=
⟨λa, (hα ⟨a⟩).elim, assume a, (hα ⟨a⟩).elim⟩

noncomputable def set_value {α β} (f : α ↪ β) (a : α) (b : β) : α ↪ β :=
by haveI := classical.dec; exact
if h : ∃ a', f a' = b then
  (equiv.swap a (classical.some h)).to_embedding.trans f
else
  ⟨λ a', if a' = a then b else f a',
   λ a₁ a₂ e, begin
    simp at e, split_ifs at e with h₁ h₂,
    { cc },
    { cases h ⟨_, e.symm⟩ },
    { cases h ⟨_, e⟩ },
    { exact f.2 e }
   end⟩

theorem set_value_eq {α β} (f : α ↪ β) (a : α) (b : β) : set_value f a b a = b :=
begin
  rw [set_value],
  cases classical.dec (∃ a', f a' = b);
    dsimp [dite], {simp},
  simp [equiv.swap_apply_left],
  apply classical.some_spec h
end

/-- Embedding into `option` -/
protected def some {α} : α ↪ option α :=
⟨some, option.injective_some α⟩

def subtype {α} (p : α → Prop) : subtype p ↪ α :=
⟨subtype.val, λ _ _, subtype.eq'⟩

/-- Restrict the codomain of an embedding. -/
def cod_restrict {α β} (p : set β) (f : α ↪ β) (H : ∀ a, f a ∈ p) : α ↪ p :=
⟨λ a, ⟨f a, H a⟩, λ a b h, f.inj (@congr_arg _ _ _ _ subtype.val h)⟩

@[simp] theorem cod_restrict_apply {α β} (p) (f : α ↪ β) (H a) :
  cod_restrict p f H a = ⟨f a, H a⟩ := rfl

def prod_congr {α β γ δ : Type*} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : α × γ ↪ β × δ :=
⟨assume ⟨a, b⟩, (e₁ a, e₂ b),
  assume ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h,
  have a₁ = a₂ ∧ b₁ = b₂, from (prod.mk.inj h).imp (assume h, e₁.inj h) (assume h, e₂.inj h),
  this.left ▸ this.right ▸ rfl⟩

section sum
open sum

def sum_congr {α β γ δ : Type*} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : α ⊕ γ ↪ β ⊕ δ :=
⟨assume s, match s with inl a := inl (e₁ a) | inr b := inr (e₂ b) end,
    assume s₁ s₂ h, match s₁, s₂, h with
    | inl a₁, inl a₂, h := congr_arg inl $ e₁.inj $ inl.inj h
    | inr b₁, inr b₂, h := congr_arg inr $ e₂.inj $ inr.inj h
    end⟩

@[simp] theorem sum_congr_apply_inl {α β γ δ}
  (e₁ : α ↪ β) (e₂ : γ ↪ δ) (a) : sum_congr e₁ e₂ (inl a) = inl (e₁ a) := rfl

@[simp] theorem sum_congr_apply_inr {α β γ δ}
  (e₁ : α ↪ β) (e₂ : γ ↪ δ) (b) : sum_congr e₁ e₂ (inr b) = inr (e₂ b) := rfl

end sum

section sigma
open sigma

def sigma_congr_right {α : Type*} {β γ : α → Type*} (e : ∀ a, β a ↪ γ a) : sigma β ↪ sigma γ :=
⟨λ ⟨a, b⟩, ⟨a, e a b⟩, λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h, begin
  injection h with h₁ h₂, subst a₂,
  congr,
  exact (e a₁).2 (eq_of_heq h₂)
end⟩

end sigma

def Pi_congr_right {α : Sort*} {β γ : α → Sort*} (e : ∀ a, β a ↪ γ a) : (Π a, β a) ↪ (Π a, γ a) :=
⟨λf a, e a (f a), λ f₁ f₂ h, funext $ λ a, (e a).inj (congr_fun h a)⟩

def arrow_congr_left {α : Sort u} {β : Sort v} {γ : Sort w}
  (e : α ↪ β) : (γ → α) ↪ (γ → β) :=
Pi_congr_right (λ _, e)

noncomputable def arrow_congr_right {α : Sort u} {β : Sort v} {γ : Sort w} [inhabited γ]
  (e : α ↪ β) : (α → γ) ↪ (β → γ) :=
by haveI := classical.prop_decidable; exact
let f' : (α → γ) → (β → γ) := λf b, if h : ∃c, e c = b then f (classical.some h) else default γ in
⟨f', assume f₁ f₂ h, funext $ assume c,
  have ∃c', e c' = e c, from ⟨c, rfl⟩,
  have eq' : f' f₁ (e c) = f' f₂ (e c), from congr_fun h _,
  have eq_b : classical.some this = c, from e.inj $ classical.some_spec this,
  by simp [f', this, if_pos, eq_b] at eq'; assumption⟩

end embedding
end function

namespace set

/-- The injection map is an embedding between subsets. -/
def embedding_of_subset {α} {s t : set α} (h : s ⊆ t) : s ↪ t :=
⟨λ x, ⟨x.1, h x.2⟩, λ ⟨x, hx⟩ ⟨y, hy⟩ h, by congr; injection h⟩

end set


import tactic.linarith
import ite_lemmas
import code
import succ_graphs

def code.time : code → ptree →. ℕ
| code.left := λ t, part.some t.sizeof
| code.right := λ t, part.some t.sizeof
| code.nil := λ t, part.some 1
| code.id := λ t, part.some t.sizeof
| (code.node a b) := λ t, (+1) <$> (a.time t) + (b.time t)
| (code.comp f g) := λ t, (+1) <$> (g.time t) + (g.eval t >>= f.time)
| (code.case f g) := λ t, (+1) <$> if t.left = ptree.nil then f.time t.right else g.time t.right
| (code.fix f) := λ t, (+t.sizeof) <$> (f.fix_iterator t).time f.time

lemma add_def (x y : part ℕ) : x + y = x >>= λ x', y >>= (λ y', pure (x' + y')) :=
by { simp only [(+), (<*>), part.bind_eq_bind, part.bind_map, part.map_eq_map], congr, ext x, simp, tauto, }

lemma time_dom_iff_eval_dom (c : code) (v : ptree) : (c.time v).dom ↔ (c.eval v).dom :=
begin
  induction c generalizing v,
  all_goals { simp [code.time, add_def, code.eval_fix], },
  case code.node : c₁ c₂ c₁ih c₂ih { simp [c₁ih, c₂ih], },
  case code.comp : c₁ c₂ c₁ih c₂ih { simp [c₁ih, c₂ih], tauto, },
  case code.case : c₁ c₂ c₁ih c₂ih { simp [c₁ih, c₂ih, apply_ite part.dom], },
  case code.fix : f ih
  { simp [execution.time],
    refine (execution.time_with_tr (f.fix_iterator v) f.time _).eval_dom_iff.symm,
    intros x x' _, rw ih, simp [part.dom_iff_mem], tauto, }
end

lemma time_dom_iff_eval_to_option_dom (c : code) (v : ptree) : (c.time v).dom ↔ (c.eval.map ptree.to_option v).dom :=
by simp [time_dom_iff_eval_dom, pfun.map]

lemma time_dom_eq_eval_dom (c : code) : c.time.dom = c.eval.dom :=
by { ext, apply time_dom_iff_eval_dom, }

def time_bound (c : code) (bound : ℕ → ℕ) : Prop :=
∀ (v : ptree), ∃ t ∈ c.time v, t ≤ bound v.sizeof

lemma time_bound_spec {c : code} {bound : ℕ → ℕ} (h : time_bound c bound) {t v} (hn : t ∈ c.time v) : t ≤ bound v.sizeof :=
by { specialize h v, rcases h with ⟨t, ht, H⟩, cases part.mem_unique hn ht, exact H, }

lemma time_bound_of_time_bound_le {c : code} {b₁ : ℕ → ℕ} (hb₁ : time_bound c b₁) {b₂ : ℕ → ℕ} (hb₂ : ∀ n, b₁ n ≤ b₂ n) :
  time_bound c b₂ := λ v, by { obtain ⟨t, ht, t_le⟩ := hb₁ v, use [t, ht], exact t_le.trans (hb₂ _), }

lemma eval_dom_of_time_bound {c : code} {bound : ℕ → ℕ} (h : time_bound c bound) : c.eval.dom = set.univ :=
begin
  ext v,
  suffices : (c.time v).dom, { simpa [pfun.dom, time_dom_iff_eval_dom], },
  rw part.dom_iff_mem, obtain ⟨t, ht, _⟩ := h v, exact ⟨t, ht⟩,
end

lemma dom_univ_iff {α β : Type*} (f : α →. β) : f.dom = set.univ ↔ ∀ x, (f x).dom :=
by simp [pfun.dom, set.eq_univ_iff_forall]

lemma eval_sizeof_le_time {c : code} {vin vout : ptree} {t : ℕ} (hv : vout ∈ c.eval vin) (ht : t ∈ c.time vin) : vout.sizeof ≤ t :=
begin
  induction c generalizing vin vout t,
  { simp only [code.eval, code.time, part.pure_eq_some, part.mem_some_iff] at hv ht, subst_vars, apply ptree.left_sizeof_le, },
  { simp only [code.eval, code.time, part.pure_eq_some, part.mem_some_iff] at hv ht, subst_vars, apply ptree.right_sizeof_le, },
  { simp [code.time] at hv ht ⊢, subst_vars, simp, },
  { simp [code.time] at hv ht ⊢, subst_vars, },
  case code.node : c₁ c₂ c₁ih c₂ih
  { simp [code.time, add_def] at hv ht,
    rcases ht with ⟨t₁, ht₁, t₂, ht₂, ht⟩,
    rcases hv with ⟨v₁, hv₁, v₂, hv₂, hv⟩,
    specialize c₁ih hv₁ ht₁, specialize c₂ih hv₂ ht₂, rw [hv, ht],
    simp, linarith only [c₁ih, c₂ih], },
  case code.comp : c₁ c₂ c₁ih c₂ih
  { simp [code.time, add_def] at hv ht,
    rcases ht with ⟨t₁, ht₁, t₂, ⟨v', hv', ht₂⟩, rfl⟩,
    rcases hv with ⟨v'', hv'', H⟩,
    cases part.mem_unique hv' hv'',
    suffices : vout.sizeof ≤ t₂, { linarith only [this], },
    exact c₁ih H ht₂, },
  case code.case : c₁ c₂ c₁ih c₂ih
  { simp [code.time] at hv ht,
    rcases ht with ⟨t', ht', rfl⟩,
    split_ifs at *, { linarith only [c₁ih hv ht'], }, { linarith only [c₂ih hv ht'], } },
  case code.fix : f ih
  { simp [code.time, code.eval_fix, execution.time] at hv ht,
    rcases ht with ⟨t, ⟨x, hx⟩, rfl⟩,
    obtain rfl : vout = x,
    { simpa using (execution.time_with_tr (f.fix_iterator vin) f.time _).rel_of_mem_eval hv hx,
      simp_rw [time_dom_iff_eval_dom, part.dom_iff_mem], simp, tauto, },
    rw execution.mem_eval at hx, simp at hx,
    cases execution.mem_ran_of_mem_states hx.1,
    { simp [execution.time_with] at h, rw h.2, simp, },
    simp [execution.time_with, pfun.ran] at h,
    rcases h with ⟨t', vout', ⟨tf, htf, rfl⟩, _, hvout⟩,
    refine (ih hvout htf).trans _, simp [add_assoc], }
end

lemma time_bound_left : time_bound code.left id :=
by simp [time_bound, code.time]

lemma time_bound_right : time_bound code.right id := time_bound_left

lemma time_bound_id : time_bound code.id id := time_bound_left

lemma time_bound_nil : time_bound code.nil (λ _, 1) :=
by simp [time_bound, code.time]

lemma time_bound_node {c₁ c₂ : code} {b₁ b₂ : ℕ → ℕ} (hb₁ : time_bound c₁ b₁) (hb₂ : time_bound c₂ b₂) :
  time_bound (code.node c₁ c₂) (λ t, b₁ t + b₂ t + 1) :=
begin
  intros v,
  obtain ⟨t₁, ht₁, hb₁⟩ := hb₁ v,
  obtain ⟨t₂, ht₂, hb₂⟩ := hb₂ v,
  use t₁ + t₂ + 1, split,
  { rw ← part.eq_some_iff at ht₁ ht₂, simp [code.time, ht₁, ht₂, add_def], ring, },
  mono*,
end

lemma time_bound_comp {c₁ c₂ : code} {b₁ b₂ : ℕ → ℕ} (hm : monotone b₁) (hb₁ : time_bound c₁ b₁) (hb₂ : time_bound c₂ b₂) :
  time_bound (c₁.comp c₂) (λ t, b₁ (b₂ t) + b₂ t + 1) :=
begin
  intros v,
  obtain ⟨t₂, ht₂, hb₂⟩ := hb₂ v,
  obtain ⟨v', hv'⟩ := (_ : ∃ v', v' ∈ c₂.eval v), swap,
  { rw [← part.dom_iff_mem, ← time_dom_iff_eval_dom, part.dom_iff_mem], use [t₂, ht₂], },
  obtain ⟨t₁, ht₁, hb₁⟩ := hb₁ v',
  use t₁ + t₂ + 1, split,
  { rw ← part.eq_some_iff at ht₁ ht₂ hv', simp [code.time, ht₁, ht₂, hv', add_def], ring, },
  { mono*, exact hb₁.trans (hm ((eval_sizeof_le_time hv' ht₂).trans hb₂)), },
end

lemma time_bound_case {c₁ c₂ : code} {b₁ b₂ : ℕ → ℕ} (hm₁ : monotone b₁) (hm₂ : monotone b₂) (hb₁ : time_bound c₁ b₁) (hb₂ : time_bound c₂ b₂) :
  time_bound (code.case c₁ c₂) (λ t, max (b₁ t) (b₂ t) + 1) :=
begin
  intros v,
  simp [code.time], split_ifs,
  { obtain ⟨t, ht, H⟩ := hb₁ v.right, use [t, ht], left, exact H.trans (hm₁ $ ptree.right_sizeof_le _), },
  { obtain ⟨t, ht, H⟩ := hb₂ v.right, use [t, ht], right, exact H.trans (hm₂ $ ptree.right_sizeof_le _), },
end

lemma time_bound_case' {c₁ c₂ : code} {b₁ b₂ : ℕ → ℕ} (hm₁ : monotone b₁) (hm₂ : monotone b₂) (hb₁ : time_bound c₁ b₁) (hb₂ : time_bound c₂ b₂) :
  time_bound (code.case c₁ c₂) (λ t, (b₁ t) + (b₂ t) + 1) :=
by { apply time_bound_of_time_bound_le (time_bound_case hm₁ hm₂ hb₁ hb₂), intro, simp, }

-- lemma time_bound_case_precise {c₁ c₂ : code} {b₁ b₂ : ℕ → ℕ} (m₁ : monotone b₁) (m₂ : monotone b₂)
--   (hb₁ : ∀ x : ptree, x.left = ptree.nil → ∃ t ∈ c₁.time x.right, t ≤ b₁ x.sizeof)
--   (hb₂ : ∀ x : ptree, x.left ≠ ptree.nil → ∃ t ∈ c₂.time x.right, t ≤ b₂ x.sizeof) :
--   time_bound (code.case c₁ c₂) (λ n, max (b₁ n) (b₂ n) + 1) :=
-- begin
--   intros n v hnv,
--   by_cases H : v.left = ptree.nil,
--   { specialize hb₁ v H, rcases hb₁ with ⟨t, ht, s⟩, use t + 1, split,
--     { simpa [code.time, H], }, { simp, left, refine s.trans _, apply m₁ hnv, } },
--   { specialize hb₂ v H, rcases hb₂ with ⟨t, ht, s⟩, use t + 1, split,
--     { simpa [code.time, H], }, { simp, right, refine s.trans _, apply m₂ hnv, } }
-- end


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.braided
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.shapes.terminal
import Mathlib.category_theory.pempty
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# The monoidal structure on a category with chosen finite products.

This is a variant of the development in `category_theory.monoidal.of_has_finite_products`,
which uses specified choices of the terminal object and binary product,
enabling the construction of a cartesian category with specific definitions of the tensor unit
and tensor product.

(Because the construction in `category_theory.monoidal.of_has_finite_products` uses `has_limit`
classes, the actual definitions there are opaque behind `classical.choice`.)

We use this in `category_theory.monoidal.types` to construct the monoidal category of types
so that the tensor product is the usual cartesian product of types.

For now we only do the construction from products, and not from coproducts,
which seems less often useful.
-/

namespace category_theory

namespace limits

/-- Swap the two sides of a `binary_fan`. -/
def binary_fan.swap {C : Type u} [category C] {P : C} {Q : C} (t : binary_fan P Q) : binary_fan Q P :=
  binary_fan.mk (binary_fan.snd t) (binary_fan.fst t)

@[simp] theorem binary_fan.swap_fst {C : Type u} [category C] {P : C} {Q : C} (t : binary_fan P Q) : binary_fan.fst (binary_fan.swap t) = binary_fan.snd t :=
  rfl

@[simp] theorem binary_fan.swap_snd {C : Type u} [category C] {P : C} {Q : C} (t : binary_fan P Q) : binary_fan.snd (binary_fan.swap t) = binary_fan.fst t :=
  rfl

/--
If a cone `t` over `P Q` is a limit cone, then `t.swap` is a limit cone over `Q P`.
-/
@[simp] theorem is_limit.swap_binary_fan_lift {C : Type u} [category C] {P : C} {Q : C} {t : binary_fan P Q} (I : is_limit t) (s : cone (pair Q P)) : is_limit.lift (is_limit.swap_binary_fan I) s = is_limit.lift I (binary_fan.swap s) :=
  Eq.refl (is_limit.lift (is_limit.swap_binary_fan I) s)

/--
Construct `has_binary_product Q P` from `has_binary_product P Q`.
This can't be an instance, as it would cause a loop in typeclass search.
-/
theorem has_binary_product.swap {C : Type u} [category C] (P : C) (Q : C) [has_binary_product P Q] : has_binary_product Q P :=
  has_limit.mk
    (limit_cone.mk (binary_fan.swap (limit.cone (pair P Q))) (is_limit.swap_binary_fan (limit.is_limit (pair P Q))))

/--
Given a limit cone over `X` and `Y`, and another limit cone over `Y` and `X`, we can construct
an isomorphism between the cone points. Relative to some fixed choice of limits cones for every pair,
these isomorphisms constitute a braiding.
-/
def binary_fan.braiding {C : Type u} [category C] {X : C} {Y : C} {s : binary_fan X Y} (P : is_limit s) {t : binary_fan Y X} (Q : is_limit t) : cone.X s ≅ cone.X t :=
  is_limit.cone_point_unique_up_to_iso P (is_limit.swap_binary_fan Q)

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `sXY.X Z`,
if `sYZ` is a limit cone we can construct a binary fan over `X sYZ.X`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan (cone.X sXY) Z) : binary_fan X (cone.X sYZ) :=
  binary_fan.mk (binary_fan.fst s ≫ binary_fan.fst sXY)
    (is_limit.lift Q (binary_fan.mk (binary_fan.fst s ≫ binary_fan.snd sXY) (binary_fan.snd s)))

@[simp] theorem binary_fan.assoc_fst {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan (cone.X sXY) Z) : binary_fan.fst (binary_fan.assoc Q s) = binary_fan.fst s ≫ binary_fan.fst sXY :=
  rfl

@[simp] theorem binary_fan.assoc_snd {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan (cone.X sXY) Z) : binary_fan.snd (binary_fan.assoc Q s) =
  is_limit.lift Q (binary_fan.mk (binary_fan.fst s ≫ binary_fan.snd sXY) (binary_fan.snd s)) :=
  rfl

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `X sYZ.X`,
if `sYZ` is a limit cone we can construct a binary fan over `sXY.X Z`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc_inv {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X (cone.X sYZ)) : binary_fan (cone.X sXY) Z :=
  binary_fan.mk (is_limit.lift P (binary_fan.mk (binary_fan.fst s) (binary_fan.snd s ≫ binary_fan.fst sYZ)))
    (binary_fan.snd s ≫ binary_fan.snd sYZ)

@[simp] theorem binary_fan.assoc_inv_fst {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X (cone.X sYZ)) : binary_fan.fst (binary_fan.assoc_inv P s) =
  is_limit.lift P (binary_fan.mk (binary_fan.fst s) (binary_fan.snd s ≫ binary_fan.fst sYZ)) :=
  rfl

@[simp] theorem binary_fan.assoc_inv_snd {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X (cone.X sYZ)) : binary_fan.snd (binary_fan.assoc_inv P s) = binary_fan.snd s ≫ binary_fan.snd sYZ :=
  rfl

/--
If all the binary fans involved a limit cones, `binary_fan.assoc` produces another limit cone.
-/
def is_limit.assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ) {s : binary_fan (cone.X sXY) Z} (R : is_limit s) : is_limit (binary_fan.assoc Q s) :=
  is_limit.mk fun (t : cone (pair X (cone.X sYZ))) => is_limit.lift R (binary_fan.assoc_inv P t)

/--
Given two pairs of limit cones corresponding to the parenthesisations of `X × Y × Z`,
we obtain an isomorphism between the cone points.
-/
def binary_fan.associator {C : Type u} [category C] {X : C} {Y : C} {Z : C} {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ) {s : binary_fan (cone.X sXY) Z} (R : is_limit s) {t : binary_fan X (cone.X sYZ)} (S : is_limit t) : cone.X s ≅ cone.X t :=
  is_limit.cone_point_unique_up_to_iso (is_limit.assoc P Q R) S

/--
Given a fixed family of limit data for every pair `X Y`, we obtain an associator.
-/
def binary_fan.associator_of_limit_cone {C : Type u} [category C] (L : (X Y : C) → limit_cone (pair X Y)) (X : C) (Y : C) (Z : C) : cone.X (limit_cone.cone (L (cone.X (limit_cone.cone (L X Y))) Z)) ≅
  cone.X (limit_cone.cone (L X (cone.X (limit_cone.cone (L Y Z))))) :=
  binary_fan.associator (limit_cone.is_limit (L X Y)) (limit_cone.is_limit (L Y Z))
    (limit_cone.is_limit (L (cone.X (limit_cone.cone (L X Y))) Z))
    (limit_cone.is_limit (L X (cone.X (limit_cone.cone (L Y Z)))))

/--
Construct a left unitor from specified limit cones.
-/
def binary_fan.left_unitor {C : Type u} [category C] {X : C} {s : cone (functor.empty C)} (P : is_limit s) {t : binary_fan (cone.X s) X} (Q : is_limit t) : cone.X t ≅ X :=
  iso.mk (binary_fan.snd t)
    (is_limit.lift Q
      (binary_fan.mk
        (is_limit.lift P
          (cone.mk X
            (nat_trans.mk
              (pempty.rec
                fun (n : pempty) =>
                  functor.obj (functor.obj (functor.const (discrete pempty)) X) n ⟶ functor.obj (functor.empty C) n))))
        𝟙))

/--
Construct a right unitor from specified limit cones.
-/
def binary_fan.right_unitor {C : Type u} [category C] {X : C} {s : cone (functor.empty C)} (P : is_limit s) {t : binary_fan X (cone.X s)} (Q : is_limit t) : cone.X t ≅ X :=
  iso.mk (binary_fan.fst t)
    (is_limit.lift Q
      (binary_fan.mk 𝟙
        (is_limit.lift P
          (cone.mk X
            (nat_trans.mk
              (pempty.rec
                fun (n : pempty) =>
                  functor.obj (functor.obj (functor.const (discrete pempty)) X) n ⟶ functor.obj (functor.empty C) n))))))

end limits

namespace monoidal_of_chosen_finite_products

/-- Implementation of the tensor product for `monoidal_of_chosen_finite_products`. -/
def tensor_obj {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) (X : C) (Y : C) : C :=
  limits.cone.X (limits.limit_cone.cone (ℬ X Y))

/-- Implementation of the tensor product of morphisms for `monoidal_of_chosen_finite_products`. -/
def tensor_hom {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) {W : C} {X : C} {Y : C} {Z : C} (f : W ⟶ X) (g : Y ⟶ Z) : tensor_obj ℬ W Y ⟶ tensor_obj ℬ X Z :=
  subtype.val
    (limits.binary_fan.is_limit.lift' (limits.limit_cone.is_limit (ℬ X Z))
      (nat_trans.app (limits.cone.π (limits.limit_cone.cone (ℬ W Y))) limits.walking_pair.left ≫ f)
      (nat_trans.app (limits.cone.π (limits.limit_cone.cone (ℬ W Y))) limits.walking_pair.right ≫ g))

theorem tensor_id {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) (X₁ : C) (X₂ : C) : tensor_hom ℬ 𝟙 𝟙 = 𝟙 := sorry

theorem tensor_comp {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) {X₁ : C} {Y₁ : C} {Z₁ : C} {X₂ : C} {Y₂ : C} {Z₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) : tensor_hom ℬ (f₁ ≫ g₁) (f₂ ≫ g₂) = tensor_hom ℬ f₁ f₂ ≫ tensor_hom ℬ g₁ g₂ := sorry

theorem pentagon {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) (W : C) (X : C) (Y : C) (Z : C) : tensor_hom ℬ (iso.hom (limits.binary_fan.associator_of_limit_cone ℬ W X Y)) 𝟙 ≫
    iso.hom (limits.binary_fan.associator_of_limit_cone ℬ W (tensor_obj ℬ X Y) Z) ≫
      tensor_hom ℬ 𝟙 (iso.hom (limits.binary_fan.associator_of_limit_cone ℬ X Y Z)) =
  iso.hom (limits.binary_fan.associator_of_limit_cone ℬ (tensor_obj ℬ W X) Y Z) ≫
    iso.hom (limits.binary_fan.associator_of_limit_cone ℬ W X (tensor_obj ℬ Y Z)) := sorry

theorem triangle {C : Type u} [category C] (𝒯 : limits.limit_cone (functor.empty C)) (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) (X : C) (Y : C) : iso.hom (limits.binary_fan.associator_of_limit_cone ℬ X (limits.cone.X (limits.limit_cone.cone 𝒯)) Y) ≫
    tensor_hom ℬ 𝟙
      (iso.hom
        (limits.binary_fan.left_unitor (limits.limit_cone.is_limit 𝒯)
          (limits.limit_cone.is_limit (ℬ (limits.cone.X (limits.limit_cone.cone 𝒯)) Y)))) =
  tensor_hom ℬ
    (iso.hom
      (limits.binary_fan.right_unitor (limits.limit_cone.is_limit 𝒯)
        (limits.limit_cone.is_limit (ℬ X (limits.cone.X (limits.limit_cone.cone 𝒯))))))
    𝟙 := sorry

theorem left_unitor_naturality {C : Type u} [category C] (𝒯 : limits.limit_cone (functor.empty C)) (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) {X₁ : C} {X₂ : C} (f : X₁ ⟶ X₂) : tensor_hom ℬ 𝟙 f ≫
    iso.hom
      (limits.binary_fan.left_unitor (limits.limit_cone.is_limit 𝒯)
        (limits.limit_cone.is_limit (ℬ (limits.cone.X (limits.limit_cone.cone 𝒯)) X₂))) =
  iso.hom
      (limits.binary_fan.left_unitor (limits.limit_cone.is_limit 𝒯)
        (limits.limit_cone.is_limit (ℬ (limits.cone.X (limits.limit_cone.cone 𝒯)) X₁))) ≫
    f := sorry

theorem right_unitor_naturality {C : Type u} [category C] (𝒯 : limits.limit_cone (functor.empty C)) (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) {X₁ : C} {X₂ : C} (f : X₁ ⟶ X₂) : tensor_hom ℬ f 𝟙 ≫
    iso.hom
      (limits.binary_fan.right_unitor (limits.limit_cone.is_limit 𝒯)
        (limits.limit_cone.is_limit (ℬ X₂ (limits.cone.X (limits.limit_cone.cone 𝒯))))) =
  iso.hom
      (limits.binary_fan.right_unitor (limits.limit_cone.is_limit 𝒯)
        (limits.limit_cone.is_limit (ℬ X₁ (limits.cone.X (limits.limit_cone.cone 𝒯))))) ≫
    f := sorry

theorem associator_naturality {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) {X₁ : C} {X₂ : C} {X₃ : C} {Y₁ : C} {Y₂ : C} {Y₃ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) : tensor_hom ℬ (tensor_hom ℬ f₁ f₂) f₃ ≫ iso.hom (limits.binary_fan.associator_of_limit_cone ℬ Y₁ Y₂ Y₃) =
  iso.hom (limits.binary_fan.associator_of_limit_cone ℬ X₁ X₂ X₃) ≫ tensor_hom ℬ f₁ (tensor_hom ℬ f₂ f₃) := sorry

end monoidal_of_chosen_finite_products

/-- A category with a terminal object and binary products has a natural monoidal structure. -/
def monoidal_of_chosen_finite_products {C : Type u} [category C] (𝒯 : limits.limit_cone (functor.empty C)) (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) : monoidal_category C :=
  monoidal_category.mk (fun (X Y : C) => sorry) (fun (_x _x_1 _x_2 _x_3 : C) (f : _x ⟶ _x_1) (g : _x_2 ⟶ _x_3) => sorry)
    (limits.cone.X (limits.limit_cone.cone 𝒯)) (fun (X Y Z : C) => limits.binary_fan.associator_of_limit_cone ℬ X Y Z)
    (fun (X : C) =>
      limits.binary_fan.left_unitor (limits.limit_cone.is_limit 𝒯)
        (limits.limit_cone.is_limit (ℬ (limits.cone.X (limits.limit_cone.cone 𝒯)) X)))
    fun (X : C) =>
      limits.binary_fan.right_unitor (limits.limit_cone.is_limit 𝒯)
        (limits.limit_cone.is_limit (ℬ X (limits.cone.X (limits.limit_cone.cone 𝒯))))

namespace monoidal_of_chosen_finite_products

/--
A type synonym for `C` carrying a monoidal category structure corresponding to
a fixed choice of limit data for the empty functor, and for `pair X Y` for every `X Y : C`.

This is an implementation detail for `symmetric_of_chosen_finite_products`.
-/
def monoidal_of_chosen_finite_products_synonym {C : Type u} [category C] (𝒯 : limits.limit_cone (functor.empty C)) (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) :=
  C

protected instance monoidal_of_chosen_finite_products_synonym.category_theory.monoidal_category {C : Type u} [category C] (𝒯 : limits.limit_cone (functor.empty C)) (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) : monoidal_category (monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
  monoidal_of_chosen_finite_products 𝒯 ℬ

theorem braiding_naturality {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) {X : C} {X' : C} {Y : C} {Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') : tensor_hom ℬ f g ≫
    iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ Y Y')) (limits.limit_cone.is_limit (ℬ Y' Y))) =
  iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ X X')) (limits.limit_cone.is_limit (ℬ X' X))) ≫
    tensor_hom ℬ g f := sorry

theorem hexagon_forward {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) (X : C) (Y : C) (Z : C) : iso.hom (limits.binary_fan.associator_of_limit_cone ℬ X Y Z) ≫
    iso.hom
        (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ X (tensor_obj ℬ Y Z)))
          (limits.limit_cone.is_limit (ℬ (tensor_obj ℬ Y Z) X))) ≫
      iso.hom (limits.binary_fan.associator_of_limit_cone ℬ Y Z X) =
  tensor_hom ℬ
      (iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ X Y)) (limits.limit_cone.is_limit (ℬ Y X))))
      𝟙 ≫
    iso.hom (limits.binary_fan.associator_of_limit_cone ℬ Y X Z) ≫
      tensor_hom ℬ 𝟙
        (iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ X Z)) (limits.limit_cone.is_limit (ℬ Z X)))) := sorry

theorem hexagon_reverse {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) (X : C) (Y : C) (Z : C) : iso.inv (limits.binary_fan.associator_of_limit_cone ℬ X Y Z) ≫
    iso.hom
        (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ (tensor_obj ℬ X Y) Z))
          (limits.limit_cone.is_limit (ℬ Z (tensor_obj ℬ X Y)))) ≫
      iso.inv (limits.binary_fan.associator_of_limit_cone ℬ Z X Y) =
  tensor_hom ℬ 𝟙
      (iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ Y Z)) (limits.limit_cone.is_limit (ℬ Z Y)))) ≫
    iso.inv (limits.binary_fan.associator_of_limit_cone ℬ X Z Y) ≫
      tensor_hom ℬ
        (iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ X Z)) (limits.limit_cone.is_limit (ℬ Z X))))
        𝟙 := sorry

theorem symmetry {C : Type u} [category C] (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) (X : C) (Y : C) : iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ X Y)) (limits.limit_cone.is_limit (ℬ Y X))) ≫
    iso.hom (limits.binary_fan.braiding (limits.limit_cone.is_limit (ℬ Y X)) (limits.limit_cone.is_limit (ℬ X Y))) =
  𝟙 := sorry

end monoidal_of_chosen_finite_products

/--
The monoidal structure coming from finite products is symmetric.
-/
def symmetric_of_chosen_finite_products {C : Type u} [category C] (𝒯 : limits.limit_cone (functor.empty C)) (ℬ : (X Y : C) → limits.limit_cone (limits.pair X Y)) : symmetric_category (monoidal_of_chosen_finite_products.monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
  symmetric_category.mk


import Qq
import Lean

import Category.Basic

open Lean Lean.Expr Lean.Meta Lean.Elab.Tactic

open Qq

universe u v

structure Result {α:Q(Type u)} (E: Q($α) → Type) (e: Q($α)) where
  expr  : Q($α)
  val   : E expr
  proof : Q($e = $expr)

def Result.Id {α:Q(Type u)} {E:Q($α) → Type} (e: Q($α)) (val: E e) : Result E e where
  expr  := e
  val   := val
  proof := q(by rfl)

def Result.map {α:Q(Type u)} {E:Q($α) → Type} {e: Q($α)}
  (r:Result E e) (F:Q($α) → Type) (f: E r.expr → F r.expr) : Result F e where
  expr  := r.expr
  val   := f r.val
  proof := r.proof

instance [Inhabited (Σ e, E e)] : Inhabited (Result E e) :=
  let ⟨e', v⟩ : Σ e, E e := default; ⟨e', v, default⟩

namespace Cat

structure Context where
  useTransparancy : Bool

structure State where
  atoms : Array Expr := #[]

instance : Inhabited State where
  default := ⟨#[]⟩

abbrev CatM := ReaderT Context <| StateT State MetaM

def CatM.run {α:Type} (f:CatM α) (red:Bool) :
  MetaM α := (f ⟨red⟩).run' {}

def CatM.add_atom (e:Expr) : CatM Nat := do
  let table ← get
  if (← read).useTransparancy then
    for h : i in [0:table.atoms.size] do
      have : i < table.atoms.size := h.2
      if ← isDefEq e table.atoms[i] then
        return i
  modifyGet fun c => (table.atoms.size, {c with atoms := c.atoms.push e})

section

variable {C: Q(Type u)}
variable {CatC: Q(Category.{u, v} $C)}

inductive Atom : ∀ X Y: Q($C), Q($X ⟶  $Y) → Type where
| Const : ∀ X Y: Q($C), ∀ f: Q($X ⟶  $Y), Nat → Atom X Y f

inductive AtomicMorphism : ∀ X Y: Q($C), Q($X ⟶  $Y) → Type where
| Nil : ∀ {X Y f}, Atom X Y f → AtomicMorphism X Y f
| Cons: ∀ {X Z: Q($C)} (Y:Q($C)),
  ∀ f: Q($Y ⟶  $Z), ∀ g: Q($X ⟶  $Y),
  Atom Y Z f → AtomicMorphism X Y g → AtomicMorphism X Z q($f ⊚ $g)

inductive Morphism : ∀ X Y:Q($C), Q($X ⟶  $Y) → Type where
| Id   : ∀ X: Q($C), Morphism X X q(𝟙 $X)
| List : ∀ {X Y}, ∀ f, AtomicMorphism X Y f → Morphism X Y f

instance {X Y:Q($C)} {f:Q($X ⟶  $Y)} : Inhabited (@Morphism u v C CatC X Y f) where
  default := Morphism.List f <| AtomicMorphism.Nil <| Atom.Const X Y f 0

instance {X Y:Q($C)} : Inhabited (Σ f, @Morphism u v C CatC X Y f) where
  default := ⟨default, default⟩

#check Result
#check AtomicMorphism

def AtomicMorphism.compose {X Y Z: Q($C)} (f1:Q($Y ⟶  $Z)) (f2:Q($X ⟶  $Y))
  (l1:AtomicMorphism Y Z f1) (l2:AtomicMorphism X Y f2) :
    @Result _ q($X ⟶  $Z) (@AtomicMorphism _ _ C CatC X Z) q($f1 ⊚ $f2) :=

  match l1 with
  | AtomicMorphism.Nil atom => Result.Id q($f1 ⊚ $f2) (.Cons Y f1 f2 atom l2)
  | .Cons Z f1 g1 atom l1 =>
  by
    let r := compose g1 f2 l1 l2
    generalize h: r.expr = expr
    have proof : Q($g1 ⊚ $f2 = $expr) := r.proof
    exact {
      expr := q($f1 ⊚ $r.expr),
      val  := .Cons Z f1 q($r.expr) atom r.val,
      proof:= show Q($f1 ⊚ $expr = ($f1 ⊚ $g1) ⊚ $f2) from q(by
        simp
        rw [«$proof»]
      )
    }

def Morphism.compose {X Y Z: Q($C)} (f1: Q($Y ⟶  $Z)) (f2: Q($X ⟶  $Y))
  (l1: @Morphism _ _ C CatC Y Z f1) (l2: @Morphism _ _ C CatC X Y f2) :
  @Result _ q($X ⟶  $Z) (@Morphism _ _ C CatC X Z) q($f1 ⊚ $f2) :=
by
  cases l1 with
  | Id =>
    apply Result.mk
    case expr =>
      exact f2
    case val =>
      exact l2
    case proof =>
      exact q(by
        rw [Category.id_comp]
      )
  | List _ a =>
    cases l2 with
    | Id =>
      apply Result.mk
      case expr =>
        exact f1
      case val =>
        exact (.List _ a)
      case proof =>
        exact q(by
          rw [Category.comp_id]
        )
    | List _ b =>
      apply Result.map (AtomicMorphism.compose f1 f2 a b)
      apply Morphism.List

#check @Category.id
#check Category.comp
#check Morphism.compose

-- \f<< for « and \f>> for »
mutual

partial def match_morphism_dom_eq_cod (X: Q($C)) (f:Q($X ⟶  $X)) :
  CatM (@Result _ q($X ⟶  $X) (@Morphism _ _ C CatC X X) f) := do

  match f with
  | ~q(𝟙 «$X») => do
    return {expr := q(𝟙 $X), val := Morphism.Id X, proof := q(by rfl)}
  | ~q(@Category.comp _ _ _ «$X» _ $g $h) => do
    let r1 ← @match_morphism_dom_eq_cod X g
    let r2 ← match_morphism_dom_eq_cod X h

    match (r1, r2) with
    | (Result.mk g' val_g proof_g, Result.mk h' val_h proof_h) =>
      match Morphism.compose g' h' val_g val_h with
      | Result.mk expr val proof =>
      return {
        expr := expr, --q($g' ⊚ $h'),
        val := val,
        proof := q(by
          rw [<-«$proof», <-«$proof_g», <-«$proof_h»]
        )
      }
  | ~q(@Category.comp _ _ _ $Y _ $g $h) => do
    let r1 ← match_morphism Y X g
    let r2 ← match_morphism X Y h

    match (r1, r2) with
    | (Result.mk g' val_g proof_g, Result.mk h' val_h proof_h) =>
      match Morphism.compose g' h' val_g val_h with
      | Result.mk expr val proof =>
        return {
          expr := expr,
          val := val,
          proof := q(by
            rw [<-«$proof», <-«$proof_g», <-«$proof_h»]
          )
        }
  | _ =>
    let idx ← CatM.add_atom f
    return Result.Id f <| Morphism.List f <| AtomicMorphism.Nil (Atom.Const X X f idx)

-- patern match a morphism when the codomain and the domain are distincts
partial def match_morphism (X Y: Q($C)) (f:Q($X ⟶  $Y)) :
  CatM (@Result _ q($X ⟶  $Y) (@Morphism _ _ C CatC X Y) f) := do

  match f with
  | ~q(@Category.comp _ _ _ «$X» _ $g $h) =>
    let r2 ← match_morphism_dom_eq_cod X h
    let r1 ← match_morphism X Y g

    match (r1, r2) with
    | (Result.mk g' val_g proof_g, Result.mk h' val_h proof_h) =>
      match Morphism.compose g' h' val_g val_h with
      | Result.mk expr val proof =>
        return {
          expr := expr,
          val  := val,
          proof:= q(by
            rw [<-«$proof», <-«$proof_g», <-«$proof_h»]
          )
        }
  | ~q(@Category.comp _ _ _ «$Y» _ $g $h) =>
    let r1 ← match_morphism_dom_eq_cod Y g
    let r2 ← match_morphism X Y h

    match (r1, r2) with
    | (Result.mk g' val_g proof_g, Result.mk h' val_h proof_h) =>
      match Morphism.compose g' h' val_g val_h with
      | Result.mk expr val proof =>
        return {
          expr := expr,
          val  := val,
          proof:= q(by
            rw [<-«$proof», <-«$proof_g», <-«$proof_h»]
          )
        }
  | ~q(@Category.comp _ _ _ $Z _ $g $h) =>
    let r2 ← match_morphism X Z h
    let r1 ← match_morphism Z Y g

    match (r1, r2) with
    | (Result.mk g' val_g proof_g, Result.mk h' val_h proof_h) =>
      match Morphism.compose g' h' val_g val_h with
      | Result.mk expr val proof =>
        return {
          expr := expr,
          val  := val,
          proof:= q(by
            rw [<-«$proof», <-«$proof_g», <-«$proof_h»]
          )
        }
  | _ =>
    let idx ← CatM.add_atom f
    return Result.Id f <| Morphism.List f <| AtomicMorphism.Nil (Atom.Const X Y f idx)

end

end

def of_eq (_ : (a: R) = c) (_ : b = c) : a = b := by simp only [*]

universe w

abbrev EndoHom (C:Type w) (CatC:Category C) (X:C) := @Category.Hom C CatC X X

partial def match_morphism_equality (mvarid:MVarId) : CatM <| List MVarId := do
  let type_eq : Q(Prop) ← mvarid.getType
  match type_eq with
  | ~q($f = $g) => do
    let type_fg ← inferType f
    -- $f and $g are morphism of type $type_f, $type_f have type Type v
    let .sort (.succ v) ← whnf (← inferType type_fg) | throwError "not a type"

    have type_fg : Q(Type v) := type_fg
    have f : Q($type_fg) := f
    have g : Q($type_fg) := g

    match type_fg with
    | ~q(EndoHom $C $CatC $X) =>

      let .sort (.succ u) ← whnf (← inferType C) | throwError "a category shound be a type"

      let type_fg : Q(Type v) := q($X ⟶  $X)
      have f : Q($type_fg) := f
      have g : Q($type_fg) := g

      let ⟨f', vf, pf⟩ ← @match_morphism_dom_eq_cod u v C CatC X f
      let ⟨g', vg, pg⟩ ← @match_morphism_dom_eq_cod u v C CatC X g

      --throwError "{f'} {g'}"

      if not (← isDefEq f' g') then do
        throwError "expressions not equal\n{f}\n{g}\n{f'}\n{g'}"

      let pg : Q(«$g» = «$f'») := pg
      mvarid.assign q(of_eq $pf $pg)

      return []

    | ~q(@Category.Hom $C $CatC $X $Y) =>

      let .sort (.succ u) ← whnf (← inferType C) | throwError "a category shound be a type"

      let type_fg : Q(Type v) := q($X ⟶  $Y)
      have f : Q($type_fg) := f
      have g : Q($type_fg) := g

      let ⟨f', vf, pf⟩ ← @match_morphism u v C CatC X Y f
      let ⟨g', vg, pg⟩ ← @match_morphism u v C CatC X Y g

      if not (← isDefEq f' g') then do
        throwError "expressions not equal\n{f}\n{g}\n{f'}\n{g'}"

      let pg : Q(«$g» = «$f'») := pg
      mvarid.assign q(of_eq $pf $pg)

      return []

    | _ => throwError "not a morphism"
  | _ => throwError "not an equality"

elab "reduce_assoc_and_id" : tactic =>
  withMainContext do
    liftMetaTactic fun mvarId => do
      CatM.run (match_morphism_equality mvarId) true

end Cat

example (C:Type u) [Category C] (X Y:C) (f: X ⟶  Y) (g:X ⟶  X) :
  (f ⊚ 𝟙 X) ⊚ g = 𝟙 Y ⊚ (f ⊚ g) := by reduce_assoc_and_id


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.chain
import Mathlib.data.list.nodup
import Mathlib.data.list.of_fn
import Mathlib.data.list.zip
import Mathlib.PostPort

universes u u_1

namespace Mathlib

namespace list

/- iota and range(') -/

@[simp] theorem length_range' (s : ℕ) (n : ℕ) : length (range' s n) = n := sorry

@[simp] theorem range'_eq_nil {s : ℕ} {n : ℕ} : range' s n = [] ↔ n = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (range' s n = [] ↔ n = 0)) (Eq.symm (propext length_eq_zero))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length (range' s n) = 0 ↔ n = 0)) (length_range' s n)))
      (iff.refl (n = 0)))

@[simp] theorem mem_range' {m : ℕ} {s : ℕ} {n : ℕ} : m ∈ range' s n ↔ s ≤ m ∧ m < s + n := sorry

theorem map_add_range' (a : ℕ) (s : ℕ) (n : ℕ) : map (Add.add a) (range' s n) = range' (a + s) n :=
  sorry

theorem map_sub_range' (a : ℕ) (s : ℕ) (n : ℕ) (h : a ≤ s) :
    map (fun (x : ℕ) => x - a) (range' s n) = range' (s - a) n :=
  sorry

theorem chain_succ_range' (s : ℕ) (n : ℕ) :
    chain (fun (a b : ℕ) => b = Nat.succ a) s (range' (s + 1) n) :=
  sorry

theorem chain_lt_range' (s : ℕ) (n : ℕ) : chain Less s (range' (s + 1) n) :=
  chain.imp (fun (a b : ℕ) (e : b = Nat.succ a) => Eq.symm e ▸ nat.lt_succ_self a)
    (chain_succ_range' s n)

theorem pairwise_lt_range' (s : ℕ) (n : ℕ) : pairwise Less (range' s n) := sorry

theorem nodup_range' (s : ℕ) (n : ℕ) : nodup (range' s n) :=
  pairwise.imp (fun (a b : ℕ) => ne_of_lt) (pairwise_lt_range' s n)

@[simp] theorem range'_append (s : ℕ) (m : ℕ) (n : ℕ) :
    range' s m ++ range' (s + m) n = range' s (n + m) :=
  sorry

theorem range'_sublist_right {s : ℕ} {m : ℕ} {n : ℕ} : range' s m <+ range' s n ↔ m ≤ n := sorry

theorem range'_subset_right {s : ℕ} {m : ℕ} {n : ℕ} : range' s m ⊆ range' s n ↔ m ≤ n := sorry

theorem nth_range' (s : ℕ) {m : ℕ} {n : ℕ} : m < n → nth (range' s n) m = some (s + m) := sorry

@[simp] theorem nth_le_range' {n : ℕ} {m : ℕ} (i : ℕ) (H : i < length (range' n m)) :
    nth_le (range' n m) i H = n + i :=
  sorry

theorem range'_concat (s : ℕ) (n : ℕ) : range' s (n + 1) = range' s n ++ [s + n] :=
  eq.mpr (id (Eq._oldrec (Eq.refl (range' s (n + 1) = range' s n ++ [s + n])) (add_comm n 1)))
    (Eq.symm (range'_append s n 1))

theorem range_core_range' (s : ℕ) (n : ℕ) : range_core s (range' s n) = range' 0 (n + s) := sorry

theorem range_eq_range' (n : ℕ) : range n = range' 0 n :=
  Eq.trans (range_core_range' n 0)
    (eq.mpr (id (Eq._oldrec (Eq.refl (range' 0 (0 + n) = range' 0 n)) (zero_add n)))
      (Eq.refl (range' 0 n)))

theorem range_succ_eq_map (n : ℕ) : range (n + 1) = 0 :: map Nat.succ (range n) := sorry

theorem range'_eq_map_range (s : ℕ) (n : ℕ) : range' s n = map (Add.add s) (range n) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (range' s n = map (Add.add s) (range n))) (range_eq_range' n)))
    (eq.mpr
      (id (Eq._oldrec (Eq.refl (range' s n = map (Add.add s) (range' 0 n))) (map_add_range' s 0 n)))
      (Eq.refl (range' s n)))

@[simp] theorem length_range (n : ℕ) : length (range n) = n := sorry

@[simp] theorem range_eq_nil {n : ℕ} : range n = [] ↔ n = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (range n = [] ↔ n = 0)) (Eq.symm (propext length_eq_zero))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length (range n) = 0 ↔ n = 0)) (length_range n)))
      (iff.refl (n = 0)))

theorem pairwise_lt_range (n : ℕ) : pairwise Less (range n) := sorry

theorem nodup_range (n : ℕ) : nodup (range n) := sorry

theorem range_sublist {m : ℕ} {n : ℕ} : range m <+ range n ↔ m ≤ n := sorry

theorem range_subset {m : ℕ} {n : ℕ} : range m ⊆ range n ↔ m ≤ n := sorry

@[simp] theorem mem_range {m : ℕ} {n : ℕ} : m ∈ range n ↔ m < n := sorry

@[simp] theorem not_mem_range_self {n : ℕ} : ¬n ∈ range n := mt (iff.mp mem_range) (lt_irrefl n)

@[simp] theorem self_mem_range_succ (n : ℕ) : n ∈ range (n + 1) := sorry

theorem nth_range {m : ℕ} {n : ℕ} (h : m < n) : nth (range n) m = some m := sorry

theorem range_succ (n : ℕ) : range (Nat.succ n) = range n ++ [n] := sorry

@[simp] theorem range_zero : range 0 = [] := rfl

theorem iota_eq_reverse_range' (n : ℕ) : iota n = reverse (range' 1 n) := sorry

@[simp] theorem length_iota (n : ℕ) : length (iota n) = n := sorry

theorem pairwise_gt_iota (n : ℕ) : pairwise gt (iota n) := sorry

theorem nodup_iota (n : ℕ) : nodup (iota n) := sorry

theorem mem_iota {m : ℕ} {n : ℕ} : m ∈ iota n ↔ 1 ≤ m ∧ m ≤ n := sorry

theorem reverse_range' (s : ℕ) (n : ℕ) :
    reverse (range' s n) = map (fun (i : ℕ) => s + n - 1 - i) (range n) :=
  sorry

/-- All elements of `fin n`, from `0` to `n-1`. -/
def fin_range (n : ℕ) : List (fin n) := pmap fin.mk (range n) sorry

@[simp] theorem fin_range_zero : fin_range 0 = [] := rfl

@[simp] theorem mem_fin_range {n : ℕ} (a : fin n) : a ∈ fin_range n := sorry

theorem nodup_fin_range (n : ℕ) : nodup (fin_range n) :=
  nodup_pmap (fun (_x : ℕ) (_x_1 : _x < n) (_x_2 : ℕ) (_x_3 : _x_2 < n) => fin.veq_of_eq)
    (nodup_range n)

@[simp] theorem length_fin_range (n : ℕ) : length (fin_range n) = n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (length (fin_range n) = n)) (fin_range.equations._eqn_1 n)))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (length (pmap fin.mk (range n) (fin_range._proof_1 n)) = n))
          length_pmap))
      (eq.mpr (id (Eq._oldrec (Eq.refl (length (range n) = n)) (length_range n))) (Eq.refl n)))

@[simp] theorem fin_range_eq_nil {n : ℕ} : fin_range n = [] ↔ n = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (fin_range n = [] ↔ n = 0)) (Eq.symm (propext length_eq_zero))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length (fin_range n) = 0 ↔ n = 0)) (length_fin_range n)))
      (iff.refl (n = 0)))

theorem prod_range_succ {α : Type u} [monoid α] (f : ℕ → α) (n : ℕ) :
    prod (map f (range (Nat.succ n))) = prod (map f (range n)) * f n :=
  sorry

/-- A variant of `prod_range_succ` which pulls off the first
  term in the product rather than the last.-/
theorem sum_range_succ' {α : Type u} [add_monoid α] (f : ℕ → α) (n : ℕ) :
    sum (map f (range (Nat.succ n))) = f 0 + sum (map (fun (i : ℕ) => f (Nat.succ i)) (range n)) :=
  sorry

@[simp] theorem enum_from_map_fst {α : Type u} (n : ℕ) (l : List α) :
    map prod.fst (enum_from n l) = range' n (length l) :=
  sorry

@[simp] theorem enum_map_fst {α : Type u} (l : List α) : map prod.fst (enum l) = range (length l) :=
  sorry

theorem enum_eq_zip_range {α : Type u} (l : List α) : enum l = zip (range (length l)) l :=
  zip_of_prod (enum_map_fst l) (enum_map_snd l)

@[simp] theorem unzip_enum_eq_prod {α : Type u} (l : List α) :
    unzip (enum l) = (range (length l), l) :=
  sorry

theorem enum_from_eq_zip_range' {α : Type u} (l : List α) {n : ℕ} :
    enum_from n l = zip (range' n (length l)) l :=
  zip_of_prod (enum_from_map_fst n l) (enum_from_map_snd n l)

@[simp] theorem unzip_enum_from_eq_prod {α : Type u} (l : List α) {n : ℕ} :
    unzip (enum_from n l) = (range' n (length l), l) :=
  sorry

@[simp] theorem nth_le_range {n : ℕ} (i : ℕ) (H : i < length (range n)) :
    nth_le (range n) i H = i :=
  sorry

@[simp] theorem nth_le_fin_range {n : ℕ} {i : ℕ} (h : i < length (fin_range n)) :
    nth_le (fin_range n) i h = { val := i, property := length_fin_range n ▸ h } :=
  sorry

theorem of_fn_eq_pmap {α : Type u_1} {n : ℕ} {f : fin n → α} :
    of_fn f =
        pmap (fun (i : ℕ) (hi : i < n) => f { val := i, property := hi }) (range n)
          fun (_x : ℕ) => iff.mp mem_range :=
  sorry

theorem of_fn_id (n : ℕ) : of_fn id = fin_range n := of_fn_eq_pmap

theorem of_fn_eq_map {α : Type u_1} {n : ℕ} {f : fin n → α} : of_fn f = map f (fin_range n) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (of_fn f = map f (fin_range n))) (Eq.symm (of_fn_id n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (of_fn f = map f (of_fn id))) (map_of_fn id f)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (of_fn f = of_fn (f ∘ id))) (function.right_id f)))
        (Eq.refl (of_fn f))))

theorem nodup_of_fn {α : Type u_1} {n : ℕ} {f : fin n → α} (hf : function.injective f) :
    nodup (of_fn f) :=
  sorry

end Mathlib


/-
Copyright (c) 2014 Floris van Doorn (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad, Mario Carneiro

! This file was ported from Lean 3 source module data.nat.order.lemmas
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Order.Basic
import Mathbin.Data.Set.Basic
import Mathbin.Algebra.Ring.Divisibility
import Mathbin.Algebra.GroupWithZero.Divisibility

/-!
# Further lemmas about the natural numbers

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

The distinction between this file and `data.nat.order.basic` is not particularly clear.
They are separated by now to minimize the porting requirements for tactics during the transition to
mathlib4. After `data.rat.order` has been ported, please feel free to reorganize these two files.
-/

universe u v

variable {m n k : ℕ}

namespace Nat

/-! ### Sets -/

#print Nat.Subtype.orderBot /-
instance Subtype.orderBot (s : Set ℕ) [DecidablePred (· ∈ s)] [h : Nonempty s] : OrderBot s
    where
  bot := ⟨Nat.find (nonempty_subtype.1 h), Nat.find_spec (nonempty_subtype.1 h)⟩
  bot_le x := Nat.find_min' _ x.2
#align nat.subtype.order_bot Nat.Subtype.orderBot
-/

#print Nat.Subtype.semilatticeSup /-
instance Subtype.semilatticeSup (s : Set ℕ) : SemilatticeSup s :=
  { Subtype.linearOrder s, LinearOrder.toLattice with }
#align nat.subtype.semilattice_sup Nat.Subtype.semilatticeSup
-/

/- warning: nat.subtype.coe_bot -> Nat.Subtype.coe_bot is a dubious translation:
lean 3 declaration is
  forall {s : Set.{0} Nat} [_inst_1 : DecidablePred.{1} Nat (fun (_x : Nat) => Membership.Mem.{0, 0} Nat (Set.{0} Nat) (Set.hasMem.{0} Nat) _x s)] [h : Nonempty.{1} (coeSort.{1, 2} (Set.{0} Nat) Type (Set.hasCoeToSort.{0} Nat) s)], Eq.{1} Nat ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (coeSort.{1, 2} (Set.{0} Nat) Type (Set.hasCoeToSort.{0} Nat) s) Nat (HasLiftT.mk.{1, 1} (coeSort.{1, 2} (Set.{0} Nat) Type (Set.hasCoeToSort.{0} Nat) s) Nat (CoeTCₓ.coe.{1, 1} (coeSort.{1, 2} (Set.{0} Nat) Type (Set.hasCoeToSort.{0} Nat) s) Nat (coeBase.{1, 1} (coeSort.{1, 2} (Set.{0} Nat) Type (Set.hasCoeToSort.{0} Nat) s) Nat (coeSubtype.{1} Nat (fun (x : Nat) => Membership.Mem.{0, 0} Nat (Set.{0} Nat) (Set.hasMem.{0} Nat) x s))))) (Bot.bot.{0} (coeSort.{1, 2} (Set.{0} Nat) Type (Set.hasCoeToSort.{0} Nat) s) (OrderBot.toHasBot.{0} (coeSort.{1, 2} (Set.{0} Nat) Type (Set.hasCoeToSort.{0} Nat) s) (Subtype.hasLe.{0} Nat Nat.hasLe (fun (x : Nat) => Membership.Mem.{0, 0} Nat (Set.{0} Nat) (Set.hasMem.{0} Nat) x s)) (Nat.Subtype.orderBot s (fun (a : Nat) => _inst_1 a) h)))) (Nat.find (fun (n : Nat) => Membership.Mem.{0, 0} Nat (Set.{0} Nat) (Set.hasMem.{0} Nat) n s) (fun (a : Nat) => _inst_1 a) (Iff.mp (Nonempty.{1} (Subtype.{1} Nat (fun (x : Nat) => Membership.Mem.{0, 0} Nat (Set.{0} Nat) (Set.hasMem.{0} Nat) x s))) (Exists.{1} Nat (fun (a : Nat) => Membership.Mem.{0, 0} Nat (Set.{0} Nat) (Set.hasMem.{0} Nat) a s)) (nonempty_subtype.{1} Nat (fun (x : Nat) => Membership.Mem.{0, 0} Nat (Set.{0} Nat) (Set.hasMem.{0} Nat) x s)) h))
but is expected to have type
  forall {s : Set.{0} Nat} [_inst_1 : DecidablePred.{1} Nat (fun (_x : Nat) => Membership.mem.{0, 0} Nat (Set.{0} Nat) (Set.instMembershipSet.{0} Nat) _x s)] [h : Nonempty.{1} (Set.Elem.{0} Nat s)], Eq.{1} Nat (Subtype.val.{1} Nat (fun (x : Nat) => Membership.mem.{0, 0} Nat (Set.{0} Nat) (Set.instMembershipSet.{0} Nat) x s) (Bot.bot.{0} (Set.Elem.{0} Nat s) (OrderBot.toBot.{0} (Set.Elem.{0} Nat s) (Subtype.le.{0} Nat instLENat (fun (x : Nat) => Membership.mem.{0, 0} Nat (Set.{0} Nat) (Set.instMembershipSet.{0} Nat) x s)) (Nat.Subtype.orderBot s (fun (a : Nat) => _inst_1 a) h)))) (Nat.find (fun (n : Nat) => Membership.mem.{0, 0} Nat (Set.{0} Nat) (Set.instMembershipSet.{0} Nat) n s) (fun (a : Nat) => _inst_1 a) (Iff.mp (Nonempty.{1} (Subtype.{1} Nat (fun (x : Nat) => Membership.mem.{0, 0} Nat (Set.{0} Nat) (Set.instMembershipSet.{0} Nat) x s))) (Exists.{1} Nat (fun (a : Nat) => Membership.mem.{0, 0} Nat (Set.{0} Nat) (Set.instMembershipSet.{0} Nat) a s)) (nonempty_subtype.{1} Nat (fun (x : Nat) => Membership.mem.{0, 0} Nat (Set.{0} Nat) (Set.instMembershipSet.{0} Nat) x s)) h))
Case conversion may be inaccurate. Consider using '#align nat.subtype.coe_bot Nat.Subtype.coe_botₓ'. -/
theorem Subtype.coe_bot {s : Set ℕ} [DecidablePred (· ∈ s)] [h : Nonempty s] :
    ((⊥ : s) : ℕ) = Nat.find (nonempty_subtype.1 h) :=
  rfl
#align nat.subtype.coe_bot Nat.Subtype.coe_bot

#print Nat.set_eq_univ /-
theorem set_eq_univ {S : Set ℕ} : S = Set.univ ↔ 0 ∈ S ∧ ∀ k : ℕ, k ∈ S → k + 1 ∈ S :=
  ⟨by rintro rfl <;> simp, fun ⟨h0, hs⟩ => Set.eq_univ_of_forall (set_induction h0 hs)⟩
#align nat.set_eq_univ Nat.set_eq_univ
-/

/-! ### `div` -/

#print Nat.lt_div_iff_mul_lt /-
protected theorem lt_div_iff_mul_lt {n d : ℕ} (hnd : d ∣ n) (a : ℕ) : a < n / d ↔ d * a < n :=
  by
  rcases d.eq_zero_or_pos with (rfl | hd0); · simp [zero_dvd_iff.mp hnd]
  rw [← mul_lt_mul_left hd0, ← Nat.eq_mul_of_div_eq_right hnd rfl]
#align nat.lt_div_iff_mul_lt Nat.lt_div_iff_mul_lt
-/

#print Nat.div_eq_iff_eq_of_dvd_dvd /-
theorem div_eq_iff_eq_of_dvd_dvd {n x y : ℕ} (hn : n ≠ 0) (hx : x ∣ n) (hy : y ∣ n) :
    n / x = n / y ↔ x = y := by
  constructor
  · intro h
    rw [← mul_right_inj' hn]
    apply Nat.eq_mul_of_div_eq_left (dvd_mul_of_dvd_left hy x)
    rw [eq_comm, mul_comm, Nat.mul_div_assoc _ hy]
    exact Nat.eq_mul_of_div_eq_right hx h
  · intro h
    rw [h]
#align nat.div_eq_iff_eq_of_dvd_dvd Nat.div_eq_iff_eq_of_dvd_dvd
-/

#print Nat.div_eq_zero_iff /-
protected theorem div_eq_zero_iff {a b : ℕ} (hb : 0 < b) : a / b = 0 ↔ a < b :=
  ⟨fun h => by rw [← mod_add_div a b, h, MulZeroClass.mul_zero, add_zero] <;> exact mod_lt _ hb,
    fun h => by
    rw [← mul_right_inj' hb.ne', ← @add_left_cancel_iff _ _ _ (a % b), mod_add_div, mod_eq_of_lt h,
      MulZeroClass.mul_zero, add_zero]⟩
#align nat.div_eq_zero_iff Nat.div_eq_zero_iff
-/

#print Nat.div_eq_zero /-
protected theorem div_eq_zero {a b : ℕ} (hb : a < b) : a / b = 0 :=
  (Nat.div_eq_zero_iff <| (zero_le a).trans_lt hb).mpr hb
#align nat.div_eq_zero Nat.div_eq_zero
-/

/-! ### `mod`, `dvd` -/

#print Nat.dvd_one /-
@[simp]
protected theorem dvd_one {n : ℕ} : n ∣ 1 ↔ n = 1 :=
  ⟨eq_one_of_dvd_one, fun e => e.symm ▸ dvd_rfl⟩
#align nat.dvd_one Nat.dvd_one
-/

#print Nat.not_two_dvd_bit1 /-
@[simp]
protected theorem not_two_dvd_bit1 (n : ℕ) : ¬2 ∣ bit1 n :=
  by
  rw [bit1, Nat.dvd_add_right two_dvd_bit0, Nat.dvd_one]
  cc
#align nat.not_two_dvd_bit1 Nat.not_two_dvd_bit1
-/

#print Nat.dvd_add_self_left /-
/-- A natural number `m` divides the sum `m + n` if and only if `m` divides `n`.-/
@[simp]
protected theorem dvd_add_self_left {m n : ℕ} : m ∣ m + n ↔ m ∣ n :=
  Nat.dvd_add_right (dvd_refl m)
#align nat.dvd_add_self_left Nat.dvd_add_self_left
-/

#print Nat.dvd_add_self_right /-
/-- A natural number `m` divides the sum `n + m` if and only if `m` divides `n`.-/
@[simp]
protected theorem dvd_add_self_right {m n : ℕ} : m ∣ n + m ↔ m ∣ n :=
  Nat.dvd_add_left (dvd_refl m)
#align nat.dvd_add_self_right Nat.dvd_add_self_right
-/

#print Nat.dvd_sub' /-
-- TODO: update `nat.dvd_sub` in core
theorem dvd_sub' {k m n : ℕ} (h₁ : k ∣ m) (h₂ : k ∣ n) : k ∣ m - n :=
  by
  cases' le_total n m with H H
  · exact dvd_sub H h₁ h₂
  · rw [tsub_eq_zero_iff_le.mpr H]
    exact dvd_zero k
#align nat.dvd_sub' Nat.dvd_sub'
-/

/- warning: nat.succ_div -> Nat.succ_div is a dubious translation:
lean 3 declaration is
  forall (a : Nat) (b : Nat), Eq.{1} Nat (HDiv.hDiv.{0, 0, 0} Nat Nat Nat (instHDiv.{0} Nat Nat.hasDiv) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) a (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) b) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HDiv.hDiv.{0, 0, 0} Nat Nat Nat (instHDiv.{0} Nat Nat.hasDiv) a b) (ite.{1} Nat (Dvd.Dvd.{0} Nat Nat.hasDvd b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) a (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (Nat.decidableDvd b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) a (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))) (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero)))))
but is expected to have type
  forall (a : Nat) (b : Nat), Eq.{1} Nat (HDiv.hDiv.{0, 0, 0} Nat Nat Nat (instHDiv.{0} Nat Nat.instDivNat) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) a (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) b) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HDiv.hDiv.{0, 0, 0} Nat Nat Nat (instHDiv.{0} Nat Nat.instDivNat) a b) (ite.{1} Nat (Dvd.dvd.{0} Nat Nat.instDvdNat b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) a (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (Nat.decidable_dvd b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) a (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)) (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0))))
Case conversion may be inaccurate. Consider using '#align nat.succ_div Nat.succ_divₓ'. -/
theorem succ_div : ∀ a b : ℕ, (a + 1) / b = a / b + if b ∣ a + 1 then 1 else 0
  | a, 0 => by simp
  | 0, 1 => by simp
  | 0, b + 2 => by
    have hb2 : b + 2 > 1 := by decide
    simp [ne_of_gt hb2, div_eq_of_lt hb2]
  | a + 1, b + 1 => by
    rw [Nat.div_eq]; conv_rhs => rw [Nat.div_eq]
    by_cases hb_eq_a : b = a + 1
    · simp [hb_eq_a, le_refl]
    by_cases hb_le_a1 : b ≤ a + 1
    · have hb_le_a : b ≤ a := le_of_lt_succ (lt_of_le_of_ne hb_le_a1 hb_eq_a)
      have h₁ : 0 < b + 1 ∧ b + 1 ≤ a + 1 + 1 := ⟨succ_pos _, (add_le_add_iff_right _).2 hb_le_a1⟩
      have h₂ : 0 < b + 1 ∧ b + 1 ≤ a + 1 := ⟨succ_pos _, (add_le_add_iff_right _).2 hb_le_a⟩
      have dvd_iff : b + 1 ∣ a - b + 1 ↔ b + 1 ∣ a + 1 + 1 := by
        rw [Nat.dvd_add_iff_left (dvd_refl (b + 1)), ← add_tsub_add_eq_tsub_right a 1 b,
          add_comm (_ - _), add_assoc, tsub_add_cancel_of_le (succ_le_succ hb_le_a), add_comm 1]
      have wf : a - b < a + 1 := lt_succ_of_le tsub_le_self
      rw [if_pos h₁, if_pos h₂, add_tsub_add_eq_tsub_right, ← tsub_add_eq_add_tsub hb_le_a,
        have := wf
        succ_div (a - b),
        add_tsub_add_eq_tsub_right]
      simp [dvd_iff, succ_eq_add_one, add_comm 1, add_assoc]
    · have hba : ¬b ≤ a := not_le_of_gt (lt_trans (lt_succ_self a) (lt_of_not_ge hb_le_a1))
      have hb_dvd_a : ¬b + 1 ∣ a + 2 := fun h =>
        hb_le_a1 (le_of_succ_le_succ (le_of_dvd (succ_pos _) h))
      simp [hba, hb_le_a1, hb_dvd_a]
#align nat.succ_div Nat.succ_div

#print Nat.succ_div_of_dvd /-
theorem succ_div_of_dvd {a b : ℕ} (hba : b ∣ a + 1) : (a + 1) / b = a / b + 1 := by
  rw [succ_div, if_pos hba]
#align nat.succ_div_of_dvd Nat.succ_div_of_dvd
-/

#print Nat.succ_div_of_not_dvd /-
theorem succ_div_of_not_dvd {a b : ℕ} (hba : ¬b ∣ a + 1) : (a + 1) / b = a / b := by
  rw [succ_div, if_neg hba, add_zero]
#align nat.succ_div_of_not_dvd Nat.succ_div_of_not_dvd
-/

#print Nat.dvd_iff_div_mul_eq /-
theorem dvd_iff_div_mul_eq (n d : ℕ) : d ∣ n ↔ n / d * d = n :=
  ⟨fun h => Nat.div_mul_cancel h, fun h => Dvd.intro_left (n / d) h⟩
#align nat.dvd_iff_div_mul_eq Nat.dvd_iff_div_mul_eq
-/

#print Nat.dvd_iff_le_div_mul /-
theorem dvd_iff_le_div_mul (n d : ℕ) : d ∣ n ↔ n ≤ n / d * d :=
  ((dvd_iff_div_mul_eq _ _).trans le_antisymm_iff).trans (and_iff_right (div_mul_le_self n d))
#align nat.dvd_iff_le_div_mul Nat.dvd_iff_le_div_mul
-/

#print Nat.dvd_iff_dvd_dvd /-
theorem dvd_iff_dvd_dvd (n d : ℕ) : d ∣ n ↔ ∀ k : ℕ, k ∣ d → k ∣ n :=
  ⟨fun h k hkd => dvd_trans hkd h, fun h => h _ dvd_rfl⟩
#align nat.dvd_iff_dvd_dvd Nat.dvd_iff_dvd_dvd
-/

#print Nat.dvd_div_of_mul_dvd /-
theorem dvd_div_of_mul_dvd {a b c : ℕ} (h : a * b ∣ c) : b ∣ c / a :=
  if ha : a = 0 then by simp [ha]
  else
    have ha : 0 < a := Nat.pos_of_ne_zero ha
    have h1 : ∃ d, c = a * b * d := h
    let ⟨d, hd⟩ := h1
    have h2 : c / a = b * d := Nat.div_eq_of_eq_mul_right ha (by simpa [mul_assoc] using hd)
    show ∃ d, c / a = b * d from ⟨d, h2⟩
#align nat.dvd_div_of_mul_dvd Nat.dvd_div_of_mul_dvd
-/

#print Nat.dvd_div_iff /-
@[simp]
theorem dvd_div_iff {a b c : ℕ} (hbc : c ∣ b) : a ∣ b / c ↔ c * a ∣ b :=
  ⟨fun h => mul_dvd_of_dvd_div hbc h, fun h => dvd_div_of_mul_dvd h⟩
#align nat.dvd_div_iff Nat.dvd_div_iff
-/

#print Nat.div_div_div_eq_div /-
@[simp]
theorem div_div_div_eq_div : ∀ {a b c : ℕ} (dvd : b ∣ a) (dvd2 : a ∣ c), c / (a / b) / b = c / a
  | 0, _ => by simp
  | a + 1, 0 => fun _ dvd _ => by simpa using dvd
  | a + 1, c + 1 =>
    have a_split : a + 1 ≠ 0 := succ_ne_zero a
    have c_split : c + 1 ≠ 0 := succ_ne_zero c
    fun b dvd dvd2 => by
    rcases dvd2 with ⟨k, rfl⟩
    rcases dvd with ⟨k2, pr⟩
    have k2_nonzero : k2 ≠ 0 := fun k2_zero => by simpa [k2_zero] using pr
    rw [Nat.mul_div_cancel_left k (Nat.pos_of_ne_zero a_split), pr,
      Nat.mul_div_cancel_left k2 (Nat.pos_of_ne_zero c_split), Nat.mul_comm ((c + 1) * k2) k, ←
      Nat.mul_assoc k (c + 1) k2, Nat.mul_div_cancel _ (Nat.pos_of_ne_zero k2_nonzero),
      Nat.mul_div_cancel _ (Nat.pos_of_ne_zero c_split)]
#align nat.div_div_div_eq_div Nat.div_div_div_eq_div
-/

#print Nat.eq_zero_of_dvd_of_lt /-
/-- If a small natural number is divisible by a larger natural number,
the small number is zero. -/
theorem eq_zero_of_dvd_of_lt {a b : ℕ} (w : a ∣ b) (h : b < a) : b = 0 :=
  Nat.eq_zero_of_dvd_of_div_eq_zero w ((Nat.div_eq_zero_iff (lt_of_le_of_lt (zero_le b) h)).right h)
#align nat.eq_zero_of_dvd_of_lt Nat.eq_zero_of_dvd_of_lt
-/

#print Nat.mod_div_self /-
@[simp]
theorem mod_div_self (m n : ℕ) : m % n / n = 0 :=
  by
  cases n
  · exact (m % 0).div_zero
  · exact Nat.div_eq_zero (m.mod_lt n.succ_pos)
#align nat.mod_div_self Nat.mod_div_self
-/

#print Nat.not_dvd_iff_between_consec_multiples /-
/-- `n` is not divisible by `a` iff it is between `a * k` and `a * (k + 1)` for some `k`. -/
theorem not_dvd_iff_between_consec_multiples (n : ℕ) {a : ℕ} (ha : 0 < a) :
    (∃ k : ℕ, a * k < n ∧ n < a * (k + 1)) ↔ ¬a ∣ n :=
  by
  refine'
    ⟨fun ⟨k, hk1, hk2⟩ => not_dvd_of_between_consec_multiples hk1 hk2, fun han =>
      ⟨n / a, ⟨lt_of_le_of_ne (mul_div_le n a) _, lt_mul_div_succ _ ha⟩⟩⟩
  exact mt (Dvd.intro (n / a)) han
#align nat.not_dvd_iff_between_consec_multiples Nat.not_dvd_iff_between_consec_multiples
-/

#print Nat.dvd_right_iff_eq /-
/-- Two natural numbers are equal if and only if they have the same multiples. -/
theorem dvd_right_iff_eq {m n : ℕ} : (∀ a : ℕ, m ∣ a ↔ n ∣ a) ↔ m = n :=
  ⟨fun h => dvd_antisymm ((h _).mpr dvd_rfl) ((h _).mp dvd_rfl), fun h n => by rw [h]⟩
#align nat.dvd_right_iff_eq Nat.dvd_right_iff_eq
-/

#print Nat.dvd_left_iff_eq /-
/-- Two natural numbers are equal if and only if they have the same divisors. -/
theorem dvd_left_iff_eq {m n : ℕ} : (∀ a : ℕ, a ∣ m ↔ a ∣ n) ↔ m = n :=
  ⟨fun h => dvd_antisymm ((h _).mp dvd_rfl) ((h _).mpr dvd_rfl), fun h n => by rw [h]⟩
#align nat.dvd_left_iff_eq Nat.dvd_left_iff_eq
-/

#print Nat.dvd_left_injective /-
/-- `dvd` is injective in the left argument -/
theorem dvd_left_injective : Function.Injective ((· ∣ ·) : ℕ → ℕ → Prop) := fun m n h =>
  dvd_right_iff_eq.mp fun a => iff_of_eq (congr_fun h a)
#align nat.dvd_left_injective Nat.dvd_left_injective
-/

#print Nat.div_lt_div_of_lt_of_dvd /-
theorem div_lt_div_of_lt_of_dvd {a b d : ℕ} (hdb : d ∣ b) (h : a < b) : a / d < b / d :=
  by
  rw [Nat.lt_div_iff_mul_lt hdb]
  exact lt_of_le_of_lt (mul_div_le a d) h
#align nat.div_lt_div_of_lt_of_dvd Nat.div_lt_div_of_lt_of_dvd
-/

end Nat