/-
Copyright (c) 2018-2019 Minchao Wu. All rights reserved.
Released under MIT license as described in the file LICENSE.
Author: Minchao Wu
-/

import defs
open nnf tactic

meta def frame_restriction : tactic unit :=
do intro `a >> `[simp]

structure KT (states : Type) extends kripke states :=
(refl : reflexive rel . frame_restriction)

instance inhabited_KT : inhabited (KT ℕ) :=
⟨{ val := λ a b, tt, rel := λ a b, tt }⟩

@[simp] def force {states : Type} (k : KT states) : states → nnf → Prop
| s (var n)    := k.val n s
| s (neg n)    := ¬ k.val n s
| s (and φ ψ)  := force s φ ∧ force s ψ
| s (or φ ψ)   := force s φ ∨ force s ψ
| s (box φ)    := ∀ s', k.rel s s' → force s' φ
| s (dia φ)    := ∃ s', k.rel s s' ∧ force s' φ

def sat {st} (k : KT st) (s) (Γ : list nnf) : Prop :=
∀ φ ∈ Γ, force k s φ

def unsatisfiable (Γ : list nnf) : Prop :=
∀ (st) (k : KT st) s, ¬ sat k s Γ

theorem unsat_singleton {φ} : unsatisfiable [φ] → ∀ (st) (k : KT st) s, ¬ force k s φ
 :=
begin
  intro h, intros, intro hf,
  apply h, intros ψ hψ, rw list.mem_singleton at hψ, rw hψ, exact hf
end

theorem sat_of_empty {st} (k : KT st) (s) : sat k s [] :=
λ φ h, absurd h $ list.not_mem_nil _

theorem ne_empty_of_unsat {Γ} (h : unsatisfiable Γ): Γ ≠ [] :=
begin
  intro heq, rw heq at h,
  apply h, apply sat_of_empty, exact nat,
  apply inhabited_KT.1, exact 0
end

inductive model
| cons : list ℕ → list model → model

instance : decidable_eq model := by tactic.mk_dec_eq_instance

open model

@[simp] def mval : ℕ → model → bool
| p (cons v r) := p ∈ v

@[simp] def mrel : model → model → bool
| m₁@(cons v r) m₂ := m₂ ∈ r ∨ m₁ = m₂

theorem refl_mrel (s : model) : mrel s s := by cases s with v r; simp

theorem mem_of_mrel_tt : Π {v r m}, mrel (cons v r) m = tt → m ∈ r ∨ cons v r = m :=
begin
  intros v r m h, by_cases hc : cons v r = m,
  {right, exact hc},{left, by_contradiction hn,
  have : mrel (cons v r) m = ff, { simp [hc, hn] },
  rw h at this, contradiction}
end

-- TODO : make this neater. Currently it's just a copy-paste
theorem mem_of_mrel_empty : Π {v m}, mrel (cons v []) m = tt → cons v [] = m :=
begin
  intros v m h, by_cases hc : cons v [] = m,
  {exact hc},
  {by_contradiction hn,
  have : mrel (cons v []) m = ff, { simp [hc, hn] },
  rw h at this, contradiction}
end

@[simp] def builder : KT model :=
{val := λ n s, mval n s, rel := λ s₁ s₂, mrel s₁ s₂, refl := refl_mrel}

theorem force_box_of_leaf {v φ} (h : force builder (cons v []) φ):
force builder (cons v []) (box φ) :=
begin
  dsimp, intros s' hs',
  have : cons v [] = s', {apply mem_of_mrel_empty, exact hs'},
  rw ←this, assumption
end

def srefl (m h : list nnf) :=
∀ {v l φ}, sat builder (cons v l) m →
box φ ∈ h →
(∀ ψ, box ψ ∈ h → ∀ m ∈ l, force builder m ψ) →
force builder (cons v l) φ

structure seqt : Type :=
(main : list nnf)
(hdld : list nnf)
-- srefl main hdld says that sequent hdld | main satisfies theorem 3.7(2)
(pmain : srefl main hdld)
-- box_only says there are only boxed formulas in hdld
(phdld : box_only hdld)

class val_constructible (Γ : seqt) :=
(satu : saturated Γ.main)
(no_box_main : ∀ {φ}, box φ ∉ Γ.main)
(no_contra_main : ∀ {n}, var n ∈ Γ.main → neg n ∉ Γ.main)
(v : list ℕ)
(hv : ∀ n, var n ∈ Γ.main ↔ n ∈ v)

class modal_applicable (Γ : seqt) extends val_constructible Γ :=
(φ : nnf)
(ex : dia φ ∈ Γ.main)

class model_constructible (Γ : seqt) extends val_constructible Γ :=
(no_dia : ∀ {φ}, nnf.dia φ ∉ Γ.main)

theorem build_model : Π Γ (h : model_constructible Γ),
sat builder (cons h.v []) Γ.main :=
begin
  intros, intro, intro hmem,
  cases heq : φ,
  case nnf.var : n {dsimp, have := h.hv, rw heq at hmem, rw this at hmem, simp [hmem]},
  case nnf.neg : n {dsimp, have h₁ := h.hv, rw heq at hmem, have := h.no_contra_main, simp, rw ←h₁, intro hvar, apply this, swap, exact hmem, exact hvar},
  case nnf.box : ψ {dsimp, intros, have := h.no_box_main, exfalso, rw heq at hmem, exact this hmem},
  case nnf.and : φ ψ { rw heq at hmem, have := h.satu.no_and, have := @this φ ψ, contradiction},
  case nnf.or : φ ψ { rw heq at hmem, have := h.satu.no_or, have := @this φ ψ, contradiction},
  case nnf.dia : φ { rw heq at hmem, have := h.no_dia, have := @this φ, contradiction},
end

/- Regular lemmas for the propositional part. -/

section
variables (φ ψ : nnf) (Γ₁ Γ₂ Δ Λ: list nnf) {st : Type}
variables (k : KT st) (s : st)
open list

theorem sat_subset (h₁ : Γ₁ ⊆ Γ₂) (h₂ : sat k s Γ₂) : sat k s Γ₁ :=
λ x hx, h₂ _ (h₁ hx)

theorem sat_sublist (h₁ : Γ₁ <+ Γ₂) (h₂ :sat k s Γ₂) : sat k s Γ₁ :=
sat_subset _ _ _ _ (sublist.subset h₁) h₂

theorem sat_append (h₁ : sat k s Γ₁) (h₂ : sat k s Γ₂) : sat k s (Γ₁ ++ Γ₂) :=
begin
  intros φ h, rw mem_append at h, cases h,
  apply h₁ _ h, apply h₂ _ h
end

theorem unsat_contra  {Δ n} : var n ∈ Δ →  neg n ∈ Δ →  unsatisfiable Δ:=
begin
  intros h₁ h₂, intros v hsat, intros s hsat,
  have := hsat _ h₁, have := hsat _ h₂, simpa
end

theorem unsat_contra_seqt {Δ : seqt} {n} : var n ∈ Δ.main →  neg n ∈ Δ.main →  unsatisfiable (Δ.main ++ Δ.hdld):=
begin
  intros h₁ h₂, intros st m, intros s hsat,
  have := unsat_contra h₁ h₂,
  have := this _ m s,
  apply this,
  apply sat_subset _ _ _ _ _ hsat,
  simp
end

theorem sat_of_and : force k s (and φ ψ) ↔ (force k s φ) ∧ (force k s ψ) :=
by split; {intro, simpa}

theorem sat_of_sat_erase (h₁ : sat k s $ Δ.erase φ) (h₂ : force k s φ) : sat k s Δ :=
begin
  intro ψ, intro h,
  by_cases (ψ = φ),
  {rw h, assumption},
  {have : ψ ∈ Δ.erase φ,
   rw mem_erase_of_ne, assumption, exact h,
   apply h₁, assumption}
end

theorem unsat_and_of_unsat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : unsatisfiable $ φ :: ψ :: Δ.erase (and φ ψ)) :
        unsatisfiable Δ :=
begin
  intro st, intros, intro h,
  apply h₂, swap 3, exact k, swap, exact s,
  intro e, intro he,
  cases he,
  {rw he, have := h _ h₁, rw sat_of_and at this, exact this.1},
  {cases he,
    {rw he, have := h _ h₁, rw sat_of_and at this, exact this.2},
    {have := h _ h₁, apply h, apply mem_of_mem_erase he} }
end

theorem unsat_and_of_unsat_split_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : unsatisfiable $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ)) :
        unsatisfiable (Δ++Γ) :=
begin
  intro st, intros, intro h,
  apply h₂, swap 3, exact k, swap, exact s,
  intro e, intro he,
  cases he,
  {rw he, have := h _ (mem_append_left _ h₁), rw sat_of_and at this, exact this.1},
  {cases he,
    {rw he, have := h _ (mem_append_left _ h₁), rw sat_of_and at this, exact this.2},
    {have := h _ (mem_append_left _ h₁), apply h, apply mem_of_mem_erase, rw erase_append_left, exact he, exact h₁} }
end

theorem sat_and_of_sat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s $ φ :: ψ :: Δ.erase (and φ ψ)) :
        sat k s Δ :=
begin
  intro e, intro he,
  by_cases (e = and φ ψ),
  { rw h, dsimp, split, repeat {apply h₂, simp} },
  { have : e ∈ Δ.erase (and φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply h₂, simp [this] }
end

theorem sat_and_of_sat_split_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ)) :
        sat k s (Δ++Γ) :=
begin
  intro e, intro he,
  by_cases (e = and φ ψ),
  { rw h, dsimp, split, repeat {apply h₂, simp} },
  { have : e ∈ Δ.erase (and φ ψ) ++ Γ,
      { rw ←erase_append_left, rw mem_erase_of_ne, repeat {assumption} },
    apply h₂, simp [this] }
end

theorem sat_split_of_sat_and_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s (Δ++Γ)) :
        sat k s $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ) :=
begin
  intros e he, rw mem_append at he, cases he,
  have : force k s (and φ ψ), {apply h₂, simp [h₁]}, rw sat_of_and at this,
  {cases he,
  {rw he, exact this.left},
  {cases he, rw he, exact this.right, apply h₂, rw mem_append, left, apply mem_of_mem_erase he}
  },
  {apply h₂, rw mem_append, right, exact he}
end

theorem unsat_or_of_unsat_split_seqt {Γ}
        (h : or φ ψ ∈ Δ)
        (h₁ : unsatisfiable $ (φ :: Δ.erase (nnf.or φ ψ)++Γ))
        (h₂ : unsatisfiable $ (ψ :: Δ.erase (nnf.or φ ψ)++Γ)) :
        unsatisfiable $ (Δ++Γ) :=
begin
  intro, intros, intro hsat,
  have := hsat _ (mem_append_left _ h),
  dsimp at this,
  cases this,
  {apply h₁, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat,
apply mem_of_mem_erase, rw erase_append_left, exact he, exact h},
  {apply h₂, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat, apply mem_of_mem_erase, rw erase_append_left, exact he, exact h}
end

theorem sat_or_of_sat_split_left
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ φ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, dsimp, left, apply hl, simp},
  {have : e ∈ Δ.erase (or φ ψ),
     { rw mem_erase_of_ne, repeat { assumption } },
   apply hl, simp [this]}
end

