/-
Copyright (c) 2022 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.AuxLemmas
import LeanColls.Array
import LeanColls.View
import LeanColls.Classes
import LeanColls.FoldableOps

namespace LeanColls

structure HashMap (κ τ : Type) [Hashable κ] [DecidableEq κ] where
  cap : Nat
  h_cap : 0 < cap ∧ cap < UInt64.size
  backing : COWArray (AList κ τ) cap
  size : Cached (
    View.view backing
    |>.map AList.size
    |> FoldableOps.sum)

namespace HashMap
variable {κ τ : Type} [Hashable κ] [DecidableEq κ]

opaque finishHash (x : UInt64) : UInt64 :=
  let x := x ^^^ (x >>> 30)
  let x := x * 0xbf58476d1ce4e5b9
  let x := x ^^^ (x >>> 27)
  let x := x * 0x94d049bb133111eb
  let x := x ^^^ (x >>> 31)
  x

structure Hashed (κ) [Hashable κ] where
  k : κ
  hashk : Cached (finishHash (hash k))

@[inline]
def mkHashed [Hashable κ] (k : κ) : Hashed κ where
  k := k
  hashk := Cached.cached _

def new (cap : Nat := 16) (h_cap : 0 < cap ∧ cap < UInt64.size := by decide) : HashMap κ τ :=
  ⟨cap, h_cap, COWArray.new [] cap, cached' 0 (by
    clear h_cap
    simp [View.map, View.view, FoldableOps.sum,
      FoldableOps.defaultImpl, Foldable.fold, Foldable'.Correct.fold']
    simp [Size.size, COWArray.new, Indexed.nth, COWArray.get, Array.new, Array.get]
    generalize Range.foldl'' _ _ _ _ = res
    match res with
    | ⟨_,A,hA⟩ =>
    clear res
    simp
    conv =>
      rhs
      arg 2
      intro acc i h
      rw [hA]
      simp
    clear hA A
    induction cap
    case zero => simp
    case succ n ih _ =>
    simp
    apply ih
    simp)⟩

instance : Inhabited (HashMap κ τ) := ⟨HashMap.new⟩

@[inline] private
def calc_idx' (k : κ) (cap : Nat) (h_cap : cap > 0) (h : cap < UInt64.size) : Fin cap :=
  let idx := (hash k) % (UInt64.ofNat cap)
  ⟨idx.toNat, by
    simp [UInt64.mod_def, Fin.mod_def]
    apply Nat.mod_lt_of_lt
    rw [UInt64.val_eq_of_lt h]
    apply Nat.mod_lt
    assumption
    exact UInt64.size_positive
    ⟩

@[inline]
def calc_idx (k : κ) (m : HashMap κ τ) : Fin m.cap :=
  match m with
  | ⟨cap, h_cap, _, _⟩ =>
  calc_idx' k cap h_cap.1 h_cap.2

/- TODO: add Array.getU64 -/
def get? (k : κ) (m : HashMap κ τ) : Option τ :=
  m.backing.get (calc_idx k m)
  |> MapLike.get?.{0,0,0,0} k

@[inline]
private def updateNoRebalance (k : κ) (t : Option τ) (m : HashMap κ τ) : Option τ × HashMap κ τ :=
  let idx := calc_idx k m
  match h : m.backing.get idx |> AList.getAndUpdate k t with
  | (old, newSlot) =>
  let newSize :=
    (if t.isSome then 1 else 0) +
    match old with | none => m.size | some _ => m.size - 1
  ⟨old, m.cap, m.h_cap, m.backing.set idx newSlot, newSize,
  by
    have : newSize = _ + match old, h with | none, h => _ | some _, h => _ := rfl
    rw [this]
    clear this newSize
    have := AList.size_update k t (COWArray.get m.backing idx)
    simp at h
    rw [h.1, h.2] at this
    match old with
    | none =>
      simp at this ⊢
      conv => lhs; rw [View.view_eq_view_canonicalToList]
      conv => rhs; rw [View.view_eq_view_canonicalToList]
      simp
      simp [List.map_set]
      rw [List.sum_set]
      case h_i =>
        simp [idx.isLt]
      simp
      rw [this]
      have := List.get_map_reverse AList.size
        (l := Array.toList m.backing.backing)
        (n := ⟨calc_idx k m, by simp [idx.isLt]⟩)
      rw [this]
      rw [←Nat.sub_add_comm (by apply List.get_le_sum)]
      conv =>
        rhs; arg 1; arg 2
        rw [Nat.add_comm]
      rw [←Nat.add_assoc]
      simp [COWArray.get, ←Array.toList_get]
      rw [Nat.add_comm]
    | some _ =>
      simp at this ⊢
      conv => lhs; rw [View.view_eq_view_canonicalToList]
      conv => rhs; rw [View.view_eq_view_canonicalToList]
      simp
      simp [List.map_set]
      rw [List.sum_set]
      case h_i =>
        simp [idx.isLt]
      simp; stop
      rw [this]
      have := List.get_map_reverse AList.size
        (l := Array.toList m.backing.backing)
        (n := ⟨calc_idx k m, by simp [idx.isLt]⟩)
      rw [this]
      rw [←Nat.sub_add_comm (by apply List.get_le_sum)]
      simp [COWArray.get, ←Array.toList_get]
    ⟩

def rebalance : HashMap κ τ → HashMap κ τ
| ⟨cap, h_cap, backing, size⟩ =>
  if size >= cap then
    new (cap := min (2 * cap) (UInt64.size - 1)) (by
      constructor
      case left =>
        simp [min]
        split
        case inl =>
          rw [(by simp : 0 = 0 * 0)]
          apply Nat.mul_lt_mul'
          decide
          exact h_cap.1
          decide
        case inr =>
          simp
      case right =>
        simp [min]
        split
        case inl h =>
          exact Nat.succ_le_succ h
        case inr h =>
          simp)
    |> Foldable.fold backing (fun acc L =>
      L.foldl (fun acc (k,t) => (acc.updateNoRebalance k (some t)).2) acc)
  else
    ⟨cap, h_cap, backing, size⟩

def set' (k : κ) (t : τ) (m : HashMap κ τ) : Option τ × HashMap κ τ :=
  let (o, h) := m.updateNoRebalance k (some t)
  (o, rebalance h)

def set (k : κ) (t : τ) (m : HashMap κ τ) : HashMap κ τ :=
  rebalance (m.updateNoRebalance k (some t)).2

def fold (m : HashMap κ τ) (f : β → (κ × τ) → β) (acc : β) :=
  Foldable.fold m.backing (fun acc l =>
    Foldable.fold l f acc
  ) acc

instance : Membership κ (HashMap κ τ) where
  mem k m := get? k m |>.isSome

instance : MapLike (HashMap κ τ) κ τ where
  get? := get?
  fold := fold

instance : FoldableOps (HashMap κ τ) (κ × τ) := default

theorem get_rebalance (k : κ) (m : HashMap κ τ)
  : m.rebalance.get? k = m.get? k
  := by
  simp [rebalance]
  split <;> simp
  simp [get?]
  sorry

