import tactic

@[derive decidable_eq]
inductive pre
| node : pre
| app : pre → pre → pre

notation `𝕋'` := pre
notation `▢` := pre.node
infixl `◦`:60 := pre.app

inductive reduces : 𝕋' → 𝕋' → Type
| kernel         (y) {z} : reduces (▢◦   ▢   ◦y◦z) y
|   stem     (x) (y) (z) : reduces (▢◦ (▢◦x) ◦y◦z) (y◦z◦(x◦z))
|   fork (w) (x) {y} (z) : reduces (▢◦(▢◦w◦x)◦y◦z) (z◦w◦x)
|   left {a₁ a₂ b₁} (h : reduces a₁ b₁) : reduces (a₁ ◦ a₂) (b₁ ◦ a₂)
|  right {a₁ a₂ b₂} (h : reduces a₂ b₂) : reduces (a₁ ◦ a₂) (a₁ ◦ b₂)
infixr ` ↦ `:60 := reduces

def reduceable (t₁ t₂) := nonempty (t₁ ↦ t₂)
infixr ` ⇢ `:60 := reduceable

def reduce_kernel : ∀ (t₁ t₂), option (t₁ ↦ t₂)
| (▢◦▢◦y◦z) y₂ := if h : y = y₂ then some (by {rw ←h, apply reduces.kernel}) else none
| _ _ := none

#check id_rhs
#check @dite --dite : Π {α : Sort u_1} (c : Prop) [h : decidable c], (c → α) → (¬c → α) → α
#check @ite  -- ite : Π {α : Sort u_1} (c : Prop) [h : decidable c],      α  →       α  → α
#print reduce_kernel._main

example {n} : nat.zero ≠ nat.succ n := begin
  intro h,
  injection h,
end

example {n} : nat.succ n ≠ nat.zero := begin
  intro h,
  injection h,
end

example {m n} : nat.succ n = nat.succ m → n = m := begin
  intro h,
  injection h,
end

#check @bool.ff.inj

lemma kernel_complete (t₁ t₂) : (∃ r, reduce_kernel t₁ t₂ = some r) ↔ ∃ y z, (▢◦▢◦y◦z) ↦ y ∧ t₁ = (▢◦▢◦y◦z) ∧ t₂ = y :=

def list_reductions (t₁ t₂) : list (t₁ ↦ t₂) := sorry

--if I can define this I can define anything
--still need to figure out how "no confusion" works tbf
def reductions (t₁ t₂) : fintype (t₁ ↦ t₂) := begin
  split,
    show finset _,
    split,
      show multiset _,
      apply quotient.mk,

      --produce a list of reductions
      --show that the multiset (quotient of this list) has no duplicates
      --prove that every possible reduction is in this multiset
end

example {α} (l : list α) : multiset α := by refine multiset.zero

#check @reduces.rec_on

#print reduces.no_confusion
#print pre.app.inj

/-
reduces.cases_on:

This function takes a reduction 'n' from an arbitrary tree 'a' to an arbitrary tree 'b' and uses it
to produce a dependent Proposition (proving something about reduction) or Type (some kind of data).