theorem sat_or_of_sat_split_right
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ ψ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, dsimp, right, apply hl, simp},
  { have : e ∈ Δ.erase (or φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply hl, simp [this] }
end

/- KT-specific lemmas -/

theorem force_of_force_box (h : force k s $ box φ) : force k s φ
:= begin dsimp at h, apply h, apply k.refl end

theorem unsat_copy_of_unsat_box
        (h₁ : box φ ∈ Δ)
        (h₂ : unsatisfiable $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ) :
        unsatisfiable (Δ ++ Λ) :=
begin
  intros st k s h,
  apply h₂, swap 3, exact k, swap, exact s,
  intros e he,
  rw [mem_append] at he,
  cases he,
  {cases he,
    {rw he, apply force_of_force_box, apply h (box φ), simp [h₁]},
    {apply h, rw mem_append, left, apply mem_of_mem_erase he }},
  {cases he,
    {rw ←he at h₁, apply h, rw mem_append, left, exact h₁},
    {apply h, rw mem_append, right, assumption}}
end

theorem sat_copy_of_sat_box
        (h₁ : box φ ∈ Δ)
        (h₂ : sat k s $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ) :
        sat k s (Δ ++ Λ) :=
begin
  intros ψ hφ,
  rw mem_append at hφ,
  cases hφ,
  {by_cases heq : ψ = box φ,
    {rw heq, apply h₂ (box φ), simp},
    {have := mem_erase_of_ne heq, rw ←this at hφ, apply h₂, simp, right, left, exact hφ}},
  {apply h₂, simp, repeat {right}, exact hφ}
end

theorem sat_box_of_sat_copy
        (h₁ : box φ ∈ Δ)
        (h₂ : sat k s (Δ ++ Λ)) :
        sat k s $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ :=
begin
  apply sat_append,
  {intros ψ h, cases h, have : sat k s Δ, {apply sat_subset Δ (Δ++Λ), simp, assumption}, have := this _ h₁, apply force_of_force_box, rw h, exact this, apply h₂, have := mem_of_mem_erase h, simp [this]},
  {intros ψ h, cases h, rw h, have := h₂ (box φ), apply this, simp [h₁], apply h₂, rw mem_append, right, exact h}
end

end

def and_child {φ ψ} (Γ : seqt) (h : nnf.and φ ψ ∈ Γ.main) : seqt :=
⟨φ :: ψ :: Γ.main.erase (and φ ψ), Γ.hdld,
begin
  intros k s γ hsat hin hall,
  by_cases heq : γ = and φ ψ,
  {rw heq, split, apply hsat, simp, apply hsat, simp},
  {apply Γ.pmain _ hin hall, apply sat_and_of_sat_split _ _ _ _ _ h hsat}
end,
Γ.phdld⟩

inductive and_instance_seqt (Γ : seqt) : seqt → Type
| cons : Π {φ ψ} (h : nnf.and φ ψ ∈ Γ.main),
         and_instance_seqt $ and_child Γ h

def or_child_left {φ ψ} (Γ : seqt) (h : nnf.or φ ψ ∈ Γ.main) : seqt :=
⟨φ :: Γ.main.erase (or φ ψ), Γ.hdld,
begin
  intros k s γ hsat hin hall,
  by_cases heq : γ = or φ ψ,
  {rw heq, dsimp, left, apply hsat, simp},
  {apply Γ.pmain, apply sat_or_of_sat_split_left, exact h, exact hsat, exact hin, exact hall}
end,
Γ.phdld⟩

def or_child_right {φ ψ} (Γ : seqt) (h : nnf.or φ ψ ∈ Γ.main) : seqt :=
⟨ψ :: Γ.main.erase (or φ ψ), Γ.hdld,
begin
  intros k s γ hsat hin hall,
  by_cases heq : γ = or φ ψ,
  {rw heq, dsimp, right, apply hsat, simp},
  {apply Γ.pmain, apply sat_or_of_sat_split_right, exact h, exact hsat, exact hin, exact hall}
end,
Γ.phdld⟩

inductive or_instance_seqt (Γ : seqt) : seqt → seqt → Type
| cons : Π {φ ψ} (h : nnf.or φ ψ ∈ Γ.main),
         or_instance_seqt (or_child_left Γ h) (or_child_right Γ h)

def box_child {φ} (Γ : seqt) (h : nnf.box φ ∈ Γ.main) : seqt :=
⟨φ :: Γ.main.erase (box φ), box φ :: Γ.hdld,
begin
  intros k s γ hsat hin hall,
  cases hin,
  {simp at hin, rw hin, apply hsat, simp},
  {apply Γ.pmain, intros ψ hψ,
   by_cases heq : ψ = box φ,
   {rw heq, dsimp, intros s' hs',
    have := mem_of_mrel_tt hs', cases this,
    {apply hall, simp, assumption},
    {rw ←this, apply hsat, simp} },
   {apply hsat, right,
    have := list.mem_erase_of_ne heq, swap, exact Γ.main,
    rw ←this at hψ, assumption},
  {assumption},{intros, apply hall, simp [a], exact H} }
end,
cons_box_only Γ.phdld⟩

inductive copy_instance_seqt (Γ : seqt) : seqt → Type
| cons : Π {φ} (h : nnf.box φ ∈ Γ.main),
         copy_instance_seqt $ box_child Γ h

theorem build_model_seqt : Π Γ (h : model_constructible Γ),
sat builder (cons h.v []) (Γ.main ++ Γ.hdld) :=
begin
  intros Γ h, apply sat_append, apply build_model,
  intros ψ hψ,
  have := box_only_ex Γ.phdld hψ, cases this with w hw,
  rw hw, apply force_box_of_leaf, apply Γ.pmain _ _,
  {intros ψ hin m hm, exfalso, apply list.not_mem_nil, exact hm},
  {apply build_model},
  {rw hw at hψ, assumption}
end


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.ring_division
import Mathlib.data.mv_polynomial.rename
import Mathlib.ring_theory.polynomial.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
## Function extensionality for multivariate polynomials

In this file we show that two multivariate polynomials over an infinite integral domain are equal
if they are equal upon evaluating them on an arbitrary assignment of the variables.

# Main declaration

* `mv_polynomial.funext`: two polynomials `φ ψ : mv_polynomial σ R`
  over an infinite integral domain `R` are equal if `eval x φ = eval x ψ` for all `x : σ → R`.

-/

namespace mv_polynomial

/-- Two multivariate polynomials over an infinite integral domain are equal
if they are equal upon evaluating them on an arbitrary assignment of the variables. -/
theorem funext {R : Type u_1} [integral_domain R] [infinite R] {σ : Type u_2}
    {p : mv_polynomial σ R} {q : mv_polynomial σ R}
    (h : ∀ (x : σ → R), coe_fn (eval x) p = coe_fn (eval x) q) : p = q :=
  sorry

theorem funext_iff {R : Type u_1} [integral_domain R] [infinite R] {σ : Type u_2}
    {p : mv_polynomial σ R} {q : mv_polynomial σ R} :
    p = q ↔ ∀ (x : σ → R), coe_fn (eval x) p = coe_fn (eval x) q :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Luca Gerolla. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luca Gerolla, Kevin Buzzard
Definition of homotopy, properties and equivalence relation.
-/
import analysis.topology.continuity
import analysis.topology.topological_space
import analysis.topology.infinite_sum
import analysis.topology.topological_structures
import analysis.topology.uniform_space
import analysis.real
import data.real.basic tactic.norm_num
import data.set.basic
import Topology.Material.pasting_lemma
import Topology.Material.path
import Topology.Material.real_results

open set filter lattice classical
namespace homotopy
open path

variables {α  : Type*} [topological_space α ]
variables {β  : Type*} [topological_space β ] { x y z w : β  }
variables ( x0 : β  )
variable s : I01

noncomputable theory

local attribute [instance] classical.prop_decidable

-- HOMOTOPY

-- General Homotopy
structure homotopy  {f : α → β} {g : α → β} ( hcf : continuous f) ( hcg : continuous g) :=
(to_fun : I01 × α →  β )
(at_zero : ( λ x, to_fun ( 0 , x) ) = f )
(at_one : ( λ x, to_fun ( 1 , x) ) = g)
(cont :  continuous  to_fun )

structure path_homotopy ( f : path x y) ( g : path x y) :=
(to_fun : I01 × I01 →  β )
(path_s : ∀ s : I01, is_path x y ( λ t, to_fun (s, t) ) )
(at_zero : ∀ y, to_fun (0,y) = f.to_fun y )
(at_one :  ∀ y, to_fun (1,y) = g.to_fun y)
(cont : continuous to_fun)

-- Simp lemmas
@[simp]
lemma at_zero_path_hom { f : path x y } { g : path x y} (F : path_homotopy f g) (y : I01) :
F.to_fun (0, y) = path.to_fun f y := F.3 y

@[simp]
lemma at_one_path_hom { f : path x y} { g : path x y} (F : path_homotopy f g) (y : I01):
F.to_fun (1, y) = path.to_fun g y := F.4 y

@[simp]
lemma at_pt_zero_hom  { f : path x y} { g : path x y} (F : path_homotopy f g) (s : I01) :
F.to_fun (s, 0) = x :=  begin exact (F.2 s).1 end

@[simp]
lemma at_pt_one_hom  { f : path x y} { g : path x y} (F : path_homotopy f g) (s : I01) :
F.to_fun (s, 1) = y :=  begin exact (F.2 s).2.1  end

variables { l  k : path x y }
variable F : path_homotopy l k

-- Alternative path_homotopy.mk
def path_homotopy.mk'  { f : path x y} { g : path x y}
  (F : I01 × I01 →  β) (start_pt : ∀ s : I01, F (s, 0) = x) (end_pt : ∀ s : I01, F (s, 1) = y)
  (at_zero : ∀ y, F (0,y) = f.to_fun y ) (at_one : ∀ y, F (1,y) = g.to_fun y )
  (F_cont : continuous F) : path_homotopy f g :=
{   to_fun := F,
    path_s :=
    begin
      unfold is_path, intro s, split, exact start_pt s, split, exact end_pt s,
      refine continuous.comp _ F_cont,
      exact continuous.prod_mk continuous_const continuous_id,
    end,
    at_zero := at_zero,
    at_one := at_one,
    cont := F_cont
}

-- Ending points of path_homotopy are fixed  (Can Remove - not Used)
lemma hom_eq_of_pts { x y : β } { f g : path x y } ( F : path_homotopy f g ) :
∀ s : I01, check_pts x y ( λ t,  F.to_fun (s, t)) :=
begin
  intro s, unfold check_pts, split,
    have h₁ : F.to_fun (s, 0) =  ( λ t,  F.to_fun (s, t)) 0, by simp,
    rw h₁ , exact (F.path_s s).left,
    have h₂  : F.to_fun (s, 1) =  ( λ t,  F.to_fun (s, t)) 1, by simp,
    rw h₂ , exact (F.path_s s).right.left
end

--- (Can Remove - not Used)
lemma hom_path_is_cont { x y : β } { f g : path x y } ( F : path_homotopy f g ) :
∀ s : I01, continuous ( λ t,  F.to_fun (s, t)) :=
begin intro s, exact (F.path_s s).right.right end

def hom_to_path { f g : path x y } ( F : path_homotopy f g ) (s : I01) : path x y :=
to_path ( λ t,  F.to_fun (s, t)) (F.path_s s)

--------------------------------------------

--------------------------------------------
-- IDENTITY / INVERSE / COMPOSITION of HOMOTOPY

--- Identity homotopy
def path_homotopy_id { x y : β} (f : path x y) : path_homotopy f f :=
{   to_fun :=  λ st  , f.to_fun (prod.snd st) ,

    path_s := begin  intro s, unfold is_path, exact ⟨ f.at_zero,  f.at_one, f.cont ⟩ end,

    at_zero := by simp ,
    at_one := by simp ,

    cont :=
    begin
      let h := λ st, f.to_fun ( @prod.snd I01 I01 st ) ,
      have hc : continuous h,
        exact continuous.comp  continuous_snd f.cont,
      exact hc,
    end
}

--- Inverse homotopy
lemma help_hom_inv : (λ (st : ↥I01 × ↥I01), F.to_fun (par_inv (st.fst), st.snd)) =
  ((λ (st : ↥I01 × ↥I01), F.to_fun (st.fst , st.snd)) ∘
     (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01))) := by trivial

def path_homotopy_inverse { x y : β} {f : path x y} {g : path x y} ( F : path_homotopy f g) : path_homotopy g f :=
{   to_fun :=   λ st  , F.to_fun ( par_inv st.1 , st.2 ),
    path_s :=
    begin
      intro s, unfold is_path, split,
        exact (F.path_s (par_inv s)).1, split,
          exact (F.path_s (par_inv s)).2.1,
          exact (F.path_s (par_inv s)).2.2
    end,
    at_zero := begin intro t,  simp [eqn_1_par_inv],  end,
    at_one := begin intro t, simp, end,
    cont :=
    begin
      show continuous ((λ (st : ↥I01 × ↥I01), F.to_fun (st.fst , st.snd)) ∘ (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01))),
      have H : continuous (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01)),
        { exact continuous.prod_mk ( continuous.comp  continuous_fst continuous_par_inv)
          ( @continuous.comp (I01×I01) I01 I01 _ _ _ (λ x : I01×I01, x.2) _ continuous_snd continuous_id) },
      simp [continuous.comp H F.cont],
    end
}

------------------------------------------

---- Composition of homotopy

local notation `I` := @set.univ I01

-- Prove T1 × I01, T2 × I01 cover I01 × I01
lemma cover_prod_I01 : ( (set.prod T1 (@set.univ I01)) ∪ (set.prod T2 (@set.univ I01)) ) =
  @set.univ (I01 × I01) :=
begin
  apply set.ext, intro x, split, simp [mem_set_of_eq],
  intro H, simp, have H : 0 ≤ x.1.val ∧ x.1.val ≤ 1, by exact x.1.property,
  unfold T1 T2 T, simp [mem_set_of_eq, or_iff_not_imp_left, -one_div_eq_inv],
  intro nL, have H2 : (1 / 2 :ℝ )< x.1.val, by exact nL H.1,
  exact ⟨ le_of_lt H2, H.2 ⟩ ,
end

-- Closedness and intersection of T1 × I01, T2 × I01
lemma prod_T1_is_closed : is_closed (set.prod T1 I) :=
begin simp [T1_is_closed, is_closed_prod]  end

lemma prod_T2_is_closed : is_closed (set.prod T2 I) :=
begin simp [T2_is_closed, is_closed_prod] end

lemma prod_inter_T : set.inter (set.prod T1 I) (set.prod T2 I) =
  set.prod  { x : I01 | x.val = 1/2 } I :=
begin
  unfold T1 T2 T set.inter set.prod, simp [mem_set_of_eq, -one_div_eq_inv],
  apply set.ext, intro x, split,
  {rw mem_set_of_eq , rw mem_set_of_eq, simp [-one_div_eq_inv], intros A B C D,
   have H : x.1.val < 1 / 2 ∨ x.1.val = 1/2, by exact lt_or_eq_of_le B,
   exact le_antisymm  B C   },
  rw mem_set_of_eq , rw mem_set_of_eq, intro H, rw H, norm_num
end

-- Define general / T1 / T2 reparametrised homotopy and prove continuity
def fgen_hom { x y : α } {r s : ℝ} {f g: path x y } (Hrs : r < s)
 ( F : path_homotopy f g) : (set.prod (T r s Hrs ) I) → α :=
λ st, F.to_fun (( par Hrs ⟨st.1.1, (mem_prod.1 st.2).1 ⟩) , st.1.2 )

theorem p_hom_cont { x y : α } {r s : ℝ} {f g : path x y } (Hrs : r < s) ( F : path_homotopy f g)  : continuous (fgen_hom Hrs F) :=
begin
  unfold fgen_hom, refine continuous.comp _ F.cont ,
  refine continuous.prod_mk _ (continuous.comp continuous_subtype_val continuous_snd),
  refine continuous.comp _ (continuous_par Hrs),
  refine continuous_subtype_mk _ _,
  exact continuous.comp continuous_subtype_val continuous_fst,
end

def fa_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : (set.prod T1 I) → α  :=
@fgen_hom _ _ _ _ 0 (1/2 : ℝ ) _ _  zero_lt_half F

lemma CA_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : continuous (fa_hom F) :=
p_hom_cont zero_lt_half F

def fb_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : (set.prod T2 I) → α  :=
@fgen_hom _ _ _ _ (1/2 : ℝ ) 1 _ _  half_lt_one F

lemma CB_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : continuous (fb_hom F) :=
p_hom_cont half_lt_one F

---

-- Other helpful lemmas

@[simp]
lemma cond_start {f : path x y} {g : path x y} {h : path x y}
  ( F : path_homotopy f g) ( G : path_homotopy g h) :
  paste cover_prod_I01 (fa_hom F) (fb_hom G) (s, 0) = x :=
begin unfold paste, split_ifs, unfold fa_hom fgen_hom, simp, unfold fb_hom fgen_hom, simp, end

@[simp]
lemma cond_end {f : path x y} {g : path x y} {h : path x y}
  ( F : path_homotopy f g) ( G : path_homotopy g h) :
  paste cover_prod_I01 (fa_hom F) (fb_hom G) (s, 1) = y :=
begin unfold paste, split_ifs, unfold fa_hom fgen_hom, simp, unfold fb_hom fgen_hom, simp, end

