/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import category_theory.category.Pointed

/-!
# The category of bipointed types

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

This defines `Bipointed`, the category of bipointed types.

## TODO

Monoidal structure
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of bipointed types. -/
structure Bipointed : Type.{u + 1} :=
(X : Type.{u})
(to_prod : X × X)

namespace Bipointed

instance : has_coe_to_sort Bipointed Type* := ⟨X⟩

attribute [protected] Bipointed.X

/-- Turns a bipointing into a bipointed type. -/
def of {X : Type*} (to_prod : X × X) : Bipointed := ⟨X, to_prod⟩

@[simp] lemma coe_of {X : Type*} (to_prod : X × X) : ↥(of to_prod) = X := rfl

alias of ← _root_.prod.Bipointed

instance : inhabited Bipointed := ⟨of ((), ())⟩

/-- Morphisms in `Bipointed`. -/
@[ext] protected structure hom (X Y : Bipointed.{u}) : Type u :=
(to_fun : X → Y)
(map_fst : to_fun X.to_prod.1 = Y.to_prod.1)
(map_snd : to_fun X.to_prod.2 = Y.to_prod.2)

namespace hom

/-- The identity morphism of `X : Bipointed`. -/
@[simps] def id (X : Bipointed) : hom X X := ⟨id, rfl, rfl⟩

instance (X : Bipointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Bipointed`. -/
@[simps] def comp {X Y Z : Bipointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_fst, g.map_fst],
  by rw [function.comp_apply, f.map_snd, g.map_snd]⟩

end hom

instance large_category : large_category Bipointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Bipointed :=
{ forget := { obj := Bipointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

/-- Swaps the pointed elements of a bipointed type. `prod.swap` as a functor. -/
@[simps] def swap : Bipointed ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.to_prod.swap⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd, f.map_fst⟩ }

/-- The equivalence between `Bipointed` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Bipointed ≌ Bipointed :=
equivalence.mk swap swap
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)

@[simp] lemma swap_equiv_symm : swap_equiv.symm = swap_equiv := rfl

end Bipointed

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the second point. -/
def Bipointed_to_Pointed_fst : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.1⟩, map := λ X Y f, ⟨f.to_fun, f.map_fst⟩ }

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the first point. -/
def Bipointed_to_Pointed_snd : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.2⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd⟩ }

@[simp] lemma Bipointed_to_Pointed_fst_comp_forget :
  Bipointed_to_Pointed_fst ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma Bipointed_to_Pointed_snd_comp_forget :
  Bipointed_to_Pointed_snd ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_fst :
  Bipointed.swap ⋙ Bipointed_to_Pointed_fst = Bipointed_to_Pointed_snd := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_snd :
  Bipointed.swap ⋙ Bipointed_to_Pointed_snd = Bipointed_to_Pointed_fst := rfl

/-- The functor from `Pointed` to `Bipointed` which bipoints the point. -/
def Pointed_to_Bipointed : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.point, X.point⟩, map := λ X Y f, ⟨f.to_fun, f.map_point, f.map_point⟩ }

/-- The functor from `Pointed` to `Bipointed` which adds a second point. -/
def Pointed_to_Bipointed_fst : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, X.point, none⟩,
  map := λ X Y f, ⟨option.map f.to_fun, congr_arg _ f.map_point, rfl⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

/-- The functor from `Pointed` to `Bipointed` which adds a first point. -/
def Pointed_to_Bipointed_snd : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, none, X.point⟩,
  map := λ X Y f, ⟨option.map f.to_fun, rfl, congr_arg _ f.map_point⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

@[simp] lemma Pointed_to_Bipointed_fst_comp_swap :
  Pointed_to_Bipointed_fst ⋙ Bipointed.swap = Pointed_to_Bipointed_snd := rfl

@[simp] lemma Pointed_to_Bipointed_snd_comp_swap :
  Pointed_to_Bipointed_snd ⋙ Bipointed.swap = Pointed_to_Bipointed_fst := rfl

/-- `Bipointed_to_Pointed_fst` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_fst :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_fst ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- `Bipointed_to_Pointed_snd` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_snd :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_snd ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_fst` and `Bipointed_to_Pointed_fst`.
-/
def Pointed_to_Bipointed_fst_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Bipointed_fst ⊣ Bipointed_to_Pointed_fst :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_fst⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.2 f.to_fun, f.map_point, rfl⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_snd.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_snd` and `Bipointed_to_Pointed_snd`.
-/
def Pointed_to_Bipointed_snd_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Bipointed_snd ⊣ Bipointed_to_Pointed_snd :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_snd⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.1 f.to_fun, rfl, f.map_point⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_fst.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Group.abelian
import category_theory.limits.shapes.kernels

noncomputable theory

open category_theory
open category_theory.limits

/-!
Some small examples of using limits and colimits in `Ab`, the category of additive commutative
groups.
-/

example (G H : Ab) (f : G ⟶ H) : Ab := kernel f
example (G H : Ab) (f : G ⟶ H) [epi f] : kernel (cokernel.π f) ≅ H :=
as_iso (kernel.ι (cokernel.π f))

-- TODO no images yet...


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

Introduce CommRing -- the category of commutative rings.

Currently only the basic setup.
-/

import category_theory.instances.monoids
import category_theory.fully_faithful
import category_theory.adjunction
import data.mv_polynomial
import algebra.ring

universes u v

open category_theory

namespace category_theory.instances

/-- The category of rings. -/
@[reducible] def Ring : Type (u+1) := bundled ring

instance (x : Ring) : ring x := x.str

instance concrete_is_ring_hom : concrete_category @is_ring_hom :=
⟨by introsI α ia; apply_instance,
  by introsI α β γ ia ib ic f g hf hg; apply_instance⟩

instance Ring_hom_is_ring_hom {R S : Ring} (f : R ⟶ S) : is_ring_hom (f : R → S) := f.2

/-- The category of commutative rings. -/
@[reducible] def CommRing : Type (u+1) := bundled comm_ring

instance (x : CommRing) : comm_ring x := x.str

-- Here we don't use the `concrete` machinery,
-- because it would require introducing a useless synonym for `is_ring_hom`.
instance : category CommRing :=
{ hom := λ R S, { f : R → S // is_ring_hom f },
  id := λ R, ⟨ id, by resetI; apply_instance ⟩,
  comp := λ R S T g h, ⟨ h.1 ∘ g.1, begin haveI := g.2, haveI := h.2, apply_instance end ⟩ }

namespace CommRing
variables {R S T : CommRing.{u}}

@[simp] lemma id_val : subtype.val (𝟙 R) = id := rfl
@[simp] lemma comp_val (f : R ⟶ S) (g : S ⟶ T) :
  (f ≫ g).val = g.val ∘ f.val := rfl

instance hom_coe : has_coe_to_fun (R ⟶ S) :=
{ F := λ f, R → S,
  coe := λ f, f.1 }

@[simp] lemma hom_coe_app (f : R ⟶ S) (r : R) : f r = f.val r := rfl

instance hom_is_ring_hom (f : R ⟶ S) : is_ring_hom (f : R → S) := f.2

def Int : CommRing := ⟨ℤ, infer_instance⟩

def Int.cast {R : CommRing} : Int ⟶ R := { val := int.cast, property := by apply_instance }

def int.eq_cast' {R : Type u} [ring R] (f : int → R) [is_ring_hom f] : f = int.cast :=
funext $ int.eq_cast f (is_ring_hom.map_one f) (λ _ _, is_ring_hom.map_add f)

def Int.hom_unique {R : CommRing} : unique (Int ⟶ R) :=
{ default := Int.cast,
  uniq := λ f, subtype.ext.mpr $ funext $ int.eq_cast f f.2.map_one f.2.map_add }

/-- The forgetful functor commutative rings to Type. -/
def forget : CommRing.{u} ⥤ Type u :=
{ obj := λ R, R,
  map := λ _ _ f, f }

instance forget.faithful : faithful (forget) := {}

/-- The functor from commutative rings to rings. -/
def to_Ring : CommRing.{u} ⥤ Ring.{u} :=
{ obj := λ X, { α := X.1, str := by apply_instance },
  map := λ X Y f, ⟨ f, by apply_instance ⟩ }

instance to_Ring.faithful : faithful (to_Ring) := {}

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
def forget_to_CommMon : CommRing.{u} ⥤ CommMon.{u} :=
{ obj := λ X, { α := X.1, str := by apply_instance },
  map := λ X Y f, ⟨ f, by apply_instance ⟩ }

instance forget_to_CommMon.faithful : faithful (forget_to_CommMon) := {}

example : faithful (forget_to_CommMon ⋙ CommMon.forget_to_Mon) := by apply_instance

section
open mv_polynomial
local attribute [instance, priority 0] subtype.fintype set_fintype classical.prop_decidable

noncomputable def polynomial : Type u ⥤ CommRing.{u} :=
{ obj := λ α, ⟨mv_polynomial α ℤ, by apply_instance⟩,
  map := λ α β f, ⟨eval₂ C (X ∘ f), by apply_instance⟩,
  map_id' := λ α, subtype.ext.mpr $ funext $ eval₂_eta,
  map_comp' := λ α β γ f g, subtype.ext.mpr $ funext $ λ p,
  by apply mv_polynomial.induction_on p; intros;
    simp only [*, eval₂_add, eval₂_mul, eval₂_C, eval₂_X, comp_val,
      eq_self_iff_true, function.comp_app, types_comp] at * }

@[simp] lemma polynomial_obj_α {α : Type u} :
  (polynomial.obj α).α = mv_polynomial α ℤ := rfl

@[simp] lemma polynomial_map_val {α β : Type u} {f : α → β} :
  (CommRing.polynomial.map f).val = eval₂ C (X ∘ f) := rfl

noncomputable def adj : adjunction polynomial (forget : CommRing ⥤ Type u) :=
adjunction.mk_of_hom_equiv _ _
{ hom_equiv := λ α R,
  { to_fun := λ f, f ∘ X,
    inv_fun := λ f, ⟨eval₂ int.cast f, by apply_instance⟩,
    left_inv := λ f, subtype.ext.mpr $ funext $ λ p,
    begin
      have H0 := λ n, (congr (int.eq_cast' (f.val ∘ C)) (rfl : n = n)).symm,
      have H1 := λ p₁ p₂, (@is_ring_hom.map_add _ _ _ _ f.val f.2 p₁ p₂).symm,
      have H2 := λ p₁ p₂, (@is_ring_hom.map_mul _ _ _ _ f.val f.2 p₁ p₂).symm,
      apply mv_polynomial.induction_on p; intros;
      simp only [*, eval₂_add, eval₂_mul, eval₂_C, eval₂_X,
        eq_self_iff_true, function.comp_app, hom_coe_app] at *
    end,
    right_inv := by tidy },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, subtype.ext.mpr $ funext $ λ p,
  begin
    apply mv_polynomial.induction_on p; intros;
    simp only [*, eval₂_mul, eval₂_add, eval₂_C, eval₂_X,
      comp_val, equiv.coe_fn_symm_mk, hom_coe_app, polynomial_map_val,
      eq_self_iff_true, function.comp_app, add_right_inj, types_comp] at *
  end }

end

end CommRing

end category_theory.instances


open System

namespace Day1

def input : FilePath := "/home/fred/lean/aoc2022/input_01"

/-
PART 1:
The jungle must be too overgrown and difficult to navigate in vehicles or access from the air; the Elves' expedition traditionally goes on foot. As your boats approach land, the Elves begin taking inventory of their supplies. One important consideration is food - in particular, the number of Calories each Elf is carrying (your puzzle input).

The Elves take turns writing down the number of Calories contained by the various meals, snacks, rations, etc. that they've brought with them, one item per line. Each Elf separates their own inventory from the previous Elf's inventory (if any) by a blank line.

For example, suppose the Elves finish writing their items' Calories and end up with the following list:

1000
2000
3000

4000

5000
6000

7000
8000
9000

10000

This list represents the Calories of the food carried by five Elves:

    The first Elf is carrying food with 1000, 2000, and 3000 Calories, a total of 6000 Calories.
    The second Elf is carrying one food item with 4000 Calories.
    The third Elf is carrying food with 5000 and 6000 Calories, a total of 11000 Calories.
    The fourth Elf is carrying food with 7000, 8000, and 9000 Calories, a total of 24000 Calories.
    The fifth Elf is carrying one food item with 10000 Calories.

In case the Elves get hungry and need extra snacks, they need to know which Elf to ask: they'd like to know how many Calories are being carried by the Elf carrying the most Calories. In the example above, this is 24000 (carried by the fourth Elf).

Find the Elf carrying the most Calories. How many total Calories is that Elf carrying?
-/
def first_part : IO Nat := do
  let rawdata ← IO.FS.lines input
  let f : (Nat × Nat) → String → (Nat × Nat) :=
    fun (cur, best) s =>
      match s with
      | "" => (0, max cur best)
      | s' => (cur + s'.toNat!, best)
  let (cur, best) := Array.foldl f (0, 0) rawdata
  return max cur best

/-
PART 2:
By the time you calculate the answer to the Elves' question, they've already realized that the Elf carrying the most Calories of food might eventually run out of snacks.

To avoid this unacceptable situation, the Elves would instead like to know the total Calories carried by the top three Elves carrying the most Calories. That way, even if one of those Elves runs out of snacks, they still have two backups.

In the example above, the top three Elves are the fourth Elf (with 24000 Calories), then the third Elf (with 11000 Calories), then the fifth Elf (with 10000 Calories). The sum of the Calories carried by these three elves is 45000.

Find the top three Elves carrying the most Calories. How many Calories are those Elves carrying in total?
-/

def TopArray (α : Type _) [LT α] [DecidableRel (α:=α) (· < ·)] (_ : Nat) := Array α

namespace TopArray
variable {α : Type _} [LT α] [DecidableRel (α:=α) (· < ·)]

def insert {n : Nat} (l : TopArray α n) (x : α) : TopArray α n :=
((l.insertAt! l.size x).insertionSort (· > ·)).eraseIdx n

end TopArray

def second_part : IO Nat := do
  let rawdata ← IO.FS.lines input
  let f : (Nat × TopArray Nat 3) → String → (Nat × TopArray Nat 3) :=
    fun (cur, topthree) s =>
      match s with
      | "" => (0, topthree.insert cur)
      | s' => (cur + s'.toNat!, topthree)
  let (last, topthree) := Array.foldl f (0, #[0, 0, 0]) rawdata
  return (topthree.insert last).foldl (· + ·) 0

end Day1


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.sheaf
import category_theory.sites.cover_lifting
import category_theory.adjunction.fully_faithful

/-!
# Dense subsites

We define `cover_dense` functors into sites as functors such that there exists a covering sieve
that factors through images of the functor for each object in `D`.

We will primarily consider cover-dense functors that are also full, since this notion is in general
not well-behaved otherwise. Note that https://ncatlab.org/nlab/show/dense+sub-site indeed has a
weaker notion of cover-dense that loosens this requirement, but it would not have all the properties
we would need, and some sheafification would be needed for here and there.

## Main results

- `category_theory.cover_dense.presheaf_hom`: If `G : C ⥤ (D, K)` is full and cover-dense,
  then given any presheaf `ℱ` and sheaf `ℱ'` on `D`, and a morphism `α : G ⋙ ℱ ⟶ G ⋙ ℱ'`,
  we may glue them together to obtain a morphism of presheaves `ℱ ⟶ ℱ'`.
- `category_theory.cover_dense.sheaf_iso`: If `ℱ` above is a sheaf and `α` is an iso,
  then the result is also an iso.
- `category_theory.cover_dense.iso_of_restrict_iso`: If `G : C ⥤ (D, K)` is full and cover-dense,
  then given any sheaves `ℱ, ℱ'` on `D`, and a morphism `α : ℱ ⟶ ℱ'`, then `α` is an iso if
  `G ⋙ ℱ ⟶ G ⋙ ℱ'` is iso.
- `category_theory.cover_dense.Sheaf_equiv_of_cover_preserving_cover_lifting`:
  If `G : (C, J) ⥤ (D, K)` is fully-faithful, cover-lifting, cover-preserving, and cover-dense,
  then it will induce an equivalence of categories of sheaves valued in a complete category.

## References

* [Elephant]: *Sketches of an Elephant*, ℱ. T. Johnstone: C2.2.
* https://ncatlab.org/nlab/show/dense+sub-site
* https://ncatlab.org/nlab/show/comparison+lemma

-/

universes v u

namespace category_theory

variables {C : Type*} [category C] {D : Type*} [category D] {E : Type*} [category E]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology E}

