import GMLAlgebra.Basic
import GMLAlgebra.Group

namespace Algebra

namespace Group

inductive Word {α} (xs : List α)
| id : Word xs
| pos : Index xs → Word xs → Word xs
| neg : Index xs → Word xs → Word xs

namespace Word
variable {α} {xs : List α} {u v w : Word xs}

instance instDecidableEq (xs : List α) : DecidableEq (Word xs)
| id, id => isTrue rfl
| id, pos _ _ => isFalse Word.noConfusion
| id, neg _ _ => isFalse Word.noConfusion
| pos _ _, id => isFalse Word.noConfusion
| pos i a, pos j b =>
  match inferDecidable (i = j), instDecidableEq xs a b with
  | isTrue rfl, isTrue rfl => isTrue rfl
  | isFalse h, _ => isFalse fun | rfl => h rfl
  | _, isFalse h => isFalse fun | rfl => h rfl
| pos _ _, neg _ _ => isFalse Word.noConfusion
| neg _ _, id => isFalse Word.noConfusion
| neg _ _, pos _ _ => isFalse Word.noConfusion
| neg i a, neg j b =>
  match inferDecidable (i = j), instDecidableEq xs a b with
  | isTrue rfl, isTrue rfl => isTrue rfl
  | isFalse h, _ => isFalse fun | rfl => h rfl
  | _, isFalse h => isFalse fun | rfl => h rfl

def lift (x : α) : Word xs → Word (x :: xs)
| id => id
| pos i a => pos (Index.tail i) (lift x a)
| neg i a => neg (Index.tail i) (lift x a)

def rpos : Index xs → Word xs → Word xs
| i, neg j w => if i = j then w else pos i (neg j w)
| i, w => pos i w

def rneg : Index xs → Word xs → Word xs
| i, pos j w => if i = j then w else neg i (pos j w)
| i, w => neg i w

def rapp : Word xs → Word xs → Word xs
| id, w => w
| pos i v, w => rpos i (rapp v w)
| neg i v, w => rneg i (rapp v w)

def raux : Word xs → Word xs → Word xs
| id, w => w
| pos i v, w => raux v (rneg i w)
| neg i v, w => raux v (rpos i w)

abbrev rinv : Word xs → Word xs := (raux . id)

def isReduced : Word xs → Bool
| pos _ (pos j w) => isReduced (pos j w)
| pos i (neg j w) => i ≠ j && isReduced (neg j w)
| neg i (pos j w) => i ≠ j && isReduced (pos j w)
| neg _ (neg j w) => isReduced (neg j w)
| _ => true

theorem isReduced_id : (id (xs:=xs)).isReduced := rfl

theorem isReduced_pos_tail {i : Index xs} : (pos i w).isReduced → w.isReduced := by
  intro h
  match w with
  | id => rfl
  | pos _ _ => exact h
  | neg _ _ => rw [isReduced, Bool.and_eq_true_iff] at h; exact h.2

theorem isReduced_neg_tail {i : Index xs} : (neg i w).isReduced → w.isReduced := by
  intro h
  match w with
  | id => rfl
  | pos _ _ => rw [isReduced, Bool.and_eq_true_iff] at h; exact h.2
  | neg _ _ => exact h

theorem isReduced_lift {x : α} (h : w.isReduced) : (w.lift x).isReduced := by
  induction w with
  | id => rfl
  | pos i w ih =>
    match w with
    | id => rfl
    | pos _ _ => rw [lift, lift, isReduced]; exact ih (isReduced_pos_tail h)
    | neg j _ =>
      by_cases i = j with
      | isTrue rfl => simp [isReduced] at h
      | isFalse hne =>
        rw [lift, lift, isReduced, Bool.and_eq_true]
        constr
        · apply decide_eq_true; intro | rfl => contradiction
        · exact ih (isReduced_pos_tail h)
  | neg i w ih =>
    match w with
    | id => rfl
    | pos j _ =>
      by_cases i = j with
      | isTrue rfl => simp [isReduced] at h
      | isFalse hne =>
        rw [lift, lift, isReduced, Bool.and_eq_true]
        constr
        · apply decide_eq_true; intro | rfl => contradiction
        · exact ih (isReduced_neg_tail h)
    | neg _ _ => rw [lift, lift, isReduced]; exact ih (isReduced_neg_tail h)

theorem isReduced_rpos (h : w.isReduced) : (w.rpos i).isReduced := by
  match w with
  | id => exact h
  | pos _ _ => exact h
  | neg j _ =>
    by_cases i = j with
    | isTrue hij => unfold rpos; clean; rw [if_pos hij, isReduced_neg_tail h]
    | isFalse hij => unfold rpos; clean; rw [if_neg hij, isReduced, decide_eq_true hij, h, and]

theorem isReduced_rneg (h : w.isReduced) : (w.rneg i).isReduced := by
  match w with
  | id => exact h
  | pos j _ =>
    by_cases i = j with
    | isTrue hij => unfold rneg; clean; rw [if_pos hij, isReduced_pos_tail h]
    | isFalse hij => unfold rneg; clean; rw [if_neg hij, isReduced, decide_eq_true hij, h, and]
  | neg _ _ => exact h

theorem isReduced_rapp (h : w.isReduced) : (rapp v w).isReduced := by
  induction v with
  | id => exact h
  | pos _ _ ih => unfold rapp; apply isReduced_rpos; exact ih
  | neg _ _ ih => unfold rapp; apply isReduced_rneg; exact ih

theorem isReduced_raux (h : w.isReduced) : (raux v w).isReduced := by
  induction v generalizing w with
  | id => exact h
  | pos _ _ ih => unfold raux; apply ih; apply isReduced_rneg h
  | neg _ _ ih => unfold raux; apply ih; apply isReduced_rpos h

theorem isReduced_rinv : w.rinv.isReduced := isReduced_raux isReduced_id

theorem rinv_eq : rinv w = raux w id := rfl

theorem rpos_rneg_cancel (h : w.isReduced) : rpos i (rneg i w) = w := by
  match w with
  | id => simp [rneg, rpos]
  | pos k w =>
    unfold rneg rpos
    match inferDecidable (i = k), w with
    | isTrue rfl, id => simp
    | isTrue rfl, pos k w => simp
    | isTrue rfl, neg k w =>
      by_cases i = k with
      | isTrue rfl => simp [isReduced] at h
      | isFalse hne => simp [hne]
    | isFalse hne, _ => simp [hne]
  | neg k w => simp [rneg, rpos]

theorem rneg_rpos_cancel (h : w.isReduced) : rneg i (rpos i w) = w := by
  match w with
  | id => simp [rneg, rpos]
  | pos k w => simp [rneg, rpos]
  | neg k w =>
    unfold rneg rpos
    match inferDecidable (i = k), w with
    | isTrue rfl, id => simp
    | isTrue rfl, pos k w =>
      by_cases i = k with
      | isTrue rfl => simp [isReduced] at h
      | isFalse hne => simp [hne]
    | isTrue rfl, neg k w => simp
    | isFalse hne, _ => simp [hne]

theorem rapp_rpos_left (h : w.isReduced) : rapp (rpos i v) w = rpos i (rapp v w) := by
  match v with
  | id => rfl
  | pos j v => rfl
  | neg j v =>
    rw [rapp]
    by_cases i = j with
    | isTrue rfl =>
      rw [rpos_rneg_cancel, rpos]
      clean
      rw [if_pos trivial]
      exact isReduced_rapp h
    | isFalse hne =>
      rw [rpos]
      clean
      rw [if_neg hne, rapp, rapp]

theorem rapp_rneg_left (h : w.isReduced) : rapp (rneg i v) w = rneg i (rapp v w) := by
  match v with
  | id => rfl
  | pos j v =>
    rw [rapp]
    by_cases i = j with
    | isTrue rfl =>
      rw [rneg_rpos_cancel (isReduced_rapp h), rneg]
      clean
      rw [if_pos trivial]
    | isFalse hne =>
      rw [rneg]
      clean
      rw [if_neg hne, rapp, rapp]
  | neg j v => rfl

theorem raux_rpos_left (h : w.isReduced) : raux (rpos i v) w = raux v (rneg i w) := by
  match v with
  | id => rfl
  | pos j v => rfl
  | neg j v =>
    rw [raux]
    by_cases i = j with
    | isTrue rfl =>
      rw [rpos_rneg_cancel h, rpos]
      clean
      rw [if_pos trivial]
    | isFalse hne =>
      rw [rpos]
      clean
      rw [if_neg hne, raux, raux]

theorem raux_rneg_left (h : w.isReduced) : raux (rneg i v) w = raux v (rpos i w) := by
  match v with
  | id => rfl
  | pos j v =>
    rw [raux]
    by_cases i = j with
    | isTrue rfl =>
      rw [rneg_rpos_cancel h, rneg]
      clean
      rw [if_pos trivial]
    | isFalse hne =>
      rw [rneg]
      clean
      rw [if_neg hne, raux, raux]
  | neg j v => rfl

theorem rapp_id (h : w.isReduced) : rapp w id = w := by
  induction w with
  | id => rfl
  | pos i w ih =>
    rw [rapp, ih (isReduced_pos_tail h)]
    match w with
    | id => rfl
    | pos j w => rfl
    | neg j w =>
      by_cases i = j with
      | isTrue rfl => simp [isReduced] at h
      | isFalse hne => rw [rpos]; clean; rw [if_neg hne]
  | neg i w ih =>
    rw [rapp, ih (isReduced_neg_tail h)]
    match w with
    | id => rfl
    | pos j w =>
      by_cases i = j with
      | isTrue rfl => simp [isReduced] at h
      | isFalse hne => rw [rneg]; clean; rw [if_neg hne]
    | neg j w => rfl

theorem raux_id : raux w id = rinv w := rfl

theorem rapp_assoc (h : w.isReduced) : rapp (rapp u v) w = rapp u (rapp v w) := by
  induction u with
  | id => rfl
  | pos i u ih => rw [rapp, rapp, rapp_rpos_left h, ih]
  | neg i u ih => rw [rapp, rapp, rapp_rneg_left h, ih]

theorem raux_raux_compat (h : w.isReduced) : raux (raux u v) w = raux v (rapp u w) := by
  induction u generalizing v w with
  | id => rfl
  | pos i u ih => rw [raux, rapp, ih h, raux_rneg_left (isReduced_rapp h)]; done
  | neg i u ih => rw [raux, rapp, ih h, raux_rpos_left (isReduced_rapp h)]

theorem rapp_raux_compat (h : w.isReduced) : rapp (raux u v) w = raux u (rapp v w) := by
  induction u generalizing v w with
  | id => rfl
  | pos i u ih => rw [raux, raux, ih h, rapp_rneg_left h]
  | neg i u ih => rw [raux, raux, ih h, rapp_rpos_left h]

theorem raux_rapp_compat (h : w.isReduced) : raux (rapp v u) w = raux u (raux v w) := by
  induction v generalizing u w with
  | id => rfl
  | pos j v ih => rw [raux, rapp, ←ih (isReduced_rneg h), raux_rpos_left h]
  | neg j v ih => rw [raux, rapp, ←ih (isReduced_rpos h), raux_rneg_left h]

theorem rinv_raux (h : w.isReduced) : rinv (raux w v) = raux v w := by
  rw [rinv, raux_raux_compat isReduced_id, rapp_id h]

theorem rinv_rinv (h : w.isReduced) : rinv (rinv w) = w := rinv_raux (v:=id) h

theorem rapp_eq (hv : v.isReduced) (hw : w.isReduced) : rapp v w  = raux (rinv v) w :=
  show rapp v w = raux (rinv v) (rapp id w) by rw [←rapp_raux_compat hw, ←rinv_eq, rinv_rinv hv]

theorem raux_eq (h : w.isReduced) : raux v w = rapp (rinv v) w := (rapp_raux_compat (v:=id) h).symm

theorem raux_self : raux w w = id := by
  induction w with
  | id => rfl
  | pos i w ih => rw [raux, rneg]; clean; rw [if_pos trivial, ih]
  | neg i w ih => rw [raux, rpos]; clean; rw [if_pos trivial, ih]

section Eval
variable (s : GroupSig α) [Group s]

def eval : Word xs → α
| id => s.id
| pos i a => s.op i.val (eval a)
| neg i a => s.op (s.inv i.val) (eval a)

theorem eval_id : eval s (id (xs:=xs)) = s.id := rfl

theorem eval_pos (i : Index xs) (a : Word xs) : eval s (pos i a) = s.op i.val (eval s a) := rfl

theorem eval_neg (i : Index xs) (a : Word xs) : eval s (neg i a) = s.op (s.inv i.val) (eval s a) := rfl

theorem eval_lift (a : Word xs) (x : α) : eval s (lift x a) = eval s a := by
  induction a with
  | id => rfl
  | pos i a ih => rw [lift, eval_pos, eval_pos, Index.val_tail, ih]
  | neg i a ih => rw [lift, eval_neg, eval_neg, Index.val_tail, ih]

theorem eval_rpos (i : Index xs) (a : Word xs) : eval s (rpos i a) = s.op i.val (eval s a) := by
  match a with
  | id => rfl
  | pos j a => rfl
  | neg j a =>
    by_cases i = j with
    | isTrue rfl =>
      rw [rpos]
      clean
      rw [if_pos trivial, eval_neg, ←op_assoc s.op, op_right_inv s.op, op_left_id s.op]
    | isFalse hne =>
      rw [rpos]
      clean
      rw [if_neg hne, eval_pos]

theorem eval_rneg (i : Index xs) (a : Word xs) : eval s (rneg i a) = s.op (s.inv i.val) (eval s a) := by
  match a with
  | id => rfl
  | pos j a =>
    by_cases i = j with
    | isTrue rfl =>
      rw [rneg]
      clean
      rw [if_pos trivial, eval_pos, ←op_assoc s.op, op_left_inv s.op, op_left_id s.op]
    | isFalse hne =>
      rw [rneg]
      clean
      rw [if_neg hne, eval_neg]
  | neg j a => rfl

theorem eval_rapp (a b : Word xs) : eval s (rapp a b) = s.op (eval s a) (eval s b) := by
  induction a with
  | id => rw [rapp, eval_id, op_left_id s.op]
  | pos i a ih => rw [rapp, eval_pos, eval_rpos, ih, op_assoc s.op]
  | neg i a ih => rw [rapp, eval_neg, eval_rneg, ih, op_assoc s.op]

theorem eval_raux (a b : Word xs) : eval s (raux a b) = s.op (s.inv (eval s a)) (eval s b) := by
  induction a generalizing b with
  | id => rw [raux, eval_id, inv_id s.inv, op_left_id s.op]
  | pos i a ih => rw [raux, eval_pos, ih, eval_rneg, inv_op s.inv, op_assoc s.op]
  | neg i a ih => rw [raux, eval_neg, ih, eval_rpos, inv_op s.inv, op_assoc s.op, inv_invol s.inv]

theorem eval_rinv (a : Word xs) : eval s (rinv a) = s.inv (eval s a) := by
  rw [rinv, eval_raux, eval_id, op_right_id s.op]

end Eval

end Word

structure Expr (xs : List α) where
  word : Word xs
  isReduced : word.isReduced

namespace Expr
variable {α} {xs : List α}

protected def eq : {a b : Expr xs} → a.word = b.word → a = b
| ⟨_,_⟩, ⟨_,_⟩, rfl => rfl

instance (xs : List α) : DecidableEq (Expr xs)
| ⟨a,_⟩, ⟨b,_⟩ =>
  match inferDecidable (a = b) with
  | isTrue h => isTrue (Expr.eq h)
  | isFalse h => isFalse fun | rfl => h rfl