-- Homotopy composition
def path_homotopy_comp  {f : path x y} {g : path x y} {h : path x y}
  ( F : path_homotopy f g) ( G : path_homotopy g h) : path_homotopy f h :=
{   to_fun := λ st, ( @paste (I01 × I01) β (set.prod T1 I) (set.prod T2 I)  cover_prod_I01 ( λ st , (fa_hom F ) st ) ) ( λ st, (fb_hom G ) st  )  st  ,

    path_s :=
    begin
      intro s, unfold is_path, split, simp,
        split, simp, simp,

      unfold paste, unfold fa_hom fb_hom fgen_hom, simp,
      by_cases H : ∀ t : I01, (s, t) ∈ set.prod T1 I, simp [H],
        refine (F.path_s (par zero_lt_half ⟨ s, _ ⟩  )).2.2, unfold set.prod at H,
        have H2 : (s, s) ∈ {p : ↥I01 × ↥I01 | p.fst ∈ T1 ∧ p.snd ∈ univ}, exact H s, simp [mem_set_of_eq] at H2, exact H2,
        simp at H,
        have H3:  s ∉ T1, simp [not_forall] at H, exact H.2,
        simp [H3], refine (G.path_s (par half_lt_one ⟨ s, _ ⟩  )).2.2,
        exact T2_of_not_T1 H3,
    end,

    at_zero := begin  intro y, simp, unfold paste, rw dif_pos, unfold fa_hom fgen_hom, simp ,
        simp [mem_set_of_eq], exact help_T1,  end,

    at_one := begin intro y, simp, unfold paste, rw dif_neg, unfold fb_hom fgen_hom, simp ,
        simp [mem_set_of_eq], exact help_02, end,

    cont :=
    begin simp, refine cont_of_paste _ _ _ (CA_hom F) (CB_hom G) ,
      exact prod_T1_is_closed,
      exact prod_T2_is_closed,
      unfold match_of_fun, intros x B1 B2,
        have Int : x ∈ set.inter (set.prod T1 I) (set.prod T2 I), exact ⟨ B1 , B2 ⟩ ,
        rwa [prod_inter_T] at Int,
        have V : x.1.1 = 1/2, rwa [set.prod, mem_set_of_eq] at Int, rwa [mem_set_of_eq] at Int, exact Int.1, cases x,
        have xeq : x_fst = ⟨ 1/2 , help_01 ⟩ , apply subtype.eq, rw V,
        simp [xeq, -one_div_eq_inv],
        show fa_hom F ⟨(⟨1 / 2, help_01⟩, x_snd), _⟩ = fb_hom G ⟨(⟨1 / 2, help_01⟩, x_snd), _⟩ , unfold fa_hom fb_hom fgen_hom,
        simp [eqn_1, eqn_2, -one_div_eq_inv],
    end
}

---------------------------------

------------------------------------------------------

---- EQUIVALENCE OF HOMOTOPY

definition is_homotopic_to  (f : path x y) ( g : path x y) : Prop := nonempty ( path_homotopy f g)

theorem is_reflexive : @reflexive (path x y) ( is_homotopic_to ) :=
begin
  unfold reflexive, intro f, unfold is_homotopic_to,
    have H : path_homotopy f f,
        exact path_homotopy_id f ,
    exact ⟨ H ⟩
end

theorem is_symmetric  : @symmetric (path x y)  (is_homotopic_to) :=
begin
    unfold symmetric, intros f g H, unfold is_homotopic_to,
    cases H with F, exact ⟨path_homotopy_inverse  F⟩,
end

theorem is_transitive  : @transitive (path x y)  (is_homotopic_to) :=
begin
    unfold transitive, intros f g h Hfg Hgh, unfold is_homotopic_to at *,
      cases Hfg  with F,  cases Hgh with G,
    exact ⟨ path_homotopy_comp F G⟩ ,
end

theorem is_equivalence : @equivalence (path x y)  (is_homotopic_to) :=
⟨ is_reflexive, is_symmetric, is_transitive⟩

-----------------------------------------------------

end homotopy


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.wf
import Mathlib.Lean3Lib.init.data.nat.basic

namespace Mathlib

namespace nat

protected def div (x : ℕ) : ℕ → ℕ := well_founded.fix lt_wf div.F

protected instance has_div : Div ℕ := { div := nat.div }

theorem div_def_aux (x : ℕ) (y : ℕ) :
    x / y =
        dite (0 < y ∧ y ≤ x) (fun (h : 0 < y ∧ y ≤ x) => (x - y) / y + 1)
          fun (h : ¬(0 < y ∧ y ≤ x)) => 0 :=
  congr_fun (well_founded.fix_eq lt_wf div.F x) y

protected def mod (x : ℕ) : ℕ → ℕ := well_founded.fix lt_wf mod.F

protected instance has_mod : Mod ℕ := { mod := nat.mod }

theorem mod_def_aux (x : ℕ) (y : ℕ) :
    x % y =
        dite (0 < y ∧ y ≤ x) (fun (h : 0 < y ∧ y ≤ x) => (x - y) % y)
          fun (h : ¬(0 < y ∧ y ≤ x)) => x :=
  congr_fun (well_founded.fix_eq lt_wf mod.F x) y

end Mathlib


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Main functional correctness theorem for stochastic backpropagation.
-/
import .util .graph .compute_grad .predicates .estimators .env .dvec .compute_grad_slow_correct .memoize_correct .lemmas .lemmas_extra

namespace certigrad
open tactic list theorems

theorem backprop_correct {costs : list ID} :
  ∀ {nodes : list node} (inputs : env) (tgts : list reference),
  ∀ {tgt : reference} {idx : ℕ}, at_idx tgts idx tgt →
  nodup (tgts ++ map node.ref nodes) →
  well_formed_at costs nodes inputs tgt →
  grads_exist_at nodes inputs tgt →
  pdfs_exist_at nodes inputs →
  is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes dvec.head →
  can_differentiate_under_integrals costs nodes inputs tgt →

  ∇ (λ θ₀, E (graph.to_dist (λ m, ⟦sum_costs m costs⟧) (env.insert tgt θ₀ inputs) nodes) dvec.head) (env.get tgt inputs)
  =
  E (graph.to_dist (λ m, backprop costs nodes m tgts) inputs nodes) (λ dict, dvec.get tgt.2 dict idx) :=

assume (nodes : list node) (inputs : env) (tgts : list reference)
       (tgt : reference) (idx : ℕ) (H_at_idx : at_idx tgts idx tgt)
       (H_nd : nodup (tgts ++ map node.ref nodes))
       (H_wf : well_formed_at costs nodes inputs tgt)
       (H_gs_exist : grads_exist_at nodes inputs tgt)
       (H_pdfs_exist : pdfs_exist_at nodes inputs)
       (H_grad_gint : is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes dvec.head)
       (H_diff_under_int : can_differentiate_under_integrals costs nodes inputs tgt),

have H_gdiff : is_gdifferentiable (λ m, ⟦sum_costs m costs⟧) tgt inputs nodes dvec.head, from
  is_gdifferentiable_of_pre _ _ _ H_wf H_gs_exist H_pdfs_exist H_diff_under_int,
have H_nabla_gint : is_nabla_gintegrable (λ m, ⟦sum_costs m costs⟧) tgt inputs nodes dvec.head, from
  is_nabla_gintegrable_of_gintegrable _ _ _ H_wf H_gs_exist H_pdfs_exist H_gdiff H_diff_under_int H_grad_gint,

begin
rw (compute_grad_slow_correct H_wf H_gs_exist H_pdfs_exist H_gdiff H_nabla_gint H_grad_gint H_diff_under_int),
rw (E.E_move_fn_to_continuation _ _ _ (λ dict, dvec.get tgt.2 dict idx)),
dunfold backprop, dsimp,
simp only [(λ m, tvec.get_from_env H_at_idx m), (λ m, memoize_correct costs nodes m H_at_idx H_nd)]
end

end certigrad


import new.unordered.d
import new.unordered.C

open topological_space Top Top.sheaf
open category_theory
open opposite

universe u
variables {X : Top.{u}} (𝓕 : sheaf Ab X) (U : X.oc)

section C_alt

variables {𝓕 U}
def C.pre.is_skewsymmetric {n : ℕ} (f : C.pre 𝓕 U n) : Prop :=
∀ (i j : fin n) (α : fin n → U.ι),
  f α =
  𝓕.1.map (eq_to_hom (face.swap_eq α i j)).op (- f (swap i j α))

def C.pre.is_skewsymmetric' {n : ℕ} (f : C.pre 𝓕 U n) : Prop :=
∀ (i j : fin n) (α : fin n → U.ι),
  f (swap i j α) =
  - 𝓕.1.map (eq_to_hom (face.swap_eq α i j).symm).op (f α)

lemma is_skewsymmetric_iff_is_skewsymmetric' {n} (f : C.pre 𝓕 U n) :
  C.pre.is_skewsymmetric f ↔ C.pre.is_skewsymmetric' f :=
{ mp := λ h i j α, begin
    specialize h i j α,
    rw [h, map_neg, map_neg, neg_neg, ← comp_apply, ← 𝓕.1.map_comp, ← op_comp, eq_to_hom_trans, eq_to_hom_refl],
    simp,
  end,
  mpr := λ h i j α, begin
    specialize h i j α,
    rw [h, neg_neg, ← comp_apply, ← 𝓕.1.map_comp, ← op_comp, eq_to_hom_trans, eq_to_hom_refl],
    simp
  end }

end C_alt

def C_alt.pre (n : ℕ) : add_subgroup (C 𝓕 U n) :=
{ carrier := { f : C.pre 𝓕 U n | f.is_skewsymmetric ∧ ∀ (α : fin n → U.ι), ¬ function.injective α → f α = 0},
  add_mem' := λ f g hf hg, begin
    rcases hf with ⟨hf1, hf2⟩,
    rcases hg with ⟨hg1, hg2⟩,
    split,
    intros i j α,
    change f α + g α = 𝓕.1.map _ (- (f _ + g _)),
    rw [map_neg, map_add, hf1 i j, hg1 i j, map_neg, map_neg, neg_add],

    intros α ha,
    change f α + g α = 0,
    rw [hf2, hg2, add_zero];
    assumption,
  end,
  zero_mem' := begin
    split,
    intros i j α,
    simp only [C_pre.zero_apply, neg_zero, map_zero],

    intros α ha,
    simp,
  end,
  neg_mem' := λ f ⟨hf1, hf2⟩, begin
    split,
    intros i j α,
    simp only [C_pre.neg_apply],
    rw neg_neg,
    rw hf1 i j,
    simp only [map_neg, neg_neg],

    intros α ha,
    change - (f α) = 0,
    rw hf2 _ ha,
    rw neg_zero,
  end }

def C_alt (n : ℕ) : Ab := AddCommGroup.of $ C_alt.pre 𝓕 U n

def d_alt (n : ℕ) : C_alt 𝓕 U n ⟶ C_alt 𝓕 U (n + 1) :=
{ to_fun := λ f, ⟨d 𝓕 U n f.1, sorry⟩,
  map_zero' := begin
    rw subtype.ext_iff_val,
    simp,
  end,
  map_add' := begin
    rintros ⟨f, hf⟩ ⟨g, hg⟩,
    rw subtype.ext_iff_val,
    simp,
  end }

lemma d_alt_d_alt_eq_zero (n : ℕ) :
  d_alt 𝓕 U n ≫ d_alt 𝓕 U (n + 1) = 0 :=
begin
  ext f α,
  rw [comp_apply],
  simp only [AddCommGroup.zero_apply, add_subgroup.coe_zero, C_pre.zero_apply],
  convert dd_eq_zero 𝓕 U n f.1 α,
end


import SciLean
import Qq

open SciLean

variable {X Y Z W : Type} [SemiHilbert X] [SemiHilbert Y] [SemiHilbert Z] [SemiHilbert W]
         {Y₁ Y₂ : Type} [SemiHilbert Y₁] [SemiHilbert Y₂]
         {ι κ : Type} [Enumtype ι] [Enumtype κ]

example {n : Nat} : (∇ (x : ℝ^{n}), ‖x‖²) = λ x : ℝ^{n} => (2:ℝ)*x := by symdiff; done
example {n : Nat} (m : ℝ) : (∇ (x : ℝ^{n}), 1/2 * m * ‖x‖²) = λ x : ℝ^{n} => m*x := by symdiff; done

@[diff]
theorem adjoint_sum_eval_rank1 (f : ι → X → Y) [∀ i, HasAdjointT (f i)]
  : (λ (x : ι → X) => ∑ i, f i (x i))†
    =
    λ y i => (f i)† y := by symdiff; sorry

@[diff]
theorem adjDiff_sum_eval_rank1 (f : ι → X → Y) [hf : ∀ i, HasAdjDiffT (f i)]
  : ∂† (λ (x : ι → X) => ∑ i, f i (x i))
    =
    λ x dy' i => ∂† (f i) (x i) dy' :=
by
  unfold adjointDifferential
  have := λ i => (hf i).1
  have := λ i => (hf i).2
  symdiff; symdiff; done

@[diff]
theorem revDiff_sum_eval_rank1 (f : ι → X → Y) [hf : ∀ i, HasAdjDiffT (f i)]
  : ℛ (λ (x : ι → X) => ∑ i, f i (x i))
    =
    λ x => (∑ i, f i (x i), λ dy' i => ∂† (f i) (x i) dy') :=
by
  unfold reverseDifferential
  symdiff; done

unif_hint adjoint_sum_eval_rank1.unif_hint_0
  (f? : ι → X → Y)
  (f : ι → W → Y) (h : X → W)
where
  f? =?= λ i x => f i (h x)
  |-
  (λ (x : ι → X) => ∑ i, (f? i) (x i))†
  =?=
  (λ (x : ι → X) => ∑ i, f i (h (x i)))†

unif_hint adjoint_sum_eval_rank1.unif_hint_1
  (f? : ι → X → Y)
  (f : ι → X → α → Y) (g : ι → α)
where
  f? =?= λ i x => f i x (g i)
  |-
  (λ (x : ι → X) => ∑ i, (f? i) (x i))†
  =?=
  (λ (x : ι → X) => ∑ i, f i (x i) (g i))†

unif_hint adjDiff_sum_eval_rank1.unif_hint_1
  (f? : ι → X → Y)
  (f : ι → X → W) (h : ι → W → Y)
where
  f? =?= λ i x => h i (f i x)
  |-
  ∂† (λ (x : ι → X) => ∑ i, (f? i) (x i))
  =?=
  ∂† (λ (x : ι → X) => ∑ i, h i (f i (x i)))

unif_hint adjDiff_sum_eval_rank1.unif_hint_2
  (f? : ι → X → Y)
  (op : Y₁ → Y₂ → Y)
  (f₁ : ι → X → Y₁) (f₂ : ι → X → Y₂)-- (h : ι → W → Y)
where
  f? =?= λ i x => op (f₁ i x) (f₂ i x)
  |-
  ∂† (λ (x : ι → X) => ∑ i, (f? i) (x i))
  =?=
  ∂† (λ (x : ι → X) => ∑ i, (op (f₁ i (x i)) (f₂ i (x i))))

unif_hint adjDiff_sum_eval_rank1.unif_hint_3
  (f? : ι → ℝ → ℝ)
  -- (op : Y₁ → Y₂ → Y)
  -- (f₁ : ι → X → Y₁) (f₂ : ι → X → Y₂)-- (h : ι → W → Y)
where
  f? =?= λ i x => x * x
  |-
  ∂† (λ (x : ι → ℝ) => ∑ i, (f? i) (x i))
  =?=
  ∂† (λ (x : ι → ℝ) => ∑ i, x i * x i)

@[simp]
theorem sum_setElem_zero {Xι} [ArrayType Xι ι X]
  : ∑ i, setElem (0 : Xι) i (f i) = introElem f := sorry

@[diff]
theorem adjDiff_ArrayType_rule_forall₂ {Xι} [ArrayType Xι ι X] (f : ι → X → Y) [∀ i, HasAdjDiffT (f i)]
  : ∂† (λ (x : Xι) i => f i x[i])
    =
    λ x dx' => introElem λ i => ∂† (f i) x[i] (dx' i) :=
by
  symdiff; simp; done

