/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u u_1 u_2

namespace Mathlib

/-!
# A type for VM-erased data

This file defines a type `erased α` which is classically isomorphic to `α`,
but erased in the VM. That is, at runtime every value of `erased α` is
represented as `0`, just like types and proofs.
-/

/-- `erased α` is the same as `α`, except that the elements
  of `erased α` are erased in the VM in the same way as types
  and proofs. This can be used to track data without storing it
  literally. -/
def erased (α : Sort u) :=
  psigma fun (s : α → Prop) => ∃ (a : α), (fun (b : α) => a = b) = s

namespace erased

/-- Erase a value. -/
def mk {α : Sort u_1} (a : α) : erased α :=
  psigma.mk (fun (b : α) => a = b) sorry

/-- Extracts the erased value, noncomputably. -/
def out {α : Sort u_1} : erased α → α :=
  sorry

/--
Extracts the erased value, if it is a type.

Note: `(mk a).out_type` is not definitionally equal to `a`.
-/
def out_type (a : erased (Sort u)) :=
  out a

/-- Extracts the erased value, if it is a proof. -/
theorem out_proof {p : Prop} (a : erased p) : p :=
  out a

@[simp] theorem out_mk {α : Sort u_1} (a : α) : out (mk a) = a :=
  let h : ∃ (x : α), (fun (b : α) => x = b) = fun (b : α) => a = b := mk._proof_1 a;
  id (cast (Eq.symm (congr_fun (classical.some_spec h) a)) rfl)

@[simp] theorem mk_out {α : Sort u_1} (a : erased α) : mk (out a) = a := sorry

theorem out_inj {α : Sort u_1} (a : erased α) (b : erased α) (h : out a = out b) : a = b := sorry

/-- Equivalence between `erased α` and `α`. -/
def equiv (α : Sort u_1) : erased α ≃ α :=
  equiv.mk out mk mk_out out_mk

protected instance has_repr (α : Type u) : has_repr (erased α) :=
  has_repr.mk
    fun (_x : erased α) =>
      string.str
        (string.str
          (string.str
            (string.str
              (string.str (string.str string.empty (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
                (char.of_nat (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
              (char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit1 1))))))))
            (char.of_nat (bit1 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
          (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
        (char.of_nat (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 1)))))))

protected instance has_to_string (α : Type u) : has_to_string (erased α) :=
  has_to_string.mk
    fun (_x : erased α) =>
      string.str
        (string.str
          (string.str
            (string.str
              (string.str (string.str string.empty (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
                (char.of_nat (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
              (char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit1 1))))))))
            (char.of_nat (bit1 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
          (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
        (char.of_nat (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 1)))))))

/-- Computably produce an erased value from a proof of nonemptiness. -/
def choice {α : Sort u_1} (h : Nonempty α) : erased α :=
  mk (Classical.choice h)

@[simp] theorem nonempty_iff {α : Sort u_1} : Nonempty (erased α) ↔ Nonempty α := sorry

protected instance inhabited {α : Sort u_1} [h : Nonempty α] : Inhabited (erased α) :=
  { default := choice h }

/--
`(>>=)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `monad`).
-/
def bind {α : Sort u_1} {β : Sort u_2} (a : erased α) (f : α → erased β) : erased β :=
  psigma.mk (fun (b : β) => psigma.fst (f (out a)) b) sorry

@[simp] theorem bind_eq_out {α : Sort u_1} {β : Sort u_2} (a : erased α) (f : α → erased β) : bind a f = f (out a) := sorry

/--
Collapses two levels of erasure.
-/
def join {α : Sort u_1} (a : erased (erased α)) : erased α :=
  bind a id

@[simp] theorem join_eq_out {α : Sort u_1} (a : erased (erased α)) : join a = out a :=
  bind_eq_out a id

/--
`(<$>)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `functor`).
-/
def map {α : Sort u_1} {β : Sort u_2} (f : α → β) (a : erased α) : erased β :=
  bind a (mk ∘ f)

@[simp] theorem map_out {α : Sort u_1} {β : Sort u_2} {f : α → β} (a : erased α) : out (map f a) = f (out a) := sorry

protected instance monad : Monad erased :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β }, toPure := { pure := mk },
        toSeq :=
          { seq := fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) => bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : erased α) (b : erased β) =>
                (fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) => bind f fun (_x : α → β) => map _x x) β α
                  (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : erased α) (b : erased β) =>
                (fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) => bind f fun (_x : α → β) => map _x x) β β
                  (map (function.const α id) a) b } },
    toBind := { bind := bind } }

@[simp] theorem pure_def {α : Type u_1} : pure = mk :=
  rfl

@[simp] theorem bind_def {α : Type u_1} {β : Type u_1} : bind = bind :=
  rfl

@[simp] theorem map_def {α : Type u_1} {β : Type u_1} : Functor.map = map :=
  rfl

protected instance is_lawful_monad : is_lawful_monad erased := sorry


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison
-/
import category_theory.punit
import category_theory.comma
import category_theory.limits.shapes.terminal
import category_theory.essentially_small

/-!
# The category of "structured arrows"

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

For `T : C ⥤ D`, a `T`-structured arrow with source `S : D`
is just a morphism `S ⟶ T.obj Y`, for some `Y : C`.

These form a category with morphisms `g : Y ⟶ Y'` making the obvious diagram commute.

We prove that `𝟙 (T.obj Y)` is the initial object in `T`-structured objects with source `T.obj Y`.
-/

namespace category_theory

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

/--
The category of `T`-structured arrows with domain `S : D` (here `T : C ⥤ D`),
has as its objects `D`-morphisms of the form `S ⟶ T Y`, for some `Y : C`,
and morphisms `C`-morphisms `Y ⟶ Y'` making the obvious triangle commute.
-/
@[derive category, nolint has_nonempty_instance]
def structured_arrow (S : D) (T : C ⥤ D) := comma (functor.from_punit S) T

namespace structured_arrow

/-- The obvious projection functor from structured arrows. -/
@[simps]
def proj (S : D) (T : C ⥤ D) : structured_arrow S T ⥤ C := comma.snd _ _

variables {S S' S'' : D} {Y Y' : C} {T : C ⥤ D}

/-- Construct a structured arrow from a morphism. -/
def mk (f : S ⟶ T.obj Y) : structured_arrow S T := ⟨⟨⟨⟩⟩, Y, f⟩

@[simp] lemma mk_left (f : S ⟶ T.obj Y) : (mk f).left = ⟨⟨⟩⟩ := rfl
@[simp] lemma mk_right (f : S ⟶ T.obj Y) : (mk f).right = Y := rfl
@[simp] lemma mk_hom_eq_self (f : S ⟶ T.obj Y) : (mk f).hom = f := rfl

@[simp, reassoc] lemma w {A B : structured_arrow S T} (f : A ⟶ B) : A.hom ≫ T.map f.right = B.hom :=
by { have := f.w; tidy }

