import simplex

open matrix fintype finset function pequiv partition tableau tableau.termination
variables {m n : ℕ}

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

@[derive _root_.decidable_eq] inductive undo : Type
| unrestrict : ℕ → undo
| revive_col : ℕ → undo
| delete_row : ℕ → undo

instance : has_repr undo :=
⟨λ u, undo.cases_on u
  (λ n, "unrestrict " ++ repr n)
  (λ n, "revive_col " ++ repr n)
  (λ n, "delete_row " ++ repr n)⟩

open undo

structure stableau (m n : ℕ) extends tableau m n :=
(feasible : to_tableau.feasible)
(undo_stack : list undo)

namespace stableau

section predicates
variable (T : stableau m n)

/-- The affine subspace represented by the tableau ignoring nonnegativity restrictiions -/
@[reducible] def flat : set (cvec (m + n)) := T.to_tableau.flat

/-- The res_set is the subset of ℚ^(m+n) that satisifies the nonnegativity constraints of
  the tableau, and the affine conditions -/
@[reducible] def res_set : set (cvec (m + n)) := T.to_tableau.res_set

/-- The dead_set is the subset of ℚ^(m+n) such that all dead variables are zero, and satisfies
  the affine conditions -/
@[reducible] def dead_set : set (cvec (m + n)) := T.to_tableau.dead_set

/-- The `sol_set` is the set of vector that satisfy the affine constraints the dead variable
  constraints, and the nonnegativity constraints. -/
@[reducible] def sol_set : set (cvec (m + n)) := T.to_tableau.sol_set

lemma sol_set_eq_res_set_inter :
  T.sol_set = res_set T ∩ { x | ∀ j, j ∈ T.dead → x (T.to_partition.colg j) 0 = 0 } := rfl

lemma sol_set_eq_dead_set_inter :
   T.sol_set = dead_set T ∩ { x | ∀ i, i ∈ T.restricted → 0 ≤ x i 0 } :=
set.inter_right_comm _ _ _

lemma sol_set_eq_res_set_inter_dead_set : T.sol_set = T.res_set ∩ T.dead_set :=
tableau.sol_set_eq_res_set_inter_dead_set _

lemma sol_set_eq_flat_inter : T.sol_set =
  T.flat ∩ { x | ∀ i, i ∈ T.restricted → 0 ≤ x i 0 }
    ∩ { x | ∀ j, j ∈ T.dead → x (T.to_partition.colg j) 0 = 0 } :=
by simp [flat, sol_set, tableau.sol_set, tableau.res_set, set.ext_iff]; tauto

/-- Predicate for a variable being unbounded above in the `res_set` -/
@[reducible] def is_unbounded_above (i : fin (m + n)) : Prop := T.to_tableau.is_unbounded_above i

/-- Predicate for a variable being unbounded below in the `res_set` -/
@[reducible] def is_unbounded_below (i : fin (m + n)) : Prop := T.to_tableau.is_unbounded_below i

@[reducible] def is_optimal (x : cvec (m + n)) (i : fin (m + n)) : Prop :=
T.to_tableau.is_optimal x i

lemma is_optimal_iff {T : stableau m n} (x : cvec (m + n)) (i : fin (m + n)) :
  T.is_optimal x i ↔ x ∈ T.sol_set ∧ ∀ y : cvec (m + n), y ∈ sol_set T → y i 0 ≤ x i 0 := iff.rfl

/-- Is this equivalent to `∀ (x : cvec (m + n)), x ∈ res_set T → x i 0 = x j 0`? No -/
@[reducible] def equal_in_flat (i j : fin (m + n)) : Prop := T.to_tableau.equal_in_flat i j

/-- Returns an element of the `flat` after assigning values to the column variables -/
@[reducible] def of_col (x : cvec n) : cvec (m + n) :=
T.to_tableau.of_col x

@[simp] lemma of_col_zero_mem_sol_set : T.of_col 0 ∈ T.sol_set :=
tableau.of_col_zero_mem_sol_set_iff.2 T.feasible

@[simp] lemma of_col_rowg (x : cvec n) (i : fin m) :
  of_col T x (T.to_partition.rowg i) = (T.to_matrix ⬝ x + T.const) i := tableau.of_col_rowg _ _ _

end predicates

section simplex

def simplex (w : tableau m n → bool) (obj : fin m) (T : stableau m n) :
  stableau m n × termination n :=
let s := T.to_tableau.simplex w obj T.feasible in
prod.mk
  { to_tableau := s.1,
    feasible := feasible_simplex,
    undo_stack := T.undo_stack }
  s.2

/- Transfer lemmas about `tableau.simplex` onto `stableau.simplex` -/
@[simp] lemma simplex_to_tableau (w : tableau m n → bool) (obj : fin m) (T : stableau m n) :
  (T.to_tableau.simplex w obj T.feasible).1 = (T.simplex w obj).1.to_tableau := rfl

@[simp] lemma rowg_simplex (T : stableau m n) (w : tableau m n → bool)
  (obj : fin m) : (T.simplex w obj).1.to_partition.rowg obj = T.to_partition.rowg obj :=
tableau.rowg_simplex _ _ _ _

@[simp] lemma flat_simplex (T : stableau m n) (w : tableau m n → bool)
  (obj : fin m) : (T.simplex w obj).1.flat = T.flat :=
tableau.flat_simplex _ _ _ _

@[simp] lemma res_set_simplex (T : stableau m n) (w : tableau m n → bool)
  (obj : fin m) : (T.simplex w obj).1.res_set = T.res_set :=
tableau.res_set_simplex _ _ _ _

@[simp] lemma dead_set_simplex (T : stableau m n) (w : tableau m n → bool)
  (obj : fin m) : (T.simplex w obj).1.dead_set = T.dead_set :=
tableau.dead_set_simplex _ _ _ _

@[simp] lemma sol_set_simplex (T : stableau m n) (w : tableau m n → bool) (obj : fin m) :
  (T.simplex w obj).1.sol_set = T.sol_set :=
tableau.sol_set_simplex _ _ _ _

@[simp] lemma restricted_simplex (T : stableau m n) (w : tableau m n → bool) (obj : fin m) :
  (T.simplex w obj).1.restricted = T.restricted :=
tableau.restricted_simplex _ _ _ _

@[simp] lemma dead_simplex (T : stableau m n) (w : tableau m n → bool) (obj : fin m) :
  (T.simplex w obj).1.dead = T.dead :=
tableau.dead_simplex _ _ _ _

@[simp] lemma undo_stack_simplex (T : stableau m n) (w : tableau m n → bool) (obj : fin m) :
  (T.simplex w obj).1.undo_stack = T.undo_stack := rfl

@[simp] lemma of_col_simplex_mem_sol_set (T : stableau m n) (w : tableau m n → bool) (obj : fin m) :
  (T.simplex w obj).1.of_col 0 ∈ T.sol_set :=
by rw [← sol_set_simplex T w obj]; exact of_col_zero_mem_sol_set _

@[simp] lemma of_col_simplex_rowg {T : stableau m n} {w : tableau m n → bool}  {obj : fin m}
  (x : cvec n) :
  (T.simplex w obj ).1.of_col x (T.to_partition.rowg obj) =
  ((T.simplex w obj).1.to_matrix ⬝ x + (T.simplex w obj).1.const) obj :=
tableau.of_col_simplex_rowg _

@[simp] lemma is_unbounded_above_simplex {T : stableau m n} {w : tableau m n → bool}
  {obj : fin m} {v : fin (m + n)} : is_unbounded_above (T.simplex w obj).1 v ↔
  is_unbounded_above T v :=
tableau.is_unbounded_above_simplex

@[simp] lemma is_optimal_simplex {T : stableau m n} {w : tableau m n → bool}
  {obj : fin m} {x : cvec (m + n)} {v : fin (m + n)} : is_optimal (T.simplex w obj).1 x v ↔
  is_optimal T x v :=
tableau.is_optimal_simplex

lemma termination_eq_while_iff {T : stableau m n} {w : tableau m n → bool}
  {obj : fin m} : (T.simplex w obj).2 = while ↔ w (T.simplex w obj).1.to_tableau = ff :=
by rw [simplex, tableau.termination_eq_while_iff, simplex_to_tableau]; refl

lemma termination_eq_optimal_iff {T : stableau m n}
  {w : tableau m n → bool} {obj : fin m} : (T.simplex w obj).2 = optimal ↔
  w (T.simplex w obj).1.to_tableau = tt ∧
  is_optimal T ((T.simplex w obj).1.of_col 0) (T.to_partition.rowg obj) :=
by rw [simplex, tableau.termination_eq_optimal_iff, simplex_to_tableau]; refl

lemma termination_eq_unbounded_iff {T : stableau m n} {w : tableau m n → bool} {obj : fin m}
  (j : fin n) :
  ((T.simplex w obj).2 = unbounded j) ↔
  w (T.simplex w obj).1.to_tableau = tt ∧ is_unbounded_above T (T.to_partition.rowg obj)
  ∧ j ∈ pivot_col (T.simplex w obj).1.to_tableau obj :=
by rw [simplex, tableau.termination_eq_unbounded_iff, simplex_to_tableau]; refl

end simplex

section add_row

/-- adds a new row without making it a restricted variable. -/
def add_row_aux (T : tableau m n) (fac : rvec (m + n)) (k : ℚ) : tableau (m + 1) n :=
{ to_matrix := λ i j, if hm : i.1 < m
    then T.to_matrix (fin.cast_lt i hm) j
    else fac 0 (T.to_partition.colg j) +
      univ.sum (λ i' : fin m, fac 0 (T.to_partition.rowg i') * T.to_matrix i' j),
  const := λ i j, if hm : i.1 < m
    then T.const (fin.cast_lt i hm) j
    else k +
      univ.sum (λ i' : fin m, fac 0 (T.to_partition.rowg i') * T.const i' 0),
  to_partition := T.to_partition.add_row,
  restricted := T.restricted.map ⟨fin.castp,
    λ ⟨_, _⟩ ⟨_, _⟩ h, fin.eq_of_veq (fin.veq_of_eq h : _)⟩,
  dead := T.dead }

@[simp] lemma add_row_aux_to_partition (T : tableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row_aux T fac k).to_partition = T.to_partition.add_row := rfl

lemma add_row_aux_to_matrix (T : tableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row_aux T fac k).to_matrix = λ i j, if hm : i.1 < m
    then T.to_matrix (fin.cast_lt i hm) j else fac 0 (T.to_partition.colg j) +
      univ.sum (λ i' : fin m, fac 0 (T.to_partition.rowg i') * T.to_matrix i' j) := rfl

lemma add_row_aux_const (T : tableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row_aux T fac k).const = λ i j, if hm : i.1 < m
    then T.const (fin.cast_lt i hm) j else k +
    univ.sum (λ i' : fin m, fac 0 (T.to_partition.rowg i') * T.const i' 0) := rfl

lemma add_row_aux_restricted (T : tableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row_aux T fac k).restricted = T.restricted.image fin.castp :=
by simp [add_row_aux, map_eq_image]

@[elab_as_eliminator] def fin.cases_last {n : ℕ}
  {C : fin n.succ → Sort*} (Hl : C (fin.last n)) (Hs : ∀ i : fin n, C i.cast_succ)
  (i : fin n.succ) : C i :=
if hi : fin.last n = i then eq.rec_on hi Hl
else have i = fin.cast_succ ⟨i, lt_of_le_of_ne (nat.le_of_lt_succ i.2) (ne.symm (fin.vne_of_ne hi))⟩,
  from fin.eq_of_veq rfl,
eq.rec_on this.symm (Hs _)

@[simp] lemma cases_last_last {n : ℕ}
  {C : fin n.succ → Sort*} (Hl : C (fin.last n)) (Hs : ∀ i : fin n, C i.cast_succ) :
  (fin.cases_last Hl Hs (fin.last n) : C (fin.last n)) = Hl :=
by simp [fin.cases_last]

lemma cast_succ_lt_last {n : ℕ} (i : fin n) : i.cast_succ < fin.last n := i.2

@[simp] lemma cases_last_cast_succ {n : ℕ}
  {C : fin n.succ → Sort*} (Hl : C (fin.last n)) (Hs : ∀ i : fin n, C i.cast_succ)
  (i : fin n) : (fin.cases_last Hl Hs i.cast_succ : C i.cast_succ) = Hs i :=
by simp [fin.cases_last, ne_of_gt (cast_succ_lt_last i)]; cases i; refl

lemma add_row_aux_feasible {T : tableau m n} (hfT : T.feasible) (fac : rvec (m + n)) (k : ℚ) :
  (add_row_aux T fac k).feasible :=
λ i, fin.cases_last
  (by simp [add_row_aux_restricted, add_row_aux_const, add_row_rowg_last])
  (λ i, by simp [add_row_aux_const, dif_pos (show i.cast_succ.1 < m, from i.2),
    fin.cast_lt_cast_succ, add_row_aux_restricted, add_row_aux_to_partition, add_row_rowg_cast_succ,
    mem_image, exists_imp_distrib, fin.injective_castp.eq_iff, @forall_swap _ (_ = _), hfT i]
      {contextual := tt}) i

def add_row (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) : stableau (m + 1) n :=
{ undo_stack := delete_row (m + n) :: T.undo_stack,
  feasible := add_row_aux_feasible T.feasible _ _,
  ..add_row_aux T.to_tableau fac k }

@[simp] lemma add_row_to_partition (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row T fac k).to_partition = T.to_partition.add_row := rfl

lemma add_row_to_matrix (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row T fac k).to_matrix = λ i j, if hm : i.1 < m
    then T.to_matrix (fin.cast_lt i hm) j else fac 0 (T.to_partition.colg j) +
      univ.sum (λ i' : fin m, fac 0 (T.to_partition.rowg i') * T.to_matrix i' j) := rfl