unif_hint adjDiff_ArrayType_rule_forall₂.unif_hint_2 {Xι} [ArrayType Xι ι X]
  (f? : ι → X → Y)
  (f : ι → X → W) (h : ι → W → Y)
where
  f? =?= λ i x => h i (f i x)
  |-
  ∂† (λ (x : Xι) i => f? i x[i])
  =?=
  ∂† (λ (x : Xι) i => h i (f i x[i]))

@[diff]
theorem adjDiff_ArrayType_rule_forall₂.unif_hint_1 {Xι} [ArrayType Xι ι X]
  (f : ι → X → Y) [∀ i, HasAdjDiffT (f i)]
  (h : ι → Y → Z) [∀ i, HasAdjDiffT (h i)]
  : ∂† (λ (x : Xι) i => h i (f i x[i]))
    =
    λ x dx' => introElem λ i => ∂† (λ x => h i (f i x)) x[i] (dx' i) :=
by
  symdiff; done

example {X} [Hilbert X] (c : ℝ) : HasAdjDiffT (fun x : X => c * ‖ x ‖²) := by infer_instance

example (c : ℝ) : HasAdjDiffT (fun x : ℝ => c * ‖ x ‖² ) := by infer_instance
example {X} [Hilbert X] (c : ℝ) : HasAdjDiffT (fun x : X => c * ⟪x,x⟫) := by infer_instance

set_option trace.Meta.Tactic.simp.rewrite true in
example {n : Nat} : ∇ (x : Fin n → ℝ), ∑ i, x i  = λ x i =>    1 := by symdiff; done
set_option trace.Meta.Tactic.simp.rewrite true in
example {n : Nat} : ∇ (x : ℝ^{n}),      ∑ i, x[i] = λ x => ⊞ i, 1 := by symdiff; rfl; done

example {n : Nat} : ∇ (x : Fin n → ℝ), ∑ i, ‖x i‖²  = λ x i =>    (2:ℝ) * x i := by symdiff; done
example {n : Nat} : ∇ (x : ℝ^{n}),      ∑ i, ‖x[i]‖² = λ x => ⊞ i, (2:ℝ) * x[i] := by symdiff; rfl; done

example {n : Nat} (c : ℝ) : ∇ (x : Fin n → ℝ), ∑ i, c * ‖x i‖²  = λ x i =>    2 * c * x i := by symdiff; done

set_option synthInstance.maxSize 1000
set_option trace.Meta.Tactic.simp.unify true in
example {n : Nat} (c : ℝ) : ∇ (x : ℝ^{n}),      ∑ i, c * ‖x[i]‖² = λ x => ⊞ i, 2 * c * x[i] := by symdiff; rfl; done

set_option trace.Meta.Tactic.simp.discharge true in
example {n : Nat} (c : ℝ) : ∂† (λ (x : ℝ^{n}) i => c * ‖x[i]‖²) = λ x dx' => ⊞ i, 2 * c * dx' i * x[i] := by
  symdiff
  rw[adjDiff_ArrayType_rule_forall₂.unif_hint]; symdiff; rfl -- (λ _ (x : ℝ) => ‖x‖²) (λ _ (x : ℝ) => c * x)
  done

example {n : Nat} (c : ℝ) : ∇ (x : Fin n → ℝ), ∑ i, (c + i) * ‖x i‖² = λ x (i : Fin n) => 2 * (c + i) * x i := by symdiff; done
set_option trace.Meta.Tactic.simp.unify true in
example {n : Nat} : ∇ (x : Fin n → ℝ), ∑ i, x i * x i = λ x i => 2 * x i :=
by
  unfold gradient; funext x;
  rw[adjDiff_sum_eval_rank1 (λ i xi => xi * xi)]
  symdiff; done
example {n : Nat} : ∇ (x : ℝ^{n}), ∑ i, x[i]*x[i] = λ x => ⊞ i, (2:ℝ) * x[i] := by symdiff; done

open Lean Qq Meta Elab Term

def unifyTest (lhs rhs : Expr) : MetaM Unit := do
  let ppLhs ← Meta.ppExpr lhs
  let ppRhs ← Meta.ppExpr rhs
  let test ← isDefEq lhs rhs
  if test then
    IO.println s!"Success: {ppLhs} =?= {ppRhs}"
  else
    throwError "Failure: {ppLhs} =?= {ppRhs}"

unif_hint
  (α β γ : Type) (F : (α→β) → (α→γ)) (g : β → γ)
where
  F =?= λ f x => g (f x)
  |-
  (λ f x => g (f x))
  =?=
  λ f => F f

unif_hint
  (α β γ : Type) (F : (α→β) → (α→γ)) (g : β → γ)
where
  F =?= λ f x => g (f x)
  |-
  λ f => F f
  =?=
  (λ f x => g (f x))

notation x " =?= " y => unifyTest x y

#eval show MetaM Unit from do
  let f? : Q(Nat→Nat) ← mkFreshExprMVar q(Nat→Nat)

  unifyTest q(λ (x : Nat) => $f? x)
            q(λ (x : Nat) => Nat.succ (Nat.succ x))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(λ (x : Fin $n? → Nat) i => $f? (x i))
            q(λ (x : Fin $n? → Nat) i => Nat.succ (x i))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)
  let g? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(λ (x : Fin $n? → Nat) i => $f? (x i))
            q(λ (x : Fin $n? → Nat) i => $g? (x i))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let F? : Q((Fin $n?→Nat)→(Fin $n?→Nat)) ← mkFreshExprMVarQ q((Fin $n?→Nat)→(Fin $n?→Nat))
  let g? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(λ (x : Fin $n? → Nat) => $F? x)
            q(λ (x : Fin $n? → Nat) i => $g? (x i))

#eval show MetaM Unit from do
  let X? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let Y? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let Z? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let g? : Q($Y?→$Z?) ← mkFreshExprMVarQ q($Y?→$Z?)
  let h? : Q($Y?→$Z?) ← mkFreshExprMVarQ q($Y?→$Z?)

  q(λ (f : $X? → $Y?) x => $g? (f x))
  =?=
  q(λ (f : $X? → $Y?) x => $h? (f x))

#eval show MetaM Unit from do
  let X? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let Y? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let F? : Q(($X?→$Y?)→($X?→$Y?)) ← mkFreshExprMVarQ q(($X?→$Y?)→($X?→$Y?))
  let G? : Q(($X?→$Y?)→($X?→$Y?)) ← mkFreshExprMVarQ q(($X?→$Y?)→($X?→$Y?))
  let g? : Q($Y?→$Y?) ← mkFreshExprMVarQ q($Y?→$Y?)

  q(λ (f : $X? → $Y?) => $F? f)
  =?=
  q(λ (f : $X? → $Y?) x => $g? (f x))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(id $ λ (x : Fin $n? → Nat) i => $f? (x i))
            q(id $ λ (x : Fin $n? → Nat) i => Nat.succ (x i))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let op? : Q(ℝ → ℝ → ℝ) ← mkFreshExprMVarQ q(ℝ → ℝ → ℝ)

  unifyTest q(λ (x : Fin $n? → ℝ) i => $op? (x i) (x i))
            q(λ (x : Fin $n? → ℝ) i => x i * x i)

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Fin $n? → ℝ → ℝ) ← mkFreshExprMVarQ q(Fin $n? → ℝ → ℝ)

  unifyTest q(λ (x : Fin $n? → ℝ) i => $f? i (x i))
            q(λ (x : Fin $n? → ℝ) i => x i * x i)

def n := q(10)

-- works fine
def FinExpr :=
  let n := q(10)
  q(Fin $n)

def FinExpr' : Q(Type) :=
  let n := q(10)
  q(Fin $n) -- unknown identifier '«$n»'

-- Construct an expression
def a : Expr := q([42 + 1])

-- Construct a typed expression
def b : Q(List Nat) := q([42 + 1])

def b' : Q(Nat) := q(42 + 1)

