/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Parallel computation of a computable sequence of computations by
a diagonal enumeration.
The important theorems of this operation are proven as
terminates_parallel and exists_of_mem_parallel.
(This operation is nondeterministic in the sense that it does not
honor sequence equivalence (irrelevance of computation time).)
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.seq.wseq
import Mathlib.PostPort

universes u v

namespace Mathlib

namespace computation

def parallel.aux2 {α : Type u} : List (computation α) → α ⊕ List (computation α) :=
  list.foldr (fun (c : computation α) (o : α ⊕ List (computation α)) => sorry) (sum.inr [])

def parallel.aux1 {α : Type u} :
    List (computation α) × wseq (computation α) → α ⊕ List (computation α) × wseq (computation α) :=
  sorry

/-- Parallel computation of an infinite stream of computations,
  taking the first result -/
def parallel {α : Type u} (S : wseq (computation α)) : computation α := corec sorry ([], S)

theorem terminates_parallel.aux {α : Type u} {l : List (computation α)} {S : wseq (computation α)}
    {c : computation α} : c ∈ l → terminates c → terminates (corec parallel.aux1 (l, S)) :=
  sorry

theorem terminates_parallel {α : Type u} {S : wseq (computation α)} {c : computation α} (h : c ∈ S)
    [T : terminates c] : terminates (parallel S) :=
  sorry

theorem exists_of_mem_parallel {α : Type u} {S : wseq (computation α)} {a : α}
    (h : a ∈ parallel S) : ∃ (c : computation α), ∃ (H : c ∈ S), a ∈ c :=
  sorry

theorem map_parallel {α : Type u} {β : Type v} (f : α → β) (S : wseq (computation α)) :
    map f (parallel S) = parallel (wseq.map (map f) S) :=
  sorry

theorem parallel_empty {α : Type u} (S : wseq (computation α)) (h : wseq.head S ~> none) :
    parallel S = empty α :=
  sorry

-- The reason this isn't trivial from exists_of_mem_parallel is because it eliminates to Sort

def parallel_rec {α : Type u} {S : wseq (computation α)} (C : α → Sort v)
    (H : (s : computation α) → s ∈ S → (a : α) → a ∈ s → C a) {a : α} (h : a ∈ parallel S) : C a :=
  let T : wseq (computation (α × computation α)) :=
    wseq.map (fun (c : computation α) => map (fun (a : α) => (a, c)) c) S;
  (fun (_x : α × computation α) (e : get (parallel T) = _x) =>
      Prod.rec
        (fun (a' : α) (c : computation α) (e : get (parallel T) = (a', c)) =>
          and.dcases_on sorry fun (ac : a ∈ c) (cs : c ∈ S) => H c cs a ac)
        _x e)
    (get (parallel T)) sorry

theorem parallel_promises {α : Type u} {S : wseq (computation α)} {a : α}
    (H : ∀ (s : computation α), s ∈ S → s ~> a) : parallel S ~> a :=
  sorry

theorem mem_parallel {α : Type u} {S : wseq (computation α)} {a : α}
    (H : ∀ (s : computation α), s ∈ S → s ~> a) {c : computation α} (cs : c ∈ S) (ac : a ∈ c) :
    a ∈ parallel S :=
  mem_of_promises (parallel S) (parallel_promises H)

theorem parallel_congr_lem {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)}
    {a : α} (H : wseq.lift_rel equiv S T) :
    (∀ (s : computation α), s ∈ S → s ~> a) ↔ ∀ (t : computation α), t ∈ T → t ~> a :=
  sorry

-- The parallel operation is only deterministic when all computation paths lead to the same value

theorem parallel_congr_left {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)}
    {a : α} (h1 : ∀ (s : computation α), s ∈ S → s ~> a) (H : wseq.lift_rel equiv S T) :
    parallel S ~ parallel T :=
  sorry

theorem parallel_congr_right {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)}
    {a : α} (h2 : ∀ (t : computation α), t ∈ T → t ~> a) (H : wseq.lift_rel equiv S T) :
    parallel S ~ parallel T :=
  parallel_congr_left (iff.mpr (parallel_congr_lem H) h2) H

end Mathlib


import .presheaves

open category_theory opposite

noncomputable theory

variables (C : Type) [category.{0} C]

inductive prod_coprod : Type
| of_cat' : C → prod_coprod
| prod : prod_coprod → prod_coprod → prod_coprod
| coprod : prod_coprod → prod_coprod → prod_coprod

variable {C}

namespace prod_coprod

inductive hom_syntax : Π (X Y : prod_coprod C), Type
| of_cat {X Y : C} : (X ⟶ Y) → hom_syntax (of_cat' X) (of_cat' Y)
| prod_mk {X Y Z : prod_coprod C} : hom_syntax X Y → hom_syntax X Z → hom_syntax X (Y.prod Z)
| fst {X Y : prod_coprod C} : hom_syntax (X.prod Y) X
| snd {X Y : prod_coprod C} : hom_syntax (X.prod Y) Y
| coprod_mk {X Y Z : prod_coprod C} : hom_syntax X Z → hom_syntax Y Z → hom_syntax (X.coprod Y) Z
| inl {X Y : prod_coprod C} : hom_syntax X (X.coprod Y)
| inr {X Y : prod_coprod C} : hom_syntax Y (X.coprod Y)
| id (X : prod_coprod C) : hom_syntax X X
| comp {X Y Z : prod_coprod C} : hom_syntax X Y → hom_syntax Y Z → hom_syntax X Z