lemma add_row_const (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row T fac k).const = λ i j, if hm : i.1 < m
    then T.const (fin.cast_lt i hm) j else k +
    univ.sum (λ i' : fin m, fac 0 (T.to_partition.rowg i') * T.const i' 0) := rfl

lemma add_row_restricted (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row T fac k).restricted = T.restricted.image fin.castp :=
add_row_aux_restricted _ _ _

@[simp] lemma add_row_dead (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (add_row T fac k).dead = T.dead := rfl

lemma minor_mem_flat_of_mem_add_row_flat {T : stableau m n} {fac : rvec (m + n)} {k : ℚ}
  {x : cvec (m + 1 + n)} : x ∈ (T.add_row fac k).flat → minor x fin.castp (λ x, x) ∈ T.flat :=
begin
  rw [mem_flat_iff, mem_flat_iff],
  intros h r,
  have := h (fin.cast_succ r),
  simp [add_row_rowg_cast_succ, add_row_const, add_row_to_matrix,
    (show (fin.cast_succ r).val < m, from r.2), add_row_colg] at this,
  simpa
end

lemma minor_mem_res_set_of_mem_add_row_res_set {T : stableau m n} {fac : rvec (m + n)} {k : ℚ}
  {x : cvec (m + 1 + n)} : x ∈ (T.add_row fac k).res_set → minor x fin.castp (λ x, x) ∈ T.res_set :=
and_implies minor_mem_flat_of_mem_add_row_flat begin
  assume h v,
  simp only [set.mem_set_of_eq, add_row_restricted, mem_image, exists_imp_distrib] at h,
  simpa [add_row_restricted, matrix.minor, id.def] using h (fin.castp v) v
end

lemma minor_mem_dead_set_of_mem_add_row_dead_set {T : stableau m n} {fac : rvec (m + n)} {k : ℚ}
  {x : cvec (m + 1 + n)} : x ∈ (T.add_row fac k).dead_set → minor x fin.castp (λ x, x) ∈ T.dead_set :=
and_implies minor_mem_flat_of_mem_add_row_flat $
  by simp only [add_row_colg, add_row_to_partition];
  exact id

lemma minor_mem_sol_set_of_mem_add_row_sol_set {T : stableau m n} {fac : rvec (m + n)} {k : ℚ}
  {x : cvec (m + 1 + n)} : x ∈ (T.add_row fac k).sol_set → minor x fin.castp (λ x, x) ∈ T.sol_set :=
by rw [sol_set_eq_res_set_inter_dead_set, sol_set_eq_res_set_inter_dead_set];
  exact and_implies minor_mem_res_set_of_mem_add_row_res_set
    minor_mem_dead_set_of_mem_add_row_dead_set

lemma sum_colg_eq_sum_fac {T : stableau m n} {fac : rvec (m + n)} {k : ℚ} {x : cvec (m + n)}
  (hx : x ∈ T.flat) : univ.sum (λ j : fin n, (T.add_row fac k).to_matrix (fin.last _) j *
    x (T.to_partition.colg j) 0) + (T.add_row fac k).const (fin.last _) 0 =
      univ.sum (λ v : fin (m + n), fac 0 v * x v 0) + k :=
calc univ.sum (λ j : fin n, (T.add_row fac k).to_matrix (fin.last _) j *
      x (T.to_partition.colg j) 0) + (T.add_row fac k).const (fin.last _) 0
    = k +
  univ.sum (λ j, (fac 0 (T.to_partition.colg j) * x (T.to_partition.colg j) 0)) +
  (univ.sum (λ j, univ.sum (λ i, fac 0 (T.to_partition.rowg i) * T.to_matrix i j *
      x (T.to_partition.colg j) 0))
    + univ.sum (λ i, fac 0 (T.to_partition.rowg i) * T.const i 0)) :
  by simp [add_row_to_matrix, add_row_const, fin.last, add_mul, sum_add_distrib, sum_mul]
... = k +
  univ.sum (λ j, (fac 0 (T.to_partition.colg j) * x (T.to_partition.colg j) 0)) +
  (univ.sum (λ i, univ.sum (λ j, fac 0 (T.to_partition.rowg i) * T.to_matrix i j *
    x (T.to_partition.colg j) 0))
    + univ.sum (λ i, fac 0 (T.to_partition.rowg i) * T.const i 0)) : by rw [sum_comm]
... = k +
  univ.sum (λ j, (fac 0 (T.to_partition.colg j) * x (T.to_partition.colg j) 0)) +
  univ.sum (λ i : fin m, (fac 0 (T.to_partition.rowg i) * x (T.to_partition.rowg i) 0)) :
begin
  rw [← sum_add_distrib],
  have : ∀ i : fin m, x (T.to_partition.rowg i) 0 =
    sum univ (λ (j : fin n), T.to_matrix i j * x (T.to_partition.colg j) 0) +
    T.const i 0, from mem_flat_iff.1 hx,
  simp [this, mul_add, add_row_colg, mul_sum, mul_assoc]
end
... = ((univ.image T.to_partition.colg).sum (λ v, (fac 0 v * x v 0)) +
  (univ.image T.to_partition.rowg).sum (λ v, (fac 0 v * x v 0))) + k :
  by rw [sum_image, sum_image];
    simp [add_row_rowg_cast_succ, add_row_colg, T.to_partition.injective_rowg.eq_iff,
      T.to_partition.injective_colg.eq_iff]
... = _ : begin
  rw [← sum_union],
  congr,
  simpa [finset.ext, eq_comm] using T.to_partition.eq_rowg_or_colg,
  { simp [disjoint, subset_iff, eq_comm, T.to_partition.rowg_ne_colg] {contextual := tt} }
end

lemma add_row_new_eq_sum_fac {T : stableau m n} {fac : rvec (m + n)} {k : ℚ}
  {x : cvec (m + 1 + n)} (hx : x ∈ (T.add_row fac k).flat) :
  x fin.lastp 0 = univ.sum (λ v : fin (m + n), fac 0 v * x (fin.castp v) 0) + k :=
calc x fin.lastp 0 = x ((T.add_row fac k).to_partition.rowg (fin.last _)) 0 :
  by simp [add_row_rowg_last]
... = univ.sum (λ j : fin n, _) + (T.add_row fac k).const _ _ : mem_flat_iff.1 hx _
... = univ.sum (λ v : fin (m + n), fac 0 v * x (fin.castp v) 0) + k :
  by erw ← sum_colg_eq_sum_fac (minor_mem_flat_of_mem_add_row_flat hx);
  simp [minor, add_row_colg, id.def (0 : fin 1)]

lemma flat_add_row (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (T.add_row fac k).flat = (λ x, minor x fin.castp (λ x, x)) ⁻¹' T.flat ∩
  {x : cvec (m + 1 + n) |
    x fin.lastp 0 = univ.sum (λ v : fin (m + n), fac 0 v * x (fin.castp v) 0) + k} :=
set.ext $ λ x, ⟨λ hx, ⟨minor_mem_flat_of_mem_add_row_flat hx, add_row_new_eq_sum_fac hx⟩,
  λ h, mem_flat_iff.2 (λ i, begin
    refine fin.cases_last _ _ i,
    { erw [add_row_to_partition, add_row_rowg_last, show _ = _, from h.2,
        ← sum_colg_eq_sum_fac h.1],
      simp [minor, add_row_colg] },
    { assume i,
      have := mem_flat_iff.1 h.1 i,
      simp [add_row_to_matrix, dif_pos (show i.cast_succ.val < m, from i.2),
        add_row_to_partition, add_row_rowg_cast_succ, minor, *, add_row_const, add_row_colg] at * }
  end)⟩

lemma res_set_add_row_aux (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  { x : cvec (m + 1 + n) | ∀ i, i ∈ (T.add_row fac k).restricted → 0 ≤ x i 0 } =
  (λ x, minor x fin.castp (λ x, x)) ⁻¹' { x | ∀ i, i ∈ T.restricted → 0 ≤ x i 0 } :=
set.ext $ λ x, ⟨λ h i hres, h _ (by simp [add_row_restricted, fin.injective_castp.eq_iff, *]),
  by simp [add_row_restricted, @eq_comm _ (fin.castp _), minor] {contextual := tt}⟩

lemma res_set_add_row (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (T.add_row fac k).res_set = (λ x, minor x fin.castp (λ x, x)) ⁻¹' T.res_set ∩
  {x : cvec (m + 1 + n) |
    x fin.lastp 0 = univ.sum (λ v : fin (m + n), fac 0 v * x (fin.castp v) 0) + k} :=
by rw [res_set, res_set, tableau.res_set, tableau.res_set, ← flat, ← flat, flat_add_row,
    res_set_add_row_aux];
  finish [set.ext_iff]

lemma dead_set_add_row_aux (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  { x : cvec (m + 1 + n) | ∀ j, j ∈ (T.add_row fac k).dead →
    x ((T.add_row fac k).to_partition.colg j ) 0 = 0 } =
  (λ x, minor x fin.castp (λ x, x)) ⁻¹' { x | ∀ j, j ∈ T.dead →
    x (T.to_partition.colg j ) 0 = 0 } :=
by simp [add_row_dead, minor, add_row_colg, set.ext_iff]

lemma dead_set_add_row (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
(T.add_row fac k).dead_set = (λ x, minor x fin.castp (λ x, x)) ⁻¹' T.dead_set ∩
  {x : cvec (m + 1 + n) |
    x fin.lastp 0 = univ.sum (λ v : fin (m + n), fac 0 v * x (fin.castp v) 0) + k} :=
by rw [dead_set, dead_set, tableau.dead_set, tableau.dead_set, ← flat, ← flat, flat_add_row,
    dead_set_add_row_aux];
  finish [set.ext_iff]

lemma sol_set_add_row (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (T.add_row fac k).sol_set = (λ x, minor x fin.castp (λ x, x)) ⁻¹' T.sol_set ∩
  {x : cvec (m + 1 + n) |
    x fin.lastp 0 = univ.sum (λ v : fin (m + n), fac 0 v * x (fin.castp v) 0) + k} :=
by rw [sol_set_eq_res_set_inter_dead_set, sol_set_eq_res_set_inter_dead_set,
    dead_set_add_row, res_set_add_row];
  simp [set.ext_iff]; tauto

lemma image_flat_add_row (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (λ x, minor x fin.castp (λ x, x)) '' (T.add_row fac k).flat = T.flat :=
begin
  simp only [flat_add_row, set.ext_iff, minor, mem_flat_iff, set.mem_preimage, set.mem_image,
    set.mem_inter_eq, add_comm, set.mem_set_of_eq],
  assume x,
  split,
  { rintros ⟨y, ⟨hy, _⟩, hyx⟩,
    subst hyx, exact hy },
  { assume h,
    refine ⟨λ i j, if hi : i.1 < m + n then x ⟨i.1, hi⟩ j
      else k + univ.sum (λ v, fac 0 v * x v 0), _⟩,
    dsimp [fin.castp, fin.lastp],
    simp [fin.is_lt, h, lt_irrefl] }
end

lemma image_sol_set_add_row (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) :
  (λ x, minor x fin.castp (λ x, x)) '' (T.add_row fac k).sol_set = T.sol_set :=
begin
  conv_rhs {rw [sol_set_eq_flat_inter, ← image_flat_add_row T fac k]},
  rw [sol_set_eq_flat_inter, dead_set_add_row_aux, res_set_add_row_aux],
  ext x,
  split,
  { rintros ⟨y, hy, ⟨_⟩⟩,
    exact ⟨⟨⟨y, hy.1.1, rfl⟩, hy.1.2⟩, hy.2⟩ },
  { rintros ⟨⟨⟨y, hy, ⟨_⟩⟩, hx₁⟩, hx₂⟩,
    exact ⟨y, ⟨⟨⟨hy, hx₁⟩, hx₂⟩, rfl⟩⟩ }
end

end add_row

section sign_of_max_row

lemma sign_of_max_row_feasible {T : tableau m n} (obj : fin m) (hT : T.feasible) (j : fin n)
  (hj : (T.simplex (λ T', T'.const obj 0 ≤ 0) obj hT).2 = unbounded j) :
  ((T.simplex (λ T', T'.const obj 0 ≤ 0) obj hT).1.pivot obj j).feasible :=
by rw [tableau.termination_eq_unbounded_iff_pivot_row_eq_none] at hj; exact
feasible_pivot_obj_of_nonpos (feasible_simplex)
  (λ hjres, by have := pivot_col_spec hj.2.1; simp * at *)
  (pivot_row_eq_none_aux hj.2.2 hj.2.1)
  (by finish)

set_option eqn_compiler.zeta true

def sign_of_max_row (T : stableau m n) (obj : fin m) : stableau m n × ℤ :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
match T'.2, sign_of_max_row_feasible obj T.feasible with
| while,       _  := (T'.1, 1)
| unbounded c, hj :=
  ({to_tableau := T'.1.to_tableau.pivot obj c,
    undo_stack := T.undo_stack,
    feasible := hj _ rfl }, 1)
| optimal,     _  := (T'.1, if T'.1.const obj 0 = 0 then 0 else -1)
end

set_option eqn_compiler.zeta false

lemma optimal_and_neg_of_sign_of_max_row_eq_zero {T : stableau m n} {obj : fin m} :
  (sign_of_max_row T obj).2 = 0 →
  let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
  T'.2 = optimal ∧
  ∀ j : fin n, j ∉ T'.1.dead →
  (((sign_of_max_row T obj).1.to_matrix obj j = 0 ∧
      (sign_of_max_row T obj).1.to_partition.colg j ∉ (sign_of_max_row T obj).1.restricted)
    ∨ ((sign_of_max_row T obj).1.to_matrix obj j ≤ 0 ∧
      (sign_of_max_row T obj).1.to_partition.colg j ∈ (sign_of_max_row T obj).1.restricted)) :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
begin
  cases h : T'.2 with c,
  { simp [sign_of_max_row, *, termination_eq_while_iff, is_optimal_iff, classical.not_forall] at * },
  { simp [sign_of_max_row, *] },
  { simp only [sign_of_max_row, *, eq_self_iff_true, true_and],
    split_ifs,
    { simp only [eq_self_iff_true, true_implies_iff],
      assume c hj,
      exact (pivot_col_eq_none_aux feasible_simplex
        (termination_eq_optimal_iff_pivot_col_eq_none.1 h).2
          (show c ∉ T'.1.dead, by simpa using hj)) },
    { simp [show (-1 : ℤ) ≠ 0, from dec_trivial], } }
end

lemma sign_of_max_row_eq_zero {T : stableau m n} {obj : fin m} :
  (sign_of_max_row T obj).2 = 0 ↔
    ∃ x : cvec (m + n), x (T.to_partition.rowg obj) 0 = 0 ∧ is_optimal T x
      (T.to_partition.rowg obj) :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
begin
  cases h : T'.2 with c,
  { simp only [sign_of_max_row, *, termination_eq_while_iff, is_optimal_iff, classical.not_forall,
      not_exists, exists_prop, false_iff, not_and, not_le, to_bool_ff_iff, one_ne_zero] at *,
    assume x hx0 hxs,
    refine ⟨T'.1.of_col 0, _⟩,
    simpa [T', hx0] },
  { simp only [sign_of_max_row, *, termination_eq_unbounded_iff, is_unbounded_above,
      classical.not_forall, not_exists, exists_prop, false_iff, not_and, not_le, to_bool_iff,
      one_ne_zero, is_optimal_iff] at * {contextual := tt},
    cases h.2.1 1 with y hy,
    assume x hxs hx,
    use [y, hy.1],
    exact lt_of_lt_of_le zero_lt_one hy.2 },
  { simp only [sign_of_max_row, *, termination_eq_optimal_iff, is_unbounded_above,
      classical.not_forall, not_exists, exists_prop, false_iff, not_and, not_le, to_bool_iff,
      one_ne_zero] at * {contextual := tt},
    split_ifs with h0,
    { simp only [eq_self_iff_true, true_iff],
      refine ⟨_, _, _, h.2.2⟩;
      simp [h0] },
    { simp only [is_optimal_iff, not_exists, neg_eq_zero, one_ne_zero, false_iff, not_and],
      assume x hx0 hsx ,
      exact absurd (le_antisymm h.1 (by simpa [hx0] using h.2.2 x hsx)) h0 } }
end

lemma sign_of_max_row_eq_one {T : stableau m n} {obj : fin m} :
  (sign_of_max_row T obj).2 = 1 ↔
    ∃ x : cvec (m + n), x ∈ sol_set T ∧ 0 < x (T.to_partition.rowg obj) 0 :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
begin
  cases h : T'.2,
  { simp only [sign_of_max_row, *, termination_eq_while_iff, eq_self_iff_true, true_iff,
      to_bool_ff_iff, not_le] at *,
    exact ⟨T'.1.of_col 0, by simp [*, T']⟩ },
  { simp only [sign_of_max_row, *, termination_eq_unbounded_iff, eq_self_iff_true,
      true_iff, to_bool_iff] at *,
    cases h.2.1 1 with y hy,
    use [y, hy.1],
    exact lt_of_lt_of_le zero_lt_one hy.2 },
  { simp only [sign_of_max_row, *, termination_eq_optimal_iff, to_bool_iff] at *,
    suffices : ∀ (x : matrix (fin (m + n)) (fin 1) ℚ), x ∈ sol_set T →
      x (T.to_partition.rowg obj) 0 ≤ 0,
    { split_ifs; simpa [show ¬(-1 : ℤ) = 1, from dec_trivial] },
    assume x hx,
    exact le_trans (h.2.2 x hx) (by simpa using h.1) }
end

lemma sign_of_max_row_eq_neg_one {T : stableau m n} {obj : fin m} :
  (sign_of_max_row T obj).2 = -1 ↔
    ∀ x : cvec (m + n), x ∈ sol_set T → x (T.to_partition.rowg obj) 0 < 0 :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
begin
  cases h : T'.2,
  { simp only [sign_of_max_row, *, termination_eq_while_iff, false_iff, classical.not_forall,
      not_lt, show (1 : ℤ) ≠ -1, from dec_trivial, to_bool_ff_iff, not_le] at *,
    use T'.1.of_col 0,
    simp [le_of_lt h] },
  { simp only [sign_of_max_row, *, termination_eq_unbounded_iff, false_iff, classical.not_forall,
      show (1 : ℤ) ≠ -1, from dec_trivial, to_bool_iff, not_lt, not_le] at *,
    cases h.2.1 1 with y hy,
    use [y, hy.1],
    exact le_trans zero_le_one hy.2 },
  { simp only [sign_of_max_row, *, termination_eq_optimal_iff, to_bool_iff] at *,
    split_ifs,
    { simp [show (0 : ℤ) ≠ -1, from dec_trivial, classical.not_forall],
      use T'.1.of_col 0, simp * },
    { simp only [eq_self_iff_true, true_iff],
      assume x hx,
      exact lt_of_le_of_lt (h.2.2 x hx) (by apply lt_of_le_of_ne; simp; tauto) } }
end

lemma sign_of_max_row_eq_simplex_or_pivot (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1 = (T.simplex (λ T', T'.const obj 0 ≤ 0) obj).1 ∨
  ∃ c, c ∈ pivot_col (T.simplex (λ T', T'.const obj 0 ≤ 0) obj).1.to_tableau obj ∧
    (sign_of_max_row T obj).1.to_tableau =
      (T.simplex (λ T', T'.const obj 0 ≤ 0) obj).1.to_tableau.pivot obj c :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
begin
  cases h : T'.2 with c,
  { simp [sign_of_max_row, h] },
  { right, use c,
    simp [sign_of_max_row, h, ((termination_eq_unbounded_iff _).1 h).2] },
  { simp [sign_of_max_row, h] }
end

@[simp] lemma sign_of_max_row_flat (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1.flat = T.flat :=
(sign_of_max_row_eq_simplex_or_pivot T obj).elim
  (by simp { contextual := tt })
  (λ ⟨j, hj⟩, begin
    rw [flat, hj.2, simplex, ← flat_simplex T (λ T', T'.const obj 0 ≤ 0) obj],
    exact tableau.flat_pivot (ne_zero_of_mem_pivot_col hj.1)
  end)

@[simp] lemma sign_of_max_row_res_set (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1.res_set = T.res_set :=
(sign_of_max_row_eq_simplex_or_pivot T obj).elim
  (by simp { contextual := tt })
  (λ ⟨j, hj⟩, begin
    rw [res_set, hj.2, simplex, ← res_set_simplex T (λ T', T'.const obj 0 ≤ 0) obj],
    exact tableau.res_set_pivot (ne_zero_of_mem_pivot_col hj.1)
  end)

@[simp] lemma sign_of_max_row_dead_set (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1.dead_set = T.dead_set :=
(sign_of_max_row_eq_simplex_or_pivot T obj).elim
  (by simp { contextual := tt })
  (λ ⟨j, hj⟩, begin
    rw [dead_set, hj.2, simplex, ← dead_set_simplex T (λ T', T'.const obj 0 ≤ 0) obj],
    exact tableau.dead_set_pivot (ne_zero_of_mem_pivot_col hj.1) (pivot_col_spec hj.1).2
  end)

@[simp] lemma sign_of_max_row_sol_set (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1.sol_set = T.sol_set :=
by simp [sol_set_eq_res_set_inter_dead_set]

@[simp] lemma restricted_sign_of_max_row (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1.restricted = T.restricted :=
(sign_of_max_row_eq_simplex_or_pivot T obj).elim
  (by simp { contextual := tt })
  (by simp { contextual := tt })

@[simp] lemma dead_sign_of_max_row (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1.dead = T.dead :=
(sign_of_max_row_eq_simplex_or_pivot T obj).elim
  (by simp { contextual := tt })
  (by simp { contextual := tt })

@[simp] lemma undo_stack_sign_of_max_row (T : stableau m n) (obj : fin m) :
  (sign_of_max_row T obj).1.undo_stack = T.undo_stack :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
by dsimp [sign_of_max_row]; cases h : T'.2; simp [h, sign_of_max_row._match_1]

lemma feasible_restrict_sign_of_max_row (T : stableau m n) (obj : fin m)
  (h0 : 0 ≤ (T.sign_of_max_row obj).2) :
  ((T.sign_of_max_row obj).1.to_tableau.restrict (T.to_partition.rowg obj)).feasible :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
tableau.feasible_restrict (T.sign_of_max_row obj).1.feasible $
  let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
  begin
    cases h : T'.2,
    { refine or.inr ⟨obj, _⟩,
      simp [sign_of_max_row, h],
      exact le_of_not_ge (by simpa using termination_eq_while_iff.1 h) },
    { refine or.inl ⟨c, _⟩,
      simp [sign_of_max_row, h] },
    { refine or.inr ⟨obj, _⟩,
      simp [sign_of_max_row, h] at *,
      split_ifs at h0; simp [*, show ¬ (1 : ℤ) ≤ 0, from dec_trivial] at * }
  end

lemma rowg_sign_of_max_row_of_le_zero {T : stableau m n} {obj : fin m}
  (h1 : (T.sign_of_max_row obj).2 ≤ 0) :
  (T.sign_of_max_row obj).1.to_partition.rowg obj = T.to_partition.rowg obj :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
by cases h : T'.2; simp [sign_of_max_row, *, show ¬ (1 : ℤ) ≤ 0, from dec_trivial] at *

lemma const_sign_of_max_row_eq_zero_of_eq_zero {T : stableau m n} {obj : fin m}
  (h : (T.sign_of_max_row obj).2 = 0) : (T.sign_of_max_row obj).1.const obj 0 = 0 :=
let T' := T.simplex (λ T', T'.const obj 0 ≤ 0) obj in
by cases h : T'.2; simp [sign_of_max_row, *] at *; split_ifs at *; simp * at *

end sign_of_max_row

section to_row

def to_row_pivot_row (T : stableau m n) (j : fin n) : option (fin m) :=
((list.fin_range m).filter (λ i, (T.to_partition.rowg i ∈ T.restricted ∧
  T.to_matrix i j < 0))).argmax (λ i, T.const i 0 / T.to_matrix i j)

lemma feasible_to_row_pivot_row {T : stableau m n} (j : fin n) (i)
  (hr : i ∈ to_row_pivot_row T j) : (T.to_tableau.pivot i j).feasible :=
begin
  unfold to_row_pivot_row at hr,
  simp only [to_row_pivot_row, list.mem_argmax_iff, list.mem_filter] at hr,
  refine feasible_pivot T.feasible (by tauto) (by tauto) _,
  assume i' hii hij0,
  have hi'j0 : T.to_matrix i' j < 0,
    from neg_of_mul_pos_left hij0 (inv_nonpos.2 $ le_of_lt $ by tauto),
  rw [abs_of_nonpos (div_nonpos_of_nonneg_of_neg (T.feasible _ hii) hi'j0),
    abs_of_nonpos (div_nonpos_of_nonneg_of_neg (T.feasible i (by tauto)) hr.1.2.2), neg_le_neg_iff],
  apply hr.2.1,
  simp,
  tauto
end

/-- pivot a row into a column. makes no sense given a dead column -/
def to_row (T : stableau m n) (j : fin n) : stableau m n × option (fin m) :=
match to_row_pivot_row T j, feasible_to_row_pivot_row j with
| none, h := (T, none)
| some i, h :=
  ({ feasible := h _ rfl,
     undo_stack := T.undo_stack,
     ..T.to_tableau.pivot i j },
  some i)
end

@[simp] lemma to_row_snd_eq_to_row_pivot_row (T : stableau m n) (j : fin n) :
  (T.to_row j).2 = to_row_pivot_row T j :=
begin
  dsimp [to_row],
  cases h : to_row_pivot_row T j; simp [*, h, to_row._match_1]
end

lemma to_row_eq_none_iff_eq_self {T : stableau m n} {j : fin n} : (T.to_row j).2 = none ↔
  (T.to_row j).1 = T :=
begin
  dsimp [to_row],
  cases h : to_row_pivot_row T j,
  { simp [h, to_row._match_1] },
  { simp [h, to_row._match_1],
    dsimp [to_row_pivot_row] at h,
    cases T with T hT, cases T,
    simp }
end

lemma to_row_eq_none {T : stableau m n} {j : fin n} (hdead : j ∉ T.dead): (T.to_row j).2 = none →
  (is_unbounded_above T (T.to_partition.colg j)) :=
begin
  dsimp [to_row],
  cases h : to_row_pivot_row T j,
  { simp only [h, to_row._match_1],
    dsimp [to_row_pivot_row] at h,
    simp only [true_and, forall_prop_of_true, eq_self_iff_true],
    exact is_unbounded_above_colg T.feasible hdead (by simpa [list.filter_eq_nil] using h) },
  { simp [h, to_row._match_1] }
end

lemma to_row_eq_pivot_of_mem {T : stableau m n} {i : fin m} {j : fin n} (hr : i ∈ (T.to_row j).2) :
  (T.to_row j).1.to_tableau = T.to_tableau.pivot i j :=
begin
  dsimp [to_row] at *,
  cases h : to_row_pivot_row T j;
  simp only [*, to_row._match_1, tableau.eta, option.not_mem_none, option.mem_def,
    option.some_inj] at *
end

lemma ne_zero_of_mem_to_row {T : stableau m n} {i : fin m} {j : fin n} (hr : i ∈ (T.to_row j).2) :
  T.to_matrix i j ≠ 0 :=
λ h0, by simpa [list.argmax_eq_some_iff, h0, lt_irrefl, to_row_snd_eq_to_row_pivot_row,
  to_row_pivot_row] using hr

lemma colg_to_row_eq_of_mem {T : stableau m n} {i : fin m} {j : fin n} (hr : i ∈ (T.to_row j).2) :
  (T.to_row j).1.to_partition.colg j = T.to_partition.rowg i :=
by rw [to_row_eq_pivot_of_mem hr, to_partition_pivot, colg_swap]

lemma rowg_to_row_eq_of_mem {T : stableau m n} {i : fin m} {j : fin n} (hr : i ∈ (T.to_row j).2) :
  (T.to_row j).1.to_partition.rowg i = T.to_partition.colg j :=
by rw [to_row_eq_pivot_of_mem hr, to_partition_pivot, rowg_swap]

lemma to_row_eq_self_or_pivot (T : stableau m n) (j : fin n) :
  (T.to_row j).1 = T ∨ ∃ i, T.to_matrix i j ≠ 0 ∧
  (T.to_row j).1.to_tableau = T.to_tableau.pivot i j :=
begin
  cases h : (T.to_row j).2 with i,
  { exact or.inl (to_row_eq_none_iff_eq_self.1 h) },
  { exact or.inr ⟨i, ne_zero_of_mem_to_row h, (to_row_eq_pivot_of_mem h)⟩ }
end

@[simp] lemma flat_to_row (T : stableau m n) (j : fin n) : (T.to_row j).1.flat = T.flat :=
(to_row_eq_self_or_pivot T j).elim (congr_arg _)
  (λ ⟨r, hr0, hr⟩, by rw [flat, hr]; exact flat_pivot hr0)

@[simp] lemma res_set_to_row (T : stableau m n) (j : fin n) : (T.to_row j).1.res_set = T.res_set :=
(to_row_eq_self_or_pivot T j).elim (congr_arg _)
  (λ ⟨r, hr0, hr⟩, by rw [res_set, hr]; exact res_set_pivot hr0)

@[simp] lemma dead_set_to_row (T : stableau m n) (j : fin n) (hdead : j ∉ T.dead):
  (T.to_row j).1.dead_set = T.dead_set :=
(to_row_eq_self_or_pivot T j).elim (congr_arg _)
  (λ ⟨r, hr0, hr⟩, by rw [dead_set, hr]; exact dead_set_pivot hr0 hdead)

@[simp] lemma sol_set_to_row (T : stableau m n) (j : fin n) (hdead : j ∉ T.dead) :
  (T.to_row j).1.sol_set = T.sol_set :=
by simp [sol_set_eq_res_set_inter_dead_set, dead_set_to_row T j hdead]

@[simp] lemma undo_stack_to_row (T : stableau m n) (j : fin n) :
  (T.to_row j).1.undo_stack = T.undo_stack :=
by dsimp [to_row]; cases h : T.to_row_pivot_row j; simp [h, to_row._match_1]

@[simp] lemma dead_to_row (T : stableau m n) (j : fin n) : (T.to_row j).1.dead = T.dead :=
(to_row_eq_self_or_pivot T j).elim (λ h, by rw h) (λ ⟨r, _, hr⟩, hr.symm ▸ rfl)

@[simp] lemma restricted_to_row (T : stableau m n) (j : fin n) :
  (T.to_row j).1.restricted = T.restricted :=
(to_row_eq_self_or_pivot T j).elim (λ h, by rw h) (λ ⟨r, _, hr⟩, hr.symm ▸ rfl)

end to_row

section sign_of_max

def sign_of_max (T : stableau m n) (v : fin (m + n)) : stableau m n × ℤ :=
row_col_cases_on T.to_partition v (sign_of_max_row T)
  (λ j, if j ∈ T.dead then (T, 0)
    else let (T', i) := T.to_row j in
      option.cases_on i (T', 1) (sign_of_max_row T'))

lemma sign_of_max_rowg (T : stableau m n) (i : fin m) :
  sign_of_max T (T.to_partition.rowg i) = sign_of_max_row T i :=
by simp [sign_of_max]

lemma sign_of_max_colg_of_dead (T : stableau m n) (j : fin n) (hdead : j ∈ T.dead) :
  sign_of_max T (T.to_partition.colg j) = (T, 0) :=
by simp [sign_of_max, hdead]

lemma sign_of_max_colg_of_not_dead (T : stableau m n) (j : fin n) (hdead : j ∉ T.dead) :
  sign_of_max T (T.to_partition.colg j) = option.cases_on (T.to_row j).2 ((T.to_row j).1, 1)
  (sign_of_max_row (T.to_row j).1) :=
by simp [sign_of_max, hdead]; cases (T.to_row j); refl

lemma sign_of_max_eq_zero {T : stableau m n} {v : fin (m + n)} :
  (sign_of_max T v).2 = 0 ↔ ∃ x : cvec (m + n), x v 0 = 0 ∧ is_optimal T x v :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp only [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff];
      exact ⟨T.of_col 0, by simp [of_col], by simp, λ y hy, by simp [hy.2 j hdead, of_col]⟩
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r,
      { simp only [h, not_exists, false_iff, not_and, one_ne_zero],
        exact λ _ _, not_optimal_of_unbounded_above (to_row_eq_none hdead h) },
      { simp [sign_of_max_row_eq_zero, to_row_eq_pivot_of_mem h, is_optimal, tableau.is_optimal,
          sol_set_pivot (ne_zero_of_mem_to_row h) hdead] }
    end)

lemma sign_of_max_eq_one {T : stableau m n} {v : fin (m + n)} :
  (sign_of_max T v).2 = 1 ↔ ∃ x : cvec (m + n), x ∈ sol_set T ∧ 0 < x v 0 :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_one])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp only [sign_of_max_colg_of_dead T j hdead, hj, zero_ne_one, false_iff,
        not_exists, not_and, not_lt];
      exact λ x hx, by rw [hx.2 _ hdead]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r,
      { cases to_row_eq_none hdead h 1 with x hx,
        simp only [hj, true_iff, eq_self_iff_true],
        use [x, hx.1],
        exact lt_of_lt_of_le zero_lt_one hx.2 },
      { simp [h, sign_of_max_row_eq_one, rowg_to_row_eq_of_mem h, sol_set_to_row _ _ hdead] }
    end)

lemma sign_of_max_eq_neg_one {T : stableau m n} {v : fin (m + n)} :
  (sign_of_max T v).2 = -1 ↔ ∀ x : cvec (m + n), x ∈ sol_set T → x v 0 < 0 :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_neg_one])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp only [hj, sign_of_max_colg_of_dead _ _ hdead, eq_neg_iff_add_eq_zero,
        classical.not_forall,exists_prop, not_lt,zero_add, one_ne_zero, false_iff];
      exact ⟨T.of_col 0, by simp [of_col]⟩
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead T j hdead],
      cases h : (T.to_row j).2 with r,
      { simpa [sol_set, hj, false_iff, show (1 : ℤ) ≠ -1, by norm_num,
          classical.not_forall, not_lt, exists_prop] using to_row_eq_none hdead h 0 },
      { simp [h, sign_of_max_row_eq_neg_one, rowg_to_row_eq_of_mem h, sol_set_to_row _ _ hdead] }
    end)

lemma feasible_restrict_sign_of_max {T : stableau m n} {v : fin (m + n)}
  (h0 : 0 ≤ (sign_of_max T v).2) : ((T.sign_of_max v).1.to_tableau.restrict v).feasible :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by rw [hr, sign_of_max_rowg] at ⊢ h0;
    exact feasible_restrict_sign_of_max_row _ _ h0)
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by rw [hj, sign_of_max_colg_of_dead _ _ hdead] at ⊢ h0;
      exact tableau.feasible_restrict T.feasible (or.inl ⟨j, rfl⟩)
    else begin
      rw [hj, sign_of_max_colg_of_not_dead _ _ hdead] at ⊢ h0,
      cases h : (T.to_row j).2 with i,
      { exact tableau.feasible_restrict (stableau.feasible _)
          (or.inl ⟨j, by simp [to_row_eq_none_iff_eq_self.1 h]⟩) },
      { have : T.to_partition.colg j = (T.to_row j).1.to_partition.rowg i,
        { simp [to_row_eq_pivot_of_mem h] },
        rw this,
        exact feasible_restrict_sign_of_max_row _ _ (by rwa h at h0) }
    end)

@[simp] lemma restricted_sign_of_max (T : stableau m n) (v : fin (m + n)) :
  (T.sign_of_max v).1.restricted = T.restricted :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r,
      { simp [h, not_exists, false_iff, not_and, one_ne_zero] },
      { simp [sign_of_max_row_eq_zero, to_row_eq_pivot_of_mem h, is_optimal, tableau.is_optimal,
          sol_set_pivot (ne_zero_of_mem_to_row h) hdead] }
    end)

@[simp] lemma dead_sign_of_max (T : stableau m n) (v : fin (m + n)) :
  (T.sign_of_max v).1.dead = T.dead :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r,
      { simp [h, not_exists, false_iff, not_and, one_ne_zero] },
      { simp [sign_of_max_row_eq_zero, to_row_eq_pivot_of_mem h, is_optimal, tableau.is_optimal,
          sol_set_pivot (ne_zero_of_mem_to_row h) hdead] }
    end)

@[simp] lemma undo_stack_sign_of_max (T : stableau m n) (v : fin (m + n)) :
  (T.sign_of_max v).1.undo_stack = T.undo_stack :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r,
      { simp [h, not_exists, false_iff, not_and, one_ne_zero] },
      { simp [sign_of_max_row_eq_zero, to_row_eq_pivot_of_mem h, is_optimal, tableau.is_optimal,
          sol_set_pivot (ne_zero_of_mem_to_row h) hdead] }
    end)

@[simp] lemma flat_sign_of_max (T : stableau m n) (v : fin (m + n)) :
  (T.sign_of_max v).1.flat = T.flat :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r,
      { simp [h, not_exists, false_iff, not_and, one_ne_zero] },
      { simp [sign_of_max_row_eq_zero, to_row_eq_pivot_of_mem h, is_optimal, tableau.is_optimal,
          sol_set_pivot (ne_zero_of_mem_to_row h) hdead] }
    end)

@[simp] lemma dead_set_sign_of_max (T : stableau m n) (v : fin (m + n)) :
  (T.sign_of_max v).1.dead_set = T.dead_set :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r; simp [h, dead_set_to_row _ _ hdead]
    end)

@[simp] lemma res_set_sign_of_max (T : stableau m n) (v : fin (m + n)) :
  (T.sign_of_max v).1.res_set = T.res_set :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r; simp [h, dead_set_to_row _ _ hdead]
    end)

@[simp] lemma sol_set_sign_of_max (T : stableau m n) (v : fin (m + n)) :
  (T.sign_of_max v).1.sol_set = T.sol_set :=
(eq_rowg_or_colg T.to_partition v).elim
  (λ ⟨r, hr⟩, by simp [sign_of_max_rowg, hr, sign_of_max_row_eq_zero])
  (λ ⟨j, hj⟩, if hdead : j ∈ T.dead
    then by simp [sign_of_max_colg_of_dead T j hdead, hj, eq_self_iff_true, true_iff]
    else begin
      simp only [hj, sign_of_max_colg_of_not_dead _ _ hdead],
      cases h : (T.to_row j).2 with r; simp [h, sol_set_to_row _ _ hdead]
    end)

end sign_of_max

-- section kill_col

-- variable (T : stableau m n)

-- def kill_col (j : fin n) : stableau m n :=
-- { to_tableau := T.to_tableau.kill_col c,
--   undo_stack := revive_col c.1 :: T.undo_stack,
--   feasible   := T.feasible }

-- @[simp] lemma to_matrix_kill_col (j : fin n) :
--   (T.kill_col c).to_matrix = T.to_matrix := rfl

-- @[simp] lemma const_kill_col (j : fin n) : (T.kill_col c).const = T.const := rfl

-- @[simp] lemma to_partition_kill_col (j : fin n) :
--   (T.kill_col c).to_partition = T.to_partition := rfl

-- @[simp] lemma dead_kill_col (j : fin n) : (T.kill_col c).dead = insert c T.dead := rfl

-- @[simp] lemma restricted_kill_col (j : fin n) :
--   (T.kill_col c).restricted = T.restricted := rfl

-- @[simp] lemma flat_kill_col (j : fin n) : (T.kill_col c).flat = T.flat :=
-- tableau.flat_kill_col _

-- @[simp] lemma res_set_kill_col (j : fin n) : (T.kill_col c).res_set = T.res_set :=
-- tableau.res_set_kill_col _

-- @[simp] lemma dead_set_kill_col (j : fin n) : (T.kill_col c).dead_set =
--   T.dead_set ∩ {x | x (T.to_partition.colg j) 0 = 0} :=
-- tableau.dead_set_kill_col _

-- lemma sol_set_kill_col (j : fin n) : (T.kill_col c).sol_set =
--   T.sol_set ∩ {x | x (T.to_partition.colg j) 0 = 0} :=
-- tableau.sol_set_kill_col _

-- end kill_col

section restrict

def restrict (T : stableau m n) (v : fin (m + n)) (h : (T.to_tableau.restrict v).feasible) :
  stableau m n :=
{ to_tableau := T.to_tableau.restrict v,
  feasible := h,
  undo_stack := unrestrict v.1 :: T.undo_stack }

end restrict

section close_row

/-- Only to be used immediately after `sign_of_max_row` -/
def close_row (T : stableau m n) (i : fin m) : stableau m n :=
let s : list (fin n) := (list.fin_range n).filter (λ j, T.to_matrix i j < 0) in
{ dead := T.dead ∪ ⟨s, list.nodup_filter _ (list.nodup_fin_range _)⟩,
  undo_stack := s.map (λ j, revive_col j.val) ++ T.undo_stack,
  ..T }

@[simp] lemma to_matrix_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).to_matrix = T.to_matrix := rfl

@[simp] lemma const_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).const = T.const := rfl

@[simp] lemma to_partition_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).to_partition = T.to_partition := rfl

@[simp] lemma restricted_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).restricted = T.restricted := rfl

lemma dead_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).dead = T.dead ∪ univ.filter (λ j, T.to_matrix i j < 0) :=
by simp [finset.ext, close_row]

lemma undo_stack_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).undo_stack = ((list.fin_range n).filter (λ j, T.to_matrix i j < 0)).map
    (λ j, revive_col j.val) ++ T.undo_stack := rfl

