import data.matrix data.rat.basic .misc tactic.fin_cases
import .matrix_pequiv

open matrix fintype finset function

variables {m n : ℕ}

local infix ` ⬝ `:70 := matrix.mul
local postfix `ᵀ` : 1500 := matrix.transpose
local notation `rvec`:2000 n := matrix (fin 1) (fin n) ℚ
local notation `cvec`:2000 m := matrix (fin m) (fin 1) ℚ

local attribute [instance] matrix.partial_order

def rvec.to_list {n : ℕ} (x : rvec n) : list ℚ :=
(vector.of_fn (x 0)).1

instance has_repr_fin_fun {n : ℕ} {α : Type*} [has_repr α] : has_repr (fin n → α) :=
⟨λ f, repr (vector.of_fn f).to_list⟩

instance {m n} : has_repr (matrix (fin m) (fin n) ℚ) := has_repr_fin_fun
open pequiv

def list.to_matrix (m :ℕ) (n : ℕ) (l : list (list ℚ)) : matrix (fin m) (fin n) ℚ :=
λ i j, (l.nth_le i sorry).nth_le j sorry

local attribute [instance] matrix.ordered_comm_group matrix.decidable_le
open pequiv

namespace simplex

open list

def pequiv_of_vector (v : vector (fin n) m) (hv : v.1.nodup) : fin m ≃. fin n :=
{ to_fun := λ i, some $ v.nth i,
  inv_fun := λ j, fin.find (λ i, v.nth i = j),
  inv := λ i j, ⟨λ h, by rw ← fin.find_spec _ h; exact rfl,
    λ h, fin.mem_find_of_unique
      (begin
        rintros ⟨i, him⟩ ⟨j, hjm⟩ h₁ h₂,
        cases v,
        refine fin.eq_of_veq (list.nodup_iff_nth_le_inj.1 hv i j _ _ (h₁.trans h₂.symm));
        simpa [v.2]
      end)
      (option.some_inj.1 h)⟩ }

def nonbasis_vector_of_vector (v : vector (fin n) m) (hv : v.to_list.nodup) :
  {v : vector (fin n) (n - m) // v.to_list.nodup} :=
⟨⟨(fin_range n).diff v.to_list,
  have h : m ≤ n,
    by rw [← list.length_fin_range n, ← v.2];
      exact list.length_le_of_subperm
        (subperm_of_subset_nodup hv (λ _ _, list.mem_fin_range _)),
  begin
    rw [← add_right_inj m, nat.sub_add_cancel h],
    conv in m { rw [← vector.to_list_length v] },
    rw ← length_append,
    conv_rhs { rw ← length_fin_range n },
    exact list.perm_length ((perm_ext
      (nodup_append.2 ⟨nodup_diff (nodup_fin_range _), hv,
        by simp [list.disjoint, mem_diff_iff_of_nodup (nodup_fin_range n), imp_false]⟩)
      (nodup_fin_range _)).2
      (by simp only [list.mem_diff_iff_of_nodup (nodup_fin_range n),
          list.mem_append, mem_fin_range, true_and, iff_true];
        exact λ _, or.symm (decidable.em _))),
  end⟩,
  nodup_diff (nodup_fin_range _)⟩

def pre_nonbasis_of_vector (v : vector (fin n) m) (hv : v.1.nodup) : fin (n - m) ≃. fin n :=
pequiv_of_vector (nonbasis_vector_of_vector v hv).1 (nonbasis_vector_of_vector v hv).2

structure prebasis (m n : ℕ) : Type :=
( basis : fin m ≃. fin n )
( nonbasis : fin (n - m) ≃. fin n )
( basis_trans_basis_symm : basis.trans basis.symm = pequiv.refl (fin m) )
( nonbasis_trans_nonbasis_symm : nonbasis.trans nonbasis.symm = pequiv.refl (fin (n - m)) )
( basis_trans_nonbasis_symm : basis.trans nonbasis.symm = ⊥ )

namespace prebasis
open pequiv

attribute [simp] basis_trans_basis_symm nonbasis_trans_nonbasis_symm basis_trans_nonbasis_symm

lemma is_some_basis (B : prebasis m n) : ∀ (i : fin m), (B.basis i).is_some :=
by rw [← trans_symm_eq_iff_forall_is_some, basis_trans_basis_symm]

lemma is_some_nonbasis (B : prebasis m n) : ∀ (k : fin (n - m)), (B.nonbasis k).is_some :=
by rw [← trans_symm_eq_iff_forall_is_some, nonbasis_trans_nonbasis_symm]

lemma injective_basis (B : prebasis m n) : injective B.basis :=
injective_of_forall_is_some (is_some_basis B)

lemma injective_nonbasis (B : prebasis m n) : injective B.nonbasis :=
injective_of_forall_is_some (is_some_nonbasis B)

def basisg (B : prebasis m n) (r : fin m) : fin n :=
option.get (B.is_some_basis r)

def nonbasisg (B : prebasis m n) (s : fin (n - m)) : fin n :=
option.get (B.is_some_nonbasis s)

lemma injective_basisg (B : prebasis m n) : injective B.basisg :=
λ x y h, by rw [basisg, basisg, ← option.some_inj, option.some_get, option.some_get] at h;
  exact injective_basis B h

lemma injective_nonbasisg (B : prebasis m n) : injective B.nonbasisg :=
λ x y h, by rw [nonbasisg, nonbasisg, ← option.some_inj, option.some_get, option.some_get] at h;
  exact injective_nonbasis B h

local infix ` ♣ `: 70 := pequiv.trans

def swap (B : prebasis m n) (r : fin m) (s : fin (n - m)) : prebasis m n :=
{ basis := B.basis.trans (equiv.swap (B.basisg r) (B.nonbasisg s)).to_pequiv,
  nonbasis := B.nonbasis.trans (equiv.swap (B.basisg r) (B.nonbasisg s)).to_pequiv,
  basis_trans_basis_symm := by rw [symm_trans_rev, ← trans_assoc, trans_assoc B.basis,
      ← equiv.to_pequiv_symm,  ← equiv.to_pequiv_trans];
    simp,
  nonbasis_trans_nonbasis_symm := by rw [symm_trans_rev, ← trans_assoc, trans_assoc B.nonbasis,
      ← equiv.to_pequiv_symm, ← equiv.to_pequiv_trans];
    simp,
  basis_trans_nonbasis_symm := by rw [symm_trans_rev, ← trans_assoc, trans_assoc B.basis,
      ← equiv.to_pequiv_symm, ← equiv.to_pequiv_trans];
    simp }

lemma not_is_some_nonbasis_of_is_some_basis (B : prebasis m n) (j : fin n) :
  (B.basis.symm j).is_some → (B.nonbasis.symm j).is_some → false :=
begin
  rw [option.is_some_iff_exists, option.is_some_iff_exists],
  rintros ⟨i, hi⟩ ⟨k, hk⟩,
  have : B.basis.trans B.nonbasis.symm i = none,
  { rw [B.basis_trans_nonbasis_symm, pequiv.bot_apply] },
  rw [pequiv.trans_eq_none] at this,
  rw [pequiv.eq_some_iff] at hi,
  exact (this j k).resolve_left (not_not.2 hi) hk
end

lemma nonbasis_ne_none_of_basis_eq_none (B : prebasis m n) (j : fin n)
  (hb : B.basis.symm j = none) (hnb : B.nonbasis.symm j = none) : false :=
have hs : card (univ.image B.basis) = m,
  by rw [card_image_of_injective _ (B.injective_basis), card_univ, card_fin],
have ht : card (univ.image B.nonbasis) = (n - m),
  by rw [card_image_of_injective _ (B.injective_nonbasis), card_univ, card_fin],
have hst : disjoint (univ.image B.basis) (univ.image B.nonbasis),
  from finset.disjoint_left.2 begin
    simp only [mem_image, exists_imp_distrib, not_exists],
    assume j i _ hbasis k _ hnonbasis,
    cases option.is_some_iff_exists.1 (is_some_basis B i) with x hi,
    cases option.is_some_iff_exists.1 (is_some_nonbasis B k) with y hk,
    have hxy : x = y,
    { rw [← option.some_inj, ← hk, ← hi, hbasis, hnonbasis] }, subst hxy,
    rw [← eq_some_iff] at hi hk,
    refine not_is_some_nonbasis_of_is_some_basis B x _ _;
    simp [hi, hk]
  end,
have (univ.image B.basis) ∪ (univ.image B.nonbasis) = univ.image (@some (fin n)),
  from eq_of_subset_of_card_le
    begin
      assume i h,
      simp only [finset.mem_image, finset.mem_union] at h,
      rcases h with ⟨j, _, hj⟩ | ⟨k, _, hk⟩,
      { simpa [hj.symm, option.is_some_iff_exists, eq_comm] using is_some_basis B j },
      { simpa [hk.symm, option.is_some_iff_exists, eq_comm] using is_some_nonbasis B k }
    end
    (begin
      rw [card_image_of_injective, card_univ, card_fin, card_disjoint_union hst, hs, ht],
      { rw add_comm,
        exact nat.le_sub_add _ _ },
      { intros _ _ h, injection h }
    end),
begin
  simp only [option.eq_none_iff_forall_not_mem, mem_iff_mem B.basis,
    mem_iff_mem B.nonbasis] at hb hnb,
  have := (finset.ext.1 this (some j)).2 (mem_image_of_mem _ (mem_univ _)),
  simp only [hb, hnb, mem_image, finset.mem_union, option.mem_def.symm] at this, tauto
end

lemma is_some_basis_iff (B : prebasis m n) (j : fin n) :
  (B.basis.symm j).is_some ↔ ¬(B.nonbasis.symm j).is_some :=
⟨not_is_some_nonbasis_of_is_some_basis B j,
  by erw [option.not_is_some_iff_eq_none, ← option.ne_none_iff_is_some, forall_swap];
    exact nonbasis_ne_none_of_basis_eq_none B j⟩

@[simp] lemma nonbasis_basisg_eq_none (B : prebasis m n) (r : fin m) :
  B.nonbasis.symm (B.basisg r) = none :=
option.not_is_some_iff_eq_none.1 ((B.is_some_basis_iff _).1 (is_some_symm_get _ _))

@[simp] lemma basis_nonbasisg_eq_none (B : prebasis m n) (s : fin (n - m)) :
  B.basis.symm (B.nonbasisg s) = none :=
option.not_is_some_iff_eq_none.1 (mt (B.is_some_basis_iff _).1 $ not_not.2 (is_some_symm_get _ _))

@[simp] lemma basisg_mem (B : prebasis m n) (r : fin m) :
  (B.basisg r) ∈ B.basis r :=
option.get_mem _

@[simp] lemma nonbasisg_mem (B : prebasis m n) (s : fin (n - m)) :
  (B.nonbasisg s) ∈ B.nonbasis s :=
option.get_mem _

@[simp] lemma basis_basisg (B : prebasis m n) (r : fin m) : B.basis.symm (B.basisg r) = some r:=
B.basis.mem_iff_mem.2 (basisg_mem _ _)

@[simp] lemma nonbasis_nonbasisg (B : prebasis m n) (s : fin (n - m)) :
  B.nonbasis.symm (B.nonbasisg s) = some s :=
B.nonbasis.mem_iff_mem.2 (nonbasisg_mem _ _)

lemma eq_basisg_or_nonbasisg (B : prebasis m n) (i : fin n) :
  (∃ j, i = B.basisg j) ∨ (∃ j, i = B.nonbasisg j) :=
begin
  dsimp only [basisg, nonbasisg],
  by_cases h : ↥(B.basis.symm i).is_some,
  { cases option.is_some_iff_exists.1 h with j hj,
    exact or.inl ⟨j, by rw [B.basis.eq_some_iff] at hj;
      rw [← option.some_inj, ← hj, option.some_get]⟩ },
  { rw [(@not_iff_comm _ _ (classical.dec _) (classical.dec _)).1 (B.is_some_basis_iff _).symm] at h,
    cases option.is_some_iff_exists.1 h with j hj,
    exact or.inr ⟨j, by rw [B.nonbasis.eq_some_iff] at hj;
      rw [← option.some_inj, ← hj, option.some_get]⟩ }
end

lemma basisg_ne_nonbasisg (B : prebasis m n) (i : fin m) (j : fin (n - m)):
  B.basisg i ≠ B.nonbasisg j :=
λ h, by simpa using congr_arg B.basis.symm h

lemma single_basisg_mul_basis (B : prebasis m n) (i : fin m) :
  ((single (0 : fin 1) (B.basisg i)).to_matrix : matrix _ _ ℚ) ⬝
    B.basis.to_matrixᵀ = (single (0 : fin 1) i).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_mem _ (basis_basisg _ _)]

lemma single_basisg_mul_nonbasis (B : prebasis m n) (i : fin m) :
  ((single (0 : fin 1) (B.basisg i)).to_matrix : matrix _ _ ℚ) ⬝
    B.nonbasis.to_matrixᵀ = 0 :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_eq_none _ (nonbasis_basisg_eq_none _ _),
  to_matrix_bot]; apply_instance

lemma single_nonbasisg_mul_nonbasis (B : prebasis m n) (k : fin (n - m)) :
  ((single (0 : fin 1) (B.nonbasisg k)).to_matrix : matrix _ _ ℚ) ⬝
    B.nonbasis.to_matrixᵀ = (single (0 : fin 1) k).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_mem _ (nonbasis_nonbasisg _ _)]

lemma single_nonbasisg_mul_basis (B : prebasis m n) (k : fin (n - m)) :
  ((single (0 : fin 1) (B.nonbasisg k)).to_matrix : matrix _ _ ℚ) ⬝
    B.basis.to_matrixᵀ = 0 :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_eq_none _ (basis_nonbasisg_eq_none _ _),
  to_matrix_bot]; apply_instance

lemma nonbasis_trans_basis_symm (B : prebasis m n) : B.nonbasis.trans B.basis.symm = ⊥ :=
symm_injective $ by rw [symm_trans_rev, symm_symm, basis_trans_nonbasis_symm, symm_bot]

@[simp] lemma nonbasis_mul_basis_transpose (B : prebasis m n) :
  (B.nonbasis.to_matrix : matrix _ _ ℚ) ⬝ B.basis.to_matrixᵀ = 0 :=
by rw [← to_matrix_bot, ← B.nonbasis_trans_basis_symm, to_matrix_trans, to_matrix_symm]

@[simp] lemma basis_mul_nonbasis_transpose (B : prebasis m n) :
  (B.basis.to_matrix : matrix _ _ ℚ) ⬝ B.nonbasis.to_matrixᵀ = 0 :=
by rw [← to_matrix_bot, ← B.basis_trans_nonbasis_symm, to_matrix_trans, to_matrix_symm]

@[simp] lemma nonbasis_mul_nonbasis_transpose (B : prebasis m n) :
  (B.nonbasis.to_matrix : matrix _ _ ℚ) ⬝ B.nonbasis.to_matrixᵀ = 1 :=
by rw [← to_matrix_refl, ← B.nonbasis_trans_nonbasis_symm, to_matrix_trans, to_matrix_symm]

