example : (p → q → False) ↔ (¬ p ∨ ¬ q) := by
  apply Iff.intro
  · intro h
    by_cases hp:p <;> by_cases hq:q
    · specialize h hp hq; contradiction
    · exact Or.inr hq
    · exact Or.inl hp
    · exact Or.inr hq
  · intro
    | Or.inl hnp => intros; contradiction
    | Or.inr hnq => intros; contradiction


import data.set.lattice tactic.find tactic.tidy tactic.ring
universe u

-- We implement first order predicate logic.

namespace logic
open list tactic set

-- The type of signatures, which defines a first-order language,
-- possibly with extra modalities, and with room for defining your
-- own preferred variable type.
@[derive inhabited]
structure signature : Type (u+1) :=
    (functional_symbol : Type u := pempty)
    (relational_symbol : Type u := pempty)
    (modality : Type u := pempty)
    (vars : Type u := ulift ℕ)
    (dec_vars : decidable_eq vars . apply_instance)
    (arity : functional_symbol → ℕ := λ_, 0)
    (rarity : relational_symbol → ℕ := λ_, 0)
    (marity : modality → ℕ := λ_, 0)

-- A pseudo-predicate saying that the we can decide the equality
-- between any symbols of the signature.
-- Many definitions of proof theory need us to decide whether
-- 2 symbols are equal, but many also do not, which justifies us
-- keeping this as a separate structure.
class signature.symbolic (σ : signature) :=
    (dec_fun : decidable_eq σ.functional_symbol)
    (dec_rel : decidable_eq σ.relational_symbol)
    (dec_mod : decidable_eq σ.modality)

-- decidable_eq instances that we get to infer from a
-- (symbolic) signature.
instance dec_vars  (σ : signature) : decidable_eq σ.vars := σ.dec_vars
instance dec_fun (σ : signature) [h : σ.symbolic] : decidable_eq σ.functional_symbol := h.dec_fun
instance dec_rel (σ : signature) [h : σ.symbolic] : decidable_eq σ.relational_symbol := h.dec_rel
instance dec_mod (σ : signature) [h : σ.symbolic] : decidable_eq σ.modality := h.dec_mod

-- The signature whose formulas are propositional formulas built up
-- from taking the instances of type α as propositional variables.
def propositional_signature (α : Type u := ulift ℕ) : signature :=
{
  relational_symbol := α,
  vars := pempty,
  dec_vars := by apply_instance,
}

-- here we start with the syntactical definitions
variable {σ : signature}

-- arity types

-- the type of functional symbols of arity n
def signature.nary (σ : signature) (n : ℕ) := subtype {f : σ.functional_symbol | σ.arity f = n}

-- the type of relational symbols of arity n
def signature.nrary (σ : signature) (n : ℕ) := subtype {r : σ.relational_symbol | σ.rarity r = n}

-- the predicate defining, and the type of, constants
def is_constant (f : σ.functional_symbol) := σ.arity f = 0
def signature.const (σ : signature) := σ.nary 0

-- terms in the language
inductive signature.term (σ : signature)
| var : σ.vars → signature.term
| app  {n : ℕ} (f : σ.nary n) (v : fin n → signature.term) :  signature.term

-- constant terms. A function that lifts a constant to a term.
def signature.cterm (σ : signature) : σ.const → σ.term
| c := term.app c fin_zero_elim

-- Rewrite a variable for a term in a term.
-- This is also called a substitution of a variable for a term.
def signature.term.rw : σ.term → σ.vars → σ.term → σ.term
| (term.var a) x t := if x = a then t else term.var a
| (term.app f v) x t :=
    let v₂ := λ m, signature.term.rw (v m) x t in
    term.app f v₂

-- Get the set of variables of a term.
def signature.term.vars  : σ.term → set σ.vars
| (term.var a) := {a}
| (term.app f v) :=
    let v₂ := λ m, signature.term.vars (v m) in
    ⋃ m, v₂ m

-- denotative and non-denotative terms.
@[reducible]
def signature.term.denotes (t : σ.term) : Prop := t.vars = (∅ : set σ.vars)
@[reducible]
def signature.term.conotes (t : σ.term) := ¬ t.denotes

-- a closed term is a Herbrand term.
def signature.hterm (σ : signature) := subtype {t : σ.term | t.denotes}

-- an open term is an expression.
def signature.expression (σ : signature) := subtype {t : σ.term | t.conotes}

-- some lemmas about term rewriting:

theorem rw_eq_of_not_in_vars : ∀ (t₁ t₂ : σ.term) (x : σ.vars), x ∉ t₁.vars → t₁.rw x t₂ = t₁ :=
begin
    intros t₁ t₂ x,
    induction t₁;
    dunfold signature.term.vars signature.term.rw;
    simp;
    intro h,
        simp[h],
    ext y,
    specialize h y,
    exact t₁_ih y h,
end

theorem trivial_rw : ∀ (t: σ.term) (x), t.rw x (term.var x) = t :=
begin
    intros t x,
    induction t;
    dunfold signature.term.rw,
        by_cases x = t;
        simp [h],
    simp at *,
    ext y,
    exact t_ih y,
end

theorem den_rw : ∀ (t₁ t₂ : σ.term) (x : σ.vars), t₁.denotes → t₁.rw x t₂ = t₁ :=
begin
    intros t₁ t₂ x den₁,
    induction t₁,
    -- case var
        replace den₁ : (term.var t₁).vars = ∅ := den₁,
        replace den₁ : {t₁} = ∅ := den₁,
        replace den₁ := eq_empty_iff_forall_not_mem.mp den₁,
        specialize den₁ t₁,
        simp at den₁,
        contradiction,
    -- case app
        replace den₁ : (term.app t₁_f t₁_v).vars = ∅ := den₁,
        let v₂ := λ m, (t₁_v m).vars,
        replace den₁ : (⋃ m, v₂ m) = ∅ := den₁,
        have c₀ : ∀ m, (v₂ m) = ∅,
            intro m,
            ext, constructor, intro h,
                simp,
                have c : x_1 ∈ (⋃ m, v₂ m),
                    simp,
                    existsi m,
                    exact h,
                rwa den₁ at c,
            intro insanity,
            simp at insanity,
            contradiction,
        have c₁ : ∀ m, (t₁_v m).denotes := c₀,
        have c₂ : ∀ m, (t₁_v m).rw x t₂ = (t₁_v m),
            intro m,
            exact t₁_ih m (c₁ m),
        dunfold signature.term.rw,
        simp[c₂],
end

-- Some auxiliary functions about terms (mostly unused):

-- subterms of a term.
def signature.term.subterms : σ.term → set σ.term
| (term.app f v) :=
    let v₂ := λ m, signature.term.subterms (v m) in
    (⋃ m, v₂ m) ∪ {(term.app f v)}
| t := {t}

-- set of all variables appearing in a list of terms.
def list.vars : list σ.term → set σ.vars
| [] := ∅
| (hd :: tl) := hd.vars ∪ tl.vars

-- subterms of a list of terms.
def list.subterms : list σ.term → set σ.term
| [] := ∅
| (hd :: tl) := hd.subterms ∪ tl.subterms

-- the same for sets.
def subterms : set σ.term → set σ.term
| S := ⋃ x ∈ S, signature.term.subterms x

-- rewrite a variable in a list of terms.
def list.rw : list σ.term → σ.vars → σ.term → list σ.term
| [] _ _:= ∅
| (hd :: tl) x t := (hd.rw x t) :: tl.rw x t

--  the type of formulas in the language
inductive  signature.formula (σ : signature)
| relational {n : ℕ} (r : σ.nrary n) (v : fin n → σ.term) :  signature.formula
| for_all :  σ.vars →  signature.formula →  signature.formula
| if_then :  signature.formula →  signature.formula →  signature.formula
| equation (t₁ t₂ : σ.term) :  signature.formula
| false :  signature.formula