namespace hom_syntax

inductive rel : Π {X Y : prod_coprod C}, hom_syntax X Y → hom_syntax X Y → Prop
| refl {X Y : prod_coprod C} (f : hom_syntax X Y) : rel f f
| symm {X Y : prod_coprod C} {f g : hom_syntax X Y} : rel f g → rel g f
| trans {X Y : prod_coprod C} {f g h : hom_syntax X Y} : rel f g → rel g h → rel f h
| comp_congr {X Y Z : prod_coprod C} {f₁ f₂ : hom_syntax X Y} {g₁ g₂ : hom_syntax Y Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.comp g₁) (f₂.comp g₂)
| prod_mk_congr {X Y Z : prod_coprod C} {f₁ f₂ : hom_syntax X Y} {g₁ g₂ : hom_syntax X Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.prod_mk g₁) (f₂.prod_mk g₂)
| coprod_mk_congr {X Y Z : prod_coprod C} {f₁ f₂ : hom_syntax X Z} {g₁ g₂ : hom_syntax Y Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.coprod_mk g₁) (f₂.coprod_mk g₂)
| id_comp {X Y : prod_coprod C} (f : hom_syntax X Y) : rel ((hom_syntax.id X).comp f) f
| comp_id {X Y : prod_coprod C} (f : hom_syntax X Y) : rel (f.comp (hom_syntax.id Y)) f
| assoc {W X Y Z : prod_coprod C} (f : hom_syntax W X) (g : hom_syntax X Y) (h : hom_syntax Y Z) :
  rel ((f.comp g).comp h) (f.comp (g.comp h))
| of_cat_id {X : C} : rel (hom_syntax.of_cat (𝟙 X)) (hom_syntax.id (of_cat' X))
| of_cat_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  rel (hom_syntax.of_cat (f ≫ g)) (hom_syntax.comp (hom_syntax.of_cat f) (hom_syntax.of_cat g))
| mk_comp_fst {X Y Z : prod_coprod C} (f : hom_syntax X Y) (g : hom_syntax X Z) :
  rel (hom_syntax.comp (hom_syntax.prod_mk f g) hom_syntax.fst) f
| mk_comp_snd {X Y Z : prod_coprod C} (f : hom_syntax X Y) (g : hom_syntax X Z) :
  rel (hom_syntax.comp (hom_syntax.prod_mk f g) hom_syntax.snd) g
| prod_eta {X Y Z : prod_coprod C} (f : hom_syntax X (Y.prod Z)) :
  rel (hom_syntax.prod_mk (f.comp hom_syntax.fst) (f.comp hom_syntax.snd)) f
| inl_comp_mk {X Y Z : prod_coprod C} (f : hom_syntax X Z) (g : hom_syntax Y Z) :
  rel (hom_syntax.comp hom_syntax.inl (hom_syntax.coprod_mk f g)) f
| inr_comp_mk {X Y Z : prod_coprod C} (f : hom_syntax X Z) (g : hom_syntax Y Z) :
  rel (hom_syntax.comp hom_syntax.inr (hom_syntax.coprod_mk f g)) g
| coprod_eta {X Y Z : prod_coprod C} (f : hom_syntax (X.coprod Y) Z) :
  rel (hom_syntax.coprod_mk (hom_syntax.inl.comp f) (hom_syntax.inr.comp f)) f

attribute [refl] rel.refl
attribute [symm] rel.symm
attribute [trans] rel.trans

infixl ` ♥ `: 50 := rel

lemma rel_prod {X Y Z : prod_coprod C} {f g : hom_syntax X (Y.prod Z)}
  (h₁ : rel (f.comp hom_syntax.fst) (g.comp hom_syntax.fst))
  (h₂ : rel (f.comp hom_syntax.snd) (g.comp hom_syntax.snd)) :
  rel f g :=
calc f ♥ hom_syntax.prod_mk (f.comp hom_syntax.fst) (f.comp hom_syntax.snd) : rel.symm (rel.prod_eta f)
   ... ♥ hom_syntax.prod_mk (g.comp hom_syntax.fst) (g.comp hom_syntax.snd) : rel.prod_mk_congr h₁ h₂
   ... ♥ g : rel.prod_eta g

lemma rel_coprod {X Y Z : prod_coprod C} {f g : hom_syntax (X.coprod Y) Z}
  (h₁ : rel (hom_syntax.inl.comp f) (hom_syntax.inl.comp g))
  (h₂ : rel (hom_syntax.inr.comp f) (hom_syntax.inr.comp g)) :
  rel f g :=
calc f ♥ hom_syntax.coprod_mk (hom_syntax.inl.comp f) (hom_syntax.inr.comp f) : rel.symm (rel.coprod_eta f)
   ... ♥ hom_syntax.coprod_mk (hom_syntax.inl.comp g) (hom_syntax.inr.comp g) : rel.coprod_mk_congr h₁ h₂
   ... ♥ g : rel.coprod_eta g

instance rel_setoid (X Y : prod_coprod C) : setoid (hom_syntax X Y) :=
{ r := rel,
  iseqv := ⟨rel.refl, λ _ _, rel.symm, λ _ _ _, rel.trans⟩ }

end hom_syntax

section hom_syntax

open hom_syntax

def hom (X Y : prod_coprod C) : Type := quotient (hom_syntax.rel_setoid X Y)

instance : category_struct (prod_coprod C) :=
{ hom := hom,
  id := λ X, quotient.mk' (hom_syntax.id X),
  comp := λ X Y Z f g, quotient.lift_on₂ f g (λ f g, quotient.mk' (hom_syntax.comp f g))
    (λ f₁ g₁ f₂ g₂ hf hg, quotient.sound (rel.comp_congr hf hg)) }

instance : category (prod_coprod C) :=
{ id_comp' := λ X Y f, quotient.induction_on f (λ f, quotient.sound (rel.id_comp f)),
  comp_id' := λ X Y f, quotient.induction_on f (λ f, quotient.sound (rel.comp_id f)),
  assoc' := λ W X Y Z f g h, quotient.induction_on₃ f g h
    (λ f g h, quotient.sound (rel.assoc f g h)) }

def of_syntax {X Y : prod_coprod C} : hom_syntax X Y → (X ⟶ Y) := quotient.mk

def of_cat : C ⥤ prod_coprod C :=
{ obj := λ X, of_cat' X,
  map := λ X Y f, of_syntax (hom_syntax.of_cat f),
  map_id' := λ X, quotient.sound rel.of_cat_id,
  map_comp' := λ X Y Z f g, quotient.sound (rel.of_cat_comp f g) }

@[simp] lemma of_cat_obj (X : C) : of_cat.obj X = of_cat' X := rfl

def prod_mk {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) : X ⟶ (Y.prod Z) :=
quotient.lift_on₂ f g (λ f g, of_syntax (prod_mk f g)) begin
  intros,
  dsimp,
  refine quotient.sound _,
  refine rel.prod_mk_congr _ _; assumption
end

def fst {X Y : prod_coprod C} : (X.prod Y) ⟶ X :=
of_syntax fst

def snd {X Y : prod_coprod C} : (X.prod Y) ⟶ Y :=
of_syntax snd

@[simp] lemma prod_mk_comp_fst {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) :
  prod_mk f g ≫ fst = f :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.mk_comp_fst _ _))

@[simp] lemma prod_mk_comp_snd {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) :
  prod_mk f g ≫ snd = g :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.mk_comp_snd _ _))

