/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Monad encapsulating continuation passing programming style, similar to
Haskell's `Cont`, `ContT` and `MonadCont`:
<http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Cont.html>

! This file was ported from Lean 3 source module control.monad.cont
! leanprover-community/mathlib commit d6814c584384ddf2825ff038e868451a7c956f31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Control.Monad.Basic
import Mathbin.Control.Monad.Writer

universe u v w u₀ u₁ v₀ v₁

structure MonadCont.Label (α : Type w) (m : Type u → Type v) (β : Type u) where
  apply : α → m β
#align monad_cont.label MonadCont.Label

def MonadCont.goto {α β} {m : Type u → Type v} (f : MonadCont.Label α m β) (x : α) :=
  f.apply x
#align monad_cont.goto MonadCont.goto

class MonadCont (m : Type u → Type v) where
  callCc : ∀ {α β}, (MonadCont.Label α m β → m α) → m α
#align monad_cont MonadCont

open MonadCont

class IsLawfulMonadCont (m : Type u → Type v) [Monad m] [MonadCont m] extends LawfulMonad m where
  callCc_bind_right {α ω γ} (cmd : m α) (next : Label ω m γ → α → m ω) :
    (callCc fun f => cmd >>= next f) = cmd >>= fun x => callCc fun f => next f x
  callCc_bind_left {α} (β) (x : α) (dead : Label α m β → β → m α) :
    (callCc fun f : Label α m β => goto f x >>= dead f) = pure x
  callCc_dummy {α β} (dummy : m α) : (callCc fun f : Label α m β => dummy) = dummy
#align is_lawful_monad_cont IsLawfulMonadCont

export IsLawfulMonadCont ()

def ContT (r : Type u) (m : Type u → Type v) (α : Type w) :=
  (α → m r) → m r
#align cont_t ContT

@[reducible]
def Cont (r : Type u) (α : Type w) :=
  ContT r id α
#align cont Cont

namespace ContT

export MonadCont (Label goto)

variable {r : Type u} {m : Type u → Type v} {α β γ ω : Type w}

def run : ContT r m α → (α → m r) → m r :=
  id
#align cont_t.run ContT.run

def map (f : m r → m r) (x : ContT r m α) : ContT r m α :=
  f ∘ x
#align cont_t.map ContT.map

theorem run_contT_map_contT (f : m r → m r) (x : ContT r m α) : run (map f x) = f ∘ run x :=
  rfl
#align cont_t.run_cont_t_map_cont_t ContT.run_contT_map_contT

def withContT (f : (β → m r) → α → m r) (x : ContT r m α) : ContT r m β := fun g => x <| f g
#align cont_t.with_cont_t ContT.withContT

theorem run_withContT (f : (β → m r) → α → m r) (x : ContT r m α) :
    run (withContT f x) = run x ∘ f :=
  rfl
#align cont_t.run_with_cont_t ContT.run_withContT

@[ext]
protected theorem ext {x y : ContT r m α} (h : ∀ f, x.run f = y.run f) : x = y := by ext <;> apply h
#align cont_t.ext ContT.ext

instance : Monad (ContT r m) where
  pure α x f := f x
  bind α β x f g := x fun i => f i g

instance : LawfulMonad (ContT r m)
    where
  id_map := by
    intros
    rfl
  pure_bind := by
    intros
    ext
    rfl
  bind_assoc := by
    intros
    ext
    rfl

def monadLift [Monad m] {α} : m α → ContT r m α := fun x f => x >>= f
#align cont_t.monad_lift ContT.monadLift

instance [Monad m] : HasMonadLift m (ContT r m) where monadLift α := ContT.monadLift

theorem monadLift_bind [Monad m] [LawfulMonad m] {α β} (x : m α) (f : α → m β) :
    (monadLift (x >>= f) : ContT r m β) = monadLift x >>= monadLift ∘ f :=
  by
  ext
  simp only [monad_lift, HasMonadLift.monadLift, (· ∘ ·), (· >>= ·), bind_assoc, id.def, run,
    ContT.monadLift]
#align cont_t.monad_lift_bind ContT.monadLift_bind

instance : MonadCont (ContT r m) where callCc α β f g := f ⟨fun x h => g x⟩ g

instance : IsLawfulMonadCont (ContT r m)
    where
  callCc_bind_right := by intros <;> ext <;> rfl
  callCc_bind_left := by intros <;> ext <;> rfl
  callCc_dummy := by intros <;> ext <;> rfl

instance (ε) [MonadExcept ε m] : MonadExcept ε (ContT r m)
    where
  throw x e f := throw e
  catch α act h f := catch (act f) fun e => h e f

instance : MonadRun (fun α => (α → m r) → ULift.{u, v} (m r)) (ContT.{u, v, u} r m)
    where run α f x := ⟨f x⟩

end ContT

variable {m : Type u → Type v} [Monad m]

def ExceptT.mkLabel {α β ε} : Label (Except.{u, u} ε α) m β → Label α (ExceptT ε m) β
  | ⟨f⟩ => ⟨fun a => monadLift <| f (Except.ok a)⟩
#align except_t.mk_label ExceptTₓ.mkLabel

theorem ExceptT.goto_mkLabel {α β ε : Type _} (x : Label (Except.{u, u} ε α) m β) (i : α) :
    goto (ExceptT.mkLabel x) i = ⟨Except.ok <$> goto x (Except.ok i)⟩ := by cases x <;> rfl
#align except_t.goto_mk_label ExceptTₓ.goto_mkLabel

def ExceptT.callCc {ε} [MonadCont m] {α β : Type _} (f : Label α (ExceptT ε m) β → ExceptT ε m α) :
    ExceptT ε m α :=
  ExceptT.mk (callCc fun x : Label _ m β => ExceptT.run <| f (ExceptT.mkLabel x) : m (Except ε α))
#align except_t.call_cc ExceptTₓ.callCc

instance {ε} [MonadCont m] : MonadCont (ExceptT ε m) where callCc α β := ExceptT.callCc

instance {ε} [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (ExceptT ε m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, ExceptT.callCc, call_cc_bind_right]
    ext
    dsimp
    congr with ⟨⟩ <;> simp [ExceptT.bindCont, @call_cc_dummy m _]
  callCc_bind_left := by
    intros
    simp [call_cc, ExceptT.callCc, call_cc_bind_right, ExceptT.goto_mkLabel, map_eq_bind_pure_comp,
      bind_assoc, @call_cc_bind_left m _]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, ExceptT.callCc, @call_cc_dummy m _]
    ext
    rfl

def OptionT.mkLabel {α β} : Label (Option.{u} α) m β → Label α (OptionT m) β
  | ⟨f⟩ => ⟨fun a => monadLift <| f (some a)⟩
#align option_t.mk_label OptionTₓ.mkLabel

theorem OptionT.goto_mkLabel {α β : Type _} (x : Label (Option.{u} α) m β) (i : α) :
    goto (OptionT.mkLabel x) i = ⟨some <$> goto x (some i)⟩ := by cases x <;> rfl
#align option_t.goto_mk_label OptionTₓ.goto_mkLabel

def OptionT.callCc [MonadCont m] {α β : Type _} (f : Label α (OptionT m) β → OptionT m α) :
    OptionT m α :=
  OptionT.mk (callCc fun x : Label _ m β => OptionT.run <| f (OptionT.mkLabel x) : m (Option α))
#align option_t.call_cc OptionTₓ.callCc

instance [MonadCont m] : MonadCont (OptionT m) where callCc α β := OptionT.callCc

instance [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (OptionT m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, OptionT.callCc, call_cc_bind_right]
    ext
    dsimp
    congr with ⟨⟩ <;> simp [OptionT.bindCont, @call_cc_dummy m _]
  callCc_bind_left := by
    intros
    simp [call_cc, OptionT.callCc, call_cc_bind_right, OptionT.goto_mkLabel, map_eq_bind_pure_comp,
      bind_assoc, @call_cc_bind_left m _]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, OptionT.callCc, @call_cc_dummy m _]
    ext
    rfl

/- warning: writer_t.mk_label -> WriterTₓ.mkLabel is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] {α : Type.{u3}} {β : Type.{u1}} {ω : Type.{u1}} [_inst_2 : One.{u1} ω], (MonadCont.Label.{u1, u2, max u3 u1} (Prod.{u3, u1} α ω) m β) -> (MonadCont.Label.{u1, max u1 u2, u3} α (WriterTₓ.{u1, u2} ω m) β)
but is expected to have type
  forall {m : Type.{u2} -> Type.{u3}} [_inst_1 : Monad.{u2, u3} m] {α : Type.{u1}} {β : Type.{u2}} {ω : Type.{u2}} [_inst_2 : One.{u2} ω], (MonadCont.Label.{u2, u3, max u1 u2} (Prod.{u1, u2} α ω) m β) -> (MonadCont.Label.{u2, max u2 u3, u1} α (WriterTₓ.{u2, u3} ω m) β)
Case conversion may be inaccurate. Consider using '#align writer_t.mk_label WriterTₓ.mkLabelₓ'. -/
def WriterT.mkLabel {α β ω} [One ω] : Label (α × ω) m β → Label α (WriterT ω m) β
  | ⟨f⟩ => ⟨fun a => monadLift <| f (a, 1)⟩
#align writer_t.mk_label WriterTₓ.mkLabel

theorem WriterT.goto_mkLabel {α β ω : Type _} [One ω] (x : Label (α × ω) m β) (i : α) :
    goto (WriterT.mkLabel x) i = monadLift (goto x (i, 1)) := by cases x <;> rfl
#align writer_t.goto_mk_label WriterTₓ.goto_mkLabel

def WriterT.callCc [MonadCont m] {α β ω : Type _} [One ω]
    (f : Label α (WriterT ω m) β → WriterT ω m α) : WriterT ω m α :=
  ⟨callCc (WriterT.run ∘ f ∘ WriterT.mkLabel : Label (α × ω) m β → m (α × ω))⟩
#align writer_t.call_cc WriterTₓ.callCc

instance (ω) [Monad m] [One ω] [MonadCont m] : MonadCont (WriterT ω m)
    where callCc α β := WriterT.callCc

/- warning: state_t.mk_label -> StateTₓ.mkLabel is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] {α : Type.{u1}} {β : Type.{u1}} {σ : Type.{u1}}, (MonadCont.Label.{u1, u2, u1} (Prod.{u1, u1} α σ) m (Prod.{u1, u1} β σ)) -> (MonadCont.Label.{u1, max u1 u2, u1} α (StateTₓ.{u1, u2} σ m) β)
but is expected to have type
  forall {m : Type.{u1} -> Type.{u2}} {_inst_1 : Type.{u1}} {α : Type.{u1}} {β : Type.{u1}}, (MonadCont.Label.{u1, u2, u1} (Prod.{u1, u1} _inst_1 β) m (Prod.{u1, u1} α β)) -> (MonadCont.Label.{u1, max u1 u2, u1} _inst_1 (StateTₓ.{u1, u2} β m) α)
Case conversion may be inaccurate. Consider using '#align state_t.mk_label StateTₓ.mkLabelₓ'. -/
def StateT.mkLabel {α β σ : Type u} : Label (α × σ) m (β × σ) → Label α (StateT σ m) β
  | ⟨f⟩ => ⟨fun a => ⟨fun s => f (a, s)⟩⟩
#align state_t.mk_label StateTₓ.mkLabel

theorem StateT.goto_mkLabel {α β σ : Type u} (x : Label (α × σ) m (β × σ)) (i : α) :
    goto (StateT.mkLabel x) i = ⟨fun s => goto x (i, s)⟩ := by cases x <;> rfl
#align state_t.goto_mk_label StateTₓ.goto_mkLabel

def StateT.callCc {σ} [MonadCont m] {α β : Type _} (f : Label α (StateT σ m) β → StateT σ m α) :
    StateT σ m α :=
  ⟨fun r => callCc fun f' => (f <| StateT.mkLabel f').run r⟩
#align state_t.call_cc StateTₓ.callCc

instance {σ} [MonadCont m] : MonadCont (StateT σ m) where callCc α β := StateT.callCc

instance {σ} [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (StateT σ m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, StateT.callCc, call_cc_bind_right, (· >>= ·), StateT.bind]
    ext
    dsimp
    congr with ⟨x₀, x₁⟩
    rfl
  callCc_bind_left := by
    intros
    simp [call_cc, StateT.callCc, call_cc_bind_left, (· >>= ·), StateT.bind, StateT.goto_mkLabel]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, StateT.callCc, call_cc_bind_right, (· >>= ·), StateT.bind, @call_cc_dummy m _]
    ext
    rfl