-- a convenient notation to set up for if_then
reserve infixr ` ⇒ `:55
class has_exp (α : Type u) := (exp : α → α → α)
infixr ⇒ := has_exp.exp

instance  signature.formula.has_exp : has_exp  σ.formula := ⟨signature.formula.if_then⟩

-- definition of connectives
def  signature.formula.not (φ :  σ.formula)   := φ ⇒  signature.formula.false
def  signature.formula.or  (φ ψ :  σ.formula) := φ.not ⇒ ψ
def  signature.formula.and (φ ψ :  σ.formula) := (φ.not.or ψ.not).not
def  signature.formula.iff (φ ψ :  σ.formula) := (φ ⇒ ψ).and (ψ ⇒ φ)
def  signature.formula.exists (φ : σ.formula) (x : σ.vars) := (signature.formula.for_all x φ.not).not

-- Rewrite (substitute) a variable for a term in a formula.
def  signature.formula.rw :  σ.formula → σ.vars → σ.term →  σ.formula
| ( signature.formula.relational r v) x t :=
    let v₂ := λ m, (v m).rw x t in
     signature.formula.relational r v₂
| ( signature.formula.for_all y φ) x t :=
    let ψ := if y = x then φ else φ.rw x t in
     signature.formula.for_all y ψ
| ( signature.formula.if_then φ ψ) x t := (φ.rw x t) ⇒ (ψ.rw x t)
| ( signature.formula.equation t₁ t₂) x t :=  signature.formula.equation (t₁.rw x t) (t₂.rw x t)
| φ _ _ := φ

-- free variables
def  signature.formula.free :  σ.formula → set σ.vars
| ( signature.formula.relational r v) := ⋃ m, (v m).vars
| ( signature.formula.for_all x φ) := φ.free - {x}
| ( signature.formula.if_then φ ψ) := φ.free ∪ ψ.free
| ( signature.formula.equation t₁ t₂) := t₁.vars ∪ t₂.vars
|  signature.formula.false := ∅

-- definition of whether a variable is
-- substitutable for a term in a formula.
-- Needed for proving some lemmas.
def  signature.formula.substitutable  :  σ.formula → σ.vars → σ.term → Prop
| ( signature.formula.for_all y φ) x t := x ∉ ( signature.formula.for_all y φ).free ∨
                                         (y ∉ t.vars ∧ φ.substitutable x t)
| ( signature.formula.if_then φ ψ) y t := φ.substitutable y t ∧ ψ.substitutable y t
| _ _ _ := true

-- open and closed  σ.formulas.
def  signature.formula.closed :  σ.formula → Prop
| φ := φ.free = ∅

def  signature.formula.open :  σ.formula → Prop
| φ := ¬ φ.closed

-- atomic and molecular formulas
def signature.formula.atomic :  σ.formula → bool
| (formula.relational r v) := tt
| (formula.equation t₁ t₂) := tt
| formula.false := tt
| _ := ff

def signature.formula.molecular : σ.formula → bool
| (formula.for_all x φ) := ff
| (formula.if_then φ ψ) := φ.molecular && ψ.molecular
| _ := tt

-- utility for propositional logic
def signature.proposition (σ : signature) := subtype {φ : σ.formula | φ.molecular}

-- variables present in a formula
def  signature.formula.vars :  σ.formula → set σ.vars
| ( signature.formula.for_all x φ) := φ.free ∪ {x}
| ( signature.formula.if_then φ ψ) := φ.vars ∪ ψ.vars
| φ := φ.free

-- terms present in a formula
def  signature.formula.terms :  σ.formula → set σ.term
| ( signature.formula.relational r v) := list.subterms (of_fn v)
| ( signature.formula.for_all x φ) := φ.terms ∪ {term.var x}
| ( signature.formula.if_then φ ψ) := φ.terms ∪ ψ.terms
| _ := ∅

-- tells wether a term is present in a set of formulas.
-- The name comes from the universal introduction rule,
-- where we prove that a formula is valid for an "abstract"
-- representative and conclude it is universally valid.
def term.abstract_in : σ.term → set  σ.formula → Prop
| t S := t ∉ (⋃ φ ∈ S,  signature.formula.terms φ)

-- the same for variables.
def abstract_in : σ.vars → set  σ.formula → Prop
| x S := x ∉ (⋃ φ ∈ S,  signature.formula.free φ)

-- construct the generalization of a  σ.formula from a list of variables.
-- This is just a fold but, I like being explicit about my folds when possible.
-- Anyway, this ended up not being used so far.
def  signature.formula.generalize :  σ.formula → list σ.vars →  σ.formula
| φ [] := φ
| φ (x::xs) :=  signature.formula.for_all x $ φ.generalize xs

-- lemmas about rewriting in formulas:
theorem formula_rw : ∀ {φ :  σ.formula} {x : σ.vars}, x ∉ φ.free → ∀(t : σ.term),φ.rw x t = φ :=
    begin
        intros φ x h t,
        revert h,
        induction φ;
        dunfold  signature.formula.free  signature.formula.rw;
        simp;
        intro h,
            ext y,
            specialize h y,
            revert h,
            induction φ_v y;
            dunfold signature.term.rw signature.term.vars;
            intro h;
            simp at *,
                simp[h],
            ext z,
            specialize h z,
            specialize ih z,
            exact ih h,
        classical,
        by_cases eq₁ : x ∈ φ_a_1.free,
            simp [h eq₁],
        by_cases eq₂ : φ_a = x;
            simp [eq₂],
        exact φ_ih eq₁,
        all_goals{
            push_neg at h,
            obtain ⟨h₁, h₂⟩ := h,
        },
            replace h₁ := φ_ih_a h₁,
            replace h₂ := φ_ih_a_1 h₂,
            rw [h₁, h₂],
            refl,
        constructor;
        apply rw_eq_of_not_in_vars;
        assumption,
    end

lemma trivial_formula_rw : ∀ {φ: σ.formula} {x}, φ.rw x (term.var x) = φ :=
    begin
        intros φ x,
        induction φ;
        dunfold  signature.formula.rw;
        try{simp},
            ext,
            induction (φ_v x_1);
            dunfold signature.term.rw,
            by_cases x = a;
                simp [h],
            simp,
            ext,
            exact ih x_2,
        rw φ_ih,
        simp,
            simp [φ_ih_a, φ_ih_a_1],
            refl,
        constructor;
        apply trivial_rw;
        assumption,
    end

-- deductive consequence of formulas: Γ ⊢ φ.
-- Type of proofs from Γ to φ.
-- The universe var here has been automatically generated,
inductive proof : set  σ.formula →  σ.formula → Type u_1
| reflexivity (Γ : set  σ.formula) (φ :  σ.formula)(h : φ ∈ Γ) : proof Γ φ
| transitivity (Γ Δ : set  σ.formula) (φ :  σ.formula)
               (h₁ : ∀ ψ ∈ Δ, proof Γ ψ)
               (h₂ : proof Δ φ) :  proof Γ φ
| modus_ponens
            (φ ψ :  σ.formula) (Γ : set  σ.formula)
            (h₁ : proof Γ (φ ⇒ ψ))
            (h₂ : proof Γ φ)
             : proof Γ ψ
| intro
            (φ ψ :  σ.formula) (Γ : set  σ.formula)
            (h : proof (Γ ∪ {φ}) ψ)
             : proof Γ (φ ⇒ ψ)
| for_all_intro
            (Γ : set  σ.formula) (φ :  σ.formula)
            (x : σ.vars) (xf : x ∈ φ.free)
            (abs : abstract_in x Γ)
            (h : proof Γ φ)
             : proof Γ ( signature.formula.for_all x φ)
| for_all_elim
            (Γ : set  σ.formula) (φ :  σ.formula)
            (x : σ.vars) --(xf : x ∈ φ.free)
            (t : σ.term) (sub : φ.substitutable x t)
            (h : proof Γ ( signature.formula.for_all x φ))
             : proof Γ (φ.rw x t)