{motive : Π (a b : 𝕋'), a ↦ b → Sort u}
{a b : 𝕋'}
(n : a ↦ b)

If 'a' reduces to 'b' via the kernel rule, show P
(Π (y : 𝕋') {z : 𝕋'}, motive (▢◦▢◦y◦z) y (reduces.kernel y))

If 'a' reduces to 'b' via the stem rule, show P
(Π (x y z : 𝕋'), motive (▢◦(▢◦x)◦y◦z) (y◦z◦(x◦z)) (reduces.stem x y z))

If 'a' reduces to 'b' via the fork rule, show P
(Π (w x : 𝕋') {y : 𝕋'} (z : 𝕋'), motive (▢◦(▢◦w◦x)◦y◦z) (z◦w◦x) (reduces.fork w x z))

If 'a' reduces to 'b' via the left rule, show P
(Π {a₁ a₂ b₁ : 𝕋'} (h : a₁ ↦ b₁), motive (a₁◦a₂) (b₁◦a₂) h.left)

If 'a' reduces to 'b' via the right rule, show P
(Π {a₁ a₂ b₂ : 𝕋'} (h : a₂ ↦ b₂), motive (a₁◦a₂) (a₁◦b₂) h.right)

Hence P is true
motive a b n

--------------------------------------------------------------------------
reduces.rec_on:

This function differs only in the case of the recursive left/right rules which build a reduction
'a ↦ b' from another reduction 'x ↦ y'

(Π {a₁ a₂ b₁ : 𝕋'} (h : a₁ ↦ b₁), motive a₁ b₁ h → motive (a₁◦a₂) (b₁◦a₂) h.left)
(Π {a₁ a₂ b₂ : 𝕋'} (h : a₂ ↦ b₂), motive a₂ b₂ h → motive (a₁◦a₂) (a₁◦b₂) h.right)

Previously we had:
Using (h : a₁ ↦ b₁), show that P holds of (a₁◦a₂) ↦ (b₁◦a₂).
Now we have:
Using (h : a₁ ↦ b₁), and that P holds of a₁ ↦ b₁, show that P holds of (a₁◦a₂) ↦ (b₁◦a₂).
-/

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

inductive and' : Prop → Prop → Prop
| mk {p q} (h₁ : p) (h₂ : q) : and' p q

def left {p q} (h : and' p q) : p := h.rec_on (λ _ _ h₁ _, h₁)

inductive weekday : Type
| sunday : weekday
| monday : weekday
| tuesday : weekday
| wednesday : weekday
| thursday : weekday
| friday : weekday
| saturday : weekday

namespace weekday
def next (d : weekday) : weekday :=
weekday.cases_on d monday tuesday wednesday thursday friday
  saturday sunday

def previous (d : weekday) : weekday :=
weekday.cases_on d saturday sunday monday tuesday wednesday
  thursday friday

#reduce next (next tuesday)
#reduce next (previous tuesday)

example : next (previous tuesday) = tuesday := rfl

theorem next_previous (d: weekday) :
  next (previous d) = d :=
weekday.cases_on d rfl rfl rfl rfl rfl rfl rfl

theorem next_previous' (d: weekday) : next (previous d) = d := by cases d; refl

end weekday

#check @false.rec_on
#check @false.elim

#check @true.rec_on

#check @bool.rec_on
#check @bool.cases_on

def band' (b1 b2 : bool) : bool := bool.cases_on b1 ff b2
#reduce band' tt tt
#reduce band' tt ff
#reduce band' ff tt
#reduce band' ff ff

def bor' (b1 b2 : bool) : bool := bool.cases_on b1 b2 tt
#reduce bor' tt tt
#reduce bor' tt ff
#reduce bor' ff tt
#reduce bor' ff ff

def bnot' (b1 : bool) : bool := bool.cases_on b1 tt ff
#reduce bnot' tt
#reduce bnot' ff

universes u v
inductive prod' (α : Type*) (β : Type*) --what?? :s
| mk : α → β → prod'

#check @prod'.mk

def fst {α β : Type*} (p : α × β) : α := prod.rec_on p (λ a _, a)

#check @prod.rec_on

inductive sum' (α : Type u) (β : Type v)
| inl {} (a : α) : sum'
| inr {} (b : β) : sum'

#check @sum'.inl
#check @sum'.inr

inductive option' (α : Type*)
| none {} : option'
| some    : α → option'

#check @option'.none --option'.none : Π {α : Type u_1}, option' α

#check @nat.cases_on
--Π {motive : ℕ → Sort u_1} (n : ℕ), motive 0 → (Π (n : ℕ), motive n.succ) → motive n
--If our motive maps into Prop, we have: "If p when n = 0, and p when n = n'+1 then p for all n"
#check @nat.rec_on
--Π {motive : ℕ → Sort u_1} (n : ℕ), motive 0 → (Π (n : ℕ), motive n → motive n.succ) → motive n
--This time it's inductive reasoning:    "If p when n = 0, and (if p when n = n' then p when n = n'+1) then p for all n"

def add' (m n : nat) : nat := nat.rec_on m n (λ k kaddn, nat.succ kaddn)

inductive foo : Type
| bar1 : ℕ → ℕ → foo
| bar2 : ℕ → ℕ → ℕ → foo

open foo

def silly (x : foo) : ℕ :=
begin
  cases x,
    case bar1 : a b
      { exact b },
    case bar2 : c d e
      { exact e }
end

open nat
variable p : ℕ → Prop

example (hz : p 0) (hs : ∀ n, p (succ n)) (m k : ℕ) :
  p (m + 3 * k) :=
begin
  cases (m + 3 * k),
  { exact hz },  -- goal is p 0
  apply hs       -- goal is a : ℕ ⊢ p (succ a)
end

lemma injection_example (h : 7 = 4) : false := begin
  injection h with h',
  injection h' with h'',
  injection h'' with h''',
  injection h''' with h'''',
  injection h'''' with h''''',
end

#print injection_example
#print nat.succ.inj_arrow

inductive eq' {α : Sort u} (a : α) : α → Prop
| refl [] : eq' a

#check @eq'
#check @eq'.refl --eq'.refl : ∀ {α : Sort u_1} (a : α), eq' a a

inductive bool'
| tt' : bool'
| ff' : bool'
open bool'

def bool'_equal (b₁ b₂ : bool') : Prop :=
bool'.cases_on b₁
( bool'.cases_on b₂
  true
  false --explicitly returns false when the two values aren't equal
)
( bool'.cases_on b₂
  false
  true
)

def bool_equal (b₁ b₂ : bool) : Prop := begin
  cases b₁,
    cases b₂,
      exact true,
    exact false,
  cases b₂,
    exact false,
  exact true
end

lemma bool_no_confusion {b₁ b₂} : (b₁ = b₂) → bool_equal b₁ b₂ := begin
  intro h,
  rw h,
  cases b₂,
    trivial,
  trivial,
end

theorem true_not_eq_false : tt ≠ ff := bool_no_confusion

theorem true_not_eq_false' : tt ≠ ff := by {intro h, cases h}

theorem true_not_eq_false'' : tt ≠ ff :=
id (λ (h : tt = ff), h.cases_on (λ (H_1 : ff = tt), bool.no_confusion H_1) (eq.refl ff) (heq.refl h))

#print bool.no_confusion_type
#reduce bool.no_confusion_type false tt tt
#reduce bool.no_confusion_type false tt ff
#reduce bool.no_confusion_type false ff tt
#reduce bool.no_confusion_type false tt tt
#reduce bool.no_confusion_type (tt = ff) tt tt
#reduce bool.no_confusion_type (tt = ff) tt ff

#check @bool.no_confusion

#reduce bool'_equal tt' tt'
#reduce bool'_equal tt' ff'
#reduce bool'_equal ff' tt'
#reduce bool'_equal ff' ff'

#print nat.no_confusion_type
#reduce nat.no_confusion_type false
#print bool.rec

def bool'_no_confusion {b₁ b₂ : bool'} : (b₁ = b₂) → bool'_equal b₁ b₂ :=
λ h,
eq.cases_on h
(bool'.cases_on b₁ trivial trivial) --bool'_equal b₁ b₁
--produces bool'_equal b₁ b₂

--our no_confusion function is actually logically equivalent to equality
def bool'_no_confusion' {b₁ b₂ : bool'} : (b₁ = b₂) ↔ bool'_equal b₁ b₂ := begin
  split,
    intro h,
    rw h,
    rw bool'_equal,
    cases b₂,
      trivial,
    trivial,
  intro h,
  cases b₁,
    cases b₂,
      refl,
    exfalso,
    assumption,
  cases b₂,
    exfalso,
    assumption,
  refl,
end

--b₁ = b₂ implies that trivial is a proof of bool'_equal b₁ b₂ since bool'_equal b₁ b₂ reduces to true
--don't forget that (tt' ≠ ff') := (tt' = ff' → false)
theorem unconfused : tt' ≠ ff' := bool'_no_confusion

#print bool'.no_confusion_type

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

inductive xnat
| zero : xnat
| succ : xnat → xnat
open xnat

def xnat_equal' (n₁ n₂ : xnat) : Prop :=
@xnat.rec_on (λ x, Prop) n₁ (
  --n₁ = 0
  @xnat.rec_on (λ x, Prop) n₂
    --n₂ = 0
    true
    --n₂ = succ n₂'
    (λ n₂' p₂, false)
)(
  --n₁ = succ n₁'
  λ n₁' p₁,
  @xnat.rec_on (λ x, Prop) n₂
    --n₂ = 0
    false
    --n₂ = succ n₂'
    (λ n₂' p₂, _)
)

--unwrap outer layer only, no recursion necessary
def xnat_equal (n₁ n₂ : xnat) : Prop := begin
  cases n₁ with n₁',
    cases n₂ with n₂',
      exact true,
    exact false,
  cases n₂ with n₂',
    exact false,
  exact n₁' = n₂' --no recursion necessary here
end

def xnat_no_confusion {s t : xnat} (h : s = t) : xnat_equal s t := begin
  rw h,
  cases t,
    trivial,
  show t = t,
  refl,
end

#print xnat_no_confusion

--how do these theorems work?
theorem wat (n : xnat) : succ n ≠ xnat.zero := xnat_no_confusion --disjoint ranges
theorem wat' (n : xnat) : xnat.zero ≠ succ n := xnat_no_confusion
theorem succ_injective (m n : xnat) : succ m = succ n → m = n := xnat_no_confusion --injective

def bool_equal' : bool → bool → Prop
| tt tt := true
| tt ff := false
| ff tt := false
| ff ff := true

section
  example (m n : ℕ) : ∃ (p : ℕ), m + n = p := begin
    induction h : m generalizing m,
    case nat.succ : m' h₂ {
      --need to use "∃ (p : ℕ), m' + n = p" here but can't
      --why is "m = m' →" added to the beginning of h₂?
    }
  end
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/

import category_theory.limits.shapes
import category_theory.limits.types
import pullbacks

/-!
# Subobject classifiers

Define a subobject classifier, show that it implies there's a terminal object,
show that if there is a subobject classifier then every mono is regular.
-/
universes v u

open category_theory category_theory.category category_theory.limits

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

-- Define what it means for χ to classify the mono f.
structure classifying {Ω Ω₀ U X : C} (true : Ω₀ ⟶ Ω) (f : U ⟶ X) (χ : X ⟶ Ω) :=
(k : U ⟶ Ω₀)
(commutes : k ≫ true = f ≫ χ)
(forms_pullback' : is_limit (pullback_cone.mk _ _ commutes))
restate_axiom classifying.forms_pullback'

variable (C)
-- A subobject classifier is a mono which classifies every mono uniquely
class has_subobject_classifier :=
(Ω Ω₀ : C)
(truth : Ω₀ ⟶ Ω)
(truth_mono' : @mono C 𝒞 _ _ truth)
(classifier_of : ∀ {U X} (f : U ⟶ X) [@mono C 𝒞 _ _ f], X ⟶ Ω)
(classifies' : ∀ {U X} (f : U ⟶ X) [mono f], classifying truth f (classifier_of f))
(uniquely' : ∀ {U X} (f : U ⟶ X) [@mono C 𝒞 _ _ f] (χ₁ : X ⟶ Ω),
            classifying truth f χ₁ → χ₁ = classifier_of f)

variable {C}
lemma mono_id (A : C) : @mono _ 𝒞 _ _ (𝟙 A) := ⟨λ _ _ _ w, by simp at w; exact w⟩

variables [has_subobject_classifier.{v} C]

-- convenience defs
@[reducible]
def subobj.Ω : C :=
@has_subobject_classifier.Ω _ 𝒞 _
@[reducible]
def subobj.Ω₀ : C :=
@has_subobject_classifier.Ω₀ _ 𝒞 _
@[reducible]
def subobj.truth : subobj.Ω₀ ⟶ subobj.Ω :=
@has_subobject_classifier.truth _ 𝒞 _
@[reducible]
instance subobj.truth_mono : mono subobj.truth :=
@has_subobject_classifier.truth_mono' _ 𝒞 _
def subobj.classifier_of {U X : C} (f : U ⟶ X) [@mono C 𝒞 _ _ f] : X ⟶ subobj.Ω :=
has_subobject_classifier.classifier_of f
def subobj.classifies {U X : C} (f : U ⟶ X) [@mono C 𝒞 _ _ f] : classifying subobj.truth f (subobj.classifier_of f) :=
has_subobject_classifier.classifies' f
def subobj.square.k {U X : C} (f : U ⟶ X) [@mono C 𝒞 _ _ f] : U ⟶ subobj.Ω₀ :=
(subobj.classifies f).k
def subobj.square.commutes {U X : C} (f : U ⟶ X) [@mono C 𝒞 _ _ f] :
  subobj.square.k f ≫ subobj.truth = f ≫ subobj.classifier_of f :=
(subobj.classifies f).commutes
def subobj.square.is_pullback {U X : C} (f : U ⟶ X) [@mono C 𝒞 _ _ f] :
  is_limit (pullback_cone.mk _ _ (subobj.square.commutes f)) :=
(subobj.classifies f).forms_pullback
restate_axiom has_subobject_classifier.uniquely'

-- subobject classifier => there is a terminal object.
-- TODO: make a lemma saying subobj.Ω₀ = ⊤_C
-- NB: together with the commented out instance at the top and the instance below that, this shows
-- that every category with a subobj classifier and pullbacks has binary products and equalizers
-- It's a todo in mathlib to show binary products implies finite products, and we have
-- in mathlib and these together imply finite limits exist.
-- So when we define (elem) toposes, we only need assume pullbacks and subobj classifier
-- and not all finite limits (but of course cartesian closed is still necessary and such)
instance terminal_of_subobj : @has_terminal C 𝒞 :=
{ has_limits_of_shape :=
  { has_limit := λ F,
    { cone :=
      { X := subobj.Ω₀,
        π := {app := λ p, pempty.elim p}},
      is_limit :=
      { lift := λ s, subobj.square.k (𝟙 s.X),
        fac' := λ _ j, j.elim,
        uniq' := λ s m J,
        begin
          clear J,
          rw ← cancel_mono subobj.truth,
          rw subobj.square.commutes,
          rw id_comp,
          apply has_subobject_classifier.uniquely (𝟙 s.X),
          refine {k := m, commutes := _, forms_pullback' := _},
          rw id_comp,
          refine ⟨λ c, c.π.app walking_cospan.right, λ c, _, λ c, _⟩,
          apply pi_app_left (pullback_cone.mk m (𝟙 s.X) _) c,
          rw ← cancel_mono subobj.truth,
          rw assoc, rw pullback_cone.condition c,
          refl,
          apply_instance,
          erw comp_id,
          intros g₂ j, specialize j walking_cospan.right, erw comp_id at j,
          exact j, apply_instance
        end } } }
}

variable (C)
lemma terminal_obj : terminal C = subobj.Ω₀ := rfl

variable {C}
instance unique_to_Ω₀ (P : C) : unique (P ⟶ subobj.Ω₀) :=
limits.unique_to_terminal P

-- TODO: really, we should prove that subobj.truth is an equalizer, and that
-- the pullback of an equalizer is an equalizer (and every mono is a pullback of truth)
def mono_is_equalizer {A B : C} (m : A ⟶ B) [@mono C 𝒞 _ _ m] :
  is_limit (fork.of_ι m (begin rw ← subobj.square.commutes m, rw ← assoc, congr' 1 end) : fork (subobj.classifier_of m) (terminal.from B ≫ subobj.truth)) :=
{ lift := λ s, (subobj.square.is_pullback m).lift (pullback_cone.mk (terminal.from s.X) (fork.ι s) (begin erw fork.condition s, rw ← assoc, congr' 1 end)),
  fac' := λ s,
    begin
      intro j, cases j,
        simp, erw (subobj.square.is_pullback m).fac _ walking_cospan.right, refl,
      simp, rw ← assoc, erw (subobj.square.is_pullback m).fac _ walking_cospan.right,
      rw ← s.w walking_parallel_pair_hom.left, refl
    end,
  uniq' := λ s n J,
  begin
    apply pullback_cone.hom_ext (subobj.square.is_pullback m), apply subsingleton.elim,
    erw (subobj.square.is_pullback m).fac, erw J walking_parallel_pair.zero, refl,
  end
}

def balanced {A B : C} (f : A ⟶ B) [ef : @epi C 𝒞 _ _ f] [mf : mono f] : is_iso f :=
@epi_limit_cone_parallel_pair_is_iso _ _ _ _ _ _ _ (mono_is_equalizer f) ef


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.kernels
import category_theory.limits.shapes.normal_mono.equalizers
import category_theory.abelian.images
import category_theory.preadditive.basic

/-!
# Every non_preadditive_abelian category is preadditive

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

In mathlib, we define an abelian category as a preadditive category with a zero object,
kernels and cokernels, products and coproducts and in which every monomorphism and epimorphis is
normal.

While virtually every interesting abelian category has a natural preadditive structure (which is why
it is included in the definition), preadditivity is not actually needed: Every category that has
all of the other properties appearing in the definition of an abelian category admits a preadditive
structure. This is the construction we carry out in this file.

The proof proceeds in roughly five steps:
1. Prove some results (for example that all equalizers exist) that would be trivial if we already
   had the preadditive structure but are a bit of work without it.
2. Develop images and coimages to show that every monomorphism is the kernel of its cokernel.

The results of the first two steps are also useful for the "normal" development of abelian
categories, and will be used there.

3. For every object `A`, define a "subtraction" morphism `σ : A ⨯ A ⟶ A` and use it to define
   subtraction on morphisms as `f - g := prod.lift f g ≫ σ`.
4. Prove a small number of identities about this subtraction from the definition of `σ`.
5. From these identities, prove a large number of other identities that imply that defining
   `f + g := f - (0 - g)` indeed gives an abelian group structure on morphisms such that composition
   is bilinear.

The construction is non-trivial and it is quite remarkable that this abelian group structure can
be constructed purely from the existence of a few limits and colimits. Even more remarkably,
since abelian categories admit exactly one preadditive structure (see
`subsingleton_preadditive_of_has_binary_biproducts`), the construction manages to exactly
reconstruct any natural preadditive structure the category may have.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

-/

noncomputable theory

open category_theory
open category_theory.limits

namespace category_theory
section
universes v u

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

/-- We call a category `non_preadditive_abelian` if it has a zero object, kernels, cokernels, binary
    products and coproducts, and every monomorphism and every epimorphism is normal. -/
class non_preadditive_abelian extends has_zero_morphisms C, normal_mono_category C,
  normal_epi_category C :=
[has_zero_object : has_zero_object C]
[has_kernels : has_kernels C]
[has_cokernels : has_cokernels C]
[has_finite_products : has_finite_products C]
[has_finite_coproducts : has_finite_coproducts C]

set_option default_priority 100

attribute [instance] non_preadditive_abelian.has_zero_object
attribute [instance] non_preadditive_abelian.has_kernels
attribute [instance] non_preadditive_abelian.has_cokernels
attribute [instance] non_preadditive_abelian.has_finite_products
attribute [instance] non_preadditive_abelian.has_finite_coproducts

end
end category_theory

open category_theory

universes v u

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

namespace category_theory.non_preadditive_abelian

section factor

variables {P Q : C} (f : P ⟶ Q)

/-- The map `p : P ⟶ image f` is an epimorphism -/
instance : epi (abelian.factor_thru_image f) :=
let I := abelian.image f, p := abelian.factor_thru_image f,
    i := kernel.ι (cokernel.π f) in
-- It will suffice to consider some g : I ⟶ R such that p ≫ g = 0 and show that g = 0.
normal_mono_category.epi_of_zero_cancel _ $ λ R (g : I ⟶ R) (hpg : p ≫ g = 0),
begin
  -- Since C is abelian, u := ker g ≫ i is the kernel of some morphism h.
  let u := kernel.ι g ≫ i,
  haveI : mono u := mono_comp _ _,
  haveI hu := normal_mono_of_mono u,
  let h := hu.g,
  -- By hypothesis, p factors through the kernel of g via some t.
  obtain ⟨t, ht⟩ := kernel.lift' g p hpg,
  have fh : f ≫ h = 0, calc
    f ≫ h = (p ≫ i) ≫ h : (abelian.image.fac f).symm ▸ rfl
       ... = ((t ≫ kernel.ι g) ≫ i) ≫ h : ht ▸ rfl
       ... = t ≫ u ≫ h : by simp only [category.assoc]; conv_lhs { congr, skip, rw ←category.assoc }
       ... = t ≫ 0 : hu.w ▸ rfl
       ... = 0 : has_zero_morphisms.comp_zero _ _,
  -- h factors through the cokernel of f via some l.
  obtain ⟨l, hl⟩ := cokernel.desc' f h fh,
  have hih : i ≫ h = 0, calc
    i ≫ h = i ≫ cokernel.π f ≫ l : hl ▸ rfl
       ... = 0 ≫ l : by rw [←category.assoc, kernel.condition]
       ... = 0 : zero_comp,
  -- i factors through u = ker h via some s.
  obtain ⟨s, hs⟩ := normal_mono.lift' u i hih,
  have hs' : (s ≫ kernel.ι g) ≫ i = 𝟙 I ≫ i, by rw [category.assoc, hs, category.id_comp],
  haveI : epi (kernel.ι g) := epi_of_epi_fac ((cancel_mono _).1 hs'),
  -- ker g is an epimorphism, but ker g ≫ g = 0 = ker g ≫ 0, so g = 0 as required.
  exact zero_of_epi_comp _ (kernel.condition g)
end

instance is_iso_factor_thru_image [mono f] : is_iso (abelian.factor_thru_image f) :=
is_iso_of_mono_of_epi _

/-- The canonical morphism `i : coimage f ⟶ Q` is a monomorphism -/
instance : mono (abelian.factor_thru_coimage f) :=
let I := abelian.coimage f, i := abelian.factor_thru_coimage f,
    p := cokernel.π (kernel.ι f) in
normal_epi_category.mono_of_cancel_zero _ $ λ R (g : R ⟶ I) (hgi : g ≫ i = 0),
begin
  -- Since C is abelian, u := p ≫ coker g is the cokernel of some morphism h.
  let u := p ≫ cokernel.π g,
  haveI : epi u := epi_comp _ _,
  haveI hu := normal_epi_of_epi u,
  let h := hu.g,
  -- By hypothesis, i factors through the cokernel of g via some t.
  obtain ⟨t, ht⟩ := cokernel.desc' g i hgi,
  have hf : h ≫ f = 0, calc
    h ≫ f = h ≫ (p ≫ i) : (abelian.coimage.fac f).symm ▸ rfl
    ... = h ≫ (p ≫ (cokernel.π g ≫ t)) : ht ▸ rfl
    ... = h ≫ u ≫ t : by simp only [category.assoc]; conv_lhs { congr, skip, rw ←category.assoc }
    ... = 0 ≫ t : by rw [←category.assoc, hu.w]
    ... = 0 : zero_comp,
  -- h factors through the kernel of f via some l.
  obtain ⟨l, hl⟩ := kernel.lift' f h hf,
  have hhp : h ≫ p = 0, calc
    h ≫ p = (l ≫ kernel.ι f) ≫ p : hl ▸ rfl
    ... = l ≫ 0 : by rw [category.assoc, cokernel.condition]
    ... = 0 : comp_zero,
  -- p factors through u = coker h via some s.
  obtain ⟨s, hs⟩ := normal_epi.desc' u p hhp,
  have hs' : p ≫ cokernel.π g ≫ s = p ≫ 𝟙 I, by rw [←category.assoc, hs, category.comp_id],
  haveI : mono (cokernel.π g) := mono_of_mono_fac ((cancel_epi _).1 hs'),
  -- coker g is a monomorphism, but g ≫ coker g = 0 = 0 ≫ coker g, so g = 0 as required.
  exact zero_of_comp_mono _ (cokernel.condition g)
end

instance is_iso_factor_thru_coimage [epi f] :
  is_iso (abelian.factor_thru_coimage f) :=
is_iso_of_mono_of_epi _

end factor

section cokernel_of_kernel
variables {X Y : C} {f : X ⟶ Y}

/-- In a `non_preadditive_abelian` category, an epi is the cokernel of its kernel. More precisely:
    If `f` is an epimorphism and `s` is some limit kernel cone on `f`, then `f` is a cokernel
    of `fork.ι s`. -/
def epi_is_cokernel_of_kernel [epi f] (s : fork f 0) (h : is_limit s) :
  is_colimit (cokernel_cofork.of_π f (kernel_fork.condition s)) :=
is_cokernel.cokernel_iso _ _
  (cokernel.of_iso_comp _ _
    (limits.is_limit.cone_point_unique_up_to_iso (limit.is_limit _) h)
    (cone_morphism.w (limits.is_limit.unique_up_to_iso (limit.is_limit _) h).hom _))
  (as_iso $ abelian.factor_thru_coimage f) (abelian.coimage.fac f)

/-- In a `non_preadditive_abelian` category, a mono is the kernel of its cokernel. More precisely:
    If `f` is a monomorphism and `s` is some colimit cokernel cocone on `f`, then `f` is a kernel
    of `cofork.π s`. -/
def mono_is_kernel_of_cokernel [mono f] (s : cofork f 0) (h : is_colimit s) :
  is_limit (kernel_fork.of_ι f (cokernel_cofork.condition s)) :=
is_kernel.iso_kernel _ _
  (kernel.of_comp_iso _ _
    (limits.is_colimit.cocone_point_unique_up_to_iso h (colimit.is_colimit _))
    (cocone_morphism.w (limits.is_colimit.unique_up_to_iso h $ colimit.is_colimit _).hom _))
  (as_iso $ abelian.factor_thru_image f) (abelian.image.fac f)

end cokernel_of_kernel
section

/-- The composite `A ⟶ A ⨯ A ⟶ cokernel (Δ A)`, where the first map is `(𝟙 A, 0)` and the second map
    is the canonical projection into the cokernel. -/
abbreviation r (A : C) : A ⟶ cokernel (diag A) := prod.lift (𝟙 A) 0 ≫ cokernel.π (diag A)

instance mono_Δ {A : C} : mono (diag A) := mono_of_mono_fac $ prod.lift_fst _ _

instance mono_r {A : C} : mono (r A) :=
begin
  let hl : is_limit (kernel_fork.of_ι (diag A) (cokernel.condition (diag A))),
  { exact mono_is_kernel_of_cokernel _ (colimit.is_colimit _) },
  apply normal_epi_category.mono_of_cancel_zero,
  intros Z x hx,
  have hxx : (x ≫ prod.lift (𝟙 A) (0 : A ⟶ A)) ≫ cokernel.π (diag A) = 0,
  { rw [category.assoc, hx] },
  obtain ⟨y, hy⟩ := kernel_fork.is_limit.lift' hl _ hxx,
  rw kernel_fork.ι_of_ι at hy,
  have hyy : y = 0,
  { erw [←category.comp_id y, ←limits.prod.lift_snd (𝟙 A) (𝟙 A),  ←category.assoc, hy,
      category.assoc, prod.lift_snd, has_zero_morphisms.comp_zero] },
  haveI : mono (prod.lift (𝟙 A) (0 : A ⟶ A)) := mono_of_mono_fac (prod.lift_fst _ _),
  apply (cancel_mono (prod.lift (𝟙 A) (0 : A ⟶ A))).1,
  rw [←hy, hyy, zero_comp, zero_comp]
end

instance epi_r {A : C} : epi (r A) :=
begin
  have hlp : prod.lift (𝟙 A) (0 : A ⟶ A) ≫ limits.prod.snd = 0 := prod.lift_snd _ _,
  let hp1 : is_limit (kernel_fork.of_ι (prod.lift (𝟙 A) (0 : A ⟶ A)) hlp),
  { refine fork.is_limit.mk _ (λ s, fork.ι s ≫ limits.prod.fst) _ _,
    { intro s,
      ext; simp, erw category.comp_id },
    { intros s m h,
      haveI : mono (prod.lift (𝟙 A) (0 : A ⟶ A)) := mono_of_mono_fac (prod.lift_fst _ _),
      apply (cancel_mono (prod.lift (𝟙 A) (0 : A ⟶ A))).1,
      convert h,
      ext; simp } },
  let hp2 : is_colimit (cokernel_cofork.of_π (limits.prod.snd : A ⨯ A ⟶ A) hlp),
  { exact epi_is_cokernel_of_kernel _ hp1 },
  apply normal_mono_category.epi_of_zero_cancel,
  intros Z z hz,
  have h : prod.lift (𝟙 A) (0 : A ⟶ A) ≫ cokernel.π (diag A) ≫ z = 0,
  { rw [←category.assoc, hz] },
  obtain ⟨t, ht⟩ := cokernel_cofork.is_colimit.desc' hp2 _ h,
  rw cokernel_cofork.π_of_π at ht,
  have htt : t = 0,
  { rw [←category.id_comp t],
    change 𝟙 A ≫ t = 0,
    rw [←limits.prod.lift_snd (𝟙 A) (𝟙 A), category.assoc, ht, ←category.assoc,
      cokernel.condition, zero_comp] },
  apply (cancel_epi (cokernel.π (diag A))).1,
  rw [←ht, htt, comp_zero, comp_zero]
end

instance is_iso_r {A : C} : is_iso (r A) :=
is_iso_of_mono_of_epi _

/-- The composite `A ⨯ A ⟶ cokernel (diag A) ⟶ A` given by the natural projection into the cokernel
    followed by the inverse of `r`. In the category of modules, using the normal kernels and
    cokernels, this map is equal to the map `(a, b) ↦ a - b`, hence the name `σ` for
    "subtraction". -/
abbreviation σ {A : C} : A ⨯ A ⟶ A := cokernel.π (diag A) ≫ inv (r A)

end

@[simp, reassoc] lemma diag_σ {X : C} : diag X ≫ σ = 0 :=
by rw [cokernel.condition_assoc, zero_comp]

@[simp, reassoc] lemma lift_σ {X : C} : prod.lift (𝟙 X) 0 ≫ σ = 𝟙 X :=
by rw [←category.assoc, is_iso.hom_inv_id]

@[reassoc] lemma lift_map {X Y : C} (f : X ⟶ Y) :
  prod.lift (𝟙 X) 0 ≫ limits.prod.map f f = f ≫ prod.lift (𝟙 Y) 0 :=
by simp

/-- σ is a cokernel of Δ X. -/
def is_colimit_σ {X : C} : is_colimit (cokernel_cofork.of_π σ diag_σ) :=
cokernel.cokernel_iso _ σ (as_iso (r X)).symm (by rw [iso.symm_hom, as_iso_inv])

/-- This is the key identity satisfied by `σ`. -/
lemma σ_comp {X Y : C} (f : X ⟶ Y) : σ ≫ f = limits.prod.map f f ≫ σ :=
begin
  obtain ⟨g, hg⟩ :=
    cokernel_cofork.is_colimit.desc' is_colimit_σ (limits.prod.map f f ≫ σ) (by simp),
  suffices hfg : f = g,
  { rw [←hg, cofork.π_of_π, hfg] },
  calc f = f ≫ prod.lift (𝟙 Y) 0 ≫ σ : by rw [lift_σ, category.comp_id]
    ... = prod.lift (𝟙 X) 0 ≫ limits.prod.map f f ≫ σ : by rw lift_map_assoc
    ... = prod.lift (𝟙 X) 0 ≫ σ ≫ g : by rw [←hg, cokernel_cofork.π_of_π]
    ... = g : by rw [←category.assoc, lift_σ, category.id_comp]
end

section

/- We write `f - g` for `prod.lift f g ≫ σ`. -/
/-- Subtraction of morphisms in a `non_preadditive_abelian` category. -/
def has_sub {X Y : C} : has_sub (X ⟶ Y) := ⟨λ f g, prod.lift f g ≫ σ⟩
local attribute [instance] has_sub

/- We write `-f` for `0 - f`. -/
/-- Negation of morphisms in a `non_preadditive_abelian` category. -/
def has_neg {X Y : C} : has_neg (X ⟶ Y) := ⟨λ f, 0 - f⟩
local attribute [instance] has_neg

/- We write `f + g` for `f - (-g)`. -/
/-- Addition of morphisms in a `non_preadditive_abelian` category. -/
def has_add {X Y : C} : has_add (X ⟶ Y) := ⟨λ f g, f - (-g)⟩
local attribute [instance] has_add

lemma sub_def {X Y : C} (a b : X ⟶ Y) : a - b = prod.lift a b ≫ σ := rfl
lemma add_def {X Y : C} (a b : X ⟶ Y) : a + b = a - (-b) := rfl
lemma neg_def {X Y : C} (a : X ⟶ Y) : -a = 0 - a := rfl

lemma sub_self {X Y : C} (a : X ⟶ Y) : a - a = 0 :=
by rw [sub_def, ←category.comp_id a, ← prod.comp_lift, category.assoc, diag_σ, comp_zero]

lemma lift_sub_lift {X Y : C} (a b c d : X ⟶ Y) :
  prod.lift a b - prod.lift c d = prod.lift (a - c) (b - d) :=
begin
  simp only [sub_def],
  ext,
  { rw [category.assoc, σ_comp, prod.lift_map_assoc, prod.lift_fst, prod.lift_fst, prod.lift_fst] },
  { rw [category.assoc, σ_comp, prod.lift_map_assoc, prod.lift_snd, prod.lift_snd, prod.lift_snd] }
end

lemma sub_sub_sub {X Y : C} (a b c d : X ⟶ Y) : (a - c) - (b - d) = (a - b) - (c - d) :=
begin
  rw [sub_def, ←lift_sub_lift, sub_def, category.assoc, σ_comp, prod.lift_map_assoc], refl
end

lemma neg_sub {X Y : C} (a b : X ⟶ Y) : (-a) - b = (-b) - a :=
by conv_lhs { rw [neg_def, ←sub_zero b, sub_sub_sub, sub_zero, ←neg_def] }

lemma neg_neg {X Y : C} (a : X ⟶ Y) : -(-a) = a :=
begin
  rw [neg_def, neg_def],
  conv_lhs { congr, rw ←sub_self a },
  rw [sub_sub_sub, sub_zero, sub_self, sub_zero]
end

lemma add_comm {X Y : C} (a b : X ⟶ Y) : a + b = b + a :=
begin
  rw [add_def],
  conv_lhs { rw ←neg_neg a },
  rw [neg_def, neg_def, neg_def, sub_sub_sub],
  conv_lhs {congr, skip, rw [←neg_def, neg_sub] },
  rw [sub_sub_sub, add_def, ←neg_def, neg_neg b, neg_def]
end

lemma add_neg {X Y : C} (a b : X ⟶ Y) : a + (-b) = a - b :=
by rw [add_def, neg_neg]

lemma add_neg_self {X Y : C} (a : X ⟶ Y) : a + (-a) = 0 :=
by rw [add_neg, sub_self]

lemma neg_add_self {X Y : C} (a : X ⟶ Y) : (-a) + a = 0 :=
by rw [add_comm, add_neg_self]

lemma neg_sub' {X Y : C} (a b : X ⟶ Y) : -(a - b) = (-a) + b :=
begin
  rw [neg_def, neg_def],
  conv_lhs { rw ←sub_self (0 : X ⟶ Y) },
  rw [sub_sub_sub, add_def, neg_def]
end

lemma neg_add {X Y : C} (a b : X ⟶ Y) : -(a + b) = (-a) - b :=
by rw [add_def, neg_sub', add_neg]

lemma sub_add {X Y : C} (a b c : X ⟶ Y) : (a - b) + c = a - (b - c) :=
by rw [add_def, neg_def, sub_sub_sub, sub_zero]

lemma add_assoc {X Y : C} (a b c : X ⟶ Y) : (a + b) + c = a + (b + c) :=
begin
  conv_lhs { congr, rw add_def },
  rw [sub_add, ←add_neg, neg_sub', neg_neg]
end

lemma add_zero {X Y : C} (a : X ⟶ Y) : a + 0 = a :=
by rw [add_def, neg_def, sub_self, sub_zero]

lemma comp_sub {X Y Z : C} (f : X ⟶ Y) (g h : Y ⟶ Z) : f ≫ (g - h) = f ≫ g - f ≫ h :=
by rw [sub_def, ←category.assoc, prod.comp_lift, sub_def]

lemma sub_comp {X Y Z : C} (f g : X ⟶ Y) (h : Y ⟶ Z) : (f - g) ≫ h = f ≫ h - g ≫ h :=
by rw [sub_def, category.assoc, σ_comp, ←category.assoc, prod.lift_map, sub_def]

lemma comp_add (X Y Z : C) (f : X ⟶ Y) (g h : Y ⟶ Z) : f ≫ (g + h) = f ≫ g + f ≫ h :=
by rw [add_def, comp_sub, neg_def, comp_sub, comp_zero, add_def, neg_def]

lemma add_comp (X Y Z : C) (f g : X ⟶ Y) (h : Y ⟶ Z) : (f + g) ≫ h = f ≫ h + g ≫ h :=
by rw [add_def, sub_comp, neg_def, sub_comp, zero_comp, add_def, neg_def]

/-- Every `non_preadditive_abelian` category is preadditive. -/
def preadditive : preadditive C :=
{ hom_group := λ X Y,
  { add := (+),
    add_assoc := add_assoc,
    zero := 0,
    zero_add := neg_neg,
    add_zero := add_zero,
    neg := λ f, -f,
    add_left_neg := neg_add_self,
    add_comm := add_comm },
  add_comp' := add_comp,
  comp_add' := comp_add }

end

end category_theory.non_preadditive_abelian


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

! This file was ported from Lean 3 source module order.category.BoolAlg
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Category.HeytAlg

/-!
# The category of boolean algebras

This defines `BoolAlg`, the category of boolean algebras.
-/

open OrderDual Opposite Set

universe u

open CategoryTheory

/-- The category of boolean algebras. -/
def BoolAlg :=
  Bundled BooleanAlgebra
#align BoolAlg BoolAlg

namespace BoolAlg

instance : CoeSort BoolAlg (Type _) :=
  Bundled.hasCoeToSort

instance (X : BoolAlg) : BooleanAlgebra X :=
  X.str

/-- Construct a bundled `BoolAlg` from a `boolean_algebra`. -/
def of (α : Type _) [BooleanAlgebra α] : BoolAlg :=
  Bundled.of α
#align BoolAlg.of BoolAlg.of

@[simp]
theorem coe_of (α : Type _) [BooleanAlgebra α] : ↥(of α) = α :=
  rfl
#align BoolAlg.coe_of BoolAlg.coe_of

instance : Inhabited BoolAlg :=
  ⟨of PUnit⟩

/-- Turn a `BoolAlg` into a `BddDistLat` by forgetting its complement operation. -/
def toBddDistLat (X : BoolAlg) : BddDistLat :=
  BddDistLat.of X
#align BoolAlg.to_BddDistLat BoolAlg.toBddDistLat

@[simp]
theorem coe_toBddDistLat (X : BoolAlg) : ↥X.toBddDistLat = ↥X :=
  rfl
#align BoolAlg.coe_to_BddDistLat BoolAlg.coe_toBddDistLat

instance : LargeCategory.{u} BoolAlg :=
  InducedCategory.category toBddDistLat

instance : ConcreteCategory BoolAlg :=
  InducedCategory.concreteCategory toBddDistLat

instance hasForgetToBddDistLat : HasForget₂ BoolAlg BddDistLat :=
  InducedCategory.hasForget₂ toBddDistLat
#align BoolAlg.has_forget_to_BddDistLat BoolAlg.hasForgetToBddDistLat

section

attribute [local instance] BoundedLatticeHomClass.toBiheytingHomClass

@[simps]
instance hasForgetToHeytAlg : HasForget₂ BoolAlg HeytAlg
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y f => show BoundedLatticeHom X Y from f }
#align BoolAlg.has_forget_to_HeytAlg BoolAlg.hasForgetToHeytAlg

end

/-- Constructs an equivalence between Boolean algebras from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : BoolAlg.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := (e : BoundedLatticeHom α β)
  inv := (e.symm : BoundedLatticeHom β α)
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align BoolAlg.iso.mk BoolAlg.Iso.mk

/-- `order_dual` as a functor. -/
@[simps]
def dual : BoolAlg ⥤ BoolAlg where
  obj X := of Xᵒᵈ
  map X Y := BoundedLatticeHom.dual
#align BoolAlg.dual BoolAlg.dual

/-- The equivalence between `BoolAlg` and itself induced by `order_dual` both ways. -/
@[simps Functor inverse]
def dualEquiv : BoolAlg ≌ BoolAlg :=
  Equivalence.mk dual dual
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
#align BoolAlg.dual_equiv BoolAlg.dualEquiv

end BoolAlg

theorem boolAlg_dual_comp_forget_to_bddDistLat :
    BoolAlg.dual ⋙ forget₂ BoolAlg BddDistLat = forget₂ BoolAlg BddDistLat ⋙ BddDistLat.dual :=
  rfl
#align BoolAlg_dual_comp_forget_to_BddDistLat boolAlg_dual_comp_forget_to_bddDistLat


import game.series.L01defs
variable X : Type --hide

/-
Idea 04: root test
-/

/- Lemma
If $A$ and $B$ are sets of any type $X$, then
$$ A \subseteq A\cup B.$$
-/
theorem subset_union_left (A B : set X) : A ⊆ A ∪ B :=
begin
    --change ∀ (x : α), x ∈ A → x ∈ A ∪ B,  --they may want to do this
    intros x hx,
    left, exact hx, done
end


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Adam Topaz

! This file was ported from Lean 3 source module category_theory.Fintype
! leanprover-community/mathlib commit c3019c79074b0619edb4b27553a91b2e82242395
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.ConcreteCategory.Basic
import Mathbin.CategoryTheory.FullSubcategory
import Mathbin.CategoryTheory.Skeletal
import Mathbin.CategoryTheory.Elementwise
import Mathbin.Data.Fintype.Card

/-!
# The category of finite types.

We define the category of finite types, denoted `Fintype` as
(bundled) types with a `fintype` instance.

We also define `Fintype.skeleton`, the standard skeleton of `Fintype` whose objects are `fin n`
for `n : ℕ`. We prove that the obvious inclusion functor `Fintype.skeleton ⥤ Fintype` is an
equivalence of categories in `Fintype.skeleton.equivalence`.
We prove that `Fintype.skeleton` is a skeleton of `Fintype` in `Fintype.is_skeleton`.
-/

open Classical

open CategoryTheory

/-- The category of finite types. -/
def FintypeCat :=
  Bundled Fintype
#align Fintype FintypeCat

namespace FintypeCat

instance : CoeSort FintypeCat (Type _) :=
  Bundled.hasCoeToSort

/-- Construct a bundled `Fintype` from the underlying type and typeclass. -/
def of (X : Type _) [Fintype X] : FintypeCat :=
  Bundled.of X
#align Fintype.of FintypeCat.of

instance : Inhabited FintypeCat :=
  ⟨⟨PEmpty⟩⟩

instance {X : FintypeCat} : Fintype X :=
  X.2

instance : Category FintypeCat :=
  InducedCategory.category Bundled.α

/-- The fully faithful embedding of `Fintype` into the category of types. -/
@[simps]
def incl : FintypeCat ⥤ Type _ :=
  inducedFunctor _ deriving Full, Faithful
#align Fintype.incl FintypeCat.incl

instance concreteCategoryFintype : ConcreteCategory FintypeCat :=
  ⟨incl⟩
#align Fintype.concrete_category_Fintype FintypeCat.concreteCategoryFintype

@[simp]
theorem id_apply (X : FintypeCat) (x : X) : (𝟙 X : X → X) x = x :=
  rfl
#align Fintype.id_apply FintypeCat.id_apply

@[simp]
theorem comp_apply {X Y Z : FintypeCat} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) : (f ≫ g) x = g (f x) :=
  rfl
#align Fintype.comp_apply FintypeCat.comp_apply

-- See `equiv_equiv_iso` in the root namespace for the analogue in `Type`.
/-- Equivalences between finite types are the same as isomorphisms in `Fintype`. -/
@[simps]
def equivEquivIso {A B : FintypeCat} : A ≃ B ≃ (A ≅ B)
    where
  toFun e :=
    { Hom := e
      inv := e.symm }
  invFun i :=
    { toFun := i.Hom
      invFun := i.inv
      left_inv := Iso.hom_inv_id_apply i
      right_inv := Iso.inv_hom_id_apply i }
  left_inv := by tidy
  right_inv := by tidy
#align Fintype.equiv_equiv_iso FintypeCat.equivEquivIso

universe u

/--
The "standard" skeleton for `Fintype`. This is the full subcategory of `Fintype` spanned by objects
of the form `ulift (fin n)` for `n : ℕ`. We parameterize the objects of `Fintype.skeleton`
directly as `ulift ℕ`, as the type `ulift (fin m) ≃ ulift (fin n)` is
nonempty if and only if `n = m`. Specifying universes, `skeleton : Type u` is a small
skeletal category equivalent to `Fintype.{u}`.
-/
def Skeleton : Type u :=
  ULift ℕ
#align Fintype.skeleton FintypeCat.Skeleton

namespace Skeleton

/-- Given any natural number `n`, this creates the associated object of `Fintype.skeleton`. -/
def mk : ℕ → Skeleton :=
  ULift.up
#align Fintype.skeleton.mk FintypeCat.Skeleton.mk

instance : Inhabited Skeleton :=
  ⟨mk 0⟩

/-- Given any object of `Fintype.skeleton`, this returns the associated natural number. -/
def len : Skeleton → ℕ :=
  ULift.down
#align Fintype.skeleton.len FintypeCat.Skeleton.len

@[ext]
theorem ext (X Y : Skeleton) : X.len = Y.len → X = Y :=
  ULift.ext _ _
#align Fintype.skeleton.ext FintypeCat.Skeleton.ext

instance : SmallCategory Skeleton.{u}
    where
  Hom X Y := ULift.{u} (Fin X.len) → ULift.{u} (Fin Y.len)
  id _ := id
  comp _ _ _ f g := g ∘ f

theorem is_skeletal : Skeletal Skeleton.{u} := fun X Y ⟨h⟩ =>
  ext _ _ <|
    Fin.equiv_iff_eq.mp <|
      Nonempty.intro <|
        { toFun := fun x => (h.Hom ⟨x⟩).down
          invFun := fun x => (h.inv ⟨x⟩).down
          left_inv := by
            intro a
            change ULift.down _ = _
            rw [ULift.up_down]
            change ((h.hom ≫ h.inv) _).down = _
            simpa
          right_inv := by
            intro a
            change ULift.down _ = _
            rw [ULift.up_down]
            change ((h.inv ≫ h.hom) _).down = _
            simpa }
#align Fintype.skeleton.is_skeletal FintypeCat.Skeleton.is_skeletal

/-- The canonical fully faithful embedding of `Fintype.skeleton` into `Fintype`. -/
def incl : Skeleton.{u} ⥤ FintypeCat.{u}
    where
  obj X := FintypeCat.of (ULift (Fin X.len))
  map _ _ f := f
#align Fintype.skeleton.incl FintypeCat.Skeleton.incl

instance : Full incl where preimage _ _ f := f

instance : Faithful incl where

instance : EssSurj incl :=
  EssSurj.mk fun X =>
    let F := Fintype.equivFin X
    ⟨mk (Fintype.card X),
      Nonempty.intro
        { Hom := F.symm ∘ ULift.down
          inv := ULift.up ∘ F }⟩

noncomputable instance : IsEquivalence incl :=
  Equivalence.ofFullyFaithfullyEssSurj _

/-- The equivalence between `Fintype.skeleton` and `Fintype`. -/
noncomputable def equivalence : Skeleton ≌ FintypeCat :=
  incl.asEquivalence
#align Fintype.skeleton.equivalence FintypeCat.Skeleton.equivalence

@[simp]
theorem incl_mk_nat_card (n : ℕ) : Fintype.card (incl.obj (mk n)) = n :=
  by
  convert Finset.card_fin n
  apply Fintype.ofEquiv_card
#align Fintype.skeleton.incl_mk_nat_card FintypeCat.Skeleton.incl_mk_nat_card

end Skeleton

/-- `Fintype.skeleton` is a skeleton of `Fintype`. -/
noncomputable def isSkeleton : IsSkeletonOf FintypeCat Skeleton Skeleton.incl
    where
  skel := Skeleton.is_skeletal
  eqv := by infer_instance
#align Fintype.is_skeleton FintypeCat.isSkeleton

end FintypeCat


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

Lemmas about traversing collections.

Inspired by:

    The Essence of the Iterator Pattern
    Jeremy Gibbons and Bruno César dos Santos Oliveira
    In Journal of Functional Programming. Vol. 19. No. 3&4. Pages 377−402. 2009.
    <http://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf>
-/
import control.traversable.basic
import control.applicative

universe variables u

open is_lawful_traversable
open function (hiding comp)
open functor

attribute [functor_norm] is_lawful_traversable.naturality
attribute [simp] is_lawful_traversable.id_traverse

namespace traversable

variable {t : Type u → Type u}
variables [traversable t] [is_lawful_traversable t]
variables F G : Type u → Type u

variables [applicative F] [is_lawful_applicative F]
variables [applicative G] [is_lawful_applicative G]
variables {α β γ : Type u}
variables g : α → F β
variables h : β → G γ
variables f : β → γ

/-- The natural applicative transformation from the identity functor
to `F`, defined by `pure : Π {α}, α → F α`. -/
def pure_transformation : applicative_transformation id F :=
{ app := @pure F _,
  preserves_pure' := λ α x, rfl,
  preserves_seq' := λ α β f x, by simp; refl }

@[simp]

variables {F G} (x : t β)

lemma map_eq_traverse_id : map f = @traverse t _ _ _ _ _ (id.mk ∘ f) :=
funext $ λ y, (traverse_eq_map_id f y).symm

theorem map_traverse (x : t α) :
  map f <$> traverse g x = traverse (map f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ f,
  refine (comp_traverse (id.mk ∘ f) g x).symm.trans _,
  congr, apply comp.applicative_comp_id
end

theorem traverse_map (f : β → F γ) (g : α → β) (x : t α) :
  traverse f (g <$> x) = traverse (f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ g,
  refine (comp_traverse f (id.mk ∘ g) x).symm.trans _,
  congr, apply comp.applicative_id_comp
end

lemma pure_traverse (x : t α) :
  traverse pure x = (pure x : F (t α)) :=
by have : traverse pure x = pure (traverse id.mk x) :=
     (naturality (pure_transformation F) id.mk x).symm;
   rwa id_traverse at this

lemma id_sequence (x : t α) :
  sequence (id.mk <$> x) = id.mk x :=
by simp [sequence, traverse_map, id_traverse]; refl

lemma comp_sequence (x : t (F (G α))) :
  sequence (comp.mk <$> x) = comp.mk (sequence <$> sequence x) :=
by simp [sequence, traverse_map]; rw ← comp_traverse; simp [map_id]

lemma naturality' (η : applicative_transformation F G) (x : t (F α)) :
  η (sequence x) = sequence (@η _ <$> x) :=
by simp [sequence, naturality, traverse_map]

@[functor_norm]
lemma traverse_id :
  traverse id.mk = (id.mk : t α → id (t α)) :=
by ext; simp [id_traverse]; refl

@[functor_norm]
lemma traverse_comp (g : α → F β) (h : β → G γ) :
  traverse (comp.mk ∘ map h ∘ g) =
  (comp.mk ∘ map (traverse h) ∘ traverse g : t α → comp F G (t γ)) :=
by ext; simp [comp_traverse]

lemma traverse_eq_map_id' (f : β → γ) :
  traverse (id.mk ∘ f) =
  id.mk ∘ (map f : t β → t γ) :=
by ext;rw traverse_eq_map_id

-- @[functor_norm]
lemma traverse_map' (g : α → β) (h : β → G γ) :
  traverse (h ∘ g) =
  (traverse h ∘ map g : t α → G (t γ)) :=
by ext; simp [traverse_map]

lemma map_traverse' (g : α → G β) (h : β → γ) :
  traverse (map h ∘ g) =
  (map (map h) ∘ traverse g : t α → G (t γ)) :=
by ext; simp [map_traverse]

lemma naturality_pf (η : applicative_transformation F G) (f : α → F β) :
  traverse (@η _ ∘ f) = @η _ ∘ (traverse f : t α → F (t β)) :=
by ext; simp [naturality]

end traversable


import tactic.basic
import .ch11_imp

namespace impparser

/-
Definition isWhite (c : ascii) : bool :=
  let n := nat_of_ascii c in
  orb (orb (n =? 32) (* space *)
           (n =? 9)) (* tab *)
      (orb (n =? 10) (* linefeed *)
           (n =? 13)). (* Carriage return. *)

Notation "x '<=?' y" := (x <=? y)
  (at level 70, no associativity) : nat_scope.

Definition isLowerAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    andb (97 <=? n) (n <=? 122).

Definition isAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    orb (andb (65 <=? n) (n <=? 90))
        (andb (97 <=? n) (n <=? 122)).

Definition isDigit (c : ascii) : bool :=
  let n := nat_of_ascii c in
     andb (48 <=? n) (n <=? 57).

Inductive chartype := white | alpha | digit | other.

Definition classifyChar (c : ascii) : chartype :=
  if isWhite c then
    white
  else if isAlpha c then
    alpha
  else if isDigit c then
    digit
  else
    other.

Fixpoint list_of_string (s : string) : list ascii :=
  match s with
  | EmptyString ⇒ []
  | String c s ⇒ c :: (list_of_string s)
  end.

Fixpoint string_of_list (xs : list ascii) : string :=
  fold_right String EmptyString xs.

Definition token := string.

Fixpoint tokenize_helper (cls : chartype) (acc xs : list ascii)
                       : list (list ascii) :=
  let tk := match acc with [] ⇒ [] | _::_ ⇒ [rev acc] end in
  match xs with
  | [] ⇒ tk
  | (x::xs') ⇒
    match cls, classifyChar x, x with
    | _, _, "(" ⇒
      tk ++ ["("]::(tokenize_helper other [] xs')
    | _, _, ")" ⇒
      tk ++ [")"]::(tokenize_helper other [] xs')
    | _, white, _ ⇒
      tk ++ (tokenize_helper white [] xs')
    | alpha,alpha,x ⇒
      tokenize_helper alpha (x::acc) xs'
    | digit,digit,x ⇒
      tokenize_helper digit (x::acc) xs'
    | other,other,x ⇒
      tokenize_helper other (x::acc) xs'
    | _,tp,x ⇒
      tk ++ (tokenize_helper tp [x] xs')
    end
  end %char.

Definition tokenize (s : string) : list string :=
  map string_of_list (tokenize_helper white [] (list_of_string s)).

Example tokenize_ex1 :
    tokenize "abc12=3 223*(3+(a+c))" %string
  = ["abc"; "12"; "="; "3"; "223";
       "*"; "("; "3"; "+"; "(";
       "a"; "+"; "c"; ")"; ")"]%string.
Proof. reflexivity. Qed.
-/

def isWhite (c : char) : bool :=
  let n := c.to_nat in
  (n = 32) || (n = 9) || (n = 10) || (n = 13)

def isLowerAlpha (c : char) : bool :=
  let n := c.to_nat in (97 ≤ n) && (n ≤ 122)

def isAlpha (c : char) : bool :=
  let n := c.to_nat in
  (65 ≤ n) && (n ≤ 90) || (97 ≤ n) && (n ≤ 122)

def isDigit (c : char) : bool :=
  let n := c.to_nat in (48 ≤ n) && (n ≤ 57)

inductive chartype | white | alpha | digit | other
open chartype

/-
TODO : file bug about whitespace on windows
-/

def classifyChar (c : char) :=
  if c.is_whitespace then white /- lean fails on crlf -/
  else if c.is_alpha then alpha
  else if c.is_digit then digit
  else other

def list_of_string (s: string) := s.data

def string_of_list (cs : list char) : string := ⟨cs⟩

def token := string

-- def tokenize_helper : list (list char) :=
--   λ(cls : chartype) (acc xs : list char),
--     list.rec_on xs tk (λx xs' ih, tk)
--     let tk := match acc with [] := [] | _ := [acc.reverse] end in

-- def tokenize_helper (cls : chartype) (acc xs : list char) : list (list char) :=
--   let tk := match acc with [] := [] | _ := [acc.reverse] end in
--   match xs with
--   | [] := tk
--   | x::xs' :=
--     match cls, classifyChar x, x with
--       | _, _, '(' := tk ++ ['(']::tokenize_helper other [] xs'
--       | _, _, _ := tk
--     end
--   end

-- def tokenize_helper (cls : chartype) (acc xs : list char) : list (list char) :=
--   let tk := match acc with [] := [] | _ := [acc.reverse] end in
--   list.rec_on xs
--     (λ_ _, tk)
--     (λx xs' ih cls acc,
--       match cls, classifyChar x, x with
--         | _, _, '(' := tk ++ ['(']::ih other []
--         | _, _, ')' := tk ++ [')']::ih other []
--         | _, white, _ := tk ++ ih white []
--         | alpha, alpha, x := ih alpha (x::acc)
--         | digit, digit, x := ih digit (x::acc)
--         | other, other, x := ih other (x::acc)
--         | _, tp, x := tk ++ ih tp [x]
--       end
--   ) cls acc

-- #print list.rec
-- #print list.rec_on

-- def tokenize_helper'' (cls : chartype) (acc xs : list char) : list (list char) :=
--   let tk := if acc ≠ [] then [] else [acc.reverse] in
--   xs.brec_on $ λxs b,
--     match xs with
--     | x::xs := tk
--     | _ := tk
--     end

/-
i don't know how to make this nicer
-/

def rev_ll (ls : list char) := if ls = [] then [] else [ls.reverse]

def tokenize_helper : chartype → list char → list char → list (list char)
| cls acc [] := rev_ll acc
| cls acc (x::xs') :=
  let tk := rev_ll acc in
  match cls, classifyChar x, x with
  | _, _, '(' := tk ++ ['(']::tokenize_helper other [] xs'
  | _, _, ')' := tk ++ [')']::tokenize_helper other [] xs'
  | _, white, _ := tk ++ tokenize_helper white [] xs'
  | alpha, alpha, x := tokenize_helper alpha (x::acc) xs'
  | digit, digit, x := tokenize_helper digit (x::acc) xs'
  | other, other, x := tokenize_helper other (x::acc) xs'
  | _, tp, x := tk ++ tokenize_helper tp [x] xs'
  end

-- #print tokenize_helper
-- #print tokenize_helper._main

def tokenize (s) : list string :=
  list.map string_of_list (tokenize_helper white [] $ list_of_string s)

-- run_cmd mk_simp_attr `token_simp

-- attribute [token_simp]
--     tokenize list_of_string classifyChar list.map string_of_list
--     tokenize_helper tokenize_helper._match_1 tokenize_helper._match_2
--     tokenize_helper' tokenize_helper'._match_1 tokenize_helper'._match_2
--     tokenize_helper'._match_3 list.reverse list.reverse_core ite
--     has_le.le and or not eq and.decidable or.decidable decidable.rec
--     char.val
--     char.is_whitespace char.is_alpha char.is_upper char.is_lower char.is_digit

-- example : tokenize "" = [] := rfl

-- set_option pp.notation false
-- set_option pp.structure_projections false

-- example : tokenize_helper white [] ['a'] = [['a']] :=
-- begin
--   simp with token_simp,
--   refl
-- end

-- example : tokenize_helper white [] ['a', 'b'] = [['a', 'b']] := rfl
-- example : tokenize_helper white [] ['a', 'b', '1'] = [['a', 'b'], ['1']] := rfl

-- example : tokenize "a" = ["a"] := rfl

-- example : tokenize "abc12=3" = ["abc", "12", "=", "3"] := rfl

example : tokenize "abc12=3 223*(3+(a+c))" =
  ["abc", "12", "=", "3",
  "223", "*", "(", "3", "+", "(", "a", "+", "c", ")", ")"] := rfl

/-
Inductive optionE (X:Type) : Type :=
  | SomeE (x : X)
  | NoneE (s : string).

Arguments SomeE {X}.
Arguments NoneE {X}.
-/

inductive optionE (α : Type)
| SomeE (a : α) : optionE
| NoneE (s : string) : optionE

open optionE

instance option_monad : monad optionE := {
  pure := λα, SomeE,
  bind := λα β a f,
    match a with
    | (SomeE e) := f e
    | (NoneE e) := NoneE e
    end
}

instance option_hasOrElse : has_orelse optionE := ⟨λα a b,
  match a with
  | (SomeE e) := SomeE e
  | (NoneE e) := b
  end
⟩

/-
Notation "' p <- e1 ;; e2"
   := (match e1 with
       | SomeE p ⇒ e2
       | NoneE err ⇒ NoneE err
       end)
   (right associativity, p pattern, at level 60, e1 at next level).

Notation "'TRY' ' p <- e1 ;; e2 'OR' e3"
   := (match e1 with
       | SomeE p ⇒ e2
       | NoneE _ ⇒ e3
       end)
   (right associativity, p pattern,
    at level 60, e1 at next level, e2 at next level).
-/

-- notation `' ` p:60 ` ← ` e₁:55 ` ;; ` e₂ :=
--   match e₁ with
--   | SomeE p := e₂
--   | NoneE err := NoneE err
--   end

-- notation `TRY ` ` ' ` p:60 ← e₁:55 ` ;; ` e₂:55 ` OR ` e₃ :=
--   match e₁ with
--   | SomeE p := e₂
--   | NoneE _ := e₃
--   end

/-
Open Scope string_scope.

Definition parser (T : Type) :=
  list token → optionE (T * list token).

Fixpoint many_helper {T} (p : parser T) acc steps xs :=
  match steps, p xs with
  | 0, _ ⇒
      NoneE "Too many recursive calls"
  | _, NoneE _ ⇒
      SomeE ((rev acc), xs)
  | S steps', SomeE (t, xs') ⇒
      many_helper p (t :: acc) steps' xs'
  end.
-/

open nat

def parser (α : Type) := list token → optionE (α × list token)

def many_helper {α} (p : parser α) : list α → ℕ → parser (list α)
| _ 0 _ := NoneE "Too many recursive calls"
| acc (succ steps') xs :=
  match p xs with
  | (NoneE _) := SomeE (acc.reverse, xs)
  | (SomeE (t, xs')) := many_helper (t :: acc) steps' xs'
  end

/-
Fixpoint many {T} (p : parser T) (steps : nat) : parser (list T) :=
  many_helper p [] steps.
-/

def many {α} (p steps) : parser (list α) := many_helper p [] steps

/-
Definition firstExpect {T} (t : token) (p : parser T)
                     : parser T :=
  fun xs ⇒ match xs with
            | x::xs' ⇒
              if string_dec x t
              then p xs'
              else NoneE ("expected '" ++ t ++ "'.")
            | [] ⇒
              NoneE ("expected '" ++ t ++ "'.")
            end.
-/

def firstExpect {α} (t : token) (p : parser α) : parser α
| (x::xs') := if x = t then p xs' else NoneE $ "expected '" ++ t ++ "'."
| [] := NoneE $ "expected '" ++ t ++ "'."

/-
Definition expect (t : token) : parser unit :=
  firstExpect t (fun xs ⇒ SomeE (tt, xs)).
-/

def expect (t) : parser unit :=
  firstExpect t $ λxs, SomeE ((), xs)

/-
Definition parseIdentifier (xs : list token)
                         : optionE (string * list token) :=
match xs with
| [] ⇒ NoneE "Expected identifier"
| x::xs' ⇒
    if forallb isLowerAlpha (list_of_string x) then
      SomeE (x, xs')
    else
      NoneE ("Illegal identifier:'" ++ x ++ "'")
end.
-/

def parseIdentifier : parser string
| [] := NoneE "Expected identifier"
| (x::xs') :=
  if x.data.all isLowerAlpha
  then SomeE (x, xs')
  else NoneE ("Illegal identifier:'" ++ x ++ "'")

/-
Definition parseNumber (xs : list token)
                     : optionE (nat * list token) :=
match xs with
| [] ⇒ NoneE "Expected number"
| x::xs' ⇒
    if forallb isDigit (list_of_string x) then
      SomeE (fold_left
               (fun n d ⇒
                  10 * n + (nat_of_ascii d -
                            nat_of_ascii "0"%char))
               (list_of_string x)
               0,
             xs')
    else
      NoneE "Expected number"
end.
-/

def parseNumber : parser ℕ
| [] := NoneE "Expected number"
| (x::xs') :=
  if x.data.all isDigit
  then SomeE (x.data.foldl (λn d, 10 * n + d.val - '0'.val) 0, xs')
  else NoneE "Expected number"

/-
Fixpoint parsePrimaryExp (steps:nat)
                         (xs : list token)
                       : optionE (aexp * list token) :=
  match steps with
  | 0 ⇒ NoneE "Too many recursive calls"
  | S steps' ⇒
      TRY ' (i, rest) <- parseIdentifier xs ;;
          SomeE (AId i, rest)
      OR
      TRY ' (n, rest) <- parseNumber xs ;;
          SomeE (ANum n, rest)
      OR
      ' (e, rest) <- firstExpect "(" (parseSumExp steps') xs ;;
      ' (u, rest') <- expect ")" rest ;;
      SomeE (e,rest')
  end

with parseProductExp (steps:nat)
                     (xs : list token) :=
  match steps with
  | 0 ⇒ NoneE "Too many recursive calls"
  | S steps' ⇒
    ' (e, rest) <- parsePrimaryExp steps' xs ;;
    ' (es, rest') <- many (firstExpect "*" (parsePrimaryExp steps'))
                          steps' rest ;;
    SomeE (fold_left AMult es e, rest')
  end

with parseSumExp (steps:nat) (xs : list token) :=
  match steps with
  | 0 ⇒ NoneE "Too many recursive calls"
  | S steps' ⇒
    ' (e, rest) <- parseProductExp steps' xs ;;
    ' (es, rest') <-
        many (fun xs ⇒
                TRY ' (e,rest') <-
                    firstExpect "+"
                                (parseProductExp steps') xs ;;
                    SomeE ( (true, e), rest')
                OR
                ' (e, rest') <-
                    firstExpect "-"
                                (parseProductExp steps') xs ;;
                SomeE ( (false, e), rest'))
        steps' rest ;;
      SomeE (fold_left (fun e0 term ⇒
                          match term with
                          | (true, e) ⇒ APlus e0 e
                          | (false, e) ⇒ AMinus e0 e
                          end)
                       es e,
             rest')
  end.

Definition parseAExp := parseSumExp.
-/

open imp imp.aexp

/- destroys need for using_well_founded and generalizes nicely -/
/-
TODO: this (or something like it) probably belongs in the library
-/

instance psum_sizeof {α β} [sa: has_sizeof α] [sb : has_sizeof β]
  : has_sizeof (psum α β) :=
begin
  unfreezeI,
  constructor,
  intro p,
  cases p,
    cases sa,
    exact sa p,
  cases sb,
  exact sb p,
end

/-
this is annoying.
TODO: is there a way to not need n ≤ succ n everywhere?
-/

mutual def parsePrimaryExp, parseProductExp, parseSumExp
with parsePrimaryExp : ℕ → parser aexp
| (succ steps) := λxs,
  have steps < succ steps, from lt_succ_self steps,
  (do (i, rest) ← parseIdentifier xs, pure (AId i, rest)) <|>
  (do (n, rest) ← parseNumber xs, pure (ANum n, rest)) <|>
  do
    (e, rest) ← firstExpect "(" (parseSumExp steps) xs,
    (u, rest') ← expect ")" rest,
    pure (e, rest')
| _ := λ_, NoneE "Too many recursive calls"

with parseProductExp : ℕ → parser aexp
| 0 := λ_, NoneE "Too many recursive calls"
| (succ steps) := λxs,
  have steps < succ steps, from lt_succ_self steps,
  do
    (e, rest) ← parsePrimaryExp steps xs,
    (es, rest') ← many (firstExpect "*" (parsePrimaryExp steps)) steps rest,
    pure (es.foldl AMult e, rest')

with parseSumExp : ℕ → parser aexp
| 0 := λ_, NoneE "Too many recursive calls"
| (succ steps) := λxs,
  have steps < succ steps, from lt_succ_self steps,
  do
    (e, rest) ← parseProductExp steps xs,
    (es, rest') ← many (λxs,
        (do
          (e, rest') ← firstExpect "+" (parseProductExp steps) xs,
          pure ((tt, e), rest')) <|>
        do
          (e, rest') ← firstExpect "-" (parseProductExp steps) xs,
          pure ((ff, e), rest')
      ) steps rest,
    pure (es.foldl (λe₀ term,
        match term with
        | (tt, e) := APlus e₀ e
        | (ff, e) := AMinus e₀ e
        end
      ) e, rest')

def parseAExp := parseSumExp

/-
Fixpoint parseAtomicExp (steps:nat)
                        (xs : list token) :=
match steps with
  | 0 ⇒ NoneE "Too many recursive calls"
  | S steps' ⇒
     TRY ' (u,rest) <- expect "true" xs ;;
         SomeE (BTrue,rest)
     OR
     TRY ' (u,rest) <- expect "false" xs ;;
         SomeE (BFalse,rest)
     OR
     TRY ' (e,rest) <- firstExpect "¬"
                                   (parseAtomicExp steps')
                                   xs ;;
         SomeE (BNot e, rest)
     OR
     TRY ' (e,rest) <- firstExpect "("
                                   (parseConjunctionExp steps')
                                   xs ;;
         ' (u,rest') <- expect ")" rest ;;
         SomeE (e, rest')
     OR
     ' (e, rest) <- parseProductExp steps' xs ;;
     TRY ' (e', rest') <- firstExpect "="
                                  (parseAExp steps') rest ;;
         SomeE (BEq e e', rest')
     OR
     TRY ' (e', rest') <- firstExpect "≤"
                                      (parseAExp steps') rest ;;
         SomeE (BLe e e', rest')
     OR
     NoneE "Expected '=' or '≤' after arithmetic expression"
end

with parseConjunctionExp (steps:nat)
                         (xs : list token) :=
  match steps with
  | 0 ⇒ NoneE "Too many recursive calls"
  | S steps' ⇒
    ' (e, rest) <- parseAtomicExp steps' xs ;;
    ' (es, rest') <- many (firstExpect "&&"
               (parseAtomicExp steps'))
            steps' rest ;;
    SomeE (fold_left BAnd es e, rest')
  end.

Definition parseBExp := parseConjunctionExp.

Check parseConjunctionExp.

Definition testParsing {X : Type}
           (p : nat →
                list token →
                optionE (X * list token))
           (s : string) :=
  let t := tokenize s in
  p 100 t.
-/

open imp.bexp

mutual def parseAtomicExp, parseConjunctionExp
with parseAtomicExp : ℕ → parser bexp
| 0 := λ_, NoneE "Too many recursive calls"
| (succ steps) := λxs,
  have steps < succ steps, from lt_succ_self steps,
  (do (u, rest) ← expect "true" xs, return (BTrue, rest)) <|>
  (do (u, rest) ← expect "false" xs, return (BFalse, rest)) <|>
  (do
    (e, rest) ← firstExpect "¬" (parseAtomicExp steps) xs,
    return (BNot e, rest)) <|>
  (do
    (e, rest) ← firstExpect "(" (parseConjunctionExp steps) xs,
    (u, rest') ← expect ")" rest,
    return (e, rest')) <|>
  do
    (e, rest) ← parseProductExp steps xs,
    (do
      (e', rest') ← firstExpect "=" (parseAExp steps) rest,
      return (BEq e e', rest')) <|>
    (do
      (e', rest') ← firstExpect "≤" (parseAExp steps) rest,
      return (BLe e e', rest')) <|>
    NoneE "Expected '=' or '≤' after arithmetic expression"

with parseConjunctionExp : ℕ → parser bexp
| 0 := λ_, NoneE "Too many recursive calls"
| (succ steps) := λxs,
  have steps < succ steps, from lt_succ_self steps,
  do
    (e, rest) ← parseAtomicExp steps xs,
    (es, rest') ← many (firstExpect "&&" (parseAtomicExp steps)) steps rest,
    return (es.foldl BAnd e, rest')

def parseBExp := parseConjunctionExp

#check parseConjunctionExp

def testParsing {α : Type} (p : ℕ → parser α) (s) := p 100 $ tokenize s

def aexp_tos : aexp → string
| (ANum n) := has_repr.repr n
| (AId x) := x
| (APlus n m) := "(" ++ aexp_tos n ++ "+" ++ aexp_tos m ++ ")"
| (AMinus n m) := "(" ++ aexp_tos n ++ "-" ++ aexp_tos m ++ ")"
| (AMult n m) := "(" ++ aexp_tos n ++ "*" ++ aexp_tos m ++ ")"

instance aexp_repr : has_repr aexp := ⟨aexp_tos⟩

def bexp_tos : bexp → string
| BTrue := "true"
| BFalse := "false"
| (BEq a₁ a₂) := "(" ++ aexp_tos a₁ ++ "=" ++ aexp_tos a₂ ++ ")"
| (BLe a₁ a₂) := "(" ++ aexp_tos a₁ ++ "≤" ++ aexp_tos a₂ ++ ")"
| (BNot b₁) := "¬" ++ bexp_tos b₁
| (BAnd b₁ b₂) := "(" ++ bexp_tos b₁ ++ "&&" ++ bexp_tos b₂ ++ ")"

instance bexp_repr : has_repr bexp := ⟨bexp_tos⟩

instance option_repr {α} [has_repr α] : has_repr (optionE α) := ⟨λo,
  match o with
  | SomeE e := "Some: " ++ has_repr.repr e
  | NoneE e := "None: " ++ e
  end
⟩

instance token_repr : has_repr token := ⟨id⟩

#eval testParsing parseProductExp "x.y.(x.x).x"

#eval testParsing parseConjunctionExp "¬(x=x&&x*x≤(x*x)*x)&&x=x"

/-
Fixpoint parseSimpleCommand (steps:nat)
                            (xs : list token) :=
  match steps with
  | 0 ⇒ NoneE "Too many recursive calls"
  | S steps' ⇒
    TRY ' (u, rest) <- expect "SKIP" xs ;;
        SomeE (SKIP%imp, rest)
    OR
    TRY ' (e,rest) <-
            firstExpect "TEST"
                        (parseBExp steps') xs ;;
        ' (c,rest') <-
            firstExpect "THEN"
                        (parseSequencedCommand steps') rest ;;
        ' (c',rest'') <-
            firstExpect "ELSE"
                        (parseSequencedCommand steps') rest' ;;
        ' (tt,rest''') <-
            expect "END" rest'' ;;
       SomeE(TEST e THEN c ELSE c' FI%imp, rest''')
    OR
    TRY ' (e,rest) <-
            firstExpect "WHILE"
                        (parseBExp steps') xs ;;
        ' (c,rest') <-
            firstExpect "DO"
                        (parseSequencedCommand steps') rest ;;
        ' (u,rest'') <-
            expect "END" rest' ;;
        SomeE(WHILE e DO c END%imp, rest'')
    OR
    TRY ' (i, rest) <- parseIdentifier xs ;;
        ' (e, rest') <- firstExpect "::=" (parseAExp steps') rest ;;
        SomeE ((i ::= e)%imp, rest')
    OR
        NoneE "Expecting a command"
end

with parseSequencedCommand (steps:nat)
                           (xs : list token) :=
  match steps with
  | 0 ⇒ NoneE "Too many recursive calls"
  | S steps' ⇒
    ' (c, rest) <- parseSimpleCommand steps' xs ;;
    TRY ' (c', rest') <-
            firstExpect ";;"
                        (parseSequencedCommand steps') rest ;;
        SomeE ((c ;; c')%imp, rest')
    OR
    SomeE (c, rest)
  end.

Definition bignumber := 1000.

Definition parse (str : string) : optionE com :=
  let tokens := tokenize str in
  match parseSequencedCommand bignumber tokens with
  | SomeE (c, []) ⇒ SomeE c
  | SomeE (_, t::_) ⇒ NoneE ("Trailing tokens remaining: " ++ t)
  | NoneE err ⇒ NoneE err
  end.
-/

open imp.com

mutual def parseSimpleCommand, parseSequencedCommand
with parseSimpleCommand : ℕ → parser com
| 0 := λ_, NoneE "Too many recursive calls"
| (succ steps) := λxs,
  have steps < succ steps, from lt_succ_self steps,
  do { (u, rest) ← expect "SKIP" xs, pure (SKIP, rest) } <|>
  do {
    (e, rest) ← firstExpect "TEST" (parseBExp steps) xs,
    (c, rest') ← firstExpect "THEN" (parseSequencedCommand steps) rest,
    (c', rest'') ← firstExpect "ELSE" (parseSequencedCommand steps) rest',
    ((), rest''') ← expect "END" rest'',
    pure (TEST e THEN c ELSE c' FI, rest''') } <|>
  do {
    (e, rest) ← firstExpect "WHILE" (parseBExp steps) xs,
    (c, rest') ← firstExpect "DO" (parseSequencedCommand steps) rest,
    (u, rest'') ← expect "END" rest',
    pure (WHILE e DO c END, rest'') } <|>
  do {
    (i, rest) ← parseIdentifier xs,
    (e, rest') ← firstExpect "::=" (parseAExp steps) rest,
    pure (i ::= e, rest') } <|>
  NoneE "Expecting a command"

with parseSequencedCommand : ℕ → parser com
| 0 := λ_, NoneE "Too many recursive calls"
| (succ steps) := λxs,
  have steps < succ steps, from lt_succ_self steps,
  do (c, rest) ← parseSimpleCommand steps xs,
  do {
    (c', rest') ← firstExpect ";;" (parseSequencedCommand steps) rest,
    pure (c ;; c', rest') } <|>
  pure (c, rest)

def bignumber := 1000

def parse (str) : optionE com :=
match parseSequencedCommand bignumber $ tokenize str with
| SomeE (c, []) := SomeE c
| SomeE (_, t::_) := NoneE $ "Trailing tokens remaining: " ++ t
| NoneE err := NoneE err
end

def com_tos : com → string
| CSkip := "SKIP"
| (CAss x a) := x ++ "::=" ++ aexp_tos a
| (CSeq c₁ c₂) := com_tos c₁ ++ ";;" ++ com_tos c₂
| (CIf b c₁ c₂) :=
  "IF " ++ bexp_tos b ++
  " THEN " ++ com_tos c₁ ++
  " ELSE " ++ com_tos c₂ ++
  " FI"
| (CWhile b c) := "WHILE " ++ bexp_tos b ++ " DO " ++ com_tos c ++ " END"

instance com_repr : has_repr com := ⟨com_tos⟩

/-
Example eg1 : parse "
  TEST x = y + 1 + 2 - y * 6 + 3 THEN
    x ::= x * 1;;
    y ::= 0
  ELSE
    SKIP
  END "
=
  SomeE (
      TEST "x" = "y" + 1 + 2 - "y" * 6 + 3 THEN
        "x" ::= "x" * 1;;
        "y" ::= 0
      ELSE
        SKIP
      FI)%imp.
Proof. cbv. reflexivity. Qed.

Example eg2 : parse "
  SKIP;;
  z::=x*y*(x*x);;
  WHILE x=x DO
    TEST (z ≤ z*z) && ~(x = 2) THEN
      x ::= z;;
      y ::= z
    ELSE
      SKIP
    END;;
    SKIP
  END;;
  x::=z "
=
  SomeE (
      SKIP;;
      "z" ::= "x" * "y" * ("x" * "x");;
      WHILE "x" = "x" DO
        TEST ("z" ≤ "z" * "z") && ~("x" = 2) THEN
          "x" ::= "z";;
          "y" ::= "z"
        ELSE
          SKIP
        FI;;
        SKIP
      END;;
      "x" ::= "z")%imp.
Proof. cbv. reflexivity. Qed.
-/

#eval parse "
  TEST x = y + 1 + 2 - y * 6 + 3 THEN
    x ::= x * 1;;
    y ::= 0
  ELSE
    SKIP
  END
"

/-
TODO - notation for numbers is broke af
also, kind of seems like lean can't handle this?
-/
-- example : parse "
--   TEST x = y + 1 + 2 - y * 6 + 3 THEN
--     x ::= x * 1;;
--     y ::= 0
--   ELSE
--     SKIP
--   END
-- " = SomeE (
--   TEST BEq "x" ("y" + 1 + 2 - "y" * 6 + 3) THEN
--     "x" ::= "x" * 1;;
--     "y" ::= 0
--   ELSE
--     SKIP
--   FI
-- ) := begin

-- end

#eval parse "
  SKIP;;
  z::=x*y*(x*x);;
  WHILE x=x DO
    TEST (z ≤ z*z) && ¬(x = 2) THEN
      x ::= z;;
      y ::= z
    ELSE
      SKIP
    END;;
    SKIP
  END;;
  x ::= z
"

end impparser


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.preadditive.additive_functor
import category_theory.abelian.basic
import category_theory.limits.preserves.shapes.kernels
import category_theory.adjunction.limits

/-!
# Transferring "abelian-ness" across a functor

If `C` is an additive category, `D` is an abelian category,
we have `F : C ⥤ D` `G : D ⥤ C` (both preserving zero morphisms),
`G` is left exact (that is, preserves finite limits),
and further we have `adj : G ⊣ F` and `i : F ⋙ G ≅ 𝟭 C`,
then `C` is also abelian.

See <https://stacks.math.columbia.edu/tag/03A3>

## Notes
The hypotheses, following the statement from the Stacks project,
may appear suprising: we don't ask that the counit of the adjunction is an isomorphism,
but just that we have some potentially unrelated isomorphism `i : F ⋙ G ≅ 𝟭 C`.

However Lemma A1.1.1 from [Elephant] shows that in this situation the counit itself
must be an isomorphism, and thus that `C` is a reflective subcategory of `D`.

Someone may like to formalize that lemma, and restate this theorem in terms of `reflective`.
(That lemma has a nice string diagrammatic proof that holds in any bicategory.)
-/

noncomputable theory

namespace category_theory
open category_theory.limits

universes v u₁ u₂

namespace abelian_of_adjunction

variables {C : Type u₁} [category.{v} C] [preadditive C]
variables {D : Type u₂} [category.{v} D] [abelian D]
variables (F : C ⥤ D)
variables (G : D ⥤ C) [functor.preserves_zero_morphisms G]
variables (i : F ⋙ G ≅ 𝟭 C) (adj : G ⊣ F)

include i

/-- No point making this an instance, as it requires `i`. -/
lemma has_kernels [preserves_finite_limits G] : has_kernels C :=
{ has_limit := λ X Y f, begin
    have := nat_iso.naturality_1 i f,
    simp at this,
    rw ←this,
    haveI : has_kernel (G.map (F.map f) ≫ i.hom.app _) := limits.has_kernel_comp_mono _ _,
    apply limits.has_kernel_iso_comp,
  end }

include adj

/-- No point making this an instance, as it requires `i` and `adj`. -/
lemma has_cokernels : has_cokernels C :=
{ has_colimit := λ X Y f, begin
    haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
    have := nat_iso.naturality_1 i f,
    simp at this,
    rw ←this,
    haveI : has_cokernel (G.map (F.map f) ≫ i.hom.app _) := limits.has_cokernel_comp_iso _ _,
    apply limits.has_cokernel_epi_comp,
  end }

variables [limits.has_cokernels C]

/-- Auxiliary construction for `coimage_iso_image` -/
def cokernel_iso {X Y : C} (f : X ⟶ Y) : G.obj (cokernel (F.map f)) ≅ cokernel f :=
begin
  -- We have to write an explicit `preserves_colimits` type here,
  -- as `left_adjoint_preserves_colimits` has universe variables.
  haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
  calc G.obj (cokernel (F.map f))
      ≅ cokernel (G.map (F.map f)) : (as_iso (cokernel_comparison _ G)).symm
  ... ≅ cokernel (_ ≫ f ≫ _)       : cokernel_iso_of_eq (nat_iso.naturality_2 i f).symm
  ... ≅ cokernel (f ≫ _)           : cokernel_epi_comp _ _
  ... ≅ cokernel f                 : cokernel_comp_is_iso _ _
end

variables [limits.has_kernels C] [preserves_finite_limits G]

/-- Auxiliary construction for `coimage_iso_image` -/
def coimage_iso_image_aux {X Y : C} (f : X ⟶ Y) :
  kernel (G.map (cokernel.π (F.map f))) ≅ kernel (cokernel.π f) :=
begin
  haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
  calc kernel (G.map (cokernel.π (F.map f)))
      ≅ kernel (cokernel.π (G.map (F.map f)) ≫ cokernel_comparison (F.map f) G)
          : kernel_iso_of_eq (π_comp_cokernel_comparison _ _).symm
  ... ≅ kernel (cokernel.π (G.map (F.map f))) : kernel_comp_mono _ _
  ... ≅ kernel (cokernel.π (_ ≫ f ≫ _) ≫ (cokernel_iso_of_eq _).hom)
          : kernel_iso_of_eq (π_comp_cokernel_iso_of_eq_hom (nat_iso.naturality_2 i f)).symm
  ... ≅ kernel (cokernel.π (_ ≫ f ≫ _))       : kernel_comp_mono _ _
  ... ≅ kernel (cokernel.π (f ≫ i.inv.app Y) ≫ (cokernel_epi_comp (i.hom.app X) _).inv)
          : kernel_iso_of_eq (by simp only [cokernel.π_desc, cokernel_epi_comp_inv])
  ... ≅ kernel (cokernel.π (f ≫ _))           : kernel_comp_mono _ _
  ... ≅ kernel (inv (i.inv.app Y) ≫ cokernel.π f ≫ (cokernel_comp_is_iso f (i.inv.app Y)).inv)
          : kernel_iso_of_eq (by simp only [cokernel.π_desc, cokernel_comp_is_iso_inv,
              iso.hom_inv_id_app_assoc, nat_iso.inv_inv_app])
  ... ≅ kernel (cokernel.π f ≫ _)             : kernel_is_iso_comp _ _
  ... ≅ kernel (cokernel.π f)                 : kernel_comp_mono _ _
end

variables [functor.preserves_zero_morphisms F]

/--
Auxiliary definition: the abelian coimage and abelian image agree.
We still need to check that this agrees with the canonical morphism.
-/
def coimage_iso_image {X Y : C} (f : X ⟶ Y) : abelian.coimage f ≅ abelian.image f :=
begin
  haveI : preserves_limits F := adj.right_adjoint_preserves_limits,
  haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
  calc abelian.coimage f
      ≅ cokernel (kernel.ι f)                 : iso.refl _
  ... ≅ G.obj (cokernel (F.map (kernel.ι f))) : (cokernel_iso _ _ i adj _).symm
  ... ≅ G.obj (cokernel (kernel_comparison f F ≫ (kernel.ι (F.map f))))
                                              : G.map_iso (cokernel_iso_of_eq (by simp))
  ... ≅ G.obj (cokernel (kernel.ι (F.map f))) : G.map_iso (cokernel_epi_comp _ _)
  ... ≅ G.obj (abelian.coimage (F.map f))     : iso.refl _
  ... ≅ G.obj (abelian.image (F.map f))       : G.map_iso (abelian.coimage_iso_image _)
  ... ≅ G.obj (kernel (cokernel.π (F.map f))) : iso.refl _
  ... ≅ kernel (G.map (cokernel.π (F.map f))) : preserves_kernel.iso _ _
  ... ≅ kernel (cokernel.π f)                 : coimage_iso_image_aux F G i adj f
  ... ≅ abelian.image f                       : iso.refl _,
end

local attribute [simp] cokernel_iso coimage_iso_image coimage_iso_image_aux

-- The account of this proof in the Stacks project omits this calculation.
-- Happily it's little effort: our `[ext]` and `[simp]` lemmas only need a little guidance.
lemma coimage_iso_image_hom {X Y : C} (f : X ⟶ Y) :
  (coimage_iso_image F G i adj f).hom = abelian.coimage_image_comparison f :=
by { ext, simpa [-functor.map_comp, ←G.map_comp_assoc] using nat_iso.naturality_1 i f, }

end abelian_of_adjunction

open abelian_of_adjunction

/--
If `C` is an additive category, `D` is an abelian category,
we have `F : C ⥤ D` `G : D ⥤ C` (both preserving zero morphisms),
`G` is left exact (that is, preserves finite limits),
and further we have `adj : G ⊣ F` and `i : F ⋙ G ≅ 𝟭 C`,
then `C` is also abelian.

See <https://stacks.math.columbia.edu/tag/03A3>
-/
def abelian_of_adjunction
  {C : Type u₁} [category.{v} C] [preadditive C] [has_finite_products C]
  {D : Type u₂} [category.{v} D] [abelian D]
  (F : C ⥤ D) [functor.preserves_zero_morphisms F]
  (G : D ⥤ C) [functor.preserves_zero_morphisms G] [preserves_finite_limits G]
  (i : F ⋙ G ≅ 𝟭 C) (adj : G ⊣ F) : abelian C :=
begin
  haveI := has_kernels F G i, haveI := has_cokernels F G i adj,
  haveI : ∀ {X Y : C} (f : X ⟶ Y), is_iso (abelian.coimage_image_comparison f),
  { intros X Y f, rw ←coimage_iso_image_hom F G i adj f, apply_instance, },
  apply abelian.of_coimage_image_comparison_is_iso,
end

/--
If `C` is an additive category equivalent to an abelian category `D`
via a functor that preserves zero morphisms,
then `C` is also abelian.
-/
def abelian_of_equivalence
  {C : Type u₁} [category.{v} C] [preadditive C] [has_finite_products C]
  {D : Type u₂} [category.{v} D] [abelian D]
  (F : C ⥤ D) [functor.preserves_zero_morphisms F] [is_equivalence F] : abelian C :=
abelian_of_adjunction F F.inv F.as_equivalence.unit_iso.symm F.as_equivalence.symm.to_adjunction

end category_theory


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import .relational
import .relational_incremental
import .recursive

open zset.

variables {Node: Type} [decidable_eq Node].

def Edge (Node: Type) := Node × Node.

instance : decidable_eq (Edge Node) := by apply_instance.

-- get a self-edge for the head
def πh (input: Edge Node) : Edge Node := (input.1, input.1).
-- get a self-edge for the tail
def πt (input: Edge Node) : Edge Node := (input.2, input.2).

def πht (x: Edge Node × Edge Node) : Edge Node :=
  let r1 := x.1 in
  let e := x.2 in
  (r1.1, e.2).

local prefix (name := lifting) `↑`:std.prec.max := lifting.

def closure1 (E R1: Z[Edge Node]) : Z[Edge Node] :=
  distinct $
    zset.map πht (equi_join prod.snd prod.fst R1 E) +
    E +
    zset.map πh E +
    zset.map πt E.

lemma lifting_closure1_eq (E R1: stream Z[Edge Node]) :
  ↑²closure1 E R1 =
  ↑distinct (
    ↑(zset.map πht) (↑²(equi_join prod.snd prod.fst) R1 E) +
    E +
    ↑(zset.map πh) E +
    ↑(zset.map πt) E) := rfl.

noncomputable def closure : Z[Edge Node] → Z[Edge Node] := naive closure1.

noncomputable def closure_seminaive : Z[Edge Node] → Z[Edge Node] :=
  λ E, let E := δ0 E in
  ∫ $ fix (λ R, ↑distinct^Δ
                (↑(zset.map πht) (↑²(equi_join prod.snd prod.fst)^Δ2 (z⁻¹ R) E) +
                E +
                ↑(zset.map πh) E +
                ↑(zset.map πt) E)).

theorem closure_efficient_ok :
  @closure_seminaive Node _ = closure :=
begin
  unfold closure,
  symmetry,
  rw<- seminaive_equiv,
  funext E,
  unfold closure_seminaive seminaive,
  dsimp,
  congr' 2,
  funext R1,
  conv_lhs {
    simp [incremental2], rw lifting_closure1_eq, skip,
  },
  simp,
  rw D_push, congr' 1,
  repeat { rw derivative_linear }, simp,
  rw D_push, simp,
  rw incremental2_unfold,
end

noncomputable def incremental_closure : operator (Z[Edge Node]) (Z[Edge Node]) :=
  incremental (λ dE,
    let E := ↑δ0 dE in
    ↑∫ $ fix2 (λ R, ↑((↑distinct)^Δ)
                  (↑(↑(zset.map πht))
                    (↑²(↑²(equi_join prod.snd prod.fst)^Δ2) (↑z⁻¹ R) E) +
                  E +
                  ↑(↑(zset.map πh)) E +
                  ↑(↑(zset.map πt)) E))).

local attribute [simp] sum_causal causal_comp_causal.

theorem incremental_closure_ok :
  @incremental_closure Node _ = (↑closure)^Δ :=
begin
  funext EΔ,
  unfold incremental_closure, unfold incremental, dsimp,
  rw<- closure_efficient_ok,
  generalize heq : I EΔ = E, clear_dependent EΔ,
  congr' 1,
  change (↑closure_seminaive E) with
    (↑∫ $ ↑(λ E, fix (λ R, ↑distinct^Δ
                    (↑(zset.map πht) (↑²(equi_join prod.snd prod.fst)^Δ2 (z⁻¹ R) E) +
                    E +
                    ↑(zset.map πh) E +
                    ↑(zset.map πt) E))) $ ↑δ0 $ E),
  rw lifting_cycle (λ (E R: stream Z[Edge Node]), ↑distinct^Δ (↑(zset.map πht)
          (↑²(equi_join prod.snd prod.fst)^Δ2 R E) +
          E +
          ↑(zset.map πh) E +
          ↑(zset.map πt) E)),
  { simp,
    congr' 2, },
  unfold uncurry_op,
  simp,
end

noncomputable def incremental_closure2 : operator Z[Edge Node] Z[Edge Node] :=
  λ dE,
    let E := ↑δ0 dE in
    (↑∫)^Δ $ fix2 (λ R, ↑((↑distinct)^Δ)^Δ
                  (↑(↑(zset.map πht))
                    (↑²(↑²(equi_join prod.snd prod.fst)^Δ2)^Δ2 (↑z⁻¹ R) E) +
                  E +
                  ↑(↑(zset.map πh)) E +
                  ↑(↑(zset.map πt)) E)).

lemma fix2_congr {a: Type} [add_comm_group a] (F1 F2: operator (stream a) (stream a)) :
  F1 = F2 →
  fix2 F1 = fix2 F2 := by cc.

@[simp]
lemma lifting_map_πht_incremental :
  ↑(↑(zset.map (@πht Node _)))^Δ = ↑(↑(zset.map πht)) :=
begin
  apply lifting_map_incremental,
end

theorem incremental_closure2_ok :
  @incremental_closure2 Node _ = (↑closure)^Δ :=
begin
  rw<- incremental_closure_ok,
  funext dE, simp [incremental_closure, incremental_closure2],
  symmetry,
  rw (incremental_comp (↑∫) _ dE),
  congr' 1,
  rw (cycle2_incremental
    (λ s (R : stream (stream Z[Edge Node])),
              ↑(↑distinct^Δ)
                (↑ ↑(zset.map πht) (↑²(↑²(equi_join prod.snd prod.fst)^Δ2) R (↑δ0 s)) +
                       ↑δ0 s +
                     ↑ ↑(zset.map πh) (↑δ0 s) +
                   ↑ ↑(zset.map πt) (↑δ0 s)))
  ), dsimp,
  apply fix2_congr, funext R,
  rw (incremental2_unfold _ dE),
  rw D_push,
  congr' 1,
  rw derivative_linear,
  rw derivative_linear,
  rw derivative_linear,
  rw D_push, simp,
  rw D_push2, simp,
  rw D_push, simp,
  rw D_push, simp,
  rw D_push, simp,
  rw D_push, simp,
  rw D_push, simp,

  -- need to prove causal_nested
  intros s, dsimp,
  apply causal_nested_comp; simp,
  apply sum_causal_nested; simp,
  apply sum_causal_nested; simp,
  apply sum_causal_nested; simp,
  apply causal_nested_comp, simp,
  apply causal_nested_lifting2; simp,
  { unfold uncurry_op,
    apply causal_lifting2_incremental; simp, },
  { apply causal_nested_id, },
end

def distinct_double_incremental {A: Type} [decidable_eq A] : operator (stream Z[A]) (stream Z[A]) :=
  λ i, D $ ↑²(↑² (@distinct_H A _)) (↑z⁻¹ (↑I (I i))) (I i).

theorem distinct_double_incremental_ok {A: Type} [decidable_eq A] :
  (↑(↑(@distinct A _)^Δ))^Δ =
  distinct_double_incremental :=
begin
  funext s,
  unfold distinct_double_incremental,
  rw distinct_incremental_ok,
  unfold distinct_incremental,
  rw incremental_unfold,
  refl,
end

section equi_join.
variables {A B C: Type}.
variables [decidable_eq A] [decidable_eq B] [decidable_eq C].

variables (π1: A → C) (π2: B → C).

local notation x `▹◃`:40 y := (lifting2 (lifting2 (equi_join x y))).

local attribute [irreducible] lifting2 equi_join.

def join_double_incremental1 : operator2 (stream (Z[A])) (stream Z[B]) (stream Z[A × B]) :=
  λ a b,
      ↑²(↑²(equi_join π1 π2))^Δ2 a b +
      ↑²(↑²(equi_join π1 π2))^Δ2 (↑z⁻¹ $ ↑I $ a) b +
      ↑²(↑²(equi_join π1 π2))^Δ2 a (↑z⁻¹ $ ↑I $ b).

@[simp]
lemma lifting_I_delay_incremental {a: Type} [add_comm_group a] :
  incremental ↑(λ (x: stream a), I (z⁻¹ x)) = ↑(λ x, I (z⁻¹ x)) :=
begin
  apply lti_incremental,
  apply lifting_lti,
  intros s1 s2,
  rw [delay_linear, integral_linear],
end

lemma lifting_I_delay_simplify (s: stream (stream Z[A])) :
  ↑(λ x, I (z⁻¹ x)) s = ↑z⁻¹ (↑I s) :=
begin
  rw<- lifting_comp,
  funext t, simp,
  rw integral_time_invariant,
end

theorem join_double_incremental1_ok :
  ↑²(↑²(equi_join π1 π2)^Δ2)^Δ2 = join_double_incremental1 π1 π2 :=
begin
  unfold join_double_incremental1,
  rw equi_join_incremental, unfold times_incremental,
  funext a b,
  rw lifting2_incremental_sum,
  rw lifting2_incremental_sum,
  simp,
  rw (lifting2_incremental_comp_1 _ (λ (x: stream Z[A]), I (z⁻¹ x))),
  rw (lifting2_incremental_comp_2 _ (λ (y: stream Z[B]), I (z⁻¹ y))),
  simp,
  rw lifting_I_delay_simplify,
  rw lifting_I_delay_simplify,
end

-- this is the fully optimized circuit
def join_double_incremental : operator2 (stream Z[A]) (stream Z[B]) (stream Z[A × B]) :=
  λ a b,
    let join := ↑²(↑²(equi_join π1 π2)) in
    join (z⁻¹ (I a)) (↑z⁻¹ $ ↑I b) +
    join (I $ ↑I $ a) b +
    join (↑I a) (z⁻¹ $ I b) +
    join a (↑z⁻¹ $ I $ ↑I b).

lemma equi_join_lifting2_time_invariant :
  ∀ s1 s2, z⁻¹ (↑²(↑² (equi_join π1 π2)) s1 s2) =
           ↑²(↑² (equi_join π1 π2)) (z⁻¹ s1) (z⁻¹ s2) :=
begin
  intros s1 s2,
  funext n t, simp,
  unfold delay, split_ifs; simp,
end

lemma equi_join_double_lift_bilinear :
  bilinear (↑²(↑² (equi_join π1 π2))) :=
begin
  split; intros,
  { funext n t, simp, rw (equi_join_bilinear _ _).1, },
  { funext n t, simp, rw (equi_join_bilinear _ _).2, },
end

lemma equi_join_I_1 :
  ∀ a b, ↑²(↑² (equi_join π1 π2)) (I a) b =
  ↑²(↑² (equi_join π1 π2)) a b +
  ↑²(↑² (equi_join π1 π2)) (z⁻¹ (I a)) b :=
begin
  intros,
  conv_lhs {
    rw [integral_unfold a],
  },
  rw (equi_join_double_lift_bilinear _ _).1,
end

lemma equi_join_lift_I_1 :
  ∀ a b,
    ↑²(↑² (equi_join π1 π2)) (↑I a) b =
    ↑²(↑² (equi_join π1 π2)) a b +
    ↑²(↑² (equi_join π1 π2)) (↑I (↑z⁻¹ a)) b :=
begin
  intros,
  funext n t, simp,
  conv_lhs {
    rw integral_unfold,
  },
  simp,
  rw (equi_join_bilinear _ _).1,
  rw integral_time_invariant,
end

lemma equi_join_lift_I_2 :
  ∀ a b,
    ↑²(↑² (equi_join π1 π2)) a (↑I b) =
    ↑²(↑² (equi_join π1 π2)) a b +
    ↑²(↑² (equi_join π1 π2)) a (↑I (↑z⁻¹ b)) :=
begin
  intros,
  funext n t, simp,
  conv_lhs {
    rw integral_unfold,
  },
  simp,
  rw (equi_join_bilinear _ _).2,
  rw integral_time_invariant,
end

lemma equi_join_I_2 :
  ∀ a b, ↑²(↑² (equi_join π1 π2)) a (I b) =
  ↑²(↑² (equi_join π1 π2)) a b +
  ↑²(↑² (equi_join π1 π2)) a (z⁻¹ (I b)) :=
begin
  intros,
  conv_lhs {
    rw [integral_unfold b],
  },
  rw (equi_join_double_lift_bilinear _ _).2,
end

lemma equi_join_I_unfold :
  ∀ a b, ↑²(↑² (equi_join π1 π2)) (I a) (I b) =
  ↑²(↑² (equi_join π1 π2)) a b +
  ↑²(↑² (equi_join π1 π2)) a (z⁻¹ (I b)) +
  ↑²(↑² (equi_join π1 π2)) (z⁻¹ (I a)) b +
  ↑²(↑² (equi_join π1 π2)) (z⁻¹ (I a)) (z⁻¹ (I b)) :=
begin
  intros,
  repeat { rw equi_join_I_1 <|> rw equi_join_I_2 },
  abel,
end

private lemma neg_add_sub {α: Type} [add_comm_group α] (x y: α) :
  (-1 : ℤ) • x + y = y - x :=
begin
  abel,
end

private lemma add_both_sides {G} [has_add G] [is_right_cancel_add G] (x: G) {a b: G} :
  a + x = b + x -> a = b :=
begin
  apply add_right_cancel,
end

private lemma fold_join_helper :
  ∀ a b, ((-1 : ℤ) • (π1▹◃π2) (I (z⁻¹ (↑I a))) b + (π1▹◃π2) (I (z⁻¹ (↑I (↑z⁻¹ a)))) b) =
   (-1 : ℤ) • (π1▹◃π2) (I (z⁻¹ a)) b  :=
begin
  intros,
  apply (add_both_sides ((π1▹◃π2) (I (z⁻¹ a)) b)),
  abel,
  rw neg_add_sub,
  rw<- add_sub_assoc,
  rw<- (equi_join_double_lift_bilinear π1 π2).1,
  rw<- integral_linear,
  rw<- delay_linear,
  rw<- (bilinear_sub_1 (equi_join_double_lift_bilinear π1 π2)),
  rw<- (linear_sub integral_linear),
  rw<- (linear_sub delay_linear),
  have hz: a + ↑I (↑z⁻¹ a) - ↑I a = 0 := by {
    have h: ↑I a = a + ↑I (↑z⁻¹ a) := by {
      funext n, simp,
      conv_lhs {
        rw integral_unfold,
      },
      rw integral_time_invariant,
    },
    rw h, abel,
  },
  rw hz, simp,
  funext n t, simp,
end

theorem join_double_incremental_ok :
  ↑²(↑²(equi_join π1 π2)^Δ2)^Δ2 = join_double_incremental π1 π2 :=
  begin
  rw join_double_incremental1_ok,
  unfold join_double_incremental1 join_double_incremental,
  funext a b, simp,
  unfold incremental2,
  unfold D,
  repeat { rw equi_join_lifting2_time_invariant },
  rw equi_join_I_unfold,
  rw equi_join_I_unfold,
  rw equi_join_I_unfold,
  abel,
  repeat { rw<- integral_lift_time_invariant <|>
           rw<- lift_integral_lift_time_invariant <|>
           rw<- integral_time_invariant },
  conv_rhs {
    rw equi_join_I_1 π1 π2 (↑I a) b,
    rw equi_join_I_2 π1 π2 a _,
    rw (equi_join_lift_I_1 π1 π2 a),
    rw (equi_join_lift_I_1 π1 π2 a),
  },
  repeat { rw<- integral_lift_time_invariant <|>
           rw<- lift_integral_lift_time_invariant <|>
           rw<- integral_time_invariant },
  repeat { rw add_assoc },
  apply eq_of_sub_eq_zero,
  abel,
  abel,
  rw fold_join_helper,
  abel,
end

end equi_join.

noncomputable def incremental_closure_opt : operator Z[Edge Node] Z[Edge Node] :=
  λ dE,
    let E := ↑δ0 dE in
    (↑∫)^Δ $ fix2 (λ R, distinct_double_incremental
                  (↑(↑(zset.map πht))
                    (join_double_incremental prod.snd prod.fst (↑z⁻¹ R) E) +
                  E +
                  ↑(↑(zset.map πh)) E +
                  ↑(↑(zset.map πt)) E)).

theorem incremental_closure_opt_ok :
  @incremental_closure_opt Node _ = (↑closure)^Δ :=
begin
  rw<- incremental_closure2_ok,
  unfold incremental_closure_opt incremental_closure2,
  funext dE, dsimp,
  congr' 1,
  congr' 1,
  funext R,
  rw distinct_double_incremental_ok,
  rw join_double_incremental_ok,
end


import category_theory.comma
import category_theory.adjunction.basic
import category_theory.limits.shapes
import category_theory.epi_mono
import category_theory.limits.over
import cartesian_closed
import pullbacks
import comma
import to_mathlib

/-!
# Properties of the over category.

We can interpret the forgetful functor `forget : over B ⥤ C` as dependent sum,
(written `Σ_B`)
and when C has binary products, it has a right adjoint `B*` given by
`A ↦ (π₁ : B × A → B)`, denoted `star` in Lean.

Furthermore, if the original category C has pullbacks and terminal object (i.e.
all finite limits), `B*` has a right adjoint iff `B` is exponentiable in `C`.
This right adjoint is written `Π_B` and is interpreted as dependent product.

Given `f : A ⟶ B` in `C/B`, the iterated slice `(C/B)/f` is isomorphic to
`C/A`.
-/
namespace category_theory
open category limits

universes v u
variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

section adjunction

variable (B : C)
variable [has_binary_products.{v} C]

local attribute [tidy] tactic.case_bash

@[reducible]
def star : C ⥤ over B :=
{ obj := λ A, @over.mk _ _ _ (B ⨯ A) limits.prod.fst,
  map := λ X Y f, over.hom_mk (limits.prod.map (𝟙 _) f) (by simp) }

def forget_adj_star : over.forget ⊣ star B :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ g A,
  { to_fun := λ f, over.hom_mk (prod.lift g.hom f),
    inv_fun := λ k, k.left ≫ limits.prod.snd,
    left_inv := by tidy,
    right_inv := by tidy } }

variables [has_terminal.{v} C] [has_pullbacks.{v} C]

def Pi_obj [exponentiable B] (f : over B) : C := pullback (post B f.hom) (point_at_hom (𝟙 B))

private def pi_obj.equiv [exponentiable B] (X : C) (Y : over B) :
  ((star B).obj X ⟶ Y) ≃ (X ⟶ Pi_obj B Y) :=
{ to_fun := λ f, pullback.lift (exp_transpose.to_fun f.left) (terminal.from _)
    (begin rw ← exp_transpose_natural_right, erw ← exp_transpose_natural_left, tidy end),
  inv_fun := λ g,
    begin
      apply over.hom_mk _ _, apply (exp_transpose.inv_fun (g ≫ pullback.fst)),
      dsimp, apply function.injective_of_left_inverse exp_transpose.left_inv,
      rw exp_transpose_natural_right, rw exp_transpose.right_inv, rw assoc,
      rw pullback.condition, have : g ≫ pullback.snd = terminal.from X,
      apply subsingleton.elim, rw ← assoc, rw this, erw ← exp_transpose_natural_left,
      apply function.injective_of_left_inverse exp_transpose.right_inv,
      rw exp_transpose.left_inv, rw exp_transpose.left_inv, simp
    end,
  left_inv := λ f, begin apply over.over_morphism.ext, simp, rw exp_transpose.left_inv end,
  right_inv := λ g, begin apply pullback.hom_ext, simp, rw exp_transpose.right_inv, apply subsingleton.elim end
  }

private lemma pi_obj.natural_equiv [exponentiable B] (X' X : C) (Y : over B) (f : X' ⟶ X) (g : (star B).obj X ⟶ Y) :
  (pi_obj.equiv B X' Y).to_fun ((star B).map f ≫ g) = f ≫ (pi_obj.equiv B X Y).to_fun g :=
begin
  apply pullback.hom_ext, simp [pi_obj.equiv], rw ← exp_transpose_natural_left,
  apply subsingleton.elim
end

def Pi_functor [exponentiable B] : over B ⥤ C := @adjunction.right_adjoint_of_equiv _ _ _ _ (star B) (Pi_obj B) (pi_obj.equiv B) (pi_obj.natural_equiv B)
def star_adj_pi_of_exponentiable [exponentiable B] : star B ⊣ Pi_functor B := adjunction.adjunction_of_equiv_right _ _
def star_is_left_adj_of_exponentiable [exponentiable B] : is_left_adjoint (star B) := ⟨Pi_functor B, star_adj_pi_of_exponentiable B⟩

def exponentiable_of_star_is_left_adj (h : is_left_adjoint (star B)) : exponentiable B :=
⟨⟨star B ⋙ h.right, adjunction.comp _ _ h.adj (forget_adj_star B)⟩⟩

end adjunction

end category_theory