/- warning: reader_t.mk_label -> ReaderTₓ.mkLabel is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] {α : Type.{u3}} {β : Type.{u1}} (ρ : Type.{u1}), (MonadCont.Label.{u1, u2, u3} α m β) -> (MonadCont.Label.{u1, max u1 u2, u3} α (ReaderTₓ.{u1, u2} ρ m) β)
but is expected to have type
  forall {m : Type.{u2} -> Type.{u3}} [_inst_1 : Monad.{u2, u3} m] {α : Type.{u1}} {β : Type.{u2}} (ρ : Type.{u2}), (MonadCont.Label.{u2, u3, u1} α m β) -> (MonadCont.Label.{u2, max u2 u3, u1} α (ReaderTₓ.{u2, u3} ρ m) β)
Case conversion may be inaccurate. Consider using '#align reader_t.mk_label ReaderTₓ.mkLabelₓ'. -/
def ReaderT.mkLabel {α β} (ρ) : Label α m β → Label α (ReaderT ρ m) β
  | ⟨f⟩ => ⟨monadLift ∘ f⟩
#align reader_t.mk_label ReaderTₓ.mkLabel

theorem ReaderT.goto_mkLabel {α ρ β} (x : Label α m β) (i : α) :
    goto (ReaderT.mkLabel ρ x) i = monadLift (goto x i) := by cases x <;> rfl
#align reader_t.goto_mk_label ReaderTₓ.goto_mkLabel

def ReaderT.callCc {ε} [MonadCont m] {α β : Type _} (f : Label α (ReaderT ε m) β → ReaderT ε m α) :
    ReaderT ε m α :=
  ⟨fun r => callCc fun f' => (f <| ReaderT.mkLabel _ f').run r⟩
#align reader_t.call_cc ReaderTₓ.callCc

instance {ρ} [MonadCont m] : MonadCont (ReaderT ρ m) where callCc α β := ReaderT.callCc

instance {ρ} [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (ReaderT ρ m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, ReaderT.callCc, call_cc_bind_right]
    ext
    rfl
  callCc_bind_left := by
    intros
    simp [call_cc, ReaderT.callCc, call_cc_bind_left, ReaderT.goto_mkLabel]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, ReaderT.callCc, @call_cc_dummy m _]
    ext
    rfl

/-- reduce the equivalence between two continuation passing monads to the equivalence between
their underlying monad -/
def ContT.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ r₁ : Type u₀}
    {α₂ r₂ : Type u₁} (F : m₁ r₁ ≃ m₂ r₂) (G : α₁ ≃ α₂) : ContT r₁ m₁ α₁ ≃ ContT r₂ m₂ α₂
    where
  toFun f r := F <| f fun x => F.symm <| r <| G x
  invFun f r := F.symm <| f fun x => F <| r <| G.symm x
  left_inv f := by funext r <;> simp
  right_inv f := by funext r <;> simp
#align cont_t.equiv ContT.equiv


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module category_theory.sites.subsheaf
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Elementwise
import Mathbin.CategoryTheory.Adjunction.Evaluation
import Mathbin.CategoryTheory.Sites.Sheafification

/-!

# Subsheaf of types

We define the sub(pre)sheaf of a type valued presheaf.

## Main results

- `category_theory.grothendieck_topology.subpresheaf` :
  A subpresheaf of a presheaf of types.
- `category_theory.grothendieck_topology.subpresheaf.sheafify` :
  The sheafification of a subpresheaf as a subpresheaf. Note that this is a sheaf only when the
  whole sheaf is.
- `category_theory.grothendieck_topology.subpresheaf.sheafify_is_sheaf` :
  The sheafification is a sheaf
- `category_theory.grothendieck_topology.subpresheaf.sheafify_lift` :
  The descent of a map into a sheaf to the sheafification.
- `category_theory.grothendieck_topology.image_sheaf` : The image sheaf of a morphism.
- `category_theory.grothendieck_topology.image_factorization` : The image sheaf as a
  `limits.image_factorization`.
-/

universe w v u

open Opposite CategoryTheory

namespace CategoryTheory.GrothendieckTopology

variable {C : Type u} [Category.{v} C] (J : GrothendieckTopology C)

/-- A subpresheaf of a presheaf consists of a subset of `F.obj U` for every `U`,
compatible with the restriction maps `F.map i`. -/
@[ext]
structure Subpresheaf (F : Cᵒᵖ ⥤ Type w) where
  obj : ∀ U, Set (F.obj U)
  map : ∀ {U V : Cᵒᵖ} (i : U ⟶ V), obj U ⊆ F.map i ⁻¹' obj V
#align category_theory.grothendieck_topology.subpresheaf CategoryTheory.GrothendieckTopology.Subpresheaf

variable {F F' F'' : Cᵒᵖ ⥤ Type w} (G G' : Subpresheaf F)

instance : PartialOrder (Subpresheaf F) :=
  PartialOrder.lift Subpresheaf.obj Subpresheaf.ext

instance : Top (Subpresheaf F) :=
  ⟨⟨fun U => ⊤, fun U V i x h => trivial⟩⟩

instance : Nonempty (Subpresheaf F) :=
  inferInstance

/-- The subpresheaf as a presheaf. -/
@[simps]
def Subpresheaf.toPresheaf : Cᵒᵖ ⥤ Type w
    where
  obj U := G.obj U
  map U V i x := ⟨F.map i x, G.map i x.Prop⟩
  map_id' X := by
    ext ⟨x, _⟩
    dsimp
    rw [F.map_id]
    rfl
  map_comp' X Y Z i j := by
    ext ⟨x, _⟩
    dsimp
    rw [F.map_comp]
    rfl
#align category_theory.grothendieck_topology.subpresheaf.to_presheaf CategoryTheory.GrothendieckTopology.Subpresheaf.toPresheaf

instance {U} : Coe (G.toPresheaf.obj U) (F.obj U) :=
  coeSubtype

/-- The inclusion of a subpresheaf to the original presheaf. -/
@[simps]
def Subpresheaf.ι : G.toPresheaf ⟶ F where app U x := x
#align category_theory.grothendieck_topology.subpresheaf.ι CategoryTheory.GrothendieckTopology.Subpresheaf.ι

instance : Mono G.ι :=
  ⟨fun H f₁ f₂ e =>
    NatTrans.ext f₁ f₂ <|
      funext fun U => funext fun x => Subtype.ext <| congr_fun (congr_app e U) x⟩

/-- The inclusion of a subpresheaf to a larger subpresheaf -/
@[simps]
def Subpresheaf.homOfLe {G G' : Subpresheaf F} (h : G ≤ G') : G.toPresheaf ⟶ G'.toPresheaf
    where app U x := ⟨x, h U x.Prop⟩
#align category_theory.grothendieck_topology.subpresheaf.hom_of_le CategoryTheory.GrothendieckTopology.Subpresheaf.homOfLe

instance {G G' : Subpresheaf F} (h : G ≤ G') : Mono (Subpresheaf.homOfLe h) :=
  ⟨fun H f₁ f₂ e =>
    NatTrans.ext f₁ f₂ <|
      funext fun U =>
        funext fun x =>
          Subtype.ext <| (congr_arg Subtype.val <| (congr_fun (congr_app e U) x : _) : _)⟩

@[simp, reassoc.1]
theorem Subpresheaf.homOfLe_ι {G G' : Subpresheaf F} (h : G ≤ G') :
    Subpresheaf.homOfLe h ≫ G'.ι = G.ι := by
  ext
  rfl
#align category_theory.grothendieck_topology.subpresheaf.hom_of_le_ι CategoryTheory.GrothendieckTopology.Subpresheaf.homOfLe_ι

instance : IsIso (Subpresheaf.ι (⊤ : Subpresheaf F)) :=
  by
  apply (config := { instances := false }) nat_iso.is_iso_of_is_iso_app
  · intro X
    rw [is_iso_iff_bijective]
    exact ⟨Subtype.coe_injective, fun x => ⟨⟨x, _root_.trivial⟩, rfl⟩⟩

theorem Subpresheaf.eq_top_iff_isIso : G = ⊤ ↔ IsIso G.ι :=
  by
  constructor
  · rintro rfl
    infer_instance
  · intro H
    ext (U x)
    apply (iff_true_iff _).mpr
    rw [← is_iso.inv_hom_id_apply (G.ι.app U) x]
    exact ((inv (G.ι.app U)) x).2
#align category_theory.grothendieck_topology.subpresheaf.eq_top_iff_is_iso CategoryTheory.GrothendieckTopology.Subpresheaf.eq_top_iff_isIso