-- Antiquotations
def c :=
  let n : Q(Nat) := q(10)
  q([42 + $n + $b'])

-- Dependently-typed antiquotations
def d (u : Level) (n : Q(Nat)) (x : Q(Type u × Fin ($n + 1))) : Q(Fin ($n + 3)) :=
  q(⟨$x.2, Nat.lt_of_lt_of_le $x.2.2 (Nat.le_add_right _ 2)⟩)

#eval show MetaM Unit from do
  let a? ← mkFreshExprMVar q(Nat)
  let b? ← mkFreshExprMVar q(Nat)
  pure ()

#eval show MetaM Unit from do
  let a? ← mkFreshExprMVarQ q(Nat)
  let b? ← mkFreshExprMVarQ q(Nat) -- incompatible metavariable _uniq.146616
  pure ()


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.hom
import Mathlib.category_theory.limits.shapes.kernels
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes v u l u_1

namespace Mathlib

/-!
# Preadditive categories

A preadditive category is a category in which `X ⟶ Y` is an abelian group in such a way that
composition of morphisms is linear in both variables.

This file contains a definition of preadditive category that directly encodes the definition given
above. The definition could also be phrased as follows: A preadditive category is a category
enriched over the category of Abelian groups. Once the general framework to state this in Lean is
available, the contents of this file should become obsolete.

## Main results

* Definition of preadditive categories and basic properties
* In a preadditive category, `f : Q ⟶ R` is mono if and only if `g ≫ f = 0 → g = 0` for all
  composable `g`.
* A preadditive category with kernels has equalizers.

## Implementation notes

The simp normal form for negation and composition is to push negations as far as possible to
the outside. For example, `f ≫ (-g)` and `(-f) ≫ g` both become `-(f ≫ g)`, and `(-f) ≫ (-g)`
is simplified to `f ≫ g`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

## Tags

additive, preadditive, Hom group, Ab-category, Ab-enriched
-/

namespace category_theory

/-- A category is called preadditive if `P ⟶ Q` is an abelian group such that composition is
    linear in both variables. -/
class preadditive (C : Type u) [category C] where
  hom_group :
    autoParam ((P Q : C) → add_comm_group (P ⟶ Q))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])
  add_comp' :
    autoParam (∀ (P Q R : C) (f f' : P ⟶ Q) (g : Q ⟶ R), (f + f') ≫ g = f ≫ g + f' ≫ g)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp_add' :
    autoParam (∀ (P Q R : C) (f : P ⟶ Q) (g g' : Q ⟶ R), f ≫ (g + g') = f ≫ g + f ≫ g')
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem preadditive.add_comp {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C)
    (R : C) (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) : (f + f') ≫ g = f ≫ g + f' ≫ g :=
  sorry

@[simp] theorem preadditive.comp_add {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C)
    (R : C) (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) : f ≫ (g + g') = f ≫ g + f ≫ g' :=
  sorry

@[simp] theorem preadditive.add_comp_assoc {C : Type u} [category C] [c : preadditive C] (P : C)
    (Q : C) (R : C) (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) {X' : C} :
    ∀ (f'_1 : R ⟶ X'), (f + f') ≫ g ≫ f'_1 = (f ≫ g + f' ≫ g) ≫ f'_1 :=
  sorry

theorem preadditive.comp_add_assoc {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C)
    (R : C) (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) {X' : C} (f' : R ⟶ X') :
    f ≫ (g + g') ≫ f' = (f ≫ g + f ≫ g') ≫ f' :=
  sorry

end category_theory

namespace category_theory.preadditive

/-- Composition by a fixed left argument as a group homomorphism -/
def left_comp {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (R : C) (f : P ⟶ Q) :
    (Q ⟶ R) →+ (P ⟶ R) :=
  add_monoid_hom.mk' (fun (g : Q ⟶ R) => f ≫ g) sorry

/-- Composition by a fixed right argument as a group homomorphism -/
def right_comp {C : Type u} [category C] [preadditive C] (P : C) {Q : C} {R : C} (g : Q ⟶ R) :
    (P ⟶ Q) →+ (P ⟶ R) :=
  add_monoid_hom.mk' (fun (f : P ⟶ Q) => f ≫ g) sorry

@[simp] theorem sub_comp_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) {X' : C} :
    ∀ (f'_1 : R ⟶ X'), (f - f') ≫ g ≫ f'_1 = (f ≫ g - f' ≫ g) ≫ f'_1 :=
  sorry

-- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma.

@[simp] theorem comp_sub {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) : f ≫ (g - g') = f ≫ g - f ≫ g' :=
  add_monoid_hom.map_sub (left_comp R f) g g'

@[simp] theorem neg_comp {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ g = -f ≫ g :=
  add_monoid_hom.map_neg (right_comp P g) f

/- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma. -/

theorem comp_neg_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q)
    (g : Q ⟶ R) {X' : C} (f' : R ⟶ X') : f ≫ (-g) ≫ f' = (-f ≫ g) ≫ f' :=
  sorry

theorem neg_comp_neg {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q)
    (g : Q ⟶ R) : (-f) ≫ (-g) = f ≫ g :=
  sorry

theorem comp_sum {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} {J : Type u_1}
    {s : finset J} (f : P ⟶ Q) (g : J → (Q ⟶ R)) :
    (f ≫ finset.sum s fun (j : J) => g j) = finset.sum s fun (j : J) => f ≫ g j :=
  sorry

theorem sum_comp_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    {J : Type u_1} {s : finset J} (f : J → (P ⟶ Q)) (g : Q ⟶ R) {X' : C} (f' : R ⟶ X') :
    finset.sum s f ≫ g ≫ f' = (finset.sum s fun (j : J) => f j ≫ g) ≫ f' :=
  sorry

protected instance has_neg.neg.category_theory.epi {C : Type u} [category C] [preadditive C] {P : C}
    {Q : C} {f : P ⟶ Q} [epi f] : epi (-f) :=
  epi.mk
    fun (R : C) (g g' : Q ⟶ R) (H : (-f) ≫ g = (-f) ≫ g') =>
      eq.mp (Eq._oldrec (Eq.refl (-g = -g')) (propext neg_inj))
        (eq.mp (Eq._oldrec (Eq.refl (f ≫ (-g) = f ≫ (-g'))) (propext (cancel_epi f)))
          (eq.mp (Eq._oldrec (Eq.refl (f ≫ (-g) = -f ≫ g')) (Eq.symm (comp_neg f g')))
            (eq.mp (Eq._oldrec (Eq.refl (-f ≫ g = -f ≫ g')) (Eq.symm (comp_neg f g)))
              (eq.mp (Eq._oldrec (Eq.refl (-f ≫ g = (-f) ≫ g')) (neg_comp f g'))
                (eq.mp (Eq._oldrec (Eq.refl ((-f) ≫ g = (-f) ≫ g')) (neg_comp f g)) H)))))

protected instance has_neg.neg.category_theory.mono {C : Type u} [category C] [preadditive C]
    {P : C} {Q : C} {f : P ⟶ Q} [mono f] : mono (-f) :=
  mono.mk
    fun (R : C) (g g' : R ⟶ P) (H : g ≫ (-f) = g' ≫ (-f)) =>
      eq.mp (Eq._oldrec (Eq.refl (-g = -g')) (propext neg_inj))
        (eq.mp (Eq._oldrec (Eq.refl ((-g) ≫ f = (-g') ≫ f)) (propext (cancel_mono f)))
          (eq.mp (Eq._oldrec (Eq.refl ((-g) ≫ f = -g' ≫ f)) (Eq.symm (neg_comp g' f)))
            (eq.mp (Eq._oldrec (Eq.refl (-g ≫ f = -g' ≫ f)) (Eq.symm (neg_comp g f)))
              (eq.mp (Eq._oldrec (Eq.refl (-g ≫ f = g' ≫ (-f))) (comp_neg g' f))
                (eq.mp (Eq._oldrec (Eq.refl (g ≫ (-f) = g' ≫ (-f))) (comp_neg g f)) H)))))

protected instance preadditive_has_zero_morphisms {C : Type u} [category C] [preadditive C] :
    limits.has_zero_morphisms C :=
  limits.has_zero_morphisms.mk

theorem mono_of_cancel_zero {C : Type u} [category C] [preadditive C] {Q : C} {R : C} (f : Q ⟶ R)
    (h : ∀ {P : C} (g : P ⟶ Q), g ≫ f = 0 → g = 0) : mono f :=
  mono.mk
    fun (P : C) (g g' : P ⟶ Q) (hg : g ≫ f = g' ≫ f) =>
      iff.mp sub_eq_zero
        (h (g - g')
          (Eq.trans (add_monoid_hom.map_sub (right_comp P f) g g') (iff.mpr sub_eq_zero hg)))

theorem mono_iff_cancel_zero {C : Type u} [category C] [preadditive C] {Q : C} {R : C} (f : Q ⟶ R) :
    mono f ↔ ∀ (P : C) (g : P ⟶ Q), g ≫ f = 0 → g = 0 :=
  { mp := fun (m : mono f) (P : C) (g : P ⟶ Q) => limits.zero_of_comp_mono f,
    mpr := mono_of_cancel_zero f }

theorem mono_of_kernel_zero {C : Type u} [category C] [preadditive C] {X : C} {Y : C} {f : X ⟶ Y}
    [limits.has_limit (limits.parallel_pair f 0)] (w : limits.kernel.ι f = 0) : mono f :=
  sorry

theorem epi_of_cancel_zero {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (f : P ⟶ Q)
    (h : ∀ {R : C} (g : Q ⟶ R), f ≫ g = 0 → g = 0) : epi f :=
  epi.mk
    fun (R : C) (g g' : Q ⟶ R) (hg : f ≫ g = f ≫ g') =>
      iff.mp sub_eq_zero
        (h (g - g')
          (Eq.trans (add_monoid_hom.map_sub (left_comp R f) g g') (iff.mpr sub_eq_zero hg)))

theorem epi_iff_cancel_zero {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (f : P ⟶ Q) :
    epi f ↔ ∀ (R : C) (g : Q ⟶ R), f ≫ g = 0 → g = 0 :=
  { mp := fun (e : epi f) (R : C) (g : Q ⟶ R) => limits.zero_of_epi_comp f,
    mpr := epi_of_cancel_zero f }

theorem epi_of_cokernel_zero {C : Type u} [category C] [preadditive C] {X : C} {Y : C} (f : X ⟶ Y)
    [limits.has_colimit (limits.parallel_pair f 0)] (w : limits.cokernel.π f = 0) : epi f :=
  sorry

end preadditive

/-- A kernel of `f - g` is an equalizer of `f` and `g`. -/
theorem preadditive.has_limit_parallel_pair {C : Type u} [category C] [preadditive C] {X : C}
    {Y : C} (f : X ⟶ Y) (g : X ⟶ Y) [limits.has_kernel (f - g)] :
    limits.has_limit (limits.parallel_pair f g) :=
  sorry

/-- If a preadditive category has all kernels, then it also has all equalizers. -/
theorem preadditive.has_equalizers_of_has_kernels {C : Type u} [category C] [preadditive C]
    [limits.has_kernels C] : limits.has_equalizers C :=
  limits.has_equalizers_of_has_limit_parallel_pair C

/-- A cokernel of `f - g` is a coequalizer of `f` and `g`. -/
theorem preadditive.has_colimit_parallel_pair {C : Type u} [category C] [preadditive C] {X : C}
    {Y : C} (f : X ⟶ Y) (g : X ⟶ Y) [limits.has_cokernel (f - g)] :
    limits.has_colimit (limits.parallel_pair f g) :=
  sorry

/-- If a preadditive category has all cokernels, then it also has all coequalizers. -/
theorem preadditive.has_coequalizers_of_has_cokernels {C : Type u} [category C] [preadditive C]
    [limits.has_cokernels C] : limits.has_coequalizers C :=
  limits.has_coequalizers_of_has_colimit_parallel_pair C

end Mathlib


/-
Copyright (c) 2014 Robert Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Lewis, Leonardo de Moura, Mario Carneiro, Floris van Doorn

! This file was ported from Lean 3 source module algebra.order.field.canonical.basic
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.Field.Canonical.Defs

/-!
# Lemmas about canonically ordered semifields.

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

-/

variable {α : Type _}

section CanonicallyLinearOrderedSemifield

variable [CanonicallyLinearOrderedSemifield α] [Sub α] [OrderedSub α]

/- warning: tsub_div -> tsub_div is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CanonicallyLinearOrderedSemifield.{u1} α] [_inst_2 : Sub.{u1} α] [_inst_3 : OrderedSub.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedCancelAddCommMonoid.toPartialOrder.{u1} α (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1)))))))) (Distrib.toHasAdd.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} α (Semiring.toNonAssocSemiring.{u1} α (StrictOrderedSemiring.toSemiring.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))))) _inst_2] (a : α) (b : α) (c : α), Eq.{succ u1} α (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (DivInvMonoid.toHasDiv.{u1} α (GroupWithZero.toDivInvMonoid.{u1} α (DivisionSemiring.toGroupWithZero.{u1} α (Semifield.toDivisionSemiring.{u1} α (LinearOrderedSemifield.toSemifield.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) a b) c) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (DivInvMonoid.toHasDiv.{u1} α (GroupWithZero.toDivInvMonoid.{u1} α (DivisionSemiring.toGroupWithZero.{u1} α (Semifield.toDivisionSemiring.{u1} α (LinearOrderedSemifield.toSemifield.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) a c) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (DivInvMonoid.toHasDiv.{u1} α (GroupWithZero.toDivInvMonoid.{u1} α (DivisionSemiring.toGroupWithZero.{u1} α (Semifield.toDivisionSemiring.{u1} α (LinearOrderedSemifield.toSemifield.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) b c))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CanonicallyLinearOrderedSemifield.{u1} α] [_inst_2 : Sub.{u1} α] [_inst_3 : OrderedSub.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (StrictOrderedSemiring.toPartialOrder.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) (Distrib.toAdd.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} α (Semiring.toNonAssocSemiring.{u1} α (StrictOrderedSemiring.toSemiring.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))))) _inst_2] (a : α) (b : α) (c : α), Eq.{succ u1} α (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (CanonicallyLinearOrderedSemifield.toDiv.{u1} α _inst_1)) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) a b) c) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (CanonicallyLinearOrderedSemifield.toDiv.{u1} α _inst_1)) a c) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (CanonicallyLinearOrderedSemifield.toDiv.{u1} α _inst_1)) b c))
Case conversion may be inaccurate. Consider using '#align tsub_div tsub_divₓ'. -/
theorem tsub_div (a b c : α) : (a - b) / c = a / c - b / c := by simp_rw [div_eq_mul_inv, tsub_mul]
#align tsub_div tsub_div

end CanonicallyLinearOrderedSemifield


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import algebra.hom.group_instances
import topology.algebra.uniform_group
import topology.uniform_space.completion

/-!
# Multiplicative action on the completion of a uniform space

In this file we define typeclasses `has_uniform_continuous_const_vadd` and
`has_uniform_continuous_const_smul` and prove that a multiplicative action on `X` with uniformly
continuous `(•) c` can be extended to a multiplicative action on `uniform_space.completion X`.

In later files once the additive group structure is set up, we provide
* `uniform_space.completion.distrib_mul_action`
* `uniform_space.completion.mul_action_with_zero`
* `uniform_space.completion.module`
-/

universes u v w x y z

noncomputable theory

variables (R : Type u) (M : Type v) (N : Type w) (X : Type x) (Y : Type y)
  [uniform_space X] [uniform_space Y]

/-- An additive action such that for all `c`, the map `λ x, c +ᵥ x` is uniformly continuous. -/
class has_uniform_continuous_const_vadd [uniform_space X] [has_vadd M X] : Prop :=
(uniform_continuous_const_vadd : ∀ (c : M), uniform_continuous ((+ᵥ) c : X → X))

/-- A multiplicative action such that for all `c`, the map `λ x, c • x` is uniformly continuous. -/
@[to_additive]
class has_uniform_continuous_const_smul [uniform_space X] [has_scalar M X] : Prop :=
(uniform_continuous_const_smul : ∀ (c : M), uniform_continuous ((•) c : X → X))

export has_uniform_continuous_const_vadd (uniform_continuous_const_vadd)
  has_uniform_continuous_const_smul (uniform_continuous_const_smul)

instance add_monoid.has_uniform_continuous_const_smul_nat [add_group X] [uniform_add_group X] :
  has_uniform_continuous_const_smul ℕ X :=
⟨uniform_continuous_const_nsmul⟩

instance add_group.has_uniform_continuous_const_smul_int [add_group X] [uniform_add_group X] :
  has_uniform_continuous_const_smul ℤ X :=
⟨uniform_continuous_const_zsmul⟩

section has_scalar

variable [has_scalar M X]

@[priority 100, to_additive]
instance has_uniform_continuous_const_smul.to_has_continuous_const_smul
  [has_uniform_continuous_const_smul M X] : has_continuous_const_smul M X :=
⟨λ c, (uniform_continuous_const_smul c).continuous⟩

variables {M X Y}

@[to_additive] lemma uniform_continuous.const_smul [has_uniform_continuous_const_smul M X]
  {f : Y → X} (hf : uniform_continuous f) (c : M) :
  uniform_continuous (c • f) :=
(uniform_continuous_const_smul c).comp hf

/-- If a scalar is central, then its right action is uniform continuous when its left action is. -/
@[priority 100]
instance has_uniform_continuous_const_smul.op [has_scalar Mᵐᵒᵖ X] [is_central_scalar M X]
  [has_uniform_continuous_const_smul M X] : has_uniform_continuous_const_smul Mᵐᵒᵖ X :=
⟨mul_opposite.rec $ λ c, begin
  change uniform_continuous (λ m, mul_opposite.op c • m),
  simp_rw op_smul_eq_smul,
  exact uniform_continuous_const_smul c,
end⟩

@[to_additive] instance mul_opposite.has_uniform_continuous_const_smul
  [has_uniform_continuous_const_smul M X] : has_uniform_continuous_const_smul M Xᵐᵒᵖ :=
⟨λ c, mul_opposite.uniform_continuous_op.comp $ mul_opposite.uniform_continuous_unop.const_smul c⟩

end has_scalar

@[to_additive] instance uniform_group.to_has_uniform_continuous_const_smul
  {G : Type u} [group G] [uniform_space G] [uniform_group G] :
  has_uniform_continuous_const_smul G G :=
⟨λ c, uniform_continuous_const.mul uniform_continuous_id⟩

namespace uniform_space

namespace completion

section has_scalar

variable [has_scalar M X]

@[to_additive has_vadd] instance : has_scalar M (completion X) :=
⟨λ c, completion.map ((•) c)⟩

@[to_additive] instance : has_uniform_continuous_const_smul M (completion X) :=
⟨λ c, uniform_continuous_map⟩

instance [has_scalar Mᵐᵒᵖ X] [is_central_scalar M X] : is_central_scalar M (completion X) :=
⟨λ c a, congr_arg (λ f, completion.map f a) $ by exact funext (op_smul_eq_smul c)⟩

variables {M X} [has_uniform_continuous_const_smul M X]

@[simp, norm_cast, to_additive]

end has_scalar

@[to_additive] instance [monoid M] [mul_action M X] [has_uniform_continuous_const_smul M X] :
  mul_action M (completion X) :=
{ smul := (•),
  one_smul := ext' (continuous_const_smul _) continuous_id $ λ a, by rw [← coe_smul, one_smul],
  mul_smul := λ x y, ext' (continuous_const_smul _) ((continuous_const_smul _).const_smul _) $
    λ a, by simp only [← coe_smul, mul_smul] }

end completion

end uniform_space


import Advent

inductive DDigit (base: Nat)
  | Z
  | DP (d: Fin base)
  | DN (d: Fin base)
deriving Repr, BEq, Inhabited

instance {base}: ToString (DDigit base) where
  toString
  | .Z => "0"
  | .DP x => toString <| (x : Nat) + 1
  | .DN x => "-" ++ (toString <| (x : Nat) + 1)

def DoubleSys base := Array (DDigit base)
namespace DoubleSys
  instance {base}: BEq (DoubleSys base) where beq (x: Array _) y := x == y
  instance {base}: Inhabited (DoubleSys base) where default := Array.empty
  instance {base}: ToString (DoubleSys base) where
    toString := Array.foldl (·.append <| char · |> (·.push '|')) ""
  where
    char
    | .Z => "0"
    | .DP d => s!"{d.succ}"
    | .DN d => s!"-{d.succ}"

  instance {base}: Coe (DoubleSys base) Nat where
    coe := Array.foldl addDig 0
  where
    base' := base * 2 + 1
    addDig n
    | .Z => n * base'
    | .DP d => n * base' + d + 1
    | .DN d => n * base' - d - 1

  private theorem doubleLe: b > 0 -> a < b * 2 -> ¬ (a < b) -> b * 2 - 1 - a < b := by
    intros u p q
    rw [<-Nat.sub_add_eq]
    have p₂: b = b * 2 - b := by
      rw [Nat.mul_add b 1 1]
      simp
    conv => rhs; rw [p₂]
    apply Nat.sub_lt_sub_left
    . apply Nat.lt_add_of_pos_left
      simp
      assumption
    . apply Nat.lt_of_not_le
      intro p
      apply q
      apply Nat.lt_of_succ_le
      rw [Nat.add_comm] at p
      assumption

  instance {base}: Coe Nat (DoubleSys base) where
    coe x := go Array.empty x x
  where
    go acc x
    | 0 => acc.reverse
    | fuel + 1 =>
      let base' := base * 2 + 1
      if x == 0 then acc.reverse else
      let r := x % base'
      let x' := x / base'
      let d := match q: r with
        | 0 => DDigit.Z
        | r' + 1 =>
          if p: r' < base then DDigit.DP ⟨ r', p ⟩
          else
            let r'' := base * 2 - 1 - r'
            DDigit.DN <| Fin.mk r'' <| by
              apply doubleLe
              . apply Nat.lt_of_not_le
                intro p₂
                rw [Nat.le_zero] at p₂
                have bq: base' = base * 2 + 1 := Eq.refl _
                conv at bq =>
                  rw [p₂]
                  rhs
                  simp
                have rp: r = x % base' := Eq.refl _
                have rp₂ : x % base' < 1 := by
                  rw [<-bq]
                  apply Nat.mod_lt
                  apply Nat.zero_lt_of_ne_zero
                  simp
                rw [←rp, q] at rp₂
                contradiction
              . apply Nat.lt_of_succ_le
                rw [<-q]
                apply Nat.le_of_lt_succ
                have qq: base' = (base * 2).succ := by simp
                rw [<-qq]
                have qqq: r = x % base' := by simp
                rw [qqq]
                apply Nat.mod_lt
                rw [qq]
                apply Nat.zero_lt_succ
              . assumption
      let x := if let .DN _ := d then x' + 1 else x'
      go (acc.push d) x fuel

end DoubleSys

abbrev SNAFU := DoubleSys 2

def readSnafu (s: String): Option SNAFU :=
  s.toList.toArray.mapM go
where
  go: Char -> Option (DDigit 2)
  | '-' => some <| DDigit.DN 0
  | '=' => some <| DDigit.DN 1
  | '0' => some <| DDigit.Z
  | '1' => some <| DDigit.DP 0
  | '2' => some <| DDigit.DP 1
  | _   => none

def writeSnafu : SNAFU -> String :=
  String.mk ∘ Array.toList ∘ Array.map toChar
where
  toChar
  | DDigit.DN 0 => '-'
  | DDigit.DN 1 => '='
  | DDigit.Z => '0'
  | DDigit.DP 0 => '1'
  | DDigit.DP 1 => '2'

def main: IO Unit := do
  let lines <- readLines 25
  let snafus := (lines.mapM readSnafu).get!
  snafus.forM IO.println
  let nats: List Nat := snafus.map <| λ (x: SNAFU) => ↑x
  nats.forM IO.println
  let back := nats.map (fun (x: Nat) => (x: SNAFU))
  if back == snafus then IO.println "OK!"
  let s := nats.sum
  IO.println s
  IO.println <| writeSnafu s


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.geom_sum
import Mathlib.order.filter.archimedean
import Mathlib.order.iterate
import Mathlib.topology.instances.ennreal
import Mathlib.tactic.ring_exp
import Mathlib.analysis.asymptotics
import Mathlib.PostPort

universes u_1 u_4

namespace Mathlib

/-!
# A collection of specific limit computations
-/

theorem tendsto_norm_at_top_at_top : filter.tendsto norm filter.at_top filter.at_top :=
  filter.tendsto_abs_at_top_at_top

theorem summable_of_absolute_convergence_real {f : ℕ → ℝ} : (∃ (r : ℝ),
    filter.tendsto (fun (n : ℕ) => finset.sum (finset.range n) fun (i : ℕ) => abs (f i)) filter.at_top (nhds r)) →
  summable f := sorry

theorem tendsto_inverse_at_top_nhds_0_nat : filter.tendsto (fun (n : ℕ) => ↑n⁻¹) filter.at_top (nhds 0) :=
  filter.tendsto.comp tendsto_inv_at_top_zero tendsto_coe_nat_at_top_at_top

theorem tendsto_const_div_at_top_nhds_0_nat (C : ℝ) : filter.tendsto (fun (n : ℕ) => C / ↑n) filter.at_top (nhds 0) := sorry

theorem nnreal.tendsto_inverse_at_top_nhds_0_nat : filter.tendsto (fun (n : ℕ) => ↑n⁻¹) filter.at_top (nhds 0) := sorry

theorem nnreal.tendsto_const_div_at_top_nhds_0_nat (C : nnreal) : filter.tendsto (fun (n : ℕ) => C / ↑n) filter.at_top (nhds 0) := sorry

theorem tendsto_one_div_add_at_top_nhds_0_nat : filter.tendsto (fun (n : ℕ) => 1 / (↑n + 1)) filter.at_top (nhds 0) := sorry

/-! ### Powers -/

theorem tendsto_add_one_pow_at_top_at_top_of_pos {α : Type u_1} [linear_ordered_semiring α] [archimedean α] {r : α} (h : 0 < r) : filter.tendsto (fun (n : ℕ) => (r + 1) ^ n) filter.at_top filter.at_top :=
  filter.tendsto_at_top_at_top_of_monotone' (fun (n m : ℕ) => pow_le_pow (le_add_of_nonneg_left (le_of_lt h)))
    (iff.mpr not_bdd_above_iff fun (x : α) => iff.mpr set.exists_range_iff (add_one_pow_unbounded_of_pos x h))

theorem tendsto_pow_at_top_at_top_of_one_lt {α : Type u_1} [linear_ordered_ring α] [archimedean α] {r : α} (h : 1 < r) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top filter.at_top :=
  sub_add_cancel r 1 ▸ tendsto_add_one_pow_at_top_at_top_of_pos (iff.mpr sub_pos h)

theorem nat.tendsto_pow_at_top_at_top_of_one_lt {m : ℕ} (h : 1 < m) : filter.tendsto (fun (n : ℕ) => m ^ n) filter.at_top filter.at_top :=
  nat.sub_add_cancel (le_of_lt h) ▸ tendsto_add_one_pow_at_top_at_top_of_pos (nat.sub_pos_of_lt h)

theorem tendsto_norm_zero' {𝕜 : Type u_1} [normed_group 𝕜] : filter.tendsto norm (nhds_within 0 (set_of fun (x : 𝕜) => x ≠ 0)) (nhds_within 0 (set.Ioi 0)) :=
  filter.tendsto.inf tendsto_norm_zero
    (iff.mpr filter.tendsto_principal_principal
      fun (x : 𝕜) (hx : x ∈ set_of fun (x : 𝕜) => x ≠ 0) => iff.mpr norm_pos_iff hx)

theorem normed_field.tendsto_norm_inverse_nhds_within_0_at_top {𝕜 : Type u_1} [normed_field 𝕜] : filter.tendsto (fun (x : 𝕜) => norm (x⁻¹)) (nhds_within 0 (set_of fun (x : 𝕜) => x ≠ 0)) filter.at_top :=
  filter.tendsto.congr (fun (x : 𝕜) => Eq.symm (normed_field.norm_inv x))
    (filter.tendsto.comp tendsto_inv_zero_at_top tendsto_norm_zero')

theorem tendsto_pow_at_top_nhds_0_of_lt_1 {𝕜 : Type u_1} [linear_ordered_field 𝕜] [archimedean 𝕜] [topological_space 𝕜] [order_topology 𝕜] {r : 𝕜} (h₁ : 0 ≤ r) (h₂ : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) := sorry

theorem tendsto_pow_at_top_nhds_within_0_of_lt_1 {𝕜 : Type u_1} [linear_ordered_field 𝕜] [archimedean 𝕜] [topological_space 𝕜] [order_topology 𝕜] {r : 𝕜} (h₁ : 0 < r) (h₂ : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds_within 0 (set.Ioi 0)) :=
  iff.mpr filter.tendsto_inf
    { left := tendsto_pow_at_top_nhds_0_of_lt_1 (has_lt.lt.le h₁) h₂,
      right := iff.mpr filter.tendsto_principal (filter.eventually_of_forall fun (n : ℕ) => pow_pos h₁ n) }

theorem is_o_pow_pow_of_lt_left {r₁ : ℝ} {r₂ : ℝ} (h₁ : 0 ≤ r₁) (h₂ : r₁ < r₂) : asymptotics.is_o (fun (n : ℕ) => r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top := sorry

theorem is_O_pow_pow_of_le_left {r₁ : ℝ} {r₂ : ℝ} (h₁ : 0 ≤ r₁) (h₂ : r₁ ≤ r₂) : asymptotics.is_O (fun (n : ℕ) => r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top :=
  or.elim (has_le.le.eq_or_lt h₂) (fun (h : r₁ = r₂) => h ▸ asymptotics.is_O_refl (fun (n : ℕ) => r₁ ^ n) filter.at_top)
    fun (h : r₁ < r₂) => asymptotics.is_o.is_O (is_o_pow_pow_of_lt_left h₁ h)

theorem is_o_pow_pow_of_abs_lt_left {r₁ : ℝ} {r₂ : ℝ} (h : abs r₁ < abs r₂) : asymptotics.is_o (fun (n : ℕ) => r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top :=
  asymptotics.is_o.of_norm_right
    (asymptotics.is_o.of_norm_left
      (asymptotics.is_o.congr (pow_abs r₁) (pow_abs r₂) (is_o_pow_pow_of_lt_left (abs_nonneg r₁) h)))

/-- Various statements equivalent to the fact that `f n` grows exponentially slower than `R ^ n`.

* 0: $f n = o(a ^ n)$ for some $-R < a < R$;
* 1: $f n = o(a ^ n)$ for some $0 < a < R$;
* 2: $f n = O(a ^ n)$ for some $-R < a < R$;
* 3: $f n = O(a ^ n)$ for some $0 < a < R$;
* 4: there exist `a < R` and `C` such that one of `C` and `R` is positive and $|f n| ≤ Ca^n$
     for all `n`;
* 5: there exists `0 < a < R` and a positive `C` such that $|f n| ≤ Ca^n$ for all `n`;
* 6: there exists `a < R` such that $|f n| ≤ a ^ n$ for sufficiently large `n`;
* 7: there exists `0 < a < R` such that $|f n| ≤ a ^ n$ for sufficiently large `n`.

NB: For backwards compatibility, if you add more items to the list, please append them at the end of
the list. -/
theorem tfae_exists_lt_is_o_pow (f : ℕ → ℝ) (R : ℝ) : tfae
  [∃ (a : ℝ), ∃ (H : a ∈ set.Ioo (-R) R), asymptotics.is_o f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), asymptotics.is_o f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo (-R) R), asymptotics.is_O f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), asymptotics.is_O f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a < R), ∃ (C : ℝ), ∃ (h₀ : 0 < C ∨ 0 < R), ∀ (n : ℕ), abs (f n) ≤ C * a ^ n,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), ∃ (C : ℝ), ∃ (H : C > 0), ∀ (n : ℕ), abs (f n) ≤ C * a ^ n,
    ∃ (a : ℝ), ∃ (H : a < R), filter.eventually (fun (n : ℕ) => abs (f n) ≤ a ^ n) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), filter.eventually (fun (n : ℕ) => abs (f n) ≤ a ^ n) filter.at_top] := sorry

theorem uniformity_basis_dist_pow_of_lt_1 {α : Type u_1} [metric_space α] {r : ℝ} (h₀ : 0 < r) (h₁ : r < 1) : filter.has_basis (uniformity α) (fun (k : ℕ) => True)
  fun (k : ℕ) => set_of fun (p : α × α) => dist (prod.fst p) (prod.snd p) < r ^ k :=
  metric.mk_uniformity_basis (fun (i : ℕ) (_x : True) => pow_pos h₀ i)
    fun (ε : ℝ) (ε0 : 0 < ε) =>
      Exists.imp (fun (k : ℕ) (hk : r ^ k < ε) => Exists.intro trivial (has_lt.lt.le hk)) (exists_pow_lt_of_lt_one ε0 h₁)

theorem geom_lt {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) {n : ℕ} (hn : 0 < n) (h : ∀ (k : ℕ), k < n → c * u k < u (k + 1)) : c ^ n * u 0 < u n := sorry

theorem geom_le {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) (n : ℕ) (h : ∀ (k : ℕ), k < n → c * u k ≤ u (k + 1)) : c ^ n * u 0 ≤ u n := sorry

/-- For any natural `k` and a real `r > 1` we have `n ^ k = o(r ^ n)` as `n → ∞`. -/
theorem is_o_pow_const_const_pow_of_one_lt {R : Type u_1} [normed_ring R] (k : ℕ) {r : ℝ} (hr : 1 < r) : asymptotics.is_o (fun (n : ℕ) => ↑n ^ k) (fun (n : ℕ) => r ^ n) filter.at_top := sorry

/-- For a real `r > 1` we have `n = o(r ^ n)` as `n → ∞`. -/
theorem is_o_coe_const_pow_of_one_lt {R : Type u_1} [normed_ring R] {r : ℝ} (hr : 1 < r) : asymptotics.is_o coe (fun (n : ℕ) => r ^ n) filter.at_top := sorry

/-- If `∥r₁∥ < r₂`, then for any naturak `k` we have `n ^ k r₁ ^ n = o (r₂ ^ n)` as `n → ∞`. -/
theorem is_o_pow_const_mul_const_pow_const_pow_of_norm_lt {R : Type u_1} [normed_ring R] (k : ℕ) {r₁ : R} {r₂ : ℝ} (h : norm r₁ < r₂) : asymptotics.is_o (fun (n : ℕ) => ↑n ^ k * r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top := sorry

theorem tendsto_pow_const_div_const_pow_of_one_lt (k : ℕ) {r : ℝ} (hr : 1 < r) : filter.tendsto (fun (n : ℕ) => ↑n ^ k / r ^ n) filter.at_top (nhds 0) :=
  asymptotics.is_o.tendsto_0 (is_o_pow_const_const_pow_of_one_lt k hr)

/-- If `|r| < 1`, then `n ^ k r ^ n` tends to zero for any natural `k`. -/
theorem tendsto_pow_const_mul_const_pow_of_abs_lt_one (k : ℕ) {r : ℝ} (hr : abs r < 1) : filter.tendsto (fun (n : ℕ) => ↑n ^ k * r ^ n) filter.at_top (nhds 0) := sorry

/-- If a sequence `v` of real numbers satisfies `k * v n ≤ v (n+1)` with `1 < k`,
then it goes to +∞. -/
theorem tendsto_at_top_of_geom_le {v : ℕ → ℝ} {c : ℝ} (h₀ : 0 < v 0) (hc : 1 < c) (hu : ∀ (n : ℕ), c * v n ≤ v (n + 1)) : filter.tendsto v filter.at_top filter.at_top :=
  filter.tendsto_at_top_mono
    (fun (n : ℕ) => geom_le (has_le.le.trans zero_le_one (has_lt.lt.le hc)) n fun (k : ℕ) (hk : k < n) => hu k)
    (filter.tendsto.at_top_mul_const h₀ (tendsto_pow_at_top_at_top_of_one_lt hc))

theorem nnreal.tendsto_pow_at_top_nhds_0_of_lt_1 {r : nnreal} (hr : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) := sorry

theorem ennreal.tendsto_pow_at_top_nhds_0_of_lt_1 {r : ennreal} (hr : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) := sorry

/-- In a normed ring, the powers of an element x with `∥x∥ < 1` tend to zero. -/
theorem tendsto_pow_at_top_nhds_0_of_norm_lt_1 {R : Type u_1} [normed_ring R] {x : R} (h : norm x < 1) : filter.tendsto (fun (n : ℕ) => x ^ n) filter.at_top (nhds 0) :=
  squeeze_zero_norm' (eventually_norm_pow_le x) (tendsto_pow_at_top_nhds_0_of_lt_1 (norm_nonneg x) h)

theorem tendsto_pow_at_top_nhds_0_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) :=
  tendsto_pow_at_top_nhds_0_of_norm_lt_1 h

/-! ### Geometric series-/

theorem has_sum_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : has_sum (fun (n : ℕ) => r ^ n) (1 - r⁻¹) := sorry

theorem summable_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : summable fun (n : ℕ) => r ^ n :=
  Exists.intro (1 - r⁻¹) (has_sum_geometric_of_lt_1 h₁ h₂)

theorem tsum_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) :=
  has_sum.tsum_eq (has_sum_geometric_of_lt_1 h₁ h₂)

theorem has_sum_geometric_two : has_sum (fun (n : ℕ) => (1 / bit0 1) ^ n) (bit0 1) := sorry

theorem summable_geometric_two : summable fun (n : ℕ) => (1 / bit0 1) ^ n :=
  Exists.intro (bit0 1) has_sum_geometric_two

theorem tsum_geometric_two : (tsum fun (n : ℕ) => (1 / bit0 1) ^ n) = bit0 1 :=
  has_sum.tsum_eq has_sum_geometric_two

theorem sum_geometric_two_le (n : ℕ) : (finset.sum (finset.range n) fun (i : ℕ) => (1 / bit0 1) ^ i) ≤ bit0 1 := sorry

theorem has_sum_geometric_two' (a : ℝ) : has_sum (fun (n : ℕ) => a / bit0 1 / bit0 1 ^ n) a := sorry

theorem summable_geometric_two' (a : ℝ) : summable fun (n : ℕ) => a / bit0 1 / bit0 1 ^ n :=
  Exists.intro a (has_sum_geometric_two' a)

theorem tsum_geometric_two' (a : ℝ) : (tsum fun (n : ℕ) => a / bit0 1 / bit0 1 ^ n) = a :=
  has_sum.tsum_eq (has_sum_geometric_two' a)

theorem nnreal.has_sum_geometric {r : nnreal} (hr : r < 1) : has_sum (fun (n : ℕ) => r ^ n) (1 - r⁻¹) := sorry

theorem nnreal.summable_geometric {r : nnreal} (hr : r < 1) : summable fun (n : ℕ) => r ^ n :=
  Exists.intro (1 - r⁻¹) (nnreal.has_sum_geometric hr)

theorem tsum_geometric_nnreal {r : nnreal} (hr : r < 1) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) :=
  has_sum.tsum_eq (nnreal.has_sum_geometric hr)

/-- The series `pow r` converges to `(1-r)⁻¹`. For `r < 1` the RHS is a finite number,
and for `1 ≤ r` the RHS equals `∞`. -/
theorem ennreal.tsum_geometric (r : ennreal) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) := sorry

theorem has_sum_geometric_of_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} (h : norm ξ < 1) : has_sum (fun (n : ℕ) => ξ ^ n) (1 - ξ⁻¹) := sorry

theorem summable_geometric_of_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} (h : norm ξ < 1) : summable fun (n : ℕ) => ξ ^ n :=
  Exists.intro (1 - ξ⁻¹) (has_sum_geometric_of_norm_lt_1 h)

theorem tsum_geometric_of_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} (h : norm ξ < 1) : (tsum fun (n : ℕ) => ξ ^ n) = (1 - ξ⁻¹) :=
  has_sum.tsum_eq (has_sum_geometric_of_norm_lt_1 h)

theorem has_sum_geometric_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : has_sum (fun (n : ℕ) => r ^ n) (1 - r⁻¹) :=
  has_sum_geometric_of_norm_lt_1 h

theorem summable_geometric_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : summable fun (n : ℕ) => r ^ n :=
  summable_geometric_of_norm_lt_1 h

theorem tsum_geometric_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) :=
  tsum_geometric_of_norm_lt_1 h

/-- A geometric series in a normed field is summable iff the norm of the common ratio is less than
one. -/
@[simp] theorem summable_geometric_iff_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} : (summable fun (n : ℕ) => ξ ^ n) ↔ norm ξ < 1 := sorry

theorem summable_norm_pow_mul_geometric_of_norm_lt_1 {R : Type u_1} [normed_ring R] (k : ℕ) {r : R} (hr : norm r < 1) : summable fun (n : ℕ) => norm (↑n ^ k * r ^ n) := sorry

theorem summable_pow_mul_geometric_of_norm_lt_1 {R : Type u_1} [normed_ring R] [complete_space R] (k : ℕ) {r : R} (hr : norm r < 1) : summable fun (n : ℕ) => ↑n ^ k * r ^ n :=
  summable_of_summable_norm (summable_norm_pow_mul_geometric_of_norm_lt_1 k hr)

/-- If `∥r∥ < 1`, then `∑' n : ℕ, n * r ^ n = r / (1 - r) ^ 2`, `has_sum` version. -/
theorem has_sum_coe_mul_geometric_of_norm_lt_1 {𝕜 : Type u_1} [normed_field 𝕜] [complete_space 𝕜] {r : 𝕜} (hr : norm r < 1) : has_sum (fun (n : ℕ) => ↑n * r ^ n) (r / (1 - r) ^ bit0 1) := sorry

/-- If `∥r∥ < 1`, then `∑' n : ℕ, n * r ^ n = r / (1 - r) ^ 2`. -/
theorem tsum_coe_mul_geometric_of_norm_lt_1 {𝕜 : Type u_1} [normed_field 𝕜] [complete_space 𝕜] {r : 𝕜} (hr : norm r < 1) : (tsum fun (n : ℕ) => ↑n * r ^ n) = r / (1 - r) ^ bit0 1 :=
  has_sum.tsum_eq (has_sum_coe_mul_geometric_of_norm_lt_1 hr)

/-!
### Sequences with geometrically decaying distance in metric spaces

In this paragraph, we discuss sequences in metric spaces or emetric spaces for which the distance
between two consecutive terms decays geometrically. We show that such sequences are Cauchy
sequences, and bound their distances to the limit. We also discuss series with geometrically
decaying terms.
-/

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, `C ≠ ∞`, `r < 1`,
then `f` is a Cauchy sequence.-/
theorem cauchy_seq_of_edist_le_geometric {α : Type u_1} [emetric_space α] (r : ennreal) (C : ennreal) (hr : r < 1) (hC : C ≠ ⊤) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C * r ^ n) : cauchy_seq f := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, then the distance from
`f n` to the limit of `f` is bounded above by `C * r^n / (1 - r)`. -/
theorem edist_le_of_edist_le_geometric_of_tendsto {α : Type u_1} [emetric_space α] (r : ennreal) (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : edist (f n) a ≤ C * r ^ n / (1 - r) := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, then the distance from
`f 0` to the limit of `f` is bounded above by `C / (1 - r)`. -/
theorem edist_le_of_edist_le_geometric_of_tendsto₀ {α : Type u_1} [emetric_space α] (r : ennreal) (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : edist (f 0) a ≤ C / (1 - r) := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then `f` is a Cauchy sequence.-/
theorem cauchy_seq_of_edist_le_geometric_two {α : Type u_1} [emetric_space α] (C : ennreal) (hC : C ≠ ⊤) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C / bit0 1 ^ n) : cauchy_seq f := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then the distance from
`f n` to the limit of `f` is bounded above by `2 * C * 2^-n`. -/
theorem edist_le_of_edist_le_geometric_two_of_tendsto {α : Type u_1} [emetric_space α] (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : edist (f n) a ≤ bit0 1 * C / bit0 1 ^ n := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then the distance from
`f 0` to the limit of `f` is bounded above by `2 * C`. -/
theorem edist_le_of_edist_le_geometric_two_of_tendsto₀ {α : Type u_1} [emetric_space α] (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : edist (f 0) a ≤ bit0 1 * C := sorry

theorem aux_has_sum_of_le_geometric {α : Type u_1} [metric_space α] {r : ℝ} {C : ℝ} (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) : has_sum (fun (n : ℕ) => C * r ^ n) (C / (1 - r)) := sorry

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then `f` is a Cauchy sequence.
Note that this lemma does not assume `0 ≤ C` or `0 ≤ r`. -/
theorem cauchy_seq_of_le_geometric {α : Type u_1} [metric_space α] (r : ℝ) (C : ℝ) (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) : cauchy_seq f :=
  cauchy_seq_of_dist_le_of_summable (fun (n : ℕ) => C * r ^ n) hu
    (Exists.intro (C / (1 - r)) (aux_has_sum_of_le_geometric hr hu))

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then the distance from
`f n` to the limit of `f` is bounded above by `C * r^n / (1 - r)`. -/
theorem dist_le_of_le_geometric_of_tendsto₀ {α : Type u_1} [metric_space α] (r : ℝ) (C : ℝ) (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : dist (f 0) a ≤ C / (1 - r) :=
  has_sum.tsum_eq (aux_has_sum_of_le_geometric hr hu) ▸
    dist_le_tsum_of_dist_le_of_tendsto₀ (fun (b : ℕ) => C * r ^ b) hu
      (Exists.intro (C / (1 - r)) (aux_has_sum_of_le_geometric hr hu)) ha

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then the distance from
`f 0` to the limit of `f` is bounded above by `C / (1 - r)`. -/
theorem dist_le_of_le_geometric_of_tendsto {α : Type u_1} [metric_space α] (r : ℝ) (C : ℝ) (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : dist (f n) a ≤ C * r ^ n / (1 - r) := sorry

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then `f` is a Cauchy sequence. -/
theorem cauchy_seq_of_le_geometric_two {α : Type u_1} [metric_space α] (C : ℝ) {f : ℕ → α} (hu₂ : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C / bit0 1 / bit0 1 ^ n) : cauchy_seq f :=
  cauchy_seq_of_dist_le_of_summable (fun (n : ℕ) => C / bit0 1 / bit0 1 ^ n) hu₂
    (Exists.intro C (has_sum_geometric_two' C))

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then the distance from
`f 0` to the limit of `f` is bounded above by `C`. -/
theorem dist_le_of_le_geometric_two_of_tendsto₀ {α : Type u_1} [metric_space α] (C : ℝ) {f : ℕ → α} (hu₂ : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C / bit0 1 / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : dist (f 0) a ≤ C :=
  tsum_geometric_two' C ▸
    dist_le_tsum_of_dist_le_of_tendsto₀ (fun (n : ℕ) => C / bit0 1 / bit0 1 ^ n) hu₂ (summable_geometric_two' C) ha

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then the distance from
`f n` to the limit of `f` is bounded above by `C / 2^n`. -/
theorem dist_le_of_le_geometric_two_of_tendsto {α : Type u_1} [metric_space α] (C : ℝ) {f : ℕ → α} (hu₂ : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C / bit0 1 / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : dist (f n) a ≤ C / bit0 1 ^ n := sorry

theorem dist_partial_sum_le_of_le_geometric {α : Type u_1} [normed_group α] {r : ℝ} {C : ℝ} {f : ℕ → α} (hf : ∀ (n : ℕ), norm (f n) ≤ C * r ^ n) (n : ℕ) : dist (finset.sum (finset.range n) fun (i : ℕ) => f i) (finset.sum (finset.range (n + 1)) fun (i : ℕ) => f i) ≤ C * r ^ n := sorry

/-- If `∥f n∥ ≤ C * r ^ n` for all `n : ℕ` and some `r < 1`, then the partial sums of `f` form a
Cauchy sequence. This lemma does not assume `0 ≤ r` or `0 ≤ C`. -/
theorem cauchy_seq_finset_of_geometric_bound {α : Type u_1} [normed_group α] {r : ℝ} {C : ℝ} {f : ℕ → α} (hr : r < 1) (hf : ∀ (n : ℕ), norm (f n) ≤ C * r ^ n) : cauchy_seq fun (s : finset ℕ) => finset.sum s fun (x : ℕ) => f x :=
  cauchy_seq_finset_of_norm_bounded (fun (n : ℕ) => C * r ^ n)
    (has_sum.summable (aux_has_sum_of_le_geometric hr (dist_partial_sum_le_of_le_geometric hf))) hf

/-- If `∥f n∥ ≤ C * r ^ n` for all `n : ℕ` and some `r < 1`, then the partial sums of `f` are within
distance `C * r ^ n / (1 - r)` of the sum of the series. This lemma does not assume `0 ≤ r` or
`0 ≤ C`. -/
theorem norm_sub_le_of_geometric_bound_of_has_sum {α : Type u_1} [normed_group α] {r : ℝ} {C : ℝ} {f : ℕ → α} (hr : r < 1) (hf : ∀ (n : ℕ), norm (f n) ≤ C * r ^ n) {a : α} (ha : has_sum f a) (n : ℕ) : norm ((finset.sum (finset.range n) fun (x : ℕ) => f x) - a) ≤ C * r ^ n / (1 - r) := sorry

/-- A geometric series in a complete normed ring is summable.
Proved above (same name, different namespace) for not-necessarily-complete normed fields. -/
theorem normed_ring.summable_geometric_of_norm_lt_1 {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : summable fun (n : ℕ) => x ^ n := sorry

/-- Bound for the sum of a geometric series in a normed ring.  This formula does not assume that the
normed ring satisfies the axiom `∥1∥ = 1`. -/
theorem normed_ring.tsum_geometric_of_norm_lt_1 {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : norm (tsum fun (n : ℕ) => x ^ n) ≤ norm 1 - 1 + (1 - norm x⁻¹) := sorry

theorem geom_series_mul_neg {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : (tsum fun (i : ℕ) => x ^ i) * (1 - x) = 1 := sorry

theorem mul_neg_geom_series {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : ((1 - x) * tsum fun (i : ℕ) => x ^ i) = 1 := sorry

/-! ### Positive sequences with small sums on encodable types -/

/-- For any positive `ε`, define on an encodable type a positive sequence with sum less than `ε` -/
def pos_sum_of_encodable {ε : ℝ} (hε : 0 < ε) (ι : Type u_1) [encodable ι] : Subtype fun (ε' : ι → ℝ) => (∀ (i : ι), 0 < ε' i) ∧ ∃ (c : ℝ), has_sum ε' c ∧ c ≤ ε :=
  let f : ℕ → ℝ := fun (n : ℕ) => ε / bit0 1 / bit0 1 ^ n;
  { val := f ∘ encodable.encode, property := sorry }

namespace nnreal

theorem exists_pos_sum_of_encodable {ε : nnreal} (hε : 0 < ε) (ι : Type u_1) [encodable ι] : ∃ (ε' : ι → nnreal), (∀ (i : ι), 0 < ε' i) ∧ ∃ (c : nnreal), has_sum ε' c ∧ c < ε := sorry

end nnreal

namespace ennreal

theorem exists_pos_sum_of_encodable {ε : ennreal} (hε : 0 < ε) (ι : Type u_1) [encodable ι] : ∃ (ε' : ι → nnreal), (∀ (i : ι), 0 < ε' i) ∧ (tsum fun (i : ι) => ↑(ε' i)) < ε := sorry

end ennreal

/-!
### Factorial
-/

theorem factorial_tendsto_at_top : filter.tendsto nat.factorial filter.at_top filter.at_top :=
  filter.tendsto_at_top_at_top_of_monotone nat.monotone_factorial fun (n : ℕ) => Exists.intro n (nat.self_le_factorial n)

theorem tendsto_factorial_div_pow_self_at_top : filter.tendsto (fun (n : ℕ) => ↑(nat.factorial n) / ↑n ^ n) filter.at_top (nhds 0) := sorry


import data.matrix data.rat.basic .misc tactic.fin_cases
import .matrix_pequiv order.order_iso .simplex_new_pivot

open matrix fintype finset function pequiv simplex simplex.prebasis

variables {m n k: ℕ}

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
local attribute [instance] matrix.partial_order

namespace simplex'

def choose_pivot_column (AN_bar : matrix (fin m) (fin (n - m)) ℚ)
  (c : rvec (n - m)) : option (fin (n - m)) :=
fin.find (λ s : fin (n - m), 0 < c 0 s)

def choose_pivot_row (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (b_bar : cvec m)
  (s : fin (n - m)) : option (fin m) :=
fin.find (λ r : fin m, 0 < AN_bar r s ∧ ∀ i : fin m, 0 < AN_bar i s →
  (AN_bar r s)⁻¹ * b_bar r 0 ≤ (AN_bar i s)⁻¹ * b_bar i 0)

lemma choose_pivot_column_eq_none (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (h0b : 0 ≤ b_bar)
  (h : choose_pivot_column (A_bar ⬝ B.nonbasis.to_matrixᵀ) (reduced_cost B A_bar c) = none) :
  is_optimal_basis B A_bar b_bar c :=
is_optimal_basis_of_reduced_cost_nonpos _ _ hA_bar h0b $
  begin
    intros i j,
    fin_cases i,
    exact le_of_not_gt (fin.find_eq_none_iff.1 h j : _)
  end

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

lemma choose_pivot_column_spec (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (c : rvec (n - m))
  (s : fin (n - m)) (hs : s ∈ choose_pivot_column AN_bar c) : 0 < c 0 s :=
fin.find_spec _ hs

def swap_inverse (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (r : fin m) (s : fin (n - m)) :
  matrix (fin m) (fin m) ℚ :=
let pivot_inv := (AN_bar r s)⁻¹ in
(1 : matrix (fin m) (fin m) ℚ).write_column r
  (λ i, if i = r then pivot_inv else -AN_bar i s * pivot_inv)

lemma pivot_element_eq (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (r : fin m) (s : fin (n - m)) :
  (pivot_element B A_bar r s) = (λ _ _, (A_bar ⬝ B.nonbasis.to_matrixᵀ) r s) :=
begin
  ext i j,
  have hi : i = 0, from subsingleton.elim _ _,
  have hj : j = 0, from subsingleton.elim _ _,
  substs hi hj,
  simp only [pivot_element, matrix_mul_apply, mul_matrix_apply, (to_matrix_symm _).symm],
  refl
end

lemma single_apply {α β : Type*} [decidable_eq α] [decidable_eq β] (a a' : α) (b : β) :
  single a b a' = if a' = a then some b else none := rfl

@[simp] lemma add_add_neg_cancel'_right {α : Type*} [add_comm_group α] (a b : α) : a + (b + -a) = b :=
add_sub_cancel'_right a b

lemma swap_inverse_eq_swap_inverse (B : prebasis m n) (AN_bar : matrix (fin m) (fin (n - m)) ℚ)
  (r : fin m) (s : fin (n - m)) (hpivot : AN_bar r s ≠ 0) :
  swap_inverse AN_bar r s =
  simplex.swap_inverse B (AN_bar ⬝ B.nonbasis.to_matrix) r s :=
have ∀ i j r s, (AN_bar ⬝ ((single s (0 : fin 1)).to_matrix ⬝ (λ (_ _ : fin 1), (AN_bar r s)⁻¹))) i j
  = (AN_bar r s)⁻¹ * AN_bar i s,
  begin
    intros, fin_cases j,
    rw [← matrix.mul_assoc, mul_eq_smul, matrix.smul_val, matrix_mul_apply, symm_single,
      simplex'.single_apply, if_pos],
    congr,
  end,
begin
  ext i j,
  simp [simplex'.swap_inverse, simplex.swap_inverse,
    matrix.mul_add, matrix.add_mul, matrix.add_val, write_column_apply,
    matrix.neg_val,
    mul_matrix_apply, matrix_mul_apply, one_val, pivot_element_eq, inv_def],
  dsimp [symm_single, simplex'.single_apply],
  split_ifs,
  { rw [if_pos h.symm, if_pos h_1],
    simp [add_val, neg_val, one_val, matrix.mul_assoc, this, h_1, inv_mul_cancel hpivot], },
  { cc },
  { cc },
  { rw [if_neg h_1, if_pos h.symm],
    simp [matrix.mul_assoc, this, mul_comm] },
  { cc },
  { rw [if_neg (ne.symm h), if_neg h_2], simp },
  { rw [if_pos h_2, if_neg (ne.symm h)], simp },
  { rw [if_neg h_2, if_neg (ne.symm h)], simp }
end

lemma swap_nonbasis_eq (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  (B.swap r s).nonbasis.to_matrix = (B.nonbasis.to_matrix : matrix _ _ ℚ)
  + (single s (B.basisg r)).to_matrix - (single s (B.nonbasisg s)).to_matrix :=
begin
  dsimp [prebasis.swap],
  simp only [to_matrix_swap, to_matrix_trans],
  simp [matrix.mul_add, (to_matrix_trans _ _).symm,
    trans_single_of_mem _ (nonbasisg_mem B s),
    trans_single_of_eq_none _ (nonbasis_basisg_eq_none B r)]
end

lemma nonbasis_transpose_mul_single (B : prebasis m n) (i : fin (n - m)) (j : fin k) :
  (B.nonbasis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single i j).to_matrix =
  (single (B.nonbasisg i) j).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, trans_single_of_mem _ (nonbasis_nonbasisg _ _)]

lemma basis_transpose_mul_single (B : prebasis m n) (i : fin m) (j : fin k) :
  (B.basis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single i j).to_matrix =
  (single (B.basisg i) j).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, trans_single_of_mem _ (basis_basisg _ _)]

@[simp] lemma swap_nonbasis_mul_single_of_eq (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  ((B.swap r s).nonbasis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single s (0 : fin 1)).to_matrix =
  B.basis.to_matrixᵀ ⬝ (single r 0).to_matrix  :=
begin
  simp [swap_nonbasis_eq, transpose_add, (to_matrix_symm _).symm, matrix.add_mul],
  simp [to_matrix_symm, nonbasis_transpose_mul_single, basis_transpose_mul_single],
end

@[simp] lemma swap_nonbasis_mul_single_of_ne (B : prebasis m n) (r : fin m) {s : fin (n - m)}
  {j : fin (n - m)} (hsj : s ≠ j) :
  ((B.swap r s).nonbasis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single j (0 : fin 1)).to_matrix =
  B.nonbasis.to_matrixᵀ ⬝ (single j 0).to_matrix  :=
begin
  simp [swap_nonbasis_eq, transpose_add, (to_matrix_symm _).symm, matrix.add_mul],
  simp [to_matrix_symm, nonbasis_transpose_mul_single, basis_transpose_mul_single,
    single_mul_single_of_ne hsj],
end

lemma reduced_cost_swap (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (c : rvec n)
  (r : fin m) (s : fin (n - m)) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  reduced_cost (B.swap r s) (simplex.swap_inverse B A_bar r s ⬝ A_bar) c =
  reduced_cost B A_bar c ⬝ (1 - (single s (0 : fin 1)).to_matrix ⬝
    (pivot_element B A_bar r s)⁻¹ ⬝ (single 0 r).to_matrix ⬝ A_bar ⬝ B.nonbasis.to_matrixᵀ -
    (single s 0).to_matrix ⬝ (pivot_element B A_bar r s)⁻¹ ⬝ (single 0 s).to_matrix) :=
have h₁ : simplex.swap_inverse B A_bar r s ⬝ A_bar ⬝ (to_matrix ((swap B r s).basis))ᵀ = 1,
  by rw [matrix.mul_assoc, swap_mul_swap_inverse hA_bar hpivot],
have h₂ : ∀ {k : ℕ}, ∀ {M : matrix (fin 1) (fin k) ℚ},
    to_matrix (single s r) ⬝ (A_bar ⬝ ((to_matrix (B.nonbasis))ᵀ ⬝
    (to_matrix (single s 0) ⬝ ((pivot_element B A_bar r s)⁻¹ ⬝ M)))) =
    (single s 0).to_matrix ⬝ M,
  begin
    intros,
    rw [← single_mul_single s (0 : fin 1) r, matrix.mul_assoc],
    refine congr_arg (matrix.mul _) _,
    simp only [(matrix.mul_assoc _ _ _).symm, pivot_element, inv_eq_inverse] at ⊢ hpivot,
    rw [one_by_one_mul_inv_cancel hpivot, matrix.one_mul]
  end,
begin
  refine mul_single_ext (λ j, _),
  let x : matrix _ _ ℚ := (B.swap r s).nonbasis.to_matrixᵀ ⬝
    (single j (0 : fin 1)).to_matrix,
  have hxdef : x = (B.swap r s).nonbasis.to_matrixᵀ ⬝
    (single j (0 : fin 1)).to_matrix, from rfl,
  have hx : (single j (0 : fin 1)).to_matrix = (B.swap r s).nonbasis.to_matrix ⬝ x,
  { simp [x, (matrix.mul_assoc _ _ _).symm] },
  let b_bar := (simplex.swap_inverse B A_bar r s ⬝ A_bar) ⬝ x,
  rw [hx, ← matrix.mul_assoc, ← add_left_inj (c ⬝ (B.swap r s).basis.to_matrixᵀ ⬝ b_bar),
    ← objective_function_eq rfl h₁, matrix.mul_assoc c _ b_bar],
  have h₃ : A_bar ⬝ ((to_matrix ((swap B r s).basis))ᵀ ⬝ b_bar) = A_bar ⬝ x,
  { simp only [b_bar, x, (matrix.mul_assoc _ _ _).symm],
    rw [mul_eq_one_comm.1 (swap_mul_swap_inverse hA_bar hpivot),
      matrix.one_mul], },
  conv_rhs {rw [objective_function_eq h₃ hA_bar], },
  conv_lhs {rw [objective_function_eq rfl hA_bar] },
  simp [x, b_bar, simplex.swap_inverse, matrix.mul_add, matrix.mul_assoc,
    mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose _),
    matrix.add_mul, mul_right_eq_of_mul_eq (nonbasis_mul_swap_basis_tranpose _ _ _), h₂],
  by_cases hjs : j = s,
  { simp only [pivot_element, matrix.mul_assoc] at hpivot,
    simp [hjs, mul_right_eq_of_mul_eq hA_bar, matrix.mul_assoc,
      mul_right_eq_of_mul_eq (nonbasis_mul_basis_transpose _),
      pivot_element, inv_eq_inverse, one_by_one_inv_mul_cancel hpivot] },
  { simp [mul_right_eq_of_mul_eq hA_bar, single_mul_single_of_ne (ne.symm hjs),
      swap_nonbasis_mul_single_of_ne _ _ (ne.symm hjs),
      mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose _)] }
end

set_option eqn_compiler.zeta true

def simplex : Π (B : prebasis m n) (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (b_bar : cvec m)
  (c : rvec (n - m)),
  option (prebasis m n × matrix (fin m) (fin (n - m)) ℚ × (cvec m) × (rvec (n - m)))
| B AN_bar b_bar c :=
  match choose_pivot_column AN_bar c with
  | none   := some (B, AN_bar, b_bar, c)
  | some s :=
    match choose_pivot_row AN_bar b_bar s with
    | none   := none
    | some r :=
      have wf : false, from sorry,
      let S := simplex'.swap_inverse AN_bar r s in
      let AN_bar' : matrix (fin m) (fin (n - m)) ℚ :=
        AN_bar.write_column s (λ j, if j = r then (1 : ℚ) else 0) in
      simplex (B.swap r s) (S ⬝ AN_bar') (S ⬝ b_bar)
        ((c - (c 0 s / AN_bar r s) • (λ _, AN_bar r) -
          (0 : matrix _ _ ℚ).write_column s (λ _, c 0 s / AN_bar r s)))
    end
  end
using_well_founded { rel_tac := λ _ _, `[exact ⟨_, empty_wf⟩], dec_tac := tactic.assumption }

lemma simplex_spec : Π (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1) (h0b : 0 ≤ b_bar),
  (option.cases_on (simplex B (A_bar ⬝ B.nonbasis.to_matrixᵀ) b_bar (reduced_cost B A_bar c))
    (is_unbounded A_bar b_bar c)
    (λ P, is_optimal_basis P.1 A_bar b_bar c) : Prop)
| B A_bar b_bar c := assume hA_bar h0b,
  begin
    rw [simplex'.simplex],
    cases hs : choose_pivot_column (A_bar ⬝ B.nonbasis.to_matrixᵀ)
      (reduced_cost B A_bar c) with s,
    { dsimp [simplex'.simplex._match_3],
      exact choose_pivot_column_eq_none _ _ _ _ hA_bar h0b hs },
    { dsimp [simplex'.simplex._match_3],
      cases hr : choose_pivot_row (A_bar ⬝ B.nonbasis.to_matrixᵀ) b_bar s with r,
      { dsimp [simplex'.simplex._match_4],
        have : 0 < reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix,
        { rw [cvec_one_lt_iff, matrix_mul_apply],
          exact choose_pivot_column_spec _ _ _ hs },
        exact is_unbounded_of_pivot_element_nonpos b_bar _ hA_bar h0b this
          (λ r i j, by rw [pivot_element_eq];
            exact choose_pivot_row_eq_none _ _ _ _ _ hr) },
      { dsimp [simplex'.simplex._match_4],
        let AN_bar := A_bar ⬝ B.nonbasis.to_matrixᵀ,
        let S := simplex'.swap_inverse AN_bar r s,
        let AN_bar' : matrix (fin m) (fin (n - m)) ℚ :=
          AN_bar.write_column s (λ j, if j = r then (1 : ℚ) else 0),
        have := simplex_spec (B.swap r s) _ _ _ _ _,
         } },
  end

end simplex'

def ex.A := list.to_matrix 3 4 [[1/64443321,   18932,    -1, 9],
                                [1/2, -7/145931, -1/145903, 3],
                                [  -11,     -1111,     22, 100]]

def ex.b : cvec 3 := (λ i _, list.nth_le [0,0,1] i sorry)
--#eval ex.b
def ex.c : rvec 4 := λ _ i, (list.nth_le [3/4, -20, 1/2, -6] i sorry)

#eval @_root_.simplex 3 7 ex.A ex.b ex.c