protected def lift (x : α) (a : Expr xs) : Expr (x :: xs) where
  word := a.word.lift x
  isReduced := Word.isReduced_lift a.isReduced

protected def id : Expr xs where
  word := Word.id
  isReduced := Word.isReduced_id

protected def pos (i : Index xs) (a : Expr xs) : Expr xs where
  word := a.word.rpos i
  isReduced := Word.isReduced_rpos a.isReduced

protected def neg (i : Index xs) (a : Expr xs) : Expr xs where
  word := a.word.rneg i
  isReduced := Word.isReduced_rneg a.isReduced

protected abbrev var (i : Index xs) : Expr xs := Expr.pos i Expr.id

protected def inv (a : Expr xs) : Expr xs where
  word := a.word.rinv
  isReduced := Word.isReduced_rinv

protected def op (a b : Expr xs) : Expr xs where
  word := a.word.rinv.raux b.word
  isReduced := Word.isReduced_raux b.isReduced

private theorem op_word_eq_rapp (a b : Expr xs) : (Expr.op a b).word = Word.rapp a.word b.word := by
  rw [Expr.op, Word.rapp_eq a.isReduced b.isReduced]

section Completeness
variable (xs : List α)

@[reducible] def sig : GroupSig (Expr xs) where
  op := Expr.op
  inv := Expr.inv
  id := Expr.id

instance : Group (sig xs) where
  op_assoc (a b c) := by apply Expr.eq; simp only [op_word_eq_rapp]; exact Word.rapp_assoc c.isReduced
  op_right_id (a) := by apply Expr.eq; exact Word.rinv_rinv a.isReduced
  op_right_inv (a) := by apply Expr.eq; exact Word.raux_self

end Completeness

section Eval
variable (s : GroupSig α) [Group s]

def eval : Expr xs → α | ⟨a,_⟩ => Word.eval s a

@[simp] theorem eval_lift (a : Expr xs) : eval s (Expr.lift x a) = eval s a := by
  unfold Expr.lift eval; clean; rw [Word.eval_lift]

@[simp] theorem eval_var (i : Index xs) : eval s (Expr.var i) = i.val := by
  unfold Expr.var Expr.pos Expr.id eval; clean; rw [Word.eval_rpos, Word.eval_id, op_right_id s.op]

@[simp] theorem eval_id : eval s (Expr.id (xs:=xs)) = s.id := by
  unfold Expr.id eval; clean; rw [Word.eval_id]

@[simp] theorem eval_inv (a : Expr xs) : eval s (Expr.inv a) = s.inv (eval s a) := by
  unfold Expr.inv eval; clean; rw [Word.eval_rinv]

@[simp] theorem eval_op (a b : Expr xs) : eval s (Expr.op a b) = s.op (eval s a) (eval s b) := by
  unfold Expr.op eval; clean; rw [Word.eval_raux, Word.eval_rinv, inv_invol s.inv]

end Eval

end Expr

class Reflect (s : GroupSig α) (x : α) (xs : List α) where
  expr : Expr xs
  eval_eq : expr.eval s = x

protected def Reflect.eq (s : GroupSig α) (x xs) [inst : Reflect s x xs] : inst.expr.eval s = x := inst.eval_eq

namespace Reflect
variable (s : GroupSig α) [Group s]

@[simp] instance instLift (y x : α) {xs : List α} [Reflect s y xs] : Reflect s y (x :: xs) where
  expr := Expr.lift x (expr s y)
  eval_eq := by simp [eval_eq]

@[simp] instance instVar (x : α) {xs : List α} : Reflect s x (x :: xs) where
  expr := Expr.var Index.head
  eval_eq := by simp

@[simp] instance instId {xs : List α} : Reflect s (no_index s.id) xs where
  expr := Expr.id
  eval_eq := by simp [eval_eq]

@[simp] instance instInv (x : α) {xs : List α} [Reflect s x xs] : Reflect s (no_index s.inv x) xs where
  expr := Expr.inv (expr s x)
  eval_eq := by simp [eval_eq]

@[simp] instance instOp (x y : α) {xs : List α} [Reflect s x xs] [Reflect s y xs] : Reflect s (no_index s.op x y) xs where
  expr := Expr.op (expr s x) (expr s y)
  eval_eq := by simp [eval_eq]

end Reflect

theorem reflect {α} (s : GroupSig α) [Group s] (xs : List α) {a b : α} [Reflect s a xs] [Reflect s b xs] : Reflect.expr s a (xs:=xs) = Reflect.expr s b → a = b := by
  intro h
  rw [←Reflect.eq s a xs, ←Reflect.eq s b xs, h]

end Group

end Algebra

section Example
open Algebra
variable {α} (s : GroupSig α) [Group s] (a b c d : α)

local infixr:70 " ⋆ " => s.op
local postfix:max "⁻¹" => s.inv
local notation "e" => s.id

example : (a ⋆ b)⁻¹ ⋆ (c ⋆ d⁻¹) = e ⋆ b⁻¹ ⋆ ((a⁻¹ ⋆ e ⋆ c) ⋆ d⁻¹) :=
  Group.reflect s [a,b,c,d] rfl

end Example


/-
Copyright (c) 2021 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.jacobson
import Mathlib.field_theory.algebraic_closure
import Mathlib.field_theory.mv_polynomial
import Mathlib.algebraic_geometry.prime_spectrum
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Nullstellensatz
This file establishes a version of Hilbert's classical Nullstellensatz for `mv_polynomial`s.
The main statement of the theorem is `vanishing_ideal_zero_locus_eq_radical`.

The statement is in terms of new definitions `vanishing_ideal` and `zero_locus`.
Mathlib already has versions of these in terms of the prime spectrum of a ring,
  but those are not well-suited for expressing this result.
Suggestions for better ways to state this theorem or organize things are welcome.

The machinery around `vanishing_ideal` and `zero_locus` is also minimal, I only added lemmas
  directly needed in this proof, since I'm not sure if they are the right approach.
-/

namespace mv_polynomial

/-- Set of points that are zeroes of all polynomials in an ideal -/
def zero_locus {k : Type u_1} [field k] {σ : Type u_2} (I : ideal (mv_polynomial σ k)) :
    set (σ → k) :=
  set_of fun (x : σ → k) => ∀ (p : mv_polynomial σ k), p ∈ I → coe_fn (eval x) p = 0

@[simp] theorem mem_zero_locus_iff {k : Type u_1} [field k] {σ : Type u_2}
    {I : ideal (mv_polynomial σ k)} {x : σ → k} :
    x ∈ zero_locus I ↔ ∀ (p : mv_polynomial σ k), p ∈ I → coe_fn (eval x) p = 0 :=
  iff.rfl

theorem zero_locus_anti_mono {k : Type u_1} [field k] {σ : Type u_2} {I : ideal (mv_polynomial σ k)}
    {J : ideal (mv_polynomial σ k)} (h : I ≤ J) : zero_locus J ≤ zero_locus I :=
  fun (x : σ → k) (hx : x ∈ zero_locus J) (p : mv_polynomial σ k) (hp : p ∈ I) => hx p (h hp)

theorem zero_locus_bot {k : Type u_1} [field k] {σ : Type u_2} : zero_locus ⊥ = ⊤ :=
  iff.mpr eq_top_iff
    fun (x : σ → k) (hx : x ∈ ⊤) (p : mv_polynomial σ k) (hp : p ∈ ⊥) =>
      trans (congr_arg (⇑(eval x)) (iff.mp ideal.mem_bot hp)) (ring_hom.map_zero (eval x))

theorem zero_locus_top {k : Type u_1} [field k] {σ : Type u_2} : zero_locus ⊤ = ⊥ :=
  iff.mpr eq_bot_iff
    fun (x : σ → k) (hx : x ∈ zero_locus ⊤) =>
      one_ne_zero (ring_hom.map_one (eval x) ▸ hx 1 submodule.mem_top)

/-- Ideal of polynomials with common zeroes at all elements of a set -/
def vanishing_ideal {k : Type u_1} [field k] {σ : Type u_2} (V : set (σ → k)) :
    ideal (mv_polynomial σ k) :=
  submodule.mk (set_of fun (p : mv_polynomial σ k) => ∀ (x : σ → k), x ∈ V → coe_fn (eval x) p = 0)
    sorry sorry sorry

@[simp] theorem mem_vanishing_ideal_iff {k : Type u_1} [field k] {σ : Type u_2} {V : set (σ → k)}
    {p : mv_polynomial σ k} :
    p ∈ vanishing_ideal V ↔ ∀ (x : σ → k), x ∈ V → coe_fn (eval x) p = 0 :=
  iff.rfl

theorem vanishing_ideal_anti_mono {k : Type u_1} [field k] {σ : Type u_2} {A : set (σ → k)}
    {B : set (σ → k)} (h : A ≤ B) : vanishing_ideal B ≤ vanishing_ideal A :=
  fun (p : mv_polynomial σ k) (hp : p ∈ vanishing_ideal B) (x : σ → k) (hx : x ∈ A) => hp x (h hx)

theorem vanishing_ideal_empty {k : Type u_1} [field k] {σ : Type u_2} : vanishing_ideal ∅ = ⊤ :=
  le_antisymm le_top
    fun (p : mv_polynomial σ k) (hp : p ∈ ⊤) (x : σ → k) (hx : x ∈ ∅) =>
      absurd hx (set.not_mem_empty x)

theorem le_vanishing_ideal_zero_locus {k : Type u_1} [field k] {σ : Type u_2}
    (I : ideal (mv_polynomial σ k)) : I ≤ vanishing_ideal (zero_locus I) :=
  fun (p : mv_polynomial σ k) (hp : p ∈ I) (x : σ → k) (hx : x ∈ zero_locus I) => hx p hp

theorem zero_locus_vanishing_ideal_le {k : Type u_1} [field k] {σ : Type u_2} (V : set (σ → k)) :
    V ≤ zero_locus (vanishing_ideal V) :=
  fun (V_1 : σ → k) (hV : V_1 ∈ V) (p : mv_polynomial σ k) (hp : p ∈ vanishing_ideal V) => hp V_1 hV

theorem zero_locus_vanishing_ideal_galois_connection {k : Type u_1} [field k] {σ : Type u_2} :
    galois_connection zero_locus vanishing_ideal :=
  fun (I : ideal (mv_polynomial σ k)) (V : order_dual (set (σ → k))) =>
    { mp :=
        fun (h : zero_locus I ≤ V) =>
          le_trans (le_vanishing_ideal_zero_locus I) (vanishing_ideal_anti_mono h),
      mpr :=
        fun (h : I ≤ vanishing_ideal V) =>
          le_trans (zero_locus_anti_mono h) (zero_locus_vanishing_ideal_le V) }

theorem mem_vanishing_ideal_singleton_iff {k : Type u_1} [field k] {σ : Type u_2} (x : σ → k)
    (p : mv_polynomial σ k) : p ∈ vanishing_ideal (singleton x) ↔ coe_fn (eval x) p = 0 :=
  { mp := fun (h : p ∈ vanishing_ideal (singleton x)) => h x rfl,
    mpr :=
      fun (hpx : coe_fn (eval x) p = 0) (y : σ → k) (hy : y ∈ singleton x) => Eq.symm hy ▸ hpx }

protected instance vanishing_ideal_singleton_is_maximal {k : Type u_1} [field k] {σ : Type u_2}
    {x : σ → k} : ideal.is_maximal (vanishing_ideal (singleton x)) :=
  sorry

theorem radical_le_vanishing_ideal_zero_locus {k : Type u_1} [field k] {σ : Type u_2}
    (I : ideal (mv_polynomial σ k)) : ideal.radical I ≤ vanishing_ideal (zero_locus I) :=
  sorry

/-- The point in the prime spectrum assosiated to a given point -/
def point_to_point {k : Type u_1} [field k] {σ : Type u_2} (x : σ → k) :
    prime_spectrum (mv_polynomial σ k) :=
  { val := vanishing_ideal (singleton x), property := sorry }

@[simp] theorem vanishing_ideal_point_to_point {k : Type u_1} [field k] {σ : Type u_2}
    (V : set (σ → k)) : prime_spectrum.vanishing_ideal (point_to_point '' V) = vanishing_ideal V :=
  sorry

theorem point_to_point_zero_locus_le {k : Type u_1} [field k] {σ : Type u_2}
    (I : ideal (mv_polynomial σ k)) :
    point_to_point '' zero_locus I ≤ prime_spectrum.zero_locus ↑I :=
  sorry

theorem is_maximal_iff_eq_vanishing_ideal_singleton {k : Type u_1} [field k] {σ : Type u_2}
    [is_alg_closed k] [fintype σ] (I : ideal (mv_polynomial σ k)) :
    ideal.is_maximal I ↔ ∃ (x : σ → k), I = vanishing_ideal (singleton x) :=
  sorry

/-- Main statement of the Nullstellensatz -/
@[simp] theorem vanishing_ideal_zero_locus_eq_radical {k : Type u_1} [field k] {σ : Type u_2}
    [is_alg_closed k] [fintype σ] (I : ideal (mv_polynomial σ k)) :
    vanishing_ideal (zero_locus I) = ideal.radical I :=
  sorry

@[simp] theorem is_prime.vanishing_ideal_zero_locus {k : Type u_1} [field k] {σ : Type u_2}
    [is_alg_closed k] [fintype σ] (P : ideal (mv_polynomial σ k)) [h : ideal.is_prime P] :
    vanishing_ideal (zero_locus P) = P :=
  trans (vanishing_ideal_zero_locus_eq_radical P) (ideal.is_prime.radical h)

end Mathlib


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

! This file was ported from Lean 3 source module algebra.group.with_one.defs
! leanprover-community/mathlib commit 995b47e555f1b6297c7cf16855f1023e355219fb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.WithBot
import Mathbin.Algebra.Ring.Defs

/-!
# Adjoining a zero/one to semigroups and related algebraic structures

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

This file contains different results about adjoining an element to an algebraic structure which then
behaves like a zero or a one. An example is adjoining a one to a semigroup to obtain a monoid. That
this provides an example of an adjunction is proved in `algebra.category.Mon.adjunctions`.

Another result says that adjoining to a group an element `zero` gives a `group_with_zero`. For more
information about these structures (which are not that standard in informal mathematics, see
`algebra.group_with_zero.basic`)

## Implementation notes

At various points in this file, `id $` is used in at the start of a proof field in a structure. This
ensures that the generated `_proof_1` lemmas are stated in terms of the algebraic operations and
not `option.map`, as the latter does not typecheck once `with_zero`/`with_one` is irreducible.
-/

universe u v w

variable {α : Type u} {β : Type v} {γ : Type w}

#print WithOne /-
/-- Add an extra element `1` to a type -/
@[to_additive "Add an extra element `0` to a type"]
def WithOne (α) :=
  Option α
#align with_one WithOne
#align with_zero WithZero
-/

namespace WithOne

instance [Repr α] : Repr (WithZero α) :=
  ⟨fun o =>
    match o with
    | none => "0"
    | some a => "↑" ++ repr a⟩

@[to_additive]
instance [Repr α] : Repr (WithOne α) :=
  ⟨fun o =>
    match o with
    | none => "1"
    | some a => "↑" ++ repr a⟩

@[to_additive]
instance : Monad WithOne :=
  Option.monad

@[to_additive]
instance : One (WithOne α) :=
  ⟨none⟩

@[to_additive]
instance [Mul α] : Mul (WithOne α) :=
  ⟨Option.liftOrGet (· * ·)⟩