lemma prod_mk_eta {X Y Z : prod_coprod C} (f : X ⟶ Y.prod Z) :
  prod_mk (f ≫ fst) (f ≫ snd) = f :=
quotient.induction_on f (λ f, quotient.sound (hom_syntax.rel.prod_eta _))

@[ext] lemma prod_hom_ext {X Y Z : prod_coprod C} {f g : X ⟶ Y.prod Z}
  (h₁ : f ≫ fst = g ≫ fst) (h₂ : f ≫ snd = g ≫ snd) : f = g :=
begin
  conv_lhs { rw ← prod_mk_eta f },
  rw [h₁, h₂, prod_mk_eta]
end

def coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) : (X.coprod Y) ⟶ Z :=
quotient.lift_on₂ f g (λ f g, of_syntax (coprod_mk f g)) begin
  intros,
  dsimp,
  refine quotient.sound _,
  refine rel.coprod_mk_congr _ _; assumption
end

def inl {X Y : prod_coprod C} : X ⟶ (X.coprod Y) :=
of_syntax inl

def inr {X Y : prod_coprod C} : Y ⟶ (X.coprod Y) :=
of_syntax inr

@[elab_as_eliminator] lemma hom_induction
  {motive : Π (X Y : prod_coprod C), (X ⟶ Y) → Prop}
  {X Y : prod_coprod C} (f : X ⟶ Y)
  (h₁ : Π {X Y : C} (f : X ⟶ Y), motive _ _ (of_cat.map f))
  (h₂ : Π {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z),
     motive X Y f → motive X Z g → motive _ _ (prod_mk f g))
  (h₃ : Π {X Y : prod_coprod C}, motive (X.prod Y) X fst)
  (h₄ : Π {X Y : prod_coprod C}, motive (X.prod Y) Y snd)
  (h₅ : Π {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z),
     motive X Z f → motive Y Z g → motive _ _ (coprod_mk f g))
  (h₆ : Π {X Y : prod_coprod C}, motive X (X.coprod Y) inl)
  (h₇ : Π {X Y : prod_coprod C}, motive Y (X.coprod Y) inr)
  (h₈ : Π (X : prod_coprod C), motive X X (𝟙 X))
  (h₉ : Π {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : Y ⟶ Z),
     motive X Y f → motive Y Z g → motive X Z (f ≫ g)) :
  motive X Y f :=