| exfalso (Γ : set  σ.formula) (φ :  σ.formula)
          (h : proof Γ  signature.formula.false)
          : proof Γ φ
| by_contradiction (Γ : set  σ.formula) (φ :  σ.formula)
                   (h : proof Γ φ.not.not)
                   : proof Γ φ
| identity_intro
            (Γ : set  σ.formula) (t : σ.term)
             : proof Γ ( signature.formula.equation t t)
| identity_elim
            (Γ : set  σ.formula) (φ :  σ.formula)
            (x : σ.vars) (xf : x ∈ φ.free)
            (t₁ t₂: σ.term)
            (sub₁ : φ.substitutable x t₁)
            (sub₂ : φ.substitutable x t₂)
            (h : proof Γ (φ.rw x t₁))
            (eq : proof Γ ( signature.formula.equation t₁ t₂))
             : proof Γ (φ.rw x t₂)

local infixr `⊢`:55 := proof

-- Some simple (meta-)theorems:

variables (Γ Δ : set  σ.formula) (φ :  σ.formula)

theorem self_entailment : Γ ⊢ (φ ⇒ φ) :=
begin
    apply proof.intro,
    apply proof.reflexivity (Γ∪{φ}) φ,
    simp
end

theorem monotonicity : Δ ⊆ Γ → Δ ⊢ φ → Γ ⊢ φ :=
begin
    intros H h,
    have c₁ : ∀ ψ ∈ Δ, proof Γ ψ,
        intros ψ hψ,
        apply proof.reflexivity Γ ψ,
        exact H hψ,
    apply proof.transitivity;
    assumption,
end

-- The following commented code chunks are unfinished attempts
-- to prove that proofs are finite (they can be safely ignored):

-- This one depends on syntatical equality between σ.formulas
-- being decidable, which in turn depends on the equality of
-- functional and relational symbols being decidable
-- (i.e. σ must be "symbolic"). We will probably move this
-- to another module to deal with "symbolic" signatures later.

-- extracts the premisses (∈ Γ) use to prove φ from Γ.
-- def proof.premisses : Γ ⊢ φ → list (subtype Γ) :=
--     begin
--         intros h,
--         induction h,
--         -- case reflexivity
--         exact [⟨h_φ, h_h⟩],
--         -- case transitivity
--         rename h_ih_h₁ ih₁,
--         induction h_ih_h₂,
--             exact [],
--         obtain ⟨ψ, H⟩ := h_ih_h₂_hd,
--         specialize ih₁ ψ H,
--         exact ih₁ ++ h_ih_h₂_ih,
--         -- case modus ponens
--         exact h_ih_h₁ ++ h_ih_h₂,
--         -- case intro
--         set t : set  σ.formula := h_Γ ∪ {h_φ},
--         have ct : h_φ ∈ t, simp,
--         let c : subtype t := ⟨h_φ, ct⟩,
--         all_goals{admit},
--     end

-- This here are earlier attempts to squash proof trees either as lists
-- or finsets.

-- open finset

-- local notation `{` x `}ₙ` := finset.singleton x

-- #find ∀ _ ∈ _, ∃ _, _

-- def list.to_set : list  σ.formula → set  σ.formula
-- | [] := ∅
-- | (φ::xs) := {φ} ∪ xs.to_set

-- def proof : list  σ.formula → Prop
-- | [] := false
-- | (ψ::[]) := ψ ∈ Γ ∨ ∅ ⊢ ψ
-- | (ψ::xs) := (ψ ∈ Γ ∨ list.to_set xs ⊢ ψ) ∧
--              proof xs

-- def proof_of (φ) : list  σ.formula → Prop
-- | [] := false
-- | (ψ::xs) := ψ = φ ∧ proof Γ (ψ::xs)

-- theorem finite_proofs :  Γ ⊢ φ → ∃ xs : list  σ.formula, proof_of Γ φ xs :=
-- begin
--     intro h,
--     induction h,
--     -- case reflexivity
--     let xs := [h_φ],
--     use xs,
--     simp [xs, proof_of,proof],
--     left,
--     assumption,
--     -- case transitivity
--     rename h_ih_h₁ ih,
--     obtain ⟨p, hp⟩ := h_ih_h₂,
--     -- let xs : list  σ.formula,
--     --     cases p;
--     --         simp[proof_of] at hp,
--     --         contradiction,
--     --     obtain ⟨hp₁, hp₂⟩ := hp,
--     --     revert hp₂,
--     admit,
--     -- case modus ponens
-- end

-- theorem finite_proofs :  Γ ⊢ φ → ∃ Δ : finset  σ.formula, ↑Δ ⊆ Γ ∧ ↑Δ ⊢ φ :=
-- begin
--     intro h,
--     induction h,
--     -- case reflexivity
--     existsi finset.singleton h_φ,
--     simp [proof.reflexivity],
--     assumption,
--     -- case transitivity
--     obtain ⟨Δ, HΔ, hΔ⟩ := h_ih_h₂,
--     -- have c : ∀ ψ ∈ Δ, ∃ (Δ₂ : finset  σ.formula), ↑Δ₂ ⊆ h_Γ ∧ proof ↑Δ₂ ψ,
--     --     intros ψ Hψ,
--     --     exact h_ih_h₁ ψ (HΔ Hψ),
--     -- have c := λ ψ ∈ Δ, classical.subtype_of_exists (h_ih_h₁ ψ (HΔ _)),
--     -- have c₂ : ⋃ ψ ∈ Δ, classical.some (h_ih_h₁ ψ (HΔ _)),
--     -- have d : ∀ {α}

--     -- induction Δ using finset.induction,
--     --     admit,
--     --     use ∅,
--     --     simp,
--     --     exact hΔ,

--     -- classical,
--     -- by_cases ne : Δ.nonempty,
--     -- obtain ⟨ψ, Hψ⟩ := ne,

--     -- have ih := h_ih_h₁ ψ H,
--     -- existsi ⋃ ψ ∈ Δ, (c ψ H).val,

-- end

-- Consistency doesn't need to be defined just for theories.
def consistent (Γ : set  σ.formula) := ¬ nonempty (Γ ⊢  signature.formula.false)

-- At any rate we can define it for theories as well.
-- Here is the definition of a theory:
def signature.theory (σ : signature) := subtype {Γ : set  σ.formula | ∀ φ, Γ ⊢ φ → φ ∈ Γ}

def theory.consistent (Γ : σ.theory) := consistent Γ.val

end logic


import Saturn.FinSeq
import Saturn.Vector
import Saturn.Clause
import Saturn.Solverstep
open Nat
open Vector
open FinSeq