@[to_additive]
instance [Inv α] : Inv (WithOne α) :=
  ⟨fun a => Option.map Inv.inv a⟩

@[to_additive]
instance [InvolutiveInv α] : InvolutiveInv (WithOne α) :=
  { WithOne.inv with
    inv_inv :=
      id fun a => (Option.map_map _ _ _).trans <| by simp_rw [inv_comp_inv, Option.map_id, id] }

@[to_additive]
instance [Inv α] : InvOneClass (WithOne α) :=
  { WithOne.one, WithOne.inv with inv_one := rfl }

@[to_additive]
instance : Inhabited (WithOne α) :=
  ⟨1⟩

@[to_additive]
instance [Nonempty α] : Nontrivial (WithOne α) :=
  Option.nontrivial

@[to_additive]
instance : CoeTC α (WithOne α) :=
  ⟨some⟩

#print WithOne.recOneCoe /-
/-- Recursor for `with_one` using the preferred forms `1` and `↑a`. -/
@[elab_as_elim, to_additive "Recursor for `with_zero` using the preferred forms `0` and `↑a`."]
def recOneCoe {C : WithOne α → Sort _} (h₁ : C 1) (h₂ : ∀ a : α, C a) : ∀ n : WithOne α, C n :=
  Option.rec h₁ h₂
#align with_one.rec_one_coe WithOne.recOneCoe
#align with_zero.rec_zero_coe WithZero.recZeroCoe
-/

#print WithOne.unone /-
/-- Deconstruct a `x : with_one α` to the underlying value in `α`, given a proof that `x ≠ 1`. -/
@[to_additive unzero
      "Deconstruct a `x : with_zero α` to the underlying value in `α`, given a proof that `x ≠ 0`."]
def unone {x : WithOne α} (hx : x ≠ 1) : α :=
  WithBot.unbot x hx
#align with_one.unone WithOne.unone
#align with_zero.unzero WithZero.unzero
-/

#print WithOne.unone_coe /-
@[simp, to_additive unzero_coe]
theorem unone_coe {x : α} (hx : (x : WithOne α) ≠ 1) : unone hx = x :=
  rfl
#align with_one.unone_coe WithOne.unone_coe
#align with_zero.unzero_coe WithZero.unzero_coe
-/

#print WithOne.coe_unone /-
@[simp, to_additive coe_unzero]
theorem coe_unone {x : WithOne α} (hx : x ≠ 1) : ↑(unone hx) = x :=
  WithBot.coe_unbot x hx
#align with_one.coe_unone WithOne.coe_unone
#align with_zero.coe_unzero WithZero.coe_unzero
-/

/- warning: with_one.some_eq_coe clashes with [anonymous] -> [anonymous]
warning: with_one.some_eq_coe -> [anonymous] is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u}} {a : α}, Eq.{succ u} (Option.{u} α) (Option.some.{u} α a) ((fun (a : Type.{u}) (b : Type.{u}) [self : HasLiftT.{succ u, succ u} a b] => self.0) α (Option.{u} α) (HasLiftT.mk.{succ u, succ u} α (Option.{u} α) (CoeTCₓ.coe.{succ u, succ u} α (Option.{u} α) (coeOption.{u} α))) a)
but is expected to have type
  forall {α : Type.{u}} {a : Type.{v}}, (Nat -> α -> a) -> Nat -> (List.{u} α) -> (List.{v} a)
Case conversion may be inaccurate. Consider using '#align with_one.some_eq_coe [anonymous]ₓ'. -/
@[to_additive]
theorem [anonymous] {a : α} : (some a : WithOne α) = ↑a :=
  rfl
#align with_one.some_eq_coe [anonymous]

#print WithOne.coe_ne_one /-
@[simp, to_additive]
theorem coe_ne_one {a : α} : (a : WithOne α) ≠ (1 : WithOne α) :=
  Option.some_ne_none a
#align with_one.coe_ne_one WithOne.coe_ne_one
#align with_zero.coe_ne_zero WithZero.coe_ne_zero
-/

#print WithOne.one_ne_coe /-
@[simp, to_additive]
theorem one_ne_coe {a : α} : (1 : WithOne α) ≠ a :=
  coe_ne_one.symm
#align with_one.one_ne_coe WithOne.one_ne_coe
#align with_zero.zero_ne_coe WithZero.zero_ne_coe
-/

#print WithOne.ne_one_iff_exists /-
@[to_additive]
theorem ne_one_iff_exists {x : WithOne α} : x ≠ 1 ↔ ∃ a : α, ↑a = x :=
  Option.ne_none_iff_exists
#align with_one.ne_one_iff_exists WithOne.ne_one_iff_exists
#align with_zero.ne_zero_iff_exists WithZero.ne_zero_iff_exists
-/

#print WithOne.canLift /-
@[to_additive]
instance canLift : CanLift (WithOne α) α coe fun a => a ≠ 1 where prf a := ne_one_iff_exists.1
#align with_one.can_lift WithOne.canLift
#align with_zero.can_lift WithZero.canLift
-/

#print WithOne.coe_inj /-
@[simp, norm_cast, to_additive]
theorem coe_inj {a b : α} : (a : WithOne α) = b ↔ a = b :=
  Option.some_inj
#align with_one.coe_inj WithOne.coe_inj
#align with_zero.coe_inj WithZero.coe_inj
-/

#print WithOne.cases_on /-
@[elab_as_elim, to_additive]
protected theorem cases_on {P : WithOne α → Prop} : ∀ x : WithOne α, P 1 → (∀ a : α, P a) → P x :=
  Option.casesOn
#align with_one.cases_on WithOne.cases_on
#align with_zero.cases_on WithZero.cases_on
-/

@[to_additive]
instance [Mul α] : MulOneClass (WithOne α)
    where
  mul := (· * ·)
  one := 1
  one_mul := id <| (Option.liftOrGet_isLeftId _).1
  mul_one := id <| (Option.liftOrGet_isRightId _).1

@[to_additive]
instance [Semigroup α] : Monoid (WithOne α) :=
  { WithOne.mulOneClass with mul_assoc := (Option.liftOrGet_isAssociative _).1 }

example [Semigroup α] : @Monoid.toMulOneClass _ (@WithOne.monoid α _) = @WithOne.mulOneClass α _ :=
  rfl

@[to_additive]
instance [CommSemigroup α] : CommMonoid (WithOne α) :=
  { WithOne.monoid with mul_comm := (Option.liftOrGet_isCommutative _).1 }

#print WithOne.coe_mul /-
@[simp, norm_cast, to_additive]
theorem coe_mul [Mul α] (a b : α) : ((a * b : α) : WithOne α) = a * b :=
  rfl
#align with_one.coe_mul WithOne.coe_mul
#align with_zero.coe_add WithZero.coe_add
-/

#print WithOne.coe_inv /-
@[simp, norm_cast, to_additive]
theorem coe_inv [Inv α] (a : α) : ((a⁻¹ : α) : WithOne α) = a⁻¹ :=
  rfl
#align with_one.coe_inv WithOne.coe_inv
#align with_zero.coe_neg WithZero.coe_neg
-/

end WithOne

namespace WithZero

instance [one : One α] : One (WithZero α) :=
  { one with }

#print WithZero.coe_one /-
@[simp, norm_cast]
theorem coe_one [One α] : ((1 : α) : WithZero α) = 1 :=
  rfl
#align with_zero.coe_one WithZero.coe_one
-/

instance [Mul α] : MulZeroClass (WithZero α) :=
  { WithZero.zero with
    mul := Option.map₂ (· * ·)
    zero_mul := id <| Option.map₂_none_left (· * ·)
    mul_zero := id <| Option.map₂_none_right (· * ·) }

/- warning: with_zero.coe_mul -> WithZero.coe_mul is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Mul.{u1} α] {a : α} {b : α}, Eq.{succ u1} (WithZero.{u1} α) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) α (WithZero.{u1} α) (HasLiftT.mk.{succ u1, succ u1} α (WithZero.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} α (WithZero.{u1} α) (WithZero.hasCoeT.{u1} α))) (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α _inst_1) a b)) (HMul.hMul.{u1, u1, u1} (WithZero.{u1} α) (WithZero.{u1} α) (WithZero.{u1} α) (instHMul.{u1} (WithZero.{u1} α) (MulZeroClass.toHasMul.{u1} (WithZero.{u1} α) (WithZero.mulZeroClass.{u1} α _inst_1))) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) α (WithZero.{u1} α) (HasLiftT.mk.{succ u1, succ u1} α (WithZero.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} α (WithZero.{u1} α) (WithZero.hasCoeT.{u1} α))) a) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) α (WithZero.{u1} α) (HasLiftT.mk.{succ u1, succ u1} α (WithZero.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} α (WithZero.{u1} α) (WithZero.hasCoeT.{u1} α))) b))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Mul.{u1} α] {a : α} {b : α}, Eq.{succ u1} (WithZero.{u1} α) (WithZero.coe.{u1} α (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α _inst_1) a b)) (HMul.hMul.{u1, u1, u1} (WithZero.{u1} α) (WithZero.{u1} α) (WithZero.{u1} α) (instHMul.{u1} (WithZero.{u1} α) (MulZeroClass.toMul.{u1} (WithZero.{u1} α) (WithZero.mulZeroClass.{u1} α _inst_1))) (WithZero.coe.{u1} α a) (WithZero.coe.{u1} α b))
Case conversion may be inaccurate. Consider using '#align with_zero.coe_mul WithZero.coe_mulₓ'. -/
@[simp, norm_cast]
theorem coe_mul {α : Type u} [Mul α] {a b : α} : ((a * b : α) : WithZero α) = a * b :=
  rfl
#align with_zero.coe_mul WithZero.coe_mul

instance [Mul α] : NoZeroDivisors (WithZero α) :=
  ⟨fun a b => id <| Option.map₂_eq_none_iff.1⟩

instance [Semigroup α] : SemigroupWithZero (WithZero α) :=
  { WithZero.mulZeroClass with mul_assoc := id fun _ _ _ => Option.map₂_assoc mul_assoc }

instance [CommSemigroup α] : CommSemigroup (WithZero α) :=
  { WithZero.semigroupWithZero with mul_comm := id fun _ _ => Option.map₂_comm mul_comm }

instance [MulOneClass α] : MulZeroOneClass (WithZero α) :=
  { WithZero.mulZeroClass,
    WithZero.hasOne with
    one_mul := id <| Option.map₂_left_identity one_mul
    mul_one := id <| Option.map₂_right_identity mul_one }

instance [One α] [Pow α ℕ] : Pow (WithZero α) ℕ :=
  ⟨fun x n =>
    match x, n with
    | none, 0 => 1
    | none, n + 1 => 0
    | some x, n => ↑(x ^ n)⟩

#print WithZero.coe_pow /-
@[simp, norm_cast]
theorem coe_pow [One α] [Pow α ℕ] {a : α} (n : ℕ) : ↑(a ^ n : α) = (↑a ^ n : WithZero α) :=
  rfl
#align with_zero.coe_pow WithZero.coe_pow
-/

instance [Monoid α] : MonoidWithZero (WithZero α) :=
  { WithZero.mulZeroOneClass,
    WithZero.semigroupWithZero with
    npow := fun n x => x ^ n
    npow_zero := fun x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| pow_zero _
    npow_succ := fun n x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| pow_succ _ _ }

instance [CommMonoid α] : CommMonoidWithZero (WithZero α) :=
  { WithZero.monoidWithZero, WithZero.commSemigroup with }

/-- Given an inverse operation on `α` there is an inverse operation
  on `with_zero α` sending `0` to `0`-/
instance [Inv α] : Inv (WithZero α) :=
  ⟨fun a => Option.map Inv.inv a⟩

#print WithZero.coe_inv /-
@[simp, norm_cast]
theorem coe_inv [Inv α] (a : α) : ((a⁻¹ : α) : WithZero α) = a⁻¹ :=
  rfl
#align with_zero.coe_inv WithZero.coe_inv
-/

#print WithZero.inv_zero /-
@[simp]
theorem inv_zero [Inv α] : (0 : WithZero α)⁻¹ = 0 :=
  rfl
#align with_zero.inv_zero WithZero.inv_zero
-/

instance [InvolutiveInv α] : InvolutiveInv (WithZero α) :=
  { WithZero.hasInv with
    inv_inv :=
      id fun a => (Option.map_map _ _ _).trans <| by simp_rw [inv_comp_inv, Option.map_id, id] }

instance [InvOneClass α] : InvOneClass (WithZero α) :=
  { WithZero.hasOne, WithZero.hasInv with inv_one := show ((1⁻¹ : α) : WithZero α) = 1 by simp }

instance [Div α] : Div (WithZero α) :=
  ⟨Option.map₂ (· / ·)⟩

#print WithZero.coe_div /-
@[norm_cast]
theorem coe_div [Div α] (a b : α) : ↑(a / b : α) = (a / b : WithZero α) :=
  rfl
#align with_zero.coe_div WithZero.coe_div
-/

instance [One α] [Pow α ℤ] : Pow (WithZero α) ℤ :=
  ⟨fun x n =>
    match x, n with
    | none, Int.ofNat 0 => 1
    | none, Int.ofNat (Nat.succ n) => 0
    | none, Int.negSucc n => 0
    | some x, n => ↑(x ^ n)⟩

#print WithZero.coe_zpow /-
@[simp, norm_cast]
theorem coe_zpow [DivInvMonoid α] {a : α} (n : ℤ) : ↑(a ^ n : α) = (↑a ^ n : WithZero α) :=
  rfl
#align with_zero.coe_zpow WithZero.coe_zpow
-/

instance [DivInvMonoid α] : DivInvMonoid (WithZero α) :=
  { WithZero.hasDiv, WithZero.hasInv,
    WithZero.monoidWithZero with
    div_eq_mul_inv := fun a b =>
      match a, b with
      | none, _ => rfl
      | some a, none => rfl
      | some a, some b => congr_arg some (div_eq_mul_inv _ _)
    zpow := fun n x => x ^ n
    zpow_zero' := fun x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| zpow_zero _
    zpow_succ' := fun n x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| DivInvMonoid.zpow_succ' _ _
    zpow_neg' := fun n x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| DivInvMonoid.zpow_neg' _ _ }

instance [DivInvOneMonoid α] : DivInvOneMonoid (WithZero α) :=
  { WithZero.divInvMonoid, WithZero.invOneClass with }

instance [DivisionMonoid α] : DivisionMonoid (WithZero α) :=
  { WithZero.divInvMonoid,
    WithZero.hasInvolutiveInv with
    mul_inv_rev := fun a b =>
      match a, b with
      | none, none => rfl
      | none, some b => rfl
      | some a, none => rfl
      | some a, some b => congr_arg some <| mul_inv_rev _ _
    inv_eq_of_mul := fun a b =>
      match a, b with
      | none, none => fun _ => rfl
      | none, some b => by contradiction
      | some a, none => by contradiction
      | some a, some b => fun h =>
        congr_arg some <| inv_eq_of_mul_eq_one_right <| Option.some_injective _ h }

instance [DivisionCommMonoid α] : DivisionCommMonoid (WithZero α) :=
  { WithZero.divisionMonoid, WithZero.commSemigroup with }

section Group

variable [Group α]

/-- if `G` is a group then `with_zero G` is a group with zero. -/
instance : GroupWithZero (WithZero α) :=
  { WithZero.monoidWithZero, WithZero.divInvMonoid,
    WithZero.nontrivial with
    inv_zero := inv_zero
    mul_inv_cancel := fun a ha => by
      lift a to α using ha
      norm_cast
      apply mul_right_inv }

end Group