/--
To construct a morphism of structured arrows,
we need a morphism of the objects underlying the target,
and to check that the triangle commutes.
-/
@[simps]
def hom_mk {f f' : structured_arrow S T} (g : f.right ⟶ f'.right) (w : f.hom ≫ T.map g = f'.hom) :
  f ⟶ f' :=
{ left := eq_to_hom (by ext),
  right := g,
  w' := by { dsimp, simpa using w.symm, }, }

/--
Given a structured arrow `X ⟶ F(U)`, and an arrow `U ⟶ Y`, we can construct a morphism of
structured arrow given by `(X ⟶ F(U)) ⟶ (X ⟶ F(U) ⟶ F(Y))`.
-/
def hom_mk' {F : C ⥤ D} {X : D} {Y : C}
(U : structured_arrow X F) (f : U.right ⟶ Y) :
U ⟶ mk (U.hom ≫ F.map f) := { left := eq_to_hom (by ext), right := f }

/--
To construct an isomorphism of structured arrows,
we need an isomorphism of the objects underlying the target,
and to check that the triangle commutes.
-/
@[simps]
def iso_mk {f f' : structured_arrow S T} (g : f.right ≅ f'.right)
  (w : f.hom ≫ T.map g.hom = f'.hom) : f ≅ f' :=
comma.iso_mk (eq_to_iso (by ext)) g (by simpa [eq_to_hom_map] using w.symm)

lemma ext {A B : structured_arrow S T} (f g : A ⟶ B) : f.right = g.right → f = g :=
comma_morphism.ext _ _ (subsingleton.elim _ _)

lemma ext_iff {A B : structured_arrow S T} (f g : A ⟶ B) : f = g ↔ f.right = g.right :=
⟨λ h, h ▸ rfl, ext f g⟩

instance proj_faithful : faithful (proj S T) :=
{ map_injective' := λ X Y, ext }

/-- The converse of this is true with additional assumptions, see `mono_iff_mono_right`. -/
lemma mono_of_mono_right {A B : structured_arrow S T} (f : A ⟶ B) [h : mono f.right] : mono f :=
(proj S T).mono_of_mono_map h

lemma epi_of_epi_right {A B : structured_arrow S T} (f : A ⟶ B) [h : epi f.right] : epi f :=
(proj S T).epi_of_epi_map h

instance mono_hom_mk {A B : structured_arrow S T} (f : A.right ⟶ B.right) (w) [h : mono f] :
  mono (hom_mk f w) :=
(proj S T).mono_of_mono_map h

instance epi_hom_mk {A B : structured_arrow S T} (f : A.right ⟶ B.right) (w) [h : epi f] :
  epi (hom_mk f w) :=
(proj S T).epi_of_epi_map h

/-- Eta rule for structured arrows. Prefer `structured_arrow.eta`, since equality of objects tends
    to cause problems. -/
lemma eq_mk (f : structured_arrow S T) : f = mk f.hom :=
by { cases f, congr, ext, }

/-- Eta rule for structured arrows. -/
@[simps]
def eta (f : structured_arrow S T) : f ≅ mk f.hom :=
iso_mk (iso.refl _) (by tidy)

/--
A morphism between source objects `S ⟶ S'`
contravariantly induces a functor between structured arrows,
`structured_arrow S' T ⥤ structured_arrow S T`.

Ideally this would be described as a 2-functor from `D`
(promoted to a 2-category with equations as 2-morphisms)
to `Cat`.
-/
@[simps]
def map (f : S ⟶ S') : structured_arrow S' T ⥤ structured_arrow S T :=
comma.map_left _ ((functor.const _).map f)

@[simp]

@[simp] lemma map_id {f : structured_arrow S T} : (map (𝟙 S)).obj f = f :=
by { rw eq_mk f, simp, }

@[simp] lemma map_comp {f : S ⟶ S'} {f' : S' ⟶ S''} {h : structured_arrow S'' T} :
  (map (f ≫ f')).obj h = (map f).obj ((map f').obj h) :=
by { rw eq_mk h, simp, }

instance proj_reflects_iso : reflects_isomorphisms (proj S T) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨structured_arrow.hom_mk (inv ((proj S T).map f)) (by simp), by tidy⟩⟩ }

open category_theory.limits

local attribute [tidy] tactic.discrete_cases

/-- The identity structured arrow is initial. -/
def mk_id_initial [full T] [faithful T] : is_initial (mk (𝟙 (T.obj Y))) :=
{ desc := λ c, hom_mk (T.preimage c.X.hom) (by { dsimp, simp, }),
  uniq' := λ c m _, begin
    ext,
    apply T.map_injective,
    simpa only [hom_mk_right, T.image_preimage, ←w m] using (category.id_comp _).symm,
  end }

variables {A : Type u₃} [category.{v₃} A] {B : Type u₄} [category.{v₄} B]

/-- The functor `(S, F ⋙ G) ⥤ (S, G)`. -/
@[simps]
def pre (S : D) (F : B ⥤ C) (G : C ⥤ D) : structured_arrow S (F ⋙ G) ⥤ structured_arrow S G :=
comma.pre_right _ F G

/-- The functor `(S, F) ⥤ (G(S), F ⋙ G)`. -/
@[simps] def post (S : C) (F : B ⥤ C) (G : C ⥤ D) :
  structured_arrow S F ⥤ structured_arrow (G.obj S) (F ⋙ G) :=
{ obj := λ X, structured_arrow.mk (G.map X.hom),
  map := λ X Y f, structured_arrow.hom_mk f.right
    (by simp [functor.comp_map, ←G.map_comp, ← f.w]) }

instance small_proj_preimage_of_locally_small {𝒢 : set C} [small.{v₁} 𝒢] [locally_small.{v₁} D] :
  small.{v₁} ((proj S T).obj ⁻¹' 𝒢) :=
begin
  suffices : (proj S T).obj ⁻¹' 𝒢 = set.range (λ f : Σ G : 𝒢, S ⟶ T.obj G, mk f.2),
  { rw this, apply_instance },
  exact set.ext (λ X, ⟨λ h, ⟨⟨⟨_, h⟩, X.hom⟩, (eq_mk _).symm⟩, by tidy⟩)
end

end structured_arrow

/--
The category of `S`-costructured arrows with target `T : D` (here `S : C ⥤ D`),
has as its objects `D`-morphisms of the form `S Y ⟶ T`, for some `Y : C`,
and morphisms `C`-morphisms `Y ⟶ Y'` making the obvious triangle commute.
-/
@[derive category, nolint has_nonempty_instance]
def costructured_arrow (S : C ⥤ D) (T : D) := comma S (functor.from_punit T)

namespace costructured_arrow

/-- The obvious projection functor from costructured arrows. -/
@[simps]
def proj (S : C ⥤ D) (T : D) : costructured_arrow S T ⥤ C := comma.fst _ _

variables {T T' T'' : D} {Y Y' : C} {S : C ⥤ D}

/-- Construct a costructured arrow from a morphism. -/
def mk (f : S.obj Y ⟶ T) : costructured_arrow S T := ⟨Y, ⟨⟨⟩⟩, f⟩

@[simp] lemma mk_left (f : S.obj Y ⟶ T) : (mk f).left = Y := rfl
@[simp] lemma mk_right (f : S.obj Y ⟶ T) : (mk f).right = ⟨⟨⟩⟩ := rfl
@[simp] lemma mk_hom_eq_self (f : S.obj Y ⟶ T) : (mk f).hom = f := rfl

@[simp, reassoc] lemma w {A B : costructured_arrow S T} (f : A ⟶ B) :
  S.map f.left ≫ B.hom = A.hom :=
by tidy

/--
To construct a morphism of costructured arrows,
we need a morphism of the objects underlying the source,
and to check that the triangle commutes.
-/
@[simps]
def hom_mk {f f' : costructured_arrow S T} (g : f.left ⟶ f'.left) (w : S.map g ≫ f'.hom = f.hom) :
  f ⟶ f' :=
{ left := g,
  right := eq_to_hom (by ext),
  w' := by simpa [eq_to_hom_map] using w, }

/--
To construct an isomorphism of costructured arrows,
we need an isomorphism of the objects underlying the source,
and to check that the triangle commutes.
-/
@[simps]
def iso_mk {f f' : costructured_arrow S T} (g : f.left ≅ f'.left)
  (w : S.map g.hom ≫ f'.hom = f.hom) : f ≅ f' :=
comma.iso_mk g (eq_to_iso (by ext)) (by simpa [eq_to_hom_map] using w)

lemma ext {A B : costructured_arrow S T} (f g : A ⟶ B) (h : f.left = g.left) : f = g :=
comma_morphism.ext _ _ h (subsingleton.elim _ _)

lemma ext_iff {A B : costructured_arrow S T} (f g : A ⟶ B) : f = g ↔ f.left = g.left :=
⟨λ h, h ▸ rfl, ext f g⟩

instance proj_faithful : faithful (proj S T) :=
{ map_injective' := λ X Y, ext }

lemma mono_of_mono_left {A B : costructured_arrow S T} (f : A ⟶ B) [h : mono f.left] : mono f :=
(proj S T).mono_of_mono_map h

/-- The converse of this is true with additional assumptions, see `epi_iff_epi_left`. -/
lemma epi_of_epi_left {A B : costructured_arrow S T} (f : A ⟶ B) [h : epi f.left] : epi f :=
(proj S T).epi_of_epi_map h

instance mono_hom_mk {A B : costructured_arrow S T} (f : A.left ⟶ B.left) (w) [h : mono f] :
  mono (hom_mk f w) :=
(proj S T).mono_of_mono_map h

instance epi_hom_mk {A B : costructured_arrow S T} (f : A.left ⟶ B.left) (w) [h : epi f] :
  epi (hom_mk f w) :=
(proj S T).epi_of_epi_map h

/-- Eta rule for costructured arrows. Prefer `costructured_arrow.eta`, as equality of objects tends
    to cause problems. -/
lemma eq_mk (f : costructured_arrow S T) : f = mk f.hom :=
by { cases f, congr, ext, }

/-- Eta rule for costructured arrows. -/
@[simps]
def eta (f : costructured_arrow S T) : f ≅ mk f.hom :=
iso_mk (iso.refl _) (by tidy)

/--
A morphism between target objects `T ⟶ T'`
covariantly induces a functor between costructured arrows,
`costructured_arrow S T ⥤ costructured_arrow S T'`.

Ideally this would be described as a 2-functor from `D`
(promoted to a 2-category with equations as 2-morphisms)
to `Cat`.
-/
@[simps]
def map (f : T ⟶ T') : costructured_arrow S T ⥤ costructured_arrow S T' :=
comma.map_right _ ((functor.const _).map f)

@[simp] lemma map_mk {f : S.obj Y ⟶ T} (g : T ⟶ T') :
  (map g).obj (mk f) = mk (f ≫ g) := rfl

@[simp] lemma map_id {f : costructured_arrow S T} : (map (𝟙 T)).obj f = f :=
by { rw eq_mk f, simp, }

@[simp] lemma map_comp {f : T ⟶ T'} {f' : T' ⟶ T''} {h : costructured_arrow S T} :
  (map (f ≫ f')).obj h = (map f').obj ((map f).obj h) :=
by { rw eq_mk h, simp, }

instance proj_reflects_iso : reflects_isomorphisms (proj S T) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨costructured_arrow.hom_mk (inv ((proj S T).map f)) (by simp), by tidy⟩⟩ }

open category_theory.limits

local attribute [tidy] tactic.discrete_cases

/-- The identity costructured arrow is terminal. -/
def mk_id_terminal [full S] [faithful S] : is_terminal (mk (𝟙 (S.obj Y))) :=
{ lift := λ c, hom_mk (S.preimage c.X.hom) (by { dsimp, simp, }),
  uniq' := begin
    rintros c m -,
    ext,
    apply S.map_injective,
    simpa only [hom_mk_left, S.image_preimage, ←w m] using (category.comp_id _).symm,
  end }

variables {A : Type u₃} [category.{v₃} A] {B : Type u₄} [category.{v₄} B]

/-- The functor `(F ⋙ G, S) ⥤ (G, S)`. -/
@[simps]
def pre (F : B ⥤ C) (G : C ⥤ D) (S : D) : costructured_arrow (F ⋙ G) S ⥤ costructured_arrow G S :=
comma.pre_left F G _

/-- The functor `(F, S) ⥤ (F ⋙ G, G(S))`. -/
@[simps] def post (F : B ⥤ C) (G : C ⥤ D) (S : C) :
  costructured_arrow F S ⥤ costructured_arrow (F ⋙ G) (G.obj S) :=
{ obj := λ X, costructured_arrow.mk (G.map X.hom),
  map := λ X Y f, costructured_arrow.hom_mk f.left
    (by simp [functor.comp_map, ←G.map_comp, ← f.w]), }

instance small_proj_preimage_of_locally_small {𝒢 : set C} [small.{v₁} 𝒢] [locally_small.{v₁} D] :
  small.{v₁} ((proj S T).obj ⁻¹' 𝒢) :=
begin
  suffices : (proj S T).obj ⁻¹' 𝒢 = set.range (λ f : Σ G : 𝒢, S.obj G ⟶ T, mk f.2),
  { rw this, apply_instance },
  exact set.ext (λ X, ⟨λ h, ⟨⟨⟨_, h⟩, X.hom⟩, (eq_mk _).symm⟩, by tidy⟩)
end

end costructured_arrow

open opposite

namespace structured_arrow

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of structured arrows `d ⟶ F.obj c` to the category of costructured arrows
`F.op.obj c ⟶ (op d)`.
-/
@[simps]
def to_costructured_arrow (F : C ⥤ D) (d : D) :
  (structured_arrow d F)ᵒᵖ ⥤ costructured_arrow F.op (op d) :=
{ obj := λ X, @costructured_arrow.mk _ _ _ _ _ (op X.unop.right) F.op X.unop.hom.op,
  map := λ X Y f, costructured_arrow.hom_mk (f.unop.right.op)
  begin
    dsimp,
    rw [← op_comp, ← f.unop.w, functor.const_obj_map],
    erw category.id_comp,
  end }

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of structured arrows `op d ⟶ F.op.obj c` to the category of costructured arrows
`F.obj c ⟶ d`.
-/
@[simps]
def to_costructured_arrow' (F : C ⥤ D) (d : D) :
  (structured_arrow (op d) F.op)ᵒᵖ ⥤ costructured_arrow F d :=
{ obj := λ X, @costructured_arrow.mk _ _ _ _ _ (unop X.unop.right) F X.unop.hom.unop,
  map := λ X Y f, costructured_arrow.hom_mk f.unop.right.unop
  begin
    dsimp,
    rw [← quiver.hom.unop_op (F.map (quiver.hom.unop f.unop.right)), ← unop_comp, ← F.op_map,
      ← f.unop.w, functor.const_obj_map],
    erw category.id_comp,
  end }

end structured_arrow

namespace costructured_arrow

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of costructured arrows `F.obj c ⟶ d` to the category of structured arrows
`op d ⟶ F.op.obj c`.
-/
@[simps]
def to_structured_arrow (F : C ⥤ D) (d : D) :
  (costructured_arrow F d)ᵒᵖ ⥤ structured_arrow (op d) F.op :=
{ obj := λ X, @structured_arrow.mk _ _ _ _ _ (op X.unop.left) F.op X.unop.hom.op,
  map := λ X Y f, structured_arrow.hom_mk f.unop.left.op
  begin
    dsimp,
    rw [← op_comp, f.unop.w, functor.const_obj_map],
    erw category.comp_id,
  end }

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of costructured arrows `F.op.obj c ⟶ op d` to the category of structured arrows
`d ⟶ F.obj c`.
-/
@[simps]
def to_structured_arrow' (F : C ⥤ D) (d : D) :
  (costructured_arrow F.op (op d))ᵒᵖ ⥤ structured_arrow d F :=
{ obj := λ X, @structured_arrow.mk _ _ _ _ _ (unop X.unop.left) F X.unop.hom.unop,
  map := λ X Y f, structured_arrow.hom_mk (f.unop.left.unop)
  begin
    dsimp,
    rw [← quiver.hom.unop_op (F.map f.unop.left.unop), ← unop_comp, ← F.op_map,
      f.unop.w, functor.const_obj_map],
    erw category.comp_id,
  end }

end costructured_arrow

/--
For a functor `F : C ⥤ D` and an object `d : D`, the category of structured arrows `d ⟶ F.obj c`
is contravariantly equivalent to the category of costructured arrows `F.op.obj c ⟶ op d`.
-/
def structured_arrow_op_equivalence (F : C ⥤ D) (d : D) :
  (structured_arrow d F)ᵒᵖ ≌ costructured_arrow F.op (op d) :=
equivalence.mk (structured_arrow.to_costructured_arrow F d)
  (costructured_arrow.to_structured_arrow' F d).right_op
  (nat_iso.of_components (λ X, (@structured_arrow.iso_mk _ _ _ _ _ _
    (structured_arrow.mk (unop X).hom) (unop X) (iso.refl _) (by tidy)).op)
    (λ X Y f, quiver.hom.unop_inj $ begin ext, dsimp, simp end))
  (nat_iso.of_components (λ X, @costructured_arrow.iso_mk _ _ _ _ _ _
    (costructured_arrow.mk X.hom) X (iso.refl _) (by tidy))
    (λ X Y f, begin ext, dsimp, simp end))

/--
For a functor `F : C ⥤ D` and an object `d : D`, the category of costructured arrows
`F.obj c ⟶ d` is contravariantly equivalent to the category of structured arrows
`op d ⟶ F.op.obj c`.
-/
def costructured_arrow_op_equivalence (F : C ⥤ D) (d : D) :
  (costructured_arrow F d)ᵒᵖ ≌ structured_arrow (op d) F.op :=
equivalence.mk (costructured_arrow.to_structured_arrow F d)
  (structured_arrow.to_costructured_arrow' F d).right_op
  (nat_iso.of_components (λ X, (@costructured_arrow.iso_mk _ _ _ _ _ _
    (costructured_arrow.mk (unop X).hom) (unop X) (iso.refl _) (by tidy)).op)
    (λ X Y f, quiver.hom.unop_inj $ begin ext, dsimp, simp end))
  (nat_iso.of_components (λ X, @structured_arrow.iso_mk _ _ _ _ _ _
    (structured_arrow.mk X.hom) X (iso.refl _) (by tidy))
    (λ X Y f, begin ext, dsimp, simp end))

end category_theory


/-
This is modified version of Lean.Meta.Tactic.Simp.Rewrite

Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.ACLt
import Lean.Meta.Match.MatchEqsExt
import Lean.Meta.AppBuilder
import Lean.Meta.SynthInstance
import Lean.Meta.Tactic.Simp.Types
import Lean.Meta.Tactic.LinearArith.Simp

import SciLean.Tactic.CustomSimp.SimpGuard

namespace SciLean.Meta.CustomSimp

open Lean Meta Simp

-- @[simp, simp_guard f (λ x => x)]
-- theorem foo (a : Nat) (b : Int) (f : Nat → Nat) : 0 = 0 := by rfl

-- #eval show Lean.Elab.Term.TermElabM Bool from do pure (hasCustomSimpGuard (← getEnv) ``foo)

def mkEqTrans (r₁ r₂ : Result) : MetaM Result := do
  match r₁.proof? with
  | none => return r₂
  | some p₁ => match r₂.proof? with
    | none    => return { r₂ with proof? := r₁.proof? }
    | some p₂ => return { r₂ with proof? := (← Meta.mkEqTrans p₁ p₂) }

def synthesizeArgs (thmId : Origin) (xs : Array Expr) (bis : Array BinderInfo) (discharge? : Expr → SimpM (Option Expr)) : SimpM Bool := do
  -- simp guard
  match thmId with
  | .decl thmName => do
    match simpGuardAttr.getParam? (← getEnv) thmName with
    | some guards => do
        let doApplyGuard ← guards.allM λ (nth, valFun, mvarNum) => do

          -- TODO: figure out how to decide if we should call mkFreshTypeMVar or mkFreshExprMVar
          let mvars ← Array.mkArray mvarNum () |>.mapM (λ _ => do pure <| some <| ← mkFreshTypeMVar)

          -- apply local context for `nth` argument and apply fresh mvars if necessary
          let val ← mkAppOptM' valFun ((xs.map some)[0:nth].toArray.append mvars)
          if (← isDefEq xs[nth]! val) then
            pure true
          else
            pure false

        if doApplyGuard then
            -- TODO: get argument name
            trace[Meta.Tactic.simp.discharge] "{← ppOrigin thmId}, not applied because of simp guard"
            return false

    | none => pure ()
  | _ => pure ()

  for x in xs, bi in bis do
    let type ← inferType x
    if bi.isInstImplicit then
      unless (← synthesizeInstance x type) do
        return false
    else if (← instantiateMVars x).isMVar then
      if (← isProp type) then
        match (← discharge? type) with
        | some proof =>
          unless (← isDefEq x proof) do
            trace[Meta.Tactic.simp.discharge] "{← ppOrigin thmId}, failed to assign proof{indentExpr type}"
            return false
        | none =>
          trace[Meta.Tactic.simp.discharge] "{← ppOrigin thmId}, failed to discharge hypotheses{indentExpr type}"
          return false
      else if (← isClass? type).isSome then
        unless (← synthesizeInstance x type) do
          return false
  return true
where
  synthesizeInstance (x type : Expr) : SimpM Bool := do
    match (← trySynthInstance type) with
    | LOption.some val =>
      if (← withReducibleAndInstances <| isDefEq x val) then
        return true
      else
        trace[Meta.Tactic.simp.discharge] "{← ppOrigin thmId}, failed to assign instance{indentExpr type}\nsythesized value{indentExpr val}\nis not definitionally equal to{indentExpr x}"
        return false
    | _ =>
      trace[Meta.Tactic.simp.discharge] "{← ppOrigin thmId}, failed to synthesize instance{indentExpr type}"
      return false

private def tryTheoremCore (lhs : Expr) (xs : Array Expr) (bis : Array BinderInfo) (val : Expr) (type : Expr) (e : Expr) (thm : SimpTheorem) (numExtraArgs : Nat) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Result) := do
  let rec go (e : Expr) : SimpM (Option Result) := do
    if (← isDefEq lhs e) then
      unless (← synthesizeArgs thm.origin xs bis discharge?) do
        return none
      let proof? ← if thm.rfl then
        pure none
      else
        let proof ← instantiateMVars (mkAppN val xs)
        if (← hasAssignableMVar proof) then
          trace[Meta.Tactic.simp.rewrite] "{← ppSimpTheorem thm}, has unassigned metavariables after unification"
          return none
        pure <| some proof
      let rhs := (← instantiateMVars type).appArg!
      if e == rhs then
        return none
      if thm.perm then
        if !(← Expr.acLt rhs e) then
          trace[Meta.Tactic.simp.rewrite] "{← ppSimpTheorem thm}, perm rejected {e} ==> {rhs}"
          return none
      trace[Meta.Tactic.simp.rewrite] "{← ppSimpTheorem thm}, {e} ==> {rhs}"
      recordSimpTheorem thm.origin
      return some { expr := rhs, proof? }
    else
      unless lhs.isMVar do
        -- We do not report unification failures when `lhs` is a metavariable
        -- Example: `x = ()`
        -- TODO: reconsider if we want thms such as `(x : Unit) → x = ()`
        trace[Meta.Tactic.simp.unify] "{← ppSimpTheorem thm}, failed to unify{indentExpr lhs}\nwith{indentExpr e}"
      return none
  /- Check whether we need something more sophisticated here.
     This simple approach was good enough for Mathlib 3 -/
  let mut extraArgs := #[]
  let mut e := e
  for _ in [:numExtraArgs] do
    extraArgs := extraArgs.push e.appArg!
    e := e.appFn!
  extraArgs := extraArgs.reverse
  match (← go e) with
  | none => return none
  | some { expr := eNew, proof? := none, .. } => return some { expr := mkAppN eNew extraArgs }
  | some { expr := eNew, proof? := some proof, .. } =>
    let mut proof := proof
    for extraArg in extraArgs do
      proof ← mkCongrFun proof extraArg
    return some { expr := mkAppN eNew extraArgs, proof? := some proof }

def tryTheoremWithExtraArgs? (e : Expr) (thm : SimpTheorem) (numExtraArgs : Nat) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Result) :=
  withNewMCtxDepth do
    let val  ← thm.getValue
    let type ← inferType val
    let (xs, bis, type) ← forallMetaTelescopeReducing type
    let type ← whnf (← instantiateMVars type)
    let lhs := type.appFn!.appArg!
    tryTheoremCore lhs xs bis val type e thm numExtraArgs discharge?

def tryTheorem? (e : Expr) (thm : SimpTheorem) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Result) := do
  withNewMCtxDepth do
    let val  ← thm.getValue
    let type ← inferType val
    let (xs, bis, type) ← forallMetaTelescopeReducing type
    let type ← whnf (← instantiateMVars type)
    let lhs := type.appFn!.appArg!
    match (← tryTheoremCore lhs xs bis val type e thm 0 discharge?) with
    | some result => return some result
    | none =>
      let lhsNumArgs := lhs.getAppNumArgs
      let eNumArgs   := e.getAppNumArgs
      if eNumArgs > lhsNumArgs then
        tryTheoremCore lhs xs bis val type e thm (eNumArgs - lhsNumArgs) discharge?
      else
        return none
/--
Remark: the parameter tag is used for creating trace messages. It is irrelevant otherwise.
-/
def rewrite? (e : Expr) (s : SimpTheoremTree) (erased : PHashSet Origin) (discharge? : Expr → SimpM (Option Expr)) (tag : String) (rflOnly : Bool) : SimpM (Option Result) := do
  let candidates ← s.getMatchWithExtra e
  if candidates.isEmpty then
    trace[Debug.Meta.Tactic.simp] "no theorems found for {tag}-rewriting {e}"
    return none
  else
    let candidates := candidates.insertionSort fun e₁ e₂ => e₁.1.priority > e₂.1.priority
    for (thm, numExtraArgs) in candidates do
      unless inErasedSet thm || (rflOnly && !thm.rfl) do
        if let some result ← tryTheoremWithExtraArgs? e thm numExtraArgs discharge? then
          trace[Debug.Meta.Tactic.simp] "rewrite result {e} => {result.expr}"
          return some result
    return none
where
  inErasedSet (thm : SimpTheorem) : Bool :=
    erased.contains thm.origin

@[inline] def andThen (s : Step) (f? : Expr → SimpM (Option Step)) : SimpM Step := do
  match s with
  | Step.done _  => return s
  | Step.visit r =>
    if let some s' ← f? r.expr then
      return s'.updateResult (← mkEqTrans r s'.result)
    else
      return s

def rewriteCtorEq? (e : Expr) : MetaM (Option Result) := withReducibleAndInstances do
  match e.eq? with
  | none => return none
  | some (_, lhs, rhs) =>
    let lhs ← whnf lhs
    let rhs ← whnf rhs
    let env ← getEnv
    match lhs.constructorApp? env, rhs.constructorApp? env with
    | some (c₁, _), some (c₂, _) =>
      if c₁.name != c₂.name then
        withLocalDeclD `h e fun h =>
          return some { expr := mkConst ``False, proof? := (← mkEqFalse' (← mkLambdaFVars #[h] (← mkNoConfusion (mkConst ``False) h))) }
      else
        return none
    | _, _ => return none

@[inline] def tryRewriteCtorEq? (e : Expr) : SimpM (Option Step) := do
  match (← rewriteCtorEq? e) with
  | some r => return Step.done r
  | none  => return none

def rewriteUsingDecide? (e : Expr) : MetaM (Option Result) := withReducibleAndInstances do
  if e.hasFVar || e.hasMVar || e.isConstOf ``True || e.isConstOf ``False then
    return none
  else
    try
      let d ← mkDecide e
      let r ← withDefault <| whnf d
      if r.isConstOf ``true then
        return some { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
      else if r.isConstOf ``false then
        return some { expr := mkConst ``False, proof? := mkAppN (mkConst ``eq_false_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``false))] }
      else
        return none
    catch _ =>
      return none

@[inline] def tryRewriteUsingDecide? (e : Expr) : SimpM (Option Step) := do
  if (← read).config.decide then
    match (← rewriteUsingDecide? e) with
    | some r => return Step.done r
    | none => return none
  else
    return none

def simpArith? (e : Expr) : SimpM (Option Step) := do
  if !(← read).config.arith then return none
  let some (e', h) ← Linear.simp? e (← read).parent? | return none
  return Step.visit { expr := e', proof? := h }

def simpMatchCore? (app : MatcherApp) (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Step) := do
  for matchEq in (← Match.getEquationsFor app.matcherName).eqnNames do
    -- Try lemma
    match (← withReducible <| CustomSimp.tryTheorem? e { origin := .decl matchEq, proof := mkConst matchEq, rfl := (← isRflTheorem matchEq) } discharge?) with
    | none   => pure ()
    | some r => return some (Simp.Step.done r)
  return none

def simpMatch? (discharge? : Expr → SimpM (Option Expr)) (e : Expr) : SimpM (Option Step) := do
  if (← read).config.iota then
    let some app ← matchMatcherApp? e | return none
    simpMatchCore? app e discharge?
  else
    return none

def rewritePre (e : Expr) (discharge? : Expr → SimpM (Option Expr)) (rflOnly := false) : SimpM Step := do
  for thms in (← read).simpTheorems do
    if let some r ← rewrite? e thms.pre thms.erased discharge? (tag := "pre") (rflOnly := rflOnly) then
      return Step.visit r
  return Step.visit { expr := e }

def rewritePost (e : Expr) (discharge? : Expr → SimpM (Option Expr)) (rflOnly := false) : SimpM Step := do
  for thms in (← read).simpTheorems do
    if let some r ← rewrite? e thms.post thms.erased discharge? (tag := "post") (rflOnly := rflOnly) then
      return Step.visit r
  return Step.visit { expr := e }

def preDefault (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step := do
  let s ← rewritePre e discharge?
  andThen s tryRewriteUsingDecide?

def postDefault (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step := do
  let s ← rewritePost e discharge?
  let s ← andThen s (simpMatch? discharge?)
  let s ← andThen s simpArith?
  let s ← andThen s tryRewriteUsingDecide?
  andThen s tryRewriteCtorEq?

end SciLean.Meta.CustomSimp


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

Binder elimination
-/
import order tactic.converter.old_conv

namespace old_conv
open tactic monad

meta instance : monad_fail old_conv :=
{ fail := λ α s, (λr e, tactic.fail (to_fmt s) : old_conv α), ..old_conv.monad }

meta instance : has_monad_lift tactic old_conv :=
⟨λα, lift_tactic⟩

meta instance (α : Type) : has_coe (tactic α) (old_conv α) :=
⟨monad_lift⟩

meta def current_relation : old_conv name := λr lhs, return ⟨r, lhs, none⟩

meta def head_beta : old_conv unit :=
λ r e, do n ← tactic.head_beta e, return ⟨(), n, none⟩

/- congr should forward data! -/
meta def congr_arg : old_conv unit → old_conv unit := congr_core (return ())
meta def congr_fun : old_conv unit → old_conv unit := λc, congr_core c (return ())

meta def congr_rule (congr : expr) (cs : list (list expr → old_conv unit)) : old_conv unit := λr lhs, do
  meta_rhs ← infer_type lhs >>= mk_meta_var, -- is maybe overly restricted for `heq`
  t ← mk_app r [lhs, meta_rhs],
  ((), meta_pr) ← solve_aux t (do
    apply congr,
    focus $ cs.map $ λc, (do
      xs ← intros,
      conversion (head_beta >> c xs)),
    done),
  rhs ← instantiate_mvars meta_rhs,
  pr ← instantiate_mvars meta_pr,
  return ⟨(), rhs, some pr⟩

meta def congr_binder (congr : name) (cs : expr → old_conv unit) : old_conv unit := do
  e ← mk_const congr,
  congr_rule e [λbs, do [b] ← return bs, cs b]

meta def funext' : (expr → old_conv unit) → old_conv unit := congr_binder ``_root_.funext

meta def propext' {α : Type} (c : old_conv α) : old_conv α := λr lhs, (do
  guard (r = `iff),
  c r lhs)
<|> (do
  guard (r = `eq),
  ⟨res, rhs, pr⟩ ← c `iff lhs,
  match pr with
  | some pr := return ⟨res, rhs, (expr.const `propext [] : expr) lhs rhs pr⟩
  | none := return ⟨res, rhs, none⟩
  end)

meta def apply (pr : expr) : old_conv unit :=
λ r e, do
  sl ← simp_lemmas.mk.add pr,
  apply_lemmas sl r e

meta def applyc (n : name) : old_conv unit :=
λ r e, do
  sl ← simp_lemmas.mk.add_simp n,
  apply_lemmas sl r e

meta def apply' (n : name) : old_conv unit := do
  e ← mk_const n,
  congr_rule e []

end old_conv

open expr tactic old_conv

/- Binder elimination:

We assume a binder `B : p → Π (α : Sort u), (α → t) → t`, where `t` is a type depending on `p`.
Examples:
  ∃: there is no `p` and `t` is `Prop`.
  ⨅, ⨆: here p is `β` and `[complete_lattice β]`, `p` is `β`

Problem: ∀x, _ should be a binder, but is not a constant!

Provide a mechanism to rewrite:

  B (x : α) ..x.. (h : x = t), p x  =  B ..x/t.., p t

Here ..x.. are binders, maybe also some constants which provide commutativity rules with `B`.

-/

meta structure binder_eq_elim :=
(match_binder  : expr → tactic (expr × expr))    -- returns the bound type and body
(adapt_rel     : old_conv unit → old_conv unit)          -- optionally adapt `eq` to `iff`
(apply_comm    : old_conv unit)                      -- apply commutativity rule
(apply_congr   : (expr → old_conv unit) → old_conv unit) -- apply congruence rule
(apply_elim_eq : old_conv unit)                      -- (B (x : β) (h : x = t), s x) = s t

meta def binder_eq_elim.check_eq (b : binder_eq_elim) (x : expr) : expr → tactic unit
| `(@eq %%β %%l %%r) := guard ((l = x ∧ ¬ x.occurs r) ∨ (r = x ∧ ¬ x.occurs l))
| _ := fail "no match"

meta def binder_eq_elim.pull (b : binder_eq_elim) (x : expr) : old_conv unit := do
  (β, f) ← lhs >>= (lift_tactic ∘ b.match_binder),
  guard (¬ x.occurs β)
  <|> b.check_eq x β
  <|> (do
    b.apply_congr $ λx, binder_eq_elim.pull,
    b.apply_comm)

meta def binder_eq_elim.push (b : binder_eq_elim) : old_conv unit :=
  b.apply_elim_eq
<|> (do
  b.apply_comm,
  b.apply_congr $ λx, binder_eq_elim.push)
<|> (do
  b.apply_congr $ b.pull,
  binder_eq_elim.push)

meta def binder_eq_elim.check (b : binder_eq_elim) (x : expr) : expr → tactic unit
| e := do
  (β, f) ← b.match_binder e,
  b.check_eq x β
  <|> (do
    (lam n bi d bd) ← return f,
    x ← mk_local' n bi d,
    binder_eq_elim.check $ bd.instantiate_var x)

meta def binder_eq_elim.old_conv (b : binder_eq_elim) : old_conv unit := do
  (β, f) ← lhs >>= (lift_tactic ∘ b.match_binder),
  (lam n bi d bd) ← return f,
  x ← mk_local' n bi d,
  b.check x (bd.instantiate_var x),
  b.adapt_rel b.push

theorem {u v} exists_comm {α : Sort u} {β : Sort v} (p : α → β → Prop) :
  (∃a b, p a b) ↔ (∃b a, p a b) :=
⟨λ⟨a, ⟨b, h⟩⟩, ⟨b, ⟨a, h⟩⟩, λ⟨a, ⟨b, h⟩⟩, ⟨b, ⟨a, h⟩⟩⟩

theorem {u v} exists_elim_eq_left {α : Sort u} (a : α) (p : Π(a':α), a' = a → Prop) :
  (∃(a':α)(h : a' = a), p a' h) ↔ p a rfl :=
⟨λ⟨a', ⟨h, p_h⟩⟩, match a', h, p_h with ._, rfl, h := h end, λh, ⟨a, rfl, h⟩⟩

theorem {u v} exists_elim_eq_right {α : Sort u} (a : α) (p : Π(a':α), a = a' → Prop) :
  (∃(a':α)(h : a = a'), p a' h) ↔ p a rfl :=
⟨λ⟨a', ⟨h, p_h⟩⟩, match a', h, p_h with ._, rfl, h := h end, λh, ⟨a, rfl, h⟩⟩

meta def exists_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@Exists %%β %%f) ← return e, return (β, f)),
  adapt_rel     := propext',
  apply_comm    := applyc ``exists_comm,
  apply_congr   := congr_binder ``exists_congr,
  apply_elim_eq := apply' ``exists_elim_eq_left <|> apply' ``exists_elim_eq_right }

theorem {u v} forall_comm {α : Sort u} {β : Sort v} (p : α → β → Prop) :
  (∀a b, p a b) ↔ (∀b a, p a b) :=
⟨assume h b a, h a b, assume h b a, h a b⟩

theorem {u v} forall_elim_eq_left {α : Sort u} (a : α) (p : Π(a':α), a' = a → Prop) :
  (∀(a':α)(h : a' = a), p a' h) ↔ p a rfl :=
⟨λh, h a rfl, λh a' h_eq, match a', h_eq with ._, rfl := h end⟩

theorem {u v} forall_elim_eq_right {α : Sort u} (a : α) (p : Π(a':α), a = a' → Prop) :
  (∀(a':α)(h : a = a'), p a' h) ↔ p a rfl :=
⟨λh, h a rfl, λh a' h_eq, match a', h_eq with ._, rfl := h end⟩

meta def forall_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do (expr.pi n bi d bd) ← return e, return (d, expr.lam n bi d bd)),
  adapt_rel     := propext',
  apply_comm    := applyc ``forall_comm,
  apply_congr   := congr_binder ``forall_congr,
  apply_elim_eq := apply' ``forall_elim_eq_left <|> apply' ``forall_elim_eq_right }

meta def supr_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@lattice.supr %%α %%β %%cl %%f) ← return e, return (β, f)),
  adapt_rel     := λc, (do r ← current_relation, guard (r = `eq), c),
  apply_comm    := applyc ``lattice.supr_comm,
  apply_congr   := congr_arg ∘ funext',
  apply_elim_eq := applyc ``lattice.supr_supr_eq_left <|> applyc ``lattice.supr_supr_eq_right }

meta def infi_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@lattice.infi %%α %%β %%cl %%f) ← return e, return (β, f)),
  adapt_rel     := λc, (do r ← current_relation, guard (r = `eq), c),
  apply_comm    := applyc ``lattice.infi_comm,
  apply_congr   := congr_arg ∘ funext',
  apply_elim_eq := applyc ``lattice.infi_infi_eq_left <|> applyc ``lattice.infi_infi_eq_right }

universes u v w w₂
variables {α : Type u} {β : Type v} {ι : Sort w} {ι₂ : Sort w₂} {s t : set α} {a : α}

@[simp] theorem mem_image {f : α → β} {b : β} : b ∈ set.image f s = ∃a, a ∈ s ∧ f a = b := rfl

section
open lattice
variables [complete_lattice α]

theorem Inf_image {s : set β} {f : β → α} : Inf (set.image f s) = (⨅ a ∈ s, f a) :=
begin
  simp [Inf_eq_infi, infi_and],
  conversion infi_eq_elim.old_conv,
end

theorem Sup_image {s : set β} {f : β → α} : Sup (set.image f s) = (⨆ a ∈ s, f a) :=
begin
  simp [Sup_eq_supr, supr_and],
  conversion supr_eq_elim.old_conv,
end

end


import Lean

-- Coordinates in a two dimensional grid. ⟨0,0⟩ is the upper left.
structure Coords where
  x : Nat -- column number
  y : Nat -- row number
deriving BEq

instance : ToString Coords where
  toString := (λ ⟨x,y⟩ => String.join ["Coords.mk ", toString x, ", ", toString y])

structure GameState where
  size     : Coords      -- coordinates of bottom-right cell
  position : Coords      -- row and column of the player
  walls    : List Coords -- maze cells that are not traversible

-- We define custom syntax for GameState.

declare_syntax_cat game_cell
declare_syntax_cat game_cell_sequence
declare_syntax_cat game_row
declare_syntax_cat horizontal_border
declare_syntax_cat game_top_row
declare_syntax_cat game_bottom_row

syntax "─" : horizontal_border

syntax "\n┌" horizontal_border* "┐\n" : game_top_row

syntax "└" horizontal_border* "┘\n" : game_bottom_row

syntax "░" : game_cell -- empty
syntax "▓" : game_cell -- wall
syntax "@" : game_cell -- player

syntax "│" game_cell* "│\n" : game_row

syntax:max game_top_row game_row* game_bottom_row : term

inductive CellContents where
  | empty  : CellContents
  | wall   : CellContents
  | player : CellContents

def update_state_with_row_aux : Nat → Nat → List CellContents → GameState → GameState
| currentRowNum, currentColNum, [], oldState => oldState
| currentRowNum, currentColNum, cell::contents, oldState =>
    let oldState' := update_state_with_row_aux currentRowNum (currentColNum+1) contents oldState
    match cell with
    | CellContents.empty => oldState'
    | CellContents.wall => {oldState' .. with
                            walls := ⟨currentColNum,currentRowNum⟩::oldState'.walls}
    | CellContents.player => {oldState' .. with
                              position := ⟨currentColNum,currentRowNum⟩}

def update_state_with_row : Nat → List CellContents → GameState → GameState
| currentRowNum, rowContents, oldState => update_state_with_row_aux currentRowNum 0 rowContents oldState

-- size, current row, remaining cells -> gamestate
def game_state_from_cells_aux : Coords → Nat → List (List CellContents) → GameState
| size, _, [] => ⟨size, ⟨0,0⟩, []⟩
| size, currentRow, row::rows =>
        let prevState := game_state_from_cells_aux size (currentRow + 1) rows
        update_state_with_row currentRow row prevState

-- size, remaining cells -> gamestate
def game_state_from_cells : Coords → List (List CellContents) → GameState
| size, cells => game_state_from_cells_aux size 0 cells

def termOfCell : Lean.TSyntax `game_cell → Lean.MacroM (Lean.TSyntax `term)
| `(game_cell| ░) => `(CellContents.empty)
| `(game_cell| ▓) => `(CellContents.wall)
| `(game_cell| @) => `(CellContents.player)
| _ => Lean.Macro.throwError "unknown game cell"

def termOfGameRow : Nat → Lean.TSyntax `game_row → Lean.MacroM (Lean.TSyntax `term)
| expectedRowSize, `(game_row| │$cells:game_cell*│) =>
      do if cells.size != expectedRowSize
         then Lean.Macro.throwError "row has wrong size"
         let cells' ← Array.mapM termOfCell cells
         `([$cells',*])
| _, _ => Lean.Macro.throwError "unknown game row"

macro_rules
| `(┌ $tb:horizontal_border* ┐
    $rows:game_row*
    └ $bb:horizontal_border* ┘) =>
      do let rsize := Lean.Syntax.mkNumLit (toString rows.size)
         let csize := Lean.Syntax.mkNumLit (toString tb.size)
         if tb.size != bb.size then Lean.Macro.throwError "top/bottom border mismatch"
         let rows' ← Array.mapM (termOfGameRow tb.size) rows
         `(game_state_from_cells ⟨$csize,$rsize⟩ [$rows',*])

---------------------------
-- Now we define a delaborator that will cause GameState to be rendered as a maze.

def extractXY : Lean.Expr → Lean.MetaM Coords
| e => do
  let e':Lean.Expr ← (Lean.Meta.whnf e)
  let sizeArgs := Lean.Expr.getAppArgs e'
  let x ← Lean.Meta.whnf sizeArgs[0]!
  let y ← Lean.Meta.whnf sizeArgs[1]!
  let numCols := (Lean.Expr.natLit? x).get!
  let numRows := (Lean.Expr.natLit? y).get!
  return Coords.mk numCols numRows

partial def extractWallList : Lean.Expr → Lean.MetaM (List Coords)
| exp => do
  let exp':Lean.Expr ← (Lean.Meta.whnf exp)
  let f := Lean.Expr.getAppFn exp'
  if f.constName!.toString == "List.cons"
  then let consArgs := Lean.Expr.getAppArgs exp'
       let rest ← extractWallList consArgs[2]!
       let ⟨wallCol, wallRow⟩ ← extractXY consArgs[1]!
       return (Coords.mk wallCol wallRow) :: rest
  else return [] -- "List.nil"

partial def extractGameState : Lean.Expr → Lean.MetaM GameState
| exp => do
    let exp': Lean.Expr ← (Lean.Meta.whnf exp)
    let gameStateArgs := Lean.Expr.getAppArgs exp'
    let size ← extractXY gameStateArgs[0]!
    let playerCoords ← extractXY gameStateArgs[1]!
    let walls ← extractWallList gameStateArgs[2]!
    pure ⟨size, playerCoords, walls⟩

def update2dArray {α : Type} : Array (Array α) → Coords → α → Array (Array α)
| a, ⟨x,y⟩, v =>
   Array.set! a y $ Array.set! (Array.get! a y) x v

def update2dArrayMulti {α : Type} : Array (Array α) → List Coords → α → Array (Array α)
| a, [], _ => a
| a, c::cs, v =>
     let a' := update2dArrayMulti a cs v
     update2dArray a' c v

def delabGameRow : Array (Lean.TSyntax `game_cell) → Lean.PrettyPrinter.Delaborator.DelabM (Lean.TSyntax `game_row)
| a => `(game_row| │ $a:game_cell* │)

def delabGameState : Lean.Expr → Lean.PrettyPrinter.Delaborator.Delab
| e =>
  do guard $ e.getAppNumArgs == 3
     let ⟨⟨numCols, numRows⟩, playerCoords, walls⟩ ←
       try extractGameState e
       catch err => failure -- can happen if game state has variables in it

     let topBar := Array.mkArray numCols $ ← `(horizontal_border| ─)
     let emptyCell ← `(game_cell| ░)
     let emptyRow := Array.mkArray numCols emptyCell
     let emptyRowStx ← `(game_row| │$emptyRow:game_cell*│)
     let allRows := Array.mkArray numRows emptyRowStx

     let a0 := Array.mkArray numRows $ Array.mkArray numCols emptyCell
     let a1 := update2dArray a0 playerCoords $ ← `(game_cell| @)
     let a2 := update2dArrayMulti a1 walls $ ← `(game_cell| ▓)
     let aa ← Array.mapM delabGameRow a2

     `(┌$topBar:horizontal_border*┐
       $aa:game_row*
       └$topBar:horizontal_border*┘)

-- The attribute [delab] registers this function as a delaborator for the GameState.mk constructor.
@[delab app.GameState.mk] def delabGameStateMk : Lean.PrettyPrinter.Delaborator.Delab := do
  let e ← Lean.PrettyPrinter.Delaborator.SubExpr.getExpr
  delabGameState e

-- We register the same elaborator for applications of the game_state_from_cells function.
@[delab app.game_state_from_cells] def delabGameState' : Lean.PrettyPrinter.Delaborator.Delab :=
  do let e ← Lean.PrettyPrinter.Delaborator.SubExpr.getExpr
     let e' ← (Lean.Meta.whnf e)
     delabGameState e'

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

inductive Move where
  | east  : Move
  | west  : Move
  | north : Move
  | south : Move

@[simp]
def make_move : GameState → Move → GameState
| ⟨s, ⟨x,y⟩, w⟩, Move.east =>
             if w.notElem ⟨x+1, y⟩ ∧ x + 1 ≤ s.x
             then ⟨s, ⟨x+1, y⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩
| ⟨s, ⟨x,y⟩, w⟩, Move.west =>
             if w.notElem ⟨x-1, y⟩
             then ⟨s, ⟨x-1, y⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩
| ⟨s, ⟨x,y⟩, w⟩, Move.north =>
             if w.notElem ⟨x, y-1⟩
             then ⟨s, ⟨x, y-1⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩
| ⟨s, ⟨x,y⟩, w⟩, Move.south =>
             if w.notElem ⟨x, y + 1⟩ ∧ y + 1 ≤ s.y
             then ⟨s, ⟨x, y+1⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩

def is_win : GameState → Prop
| ⟨⟨sx, sy⟩, ⟨x,y⟩, w⟩ => x = 0 ∨ y = 0 ∨ x + 1 = sx ∨ y + 1 = sy

def can_escape (state : GameState) : Prop :=
  ∃ (gs : List Move), is_win (List.foldl make_move state gs)

theorem can_still_escape (g : GameState) (m : Move) (hg : can_escape (make_move g m)) : can_escape g :=
 have ⟨pms, hpms⟩ := hg
 Exists.intro (m::pms) hpms

theorem step_west
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x,y⟩)
  (W : can_escape ⟨s,⟨x,y⟩,w⟩) :
  can_escape ⟨s,⟨x+1,y⟩,w⟩ :=
   by have hmm : GameState.mk s ⟨x,y⟩ w = make_move ⟨s,⟨x+1, y⟩,w⟩ Move.west :=
               by have h' : x + 1 - 1 = x := rfl
                  simp [h', hclear']
      rw [hmm] at W
      exact can_still_escape ⟨s,⟨x+1,y⟩,w⟩ Move.west W

theorem step_east
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x+1,y⟩)
  (hinbounds : x + 1 ≤ s.x)
  (E : can_escape ⟨s,⟨x+1,y⟩,w⟩) :
  can_escape ⟨s,⟨x, y⟩,w⟩ :=
    by have hmm : GameState.mk s ⟨x+1,y⟩ w = make_move ⟨s, ⟨x,y⟩,w⟩ Move.east :=
         by simp [hclear', hinbounds]
       rw [hmm] at E
       exact can_still_escape ⟨s, ⟨x,y⟩, w⟩ Move.east E

theorem step_north
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x,y⟩)
  (N : can_escape ⟨s,⟨x,y⟩,w⟩) :
  can_escape ⟨s,⟨x, y+1⟩,w⟩ :=
    by have hmm : GameState.mk s ⟨x,y⟩ w = make_move ⟨s,⟨x, y+1⟩,w⟩ Move.north :=
         by have h' : y + 1 - 1 = y := rfl
            simp [h', hclear']
       rw [hmm] at N
       exact can_still_escape ⟨s,⟨x,y+1⟩,w⟩ Move.north N

theorem step_south
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x,y+1⟩)
  (hinbounds : y + 1 ≤ s.y)
  (S : can_escape ⟨s,⟨x,y+1⟩,w⟩) :
  can_escape ⟨s,⟨x, y⟩,w⟩ :=
    by have hmm : GameState.mk s ⟨x,y+1⟩ w = make_move ⟨s,⟨x, y⟩,w⟩ Move.south :=
            by simp [hclear', hinbounds]
       rw [hmm] at S
       exact can_still_escape ⟨s,⟨x,y⟩,w⟩ Move.south S

def escape_west {sx sy : Nat} {y : Nat} {w : List Coords} : can_escape ⟨⟨sx, sy⟩,⟨0, y⟩,w⟩ :=
    ⟨[], Or.inl rfl⟩

def escape_east {sy x y : Nat} {w : List Coords} : can_escape ⟨⟨x+1, sy⟩,⟨x, y⟩,w⟩ :=
  ⟨[], Or.inr $ Or.inr $ Or.inl rfl⟩

def escape_north {sx sy : Nat} {x : Nat} {w : List Coords} : can_escape ⟨⟨sx, sy⟩,⟨x, 0⟩,w⟩ :=
  ⟨[], Or.inr $ Or.inl rfl⟩

def escape_south {sx x y : Nat} {w: List Coords} : can_escape ⟨⟨sx, y+1⟩,⟨x, y⟩,w⟩ :=
  ⟨[], Or.inr $ Or.inr $ Or.inr rfl⟩

-- Define an "or" tactic combinator, like <|> in Lean 3.
elab t1:tactic " ⟨|⟩ " t2:tactic : tactic =>
   try Lean.Elab.Tactic.evalTactic t1
   catch err => Lean.Elab.Tactic.evalTactic t2

elab "fail" m:term  : tactic => throwError m

macro "out" : tactic => `(tactic|
  apply escape_north ⟨|⟩ apply escape_south ⟨|⟩
  apply escape_east ⟨|⟩ apply escape_west ⟨|⟩
  fail "not currently at maze boundary")

def maze1 := ┌───┐
             │▓▓▓│
             │░@▓│
             │▓▓▓│
             └───┘

def foo : can_escape maze1 := by
  apply step_west
  set_option trace.Meta.debug true in
  simp
  out