/-
The inductive step for adding a new clause when it is not dropped. The new clauses and maps
are defined. All the witnesses for the relations between the old and new clauses are also
constructed.
-/
def prependClause{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
      (rc: ReductionClauses branch focus focusLt clauses) →
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
            ReductionClauses branch focus focusLt (head +: clauses) :=
          fun rc head neg =>
            let headImage := (delete focus focusLt head.coords).vec
            let domN := dom + 1
            let codomN := rc.codom + 1
            let clausesN := head +: clauses
            let restClausesN := headImage +: rc.restClauses
            let forwardVecN := (some zero) +: (rc.forwardVec.map (fun nop => nop.map (. + 1)) )
            let forwardN: (k : Nat) →  k < domN → Option Nat  :=
              fun k  =>
              match k with
              | zero => fun _ => some zero
              | l + 1 =>
                fun w : l + 1 < domN   =>  (rc.forward l (le_of_succ_le_succ w)).map (. + 1)
            have forwardNEq : forwardVecN.coords = forwardN := by
                  apply funext
                  intro j
                  cases j with
                  | zero =>
                    apply funext
                    intro jw
                    rfl
                  | succ i =>
                    apply funext
                    intro jw
                    have tl :forwardVecN.coords (succ i) jw =
                        forwardVecN.coords.tail i (Nat.le_of_succ_le_succ jw) := by rfl
                    rw [tl,
                      tail_commutes (some zero) (rc.forwardVec.map (fun nop => nop.map (. + 1))),
                      map_coords_commute]
            have forwardWitN : (k: Nat) → (w: k < domN) → boundOpt codomN (forwardN k w) :=
              fun k  =>
              match k with
              | zero => fun w =>
                let lem1 : forwardN zero w = some zero := by rfl
                by
                  rw [lem1]
                  apply zero_lt_succ
                  done
              | l + 1 =>
                fun w : l + 1 < domN   =>
                  let lem : forwardN (l + 1) w =
                    (rc.forward l (le_of_succ_le_succ w)).map (. + 1) := by rfl
                  let lem2 := boundOptSucc rc.codom
                            (rc.forward l (le_of_succ_le_succ w))
                            (rc.forwardWit l (le_of_succ_le_succ w))
                  by
                    rw [lem]
                    exact lem2
                    done
            let reverseVecN := zero +: (rc.reverseVec.map (. + 1))
            let reverseN : (k : Nat) →  k < codomN → Nat :=
              fun k =>
              match k with
              | zero => fun _ => zero
              | l + 1 => fun w => (rc.reverse l (Nat.le_of_succ_le_succ w)) + 1
            have reverseNEq : reverseVecN.coords = reverseN := by
                  apply funext
                  intro j
                  cases j with
                  | zero =>
                    apply funext
                    intro jw
                    rfl
                  | succ i =>
                    apply funext
                    intro jw
                    have tl :reverseVecN.coords (succ i) jw =
                        reverseVecN.coords.tail i (Nat.le_of_succ_le_succ jw) := by rfl
                    rw [tl,
                       tail_commutes zero (rc.reverseVec.map (. + 1)),
                        map_coords_commute]
            have reverseWitN : (k : Nat) → (w : k < codomN) → reverseN k w < domN :=
              fun k =>
              match k with
              | zero => fun _ => zero_lt_succ _
              | l + 1 => fun w => by
                  apply succ_le_succ
                  exact rc.reverseWit l (le_of_succ_le_succ w)
                  done
            ReductionClauses.mk codomN restClausesN
                    forwardVecN
                    (forwardNEq ▸ forwardWitN)
                    reverseVecN
                    (reverseNEq ▸ reverseWitN)

theorem none_mapsto_none{α β : Type}(fn: α → β): (x: Option α) → (x.map fn = none) → x = none
  | none, rfl => by rfl

theorem map_plusone_not_somezero{n: Option Nat} : Not (n.map (. + 1) = some zero) :=
  match n with
  | none => fun hyp =>
    Option.noConfusion hyp
  | some j =>
    fun hyp : some (j + 1) = some zero =>
    let lem : j + 1 = zero := by
      injection hyp
      assumption
    Nat.noConfusion lem

theorem map_plusone_pred{n : Option Nat}{m : Nat} : n.map (. + 1) = some (m + 1) →
  n = some m :=
    match n with
  | none => fun hyp =>
    Option.noConfusion hyp
  | some j =>
    fun hyp : some (j + 1) = some (m + 1) =>
      let lem1 : j + 1 = m + 1 := by
        injection hyp
        assumption
      let lem2 : j = m := by
        injection lem1
        assumption
    congrArg some lem2

namespace PrependClause

theorem forwardResolve{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
      (rc: ReductionClauses branch focus focusLt clauses) →
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
        (l: Nat) → (w : l + 1 < dom + 1) →
          (prependClause  branch focus focusLt clauses rc head neg).forward (l + 1) w =
            (rc.forward l (le_of_succ_le_succ w)).map (. + 1) := by
                  intro rc head neg l w
                  let rcN := prependClause  branch focus focusLt clauses rc head neg
                  have res1 : rcN.forward (l + 1) w =
                      rcN.forwardVec.coords (l + 1) w := by rfl
                  have res2 : rc.forward l (le_of_succ_le_succ w) =
                      rc.forwardVec.coords l (le_of_succ_le_succ w) := by rfl
                  rw [res1]
                  rw [res2]
                  have res3 :rcN.forwardVec =
                    (some zero) +: (rc.forwardVec.map (fun nop => nop.map (. + 1)) )
                      := by rfl
                  rw [res3]
                  have res4 :
                      ((some zero) +:
                        (rc.forwardVec.map (fun nop => nop.map (. + 1)) )).coords
                          (l + 1) w =
                      (
                        ((some zero) +:
                        (rc.forwardVec.map (fun nop => nop.map (. + 1)) )).coords.tail
                      ) l (Nat.le_of_succ_le_succ w) := by rfl
                  rw [res4]
                  rw [(tail_commutes
                      (some zero) (rc.forwardVec.map (fun nop => nop.map (. + 1)) ))]
                  rw [map_coords_commute]

def droppedProof{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
      (rc: ReductionClauses branch focus focusLt clauses) →
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
          DroppedProof rc →
          DroppedProof (prependClause  branch focus focusLt clauses rc head neg) :=
          fun rc head neg drc =>
            let rcN := prependClause  branch focus focusLt clauses rc head neg
            let domN := dom + 1
            let codomN := rc.codom + 1
            let clausesN := head +: clauses
            let droppedN :
              (k : Nat) → (w: k < domN) → rcN.forward k w = none →
                  (clausesN.coords k w).coords focus focusLt = some branch :=
                by
                intro k
                  match k with
                  | zero =>
                    intro w wf
                    exact Option.noConfusion wf
                  | l + 1 =>
                    intro w nw
                    have clres: clausesN.coords (l + 1) w =
                        clauses.coords l (le_of_succ_le_succ w) := by rfl
                    rw [clres]
                    have prev := drc.dropped l (le_of_succ_le_succ w)
                    apply prev
                    rw [forwardResolve] at nw
                    apply none_mapsto_none (. + 1)
                    exact nw
            ⟨droppedN⟩

def forwardRelation{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
      (rc: ReductionClauses branch focus focusLt clauses) →
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
          ForwardRelation rc →
          ForwardRelation (prependClause  branch focus focusLt clauses rc head neg) :=
        fun rc head neg frc =>
          let rcN := prependClause  branch focus focusLt clauses rc head neg
          let domN := dom + 1
          let codomN := rc.codom + 1
          let clausesN := head +: clauses
          have forwardRelationN : (k : Nat) → (w: k < domN) → (j: Nat) →  rcN.forward k w = some j →
              (jw : j < codomN) →  delete focus focusLt ((clausesN.coords k w).coords) =
                (rcN.restClauses.coords j jw).coords := by
                intro k
                match k with
                | zero =>
                    intro w j sw
                    let lem1 : rcN.forward zero w = some zero := by rfl
                    let lem2 : some j = some zero := Eq.trans (Eq.symm sw) lem1
                    let lem3 : j = zero := by
                      injection lem2
                      assumption
                    rw [lem3]
                    intro jw
                    have hl1 : clausesN.coords zero w = head := by rfl
                    rw [hl1]
                    have hl2 : rcN.restClauses.coords zero jw =
                         (delete focus focusLt (head.coords)).vec := by rfl
                    rw [hl2]
                    apply Eq.symm
                    apply seq_to_vec_coords
                | l + 1 =>
                    intro w
                    match c:rcN.forward (l + 1) w with
                    | none =>
                      intro j sw jw
                      exact Option.noConfusion sw
                    | some zero =>
                      rw [forwardResolve] at c
                      let contra:= map_plusone_not_somezero c
                      exact False.elim contra
                    | some (j + 1) =>
                      intro j1 eq1
                      have eq2 : j + 1 = j1 := by
                        injection eq1
                        assumption
                      rw [← eq2]
                      intro jw
                      have clres: clausesN.coords (l + 1) w =
                        clauses.coords l (le_of_succ_le_succ w) := by rfl
                      rw [clres]
                      rw [forwardResolve] at c
                      let cc:= map_plusone_pred c
                      have prev :=
                          frc.forwardRelation l (le_of_succ_le_succ w) j cc
                            (le_of_succ_le_succ jw)
                      rw [prev]
                      rfl
          ⟨forwardRelationN⟩

theorem reverseResolve{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
      (rc: ReductionClauses branch focus focusLt clauses) →
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
        (l: Nat) → (w : l + 1 < rc.codom + 1) →
          (prependClause  branch focus focusLt clauses rc head neg).reverse (l + 1) w =
            (rc.reverse l (le_of_succ_le_succ w)) + 1 := by
            intro rc head neg l w
            let rcN := prependClause  branch focus focusLt clauses rc head neg
            have res1 : rcN.reverse (l + 1) w =
                                      rcN.reverseVec.coords (l + 1) w := by rfl
            have res2 : rc.reverse l (le_of_succ_le_succ w) =
                    rc.reverseVec.coords l (le_of_succ_le_succ w) := by rfl
            rw [res1]
            rw [res2]
            have res3 :rcN.reverseVec =
              zero +: (rc.reverseVec.map (. + 1)) := by rfl
            rw [res3]
            have res4 :
                (zero +:
                  (rc.reverseVec.map (. + 1)) ).coords (l + 1) w =
                  (zero +:
                  (rc.reverseVec.map (. + 1)) ).coords.tail
                  l (Nat.le_of_succ_le_succ w) := by rfl
            rw [res4]
            rw [(tail_commutes
                zero (rc.reverseVec.map (. + 1)))]
            rw [map_coords_commute]

def reverseRelation{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
      (rc: ReductionClauses branch focus focusLt clauses) →
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
          ReverseRelation rc →
          ReverseRelation (prependClause  branch focus focusLt clauses rc head neg) :=
        fun rc head pos rrc =>
          let rcN := prependClause  branch focus focusLt clauses rc head pos
          let domN := dom + 1
          let codomN := rcN.codom
          let clausesN := head +: clauses
          have relationN : (k : Nat) → (w: k < codomN) →
                 (rcN.restClauses.coords k w).coords =
                  delete focus focusLt
                      (clausesN.coords (rcN.reverse k w) (rcN.reverseWit k w)).coords :=
                    by
                    intro k
                    match k with
                    | zero =>
                      intro w
                      have resRHS : rcN.restClauses.coords zero w
                                = (delete focus focusLt head.coords).vec := by rfl
                      rw [resRHS]
                      rw [seq_to_vec_coords]
                      rfl
                    | l + 1 =>
                      intro w
                      let lem1 : rcN.restClauses.coords (l + 1) w =
                              rc.restClauses.coords l (le_of_succ_le_succ w) := by rfl
                      let lem2 := rrc.relation l (le_of_succ_le_succ w)
                      rw [lem1]
                      rw [lem2]
                      have rs0 : clausesN.coords (rcN.reverse (l + 1) w)
                                (rcN.reverseWit (l + 1) w) =
                                  clausesN.coords
                                    (rc.reverse l (Nat.le_of_succ_le_succ w) + 1)
                                    (succ_le_succ
                                      (rc.reverseWit l (Nat.le_of_succ_le_succ w))) := by
                                    apply witness_independent
                                    apply reverseResolve
                      rw [rs0]
                      rfl
          ⟨relationN⟩

def pureReverse{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
      (rc: ReductionClauses branch focus focusLt clauses) →
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
          NonPosReverse rc →
          NonPosReverse (prependClause  branch focus focusLt clauses rc head neg) :=
        fun rc head neg prc =>
          let rcN := prependClause  branch focus focusLt clauses rc head neg
          let domN := dom + 1
          let codomN := rc.codom + 1
          let clausesN := head +: clauses
          have pureN : (k : Nat) → (w: k < codomN)  →
                Not (
                  (clausesN.coords (rcN.reverse k w) (rcN.reverseWit k w)).coords
                    (focus) focusLt = some branch) := by
                intro k
                match k with
                | zero =>
                      intro w hyp
                      apply neg
                      let lem :
                         (clausesN.coords (rcN.reverse zero w) (rcN.reverseWit zero w)).coords
                          focus focusLt = head.coords focus focusLt := by rfl
                      rw [← lem]
                      exact hyp
                | l + 1 =>
                    intro w hyp
                    have rs0 : clausesN.coords (rcN.reverse (l + 1) w)
                                (rcN.reverseWit (l + 1) w) =
                                  clausesN.coords
                                    (rc.reverse l (Nat.le_of_succ_le_succ w) + 1)
                                    (succ_le_succ
                                      (rc.reverseWit l (Nat.le_of_succ_le_succ w))) := by
                                    apply witness_independent
                                    apply reverseResolve
                    rw [rs0] at hyp
                    have rs1 : clausesN.coords
                                    (rc.reverse l (Nat.le_of_succ_le_succ w) + 1)
                                    (succ_le_succ
                                      (rc.reverseWit l (Nat.le_of_succ_le_succ w))) =
                                        clauses.coords (rc.reverse l (Nat.le_of_succ_le_succ w))
                                        (rc.reverseWit l (Nat.le_of_succ_le_succ w)) := by rfl
                    rw [rs1] at hyp
                    let prev := prc.nonPosRev l (Nat.le_of_succ_le_succ w)
                    exact absurd hyp prev
          ⟨pureN⟩

def prependResData{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
        (head : Clause (n + 1)) → (neg : Not (head.coords focus focusLt = some branch)) →
        (rd : ReductionData branch focus focusLt clauses) →
        ReductionData branch focus focusLt (head +: clauses) :=
          fun head neg rd =>
          let rc := prependClause branch focus focusLt clauses rd.restrictionClauses head neg
          ⟨rc,
          droppedProof branch focus focusLt clauses rd.restrictionClauses head neg rd.droppedProof,
          forwardRelation branch focus focusLt clauses rd.restrictionClauses head neg rd.forwardRelation,
          reverseRelation branch focus focusLt clauses rd.restrictionClauses head neg rd.reverseRelation,
          pureReverse branch focus focusLt clauses rd.restrictionClauses head neg rd.nonPosReverse⟩

end PrependClause


lemma add_right_comm (a b c : mynat) : a + b + c = a + c + b :=
begin
induction c with d hd,
rw add_zero,
rw add_zero,
refl,
rw add_succ (a + b),
rw add_succ a,
rw succ_add (a + d),
rw hd,
refl,
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 Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.PostPort

universes v u₁ u₂ l u₃

namespace Mathlib

namespace category_theory

/--
Define the lift of a cone: For a cone `c` for `K ⋙ F`, give a cone for `K`
which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of limits:
every limit cone has a lift.

Note this definition is really only useful when `c` is a limit already.
-/
structure liftable_cone {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cone (K ⋙ F))
    where
  lifted_cone : limits.cone K
  valid_lift : functor.map_cone F lifted_cone ≅ c

/--
Define the lift of a cocone: For a cocone `c` for `K ⋙ F`, give a cocone for
`K` which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of colimits:
every limit cocone has a lift.

Note this definition is really only useful when `c` is a colimit already.
-/
structure liftable_cocone {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cocone (K ⋙ F))
    where
  lifted_cocone : limits.cocone K
  valid_lift : functor.map_cocone F lifted_cocone ≅ c

/--
Definition 3.3.1 of [Riehl].
We say that `F` creates limits of `K` if, given any limit cone `c` for `K ⋙ F`
(i.e. below) we can lift it to a cone "above", and further that `F` reflects
limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D)
    extends limits.reflects_limit K F where
  lifts : (c : limits.cone (K ⋙ F)) → limits.is_limit c → liftable_cone K F c

/--
`F` creates limits of shape `J` if `F` creates the limit of any diagram
`K : J ⥤ C`.
-/
class creates_limits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] (J : Type v)
    [small_category J] (F : C ⥤ D)
    where
  creates_limit : {K : J ⥤ C} → creates_limit K F

/-- `F` creates limits if it creates limits of shape `J` for any small `J`. -/
class creates_limits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) where
  creates_limits_of_shape : {J : Type v} → {𝒥 : small_category J} → creates_limits_of_shape J F

/--
Dual of definition 3.3.1 of [Riehl].
We say that `F` creates colimits of `K` if, given any limit cocone `c` for
`K ⋙ F` (i.e. below) we can lift it to a cocone "above", and further that `F`
reflects limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cocone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D)
    extends limits.reflects_colimit K F where
  lifts : (c : limits.cocone (K ⋙ F)) → limits.is_colimit c → liftable_cocone K F c

/--
`F` creates colimits of shape `J` if `F` creates the colimit of any diagram
`K : J ⥤ C`.
-/
class creates_colimits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] (J : Type v)
    [small_category J] (F : C ⥤ D)
    where
  creates_colimit : {K : J ⥤ C} → creates_colimit K F

/-- `F` creates colimits if it creates colimits of shape `J` for any small `J`. -/
class creates_colimits {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) where
  creates_colimits_of_shape : {J : Type v} → {𝒥 : small_category J} → creates_colimits_of_shape J F

/- Interface to the `creates_limit` class. -/

/-- `lift_limit t` is the cone for `K` given by lifting the limit `t` for `K ⋙ F`. -/
def lift_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J]
    {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : limits.cone (K ⋙ F)} (t : limits.is_limit c) :
    limits.cone K :=
  liftable_cone.lifted_cone (creates_limit.lifts c t)

/-- The lifted cone has an image isomorphic to the original cone. -/
def lifted_limit_maps_to_original {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : limits.cone (K ⋙ F)}
    (t : limits.is_limit c) : functor.map_cone F (lift_limit t) ≅ c :=
  liftable_cone.valid_lift (creates_limit.lifts c t)

/-- The lifted cone is a limit. -/
def lifted_limit_is_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : limits.cone (K ⋙ F)}
    (t : limits.is_limit c) : limits.is_limit (lift_limit t) :=
  limits.reflects_limit.reflects
    (limits.is_limit.of_iso_limit t (iso.symm (lifted_limit_maps_to_original t)))

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
theorem has_limit_of_created {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) [limits.has_limit (K ⋙ F)] [creates_limit K F] :
    limits.has_limit K :=
  limits.has_limit.mk
    (limits.limit_cone.mk (lift_limit (limits.limit.is_limit (K ⋙ F)))
      (lifted_limit_is_limit (limits.limit.is_limit (K ⋙ F))))

/--
If `F` creates limits of shape `J`, and `D` has limits of shape `J`, then
`C` has limits of shape `J`.
-/
theorem has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape {C : Type u₁}
    [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (F : C ⥤ D)
    [limits.has_limits_of_shape J D] [creates_limits_of_shape J F] :
    limits.has_limits_of_shape J C :=
  limits.has_limits_of_shape.mk fun (G : J ⥤ C) => has_limit_of_created G F

/-- If `F` creates limits, and `D` has all limits, then `C` has all limits. -/
theorem has_limits_of_has_limits_creates_limits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (F : C ⥤ D) [limits.has_limits D] [creates_limits F] : limits.has_limits C :=
  limits.has_limits.mk
    fun (J : Type v) (I : small_category J) =>
      has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape F

/- Interface to the `creates_colimit` class. -/

/-- `lift_colimit t` is the cocone for `K` given by lifting the colimit `t` for `K ⋙ F`. -/
def lift_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F] {c : limits.cocone (K ⋙ F)}
    (t : limits.is_colimit c) : limits.cocone K :=
  liftable_cocone.lifted_cocone (creates_colimit.lifts c t)

/-- The lifted cocone has an image isomorphic to the original cocone. -/
def lifted_colimit_maps_to_original {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F]
    {c : limits.cocone (K ⋙ F)} (t : limits.is_colimit c) :
    functor.map_cocone F (lift_colimit t) ≅ c :=
  liftable_cocone.valid_lift (creates_colimit.lifts c t)

/-- The lifted cocone is a colimit. -/
def lifted_colimit_is_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F] {c : limits.cocone (K ⋙ F)}
    (t : limits.is_colimit c) : limits.is_colimit (lift_colimit t) :=
  limits.reflects_colimit.reflects
    (limits.is_colimit.of_iso_colimit t (iso.symm (lifted_colimit_maps_to_original t)))

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
theorem has_colimit_of_created {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) [limits.has_colimit (K ⋙ F)] [creates_colimit K F] :
    limits.has_colimit K :=
  limits.has_colimit.mk
    (limits.colimit_cocone.mk (lift_colimit (limits.colimit.is_colimit (K ⋙ F)))
      (lifted_colimit_is_colimit (limits.colimit.is_colimit (K ⋙ F))))