@[simp] lemma basis_mul_basis_transpose (B : prebasis m n) :
  (B.basis.to_matrix : matrix _ _ ℚ) ⬝ B.basis.to_matrixᵀ = 1 :=
by rw [← to_matrix_refl, ← B.basis_trans_basis_symm, to_matrix_trans, to_matrix_symm]

lemma transpose_mul_add_transpose_mul (B : prebasis m n) :
  (B.basis.to_matrixᵀ ⬝ B.basis.to_matrix : matrix (fin n) (fin n) ℚ) +
  B.nonbasis.to_matrixᵀ ⬝ B.nonbasis.to_matrix  = 1 :=
begin
  ext,
  repeat {rw [← to_matrix_symm, ← to_matrix_trans] },
  simp only [add_val, pequiv.symm_trans, pequiv.to_matrix, one_val,
    pequiv.mem_of_set_iff, set.mem_set_of_eq],
  have := is_some_basis_iff B j,
  split_ifs; tauto
end

lemma swap_basis_eq (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  (B.swap r s).basis.to_matrix = (B.basis.to_matrix : matrix _ _ ℚ)
  - (single r (B.basisg r)).to_matrix + (single r (B.nonbasisg s)).to_matrix :=
begin
  dsimp [swap],
  rw [to_matrix_trans, to_matrix_swap],
  simp only [matrix.mul_add, sub_eq_add_neg, matrix.mul_one, matrix.mul_neg,
    (to_matrix_trans _ _).symm, trans_single_of_mem _ (basisg_mem B r),
    trans_single_of_eq_none _ (basis_nonbasisg_eq_none B s), to_matrix_bot, neg_zero, add_zero]
end

lemma nonbasis_trans_swap_basis_symm (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  B.nonbasis.trans (B.swap r s).basis.symm = single s r :=
begin
  rw [swap, symm_trans_rev, ← equiv.to_pequiv_symm, ← equiv.perm.inv_def, equiv.swap_inv],
  ext i j,
  rw [mem_single_iff],
  dsimp [pequiv.trans, equiv.to_pequiv, equiv.swap_apply_def],
  simp only [coe, coe_mk_apply, option.mem_def, option.bind_eq_some'],
  rw [option.mem_def.1 (nonbasisg_mem B i)],
  simp [B.injective_nonbasisg.eq_iff, (B.basisg_ne_nonbasisg _ _).symm],
  split_ifs; simp [*, eq_comm]
end

lemma nonbasis_mul_swap_basis_tranpose (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  (B.nonbasis.to_matrix : matrix _ _ ℚ) ⬝ (B.swap r s).basis.to_matrixᵀ = (single s r).to_matrix :=
by rw [← nonbasis_trans_swap_basis_symm, to_matrix_trans, to_matrix_symm]

lemma basis_trans_swap_basis_transpose (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  B.basis.trans (B.swap r s).basis.symm = of_set {i | i ≠ r} :=
begin
  rw [swap, symm_trans_rev, ← equiv.to_pequiv_symm, ← equiv.perm.inv_def, equiv.swap_inv],
  ext i j,
  dsimp [pequiv.trans, equiv.to_pequiv, equiv.swap_apply_def],
  simp only [coe, coe_mk_apply, option.mem_def, option.bind_eq_some'],
  rw [option.mem_def.1 (basisg_mem B i)],
  simp [B.injective_basisg.eq_iff, B.basisg_ne_nonbasisg],
  split_ifs,
  { simp * },
  { simp *; split; intros; simp * at * }
end

lemma swap_basis_transpose_mul_single_of_ne (B : prebasis m n) {r : fin m}
  (s : fin (n - m)) {i : fin m} (hir : i ≠ r) :
  ((B.swap r s).basis.to_matrixᵀ : matrix (fin n) (fin m) ℚ) ⬝ (single i (0 : fin 1)).to_matrix =
  B.basis.to_matrixᵀ ⬝ (single i 0).to_matrix :=
begin
  simp only [swap_basis_eq, sub_eq_add_neg, matrix.mul_add, matrix.mul_neg, matrix.mul_one,
    matrix.add_mul, (to_matrix_trans _ _).symm, (to_matrix_symm _).symm, transpose_add,
    transpose_neg, matrix.neg_mul, symm_trans_rev, trans_assoc],
  rw [trans_single_of_mem _ (basis_basisg _ _), trans_single_of_eq_none, trans_single_of_eq_none,
    to_matrix_bot, neg_zero, add_zero, add_zero];
  {dsimp [single]; simp [*, B.injective_basisg.eq_iff]} <|> apply_instance
end

lemma swap_basis_transpose_mul_single (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  ((B.swap r s).basis.to_matrixᵀ : matrix (fin n) (fin m) ℚ) ⬝ (single r (0 : fin 1)).to_matrix =
  B.nonbasis.to_matrixᵀ ⬝ (single s (0 : fin 1)).to_matrix :=
begin
  simp only [swap_basis_eq, sub_eq_add_neg, matrix.mul_add, matrix.mul_neg, matrix.mul_one,
    matrix.add_mul, (to_matrix_trans _ _).symm, (to_matrix_symm _).symm, transpose_add,
    transpose_neg, matrix.neg_mul, symm_trans_rev, trans_assoc, symm_single],
  rw [trans_single_of_mem _ (basis_basisg _ _), trans_single_of_mem _ (mem_single _ _),
    trans_single_of_mem _ (mem_single _ _), trans_single_of_mem _ (nonbasis_nonbasisg _ _)],
  simp,
  all_goals {apply_instance}
end

def equiv_aux : prebasis m n ≃ Σ' (basis : fin m ≃. fin n)
  (nonbasis : fin (n - m) ≃. fin n)
  ( basis_trans_basis_symm : basis.trans basis.symm = pequiv.refl (fin m) )
( nonbasis_trans_nonbasis_symm : nonbasis.trans nonbasis.symm = pequiv.refl (fin (n - m)) ),
  basis.trans nonbasis.symm = ⊥ :=
{ to_fun := λ ⟨a, b, c, d, e⟩, ⟨a, b, c, d, e⟩,
  inv_fun := λ ⟨a, b, c, d, e⟩, ⟨a, b, c, d, e⟩,
  left_inv := λ ⟨_, _, _, _, _⟩, rfl,
  right_inv := λ ⟨_, _, _, _, _⟩, rfl }

--instance : fintype (prebasis m n) := sorry

end prebasis

open prebasis

/- By convention `A_bar` and `b_bar` are in tableau form, so definitions may only be correct
  assuming `A ⬝ B.basis.to_matrixᵀ = 1` and `b_bar = 0` -/

def pivot_element (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (r : fin m)
  (s : fin (n - m)) : cvec 1 :=
(single 0 r).to_matrix ⬝ A_bar ⬝ B.nonbasis.to_matrixᵀ ⬝ (single s 0).to_matrix

def swap_inverse (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (r : fin m) (s : fin (n - m)) : matrix (fin m) (fin m) ℚ :=
(1 + (1 - A_bar ⬝ B.nonbasis.to_matrixᵀ ⬝ (single s (0 : fin 1)).to_matrix ⬝
    (single (0 : fin 1) r).to_matrix) ⬝ (single r (0 : fin 1)).to_matrix ⬝
    (pivot_element B A_bar r s)⁻¹ ⬝ (single (0 : fin 1) r).to_matrix)

def ratio (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (b_bar : cvec m)
  (r : fin m) (s : fin (n - m)) : cvec 1 :=
(pivot_element B A_bar r s)⁻¹ ⬝ ((single 0 r).to_matrix ⬝ b_bar)

lemma swap_mul_swap_inverse {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  swap_inverse B A_bar r s ⬝ (A_bar ⬝ (B.swap r s).basis.to_matrixᵀ) = 1 :=
have ((single (0 : fin 1) r).to_matrix ⬝ (single r 0).to_matrix : cvec 1) = 1,
  by rw [← to_matrix_trans]; simp,
begin
  refine mul_single_ext (λ i, _),
  simp only [swap_inverse, matrix.mul_add, matrix.add_mul, sub_eq_add_neg, matrix.neg_mul, matrix.mul_neg,
    matrix.one_mul, matrix.mul_one, matrix.mul_assoc, transpose_add, transpose_neg,
     mul_right_eq_of_mul_eq this, pivot_element],
  rw [pivot_element, matrix.mul_assoc, matrix.mul_assoc] at hpivot,
  by_cases h : i = r,
  { simp only [h, swap_basis_transpose_mul_single, mul_right_eq_of_mul_eq hA_bar,
      one_by_one_inv_mul_cancel hpivot, inv_eq_inverse],
    simp },
  { have : ((single (0 : fin 1) r).to_matrix ⬝ (single i 0).to_matrix : cvec 1) = 0,
    { rw [← to_matrix_trans, single_trans_single_of_ne (ne.symm h), to_matrix_bot] },
    simp [swap_basis_transpose_mul_single_of_ne _ _ h,
      mul_right_eq_of_mul_eq hA_bar, this] }
end

lemma has_left_inverse_swap {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  (A_bar ⬝ (B.swap r s).basis.to_matrixᵀ).has_left_inverse :=
⟨_, swap_mul_swap_inverse hA_bar hpivot⟩

lemma has_left_inverse_swap_inverse {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  (swap_inverse B A_bar r s).has_left_inverse :=
has_right_inverse_iff_has_left_inverse.1 ⟨_, swap_mul_swap_inverse hA_bar hpivot⟩

lemma inverse_swap_eq {A_bar : matrix (fin m) (fin n) ℚ} {B : prebasis m n}
  {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  inverse (A_bar ⬝ (B.swap r s).basis.to_matrixᵀ) = swap_inverse B A_bar r s :=
eq.symm $ eq_inverse_of_mul_eq_one $ by rw [swap_mul_swap_inverse hA_bar hpivot]

def adjust (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (b_bar : cvec m)
  (s : fin (n - m)) (a : cvec 1) : cvec n :=
B.basis.to_matrixᵀ ⬝ b_bar + (B.nonbasis.to_matrixᵀ -
  B.basis.to_matrixᵀ ⬝ A_bar ⬝ B.nonbasis.to_matrixᵀ) ⬝ (single s 0).to_matrix ⬝ a

lemma adjust_is_solution {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ} (b_bar : cvec m)
  (s : fin (n - m)) (a : cvec 1) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1) :
  A_bar ⬝ adjust B A_bar b_bar s a = b_bar :=
by simp [matrix.mul_assoc, matrix.mul_add, adjust, matrix.add_mul, mul_right_eq_of_mul_eq hA_bar]

lemma single_pivot_mul_adjust (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (b_bar : cvec m)
  (s : fin (n - m)) (a : cvec 1) :
  (single 0 s).to_matrix ⬝ B.nonbasis.to_matrix ⬝ adjust B A_bar b_bar s a = a :=
by simp [matrix.mul_assoc, matrix.add_mul, matrix.mul_add, adjust,
  mul_right_eq_of_mul_eq (nonbasis_mul_basis_transpose B),
  mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose B)]

lemma basis_mul_adjust (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (b_bar : cvec m)
  (s : fin (n - m)) (a : cvec 1) : B.basis.to_matrix ⬝ adjust B A_bar b_bar s a = b_bar -
  A_bar ⬝ B.nonbasis.to_matrixᵀ ⬝ (single s 0).to_matrix ⬝ a :=
by simp [matrix.mul_assoc, matrix.add_mul, matrix.mul_add, adjust,
  mul_right_eq_of_mul_eq (basis_mul_basis_transpose B),
  mul_right_eq_of_mul_eq (basis_mul_nonbasis_transpose B)]

lemma nonbasis_mul_adjust (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (s : fin (n - m)) (a : cvec 1) :
  B.nonbasis.to_matrix ⬝ adjust B A_bar b_bar s a = to_matrix (single s 0) ⬝ a :=
by simp [matrix.mul_assoc, matrix.add_mul, matrix.mul_add, adjust,
  mul_right_eq_of_mul_eq (nonbasis_mul_basis_transpose B),
  mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose B)]

lemma adjust_nonneg_iff {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  {b_bar : cvec m} {s : fin (n - m)} {a : cvec 1} (ha : 0 ≤ a) (hb : 0 ≤ b_bar) :
  0 ≤ adjust B A_bar b_bar s a ↔
    ∀ (i : fin m), 0 < pivot_element B A_bar i s → a ≤ ratio B A_bar b_bar i s :=
have ∀ i : fin m, (single (0 : fin 1) (B.basisg i)).to_matrix ⬝ 0 ≤
  (single 0 (B.basisg i)).to_matrix ⬝ (B.basis.to_matrixᵀ ⬝ b_bar +
    (B.nonbasis.to_matrixᵀ - B.basis.to_matrixᵀ ⬝ A_bar ⬝ B.nonbasis.to_matrixᵀ) ⬝
    to_matrix (single s 0) ⬝ a) ↔
    0 < pivot_element B A_bar i s → a ≤ ratio B A_bar b_bar i s,
  begin
    assume i,
    simp only [matrix.mul_zero, ratio, matrix.mul_add, matrix.add_mul, matrix.mul_assoc,
      sub_eq_add_neg, matrix.mul_neg, matrix.neg_mul, matrix.mul_assoc,
      mul_right_eq_of_mul_eq (single_basisg_mul_basis B i),
      mul_right_eq_of_mul_eq (single_basisg_mul_nonbasis B i), matrix.zero_mul, zero_add],
    rw [← sub_eq_add_neg, sub_nonneg],
    simp only [pivot_element, matrix.mul_assoc],
    cases classical.em (0 < (single (0 : fin 1) i).to_matrix ⬝
      (A_bar ⬝ (B.nonbasis.to_matrixᵀ ⬝ (single s (0 : fin 1)).to_matrix))) with hpos hpos,
    { rw [← matrix.mul_eq_mul, ← mul_comm, ← div_eq_mul_inv, le_div_iff hpos, mul_comm,
        matrix.mul_eq_mul],
      simp [matrix.mul_assoc, hpos] },
    { simp only [hpos, forall_prop_of_false, iff_true, not_false_iff],
      simp only [(matrix.mul_assoc _ _ _).symm, (matrix.mul_eq_mul _ _).symm] at *,
      intros,
      refine le_trans (mul_nonpos_of_nonpos_of_nonneg (le_of_not_gt hpos) ha) _,
      rw [cvec_le_iff] at hb,
      simpa using hb i },
  end,
begin
  rw [adjust, cvec_le_iff],
  split,
  { assume h i,
    rw [← this],
    exact h (B.basisg i) },
  { assume h j,
    rcases eq_basisg_or_nonbasisg B j with ⟨i, hi⟩ | ⟨k, hk⟩,
    { rw [hi, this], exact h _ },
    { simp only [hk, matrix.mul_assoc,
        mul_right_eq_of_mul_eq (single_nonbasisg_mul_basis _ _),
        matrix.mul_add, matrix.add_mul, matrix.mul_neg,
        mul_right_eq_of_mul_eq (single_nonbasisg_mul_nonbasis _ _),
        add_zero, matrix.neg_mul, matrix.zero_mul,
        zero_add, matrix.mul_zero, sub_eq_add_neg, neg_zero],
      by_cases hks : k = s,
      { simpa [hks] },
      { rw [mul_right_eq_of_mul_eq (single_mul_single_of_ne hks _ _), matrix.zero_mul],
        exact le_refl _ } } }
end

def reduced_cost (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (c : rvec n) :
  rvec (n - m) :=
c ⬝ (B.nonbasis.to_matrixᵀ - B.basis.to_matrixᵀ ⬝ A_bar ⬝ B.nonbasis.to_matrixᵀ)

noncomputable def solution_of_basis (B : prebasis m n) (A : matrix (fin m) (fin n) ℚ) (b : cvec m) :
  cvec n :=
B.basis.to_matrixᵀ ⬝ inverse (A ⬝ B.basis.to_matrixᵀ) ⬝ b

lemma solution_of_basis_is_solution {A : matrix (fin m) (fin n) ℚ} {B : prebasis m n}
  (b : cvec m) (hA : (A ⬝ B.basis.to_matrixᵀ).has_left_inverse) :
  A ⬝ solution_of_basis B A b = b :=
by rw [solution_of_basis, ← matrix.mul_assoc, ← matrix.mul_assoc,
    mul_inverse (has_right_inverse_iff_has_left_inverse.2 hA), matrix.one_mul]

noncomputable def objective_function_of_basis (A : matrix (fin m) (fin n) ℚ) (B : prebasis m n)
  (b : cvec m) (c : rvec n) : cvec 1 :=
c ⬝ solution_of_basis B A b

/-- For proving `solution_of_basis_eq_adjust`, it suffices to prove they are equal after
  left multiplication by `A_bar` and after left multiplication by `B.nonbasis.to_matrix`.
  This lemma helps prove that. -/
lemma basis_transpose_add_nonbasis_transpose_mul_nonbasis {B : prebasis m n}
  {A_bar : matrix (fin m) (fin n) ℚ} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1) :
  (B.basis.to_matrixᵀ ⬝ A_bar + B.nonbasis.to_matrixᵀ ⬝ B.nonbasis.to_matrix) ⬝
  (1 - B.basis.to_matrixᵀ ⬝ A_bar ⬝ B.nonbasis.to_matrixᵀ ⬝ B.nonbasis.to_matrix) = 1 :=
by rw [← transpose_mul_add_transpose_mul B];
  simp [matrix.mul_add, matrix.add_mul, matrix.mul_neg, matrix.mul_assoc,
    mul_right_eq_of_mul_eq hA_bar,
    mul_right_eq_of_mul_eq (nonbasis_mul_basis_transpose _),
    mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose _)]

lemma solution_of_basis_eq_adjust {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  (b_bar : cvec m) {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  solution_of_basis (B.swap r s) A_bar b_bar = adjust B A_bar b_bar s (ratio B A_bar b_bar r s) :=
/- It suffices to prove they are equal after left multiplication by `A_bar` and by
`B.nonbasis.to_matrix` -/
suffices A_bar ⬝ (B.swap r s).basis.to_matrixᵀ
    ⬝ inverse (A_bar ⬝ (B.swap r s).basis.to_matrixᵀ) ⬝ b_bar =
    A_bar ⬝ adjust B A_bar b_bar s (ratio B A_bar b_bar r s) ∧
    B.nonbasis.to_matrix ⬝ (B.swap r s).basis.to_matrixᵀ
    ⬝ inverse (A_bar ⬝ (B.swap r s).basis.to_matrixᵀ) ⬝ b_bar =
    B.nonbasis.to_matrix ⬝ adjust B A_bar b_bar s (ratio B A_bar b_bar r s),
  begin
    rw [solution_of_basis, ← matrix.mul_left_inj ⟨_, mul_eq_one_comm.1
      (basis_transpose_add_nonbasis_transpose_mul_nonbasis hA_bar)⟩, matrix.add_mul,
      matrix.add_mul],
    simp only [matrix.mul_assoc] at *,
    rw [this.1, this.2]
  end,
{ left := by rw [adjust_is_solution _ _ _ hA_bar, matrix.mul_inverse
    (has_right_inverse_iff_has_left_inverse.2 (has_left_inverse_swap hA_bar hpivot)),
    matrix.one_mul],
  right :=
/- This `have` would be unnecessary with a powerful `assoc_rw` tactic -/
    have (single s r).to_matrix ⬝ (A_bar ⬝ (B.nonbasis.to_matrixᵀ ⬝ ((single s (0 : fin 1)).to_matrix
      ⬝ ((single 0 r).to_matrix ⬝ ((single r 0).to_matrix ⬝ (inverse (pivot_element B A_bar r s)
      ⬝ ((single 0 r).to_matrix ⬝ b_bar))))))) = (single s (0 : fin 1)).to_matrix
      ⬝ (single 0 r).to_matrix ⬝ b_bar,
      begin
        rw [pivot_element, mul_right_eq_of_mul_eq (single_mul_single (0 : fin 1) r (0 : fin 1)),
          single_subsingleton_eq_refl, to_matrix_refl, matrix.one_mul,
          ← single_mul_single s (0 : fin 1) r],
        simp only [(matrix.mul_assoc _ _ _).symm],
        simp only [(single s (0 : fin 1)).to_matrix.mul_assoc],
        rw [one_by_one_mul_inv_cancel, matrix.one_mul],
        { simpa [pivot.matrix.mul_assoc] using hpivot }
      end,
    begin
      simp only [adjust, matrix.mul_add, zero_add, sub_eq_add_neg, matrix.neg_mul,
        mul_right_eq_of_mul_eq (nonbasis_mul_basis_transpose _), matrix.zero_mul,
        nonbasis_mul_swap_basis_tranpose, matrix.mul_assoc, matrix.add_mul, matrix.mul_neg,
        mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose _), matrix.one_mul, neg_zero,
        add_zero, inverse_swap_eq hA_bar hpivot, swap_inverse, ratio, this, inv_eq_inverse],
      simp
    end }

lemma cvec_eq_basis_add_nonbasis (B : prebasis m n) (x : cvec n) :
  x = B.basis.to_matrixᵀ ⬝ B.basis.to_matrix ⬝ x + B.nonbasis.to_matrixᵀ ⬝ B.nonbasis.to_matrix ⬝ x :=
by simp only [(matrix.mul_assoc _ _ _).symm, (matrix.add_mul _ _ _).symm,
  B.transpose_mul_add_transpose_mul, matrix.one_mul]

lemma objective_function_eq {B : prebasis m n}
  {A_bar : matrix (fin m) (fin n) ℚ} {b_bar : cvec m} {c : rvec n} {x : cvec n}
  (hAx : A_bar ⬝ x = b_bar) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1) :
  c ⬝ x = c ⬝ B.basis.to_matrixᵀ ⬝ b_bar +
  reduced_cost B A_bar c ⬝ B.nonbasis.to_matrix ⬝ x :=
have B.basis.to_matrix ⬝ x = b_bar - A_bar ⬝ B.nonbasis.to_matrixᵀ
    ⬝ B.nonbasis.to_matrix ⬝ x,
  by rw [eq_sub_iff_add_eq, ← (B.basis.to_matrix).one_mul, ← hA_bar,
    matrix.mul_assoc, matrix.mul_assoc, matrix.mul_assoc, matrix.mul_assoc,
    ← matrix.mul_add, ← matrix.mul_assoc, ← matrix.mul_assoc, ← matrix.add_mul,
    transpose_mul_add_transpose_mul, matrix.one_mul, hAx],
begin
  conv_lhs {rw [cvec_eq_basis_add_nonbasis B x, matrix.mul_assoc, this]},
  simp [matrix.mul_add, matrix.mul_assoc, matrix.add_mul, reduced_cost]
end

lemma objective_function_swap_eq {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  (b_bar : cvec m) (c : rvec n) {r : fin m} {s : fin (n - m)}
  (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1) (hpivot : pivot_element B A_bar r s ≠ 0) :
  objective_function_of_basis A_bar (B.swap r s) b_bar c =
  objective_function_of_basis A_bar B b_bar c +
  reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix ⬝ ratio B A_bar b_bar r s :=
have h₁ : A_bar ⬝ (B.basis.to_matrixᵀ ⬝ b_bar) = b_bar,
  by rw [← matrix.mul_assoc, hA_bar, matrix.one_mul],
have h₂ : (A_bar ⬝ (to_matrix ((swap B r s).basis))ᵀ).has_left_inverse,
  from has_left_inverse_swap hA_bar hpivot,
begin
  rw [objective_function_of_basis, objective_function_eq
    (solution_of_basis_is_solution _ h₂) hA_bar,
    solution_of_basis_eq_adjust _ hA_bar hpivot, objective_function_of_basis,
    solution_of_basis, hA_bar, inverse_one, matrix.mul_one, c.mul_assoc,
    matrix.mul_assoc, matrix.mul_assoc],
  congr' 2,
  rw [adjust],
  simp only [matrix.mul_add, matrix.mul_assoc, sub_eq_add_neg,
    matrix.add_mul, matrix.neg_mul, matrix.mul_neg,
    mul_right_eq_of_mul_eq (nonbasis_mul_basis_transpose _),
    mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose _)],
  simp
end

lemma swap_nonneg_iff {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ} (b_bar : cvec m)
  {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : 0 < pivot_element B A_bar r s) (h0b : 0 ≤ b_bar) :
  0 ≤ solution_of_basis (B.swap r s) A_bar b_bar ↔
  (∀ i : fin m, 0 < pivot_element B A_bar i s →
    ratio B A_bar b_bar r s ≤ ratio B A_bar b_bar i s) :=
begin
  rw [solution_of_basis_eq_adjust _ hA_bar (ne_of_lt hpivot).symm, adjust_nonneg_iff _ h0b, ratio],
  rw cvec_le_iff at h0b,
  exact mul_nonneg (inv_nonneg.2 (le_of_lt hpivot)) (by simpa using h0b r)
end

lemma swap_inverse_mul_nonneg {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ} (b_bar : cvec m)
  {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : 0 < pivot_element B A_bar r s) (h0b : 0 ≤ b_bar) :
  (∀ i : fin m, 0 < pivot_element B A_bar i s →
    ratio B A_bar b_bar r s ≤ ratio B A_bar b_bar i s) →
  0 ≤ swap_inverse B A_bar r s ⬝ b_bar:=
begin
  rw [← swap_nonneg_iff b_bar hA_bar hpivot h0b, solution_of_basis,
    inverse_swap_eq hA_bar (ne_of_lt hpivot).symm],
  assume hratio,
  rw [cvec_le_iff] at *,
  assume i,
  simpa [mul_right_eq_of_mul_eq (single_basisg_mul_basis _ _), matrix.mul_assoc]
    using hratio ((B.swap r s).basisg i)
end

def is_unbounded (A : matrix (fin m) (fin n) ℚ) (b : cvec m) (c : rvec n) : Prop :=
∀ q : cvec 1, ∃ x, 0 ≤ x ∧ A ⬝ x = b ∧ q ≤ c ⬝ x

def is_optimal (A : matrix (fin m) (fin n) ℚ) (b : cvec m) (c : rvec n) (x : cvec n) : Prop :=
0 ≤ x ∧ A ⬝ x = b ∧ ∀ y, 0 ≤ y → A ⬝ y = b → c ⬝ y ≤ c ⬝ x

def is_optimal_basis (B : prebasis m n) (A : matrix (fin m) (fin n) ℚ)
  (b : cvec m) (c : rvec n) : Prop :=
(A ⬝ B.basis.to_matrixᵀ).has_left_inverse ∧
  is_optimal A b c (B.basis.to_matrixᵀ ⬝ inverse (A ⬝ B.basis.to_matrixᵀ) ⬝ b)

set_option class.instance_max_depth 100

lemma is_unbounded_of_pivot_element_nonpos {B : prebasis m n}
  {A_bar : matrix (fin m) (fin n) ℚ} (b_bar : cvec m) (c : rvec n)
  {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (h0b : 0 ≤ b_bar) (hs : reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix > 0)
  (h : ∀ r, pivot_element B A_bar r s ≤ 0) : is_unbounded A_bar b_bar c :=
begin
  assume q,
  let a := (reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix)⁻¹ ⬝
    (q - c ⬝ ((to_matrix (B.basis))ᵀ ⬝ b_bar)),
  use adjust B A_bar b_bar s (max 0 a),
  simp only [adjust_is_solution b_bar _ _ hA_bar, true_and, eq_self_iff_true],
  simp only [objective_function_eq (adjust_is_solution b_bar _ _ hA_bar) hA_bar]
    {single_pass := tt},
  simp only [nonbasis_mul_adjust, matrix.mul_assoc],
  split,
  { rw adjust_nonneg_iff (le_max_left _ _) h0b,
    assume i hi,
    exact absurd hi (not_lt_of_ge (h _)), },
  { cases le_total a 0 with ha0 ha0,
    { rw [max_eq_left ha0],
      simp only [a, (mul_eq_mul _ _).symm] at ha0,
      rw [mul_comm, ← div_eq_mul_inv, div_le_iff hs, _root_.zero_mul, sub_nonpos] at ha0,
      simpa },
    { simp only [max_eq_right ha0],
      rw [← (reduced_cost _ _ _).mul_assoc],
      dsimp only [a],
      rw [← matrix.mul_assoc (reduced_cost _ _ _ ⬝ _ ), ← mul_eq_mul,
        ← mul_eq_mul, mul_inv_cancel (ne_of_lt hs).symm],
      simp [le_refl] } }
end

lemma is_optimal_basis_of_reduced_cost_nonpos {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  (b_bar : cvec m) (c : rvec n) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (h0b : 0 ≤ b_bar) (hs : reduced_cost B A_bar c ≤ 0) :
  is_optimal_basis B A_bar b_bar c :=
begin
  rw [is_optimal_basis, hA_bar, inverse_one, matrix.mul_one],
  refine ⟨⟨1, matrix.one_mul _⟩, matrix.mul_nonneg (by rw [← to_matrix_symm]; exact pequiv_nonneg _) h0b,
    by rw [← matrix.mul_assoc, hA_bar, matrix.one_mul], _⟩,
  assume x h0x hAx,
  rw [objective_function_eq hAx hA_bar, ← le_sub_iff_add_le', ← matrix.mul_assoc, sub_self],
  exact matrix.mul_nonpos_of_nonpos_of_nonneg
    (matrix.mul_nonpos_of_nonpos_of_nonneg hs (pequiv_nonneg _)) h0x
end

def choose_pivot_column (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (c : rvec n) : option (fin (n - m)) :=
(fin.find (λ s : fin (n - m), 0 < reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix))

lemma choose_pivot_column_eq_none (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (h0b : 0 ≤ b_bar)
  (h : choose_pivot_column B A_bar c = none) :
  is_optimal_basis B A_bar b_bar c :=
is_optimal_basis_of_reduced_cost_nonpos _ _ hA_bar h0b $
  begin
    rw rvec_le_iff,
    simpa only [matrix.zero_mul, not_lt] using fin.find_eq_none_iff.1 h
  end

lemma choose_pivot_column_spec (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (s : fin (n - m)) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (h0b : 0 ≤ b_bar) (h : choose_pivot_column B A_bar c = some s) :
  0 < reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix :=
fin.find_spec _ h

def choose_pivot_row (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (b_bar : cvec m)
  (c : rvec n) (s : fin (n - m)) : option (fin m) :=
fin.find (λ r : fin m,
  0 < pivot_element B A_bar r s ∧
  ∀ i : fin m, ((0 : cvec 1) < pivot_element B A_bar i s) →
    ratio B A_bar b_bar r s ≤ ratio B A_bar b_bar i s)

lemma choose_pivot_row_spec (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (r : fin m) (s : fin (n - m))
  (hr : r ∈ choose_pivot_row B A_bar b_bar c s) :
  0 < pivot_element B A_bar r s ∧
  ∀ i : fin m, 0 < pivot_element B A_bar i s →
    ratio B A_bar b_bar r s ≤ ratio B A_bar b_bar i s :=
fin.find_spec _ hr

lemma choose_pivot_row_eq_none (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (r : fin m) (s : fin (n - m))
  (hn : choose_pivot_row B A_bar b_bar c s = none) :
  pivot_element B A_bar r s ≤ 0 :=
le_of_not_gt $ λ hpivot, begin
  rw [choose_pivot_row, fin.find_eq_none_iff] at hn,
  cases @finset.min_of_mem _ _
    ((univ.filter (λ j, 0 < pivot_element B A_bar j s)).image
      (λ i, ratio B A_bar b_bar i s)) (ratio B A_bar b_bar r s)
      (mem_image_of_mem _ (finset.mem_filter.2 ⟨mem_univ _, hpivot⟩)) with q hq,
  rcases mem_image.1 (mem_of_min hq) with ⟨i, hip, hiq⟩,
  subst hiq,
  refine hn i ⟨(finset.mem_filter.1 hip).2, λ j hj, _⟩,
  refine min_le_of_mem _ hq,
  refine mem_image_of_mem _ _,
  simpa using hj
end

lemma is_unbounded_of_choose_pivot_row_eq_none (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (s : fin (n - m))
  (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1) (h0b : 0 ≤ b_bar)
  (hs : 0 < reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix)
  (hn : choose_pivot_row B A_bar b_bar c s = none) : is_unbounded A_bar b_bar c :=
is_unbounded_of_pivot_element_nonpos _ _ hA_bar h0b hs
  (λ _, choose_pivot_row_eq_none _ _ _ _ _ _ hn)

lemma is_unbounded_swap {B : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ} {b_bar : cvec m}
  {c : rvec n} {r : fin m} {s : fin (n - m)} (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  is_unbounded (swap_inverse B A_bar r s ⬝ A_bar) (swap_inverse B A_bar r s ⬝ b_bar) c →
  is_unbounded A_bar b_bar c :=
by simp only [is_unbounded, matrix.mul_assoc, matrix.mul_left_inj
  (has_left_inverse_swap_inverse hA_bar hpivot), imp_self]

lemma is_optimal_basis_swap {B  : prebasis m n} {A_bar : matrix (fin m) (fin n) ℚ}
  {b_bar : cvec m} {c : rvec n} (S : matrix (fin m) (fin m) ℚ)
  (hS : S.has_left_inverse) (h : is_optimal_basis B (S ⬝ A_bar) (S ⬝ b_bar) c) :
  is_optimal_basis B A_bar b_bar c :=
begin
  rw [is_optimal_basis, matrix.mul_assoc, ← has_left_inverse_mul hS] at h,
  simp only [is_optimal_basis, is_optimal, matrix.mul_assoc, matrix.mul_left_inj
    hS, h.1, inverse_one, matrix.one_mul,
    matrix.mul_one, matrix.mul_left_inj
    (inverse_has_left_inverse (has_right_inverse_iff_has_left_inverse.2 hS)),
    inverse_mul hS, inverse_one, mul_right_eq_of_mul_eq (inverse_mul hS),
    matrix.one_mul, matrix.mul_one, mul_inverse_rev hS h.1, *] at *,
  tauto,
end

axiom wf (p : Prop) : p

def simplex : Π (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (h0b : 0 ≤ b_bar),
  { o : option (Σ (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ), cvec m) //
    option.cases_on o (is_unbounded A_bar b_bar c)
      (λ P, is_optimal_basis P.1 A_bar b_bar c) }
| B A_bar b_bar c hA_bar h0b :=
  match choose_pivot_column B A_bar c,
    (λ s, choose_pivot_column_spec B A_bar b_bar c s hA_bar h0b),
      choose_pivot_column_eq_none B A_bar b_bar c hA_bar h0b with
  | none,   _, hn := ⟨some ⟨B, A_bar, b_bar⟩, hn rfl⟩
  | some s, hs, _ :=
    match choose_pivot_row B A_bar b_bar c s,
      (λ r, choose_pivot_row_spec B A_bar b_bar c r s),
      is_unbounded_of_choose_pivot_row_eq_none B A_bar b_bar c s hA_bar h0b (hs _ rfl) with
    | none,     _, hnone  := ⟨none, hnone rfl⟩
    | (some r), hr, _ := let S := swap_inverse B A_bar r s in
      have wf : prebasis.sizeof m n (swap B r s) < prebasis.sizeof m n B, from wf _,
      let o := simplex (B.swap r s) (S ⬝ A_bar) (S ⬝ b_bar) c
        (by rw [matrix.mul_assoc, swap_mul_swap_inverse hA_bar (ne_of_lt (hr r rfl).1).symm])
        (swap_inverse_mul_nonneg b_bar hA_bar (hr _ rfl).1 h0b (hr _ rfl).2) in
      ⟨o.1, option.cases_on o.1 (is_unbounded_swap hA_bar (ne_of_lt (hr r rfl).1).symm)
        (λ P, is_optimal_basis_swap S (has_left_inverse_swap_inverse hA_bar
          (ne_of_lt (hr r rfl).1).symm))
        o.2⟩
    end
  end

#print simplex.simplex._main._pack
#print acc

def rel (A : matrix (fin m) (fin n) ℚ) (b : cvec m) (c : rvec n) :
  prebasis m n → prebasis m n → Prop :=
tc (λ B C, ∃ hs : (choose_pivot_column B
    (inverse (A ⬝ B.basis.to_matrixᵀ) ⬝ A) (inverse (A ⬝ B.basis.to_matrixᵀ) ⬝ b) c).is_some,
  ∃ hr : (choose_pivot_row B
    (inverse (A ⬝ B.basis.to_matrixᵀ) ⬝ A) (inverse (A ⬝ B.basis.to_matrixᵀ) ⬝ b)
      c (option.get hs)).is_some,
  C = B.swap (option.get hr) (option.get hs))

-- #eval inverse (list.to_matrix 3 3
--   [[1,2,3],[0,1,5],[0,0,1]])

-- def ex.A := list.to_matrix 2 5 [[1,1,0,1,0],
--                                 [0,1,-1,0,1]]

-- def ex.b : cvec 2 := (λ i _, (list.nth_le [8,0] i sorry))

-- def ex.c : rvec 5 := λ _ i, (list.nth_le [1, 1, 1, 0, 0] i sorry)

-- def ex.B : prebasis 2 5 :=
--   ⟨pequiv_of_vector ⟨[3, 4], rfl⟩ dec_trivial,
--     pre_nonbasis_of_vector ⟨[3, 4], rfl⟩ dec_trivial, sorry, sorry, sorry⟩

-- #eval ex.A ⬝ ex.B.basis.to_matrixᵀ

-- -- #eval (simplex ex.B ex.A ex.b ex.c dec_trivial dec_trivial).1

-- def ex.A := list.to_matrix 3 7 [[1/4, - 8, -  1, 9, 1, 0, 0],
--                                 [1/2, -12, -1/2, 3, 0, 1, 0],
--                                 [  0,   0,    1, 0, 0, 0, 1]]

-- def ex.b : cvec 3 := (λ i _, list.nth_le [0,0,1] i sorry)
-- --#eval ex.b
-- def ex.c : rvec 7 := λ _ i, (list.nth_le [3/4, -20, 1/2, -6, 0, 0, 0] i sorry)
-- --#eval ex.c
-- def ex.B : prebasis 3 7 :=
--   ⟨pequiv_of_vector ⟨[4, 5, 6], rfl⟩ dec_trivial,
--     pre_nonbasis_of_vector ⟨[4,5,6], rfl⟩ dec_trivial, sorry, sorry, sorry⟩

-- #eval (simplex ex.B ex.A ex.b ex.c dec_trivial dec_trivial).1.is_some

-- #eval (find_optimal_solution_from_starting_basis ex.A ex.c ex.b ex.B)
-- --set_option trace.fun_info true
-- #eval (is_optimal_bool ex.A ex.c ex.b ex.B)

-- -- (some [[2064/445]])
-- -- (some [[6401/1895]])
-- #eval (is_feasible_basis ex.A ex.c ex.b ex.B : bool)
-- -- #eval (show matrix _ _ ℚ, from minor ex.A id ex.B.read) *
-- --   _root_.inverse (show matrix _ _ ℚ, from minor ex.A id ex.B.read )
-- -- #eval ((1 : cvec 1) - (minor ex.c id ex.B.read) ⬝
-- --   _root_.inverse (minor ex.A id ex.B.read) ⬝
-- --   (minor ex.A id ex.NB.read))

-- #eval finishing_basis ex.A ex.c ex.b ex.B

-- #eval test ex.A ex.c ex.b ex.B

-- #eval (let x : cvec 4 := λ i _, list.nth_le [0, 80/89, 62/89, 196/89] i sorry in
--   let A := list.to_matrix 3 4 [[12, -1, 1, 1],
--                      [1, 1.45, 1, 0],
--                      [1, 2, 0, 1]]
--                      in A ⬝ x
--  )


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

! This file was ported from Lean 3 source module category_theory.limits.creates
! leanprover-community/mathlib commit fe5e4ce6c72d96d77ad40ac832a6e7f8040990bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Preserves.Basic

/-!
# Creating (co)limits

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

open CategoryTheory CategoryTheory.Limits

noncomputable section

namespace CategoryTheory

universe w' w v₁ v₂ v₃ u₁ u₂ u₃

variable {C : Type u₁} [Category.{v₁} C]

section Creates

variable {D : Type u₂} [Category.{v₂} D]

variable {J : Type w} [Category.{w'} J] {K : J ⥤ C}

/-- 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 LiftableCone (K : J ⥤ C) (F : C ⥤ D) (c : Cone (K ⋙ F)) where
  /-- a cone in the source category of the functor -/
  liftedCone : Cone K
  /-- the isomorphism expressing that `liftedCone` lifts the given cone -/
  validLift : F.mapCone liftedCone ≅ c
#align category_theory.liftable_cone CategoryTheory.LiftableCone

/-- 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 LiftableCocone (K : J ⥤ C) (F : C ⥤ D) (c : Cocone (K ⋙ F)) where
  /-- a cocone in the source category of the functor -/
  liftedCocone : Cocone K
  /-- the isomorphism expressing that `liftedCocone` lifts the given cocone -/
  validLift : F.mapCocone liftedCocone ≅ c
#align category_theory.liftable_cocone CategoryTheory.LiftableCocone

/-- 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 `createsLimitOfReflectsIso`.
-/
class CreatesLimit (K : J ⥤ C) (F : C ⥤ D) extends ReflectsLimit K F where
  /-- any limit cone can be lifted to a cone above -/
  lifts : ∀ c, IsLimit c → LiftableCone K F c
#align category_theory.creates_limit CategoryTheory.CreatesLimit

/-- `F` creates limits of shape `J` if `F` creates the limit of any diagram
`K : J ⥤ C`.
-/
class CreatesLimitsOfShape (J : Type w) [Category.{w'} J] (F : C ⥤ D) where
  CreatesLimit : ∀ {K : J ⥤ C}, CreatesLimit K F := by infer_instance
#align category_theory.creates_limits_of_shape CategoryTheory.CreatesLimitsOfShape

-- This should be used with explicit universe variables.
/-- `F` creates limits if it creates limits of shape `J` for any `J`. -/
@[nolint checkUnivs]
class CreatesLimitsOfSize (F : C ⥤ D) where
  CreatesLimitsOfShape : ∀ {J : Type w} [Category.{w'} J], CreatesLimitsOfShape J F := by
    infer_instance
#align category_theory.creates_limits_of_size CategoryTheory.CreatesLimitsOfSize

/-- `F` creates small limits if it creates limits of shape `J` for any small `J`. -/
abbrev CreatesLimits (F : C ⥤ D) :=
  CreatesLimitsOfSize.{v₂, v₂} F
#align category_theory.creates_limits CategoryTheory.CreatesLimits

/-- 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 `createsColimitOfReflectsIso`.
-/
class CreatesColimit (K : J ⥤ C) (F : C ⥤ D) extends ReflectsColimit K F where
  /-- any limit cocone can be lifted to a cocone above -/
  lifts : ∀ c, IsColimit c → LiftableCocone K F c
#align category_theory.creates_colimit CategoryTheory.CreatesColimit

/-- `F` creates colimits of shape `J` if `F` creates the colimit of any diagram
`K : J ⥤ C`.
-/
class CreatesColimitsOfShape (J : Type w) [Category.{w'} J] (F : C ⥤ D) where
  CreatesColimit : ∀ {K : J ⥤ C}, CreatesColimit K F := by infer_instance
#align category_theory.creates_colimits_of_shape CategoryTheory.CreatesColimitsOfShape

-- This should be used with explicit universe variables.
/-- `F` creates colimits if it creates colimits of shape `J` for any small `J`. -/
@[nolint checkUnivs]
class CreatesColimitsOfSize (F : C ⥤ D) where
  CreatesColimitsOfShape : ∀ {J : Type w} [Category.{w'} J], CreatesColimitsOfShape J F := by
    infer_instance
#align category_theory.creates_colimits_of_size CategoryTheory.CreatesColimitsOfSize

/-- `F` creates small colimits if it creates colimits of shape `J` for any small `J`. -/
abbrev CreatesColimits (F : C ⥤ D) :=
  CreatesColimitsOfSize.{v₂, v₂} F
#align category_theory.creates_colimits CategoryTheory.CreatesColimits

attribute [instance] CreatesLimitsOfShape.CreatesLimit CreatesLimitsOfSize.CreatesLimitsOfShape
  CreatesColimitsOfShape.CreatesColimit CreatesColimitsOfSize.CreatesColimitsOfShape

-- see Note [lower instance priority]
-- Interface to the `CreatesLimit` class.
/-- `liftLimit t` is the cone for `K` given by lifting the limit `t` for `K ⋙ F`. -/
def liftLimit {K : J ⥤ C} {F : C ⥤ D} [CreatesLimit K F] {c : Cone (K ⋙ F)} (t : IsLimit c) :
    Cone K :=
  (CreatesLimit.lifts c t).liftedCone
#align category_theory.lift_limit CategoryTheory.liftLimit

/-- The lifted cone has an image isomorphic to the original cone. -/
def liftedLimitMapsToOriginal {K : J ⥤ C} {F : C ⥤ D} [CreatesLimit K F] {c : Cone (K ⋙ F)}
    (t : IsLimit c) : F.mapCone (liftLimit t) ≅ c :=
  (CreatesLimit.lifts c t).validLift
#align category_theory.lifted_limit_maps_to_original CategoryTheory.liftedLimitMapsToOriginal

/-- The lifted cone is a limit. -/
def liftedLimitIsLimit {K : J ⥤ C} {F : C ⥤ D} [CreatesLimit K F] {c : Cone (K ⋙ F)}
    (t : IsLimit c) : IsLimit (liftLimit t) :=
  ReflectsLimit.reflects (IsLimit.ofIsoLimit t (liftedLimitMapsToOriginal t).symm)
#align category_theory.lifted_limit_is_limit CategoryTheory.liftedLimitIsLimit

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
theorem hasLimit_of_created (K : J ⥤ C) (F : C ⥤ D) [HasLimit (K ⋙ F)] [CreatesLimit K F] :
    HasLimit K :=
  HasLimit.mk
    { cone := liftLimit (limit.isLimit (K ⋙ F))
      isLimit := liftedLimitIsLimit _ }
#align category_theory.has_limit_of_created CategoryTheory.hasLimit_of_created

/-- If `F` creates limits of shape `J`, and `D` has limits of shape `J`, then
`C` has limits of shape `J`.
-/
theorem hasLimitsOfShape_of_hasLimitsOfShape_createsLimitsOfShape (F : C ⥤ D) [HasLimitsOfShape J D]
    [CreatesLimitsOfShape J F] : HasLimitsOfShape J C :=
  ⟨fun G => hasLimit_of_created G F⟩
#align category_theory.has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape CategoryTheory.hasLimitsOfShape_of_hasLimitsOfShape_createsLimitsOfShape

/-- If `F` creates limits, and `D` has all limits, then `C` has all limits. -/
theorem has_limits_of_has_limits_creates_limits (F : C ⥤ D) [HasLimitsOfSize.{w, w'} D]
    [CreatesLimitsOfSize.{w, w'} F] : HasLimitsOfSize.{w, w'} C :=
  ⟨fun _ _ => hasLimitsOfShape_of_hasLimitsOfShape_createsLimitsOfShape F⟩
#align category_theory.has_limits_of_has_limits_creates_limits CategoryTheory.has_limits_of_has_limits_creates_limits

-- Interface to the `CreatesColimit` class.
/-- `liftColimit t` is the cocone for `K` given by lifting the colimit `t` for `K ⋙ F`. -/
def liftColimit {K : J ⥤ C} {F : C ⥤ D} [CreatesColimit K F] {c : Cocone (K ⋙ F)}
    (t : IsColimit c) : Cocone K :=
  (CreatesColimit.lifts c t).liftedCocone
#align category_theory.lift_colimit CategoryTheory.liftColimit

/-- The lifted cocone has an image isomorphic to the original cocone. -/
def liftedColimitMapsToOriginal {K : J ⥤ C} {F : C ⥤ D} [CreatesColimit K F] {c : Cocone (K ⋙ F)}
    (t : IsColimit c) : F.mapCocone (liftColimit t) ≅ c :=
  (CreatesColimit.lifts c t).validLift
#align category_theory.lifted_colimit_maps_to_original CategoryTheory.liftedColimitMapsToOriginal

/-- The lifted cocone is a colimit. -/
def liftedColimitIsColimit {K : J ⥤ C} {F : C ⥤ D} [CreatesColimit K F] {c : Cocone (K ⋙ F)}
    (t : IsColimit c) : IsColimit (liftColimit t) :=
  ReflectsColimit.reflects (IsColimit.ofIsoColimit t (liftedColimitMapsToOriginal t).symm)
#align category_theory.lifted_colimit_is_colimit CategoryTheory.liftedColimitIsColimit

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
theorem hasColimit_of_created (K : J ⥤ C) (F : C ⥤ D) [HasColimit (K ⋙ F)] [CreatesColimit K F] :
    HasColimit K :=
  HasColimit.mk
    { cocone := liftColimit (colimit.isColimit (K ⋙ F))
      isColimit := liftedColimitIsColimit _ }
#align category_theory.has_colimit_of_created CategoryTheory.hasColimit_of_created

/-- If `F` creates colimits of shape `J`, and `D` has colimits of shape `J`, then
`C` has colimits of shape `J`.
-/
theorem hasColimitsOfShape_of_hasColimitsOfShape_createsColimitsOfShape (F : C ⥤ D)
    [HasColimitsOfShape J D] [CreatesColimitsOfShape J F] : HasColimitsOfShape J C :=
  ⟨fun G => hasColimit_of_created G F⟩
#align category_theory.has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape CategoryTheory.hasColimitsOfShape_of_hasColimitsOfShape_createsColimitsOfShape

/-- If `F` creates colimits, and `D` has all colimits, then `C` has all colimits. -/
theorem has_colimits_of_has_colimits_creates_colimits (F : C ⥤ D) [HasColimitsOfSize.{w, w'} D]
    [CreatesColimitsOfSize.{w, w'} F] : HasColimitsOfSize.{w, w'} C :=
  ⟨fun _ _ => hasColimitsOfShape_of_hasColimitsOfShape_createsColimitsOfShape F⟩
#align category_theory.has_colimits_of_has_colimits_creates_colimits CategoryTheory.has_colimits_of_has_colimits_creates_colimits

instance (priority := 10) reflectsLimitsOfShapeOfCreatesLimitsOfShape (F : C ⥤ D)
    [CreatesLimitsOfShape J F] : ReflectsLimitsOfShape J F where
#align category_theory.reflects_limits_of_shape_of_creates_limits_of_shape CategoryTheory.reflectsLimitsOfShapeOfCreatesLimitsOfShape

instance (priority := 10) reflectsLimitsOfCreatesLimits (F : C ⥤ D)
    [CreatesLimitsOfSize.{w, w'} F] : ReflectsLimitsOfSize.{w, w'} F where
#align category_theory.reflects_limits_of_creates_limits CategoryTheory.reflectsLimitsOfCreatesLimits

instance (priority := 10) reflectsColimitsOfShapeOfCreatesColimitsOfShape (F : C ⥤ D)
    [CreatesColimitsOfShape J F] : ReflectsColimitsOfShape J F where
#align category_theory.reflects_colimits_of_shape_of_creates_colimits_of_shape CategoryTheory.reflectsColimitsOfShapeOfCreatesColimitsOfShape

instance (priority := 10) reflectsColimitsOfCreatesColimits (F : C ⥤ D)
    [CreatesColimitsOfSize.{w, w'} F] : ReflectsColimitsOfSize.{w, w'} F where
#align category_theory.reflects_colimits_of_creates_colimits CategoryTheory.reflectsColimitsOfCreatesColimits

/-- 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 LiftsToLimit (K : J ⥤ C) (F : C ⥤ D) (c : Cone (K ⋙ F)) (t : IsLimit c) extends
  LiftableCone K F c where
  /-- the lifted cone is limit -/
  makesLimit : IsLimit liftedCone
#align category_theory.lifts_to_limit CategoryTheory.LiftsToLimit

/-- 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 LiftsToColimit (K : J ⥤ C) (F : C ⥤ D) (c : Cocone (K ⋙ F)) (t : IsColimit c) extends
  LiftableCocone K F c where
  /-- the lifted cocone is colimit -/
  makesColimit : IsColimit liftedCocone
#align category_theory.lifts_to_colimit CategoryTheory.LiftsToColimit

/-- 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 createsLimitOfReflectsIso {K : J ⥤ C} {F : C ⥤ D} [ReflectsIsomorphisms F]
    (h : ∀ c t, LiftsToLimit K F c t) : CreatesLimit K F
    where
  lifts c t := (h c t).toLiftableCone
  toReflectsLimit :=
    { reflects := fun {d} hd => by
        let d' : Cone K := (h (F.mapCone d) hd).toLiftableCone.liftedCone
        let i : F.mapCone d' ≅ F.mapCone d :=
          (h (F.mapCone d) hd).toLiftableCone.validLift
        let hd' : IsLimit d' := (h (F.mapCone d) hd).makesLimit
        let f : d ⟶ d' := hd'.liftConeMorphism d
        have : (Cones.functoriality K F).map f = i.inv :=
          (hd.ofIsoLimit i.symm).uniq_cone_morphism
        haveI : IsIso ((Cones.functoriality K F).map f) :=
          by
          rw [this]
          infer_instance
        haveI : IsIso f := isIso_of_reflects_iso f (Cones.functoriality K F)
        exact IsLimit.ofIsoLimit hd' (asIso f).symm }
#align category_theory.creates_limit_of_reflects_iso CategoryTheory.createsLimitOfReflectsIso

-- 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.
/--
When `F` is fully faithful, to show that `F` creates the limit for `K` it suffices to exhibit a lift
of a limit cone for `K ⋙ F`.
-/
def createsLimitOfFullyFaithfulOfLift' {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    {l : Cone (K ⋙ F)} (hl : IsLimit l) (c : Cone K) (i : F.mapCone c ≅ l) :
    CreatesLimit K F :=
  createsLimitOfReflectsIso fun _ t =>
    { liftedCone := c
      validLift := i ≪≫ IsLimit.uniqueUpToIso hl t
      makesLimit :=
        IsLimit.ofFaithful F (IsLimit.ofIsoLimit hl i.symm) _ fun _ => F.image_preimage _ }
#align category_theory.creates_limit_of_fully_faithful_of_lift' CategoryTheory.createsLimitOfFullyFaithfulOfLift'

-- 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.
/-- When `F` is fully faithful, and `HasLimit (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`.
-/
def createsLimitOfFullyFaithfulOfLift {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    [HasLimit (K ⋙ F)] (c : Cone K) (i : F.mapCone c ≅ limit.cone (K ⋙ F)) :
    CreatesLimit K F :=
  createsLimitOfFullyFaithfulOfLift' (limit.isLimit _) c i
#align category_theory.creates_limit_of_fully_faithful_of_lift CategoryTheory.createsLimitOfFullyFaithfulOfLift

-- 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.
/--
When `F` is fully faithful, to show that `F` creates the limit for `K` it suffices to show that a
limit point is in the essential image of `F`.
-/
def createsLimitOfFullyFaithfulOfIso' {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    {l : Cone (K ⋙ F)} (hl : IsLimit l) (X : C) (i : F.obj X ≅ l.pt) : CreatesLimit K F :=
  createsLimitOfFullyFaithfulOfLift' hl
    { pt := X
      π :=
        { app := fun j => F.preimage (i.hom ≫ l.π.app j)
          naturality := fun Y Z f =>
            F.map_injective <| by
              dsimp
              simpa using (l.w f).symm } }
    (Cones.ext i fun j => by simp only [Functor.image_preimage, Functor.mapCone_π_app])
#align category_theory.creates_limit_of_fully_faithful_of_iso' CategoryTheory.createsLimitOfFullyFaithfulOfIso'

-- 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.
/-- When `F` is fully faithful, and `HasLimit (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`.
-/
def createsLimitOfFullyFaithfulOfIso {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    [HasLimit (K ⋙ F)] (X : C) (i : F.obj X ≅ limit (K ⋙ F)) : CreatesLimit K F :=
  createsLimitOfFullyFaithfulOfIso' (limit.isLimit _) X i
#align category_theory.creates_limit_of_fully_faithful_of_iso CategoryTheory.createsLimitOfFullyFaithfulOfIso

-- see Note [lower instance priority]
/-- `F` preserves the limit of `K` if it creates the limit and `K ⋙ F` has the limit. -/
instance (priority := 100) preservesLimitOfCreatesLimitAndHasLimit (K : J ⥤ C) (F : C ⥤ D)
    [CreatesLimit K F] [HasLimit (K ⋙ F)] : PreservesLimit K F where
  preserves t := IsLimit.ofIsoLimit (limit.isLimit _)
    ((liftedLimitMapsToOriginal (limit.isLimit _)).symm ≪≫
      (Cones.functoriality K F).mapIso ((liftedLimitIsLimit (limit.isLimit _)).uniqueUpToIso t))
#align category_theory.preserves_limit_of_creates_limit_and_has_limit CategoryTheory.preservesLimitOfCreatesLimitAndHasLimit

-- see Note [lower instance priority]
/-- `F` preserves the limit of shape `J` if it creates these limits and `D` has them. -/
instance (priority := 100) preservesLimitOfShapeOfCreatesLimitsOfShapeAndHasLimitsOfShape
    (F : C ⥤ D) [CreatesLimitsOfShape J F] [HasLimitsOfShape J D] : PreservesLimitsOfShape J F where
#align category_theory.preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape CategoryTheory.preservesLimitOfShapeOfCreatesLimitsOfShapeAndHasLimitsOfShape

-- see Note [lower instance priority]
/-- `F` preserves limits if it creates limits and `D` has limits. -/
instance (priority := 100) preservesLimitsOfCreatesLimitsAndHasLimits (F : C ⥤ D)
    [CreatesLimitsOfSize.{w, w'} F] [HasLimitsOfSize.{w, w'} D] : PreservesLimitsOfSize.{w, w'} F
    where
#align category_theory.preserves_limits_of_creates_limits_and_has_limits CategoryTheory.preservesLimitsOfCreatesLimitsAndHasLimits

/-- If `F` reflects isomorphisms and we can lift any colimit cocone to a colimit cocone,
then `F` creates colimits.
In particular here we don't need to assume that F reflects colimits.
-/
def createsColimitOfReflectsIso {K : J ⥤ C} {F : C ⥤ D} [ReflectsIsomorphisms F]
    (h : ∀ c t, LiftsToColimit K F c t) : CreatesColimit K F
    where
  lifts c t := (h c t).toLiftableCocone
  toReflectsColimit :=
    {
      reflects := fun {d} hd => by
        let d' : Cocone K := (h (F.mapCocone d) hd).toLiftableCocone.liftedCocone
        let i : F.mapCocone d' ≅ F.mapCocone d :=
          (h (F.mapCocone d) hd).toLiftableCocone.validLift
        let hd' : IsColimit d' := (h (F.mapCocone d) hd).makesColimit
        let f : d' ⟶ d := hd'.descCoconeMorphism d
        have : (Cocones.functoriality K F).map f = i.hom :=
          (hd.ofIsoColimit i.symm).uniq_cocone_morphism
        haveI : IsIso ((Cocones.functoriality K F).map f) :=
          by
          rw [this]
          infer_instance
        haveI := isIso_of_reflects_iso f (Cocones.functoriality K F)
        exact IsColimit.ofIsoColimit hd' (asIso f) }
#align category_theory.creates_colimit_of_reflects_iso CategoryTheory.createsColimitOfReflectsIso

-- Notice however that even if the isomorphism is `Iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
/--
When `F` is fully faithful, to show that `F` creates the colimit for `K` it suffices to exhibit a
lift of a colimit cocone for `K ⋙ F`.
-/
def createsColimitOfFullyFaithfulOfLift' {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    {l : Cocone (K ⋙ F)} (hl : IsColimit l) (c : Cocone K) (i : F.mapCocone c ≅ l) :
    CreatesColimit K F :=
  createsColimitOfReflectsIso fun _ t =>
    { liftedCocone := c
      validLift := i ≪≫ IsColimit.uniqueUpToIso hl t
      makesColimit :=
        IsColimit.ofFaithful F (IsColimit.ofIsoColimit hl i.symm) _ fun _ => F.image_preimage _ }
#align category_theory.creates_colimit_of_fully_faithful_of_lift' CategoryTheory.createsColimitOfFullyFaithfulOfLift'

-- Notice however that even if the isomorphism is `Iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
/--
When `F` is fully faithful, and `HasColimit (K ⋙ F)`, to show that `F` creates the colimit for `K`
it suffices to exhibit a lift of the chosen colimit cocone for `K ⋙ F`.
-/
def createsColimitOfFullyFaithfulOfLift {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    [HasColimit (K ⋙ F)] (c : Cocone K) (i : F.mapCocone c ≅ colimit.cocone (K ⋙ F)) :
    CreatesColimit K F :=
  createsColimitOfFullyFaithfulOfLift' (colimit.isColimit _) c i
#align category_theory.creates_colimit_of_fully_faithful_of_lift CategoryTheory.createsColimitOfFullyFaithfulOfLift

-- Notice however that even if the isomorphism is `Iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
/--
When `F` is fully faithful, to show that `F` creates the colimit for `K` it suffices to show that
a colimit point is in the essential image of `F`.
-/
def createsColimitOfFullyFaithfulOfIso' {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    {l : Cocone (K ⋙ F)} (hl : IsColimit l) (X : C) (i : F.obj X ≅ l.pt) : CreatesColimit K F :=
  createsColimitOfFullyFaithfulOfLift' hl
    { pt := X
      ι :=
        { app := fun j => F.preimage (l.ι.app j ≫ i.inv)
          naturality := fun Y Z f =>
            F.map_injective <| by
              dsimp
              simpa [← cancel_mono i.hom] using l.w f } }
    (Cocones.ext i fun j => by simp)
#align category_theory.creates_colimit_of_fully_faithful_of_iso' CategoryTheory.createsColimitOfFullyFaithfulOfIso'

-- Notice however that even if the isomorphism is `Iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
/--
When `F` is fully faithful, and `HasColimit (K ⋙ F)`, to show that `F` creates the colimit for `K`
it suffices to show that the chosen colimit point is in the essential image of `F`.
-/
def createsColimitOfFullyFaithfulOfIso {K : J ⥤ C} {F : C ⥤ D} [Full F] [Faithful F]
    [HasColimit (K ⋙ F)] (X : C) (i : F.obj X ≅ colimit (K ⋙ F)) : CreatesColimit K F :=
  createsColimitOfFullyFaithfulOfIso' (colimit.isColimit _) X i
#align category_theory.creates_colimit_of_fully_faithful_of_iso CategoryTheory.createsColimitOfFullyFaithfulOfIso

-- see Note [lower instance priority]
/-- `F` preserves the colimit of `K` if it creates the colimit and `K ⋙ F` has the colimit. -/
instance (priority := 100) preservesColimitOfCreatesColimitAndHasColimit (K : J ⥤ C) (F : C ⥤ D)
    [CreatesColimit K F] [HasColimit (K ⋙ F)] : PreservesColimit K F where
  preserves t :=
    IsColimit.ofIsoColimit (colimit.isColimit _)
      ((liftedColimitMapsToOriginal (colimit.isColimit _)).symm ≪≫
        (Cocones.functoriality K F).mapIso
          ((liftedColimitIsColimit (colimit.isColimit _)).uniqueUpToIso t))
#align category_theory.preserves_colimit_of_creates_colimit_and_has_colimit CategoryTheory.preservesColimitOfCreatesColimitAndHasColimit

-- see Note [lower instance priority]
/-- `F` preserves the colimit of shape `J` if it creates these colimits and `D` has them. -/
instance (priority := 100) preservesColimitOfShapeOfCreatesColimitsOfShapeAndHasColimitsOfShape
    (F : C ⥤ D) [CreatesColimitsOfShape J F] [HasColimitsOfShape J D] : PreservesColimitsOfShape J F
    where
#align category_theory.preserves_colimit_of_shape_of_creates_colimits_of_shape_and_has_colimits_of_shape CategoryTheory.preservesColimitOfShapeOfCreatesColimitsOfShapeAndHasColimitsOfShape

-- see Note [lower instance priority]
/-- `F` preserves limits if it creates limits and `D` has limits. -/
instance (priority := 100) preservesColimitsOfCreatesColimitsAndHasColimits (F : C ⥤ D)
    [CreatesColimitsOfSize.{w, w'} F] [HasColimitsOfSize.{w, w'} D] :
    PreservesColimitsOfSize.{w, w'} F where
#align category_theory.preserves_colimits_of_creates_colimits_and_has_colimits CategoryTheory.preservesColimitsOfCreatesColimitsAndHasColimits

/-- Transfer creation of limits along a natural isomorphism in the diagram. -/
def createsLimitOfIsoDiagram {K₁ K₂ : J ⥤ C} (F : C ⥤ D) (h : K₁ ≅ K₂) [CreatesLimit K₁ F] :
    CreatesLimit K₂ F :=
  { reflectsLimitOfIsoDiagram F h with
    lifts := fun c t =>
      let t' := (IsLimit.postcomposeInvEquiv (isoWhiskerRight h F : _) c).symm t
      { liftedCone := (Cones.postcompose h.hom).obj (liftLimit t')
        validLift :=
          Functor.mapConePostcompose F ≪≫
            (Cones.postcompose (isoWhiskerRight h F).hom).mapIso (liftedLimitMapsToOriginal t') ≪≫
              Cones.ext (Iso.refl _) fun j => by
                dsimp
                rw [Category.assoc, ← F.map_comp]
                simp } }
#align category_theory.creates_limit_of_iso_diagram CategoryTheory.createsLimitOfIsoDiagram

/-- If `F` creates the limit of `K` and `F ≅ G`, then `G` creates the limit of `K`. -/
def createsLimitOfNatIso {F G : C ⥤ D} (h : F ≅ G) [CreatesLimit K F] : CreatesLimit K G
    where
  lifts c t :=
    { liftedCone := liftLimit ((IsLimit.postcomposeInvEquiv (isoWhiskerLeft K h : _) c).symm t)
      validLift := by
        refine' (IsLimit.mapConeEquiv h _).uniqueUpToIso t
        apply IsLimit.ofIsoLimit _ (liftedLimitMapsToOriginal _).symm
        apply (IsLimit.postcomposeInvEquiv _ _).symm t }
  toReflectsLimit := reflectsLimitOfNatIso _ h
#align category_theory.creates_limit_of_nat_iso CategoryTheory.createsLimitOfNatIso

/-- If `F` creates limits of shape `J` and `F ≅ G`, then `G` creates limits of shape `J`. -/
def createsLimitsOfShapeOfNatIso {F G : C ⥤ D} (h : F ≅ G) [CreatesLimitsOfShape J F] :
    CreatesLimitsOfShape J G where CreatesLimit := createsLimitOfNatIso h
#align category_theory.creates_limits_of_shape_of_nat_iso CategoryTheory.createsLimitsOfShapeOfNatIso

/-- If `F` creates limits and `F ≅ G`, then `G` creates limits. -/
def createsLimitsOfNatIso {F G : C ⥤ D} (h : F ≅ G) [CreatesLimitsOfSize.{w, w'} F] :
    CreatesLimitsOfSize.{w, w'} G
    where CreatesLimitsOfShape := createsLimitsOfShapeOfNatIso h
#align category_theory.creates_limits_of_nat_iso CategoryTheory.createsLimitsOfNatIso

/-- Transfer creation of colimits along a natural isomorphism in the diagram. -/
def createsColimitOfIsoDiagram {K₁ K₂ : J ⥤ C} (F : C ⥤ D) (h : K₁ ≅ K₂) [CreatesColimit K₁ F] :
    CreatesColimit K₂ F :=
  { reflectsColimitOfIsoDiagram F h with
    lifts := fun c t =>
      let t' := (IsColimit.precomposeHomEquiv (isoWhiskerRight h F : _) c).symm t
      { liftedCocone := (Cocones.precompose h.inv).obj (liftColimit t')
        validLift :=
          Functor.mapCoconePrecompose F ≪≫
            (Cocones.precompose (isoWhiskerRight h F).inv).mapIso
                (liftedColimitMapsToOriginal t') ≪≫
              Cocones.ext (Iso.refl _) fun j => by
                dsimp
                rw [← F.map_comp_assoc]
                simp } }
#align category_theory.creates_colimit_of_iso_diagram CategoryTheory.createsColimitOfIsoDiagram

/-- If `F` creates the colimit of `K` and `F ≅ G`, then `G` creates the colimit of `K`. -/
def createsColimitOfNatIso {F G : C ⥤ D} (h : F ≅ G) [CreatesColimit K F] : CreatesColimit K G
    where
  lifts c t :=
    { liftedCocone := liftColimit ((IsColimit.precomposeHomEquiv (isoWhiskerLeft K h : _) c).symm t)
      validLift := by
        refine' (IsColimit.mapCoconeEquiv h _).uniqueUpToIso t
        apply IsColimit.ofIsoColimit _ (liftedColimitMapsToOriginal _).symm
        apply (IsColimit.precomposeHomEquiv _ _).symm t }
  toReflectsColimit := reflectsColimitOfNatIso _ h
#align category_theory.creates_colimit_of_nat_iso CategoryTheory.createsColimitOfNatIso

/-- If `F` creates colimits of shape `J` and `F ≅ G`, then `G` creates colimits of shape `J`. -/
def createsColimitsOfShapeOfNatIso {F G : C ⥤ D} (h : F ≅ G) [CreatesColimitsOfShape J F] :
    CreatesColimitsOfShape J G where CreatesColimit := createsColimitOfNatIso h
#align category_theory.creates_colimits_of_shape_of_nat_iso CategoryTheory.createsColimitsOfShapeOfNatIso

/-- If `F` creates colimits and `F ≅ G`, then `G` creates colimits. -/
def createsColimitsOfNatIso {F G : C ⥤ D} (h : F ≅ G) [CreatesColimitsOfSize.{w, w'} F] :
    CreatesColimitsOfSize.{w, w'} G
    where CreatesColimitsOfShape := createsColimitsOfShapeOfNatIso h
#align category_theory.creates_colimits_of_nat_iso CategoryTheory.createsColimitsOfNatIso

-- For the inhabited linter later.
/-- If F creates the limit of K, any cone lifts to a limit. -/
def liftsToLimitOfCreates (K : J ⥤ C) (F : C ⥤ D) [CreatesLimit K F] (c : Cone (K ⋙ F))
    (t : IsLimit c) : LiftsToLimit K F c t
    where
  liftedCone := liftLimit t
  validLift := liftedLimitMapsToOriginal t
  makesLimit := liftedLimitIsLimit t
#align category_theory.lifts_to_limit_of_creates CategoryTheory.liftsToLimitOfCreates

-- For the inhabited linter later.
/-- If F creates the colimit of K, any cocone lifts to a colimit. -/
def liftsToColimitOfCreates (K : J ⥤ C) (F : C ⥤ D) [CreatesColimit K F] (c : Cocone (K ⋙ F))
    (t : IsColimit c) : LiftsToColimit K F c t
    where
  liftedCocone := liftColimit t
  validLift := liftedColimitMapsToOriginal t
  makesColimit := liftedColimitIsColimit t
#align category_theory.lifts_to_colimit_of_creates CategoryTheory.liftsToColimitOfCreates

/-- Any cone lifts through the identity functor. -/
def idLiftsCone (c : Cone (K ⋙ 𝟭 C)) : LiftableCone K (𝟭 C) c
    where
  liftedCone :=
    { pt := c.pt
      π := c.π ≫ K.rightUnitor.hom }
  validLift := Cones.ext (Iso.refl _) (by aesop_cat)
#align category_theory.id_lifts_cone CategoryTheory.idLiftsCone

/-- The identity functor creates all limits. -/
instance idCreatesLimits : CreatesLimitsOfSize.{w, w'} (𝟭 C)
    where CreatesLimitsOfShape :=
    { CreatesLimit := { lifts := fun c _ => idLiftsCone c } }
#align category_theory.id_creates_limits CategoryTheory.idCreatesLimits

/-- Any cocone lifts through the identity functor. -/
def idLiftsCocone (c : Cocone (K ⋙ 𝟭 C)) : LiftableCocone K (𝟭 C) c
    where
  liftedCocone :=
    { pt := c.pt
      ι := K.rightUnitor.inv ≫ c.ι }
  validLift := Cocones.ext (Iso.refl _) (by aesop_cat)
#align category_theory.id_lifts_cocone CategoryTheory.idLiftsCocone

/-- The identity functor creates all colimits. -/
instance idCreatesColimits : CreatesColimitsOfSize.{w, w'} (𝟭 C)
    where CreatesColimitsOfShape :=
    { CreatesColimit := { lifts := fun c _ => idLiftsCocone c } }
#align category_theory.id_creates_colimits CategoryTheory.idCreatesColimits

/-- Satisfy the inhabited linter -/
instance inhabitedLiftableCone (c : Cone (K ⋙ 𝟭 C)) : Inhabited (LiftableCone K (𝟭 C) c) :=
  ⟨idLiftsCone c⟩
#align category_theory.inhabited_liftable_cone CategoryTheory.inhabitedLiftableCone

instance inhabitedLiftableCocone (c : Cocone (K ⋙ 𝟭 C)) : Inhabited (LiftableCocone K (𝟭 C) c) :=
  ⟨idLiftsCocone c⟩
#align category_theory.inhabited_liftable_cocone CategoryTheory.inhabitedLiftableCocone

/-- Satisfy the inhabited linter -/
instance inhabitedLiftsToLimit (K : J ⥤ C) (F : C ⥤ D) [CreatesLimit K F] (c : Cone (K ⋙ F))
    (t : IsLimit c) : Inhabited (LiftsToLimit _ _ _ t) :=
  ⟨liftsToLimitOfCreates K F c t⟩
#align category_theory.inhabited_lifts_to_limit CategoryTheory.inhabitedLiftsToLimit

instance inhabitedLiftsToColimit (K : J ⥤ C) (F : C ⥤ D) [CreatesColimit K F] (c : Cocone (K ⋙ F))
    (t : IsColimit c) : Inhabited (LiftsToColimit _ _ _ t) :=
  ⟨liftsToColimitOfCreates K F c t⟩
#align category_theory.inhabited_lifts_to_colimit CategoryTheory.inhabitedLiftsToColimit

section Comp

variable {E : Type u₃} [ℰ : Category.{v₃} E]

variable (F : C ⥤ D) (G : D ⥤ E)

instance compCreatesLimit [CreatesLimit K F] [CreatesLimit (K ⋙ F) G] :
    CreatesLimit K (F ⋙ G) where
  lifts c t := by
    let c' : Cone ((K ⋙ F) ⋙ G) := c
    let t' : IsLimit c' := t
    exact
      { liftedCone := liftLimit (liftedLimitIsLimit t')
        validLift := (Cones.functoriality (K ⋙ F) G).mapIso
            (liftedLimitMapsToOriginal (liftedLimitIsLimit t')) ≪≫
          liftedLimitMapsToOriginal t' }
#align category_theory.comp_creates_limit CategoryTheory.compCreatesLimit

instance compCreatesLimitsOfShape [CreatesLimitsOfShape J F] [CreatesLimitsOfShape J G] :
    CreatesLimitsOfShape J (F ⋙ G) where CreatesLimit := inferInstance
#align category_theory.comp_creates_limits_of_shape CategoryTheory.compCreatesLimitsOfShape

instance compCreatesLimits [CreatesLimitsOfSize.{w, w'} F] [CreatesLimitsOfSize.{w, w'} G] :
    CreatesLimitsOfSize.{w, w'} (F ⋙ G) where CreatesLimitsOfShape := inferInstance
#align category_theory.comp_creates_limits CategoryTheory.compCreatesLimits

instance compCreatesColimit [CreatesColimit K F] [CreatesColimit (K ⋙ F) G] :
    CreatesColimit K (F ⋙ G) where
  lifts c t :=
    let c' : Cocone ((K ⋙ F) ⋙ G) := c
    let t' : IsColimit c' := t
    { liftedCocone := liftColimit (liftedColimitIsColimit t')
      validLift :=
        (Cocones.functoriality (K ⋙ F) G).mapIso
            (liftedColimitMapsToOriginal (liftedColimitIsColimit t')) ≪≫
          liftedColimitMapsToOriginal t' }
#align category_theory.comp_creates_colimit CategoryTheory.compCreatesColimit

instance compCreatesColimitsOfShape [CreatesColimitsOfShape J F] [CreatesColimitsOfShape J G] :
    CreatesColimitsOfShape J (F ⋙ G) where CreatesColimit := inferInstance
#align category_theory.comp_creates_colimits_of_shape CategoryTheory.compCreatesColimitsOfShape

instance compCreatesColimits [CreatesColimitsOfSize.{w, w'} F] [CreatesColimitsOfSize.{w, w'} G] :
    CreatesColimitsOfSize.{w, w'} (F ⋙ G) where CreatesColimitsOfShape := inferInstance
#align category_theory.comp_creates_colimits CategoryTheory.compCreatesColimits

end Comp

end Creates

end CategoryTheory


import data.fintype

universes u v

theorem nat.of_le_succ {n m : ℕ} (H : n ≤ m.succ) : n ≤ m ∨ n = m.succ :=
(lt_or_eq_of_le H).imp nat.le_of_lt_succ id

@[elab_with_expected_type]
def nat.le_rec_on {C : ℕ → Sort u} (next : Π {n}, C n → C (n+1)) : Π {n m : ℕ}, n ≤ m → C n → C m
| n 0 H x := eq.rec_on (nat.eq_zero_of_le_zero H) x
| n (m+1) H x := or.by_cases (nat.of_le_succ H) (λ h : n ≤ m, next $ nat.le_rec_on h x) (λ h : n = m + 1, eq.rec_on h x)

theorem nat.le_rec_on_self {C : ℕ → Sort u} (next : Π n, C n → C (n+1)) {n h} (x : C n) : (nat.le_rec_on next h x : C n) = x :=
by cases n; unfold nat.le_rec_on or.by_cases; rw [dif_neg n.not_succ_le_self, dif_pos rfl]

theorem nat.le_rec_on_succ {C : ℕ → Sort u} (next : Π n, C n → C (n+1)) {n m h2} (h1) (x : C n) :
  (nat.le_rec_on next h2 x : C (m+1)) = next m (nat.le_rec_on next h1 x) :=
by conv { to_lhs, rw [nat.le_rec_on, or.by_cases, dif_pos h1] }

theorem nat.le_rec_on_succ' {C : ℕ → Sort u} (next : Π n, C n → C (n+1)) {n h} (x : C n) :
  (nat.le_rec_on next h x : C (n+1)) = next n x :=
by rw [nat.le_rec_on_succ next (le_refl n), nat.le_rec_on_self]

theorem nat.le_rec_on_trans {C : ℕ → Sort u} (next : Π n, C n → C (n+1)) {n m k} (hnm : n ≤ m) (hmk : m ≤ k) {hnk} (x : C n) :
  (nat.le_rec_on next hnk x : C k) = nat.le_rec_on next hmk (nat.le_rec_on next hnm x) :=
begin
  induction hmk with k hmk ih, { rw nat.le_rec_on_self },
  rw [nat.le_rec_on_succ _ (le_trans hnm hmk), ih, nat.le_rec_on_succ]
end

theorem nat.le_rec_on_injective {C : ℕ → Sort u} (next : Π n, C n → C (n+1)) (Hnext : ∀ n, function.injective (next n))
  {n m} (hnm : n ≤ m) : function.injective (nat.le_rec_on next hnm) :=
begin
  induction hnm with m hnm ih, { intros x y H, rwa [nat.le_rec_on_self, nat.le_rec_on_self] at H },
  intros x y H, rw [nat.le_rec_on_succ _ hnm, nat.le_rec_on_succ _ hnm] at H, exact ih (Hnext _ H)
end

theorem nat.le_rec_on_surjective {C : ℕ → Sort u} (next : Π n, C n → C (n+1)) (Hnext : ∀ n, function.surjective (next n))
  {n m} (hnm : n ≤ m) : function.surjective (nat.le_rec_on next hnm) :=
begin
  induction hnm with m hnm ih, { intros x, use x, rw nat.le_rec_on_self },
  intros x, rcases Hnext _ x with ⟨w, rfl⟩, rcases ih w with ⟨x, rfl⟩, use x, rw nat.le_rec_on_succ
end

lemma to_Prop_inj : Π {a b : bool} (H : (a : Prop) ↔ (b : Prop)), a = b
| a tt H := H.2 rfl
| a ff H := bool.eq_ff_of_ne_tt $ λ h, absurd (H.1 h) dec_trivial

def von_Neumann : ℕ → Type
| 0     := empty
| (n+1) := von_Neumann n → bool

namespace von_Neumann

def fintype_and_decidable_eq : Π n, fintype (von_Neumann n) × decidable_eq (von_Neumann n)
| 0     := (empty.fintype, empty.decidable_eq)
| (n+1) := let ⟨i1, i2⟩ := fintype_and_decidable_eq n in (@pi.fintype _ _ i1 i2 _,
    λ f g, @decidable_of_iff _ (∀ i, f i = g i) ⟨funext, λ (H:f=g) i, congr_fun H i⟩ (@fintype.decidable_forall_fintype _ i1 _ _))

instance (n) : fintype (von_Neumann n) := (fintype_and_decidable_eq n).1
instance (n) : decidable_eq (von_Neumann n) := (fintype_and_decidable_eq n).2

instance (n) : has_mem (von_Neumann n) (von_Neumann (n+1)) := ⟨λ u f, f u⟩

@[extensionality] theorem ext {n} {f g : von_Neumann (n+1)} (H : ∀ s, s ∈ f ↔ s ∈ g) : f = g :=
funext $ λ s, to_Prop_inj (H s)

def next : Π {n}, von_Neumann n → von_Neumann (n+1)
| (n+1) f := λ t, ∃ u ∈ f, next u = t

theorem mem_next {n} (f s : von_Neumann (n+1)) : s ∈ next f ↔ ∃ u ∈ f, next u = s :=
bool.coe_to_bool _

theorem next_inj : ∀ n, function.injective (@next n)
| (n+1) f g H := funext $ λ s, to_Prop_inj
    ⟨λ hfs, have _ := congr_fun H (next s), let ⟨u, hug, hnus⟩ := (bool.to_bool_eq.1 this).1 ⟨s, hfs, rfl⟩ in next_inj n hnus ▸ hug,
    λ hgs, have _ := congr_fun H (next s), let ⟨u, huf, hnus⟩ := (bool.to_bool_eq.1 this).2 ⟨s, hgs, rfl⟩ in next_inj n hnus ▸ huf⟩

theorem next_mem_next {n} (f : von_Neumann (n+1)) (s) : next s ∈ next f ↔ s ∈ f :=
(mem_next _ _).trans ⟨λ ⟨u, huf, hus⟩, next_inj n hus ▸ huf, λ hsf, ⟨s, hsf, rfl⟩⟩

def Next {n m} (H : n ≤ m) : von_Neumann n → von_Neumann m :=
nat.le_rec_on (λ n, next) H

theorem Next_self {n h} (x : von_Neumann n) : Next h x = x := nat.le_rec_on_self _ _
theorem Next_succ {n m h2} (h1 : n ≤ m) (x) : Next h2 x = next (Next h1 x) := nat.le_rec_on_succ _ _ _
theorem Next_succ' {n h} (x : von_Neumann n) : Next h x = next x := nat.le_rec_on_succ' _ _
theorem Next_trans {n m k} (h1 : n ≤ m) (h2 : m ≤ k) {h3} (x) : Next h3 x = Next h2 (Next h1 x) := nat.le_rec_on_trans _ _ _ _
theorem Next_trans' {n m k} (h1 : n ≤ m) (h2 : m ≤ k) (x) : Next h2 (Next h1 x) = Next (le_trans h1 h2) x := (Next_trans _ _ _).symm

theorem Next_inj {n m} (H : n ≤ m) : function.injective (Next H) :=
by unfold Next; convert nat.le_rec_on_injective _ next_inj H; ext; refl

instance : setoid Σ n, von_Neumann n :=
{ r := λ S T, Next (le_max_left _ _) S.2 = Next (le_max_right _ _) T.2,
  iseqv := ⟨λ _, rfl, λ ⟨m,s⟩ ⟨n,t⟩ H, Next_inj (le_of_eq $ max_comm _ _) $ by rw [Next_trans', Next_trans', H],
    λ ⟨m,s⟩ ⟨n,t⟩ ⟨p,u⟩ h1 h2, have h3 : _ := congr_arg (Next $ le_max_left _ p) h1,
    have h4 : _ := congr_arg (Next $ max_le (le_trans (le_max_right m _) (le_max_left _ _)) (le_max_right _ _)) h2,
    Next_inj (max_le (le_trans (le_max_left _ n) (le_max_left _ _)) (le_max_right _ _)) $
    by rw [Next_trans', Next_trans'] at h3 h4 ⊢; exact h3.trans h4⟩ }

theorem Next_mem_Next {n m h1} {h2 : n+1 ≤ m+1} {s} {f : von_Neumann (n+1)} : Next h1 s ∈ Next h2 f ↔ s ∈ f :=
begin
  induction h1 with m hnm ih, { rw [Next_self, Next_self] },
  rw [Next_succ hnm, Next_succ (nat.succ_le_succ hnm), next_mem_next, ih]
end

theorem Next_mem_Next_symm {n m} (h1 : n ≤ m) {s} {f : von_Neumann (n+1)} : s ∈ f ↔ Next h1 s ∈ Next (nat.succ_le_succ h1) f :=
Next_mem_Next.symm

end von_Neumann

/-- Hereditarily finite sets. V[ω]. -/
def hfs : Type :=
quotient von_Neumann.setoid

namespace hfs

--def aux {n} (m) : n ≤ m → von_Neumann n → von_Neumann m := von_Neumann.Next
--theorem a {n m} (h : n ≤ m) {x} : von_Neumann.Next h x = aux m h x := rfl

instance : has_mem hfs hfs :=
⟨λ s f, quotient.lift_on₂ s f (λ s f, von_Neumann.Next (le_max_left _ f.1) s.2 ∈ von_Neumann.Next (nat.le_succ_of_le (le_max_right s.1 _)) f.2) $
λ s₁ f₁ s₂ f₂ hs hf, have hs' : _ := congr_arg (von_Neumann.Next (le_max_left _ (max f₁.1 f₂.1))) hs,
have hf' : _ := congr_arg (von_Neumann.Next (le_max_right (max s₁.1 s₂.1) _)) hf,
show (_ ∈ _) = (_ ∈ _), by rw [von_Neumann.Next_mem_Next_symm (max_le_max (le_max_left _ s₂.1) (le_max_left _ f₂.1)),
    von_Neumann.Next_mem_Next_symm (max_le_max (le_max_right s₁.1 s₂.1) (le_max_right f₁.1 f₂.1))];
rw [von_Neumann.Next_trans', von_Neumann.Next_trans'] at hs' hf'; iterate 4 { rw von_Neumann.Next_trans' };
rw [von_Neumann.Next_succ, von_Neumann.Next_succ, hf', hs']⟩

-- Extensionality
@[extensionality] theorem ext {f g : hfs} (H : ∀ s, s ∈ f ↔ s ∈ g) : f = g :=
quotient.induction_on₂ f g $ λ f g, quotient.sound $ show _ = _, begin
  generalize : von_Neumann.setoid._proof_1 f g = h1,
  generalize : von_Neumann.setoid._proof_2 f g = h2,
  revert h1 h2, generalize : max _ _ = n, cases n with n ih,
  { intros, change @eq empty _ _, exact subsingleton.elim _ _ },
  intros h1 h2, ext x,
  sorry
end

end hfs


import hilbert.wr.ki

namespace clfrags
    namespace hilbert
        namespace wr
            namespace ki

                theorem ki₁₀ {a b c : Prop} (h₁ : a) (h₂ : c) : ki a b c :=
                    have h₃ : ki a c (ki a b c), from ki₂ h₁,
                    show ki a b c, from ki₁ h₂ h₃

                theorem ki'₃ {a b c d : Prop} (h₁ : a) :
                    ki a (ki a b (ki a c d)) (ki a (ki a b c) (ki a b d)) :=
                    have h₂ : ki a a a, from ki₁₀ h₁ h₁,
                    have h₃ : ki a a (ki a (ki a b (ki a c d)) (ki a (ki a b c) (ki a b d))), from ki₃ h₂,
                    show ki a (ki a b (ki a c d)) (ki a (ki a b c) (ki a b d)), from ki₁ h₁ h₃

                theorem ki'₄ {a b c : Prop} (h₁ : a) :
                    ki a (ki a (ki a c b) c) c :=
                    have h₂ : ki a a a, from ki₁₀ h₁ h₁,
                    have h₃ : ki a a (ki a (ki a (ki a c b) c) c), from ki₄ h₂,
                    show ki a (ki a (ki a c b) c) c, from ki₁ h₁ h₃

                theorem ki₀ {a b c : Prop} (h₁ : ki a b c) : a :=
                    let r := ki a b c in
                        have h₂ : r, from h₁,
                        have h₃ : ki r r (ki a b c), from ki₁₀ h₂ h₂,
                        have h₄ : ki r r a, from ki₈ h₃,
                        show a, from ki₁ h₂ h₄

                theorem ki₁₁ {a b : Prop} (h₁ : a) : ki a b b :=
                    have h₂ : ki a (ki a b (ki a a b)) (ki a (ki a b a) (ki a b b)), from ki'₃ h₁,
                    have h₃ : ki a b (ki a a b), from ki₂ h₁,
                    have h₄ : ki a (ki a b a) (ki a b b), from ki₁ h₃ h₂,
                    have h₅ : ki a b a, from ki₁₀ h₁ h₁,
                    show ki a b b, from ki₁ h₅ h₄

                theorem ki₁₂ {a b c d : Prop} (h₁ : ki a b (ki a c d)) : ki a c (ki a b d) :=
                    have h₂ : a, from ki₀ h₁,
                    have h₃ : ki a (ki a b (ki a c d)) (ki a (ki a b c) (ki a b d)), from ki'₃ h₂,
                    have h₄ : ki a (ki a b c) (ki a b d), from ki₁ h₁ h₃,
                    have h₅ : ki a c (ki a (ki a b c) (ki a b d)), from ki₁₀ h₂ h₄,
                    let r := ki a b d, q := ki a b c in
                        have h₆ : ki a (ki a c (ki a q r)) (ki a (ki a c q) (ki a c r)), from ki'₃ h₂,
                        have h₇ : ki a (ki a c q) (ki a c r), from ki₁ h₅ h₆,
                        have h₈ : ki a c q, from ki₂ h₂,
                        have h₉ : ki a c r, from ki₁ h₈ h₇,
                        show ki a c (ki a b d), from h₉

                theorem ki₁₃ {a b c : Prop} (h₁ : ki a b (ki a b c)) : ki a b c :=
                    have h₂ : a, from ki₀ h₁,
                    have h₃ : ki a (ki a b (ki a b c)) (ki a (ki a b b) (ki a b c)), from ki'₃ h₂,
                    have h₄ : ki a (ki a b b) (ki a b c), from ki₁ h₁ h₃,
                    have h₅ : ki a b b, from ki₁₁ h₂,
                    show ki a b c, from ki₁ h₅ h₄

                theorem ki₁₄ {a b c d : Prop} (h₁ : ki a b d) : ki a (ki b b c) d :=
                    have h₂ : a, from ki₀ h₁,
                    have h₃ : ki a c (ki a b d), from ki₁₀ h₂ h₁,
                    have h₄ : ki a b (ki a c d), from ki₁₂ h₃,
                    show ki a (ki b b c) d, from ki₅ h₄

                theorem ki₁₅ {a b c d : Prop} (h₁ : ki a b d) : ki a (ki c c b) d :=
                    have h₂ : a, from ki₀ h₁,
                    have h₃ : ki a c (ki a b d), from ki₁₀ h₂ h₁,
                    show ki a (ki c c b) d, from ki₅ h₃

                theorem ki₁₆ {a b c d : Prop} (h₁ : ki a b c) (h₂ : ki a c d) :
                    ki a b d :=
                    have h₃ : a, from ki₀ h₁,
                    have h₄ : ki a (ki a b (ki a c d)) (ki a (ki a b c) (ki a b d)), from ki'₃ h₃,
                    have h₅ : ki a b (ki a c d), from ki₁₀ h₃ h₂,
                    have h₆ : ki a (ki a b c) (ki a b d), from ki₁ h₅ h₄,
                    show ki a b d, from ki₁ h₁ h₆

                theorem ki₁_ki {a b c d e : Prop} (h₁ : ki d e b) (h₂ : ki d e (ki a b c)) : ki d e c :=
                    have h₃ : ki d e (ki d b c), from ki₉ h₂,
                    have h₄ : ki d b (ki d e c), from ki₁₂ h₃,
                    have h₅ : ki d e (ki d e c), from ki₁₆ h₁ h₄,
                    show ki d e c, from ki₁₃ h₅

                theorem ki₂_ki {a b c d e : Prop} (h₁ : ki d e a) : ki d e (ki a b (ki a c b)) :=
                    have h₂ : d, from ki₀ h₁,
                    have h₃ : ki d b (ki d c b), from ki₂ h₂,
                    have h₄ : ki d (ki e e b) (ki d c b), from ki₁₅ h₃,
                    have h₅ : ki d (ki e e b) a, from ki₁₄ h₁,
                    have h₆ : ki d (ki e e b) (ki a c b), from ki₇ h₅ h₄,
                    have h₇ : ki d e (ki d b (ki a c b)), from ki₆ h₆,
                    show ki d e (ki a b (ki a c b)), from ki₇ h₁ h₇

                theorem ki₁₀_ki {a b c d e : Prop} (h₁ : ki d e a) (h₂ : ki d e c) : ki d e (ki a b c) :=
                    have h₃ : ki d e (ki a c (ki a b c)), from ki₂_ki h₁,
                    show ki d e (ki a b c), from ki₁_ki h₂ h₃

                theorem ki₁₂_ki {a b c d e f : Prop} (h₁ : ki e f (ki a b (ki a c d))) :
                        ki e f (ki a c (ki a b d)) :=
                    have h₂ : ki e f a, from ki₈ h₁,
                    have h₃ : ki e f (ki a (ki a b (ki a c d)) (ki a (ki a b c) (ki a b d))), from ki₃ h₂,
                    have h₄ : ki e f (ki a (ki a b c) (ki a b d)), from ki₁_ki h₁ h₃,
                    have h₅ : ki e f (ki a c (ki a (ki a b c) (ki a b d))), from ki₁₀_ki h₂ h₄,
                    let r := ki a b d, q := ki a b c in
                        have h₆ : ki e f (ki a (ki a c (ki a q r)) (ki a (ki a c q) (ki a c r))), from ki₃ h₂,
                        have h₇ : ki e f (ki a (ki a c q) (ki a c r)), from ki₁_ki h₅ h₆,
                        have h₈ : ki e f (ki a c q), from ki₂_ki h₂,
                        have h₉ : ki e f (ki a c r), from ki₁_ki h₈ h₇,
                        show ki e f (ki a c (ki a b d)), from h₉

                theorem ki₃_ki {a b c d e f g h : Prop}
                    (h₁ : ki g h (ki b f a)) :
                    ki g h (ki b f (ki a (ki a c (ki a d e)) (ki a (ki a c d) (ki a c e)))) :=
                    have h₂ : ki g h (ki g f a), from ki₉ h₁,
                    have h₃ : ki g (ki h h f) a, from ki₅ h₂,
                    have h₄ : ki g (ki h h f) (ki a (ki a c (ki a d e)) (ki a (ki a c d) (ki a c e))), from ki₃ h₃,
                    have h₅ : ki g h (ki g f (ki a (ki a c (ki a d e)) (ki a (ki a c d) (ki a c e)))), from ki₆ h₄,
                    have h₆ : ki g h b, from ki₈ h₁,
                    show ki g h (ki b f (ki a (ki a c (ki a d e)) (ki a (ki a c d) (ki a c e)))), from ki₇ h₆ h₅

                theorem ki₄_ki {a b c d e f g : Prop}
                    (h₁ : ki f g (ki b e a)) :
                    ki f g (ki b e (ki a (ki a (ki a c d) c) c)) :=
                    have h₂ : ki f g (ki f e a), from ki₉ h₁,
                    have h₃ : ki f (ki g g e) a, from ki₅ h₂,
                    have h₄ : ki f (ki g g e) (ki a (ki a (ki a c d) c) c), from ki₄ h₃,
                    have h₅ : ki f g (ki f e (ki a (ki a (ki a c d) c) c)), from ki₆ h₄,
                    have h₆ : ki f g b, from ki₈ h₁,
                    show ki f g (ki b e (ki a (ki a (ki a c d) c) c)), from ki₇ h₆ h₅

                theorem ki₅_ki {a b c d e f : Prop} (h₁ : ki e f (ki a b (ki a c d))) :
                    ki e f (ki a (ki b b c) d) :=
                    have h₂ : ki e f (ki e b (ki a c d)), from ki₉ h₁,
                    have h₃ : ki e b (ki e f (ki a c d)), from ki₁₂ h₂,
                    have h₄ : ki e (ki b b f) (ki a c d), from ki₅ h₃,
                    have h₅ : ki e (ki b b f) (ki e c d), from ki₉ h₄,
                    have h₆ : ki e b (ki e f (ki e c d)), from ki₆ h₅,
                    have h₇ : ki e b (ki e c (ki e f d)), from ki₁₂_ki h₆,
                    have h₈ : ki e (ki b b c) (ki e f d), from ki₅ h₇,
                    have h₉ : ki e f (ki e (ki b b c) d), from ki₁₂ h₈,
                    have h₁₀ : ki e f a, from ki₈ h₁,
                    show ki e f (ki a (ki b b c) d), from ki₇ h₁₀ h₉

                theorem ki₆_ki {a b c d e f : Prop} (h₁ : ki e f (ki a (ki b b c) d)) :
                    ki e f (ki a b (ki a c d)) :=
                    have h₂ : ki e f (ki e (ki b b c) d), from ki₉ h₁,
                    have h₃ : ki e (ki b b c) (ki e f d), from ki₁₂ h₂,
                    have h₄ : ki e b (ki e c (ki e f d)), from ki₆ h₃,
                    have h₅ : ki e b (ki e f (ki e c d)), from ki₁₂_ki h₄,
                    have h₆ : ki e f (ki e b (ki e c d)), from ki₁₂ h₅,
                    have h₇ : ki e (ki f f b) (ki e c d), from ki₅ h₆,
                    have h₈ : ki e f a, from ki₈ h₁,
                    have h₉ : ki e (ki f f b) a, from ki₁₄ h₈,
                    have h₁₀ : ki e (ki f f b) (ki a c d), from ki₇ h₉ h₇,
                    have h₁₁ : ki e f (ki e b (ki a c d)), from ki₆ h₁₀,
                    show ki e f (ki a b (ki a c d)), from ki₇ h₈ h₁₁

                theorem ki₇_ki {a b c d e f g : Prop} (h₁ : ki f g (ki a e b)) (h₂ : ki f g (ki a e (ki a c d))) :
                    ki f g (ki a e (ki b c d)) :=
                    have h₃ : ki f g (ki f e b), from ki₉ h₁,
                    have h₄ : ki f (ki g g e) b, from ki₅ h₃,
                    have h₅ : ki f g a, from ki₈ h₁,
                    have h₆ : ki f g (ki f e (ki a c d)), from ki₉ h₂,
                    have h₇ : ki f (ki g g e) (ki a c d), from ki₅ h₆,
                    have h₈ : ki f (ki g g e) (ki f c d), from ki₉ h₇,
                    have h₉ : ki f (ki g g e) (ki b c d), from ki₇ h₄ h₈,
                    have h₁₀ : ki f g (ki f e (ki b c d)), from ki₆ h₉,
                    show ki f g (ki a e (ki b c d)), from ki₇ h₅ h₁₀

                theorem ki₈_ki {a b c d e f g : Prop} (h₁ : ki f g (ki a e (ki b c d))) :
                    ki f g (ki a e b) :=
                    have h₂ : ki f g (ki f e (ki b c d)), from ki₉ h₁,
                    have h₃ : ki f (ki g g e) (ki b c d), from ki₅ h₂,
                    have h₄ : ki f (ki g g e) b, from ki₈ h₃,
                    have h₅ : ki f g (ki f e b), from ki₆ h₄,
                    have h₆ : ki f g a, from ki₈ h₁,
                    show ki f g (ki a e b), from ki₇ h₆ h₅

                theorem ki₉_ki {a b c d e f g : Prop} (h₁ : ki f g (ki a e (ki b c d))) :
                    ki f g (ki a e (ki a c d)) :=
                    have h₂ : ki f g a, from ki₈ h₁,
                    have h₃ : ki f g (ki f e (ki b c d)), from ki₉ h₁,
                    have h₄ : ki f (ki g g e) (ki b c d), from ki₅ h₃,
                    have h₅ : ki f (ki g g e) (ki f c d), from ki₉ h₄,
                    have h₆ : ki f (ki g g e) a, from ki₁₄ h₂,
                    have h₇ : ki f (ki g g e) (ki a c d), from ki₇ h₆ h₅,
                    have h₈ : ki f g (ki f e (ki a c d)), from ki₆ h₇,
                    show ki f g (ki a e (ki a c d)), from ki₇ h₂ h₈

            end ki
        end wr
    end hilbert
end clfrags


/-
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.shapes.equalizers
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# Constructing equalizers from pullbacks and binary products.

If a category has pullbacks and binary products, then it has equalizers.

TODO: provide the dual result.
-/

namespace category_theory.limits

-- We hide the "implementation details" inside a namespace

namespace has_equalizers_of_pullbacks_and_binary_products

/-- Define the equalizing object -/
def construct_equalizer {C : Type u} [category C] [has_binary_products C] [has_pullbacks C] (F : walking_parallel_pair ⥤ C) : C :=
  pullback (prod.lift 𝟙 (functor.map F walking_parallel_pair_hom.left))
    (prod.lift 𝟙 (functor.map F walking_parallel_pair_hom.right))

/-- Define the equalizing morphism -/
def pullback_fst {C : Type u} [category C] [has_binary_products C] [has_pullbacks C] (F : walking_parallel_pair ⥤ C) : construct_equalizer F ⟶ functor.obj F walking_parallel_pair.zero :=
  pullback.fst

theorem pullback_fst_eq_pullback_snd {C : Type u} [category C] [has_binary_products C] [has_pullbacks C] (F : walking_parallel_pair ⥤ C) : pullback_fst F = pullback.snd := sorry

/-- Define the equalizing cone -/
def equalizer_cone {C : Type u} [category C] [has_binary_products C] [has_pullbacks C] (F : walking_parallel_pair ⥤ C) : cone F :=
  cone.of_fork (fork.of_ι (pullback_fst F) sorry)

/-- Show the equalizing cone is a limit -/
def equalizer_cone_is_limit {C : Type u} [category C] [has_binary_products C] [has_pullbacks C] (F : walking_parallel_pair ⥤ C) : is_limit (equalizer_cone F) :=
  is_limit.mk
    fun (c : cone F) =>
      pullback.lift (nat_trans.app (cone.π c) walking_parallel_pair.zero)
        (nat_trans.app (cone.π c) walking_parallel_pair.zero) sorry

end has_equalizers_of_pullbacks_and_binary_products

/-- Any category with pullbacks and binary products, has equalizers. -/
-- This is not an instance, as it is not always how one wants to construct equalizers!

theorem has_equalizers_of_pullbacks_and_binary_products {C : Type u} [category C] [has_binary_products C] [has_pullbacks C] : has_equalizers C :=
  has_limits_of_shape.mk fun (F : walking_parallel_pair ⥤ C) => has_limit.mk (limit_cone.mk sorry sorry)


lemma ne_succ_self (n : mynat) : n ≠ succ n :=
begin
cases n with k,
exact zero_ne_succ 0,
intro x,
have h := succ_eq_succ_iff k (succ k),
rw h at x,
symmetry at x,
rw succ_eq_add_one at x,
have h2 := eq_zero_of_add_right_eq_self x,
rw one_eq_succ_zero at h2,
symmetry at h2,
apply zero_ne_succ 0,
exact h2,

end