theorem get_set_eq [Hashable κ] (k : κ) (t : τ) (m : HashMap κ τ)
  : (m.set k t |>.get? k) = some t
  := by
  simp [set, get_rebalance]
  simp [get?, updateNoRebalance, calc_idx, calc_idx']
  simp [COWArray.get, COWArray.set]
  simp [MapLike.get?]

theorem get_set_ne [Hashable κ]
  (k : κ) (t : τ) (k' : κ) (m : HashMap κ τ)
  (h_k : k ≠ k')
  : (m.set k t |>.get? k') = m.get? k'
  := by
  simp [set, get_rebalance]
  simp [get?, updateNoRebalance]
  simp [COWArray.get, COWArray.set]
  simp [calc_idx]
  generalize calc_idx' k _ _ _ = k_idx
  generalize calc_idx' k' _ _ _ = k'_idx
  match h : decide (k_idx = k'_idx) with
  | true =>
    simp at h
    simp [h]
    simp [MapLike.get?, h_k.symm]
  | false =>
    have : k_idx ≠ k'_idx := by
      intro h; cases h; simp at h
    simp [this, Array.copy_def]


import .fv .lc

local attribute [simp] not_or_distrib and_assoc

namespace tts ------------------------------------------------------------------
namespace typ ------------------------------------------------------------------
variables {V : Type} [_root_.decidable_eq V] -- Type of variable names
variables {x y : tagged V} -- Variables
variables {xs : list (tagged V)} -- List of variables
variables {t tx t₁ t₂ : typ V} -- Types
variables {ts txs ts₂ : list (typ V)} -- Lists of types

open list occurs

/- subst -/

/-- Substitute a free variable for a type in a type -/
def subst (x : tagged V) (tx : typ V) : typ V → typ V
| (var bound y)  := var bound y
| (var free y)   := if x = y then tx else var free y
| (arr t₁ t₂)    := arr (subst t₁) (subst t₂)

@[simp] theorem subst_var_bound : subst x tx (var bound y) = var bound y :=
rfl

@[simp] theorem subst_var_free_eq (h : x = y) : subst x tx (var free y) = tx :=
by simp [subst, h]

@[simp] theorem subst_var_free_ne (h : x ≠ y) : subst x tx (var free y) = var free y :=
by simp [subst, h]

@[simp] theorem subst_arr : subst x tx (arr t₁ t₂) = arr (subst x tx t₁) (subst x tx t₂) :=
rfl

-- Substitution with a fresh name is the identity
@[simp] theorem subst_fresh (h : x ∉ fv t) : subst x tx t = t :=
by induction t with o; try {cases o}; try {simp at h}; try {cases h}; simp *

-- Mapping substitution over a list with a fresh name is the identity
@[simp] theorem subst_fresh_list (h : x ∉ fv_list ts) : map (subst x t) ts = ts :=
by induction ts; try {simp at h}; try {cases h}; simp *

@[simp] theorem subst_fresh_var_free (h : x ∉ xs) :
  map (subst x tx) (map (var free) xs) = map (var free) xs :=
begin
  apply subst_fresh_list,
  induction xs with _ _ ih; simp,
  exact ⟨ne_of_not_mem_cons h, ih (not_mem_of_not_mem_cons h)⟩
end

/- subst_list -/

/-- Substitute a list of free variables for a list of types in a type -/
def subst_list : list (tagged V) → list (typ V) → typ V → typ V
| (x :: xs) (tx :: txs) t := subst_list xs txs (subst x tx t)
| _         _           t := t

@[simp] theorem subst_list_nil_left : subst_list [] txs t = t :=
rfl

@[simp] theorem subst_list_nil_right : subst_list xs [] t = t :=
by cases xs; refl

@[simp] theorem subst_list_cons_cons :
  subst_list (x :: xs) (tx :: txs) t = subst_list xs txs (subst x tx t) :=
rfl

@[simp] theorem subst_list_fresh (F : ∀ x ∈ xs, x ∉ fv t) : subst_list xs txs t = t :=
begin
  induction xs generalizing txs t,
  case list.nil { simp },
  case list.cons : _ _ ih { simp at F, cases txs; [simp, {simp [F.1, ih F.2]}] }
end

private theorem nth_of_map {α} {a} {f : α → α} (p : f a = a) :
  ∀ {l n}, option.get_or_else ((nth l n).map f) a = f (option.get_or_else (nth l n) a)
| []       n     := by simp [option.get_or_else, p]
| (hd::tl) 0     := by simp [option.get_or_else]
| (hd::tl) (n+1) := by simp [option.get_or_else, nth_of_map]

-- Substitution distributes over open
theorem subst_open_typs (lx : lc tx) :
  subst x tx (open_typs ts t) = open_typs (map (subst x tx) ts) (subst x tx t) :=
begin
  induction t,
  case typ.var : o y {
    cases o,
    case occurs.bound { simp [nth_of_map] },
    case occurs.free  { by_cases x = y; simp * } },
  case typ.arr { simp * }
end

-- Substitution and open_vars for distinct names commute
theorem subst_open_vars (h : x ∉ xs) (lx : lc tx) :
  open_vars xs (subst x tx t) = subst x tx (open_vars xs t) :=
by simp [open_vars, h, subst_open_typs lx]

theorem subst_list_intro_aux
  (ts : list (typ V))
  (d : xs.nodup)
  (ln_eq : xs.length = txs.length)
  (F : ∀ x ∈ xs, x ∉ fv t ∪ fv_list txs ∪ fv_list ts)
  (ltxs : ∀ t ∈ txs, lc t)
  (l₂ : ∀ t ∈ ts, lc t) :
  open_typs (ts ++ txs) t = subst_list xs txs (open_typs (ts ++ map (var free) xs) t) :=
begin
  induction xs generalizing txs ts d,
  case list.nil {
    have : txs = [] := length_eq_zero.mp (by simp at ln_eq; simp [ln_eq]),
    simp [this] },
  case list.cons : hd tl ih {
    cases txs; simp at ln_eq,
    case list.nil { cases ln_eq },
    case list.cons : hdxs tlxs {
      simp at ltxs,
      have lhdxs : lc hdxs := ltxs.1,
      have ltlxs : ∀ t ∈ tlxs, lc t := ltxs.2,
      simp at F,
      have hdFt    : hd ∉ fv t := F.1,
      have hdFhdxs : hd ∉ fv hdxs := F.2.1,
      have hdFts   : hd ∉ fv_list ts := F.2.2.1,
      have tlF     : ∀ x ∈ tl, x ∉ fv t ∪ fv_list tlxs ∪ fv_list (ts ++ [hdxs]) :=
        λ x h, let H := F.2.2.2.2 x h in by simp [H.1, H.2.1, H.2.2.1, H.2.2.2],
      have lts_hdxs : ∀ t ∈ ts ++ [hdxs], lc t :=
        λ t h, by simp at h; cases h; simp [h, l₂ t, lhdxs],
      simp at d,
      have ih : open_typs (ts ++ [hdxs] ++ tlxs) t =
      subst_list tl tlxs (open_typs (ts ++ [hdxs] ++ map (var free) tl) t) :=
        ih _ d.2 ln_eq tlF ltlxs lts_hdxs,
      have append_cons_mid : ∀ {α} {a : α} {l₁ l₂ : list α}, l₁ ++ a :: l₂ = l₁ ++ [a] ++ l₂,
        by intros; simp,
      rw [append_cons_mid, ih, ←append_cons_mid],
      simp [ih, subst_open_typs lhdxs, subst_fresh hdFt, subst_fresh_list hdFts, subst_fresh_var_free d.1] } }
end

-- Opening up a type `t` with `ts` is the same as opening up `t` with fresh
-- names `xs` and then substituting `xs` for `ts`.
theorem subst_list_intro
  (d : xs.nodup)
  (ln_eq : xs.length = ts.length)
  (F : ∀ x ∈ xs, x ∉ fv t ∪ fv_list ts)
  (l : ∀ t ∈ ts, lc t) :
  open_typs ts t = subst_list xs ts (open_vars xs t) :=
subst_list_intro_aux [] d ln_eq (λ x, by simpa using F x) l (by simp)

-- A type substituted with another type is locally-closed if all type arguments
-- are locally-closed.
theorem subst_lc (lx : lc tx) (l : lc t) : lc (subst x tx t) :=
begin
  induction l,
  case lc.var : y { by_cases h : x = y; simp [h, lx] },
  case lc.arr { simp * }
end

-- A type substituted with a list of types is locally-closed if all type
-- arguments are locally-closed.
theorem subst_list_lc
  (ln_eq : xs.length = txs.length)
  (ltxs : ∀ tx ∈ txs, lc tx)
  (lt : lc t) :
  lc (subst_list xs txs t) :=
begin
  induction xs generalizing txs t,
  case list.nil { simp [lt] },
  case list.cons : _ _ ih {
    cases txs,
    case list.nil { simp [lt] },
    case list.cons {
      simp at ln_eq,
      simp at ltxs,
      simp [ih ln_eq ltxs.2 (subst_lc ltxs.1 lt)] } }
end

-- Mapping substitution over a list of types is locally-closed if all type
-- arguments are locally-closed.
theorem map_subst_lc (lt : lc t) (lts : ∀ t ∈ ts, lc t) :
  ∀ t ∈ map (subst x t) ts, lc t :=
begin
  induction ts,
  case list.nil { simp },
  case list.cons : _ _ ih {
    simp at lts,
    exact forall_mem_cons.mpr ⟨subst_lc lt lts.1, ih lts.2⟩ }
end

end /- namespace -/ typ --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


example (x y : ℕ) (p : ℕ → Prop) (q : Prop) (h : q → x = y) (h' : p y) (hq : q) : p x :=
  by { rw (h hq), assumption }


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  split,
  assume h1 : two_colorable G,
  have h2 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
    have h3 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
      have h4 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
        have h5 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
          have h6 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
            have h7 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
              have h8 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                have h9 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                  have h10 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                    have h11 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                      have h12 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                        have h13 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                          have h14 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                            have h15 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                              have h16 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                have h17 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                  have h18 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                    have h19 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                      have h20 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                        have h21 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                          have h22 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                            have h23 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                              have h24 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                                have h25 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                                  have h26 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                                    have h27 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                                      have h28 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                                        have h29 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a,b) ∈ E G), from by {
                                                          have h30 : ∃ (A B : set G), (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem two_colorable_iff_bipartite {G : Type*} [fintype G] [decidable_eq G] [fintype (G × G)] [decidable_eq (G × G)] [fintype (G × G × G)] [decidable_eq (G × G × G)] [fintype (G × G × G × G)] [decidable_eq (G × G × G × G)] [fintype (G × G × G × G × G)] [decidable_eq (G × G × G × G × G)] [fintype (G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [decidable_eq (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G)] [fintype (G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G × G ×
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem bipartite_iff_two_colorable {G : Type*} [graph G] : bipartite G ↔ two_colorable G :=
begin
  split,
  assume h1 : bipartite G,
  have h2 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h1,
  have h3 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h2,
  have h4 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h3,
  have h5 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h4,
  have h6 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h5,
  have h7 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h6,
  have h8 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h7,
  have h9 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h8,
  have h10 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h9,
  have h11 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h10,
  have h12 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h11,
  have h13 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h12,
  have h14 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h13,
  have h15 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h14,
  have h16 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h15,
  have h17 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h16,
  have h18 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h17,
  have h19 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h18,
  have h20 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h19,
  have h21 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h20,
  have h22 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h21,
  have h23 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h22,
  have h24 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h23,
  have h25 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h24,
  have h26 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h25,
  have h27 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h26,
  have h28 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2 = ∅ ∧ ∀ e : G, e ∈ edges G → e.1 ∈ V1 ∧ e.2 ∈ V2, from h27,
  have h29 : ∃ V1 V2 : set G, V1 ∪ V2 = univ ∧ V1 ∩ V2
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


import parlang.defs
import mcl.defs

open parlang
open parlang.state
open parlang.thread_state
open mcl

def compute_list {σ ι : Type} {τ : ι → Type} [decidable_eq ι] : list (σ → σ) → (thread_state σ τ → thread_state σ τ)
| (f :: tl) := compute_list tl ∘ @compute σ ι τ _ f
| [] := id

lemma compute_to_compute_list {σ ι : Type} {τ : ι → Type} [decidable_eq ι] (f : σ → σ) : @compute σ ι τ _ f = compute_list [f] := by refl

lemma compute_list_merge {σ ι : Type} {τ : ι → Type} [decidable_eq ι] (f g : list (σ → σ)) :
(@compute_list σ ι τ _ g) ∘ compute_list f = compute_list (f ++ g) := begin
    induction f,
    case list.nil {
        simp [compute_list],
    }, {
        simp [compute_list],
        rw ← f_ih,
    }
end

lemma compute_list_accesses {sig : signature} {n} (s : state n (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)) (i) (computes) (tid) :
i ∉ (compute_list computes (vector.nth (s.threads) tid)).accesses ↔ i ∉ (vector.nth (s.threads) tid).accesses := sorry

-- todo: rewrite to s = { tlocal := ... s.tlocal, ..s }
lemma compute_list_tlocal {sig : signature} {computes : list (memory (parlang_mcl_tlocal sig) → memory (parlang_mcl_tlocal sig))} {tlocal loads stores} {shared : memory $ parlang_mcl_shared sig} :
compute_list computes {tlocal := tlocal, shared := shared, loads := loads, stores := stores} =
{tlocal := computes.foldl (λ tl com, com tl) tlocal, shared := shared, loads := loads, stores := stores} := begin
    induction computes generalizing tlocal,
    {
        refl,
    }, {
        simp [compute_list, compute, computes_ih],
    }
end

@[simp]
lemma compute_list_stores_core {sig : signature} {computes}
{ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} :
(compute_list computes ts).stores = ts.stores := begin
    induction computes generalizing ts,
    { simp [compute_list], },
    { cases ts, simp [compute_list, compute], rw computes_ih, },
end

@[simp]
lemma compute_list_loads_core {sig : signature} {computes}
{ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} :
(compute_list computes ts).loads = ts.loads := begin
    induction computes generalizing ts,
    { simp [compute_list], },
    { cases ts, simp [compute_list, compute], rw computes_ih, },
end

@[simp]
lemma compute_list_shared {sig : signature} {computes}
{ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} :
(compute_list computes ts).shared = ts.shared := begin
    induction computes generalizing ts,
    { simp [compute_list], },
    { cases ts, simp [compute_list, compute], rw computes_ih, },
end

lemma compute_list_stores {sig : signature} {computes}
{ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} {i : mcl_address sig} :
i ∉ ts.stores ↔ i ∉ (compute_list computes ts).stores := by simp

lemma compute_list_loads {sig : signature} {computes}
{ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} {i : mcl_address sig} :
i ∉ ts.loads ↔ i ∉ (compute_list computes ts).loads := by simp


import time_bound

namespace pfun

variables {α β : Type*} (f : α →. β)

def to_fun (hf : f.dom = set.univ) : α → β := λ x, (f x).get (by { change x ∈ f.dom, rw hf, trivial, })

@[simp] lemma coe_to_fun (hf : f.dom = set.univ) : (f.to_fun hf : α →. β) = f :=
by { ext, simp [to_fun], }

end pfun


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

/-!
# More `char` instances

This file provides a `linear_order` instance on `char`. `char` is the type of Unicode scalar values.
-/

instance : linear_order char :=
{ le_refl := λ a, @le_refl ℕ _ _,
  le_trans := λ a b c, @le_trans ℕ _ _ _ _,
  le_antisymm := λ a b h₁ h₂,
    char.eq_of_veq $ le_antisymm h₁ h₂,
  le_total := λ a b, @le_total ℕ _ _ _,
  lt_iff_le_not_le := λ a b, @lt_iff_le_not_le ℕ _ _ _,
  decidable_le := char.decidable_le,
  decidable_eq := char.decidable_eq,
  decidable_lt := char.decidable_lt,
  ..char.has_le, ..char.has_lt }

lemma char.of_nat_to_nat {c : char} (h : is_valid_char c.to_nat) :
  char.of_nat c.to_nat = c :=
begin
  rw [char.of_nat, dif_pos h],
  cases c,
  simp [char.to_nat]
end


import .core

namespace tts ------------------------------------------------------------------
namespace exp ------------------------------------------------------------------
variables {V : Type} [decidable_eq V] -- Type of variable names
variables {k k₂ k₃ : ℕ} -- Natural numbers
variables {v : V} -- Variable names
variables {x : tagged V} -- Variables
variables {e ea eb ed ef e₁ e₂ e₃ : exp V} -- Expressions

open occurs

/-- Open an expression (last parameter) with an expression (e) for a bound
variable. -/
def open_exp (e : exp V) : ℕ → exp V → exp V
| k (var bound x)  := if k = x.tag then e else var bound x
| _ (var free x)   := var free x
| k (app ef ea)    := app (open_exp k ef) (open_exp k ea)
| k (lam v eb)     := lam v (open_exp k.succ eb)
| k (let_ v ed eb) := let_ v (open_exp k ed) (open_exp k.succ eb)

@[simp] theorem open_exp_var_bound_eq (h : k = x.tag) :
  open_exp e k (var bound x) = e :=
by simp [open_exp, h]

@[simp] theorem open_exp_var_bound_ne (h : k ≠ x.tag) :
  open_exp e k (var bound x) = var bound x :=
by simp [open_exp, h]

@[simp] theorem open_exp_var_free :
  open_exp e k (var free x) = var free x :=
rfl

@[simp] theorem open_exp_app :
  open_exp e k (app ef ea) = app (open_exp e k ef) (open_exp e k ea) :=
rfl

@[simp] theorem open_exp_lam :
  open_exp e k (lam v eb) = lam v (open_exp e k.succ eb) :=
rfl

@[simp] theorem open_exp_let_ :
  open_exp e k (let_ v ed eb) = let_ v (open_exp e k ed) (open_exp e k.succ eb) :=
rfl

/-- Open an expression with an expression `e` for the last bound variable (0) -/
def open_exp₀ (e : exp V) : exp V → exp V :=
open_exp e 0

/-- Open an expression with a free variable `x` for the last bound variable -/
def open_var (x : tagged V) : exp V → exp V :=
open_exp₀ (var free x)

/-- Open an expression with a variable of the name `v` fresh from the variable
set `L` for the last bound variable. -/
def open_fresh (v : V) (L : finset (tagged V)) : exp V → exp V :=
open_var $ (fresh.tagged v).gen L

end /- namespace -/ exp --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import Aesop

set_option aesop.check.all true

example (h : α) : α := by
  fail_if_success
    aesop (rule_sets [-builtin,-default])
          (add safe h (apply (index := [target False])))
          (options := { terminal := true })
  aesop (rule_sets [-builtin,-default]) (add safe h apply)

-- See Com test for a more realistic scenario.


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Stephen Morgan, Scott Morrison

import category_theory.products
import category_theory.types

namespace category_theory

universes u₁ v₁ u₂ v₂

def op (C : Type u₁) : Type u₁ := C

notation C `ᵒᵖ` := op C

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

instance opposite : category.{u₁ v₁} (Cᵒᵖ) :=
{ hom     := λ X Y : C, Y ⟶ X,
  comp    := λ _ _ _ f g, g ≫ f,
  id      := λ X, 𝟙 X }

namespace functor

section
variables {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒟

protected definition op (F : C ⥤ D) : (Cᵒᵖ) ⥤ (Dᵒᵖ) :=
{ obj       := λ X, F X,
  map'      := λ X Y f, F.map f,
  map_id'   := begin /- `obviously'` says: -/ intros, erw [map_id], refl, end,
  map_comp' := begin /- `obviously'` says: -/ intros, erw [map_comp], refl end }

@[simp] lemma opposite_obj (F : C ⥤ D) (X : C) : (F.op) X = F X := rfl
@[simp] lemma opposite_map (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) : (F.op).map f = F.map f := rfl
end

variable (C)

/-- `functor.hom` is the hom-pairing, sending (X,Y) to X → Y, contravariant in X and covariant in Y. -/
definition hom : (Cᵒᵖ × C) ⥤ (Type v₁) :=
{ obj       := λ p, @category.hom C _ p.1 p.2,
  map'      := λ X Y f, λ h, f.1 ≫ h ≫ f.2,
  map_id'   := begin /- `obviously'` says: -/ intros, ext, intros, cases X, dsimp at *, simp, erw [category.id_comp] end,
  map_comp' := begin /- `obviously'` says: -/ intros, ext, intros, cases f, cases g, cases X, cases Y, cases Z, dsimp at *, simp, erw [category.assoc] end }

@[simp] lemma hom_obj (X : Cᵒᵖ × C) : (functor.hom C) X = @category.hom C _ X.1 X.2 := rfl
@[simp] lemma hom_pairing_map {X Y : Cᵒᵖ × C} (f : X ⟶ Y) : (functor.hom C).map f = λ h, f.1 ≫ h ≫ f.2 := rfl

end functor

end category_theory


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Stephen Morgan, Scott Morrison

import category_theory.products
import category_theory.types

namespace category_theory

universes v₁ v₂ u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

/-- The type of objects of the opposite of C (which should be a category).

  In order to avoid confusion between C and its opposite category, we
  set up the type of objects `opposite C` using the following pattern,
  which will be repeated later for the morphisms.

  1. Define `opposite C := C`.
  2. Define the isomorphisms `op : C → opposite C`, `unop : opposite C → C`.
  3. Make the definition `opposite` irreducible.

  This has the following consequences.

  * `opposite C` and `C` are distinct types in the elaborator, so you
    must use `op` and `unop` explicitly to convert between them.
  * Both `unop (op X) = X` and `op (unop X) = X` are definitional
    equalities. Notably, every object of the opposite category is
    definitionally of the form `op X`, which greatly simplifies the
    definition of the structure of the opposite category, for example.

  (If Lean supported definitional eta equality for records, we could
  achieve the same goals using a structure with one field.)
-/
def opposite (C : Type u₁) : Type u₁ := C

-- Use a high right binding power (like that of postfix ⁻¹) so that, for example,
-- `presheaf Cᵒᵖ` parses as `presheaf (Cᵒᵖ)` and not `(presheaf C)ᵒᵖ`.
notation C `ᵒᵖ`:std.prec.max_plus := opposite C

variables {C : Type u₁}

def op (X : C) : Cᵒᵖ := X
def unop (X : Cᵒᵖ) : C := X

attribute [irreducible] opposite

@[simp] lemma unop_op (X : C) : unop (op X) = X := rfl
@[simp] lemma op_unop (X : Cᵒᵖ) : op (unop X) = X := rfl

lemma op_inj : function.injective (@op C) :=
by { rintros _ _ ⟨ ⟩, refl }
lemma unop_inj : function.injective (@unop C) :=
by { rintros _ _ ⟨ ⟩, refl }

section has_hom

variables [𝒞 : has_hom.{v₁} C]
include 𝒞

/-- The hom types of the opposite of a category (or graph).

  As with the objects, we'll make this irreducible below.
  Use `f.op` and `f.unop` to convert between morphisms of C
  and morphisms of Cᵒᵖ.
-/
instance has_hom.opposite : has_hom Cᵒᵖ :=
{ hom := λ X Y, unop Y ⟶ unop X }

def has_hom.hom.op {X Y : C} (f : X ⟶ Y) : op Y ⟶ op X := f
def has_hom.hom.unop {X Y : Cᵒᵖ} (f : X ⟶ Y) : unop Y ⟶ unop X := f

attribute [irreducible] has_hom.opposite

lemma has_hom.hom.op_inj {X Y : C} :
  function.injective (has_hom.hom.op : (X ⟶ Y) → (op Y ⟶ op X)) :=
λ _ _ H, congr_arg has_hom.hom.unop H

lemma has_hom.hom.unop_inj {X Y : Cᵒᵖ} :
  function.injective (has_hom.hom.unop : (X ⟶ Y) → (unop Y ⟶ unop X)) :=
λ _ _ H, congr_arg has_hom.hom.op H

@[simp] lemma has_hom.hom.unop_op {X Y : C} {f : X ⟶ Y} : f.op.unop = f := rfl
@[simp] lemma has_hom.hom.op_unop {X Y : Cᵒᵖ} {f : X ⟶ Y} : f.unop.op = f := rfl

end has_hom

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

instance category.opposite : category.{v₁} Cᵒᵖ :=
{ comp := λ _ _ _ f g, (g.unop ≫ f.unop).op,
  id   := λ X, (𝟙 (unop X)).op }

@[simp] lemma op_comp {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).op = g.op ≫ f.op := rfl
@[simp] lemma op_id {X : C} : (𝟙 X).op = 𝟙 (op X) := rfl

@[simp] lemma unop_comp {X Y Z : Cᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).unop = g.unop ≫ f.unop := rfl
@[simp] lemma unop_id {X : Cᵒᵖ} : (𝟙 X).unop = 𝟙 (unop X) := rfl

def op_op : (Cᵒᵖ)ᵒᵖ ⥤ C :=
{ obj := λ X, unop (unop X),
  map := λ X Y f, f.unop.unop }

-- TODO this is an equivalence

namespace functor

section

variables {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒟

variables {C D}

protected definition op (F : C ⥤ D) : Cᵒᵖ ⥤ Dᵒᵖ :=
{ obj := λ X, op (F.obj (unop X)),
  map := λ X Y f, (F.map f.unop).op }

@[simp] lemma op_obj (F : C ⥤ D) (X : Cᵒᵖ) : (F.op).obj X = op (F.obj (unop X)) := rfl
@[simp] lemma op_map (F : C ⥤ D) {X Y : Cᵒᵖ} (f : X ⟶ Y) : (F.op).map f = (F.map f.unop).op := rfl

protected definition unop (F : Cᵒᵖ ⥤ Dᵒᵖ) : C ⥤ D :=
{ obj := λ X, unop (F.obj (op X)),
  map := λ X Y f, (F.map f.op).unop }

@[simp] lemma unop_obj (F : Cᵒᵖ ⥤ Dᵒᵖ) (X : C) : (F.unop).obj X = unop (F.obj (op X)) := rfl
@[simp] lemma unop_map (F : Cᵒᵖ ⥤ Dᵒᵖ) {X Y : C} (f : X ⟶ Y) : (F.unop).map f = (F.map f.op).unop := rfl

variables (C D)

definition op_hom : (C ⥤ D)ᵒᵖ ⥤ (Cᵒᵖ ⥤ Dᵒᵖ) :=
{ obj := λ F, (unop F).op,
  map := λ F G α,
  { app := λ X, (α.unop.app (unop X)).op,
    naturality' := λ X Y f, has_hom.hom.unop_inj $ eq.symm (α.unop.naturality f.unop) } }

@[simp] lemma op_hom.obj (F : (C ⥤ D)ᵒᵖ) : (op_hom C D).obj F = (unop F).op := rfl
@[simp] lemma op_hom.map_app {F G : (C ⥤ D)ᵒᵖ} (α : F ⟶ G) (X : Cᵒᵖ) :
  ((op_hom C D).map α).app X = (α.unop.app (unop X)).op := rfl

definition op_inv : (Cᵒᵖ ⥤ Dᵒᵖ) ⥤ (C ⥤ D)ᵒᵖ :=
{ obj := λ F, op F.unop,
  map := λ F G α, has_hom.hom.op
  { app := λ X, (α.app (op X)).unop,
    naturality' := λ X Y f, has_hom.hom.op_inj $ eq.symm (α.naturality f.op) } }

@[simp] lemma op_inv.obj (F : Cᵒᵖ ⥤ Dᵒᵖ) : (op_inv C D).obj F = op F.unop := rfl
@[simp] lemma op_inv.map_app {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F ⟶ G) (X : C) :
  (((op_inv C D).map α).unop).app X = (α.app (op X)).unop := rfl

-- TODO show these form an equivalence

instance {F : C ⥤ D} [full F] : full F.op :=
{ preimage := λ X Y f, (F.preimage f.unop).op }

instance {F : C ⥤ D} [faithful F] : faithful F.op :=
{ injectivity' := λ X Y f g h,
    has_hom.hom.unop_inj $ by simpa using injectivity F (has_hom.hom.op_inj h) }

end

section

variable (C)

/-- `functor.hom` is the hom-pairing, sending (X,Y) to X → Y, contravariant in X and covariant in Y. -/
definition hom : Cᵒᵖ × C ⥤ Type v₁ :=
{ obj       := λ p, unop p.1 ⟶ p.2,
  map       := λ X Y f, λ h, f.1.unop ≫ h ≫ f.2 }

@[simp] lemma hom_obj (X : Cᵒᵖ × C) : (functor.hom C).obj X = (unop X.1 ⟶ X.2) := rfl
@[simp] lemma hom_pairing_map {X Y : Cᵒᵖ × C} (f : X ⟶ Y) :
  (functor.hom C).map f = λ h, f.1.unop ≫ h ≫ f.2 := rfl

end

end functor

omit 𝒞

instance opposite.has_one [has_one C] : has_one (Cᵒᵖ) :=
{ one := op 1 }

instance opposite.has_mul [has_mul C] : has_mul (Cᵒᵖ) :=
{ mul := λ x y, op $ unop y * unop  x }

@[simp] lemma opposite.unop_one [has_one C] : unop (1 : Cᵒᵖ) = (1 : C) := rfl

@[simp] lemma opposite.unop_mul [has_mul C] (xs ys : Cᵒᵖ) : unop (xs * ys) = (unop ys * unop xs : C) := rfl

@[simp] lemma opposite.op_one [has_one C] : op (1 : C) = 1 := rfl

@[simp] lemma opposite.op_mul [has_mul C] (xs ys : C) : op (xs * ys) = (op ys * op xs) := rfl

instance opposite.monoid [monoid C] : monoid (Cᵒᵖ) :=
{ one := op 1,
  mul := λ x y, op $ unop y * unop  x,
  mul_one := by { intros, apply unop_inj, simp },
  one_mul := by { intros, simp },
  mul_assoc := by { intros, simp [mul_assoc], } }

end category_theory


example (P Q : Type) : P → (Q → P) :=
begin
intro p,
intro q,
exact p,
end


import category_theory.triangulated.pretriangulated

namespace category_theory

variables (C : Type*) [category C] [has_shift C ℤ]

namespace pretriangulated

namespace triangle

@[simps]
def eval₁ : triangle C ⥤ C :=
{ obj := λ T, T.obj₁,
  map := λ T T' φ, φ.hom₁, }

@[simps]
def eval₂ : triangle C ⥤ C :=
{ obj := λ T, T.obj₂,
  map := λ T T' φ, φ.hom₂, }
@[simps]

def eval₃ : triangle C ⥤ C :=
{ obj := λ T, T.obj₃,
  map := λ T T' φ, φ.hom₃, }

variable {C}

instance is_iso_hom₁ {T T' : triangle C} (φ : T ⟶ T') [is_iso φ] : is_iso φ.hom₁ :=
by { change is_iso ((eval₁ C).map φ), apply_instance, }

instance is_iso_hom₂ {T T' : triangle C} (φ : T ⟶ T') [is_iso φ] : is_iso φ.hom₂ :=
by { change is_iso ((eval₂ C).map φ), apply_instance, }

instance is_iso_hom₃ {T T' : triangle C} (φ : T ⟶ T') [is_iso φ] : is_iso φ.hom₃ :=
by { change is_iso ((eval₃ C).map φ), apply_instance, }

end triangle

end pretriangulated

namespace iso

open pretriangulated

variable {C}

@[simps]
def triangle_eval₁ {T T' : triangle C} (e : T ≅ T') : T.obj₁ ≅ T'.obj₁ :=
(triangle.eval₁ C).map_iso e

@[simps]
def triangle_eval₂ {T T' : triangle C} (e : T ≅ T') : T.obj₂ ≅ T'.obj₂ :=
(triangle.eval₂ C).map_iso e

@[simps]
def triangle_eval₃ {T T' : triangle C} (e : T ≅ T') : T.obj₃ ≅ T'.obj₃ :=
(triangle.eval₃ C).map_iso e

@[simp, reassoc]
lemma triangle_hom_inv_id₁ {T T' : triangle C} (e : T ≅ T') : e.hom.hom₁ ≫ e.inv.hom₁ = 𝟙 _ :=
e.triangle_eval₁.hom_inv_id

@[simp, reassoc]
lemma triangle_hom_inv_id₂ {T T' : triangle C} (e : T ≅ T') : e.hom.hom₂ ≫ e.inv.hom₂ = 𝟙 _ :=
e.triangle_eval₂.hom_inv_id

@[simp, reassoc]
lemma triangle_hom_inv_id₃ {T T' : triangle C} (e : T ≅ T') : e.hom.hom₃ ≫ e.inv.hom₃ = 𝟙 _ :=
e.triangle_eval₃.hom_inv_id

@[simp, reassoc]
lemma triangle_inv_hom_id₁ {T T' : triangle C} (e : T ≅ T') : e.inv.hom₁ ≫ e.hom.hom₁ = 𝟙 _ :=
e.triangle_eval₁.inv_hom_id

@[simp, reassoc]
lemma triangle_inv_hom_id₂ {T T' : triangle C} (e : T ≅ T') : e.inv.hom₂ ≫ e.hom.hom₂ = 𝟙 _ :=
e.triangle_eval₂.inv_hom_id

@[simp, reassoc]
lemma triangle_inv_hom_id₃ {T T' : triangle C} (e : T ≅ T') : e.inv.hom₃ ≫ e.hom.hom₃ = 𝟙 _ :=
e.triangle_eval₃.inv_hom_id

end iso

end category_theory


/-
trace.lean
Author: Mario Carneiro

This file defines a coinductive datatype for "traces", which are possible
program behaviors including I/O. Because Lean does not yet support coinductive
datatypes, we have to define this one manually (one would like to define
`trace := gfp trace1` and skip all the lemmas).

A trace is coinductively defined by `trace1 α := roption (η ⊕ (Σ i:ι, o i → α))`.
Here `η` is the type of possible final states (including stuck states and
error states if applicable), `ι` is the type of I/O inputs (possible functions
to call and arguments to pass), and `o i` is the type of I/O return values
(dependent on the input). The trace is really a tree because the I/O output is
nondeterministic; the program behavior describes what will happen for any
return value. The `roption` handles program divergence; if the program does
not terminate then no trace will be produced.
-/
import util.basic

namespace vc0
section
variables (η : Type) {ι : Type} (o : ι → Type)

def trace1 (α : Type) : Type := roption (η ⊕ (Σ i, o i → α))

variables {η o}
def trace1.out {α} (t : trace1 η o α) : roption (Σ i, o i → α) :=
t.bind $ λ x, match x with
| (sum.inl _) := roption.none
| (sum.inr x) := roption.some x
end

theorem trace1.mem_out {α} (t : trace1 η o α) {x} : x ∈ t.out ↔
  (sum.inr x : η ⊕ (Σ i, o i → α)) ∈ (by exact t : roption _) :=
roption.mem_bind_iff.trans
⟨by rintro ⟨_|x, ⟨h, e⟩, ⟨⟩, rfl⟩; exact ⟨_, e⟩,
  λ h, ⟨sum.inr x, h, trivial, rfl⟩⟩

def trace1.fst {α} (t : trace1 η o α) : roption ι :=
sigma.fst <$> trace1.out t

def trace1.snd {α} (t : trace1 η o α) : ∀ i ∈ t.fst, o i → α :=
roption.mem_cases _ (by exact λ h, ((trace1.out t).get h).2)

theorem trace1.fst_snd_mem {α} (t : trace1 η o α) : ∀ i h,
  (⟨i, trace1.snd t i h⟩ : Σ i, o i → α) ∈ t.out :=
roption.mem_cases _ begin
  change ∀ h : t.out.dom, (⟨(t.out.get h).1, (t.out.get h).2⟩ : Σ i, o i → α) ∈ t.out,
  intro h, rw sigma.eta, apply roption.get_mem
end

theorem trace1.snd_eq {α} (t : trace1 η o α) (i h g)
  (H : (⟨i, g⟩ : Σ i, o i → α) ∈ t.out) : trace1.snd t i h = g :=
by simpa using roption.mem_unique (t.fst_snd_mem i h) H

instance trace1.functor : functor (trace1 η o) :=
{ map := λ α β f, roption.map $ sum.map id $ sigma.map id $ λ i, (∘) f }

instance trace1.is_lawful_functor : is_lawful_functor (trace1 η o) :=
{ id_map := λ α, roption.map_id' $ by rintro (_|⟨i, g⟩); refl,
  comp_map := λ α β γ g h t, begin
    refine eq.trans _ (roption.map_map _ _ _).symm,
    simp [(<$>)], congr, ext ⟨i, g⟩; refl
  end }

def trace1.pmap {α β} (t : trace1 η o α)
  (f : ∀ x:Σ i, o i → α, x ∈ t.out → o x.1 → α → β) : trace1 η o β :=
⟨t.dom, λ h, begin
  cases e : t.get h with a x,
  { exact sum.inl a },
  { exact sum.inr ⟨x.1, λ b, f _ (t.mem_out.2 ⟨h, e⟩) b (x.2 b)⟩ }
end⟩

theorem trace1.pmap_inl {α β} (t : trace1 η o α) (f h)
  {a} (H : t.get h = sum.inl a) :
  (t.pmap f : trace1 η o β).get h = sum.inl a :=
by simp [trace1.pmap, H]

theorem trace1.pmap_inr {α β} (t : trace1 η o α) (f h)
  {x} (H : t.get h = sum.inr x) :
  (t.pmap f : trace1 η o β).get h =
  sum.inr ⟨x.1, λ b, f _ (t.mem_out.2 ⟨h, H⟩) b (x.2 b)⟩ :=
by simp [trace1.pmap, H]

def trace1.out_map {α β} (f : α → β) (t : trace1 η o α) :
  (f <$> t : trace1 η o β).out = (sigma.map id $ λ i, (∘) f) <$> t.out :=
roption.ext $ λ x, by simp [trace1.mem_out, (<$>), sum.map]; refl

theorem trace1.fst_map {α β} (f : α → β) (t : trace1 η o α) :
  (f <$> t : trace1 η o β).fst = t.fst :=
show sigma.fst <$> trace1.out _ = sigma.fst <$> _, begin
  rw [trace1.out_map, ← comp_map],
  congr' 1, ext ⟨a, b⟩, refl
end

theorem trace1.snd_map {α β} (f : α → β) (t : trace1 η o α) (i h h' b) :
  (f <$> t : trace1 η o β).snd i h b = f (t.snd i h' b) :=
begin
  have := (f <$> t).fst_snd_mem i h,
  simp [t.out_map f] at this,
  rcases this with ⟨i, g, h₁, h₂⟩,
  injection h₂ with h₃ h₄, subst h₃, simp at h₄,
  rw [← h₄, ← t.snd_eq _ h' _ h₁]
end

variables (η o)
def traceN : ℕ → Type → Type
| 0     α := α
| (n+1) α := traceN n (trace1 η o α)
variables {η o}

def traceN.map : ∀ (n) {α β}, (α → β) → traceN η o n α → traceN η o n β
| 0     α β f := f
| (n+1) α β f := @traceN.map n _ _ ((<$>) f)

instance traceN.functor (n) : functor (traceN η o n) :=
{ map := @traceN.map _ _ _ n }

instance traceN.is_lawful_functor : ∀ n, is_lawful_functor (traceN η o n)
| 0 := by split; intros; refl
| (n+1) := begin
    split; intros,
    { show (<$>) id <$> x = x,
      rw [(funext (@id_map (trace1 η o) _ _ _) : (<$>) id = id),
        @id_map _ _ (traceN.is_lawful_functor n)] },
    { change ((<$>) (h ∘ g) <$> x : traceN η o n (trace1 η o γ)) =
        (<$>) h <$> (<$>) g <$> x,
      rw [(funext (@comp_map (trace1 η o) _ _ _ _ _ _ _) :
          (<$>) (h ∘ g) = (<$>) h ∘ (<$>) g),
        @comp_map _ _ (traceN.is_lawful_functor n)] },
  end

def trace1.forall₂ {α β} (R : α → β → Prop) : trace1 η o α → trace1 η o β → Prop :=
roption.forall₂ $ sum.forall₂ eq $ sigma.forall₂ $ λ i f g, ∀ x, R (f x) (g x)

def traceN.forall₂ : ∀ {n α β}, (α → β → Prop) → traceN η o n α → traceN η o n β → Prop
| 0     α β R := R
| (n+1) α β R := @traceN.forall₂ n _ _ (trace1.forall₂ R)

def traceN.fst : ∀ {n α}, traceN η o (n+1) α → roption ι
| 0     α t := trace1.fst t
| (n+1) α t := @traceN.fst n _ t

def traceN.out : ∀ {n α}, traceN η o (n+1) α → roption (Σ i, o i → traceN η o n α)
| 0     α := trace1.out
| (n+1) α := @traceN.out n _

def traceN.snd : ∀ {n α} (t : traceN η o (n+1) α) (i ∈ t.fst), o i → traceN η o n α
| 0     α t := trace1.snd t
| (n+1) α t := @traceN.snd n _ t

theorem traceN.fst_map : ∀ n {α β} (f : α → β) (t : traceN η o (n+1) α),
  (f <$> t : traceN η o (n+1) β).fst = t.fst
| 0     α β f := trace1.fst_map _
| (n+1) α β f := traceN.fst_map n _

theorem traceN.snd_map : ∀ n {α β} (f : α → β) (t : traceN η o (n+1) α) (i h h' b),
  (f <$> t : traceN η o (n+1) β).snd i h b = f <$> t.snd i h' b
| 0     α β f := trace1.snd_map _
| (n+1) α β f := traceN.snd_map n _

theorem traceN.snd_map' (n) {α β} (f : α → β) (t : traceN η o (n+1) α) (i h b) :
  (f <$> t : traceN η o (n+1) β).snd i h b = f <$> t.snd i (by rwa t.fst_map _ _ at h) b :=
traceN.snd_map _ _ _ _ _ _ _

theorem traceN.out_map : ∀ n {α β} (f : α → β) (t : traceN η o n (trace1 η o α)),
  (f <$> t : traceN η o (n+1) β).out =
  (sigma.map id $ by exact λ i g x, f <$> g x) <$> t.out
| 0     α β f t := trace1.out_map _ _
| (n+1) α β f t := traceN.out_map n _ _

variables (η o)
def trace : Type := -- gfp trace1
{f : ∀ n, traceN η o n unit // ∀ n, f n = (λ _, ()) <$> f (n+1) }
variables {η o}

theorem trace_fst_aux (f : ∀ n, traceN η o n unit)
  (H : ∀ n, f n = (λ _, ()) <$> f (n+1)) :
  ∀ n, (f (n+1)).fst = (f 1).fst
| 0 := rfl
| (n+1) := by rw [← trace_fst_aux n, H (n+1), traceN.fst_map]; refl

theorem trace_map_aux (f : ∀ n, traceN η o n unit)
  (H : ∀ n, f n = (λ _, ()) <$> f (n+1)) :
  ∀ n, sigma.fst <$> (f (n+1)).out = sigma.fst <$> (f 1).out
| 0 := rfl
| (n+1) := begin
  rw [← trace_map_aux n, H (n+1), traceN.out_map, ← comp_map],
  congr, ext ⟨i, b⟩, refl
end

def trace.destruct : trace η o → trace1 η o (trace η o)
| ⟨f, H⟩ := trace1.pmap (f 1) (λ x i b _, begin
  have hx : ∀ n, x.1 ∈ traceN.fst (f (n + 1)),
  { intro n, rwa trace_fst_aux _ H n, exact roption.mem_map _ i },
  have := λ n, traceN.out (f (n+1)),
  refine ⟨λ n, traceN.snd (f (n+1)) _ (hx n) b, λ n, _⟩,
  refine eq.trans _ ((f (n+1+1)).snd_map' n (λ _, ()) _ _ b),
  { rw traceN.fst_map, exact hx (n+1) },
  { congr, apply H }
end)

def traceN.iter {α} (F : α → trace1 η o α) (a : α) : ∀ n, traceN η o n α
| 0     := a
| (n+1) := (F <$> traceN.iter n : traceN η o n (trace1 η o α))

theorem traceN.iter_fst {α} (F : α → trace1 η o α) (a : α) :
  ∀ n, (traceN.iter F a (n+1)).fst = (F a).fst
| 0     := rfl
| (n+1) := (traceN.fst_map _ _ _).trans (traceN.iter_fst n)

theorem traceN.iter_snd' {α} (F : α → trace1 η o α) (a : α) : ∀ n i h b,
  (traceN.iter F a (n+1)).snd i h b =
  traceN.iter F ((F a).snd i (by rwa traceN.iter_fst at h) b) n
| 0     i h b := rfl
| (n+1) i h b := (traceN.snd_map' _ _ _ i h b).trans (congr_arg _ (traceN.iter_snd' n _ _ _))

theorem traceN.iter_snd {α} (F : α → trace1 η o α) (a : α) (n i h h' b) :
  (traceN.iter F a (n+1)).snd i h b = traceN.iter F ((F a).snd i h' b) n :=
traceN.iter_snd' _ _ _ _ _ _

def trace.corec {α} (F : α → trace1 η o α) (a : α) : trace η o :=
⟨λ n, (λ _, ()) <$> traceN.iter F a n, λ n,
  by rw traceN.iter; exact
  eq.trans (by refl) ((comp_map _ _ _).trans (comp_map _ _ _))⟩

theorem trace.corec_eq {α} (F : α → trace1 η o α) (a : α) :
  trace.destruct (trace.corec F a) = trace.corec F <$> F a :=
roption.ext' iff.rfl $ λ h₁ h₂, begin
  change (F a).dom at h₁,
  change h₂ with h₁, clear h₂,
  change (trace1.pmap _ _).get _ = sum.map _ _ _,
  have e : ((λ _, ()) <$> traceN.iter F a 1).get h₁ =
    sum.map id (sigma.map id (λ _ _ _, ())) ((F a).get h₁) := rfl,
  cases e' : (F a).get h₁; rw e' at e,
  { rw trace1.pmap_inl _ _ _ e, refl },
  { rw trace1.pmap_inr _ _ _ e, cases val with i g,
    simp! [sigma.map], ext b,
    simp [trace.corec], ext n,
    suffices : ∀ h, traceN.snd ((λ _, ()) <$> traceN.iter F a (n+1))
      i h b = (λ _, ()) <$> traceN.iter F (g b) n, {apply this},
    intro,
    rw traceN.fst_map at h,
    rw [traceN.snd_map _ _ _ _ _ h, traceN.iter_snd', trace1.snd_eq],
    exact (trace1.mem_out _).2 ⟨_, e'⟩ },
end

/-
theorem trace.eq_of_bisim (R : trace η o → trace η o → Prop)
  (H : ∀ t₁ t₂, R t₁ t₂ → trace1.forall₂ R t₁.destruct t₂.destruct) :
  ∀ t₁ t₂, R t₁ t₂ → t₁ = t₂ :=
sorry
-/

end

end vc0


import .tableau order.lexicographic

open matrix fintype finset function pequiv partition
variables {m n : ℕ}
variables {X : ℕ → ℕ → Type} [is_tableau X]

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 is_tableau

def to_lex (T : X m n) (c : fin n) (r' : fin m) : lex ℚ (fin (m + n)) :=
(abs ((const T) r' 0 / (to_matrix T) r' c), (to_partition T).rowg r')

lemma to_lex_le_iff (T : X m n) (c : fin n) (i i' : fin m) :
  to_lex T c i ≤ to_lex T c i' ↔
  abs ((const T) i 0 / (to_matrix T) i c) < abs ((const T) i' 0 / (to_matrix T) i' c) ∨
    (abs ((const T) i 0 / (to_matrix T) i c) = abs ((const T) i' 0 / (to_matrix T) i' c) ∧
    (to_partition T).rowg i ≤ (to_partition T).rowg i') :=
prod.lex_def _ _

lemma pivot_col_spec {T : X m n} {obj : fin m} {c : fin n} :
  c ∈ pivot_col T obj → (((to_matrix T) obj c ≠ 0 ∧ (to_partition T).colg c ∉ (restricted T))
  ∨ (0 < (to_matrix T) obj c ∧ (to_partition T).colg c ∈ (restricted T))) ∧ c ∉ (dead T) :=
by simp only [to_matrix, const, to_partition, restricted, feasible, to_tableau_pivot,
  to_tableau_pivot_col] at *; exact tableau.pivot_col_spec

lemma nonpos_of_lt_pivot_col {T : X m n} {obj : fin m} {c j : fin n}
  (hc : c ∈ pivot_col T obj) (hcres : (to_partition T).colg c ∈ (restricted T))
  (hdead : j ∉ (dead T)) (hjc : (to_partition T).colg j < (to_partition T).colg c) :
  (to_matrix T) obj j ≤ 0 :=
by simp only [to_matrix, const, to_partition, restricted, feasible, to_tableau_pivot,
  to_tableau_pivot_col] at *; exact tableau.nonpos_of_lt_pivot_col hc hcres hdead hjc

lemma pivot_col_eq_none_aux {T : X m n} {obj : fin m} (hT : (feasible T)) {c : fin n} :
  pivot_col T obj = none → c ∉ (dead T) →
  (((to_matrix T) obj c = 0 ∧ (to_partition T).colg c ∉ (restricted T))
    ∨ ((to_matrix T) obj c ≤ 0 ∧ (to_partition T).colg c ∈ (restricted T))) :=
by simp only [to_matrix, const, to_partition, restricted, feasible, to_tableau_pivot,
  to_tableau_pivot_col] at *; exact tableau.pivot_col_eq_none_aux hT

lemma pivot_col_eq_none {T : X m n} {obj : fin m} (hT : (feasible T))
  (h : pivot_col T obj = none) : (is_optimal T) ((of_col T) 0) ((to_partition T).rowg obj) :=
is_optimal_of_col_zero hT
(λ j hj, begin
  have := pivot_col_eq_none_aux hT h hj,
  finish [lt_irrefl]
end)

lemma pivot_row_spec {T : X m n} {obj r : fin m} {c : fin n} :
  r ∈ pivot_row T obj c →
  obj ≠ r ∧ (to_partition T).rowg r ∈ (restricted T) ∧
  (to_matrix T) obj c / (to_matrix T) r c < 0 ∧
  (∀ r' : fin m, obj ≠ r' → (to_partition T).rowg r' ∈ (restricted T) →
    (to_matrix T) obj c / (to_matrix T) r' c < 0 →
  abs ((const T) r 0 / (to_matrix T) r c) ≤ abs ((const T) r' 0 / (to_matrix T) r' c)) :=
by simp only [to_matrix, const, to_partition, restricted, feasible, to_tableau_pivot,
  to_tableau_pivot_col, to_tableau_pivot_row] at *; exact tableau.pivot_row_spec

lemma nonneg_of_lt_pivot_row {T : X m n} {obj : fin m} {r i : fin m} {c : fin n}
  (hc0 : 0 < (to_matrix T) obj c) (hres : (to_partition T).rowg i ∈ (restricted T))
  (hc : c ∈ pivot_col T obj) (hr : r ∈ pivot_row T obj c)
  (hconst : (const T) i 0 = 0)
  (hjc : (to_partition T).rowg i < (to_partition T).rowg r) :
  0 ≤ (to_matrix T) i c :=
by simp only [to_matrix, const, to_partition, restricted, feasible, to_tableau_pivot,
    to_tableau_pivot_col, to_tableau_pivot_row] at *;
  exact tableau.nonneg_of_lt_pivot_row hc0 hres hc hr hconst hjc

lemma ne_zero_of_mem_pivot_row {T : X m n} {obj r : fin m} {c : fin n}
  (hr : r ∈ pivot_row T obj c) : (to_matrix T) r c ≠ 0 :=
assume hrc, by simpa [lt_irrefl, hrc] using pivot_row_spec hr

lemma ne_zero_of_mem_pivot_col {T : X m n} {obj : fin m} {c : fin n}
  (hc : c ∈ pivot_col T obj) : (to_matrix T) obj c ≠ 0 :=
λ h, by simpa [h, lt_irrefl] using pivot_col_spec hc

lemma pivot_row_eq_none_aux {T : X m n} {obj : fin m} {c : fin n}
  (hrow : pivot_row T obj c = none) (hs : c ∈ pivot_col T obj) :
  ∀ r, obj ≠ r → (to_partition T).rowg r ∈ (restricted T) → 0 ≤ (to_matrix T) obj c / (to_matrix T) r c :=
by simp only [to_matrix, const, to_partition, restricted, feasible, to_tableau_pivot,
    to_tableau_pivot_col, to_tableau_pivot_row] at *;
  exact tableau.pivot_row_eq_none_aux hrow hs

lemma pivot_row_eq_none {T : X m n} {obj : fin m} {c : fin n} (hT : (feasible T))
  (hrow : pivot_row T obj c = none) (hs : c ∈ pivot_col T obj) :
  (is_unbounded_above T) ((to_partition T).rowg obj) :=
have hrow : ∀ r, obj ≠ r → (to_partition T).rowg r ∈ (restricted T) →
    0 ≤ (to_matrix T) obj c / (to_matrix T) r c,
  from pivot_row_eq_none_aux hrow hs,
have hc : (((to_matrix T) obj c ≠ 0 ∧ (to_partition T).colg c ∉ (restricted T))
    ∨ (0 < (to_matrix T) obj c ∧ (to_partition T).colg c ∈ (restricted T))) ∧ c ∉ (dead T),
  from pivot_col_spec hs,
have hToc : (to_matrix T) obj c ≠ 0, from λ h, by simpa [h, lt_irrefl] using hc,
(lt_or_gt_of_ne hToc).elim
  (λ hToc : (to_matrix T) obj c < 0, is_unbounded_above_rowg_of_nonpos hT c
    (hc.1.elim and.right (λ h, (not_lt_of_gt hToc h.1).elim)) hc.2
    (λ 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 < (to_matrix T) 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))
    hc.2 hToc)

def feasible_of_mem_pivot_row_and_col {T : X m n} {obj : fin m} (hT : (feasible T)) {c}
  (hc : c ∈ pivot_col T obj) {r} (hr : r ∈ pivot_row T obj c) :
  feasible (pivot T r c) :=
begin
  have := pivot_col_spec hc,
  have := 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)

-- def fickle (T T' : X m n) (v : fin (m + n)) : Prop :=
-- (to_partition T).rowp v ≠ T'.to_partition.rowp v ∨
-- (to_partition T).colp v ≠ T'.to_partition.colp v

-- lemma fickle_symm {T T' : X m n} {v : fin (m + n)} :
--   fickle T T' v ↔ fickle T' T v :=
-- by simp [fickle, eq_comm]

-- lemma fickle_colg_iff_ne {T T' : X m n} {j : fin n} :
--   fickle T T' ((to_partition T).colg j) ↔
--   (to_partition T).colg j ≠ T'.to_partition.colg j :=
-- ⟨λ h h', h.elim (by rw [rowp_colg_eq_none, h', rowp_colg_eq_none]; simp)
--   (by rw [colp_colg, h', colp_colg]; simp),
-- λ h, or.inr $ λ h', h begin
--   have : T'.to_partition.colp ((to_partition T).colg j) = some j,
--   { simpa [eq_comm] using h' },
--   rwa [← pequiv.eq_some_iff, colp_symm_eq_some_colg, option.some_inj, eq_comm] at this
-- end⟩

-- lemma fickle_rowg_iff_ne {T T' : X m n} {i : fin m} :
--   fickle T T' ((to_partition T).rowg i) ↔
--   (to_partition T).rowg i ≠ T'.to_partition.rowg i :=
-- ⟨λ h h', h.elim (by rw [rowp_rowg, h', rowp_rowg]; simp)
--   (by rw [colp_rowg_eq_none, h', colp_rowg_eq_none]; simp),
-- λ h, or.inl $ λ h', h begin
--   have : T'.to_partition.rowp ((to_partition T).rowg i) = some i,
--   { simpa [eq_comm] using h' },
--   rwa [← pequiv.eq_some_iff, rowp_symm_eq_some_rowg, option.some_inj, eq_comm] at this
-- end⟩

-- lemma not_unique_row_and_unique_col {T T' : X m n} {r c c'}
--   (hcobj0 : 0 < (to_matrix T) obj c)
--   (hc'obj0 : 0 < T'.to_matrix obj c')
--   (hrc0 : (to_matrix T) r c < 0)
--   (hflat : (flat T) = T'.flat)
--   (hs : (to_partition T).rowg r = T'.to_partition.colg c')
--   (hrobj : (to_partition T).rowg obj = T'.to_partition.rowg obj)
--   (hfickle : ∀ i, (fickle T T' ((to_partition T).rowg i)) → (const T) i 0 = 0)
--   (hobj : (const T) obj 0 = T'.const obj 0)
--   (nonpos_of_colg_eq : ∀ j, j ≠ c' →
--     T'.to_partition.colg j = (to_partition T).colg c → T'.to_matrix obj j ≤ 0)
--   (unique_col : ∀ j,
--     (fickle T' T (T'.to_partition.colg j)) → j ≠ c' → T'.to_matrix obj j ≤ 0)
--   (unique_row : ∀ i ≠ r, (const T) i 0 = 0 → fickle T T' ((to_partition T).rowg i) →
--     0 ≤ (to_matrix T) i c) :
--   false :=
-- let objr := (to_partition T).rowg obj in
-- let x := λ y : ℚ, (of_col T) (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 ((to_partition T).rowg i) 0 = (const T) i 0 + y * (to_matrix T) i c,
--   by simp [x, of_col_single_rowg],
-- have hxcol : ∀ {y j}, j ≠ c → x y ((to_partition T).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 ((to_partition T).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 v) 0
--   (T'.to_matrix obj) in
-- have hxobj : ∀ y, x y objr 0 = (const T) obj 0 + y * (to_matrix T) obj c, from λ y, hxrow _ _,
-- have hgetr : ∀ {y v}, c_star v * x y v 0 ≠ 0 → (T'.to_partition.colp v).is_some,
--   from λ y v, by cases h : T'.to_partition.colp v; dsimp [c_star]; rw h; simp,
-- have c_star_eq_get : ∀ {v} (hv : (T'.to_partition.colp 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 ≠ (to_partition T).colg c →
--     ((to_partition T).rowp v).is_some,
--   from λ y v, (eq_rowg_or_colg (to_partition T) v).elim
--     (λ ⟨i, hi⟩, by rw [hi, rowp_rowg]; simp)
--     (λ ⟨j, hj⟩ h0 hvc,
--       by rw [hj, hxcol (mt (congr_arg (to_partition T).colg) (hvc ∘ hj.trans)), mul_zero] at h0;
--         exact (h0 rfl).elim),
-- have hsummmnn : ∀ {y}, (univ.erase ((to_partition T).colg c)).sum (λ v, c_star v * x y v 0) =
--     univ.sum (λ i, c_star ((to_partition T).rowg i) * x y ((to_partition T).rowg i) 0),
--   from λ y, eq.symm $ sum_bij_ne_zero (λ i _ _, (to_partition T).rowg i) (by simp)
--     (λ _ _ _ _ _ _ h, (to_partition T).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 ((to_partition T).rowg i) * x y ((to_partition T).rowg i) 0) =
--     univ.sum (λ i, c_star ((to_partition T).rowg i) * (const T) i 0) +
--     y * univ.sum (λ i, c_star ((to_partition T).rowg i) * (to_matrix T) 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 * (to_matrix T) obj c = c_star ((to_partition T).colg c) * y +
--     univ.sum (λ i, c_star ((to_partition T).rowg i) * (const T) i 0) +
--       y * univ.sum (λ i, c_star ((to_partition T).rowg i) * (to_matrix T) i c),
--   from λ y, by rw [← add_left_inj ((const T) obj 0), ← hxobj, hxobj',
--     ← insert_erase (mem_univ ((to_partition T).colg c)), sum_insert (not_mem_erase _ _),
--     hsummmnn, hobj, hsumm, hxcolc]; simp,
-- have hy' : ∀ (y), y * ((to_matrix T) obj c - c_star ((to_partition T).colg c) -
--     univ.sum (λ i, c_star ((to_partition T).rowg i) * (to_matrix T) i c)) =
--     univ.sum (λ i, c_star ((to_partition T).rowg i) * (const T) i 0),
--   from λ y, by rw [mul_sub, mul_sub, hy]; simp [mul_comm, mul_assoc, mul_left_comm],
-- have h0 : (to_matrix T) obj c - c_star ((to_partition T).colg c) -
--     univ.sum (λ i, c_star ((to_partition T).rowg i) * (to_matrix T) 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 ((to_partition T).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 ((to_partition T).rowg i) = some c' → i = r,
--   from λ i h, by simpa [hs.symm, (to_partition T).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 ((to_partition T).rowg i) * (to_matrix T) 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 ((to_partition T).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 ((to_partition T).rowg i) * (to_matrix T) i c,
--   from imp_of_not_imp_not _ _ (by simpa using @sum_nonpos _ _ (@univ (fin m) _)
--     (λ i, c_star ((to_partition T).rowg i) * (to_matrix T) i c) _ _) sumpos,
-- let ⟨i, hi⟩ := hexi in
-- have hi0 : (const T) i 0 = 0, from hfickle i
--   (fickle_rowg_iff_ne.2 $
--     λ 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 ((to_partition T).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) * (to_matrix T) 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 : (to_matrix T) i c < 0,
--   from neg_of_mul_pos_right hi' (unique_col _
--     (by rw [fickle_colg_iff_ne]; simp) hnec'),
-- not_le_of_gt hic0 (unique_row _ hir hi0
--   (by rw [fickle_rowg_iff_ne, ← colg_get_colp_symm _ _ hi_some]; exact colg_ne_rowg _ _ _))

-- inductive rel : X m n → X m n → Prop
-- | pivot : ∀ {T}, feasible T → ∀ {r c}, c ∈ pivot_col T obj →
--   r ∈ pivot_row T obj c → rel (T.pivot r c) T
-- | trans_pivot : ∀ {T₁ T₂ r c}, rel T₁ T₂ → c ∈ pivot_col T₁ obj →
--   r ∈ pivot_row T₁ obj c → rel (T₁.pivot r c) T₂

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

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

-- /-- Slightly stronger recursor than the default recursor -/
-- @[elab_as_eliminator]
-- lemma rel.rec_on' {obj : fin m} {C : X m n → X m n → Prop} {T T' : X m n}
--   (hrel : rel obj T T')
--   (hpivot : ∀ {T : X m n} {r : fin m} {c : fin n},
--      feasible T → c ∈ pivot_col T obj → r ∈ pivot_row T obj c → C (pivot T r c) T)
--   (hpivot_trans : ∀ {T₁ T₂ : X m n} {r : fin m} {c : fin n},
--     rel obj (T₁.pivot r c) T₁ → rel obj T₁ T₂ →
--      c ∈ pivot_col T₁ obj →
--      r ∈ 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₃ : X 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 (X m n) (rel obj) := ⟨@rel.trans _ _ obj⟩

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

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

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

-- lemma dead_eq_of_rel {T T' : X m n} (h : rel obj T T') : (dead T) = T'.dead :=
-- rel.rec_on' h (λ _ _ _ _ _ _, rfl) (λ _ _ _ _ _ _ _ _, eq.trans)

-- lemma dead_eq_of_rel_or_eq {T T' : X m n} (h : T = T' ∨ rel obj T T') : (dead T) = T'.dead :=
-- h.elim (congr_arg _) $ dead_eq_of_rel _

-- lemma exists_mem_pivot_row_col_of_rel {T T' : X m n} (h : rel obj T' T) :
--   ∃ r c, c ∈ pivot_col T obj ∧ r ∈ 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' : X m n} (h : rel obj T' T) {c : fin n}
--   (hc : c ∈ pivot_col T obj) : ∃ r, r ∈ pivot_row T obj c :=
-- let ⟨r, c', hc', hr⟩ := exists_mem_pivot_row_col_of_rel obj h in ⟨r, by simp * at *⟩

-- lemma exists_mem_pivot_col_of_fickle {T₁ T₂ : X m n} (h : rel obj T₂ T₁) {c : fin n} :
--   fickle T₁ T₂ (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 ∈ pivot_col T₃ obj :=
-- rel.rec_on' h begin
--     assume T r c' hT hc' hr,
--     rw fickle_colg_iff_ne,
--     by_cases hcc : c = c',
--     { subst hcc,
--       exact λ _, ⟨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₁₂,
--     (imp_iff_not_or.1 ih₁₂).elim
--       (λ ih₁₂, (imp_iff_not_or.1 ihp₁).elim
--         (λ ihp₁ hf, (fickle_colg_iff_ne.1 hf (by simp [*, fickle_colg_iff_ne] at *)).elim)
--         (λ ⟨T₃, hT₃⟩ hf, ⟨T₃,
--           hT₃.1.elim (λ h, h.symm ▸ or.inr hrel₁₂) (λ h, or.inr $ h.trans hrel₁₂),
--           hT₃.2.1, hT₃.2.2.1.trans (by simpa [eq_comm, fickle_colg_iff_ne] using ih₁₂), hT₃.2.2.2⟩))
--       (λ ⟨T₃, hT₃⟩ hf, ⟨T₃, hT₃.1, hrelp₁.trans hT₃.2.1, hT₃.2.2⟩))

-- lemma exists_mem_pivot_row_of_fickle {T₁ T₂ : X m n} (h : rel obj T₂ T₁) (r : fin m) :
--   fickle T₁ T₂ (T₁.to_partition.rowg r) →
--   ∃ (T₃ : X m n) c, (T₃ = T₁ ∨ rel obj T₃ T₁) ∧ (rel obj T₂ T₃) ∧
--     T₃.to_partition.rowg r = T₁.to_partition.rowg r ∧
--     c ∈ pivot_col T₃ obj ∧ r ∈ pivot_row T₃ obj c :=
-- rel.rec_on' h
--   begin
--     assume T r' c hT hc hr',
--     rw fickle_rowg_iff_ne,
--     by_cases hrr : r = r',
--     { subst hrr,
--       exact λ _, ⟨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₁₂,
--     (imp_iff_not_or.1 ih₁₂).elim
--       (λ ih₁₂, (imp_iff_not_or.1 ihp₁).elim
--         (λ ihp₁ hf, (fickle_rowg_iff_ne.1 hf (by simp [*, fickle_rowg_iff_ne] at *)).elim)
--         (λ ⟨T₃, c', hT₃⟩ hf, ⟨T₃, c', hT₃.1.elim (λ h, h.symm ▸ or.inr hrel₁₂)
--           (λ h, or.inr $ h.trans hrel₁₂),
--             hT₃.2.1,
--             hT₃.2.2.1.trans (by simpa [eq_comm, fickle_rowg_iff_ne] using ih₁₂),
--             by clear_aux_decl; tauto⟩))
--       (λ ⟨T₃, c', hT₃⟩ _, ⟨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₂ : X m n} (h : rel obj T₁ T₂) : ∀ {r c}
--   (hc : c ∈ pivot_col T₂ obj) (hr : r ∈ 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_col_of_mem_pivot_row {T : X m n} (hrelTT : rel obj T T)
--   {r c} (hc : c ∈ pivot_col T obj) (hr : r ∈ pivot_row T obj c) :
--   ∃ (T' : X m n), c ∈ pivot_col T' obj ∧ T'.to_partition.colg c =
--   (to_partition T).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'⟩ := exists_mem_pivot_col_of_fickle obj hrelTTp $ fickle_colg_iff_ne.2 $
--   (show (T.pivot r c).to_partition.colg c ≠ (to_partition T).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_col_of_fickle_row {T T' : X m n} (hrelTT' : rel obj T T') {r : fin m}
--   (hrelT'T : rel obj T' T) (hrow : fickle T T' ((to_partition T).rowg r)) :
--   ∃ (T₃ : X m n) c, c ∈ pivot_col T₃ obj ∧ T₃.to_partition.colg c =
--   (to_partition T).rowg r ∧ rel obj T₃ T ∧ rel obj T T₃ :=
-- let ⟨T₃, c, hT₃, hrelT₃T, hrow₃, hc, hr⟩ :=
--   exists_mem_pivot_row_of_fickle obj hrelT'T _ hrow in
-- let ⟨T₄, hT₄⟩ := exists_mem_pivot_col_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₂ : X 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' : _ := 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₂ : X 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₂ : X 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 : (const T) r 0 = 0, from const_eq_zero_of_const_obj_eq hfT
--       (ne_zero_of_mem_pivot_col hc) (ne_zero_of_mem_pivot_row hr)
--       (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_fickle_of_rel_self {T T' : X m n} (hrelTT' : rel obj T T')
--   (hrelT'T : rel obj T' T) (i : fin m) (hrow : fickle T T' ((to_partition T).rowg i)) :
--   (const T) i 0 = 0 :=
-- let ⟨T₃, c, hT₃₁, hT'₃, hrow₃, hc, hi⟩ := exists_mem_pivot_row_of_fickle obj hrelT'T _ 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_pivot_col hc)
--   (ne_zero_of_mem_pivot_row hi) (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 = (const T) 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 : X m n} (hrelTT : rel obj T T)
--   {c} (hc : c ∈ pivot_col T obj) : (to_partition T).colg c ∈ (restricted T) :=
-- let ⟨r, hr⟩ := exists_mem_pivot_row_of_rel obj hrelTT hc in
-- let ⟨T', c', hT', hrelTT', hrowcol, _, hr'⟩ := exists_mem_pivot_row_of_fickle obj
--     ((eq_or_rel_pivot_of_rel _ hrelTT hc hr).elim
--       (λ h, show rel obj T (T.pivot r c), from h ▸ hrelTT) id) _
--   (fickle_rowg_iff_ne.2 $
--     show (T.pivot r c).to_partition.rowg r ≠ (to_partition T).rowg r, by simp) in
-- (restricted_eq_of_rel _ hrelTT').symm ▸ by convert (pivot_row_spec hr').2.1; simp [hrowcol]

-- lemma eq_zero_of_not_mem_restricted_of_rel_self {T : X m n} (hrelTT : rel obj T T)
--   {j} (hjres : (to_partition T).colg j ∉ (restricted T)) (hdead : j ∉ (dead T)) : (to_matrix T) obj j = 0 :=
-- let ⟨r, c, hc, hr⟩ := exists_mem_pivot_row_col_of_rel obj hrelTT in
-- have hcres : (to_partition T).colg c ∈ (restricted T),
--   from colg_mem_restricted_of_rel_self obj hrelTT hc,
-- by_contradiction $ λ h0,
-- begin
--   simp [pivot_col] at hc,
--   cases h : fin.find (λ c, (to_matrix T) obj c ≠ 0 ∧ colg ((to_partition T)) c ∉ (restricted T)
--     ∧ c ∉ (dead T)),
--   { 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 : X m n), ¬ rel obj T T :=
-- λ T1 hrelT1,
-- let ⟨rT1 , cT1, hrT1, hcT1⟩ := exists_mem_pivot_row_col_of_rel obj hrelT1 in
-- let ⟨t, ht⟩ := finset.max_of_mem
--   (show T1.to_partition.colg cT1 ∈ univ.filter (λ v, ∃ (T' : X m n) (c : fin n),
--       rel obj T' T' ∧ c ∈ pivot_col 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 : X m n),
--     rel obj T T → ∀ (j : fin n), pivot_col T obj = some j →
--       (to_partition T).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⟩ := exists_mem_pivot_row_of_fickle obj
--   hrelTT''p r (by rw fickle_symm; simp [fickle_colg_iff_ne]) 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 : (to_partition T).colg c ≤ t, from htmax _ T hrelTT _ hc rfl,
-- have hoT'T : T'.const obj 0 = (const T) obj 0, from const_obj_eq_of_rel_of_rel _ hrelT'T hrelTT',
-- have hfickle : ∀ i, fickle T T' ((to_partition T).rowg i) → (const T) i 0 = 0,
--   from const_eq_zero_of_fickle_of_rel_self obj hrelTT' hrelT'T,
-- have hobj : (const T) obj 0 = T'.const obj 0, from const_obj_eq_of_rel_of_rel _ hrelTT' hrelT'T,
-- have hflat : (flat T) = T'.flat, from flat_eq_of_rel obj hrelTT',
-- have hrobj : (to_partition T).rowg obj = T'.to_partition.rowg obj, from rowg_obj_eq_of_rel _ hrelTT',
-- have hs : (to_partition T).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' ▸ (pivot_row_spec hr).2.1,
-- have hc'obj0 : 0 < T'.to_matrix obj c' ∧ c' ∉ T'.dead,
--   by simpa [hc'res] using pivot_col_spec hcT',
-- have hcres : (to_partition T).colg c ∈ (restricted T),
--   from colg_mem_restricted_of_rel_self obj hrelTT hc,
-- have hcobj0 : 0 < to_matrix T obj c ∧ c ∉ (dead T),
--   by simpa [hcres] using pivot_col_spec hc,
-- have hrc0 : (to_matrix T) r c < 0,
--   from inv_neg'.1 $ neg_of_mul_neg_left (pivot_row_spec hr).2.2.1 (le_of_lt hcobj0.1),
-- have nonpos_of_colg_ne : ∀ j, (fickle T' T (T'.to_partition.colg j)) → j ≠ c' →
--     T'.to_matrix obj j ≤ 0,
--   from λ j hj hjc',
--     let ⟨T₃, hT₃⟩ := exists_mem_pivot_col_of_fickle obj hrelTT' hj in
--     nonpos_of_lt_pivot_col hcT' hc'res
--       (dead_eq_of_rel_or_eq obj hT₃.1 ▸ (pivot_col_spec hT₃.2.2.2).2)
--       (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 = (to_partition T).colg c → T'.to_matrix obj j ≤ 0,
--   from λ j hjc' hj,
--     if hjc : j = c
--     then by clear_aux_decl; subst hjc;
--       exact nonpos_of_lt_pivot_col hcT' hc'res
--         (by rw [dead_eq_of_rel obj hrelT'T]; tauto)
--         (lt_of_le_of_ne (hj.symm ▸ hct.symm ▸ hc't) (by simpa))
--     else nonpos_of_colg_ne _ (fickle_colg_iff_ne.2 $ by simpa [hj, eq_comm] using hjc) hjc',
-- have unique_row : ∀ i ≠ r, (const T) i 0 = 0 → fickle T T' ((to_partition T).rowg i) →
--     0 ≤ (to_matrix T) i c,
--   from λ i hir hi0 hrow,
--     let ⟨T₃, c₃, hc₃, hrow₃, hrelT₃T, hrelTT₃⟩ :=
--       exists_mem_pivot_col_of_fickle_row _ hrelTT' hrelT'T hrow in
--     have hrelT₃T₃ : rel obj T₃ T₃, from hrelT₃T.trans hrelTT₃,
--     nonneg_of_lt_pivot_row (by exact hcobj0.1)
--       (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 [fickle_rowg_iff_ne] using hrow)),
-- not_unique_row_and_unique_col obj hcobj0.1 hc'obj0.1 hrc0 hflat hs hrobj hfickle hobj
--   nonpos_of_colg_eq nonpos_of_colg_ne unique_row

-- noncomputable instance fintype_rel (T : X 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 [dead_eq_of_rel _ T₁.2, dead_eq_of_rel _ T₂.2])
--     (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

def rel (obj : fin m) : Π (T₁ T₂ : X m n), Prop :=
inv_image (tableau.rel obj) to_tableau

lemma rel_wf (m n : ℕ) (obj : fin m): well_founded (@rel m n X _ obj) :=
inv_image.wf _ (tableau.rel_wf _ _ _)

lemma rel.pivot {obj : fin m} {T : X m n} : feasible T → ∀ {r : fin m} {c : fin n},
  c ∈ pivot_col T obj → r ∈ pivot_row T obj c → rel obj (pivot T r c) T :=
by simp only [to_matrix, const, to_partition, restricted, feasible, to_tableau_pivot,
    to_tableau_pivot_col, to_tableau_pivot_row, rel, inv_image] at *;
  exact tableau.rel.pivot

inductive termination (n : ℕ) : Type
| while {}              : termination
| unbounded (c : fin n) : termination
| optimal {}            : termination

namespace termination

lemma injective_unbounded : function.injective (@unbounded n) :=
λ _ _ h, by injection h

@[simp] lemma unbounded_inj {c c' : fin n} : unbounded c = unbounded c' ↔ c = c' :=
injective_unbounded.eq_iff

end termination

open termination

instance {n : ℕ} : has_repr $ termination n :=
⟨λ t, termination.cases_on t
  "while"
  (λ c, "unbounded " ++ repr c)
  "optimal"⟩

open termination

/-- The simplex algorithm -/
def simplex (w : X m n → bool) (obj : fin m) : Π (T : X m n) (hT : feasible T),
  X m n × termination n
| T := λ hT, cond (w T)
  (match pivot_col T obj, @feasible_of_mem_pivot_row_and_col _ _ _ _ _ obj hT,
      @rel.pivot m n X _ obj _ hT with
    | none,   hc, hrel := (T, optimal)
    | some c, hc, hrel :=
      match pivot_row T obj c, @hc _ rfl, (λ r, @hrel r c rfl) with
      | none,   hr, hrel := (T, unbounded c)
      | some r, hr, hrel := have wf : rel obj (pivot T r c) T, from hrel _ rfl,
        simplex (pivot T 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 : X m n → bool} {T : X m n} (hT : feasible T)
  (hw : w T = tt) {obj : fin m} {r : fin m} {c : fin n}
  (hc : c ∈ pivot_col T obj) (hr : r ∈ pivot_row T obj c) :
  simplex w obj (pivot T r c) (feasible_of_mem_pivot_row_and_col hT hc hr) =
  simplex w obj T 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 : X m n → bool) (obj : fin m) :
  Π (T : X m n) (hT : feasible T),
  ((simplex w obj T hT).2 = while ∧ w (simplex w obj T hT).1 = ff) ∨
  ((simplex w obj T hT).2 = optimal ∧ w (simplex w obj T hT).1 = tt ∧
    pivot_col (simplex w obj T hT).1 obj = none) ∨
  ∃ c, ((simplex w obj T hT).2 = unbounded c ∧ w (simplex w obj T hT).1 = tt ∧
    c ∈ pivot_col (simplex w obj T hT).1 obj ∧
    pivot_row (simplex w obj T hT).1 obj c = none)
| T := λ hT,
  begin
    cases hw : w T,
    { rw simplex, simp [hw] },
    { cases hc : pivot_col T obj with c,
      { rw simplex, simp [hc, hw, simplex._match_1] },
      { cases hr : 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 (pivot T 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 : X m n → bool} {T : X m n} {hT : feasible T}
  {obj : fin m} (hw : w T = ff) : simplex w obj T hT = (T, while) :=
by rw [simplex, hw]; refl

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

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

lemma simplex_induction (P : X m n → Prop) (w : X m n → bool) (obj : fin m):
  Π {T : X m n} (hT : feasible T)  (h0 : P T)
  (hpivot : ∀ {T' r c}, w T' = tt → c ∈ pivot_col T' obj → r ∈ pivot_row T' obj c
    → feasible T' → P T' → P (pivot T' r c)),
  P (simplex w obj T hT).1
| T := λ hT h0 hpivot,
  begin
    cases hw : w T,
    { rwa [simplex_while_eq_ff hw] },
    { cases hc : pivot_col T obj with c,
      { rwa [simplex_pivot_col_eq_none hw hc] },
      { cases hr : pivot_row T obj c with r,
        { rwa simplex_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_col 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 : X m n → bool} {T : X m n}
  {hT : feasible T} {obj : fin m} : feasible (simplex w obj T hT).1 :=
simplex_induction feasible _ _ hT hT
  (λ _ _ _ _ hc hr _ hT', feasible_of_mem_pivot_row_and_col hT' hc hr)

@[simp] lemma simplex_simplex {w : X m n → bool} {T : X m n} {hT : feasible T}
  {obj : fin m} : simplex w obj (simplex w obj T hT).1 feasible_simplex = simplex w obj T hT :=
simplex_induction (λ T', ∀ (hT' : feasible T'), simplex w obj T' hT' = simplex w obj T 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 : X m n) (hT : feasible T) (w : X m n → bool)
  (obj : fin m) : (to_partition (simplex w obj T hT).1).rowg obj = (to_partition T).rowg obj :=
simplex_induction (λ T', (to_partition T').rowg obj = (to_partition T).rowg obj) _ _ _ rfl
  (λ T' r c hw hc hr, by simp [rowg_swap_of_ne _ (pivot_row_spec hr).1])

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

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

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

@[simp] lemma res_set_simplex (T : X m n) (hT : feasible T) (w : X m n → bool)
  (obj : fin m) : res_set (simplex w obj T hT).1 = res_set T :=
simplex_induction (λ T', (res_set T') = (res_set T)) w obj _ rfl
  (λ T' r c hw hc hr, by simp [res_set_pivot (ne_zero_of_mem_pivot_row hr)] {contextual := tt})

@[simp] lemma dead_set_simplex (T : X m n) (hT : feasible T) (w : X m n → bool)
  (obj : fin m) : dead_set (simplex w obj T hT).1 = dead_set T :=
simplex_induction (λ T', dead_set T' = dead_set T) w obj _ rfl
  (λ T' r c hw hc hr,
    by simp [dead_set_pivot (ne_zero_of_mem_pivot_row hr) (pivot_col_spec hc).2] {contextual := tt})

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

@[simp] lemma of_col_simplex_zero_mem_sol_set {w : X m n → bool} {T : X m n}
  {hT : feasible T} {obj : fin m} : of_col (simplex w obj T hT).1 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 : X m n → bool} {T : X m n}
  {hT : feasible T} {obj : fin m} (x : cvec n) :
  of_col (simplex w obj T hT).1 x ((to_partition T).rowg obj) =
  (to_matrix (simplex w obj T hT).1 ⬝ x + const (simplex w obj T hT).1) obj :=
by rw [← of_col_rowg (simplex w obj T hT).1 x obj, rowg_simplex]

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

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

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

lemma termination_eq_optimal_iff_pivot_col_eq_none {T : X m n}
  {hT : feasible T} {w : X m n → bool} {obj : fin m} : (simplex w obj T hT).2 = optimal ↔
  w (simplex w obj T hT).1 = tt ∧ pivot_col (simplex w obj T hT).1 obj = none :=
by rcases simplex_spec_aux w obj T hT with _ | ⟨_, _, _⟩ | ⟨⟨_, _⟩, _, _, _, _⟩; simp * at *

lemma termination_eq_unbounded_iff_pivot_row_eq_none {T : X m n} {hT : feasible T}
  {w : X m n → bool} {obj : fin m} {c : fin n} :
  (simplex w obj T hT).2 = unbounded c ↔
  w (simplex w obj T hT).1 = tt ∧ c ∈ pivot_col (simplex w obj T hT).1 obj ∧
    pivot_row (simplex w obj T hT).1 obj c = none :=
by split; intros; rcases simplex_spec_aux w obj T hT with
  _ | ⟨_, _, _⟩ | ⟨⟨⟨_, _⟩, _⟩, _, _, _, _⟩; simp * at *

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

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

lemma termination_eq_unbounded_iff {T : X m n} {hT : feasible T}
  {w : X m n → bool} {obj : fin m} {c : fin n}: (simplex w obj T hT).2 = unbounded c ↔
  w (simplex w obj T hT).1 = tt ∧ is_unbounded_above T ((to_partition T).rowg obj)
  ∧ c ∈ pivot_col (simplex w obj T hT).1 obj :=
⟨λ hc, and.assoc.1 $ ⟨unbounded_of_termination_eq_unbounded hc,
  (termination_eq_unbounded_iff_pivot_row_eq_none.1 hc).2.1⟩,
begin
  have := @not_optimal_of_unbounded_above m n _ _ (simplex w obj T hT).1 ((to_partition T).rowg obj)
    (of_col (simplex w obj T hT).1 0),
  cases ht : (simplex w obj T hT).2;
  simp [termination_eq_optimal_iff, termination_eq_while_iff,
    termination_eq_unbounded_iff_pivot_row_eq_none, *] at *
end⟩

end is_tableau