@[simp] lemma flat_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).flat = T.flat := rfl

@[simp] lemma res_set_close_row (T : stableau m n) (i : fin m) :
  (T.close_row i).res_set = T.res_set := rfl

lemma sol_set_close_row_subset (T : stableau m n) (i : fin m) :
  (T.close_row i).sol_set ⊆ T.sol_set :=
λ _, by simp [sol_set, tableau.sol_set, tableau.res_set, close_row, tableau.flat] {contextual := tt}

lemma sol_set_close_row_sign_of_max_row (T : stableau m n) (i : fin m)
  (hres : (T.sign_of_max_row i).1.to_partition.rowg i ∈ T.restricted)
  (h0 : (T.sign_of_max_row i).2 = 0) :
  ((T.sign_of_max_row i).1.close_row i).sol_set = T.sol_set :=
have hsub : ((T.sign_of_max_row i).1.close_row i).sol_set ⊆ T.sol_set,
  by simpa using sol_set_close_row_subset (sign_of_max_row T i).1 i,
set.subset.antisymm hsub
  (λ x hx, begin
    rw [← sign_of_max_row_sol_set _ i] at hx,
    refine ⟨hx.1, λ j hj, _⟩,
    rw [dead_close_row, finset.mem_union, finset.mem_filter] at hj,
    cases hj with hj hj,
    { simpa using hx.2 _ hj },
    { cases sign_of_max_row_eq_zero.1 h0 with y hy,
      { have hx0 : x ((sign_of_max_row T i).fst.to_partition.rowg i) 0 = 0,
          from le_antisymm (le_trans begin
            rw [rowg_sign_of_max_row_of_le_zero],
            exact hy.2.2 x (by simpa using hx),
            simp * at *
          end
            (le_of_eq hy.1))
          (hx.1.2 _ (by simpa using hres)),
        have hj'0 : ∀ j', (sign_of_max_row T i).fst.to_matrix i j' *
          x ((sign_of_max_row T i).fst.to_partition.colg j') 0 ≤ 0,
        { assume j',
          by_cases hdead : j' ∈ T.dead,
          { have := hx.2 j', simp * at * },
          { cases (optimal_and_neg_of_sign_of_max_row_eq_zero h0).2 j'
              (by simpa using hdead) with h h,
            { simp [h.1] },
            { exact mul_nonpos_of_nonpos_of_nonneg h.1 (hx.1.2 _ h.2) } } },
        rw [mem_flat_iff.1 hx.1.1, const_sign_of_max_row_eq_zero_of_eq_zero h0, add_zero] at hx0,
        exact (mul_eq_zero.1 ((sum_eq_zero_iff_of_nonpos (λ j' hj', hj'0 j')).1 hx0 _
            (mem_univ j))).resolve_left
          (ne_of_lt hj.2) } }
  end)

end close_row

section assert_ge

def assert_ge (T : stableau m n) (fac : rvec (m + n)) (k : ℚ) : stableau (m + 1) n × bool :=
let T' := sign_of_max (T.add_row fac k) fin.lastp in
if hneg : T'.2 < 0 then (T'.1, ff)
  else if T'.2 = 0 then (T'.1.close_row $ fin.last _, tt)
    else (T'.1.restrict fin.lastp (feasible_restrict_sign_of_max $ le_of_not_gt hneg), tt)

end assert_ge

end stableau


/-
Copyright (c) 2022 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Amelia Livingston

! This file was ported from Lean 3 source module algebra.homology.opposite
! leanprover-community/mathlib commit 8c75ef3517d4106e89fe524e6281d0b0545f47fc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Abelian.Opposite
import Mathbin.CategoryTheory.Abelian.Homology
import Mathbin.Algebra.Homology.Additive

/-!
# Opposite categories of complexes
Given a preadditive category `V`, the opposite of its category of chain complexes is equivalent to
the category of cochain complexes of objects in `Vᵒᵖ`. We define this equivalence, and another
analagous equivalence (for a general category of homological complexes with a general
complex shape).

We then show that when `V` is abelian, if `C` is a homological complex, then the homology of
`op(C)` is isomorphic to `op` of the homology of `C` (and the analagous result for `unop`).

## Implementation notes
It is convenient to define both `op` and `op_symm`; this is because given a complex shape `c`,
`c.symm.symm` is not defeq to `c`.

## Tags
opposite, chain complex, cochain complex, homology, cohomology, homological complex
-/

noncomputable section

open Opposite CategoryTheory CategoryTheory.Limits

section

variable {V : Type _} [Category V] [Abelian V]

theorem imageToKernel_op {X Y Z : V} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
    imageToKernel g.op f.op (by rw [← op_comp, w, op_zero]) =
      (imageSubobjectIso _ ≪≫ (imageOpOp _).symm).Hom ≫
        (cokernel.desc f (factorThruImage g)
              (by rw [← cancel_mono (image.ι g), category.assoc, image.fac, w, zero_comp])).op ≫
          (kernelSubobjectIso _ ≪≫ kernelOpOp _).inv :=
  by
  ext
  simpa only [iso.trans_hom, iso.symm_hom, iso.trans_inv, kernel_op_op_inv, category.assoc,
    imageToKernel_arrow, kernel_subobject_arrow', kernel.lift_ι, ← op_comp, cokernel.π_desc, ←
    image_subobject_arrow, ← image_unop_op_inv_comp_op_factor_thru_image g.op]
#align image_to_kernel_op imageToKernel_op

theorem imageToKernel_unop {X Y Z : Vᵒᵖ} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
    imageToKernel g.unop f.unop (by rw [← unop_comp, w, unop_zero]) =
      (imageSubobjectIso _ ≪≫ (imageUnopUnop _).symm).Hom ≫
        (cokernel.desc f (factorThruImage g)
              (by rw [← cancel_mono (image.ι g), category.assoc, image.fac, w, zero_comp])).unop ≫
          (kernelSubobjectIso _ ≪≫ kernelUnopUnop _).inv :=
  by
  ext
  dsimp only [image_unop_unop]
  simp only [iso.trans_hom, iso.symm_hom, iso.trans_inv, kernel_unop_unop_inv, category.assoc,
    imageToKernel_arrow, kernel_subobject_arrow', kernel.lift_ι, cokernel.π_desc, iso.unop_inv, ←
    unop_comp, factor_thru_image_comp_image_unop_op_inv, Quiver.Hom.unop_op, image_subobject_arrow]
#align image_to_kernel_unop imageToKernel_unop

/-- Given `f, g` with `f ≫ g = 0`, the homology of `g.op, f.op` is the opposite of the homology of
`f, g`. -/
def homologyOp {X Y Z : V} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
    homology g.op f.op (by rw [← op_comp, w, op_zero]) ≅ Opposite.op (homology f g w) :=
  cokernelIsoOfEq (imageToKernel_op _ _ w) ≪≫
    cokernelEpiComp _ _ ≪≫
      cokernelCompIsIso _ _ ≪≫
        cokernelOpOp _ ≪≫
          (homologyIsoKernelDesc _ _ _ ≪≫
              kernelIsoOfEq
                  (by ext <;> simp only [image.fac, cokernel.π_desc, cokernel.π_desc_assoc]) ≪≫
                kernelCompMono _ (image.ι g)).op
#align homology_op homologyOp

/-- Given morphisms `f, g` in `Vᵒᵖ` with `f ≫ g = 0`, the homology of `g.unop, f.unop` is the
opposite of the homology of `f, g`. -/
def homologyUnop {X Y Z : Vᵒᵖ} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
    homology g.unop f.unop (by rw [← unop_comp, w, unop_zero]) ≅ Opposite.unop (homology f g w) :=
  cokernelIsoOfEq (imageToKernel_unop _ _ w) ≪≫
    cokernelEpiComp _ _ ≪≫
      cokernelCompIsIso _ _ ≪≫
        cokernelUnopUnop _ ≪≫
          (homologyIsoKernelDesc _ _ _ ≪≫
              kernelIsoOfEq
                  (by ext <;> simp only [image.fac, cokernel.π_desc, cokernel.π_desc_assoc]) ≪≫
                kernelCompMono _ (image.ι g)).unop
#align homology_unop homologyUnop

end

namespace HomologicalComplex

variable {ι V : Type _} [Category V] {c : ComplexShape ι}

section

variable [Preadditive V]

/-- Sends a complex `X` with objects in `V` to the corresponding complex with objects in `Vᵒᵖ`. -/
@[simps]
protected def op (X : HomologicalComplex V c) : HomologicalComplex Vᵒᵖ c.symm
    where
  pt i := op (X.pt i)
  d i j := (X.d j i).op
  shape' i j hij := by rw [X.shape j i hij, op_zero]
  d_comp_d' := by
    intros
    rw [← op_comp, X.d_comp_d, op_zero]
#align homological_complex.op HomologicalComplex.op

/-- Sends a complex `X` with objects in `V` to the corresponding complex with objects in `Vᵒᵖ`. -/
@[simps]
protected def opSymm (X : HomologicalComplex V c.symm) : HomologicalComplex Vᵒᵖ c
    where
  pt i := op (X.pt i)
  d i j := (X.d j i).op
  shape' i j hij := by rw [X.shape j i hij, op_zero]
  d_comp_d' := by
    intros
    rw [← op_comp, X.d_comp_d, op_zero]
#align homological_complex.op_symm HomologicalComplex.opSymm

/-- Sends a complex `X` with objects in `Vᵒᵖ` to the corresponding complex with objects in `V`. -/
@[simps]
protected def unop (X : HomologicalComplex Vᵒᵖ c) : HomologicalComplex V c.symm
    where
  pt i := unop (X.pt i)
  d i j := (X.d j i).unop
  shape' i j hij := by rw [X.shape j i hij, unop_zero]
  d_comp_d' := by
    intros
    rw [← unop_comp, X.d_comp_d, unop_zero]
#align homological_complex.unop HomologicalComplex.unop

/-- Sends a complex `X` with objects in `Vᵒᵖ` to the corresponding complex with objects in `V`. -/
@[simps]
protected def unopSymm (X : HomologicalComplex Vᵒᵖ c.symm) : HomologicalComplex V c
    where
  pt i := unop (X.pt i)
  d i j := (X.d j i).unop
  shape' i j hij := by rw [X.shape j i hij, unop_zero]
  d_comp_d' := by
    intros
    rw [← unop_comp, X.d_comp_d, unop_zero]
#align homological_complex.unop_symm HomologicalComplex.unopSymm

variable (V c)

/-- Auxilliary definition for `op_equivalence`. -/
@[simps]
def opFunctor : (HomologicalComplex V c)ᵒᵖ ⥤ HomologicalComplex Vᵒᵖ c.symm
    where
  obj X := (unop X).op
  map X Y f :=
    { f := fun i => (f.unop.f i).op
      comm' := fun i j hij => by simp only [op_d, ← op_comp, f.unop.comm] }
#align homological_complex.op_functor HomologicalComplex.opFunctor

/-- Auxilliary definition for `op_equivalence`. -/
@[simps]
def opInverse : HomologicalComplex Vᵒᵖ c.symm ⥤ (HomologicalComplex V c)ᵒᵖ
    where
  obj X := op X.unopSymm
  map X Y f :=
    Quiver.Hom.op
      { f := fun i => (f.f i).unop
        comm' := fun i j hij => by simp only [unop_symm_d, ← unop_comp, f.comm] }
#align homological_complex.op_inverse HomologicalComplex.opInverse

/-- Auxilliary definition for `op_equivalence`. -/
def opUnitIso : 𝟭 (HomologicalComplex V c)ᵒᵖ ≅ opFunctor V c ⋙ opInverse V c :=
  NatIso.ofComponents
    (fun X =>
      (HomologicalComplex.Hom.isoOfComponents (fun i => Iso.refl _) fun i j hij => by
            simp only [iso.refl_hom, category.id_comp, unop_symm_d, op_d, Quiver.Hom.unop_op,
              category.comp_id] :
          (Opposite.unop X).op.unopSymm ≅ unop X).op)
    (by
      intro X Y f
      refine' Quiver.Hom.unop_inj _
      ext
      simp only [Quiver.Hom.unop_op, functor.id_map, iso.op_hom, functor.comp_map, unop_comp,
        comp_f, hom.iso_of_components_hom_f]
      erw [category.id_comp, category.comp_id (f.unop.f x)])
#align homological_complex.op_unit_iso HomologicalComplex.opUnitIso

/-- Auxilliary definition for `op_equivalence`. -/
def opCounitIso : opInverse V c ⋙ opFunctor V c ≅ 𝟭 (HomologicalComplex Vᵒᵖ c.symm) :=
  NatIso.ofComponents
    (fun X =>
      HomologicalComplex.Hom.isoOfComponents (fun i => Iso.refl _) fun i j hij => by
        simpa only [iso.refl_hom, category.id_comp, category.comp_id] )
    (by
      intro X Y f
      ext
      simpa only [Quiver.Hom.unop_op, Quiver.Hom.op_unop, functor.comp_map, functor.id_map,
        iso.refl_hom, category.id_comp, category.comp_id, comp_f, hom.iso_of_components_hom_f] )
#align homological_complex.op_counit_iso HomologicalComplex.opCounitIso

/-- Given a category of complexes with objects in `V`, there is a natural equivalence between its
opposite category and a category of complexes with objects in `Vᵒᵖ`. -/
@[simps]
def opEquivalence : (HomologicalComplex V c)ᵒᵖ ≌ HomologicalComplex Vᵒᵖ c.symm
    where
  Functor := opFunctor V c
  inverse := opInverse V c
  unitIso := opUnitIso V c
  counitIso := opCounitIso V c
  functor_unitIso_comp' := by
    intro X
    ext
    simp only [op_unit_iso, op_counit_iso, nat_iso.of_components_hom_app, iso.op_hom, comp_f,
      op_functor_map_f, Quiver.Hom.unop_op, hom.iso_of_components_hom_f]
    exact category.comp_id _
#align homological_complex.op_equivalence HomologicalComplex.opEquivalence

/-- Auxilliary definition for `unop_equivalence`. -/
@[simps]
def unopFunctor : (HomologicalComplex Vᵒᵖ c)ᵒᵖ ⥤ HomologicalComplex V c.symm
    where
  obj X := (unop X).unop
  map X Y f :=
    { f := fun i => (f.unop.f i).unop
      comm' := fun i j hij => by simp only [unop_d, ← unop_comp, f.unop.comm] }
#align homological_complex.unop_functor HomologicalComplex.unopFunctor

/-- Auxilliary definition for `unop_equivalence`. -/
@[simps]
def unopInverse : HomologicalComplex V c.symm ⥤ (HomologicalComplex Vᵒᵖ c)ᵒᵖ
    where
  obj X := op X.opSymm
  map X Y f :=
    Quiver.Hom.op
      { f := fun i => (f.f i).op
        comm' := fun i j hij => by simp only [op_symm_d, ← op_comp, f.comm] }
#align homological_complex.unop_inverse HomologicalComplex.unopInverse

/-- Auxilliary definition for `unop_equivalence`. -/
def unopUnitIso : 𝟭 (HomologicalComplex Vᵒᵖ c)ᵒᵖ ≅ unopFunctor V c ⋙ unopInverse V c :=
  NatIso.ofComponents
    (fun X =>
      (HomologicalComplex.Hom.isoOfComponents (fun i => Iso.refl _) fun i j hij => by
            simp only [iso.refl_hom, category.id_comp, unop_symm_d, op_d, Quiver.Hom.unop_op,
              category.comp_id] :
          (Opposite.unop X).op.unopSymm ≅ unop X).op)
    (by
      intro X Y f
      refine' Quiver.Hom.unop_inj _
      ext
      simp only [Quiver.Hom.unop_op, functor.id_map, iso.op_hom, functor.comp_map, unop_comp,
        comp_f, hom.iso_of_components_hom_f]
      erw [category.id_comp, category.comp_id (f.unop.f x)])
#align homological_complex.unop_unit_iso HomologicalComplex.unopUnitIso

/-- Auxilliary definition for `unop_equivalence`. -/
def unopCounitIso : unopInverse V c ⋙ unopFunctor V c ≅ 𝟭 (HomologicalComplex V c.symm) :=
  NatIso.ofComponents
    (fun X =>
      HomologicalComplex.Hom.isoOfComponents (fun i => Iso.refl _) fun i j hij => by
        simpa only [iso.refl_hom, category.id_comp, category.comp_id] )
    (by
      intro X Y f
      ext
      simpa only [Quiver.Hom.unop_op, Quiver.Hom.op_unop, functor.comp_map, functor.id_map,
        iso.refl_hom, category.id_comp, category.comp_id, comp_f, hom.iso_of_components_hom_f] )
#align homological_complex.unop_counit_iso HomologicalComplex.unopCounitIso

/-- Given a category of complexes with objects in `Vᵒᵖ`, there is a natural equivalence between its
opposite category and a category of complexes with objects in `V`. -/
@[simps]
def unopEquivalence : (HomologicalComplex Vᵒᵖ c)ᵒᵖ ≌ HomologicalComplex V c.symm
    where
  Functor := unopFunctor V c
  inverse := unopInverse V c
  unitIso := unopUnitIso V c
  counitIso := unopCounitIso V c
  functor_unitIso_comp' := by
    intro X
    ext
    simp only [op_unit_iso, op_counit_iso, nat_iso.of_components_hom_app, iso.op_hom, comp_f,
      op_functor_map_f, Quiver.Hom.unop_op, hom.iso_of_components_hom_f]
    exact category.comp_id _
#align homological_complex.unop_equivalence HomologicalComplex.unopEquivalence

variable {V c}

instance opFunctor_additive : (@opFunctor ι V _ c _).Additive where
#align homological_complex.op_functor_additive HomologicalComplex.opFunctor_additive

instance unopFunctor_additive : (@unopFunctor ι V _ c _).Additive where
#align homological_complex.unop_functor_additive HomologicalComplex.unopFunctor_additive

end

variable [Abelian V] (C : HomologicalComplex V c) (i : ι)

/-- Auxilliary tautological definition for `homology_op`. -/
def homologyOpDef :
    C.op.homology i ≅
      homology (C.dFrom i).op (C.dTo i).op (by rw [← op_comp, C.d_to_comp_d_from i, op_zero]) :=
  Iso.refl _
#align homological_complex.homology_op_def HomologicalComplex.homologyOpDef

/-- Given a complex `C` of objects in `V`, the `i`th homology of its 'opposite' complex (with
objects in `Vᵒᵖ`) is the opposite of the `i`th homology of `C`. -/
def homologyOp : C.op.homology i ≅ Opposite.op (C.homology i) :=
  homologyOpDef _ _ ≪≫ homologyOp _ _ _
#align homological_complex.homology_op HomologicalComplex.homologyOp

/-- Auxilliary tautological definition for `homology_unop`. -/
def homologyUnopDef (C : HomologicalComplex Vᵒᵖ c) :
    C.unop.homology i ≅
      homology (C.dFrom i).unop (C.dTo i).unop
        (by rw [← unop_comp, C.d_to_comp_d_from i, unop_zero]) :=
  Iso.refl _
#align homological_complex.homology_unop_def HomologicalComplex.homologyUnopDef

/-- Given a complex `C` of objects in `Vᵒᵖ`, the `i`th homology of its 'opposite' complex (with
objects in `V`) is the opposite of the `i`th homology of `C`. -/
def homologyUnop (C : HomologicalComplex Vᵒᵖ c) :
    C.unop.homology i ≅ Opposite.unop (C.homology i) :=
  homologyUnopDef _ _ ≪≫ homologyUnop _ _ _
#align homological_complex.homology_unop HomologicalComplex.homologyUnop

end HomologicalComplex


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module data.rbtree.main
! leanprover-community/mathlib commit 4d4167104581a21259f7f448e1972a63a4546be7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Rbtree.Find
import Mathbin.Data.Rbtree.Insert
import Mathbin.Data.Rbtree.MinMax
import Mathbin.Order.RelClasses

universe u

namespace Rbnode

variable {α : Type u} {lt : α → α → Prop}

theorem isSearchable_of_wellFormed {t : Rbnode α} [IsStrictWeakOrder α lt] :
    t.WellFormed lt → IsSearchable lt t none none :=
  by
  intro h; induction h
  · constructor
    simp [lift]
  · subst h_n'
    apply is_searchable_insert
    assumption
#align rbnode.is_searchable_of_well_formed Rbnode.isSearchable_of_wellFormed

open Color

theorem isRedBlack_of_wellFormed {t : Rbnode α} : t.WellFormed lt → ∃ c n, IsRedBlack t c n :=
  by
  intro h; induction h
  · exists black
    exists 0
    constructor
  · cases' h_ih with c ih
    cases' ih with n ih
    subst h_n'
    apply insert_is_red_black
    assumption
#align rbnode.is_red_black_of_well_formed Rbnode.isRedBlack_of_wellFormed

end Rbnode

namespace Rbtree

variable {α : Type u} {lt : α → α → Prop}

theorem balanced (t : Rbtree α lt) : t.depth max ≤ 2 * t.depth min + 1 :=
  by
  cases' t with n p; simp only [depth]
  have := Rbnode.isRedBlack_of_wellFormed p
  cases' this with _ this; cases' this with _ this
  apply Rbnode.balanced; assumption
#align rbtree.balanced Rbtree.balanced

theorem not_mem_mkRbtree : ∀ a : α, a ∉ mkRbtree α lt := by
  simp [Membership.Mem, Rbtree.Mem, Rbnode.Mem, mkRbtree]
#align rbtree.not_mem_mk_rbtree Rbtree.not_mem_mkRbtree

theorem not_mem_of_empty {t : Rbtree α lt} (a : α) : t.Empty = true → a ∉ t := by
  cases' t with n p <;> cases n <;>
    simp [Empty, Membership.Mem, Rbtree.Mem, Rbnode.Mem, false_imp_iff]
#align rbtree.not_mem_of_empty Rbtree.not_mem_of_empty

theorem mem_of_mem_of_eqv [IsStrictWeakOrder α lt] {t : Rbtree α lt} {a b : α} :
    a ∈ t → a ≈[lt]b → b ∈ t :=
  by
  cases' t with n p <;> simp [Membership.Mem, Rbtree.Mem] <;> clear p <;> induction n <;>
        simp only [Rbnode.Mem, StrictWeakOrder.Equiv, false_imp_iff] <;>
      intro h₁ h₂ <;>
    cases_type*or.1
  iterate 2

    · have : Rbnode.Mem lt b n_lchild := n_ih_lchild h₁ h₂
      simp [this]
    · simp [incomp_trans_of lt h₂.swap h₁]
    · have : Rbnode.Mem lt b n_rchild := n_ih_rchild h₁ h₂
      simp [this]
#align rbtree.mem_of_mem_of_eqv Rbtree.mem_of_mem_of_eqv

section Dec

variable [DecidableRel lt]

theorem insert_ne_mkRbtree (t : Rbtree α lt) (a : α) : t.insert a ≠ mkRbtree α lt :=
  by
  cases' t with n p
  simpa [insert, mkRbtree] using Rbnode.insert_ne_leaf lt n a
#align rbtree.insert_ne_mk_rbtree Rbtree.insert_ne_mkRbtree

theorem find_correct [IsStrictWeakOrder α lt] (a : α) (t : Rbtree α lt) :
    a ∈ t ↔ ∃ b, t.find a = some b ∧ a ≈[lt]b := by cases t; apply Rbnode.find_correct;
  apply Rbnode.isSearchable_of_wellFormed; assumption
#align rbtree.find_correct Rbtree.find_correct

theorem find_correct_of_total [IsStrictTotalOrder α lt] (a : α) (t : Rbtree α lt) :
    a ∈ t ↔ t.find a = some a :=
  Iff.intro
    (fun h =>
      match Iff.mp (find_correct a t) h with
      | ⟨b, HEq, heqv⟩ => by simp [HEq, (eq_of_eqv_lt heqv).symm])
    fun h => Iff.mpr (find_correct a t) ⟨a, ⟨h, refl a⟩⟩
#align rbtree.find_correct_of_total Rbtree.find_correct_of_total

theorem find_correct_exact [IsStrictTotalOrder α lt] (a : α) (t : Rbtree α lt) :
    MemExact a t ↔ t.find a = some a := by cases t; apply Rbnode.find_correct_exact;
  apply Rbnode.isSearchable_of_wellFormed; assumption
#align rbtree.find_correct_exact Rbtree.find_correct_exact

theorem find_insert_of_eqv [IsStrictWeakOrder α lt] (t : Rbtree α lt) {x y} :
    x ≈[lt]y → (t.insert x).find y = some x :=
  by
  cases t; intro h; apply Rbnode.find_insert_of_eqv lt h; apply Rbnode.isSearchable_of_wellFormed
  assumption
#align rbtree.find_insert_of_eqv Rbtree.find_insert_of_eqv

theorem find_insert [IsStrictWeakOrder α lt] (t : Rbtree α lt) (x) : (t.insert x).find x = some x :=
  find_insert_of_eqv t (refl x)
#align rbtree.find_insert Rbtree.find_insert

theorem find_insert_of_disj [IsStrictWeakOrder α lt] {x y : α} (t : Rbtree α lt) :
    lt x y ∨ lt y x → (t.insert x).find y = t.find y :=
  by
  cases t; intro h; apply Rbnode.find_insert_of_disj lt h
  apply Rbnode.isSearchable_of_wellFormed
  assumption
#align rbtree.find_insert_of_disj Rbtree.find_insert_of_disj

theorem find_insert_of_not_eqv [IsStrictWeakOrder α lt] {x y : α} (t : Rbtree α lt) :
    ¬x ≈[lt]y → (t.insert x).find y = t.find y :=
  by
  cases t; intro h; apply Rbnode.find_insert_of_not_eqv lt h
  apply Rbnode.isSearchable_of_wellFormed; assumption
#align rbtree.find_insert_of_not_eqv Rbtree.find_insert_of_not_eqv

theorem find_insert_of_ne [IsStrictTotalOrder α lt] {x y : α} (t : Rbtree α lt) :
    x ≠ y → (t.insert x).find y = t.find y :=
  by
  cases t; intro h
  have : ¬x ≈[lt]y := fun h' => h (eq_of_eqv_lt h')
  apply Rbnode.find_insert_of_not_eqv lt this
  apply Rbnode.isSearchable_of_wellFormed; assumption
#align rbtree.find_insert_of_ne Rbtree.find_insert_of_ne

theorem not_mem_of_find_none [IsStrictWeakOrder α lt] {a : α} {t : Rbtree α lt} :
    t.find a = none → a ∉ t := fun h =>
  Iff.mpr (not_congr (find_correct a t)) <| by
    intro h
    cases' h with _ h; cases' h with h₁ h₂
    rw [h] at h₁; contradiction
#align rbtree.not_mem_of_find_none Rbtree.not_mem_of_find_none

theorem eqv_of_find_some [IsStrictWeakOrder α lt] {a b : α} {t : Rbtree α lt} :
    t.find a = some b → a ≈[lt]b := by cases t; apply Rbnode.eqv_of_find_some;
  apply Rbnode.isSearchable_of_wellFormed; assumption
#align rbtree.eqv_of_find_some Rbtree.eqv_of_find_some

theorem eq_of_find_some [IsStrictTotalOrder α lt] {a b : α} {t : Rbtree α lt} :
    t.find a = some b → a = b := fun h =>
  suffices a ≈[lt]b from eq_of_eqv_lt this
  eqv_of_find_some h
#align rbtree.eq_of_find_some Rbtree.eq_of_find_some

theorem mem_of_find_some [IsStrictWeakOrder α lt] {a b : α} {t : Rbtree α lt} :
    t.find a = some b → a ∈ t := fun h => Iff.mpr (find_correct a t) ⟨b, ⟨h, eqv_of_find_some h⟩⟩
#align rbtree.mem_of_find_some Rbtree.mem_of_find_some

theorem find_eq_find_of_eqv [IsStrictWeakOrder α lt] {a b : α} (t : Rbtree α lt) :
    a ≈[lt]b → t.find a = t.find b := by
  cases t; apply Rbnode.find_eq_find_of_eqv
  apply Rbnode.isSearchable_of_wellFormed; assumption
#align rbtree.find_eq_find_of_eqv Rbtree.find_eq_find_of_eqv

theorem contains_correct [IsStrictWeakOrder α lt] (a : α) (t : Rbtree α lt) :
    a ∈ t ↔ t.contains a = true := by
  have h := find_correct a t
  simp [h, contains]; apply Iff.intro
  · intro h'
    cases' h' with _ h'
    cases h'
    simp [*]
    simp [Option.isSome]
  · intro h'
    cases' heq : find t a with v
    simp [HEq, Option.isSome] at h'
    contradiction
    exists v
    simp
    apply eqv_of_find_some HEq
#align rbtree.contains_correct Rbtree.contains_correct

theorem mem_insert_of_incomp {a b : α} (t : Rbtree α lt) : ¬lt a b ∧ ¬lt b a → a ∈ t.insert b := by
  cases t; apply Rbnode.mem_insert_of_incomp
#align rbtree.mem_insert_of_incomp Rbtree.mem_insert_of_incomp

theorem mem_insert [IsIrrefl α lt] : ∀ (a : α) (t : Rbtree α lt), a ∈ t.insert a := by intros ;
  apply mem_insert_of_incomp; constructor <;> apply irrefl_of lt
#align rbtree.mem_insert Rbtree.mem_insert

theorem mem_insert_of_equiv {a b : α} (t : Rbtree α lt) : a ≈[lt]b → a ∈ t.insert b := by cases t;
  apply Rbnode.mem_insert_of_incomp
#align rbtree.mem_insert_of_equiv Rbtree.mem_insert_of_equiv

theorem mem_insert_of_mem [IsStrictWeakOrder α lt] {a : α} {t : Rbtree α lt} (b : α) :
    a ∈ t → a ∈ t.insert b := by cases t; apply Rbnode.mem_insert_of_mem
#align rbtree.mem_insert_of_mem Rbtree.mem_insert_of_mem

theorem equiv_or_mem_of_mem_insert {a b : α} {t : Rbtree α lt} :
    a ∈ t.insert b → a ≈[lt]b ∨ a ∈ t := by cases t; apply Rbnode.equiv_or_mem_of_mem_insert
#align rbtree.equiv_or_mem_of_mem_insert Rbtree.equiv_or_mem_of_mem_insert

theorem incomp_or_mem_of_mem_ins {a b : α} {t : Rbtree α lt} :
    a ∈ t.insert b → ¬lt a b ∧ ¬lt b a ∨ a ∈ t :=
  equiv_or_mem_of_mem_insert
#align rbtree.incomp_or_mem_of_mem_ins Rbtree.incomp_or_mem_of_mem_ins

theorem eq_or_mem_of_mem_ins [IsStrictTotalOrder α lt] {a b : α} {t : Rbtree α lt} :
    a ∈ t.insert b → a = b ∨ a ∈ t := fun h =>
  suffices a ≈[lt]b ∨ a ∈ t by simp [eqv_lt_iff_eq] at this <;> assumption
  incomp_or_mem_of_mem_ins h
#align rbtree.eq_or_mem_of_mem_ins Rbtree.eq_or_mem_of_mem_ins

end Dec

theorem mem_of_min_eq [IsIrrefl α lt] {a : α} {t : Rbtree α lt} : t.min = some a → a ∈ t := by
  cases t; apply Rbnode.mem_of_min_eq
#align rbtree.mem_of_min_eq Rbtree.mem_of_min_eq

theorem mem_of_max_eq [IsIrrefl α lt] {a : α} {t : Rbtree α lt} : t.max = some a → a ∈ t := by
  cases t; apply Rbnode.mem_of_max_eq
#align rbtree.mem_of_max_eq Rbtree.mem_of_max_eq

theorem eq_leaf_of_min_eq_none {t : Rbtree α lt} : t.min = none → t = mkRbtree α lt := by cases t;
  intro h; congr ; apply Rbnode.eq_leaf_of_min_eq_none h
#align rbtree.eq_leaf_of_min_eq_none Rbtree.eq_leaf_of_min_eq_none

theorem eq_leaf_of_max_eq_none {t : Rbtree α lt} : t.max = none → t = mkRbtree α lt := by cases t;
  intro h; congr ; apply Rbnode.eq_leaf_of_max_eq_none h
#align rbtree.eq_leaf_of_max_eq_none Rbtree.eq_leaf_of_max_eq_none

theorem min_is_minimal [IsStrictWeakOrder α lt] {a : α} {t : Rbtree α lt} :
    t.min = some a → ∀ {b}, b ∈ t → a ≈[lt]b ∨ lt a b := by
  classical
    cases t
    apply Rbnode.min_is_minimal
    apply Rbnode.isSearchable_of_wellFormed
    assumption
#align rbtree.min_is_minimal Rbtree.min_is_minimal

theorem max_is_maximal [IsStrictWeakOrder α lt] {a : α} {t : Rbtree α lt} :
    t.max = some a → ∀ {b}, b ∈ t → a ≈[lt]b ∨ lt b a :=
  by
  cases t
  apply Rbnode.max_is_maximal
  apply Rbnode.isSearchable_of_wellFormed
  assumption
#align rbtree.max_is_maximal Rbtree.max_is_maximal

end Rbtree


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.algebra.tower
import linear_algebra.prod

/-!
# Adjoining elements to form subalgebras

This file develops the basic theory of subalgebras of an R-algebra generated
by a set of elements. A basic interface for `adjoin` is set up, and various
results about finitely-generated subalgebras and submodules are proved.

## Definitions

* `fg (S : subalgebra R A)` : A predicate saying that the subalgebra is finitely-generated
as an A-algebra

## Tags

adjoin, algebra, finitely-generated algebra

-/

universes u v w

open_locale pointwise
open submodule subsemiring

variables {R : Type u} {A : Type v} {B : Type w}

namespace algebra

section semiring
variables [comm_semiring R] [semiring A] [semiring B]
variables [algebra R A] [algebra R B] {s t : set A}

theorem subset_adjoin : s ⊆ adjoin R s :=
algebra.gc.le_u_l s

theorem adjoin_le {S : subalgebra R A} (H : s ⊆ S) : adjoin R s ≤ S :=
algebra.gc.l_le H

theorem adjoin_le_iff {S : subalgebra R A} : adjoin R s ≤ S ↔ s ⊆ S:=
algebra.gc _ _

theorem adjoin_eq_of_le (S : subalgebra R A) (h₁ : s ⊆ S) (h₂ : S ≤ adjoin R s) : adjoin R s = S :=
le_antisymm (adjoin_le h₁) h₂

theorem adjoin_eq (S : subalgebra R A) : adjoin R ↑S = S :=
adjoin_eq_of_le _ (set.subset.refl _) subset_adjoin

@[elab_as_eliminator] theorem adjoin_induction {p : A → Prop} {x : A} (h : x ∈ adjoin R s)
  (Hs : ∀ x ∈ s, p x)
  (Halg : ∀ r, p (algebra_map R A r))
  (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
let S : subalgebra R A :=
{ carrier := p, mul_mem' := Hmul, add_mem' := Hadd, algebra_map_mem' := Halg } in
adjoin_le (show s ≤ S, from Hs) h

/-- The difference with `algebra.adjoin_induction` is that this acts on the subtype. -/
lemma adjoin_induction' {p : adjoin R s → Prop} (Hs : ∀ x (h : x ∈ s), p ⟨x, subset_adjoin h⟩)
  (Halg : ∀ r, p (algebra_map R _ r)) (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) (x : adjoin R s) : p x :=
subtype.rec_on x $ λ x hx, begin
  refine exists.elim _ (λ (hx : x ∈ adjoin R s) (hc : p ⟨x, hx⟩), hc),
  exact adjoin_induction hx (λ x hx, ⟨subset_adjoin hx, Hs x hx⟩)
    (λ r, ⟨subalgebra.algebra_map_mem _ r, Halg r⟩)
    (λ x y hx hy, exists.elim hx $ λ hx' hx, exists.elim hy $ λ hy' hy,
    ⟨subalgebra.add_mem _ hx' hy', Hadd _ _ hx hy⟩) (λ x y hx hy, exists.elim hx $ λ hx' hx,
    exists.elim hy $ λ hy' hy, ⟨subalgebra.mul_mem _ hx' hy', Hmul _ _ hx hy⟩),
end

@[simp] lemma adjoin_adjoin_coe_preimage {s : set A} :
  adjoin R ((coe : adjoin R s → A) ⁻¹' s) = ⊤ :=
begin
  refine eq_top_iff.2 (λ x, adjoin_induction' (λ a ha, _) (λ r, _) (λ _ _, _) (λ _ _, _) x),
  { exact subset_adjoin ha },
  { exact subalgebra.algebra_map_mem _ r },
  { exact subalgebra.add_mem _ },
  { exact subalgebra.mul_mem _ }
end

lemma adjoin_union (s t : set A) : adjoin R (s ∪ t) = adjoin R s ⊔ adjoin R t :=
(algebra.gc : galois_connection _ (coe : subalgebra R A → set A)).l_sup

variables (R A)
@[simp] theorem adjoin_empty : adjoin R (∅ : set A) = ⊥ :=
show adjoin R ⊥ = ⊥, by { apply galois_connection.l_bot, exact algebra.gc }

@[simp] theorem adjoin_univ : adjoin R (set.univ : set A) = ⊤ :=
eq_top_iff.2 $ λ x, subset_adjoin $ set.mem_univ _

variables (R) {A} (s)

theorem adjoin_eq_span : (adjoin R s).to_submodule = span R (submonoid.closure s) :=
begin
  apply le_antisymm,
  { intros r hr, rcases subsemiring.mem_closure_iff_exists_list.1 hr with ⟨L, HL, rfl⟩, clear hr,
    induction L with hd tl ih, { exact zero_mem _ },
    rw list.forall_mem_cons at HL,
    rw [list.map_cons, list.sum_cons],
    refine submodule.add_mem _ _ (ih HL.2),
    replace HL := HL.1, clear ih tl,
    suffices : ∃ z r (hr : r ∈ submonoid.closure s), has_scalar.smul z r = list.prod hd,
    { rcases this with ⟨z, r, hr, hzr⟩, rw ← hzr,
      exact smul_mem _ _ (subset_span hr) },
    induction hd with hd tl ih, { exact ⟨1, 1, (submonoid.closure s).one_mem', one_smul _ _⟩ },
    rw list.forall_mem_cons at HL,
    rcases (ih HL.2) with ⟨z, r, hr, hzr⟩, rw [list.prod_cons, ← hzr],
    rcases HL.1 with ⟨hd, rfl⟩ | hs,
    { refine ⟨hd * z, r, hr, _⟩,
      rw [algebra.smul_def, algebra.smul_def, (algebra_map _ _).map_mul, _root_.mul_assoc] },
    { exact ⟨z, hd * r, submonoid.mul_mem _ (submonoid.subset_closure hs) hr,
        (mul_smul_comm _ _ _).symm⟩ } },
  refine span_le.2 _,
  change submonoid.closure s ≤ (adjoin R s).to_subsemiring.to_submonoid,
  exact submonoid.closure_le.2 subset_adjoin
end

lemma span_le_adjoin (s : set A) : span R s ≤ (adjoin R s).to_submodule :=
span_le.mpr subset_adjoin

lemma adjoin_to_submodule_le {s : set A} {t : submodule R A} :
  (adjoin R s).to_submodule ≤ t ↔ ↑(submonoid.closure s) ⊆ (t : set A) :=
by rw [adjoin_eq_span, span_le]

lemma adjoin_eq_span_of_subset {s : set A} (hs : ↑(submonoid.closure s) ⊆ (span R s : set A)) :
  (adjoin R s).to_submodule = span R s :=
le_antisymm ((adjoin_to_submodule_le R).mpr hs) (span_le_adjoin R s)

lemma adjoin_image (f : A →ₐ[R] B) (s : set A) :
  adjoin R (f '' s) = (adjoin R s).map f :=
le_antisymm (adjoin_le $ set.image_subset _ subset_adjoin) $
subalgebra.map_le.2 $ adjoin_le $ set.image_subset_iff.1 subset_adjoin

@[simp] lemma adjoin_insert_adjoin (x : A) :
  adjoin R (insert x ↑(adjoin R s)) = adjoin R (insert x s) :=
le_antisymm
  (adjoin_le (set.insert_subset.mpr
    ⟨subset_adjoin (set.mem_insert _ _), adjoin_mono (set.subset_insert _ _)⟩))
  (algebra.adjoin_mono (set.insert_subset_insert algebra.subset_adjoin))

lemma adjoin_prod_le (s : set A) (t : set B) :
  adjoin R (set.prod s t) ≤ (adjoin R s).prod (adjoin R t) :=
adjoin_le $ set.prod_mono subset_adjoin subset_adjoin

lemma mem_adjoin_of_map_mul {s} {x : A} {f : A →ₗ[R] B} (hf : ∀ a₁ a₂, f(a₁ * a₂) = f a₁ * f a₂)
  (h : x ∈ adjoin R s) : f x ∈ adjoin R (f '' (s ∪ {1})) :=
begin
  refine @adjoin_induction R A _ _ _ _ (λ a, f a ∈ adjoin R (f '' (s ∪ {1}))) x h
    (λ a ha, subset_adjoin ⟨a, ⟨set.subset_union_left _ _ ha, rfl⟩⟩)
    (λ r, _)
    (λ y z hy hz, by simpa [hy, hz] using subalgebra.add_mem _ hy hz)
    (λ y z hy hz, by simpa [hy, hz, hf y z] using subalgebra.mul_mem _ hy hz),
  have : f 1 ∈ adjoin R (f '' (s ∪ {1})) :=
  subset_adjoin ⟨1, ⟨set.subset_union_right _ _ $ set.mem_singleton 1, rfl⟩⟩,
  replace this := subalgebra.smul_mem (adjoin R (f '' (s ∪ {1}))) this r,
  convert this,
  rw algebra_map_eq_smul_one,
  exact f.map_smul _ _
end

lemma adjoin_inl_union_inr_eq_prod (s) (t) :
  adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})) =
    (adjoin R s).prod (adjoin R t) :=
begin
  apply le_antisymm,
  { simp only [adjoin_le_iff, set.insert_subset, subalgebra.zero_mem, subalgebra.one_mem,
      subset_adjoin, -- the rest comes from `squeeze_simp`
      set.union_subset_iff, linear_map.coe_inl, set.mk_preimage_prod_right,
      set.image_subset_iff, set_like.mem_coe, set.mk_preimage_prod_left, linear_map.coe_inr,
      and_self, set.union_singleton, subalgebra.coe_prod] },
  { rintro ⟨a, b⟩ ⟨ha, hb⟩,
    let P := adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})),
    have Ha : (a, (0 : B)) ∈ adjoin R ((linear_map.inl R A B) '' (s ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inl_map_mul) ha,
    have Hb : ((0 : A), b) ∈ adjoin R ((linear_map.inr R A B) '' (t ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inr_map_mul) hb,
    replace Ha : (a, (0 : B)) ∈ P := adjoin_mono (set.subset_union_left _ _) Ha,
    replace Hb : ((0 : A), b) ∈ P := adjoin_mono (set.subset_union_right _ _) Hb,
    simpa using subalgebra.add_mem _ Ha Hb }
end

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A]
variables [algebra R A] {s t : set A}

variables (R s t)
theorem adjoin_union_eq_adjoin_adjoin :
  adjoin R (s ∪ t) = (adjoin (adjoin R s) t).restrict_scalars R :=
le_antisymm
  (closure_mono $ set.union_subset
    (set.range_subset_iff.2 $ λ r, or.inl ⟨algebra_map R (adjoin R s) r, rfl⟩)
    (set.union_subset_union_left _ $ λ x hxs, ⟨⟨_, subset_adjoin hxs⟩, rfl⟩))
  (closure_le.2 $ set.union_subset
    (set.range_subset_iff.2 $ λ x, adjoin_mono (set.subset_union_left _ _) x.2)
    (set.subset.trans (set.subset_union_right _ _) subset_adjoin))

lemma adjoin_singleton_one : adjoin R ({1} : set A) = ⊥ :=
eq_bot_iff.2 $ adjoin_le $ set.singleton_subset_iff.2 $ set_like.mem_coe.2 $ one_mem _

theorem adjoin_union_coe_submodule : (adjoin R (s ∪ t)).to_submodule =
  (adjoin R s).to_submodule * (adjoin R t).to_submodule :=
begin
  rw [adjoin_eq_span, adjoin_eq_span, adjoin_eq_span, span_mul_span],
  congr' 1 with z, simp [submonoid.closure_union, submonoid.mem_sup, set.mem_mul]
end

end comm_semiring

section ring
variables [comm_ring R] [ring A]
variables [algebra R A] {s t : set A}
variables {R s t}

theorem adjoin_int (s : set R) : adjoin ℤ s = subalgebra_of_subring (subring.closure s) :=
le_antisymm (adjoin_le subring.subset_closure)
  (subring.closure_le.2 subset_adjoin : subring.closure s ≤ (adjoin ℤ s).to_subring)

theorem mem_adjoin_iff {s : set A} {x : A} :
  x ∈ adjoin R s ↔ x ∈ subring.closure (set.range (algebra_map R A) ∪ s) :=
⟨λ hx, subsemiring.closure_induction hx subring.subset_closure (subring.zero_mem _)
  (subring.one_mem _) (λ _ _, subring.add_mem _) ( λ _ _, subring.mul_mem _),
  suffices subring.closure (set.range ⇑(algebra_map R A) ∪ s) ≤ (adjoin R s).to_subring,
    from @this x, subring.closure_le.2 subsemiring.subset_closure⟩

theorem adjoin_eq_ring_closure (s : set A) :
  (adjoin R s).to_subring = subring.closure (set.range (algebra_map R A) ∪ s) :=
subring.ext $ λ x, mem_adjoin_iff

end ring

end algebra

open algebra subalgebra

namespace alg_hom

variables [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]

lemma map_adjoin (φ : A →ₐ[R] B) (s : set A) :
  (adjoin R s).map φ = adjoin R (φ '' s) :=
(adjoin_image _ _ _).symm

end alg_hom


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Mon.basic
import Mathlib.category_theory.limits.limits
import Mathlib.category_theory.limits.concrete_category
import Mathlib.PostPort

universes v l u_1

namespace Mathlib

/-!
# The category of monoids has all colimits.

We do this construction knowing nothing about monoids.
In particular, I want to claim that this file could be produced by a python script
that just looks at the output of `#print monoid`:

  -- structure monoid : Type u → Type u
  -- fields:
  -- monoid.mul : Π {α : Type u} [c : monoid α], α → α → α
  -- monoid.mul_assoc : ∀ {α : Type u} [c : monoid α] (a b c_1 : α), a * b * c_1 = a * (b * c_1)
  -- monoid.one : Π (α : Type u) [c : monoid α], α
  -- monoid.one_mul : ∀ {α : Type u} [c : monoid α] (a : α), 1 * a = a
  -- monoid.mul_one : ∀ {α : Type u} [c : monoid α] (a : α), a * 1 = a

and if we'd fed it the output of `#print comm_ring`, this file would instead build
colimits of commutative rings.

A slightly bolder claim is that we could do this with tactics, as well.
-/

namespace Mon.colimits

/-!
We build the colimit of a diagram in `Mon` by constructing the
free monoid on the disjoint union of all the monoids in the diagram,
then taking the quotient by the monoid laws within each monoid,
and the identifications given by the morphisms in the diagram.
-/

/--
An inductive type representing all monoid expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
-- There's always `of`

inductive prequotient {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) where
| of : (j : J) → ↥(category_theory.functor.obj F j) → prequotient F
| one : prequotient F
| mul : prequotient F → prequotient F → prequotient F

-- Then one generator for each operation

protected instance prequotient.inhabited {J : Type v} [category_theory.small_category J]
    (F : J ⥤ Mon) : Inhabited (prequotient F) :=
  { default := prequotient.one }

/--
The relation on `prequotient` saying when two expressions are equal
because of the monoid laws, or
because one element is mapped to another by a morphism in the diagram.
-/
-- Make it an equivalence relation:

inductive relation {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) :
    prequotient F → prequotient F → Prop
    where
| refl : ∀ (x : prequotient F), relation F x x
| symm : ∀ (x y : prequotient F), relation F x y → relation F y x
| trans : ∀ (x y z : prequotient F), relation F x y → relation F y z → relation F x z
| map :
    ∀ (j j' : J) (f : j ⟶ j') (x : ↥(category_theory.functor.obj F j)),
      relation F (prequotient.of j' (coe_fn (category_theory.functor.map F f) x))
        (prequotient.of j x)
| mul :
    ∀ (j : J) (x y : ↥(category_theory.functor.obj F j)),
      relation F (prequotient.of j (x * y))
        (prequotient.mul (prequotient.of j x) (prequotient.of j y))
| one : ∀ (j : J), relation F (prequotient.of j 1) prequotient.one
| mul_1 :
    ∀ (x x' y : prequotient F),
      relation F x x' → relation F (prequotient.mul x y) (prequotient.mul x' y)
| mul_2 :
    ∀ (x y y' : prequotient F),
      relation F y y' → relation F (prequotient.mul x y) (prequotient.mul x y')
| mul_assoc :
    ∀ (x y z : prequotient F),
      relation F (prequotient.mul (prequotient.mul x y) z) (prequotient.mul x (prequotient.mul y z))
| one_mul : ∀ (x : prequotient F), relation F (prequotient.mul prequotient.one x) x
| mul_one : ∀ (x : prequotient F), relation F (prequotient.mul x prequotient.one) x

-- There's always a `map` relation

-- Then one relation per operation, describing the interaction with `of`

-- Then one relation per argument of each operation

-- And one relation per axiom

/--
The setoid corresponding to monoid expressions modulo monoid relations and identifications.
-/
instance colimit_setoid {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) :
    setoid (prequotient F) :=
  setoid.mk (relation F) sorry

/--
The underlying type of the colimit of a diagram in `Mon`.
-/
def colimit_type {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) :=
  quotient (colimit_setoid F)

protected instance monoid_colimit_type {J : Type v} [category_theory.small_category J]
    (F : J ⥤ Mon) : monoid (colimit_type F) :=
  monoid.mk
    (Quot.lift
      (fun (x : prequotient F) =>
        Quot.lift (fun (y : prequotient F) => Quot.mk setoid.r (prequotient.mul x y)) sorry)
      sorry)
    sorry (Quot.mk setoid.r prequotient.one) sorry sorry

@[simp] theorem quot_one {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) :
    Quot.mk setoid.r prequotient.one = 1 :=
  rfl

@[simp] theorem quot_mul {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon)
    (x : prequotient F) (y : prequotient F) :
    Quot.mk setoid.r (prequotient.mul x y) = Quot.mk setoid.r x * Quot.mk setoid.r y :=
  rfl

/-- The bundled monoid giving the colimit of a diagram. -/
def colimit {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : Mon :=
  category_theory.bundled.mk (colimit_type F)

/-- The function from a given monoid in the diagram to the colimit monoid. -/
def cocone_fun {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (j : J)
    (x : ↥(category_theory.functor.obj F j)) : colimit_type F :=
  Quot.mk setoid.r (prequotient.of j x)

/-- The monoid homomorphism from a given monoid in the diagram to the colimit monoid. -/
def cocone_morphism {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (j : J) :
    category_theory.functor.obj F j ⟶ colimit F :=
  monoid_hom.mk (cocone_fun F j) sorry sorry

@[simp] theorem cocone_naturality {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon)
    {j : J} {j' : J} (f : j ⟶ j') :
    category_theory.functor.map F f ≫ cocone_morphism F j' = cocone_morphism F j :=
  monoid_hom.ext fun (x : ↥(category_theory.functor.obj F j)) => quot.sound (relation.map j j' f x)

@[simp] theorem cocone_naturality_components {J : Type v} [category_theory.small_category J]
    (F : J ⥤ Mon) (j : J) (j' : J) (f : j ⟶ j') (x : ↥(category_theory.functor.obj F j)) :
    coe_fn (cocone_morphism F j') (coe_fn (category_theory.functor.map F f) x) =
        coe_fn (cocone_morphism F j) x :=
  sorry

/-- The cocone over the proposed colimit monoid. -/
def colimit_cocone {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) :
    category_theory.limits.cocone F :=
  category_theory.limits.cocone.mk (colimit F) (category_theory.nat_trans.mk (cocone_morphism F))

/-- The function from the free monoid on the diagram to the cone point of any other cocone. -/
@[simp] def desc_fun_lift {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon)
    (s : category_theory.limits.cocone F) : prequotient F → ↥(category_theory.limits.cocone.X s) :=
  sorry

/-- The function from the colimit monoid to the cone point of any other cocone. -/
def desc_fun {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon)
    (s : category_theory.limits.cocone F) : colimit_type F → ↥(category_theory.limits.cocone.X s) :=
  Quot.lift (desc_fun_lift F s) sorry

/-- The monoid homomorphism from the colimit monoid to the cone point of any other cocone. -/
def desc_morphism {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon)
    (s : category_theory.limits.cocone F) : colimit F ⟶ category_theory.limits.cocone.X s :=
  monoid_hom.mk (desc_fun F s) sorry sorry

/-- Evidence that the proposed colimit is the colimit. -/
def colimit_is_colimit {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) :
    category_theory.limits.is_colimit (colimit_cocone F) :=
  category_theory.limits.is_colimit.mk
    fun (s : category_theory.limits.cocone F) => desc_morphism F s

protected instance has_colimits_Mon : category_theory.limits.has_colimits Mon :=
  category_theory.limits.has_colimits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.has_colimits_of_shape.mk
        fun (F : J ⥤ Mon) =>
          category_theory.limits.has_colimit.mk
            (category_theory.limits.colimit_cocone.mk (colimit_cocone F) (colimit_is_colimit F))

end Mathlib