/--
If `F` creates colimits of shape `J`, and `D` has colimits of shape `J`, then
`C` has colimits of shape `J`.
-/
theorem has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape {C : Type u₁}
    [category C] {D : Type u₂} [category D] {J : Type v} [small_category J] (F : C ⥤ D)
    [limits.has_colimits_of_shape J D] [creates_colimits_of_shape J F] :
    limits.has_colimits_of_shape J C :=
  limits.has_colimits_of_shape.mk fun (G : J ⥤ C) => has_colimit_of_created G F

/-- If `F` creates colimits, and `D` has all colimits, then `C` has all colimits. -/
theorem has_colimits_of_has_colimits_creates_colimits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (F : C ⥤ D) [limits.has_colimits D] [creates_colimits F] : limits.has_colimits C :=
  limits.has_colimits.mk
    fun (J : Type v) (I : small_category J) =>
      has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape F

/--
A helper to show a functor creates limits. In particular, if we can show
that for any limit cone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates limits.
Usually, `F` creating limits says that _any_ lift of `c` is a limit, but
here we only need to show that our particular lift of `c` is a limit.
-/
structure lifts_to_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cone (K ⋙ F)) (t : limits.is_limit c)
    extends liftable_cone K F c where
  makes_limit : limits.is_limit (liftable_cone.lifted_cone _to_liftable_cone)