quotient.induction_on f
  begin
    intro f,
    apply hom_syntax.rec_on f; try { assumption },
    { intros _ _ _ f g,
      exact h₂ (of_syntax f) (of_syntax g) },
    { intros _ _ _ f g,
      exact h₅ (of_syntax f) (of_syntax g) },
    { intros _ _ _ f g,
      exact h₉ (of_syntax f) (of_syntax g) }
  end

@[simp] lemma inl_comp_coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inl ≫ coprod_mk f g = f :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.inl_comp_mk _ _))

@[simp] lemma inr_comp_coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inr ≫ coprod_mk f g = g :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.inr_comp_mk _ _))

lemma coprod_mk_eta {X Y Z : prod_coprod C} (f : X.coprod Y ⟶ Z) :
  coprod_mk (inl ≫ f) (inr ≫ f) = f :=
quotient.induction_on f (λ f, quotient.sound (hom_syntax.rel.coprod_eta _))

@[ext] lemma coprod_hom_ext {X Y Z : prod_coprod C} {f g : X.coprod Y ⟶ Z}
  (h₁ : inl ≫ f = inl ≫ g ) (h₂ : inr ≫ f = inr ≫ g) : f = g :=
begin
  conv_lhs { rw ← coprod_mk_eta f },
  rw [h₁, h₂, coprod_mk_eta]
end

def to_presheaf_obj (X : prod_coprod C) : (Cᵒᵖ ⥤ Type) :=
prod_coprod.rec_on X
  yoneda.obj
  (λ X Y ih₁ ih₂, Pprod ih₁ ih₂)
  (λ X Y ih₁ ih₂, Pcoprod ih₁ ih₂)

@[simp] def to_presheaf_hom_syntax : Π {X Y : prod_coprod C}, hom_syntax X Y →
  ((to_presheaf_obj X) ⟶ (to_presheaf_obj Y))
| _ _ (hom_syntax.of_cat f) := yoneda.map f
| _ _ (hom_syntax.prod_mk f g) := Pprod_lift (to_presheaf_hom_syntax f) (to_presheaf_hom_syntax g)
| _ _ (hom_syntax.fst) := Pprod_fst
| _ _ (hom_syntax.snd) := Pprod_snd
| _ _ (hom_syntax.coprod_mk f g) := Pcoprod_lift (to_presheaf_hom_syntax f) (to_presheaf_hom_syntax g)
| _ _ (hom_syntax.inl) := Pcoprod_inl
| _ _ (hom_syntax.inr) := Pcoprod_inr
| _ _ (hom_syntax.id X) := 𝟙 _
| _ _ (hom_syntax.comp f g) := to_presheaf_hom_syntax f ≫ to_presheaf_hom_syntax g

lemma to_presheaf_hom_syntax_comp {X Y Z : prod_coprod C} (f : hom_syntax X Y) (g : hom_syntax Y Z) :
  to_presheaf_hom_syntax (f.comp g) = to_presheaf_hom_syntax f ≫ to_presheaf_hom_syntax g := rfl

lemma to_presheaf_hom_syntax_rel {X Y : prod_coprod C} (f g : hom_syntax X Y) (h : rel f g) :
  to_presheaf_hom_syntax f = to_presheaf_hom_syntax g :=
begin
  induction h; try { simp * }; try { ext }; try { refl }; tidy,
end

def to_presheaf : prod_coprod C ⥤ (Cᵒᵖ ⥤ Type) :=
{ obj := to_presheaf_obj,
  map := λ X Y f, quotient.lift_on f (to_presheaf_hom_syntax) to_presheaf_hom_syntax_rel,
  map_id' := λ _, rfl,
  map_comp' := λ _ _ _ f g, quotient.induction_on₂ f g begin intros, simp,
    erw quotient.lift_on_mk,
    simp [to_presheaf_hom_syntax_comp] end }