instance [CommGroup α] : CommGroupWithZero (WithZero α) :=
  { WithZero.groupWithZero, WithZero.commMonoidWithZero with }

instance [AddMonoidWithOne α] : AddMonoidWithOne (WithZero α) :=
  { WithZero.addMonoid,
    WithZero.hasOne with
    natCast := fun n => if n = 0 then 0 else (n.cast : α)
    natCast_zero := rfl
    natCast_succ := fun n => by
      cases n
      show (((1 : ℕ) : α) : WithZero α) = 0 + 1; · rw [Nat.cast_one, coe_one, zero_add]
      show (((n + 2 : ℕ) : α) : WithZero α) = ((n + 1 : ℕ) : α) + 1
      · rw [Nat.cast_succ, coe_add, coe_one] }

instance [Semiring α] : Semiring (WithZero α) :=
  { WithZero.addMonoidWithOne, WithZero.addCommMonoid, WithZero.mulZeroClass,
    WithZero.monoidWithZero with
    left_distrib := fun a b c => by
      cases' a with a; · rfl
      cases' b with b <;> cases' c with c <;> try rfl
      exact congr_arg some (left_distrib _ _ _)
    right_distrib := fun a b c => by
      cases' c with c
      · change (a + b) * 0 = a * 0 + b * 0
        simp
      cases' a with a <;> cases' b with b <;> try rfl
      exact congr_arg some (right_distrib _ _ _) }

end WithZero


/-
Copyright (c) 2021 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/

import group_theory.complement
import group_theory.group_action.basic
import group_theory.sylow

/-!
# The Schur-Zassenhaus Theorem

In this file we prove the Schur-Zassenhaus theorem.

## Main results

- `exists_right_complement'_of_coprime` : The **Schur-Zassenhaus** theorem:
  If `H : subgroup G` is normal and has order coprime to its index,
  then there exists a subgroup `K` which is a (right) complement of `H`.
- `exists_left_complement'_of_coprime`  The **Schur-Zassenhaus** theorem:
  If `H : subgroup G` is normal and has order coprime to its index,
  then there exists a subgroup `K` which is a (left) complement of `H`.
-/

open_locale big_operators

namespace subgroup

section schur_zassenhaus_abelian

open mem_left_transversals

variables {G : Type*} [group G] {H : subgroup G}

@[to_additive] instance : mul_action G (left_transversals (H : set G)) :=
{ smul := λ g T, ⟨left_coset g T, mem_left_transversals_iff_exists_unique_inv_mul_mem.mpr (λ g', by
  { obtain ⟨t, ht1, ht2⟩ := mem_left_transversals_iff_exists_unique_inv_mul_mem.mp T.2 (g⁻¹ * g'),
    simp_rw [←mul_assoc, ←mul_inv_rev] at ht1 ht2,
    refine ⟨⟨g * t, mem_left_coset g t.2⟩, ht1, _⟩,
    rintros ⟨_, t', ht', rfl⟩ h,
    exact subtype.ext ((mul_right_inj g).mpr (subtype.ext_iff.mp (ht2 ⟨t', ht'⟩ h))) })⟩,
  one_smul := λ T, subtype.ext (one_left_coset T),
  mul_smul := λ g g' T, subtype.ext (left_coset_assoc ↑T g g').symm }

lemma smul_symm_apply_eq_mul_symm_apply_inv_smul
  (g : G) (α : left_transversals (H : set G)) (q : G ⧸ H) :
  ↑(to_equiv (g • α).2 q) = g * (to_equiv α.2 (g⁻¹ • q : G ⧸ H)) :=
(subtype.ext_iff.mp (by exact (to_equiv (g • α).2).apply_eq_iff_eq_symm_apply.mpr
  ((congr_arg _ ((to_equiv α.2).symm_apply_apply _)).trans (smul_inv_smul g q)).symm)).trans
  (subtype.coe_mk _ (mem_left_coset g (subtype.mem _)))

variables [is_commutative H] [fintype (G ⧸ H)]

variables (α β γ : left_transversals (H : set G))

/-- The difference of two left transversals -/
@[to_additive "The difference of two left transversals"]
noncomputable def diff [hH : normal H] : H :=
∏ (q : G ⧸ H), ⟨(to_equiv α.2 q) * (to_equiv β.2 q)⁻¹, hH.mem_comm (quotient.exact'
  (((to_equiv β.2).symm_apply_apply q).trans ((to_equiv α.2).symm_apply_apply q).symm))⟩

@[to_additive] lemma diff_mul_diff [normal H] : diff α β * diff β γ = diff α γ :=
finset.prod_mul_distrib.symm.trans (finset.prod_congr rfl (λ x hx, subtype.ext
  (by rw [coe_mul, coe_mk, coe_mk, coe_mk, mul_assoc, inv_mul_cancel_left])))

@[to_additive] lemma diff_self [normal H] : diff α α = 1 :=
mul_right_eq_self.mp (diff_mul_diff α α α)

@[to_additive] lemma diff_inv [normal H]: (diff α β)⁻¹ = diff β α :=
inv_eq_of_mul_eq_one ((diff_mul_diff α β α).trans (diff_self α))

lemma smul_diff_smul [hH : normal H] (g : G) :
  diff (g • α) (g • β) = ⟨g * diff α β * g⁻¹, hH.conj_mem (diff α β).1 (diff α β).2 g⟩ :=
begin
  let ϕ : H →* H :=
  { to_fun := λ h, ⟨g * h * g⁻¹, hH.conj_mem h.1 h.2 g⟩,
    map_one' := subtype.ext (by rw [coe_mk, coe_one, mul_one, mul_inv_self]),
    map_mul' := λ h₁ h₂, subtype.ext (by rw [coe_mk, coe_mul, coe_mul, coe_mk, coe_mk, mul_assoc,
      mul_assoc, mul_assoc, mul_assoc, mul_assoc, inv_mul_cancel_left]) },
  refine eq.trans (finset.prod_bij' (λ q _, (↑g)⁻¹ * q) (λ _ _, finset.mem_univ _)
    (λ q _, subtype.ext _) (λ q _, ↑g * q) (λ _ _, finset.mem_univ _)
    (λ q _, mul_inv_cancel_left g q) (λ q _, inv_mul_cancel_left g q)) (ϕ.map_prod _ _).symm,
  change _ * _ = g * (_ * _) * g⁻¹,
  simp_rw [smul_symm_apply_eq_mul_symm_apply_inv_smul, mul_inv_rev, mul_assoc],
  refl,
end

lemma smul_diff [H.normal] (h : H) :
  diff (h • α) β = h ^ H.index * diff α β :=
begin
  rw [diff, diff, index_eq_card, ←finset.card_univ, ←finset.prod_const, ←finset.prod_mul_distrib],
  refine finset.prod_congr rfl (λ q _, _),
  rw [subtype.ext_iff, coe_mul, coe_mk, coe_mk, ←mul_assoc, mul_right_cancel_iff],
  rw [show h • α = (h : G) • α, from rfl, smul_symm_apply_eq_mul_symm_apply_inv_smul],
  rw [mul_left_cancel_iff, ←subtype.ext_iff, equiv.apply_eq_iff_eq, inv_smul_eq_iff],
  exact self_eq_mul_left.mpr ((quotient_group.eq_one_iff _).mpr h.2),
end

variables (H)

instance setoid_diff [H.normal] : setoid (left_transversals (H : set G)) :=
setoid.mk (λ α β, diff α β = 1) ⟨λ α, diff_self α, λ α β h₁,
  by rw [←diff_inv, h₁, one_inv], λ α β γ h₁ h₂, by rw [←diff_mul_diff, h₁, h₂, one_mul]⟩

/-- The quotient of the transversals of an abelian normal `N` by the `diff` relation -/
def quotient_diff [H.normal] :=
quotient H.setoid_diff

instance [H.normal] : inhabited H.quotient_diff := quotient.inhabited _

variables {H}

instance [H.normal] : mul_action G H.quotient_diff :=
{ smul := λ g, quotient.map (λ α, g • α) (λ α β h, (smul_diff_smul α β g).trans
    (subtype.ext (mul_inv_eq_one.mpr (mul_right_eq_self.mpr (subtype.ext_iff.mp h))))),
  mul_smul := λ g₁ g₂ q, quotient.induction_on q (λ α, congr_arg quotient.mk (mul_smul g₁ g₂ α)),
  one_smul := λ q, quotient.induction_on q (λ α, congr_arg quotient.mk (one_smul G α)) }

variables [fintype H]

lemma exists_smul_eq [H.normal] (α β : H.quotient_diff)
  (hH : nat.coprime (fintype.card H) H.index) :
  ∃ h : H, h • α = β :=
quotient.induction_on α (quotient.induction_on β
  (λ β α, exists_imp_exists (λ n, quotient.sound)
    ⟨(pow_coprime hH).symm (diff α β)⁻¹, by
    { change diff ((_ : H) • _) _ = 1,
      rw smul_diff,
      change pow_coprime hH ((pow_coprime hH).symm (diff α β)⁻¹) * (diff α β) = 1,
      rw [equiv.apply_symm_apply, inv_mul_self] }⟩))

lemma smul_left_injective [H.normal] (α : H.quotient_diff)
  (hH : nat.coprime (fintype.card H) H.index) :
  function.injective (λ h : H, h • α) :=
λ h₁ h₂, begin
  refine quotient.induction_on α (λ α hα, _),
  replace hα : diff (h₁ • α) (h₂ • α) = 1 := quotient.exact hα,
  rw [smul_diff, ←diff_inv, smul_diff, diff_self, mul_one, mul_inv_eq_one] at hα,
  exact (pow_coprime hH).injective hα,
end

lemma is_complement'_stabilizer_of_coprime [fintype G] [H.normal] {α : H.quotient_diff}
  (hH : nat.coprime (fintype.card H) H.index) :
  is_complement' H (mul_action.stabilizer G α) :=