/--
A helper to show a functor creates colimits. In particular, if we can show
that for any limit cocone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates colimits.
Usually, `F` creating colimits says that _any_ lift of `c` is a colimit, but
here we only need to show that our particular lift of `c` is a colimit.
-/
structure lifts_to_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) (c : limits.cocone (K ⋙ F)) (t : limits.is_colimit c)
    extends liftable_cocone K F c where
  makes_colimit : limits.is_colimit (liftable_cocone.lifted_cocone _to_liftable_cocone)

/--
If `F` reflects isomorphisms and we can lift any limit cone to a limit cone,
then `F` creates limits.
In particular here we don't need to assume that F reflects limits.
-/
def creates_limit_of_reflects_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F]
    (h : (c : limits.cone (K ⋙ F)) → (t : limits.is_limit c) → lifts_to_limit K F c t) :
    creates_limit K F :=
  creates_limit.mk
    fun (c : limits.cone (K ⋙ F)) (t : limits.is_limit c) => lifts_to_limit.to_liftable_cone (h c t)

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to exhibit a lift of the chosen limit cone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,

-- this construction will insert additional identity morphisms in the cone maps,

-- so the constructed limits may not be ideal, definitionally.

def creates_limit_of_fully_faithful_of_lift {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F]
    [limits.has_limit (K ⋙ F)] (c : limits.cone K)
    (i : functor.map_cone F c ≅ limits.limit.cone (K ⋙ F)) : creates_limit K F :=
  creates_limit_of_reflects_iso
    fun (c' : limits.cone (K ⋙ F)) (t : limits.is_limit c') =>
      lifts_to_limit.mk
        (liftable_cone.mk c
          (i ≪≫ limits.is_limit.unique_up_to_iso (limits.limit.is_limit (K ⋙ F)) t))
        (limits.is_limit.of_faithful F
          (limits.is_limit.of_iso_limit (limits.limit.is_limit (K ⋙ F)) (iso.symm i))
          (fun (s : limits.cone K) =>
            functor.preimage F
              (limits.is_limit.lift
                (limits.is_limit.of_iso_limit (limits.limit.is_limit (K ⋙ F)) (iso.symm i))
                (functor.map_cone F s)))
          sorry)

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to show that the chosen limit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,