@[simp] lemma to_presheaf_obj_of_cat (X : C) : to_presheaf.obj (of_cat' X) = yoneda.obj X := rfl

@[simp] lemma to_presheaf_obj_prod (X Y : prod_coprod C) : to_presheaf.obj (prod X Y) =
  Pprod (to_presheaf_obj X) (to_presheaf_obj Y) := rfl

@[simp] lemma to_presheaf_obj_coprod (X Y : prod_coprod C) : to_presheaf.obj (coprod X Y) =
  Pcoprod (to_presheaf_obj X) (to_presheaf_obj Y) := rfl

@[simp] lemma to_presheaf_of_cat {X Y : C} (f : X ⟶ Y) :
  to_presheaf.map (of_cat.map f) = yoneda.map f := rfl

@[simp] lemma to_presheaf_prod_mk {X Y Z : prod_coprod C}
  (f : X ⟶ Y) (g : X ⟶ Z) :
  to_presheaf.map (prod_mk f g) = Pprod_lift (to_presheaf.map f) (to_presheaf.map g) :=
begin
  refine quotient.induction_on₂ f g _,
  intros, refl
end

@[simp] lemma to_presheaf_coprod_mk {X Y Z : prod_coprod C}
  (f : X ⟶ Z) (g : Y ⟶ Z) :
  to_presheaf.map (coprod_mk f g) = Pcoprod_lift (to_presheaf.map f) (to_presheaf.map g) :=
begin
  refine quotient.induction_on₂ f g _,
  intros, refl
end

@[simp] lemma to_presheaf_fst {X Y : prod_coprod C} :
  to_presheaf.map (fst : X.prod Y ⟶ X) = Pprod_fst := rfl

@[simp] lemma to_presheaf_snd {X Y : prod_coprod C} :
  to_presheaf.map (snd : X.prod Y ⟶ Y) = Pprod_snd := rfl

@[simp] lemma to_presheaf_inl {X Y : prod_coprod C} :
  to_presheaf.map (inl : X ⟶ X.coprod Y) = Pcoprod_inl := rfl

@[simp] lemma to_presheaf_inr {X Y : prod_coprod C} :
  to_presheaf.map (inr : Y ⟶ X.coprod Y) = Pcoprod_inr := rfl

end hom_syntax

def transformation_syntax : Π {X : C} {Y : prod_coprod C}, (to_presheaf.obj Y).obj (opposite.op X) →
  hom_syntax (of_cat' X) Y
| X (of_cat' Y) := λ f, hom_syntax.of_cat f
| X (prod Y Z) := λ f, hom_syntax.prod_mk (transformation_syntax f.1) (transformation_syntax f.2)
| X (coprod Y Z) := λ f, f.elim
  (λ f, (transformation_syntax f).comp hom_syntax.inl)
  (λ f, (transformation_syntax f).comp hom_syntax.inr)

@[simp] def transformation : Π {X : C} {Y : prod_coprod C},
  (to_presheaf.obj Y).obj (opposite.op X) →
  ((of_cat' X) ⟶ Y)
| X (of_cat' Y) := λ f, of_cat.map f
| X (prod Y Z) := λ f, prod_mk (transformation f.1) (transformation f.2)
| X (coprod Y Z) := λ f, f.elim
  (λ f, (transformation f) ≫ inl)
  (λ f, (transformation f) ≫ inr)

lemma transformation_eq_of_syntax_transformation_syntax {X : C} {Y : prod_coprod C}
  (x : (to_presheaf.obj Y).obj (opposite.op X)) :
  transformation x = of_syntax (transformation_syntax x) :=
by induction Y; simp [transformation, transformation_syntax, *]; tidy

lemma transformation_left_naturality : Π {X Y : prod_coprod C}
  (f : X ⟶ Y) ⦃Z : C⦄ (z : (to_presheaf.obj X).obj (op Z)),
  transformation ((to_presheaf.map f).app (op Z) z) =
  transformation z ≫ f :=
begin
  intros X Y f Z z, revert Z z,
  refine hom_induction f _ _ _ _ _ _ _ _ _; intros; try { ext };
  try { dsimp at * }; try { simp * at * },
  cases z; simp *
end

def transformation_inverse {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) :
  (to_presheaf.obj Y).obj (opposite.op X) :=
yoneda_equiv (to_presheaf.map f)

lemma transformation_transformation_inverse {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : transformation (transformation_inverse f) = f :=
begin
  simp [yoneda_equiv, transformation_inverse, transformation_left_naturality],
  exact category.id_comp _,
end

lemma transformation_inverse_transformation {X : C} {Y : prod_coprod C}
  (f : (to_presheaf.obj Y).obj (opposite.op X)) :
  transformation_inverse (transformation f) = f :=
begin
  simp [yoneda_equiv, transformation_inverse, transformation_left_naturality],
  induction Y,
  { simp [transformation], exact category.id_comp _ },
  { simp [transformation, *] },
  { cases f;
    simp [transformation, *] }
end

instance of_cat_full : full (@of_cat C _) :=
{ preimage := λ X Y f, ((to_presheaf.map f).app (op X) (𝟙 X)),
  witness' := λ X Y f, begin
    have := transformation_left_naturality f (𝟙 X),
    simp at this,
    erw [category.id_comp] at this,
    simpa using this
  end }

instance of_cat_faithful : faithful (@of_cat C _) :=
{ map_injective' := λ X Y f g h, begin
    have := congr_arg transformation_inverse h,
    simp [transformation_inverse] at this,
    erw [category.id_comp] at this,
    erw [category.id_comp] at this,
    assumption
end }

def normalize {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : hom_syntax (of_cat' X) Y :=
transformation_syntax (transformation_inverse f)

lemma of_syntax_normalize {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : of_syntax (normalize f) = f :=
by rw [normalize, ← transformation_eq_of_syntax_transformation_syntax,
  transformation_transformation_inverse]

end prod_coprod


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (v1) = (v2) → (v2) ≠ ((((a1).write i1 (v2)).write i3 (v1)).read i1) → False := by
  arr


class Preorder (α : Type u) extends LT α :=
  (le : α → α → Prop)
  (lt_iff_le_not_le : ∀ a b : α, lt a b ↔ (le a b ∧ ¬ le b a) := by intros; rfl)

theorem Preorder.toLE_injective (A B : Preorder α) (h : A.le = B.le) (h2 : A.toLT = B.toLT) : A = B := by
  cases A; cases B; cases h
  congr


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h2 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h3 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h4 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h5 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h6 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h7 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h8 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h9 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h10 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h11 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h12 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h13 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h14 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h15 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h16 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h17 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h18 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h19 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h20 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h21 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h22 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h23 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h24 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h25 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h26 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h27 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h28 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h29 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h30 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h31 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h32 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h33 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h34 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h35 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h36 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h37 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h38 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h39 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h40 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h41 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h42 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from sorry,
  have h43 : ∀ i j : ℤ, i ≠ j → (int.f
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h2 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h3 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h4 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h5 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h6 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h7 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h8 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h9 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h10 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h11 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h12 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h13 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h14 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h15 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h16 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h17 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h18 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h19 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h20 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h21 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h22 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h23 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h24 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h25 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h26 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h27 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h28 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h29 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h30 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h31 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h32 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h33 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h34 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h35 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h36 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h37 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h38 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h39 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h40 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h41 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h42 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h43 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h44 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h45 : ∀ i j : ℤ, i ≠
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h2 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h3 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h4 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h5 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h6 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h7 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h8 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h9 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h10 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h11 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h12 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h13 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h14 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h15 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h16 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h17 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h18 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h19 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h20 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h21 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h22 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h23 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h24 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h25 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h26 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h27 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h28 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h29 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h30 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h31 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h32 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h33 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h34 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h35 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h36 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h37 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h38 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h39 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h40 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h41 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h42 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h43 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from sorry,
  have h44 : ∀ (i j : ℤ), i ≠ j
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from sorry,

  assume (h7 : ε > 0),
  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,
  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := sorry,
  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from sorry,

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from sorry,

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from sorry,
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2021 Luke Kershaw. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luke Kershaw
-/
import category_theory.preadditive.additive_functor
import category_theory.shift.basic
import category_theory.triangulated.rotate

/-!
# Pretriangulated Categories

This file contains the definition of pretriangulated categories and triangulated functors
between them.

## Implementation Notes

We work under the assumption that pretriangulated categories are preadditive categories,
but not necessarily additive categories, as is assumed in some sources.

TODO: generalise this to n-angulated categories as in https://arxiv.org/abs/1006.4592
-/

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v v₀ v₁ v₂ u u₀ u₁ u₂

namespace category_theory
open category pretriangulated

/-
We work in a preadditive category `C` equipped with an additive shift.
-/
variables (C : Type u) [category.{v} C] [has_zero_object C] [has_shift C ℤ] [preadditive C]
  [∀ n : ℤ, functor.additive (shift_functor C n)]
variables (D : Type u₂) [category.{v₂} D] [has_zero_object D] [has_shift D ℤ] [preadditive D]
  [∀ n : ℤ, functor.additive (shift_functor D n)]

/--
A preadditive category `C` with an additive shift, and a class of "distinguished triangles"
relative to that shift is called pretriangulated if the following hold:
* Any triangle that is isomorphic to a distinguished triangle is also distinguished.
* Any triangle of the form `(X,X,0,id,0,0)` is distinguished.
* For any morphism `f : X ⟶ Y` there exists a distinguished triangle of the form `(X,Y,Z,f,g,h)`.
* The triangle `(X,Y,Z,f,g,h)` is distinguished if and only if `(Y,Z,X⟦1⟧,g,h,-f⟦1⟧)` is.
* Given a diagram:
  ```
        f       g       h
    X  ───> Y  ───> Z  ───> X⟦1⟧
    │       │                │
    │a      │b               │a⟦1⟧'
    V       V                V
    X' ───> Y' ───> Z' ───> X'⟦1⟧
        f'      g'      h'
  ```
  where the left square commutes, and whose rows are distinguished triangles,
  there exists a morphism `c : Z ⟶ Z'` such that `(a,b,c)` is a triangle morphism.

See <https://stacks.math.columbia.edu/tag/0145>
-/
class pretriangulated :=
(distinguished_triangles [] : set (triangle C))
(isomorphic_distinguished : Π (T₁ ∈ distinguished_triangles) (T₂ ≅ T₁),
  T₂ ∈ distinguished_triangles)
(contractible_distinguished : Π (X : C), (contractible_triangle X) ∈ distinguished_triangles)
(distinguished_cocone_triangle : Π (X Y : C) (f : X ⟶ Y), (∃ (Z : C) (g : Y ⟶ Z)
  (h : Z ⟶ X⟦(1:ℤ)⟧),
  triangle.mk f g h ∈ distinguished_triangles))
(rotate_distinguished_triangle : Π (T : triangle C),
  T ∈ distinguished_triangles ↔ T.rotate ∈ distinguished_triangles)
(complete_distinguished_triangle_morphism : Π (T₁ T₂ : triangle C)
  (h₁ : T₁ ∈ distinguished_triangles) (h₂ : T₂ ∈ distinguished_triangles) (a : T₁.obj₁ ⟶ T₂.obj₁)
  (b : T₁.obj₂ ⟶ T₂.obj₂) (comm₁ : T₁.mor₁ ≫ b = a ≫ T₂.mor₁),
  (∃ (c : T₁.obj₃ ⟶ T₂.obj₃), (T₁.mor₂ ≫ c = b ≫ T₂.mor₂) ∧ (T₁.mor₃ ≫ a⟦1⟧' = c ≫ T₂.mor₃) ))

namespace pretriangulated
variables [hC : pretriangulated C]

include hC

notation `dist_triang `:20 C := distinguished_triangles C
/--
Given any distinguished triangle `T`, then we know `T.rotate` is also distinguished.
-/
lemma rot_of_dist_triangle (T ∈ dist_triang C) : (T.rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle T).mp H

/--
Given any distinguished triangle `T`, then we know `T.inv_rotate` is also distinguished.
-/
lemma inv_rot_of_dist_triangle (T ∈ dist_triang C) : (T.inv_rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle (T.inv_rotate)).mpr
  (isomorphic_distinguished T H T.inv_rotate.rotate (inv_rot_comp_rot.app T))

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `f ≫ g = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₁₂ (T ∈ dist_triang C) : T.mor₁ ≫ T.mor₂ = 0 :=
begin
  obtain ⟨c, hc⟩ := complete_distinguished_triangle_morphism _ _
    (contractible_distinguished T.obj₁) H (𝟙 T.obj₁) T.mor₁ rfl,
  simpa only [contractible_triangle_mor₂, zero_comp] using hc.left.symm,
end

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `g ≫ h = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₂₃  (T ∈ dist_triang C) : T.mor₂ ≫ T.mor₃ = 0 :=
comp_dist_triangle_mor_zero₁₂ C T.rotate (rot_of_dist_triangle C T H)

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `h ≫ f⟦1⟧ = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₃₁ (T ∈ dist_triang C) :
  T.mor₃ ≫ ((shift_equiv C 1).functor.map T.mor₁) = 0 :=
have H₂ : _ := rot_of_dist_triangle C T.rotate (rot_of_dist_triangle C T H),
by simpa using comp_dist_triangle_mor_zero₁₂ C (T.rotate.rotate) H₂

/-
TODO: If `C` is pretriangulated with respect to a shift,
then `Cᵒᵖ` is pretriangulated with respect to the inverse shift.
-/

end pretriangulated
end category_theory


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Elab.PreDefinition.Structural.Basic

namespace Lean.Elab.Structural
open Meta

private def getIndexMinPos (xs : Array Expr) (indices : Array Expr) : Nat := Id.run <| do
  let mut minPos := xs.size
  for index in indices do
    match xs.indexOf? index with
    | some pos => if pos.val < minPos then minPos := pos.val
    | _        => pure ()
  return minPos

-- Indices can only depend on other indices
private def hasBadIndexDep? (ys : Array Expr) (indices : Array Expr) : MetaM (Option (Expr × Expr)) := do
  for index in indices do
    let indexType ← inferType index
    for y in ys do
      if !indices.contains y && (← dependsOn indexType y.fvarId!) then
        return some (index, y)
  return none

-- Inductive datatype parameters cannot depend on ys
private def hasBadParamDep? (ys : Array Expr) (indParams : Array Expr) : MetaM (Option (Expr × Expr)) := do
  for p in indParams do
    let pType ← inferType p
    for y in ys do
      if ← dependsOn pType y.fvarId! then
        return some (p, y)
  return none

private def throwStructuralFailed : MetaM α :=
  throwError "structural recursion cannot be used"

private def orelse' (x y : M α) : M α := do
  let saveState ← get
  orelseMergeErrors x (do set saveState; y)

/--
  Try to find an argument that is structurally smaller in every recursive application.
  We use this argument to justify termination using the auxiliary `brecOn` construction.

  We give preference for arguments that are *not* indices of inductive types of other arguments.
  See issue #837 for an example where we can show termination using the index of an inductive family, but
  we don't get the desired definitional equalities.

  We perform two passes. In the first-pass, we only consider arguments that are not indices.
  In the second pass, we consider them.

  TODO: explore whether there are better solutions, and whether there are other ways to break the heuristic used
  for creating the smart unfolding auxiliary definition.
-/
partial def findRecArg (numFixed : Nat) (xs : Array Expr) (k : RecArgInfo → M α) : M α := do
  /- Collect arguments that are indices. See comment above. -/
  let indicesRef : IO.Ref FVarIdSet ← IO.mkRef {}
  for x in xs do
    let xType ← inferType x
    /- Traverse all sub-expressions in the type of `x` -/
    forEachExpr xType fun e =>
      /- If `e` is an inductive family, we store in `indicesRef` all variables in `xs` that occur in "index positions". -/
      matchConstInduct e.getAppFn (fun _ => pure ()) fun info _ => do
        if info.numIndices > 0 && info.numParams + info.numIndices == e.getAppNumArgs then
          for arg in e.getAppArgs[:info.numIndices] do
            forEachExpr arg fun e => do
              if e.isFVar && xs.any (. == e) then
                indicesRef.modify fun indices => indices.insert e.fvarId!
  let indices ← indicesRef.get
  /- We perform two passes. See comment above. -/
  let rec go (i : Nat) (firstPass : Bool) : M α := do
    if h : i < xs.size then
      let x := xs.get ⟨i, h⟩
      let localDecl ← getFVarLocalDecl x
      if localDecl.isLet then
        throwStructuralFailed
      else if firstPass == indices.contains localDecl.fvarId then
        go (i+1) firstPass
      else
        let xType ← whnfD localDecl.type
        matchConstInduct xType.getAppFn (fun _ => go (i+1) firstPass) fun indInfo us => do
        if !(← hasConst (mkBRecOnName indInfo.name)) then
          go (i+1) firstPass
        else if indInfo.isReflexive && !(← hasConst (mkBInductionOnName indInfo.name)) then
          go (i+1) firstPass
        else
          let indArgs    := xType.getAppArgs
          let indParams  := indArgs.extract 0 indInfo.numParams
          let indIndices := indArgs.extract indInfo.numParams indArgs.size
          if !indIndices.all Expr.isFVar then
            orelse'
              (throwError "argument #{i+1} was not used because its type is an inductive family and indices are not variables{indentExpr xType}")
              (go (i+1) firstPass)
          else if !indIndices.allDiff then
            orelse'
              (throwError "argument #{i+1} was not used because its type is an inductive family and indices are not pairwise distinct{indentExpr xType}")
              (go (i+1) firstPass)
          else
            let indexMinPos := getIndexMinPos xs indIndices
            let numFixed    := if indexMinPos < numFixed then indexMinPos else numFixed
            let fixedParams := xs.extract 0 numFixed
            let ys          := xs.extract numFixed xs.size
            match (← hasBadIndexDep? ys indIndices) with
            | some (index, y) =>
              orelse'
                (throwError "argument #{i+1} was not used because its type is an inductive family{indentExpr xType}\nand index{indentExpr index}\ndepends on the non index{indentExpr y}")
                (go (i+1) firstPass)
            | none =>
              match (← hasBadParamDep? ys indParams) with
              | some (indParam, y) =>
                orelse'
                  (throwError "argument #{i+1} was not used because its type is an inductive datatype{indentExpr xType}\nand parameter{indentExpr indParam}\ndepends on{indentExpr y}")
                  (go (i+1) firstPass)
              | none =>
                let indicesPos := indIndices.map fun index => match ys.indexOf? index with | some i => i.val | none => unreachable!
                orelse'
                  (mapError
                    (k { fixedParams := fixedParams
                         ys          := ys
                         pos         := i - fixedParams.size
                         indicesPos  := indicesPos
                         indName     := indInfo.name
                         indLevels   := us
                         indParams   := indParams
                         indIndices  := indIndices
                         reflexive := indInfo.isReflexive
                         indPred := ←isInductivePredicate indInfo.name })
                    (fun msg => m!"argument #{i+1} was not used for structural recursion{indentD msg}"))
                  (go (i+1) firstPass)
    else if firstPass then
      go (i := numFixed) (firstPass := false)
    else
      throwStructuralFailed

  go (i := numFixed) (firstPass := true)

end Lean.Elab.Structural


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((((a3).write i2 (v2)).write i3 (((a3).write i3 (v2)).read i2)).read i2) ≠ (v2) → False := by
  arr


import tactic
import data.option.basic

namespace option

instance coe_option {A B} [has_lift_t A B]: has_lift_t (option A) (option B)
:= ⟨λ (x : option A), x.map (λ a, ↑a)⟩

@[norm_cast]
lemma coe_option_get_or_else {A B} [has_lift_t A B] (o : option A) (a : A)
: (↑(o.get_or_else a) : B) = ((↑o : option B).get_or_else (↑a : B))
:= begin cases o, simpa, simpa, end

end option


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


open lean
open interactive.types
open tactic

@[user_attribute] meta def auto_lemma_attr : user_attribute unit :=
{ name := `auto_lemma, descr := "Mark a lemma availble for use in the auto tactic." }

meta def auto_attr_handler (inductive_name : name) : command :=
do e ← get_env,
   when (¬e.is_inductive inductive_name)
     (fail $ "auto attribute failed, target is not an inductive datatype: " ++ to_string inductive_name),
   let ctors := e.constructors_of inductive_name,
   monad.mapm (fun ctor,
    do user_attribute.set auto_lemma_attr ctor () tt) ctors,
   return ()

@[user_attribute] meta def auto_attr : user_attribute unit :=
{ name := `auto, descr := "make constructors availble for use in auto tactic",
  after_set := some (λ n _ _, auto_attr_handler n)
}

meta def auto : tactic unit :=
do ls ← local_context,
   ns ← attribute.get_instances `auto_lemma,
   cs ← monad.mapm (fun n, mk_const n) ns,
   -- trace $ ("Lemmas: " ++ to_string ls ++ to_string cs),
   tactic.back_chaining_using (ls ++ cs) <|> tactic.fail "auto tactic failed"


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