begin
  classical,
  let ϕ : H ≃ mul_action.orbit G α := equiv.of_bijective (λ h, ⟨h • α, h, rfl⟩)
    ⟨λ h₁ h₂ hh, smul_left_injective α hH (subtype.ext_iff.mp hh),
      λ β, exists_imp_exists (λ h hh, subtype.ext hh) (exists_smul_eq α β hH)⟩,
  have key := card_eq_card_quotient_mul_card_subgroup (mul_action.stabilizer G α),
  rw ← fintype.card_congr (ϕ.trans (mul_action.orbit_equiv_quotient_stabilizer G α)) at key,
  apply is_complement'_of_coprime key.symm,
  rw [card_eq_card_quotient_mul_card_subgroup H, mul_comm, mul_right_inj'] at key,
  { rwa [←key, ←index_eq_card] },
  { rw [←pos_iff_ne_zero, fintype.card_pos_iff],
    apply_instance },
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma exists_right_complement'_of_coprime_aux [fintype G] [H.normal]
  (hH : nat.coprime (fintype.card H) H.index) :
  ∃ K : subgroup G, is_complement' H K :=
nonempty_of_inhabited.elim
  (λ α : H.quotient_diff, ⟨mul_action.stabilizer G α, is_complement'_stabilizer_of_coprime hH⟩)

end schur_zassenhaus_abelian

open_locale classical

universe u

namespace schur_zassenhaus_induction

/-! ## Proof of the Schur-Zassenhaus theorem

In this section, we prove the Schur-Zassenhaus theorem.
The proof is by contradiction. We assume that `G` is a minimal counterexample to the theorem.
-/

variables {G : Type u} [group G] [fintype G] {N : subgroup G} [normal N]
  (h1 : nat.coprime (fintype.card N) N.index)
  (h2 : ∀ (G' : Type u) [group G'] [fintype G'], by exactI
    ∀ (hG'3 : fintype.card G' < fintype.card G)
    {N' : subgroup G'} [N'.normal] (hN : nat.coprime (fintype.card N') N'.index),
    ∃ H' : subgroup G', is_complement' N' H')
  (h3 : ∀ H : subgroup G, ¬ is_complement' N H)

include h1 h2 h3

/-! We will arrive at a contradiction via the following steps:
 * step 0: `N` (the normal Hall subgroup) is nontrivial.
 * step 1: If `K` is a subgroup of `G` with `K ⊔ N = ⊤`, then `K = ⊤`.
 * step 2: `N` is a minimal normal subgroup, phrased in terms of subgroups of `G`.
 * step 3: `N` is a minimal normal subgroup, phrased in terms of subgroups of `N`.
 * step 4: `p` (`min_fact (fintype.card N)`) is prime (follows from step0).
 * step 5: `P` (a Sylow `p`-subgroup of `N`) is nontrivial.
 * step 6: `N` is a `p`-group (applies step 1 to the normalizer of `P` in `G`).
 * step 7: `N` is abelian (applies step 3 to the center of `N`).
-/

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
@[nolint unused_arguments] private lemma step0 : N ≠ ⊥ :=
begin
  unfreezingI { rintro rfl },
  exact h3 ⊤ is_complement'_bot_top,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step1 (K : subgroup G) (hK : K ⊔ N = ⊤) : K = ⊤ :=
begin
  contrapose! h3,
  have h4 : (N.comap K.subtype).index = N.index,
  { rw [←N.relindex_top_right, ←hK],
    exact relindex_eq_relindex_sup K N },
  have h5 : fintype.card K < fintype.card G,
  { rw ← K.index_mul_card,
    exact lt_mul_of_one_lt_left fintype.card_pos (one_lt_index_of_ne_top h3) },
  have h6 : nat.coprime (fintype.card (N.comap K.subtype)) (N.comap K.subtype).index,
  { rw h4,
    exact h1.coprime_dvd_left (card_comap_dvd_of_injective N K.subtype subtype.coe_injective) },
  obtain ⟨H, hH⟩ := h2 K h5 h6,
  replace hH : fintype.card (H.map K.subtype) = N.index :=
  ((set.card_image_of_injective _ subtype.coe_injective).trans (nat.mul_left_injective
    fintype.card_pos (hH.symm.card_mul.trans (N.comap K.subtype).index_mul_card.symm))).trans h4,
  have h7 : fintype.card N * fintype.card (H.map K.subtype) = fintype.card G,
  { rw [hH, ←N.index_mul_card, mul_comm] },
  have h8 : (fintype.card N).coprime (fintype.card (H.map K.subtype)),
  { rwa hH },
  exact ⟨H.map K.subtype, is_complement'_of_coprime h7 h8⟩,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step2 (K : subgroup G) [K.normal] (hK : K ≤ N) : K = ⊥ ∨ K = N :=
begin
  have : function.surjective (quotient_group.mk' K) := quotient.surjective_quotient_mk',
  have h4 := step1 h1 h2 h3,
  contrapose! h4,
  have h5 : fintype.card (G ⧸ K) < fintype.card G,
  { rw [←index_eq_card, ←K.index_mul_card],
    refine lt_mul_of_one_lt_right (nat.pos_of_ne_zero index_ne_zero_of_fintype)
      (K.one_lt_card_iff_ne_bot.mpr h4.1) },
  have h6 : nat.coprime (fintype.card (N.map (quotient_group.mk' K)))
    (N.map (quotient_group.mk' K)).index,
  { have index_map := N.index_map_eq this (by rwa quotient_group.ker_mk),
    have index_pos : 0 < N.index := nat.pos_of_ne_zero index_ne_zero_of_fintype,
    rw index_map,
    refine h1.coprime_dvd_left _,
    rw [←nat.mul_dvd_mul_iff_left index_pos, index_mul_card, ←index_map, index_mul_card],
    exact K.card_quotient_dvd_card },
  obtain ⟨H, hH⟩ := h2 (G ⧸ K) h5 h6,
  refine ⟨H.comap (quotient_group.mk' K), _, _⟩,
  { have key : (N.map (quotient_group.mk' K)).comap (quotient_group.mk' K) = N,
    { refine comap_map_eq_self _,
      rwa quotient_group.ker_mk },
    rwa [←key, comap_sup_eq, hH.symm.sup_eq_top, comap_top] },
  { rw ← comap_top (quotient_group.mk' K),
    intro hH',
    rw [comap_injective this hH', is_complement'_top_right,
        map_eq_bot_iff, quotient_group.ker_mk] at hH,
    { exact h4.2 (le_antisymm hK hH) } },
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step3 (K : subgroup N) [(K.map N.subtype).normal] : K = ⊥ ∨ K = ⊤ :=
begin
  have key := step2 h1 h2 h3 (K.map N.subtype) K.map_subtype_le,
  rw ← map_bot N.subtype at key,
  conv at key { congr, skip, to_rhs, rw [←N.subtype_range, N.subtype.range_eq_map] },
  have inj := map_injective (show function.injective N.subtype, from subtype.coe_injective),
  rwa [inj.eq_iff, inj.eq_iff] at key,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step4 : (fintype.card N).min_fac.prime :=
(nat.min_fac_prime (N.one_lt_card_iff_ne_bot.mpr (step0 h1 h2 h3)).ne')

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step5 {P : sylow (fintype.card N).min_fac N} : P.1 ≠ ⊥ :=
begin
  haveI : fact ((fintype.card N).min_fac.prime) := ⟨step4 h1 h2 h3⟩,
  exact P.ne_bot_of_dvd_card (fintype.card N).min_fac_dvd,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step6 : is_p_group (fintype.card N).min_fac N :=
begin
  haveI : fact ((fintype.card N).min_fac.prime) := ⟨step4 h1 h2 h3⟩,
  refine sylow.nonempty.elim (λ P, P.2.of_surjective P.1.subtype _),
  rw [←monoid_hom.range_top_iff_surjective, subtype_range],
  haveI : (P.1.map N.subtype).normal := normalizer_eq_top.mp
    (step1 h1 h2 h3 (P.1.map N.subtype).normalizer P.normalizer_sup_eq_top),
  exact (step3 h1 h2 h3 P.1).resolve_left (step5 h1 h2 h3),
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
lemma step7 : is_commutative N :=
begin
  haveI := N.bot_or_nontrivial.resolve_left (step0 h1 h2 h3),
  haveI : fact ((fintype.card N).min_fac.prime) := ⟨step4 h1 h2 h3⟩,
  exact ⟨⟨λ g h, eq_top_iff.mp ((step3 h1 h2 h3 N.center).resolve_left
    (step6 h1 h2 h3).bot_lt_center.ne') (mem_top h) g⟩⟩,
end

end schur_zassenhaus_induction

variables {n : ℕ} {G : Type u} [group G]

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma exists_right_complement'_of_coprime_aux' [fintype G] (hG : fintype.card G = n)
  {N : subgroup G} [N.normal] (hN : nat.coprime (fintype.card N) N.index) :
  ∃ H : subgroup G, is_complement' N H :=
begin
  unfreezingI { revert G },
  apply nat.strong_induction_on n,
  rintros n ih G _ _ rfl N _ hN,
  refine not_forall_not.mp (λ h3, _),
  haveI := by exactI
    schur_zassenhaus_induction.step7 hN (λ G' _ _ hG', by { apply ih _ hG', refl }) h3,
  exact not_exists_of_forall_not h3 (exists_right_complement'_of_coprime_aux hN),
end

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (right) complement of `H`. -/

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (right) complement of `H`. -/
theorem exists_right_complement'_of_coprime
  {N : subgroup G} [N.normal] (hN : nat.coprime (nat.card N) N.index) :
  ∃ H : subgroup G, is_complement' N H :=
begin
  by_cases hN1 : nat.card N = 0,
  { rw [hN1, nat.coprime_zero_left, index_eq_one] at hN,
    rw hN,
    exact ⟨⊥, is_complement'_top_bot⟩ },
  by_cases hN2 : N.index = 0,
  { rw [hN2, nat.coprime_zero_right] at hN,
    haveI := (cardinal.to_nat_eq_one_iff_unique.mp hN).1,
    rw N.eq_bot_of_subsingleton,
    exact ⟨⊤, is_complement'_bot_top⟩ },
  have hN3 : nat.card G ≠ 0,
  { rw ← N.card_mul_index,
    exact mul_ne_zero hN1 hN2 },
  haveI := (cardinal.lt_omega_iff_fintype.mp
    (lt_of_not_ge (mt cardinal.to_nat_apply_of_omega_le hN3))).some,
  rw nat.card_eq_fintype_card at hN,
  exact exists_right_complement'_of_coprime_of_fintype hN,
end

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (left) complement of `H`. -/
theorem exists_left_complement'_of_coprime_of_fintype
  [fintype G] {N : subgroup G} [N.normal] (hN : nat.coprime (fintype.card N) N.index) :
  ∃ H : subgroup G, is_complement' H N :=
Exists.imp (λ _, is_complement'.symm) (exists_right_complement'_of_coprime_of_fintype hN)

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (left) complement of `H`. -/
theorem exists_left_complement'_of_coprime
  {N : subgroup G} [N.normal] (hN : nat.coprime (nat.card N) N.index) :
  ∃ H : subgroup G, is_complement' H N :=
Exists.imp (λ _, is_complement'.symm) (exists_right_complement'_of_coprime hN)

end subgroup


import tableau order.lexicographic

open matrix fintype finset function pequiv partition
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

namespace tableau

def pivot_linear_order (T : tableau m n) : decidable_linear_order (fin n) :=
decidable_linear_order.lift T.to_partition.colg (injective_colg _) (by apply_instance)

def find_pivot_column (T : tableau m n) (obj : fin m) : option (fin n) :=
option.cases_on
  (fin.find (λ c : fin n, T.to_matrix obj c ≠ 0 ∧ T.to_partition.colg c ∉ T.restricted))
  (((list.fin_range n).filter (λ c : fin n, 0 < T.to_matrix obj c)).argmin
    T.to_partition.colg)
  some

def pivot_row_linear_order (T : tableau m n) (c : fin n) : decidable_linear_order (fin m) :=
decidable_linear_order.lift
  (show fin m → lex ℚ (fin (m + n)),
    from λ r', (abs (T.const r' 0 / T.to_matrix r' c), T.to_partition.rowg r'))
  (λ x y, by simp [T.to_partition.injective_rowg.eq_iff])
  (by apply_instance)

section
local attribute [instance, priority 0] fin.has_le fin.decidable_linear_order

lemma pivot_row_linear_order_le_def (T : tableau m n) (c : fin n) :
  @has_le.le (fin m)
  (by haveI := pivot_row_linear_order T c; apply_instance) =
  (λ i i', abs (T.const i 0 / T.to_matrix i c) < abs (T.const i' 0 / T.to_matrix i' c) ∨
    (abs (T.const i 0 / T.to_matrix i c) = abs (T.const i' 0 / T.to_matrix i' c) ∧
    T.to_partition.rowg i ≤ T.to_partition.rowg i')) :=
funext $ λ i, funext $ λ i', propext $ prod.lex_def _ _

end

def find_pivot_row (T : tableau m n) (obj: fin m) (c : fin n) : option (fin m) :=
let l := (list.fin_range m).filter (λ r : fin m, obj ≠ r ∧ T.to_partition.rowg r ∈ T.restricted
  ∧ T.to_matrix obj c / T.to_matrix r c < 0) in
@list.minimum _ (pivot_row_linear_order T c) l

lemma find_pivot_column_spec {T : tableau m n} {obj : fin m} {c : fin n} :
  c ∈ find_pivot_column T obj → (T.to_matrix obj c ≠ 0 ∧ T.to_partition.colg c ∉ T.restricted)
  ∨ (0 < T.to_matrix obj c ∧ T.to_partition.colg c ∈ T.restricted) :=
begin
  simp [find_pivot_column],
  cases h : fin.find (λ c : fin n, T.to_matrix obj c ≠ 0 ∧ T.to_partition.colg c ∉ T.restricted),
  { finish [h, fin.find_eq_some_iff, fin.find_eq_none_iff, lt_irrefl (0 : ℚ),
      list.argmin_eq_some_iff] },
  { finish [fin.find_eq_some_iff] }
end

lemma nonpos_of_lt_find_pivot_column {T : tableau m n} {obj : fin m} {c j : fin n}
  (hc : c ∈ find_pivot_column T obj) (hcres : T.to_partition.colg c ∈ T.restricted)
  (hjc : T.to_partition.colg j < T.to_partition.colg c) :
  T.to_matrix obj j ≤ 0 :=
begin
  rw [find_pivot_column] at hc,
  cases h : fin.find (λ c, T.to_matrix obj c ≠ 0 ∧ colg (T.to_partition) c ∉ T.restricted),
  { rw h at hc,
    refine le_of_not_lt (λ hj0, _),
    exact not_le_of_gt hjc ((list.mem_argmin_iff.1 hc).2.1 j (list.mem_filter.2 (by simp [hj0]))) },
  { rw h at hc,
    simp [*, fin.find_eq_some_iff] at * }
end

lemma find_pivot_column_eq_none {T : tableau m n} {obj : fin m} (hT : T.feasible)
  (h : find_pivot_column T obj = none) : T.is_optimal (T.of_col 0) (T.to_partition.rowg obj) :=
is_optimal_of_col_zero hT
begin
  revert h,
  simp [find_pivot_column],
  cases h : fin.find (λ c : fin n, T.to_matrix obj c ≠ 0 ∧ T.to_partition.colg c ∉ T.restricted),
  { finish [fin.find_eq_none_iff, list.argmin_eq_some_iff, list.filter_eq_nil] },
  { simp [h] }
end

lemma find_pivot_row_spec {T : tableau m n} {obj r : fin m} {c : fin n} :
  r ∈ find_pivot_row T obj c →
  obj ≠ r ∧ T.to_partition.rowg r ∈ T.restricted ∧
  T.to_matrix obj c / T.to_matrix r c < 0 ∧
  (∀ r' : fin m, obj ≠ r' → T.to_partition.rowg r' ∈ T.restricted →
    T.to_matrix obj c / T.to_matrix r' c < 0 →
  abs (T.const r 0 / T.to_matrix r c) ≤ abs (T.const r' 0 / T.to_matrix r' c)) :=
begin
  simp only [list.mem_filter, find_pivot_row, option.mem_def, with_bot.some_eq_coe,
    list.minimum_eq_coe_iff, list.mem_fin_range, true_and, and_imp],
  rw [pivot_row_linear_order_le_def],
  intros hor hres hr0 h,
  simp only [*, true_and, ne.def, not_false_iff],
  intros r' hor' hres' hr0',
  cases h r' hor' hres' hr0',
  { exact le_of_lt (by assumption) },
  { exact le_of_eq (by tauto) }
end

lemma nonneg_of_lt_find_pivot_row {T : tableau m n} {obj : fin m} {r i : fin m} {c : fin n}
  (hc0 : 0 < T.to_matrix obj c) (hres : T.to_partition.rowg i ∈ T.restricted)
  (hc : c ∈ find_pivot_column T obj) (hr : r ∈ find_pivot_row T obj c)
  (hconst : T.const i 0 = 0)
  (hjc : T.to_partition.rowg i < T.to_partition.rowg r) :
  0 ≤ T.to_matrix i c :=
if hobj : obj = i then le_of_lt $ hobj ▸ hc0
else
le_of_not_gt $ λ hic, not_le_of_lt hjc
begin
  have := ((@list.minimum_eq_coe_iff _ (id _) _ _).1 hr).2 i
    (list.mem_filter.2 ⟨list.mem_fin_range _, hobj, hres, div_neg_of_pos_of_neg hc0 hic⟩),
  rw [pivot_row_linear_order_le_def] at this,
  simp [hconst, not_lt_of_ge (abs_nonneg _), *] at *
end

lemma ne_zero_of_mem_find_pivot_row {T : tableau m n} {obj r : fin m} {c : fin n}
  (hr : r ∈ find_pivot_row T obj c) : T.to_matrix r c ≠ 0 :=
assume hrc, by simpa [lt_irrefl, hrc] using find_pivot_row_spec hr

lemma ne_zero_of_mem_find_pivot_column {T : tableau m n} {obj : fin m} {c : fin n}
  (hc : c ∈ find_pivot_column T obj) : T.to_matrix obj c ≠ 0 :=
λ h, by simpa [h, lt_irrefl] using find_pivot_column_spec hc

lemma find_pivot_row_eq_none_aux {T : tableau m n} {obj : fin m} {c : fin n}
  (hrow : find_pivot_row T obj c = none) (hs : c ∈ find_pivot_column T obj) :
  ∀ r, obj ≠ r → T.to_partition.rowg r ∈ T.restricted → 0 ≤ T.to_matrix obj c / T.to_matrix r c :=
by simpa [find_pivot_row, list.filter_eq_nil] using hrow

lemma find_pivot_row_eq_none {T : tableau m n} {obj : fin m} {c : fin n} (hT : T.feasible)
  (hrow : find_pivot_row T obj c = none) (hs : c ∈ find_pivot_column T obj) :
  T.is_unbounded_above (T.to_partition.rowg obj) :=
have hrow : ∀ r, obj ≠ r → T.to_partition.rowg r ∈ T.restricted →
    0 ≤ T.to_matrix obj c / T.to_matrix r c,
  from find_pivot_row_eq_none_aux hrow hs,
have hc : (T.to_matrix obj c ≠ 0 ∧ T.to_partition.colg c ∉ T.restricted)
    ∨ (0 < T.to_matrix obj c ∧ T.to_partition.colg c ∈ T.restricted),
  from find_pivot_column_spec hs,
have hToc : T.to_matrix obj c ≠ 0, from λ h, by simpa [h, lt_irrefl] using hc,
(lt_or_gt_of_ne hToc).elim
  (λ hToc : T.to_matrix obj c < 0, is_unbounded_above_rowg_of_nonpos hT c
    (hc.elim and.right (λ h, (not_lt_of_gt hToc h.1).elim))
    (λ i hi, classical.by_cases
      (λ hoi : obj = i, le_of_lt (hoi ▸ hToc))
      (λ hoi : obj ≠ i, inv_nonpos.1 $ nonpos_of_mul_nonneg_right (hrow _ hoi hi) hToc))
    hToc)
  (λ hToc : 0 < T.to_matrix obj c, is_unbounded_above_rowg_of_nonneg hT c
    (λ i hi, classical.by_cases
      (λ hoi : obj = i, le_of_lt (hoi ▸ hToc))
      (λ hoi : obj ≠ i, inv_nonneg.1 $ nonneg_of_mul_nonneg_left (hrow _ hoi hi) hToc))
    hToc)

def feasible_of_mem_pivot_row_and_column {T : tableau m n} {obj : fin m} (hT : T.feasible) {c}
  (hc : c ∈ find_pivot_column T obj) {r} (hr : r ∈ find_pivot_row T obj c) :
  feasible (T.pivot r c) :=
begin
  have := find_pivot_column_spec hc,
  have := find_pivot_row_spec hr,
  have := @feasible_simplex_pivot _ _ _ obj hT r c,
  tauto
end

section blands_rule

local attribute [instance, priority 0] classical.dec
variable (obj : fin m)

lemma not_unique_row_and_unique_col {T T' : tableau m n} {r c c'}
  (hcobj0 : 0 < T.to_matrix obj c)
  (hc'obj0 : 0 < T'.to_matrix obj c')
  (hrc0 : T.to_matrix r c < 0)
  (hflat : T.flat = T'.flat)
  (hs : T.to_partition.rowg r = T'.to_partition.colg c')
  (hrobj : T.to_partition.rowg obj = T'.to_partition.rowg obj)
  (hfickle : ∀ i, T.to_partition.rowg i ≠ T'.to_partition.rowg i → T.const i 0 = 0)
  (hobj : T.const obj 0 = T'.const obj 0)
  (nonpos_of_colg_ne : ∀ j,
    T'.to_partition.colg j ≠ T.to_partition.colg j → j ≠ c' → T'.to_matrix obj j ≤ 0)
  (nonpos_of_colg_eq : ∀ j, j ≠ c' →
    T'.to_partition.colg j = T.to_partition.colg c → T'.to_matrix obj j ≤ 0)
  (unique_row : ∀ i ≠ r, T.const i 0 = 0 → T.to_partition.rowg i ≠ T'.to_partition.rowg i →
    0 ≤ T.to_matrix i c) :
  false :=
let objr := T.to_partition.rowg obj in
let x := λ y : ℚ, T.of_col (y • (single c 0).to_matrix) in
have hxflatT' : ∀ {y}, x y ∈ flat T', from hflat ▸ λ _, of_col_mem_flat _ _,
have hxrow : ∀ y i, x y (T.to_partition.rowg i) 0 = T.const i 0 + y * T.to_matrix i c,
  by simp [x, of_col_single_rowg],
have hxcol : ∀ {y j}, j ≠ c → x y (T.to_partition.colg j) 0 = 0,
  from λ y j hjc, by simp [x, of_col_colg, pequiv.to_matrix, single_apply_of_ne hjc.symm],
have hxcolc : ∀ {y}, x y (T.to_partition.colg c) 0 = y, by simp [x, of_col_colg, pequiv.to_matrix],
let c_star : fin (m + n) → ℚ := λ v, option.cases_on (T'.to_partition.colp.symm v) 0
  (T'.to_matrix obj) in
have hxobj : ∀ y, x y objr 0 = T.const obj 0 + y * T.to_matrix obj c, from λ y, hxrow _ _,
have hgetr : ∀ {y v}, c_star v * x y v 0 ≠ 0 → (T'.to_partition.colp.symm v).is_some,
  from λ y v, by cases h : T'.to_partition.colp.symm v; dsimp [c_star]; rw h; simp,
have c_star_eq_get : ∀ {v} (hv : (T'.to_partition.colp.symm v).is_some),
    c_star v = T'.to_matrix obj (option.get hv),
  from λ v hv, by dsimp only [c_star]; conv_lhs{rw [← option.some_get hv]}; refl,
have hsummmn : ∀ {y}, sum univ (λ j, T'.to_matrix obj j * x y (T'.to_partition.colg j) 0) =
    sum univ (λ v, c_star v * x y v 0),
  from λ y, sum_bij_ne_zero (λ j _ _, T'.to_partition.colg j) (λ _ _ _, mem_univ _)
    (λ _ _ _ _ _ _ h, T'.to_partition.injective_colg h)
    (λ v _ h0, ⟨option.get (hgetr h0), mem_univ _,
      by rw [← c_star_eq_get (hgetr h0)]; simpa using h0, by simp⟩)
    (λ _ _ h0, by dsimp [c_star]; rw [colp_colg]),
have hgetc : ∀ {y v}, c_star v * x y v 0 ≠ 0 → v ≠ T.to_partition.colg c →
    (T.to_partition.rowp.symm v).is_some,
  from λ y v, (eq_rowg_or_colg T.to_partition v).elim
    (λ ⟨i, hi⟩, by rw [hi, rowp_rowg]; simp)
    (λ ⟨j, hj⟩ h0 hvc,
      by rw [hj, hxcol (mt (congr_arg T.to_partition.colg) (hvc ∘ hj.trans)), mul_zero] at h0;
        exact (h0 rfl).elim),
have hsummmnn : ∀ {y}, (univ.erase (T.to_partition.colg c)).sum (λ v, c_star v * x y v 0) =
    univ.sum (λ i, c_star (T.to_partition.rowg i) * x y (T.to_partition.rowg i) 0),
  from λ y, eq.symm $ sum_bij_ne_zero (λ i _ _, T.to_partition.rowg i) (by simp)
    (λ _ _ _ _ _ _ h, T.to_partition.injective_rowg h)
    (λ v hvc h0, ⟨option.get (hgetc h0 (mem_erase.1 hvc).1), mem_univ _, by simpa using h0⟩)
    (by intros; refl),
have hsumm : ∀ {y}, univ.sum (λ i, c_star (T.to_partition.rowg i) * x y (T.to_partition.rowg i) 0) =
    univ.sum (λ i, c_star (T.to_partition.rowg i) * T.const i 0) +
    y * univ.sum (λ i, c_star (T.to_partition.rowg i) * T.to_matrix i c),
  from λ y, by simp only [hxrow, mul_add, add_mul, sum_add_distrib, mul_assoc,
    mul_left_comm _ y, mul_sum.symm],
have hxobj' : ∀ y, x y objr 0 = univ.sum (λ v, c_star v * x y v 0) + T'.const obj 0,
  from λ y, by dsimp [objr]; rw [hrobj, mem_flat_iff.1 hxflatT', hsummmn],
have hy : ∀ {y}, y * T.to_matrix obj c = c_star (T.to_partition.colg c) * y +
    univ.sum (λ i, c_star (T.to_partition.rowg i) * T.const i 0) +
      y * univ.sum (λ i, c_star (T.to_partition.rowg i) * T.to_matrix i c),
  from λ y, by rw [← add_left_inj (T.const obj 0), ← hxobj, hxobj',
    ← insert_erase (mem_univ (T.to_partition.colg c)), sum_insert (not_mem_erase _ _),
    hsummmnn, hobj, hsumm, hxcolc]; simp,
have hy' : ∀ (y), y * (T.to_matrix obj c - c_star (T.to_partition.colg c) -
    univ.sum (λ i, c_star (T.to_partition.rowg i) * T.to_matrix i c)) =
    univ.sum (λ i, c_star (T.to_partition.rowg i) * T.const i 0),
  from λ y, by rw [mul_sub, mul_sub, hy]; simp [mul_comm, mul_assoc, mul_left_comm],
have h0 : T.to_matrix obj c - c_star (T.to_partition.colg c) -
    univ.sum (λ i, c_star (T.to_partition.rowg i) * T.to_matrix i c) = 0,
  by rw [← (domain.mul_left_inj (@one_ne_zero ℚ _)), hy', ← hy' 0, zero_mul, mul_zero],
have hcolnec' : T'.to_partition.colp.symm (T.to_partition.colg c) ≠ some c',
  from λ h,
    by simpa [hs.symm] using congr_arg T'.to_partition.colg (option.eq_some_iff_get_eq.1 h).snd,
have eq_of_roweqc' : ∀ {i}, T'.to_partition.colp.symm (T.to_partition.rowg i) = some c' → i = r,
  from λ i h, by simpa [hs.symm, T.to_partition.injective_rowg.eq_iff] using
    congr_arg T'.to_partition.colg (option.eq_some_iff_get_eq.1 h).snd,
have sumpos : 0 < univ.sum (λ i, c_star (T.to_partition.rowg i) * T.to_matrix i c),
  by rw [← sub_eq_zero.1 h0]; exact add_pos_of_pos_of_nonneg hcobj0
    (begin
      simp only [c_star, neg_nonneg],
      cases h : T'.to_partition.colp.symm (T.to_partition.colg c) with j,
      { refl },
      { exact nonpos_of_colg_eq j (mt (congr_arg some) (h ▸ hcolnec'))
          (by rw [← (option.eq_some_iff_get_eq.1 h).snd]; simp) }
    end),
have hexi : ∃ i, 0 < c_star (T.to_partition.rowg i) * T.to_matrix i c,
  from imp_of_not_imp_not _ _ (by simpa using @sum_nonpos _ _ (@univ (fin m) _)
    (λ i, c_star (T.to_partition.rowg i) * T.to_matrix i c) _ _) sumpos,
let ⟨i, hi⟩ := hexi in
have hi0 : T.const i 0 = 0, from hfickle i
  (λ h, by dsimp [c_star] at hi; rw [h, colp_rowg_eq_none] at hi; simpa [lt_irrefl] using hi),
have hi_some : (T'.to_partition.colp.symm (T.to_partition.rowg i)).is_some,
  from option.ne_none_iff_is_some.1 (λ h, by dsimp only [c_star] at hi; rw h at hi;
    simpa [lt_irrefl] using hi),
have hi' : 0 < T'.to_matrix obj (option.get hi_some) * T.to_matrix i c,
  by dsimp only [c_star] at hi; rwa [← option.some_get hi_some] at hi,
have hir : i ≠ r, from λ hir, begin
    have : option.get hi_some = c', from T'.to_partition.injective_colg
      (by rw [colg_get_colp_symm, ← hs, hir]),
    rw [this, hir] at hi',
    exact not_lt_of_gt hi' (mul_neg_of_pos_of_neg hc'obj0 hrc0)
  end,
have hnec' : option.get hi_some ≠ c',
  from λ eq_c', hir $ @eq_of_roweqc' i (eq_c' ▸ by simp),
have hic0 : T.to_matrix i c < 0,
  from neg_of_mul_pos_right hi' (nonpos_of_colg_ne _ (by simp) hnec'),
not_le_of_gt hic0 (unique_row _ hir hi0
  (by rw [← colg_get_colp_symm _ _ hi_some]; exact colg_ne_rowg _ _ _))

inductive rel : tableau m n → tableau m n → Prop
| pivot : ∀ {T}, feasible T → ∀ {r c}, c ∈ find_pivot_column T obj →
  r ∈ find_pivot_row T obj c → rel (T.pivot r c) T
| trans_pivot : ∀ {T₁ T₂ r c}, rel T₁ T₂ → c ∈ find_pivot_column T₁ obj →
  r ∈ find_pivot_row T₁ obj c → rel (T₁.pivot r c) T₂

lemma feasible_of_rel_right {T T' : tableau m n} (h : rel obj T' T) : T.feasible :=
rel.rec_on h (by tauto) (by tauto)

lemma feasible_of_rel_left {T T' : tableau m n} (h : rel obj T' T) : T'.feasible :=
rel.rec_on h (λ _ hT _ _ hc hr, feasible_of_mem_pivot_row_and_column hT hc hr)
  (λ _ _ _ _ _ hc hr hT, feasible_of_mem_pivot_row_and_column hT hc hr)

/-- Slightly stronger recursor than the default recursor -/
@[elab_as_eliminator]
lemma rel.rec_on' {obj : fin m} {C : tableau m n → tableau m n → Prop} {T T' : tableau m n}
  (hrel : rel obj T T')
  (hpivot : ∀ {T : tableau m n} {r : fin m} {c : fin n},
     feasible T → c ∈ find_pivot_column T obj → r ∈ find_pivot_row T obj c → C (pivot T r c) T)
  (hpivot_trans : ∀ {T₁ T₂ : tableau m n} {r : fin m} {c : fin n},
    rel obj (T₁.pivot r c) T₁ → rel obj T₁ T₂ →
     c ∈ find_pivot_column T₁ obj →
     r ∈ find_pivot_row T₁ obj c → C (T₁.pivot r c) T₁ → C T₁ T₂ → C (pivot T₁ r c) T₂) :
  C T T' :=
rel.rec_on hrel (λ T hT r c  hc hr, hpivot hT hc hr) (λ T₁ T₂ r c hrelT₁₂ hc hr ih, hpivot_trans
  (rel.pivot (feasible_of_rel_left obj hrelT₁₂) hc hr) hrelT₁₂ hc hr
  (hpivot (feasible_of_rel_left obj hrelT₁₂) hc hr) ih)

lemma rel.trans {obj : fin m} {T₁ T₂ T₃ : tableau m n} (h₁₂ : rel obj T₁ T₂) :
  rel obj T₂ T₃ → rel obj T₁ T₃ :=
rel.rec_on h₁₂
  (λ T r c hT hc hr hrelT, rel.trans_pivot hrelT hc hr)
  (λ T₁ T₂ r c hrelT₁₂ hc hr ih hrelT₂₃, rel.trans_pivot (ih hrelT₂₃) hc hr)

instance : is_trans (tableau m n) (rel obj) := ⟨@rel.trans _ _ obj⟩

lemma flat_eq_of_rel {T T' : tableau m n} (h : rel obj T' T) : flat T' = flat T :=
rel.rec_on' h (λ _ _ _ _ _ hr, flat_pivot (ne_zero_of_mem_find_pivot_row hr))
  (λ _ _ _ _ _ _ _ _, eq.trans)

lemma rowg_obj_eq_of_rel {T T' : tableau m n} (h : rel obj T T') : T.to_partition.rowg obj =
  T'.to_partition.rowg obj :=
rel.rec_on' h (λ T r c hfT hc hr, by simp [rowg_swap_of_ne _ (find_pivot_row_spec hr).1])
  (λ _ _ _ _ _ _ _ _, eq.trans)

lemma restricted_eq_of_rel {T T' : tableau m n} (h : rel obj T T') : T.restricted = T'.restricted :=
rel.rec_on' h (λ _ _ _ _ _ _, rfl) (λ _ _ _ _ _ _ _ _, eq.trans)

lemma exists_mem_pivot_row_column_of_rel {T T' : tableau m n} (h : rel obj T' T) :
  ∃ r c, c ∈ find_pivot_column T obj ∧ r ∈ find_pivot_row T obj c :=
rel.rec_on' h (λ _ r c _ hc hr, ⟨r, c, hc, hr⟩) (λ _ _ _ _ _ _ _ _ _, id)

lemma exists_mem_pivot_row_of_rel {T T' : tableau m n} (h : rel obj T' T) {c : fin n}
  (hc : c ∈ find_pivot_column T obj) : ∃ r, r ∈ find_pivot_row T obj c :=
let ⟨r, c', hc', hr⟩ := exists_mem_pivot_row_column_of_rel obj h in ⟨r, by simp * at *⟩

lemma colg_eq_or_exists_mem_pivot_column {T₁ T₂ : tableau m n} (h : rel obj T₂ T₁) {c : fin n} :
  T₁.to_partition.colg c = T₂.to_partition.colg c ∨
  ∃ T₃, (T₃ = T₁ ∨ rel obj T₃ T₁) ∧ (rel obj T₂ T₃) ∧
  T₃.to_partition.colg c = T₁.to_partition.colg c ∧
  c ∈ find_pivot_column T₃ obj :=
rel.rec_on' h begin
    assume T r c' hT hc' hr,
    by_cases hcc : c = c',
    { subst hcc,
      exact or.inr ⟨T, or.inl rfl, rel.pivot hT hc' hr, rfl, hc'⟩ },
    { simp [colg_swap_of_ne _ hcc] }
  end
  (λ T₁ T₂ r c hrelp₁ hrel₁₂ hc hr ihp₁ ih₁₂,
    ih₁₂.elim
      (λ ih₁₂, ihp₁.elim
        (λ ihp₁, or.inl (ih₁₂.trans ihp₁))
        (λ ⟨T₃, hT₃⟩, or.inr ⟨T₃,
          hT₃.1.elim (λ h, h.symm ▸ or.inr hrel₁₂) (λ h, or.inr $ h.trans hrel₁₂),
          hT₃.2.1, hT₃.2.2.1.trans ih₁₂.symm, hT₃.2.2.2⟩))
      (λ ⟨T₃, hT₃⟩, or.inr ⟨T₃, hT₃.1, hrelp₁.trans hT₃.2.1, hT₃.2.2⟩))

lemma rowg_eq_or_exists_mem_pivot_row {T₁ T₂ : tableau m n} (h : rel obj T₂ T₁) (r : fin m) :
  T₁.to_partition.rowg r = T₂.to_partition.rowg r ∨
  ∃ (T₃ : tableau m n) c, (T₃ = T₁ ∨ rel obj T₃ T₁) ∧ (rel obj T₂ T₃) ∧
    T₃.to_partition.rowg r = T₁.to_partition.rowg r ∧
    c ∈ find_pivot_column T₃ obj ∧ r ∈ find_pivot_row T₃ obj c :=
rel.rec_on' h
  begin
    assume T r' c hT hc hr',
    by_cases hrr : r = r',
    { subst hrr,
      exact or.inr ⟨T, c, or.inl rfl, rel.pivot hT hc hr', rfl, hc, hr'⟩ },
    { simp [rowg_swap_of_ne _ hrr] }
  end
  (λ T₁ T₂ r c hrelp₁ hrel₁₂ hc hr ihp₁ ih₁₂,
    ih₁₂.elim
      (λ ih₁₂, ihp₁.elim
        (λ ihp₁, or.inl $ ih₁₂.trans ihp₁)
        (λ ⟨T₃, c', hT₃⟩, or.inr ⟨T₃, c', hT₃.1.elim (λ h, h.symm ▸ or.inr hrel₁₂)
           (λ h, or.inr $ h.trans hrel₁₂), hT₃.2.1, ih₁₂.symm ▸ hT₃.2.2.1, hT₃.2.2.2⟩))
      (λ ⟨T₃, c', hT₃⟩, or.inr ⟨T₃, c', hT₃.1,
        (rel.pivot (feasible_of_rel_left _ hrel₁₂) hc hr).trans hT₃.2.1, hT₃.2.2⟩))

lemma eq_or_rel_pivot_of_rel {T₁ T₂ : tableau m n} (h : rel obj T₁ T₂) : ∀ {r c}
  (hc : c ∈ find_pivot_column T₂ obj) (hr : r ∈ find_pivot_row T₂ obj c),
  T₁ = T₂.pivot r c ∨ rel obj T₁ (T₂.pivot r c) :=
rel.rec_on' h (λ T r c hT hc hr r' c' hc' hr', by simp * at *)
  (λ T₁ T₂ r c hrelp₁ hrel₁₂ hc hr ihp₁ ih₁₂ r' c' hc' hr',
    (ih₁₂ hc' hr').elim
      (λ ih₁₂, or.inr $ ih₁₂ ▸ rel.pivot (feasible_of_rel_left _ hrel₁₂) hc hr)
      (λ ih₁₂, or.inr $ (rel.pivot (feasible_of_rel_left _ hrel₁₂) hc hr).trans ih₁₂))

lemma exists_mem_pivot_column_of_mem_pivot_row {T : tableau m n} (hrelTT : rel obj T T)
  {r c} (hc : c ∈ find_pivot_column T obj) (hr : r ∈ find_pivot_row T obj c) :
  ∃ (T' : tableau m n), c ∈ find_pivot_column T' obj ∧ T'.to_partition.colg c =
  T.to_partition.rowg r ∧ rel obj T' T ∧ rel obj T T' :=
have hrelTTp : rel obj T (T.pivot r c),
  from (eq_or_rel_pivot_of_rel _ hrelTT hc hr).elim (λ h, h ▸ hrelTT ) id,
let ⟨T', hT'⟩ := (colg_eq_or_exists_mem_pivot_column obj hrelTTp).resolve_left
  (show (T.pivot r c).to_partition.colg c ≠ T.to_partition.colg c, by simp) in
⟨T', hT'.2.2.2, by simp [hT'.2.2.1], hT'.1.elim
  (λ h, h.symm ▸ rel.pivot (feasible_of_rel_left _ hrelTT) hc hr)
  (λ h, h.trans $ rel.pivot (feasible_of_rel_left _ hrelTT) hc hr), hT'.2.1⟩

lemma exists_mem_pivot_column_of_rowg_ne {T T' : tableau m n} (hrelTT' : rel obj T T') {r : fin m}
  (hrelT'T : rel obj T' T) (hrow : T.to_partition.rowg r ≠ T'.to_partition.rowg r) :
  ∃ (T₃ : tableau m n) c, c ∈ find_pivot_column T₃ obj ∧ T₃.to_partition.colg c =
  T.to_partition.rowg r ∧ rel obj T₃ T ∧ rel obj T T₃ :=
let ⟨T₃, c, hT₃, hrelT₃T, hrow₃, hc, hr⟩ :=
  (rowg_eq_or_exists_mem_pivot_row obj hrelT'T _).resolve_left hrow in
let ⟨T₄, hT₄⟩ := exists_mem_pivot_column_of_mem_pivot_row obj
  (show rel obj T₃ T₃, from hT₃.elim (λ h, h.symm ▸ hrelTT'.trans hrelT'T)
    (λ h, h.trans $ hrelTT'.trans hrelT₃T)) hc hr in
⟨T₄, c, hT₄.1, hT₄.2.1.trans hrow₃, hT₄.2.2.1.trans $ hT₃.elim (λ h, h.symm ▸ hrelTT'.trans hrelT'T)
  (λ h, h.trans $ hrelTT'.trans hrelT'T), hrelTT'.trans (hrelT₃T.trans hT₄.2.2.2)⟩

lemma const_obj_le_of_rel {T₁ T₂ : tableau m n} (h : rel obj T₁ T₂) :
  T₂.const obj 0 ≤ T₁.const obj 0 :=
rel.rec_on' h (λ T r c hT hc hr,
    have hr' : _ := find_pivot_row_spec hr,
    simplex_const_obj_le hT (by tauto) (by tauto))
  (λ _ _ _ _ _ _ _ _ h₁ h₂, le_trans h₂ h₁)

lemma const_obj_eq_of_rel_of_rel {T₁ T₂ : tableau m n} (h₁₂ : rel obj T₁ T₂)
  (h₂₁ : rel obj T₂ T₁) : T₁.const obj 0 = T₂.const obj 0 :=
le_antisymm (const_obj_le_of_rel _ h₂₁) (const_obj_le_of_rel _ h₁₂)

lemma const_eq_const_of_const_obj_eq {T₁ T₂ : tableau m n} (h₁₂ : rel obj T₁ T₂) :
  ∀ (hobj : T₁.const obj 0 = T₂.const obj 0) (i : fin m), T₁.const i 0 = T₂.const i 0 :=
rel.rec_on' h₁₂
  (λ T r c hfT hc hr hobj i,
    have hr0 : T.const r 0 = 0, from const_eq_zero_of_const_obj_eq hfT
      (ne_zero_of_mem_find_pivot_column hc) (ne_zero_of_mem_find_pivot_row hr)
      (find_pivot_row_spec hr).1 hobj,
    if hir : i = r
      then by simp [hir, hr0]
      else by simp [const_pivot_of_ne _ hir, hr0])
  (λ T₁ T₂ r c hrelp₁ hrel₁₂ hc hr ihp₁ ih₁₂ hobj i,
    have hobjp : (pivot T₁ r c).const obj 0 = T₁.const obj 0,
      from le_antisymm (hobj.symm ▸ const_obj_le_of_rel _ hrel₁₂)
        (const_obj_le_of_rel _ hrelp₁),
    by rw [ihp₁ hobjp, ih₁₂ (hobjp.symm.trans hobj)])

lemma const_eq_zero_of_rowg_ne_of_rel_self {T T' : tableau m n} (hrelTT' : rel obj T T')
  (hrelT'T : rel obj T' T) (i : fin m) (hrow : T.to_partition.rowg i ≠ T'.to_partition.rowg i) :
  T.const i 0 = 0 :=
let ⟨T₃, c, hT₃₁, hT'₃, hrow₃, hc, hi⟩ := (rowg_eq_or_exists_mem_pivot_row obj hrelT'T _).resolve_left hrow in
have T₃.const i 0 = 0, from const_eq_zero_of_const_obj_eq
  (feasible_of_rel_right _ hT'₃) (ne_zero_of_mem_find_pivot_column hc)
  (ne_zero_of_mem_find_pivot_row hi) (find_pivot_row_spec hi).1
  (const_obj_eq_of_rel_of_rel _ (rel.pivot (feasible_of_rel_right _ hT'₃) hc hi)
    ((eq_or_rel_pivot_of_rel _ hT'₃ hc hi).elim
      (λ h, h ▸ hT₃₁.elim (λ h, h.symm ▸ hrelTT') (λ h, h.trans hrelTT'))
      (λ hrelT'p, hT₃₁.elim (λ h, h.symm ▸ hrelTT'.trans (h ▸ hrelT'p))
        (λ h, h.trans $ hrelTT'.trans hrelT'p)))),
have hobj : T₃.const obj 0 = T.const obj 0,
  from hT₃₁.elim (λ h, h ▸ rfl) (λ h, const_obj_eq_of_rel_of_rel _ h (hrelTT'.trans hT'₃)),
hT₃₁.elim (λ h, h ▸ this) (λ h, const_eq_const_of_const_obj_eq obj h hobj i ▸ this)

lemma colg_mem_restricted_of_rel_self {T : tableau m n} (hrelTT : rel obj T T)
  {c} (hc : c ∈ find_pivot_column T obj) : T.to_partition.colg c ∈ T.restricted :=
let ⟨r, hr⟩ := exists_mem_pivot_row_of_rel obj hrelTT hc in
let ⟨T', c', hT', hrelTT', hrowcol, _, hr'⟩ := (rowg_eq_or_exists_mem_pivot_row obj
    ((eq_or_rel_pivot_of_rel _ hrelTT hc hr).elim
      (λ h, show rel obj T (T.pivot r c), from h ▸ hrelTT) id) _).resolve_left
  (show (T.pivot r c).to_partition.rowg r ≠ T.to_partition.rowg r, by simp) in
(restricted_eq_of_rel _ hrelTT').symm ▸ by convert (find_pivot_row_spec hr').2.1; simp [hrowcol]

lemma eq_zero_of_not_mem_restricted_of_rel_self {T : tableau m n} (hrelTT : rel obj T T)
  {j} (hjres : T.to_partition.colg j ∉ T.restricted) : T.to_matrix obj j = 0 :=
let ⟨r, c, hc, hr⟩ := exists_mem_pivot_row_column_of_rel obj hrelTT in
have hcres : T.to_partition.colg c ∈ T.restricted,
  from colg_mem_restricted_of_rel_self obj hrelTT hc,
by_contradiction $ λ h0,
begin
  simp [find_pivot_column] at hc,
  cases h : fin.find (λ c, T.to_matrix obj c ≠ 0 ∧ colg (T.to_partition) c ∉ T.restricted),
  { simp [*, fin.find_eq_none_iff] at * },
  { rw h at hc, clear_aux_decl,
    have := (fin.find_eq_some_iff.1 h).1,
    simp * at * }
end

lemma rel.irrefl {obj : fin m} : ∀ (T : tableau m n), ¬ rel obj T T :=
λ T1 hrelT1,
let ⟨rT1 , cT1, hrT1, hcT1⟩ := exists_mem_pivot_row_column_of_rel obj hrelT1 in
let ⟨t, ht⟩ := finset.max_of_mem
  (show T1.to_partition.colg cT1 ∈ univ.filter (λ v, ∃ (T' : tableau m n) (c : fin n),
      rel obj T' T' ∧ c ∈ find_pivot_column T' obj ∧ T'.to_partition.colg c = v),
    by simp only [true_and, mem_filter, mem_univ, exists_and_distrib_left];
      exact ⟨T1, hrelT1, cT1, hrT1, rfl⟩) in
let ⟨_, T', c', hrelTT'', hcT', hct⟩ := finset.mem_filter.1 (finset.mem_of_max ht) in
have htmax : ∀ (s : fin (m + n)) (T : tableau m n),
    rel obj T T → ∀ (j : fin n), find_pivot_column T obj = some j →
      T.to_partition.colg j = s → s ≤ t,
  by simpa using λ s (h : s ∈ _), finset.le_max_of_mem h ht,
let ⟨r, hrT'⟩ := exists_mem_pivot_row_of_rel obj hrelTT'' hcT' in
have hrelTT''p : rel obj T' (T'.pivot r c'),
  from (eq_or_rel_pivot_of_rel obj hrelTT'' hcT' hrT').elim (λ h, h ▸ hrelTT'') id,
let ⟨T, c, hTT', hrelT'T, hT'Tr, hc, hr⟩ := (rowg_eq_or_exists_mem_pivot_row obj
  hrelTT''p r).resolve_left (by simp) in
have hfT' : feasible T', from feasible_of_rel_left _ hrelTT'',
have hfT : feasible T, from feasible_of_rel_right _ hrelT'T,
have hrelT'pT' : rel obj (T'.pivot r c') T', from rel.pivot hfT' hcT' hrT',
have hrelTT' : rel obj T T', from hTT'.elim (λ h, h.symm ▸ hrelT'pT') (λ h, h.trans hrelT'pT'),
have hrelTT : rel obj T T, from hrelTT'.trans hrelT'T,
have hc't : T.to_partition.colg c ≤ t, from htmax _ T hrelTT _ hc rfl,
have hoT'T : T'.const obj 0 = T.const obj 0, from const_obj_eq_of_rel_of_rel _ hrelT'T hrelTT',
have hfickle : ∀ i, T.to_partition.rowg i ≠ T'.to_partition.rowg i → T.const i 0 = 0,
  from const_eq_zero_of_rowg_ne_of_rel_self obj hrelTT' hrelT'T,
have hobj : T.const obj 0 = T'.const obj 0, from const_obj_eq_of_rel_of_rel _ hrelTT' hrelT'T,
have hflat : T.flat = T'.flat, from flat_eq_of_rel obj hrelTT',
have hrobj : T.to_partition.rowg obj = T'.to_partition.rowg obj, from rowg_obj_eq_of_rel _ hrelTT',
have hs : T.to_partition.rowg r = T'.to_partition.colg c', by simpa using hT'Tr,
have hc'res : T'.to_partition.colg c' ∈ T'.restricted,
  from hs ▸ restricted_eq_of_rel _ hrelTT' ▸ (find_pivot_row_spec hr).2.1,
have hc'obj0 : 0 < T'.to_matrix obj c', by simpa [hc'res] using find_pivot_column_spec hcT',
have hcres : T.to_partition.colg c ∈ T.restricted,
  from colg_mem_restricted_of_rel_self obj hrelTT hc,
have hcobj0 : 0 < to_matrix T obj c, by simpa [hcres] using find_pivot_column_spec hc,
have hrc0 : T.to_matrix r c < 0,
  from inv_neg'.1 $ neg_of_mul_neg_left (find_pivot_row_spec hr).2.2.1 (le_of_lt hcobj0),
have nonpos_of_colg_ne : ∀ j, T'.to_partition.colg j ≠ T.to_partition.colg j → j ≠ c' →
    T'.to_matrix obj j ≤ 0,
  from λ j hj hjc',
    let ⟨T₃, hT₃⟩ := (colg_eq_or_exists_mem_pivot_column obj hrelTT').resolve_left hj in
    nonpos_of_lt_find_pivot_column hcT' hc'res
      (lt_of_le_of_ne
        (hct.symm ▸ hT₃.2.2.1 ▸ htmax _ T₃ (hT₃.1.elim (λ h, h.symm ▸ hrelTT'')
          (λ h, h.trans (hrelT'T.trans hT₃.2.1))) _ hT₃.2.2.2 rfl)
        (by rwa [ne.def, T'.to_partition.injective_colg.eq_iff])),
have nonpos_of_colg_eq : ∀ j, j ≠ c' →
    T'.to_partition.colg j = T.to_partition.colg c → T'.to_matrix obj j ≤ 0,
  from λ j hjc' hj,
    if hjc : j = c
      then by clear_aux_decl; subst j; exact nonpos_of_lt_find_pivot_column hcT' hc'res
        (lt_of_le_of_ne
          (hj.symm ▸ hct.symm ▸ htmax _ _ hrelTT _ hc rfl)
          (hs ▸ hj.symm ▸ colg_ne_rowg _ _ _))
      else let ⟨T₃, hT₃⟩ := (colg_eq_or_exists_mem_pivot_column obj hrelTT').resolve_left
        (show T'.to_partition.colg j ≠ T.to_partition.colg j,
          by simpa [hj, T.to_partition.injective_colg.eq_iff, eq_comm] using hjc) in
      nonpos_of_lt_find_pivot_column hcT' hc'res
        (lt_of_le_of_ne
          (hct.symm ▸ hT₃.2.2.1 ▸ htmax _ T₃ (hT₃.1.elim (λ h, h.symm ▸ hrelTT'')
            (λ h, h.trans (hrelT'T.trans hT₃.2.1))) _ hT₃.2.2.2 rfl)
          (by rwa [ne.def, T'.to_partition.injective_colg.eq_iff])),
have unique_row : ∀ i ≠ r, T.const i 0 = 0 → T.to_partition.rowg i ≠ T'.to_partition.rowg i →
    0 ≤ T.to_matrix i c,
  from λ i hir hi0 hrow,
    let ⟨T₃, c₃, hc₃, hrow₃, hrelT₃T, hrelTT₃⟩ :=
      exists_mem_pivot_column_of_rowg_ne _ hrelTT' hrelT'T hrow in
    have hrelT₃T₃ : rel obj T₃ T₃, from hrelT₃T.trans hrelTT₃,
    nonneg_of_lt_find_pivot_row (by exact hcobj0)
      (by rw [← hrow₃, ← restricted_eq_of_rel _ hrelT₃T];
        exact colg_mem_restricted_of_rel_self _ hrelT₃T₃ hc₃) hc hr hi0
      (lt_of_le_of_ne (by rw [hs, hct, ← hrow₃]; exact htmax _ _ hrelT₃T₃ _ hc₃ rfl)
        (by simpa [T.to_partition.injective_rowg.eq_iff])),
not_unique_row_and_unique_col obj hcobj0 hc'obj0 hrc0 hflat hs hrobj hfickle hobj
  nonpos_of_colg_ne nonpos_of_colg_eq unique_row

noncomputable instance fintype_rel (T : tableau m n) : fintype {T' | rel obj T' T} :=
fintype.of_injective (λ T', T'.val.to_partition)
  (λ T₁ T₂ h, subtype.eq $ tableau.ext
    (by rw [flat_eq_of_rel _ T₁.2, flat_eq_of_rel _ T₂.2]) h
    (by rw [restricted_eq_of_rel _ T₁.2, restricted_eq_of_rel _ T₂.2]))

lemma rel_wf (m n : ℕ) (obj : fin m): well_founded (@rel m n obj) :=
subrelation.wf
  (show subrelation (@rel m n obj) (measure (λ T, fintype.card {T' | rel obj T' T})),
    from assume T₁ T₂ h,
    set.card_lt_card (set.ssubset_iff_subset_not_subset.2 ⟨λ T' hT', hT'.trans h,
      classical.not_forall.2 ⟨T₁, λ h', rel.irrefl _ (h' h)⟩⟩))
  (measure_wf (λ T, fintype.card {T' | rel obj T' T}))

end blands_rule

@[derive _root_.decidable_eq] inductive termination : Type
| while     : termination
| unbounded : termination
| optimal   : termination

open termination

instance : has_repr termination := ⟨λ t, termination.cases_on t "while" "unbounded" "optimal"⟩

instance : fintype termination := ⟨⟨quotient.mk [while, unbounded, optimal], dec_trivial⟩,
  λ x, by cases x; exact dec_trivial⟩

open termination

/-- The simplex algorithm -/
def simplex (w : tableau m n → bool) (obj : fin m) : Π (T : tableau m n) (hT : feasible T),
  tableau m n × termination
| T := λ hT, cond (w T)
  (match find_pivot_column T obj, @feasible_of_mem_pivot_row_and_column _ _ _ obj hT,
      @rel.pivot m n obj _ hT with
    | none,   hc, hrel := (T, optimal)
    | some c, hc, hrel :=
      match find_pivot_row T obj c, @hc _ rfl, (λ r, @hrel r c rfl) with
      | none,   hr, hrel := (T, unbounded)
      | some r, hr, hrel := have wf : rel obj (pivot T r c) T, from hrel _ rfl,
        simplex (T.pivot r c) (hr rfl)
      end
    end)
  (T, while)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, rel_wf m n obj⟩],
  dec_tac := tactic.assumption}

lemma simplex_pivot {w : tableau m n → bool} {T : tableau m n} (hT : feasible T)
  (hw : w T = tt) {obj : fin m} {r : fin m} {c : fin n}
  (hc : c ∈ find_pivot_column T obj) (hr : r ∈ find_pivot_row T obj c) :
  (T.pivot r c).simplex w obj  (feasible_of_mem_pivot_row_and_column hT hc hr) =
  T.simplex w obj hT  :=
by conv_rhs { rw simplex };
  simp [hw, show _ = _, from hr, show _ = _, from hc, simplex._match_1, simplex._match_2]

lemma simplex_spec_aux (w : tableau m n → bool) (obj : fin m) :
  Π (T : tableau m n) (hT : feasible T),
  ((T.simplex w obj hT).2 = while ∧ w (T.simplex w obj hT).1 = ff) ∨
  ((T.simplex w obj hT).2 = optimal ∧ w (T.simplex w obj hT).1 = tt ∧
    find_pivot_column (T.simplex w obj hT).1 obj = none) ∨
  ((T.simplex w obj hT).2 = unbounded ∧ w (T.simplex w obj hT).1 = tt ∧
    ∃ c, c ∈ find_pivot_column (T.simplex w obj hT).1 obj ∧
    find_pivot_row (T.simplex w obj hT).1 obj c = none)
| T := λ hT,
  begin
    cases hw : w T,
    { rw simplex, simp [hw] },
    { cases hc : find_pivot_column T obj with c,
      { rw simplex, simp [hc, hw, simplex._match_1] },
      { cases hr : find_pivot_row T obj c with r,
        { rw simplex, simp [hr, hc, hw, simplex._match_1, simplex._match_2] },
        { rw [← simplex_pivot hT hw hc hr],
          exact have wf : rel obj (T.pivot r c) T, from rel.pivot hT hc hr,
            simplex_spec_aux _ _ } } }
  end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, rel_wf m n obj⟩],
  dec_tac := tactic.assumption}

lemma simplex_while_eq_ff {w : tableau m n → bool} {T : tableau m n} {hT : feasible T}
  {obj : fin m} (hw : w T = ff) : T.simplex w obj hT = (T, while) :=
by rw [simplex, hw]; refl

lemma simplex_find_pivot_column_eq_none {w : tableau m n → bool} {T : tableau m n} {hT : feasible T}
  (hw : w T = tt) {obj : fin m} (hc : find_pivot_column T obj = none) :
  T.simplex w obj hT = (T, optimal) :=
by rw simplex; simp [hc, hw, simplex._match_1]

lemma simplex_find_pivot_row_eq_none {w : tableau m n → bool} {T : tableau m n} {hT : feasible T}
  {obj : fin m} (hw : w T = tt) {c} (hc : c ∈ find_pivot_column T obj)
  (hr : find_pivot_row T obj c = none) : T.simplex w obj hT = (T, unbounded) :=
by rw simplex; simp [hw, show _ = _, from hc, hr, simplex._match_1, simplex._match_2]

lemma simplex_induction (P : tableau m n → Prop) (w : tableau m n → bool) (obj : fin m):
  Π {T : tableau m n} (hT : feasible T)  (h0 : P T)
  (hpivot : ∀ {T' r c}, w T' = tt → c ∈ find_pivot_column T' obj → r ∈ find_pivot_row T' obj c
    → feasible T' → P T' → P (T'.pivot r c)),
  P (T.simplex w obj hT).1
| T := λ hT h0 hpivot,
  begin
    cases hw : w T,
    { rwa [simplex_while_eq_ff hw] },
    { cases hc : find_pivot_column T obj with c,
      { rwa [simplex_find_pivot_column_eq_none hw hc] },
      { cases hr : find_pivot_row T obj c with r,
        { rwa simplex_find_pivot_row_eq_none hw hc hr },
        { rw [← simplex_pivot _ hw hc hr],
          exact have wf : rel obj (pivot T r c) T, from rel.pivot hT hc hr,
            simplex_induction (feasible_of_mem_pivot_row_and_column hT hc hr)
              (hpivot hw hc hr hT h0) @hpivot } } }
  end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, rel_wf m n obj⟩],
  dec_tac := `[tauto]}

@[simp] lemma feasible_simplex {w : tableau m n → bool} {T : tableau m n}
  {hT : feasible T} {obj : fin m} : feasible (T.simplex w obj hT).1 :=
simplex_induction feasible _ _ hT hT
  (λ _ _ _ _ hc hr _ hT', feasible_of_mem_pivot_row_and_column hT' hc hr)

@[simp] lemma simplex_simplex {w : tableau m n → bool} {T : tableau m n} {hT : feasible T}
  {obj : fin m} : (T.simplex w obj hT).1.simplex w obj feasible_simplex = T.simplex w obj hT :=
simplex_induction (λ T', ∀ (hT' : feasible T'), T'.simplex w obj hT' = T.simplex w obj hT) w _ _
  (λ _, rfl) (λ T' r c hw hc hr hT' ih hpivot, by rw [simplex_pivot hT' hw hc hr, ih]) _

/-- `simplex` does not move the row variable it is trying to maximise. -/
@[simp] lemma rowg_simplex (T : tableau m n) (hT : feasible T) (w : tableau m n → bool)
  (obj : fin m) : (T.simplex w obj hT).1.to_partition.rowg obj = T.to_partition.rowg obj :=
simplex_induction (λ T', T'.to_partition.rowg obj = T.to_partition.rowg obj) _ _ _ rfl
  (λ T' r c hw hc hr, by simp [rowg_swap_of_ne _ (find_pivot_row_spec hr).1])

@[simp] lemma flat_simplex (T : tableau m n) (hT : feasible T) (w : tableau m n → bool)
  (obj : fin m) : (T.simplex w obj hT).1.flat = T.flat :=
simplex_induction (λ T', T'.flat = T.flat) w obj _ rfl
  (λ T' r c hw hc hr hT' ih,
    have T'.to_matrix r c ≠ 0,
      from λ h, by simpa [h, lt_irrefl] using find_pivot_row_spec hr,
    by rw [flat_pivot this, ih])

@[simp] lemma restricted_simplex (T : tableau m n) (hT : feasible T) (w : tableau m n → bool)
  (obj : fin m) : (T.simplex w obj hT).1.restricted = T.restricted :=
simplex_induction (λ T', T'.restricted = T.restricted) _ _ _ rfl (by simp { contextual := tt })

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

@[simp] lemma of_col_simplex_zero_mem_sol_set {w : tableau m n → bool} {T : tableau m n}
  {hT : feasible T} {obj : fin m} : (T.simplex w obj hT).1.of_col 0 ∈ sol_set T :=
by rw [← sol_set_simplex, of_col_zero_mem_sol_set_iff]; exact feasible_simplex

@[simp] lemma of_col_simplex_rowg {w : tableau m n → bool} {T : tableau m n}
  {hT : feasible T} {obj : fin m} (x : cvec n) :
  (T.simplex w obj hT).1.of_col x (T.to_partition.rowg obj) =
  ((T.simplex w obj hT).1.to_matrix ⬝ x + (T.simplex w obj hT).1.const) obj :=
by rw [← of_col_rowg (T.simplex w obj hT).1 x obj, rowg_simplex]

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

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

lemma termination_eq_while_iff {T : tableau m n} {hT : feasible T} {w : tableau m n → bool}
  {obj : fin m} : (T.simplex w obj hT).2 = while ↔ w (T.simplex w obj hT).1 = ff :=
by have := simplex_spec_aux w obj T hT; finish

lemma termination_eq_optimal_iff_find_pivot_column_eq_none {T : tableau m n}
  {hT : feasible T} {w : tableau m n → bool} {obj : fin m} : (T.simplex w obj hT).2 = optimal ↔
  w (T.simplex w obj hT).1 = tt ∧ find_pivot_column (T.simplex w obj hT).1 obj = none :=
by have := simplex_spec_aux w obj T hT; finish

lemma termination_eq_unbounded_iff_find_pivot_row_eq_none {T : tableau m n} {hT : feasible T}
  {w : tableau m n → bool} {obj : fin m} : (T.simplex w obj hT).2 = unbounded ↔
  w (T.simplex w obj hT).1 = tt ∧ ∃ c, c ∈ find_pivot_column (T.simplex w obj hT).1 obj ∧
  find_pivot_row (T.simplex w obj hT).1 obj c = none :=
by have := simplex_spec_aux w obj T hT; finish

lemma termination_eq_unbounded_iff_aux {T : tableau m n} {hT : feasible T}
  {w : tableau m n → bool} {obj : fin m} : (T.simplex w obj hT).2 = unbounded →
  w (T.simplex w obj hT).1 = tt ∧
  is_unbounded_above T (T.to_partition.rowg obj) :=
begin
  rw termination_eq_unbounded_iff_find_pivot_row_eq_none,
  rintros ⟨_, c, hc⟩,
  simpa * using find_pivot_row_eq_none feasible_simplex hc.2 hc.1
end

lemma termination_eq_optimal_iff {T : tableau m n} {hT : feasible T}
  {w : tableau m n → bool} {obj : fin m} : (T.simplex w obj hT).2 = optimal ↔
  w (T.simplex w obj hT).1 = tt ∧
  is_optimal T ((T.simplex w obj hT).1.of_col 0) (T.to_partition.rowg obj) :=
begin
  rw [termination_eq_optimal_iff_find_pivot_column_eq_none],
  split,
  { rintros ⟨_, hc⟩,
    simpa * using find_pivot_column_eq_none feasible_simplex hc },
  { cases ht : (T.simplex w obj hT).2,
    { simp [*, termination_eq_while_iff] at * },
    { cases termination_eq_unbounded_iff_aux ht,
      simp [*, not_optimal_of_unbounded_above right] },
    { simp [*, termination_eq_optimal_iff_find_pivot_column_eq_none] at * } }
end

lemma termination_eq_unbounded_iff {T : tableau m n} {hT : feasible T}
  {w : tableau m n → bool} {obj : fin m} : (T.simplex w obj hT).2 = unbounded ↔
  w (T.simplex w obj hT).1 = tt ∧ is_unbounded_above T (T.to_partition.rowg obj) :=
⟨termination_eq_unbounded_iff_aux,
  begin
    have := @not_optimal_of_unbounded_above m n (T.simplex w obj hT).1 (T.to_partition.rowg obj)
      ((T.simplex w obj hT).1.of_col 0),
    cases ht : (T.simplex w obj hT).2;
    simp [termination_eq_optimal_iff, termination_eq_while_iff, *] at *
  end⟩

end tableau