-- this construction will insert additional identity morphisms in the cone maps,

-- so the constructed limits may not be ideal, definitionally.

def creates_limit_of_fully_faithful_of_iso {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F]
    [limits.has_limit (K ⋙ F)] (X : C) (i : functor.obj F X ≅ limits.limit (K ⋙ F)) :
    creates_limit K F :=
  creates_limit_of_fully_faithful_of_lift
    (limits.cone.mk X
      (nat_trans.mk fun (j : J) => functor.preimage F (iso.hom i ≫ limits.limit.π (K ⋙ F) j)))
    (limits.cones.ext i sorry)

/-- `F` preserves the limit of `K` if it creates the limit and `K ⋙ F` has the limit. -/
protected instance preserves_limit_of_creates_limit_and_has_limit {C : Type u₁} [category C]
    {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D)
    [creates_limit K F] [limits.has_limit (K ⋙ F)] : limits.preserves_limit K F :=
  limits.preserves_limit.mk
    fun (c : limits.cone K) (t : limits.is_limit c) =>
      limits.is_limit.of_iso_limit (limits.limit.is_limit (K ⋙ F))
        (iso.symm (lifted_limit_maps_to_original (limits.limit.is_limit (K ⋙ F))) ≪≫
          functor.map_iso (limits.cones.functoriality K F)
            (limits.is_limit.unique_up_to_iso
              (lifted_limit_is_limit (limits.limit.is_limit (K ⋙ F))) t))

/-- `F` preserves the limit of shape `J` if it creates these limits and `D` has them. -/
protected instance preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape
    {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J]
    (F : C ⥤ D) [creates_limits_of_shape J F] [limits.has_limits_of_shape J D] :
    limits.preserves_limits_of_shape J F :=
  limits.preserves_limits_of_shape.mk
    fun (K : J ⥤ C) => category_theory.preserves_limit_of_creates_limit_and_has_limit K F

/-- `F` preserves limits if it creates limits and `D` has limits. -/
protected instance preserves_limits_of_creates_limits_and_has_limits {C : Type u₁} [category C]
    {D : Type u₂} [category D] (F : C ⥤ D) [creates_limits F] [limits.has_limits D] :
    limits.preserves_limits F :=
  limits.preserves_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      category_theory.preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape F

/--
If `F` reflects isomorphisms and we can lift any limit cocone to a limit cocone,
then `F` creates colimits.
In particular here we don't need to assume that F reflects colimits.
-/
def creates_colimit_of_reflects_iso {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F]
    (h : (c : limits.cocone (K ⋙ F)) → (t : limits.is_colimit c) → lifts_to_colimit K F c t) :
    creates_colimit K F :=
  creates_colimit.mk
    fun (c : limits.cocone (K ⋙ F)) (t : limits.is_colimit c) =>
      lifts_to_colimit.to_liftable_cocone (h c t)

/-- `F` preserves the colimit of `K` if it creates the colimit and `K ⋙ F` has the colimit. -/
protected instance preserves_colimit_of_creates_colimit_and_has_colimit {C : Type u₁} [category C]
    {D : Type u₂} [category D] {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D)
    [creates_colimit K F] [limits.has_colimit (K ⋙ F)] : limits.preserves_colimit K F :=
  limits.preserves_colimit.mk
    fun (c : limits.cocone K) (t : limits.is_colimit c) =>
      limits.is_colimit.of_iso_colimit (limits.colimit.is_colimit (K ⋙ F))
        (iso.symm (lifted_colimit_maps_to_original (limits.colimit.is_colimit (K ⋙ F))) ≪≫
          functor.map_iso (limits.cocones.functoriality K F)
            (limits.is_colimit.unique_up_to_iso
              (lifted_colimit_is_colimit (limits.colimit.is_colimit (K ⋙ F))) t))

/-- `F` preserves the colimit of shape `J` if it creates these colimits and `D` has them. -/
protected instance preserves_colimit_of_shape_of_creates_colimits_of_shape_and_has_colimits_of_shape
    {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v} [small_category J]
    (F : C ⥤ D) [creates_colimits_of_shape J F] [limits.has_colimits_of_shape J D] :
    limits.preserves_colimits_of_shape J F :=
  limits.preserves_colimits_of_shape.mk
    fun (K : J ⥤ C) => category_theory.preserves_colimit_of_creates_colimit_and_has_colimit K F

/-- `F` preserves limits if it creates limits and `D` has limits. -/
protected instance preserves_colimits_of_creates_colimits_and_has_colimits {C : Type u₁}
    [category C] {D : Type u₂} [category D] (F : C ⥤ D) [creates_colimits F]
    [limits.has_colimits D] : limits.preserves_colimits F :=
  limits.preserves_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      category_theory.preserves_colimit_of_shape_of_creates_colimits_of_shape_and_has_colimits_of_shape
        F

/-- If `F` creates the limit of `K` and `F ≅ G`, then `G` creates the limit of `K`. -/
def creates_limit_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] {K : J ⥤ C} {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_limit K F] :
    creates_limit K G :=
  creates_limit.mk
    fun (c : limits.cone (K ⋙ G)) (t : limits.is_limit c) =>
      liftable_cone.mk
        (lift_limit
          (coe_fn (equiv.symm (limits.is_limit.postcompose_inv_equiv (iso_whisker_left K h) c)) t))
        (limits.is_limit.unique_up_to_iso
          (limits.is_limit.map_cone_equiv h
            (limits.is_limit.of_iso_limit
              (coe_fn (equiv.symm (limits.is_limit.postcompose_inv_equiv (iso_whisker_left K h) c))
                t)
              (iso.symm
                (lifted_limit_maps_to_original
                  (coe_fn
                    (equiv.symm (limits.is_limit.postcompose_inv_equiv (iso_whisker_left K h) c))
                    t)))))
          t)

/-- If `F` creates limits of shape `J` and `F ≅ G`, then `G` creates limits of shape `J`. -/
def creates_limits_of_shape_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G)
    [creates_limits_of_shape J F] : creates_limits_of_shape J G :=
  creates_limits_of_shape.mk fun (K : J ⥤ C) => creates_limit_of_nat_iso h

/-- If `F` creates limits and `F ≅ G`, then `G` creates limits. -/
def creates_limits_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (h : F ≅ G) [creates_limits F] : creates_limits G :=
  creates_limits.mk fun (J : Type v) (𝒥₁ : small_category J) => creates_limits_of_shape_of_nat_iso h

/-- If `F` creates the colimit of `K` and `F ≅ G`, then `G` creates the colimit of `K`. -/
def creates_colimit_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] {K : J ⥤ C} {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G) [creates_colimit K F] :
    creates_colimit K G :=
  creates_colimit.mk
    fun (c : limits.cocone (K ⋙ G)) (t : limits.is_colimit c) =>
      liftable_cocone.mk
        (lift_colimit
          (coe_fn (equiv.symm (limits.is_colimit.precompose_hom_equiv (iso_whisker_left K h) c)) t))
        (limits.is_colimit.unique_up_to_iso
          (limits.is_colimit.map_cocone_equiv h
            (limits.is_colimit.of_iso_colimit
              (coe_fn (equiv.symm (limits.is_colimit.precompose_hom_equiv (iso_whisker_left K h) c))
                t)
              (iso.symm
                (lifted_colimit_maps_to_original
                  (coe_fn
                    (equiv.symm (limits.is_colimit.precompose_hom_equiv (iso_whisker_left K h) c))
                    t)))))
          t)