/-- If the image of a morphism falls in a subpresheaf, then the morphism factors through it. -/
@[simps]
def Subpresheaf.lift (f : F' ⟶ F) (hf : ∀ U x, f.app U x ∈ G.obj U) : F' ⟶ G.toPresheaf
    where
  app U x := ⟨f.app U x, hf U x⟩
  naturality' := by
    have := elementwise_of f.naturality
    intros
    ext
    simp [this]
#align category_theory.grothendieck_topology.subpresheaf.lift CategoryTheory.GrothendieckTopology.Subpresheaf.lift

@[simp, reassoc.1]
theorem Subpresheaf.lift_ι (f : F' ⟶ F) (hf : ∀ U x, f.app U x ∈ G.obj U) : G.lift f hf ≫ G.ι = f :=
  by
  ext
  rfl
#align category_theory.grothendieck_topology.subpresheaf.lift_ι CategoryTheory.GrothendieckTopology.Subpresheaf.lift_ι

/-- Given a subpresheaf `G` of `F`, an `F`-section `s` on `U`, we may define a sieve of `U`
consisting of all `f : V ⟶ U` such that the restriction of `s` along `f` is in `G`. -/
@[simps]
def Subpresheaf.sieveOfSection {U : Cᵒᵖ} (s : F.obj U) : Sieve (unop U)
    where
  arrows V f := F.map f.op s ∈ G.obj (op V)
  downward_closed' V W i hi j :=
    by
    rw [op_comp, functor_to_types.map_comp_apply]
    exact G.map _ hi
#align category_theory.grothendieck_topology.subpresheaf.sieve_of_section CategoryTheory.GrothendieckTopology.Subpresheaf.sieveOfSection

/-- Given a `F`-section `s` on `U` and a subpresheaf `G`, we may define a family of elements in
`G` consisting of the restrictions of `s` -/
def Subpresheaf.familyOfElementsOfSection {U : Cᵒᵖ} (s : F.obj U) :
    (G.sieveOfSection s).1.FamilyOfElements G.toPresheaf := fun V i hi => ⟨F.map i.op s, hi⟩
#align category_theory.grothendieck_topology.subpresheaf.family_of_elements_of_section CategoryTheory.GrothendieckTopology.Subpresheaf.familyOfElementsOfSection

theorem Subpresheaf.family_of_elements_compatible {U : Cᵒᵖ} (s : F.obj U) :
    (G.familyOfElementsOfSection s).Compatible :=
  by
  intro Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ e
  ext1
  change F.map g₁.op (F.map f₁.op s) = F.map g₂.op (F.map f₂.op s)
  rw [← functor_to_types.map_comp_apply, ← functor_to_types.map_comp_apply, ← op_comp, ← op_comp, e]
#align category_theory.grothendieck_topology.subpresheaf.family_of_elements_compatible CategoryTheory.GrothendieckTopology.Subpresheaf.family_of_elements_compatible

theorem Subpresheaf.nat_trans_naturality (f : F' ⟶ G.toPresheaf) {U V : Cᵒᵖ} (i : U ⟶ V)
    (x : F'.obj U) : (f.app V (F'.map i x)).1 = F.map i (f.app U x).1 :=
  congr_arg Subtype.val (FunctorToTypes.naturality _ _ f i x)
#align category_theory.grothendieck_topology.subpresheaf.nat_trans_naturality CategoryTheory.GrothendieckTopology.Subpresheaf.nat_trans_naturality

include J

/-- The sheafification of a subpresheaf as a subpresheaf.
Note that this is a sheaf only when the whole presheaf is a sheaf. -/
def Subpresheaf.sheafify : Subpresheaf F
    where
  obj U := { s | G.sieveOfSection s ∈ J (unop U) }
  map := by
    rintro U V i s hs
    refine' J.superset_covering _ (J.pullback_stable i.unop hs)
    intro _ _ h
    dsimp at h⊢
    rwa [← functor_to_types.map_comp_apply]
#align category_theory.grothendieck_topology.subpresheaf.sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify

theorem Subpresheaf.le_sheafify : G ≤ G.sheafify J :=
  by
  intro U s hs
  change _ ∈ J _
  convert J.top_mem _
  rw [eq_top_iff]
  rintro V i -
  exact G.map i.op hs
#align category_theory.grothendieck_topology.subpresheaf.le_sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.le_sheafify

variable {J}

theorem Subpresheaf.eq_sheafify (h : Presieve.IsSheaf J F) (hG : Presieve.IsSheaf J G.toPresheaf) :
    G = G.sheafify J := by
  apply (G.le_sheafify J).antisymm
  intro U s hs
  suffices ((hG _ hs).amalgamate _ (G.family_of_elements_compatible s)).1 = s
    by
    rw [← this]
    exact ((hG _ hs).amalgamate _ (G.family_of_elements_compatible s)).2
  apply (h _ hs).IsSeparatedFor.ext
  intro V i hi
  exact (congr_arg Subtype.val ((hG _ hs).valid_glue (G.family_of_elements_compatible s) _ hi) : _)
#align category_theory.grothendieck_topology.subpresheaf.eq_sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.eq_sheafify

theorem Subpresheaf.sheafify_isSheaf (hF : Presieve.IsSheaf J F) :
    Presieve.IsSheaf J (G.sheafify J).toPresheaf :=
  by
  intro U S hS x hx
  let S' := sieve.bind S fun Y f hf => G.sieve_of_section (x f hf).1
  have := fun {V} {i : V ⟶ U} (hi : S' i) => hi
  choose W i₁ i₂ hi₂ h₁ h₂
  dsimp [-sieve.bind_apply] at *
  let x'' : presieve.family_of_elements F S' := fun V i hi => F.map (i₁ hi).op (x _ (hi₂ hi))
  have H : ∀ s, x.is_amalgamation s ↔ x''.is_amalgamation s.1 :=
    by
    intro s
    constructor
    · intro H V i hi
      dsimp only [x'']
      conv_lhs => rw [← h₂ hi]
      rw [← H _ (hi₂ hi)]
      exact functor_to_types.map_comp_apply F (i₂ hi).op (i₁ hi).op _
    · intro H V i hi
      ext1
      apply (hF _ (x i hi).2).IsSeparatedFor.ext
      intro V' i' hi'
      have hi'' : S' (i' ≫ i) := ⟨_, _, _, hi, hi', rfl⟩
      have := H _ hi''
      rw [op_comp, F.map_comp] at this
      refine' this.trans (congr_arg Subtype.val (hx _ _ (hi₂ hi'') hi (h₂ hi'')))
  have : x''.compatible := by
    intro V₁ V₂ V₃ g₁ g₂ g₃ g₄ S₁ S₂ e
    rw [← functor_to_types.map_comp_apply, ← functor_to_types.map_comp_apply]
    exact
      congr_arg Subtype.val
        (hx (g₁ ≫ i₁ S₁) (g₂ ≫ i₁ S₂) (hi₂ S₁) (hi₂ S₂) (by simp only [category.assoc, h₂, e]))
  obtain ⟨t, ht, ht'⟩ := hF _ (J.bind_covering hS fun V i hi => (x i hi).2) _ this
  refine' ⟨⟨t, _⟩, (H ⟨t, _⟩).mpr ht, fun y hy => Subtype.ext (ht' _ ((H _).mp hy))⟩
  show G.sieve_of_section t ∈ J _
  refine' J.superset_covering _ (J.bind_covering hS fun V i hi => (x i hi).2)
  intro V i hi
  dsimp
  rw [ht _ hi]
  exact h₁ hi
#align category_theory.grothendieck_topology.subpresheaf.sheafify_is_sheaf CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify_isSheaf

theorem Subpresheaf.eq_sheafify_iff (h : Presieve.IsSheaf J F) :
    G = G.sheafify J ↔ Presieve.IsSheaf J G.toPresheaf :=
  ⟨fun e => e.symm ▸ G.sheafify_isSheaf h, G.eq_sheafify h⟩
#align category_theory.grothendieck_topology.subpresheaf.eq_sheafify_iff CategoryTheory.GrothendieckTopology.Subpresheaf.eq_sheafify_iff

theorem Subpresheaf.isSheaf_iff (h : Presieve.IsSheaf J F) :
    Presieve.IsSheaf J G.toPresheaf ↔
      ∀ (U) (s : F.obj U), G.sieveOfSection s ∈ J (unop U) → s ∈ G.obj U :=
  by
  rw [← G.eq_sheafify_iff h]
  change _ ↔ G.sheafify J ≤ G
  exact ⟨Eq.ge, (G.le_sheafify J).antisymm⟩
#align category_theory.grothendieck_topology.subpresheaf.is_sheaf_iff CategoryTheory.GrothendieckTopology.Subpresheaf.isSheaf_iff

theorem Subpresheaf.sheafify_sheafify (h : Presieve.IsSheaf J F) :
    (G.sheafify J).sheafify J = G.sheafify J :=
  ((Subpresheaf.eq_sheafify_iff _ h).mpr <| G.sheafify_isSheaf h).symm
#align category_theory.grothendieck_topology.subpresheaf.sheafify_sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify_sheafify

/-- The lift of a presheaf morphism onto the sheafification subpresheaf.  -/
noncomputable def Subpresheaf.sheafifyLift (f : G.toPresheaf ⟶ F') (h : Presieve.IsSheaf J F') :
    (G.sheafify J).toPresheaf ⟶ F'
    where
  app U s := (h _ s.Prop).amalgamate _ ((G.family_of_elements_compatible ↑s).compPresheafMap f)
  naturality' := by
    intro U V i
    ext s
    apply (h _ ((subpresheaf.sheafify J G).toPresheaf.map i s).Prop).IsSeparatedFor.ext
    intro W j hj
    refine' (presieve.is_sheaf_for.valid_glue _ _ _ hj).trans _
    dsimp
    conv_rhs => rw [← functor_to_types.map_comp_apply]
    change _ = F'.map (j ≫ i.unop).op _
    refine' Eq.trans _ (presieve.is_sheaf_for.valid_glue _ _ _ _).symm
    · dsimp at hj⊢
      rwa [functor_to_types.map_comp_apply]
    · dsimp [presieve.family_of_elements.comp_presheaf_map]
      congr 1
      ext1
      exact (functor_to_types.map_comp_apply _ _ _ _).symm
#align category_theory.grothendieck_topology.subpresheaf.sheafify_lift CategoryTheory.GrothendieckTopology.Subpresheaf.sheafifyLift

theorem Subpresheaf.to_sheafifyLift (f : G.toPresheaf ⟶ F') (h : Presieve.IsSheaf J F') :
    Subpresheaf.homOfLe (G.le_sheafify J) ≫ G.sheafifyLift f h = f :=
  by
  ext (U s)
  apply (h _ ((subpresheaf.hom_of_le (G.le_sheafify J)).app U s).Prop).IsSeparatedFor.ext
  intro V i hi
  have := elementwise_of f.naturality
  exact (presieve.is_sheaf_for.valid_glue _ _ _ hi).trans (this _ _)
#align category_theory.grothendieck_topology.subpresheaf.to_sheafify_lift CategoryTheory.GrothendieckTopology.Subpresheaf.to_sheafifyLift

theorem Subpresheaf.to_sheafify_lift_unique (h : Presieve.IsSheaf J F')
    (l₁ l₂ : (G.sheafify J).toPresheaf ⟶ F')
    (e : Subpresheaf.homOfLe (G.le_sheafify J) ≫ l₁ = Subpresheaf.homOfLe (G.le_sheafify J) ≫ l₂) :
    l₁ = l₂ := by
  ext (U⟨s, hs⟩)
  apply (h _ hs).IsSeparatedFor.ext
  rintro V i hi
  dsimp at hi
  erw [← functor_to_types.naturality, ← functor_to_types.naturality]
  exact (congr_fun (congr_app e <| op V) ⟨_, hi⟩ : _)
#align category_theory.grothendieck_topology.subpresheaf.to_sheafify_lift_unique CategoryTheory.GrothendieckTopology.Subpresheaf.to_sheafify_lift_unique

theorem Subpresheaf.sheafify_le (h : G ≤ G') (hF : Presieve.IsSheaf J F)
    (hG' : Presieve.IsSheaf J G'.toPresheaf) : G.sheafify J ≤ G' :=
  by
  intro U x hx
  convert((G.sheafify_lift (subpresheaf.hom_of_le h) hG').app U ⟨x, hx⟩).2
  apply (hF _ hx).IsSeparatedFor.ext
  intro V i hi
  have :=
    congr_arg (fun f : G.to_presheaf ⟶ G'.to_presheaf => (nat_trans.app f (op V) ⟨_, hi⟩).1)
      (G.to_sheafify_lift (subpresheaf.hom_of_le h) hG')
  convert this.symm
  erw [← subpresheaf.nat_trans_naturality]
  rfl
#align category_theory.grothendieck_topology.subpresheaf.sheafify_le CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify_le

omit J

section Image

/-- The image presheaf of a morphism, whose components are the set-theoretic images. -/
@[simps]
def imagePresheaf (f : F' ⟶ F) : Subpresheaf F
    where
  obj U := Set.range (f.app U)
  map U V i := by
    rintro _ ⟨x, rfl⟩
    have := elementwise_of f.naturality
    exact ⟨_, this i x⟩
#align category_theory.grothendieck_topology.image_presheaf CategoryTheory.GrothendieckTopology.imagePresheaf

@[simp]
theorem top_subpresheaf_obj (U) : (⊤ : Subpresheaf F).obj U = ⊤ :=
  rfl
#align category_theory.grothendieck_topology.top_subpresheaf_obj CategoryTheory.GrothendieckTopology.top_subpresheaf_obj

@[simp]
theorem imagePresheaf_id : imagePresheaf (𝟙 F) = ⊤ :=
  by
  ext
  simp
#align category_theory.grothendieck_topology.image_presheaf_id CategoryTheory.GrothendieckTopology.imagePresheaf_id

/-- A morphism factors through the image presheaf. -/
@[simps]
def toImagePresheaf (f : F' ⟶ F) : F' ⟶ (imagePresheaf f).toPresheaf :=
  (imagePresheaf f).lift f fun U x => Set.mem_range_self _
#align category_theory.grothendieck_topology.to_image_presheaf CategoryTheory.GrothendieckTopology.toImagePresheaf

variable (J)

/-- A morphism factors through the sheafification of the image presheaf. -/
@[simps]
def toImagePresheafSheafify (f : F' ⟶ F) : F' ⟶ ((imagePresheaf f).sheafify J).toPresheaf :=
  toImagePresheaf f ≫ Subpresheaf.homOfLe ((imagePresheaf f).le_sheafify J)
#align category_theory.grothendieck_topology.to_image_presheaf_sheafify CategoryTheory.GrothendieckTopology.toImagePresheafSheafify

variable {J}

@[simp, reassoc.1]
theorem toImagePresheaf_ι (f : F' ⟶ F) : toImagePresheaf f ≫ (imagePresheaf f).ι = f :=
  (imagePresheaf f).lift_ι _ _
#align category_theory.grothendieck_topology.to_image_presheaf_ι CategoryTheory.GrothendieckTopology.toImagePresheaf_ι

theorem imagePresheaf_comp_le (f₁ : F ⟶ F') (f₂ : F' ⟶ F'') :
    imagePresheaf (f₁ ≫ f₂) ≤ imagePresheaf f₂ := fun U x hx => ⟨f₁.app U hx.some, hx.choose_spec⟩
#align category_theory.grothendieck_topology.image_presheaf_comp_le CategoryTheory.GrothendieckTopology.imagePresheaf_comp_le

instance {F F' : Cᵒᵖ ⥤ Type max v w} (f : F ⟶ F') [hf : Mono f] : IsIso (toImagePresheaf f) :=
  by
  apply (config := { instances := false }) nat_iso.is_iso_of_is_iso_app
  intro X
  rw [is_iso_iff_bijective]
  constructor
  · intro x y e
    have := (nat_trans.mono_iff_mono_app _ _).mp hf X
    rw [mono_iff_injective] at this
    exact this (congr_arg Subtype.val e : _)
  · rintro ⟨_, ⟨x, rfl⟩⟩
    exact ⟨x, rfl⟩

/-- The image sheaf of a morphism between sheaves, defined to be the sheafification of
`image_presheaf`. -/
@[simps]
def imageSheaf {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Sheaf J (Type w) :=
  ⟨((imagePresheaf f.1).sheafify J).toPresheaf,
    by
    rw [is_sheaf_iff_is_sheaf_of_type]
    apply subpresheaf.sheafify_is_sheaf
    rw [← is_sheaf_iff_is_sheaf_of_type]
    exact F'.2⟩
#align category_theory.grothendieck_topology.image_sheaf CategoryTheory.GrothendieckTopology.imageSheaf

/-- A morphism factors through the image sheaf. -/
@[simps]
def toImageSheaf {F F' : Sheaf J (Type w)} (f : F ⟶ F') : F ⟶ imageSheaf f :=
  ⟨toImagePresheafSheafify J f.1⟩
#align category_theory.grothendieck_topology.to_image_sheaf CategoryTheory.GrothendieckTopology.toImageSheaf

/-- The inclusion of the image sheaf to the target. -/
@[simps]
def imageSheafι {F F' : Sheaf J (Type w)} (f : F ⟶ F') : imageSheaf f ⟶ F' :=
  ⟨Subpresheaf.ι _⟩
#align category_theory.grothendieck_topology.image_sheaf_ι CategoryTheory.GrothendieckTopology.imageSheafι

@[simp, reassoc.1]
theorem toImageSheaf_ι {F F' : Sheaf J (Type w)} (f : F ⟶ F') :
    toImageSheaf f ≫ imageSheafι f = f := by
  ext1
  simp [to_image_presheaf_sheafify]
#align category_theory.grothendieck_topology.to_image_sheaf_ι CategoryTheory.GrothendieckTopology.toImageSheaf_ι

instance {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Mono (imageSheafι f) :=
  (sheafToPresheaf J _).mono_of_mono_map
    (by
      dsimp
      infer_instance)

instance {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Epi (toImageSheaf f) :=
  by
  refine' ⟨fun G' g₁ g₂ e => _⟩
  ext (U⟨s, hx⟩)
  apply ((is_sheaf_iff_is_sheaf_of_type J _).mp G'.2 _ hx).IsSeparatedFor.ext
  rintro V i ⟨y, e'⟩
  change (g₁.val.app _ ≫ G'.val.map _) _ = (g₂.val.app _ ≫ G'.val.map _) _
  rw [← nat_trans.naturality, ← nat_trans.naturality]
  have E : (to_image_sheaf f).val.app (op V) y = (image_sheaf f).val.map i.op ⟨s, hx⟩ :=
    Subtype.ext e'
  have := congr_arg (fun f : F ⟶ G' => (Sheaf.hom.val f).app _ y) e
  dsimp at this⊢
  convert this <;> exact E.symm

/-- The mono factorization given by `image_sheaf` for a morphism. -/
def imageMonoFactorization {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Limits.MonoFactorisation f
    where
  i := imageSheaf f
  m := imageSheafι f
  e := toImageSheaf f
#align category_theory.grothendieck_topology.image_mono_factorization CategoryTheory.GrothendieckTopology.imageMonoFactorization

/-- The mono factorization given by `image_sheaf` for a morphism is an image. -/
noncomputable def imageFactorization {F F' : Sheaf J (Type max v u)} (f : F ⟶ F') :
    Limits.ImageFactorisation f where
  f := imageMonoFactorization f
  IsImage :=
    { lift := fun I =>
        by
        haveI := (Sheaf.hom.mono_iff_presheaf_mono J _ _).mp I.m_mono
        refine' ⟨subpresheaf.hom_of_le _ ≫ inv (to_image_presheaf I.m.1)⟩
        apply subpresheaf.sheafify_le
        · conv_lhs => rw [← I.fac]
          apply image_presheaf_comp_le
        · rw [← is_sheaf_iff_is_sheaf_of_type]
          exact F'.2
        · apply presieve.is_sheaf_iso J (as_iso <| to_image_presheaf I.m.1)
          rw [← is_sheaf_iff_is_sheaf_of_type]
          exact I.I.2
      lift_fac := fun I => by
        ext1
        dsimp [image_mono_factorization]
        generalize_proofs h
        rw [← subpresheaf.hom_of_le_ι h, category.assoc]
        congr 1
        rw [is_iso.inv_comp_eq, to_image_presheaf_ι] }
#align category_theory.grothendieck_topology.image_factorization CategoryTheory.GrothendieckTopology.imageFactorization

instance : Limits.HasImages (Sheaf J (Type max v u)) :=
  ⟨fun _ _ f => ⟨⟨imageFactorization f⟩⟩⟩

end Image

end CategoryTheory.GrothendieckTopology


import basic hp.core.source

/-! System for assigning labels to things.
Labels are chosen from hard-coded sets of letters.
Which set is used depends on the type of the thing being labelled.
So for example a group element should be labelled with `g`, `h` etc
but a point in a metric space should be labelled with `x`, `y` etc.

[todo] Allow adding new suggested name lists with attributes.
[todo] I think that a lot of non-humanproof tactics would benefit (in terms of user-friendliness) from
using this kind of labelling system. Perhaps there is some way it can be integrated with Lean.

# Labelling pools

A labelling pool is a dictionary `string ⇀ list string` sending a key string to a set of possible labels.
A labeller is defined by three pools:
- Class pool: sending names of classes `𝒞` to labels for types `α` that are instances of `𝒞`.
  For example a type `_ : Type` implementing `group _` should be labelled `G`.
  If a class has multiple arguments, the first argument is always bound to.
- Element pool: Suppose we have `α : Type` and `[𝒞 α]` for some typeclass `𝒞`, then the element pool contains labels for the elements of `α`.
  For example, `{G : Type} [group G]` causes `_ : G` to be labelled `g` or `h`. While `[metric_space X]` will be labelled `x y : X`
- Type pool: takes the function constant name of a type as the key and returns element names for that type.
  Eg terms of type `set α` will be labelled `A`, `B` etc.

-/
namespace hp

meta def labeller.pool := listdict string string

@[derive_setters]
meta structure labeller :=
-- class pool
(cp : labeller.pool)
-- element pool
(ep : labeller.pool)
-- type pool
(tp : labeller.pool)
(in_play : table name)
(counts : dictd string nat)

namespace labeller

meta instance : has_mem name labeller := ⟨λ n l, n ∈ l.in_play⟩
meta instance {n} {l : labeller} : decidable (n ∈ l) := by apply_instance

/- [todo] user attribute that allows users to add their own  -/

meta def default_labels := ["x", "y", "z", "v", "w", "a", "b", "c"]

meta def default_class_pool : pool :=
listdict.of [
  ("category", ["C", "D", "E"]),
  ("group", ["G", "H"]),
  -- ("point", ["x", "y", "z", "v", "w", "a", "b", "c"]),
  ("has_mem", ["a", "b", "c", "x", "y", "z", "u", "v", "w", "p", "q", "r", "s", "t"]),
  ("metric_space" , ["X", "Y", "Z"])
]

meta def default_element_pool : pool :=
listdict.of [ ("category", ["X","Y","Z"])
            , ("group", ["g", "h", "a", "b", "c", "x", "y", "z"]) ]

/-- pool for converting the head const of the type of an expression to its label -/
meta def default_type_pool : pool :=
listdict.of [ ("", ["x", "y", "z", "a", "b", "c"]) -- default
            , ("→", ["f", "g", "h"])
            , ("sequence" , ["κ", "σ", "τ"])
            , ("set", ["A", "B", "C", "D", "E", "X", "Y", "Z", "U", "V", "W", "P", "Q", "R", "S", "T"])
            , ("fin", ["i", "j", "k", "r", "s", "t"])
            , ("nat", ["n", "m", "p", "q", "i", "j", "r", "t"])
            , ("hom", ["f", "g", "h", "k", "l", "q", "r", "s", "t", "u", "v", "w"])
            -- , ("real", ["x", "y", "z"])
            , ("real", ["ε", "δ", "η", "ζ", "θ", "α", "β", "γ", "ω"])
            , ("Type", ["α", "β", "γ", "δ", "ε"])
            , ("Prop", ["P", "Q", "R"])
]

meta instance : inhabited labeller :=
⟨{ in_play := ∅
, counts := dictd.empty (λ _, 0)
, cp := default_class_pool
, tp := default_type_pool
, ep := default_element_pool
}⟩

meta def to_subscript_digit : nat → string
| 0 := "₀" | 1 := "₁" | 2 := "₂" | 3 := "₃" | 4 := "₄" | 5 := "₅" | 6 := "₆" | 7 := "₇" | 8 := "₈" | 9 := "₉"
| n := "♘"

meta def to_digits_rev : nat → list nat
| 0 := []
| n := (n % 10) :: to_digits_rev (n / 10)

meta def to_subscript : nat → string
| 0 := "₀"
| n := string.join $ list.map to_subscript_digit $ list.reverse $ to_digits_rev $ n

/- Here are the rules for looking up potential label names for a given expression (x : α).
- if `α = f ..xs`, look up `f.last` in `type_pool`
- if `α = Type`, look up "Type" in `type_pool`
- if `α = Prop`, look up "Prop" in `type_pool`
- if `α = expr.pi _ _ _ _`, look up "→" in `type_pool`,
- if `[C α]` for some class `C`, look up `C` in `element_pool`.
- if `[C x]` for some class `C`, look up `C` in `class_pool`.
  Also note that `[C x]` might not be in context yet, so might need to be clever with when labelling occurs.

 -/

variables {m : Type → Type} [monad m] [monad_state labeller m] [has_monad_lift tactic m] {α β : Type}

meta def get_fn_name : expr → string
| (expr.app f _) := get_fn_name f
| (expr.pi _ _ _ _) := "→"
| (expr.sort level.zero) := "Prop"
| (expr.sort _) := "Type"
| (expr.const n _) := n.last
| _ := "none"

meta def is_in_play : name → m bool | n:= do
  labs ← get,
  pure $ n ∈ in_play labs

meta def push_label : name → m unit | n := do
  modify $ labeller.modify_in_play $ insert n

meta def trace_label_state : m unit := do
  labs ← get,
  trace (to_string $ labs.in_play) (pure ()),
  pure ()

meta def select_label : list string → m name
| [] := ⍐ $ tactic.fail "need to select from at least one label"
| ss := do
  labs ← get,

  unused ← pure $ ss.find ((∉ labs) ∘ mk_simple_name),
  match unused with
  | (some h) := do
    n ← pure $ mk_simple_name h,
    push_label n,
    pure n
  | none := do
    ss ← pure $ ss.map (λ x, (x, labs.counts.get x)),
    some (base, i) ← pure $ ss.min_by (int.of_nat ∘ prod.snd),
    n ← pure $ mk_simple_name $ base ++ to_subscript i,
    modify $ labeller.modify_counts $ λ cs, cs.modify (+ 1) base,
    push_label n,
    pure n
  end

meta def label_intro (is_src : bool) : binder → cotelescope → m name
| ⟨n,bi,y⟩ rest := do
  y ← ⍐ $ tactic.instantiate_mvars $ y,
  labs ← get,
  ip ← ⍐ $ tactic.is_prop y,
  if ip then do
    -- if it's a Prop, then make it an H or a T.
    base ← pure $ if is_src then "H" else "T",
    select_label [base]
  else if n ≠ name.anonymous ∧ n ∉ labs then do
    -- if the binder name is not anon and is not in the labeller
    -- then register it as a label and return it.
    push_label n,
    pure n
  else do
    -- instantiate the rest of the cotelescope with a local.
    rest ← pure $ assignable.instantiate_var rest $ expr.local_const n n bi y,

    cls ← pure $ rest.collect $ λ b,
      match b with
      | ⟨_, binder_info.inst_implicit, expr.app (expr.const f _) (expr.local_const un _ _ _)⟩ :=
        if un = n then labs.cp.get f.last else []
      | _ := []
      end,
    -- cs are the typeclasses that the type belongs to
    cs ← ⍐ $ tactic.get_classes y,

    els ← pure $ cs.collect $ λ c, labs.ep.get c.last,
    -- ⍐ $ tactic.trace $ get_fn_name y,
    tls ← pure $ labs.tp.get $ get_fn_name y,
    ns ← pure $ cls ++ els ++ tls,
    ns ← pure $ if ns.empty then default_labels else ns,
    -- ⍐ $ tactic.trace $ ("selecting from names: ", ns),
    select_label ns

meta def label (p: pool) : expr → tactic (list string)
| T := do
  cs ← tactic.get_classes T,
  ts : string ← pure $ match expr.app_fn T with
        | (expr.const f _) := f.head
        | (expr.pi _ _ _ _) := "→"
        | _ := "none"
        end,
  ls ← pure $ cs.collect $ λ c, p.get c.head,
  pure $ match ls with
        | [] := p.get ""
        | ls := ls
        end

-- meta def get_fresh_label (ls : labeller) (type : string) (parent : name) : id (labeller × name) := do
--   -- [todo] also check the local_context.
--   if ¬(name.is_private parent ∨ parent = name.anonymous ∨ table.contains parent ls.in_play) then pure (ls, parent) else do
--   base ← pure $ match parent with
--   | name.anonymous := ""
--   | name.mk_numeral i n := ""
--   | name.mk_string  s n := s
--   end,
--   pool ← pure $ ls.pools.get base,
--   pool ← pure $ if pool.empty then ls.pools.get "" else pool,

--   ls ← pure $ { labeller .
--     in_play := ls.in_play.insert n,
--     counts := ls.counts.modify (+ 1) base,
--     ..ls
--   },
--   pure (ls, n)

open tactic.unsafe

meta def rename_meta : expr → m expr
| m@(expr.mvar un pn _):= do
  -- ⍐ tactic.trace_state,
  y ← ⍐ $ tactic.infer_type m >>= tactic.instantiate_mvars,
  b ← pure $ binder.mk name.anonymous binder_info.default y,
  label ← label_intro ff b [],
  -- ⍐ $ tactic.trace ("rename_meta", un, y, label),
  -- [todo] check if pn is sensible or something like `_mvar_.....`
  ⍐ $ type_context.run $ do
    -- pure (ls, mvar)
    lctx ← type_context.get_context m,
    g ← type_context.mk_mvar label y lctx,
    type_context.assign m g,
    pure g
| _ := ⍐ $ tactic.fail "not an mvar"

meta def type_to_label_type_key : expr → tactic string
| e := pure $ expr.to_string e -- [todo]

-- meta def rename_meta (ls : labeller) (mvar : expr) (parent : name := name.anonymous) : tactic (labeller × expr) := do
--   y ← tactic.infer_type mvar,
--   ip ← tactic.is_prop y,
--   if ip then rename_meta_core ls "target" parent mvar else do
--   type ← type_to_label_type_key y,
--   rename_meta_core ls type parent mvar

-- meta def get_fresh_binder_label (ls : labeller) : binder → tactic (labeller × binder)
-- | ⟨n,bi,y⟩ := do
--   ys ← type_to_label_type_key y,
--   (ls, n) ← pure $ get_fresh_label ls ys n,
--   pure (ls, ⟨n,bi,y⟩)

meta def label_cotelescope : cotelescope → m cotelescope
| [] := pure []
| (b :: rest) := do
  n ← label_intro tt b rest,
  -- ⍐ $ tactic.trace ("relabel", b, n),
  b ← pure $ {name := n, ..b},
  l ← ⍐ $ binder.mk_local b,
  rest ← pure $ @assignable.instantiate_var cotelescope (cotelescope.assignable) rest l,
  -- ⍐ $ tactic.trace (rest.reverse),
  rest ← label_cotelescope (rest),
  rest ← pure $ assignable.abstract_local rest l.local_uniq_name,
  -- ⍐ $ tactic.trace (rest.reverse),
  pure $ b :: rest

meta def label_telescope : telescope → m telescope :=
(pure ∘ list.reverse) >=> label_cotelescope >=> (pure ∘ list.reverse)

meta def free_label  (n : name) : m unit := do
  ls ← get,
  -- put $ ls.modify_in_play (dict.erase n),
  pure ()

meta def relabel_source : source → m source
| src := do
  l ← label_intro tt ⟨src.label, binder_info.default, src.type⟩ [],
  pure {label := l, ..src}

end labeller

end hp


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

General utility functions for buffers.
-/
import data.array.lemmas
import control.traversable.instances

namespace buffer

open function

variables {α : Type*} {xs : list α}

instance : inhabited (buffer α) := ⟨nil⟩

@[ext]
lemma ext : ∀ {b₁ b₂ : buffer α}, to_list b₁ = to_list b₂ → b₁ = b₂
| ⟨n₁, a₁⟩ ⟨n₂, a₂⟩ h := begin
  simp [to_list, to_array] at h,
  have e : n₁ = n₂ :=
    by rw [←array.to_list_length a₁, ←array.to_list_length a₂, h],
  subst e,
  have h : a₁ == a₂.to_list.to_array := h ▸ a₁.to_list_to_array.symm,
  rw eq_of_heq (h.trans a₂.to_list_to_array)
end

lemma ext_iff {b₁ b₂ : buffer α} : b₁ = b₂ ↔ to_list b₁ = to_list b₂ :=
⟨λ h, h ▸ rfl, ext⟩

lemma size_eq_zero_iff {b : buffer α} : b.size = 0 ↔ b = nil :=
begin
  rcases b with ⟨_|n, ⟨a⟩⟩,
  { simp only [size, nil, mk_buffer, true_and, true_iff, eq_self_iff_true, heq_iff_eq,
               sigma.mk.inj_iff],
    ext i,
    exact fin.elim0 i },
  { simp [size, nil, mk_buffer, nat.succ_ne_zero] }
end

@[simp] lemma size_nil : (@nil α).size = 0 :=
by rw size_eq_zero_iff

@[simp] lemma to_list_nil : to_list (@nil α) = [] := rfl

instance (α) [decidable_eq α] : decidable_eq (buffer α) :=
by tactic.mk_dec_eq_instance

@[simp]
lemma to_list_append_list {b : buffer α} :
  to_list (append_list b xs) = to_list b ++ xs :=
by induction xs generalizing b; simp! [*]; cases b; simp! [to_list,to_array]

@[simp]
lemma append_list_mk_buffer  :
  append_list mk_buffer xs = array.to_buffer (list.to_array xs) :=
by ext x : 1; simp [array.to_buffer,to_list,to_list_append_list];
   induction xs; [refl,skip]; simp [to_array]; refl

@[simp] lemma to_buffer_to_list (b : buffer α) : b.to_list.to_buffer = b :=
begin
  cases b,
  rw [to_list, to_array, list.to_buffer, append_list_mk_buffer],
  congr,
  { simpa },
  { apply array.to_list_to_array }
end

@[simp] lemma to_list_to_buffer (l : list α) : l.to_buffer.to_list = l :=
begin
  cases l,
  { refl },
  { rw [list.to_buffer, to_list_append_list],
    refl }
end

@[simp] lemma to_list_to_array (b : buffer α) : b.to_array.to_list = b.to_list :=
by { cases b, simp [to_list] }

@[simp] lemma append_list_nil (b : buffer α) : b.append_list [] = b := rfl

lemma to_buffer_cons (c : α) (l : list α) :
  (c :: l).to_buffer = [c].to_buffer.append_list l :=
begin
  induction l with hd tl hl,
  { simp },
  { apply ext,
    simp [hl] }
end

@[simp] lemma size_push_back (b : buffer α) (a : α) : (b.push_back a).size = b.size + 1 :=
by { cases b, simp [size, push_back] }

@[simp] lemma size_append_list (b : buffer α) (l : list α) :
  (b.append_list l).size = b.size + l.length :=
begin
  induction l with hd tl hl generalizing b,
  { simp },
  { simp [append_list, hl, add_comm, add_assoc] }
end

@[simp] lemma size_to_buffer (l : list α) : l.to_buffer.size = l.length :=
begin
  induction l with hd tl hl,
  { simpa },
  { rw [to_buffer_cons],
    have : [hd].to_buffer.size = 1 := rfl,
    simp [add_comm, this] }
end

@[simp] lemma length_to_list (b : buffer α) : b.to_list.length = b.size :=
by rw [←to_buffer_to_list b, to_list_to_buffer, size_to_buffer]

lemma size_singleton (a : α) : [a].to_buffer.size = 1 := rfl

lemma read_push_back_left (b : buffer α) (a : α) {i : ℕ} (h : i < b.size) :
  (b.push_back a).read ⟨i, by { convert nat.lt_succ_of_lt h, simp }⟩ = b.read ⟨i, h⟩ :=
by { cases b, convert array.read_push_back_left _, simp }

@[simp] lemma read_push_back_right (b : buffer α) (a : α) :
  (b.push_back a).read ⟨b.size, by simp⟩ = a :=
by { cases b, convert array.read_push_back_right }

lemma read_append_list_left' (b : buffer α) (l : list α) {i : ℕ}
  (h : i < (b.append_list l).size) (h' : i < b.size) :
  (b.append_list l).read ⟨i, h⟩ = b.read ⟨i, h'⟩ :=
begin
  induction l with hd tl hl generalizing b,
  { refl },
  { have hb : i < ((b.push_back hd).append_list tl).size := by convert h using 1,
    have hb' : i < (b.push_back hd).size := by { convert nat.lt_succ_of_lt h', simp },
    have : (append_list b (hd :: tl)).read ⟨i, h⟩ =
      read ((push_back b hd).append_list tl) ⟨i, hb⟩ := rfl,
    simp [this, hl _ hb hb', read_push_back_left _ _ h'] }
end

lemma read_append_list_left (b : buffer α) (l : list α) {i : ℕ} (h : i < b.size) :
  (b.append_list l).read ⟨i, by simpa using nat.lt_add_right _ _ _ h⟩ = b.read ⟨i, h⟩ :=
read_append_list_left' b l _ h

@[simp] lemma read_append_list_right (b : buffer α) (l : list α) {i : ℕ} (h : i < l.length) :
  (b.append_list l).read ⟨b.size + i, by simp [h]⟩ = l.nth_le i h :=
begin
  induction l with hd tl hl generalizing b i,
  { exact absurd i.zero_le (not_le_of_lt h) },
  { convert_to ((b.push_back hd).append_list tl).read _ = _,
    cases i,
    { convert read_append_list_left _ _ _;
      simp },
    { rw [list.length, nat.succ_lt_succ_iff] at h,
      have : b.size + i.succ = (b.push_back hd).size + i,
        { simp [add_comm, add_left_comm, nat.succ_eq_add_one] },
      convert hl (b.push_back hd) h using 1,
      simpa [nat.add_succ, nat.succ_add] } }
end

lemma read_to_buffer' (l : list α) {i : ℕ} (h : i < l.to_buffer.size) (h' : i < l.length) :
  l.to_buffer.read ⟨i, h⟩ = l.nth_le i h' :=
begin
  cases l with hd tl,
  { simpa using h' },
  { have hi : i < ([hd].to_buffer.append_list tl).size := by simpa [add_comm] using h,
    convert_to ([hd].to_buffer.append_list tl).read ⟨i, hi⟩ = _,
    cases i,
    { convert read_append_list_left _ _ _,
      simp },
    { rw list.nth_le,
      convert read_append_list_right _ _ _,
      simp [nat.succ_eq_add_one, add_comm] } }
end

@[simp] lemma read_to_buffer (l : list α) (i) :
  l.to_buffer.read i = l.nth_le i (by { convert i.property, simp }) :=
by { convert read_to_buffer' _ _ _, { simp }, { simpa using i.property } }

lemma nth_le_to_list' (b : buffer α) {i : ℕ} (h h') :
  b.to_list.nth_le i h = b.read ⟨i, h'⟩ :=
begin
  have : b.to_list.to_buffer.read ⟨i, (by simpa using h')⟩ = b.read ⟨i, h'⟩,
  { congr' 1; simp [fin.heq_ext_iff] },
  simp [←this]
end

lemma nth_le_to_list (b : buffer α) {i : ℕ} (h) :
  b.to_list.nth_le i h = b.read ⟨i, by simpa using h⟩ :=
nth_le_to_list' _ _ _

lemma read_eq_nth_le_to_list (b : buffer α) (i) :
  b.read i = b.to_list.nth_le i (by simp) :=
by simp [nth_le_to_list]

lemma read_singleton (c : α) : [c].to_buffer.read ⟨0, by simp⟩ = c :=
by simp

/-- The natural equivalence between lists and buffers, using
`list.to_buffer` and `buffer.to_list`. -/
def list_equiv_buffer (α : Type*) : list α ≃ buffer α :=
begin
  refine { to_fun := list.to_buffer, inv_fun := buffer.to_list, .. };
  simp [left_inverse,function.right_inverse]
end

instance : traversable buffer :=
equiv.traversable list_equiv_buffer

instance : is_lawful_traversable buffer :=
equiv.is_lawful_traversable list_equiv_buffer

/--
A convenience wrapper around `read` that just fails if the index is out of bounds.
-/
meta def read_t (b : buffer α) (i : ℕ) : tactic α :=
if h : i < b.size then return $ b.read (fin.mk i h)
else tactic.fail "invalid buffer access"

end buffer


import tactic

-- Если вы не работали с монадами и do-блоками раньше, почитайте туториал в интернете
-- `tactic α` - функция, работающие в контексте состояния тактики и возвращает α
-- `tactic unit` - ничего не возвращает (или же возвращает `()`)

open tactic

meta def make_nat : tactic ℕ :=
return 42

-- Как использовать результат работы других тактик внутри do-блока?
-- n ← make_nat

meta def trace_nat : tactic unit :=
do
  n ← make_nat,
  tactic.trace n

-- Как дебагать тактики?
example : false :=
begin
  trace_nat,
  sorry,
end

run_cmd trace_nat

-- Как работать с окружением в тактике?
-- Для первой цели есть функция tactic.target
#check tactic.target

meta def show_goal : tactic unit :=
do
  t ← target,
  trace t
  -- trace $ expr.to_raw_fmt t покажет полную структуру, не pretty printed

example (a b : ℤ) : a^2 + b^2 ≥ 0 :=
begin
  show_goal,
  sorry,
end

-- Для локальных гипотез: функции get_local и local_context
#check get_local
#check tactic.local_context
#check infer_type

meta def inspect_local_one (nm : name) : tactic unit :=
do
  a ← get_local nm,
  trace a,
  trace (expr.to_raw_fmt a),
  a_type ← infer_type a,
  trace a_type,
  trace (expr.to_raw_fmt a_type)

example (A : Type) (b c : A) (h : b = c) : false :=
begin
  inspect_local_one `A,
  inspect_local_one `h,
  sorry,
end

-- Для монадического программирования есть много (хоть и не так богато, как в Haskell) функций
#check list.mmap

meta def inspect_all : tactic unit :=
do
  ctx ← local_context,
  trace ctx,
  ctx_types ← list.mmap (infer_type) ctx,
  trace ctx_types,
  ctx.mmap' (λ e,
              do
                e_type ← infer_type e,
                trace $ (to_string e) ++ " : " ++ (to_string e_type))

example (A : Type) (b c : A) (h : b = c) : false :=
begin
  inspect_all,
  sorry,
end

-- Наконец, реализуем версию тактики `assumption`

meta def assump_one (e : expr) : tactic unit :=
do
  tactic.exact e

meta def assump_list : list expr → tactic unit
| [] := fail "No assumption found!"
| (hd :: tl) := exact hd <|> assump_list tl

meta def assump : tactic unit :=
do
  -- fail "TODO: implement"
  ctx ← local_context,
  assump_list ctx

-- Тест
example {A B C : Prop} (ha : A) (hb : B) (hc : C) : B :=
begin
  assump,
  -- sorry,
end

-- Больше упражнений: https://github.com/leanprover-community/lftcm2020/blob/master/src/exercises_sources/monday/metaprogramming.lean


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Jacob von Raumer
-/
import Lean

/-!

# Recursive cases (`rcases`) tactic and related tactics

`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c ∨ d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.

Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:

* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
  hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
  hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
  against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
  of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
  then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
  and so on.
* An alternation pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
  or a nested disjunction like `a ∨ b ∨ c`.

The patterns are fairly liberal about the exact shape of the constructors, and will insert
additional alternation branches and tuple arguments if there are not enough arguments provided, and
reuse the tail for further matches if there are too many arguments provided to alternation and
tuple patterns.

This file also contains the `obtain` and `rintro` tactics, which use the same syntax of `rcases`
patterns but with a slightly different use case:

* `rintro` (or `rintros`) is used like `rintro x ⟨y, z⟩` and is the same as `intros` followed by
  `rcases` on the newly introduced arguments.
* `obtain` is the same as `rcases` but with a syntax styled after `have` rather than `cases`.
  `obtain ⟨hx, hy⟩ | hz := foo` is equivalent to `rcases foo with ⟨hx, hy⟩ | hz`. Unlike `rcases`,
  `obtain` also allows one to omit `:= foo`, although a type must be provided in this case,
  as in `obtain ⟨hx, hy⟩ | hz : a ∧ b ∨ c`, in which case it produces a subgoal for proving
  `a ∧ b ∨ c` in addition to the subgoals `hx : a, hy : b |- goal` and `hz : c |- goal`.

## Tags

rcases, rintro, obtain, destructuring, cases, pattern matching, match
-/

namespace Lean.Parser.Tactic

declare_syntax_cat rcasesPat
syntax rcasesPatMed := sepBy1(rcasesPat, " | ")
syntax rcasesPatLo := rcasesPatMed (" : " term)?
syntax (name := rcasesPat.one) ident : rcasesPat
syntax (name := rcasesPat.ignore) "_" : rcasesPat
syntax (name := rcasesPat.clear) "-" : rcasesPat
syntax (name := rcasesPat.tuple) "⟨" rcasesPatLo,* "⟩" : rcasesPat
syntax (name := rcasesPat.paren) "(" rcasesPatLo ")" : rcasesPat

declare_syntax_cat rintroPat
syntax (name := rintroPat.one) rcasesPat : rintroPat
syntax (name := rintroPat.binder) "(" rintroPat+ (" : " term)? ")" : rintroPat

end Lean.Parser.Tactic

/- A list, with a disjunctive meaning (like a list of inductive constructors, or subgoals) -/
local notation "ListΣ" => List

/- A list, with a conjunctive meaning (like a list of constructor arguments, or hypotheses) -/
local notation "ListΠ" => List

namespace Lean.Meta

/-- Constructs a substitution consisting of `s` followed by `t`.
  This satisfies `(s.append t).apply e = t.apply (s.apply e)` -/
def FVarSubst.append (s t : FVarSubst) : FVarSubst :=
  s.1.foldl (fun s' k v => s'.insert k (t.apply v)) t

namespace RCases

/--
An `rcases` pattern can be one of the following, in a nested combination:

* A name like `foo`
* The special keyword `rfl` (for pattern matching on equality using `subst`)
* A hyphen `-`, which clears the active hypothesis and any dependents.
* A type ascription like `pat : ty` (parentheses are optional)
* A tuple constructor like `⟨p1, p2, p3⟩`
* An alternation / variant pattern `p1 | p2 | p3`

Parentheses can be used for grouping; alternation is higher precedence than type ascription, so
`p1 | p2 | p3 : ty` means `(p1 | p2 | p3) : ty`.

N-ary alternations are treated as a group, so `p1 | p2 | p3` is not the same as `p1 | (p2 | p3)`,
and similarly for tuples. However, note that an n-ary alternation or tuple can match an n-ary
conjunction or disjunction, because if the number of patterns exceeds the number of constructors in
the type being destructed, the extra patterns will match on the last element, meaning that
`p1 | p2 | p3` will act like `p1 | (p2 | p3)` when matching `a1 ∨ a2 ∨ a3`. If matching against a
type with 3 constructors,  `p1 | (p2 | p3)` will act like `p1 | (p2 | p3) | _` instead.
-/
inductive RCasesPatt : Type
| one : Syntax → Name → RCasesPatt
| clear : Syntax → RCasesPatt
| typed : Syntax → RCasesPatt → Syntax → RCasesPatt
| tuple : Syntax → ListΠ RCasesPatt → RCasesPatt
| alts : Syntax → ListΣ RCasesPatt → RCasesPatt
deriving Repr

namespace RCasesPatt

instance : Inhabited RCasesPatt := ⟨RCasesPatt.one Syntax.missing `_⟩

/-- Get the name from a pattern, if provided -/
partial def name? : RCasesPatt → Option Name
| one _ `_    => none
| one _ `rfl  => none
| one _ n     => n
| typed _ p _ => p.name?
| alts _ [p]  => p.name?
| _           => none

/-- Get the syntax node from which this pattern was parsed. Used for error messages -/
def ref : RCasesPatt → Syntax
| one ref _ => ref
| clear ref => ref
| typed ref _ _ => ref
| tuple ref _ => ref
| alts ref _ => ref

/-- Interpret an rcases pattern as a tuple, where `p` becomes `⟨p⟩`
if `p` is not already a tuple. -/
def asTuple : RCasesPatt → ListΠ RCasesPatt
| tuple _ ps => ps
| p          => [p]

/-- Interpret an rcases pattern as an alternation, where non-alternations are treated as one
alternative. -/
def asAlts : RCasesPatt → ListΣ RCasesPatt
| alts _ ps => ps
| p         => [p]

/-- Convert a list of patterns to a tuple pattern, but mapping `[p]` to `p` instead of `⟨p⟩`. -/
def typed? (ref : Syntax) : RCasesPatt → Option Syntax → RCasesPatt
| p, none => p
| p, some ty => typed ref p ty

/-- Convert a list of patterns to a tuple pattern, but mapping `[p]` to `p` instead of `⟨p⟩`. -/
def tuple' : ListΠ RCasesPatt → RCasesPatt
| [p] => p
| ps  => tuple (ps.head?.map (·.ref) |>.getD Syntax.missing) ps

/-- Convert a list of patterns to an alternation pattern, but mapping `[p]` to `p` instead of
a unary alternation `|p`. -/
def alts' (ref : Syntax) : ListΣ RCasesPatt → RCasesPatt
| [p] => p
| ps  => alts ref ps

/-- This function is used for producing rcases patterns based on a case tree. Suppose that we have
a list of patterns `ps` that will match correctly against the branches of the case tree for one
constructor. This function will merge tuples at the end of the list, so that `[a, b, ⟨c, d⟩]`
becomes `⟨a, b, c, d⟩` instead of `⟨a, b, ⟨c, d⟩⟩`.

We must be careful to turn `[a, ⟨⟩]` into `⟨a, ⟨⟩⟩` instead of `⟨a⟩` (which will not perform the
nested match). -/
def tuple₁Core : ListΠ RCasesPatt → ListΠ RCasesPatt
| []         => []
| [tuple ref []] => [tuple ref []]
| [tuple _ ps] => ps
| p :: ps    => p :: tuple₁Core ps

/-- This function is used for producing rcases patterns based on a case tree. This is like
`tuple₁Core` but it produces a pattern instead of a tuple pattern list, converting `[n]` to `n`
instead of `⟨n⟩` and `[]` to `_`, and otherwise just converting `[a, b, c]` to `⟨a, b, c⟩`. -/
def tuple₁ : ListΠ RCasesPatt → RCasesPatt
| []      => default
| [one ref n] => one ref n
| ps      => tuple ps.head!.ref $ tuple₁Core ps

/-- This function is used for producing rcases patterns based on a case tree. Here we are given
the list of patterns to apply to each argument of each constructor after the main case, and must
produce a list of alternatives with the same effect. This function calls `tuple₁` to make the
individual alternatives, and handles merging `[a, b, c | d]` to `a | b | c | d` instead of
`a | b | (c | d)`. -/
def alts₁Core : ListΣ (ListΠ RCasesPatt) → ListΣ RCasesPatt
| []          => []
| [[alts _ ps]] => ps
| p :: ps     => tuple₁ p :: alts₁Core ps

/-- This function is used for producing rcases patterns based on a case tree. This is like
`alts₁Core`, but it produces a cases pattern directly instead of a list of alternatives. We
specially translate the empty alternation to `⟨⟩`, and translate `|(a | b)` to `⟨a | b⟩` (because we
don't have any syntax for unary alternation). Otherwise we can use the regular merging of
alternations at the last argument so that `a | b | (c | d)` becomes `a | b | c | d`. -/
def alts₁ (ref : Syntax) : ListΣ (ListΠ RCasesPatt) → RCasesPatt
| [[]]        => tuple Syntax.missing []
| [[alts ref ps]] => tuple ref ps
| ps          => alts' ref $ alts₁Core ps

open MessageData in
partial instance : ToMessageData RCasesPatt := ⟨fmt 0⟩ where
  parenAbove (tgt p : Nat) (m : MessageData) : MessageData :=
    if tgt < p then m.paren else m
  fmt : Nat → RCasesPatt → MessageData
  | _, one _ n => n
  | _, clear _ => "-"
  | p, typed _ pat ty => parenAbove 0 p m!"{fmt 1 pat}: {ty}"
  | _, tuple _ pats => bracket "⟨" (joinSep (pats.map (fmt 0)) ("," ++ Format.line)) "⟩"
  | p, alts _ pats => parenAbove 1 p (joinSep (pats.map (fmt 2)) " | ")

end RCasesPatt

/-- Takes the number of fields of a single constructor and patterns to match its fields against
(not necessarily the same number). The returned lists each contain one element per field of the
constructor. The `name` is the name which will be used in the top-level `cases` tactic, and the
`rcases_patt` is the pattern which the field will be matched against by subsequent `cases`
tactics. -/
def processConstructor (ref : Syntax) : Nat → ListΠ RCasesPatt → ListΠ Name × ListΠ RCasesPatt
| 0,     ps      => ([], [])
| 1,     []      => ([`_], [default])
| 1,     [p]     => ([p.name?.getD `_], [p])
| 1,     ps      => ([`_], [RCasesPatt.tuple ref ps])
| n + 1, p :: ps => let (ns, tl) := processConstructor ref n ps
                    (p.name?.getD `_ :: ns, p :: tl)
| _,     _       => ([], [])

/-- Takes a list of constructor names, and an (alternation) list of patterns, and matches each
pattern against its constructor. It returns the list of names that will be passed to `cases`,
and the list of `(constructor name, patterns)` for each constructor, where `patterns` is the
(conjunctive) list of patterns to apply to each constructor argument. -/
def processConstructors (ref : Syntax) (params : Nat) (altVarNames : Array AltVarNames := #[]) :
  ListΣ Name → ListΣ RCasesPatt → MetaM (Array AltVarNames × ListΣ (Name × ListΠ RCasesPatt))
| [], ps => pure (altVarNames, [])
| c :: cs, ps => do
  let n := FunInfo.getArity $ ← getFunInfo (← mkConstWithLevelParams c)
  let p := ps.headD default
  let t := ps.tailD []
  let (h, t) := match cs, t with
  | [], _ :: _ => ([RCasesPatt.alts ref ps], [])
  | _,  _      => (p.asTuple, t)
  let (ns, ps) := processConstructor p.ref (n - params) h
  let (altVarNames, r)  ← processConstructors ref params (altVarNames.push ⟨true, ns⟩) cs t
  pure (altVarNames, (c, ps) :: r)

open Elab Tactic

-- this belongs in core; it is a variation on subst that passes fvarSubst through
def subst' (mvarId : MVarId) (hFVarId : FVarId)
  (fvarSubst : FVarSubst := {}) : MetaM (FVarSubst × MVarId) := do
  let hLocalDecl ← getLocalDecl hFVarId
  let error {α} _ : MetaM α := throwTacticEx `subst mvarId
    m!"invalid equality proof, it is not of the form (x = t) or (t = x){indentExpr hLocalDecl.type}"
  let some (α, lhs, rhs) ← matchEq? hLocalDecl.type | error ()
  let substReduced (newType : Expr) (symm : Bool) : MetaM (FVarSubst × MVarId) := do
    let mvarId ← assert mvarId hLocalDecl.userName newType (mkFVar hFVarId)
    let (hFVarId', mvarId) ← intro1P mvarId
    let mvarId ← clear mvarId hFVarId
    substCore mvarId hFVarId' (symm := symm) (tryToSkip := true) (fvarSubst := fvarSubst)
  let rhs' ← whnf rhs
  if rhs'.isFVar then
    if rhs != rhs' then
      substReduced (← mkEq lhs rhs') true
    else
      substCore mvarId hFVarId (symm := true) (tryToSkip := true) (fvarSubst := fvarSubst)
  else
    let lhs' ← whnf lhs
    if lhs'.isFVar then
      if lhs != lhs' then
        substReduced (← mkEq lhs' rhs) false
      else
        substCore mvarId hFVarId (symm := false) (tryToSkip := true) (fvarSubst := fvarSubst)
    else error ()

mutual

/-- This will match a pattern `pat` against a local hypothesis `e`.
  * `g`: The initial subgoal
  * `fs`: A running variable substitution, the result of `cases` operations upstream.
    The variable `e` must be run through this map before locating it in the context of `g`,
    and the output variable substitutions will be end extensions of this one.
  * `clears`: The list of variables to clear in all subgoals generated from this point on.
    We defer clear operations because clearing too early can cause `cases` to fail.
    The actual clearing happens in `RCases.finish`.
  * `e`: a local hypothesis, the scrutinee to match against.
  * `a`: opaque "user data" which is passed through all the goal calls at the end.
  * `pat`: the pattern to match against
  * `cont`: A continuation. This is called on every goal generated by the result of the pattern
    match, with updated values for `g` , `fs`, `clears`, and `a`. -/
partial def rcasesCore (g : MVarId) (fs : FVarSubst) (clears : Array FVarId) (e : FVarId) (a : α)
  (pat : RCasesPatt) (cont : MVarId → FVarSubst → Array FVarId → α → TermElabM α) : TermElabM α :=
  let translate e : MetaM _ := do
    let e := fs.get e
    unless e.isFVar do
      throwError "rcases tactic failed: {e} is not a fvar"
    pure e
  withRef pat.ref <| withMVarContext g <| match pat with
  | RCasesPatt.one _ `rfl => do
    let (fs, g) ← subst' g (← translate e).fvarId! fs
    cont g fs clears a
  | RCasesPatt.one _ _ => cont g fs clears a
  | RCasesPatt.clear _ => cont g fs (clears.push e) a
  | RCasesPatt.typed _ pat ty => do
    let expected ← Term.elabType ty
    let e ← translate e
    let etype ← inferType e
    unless ← isDefEq etype expected do
      Term.throwTypeMismatchError "rcases: scrutinee" expected etype e
    let g ← replaceLocalDeclDefEq g e.fvarId! expected
    cont g fs clears a
  | RCasesPatt.alts _ [p] => rcasesCore g fs clears e a p cont
  | _ => do
    let e ← translate e
    let type ← whnfD (← inferType e)
    let failK {α} _ : TermElabM α :=
      throwError "rcases tactic failed: {e} : {type} is not an inductive datatype"
    let (r, subgoals) ← matchConst type.getAppFn failK fun
      | ConstantInfo.quotInfo info, _ => do
        unless info.kind matches QuotKind.type do failK ()
        let pat := pat.asAlts.headD default
        let ([x], ps) := processConstructor pat.ref 1 pat.asTuple | panic! "rcases"
        let (vars, g) ← Meta.revert g (← getFVarsToGeneralize #[e])
        withMVarContext g do
          let elimInfo ← getElimInfo `Quot.ind
          let res ← ElimApp.mkElimApp `Quot.ind elimInfo #[e] (← getMVarTag g)
          let elimArgs := res.elimApp.getAppArgs
          ElimApp.setMotiveArg g elimArgs[elimInfo.motivePos].mvarId! #[e.fvarId!]
          assignExprMVar g res.elimApp
          let #[(n, g)] := res.alts | panic! "rcases"
          let (v, g) ← intro g x
          let (varsOut, g) ← introNP g vars.size
          let fs' := (vars.zip varsOut).foldl (init := fs) fun fs (v, w) => fs.insert v (mkFVar w)
          pure ([(n, ps)], #[⟨⟨g, #[mkFVar v], fs'⟩, n⟩])
      | ConstantInfo.inductInfo info, _ => do
        let (altVarNames, r) ← processConstructors pat.ref info.numParams #[] info.ctors pat.asAlts
        (r, ·) <$> cases g e.fvarId! altVarNames
      | _, _ => failK ()
    (·.2) <$> subgoals.foldlM (init := (r, a)) fun (r, a) ⟨goal, ctorName⟩ => do
      let rec align
      | [] => pure ([], a)
      | (tgt, ps) :: as => do
        if tgt == ctorName then
          let fs := fs.append goal.subst
          (as, ·) <$> rcasesContinue goal.mvarId fs clears a (ps.zip goal.fields.toList) cont
        else
          align as
      align r

/-- This will match a list of patterns against a list of hypotheses `e`. The arguments are similar
to `rcasesCore`, but the patterns and local variables are in `pats`. Because the calls are all
nested in continuations, later arguments can be matched many times, once per goal produced by
earlier arguments. For example `⟨a | b, ⟨c, d⟩⟩` performs the `⟨c, d⟩` match twice, once on the
`a` branch and once on `b`. -/
partial def rcasesContinue (g : MVarId) (fs : FVarSubst) (clears : Array FVarId) (a : α)
  (pats : ListΠ (RCasesPatt × Expr)) (cont : MVarId → FVarSubst → Array FVarId → α → TermElabM α) :
  TermElabM α :=
  match pats with
  | []  => cont g fs clears a
  | ((pat, e) :: ps) => do
    unless e.isFVar do
      throwError "rcases tactic failed: {e} is not a fvar"
    rcasesCore g fs clears e.fvarId! a pat fun g fs clears a =>
      rcasesContinue g fs clears a ps cont

end

/-- Like `tryClearMany`, but also clears dependent hypotheses if possible -/
def tryClearMany' (mvarId : MVarId) (fvarIds : Array FVarId) : MetaM MVarId := do
  let mctx ← getMCtx
  let toErase := (← getMVarDecl mvarId).lctx.foldl (init := fvarIds) fun toErase localDecl =>
    if mctx.findLocalDeclDependsOn localDecl toErase.contains then
      toErase.push localDecl.fvarId
    else toErase
  tryClearMany mvarId toErase

/-- The terminating continuation used in `rcasesCore` and `rcasesContinue`. We specialize the type
`α` to `Array MVarId` to collect the list of goals, and given the list of `clears`, it attempts to
clear them from the goal and adds the goal to the list. -/
def finish (g : MVarId) (fs : FVarSubst) (clears : Array FVarId)
  (gs : Array MVarId) : TermElabM (Array MVarId) := do
  let cs : Array Expr := (clears.map fs.get).filter Expr.isFVar
  gs.push <$> tryClearMany' g (cs.map Expr.fvarId!)

open Elab

/-- Parses a `Syntax` into the `RCasesPatt` type used by the `RCases` tactic. -/
partial def RCasesPatt.parse (stx : Syntax) : MetaM RCasesPatt :=
  match stx with
  | `(Lean.Parser.Tactic.rcasesPatMed| $ps:rcasesPat|*) => do
    pure $ RCasesPatt.alts' stx (← ps.getElems.toList.mapM parse)
  | `(Lean.Parser.Tactic.rcasesPatLo| $pat:rcasesPatMed : $t:term) => do
    pure $ RCasesPatt.typed stx (← parse pat) t
  | `(Lean.Parser.Tactic.rcasesPatLo| $pat:rcasesPatMed) => parse pat
  | `(rcasesPat| _) => pure $ RCasesPatt.one stx `_
  | `(rcasesPat| $h:ident) => pure $ RCasesPatt.one stx h.getId
  | `(rcasesPat| -) => pure $ RCasesPatt.clear stx
  | `(rcasesPat| ⟨$ps,*⟩) => do
    pure $ RCasesPatt.tuple stx (← ps.getElems.toList.mapM parse)
  | `(rcasesPat| ($pat)) => parse pat
  | _ => throwUnsupportedSyntax

-- extracted from elabCasesTargets
def generalizeExceptFVar (mvarId : MVarId) (args : Array GeneralizeArg) : MetaM (Array Expr × MVarId) := do
  let argsToGeneralize := args.filter fun arg => !(arg.expr.isFVar && arg.hName?.isNone)
  let (fvarIdsNew, mvarId) ← generalize mvarId argsToGeneralize
  let mut result := #[]
  let mut j := 0
  for arg in args do
    if arg.expr.isFVar && arg.hName?.isNone then
      result := result.push arg.expr
    else
      result := result.push (mkFVar fvarIdsNew[j])
      j := j+1
  pure (result, mvarId)

/-- Given a list of targets of the form `e` or `h : e`, and a pattern, match all the targets
against the pattern. Returns the list of produced subgoals. -/
def rcases (tgts : Array (Option Name × Syntax))
  (pat : RCasesPatt) (g : MVarId) : TermElabM (List MVarId) := do
  let pats ← match tgts.size with
  | 0 => return [g]
  | 1 => pure [pat]
  | _ => pure (processConstructor pat.ref tgts.size pat.asTuple).2
  let (pats, args) := Array.unzip <|← (tgts.zip pats.toArray).mapM fun ((hName?, tgt), pat) => do
    let (pat, ty) ← match pat with
    | RCasesPatt.typed ref pat ty => pure (pat, some (← withRef ref <| Term.elabType ty))
    | _ => pure (pat, none)
    let expr ← Term.ensureHasType ty (← Term.elabTerm tgt ty)
    pure (pat, { expr, xName? := pat.name?, hName? : GeneralizeArg })
  let (vs, g) ← generalizeExceptFVar g args
  let gs ← rcasesContinue g {} #[] #[] (pats.zip vs).toList finish
  pure gs.toList

/-- The `obtain` tactic in the no-target case. Given a type `T`, create a goal `|- T` and
and pattern match `T` against the given pattern. Returns the list of goals, with the assumed goal
first followed by the goals produced by the pattern match. -/
def obtainNone (pat : RCasesPatt) (ty : Syntax) (g : MVarId) : TermElabM (List MVarId) := do
  let ty ← Term.elabType ty
  let g₁ ← mkFreshExprMVar (some ty)
  let (v, g₂) ← intro1 (← assert g (pat.name?.getD default) ty g₁)
  let gs ← rcasesCore g₂ {} #[] v #[] pat finish
  pure (g₁.mvarId! :: gs.toList)

mutual

partial def rintroCore (g : MVarId) (fs : FVarSubst) (clears : Array FVarId) (a : α)
  (ref pat : Syntax) (ty? : Option Syntax)
  (cont : MVarId → FVarSubst → Array FVarId → α → TermElabM α) : TermElabM α := do
  match pat with
  | `(rintroPat| $pat:rcasesPat) =>
    let pat := (← RCasesPatt.parse pat).typed? ref ty?
    let (v, g) ← intro g (pat.name?.getD `_)
    rcasesCore g fs clears v a pat cont
  | `(rintroPat| ($(pats)* $[: $ty?]?)) =>
    rintroContinue g fs clears pat pats ty? a cont
  | _ => throwUnsupportedSyntax

partial def rintroContinue (g : MVarId) (fs : FVarSubst) (clears : Array FVarId)
  (ref : Syntax) (pats : Array Syntax) (ty? : Option Syntax) (a : α)
  (cont : MVarId → FVarSubst → Array FVarId → α → TermElabM α) : TermElabM α := do
  withMVarContext g do
    let rec loop i g fs clears a := do
      if h : i < pats.size then
        rintroCore g fs clears a ref (pats.get ⟨i, h⟩) ty? (loop (i+1))
      else cont g fs clears a
    loop 0 g fs clears a

end

def rintro (ref : Syntax) (pats : Array Syntax) (ty? : Option Syntax)
  (g : MVarId) : TermElabM (List MVarId) :=
  (·.toList) <$> rintroContinue g {} #[] ref pats ty? #[] finish

end Lean.Meta.RCases

namespace Lean.Parser.Tactic
open Elab Elab.Tactic Meta RCases

elab (name := rcases?) "rcases?" tgts:casesTarget,* num:(" : " num)? : tactic =>
  throwError "unimplemented"

elab (name := rcases) tk:"rcases" tgts:casesTarget,* pat:(" with " rcasesPatLo)? : tactic => do
  let pat ← match pat.getArgs with
  | #[_, pat] => RCasesPatt.parse pat
  | #[] => pure $ RCasesPatt.tuple tk []
  | _ => throwUnsupportedSyntax
  let tgts := tgts.getElems.map fun tgt =>
    (if tgt[0].isNone then none else some tgt[0][0].getId, tgt[1])
  withMainContext do
    replaceMainGoal (← RCases.rcases tgts pat (← getMainGoal))

elab (name := obtain) tk:"obtain"
    pat:(ppSpace rcasesPatMed)? ty:(" : " term)? val:(" := " term,+)? : tactic => do
  let pat ← liftM $ pat.getOptional?.mapM RCasesPatt.parse
  if val.isNone then
    if ty.isNone then throwError
        ("`obtain` requires either an expected type or a value.\n" ++
        "usage: `obtain ⟨patt⟩? : type (:= val)?` or `obtain ⟨patt⟩? (: type)? := val`")
    let pat := pat.getD (RCasesPatt.one tk `this)
    withMainContext do
      replaceMainGoal (← RCases.obtainNone pat ty[1] (← getMainGoal))
  else
    let pat := pat.getD (RCasesPatt.one tk `_)
    let pat := pat.typed? tk $ if ty.isNone then none else some ty[1]
    let tgts := val[1].getSepArgs.map fun val => (none, val)
    withMainContext do
      replaceMainGoal (← RCases.rcases tgts pat (← getMainGoal))

elab (name := rintro?) "rintro?" (" : " num)? : tactic =>
  throwError "unimplemented"

elab (name := rintro) "rintro" pats:(ppSpace colGt rintroPat)+ ty:(" : " term)? : tactic => do
  let ty? := if ty.isNone then none else some ty[1]
  withMainContext do
    replaceMainGoal (← RCases.rintro ty pats.getArgs ty? (← getMainGoal))


/-
Copyright (c) 2022 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky

! This file was ported from Lean 3 source module tactic.swap_var
! leanprover-community/mathlib commit b3d0944867b430bb5557ba6391ca9c7749a16cbb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Interactive

/-!
# Swap bound variable tactic

This files defines a tactic `swap_var` whose main purpose is to be a weaker
version of `wlog` that juggles bound names.

It is a helper around the core tactic `rename`.

* `swap_var old new` renames all names named `old` to `new` and vice versa in the goal
  and all hypotheses.

```lean
example (P Q : Prop) (hp : P) (hq : Q) : P ∧ Q :=
begin
  split,
  work_on_goal 1 { swap_var [P Q] },
  all_goals { exact ‹P› }
end
```

# See also
* `tactic.interactive.rename`
* `tactic.interactive.rename_var`

-/

namespace Tactic.Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
private unsafe def swap_arg_parser : lean.parser (Name × Name) :=
  Prod.mk <$> ident <*> (optional (tk "<->" <|> tk "↔") *> ident)
#align tactic.interactive.swap_arg_parser tactic.interactive.swap_arg_parser

private unsafe def swap_args_parser : lean.parser (List (Name × Name)) :=
  Functor.map (fun x => [x]) swap_arg_parser <|> tk "[" *> sep_by (tk ",") swap_arg_parser <* tk "]"
#align tactic.interactive.swap_args_parser tactic.interactive.swap_args_parser

/-- `swap_var [x y, P ↔ Q]` swaps the names `x` and `y`, `P` and `Q`.
Such a swapping can be used as a weak `wlog` if the tactic proofs use the same names.

```lean
example (P Q : Prop) (hp : P) (hq : Q) : P ∧ Q :=
begin
  split,
  work_on_goal 1 { swap_var [P Q] },
  all_goals { exact ‹P› }
end
```
-/
unsafe def swap_var (renames : parse swap_args_parser) : tactic Unit := do
  renames fun e => do
      let n ← tactic.get_unused_name
      -- how to call `interactive.tactic.rename` here?
          propagate_tags <|
          tactic.rename_many <| native.rb_map.of_list [(e.1, n), (e.2, e.1)]
      propagate_tags <| tactic.rename_many <| native.rb_map.of_list [(n, e.2)]
  pure ()
#align tactic.interactive.swap_var tactic.interactive.swap_var

end Tactic.Interactive

add_tactic_doc
  { Name := "swap_var"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.swap_var]
    tags := ["renaming"] }


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.coherence

/-!
# Monoidal opposites

We write `Cᵐᵒᵖ` for the monoidal opposite of a monoidal category `C`.
-/

universes v₁ v₂ u₁ u₂

variables {C : Type u₁}

namespace category_theory

open category_theory.monoidal_category

/-- A type synonym for the monoidal opposite. Use the notation `Cᴹᵒᵖ`. -/
@[nolint has_nonempty_instance]
def monoidal_opposite (C : Type u₁) := C

namespace monoidal_opposite

notation C `ᴹᵒᵖ`:std.prec.max_plus := monoidal_opposite C

/-- Think of an object of `C` as an object of `Cᴹᵒᵖ`. -/
@[pp_nodot]
def mop (X : C) : Cᴹᵒᵖ := X

/-- Think of an object of `Cᴹᵒᵖ` as an object of `C`. -/
@[pp_nodot]
def unmop (X : Cᴹᵒᵖ) : C := X

lemma op_injective : function.injective (mop : C → Cᴹᵒᵖ) := λ _ _, id
lemma unop_injective : function.injective (unmop : Cᴹᵒᵖ → C) := λ _ _, id

@[simp] lemma op_inj_iff (x y : C) : mop x = mop y ↔ x = y := iff.rfl
@[simp]

attribute [irreducible] monoidal_opposite

@[simp] lemma mop_unmop (X : Cᴹᵒᵖ) : mop (unmop X) = X := rfl
@[simp] lemma unmop_mop (X : C) : unmop (mop X) = X := rfl

instance monoidal_opposite_category [I : category.{v₁} C] : category Cᴹᵒᵖ :=
{ hom := λ X Y, unmop X ⟶ unmop Y,
  id := λ X, 𝟙 (unmop X),
  comp := λ X Y Z f g, f ≫ g, }

end monoidal_opposite

end category_theory

open category_theory
open category_theory.monoidal_opposite

variables [category.{v₁} C]

/-- The monoidal opposite of a morphism `f : X ⟶ Y` is just `f`, thought of as `mop X ⟶ mop Y`. -/
def quiver.hom.mop {X Y : C} (f : X ⟶ Y) : @quiver.hom Cᴹᵒᵖ _ (mop X) (mop Y) := f
/-- We can think of a morphism `f : mop X ⟶ mop Y` as a morphism `X ⟶ Y`. -/
def quiver.hom.unmop {X Y : Cᴹᵒᵖ} (f : X ⟶ Y) : unmop X ⟶ unmop Y := f

namespace category_theory

lemma mop_inj {X Y : C} :
  function.injective (quiver.hom.mop : (X ⟶ Y) → (mop X ⟶ mop Y)) :=
λ _ _ H, congr_arg quiver.hom.unmop H

lemma unmop_inj {X Y : Cᴹᵒᵖ} :
  function.injective (quiver.hom.unmop : (X ⟶ Y) → (unmop X ⟶ unmop Y)) :=
λ _ _ H, congr_arg quiver.hom.mop H

@[simp] lemma unmop_mop {X Y : C} {f : X ⟶ Y} : f.mop.unmop = f := rfl
@[simp] lemma mop_unmop {X Y : Cᴹᵒᵖ} {f : X ⟶ Y} : f.unmop.mop = f := rfl

@[simp] lemma mop_comp {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).mop = f.mop ≫ g.mop := rfl
@[simp] lemma mop_id {X : C} : (𝟙 X).mop = 𝟙 (mop X) := rfl

@[simp] lemma unmop_comp {X Y Z : Cᴹᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).unmop = f.unmop ≫ g.unmop := rfl
@[simp] lemma unmop_id {X : Cᴹᵒᵖ} : (𝟙 X).unmop = 𝟙 (unmop X) := rfl

@[simp] lemma unmop_id_mop {X : C} : (𝟙 (mop X)).unmop = 𝟙 X := rfl
@[simp] lemma mop_id_unmop {X : Cᴹᵒᵖ} : (𝟙 (unmop X)).mop = 𝟙 X := rfl

namespace iso

variables {X Y : C}

/-- An isomorphism in `C` gives an isomorphism in `Cᴹᵒᵖ`. -/
@[simps]
def mop (f : X ≅ Y) : mop X ≅ mop Y :=
{ hom := f.hom.mop,
  inv := f.inv.mop,
  hom_inv_id' := unmop_inj f.hom_inv_id,
  inv_hom_id' := unmop_inj f.inv_hom_id }

end iso

variables [monoidal_category.{v₁} C]

open opposite monoidal_category

instance monoidal_category_op : monoidal_category Cᵒᵖ :=
{ tensor_obj := λ X Y, op (unop X ⊗ unop Y),
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, (f.unop ⊗ g.unop).op,
  tensor_unit := op (𝟙_ C),
  associator := λ X Y Z, (α_ (unop X) (unop Y) (unop Z)).symm.op,
  left_unitor := λ X, (λ_ (unop X)).symm.op,
  right_unitor := λ X, (ρ_ (unop X)).symm.op,
  associator_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  left_unitor_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  right_unitor_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  triangle' := by { intros, apply quiver.hom.unop_inj, coherence, },
  pentagon' := by { intros, apply quiver.hom.unop_inj, coherence, }, }

lemma op_tensor_obj (X Y : Cᵒᵖ) : X ⊗ Y = op (unop X ⊗ unop Y) := rfl
lemma op_tensor_unit : (𝟙_ Cᵒᵖ) = op (𝟙_ C) := rfl

instance monoidal_category_mop : monoidal_category Cᴹᵒᵖ :=
{ tensor_obj := λ X Y, mop (unmop Y ⊗ unmop X),
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, (g.unmop ⊗ f.unmop).mop,
  tensor_unit := mop (𝟙_ C),
  associator := λ X Y Z, (α_ (unmop Z) (unmop Y) (unmop X)).symm.mop,
  left_unitor := λ X, (ρ_ (unmop X)).mop,
  right_unitor := λ X, (λ_ (unmop X)).mop,
  associator_naturality' := by { intros, apply unmop_inj, simp, },
  left_unitor_naturality' := by { intros, apply unmop_inj, simp, },
  right_unitor_naturality' := by { intros, apply unmop_inj, simp, },
  triangle' := by { intros, apply unmop_inj, coherence, },
  pentagon' := by { intros, apply unmop_inj, coherence, }, }

lemma mop_tensor_obj (X Y : Cᴹᵒᵖ) : X ⊗ Y = mop (unmop Y ⊗ unmop X) := rfl
lemma mop_tensor_unit : (𝟙_ Cᴹᵒᵖ) = mop (𝟙_ C) := rfl

end category_theory