/--
An auxiliary structure that witnesses the fact that `f` factors through an image object of `G`.
-/
@[nolint has_inhabited_instance]
structure presieve.cover_by_image_structure (G : C ⥤ D) {V U : D} (f : V ⟶ U) :=
(obj : C)
(lift : V ⟶ G.obj obj)
(map : G.obj obj ⟶ U)
(fac' : lift ≫ map = f . obviously)

restate_axiom presieve.cover_by_image_structure.fac'

attribute [simp, reassoc] presieve.cover_by_image_structure.fac

/--
For a functor `G : C ⥤ D`, and an object `U : D`, `presieve.cover_by_image G U` is the presieve
of `U` consisting of those arrows that factor through images of `G`.
-/
def presieve.cover_by_image (G : C ⥤ D) (U : D) : presieve U :=
λ Y f, nonempty (presieve.cover_by_image_structure G f)

/--
For a functor `G : C ⥤ D`, and an object `U : D`, `sieve.cover_by_image G U` is the sieve of `U`
consisting of those arrows that factor through images of `G`.
-/
def sieve.cover_by_image (G : C ⥤ D) (U : D) : sieve U :=
⟨presieve.cover_by_image G U,
  λ X Y f ⟨⟨Z, f₁, f₂, (e : _ = _)⟩⟩ g,
    ⟨⟨Z, g ≫ f₁, f₂, show (g ≫ f₁) ≫ f₂ = g ≫ f, by rw [category.assoc, ← e]⟩⟩⟩

lemma presieve.in_cover_by_image (G : C ⥤ D) {X : D} {Y : C} (f : G.obj Y ⟶ X) :
  presieve.cover_by_image G X f := ⟨⟨Y, 𝟙 _, f, by simp⟩⟩

/--
A functor `G : (C, J) ⥤ (D, K)` is called `cover_dense` if for each object in `D`,
  there exists a covering sieve in `D` that factors through images of `G`.

This definition can be found in https://ncatlab.org/nlab/show/dense+sub-site Definition 2.2.
-/
structure cover_dense (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
(is_cover : ∀ (U : D), sieve.cover_by_image G U ∈ K U)

open presieve opposite

namespace cover_dense

variable {K}

variables {A : Type*} [category A] {G : C ⥤ D} (H : cover_dense K G)

-- this is not marked with `@[ext]` because `H` can not be inferred from the type
lemma ext (H : cover_dense K G) (ℱ : SheafOfTypes K) (X : D) {s t : ℱ.val.obj (op X)}
  (h : ∀ ⦃Y : C⦄ (f : G.obj Y ⟶ X), ℱ.val.map f.op s = ℱ.val.map f.op t) :
  s = t :=
begin
  apply (ℱ.property (sieve.cover_by_image G X) (H.is_cover X)).is_separated_for.ext,
  rintros Y _ ⟨Z, f₁, f₂, ⟨rfl⟩⟩,
  simp [h f₂]
end

/--
(Implementation). Given an hom between the pullbacks of two sheaves, we can whisker it with
`coyoneda` to obtain an hom between the pullbacks of the sheaves of maps from `X`.
-/
@[simps] def hom_over {ℱ : Dᵒᵖ ⥤ A} {ℱ' : Sheaf K A} (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) (X : A) :
  G.op ⋙ (ℱ ⋙ coyoneda.obj (op X)) ⟶ G.op ⋙ (sheaf_over ℱ' X).val :=
whisker_right α (coyoneda.obj (op X))

/--
(Implementation). Given an iso between the pullbacks of two sheaves, we can whisker it with
`coyoneda` to obtain an iso between the pullbacks of the sheaves of maps from `X`.
-/
@[simps] def iso_over {ℱ ℱ' : Sheaf K A} (α : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) (X : A) :
  G.op ⋙ (sheaf_over ℱ X).val ≅ G.op ⋙ (sheaf_over ℱ' X).val :=
iso_whisker_right α (coyoneda.obj (op X))

lemma sheaf_eq_amalgamation (ℱ : Sheaf K A) {X : A} {U : D} {T : sieve U} (hT)
  (x : family_of_elements _ T) (hx) (t) (h : x.is_amalgamation t) :
  t = (ℱ.property X T hT).amalgamate x hx :=
(ℱ.property X T hT).is_separated_for x t _ h ((ℱ.property X T hT).is_amalgamation hx)

include H
variable [full G]
namespace types
variables {ℱ : Dᵒᵖ ⥤ Type v} {ℱ' : SheafOfTypes.{v} K} (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val)

/--
(Implementation). Given a section of `ℱ` on `X`, we can obtain a family of elements valued in `ℱ'`
that is defined on a cover generated by the images of `G`. -/
@[simp, nolint unused_arguments] noncomputable
def pushforward_family {X} (x : ℱ.obj (op X)) :
  family_of_elements ℱ'.val (cover_by_image G X) := λ Y f hf,
ℱ'.val.map hf.some.lift.op $ α.app (op _) (ℱ.map hf.some.map.op x : _)

/-- (Implementation). The `pushforward_family` defined is compatible. -/
lemma pushforward_family_compatible {X} (x : ℱ.obj (op X)) :
  (pushforward_family H α x).compatible :=
begin
  intros Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ e,
  apply H.ext,
  intros Y f,
  simp only [pushforward_family, ← functor_to_types.map_comp_apply, ← op_comp],
  change (ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _) _ =
    (ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _) _,
  rw ← G.image_preimage (f ≫ g₁ ≫ _),
  rw ← G.image_preimage (f ≫ g₂ ≫ _),
  erw ← α.naturality (G.preimage _).op,
  erw ← α.naturality (G.preimage _).op,
  refine congr_fun _ x,
  simp only [quiver.hom.unop_op, functor.comp_map, ← op_comp, ← category.assoc,
    functor.op_map, ← ℱ.map_comp, G.image_preimage],
  congr' 3,
  simp [e]
end

/-- (Implementation). The morphism `ℱ(X) ⟶ ℱ'(X)` given by gluing the `pushforward_family`. -/
noncomputable
def app_hom (X : D) : ℱ.obj (op X) ⟶ ℱ'.val.obj (op X) := λ x,
  (ℱ'.property _ (H.is_cover X)).amalgamate
    (pushforward_family H α x)
    (pushforward_family_compatible H α x)

@[simp] lemma pushforward_family_apply {X} (x : ℱ.obj (op X)) {Y : C} (f : G.obj Y ⟶ X) :
  pushforward_family H α x f (presieve.in_cover_by_image G f) = α.app (op Y) (ℱ.map f.op x) :=
begin
  unfold pushforward_family,
  refine congr_fun _ x,
  rw ← G.image_preimage (nonempty.some _ : presieve.cover_by_image_structure _ _).lift,
  change ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _ = ℱ.map f.op ≫ α.app (op Y),
  erw ← α.naturality (G.preimage _).op,
  simp only [← functor.map_comp, ← category.assoc, functor.comp_map, G.image_preimage,
     G.op_map, quiver.hom.unop_op, ← op_comp, presieve.cover_by_image_structure.fac],
end

@[simp] lemma app_hom_restrict {X : D} {Y : C} (f : op X ⟶ op (G.obj Y)) (x) :
  ℱ'.val.map f (app_hom H α X x) = α.app (op Y) (ℱ.map f x) :=
begin
  refine ((ℱ'.property _ (H.is_cover X)).valid_glue
    (pushforward_family_compatible H α x) f.unop (presieve.in_cover_by_image G f.unop)).trans _,
  apply pushforward_family_apply
end

@[simp] lemma app_hom_valid_glue {X : D} {Y : C} (f : op X ⟶ op (G.obj Y)) :
  app_hom H α X ≫ ℱ'.val.map f = ℱ.map f ≫ α.app (op Y) :=
by { ext, apply app_hom_restrict }

/--
(Implementation). The maps given in `app_iso` is inverse to each other and gives a `ℱ(X) ≅ ℱ'(X)`.
-/
@[simps] noncomputable
def app_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) (X : D) :
  ℱ.val.obj (op X) ≅ ℱ'.val.obj (op X) :=
{ hom := app_hom H i.hom X,
  inv := app_hom H i.inv X,
  hom_inv_id' := by { ext x, apply H.ext, intros Y f, simp },
  inv_hom_id' := by { ext x, apply H.ext, intros Y f, simp } }

/--
Given an natural transformation `G ⋙ ℱ ⟶ G ⋙ ℱ'` between presheaves of types, where `G` is full
and cover-dense, and `ℱ'` is a sheaf, we may obtain a natural transformation between sheaves.
-/
@[simps] noncomputable
def presheaf_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) : ℱ ⟶ ℱ'.val :=
{ app := λ X, app_hom H α (unop X), naturality' := λ X Y f,
  begin
    ext x,
    apply H.ext ℱ' (unop Y),
    intros Y' f',
    simp only [app_hom_restrict, types_comp_apply, ← functor_to_types.map_comp_apply],
    rw app_hom_restrict H α (f ≫ f'.op : op (unop X) ⟶ _)
  end }

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of types, where `G` is full and
cover-dense, and `ℱ, ℱ'` are sheaves, we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def presheaf_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) :
  ℱ.val ≅ ℱ'.val :=
nat_iso.of_components (λ X, app_iso H i (unop X)) (presheaf_hom H i.hom).naturality

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of types, where `G` is full and
cover-dense, and `ℱ, ℱ'` are sheaves, we may obtain a natural isomorphism between sheaves.
-/
@[simps] noncomputable
def sheaf_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) : ℱ ≅ ℱ' :=
{ hom := (presheaf_iso H i).hom, inv := (presheaf_iso H i).inv,
  hom_inv_id' := (presheaf_iso H i).hom_inv_id, inv_hom_id' := (presheaf_iso H i).inv_hom_id }

end types
open types

variables {ℱ : Dᵒᵖ ⥤ A} {ℱ' : Sheaf K A}

/-- (Implementation). The sheaf map given in `types.sheaf_hom` is natural in terms of `X`. -/
@[simps] noncomputable
def sheaf_coyoneda_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  coyoneda ⋙ (whiskering_left Dᵒᵖ A Type*).obj ℱ ⟶
  coyoneda ⋙ (whiskering_left Dᵒᵖ A Type*).obj ℱ'.val :=
{ app := λ X, presheaf_hom H (hom_over α (unop X)), naturality' := λ X Y f,
  begin
    ext U x,
    change app_hom H (hom_over α (unop Y)) (unop U) (f.unop ≫ x) =
      f.unop ≫ app_hom H (hom_over α (unop X)) (unop U) x,
    symmetry,
    apply sheaf_eq_amalgamation,
    apply H.is_cover,
    intros Y' f' hf',
    change unop X ⟶ ℱ.obj (op (unop _)) at x,
    simp only [pushforward_family, functor.comp_map,
      coyoneda_obj_map, hom_over_app, category.assoc],
    congr' 1,
    conv_lhs { rw ← hf'.some.fac },
    simp only [← category.assoc, op_comp, functor.map_comp],
    congr' 1,
    refine (app_hom_restrict H (hom_over α (unop X)) hf'.some.map.op x).trans _,
    simp
  end }

/--
(Implementation). `sheaf_coyoneda_hom` but the order of the arguments of the functor are swapped.
-/
noncomputable
def sheaf_yoneda_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  ℱ ⋙ yoneda ⟶ ℱ'.val ⋙ yoneda :=
begin
  let α := sheaf_coyoneda_hom H α,
  refine { app := _, naturality' := _ },
  { intro U,
    refine { app := λ X, (α.app X).app U,
      naturality' := λ X Y f, by simpa using congr_app (α.naturality f) U } },
  { intros U V i,
    ext X x,
    exact congr_fun ((α.app X).naturality i) x },
end

/--
Given an natural transformation `G ⋙ ℱ ⟶ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ'` is a sheaf, we may obtain a natural transformation
between presheaves.
-/
noncomputable
def sheaf_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  ℱ ⟶ ℱ'.val :=
let α' := sheaf_yoneda_hom H α in
  { app := λ X, yoneda.preimage (α'.app X),
    naturality' := λ X Y f, yoneda.map_injective (by simpa using α'.naturality f) }

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ', ℱ` are sheaves,
we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def presheaf_iso {ℱ ℱ' : Sheaf K A} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) :
  ℱ.val ≅ ℱ'.val :=
begin
  haveI : ∀ (X : Dᵒᵖ), is_iso ((sheaf_hom H i.hom).app X),
  { intro X,
    apply is_iso_of_reflects_iso _ yoneda,
    use (sheaf_yoneda_hom H i.inv).app X,
    split;
      ext x : 2;
      simp only [sheaf_hom, nat_trans.comp_app, nat_trans.id_app, functor.image_preimage],
      exact ((presheaf_iso H (iso_over i (unop x))).app X).hom_inv_id,
      exact ((presheaf_iso H (iso_over i (unop x))).app X).inv_hom_id,
    apply_instance },
  haveI : is_iso (sheaf_hom H i.hom) := by apply nat_iso.is_iso_of_is_iso_app,
  apply as_iso (sheaf_hom H i.hom),
end

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ', ℱ` are sheaves,
we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def sheaf_iso {ℱ ℱ' : Sheaf K A} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) : ℱ ≅ ℱ' :=
{ hom := (presheaf_iso H i).hom,
  inv := (presheaf_iso H i).inv,
  hom_inv_id' := (presheaf_iso H i).hom_inv_id,
  inv_hom_id' := (presheaf_iso H i).inv_hom_id }

/--
The constructed `sheaf_hom α` is equal to `α` when restricted onto `C`.
-/
lemma sheaf_hom_restrict_eq (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  whisker_left G.op (sheaf_hom H α) = α :=
begin
  ext X,
  apply yoneda.map_injective,
  ext U,
  erw yoneda.image_preimage,
  symmetry,
  change (show (ℱ'.val ⋙ coyoneda.obj (op (unop U))).obj (op (G.obj (unop X))), from _) = _,
  apply sheaf_eq_amalgamation ℱ' (H.is_cover _),
  intros Y f hf,
  conv_lhs { rw ← hf.some.fac },
  simp only [pushforward_family, functor.comp_map, yoneda_map_app,
    coyoneda_obj_map, op_comp, functor_to_types.map_comp_apply, hom_over_app, ← category.assoc],
  congr' 1,
  simp only [category.assoc],
  congr' 1,
  rw ← G.image_preimage hf.some.map,
  symmetry,
  apply α.naturality (G.preimage hf.some.map).op,
  apply_instance
end

/--
If the pullback map is obtained via whiskering,
then the result `sheaf_hom (whisker_left G.op α)` is equal to `α`.
-/
lemma sheaf_hom_eq (α : ℱ ⟶ ℱ'.val) : sheaf_hom H (whisker_left G.op α) = α :=
begin
  ext X,
  apply yoneda.map_injective,
  ext U,
  erw yoneda.image_preimage,
  symmetry,
  change (show (ℱ'.val ⋙ coyoneda.obj (op (unop U))).obj (op (unop X)), from _) = _,
  apply sheaf_eq_amalgamation ℱ' (H.is_cover _),
  intros Y f hf,
  conv_lhs { rw ← hf.some.fac },
  simp [-presieve.cover_by_image_structure.fac],
  erw α.naturality_assoc,
  refl,
  apply_instance
end

/--
A full and cover-dense functor `G` induces an equivalence between morphisms into a sheaf and
morphisms over the restrictions via `G`.
-/
noncomputable
def restrict_hom_equiv_hom : (G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) ≃ (ℱ ⟶ ℱ'.val) :=
{ to_fun := sheaf_hom H,
  inv_fun := whisker_left G.op,
  left_inv := sheaf_hom_restrict_eq H,
  right_inv := sheaf_hom_eq H }

/--
Given a full and cover-dense functor `G` and a natural transformation of sheaves `α : ℱ ⟶ ℱ'`,
if the pullback of `α` along `G` is iso, then `α` is also iso.
-/
lemma iso_of_restrict_iso {ℱ ℱ' : Sheaf K A} (α : ℱ ⟶ ℱ')
  (i : is_iso (whisker_left G.op α)) : is_iso α :=
begin
  convert is_iso.of_iso (sheaf_iso H (as_iso (whisker_left G.op α))),
  symmetry,
  apply sheaf_hom_eq
end

/-- A fully faithful cover-dense functor preserves compatible families. -/
lemma compatible_preserving [faithful G] : compatible_preserving K G :=
begin
  constructor,
  intros ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ eq,
  apply H.ext,
  intros W i,
  simp only [← functor_to_types.map_comp_apply, ← op_comp],
  rw ← G.image_preimage (i ≫ f₁),
  rw ← G.image_preimage (i ≫ f₂),
  apply hx,
  apply G.map_injective,
  simp [eq]
end

noncomputable
instance sites.pullback.full [faithful G] (Hp : cover_preserving J K G) :
  full (sites.pullback A H.compatible_preserving Hp) :=
{ preimage := λ ℱ ℱ' α, H.sheaf_hom α,
  witness' := λ ℱ ℱ' α, H.sheaf_hom_restrict_eq α }

instance sites.pullback.faithful [faithful G] (Hp : cover_preserving J K G) :
  faithful (sites.pullback A H.compatible_preserving Hp) :=
{ map_injective' := λ ℱ ℱ' α β (eq : whisker_left G.op α = whisker_left G.op β),
  by rw [← H.sheaf_hom_eq α, ← H.sheaf_hom_eq β, eq] }

end cover_dense

end category_theory

namespace category_theory.cover_dense

open category_theory

variables {C : Type u} [small_category C] {D : Type u} [small_category D]
variables {G : C ⥤ D} [full G] [faithful G]
variables {J : grothendieck_topology C} {K : grothendieck_topology D}
variables {A : Type v} [category.{u} A] [limits.has_limits A]
variables (Hd : cover_dense K G) (Hp : cover_preserving J K G) (Hl : cover_lifting J K G)

include Hd Hp Hl

/--
Given a functor between small sites that is cover-dense, cover-preserving, and cover-lifting,
it induces an equivalence of category of sheaves valued in a complete category.
-/
@[simps functor inverse] noncomputable
def Sheaf_equiv_of_cover_preserving_cover_lifting : Sheaf J A ≌ Sheaf K A :=
begin
  symmetry,
  let α := sites.pullback_copullback_adjunction A Hp Hl Hd.compatible_preserving,
  haveI : ∀ (X : Sheaf J A), is_iso (α.counit.app X),
  { intro ℱ,
    apply_with (reflects_isomorphisms.reflects (Sheaf_to_presheaf J A)) { instances := ff },
    exact is_iso.of_iso ((@as_iso _ _ _ _ _ (Ran.reflective A G.op)).app ℱ.val) },
  haveI : is_iso α.counit := nat_iso.is_iso_of_is_iso_app _,
  exact
  { functor := sites.pullback A Hd.compatible_preserving Hp,
    inverse := sites.copullback A Hl,
    unit_iso := as_iso α.unit,
    counit_iso := as_iso α.counit,
    functor_unit_iso_comp' := λ ℱ, by convert α.left_triangle_components }
end

end category_theory.cover_dense


import Duper.RuleM
import Duper.MClause
import Duper.Clause
import Duper.Util.ProofReconstruction
import Duper.Selection

namespace Duper
open Lean
open Meta
open RuleM

initialize Lean.registerTraceClass `Rule.equalityFactoring

/-
  Notes on the equality_factoring_soundness proofs:
  1. s, t, u, and v should all have the same type (α) because if they didn't, then equalityFactoringWithAllConstraints would throw an error.
  2. The reason we require four soundness proofs is that from the literals s = t and u = v, we may have s unified with u, s unified with v,
     t unified with u, or t unified with v.
-/
theorem equality_factoring_soundness1 {α : Type} {s : α} {t : α} (v : α) (h : s = t) : t ≠ v ∨ s = v := by
  apply @Classical.byCases (s = v)
  . intro s_eq_v
    exact Or.intro_right _ s_eq_v
  . intro s_ne_v
    rw [← h]
    exact Or.intro_left _ s_ne_v

theorem equality_factoring_soundness2 {α : Type} {s : α} {t : α} (u : α) (h : s = t) : t ≠ u ∨ u = s := by
  apply @Classical.byCases (u = s)
  . intro u_eq_s
    exact Or.intro_right _ u_eq_s
  . intro u_ne_s
    rw [← h]
    exact Or.intro_left _ (Ne.symm u_ne_s)

theorem equality_factoring_soundness3 {α : Type} {s : α} {t : α} (v : α) (h : s = t) : s ≠ v ∨ t = v := by
  apply @Classical.byCases (t = v)
  . intro t_eq_v
    exact Or.intro_right _ t_eq_v
  . intro t_ne_v
    rw [h]
    exact Or.intro_left _ t_ne_v

theorem equality_factoring_soundness4 {α : Type} {s : α} {t : α} (u : α) (h : s = t) : s ≠ u ∨ u = t := by
  apply @Classical.byCases (u = t)
  . intro u_eq_t
    exact Or.intro_right _ u_eq_t
  . intro u_ne_t
    rw [h]
    exact Or.intro_left _ (Ne.symm u_ne_t)

def mkEqualityFactoringProof (i : Nat) (j : Nat) (litside_i : LitSide) (litside_j : LitSide) (premises : List Expr) (parents : List ProofParent)
  (transferExprs : Array Expr) (c : Clause) : MetaM Expr := do
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!
    let mut proofCases : Array Expr := Array.mkEmpty parentLits.size
    for k in [:parentLits.size] do
      let lit := parentLits[k]!
      if k == i then
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let proofCase ←
            match (litside_i, litside_j) with
            | (LitSide.lhs, LitSide.lhs) => Meta.mkAppM ``equality_factoring_soundness1 #[Lit.getOtherSide parentLits[j]! litside_j, h]
            | (LitSide.lhs, LitSide.rhs) => Meta.mkAppM ``equality_factoring_soundness2 #[Lit.getOtherSide parentLits[j]! litside_j, h]
            | (LitSide.rhs, LitSide.lhs) => Meta.mkAppM ``equality_factoring_soundness3 #[Lit.getOtherSide parentLits[j]! litside_j, h]
            | (LitSide.rhs, LitSide.rhs) => Meta.mkAppM ``equality_factoring_soundness4 #[Lit.getOtherSide parentLits[j]! litside_j, h]
          Meta.mkLambdaFVars #[h] $ ← orSubclause (cLits.map Lit.toExpr) 2 proofCase
        proofCases := proofCases.push proofCase
      else if k == j then
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let idx := c.lits.size - 1
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
        proofCases := proofCases.push proofCase
      else
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let idx :=
            if k < j && k < i then k
            else if (i < k && k < j) || (j < k && k < i) then k - 1
            else k - 2
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
        proofCases := proofCases.push proofCase
    let r ← orCases (parentLits.map Lit.toExpr) proofCases
    Meta.mkLambdaFVars xs $ mkApp r appliedPremise

/--
  Attempts to perform equality factoring on clause c with c.lits[i] as the literal to be transformed subject to the following constraints:
  1. c.lits[i].litside_i can be unified with c.lits[j].litside_j
  2. c.lits[i].litside_i is not less than c.lits[i].(LitSide.toggleSide litside_i) by the ground reduction ordering after the unification from (1)
  3. c.lits[i] is maximal and nothing is selected

  If any of these constraints fail to hold, then equalityFactoringWithAllConstraints should not do anything
-/
def equalityFactoringWithAllConstraints (given : Clause) (c : MClause) (i : Nat) (j : Nat) (litside_i : LitSide) (litside_j : LitSide) : RuleM ClauseStream :=
  withoutModifyingMCtx $ do
    let lit_i := c.lits[i]!
    let lit_j := c.lits[j]!
    let loaded ← getLoadedClauses
    let ug ← unifierGenerator #[(Lit.getSide lit_i litside_i, Lit.getSide lit_j litside_j)]
    let yC := do
      setLoadedClauses loaded
      match ← compare (Lit.getSide lit_i litside_i) (Lit.getOtherSide lit_i litside_i) with
      | Comparison.LessThan => return none
      | _ =>
        if (getSelections c).isEmpty ∧ (← c.isMaximalLit (← getOrder) i) then
          let new_lit : Lit :=
            { sign := false,
              lvl := lit_i.lvl -- lit_i.lvl = lit_j.lvl
              ty := lit_i.ty -- lit_i.ty = lit_j.ty
              lhs := Lit.getOtherSide lit_i litside_i
              rhs := Lit.getOtherSide lit_j litside_j
            }
          let modified_clause :=
            if (j < i) then -- erase i first so that c.lits[j] is still at the same index after the erasure
              ((c.eraseLit i).eraseLit j).appendLits #[new_lit, c.lits[j]!]
            else -- i < j because i cannot equal j
              ((c.eraseLit j).eraseLit i).appendLits #[new_lit, c.lits[j]!]
          trace[Rule.equalityFactoring] "Successfully calling equality factoring on {c.lits} to yield {modified_clause.lits}"
          some <$> yieldClause modified_clause "equality factoring" (mkProof := some (mkEqualityFactoringProof i j litside_i litside_j))
        else
          return none
    return ClauseStream.mk ug given yC "equality factoring"

/--
  Attempts to perform equality factoring with c.lits[i] as the literal to be transformed
-/
def equalityFactoringAtLit (given : Clause) (c : MClause) (i : Nat) (j : Nat) : RuleM (Array ClauseStream) := do
  /-
  Note: In the Schulz paper, it states that a side condition for EqualityFactoring is that if:
  1. s and t are the terms in c.lits[i]
  2. u and v are the terms in c.lits[j]
  3. σ = mgu(s, u)
  Then σ(s) can't be less than σ(t) by the ground reduction ordering.

  Technically, the only way to check whether this is the case is to try unifying s and u for every possible combination of s and u where
  s ∈ {c.lits[i].lhs, c.lits[i].rhs} and u ∈ {c.lits[j].lhs, c.lits[j].rhs}, and then confirming whether σ(s) is greater than or equal to
  σ(t) by the ground reduction ordering.

  However, unification is expensive, and we have the convenient property that if s < t, then σ(s) < σ(t) for all σ. So in order to successfully
  carry out the inference, we will still have to check whether σ(s) < σ(t) after the unification. But in some instances, we can know that the
  inference cannot be performed for certain choices of s ∈ {c.lits[i].lhs, c.lits[i].rhs} if we can see before unification that s < t. For
  instance, if c.lits[i].lhs < c.lits[i].rhs before unification, σ(c.lits[i].lhs) < σ(c.lits[i].rhs) after unification, so we know the inference
  will be excluded regardless, and so we don't need to bother attempting to call equalityFactoringWithAllConstraints with litside_i = LitSide.lhs.

  All this to say, though its counterintuitive, it is intentional that c.lits[i].lhs and c.lits[i].rhs are compared before unification in this function
  and after unification in equalityFactoringWithAllConstraints
  -/
  match ← compare c.lits[i]!.lhs c.lits[i]!.rhs with
  | Comparison.LessThan =>
    trace[Rule.equalityFactoring] "{c.lits[i]!.lhs} < {c.lits[i]!.rhs} by the ground reduction ordering"
    let str1 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].lhs
    let str2 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].rhs
    return #[str1, str2]
  | Comparison.GreaterThan =>
    trace[Rule.equalityFactoring] "{c.lits[i]!.lhs} > {c.lits[i]!.rhs} by the ground reduction ordering"
    let str1 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].lhs
    let str2 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].rhs
    return #[str1, str2]
  | _ => -- If the Comparison is Equal or Incomparable, we unfortunately have to just try all possibilities
    trace[Rule.equalityFactoring] "{c.lits[i]!.lhs} equal to or incomparable to {c.lits[i]!.rhs} by the ground reduction ordering"
    let str1 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].lhs
    let str2 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].rhs
    let str3 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].lhs
    let str4 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].rhs
    return #[str1, str2, str3, str4]

def equalityFactoring (given : Clause) (c : MClause) (cNum : Nat) : RuleM (Array ClauseStream) := do
  trace[Rule.equalityFactoring] "EqFact inferences with {c.lits}"
  let mut streams := #[]
  for i in [:c.lits.size] do
    if(c.lits[i]!.sign) then
      for j in [i+1:c.lits.size] do -- Since we call equalityFactoringAtLit c i j and equalityFactoringAtLit c j i, we can always have j > i
        if(c.lits[j]!.sign) then
          -- Attempt to perform equalityFactoring with c.lits[i] as the literal to be transformed
          trace[Rule.equalityFactoring] "Attempting to call equalityFactoring on {c.lits} using {c.lits[i]!} and {c.lits[j]!}"
          let str ← equalityFactoringAtLit given c i j
          streams := streams.append str
          -- Attempt to perform equalityFactoring with c.lits[j] as the literal to be transformed
          let str ← equalityFactoringAtLit given c j i
          streams := streams.append str
  return streams

end Duper


--  An abstract formalization of "isomorphism is equality up to relabeling"
-- -------------------------------------------------------------------------
--
-- See `README.md` for more info.
--
-- Helpers for the construction of functors into `universeStructure`.

import Structure.Basic
import Structure.Forgetfulness

open Morphisms
open HasStructure
open Structure
open GeneralizedFunctor
open StructureFunctor
open Forgetfulness
open SetoidStructureFunctor
open SetoidStructureEquiv

set_option autoBoundImplicitLocal false

-- Aliases for functors into `universeStructure`.

@[reducible] def UniverseFunctor (S : Structure) := StructureFunctor S universeStructure

-- A special limitation of `UniverseFunctor S` for a generic `S` is that since equivalences of
-- equivalences in `S` are propositions, we can only map instances of `S` to setoid structures. The
-- definition of `UniverseFunctor` itself does not encode this knowledge, but sometimes we want to
-- restrict ourselves to this very frequent case. We can do this by replacing `UniverseFunctor` with
-- `SetoidUniverseFunctor` and then coercing it into a `UniverseFunctor`.

structure SetoidUniverseFunctor (S : Structure) :=
(map     : S → universeStructure)
(functor : Functor (T := universeStructure) (setoidStructure ∘ map))

namespace SetoidUniverseFunctor

def universeFunctor {S : Structure} (F : SetoidUniverseFunctor S) : UniverseFunctor S :=
{ map     := setoidStructure ∘ F.map,
  functor := F.functor }

instance {S : Structure} : Coe (SetoidUniverseFunctor S) (UniverseFunctor S) := ⟨universeFunctor⟩

def toSetoidUniverseFunctor {S : Structure} (F : UniverseFunctor S) : SetoidUniverseFunctor S :=
{ map     := F.map,
  functor := comp.genFun' F.map F.functor toSetoidStructureEquiv.genFun }

def compFun {S T : Structure} (F : StructureFunctor S T) (G : SetoidUniverseFunctor T) : SetoidUniverseFunctor S :=
{ map     := G.map ∘ F.map,
  functor := comp.genFun' F.map F.functor G.functor }

def constFun {S : Structure} (T : Structure) : SetoidUniverseFunctor S :=
{ map     := Function.const (IsType.type S) T,
  functor := const.genFun (setoidStructure T) }

end SetoidUniverseFunctor

-- The function `setoidStructure`, which truncates the equivalences of a structure to setoids, is a
-- `UniverseFunctor`.

def structureToSetoidStructureFunctor' : SetoidUniverseFunctor universeStructure :=
{ map     := id,
  functor := toSetoidStructureEquiv.genFun }

def setoidUniverseFunctor {S : Structure} (F : UniverseFunctor S) : SetoidUniverseFunctor S :=
SetoidUniverseFunctor.compFun F structureToSetoidStructureFunctor'

def structureToSetoidStructureFunctor : UniverseFunctor universeStructure :=
SetoidUniverseFunctor.universeFunctor structureToSetoidStructureFunctor'

-- A helper structure for constructing a `SetoidUniverseFunctor`, and thus indirectly also a
-- `UniverseFunctor`.
--
-- Instead of directly specifying the resulting structure equivalence, we only give its `toFun` because
-- the `invFun` can be obtained by inverting the input equivalence. By stating the functor axioms in terms
-- of `toFun`, we can ensure that the result is indeed a functor.
--
-- The limitation that we can only define functors to setoid structures is reflected in
-- `SetoidUniverseFunctorDesc` in two ways:
-- * `toFun` yields a `SetoidStructureFunctor` because for a given equivalence `e`, it would be
--   unrealistic to obtain a regular `StructureFunctor`.
-- * The `respects...` functions return proofs. Especially, `respectsSetoid` can only return a proof since
--   it takes a proof as an input.

structure SetoidUniverseFunctorDesc (S : Structure) where
(map                                                : S → Structure)
(toFun          {a b   : S}                         : a ≃ b → SetoidStructureFunctor (map a) (map b))
(respectsSetoid {a b   : S} {e₁ e₂ : a ≃ b}         : e₁ ≈ e₂ → ∀ T, toFun e₁ T ≈ toFun e₂ T)
(respectsComp   {a b c : S} (e : a ≃ b) (f : b ≃ c) : ∀ T, toFun (f • e) T ≈ toFun f (toFun e T))
(respectsId     (a     : S)                         : ∀ T, toFun (id_ a) T ≈ T)

namespace SetoidUniverseFunctorDesc

variable {S : Structure} (D : SetoidUniverseFunctorDesc S)

def targetLeftInv {a b : S} (e : a ≃ b) : D.toFun e⁻¹ ⊙ D.toFun e ≃ @idFun (setoidStructure (D.map a)) :=
makeToSetoidStructureFunctorEquiv (λ T => let h₁ := D.respectsComp e e⁻¹ T;
                                          let h₂ := D.respectsSetoid (leftInv e) T;
                                          let h₃ := Setoid.trans (Setoid.symm h₁) h₂;
                                          let h₄ := D.respectsId a T;
                                          Setoid.trans h₃ h₄)

def targetRightInv {a b : S} (e : a ≃ b) : D.toFun e ⊙ D.toFun e⁻¹ ≃ @idFun (setoidStructure (D.map b)) :=
makeToSetoidStructureFunctorEquiv (λ T => let h₁ := D.respectsComp e⁻¹ e T;
                                          let h₂ := D.respectsSetoid (rightInv e) T;
                                          let h₃ := Setoid.trans (Setoid.symm h₁) h₂
                                          let h₄ := D.respectsId b T;
                                          Setoid.trans h₃ h₄)

def targetEquiv {a b : S} (e : a ≃ b) : SetoidStructureEquiv (D.map a) (D.map b) :=
{ toFun  := D.toFun e,
  invFun := D.toFun e⁻¹,
  isInv  := makeSetoidStructureFunctorInverse (targetLeftInv D e) (targetRightInv D e) }

theorem targetRespectsEquiv {a b : S} {e₁ e₂ : a ≃ b} :
  e₁ ≈ e₂ → targetEquiv D e₁ ≈ targetEquiv D e₂ :=
λ h => ⟨makeSetoidStructureEquivEquiv (D.respectsSetoid h)
                                      (D.respectsSetoid (inv_congrArg h))⟩

theorem targetRespectsComp {a b c : S} (e : a ≃ b) (f : b ≃ c) :
  targetEquiv D (f • e) ≈ StructureEquiv.trans (targetEquiv D e) (targetEquiv D f) :=
⟨makeSetoidStructureEquivEquiv (D.respectsComp e f)
                               (λ T => let h₁ := D.respectsComp f⁻¹ e⁻¹ T;
                                       let h₂ := D.respectsSetoid (compInv e f) T;
                                       Setoid.trans h₂ h₁)⟩

theorem targetRespectsId (a : S) :
  targetEquiv D (id_ a) ≈ StructureEquiv.refl (setoidStructure (D.map a)) :=
⟨makeSetoidStructureEquivEquiv (D.respectsId a)
                               (λ T => let h₁ := D.respectsId a T;
                                       let h₂ := D.respectsSetoid (idInv a) T;
                                       Setoid.trans h₂ h₁)⟩

theorem targetRespectsInv {a b : S} (e : a ≃ b) :
  targetEquiv D e⁻¹ ≈ StructureEquiv.symm (targetEquiv D e) :=
⟨makeSetoidStructureEquivEquiv (λ T => Setoid.refl (D.toFun e⁻¹ T))
                               (D.respectsSetoid (invInv e))⟩

def setoidUniverseFunctor : SetoidUniverseFunctor S :=
{ map     := D.map,
  functor := { mapEquiv  := targetEquiv D,
               isFunctor := { respectsEquiv := targetRespectsEquiv D,
                              respectsComp  := targetRespectsComp   D,
                              respectsId    := targetRespectsId     D,
                              respectsInv   := targetRespectsInv    D } } }

def universeFunctor : UniverseFunctor S := SetoidUniverseFunctor.universeFunctor (setoidUniverseFunctor D)

end SetoidUniverseFunctorDesc

instance {S : Structure} : Coe (SetoidUniverseFunctorDesc S) (SetoidUniverseFunctor S) := ⟨SetoidUniverseFunctorDesc.setoidUniverseFunctor⟩
instance {S : Structure} : Coe (SetoidUniverseFunctorDesc S) (UniverseFunctor S)       := ⟨SetoidUniverseFunctorDesc.universeFunctor⟩

-- A 2-functor specifically between universe structures. I.e. we have a functor between structures and a
-- functor between equivalences.

structure UniverseStructureFunctor where
(map                                                       : Structure → Structure)
(mapEquiv      {S T   : Structure}                         : S ≃ T → map S ≃ map T)
(respectsEquiv {S T   : Structure}                         : GeneralizedFunctor.Functor (S := StructureEquiv.equivStructure S T) (T := StructureEquiv.equivStructure (map S) (map T)) mapEquiv)
(respectsComp  {S T U : Structure} (e : S ≃ T) (f : T ≃ U) : mapEquiv (f • e) ≃ mapEquiv f • mapEquiv e)
-- TODO: Why don't `≃` and `id_` work as they should here?
(respectsId    (S     : Structure)                         : StructureEquiv.EquivEquiv (mapEquiv (id_ S)) (StructureEquiv.refl (map S)))
(respectsInv   {S T   : Structure} (e : S ≃ T)             : mapEquiv e⁻¹ ≃ (mapEquiv e)⁻¹)

namespace UniverseStructureFunctor

instance universeStructureFunctorCoeFun : CoeFun UniverseStructureFunctor (λ _ => Structure → Structure) := ⟨UniverseStructureFunctor.map⟩

variable (F : UniverseStructureFunctor)

def congrArg {S T : Structure} (e : S ≃ T) : F S ≃ F T := F.mapEquiv e

def universeFunctor : UniverseFunctor universeStructure :=
{ map     := F.map,
  functor := { mapEquiv  := F.mapEquiv,
               isFunctor := { respectsEquiv := λ ⟨η⟩ => ⟨F.respectsEquiv η⟩,
                              respectsComp  := λ e f => ⟨F.respectsComp  e f⟩,
                              respectsId    := λ S   => ⟨F.respectsId    S⟩,
                              respectsInv   := λ e   => ⟨F.respectsInv   e⟩ } } }

end UniverseStructureFunctor

instance : Coe UniverseStructureFunctor (UniverseFunctor universeStructure) := ⟨UniverseStructureFunctor.universeFunctor⟩

-- Similar to `SetoidUniverseFunctorDesc`, but constructs a `UniverseStructureFunctor` producing regular
-- structures without any truncation to setoids. This is possible because equivalences of structure
-- equivalences also come in a non-setoid form.

structure UniverseStructureFunctorDesc where
(map                                                       : Structure → Structure)
(toFun         {S T   : Structure}                         : S ≃ T → StructureFunctor (map S) (map T))
(respectsEquiv {S T   : Structure}                         : GeneralizedFunctor.Functor (S := StructureEquiv.equivStructure S T) (T := functorStructure (map S) (map T)) toFun)
(respectsComp  {S T U : Structure} (e : S ≃ T) (f : T ≃ U) : toFun (f • e) ≃ toFun f ⊙ toFun e)
(respectsCompNat {S T U : Structure} {e₁ e₂ : S ≃ T} {f₁ f₂ : T ≃ U} (η : e₁ ≃ e₂) (θ : f₁ ≃ f₂) :
   compFun.congrArg (respectsEquiv η) (respectsEquiv θ) • respectsComp e₁ f₁ ≈ respectsComp e₂ f₂ • respectsEquiv (StructureEquiv.comp_congrArg η θ))
(respectsId    (S     : Structure)                         : toFun (id_ S) ≃ @idFun (map S))

namespace UniverseStructureFunctorDesc

variable (D : UniverseStructureFunctorDesc)

-- TODO: We can probably make use of `toFunFunctor` somehow in order to make the missing proofs easier.

def toFunFunctor (S T : Structure) : StructureFunctor (StructureEquiv.equivStructure S T) (functorStructure (D.map S) (D.map T)) :=
{ map     := D.toFun,
  functor := D.respectsEquiv }

def targetLeftInv {S T : Structure} (e : S ≃ T) : D.toFun e⁻¹ ⊙ D.toFun e ≃ @idFun (D.map S) :=
let η₁ := FunctorEquiv.symm (D.respectsComp e e⁻¹);
let η₂ := D.respectsEquiv (StructureEquiv.leftInv' e);
FunctorEquiv.trans (FunctorEquiv.trans η₁ η₂) (D.respectsId S)

def targetRightInv {S T : Structure} (e : S ≃ T) : D.toFun e ⊙ D.toFun e⁻¹ ≃ @idFun (D.map T) :=
let η₁ := FunctorEquiv.symm (D.respectsComp e⁻¹ e);
let η₂ := D.respectsEquiv (StructureEquiv.rightInv' e);
FunctorEquiv.trans (FunctorEquiv.trans η₁ η₂) (D.respectsId T)

-- This might simplify some proofs.
theorem targetInv {S T : Structure} (e : S ≃ T) :
  targetRightInv D e ≈ StructureEquiv.symm_symm e ▸ targetLeftInv D e⁻¹ :=
sorry

def targetEquiv {S T : Structure} (e : S ≃ T) : StructureEquiv (D.map S) (D.map T) :=
{ toFun  := D.toFun e,
  invFun := D.toFun e⁻¹,
  isInv  := { leftInv  := targetLeftInv  D e,
              rightInv := targetRightInv D e,
              lrCompat := sorry,
              rlCompat := sorry } }

def targetRespectsEquiv {S T : Structure} {e₁ e₂ : S ≃ T} (η : e₁ ≃ e₂) :
  targetEquiv D e₁ ≃ targetEquiv D e₂ :=
{ toFunEquiv    := D.respectsEquiv η,
  invFunEquiv   := D.respectsEquiv (StructureEquiv.inv_congrArg η),
  leftInvEquiv  := sorry,
  rightInvEquiv := sorry }

def targetEquiv.functor {S T : Structure} :
  GeneralizedFunctor.Functor (S := StructureEquiv.equivStructure S T) (T := StructureEquiv.equivStructure (D.map S) (D.map T)) (targetEquiv D) :=
{ mapEquiv  := targetRespectsEquiv D,
  isFunctor := sorry }

def targetRespectsComp {S T U : Structure} (e : S ≃ T) (f : T ≃ U) :
  targetEquiv D (StructureEquiv.trans e f) ≃ StructureEquiv.trans (targetEquiv D e) (targetEquiv D f) :=
{ toFunEquiv    := D.respectsComp e   f,
  invFunEquiv   := D.respectsComp f⁻¹ e⁻¹,
  leftInvEquiv  := sorry,
  rightInvEquiv := sorry }

def targetRespectsId (S : Structure) :
  targetEquiv D (StructureEquiv.refl S) ≃ StructureEquiv.refl (D.map S) :=
{ toFunEquiv    := D.respectsId S,
  invFunEquiv   := D.respectsId S,
  leftInvEquiv  := sorry,
  rightInvEquiv := sorry }

def targetRespectsInv {S T : Structure} (e : S ≃ T) :
  targetEquiv D (StructureEquiv.symm e) ≃ StructureEquiv.symm (targetEquiv D e) :=
{ toFunEquiv    := FunctorEquiv.refl (D.toFun e⁻¹),
  invFunEquiv   := D.respectsEquiv (StructureEquiv.invInv e),
  leftInvEquiv  := sorry,
  rightInvEquiv := sorry }

def universeStructureFunctor : UniverseStructureFunctor :=
{ map            := D.map,
  mapEquiv       := targetEquiv         D,
  respectsEquiv  := targetEquiv.functor D,
  respectsComp   := targetRespectsComp  D,
  respectsId     := targetRespectsId    D,
  respectsInv    := targetRespectsInv   D }

def universeFunctor : UniverseFunctor universeStructure := UniverseStructureFunctor.universeFunctor (universeStructureFunctor D)

end UniverseStructureFunctorDesc

instance : Coe UniverseStructureFunctorDesc UniverseStructureFunctor := ⟨UniverseStructureFunctorDesc.universeStructureFunctor⟩
instance : Coe UniverseStructureFunctorDesc (UniverseFunctor universeStructure) := ⟨UniverseStructureFunctorDesc.universeFunctor⟩


-- Copyright (c) 2018 Michael Jendrusch. All rights reserved.
import data.equiv.basic
import category_theory.category
import category_theory.functor
import category_theory.products
import category_theory.natural_isomorphism
import ..monoidal_category
import ..monoid_object
open category_theory
open tactic

universes u v

namespace category_theory.monoidal

section

open monoidal_category

inductive nat_hom (m n : ℕ) : Type
| mk : nat_hom

@[simp] lemma equality {m n : ℕ} (f : nat_hom m n) : f = nat_hom.mk m n :=
by cases f; refl

@[simp] def nat_id (X : ℕ) : nat_hom X X :=
nat_hom.mk X X
@[simp] def nat_comp (X Y Z : ℕ) (f : nat_hom X Y) (g : nat_hom Y Z) : nat_hom X Z :=
nat_hom.mk X Z
@[simp] def nat_tensor_obj (X Y : ℕ) : ℕ := X + Y
@[simp] def nat_tensor_hom (A B C D : ℕ) (f : nat_hom A B) (g : nat_hom C D) :
  nat_hom (A + C) (B + D) := nat_hom.mk (A + C) (B + D)

instance naturals : monoidal_category (nat) :=
{ hom  := λ X Y, nat_hom X Y,
  id   := nat_id,
  comp := nat_comp,
  id_comp' := by tidy; rw equality f,
  comp_id' := by tidy; rw equality f,
  tensor_obj := nat_tensor_obj,
  tensor_hom := nat_tensor_hom,
  tensor_unit := nat.zero,
  left_unitor := λ X,
    { hom := nat_hom.mk (nat_tensor_obj 0 X) X,
      inv := nat_hom.mk X (nat_tensor_obj 0 X) },
  right_unitor := λ X,
    { hom := nat_hom.mk (nat_tensor_obj X 0) X,
      inv := nat_hom.mk X (nat_tensor_obj X 0) },
  associator := λ X Y Z,
    { hom := nat_hom.mk (nat_tensor_obj (nat_tensor_obj X Y) Z)
                        (nat_tensor_obj X (nat_tensor_obj Y Z)),
      inv := nat_hom.mk (nat_tensor_obj X (nat_tensor_obj Y Z))
                        (nat_tensor_obj (nat_tensor_obj X Y) Z)} }

end

instance nat_monoid_object (n : nat) : monoid_object n :=
{ unit    := nat_hom.mk 0 n,
  product := nat_hom.mk (n + n) n }

instance nat_comonoid_object (n : nat) : comonoid_object n :=
{ counit    := nat_hom.mk n 0,
  coproduct := nat_hom.mk n (n + n) }

instance nat_frobenius_object (n : nat) : frobenius_object n := {}

end category_theory.monoidal


import mll

def sequent := list Form_occ

instance : has_append sequent := ⟨list.append⟩
instance : has_mem Form_occ sequent := ⟨list.mem⟩

inductive proof : sequent → Type
| ax {A pi ni}                   : proof [(~A,pi), (A,ni)]
| cut (A) {i j} {Γ Γ' Δ Δ'}      : proof (Γ ++ [(A,i)] ++ Γ') → proof (Δ ++ [(~A,j)] ++ Δ') → proof (Γ++Γ'++Δ++Δ')
| tensor {A B ai bi ci} {Γ Γ' Δ Δ'} : proof (Γ ++ [(A,ai)] ++ Γ') → proof (Δ ++ [(B,bi)] ++ Δ') → proof (Γ++Γ'++ [(A ⊗ B,ci)] ++Δ++Δ')
| par {A B ai bi ci} {Γ Γ'}         : proof (Γ ++ [(A,ai),(B,bi)] ++ Γ') → proof (Γ ++ [(A ⅋ B,ci)] ++ Γ')
| ex {Ai Bi} {Γ Γ'}          : proof (Γ ++ [Ai,Bi] ++ Γ') → proof (Γ ++ [Bi,Ai] ++ Γ')

def mem_Form_occ_proof {Γ : sequent} : Form_occ → proof Γ → Prop :=
begin
  intros Ai π,
  induction π,
  case proof.ax : A pi ni { exact Ai = (A,pi)  }

end

instance {Γ : sequent} : has_mem Form_occ (proof Γ) := ⟨∃ Γ⟩

inductive proof_net : sequent → Type
| mk {Γ : sequent} (ps : proof_structure) : (Π A ∈ Γ, { i : ℕ // (A,i) ∈ ps ∧ ∀ Δ ∈ ps.links, ¬premise (A,i) Δ }) → proof_net Γ

instance {Γ : sequent} : has_coe (proof_net Γ) proof_structure := ⟨by rintro ⟨Γ,ps,_⟩; exact ps⟩

def relabel_Link (f : ℕ → ℕ) : Link → Link
| (Link.ax pi ni A) := Link.ax (f pi) (f ni) A
| (Link.cut pi ni A) := Link.cut (f pi) (f ni) A
| (Link.tensor ai bi ci A B) := Link.tensor (f ai) (f bi) (f ci) A B
| (Link.par ai bi ci A B) := Link.par (f ai) (f bi) (f ci) A B

lemma relabel_valid {l f} (hf : function.injective f): valid_link l → valid_link (relabel_Link f l) :=
begin
  cases l,
  case Link.ax : pi ni A { rintro ⟨_⟩, constructor, },
  case Link.cut : pi ni A { rintro ⟨_⟩, constructor, },
  case Link.tensor : ai bi ci A B {
    rintro ⟨_⟩, constructor, rintro e, injection e with e₁ e₂, apply ᾰ_ᾰ, congr, assumption, exact hf e₂, },
  case Link.par : ai bi ci A B {
    rintro ⟨_⟩, constructor, rintro e, injection e with e₁ e₂, apply ᾰ_ᾰ, congr, assumption, exact hf e₂, },
end

lemma relabel_injective {f} (hf : function.injective f) : function.injective (relabel_Link f) :=
by rintros ⟨l₁⟩ ⟨l₂⟩; intros h; injection h; congr; repeat {refl <|> assumption <|> apply hf}

lemma relabel_premise {l f D i } (hf : function.injective f) : premise (D,i) (relabel_Link f l) → ∃ j, f j = i ∧ premise (D,j) l :=
begin
  cases l,
  case Link.ax : pi ni A { rintro ⟨_⟩ },
  case Link.cut : pi ni A { rintro ⟨_⟩, exact ⟨pi,rfl,premise.cut_pos⟩, exact ⟨ni,rfl,premise.cut_neg⟩, },
  case Link.tensor : ai bi ci A B {
    rintro ⟨_⟩, exact ⟨ai,rfl,premise.tensor_left⟩, exact ⟨bi,rfl,premise.tensor_right⟩, },
  case Link.par : ai bi ci A B {
    rintro ⟨_⟩, exact ⟨ai,rfl,premise.par_left⟩, exact ⟨bi,rfl,premise.par_right⟩, },
end

lemma relabel_conclusion {l f D i } (hf : function.injective f) : conclusion (D,i) (relabel_Link f l) → ∃j, f j = i ∧ conclusion (D,j) l :=
begin
  cases l,
  case Link.ax : pi ni A {
    rintro ⟨_⟩, exact ⟨pi,rfl,conclusion.ax_pos⟩, exact ⟨ni,rfl,conclusion.ax_neg⟩, },
  case Link.cut : pi ni A { rintro ⟨_⟩ },
  case Link.tensor : ai bi ci A B { rintro ⟨_⟩, exact ⟨ci,rfl,conclusion.tensor⟩ },
  case Link.par : ai bi ci A B { rintro ⟨_⟩, exact ⟨ci,rfl,conclusion.par⟩ },
end

lemma relabel_mem {Δ f A i} (hf : function.injective f) : (A,i) ∈ (relabel_Link f Δ) → ∃ j, f j = i ∧ (A,j) ∈ Δ :=
begin
  intro h, cases h with h h,
  rcases (relabel_premise hf h) with ⟨j, ⟨fji,pΔ⟩⟩, refine ⟨j,fji,mem_Link.prem pΔ⟩,
  rcases (relabel_conclusion hf h) with ⟨j, ⟨fji,pΔ⟩⟩, refine ⟨j,fji,mem_Link.con pΔ⟩,
end

def proof_structure.relabel (ps : proof_structure) (f : ℕ → ℕ) (hf : function.injective f) : proof_structure :=
⟨set.image (relabel_Link f) ps.links,
  by rintros l ⟨l', ⟨hl',⟨_⟩⟩⟩; exact relabel_valid hf (ps.valid l' hl'),
begin
  rintros ⟨A,i⟩ _ _ ⟨k₁, ⟨hk₁,⟨_⟩⟩⟩ ⟨k₂, ⟨hk₂,⟨_⟩⟩⟩,
  intros pk₁ pk₂,
  congr,
  rcases relabel_premise hf pk₁ with ⟨j,hfj,u₁⟩,
  rcases relabel_premise hf pk₂ with ⟨j',hfj',u₂⟩,
  have : j' = j, rw ←hfj at hfj', exact hf hfj', rw this at u₂,
  exact ps.prem_unique (A,j) _ _ hk₁ hk₂ u₁ u₂
end
,
begin
  rintros ⟨A,i⟩ _ _ ⟨k₁, ⟨hk₁,⟨_⟩⟩⟩ ⟨k₂, ⟨hk₂,⟨_⟩⟩⟩,
  intros pk₁ pk₂,
  congr,
  rcases relabel_conclusion hf pk₁ with ⟨j,hfj,u₁⟩,
  rcases relabel_conclusion hf pk₂ with ⟨j',hfj',u₂⟩,
  have : j' = j, rw ←hfj at hfj', exact hf hfj', rw this at u₂,
  exact ps.con_unique (A,j) _ _ hk₁ hk₂ u₁ u₂
end⟩

def separators {α β} (f g : α → β) : Prop := ∀ x y, f x ≠ g y

lemma sep_even_odd : separators (λ x, 2 * x) (λ x, 2 * x + 1) :=
  λ x y, nat.two_mul_ne_two_mul_add_one

def disjoint_of_separators {ps₁ ps₂ : proof_structure} {f g} (hf hg) : separators f g → disjoint { Ai | Ai ∈ (ps₁.relabel f hf) } { Ai | Ai ∈ (ps₂.relabel g hg) } :=
begin
  rintros s ⟨A,i⟩ ⟨⟨Δ₁,⟨Δ₁', hΔ₁', ⟨_⟩⟩,h₁⟩,⟨Δ₂,⟨Δ₂', hΔ₂', ⟨_⟩⟩,h₂⟩⟩,
  rcases (relabel_mem hf h₁) with ⟨j₁,hfg,h₁⟩,
  rcases (relabel_mem hg h₂) with ⟨j₂,⟨_⟩,h₂⟩,
  exact s j₁ j₂ hfg,
end

def proof_net.disjoint {Γ Δ} : proof_net Γ → proof_net Δ → Prop :=
  by rintro ⟨_,ps₁,_⟩ ⟨_,ps₂,_⟩; exact disjoint {Ai | Ai ∈ ps₁} {Ai | Ai ∈ ps₂}

def net_links_ax (pi ni A) : set Link :=
  {Link.ax pi ni A}

def net_links_tensor (ai bi ci A B) (sA sB : set Link) : set Link :=
  {Link.tensor ai bi ci A B} ∪ sA ∪ sB

def net_links_par (ai bi ci A B) (s : set Link) : set Link :=
  {Link.par ai bi ci A B} ∪ s

def net_links_cut (pi ni A) (sA snA : set Link) : set Link :=
  {Link.cut pi ni A} ∪ sA ∪ snA

def proof_net_ax (A) : proof_net [~A,A] :=
⟨
  ⟨{Link.ax 0 0 A},
  by rintro l ⟨h⟩; exact valid_link.ax,
  by rintro Ai Δ₁ Δ₂ ⟨_⟩ ⟨_⟩; finish,
  by rintro Ai Δ₁ Δ₂ ⟨_⟩ ⟨_⟩; finish ⟩
,
  begin
    rintro B Bmem,
    refine ⟨0,_,_⟩, rcases Bmem with ⟨_,_⟩, use Link.ax 0 0 A, simp, exact mem_Link.con conclusion.ax_neg,

      -- exact ⟨0,Link.ax 0 0 A,by simp,conclusion.ax_neg,_⟩, rintro Δ' ⟨_⟩ ⟨_⟩,
    rcases H with ⟨⟨_⟩⟩,
      exact ⟨0,Link.ax 0 0 A,by simp,conclusion.ax_pos,_⟩, rintro Δ' ⟨_⟩ ⟨_⟩,
    cases H,
  end
⟩

def proof_net_tensor {Γ Γ' A B Δ Δ'} (pnA : proof_net (Γ ++ [A] ++ Γ')) (pnB : proof_net (Δ ++ [B] ++ Δ')) : pnA.disjoint pnB → proof_net (Γ ++ Γ' ++ [A ⊗ B] ++ Δ ++ Δ') :=
begin
  rcases pnA with ⟨_,psA, hA⟩,
  rcases pnB with ⟨_,psB, hB⟩,
  intro dAB,
  specialize hA A (by refine list.mem_append_left _ (list.mem_append_right _ (list.mem_cons_self A list.nil))),
  specialize hB B,
  cases hA with ai ΔA hA,

end


theorem ex (v v' : Nat) (ty : Nat → String) (h : some v = some v') : some (ty v) = some (ty v') := by
  simp_all


import algebra.homology.short_complex.short_exact
import algebra.add_torsor

noncomputable theory

namespace category_theory

open limits category

universes v u

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

@[derive category]
def short_exact_sequence [has_zero_morphisms C] :=
full_subcategory (λ (S : short_complex C), S.short_exact)

namespace short_exact_sequence

variable {C}

section

variables [has_zero_morphisms C] (S : short_exact_sequence C)

abbreviation short_complex : short_complex C := S.1

lemma short_exact : S.short_complex.short_exact := S.2

lemma exact : S.short_complex.exact := S.short_exact.exact

instance : mono S.short_complex.f := S.short_exact.mono_f
instance : epi S.short_complex.g := S.short_exact.epi_g

end

instance five_lemma [preadditive C] [balanced C]
  {S₁ S₂ : short_exact_sequence C} (φ : S₁ ⟶ S₂)
  [is_iso φ.τ₁] [is_iso φ.τ₃] : is_iso φ.τ₂ :=
begin
  rw is_iso_iff_mono_and_epi,
  refine ⟨_, _⟩,
  { rw preadditive.mono_iff_cancel_zero,
    intros A f hf,
    let f' := S₁.short_exact.lift f
      (by simp only [assoc, ← cancel_mono φ.τ₃, ← φ.comm₂₃, reassoc_of hf, zero_comp]),
    have hf' : f' ≫ _ = _ := S₁.short_exact.lift_f _ _,
    have hf'' : f' = 0,
    { simp only [← cancel_mono φ.τ₁, ← cancel_mono S₂.short_complex.f, assoc, φ.comm₁₂,
        reassoc_of hf', hf, zero_comp], },
    rw [← hf', hf'', zero_comp], },
  { rw preadditive.epi_iff_cancel_zero,
    intros A f hf,
    let f' := S₂.short_exact.desc f
      (by simp only [← cancel_epi φ.τ₁, φ.comm₁₂_assoc, hf, comp_zero]),
    have hf' : _ ≫ f' = _ := S₂.short_exact.g_desc _ _,
    have hf'' : f' = 0,
    { simp only [← cancel_epi φ.τ₃, ← cancel_epi S₁.short_complex.g, ← φ.comm₂₃_assoc,
        hf', hf, comp_zero], },
    rw [← hf', hf'', comp_zero], },
end

end short_exact_sequence

namespace abelian

variables {C} (A B : C)

structure extension [has_zero_morphisms C] :=
(X : C)
(i : B ⟶ X)
(p : X ⟶ A)
(w : i ≫ p = 0)
(ex : (short_complex.mk _ _ w).short_exact)

namespace extension

section

variables {A B} [has_zero_morphisms C]

instance (E : extension A B) : mono E.i := E.ex.mono_f
instance (E : extension A B) : epi E.p := E.ex.epi_g

@[ext]
structure hom (E₁ E₂ : extension A B) :=
(τ : E₁.X ⟶ E₂.X)
(commi' : E₁.i ≫ τ = E₂.i . obviously)
(commp' : τ ≫ E₂.p = E₁.p . obviously)

restate_axiom hom.commi'
restate_axiom hom.commp'
attribute [simp, reassoc] w hom.commi hom.commp

@[simps]
def hom.id (E : extension A B) : hom E E :=
{ τ := 𝟙 _, }

@[simps]
def hom.comp {E₁ E₂ E₃ : extension A B} (φ : hom E₁ E₂) (φ' : hom E₂ E₃) : hom E₁ E₃ :=
{ τ := φ.τ ≫ φ'.τ, }

instance : category (extension A B) :=
{ hom := hom,
  id := hom.id,
  comp := λ E₁ E₂ E₃, hom.comp, }

@[simps]
def hom.mk' {E₁ E₂ : extension A B} (τ : E₁.X ⟶ E₂.X)
  (commi : E₁.i ≫ τ = E₂.i) (commp : τ ≫ E₂.p = E₁.p) : E₁ ⟶ E₂ :=
{ τ := τ,
  commi' := commi,
  commp' := commp, }

@[simp]
lemma comp_τ {E₁ E₂ E₃ : extension A B} (φ : E₁ ⟶ E₂) (φ' : E₂ ⟶ E₃) :
  (φ ≫ φ').τ = φ.τ ≫ φ'.τ := rfl

@[simp]
lemma id_τ (E : extension A B) :
  hom.τ (𝟙 E) = 𝟙 E.X := rfl

variables (A B)

@[simps]
def to_short_exact_sequence_functor : extension A B ⥤ short_exact_sequence C :=
{ obj := λ E, ⟨short_complex.mk E.i E.p E.w, E.ex⟩,
  map := λ E₁ E₂ φ,
  { τ₁ := 𝟙 _,
    τ₂ := φ.τ,
    τ₃ := 𝟙 _, },
  map_comp' := λ E₁ E₂ E₃ φ φ', begin
    ext,
    { dsimp, erw short_complex.comp_τ₁, dsimp, simp only [comp_id], },
    { refl, },
    { dsimp, erw short_complex.comp_τ₃, dsimp, simp only [comp_id], },
  end, }

instance : faithful (to_short_exact_sequence_functor A B) :=
⟨λ E₁ E₂ f₁ f₂ eq, begin
  ext,
  simpa only using congr_arg short_complex.hom.τ₂ eq,
end⟩

instance (E₁ E₂ : extension A B) (f : E₁ ⟶ E₂) :
  is_iso ((to_short_exact_sequence_functor A B).map f).τ₁ :=
by { dsimp, apply_instance, }

instance (E₁ E₂ : extension A B) (f : E₁ ⟶ E₂) :
  is_iso ((to_short_exact_sequence_functor A B).map f).τ₃ :=
by { dsimp, apply_instance, }

end

section preadditive

variables [has_zero_object C] [preadditive C]
  (A B) [has_binary_biproduct B A]

@[simps]
def trivial : extension A B :=
{ X := biprod B A,
  i := biprod.inl,
  p := biprod.snd,
  w := biprod.inl_snd,
  ex := short_complex.splitting.short_exact
    { r := biprod.fst,
      s := biprod.inr,
      f_r := by tidy,
      s_g := by tidy,
      id := by tidy, }, }

end preadditive

variable [abelian C]

variables {A B} {E₁ E₂ : extension A B}

instance (f : E₁ ⟶ E₂) : is_iso f.τ :=
(infer_instance : is_iso ((to_short_exact_sequence_functor A B).map f).τ₂)

instance (f : E₁ ⟶ E₂) : is_iso f :=
⟨begin
  refine ⟨⟨inv f.τ, _, _⟩, _, _⟩,
  tidy,
end⟩

@[simp, reassoc]
lemma iso_hom_inv_τ (e : E₁ ≅ E₂) : e.hom.τ ≫ e.inv.τ = 𝟙 _ :=
by rw [← comp_τ, e.hom_inv_id, id_τ]

@[simp, reassoc]
lemma iso_inv_hom_τ (e : E₁ ≅ E₂) : e.inv.τ ≫ e.hom.τ = 𝟙 _ :=
by rw [← comp_τ, e.inv_hom_id, id_τ]

@[simps]
instance has_vadd : has_vadd (A ⟶ B) (E₁ ⟶ E₂) :=
{ vadd := λ g f,
  { τ := E₁.p ≫ g ≫ E₂.i + f.τ, }, }

instance : add_action (A ⟶ B) (E₁ ⟶ E₂) :=
{ zero_vadd := by tidy,
  add_vadd := λ g₁ g₂ f, begin
    ext,
    simp only [has_vadd_vadd_τ, preadditive.add_comp, preadditive.comp_add, add_assoc],
  end, }

def hom.vsub (f₁ f₂ : E₁ ⟶ E₂) : A ⟶ B :=
begin
  let g₀ := E₂.ex.lift (f₁.τ - f₂.τ) (by simp),
  have hg₀ : g₀ ≫ E₂.i = _ := E₂.ex.lift_f _ _,
  exact E₁.ex.desc g₀ begin
    dsimp,
    simp only [← cancel_mono E₂.i, assoc, hg₀, preadditive.comp_sub,
      hom.commi, sub_self, zero_comp],
  end,
end

lemma hom.p_vsub_i (f₁ f₂ : E₁ ⟶ E₂) : E₁.p ≫ hom.vsub f₁ f₂ ≫ E₂.i = f₁.τ - f₂.τ :=
begin
  dsimp [hom.vsub],
  rw [← assoc, E₁.ex.g_desc, E₂.ex.lift_f],
end

instance has_vsub : has_vsub (A ⟶ B) (E₁ ⟶ E₂) :=
{ vsub := hom.vsub, }

@[simp, reassoc]
lemma p_has_vsub_vsub_i (f₁ f₂ : E₁ ⟶ E₂) :
  E₁.p ≫ (f₁ -ᵥ f₂) ≫ E₂.i = f₁.τ - f₂.τ :=
hom.p_vsub_i f₁ f₂

@[simp]
lemma vsub_vadd (f₁ f₂ : E₁ ⟶ E₂) :
  (f₁ -ᵥ f₂ : A ⟶ B) +ᵥ f₂ = f₁ :=
begin
  ext,
  simp only [has_vadd_vadd_τ, p_has_vsub_vsub_i, sub_add_cancel],
end

@[simp]
lemma vadd_vsub (g : A ⟶ B) (f : E₁ ⟶ E₂) :
  g +ᵥ f -ᵥ f = g :=
by rw [← cancel_mono E₂.i, ← cancel_epi E₁.p, p_has_vsub_vsub_i, has_vadd_vadd_τ, add_sub_cancel]

@[simps]
def iso_trivial_equiv (e : extension A B) :
  (e ≅ trivial A B) ≃ (short_complex.mk _ _ e.w).splitting :=
{ to_fun := λ φ,
  { r := φ.hom.τ ≫ biprod.fst,
    s := biprod.inr ≫ φ.inv.τ,
    f_r := by simp only [hom.commi_assoc, trivial_i, biprod.inl_fst],
    s_g := by simp only [assoc, hom.commp, trivial_p, biprod.inr_snd],
    id := begin
      dsimp,
      rw [← cancel_epi φ.inv.τ, ← cancel_mono φ.hom.τ],
      simp only [assoc, preadditive.comp_add, iso_inv_hom_τ_assoc, hom.commp_assoc,
        trivial_p, preadditive.add_comp, hom.commi, trivial_i, iso_inv_hom_τ, comp_id],
      erw [comp_id],
      dsimp,
      rw biprod.total,
    end },
  inv_fun := λ s, as_iso
  { τ := biprod.lift s.r e.p,
    commi' := begin
      ext,
      { simp only [assoc, biprod.lift_fst, trivial_i, biprod.inl_fst, s.f_r], },
      { simp only [w, assoc, biprod.lift_snd, trivial_i, biprod.inl_snd], },
    end, },
  left_inv := λ φ, begin
    ext,
    { tidy, },
    { dsimp,
      simpa only [biprod.lift_snd] using φ.hom.commp'.symm, },
  end,
  right_inv := λ s, short_complex.splitting.ext_r _ _ (by simp), }

@[simps]
def pull {A' : C} (E : extension A B) (π : A' ⟶ A) : extension A' B :=
{ X := pullback E.p π,
  i := pullback.lift E.i 0 (by simp),
  p := pullback.snd,
  w := pullback.lift_snd _ _ _,
  ex := short_complex.short_exact.of_f_is_kernel begin
    refine limits.kernel_fork.is_limit.of_ι _ _
      (λ Z x hx, E.ex.lift (x ≫ pullback.fst)
        (by { dsimp at hx ⊢, rw [assoc, pullback.condition, reassoc_of hx, zero_comp], })) _ _,
    { intros Z x hx,
      ext,
      { simp only [assoc, pullback.lift_fst, short_complex.short_exact.lift_f], },
      { simp only [assoc, pullback.lift_snd, comp_zero, hx], }, },
    { intros Z x hx m hm,
      simpa only [← cancel_mono E.i, assoc, short_complex.short_exact.lift_f,
        pullback.lift_fst] using hm =≫ pullback.fst, },
  end, }

@[simps]
def pull_short_complex {A' : C} (E : extension A B) (π : A' ⟶ A) :
  short_complex.mk _ _ (E.pull π).w ⟶ short_complex.mk _ _ E.w :=
{ τ₁ := 𝟙 _,
  τ₂ := pullback.fst,
  τ₃ := π,
  comm₂₃' := pullback.condition, }

@[simps]
def pull_functor {A A' : C} (π : A' ⟶ A) (B : C) : extension A B ⥤ extension A' B :=
{ obj := λ E, E.pull π,
  map := λ E₁ E₂ f,
  { τ := pullback.map _ _ _ _ f.τ (𝟙 A') (𝟙 A) (by simp) (by simp), }, }

def pull_functor_id (A B : C) : pull_functor (𝟙 A) B ≅ 𝟭 _ :=
nat_iso.of_components
  (λ E, as_iso
    { τ := pullback.fst,
      commp' := by { dsimp, rw [pullback.condition, comp_id], }, })
  (by tidy)

def pull_functor_comp {A A' A'' : C} (π : A' ⟶ A) (π' : A'' ⟶ A') (B : C) :
  pull_functor π B ⋙ pull_functor π' B ≅ pull_functor (π' ≫ π) B :=
nat_iso.of_components
  (λ E, as_iso
    { τ := pullback.lift (pullback.fst ≫ pullback.fst) pullback.snd
        (by erw [assoc, pullback.condition, pullback.condition_assoc]), })
  (by tidy)

@[simps]
def push {B' : C} (E : extension A B) (ι : B ⟶ B') : extension A B' :=
{ X := pushout E.i ι,
  i := pushout.inr,
  p := pushout.desc E.p 0 (by simp),
  w := pushout.inr_desc _ _ _,
  ex := short_complex.short_exact.of_g_is_cokernel begin
    refine limits.cokernel_cofork.is_colimit.of_π _ _
      (λ Z x hx, E.ex.desc (pushout.inl ≫ x)
      (by { dsimp at hx ⊢, rw [pushout.condition_assoc, hx, comp_zero], })) _ _,
    { intros A x hx,
      ext,
      { simp only [pushout.inl_desc_assoc, E.ex.g_desc (pushout.inl ≫ x)], },
      { simp only [pushout.inr_desc_assoc, zero_comp, hx], }, },
    { intros Z x hx m hm,
      rw [← cancel_epi E.p, E.ex.g_desc (pushout.inl ≫ x), ← hm, pushout.inl_desc_assoc], },
  end, }

@[simps]
def push_short_complex {B' : C} (E : extension A B) (ι : B ⟶ B') :
  short_complex.mk _ _ E.w ⟶ short_complex.mk _ _ (E.push ι).w :=
{ τ₁ := ι,
  τ₂ := pushout.inl,
  τ₃ := 𝟙 _,
  comm₁₂' := pushout.condition.symm, }

@[simps]
def push_functor (A : C) {B B' : C} (ι : B ⟶ B') : extension A B ⥤ extension A B' :=
{ obj := λ E, E.push ι,
  map := λ E₁ E₂ f,
  { τ := pushout.map _ _ _ _ f.τ (𝟙 B') (𝟙 B) (by simp) (by simp), }, }

def push_functor_id (A B : C) : push_functor A (𝟙 B) ≅ 𝟭 _ :=
iso.symm (nat_iso.of_components
  (λ E, as_iso
    { τ := pushout.inl,
      commi' := by { dsimp, rw [pushout.condition, id_comp], }, })
  (by tidy))

def push_functor_comp (A : C) {B B' B'' : C} (ι : B ⟶ B') (ι' : B' ⟶ B'') :
  push_functor A ι ⋙ push_functor A ι' ≅ push_functor A (ι ≫ ι') :=
iso.symm (nat_iso.of_components
  (λ E, as_iso
    { τ := pushout.desc (pushout.inl ≫ pushout.inl) pushout.inr
        (by rw [pushout.condition_assoc, pushout.condition, assoc]), })
  (by tidy))

def pull_functor_comm_push_functor {A A' B B' : C} (π : A' ⟶ A) (ι : B ⟶ B') :
  pull_functor π B ⋙ push_functor A' ι ≅
    push_functor A ι ⋙ pull_functor π B' :=
nat_iso.of_components
  (λ E, as_iso
    { τ := pushout.desc
        (pullback.map _ _ _ _ pushout.inl (𝟙 A') (𝟙 A) (by tidy) (by simp))
        (pullback.lift pushout.inr 0
          (by { dsimp, simp only [pushout.inr_desc, zero_comp], }))
        begin
          ext,
          { dsimp, simp [pushout.condition], },
          { dsimp, simp, },
        end, })
  (by tidy)

end extension

variable [abelian C]

def extensions := quotient (is_isomorphic_setoid (extension A B))

def extensions_map_src {A A' : C} (π : A' ⟶ A) (B : C) : extensions A B → extensions A' B :=
quot.map (extension.pull_functor π B).obj begin
  rintro E₁ E₂ ⟨e⟩,
  exact ⟨(extension.pull_functor π B).map_iso e⟩,
end

def extensions_map_tgt (A : C) {B B' : C} (ι : B ⟶ B') : extensions A B → extensions A B' :=
quot.map (extension.push_functor A ι).obj begin
  rintro E₁ E₂ ⟨e⟩,
  exact ⟨(extension.push_functor A ι).map_iso e⟩,
end

lemma extensions_map_src_id (A B : C) :
  extensions_map_src (𝟙 A) B = id :=
begin
  ext E,
  obtain ⟨E, rfl⟩ := quotient.surjective_quotient_mk' E,
  exact quot.sound ⟨(extension.pull_functor_id A B).app E⟩,
end

lemma extensions_map_src_comp {A A' A'' : C} (π' : A'' ⟶ A') (π : A' ⟶ A) (B : C) :
  extensions_map_src π' B ∘ extensions_map_src π B = extensions_map_src (π' ≫ π) B :=
begin
  ext E,
  obtain ⟨E, rfl⟩ := quotient.surjective_quotient_mk' E,
  exact quot.sound ⟨(extension.pull_functor_comp π π' B).app E⟩,
end

lemma extensions_map_tgt_id (A B : C) :
  extensions_map_tgt A (𝟙 B) = id :=
begin
  ext E,
  obtain ⟨E, rfl⟩ := quotient.surjective_quotient_mk' E,
  exact quot.sound ⟨(extension.push_functor_id A B).app E⟩,
end

lemma extensions_map_tgt_comp (A : C) {B B' B'' : C} (ι : B ⟶ B') (ι' : B' ⟶ B'') :
  extensions_map_tgt A ι' ∘ extensions_map_tgt A ι = extensions_map_tgt A (ι ≫ ι') :=
begin
  ext E,
  obtain ⟨E, rfl⟩ := quotient.surjective_quotient_mk' E,
  exact quot.sound ⟨(extension.push_functor_comp A ι ι').app E⟩,
end

lemma extensions_map_tgt_comp_map_src {A A' B B' : C} (π : A' ⟶ A) (ι : B ⟶ B') :
  extensions_map_tgt A' ι ∘ extensions_map_src π B =
    extensions_map_src π B' ∘ extensions_map_tgt A ι :=
begin
  ext E,
  obtain ⟨E, rfl⟩ := quotient.surjective_quotient_mk' E,
  exact quot.sound ⟨(extension.pull_functor_comm_push_functor π ι).app E⟩,
end

variable (C)

@[simps]
def extensions_functor : C ⥤ Cᵒᵖ ⥤ Type (max u v) :=
{ obj := λ B,
  { obj := λ A, extensions A.unop B,
    map := λ A A' π, extensions_map_src π.unop B,
    map_id' := λ A, extensions_map_src_id A.unop B,
    map_comp' := λ A A' A'' π π', (extensions_map_src_comp π'.unop π.unop B).symm, },
  map := λ B B' ι,
  { app := λ A, extensions_map_tgt A.unop ι,
    naturality' := λ A A' π, extensions_map_tgt_comp_map_src π.unop ι, },
  map_id' := λ B, begin
    ext A : 2,
    exact extensions_map_tgt_id A.unop B,
  end,
  map_comp' := λ B B' B'' ι ι', begin
    ext A : 2,
    exact (extensions_map_tgt_comp A.unop ι ι').symm,
  end }

end abelian

end category_theory


import MLIR.Dialects.ToyModel
import MLIR.Dialects.BuiltinModel
import MLIR.Semantics.Fitree
import MLIR.Semantics.Verifier
import MLIR.Semantics.SSAEnv
import MLIR.Semantics.UB
import MLIR.Semantics.TensorElem
import MLIR.Util.Metagen
import MLIR.Util.Reduce

import MLIR.AST
import MLIR.EDSL

import Lean

open MLIR.AST

/- To be automatically generated -/

inductive ToyOp: Type → Type :=
  | Constant:
      (cst_D: DimList) → (cst_τ: MLIRTy) → (cst: TensorLiteral cst_D cst_τ) →
      ToyOp (RankedTensor cst_D cst_τ)
  | Transpose:
      (τ: MLIRTy) → (n m: Nat) →
      RankedTensor [Dimension.Known n, Dimension.Known m] τ →
      ToyOp (RankedTensor [Dimension.Known m, Dimension.Known n] τ)
  | Reshape:
      (τ: MLIRTy) → (D D': DimList) → (H: D.known) → (H': D'.known) →
      (Hprod: D'.prod = D.prod) →
      RankedTensor D τ →
      ToyOp (RankedTensor D' τ)

/- To be automatically generated (hopefully; basically this is the
   verification stuff) -/

def toy_semantics_op (op: Op builtin):
    Fitree (UBE +' SSAEnvE builtin +' ToyOp) Unit :=
  match op with
  | Op.mk "toy.constant" [(res, builtin.tensor D₁ τ₁)] [] [] attrs =>
      match AttrDict.find attrs "value" with
      | some (builtin.dense_tensor_attr elem D₂ τ₂) =>
          match TensorLiteral.ofTensorElem elem D₁ τ₁ with
          | none =>
              raiseUB s!"{op}"
          | some t_lit => do
              let t ← Fitree.trigger <| ToyOp.Constant D₁ τ₁ t_lit
              SSAEnv.set? (builtin.tensor D₁ τ₁) res t
      | _ =>
          raiseUB s!"{op}"

  | Op.mk "toy.transpose" [(res, τ₂)] [(t_name, builtin.tensor D τ)] [] _ =>
      match D with
      | [Dimension.Known n, Dimension.Known m] => do
          let t ← Fitree.trigger (SSAEnvE.Get (builtin.tensor
                  [Dimension.Known n, Dimension.Known m] τ) t_name);
          let t' ← Fitree.trigger (ToyOp.Transpose τ n m t);
          SSAEnv.set? (builtin.tensor [Dimension.Known m, Dimension.Known n] τ)
            (some res) t'
      | _ =>
          raiseUB s!"{op}"

  | Op.mk "toy.reshape" [(res, builtin.tensor D' τ₂)]
        [(t_name, builtin.tensor D τ₁)] [] _ =>
      if H: τ₁ = τ₂
        ∧ DimList.known D
        ∧ DimList.known D'
        ∧ DimList.prod D' = DimList.prod D then do
        let t ← Fitree.trigger (SSAEnvE.Get (builtin.tensor D τ₁) t_name);
        let t' ← Fitree.trigger (ToyOp.Reshape τ₁ D D'
                H.2.1 H.2.2.1 H.2.2.2 t);
        let t': RankedTensor D' τ₂ := cast (by rw [H.1]) t';
        SSAEnv.set? (builtin.tensor D' τ₂) (some res) t'
      else
        raiseUB s!"{op}"

  | _ => raiseUB s!"{op}"

-- TODO: toy_semantics_bb: handle basic block arguments
@[simp]
def toy_semantics_region: Region builtin →
      Fitree (UBE +' (SSAEnvE builtin) +' ToyOp) Unit
  | Region.mk name args [] =>
      Fitree.ret ()
  | Region.mk name args (op1::ops) =>
      List.foldr (fun t acc => Fitree.bind acc (fun _ => t))
                 (toy_semantics_op op1)
                 (ops.map toy_semantics_op)

/- Manually specified: ToyOp event handler -/

def ToyOp.handle {E}: ToyOp ~> Fitree E :=
  fun _ e => match e with
  | ToyOp.Constant D τ t_lit =>
      return RankedTensor.ofTensorLiteral t_lit
  | ToyOp.Transpose α n m t =>
      return transpose t
  | ToyOp.Reshape α D D' H H' Hprod t =>
      return reshape D' H H' Hprod t

-- Interpretation in context

def interp_toy {E} (t: Fitree (ToyOp +' E) R): Fitree E R :=
  t.interp (Fitree.case ToyOp.handle (fun T => @Fitree.trigger E E T _))

@[simp]
def run_toy (t: Fitree (UBE +' SSAEnvE builtin +' ToyOp) Unit)
    (env: SSAEnv builtin): Fitree Void1 (Unit × SSAEnv builtin) :=
  Fitree.interp ToyOp.handle (interpSSA' (interpUB'! t) env)

/-
### Examples and testing
-/

-- TODO: Can we infer the builtin in there?
def transpose_stmt: Op builtin := [mlir_op|
  %t2 = "toy.transpose"(%t1): (tensor<2×4×i32>) -> (tensor<4×2×i32>)
]

def constant_stmt: Op builtin := [mlir_op|
  %t = "toy.constant"() {value=dense<[[1,2],[3,4]]>: tensor<2×2×i32>}:
    () -> (tensor<2×2×i32>)
]

def double_transpose: Region builtin := [mlir_region| {
  ^dbl:
    %t2 = "toy.transpose"(%t1): (tensor<2×4×i32>) -> (tensor<4×2×i32>)
    %t3 = "toy.transpose"(%t2): (tensor<4×2×i32>) -> (tensor<2×4×i32>)
}]

#eval Fitree.run <| run_toy (toy_semantics_op transpose_stmt) SSAEnv.empty

#eval Fitree.run <| run_toy (toy_semantics_op constant_stmt) SSAEnv.empty

theorem double_transpose_correct:
  ∀ (t1: RankedTensor [.Known 2, .Known 4] .i32),
    run_toy (toy_semantics_region double_transpose)
      (SSAEnv.One [("t1", ⟨builtin.tensor [.Known 2, .Known 4] .i32, t1⟩)])
    =
    Fitree.ret ((), SSAEnv.One [
      (SSAVal.SSAVal "t1", ⟨builtin.tensor [.Known 2, .Known 4] .i32, t1⟩),
      (SSAVal.SSAVal "t2", ⟨builtin.tensor [.Known 4, .Known 2] .i32,
                           transpose t1⟩),
      (SSAVal.SSAVal "t3", ⟨builtin.tensor [.Known 2, .Known 4] .i32, t1⟩)
    ]) := by
  intros t1
  simp [double_transpose, toy_semantics_region, toy_semantics_op]; simp_itree
  simp [interpUB'!]; simp_itree
  simp [interpSSA', Fitree.interpState, SSAEnvE.handle]; simp_itree
  simp [SSAEnv.get, SSAEnv.getT, SSAEnv.set]; simp_itree
  simp [SSAEnv.get, SSAEnv.getT, SSAEnv.set]; simp_itree
  rw [transpose_involutive]


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.preserves.basic
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.strong_epi
import category_theory.limits.shapes.pullbacks

/-!
# Definitions and basic properties of regular monomorphisms and epimorphisms.

A regular monomorphism is a morphism that is the equalizer of some parallel pair.

We give the constructions
* `split_mono → regular_mono` and
* `regular_mono → mono`
as well as the dual constructions for regular epimorphisms. Additionally, we give the
construction
* `regular_epi ⟶ strong_epi`.

-/

noncomputable theory

namespace category_theory
open category_theory.limits

universes v₁ u₁ u₂

variables {C : Type u₁} [category.{v₁} C]

variables {X Y : C}

/-- A regular monomorphism is a morphism which is the equalizer of some parallel pair. -/
class regular_mono (f : X ⟶ Y) :=
(Z : C)
(left right : Y ⟶ Z)
(w : f ≫ left = f ≫ right)
(is_limit : is_limit (fork.of_ι f w))

attribute [reassoc] regular_mono.w

/-- Every regular monomorphism is a monomorphism. -/
@[priority 100]
instance regular_mono.mono (f : X ⟶ Y) [regular_mono f] : mono f :=
mono_of_is_limit_parallel_pair regular_mono.is_limit

instance equalizer_regular (g h : X ⟶ Y) [has_limit (parallel_pair g h)] :
  regular_mono (equalizer.ι g h) :=
{ Z := Y,
  left := g,
  right := h,
  w := equalizer.condition g h,
  is_limit := fork.is_limit.mk _ (λ s, limit.lift _ s) (by simp) (λ s m w, by { ext1, simp [←w] }) }

/-- Every split monomorphism is a regular monomorphism. -/
@[priority 100]
instance regular_mono.of_split_mono (f : X ⟶ Y) [split_mono f] : regular_mono f :=
{ Z     := Y,
  left  := 𝟙 Y,
  right := retraction f ≫ f,
  w     := by tidy,
  is_limit := split_mono_equalizes f }

/-- If `f` is a regular mono, then any map `k : W ⟶ Y` equalizing `regular_mono.left` and
    `regular_mono.right` induces a morphism `l : W ⟶ X` such that `l ≫ f = k`. -/
def regular_mono.lift' {W : C} (f : X ⟶ Y) [regular_mono f] (k : W ⟶ Y)
  (h : k ≫ (regular_mono.left : Y ⟶ @regular_mono.Z _ _ _ _ f _) = k ≫ regular_mono.right) :
  {l : W ⟶ X // l ≫ f = k} :=
fork.is_limit.lift' regular_mono.is_limit _ h

/--
The second leg of a pullback cone is a regular monomorphism if the right component is too.

See also `pullback.snd_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_fst_of_regular` for the flipped version.
-/
def regular_of_is_pullback_snd_of_regular {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S}
  {k : R ⟶ S} [hr : regular_mono h] (comm : f ≫ h = g ≫ k)
  (t : is_limit (pullback_cone.mk _ _ comm)) :
regular_mono g :=
{ Z := hr.Z,
  left := k ≫ hr.left,
  right := k ≫ hr.right,
  w := by rw [← reassoc_of comm, ← reassoc_of comm, hr.w],
  is_limit :=
  begin
    apply fork.is_limit.mk' _ _,
    intro s,
    have l₁ : (fork.ι s ≫ k) ≫ regular_mono.left = (fork.ι s ≫ k) ≫ regular_mono.right,
      rw [category.assoc, s.condition, category.assoc],
    obtain ⟨l, hl⟩ := fork.is_limit.lift' hr.is_limit _ l₁,
    obtain ⟨p, hp₁, hp₂⟩ := pullback_cone.is_limit.lift' t _ _ hl,
    refine ⟨p, hp₂, _⟩,
    intros m w,
    have z : m ≫ g = p ≫ g := w.trans hp₂.symm,
    apply t.hom_ext,
    apply (pullback_cone.mk f g comm).equalizer_ext,
    { erw [← cancel_mono h, category.assoc, category.assoc, comm, reassoc_of z] },
    { exact z },
  end }

/--
The first leg of a pullback cone is a regular monomorphism if the left component is too.

See also `pullback.fst_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_snd_of_regular` for the flipped version.
-/
def regular_of_is_pullback_fst_of_regular {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S}
  {k : R ⟶ S} [hr : regular_mono k] (comm : f ≫ h = g ≫ k)
  (t : is_limit (pullback_cone.mk _ _ comm)) :
regular_mono f :=
regular_of_is_pullback_snd_of_regular comm.symm (pullback_cone.flip_is_limit t)

/-- A regular monomorphism is an isomorphism if it is an epimorphism. -/
lemma is_iso_of_regular_mono_of_epi (f : X ⟶ Y) [regular_mono f] [e : epi f] : is_iso f :=
@is_iso_limit_cone_parallel_pair_of_epi _ _ _ _ _ _ _ regular_mono.is_limit e

/-- A regular epimorphism is a morphism which is the coequalizer of some parallel pair. -/
class regular_epi (f : X ⟶ Y) :=
(W : C)
(left right : W ⟶ X)
(w : left ≫ f = right ≫ f)
(is_colimit : is_colimit (cofork.of_π f w))

attribute [reassoc] regular_epi.w

/-- Every regular epimorphism is an epimorphism. -/
@[priority 100]
instance regular_epi.epi (f : X ⟶ Y) [regular_epi f] : epi f :=
epi_of_is_colimit_parallel_pair regular_epi.is_colimit

instance coequalizer_regular (g h : X ⟶ Y) [has_colimit (parallel_pair g h)] :
  regular_epi (coequalizer.π g h) :=
{ W := X,
  left := g,
  right := h,
  w := coequalizer.condition g h,
  is_colimit := cofork.is_colimit.mk _ (λ s, colimit.desc _ s) (by simp)
    (λ s m w, by { ext1, simp [←w] }) }

/-- Every split epimorphism is a regular epimorphism. -/
@[priority 100]
instance regular_epi.of_split_epi (f : X ⟶ Y) [split_epi f] : regular_epi f :=
{ W     := X,
  left  := 𝟙 X,
  right := f ≫ section_ f,
  w     := by tidy,
  is_colimit := split_epi_coequalizes f }

/-- If `f` is a regular epi, then every morphism `k : X ⟶ W` coequalizing `regular_epi.left` and
    `regular_epi.right` induces `l : Y ⟶ W` such that `f ≫ l = k`. -/
def regular_epi.desc' {W : C} (f : X ⟶ Y) [regular_epi f] (k : X ⟶ W)
  (h : (regular_epi.left : regular_epi.W f ⟶ X) ≫ k = regular_epi.right ≫ k) :
  {l : Y ⟶ W // f ≫ l = k} :=
cofork.is_colimit.desc' (regular_epi.is_colimit) _ h

/--
The second leg of a pushout cocone is a regular epimorphism if the right component is too.

See also `pushout.snd_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_fst_of_regular` for the flipped version.
-/
def regular_of_is_pushout_snd_of_regular
  {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S}
  [gr : regular_epi g] (comm : f ≫ h = g ≫ k) (t : is_colimit (pushout_cocone.mk _ _ comm)) :
regular_epi h :=
{ W := gr.W,
  left := gr.left ≫ f,
  right := gr.right ≫ f,
  w := by rw [category.assoc, category.assoc, comm, reassoc_of gr.w],
  is_colimit :=
  begin
    apply cofork.is_colimit.mk' _ _,
    intro s,
    have l₁ : gr.left ≫ f ≫ s.π = gr.right ≫ f ≫ s.π,
      rw [← category.assoc, ← category.assoc, s.condition],
    obtain ⟨l, hl⟩ := cofork.is_colimit.desc' gr.is_colimit (f ≫ cofork.π s) l₁,
    obtain ⟨p, hp₁, hp₂⟩ := pushout_cocone.is_colimit.desc' t _ _ hl.symm,
    refine ⟨p, hp₁, _⟩,
    intros m w,
    have z := w.trans hp₁.symm,
    apply t.hom_ext,
    apply (pushout_cocone.mk _ _ comm).coequalizer_ext,
    { exact z },
    { erw [← cancel_epi g, ← reassoc_of comm, ← reassoc_of comm, z], refl },
  end }

/--
The first leg of a pushout cocone is a regular epimorphism if the left component is too.

See also `pushout.fst_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_snd_of_regular` for the flipped version.
-/
def regular_of_is_pushout_fst_of_regular
  {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S}
  [fr : regular_epi f] (comm : f ≫ h = g ≫ k) (t : is_colimit (pushout_cocone.mk _ _ comm)) :
regular_epi k :=
regular_of_is_pushout_snd_of_regular comm.symm (pushout_cocone.flip_is_colimit t)

/-- A regular epimorphism is an isomorphism if it is a monomorphism. -/
lemma is_iso_of_regular_epi_of_mono (f : X ⟶ Y) [regular_epi f] [m : mono f] : is_iso f :=
@is_iso_limit_cocone_parallel_pair_of_epi _ _ _ _ _ _ _ regular_epi.is_colimit m

@[priority 100]
instance strong_epi_of_regular_epi (f : X ⟶ Y) [regular_epi f] : strong_epi f :=
{ epi := by apply_instance,
  has_lift :=
  begin
    introsI,
    have : (regular_epi.left : regular_epi.W f ⟶ X) ≫ u = regular_epi.right ≫ u,
    { apply (cancel_mono z).1,
      simp only [category.assoc, h, regular_epi.w_assoc] },
    obtain ⟨t, ht⟩ := regular_epi.desc' f u this,
    exact arrow.has_lift.mk ⟨t, ht, (cancel_epi f).1
      (by simp only [←category.assoc, ht, ←h, arrow.mk_hom, arrow.hom_mk'_right])⟩,
  end }

end category_theory


-- A minimal implementation of lenses.
universe variables u v

-- This tactic proves (∀v s, get (set v s) = v by case splitting on s
-- and using reflexivity.
meta def lens.get_set_tactic : tactic unit := do
  tactic.intro `v,
  e ← tactic.intro `s,
  tactic.cases e [],
  tactic.reflexivity

-- This tactic proves (∀v s, set (get s) = s by case splitting on s
-- and using reflexivity.
meta def lens.set_get_tactic : tactic unit := do
  e ← tactic.intro `s,
  tactic.cases e [],
  tactic.reflexivity

-- This tactic proves (∀u v s, set u (set v s) = set u s by case splitting on s
-- and using reflexivity.
meta def lens.set_set_tactic : tactic unit := do
  tactic.intro `u,
  tactic.intro `v,
  e ← tactic.intro `s,
  tactic.cases e [],
  tactic.reflexivity

-- A lens is a structure with a getter, setter, and axioms about their effect.
structure lens (S : Type u) (α : Type v) :=
  (get : S → α)
  (set : α → S → S)
  (get_set :  ∀ (v : α) (s : S), get (set v s) = v . lens.get_set_tactic)
  (set_get :  ∀ (s : S), set (get s) s = s         . lens.set_get_tactic)
  (set_set :  ∀ (u v : α) (s : S), set u (set v s) = set u s . lens.set_set_tactic)

@[simp]
lemma get_set_cancel {S : Type u} {α : Type v} (l : lens S α)
: ∀ (v : α) (s : S), l.get (l.set v s) = v := l.get_set

@[simp]
lemma set_get_cancel {S : Type u} {α : Type v} (l : lens S α)
: ∀ (s : S), l.set (l.get s) s = s := l.set_get

@[simp]
lemma set_set_cancel {S : Type u} {α : Type v} (l : lens S α)
: ∀ (u v : α) (s : S), l.set u (l.set v s) = l.set u s := l.set_set

namespace lens

variables { s t : Type u }
variables { a b : Type v }

-- This applies a function to the value of a lens on an object and updates the state.
def over (l : lens s a) (f : a → a) (x : s) : s := lens.set l (f (lens.get l x)) x

end lens

infixr ` .~ `:4 := lens.set

infixr ` %~ `:4 := lens.over

@[reducible]
def call {a b} : a → (a → b) → b := λx f, f x

infixl ` & `:2 := call

@[simp]
theorem call_elim {α : Type u} {β : Type v} (f : α → β) (x : α) : (x & f) = f x :=  by simp [call]