/-- If `F` creates colimits of shape `J` and `F ≅ G`, then `G` creates colimits of shape `J`. -/
def creates_colimits_of_shape_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {F : C ⥤ D} {G : C ⥤ D} (h : F ≅ G)
    [creates_colimits_of_shape J F] : creates_colimits_of_shape J G :=
  creates_colimits_of_shape.mk fun (K : J ⥤ C) => creates_colimit_of_nat_iso h

/-- If `F` creates colimits and `F ≅ G`, then `G` creates colimits. -/
def creates_colimits_of_nat_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (h : F ≅ G) [creates_colimits F] : creates_colimits G :=
  creates_colimits.mk
    fun (J : Type v) (𝒥₁ : small_category J) => creates_colimits_of_shape_of_nat_iso h

-- For the inhabited linter later.

/-- If F creates the limit of K, any cone lifts to a limit. -/
def lifts_to_limit_of_creates {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_limit K F] (c : limits.cone (K ⋙ F))
    (t : limits.is_limit c) : lifts_to_limit K F c t :=
  lifts_to_limit.mk (liftable_cone.mk (lift_limit t) (lifted_limit_maps_to_original t))
    (lifted_limit_is_limit t)

-- For the inhabited linter later.

/-- If F creates the colimit of K, any cocone lifts to a colimit. -/
def lifts_to_colimit_of_creates {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v}
    [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_colimit K F] (c : limits.cocone (K ⋙ F))
    (t : limits.is_colimit c) : lifts_to_colimit K F c t :=
  lifts_to_colimit.mk (liftable_cocone.mk (lift_colimit t) (lifted_colimit_maps_to_original t))
    (lifted_colimit_is_colimit t)

/-- Any cone lifts through the identity functor. -/
def id_lifts_cone {C : Type u₁} [category C] {J : Type v} [small_category J] {K : J ⥤ C}
    (c : limits.cone (K ⋙ 𝟭)) : liftable_cone K 𝟭 c :=
  liftable_cone.mk
    (limits.cone.mk (limits.cone.X c) (limits.cone.π c ≫ iso.hom (functor.right_unitor K)))
    (limits.cones.ext
      (iso.refl
        (limits.cone.X
          (functor.map_cone 𝟭
            (limits.cone.mk (limits.cone.X c)
              (limits.cone.π c ≫ iso.hom (functor.right_unitor K))))))
      sorry)

/-- The identity functor creates all limits. -/
protected instance id_creates_limits {C : Type u₁} [category C] : creates_limits 𝟭 :=
  creates_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      creates_limits_of_shape.mk
        fun (F : J ⥤ C) =>
          creates_limit.mk fun (c : limits.cone (F ⋙ 𝟭)) (t : limits.is_limit c) => id_lifts_cone c

/-- Any cocone lifts through the identity functor. -/
def id_lifts_cocone {C : Type u₁} [category C] {J : Type v} [small_category J] {K : J ⥤ C}
    (c : limits.cocone (K ⋙ 𝟭)) : liftable_cocone K 𝟭 c :=
  liftable_cocone.mk
    (limits.cocone.mk (limits.cocone.X c) (iso.inv (functor.right_unitor K) ≫ limits.cocone.ι c))
    (limits.cocones.ext
      (iso.refl
        (limits.cocone.X
          (functor.map_cocone 𝟭
            (limits.cocone.mk (limits.cocone.X c)
              (iso.inv (functor.right_unitor K) ≫ limits.cocone.ι c)))))
      sorry)

/-- The identity functor creates all colimits. -/
protected instance id_creates_colimits {C : Type u₁} [category C] : creates_colimits 𝟭 :=
  creates_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      creates_colimits_of_shape.mk
        fun (F : J ⥤ C) =>
          creates_colimit.mk
            fun (c : limits.cocone (F ⋙ 𝟭)) (t : limits.is_colimit c) => id_lifts_cocone c

/-- Satisfy the inhabited linter -/
protected instance inhabited_liftable_cone {C : Type u₁} [category C] {J : Type v}
    [small_category J] {K : J ⥤ C} (c : limits.cone (K ⋙ 𝟭)) : Inhabited (liftable_cone K 𝟭 c) :=
  { default := id_lifts_cone c }

protected instance inhabited_liftable_cocone {C : Type u₁} [category C] {J : Type v}
    [small_category J] {K : J ⥤ C} (c : limits.cocone (K ⋙ 𝟭)) :
    Inhabited (liftable_cocone K 𝟭 c) :=
  { default := id_lifts_cocone c }

/-- Satisfy the inhabited linter -/
protected instance inhabited_lifts_to_limit {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_limit K F]
    (c : limits.cone (K ⋙ F)) (t : limits.is_limit c) : Inhabited (lifts_to_limit K F c t) :=
  { default := lifts_to_limit_of_creates K F c t }

protected instance inhabited_lifts_to_colimit {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] (K : J ⥤ C) (F : C ⥤ D) [creates_colimit K F]
    (c : limits.cocone (K ⋙ F)) (t : limits.is_colimit c) : Inhabited (lifts_to_colimit K F c t) :=
  { default := lifts_to_colimit_of_creates K F c t }

protected instance comp_creates_limit {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {K : J ⥤ C} {E : Type u₃} [ℰ : category E] (F : C ⥤ D)
    (G : D ⥤ E) [creates_limit K F] [creates_limit (K ⋙ F) G] : creates_limit K (F ⋙ G) :=
  creates_limit.mk
    fun (c : limits.cone (K ⋙ F ⋙ G)) (t : limits.is_limit c) =>
      liftable_cone.mk (lift_limit (lifted_limit_is_limit t))
        (functor.map_iso (limits.cones.functoriality (K ⋙ F) G)
            (lifted_limit_maps_to_original (lifted_limit_is_limit t)) ≪≫
          lifted_limit_maps_to_original t)

protected instance comp_creates_limits_of_shape {C : Type u₁} [category C] {D : Type u₂}
    [category D] {J : Type v} [small_category J] {E : Type u₃} [ℰ : category E] (F : C ⥤ D)
    (G : D ⥤ E) [creates_limits_of_shape J F] [creates_limits_of_shape J G] :
    creates_limits_of_shape J (F ⋙ G) :=
  creates_limits_of_shape.mk infer_instance

protected instance comp_creates_limits {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_limits F] [creates_limits G] :
    creates_limits (F ⋙ G) :=
  creates_limits.mk infer_instance

protected instance comp_creates_colimit {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] {K : J ⥤ C} {E : Type u₃} [ℰ : category E] (F : C ⥤ D)
    (G : D ⥤ E) [creates_colimit K F] [creates_colimit (K ⋙ F) G] : creates_colimit K (F ⋙ G) :=
  creates_colimit.mk
    fun (c : limits.cocone (K ⋙ F ⋙ G)) (t : limits.is_colimit c) =>
      liftable_cocone.mk (lift_colimit (lifted_colimit_is_colimit t))
        (functor.map_iso (limits.cocones.functoriality (K ⋙ F) G)
            (lifted_colimit_maps_to_original (lifted_colimit_is_colimit t)) ≪≫
          lifted_colimit_maps_to_original t)

protected instance comp_creates_colimits_of_shape {C : Type u₁} [category C] {D : Type u₂}
    [category D] {J : Type v} [small_category J] {E : Type u₃} [ℰ : category E] (F : C ⥤ D)
    (G : D ⥤ E) [creates_colimits_of_shape J F] [creates_colimits_of_shape J G] :
    creates_colimits_of_shape J (F ⋙ G) :=
  creates_colimits_of_shape.mk infer_instance

protected instance comp_creates_colimits {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [ℰ : category E] (F : C ⥤ D) (G : D ⥤ E) [creates_colimits F]
    [creates_colimits G] : creates_colimits (F ⋙ G) :=
  creates_colimits.mk infer_instance

end Mathlib