/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import computability.primrec
import data.nat.psub
import data.pfun

/-!
# The partial recursive functions

The partial recursive functions are defined similarly to the primitive
recursive functions, but now all functions are partial, implemented
using the `part` monad, and there is an additional operation, called
μ-recursion, which performs unbounded minimization.

## References

* [Mario Carneiro, *Formalizing computability theory via partial recursive functions*][carneiro2019]
-/

open encodable denumerable part

local attribute [-simp] not_forall

namespace nat

section rfind
parameter (p : ℕ →. bool)

private def lbp (m n : ℕ) : Prop := m = n + 1 ∧ ∀ k ≤ n, ff ∈ p k

parameter (H : ∃ n, tt ∈ p n ∧ ∀ k < n, (p k).dom)

private def wf_lbp : well_founded lbp :=
⟨let ⟨n, pn⟩ := H in begin
  suffices : ∀m k, n ≤ k + m → acc (lbp p) k,
  { from λ a, this _ _ (nat.le_add_left _ _) },
  intros m k kn,
  induction m with m IH generalizing k;
    refine ⟨_, λ y r, _⟩; rcases r with ⟨rfl, a⟩,
  { injection mem_unique pn.1 (a _ kn) },
  { exact IH _ (by rw nat.add_right_comm; exact kn) }
end⟩

def rfind_x : {n // tt ∈ p n ∧ ∀m < n, ff ∈ p m} :=
suffices ∀ k, (∀n < k, ff ∈ p n) → {n // tt ∈ p n ∧ ∀m < n, ff ∈ p m},
from this 0 (λ n, (nat.not_lt_zero _).elim),
@well_founded.fix _ _ lbp wf_lbp begin
  intros m IH al,
  have pm : (p m).dom,
  { rcases H with ⟨n, h₁, h₂⟩,
    rcases lt_trichotomy m n with h₃|h₃|h₃,
    { exact h₂ _ h₃ },
    { rw h₃, exact h₁.fst },
    { injection mem_unique h₁ (al _ h₃) } },
  cases e : (p m).get pm,
  { suffices,
    exact IH _ ⟨rfl, this⟩ (λ n h, this _ (le_of_lt_succ h)),
    intros n h, cases h.lt_or_eq_dec with h h,
    { exact al _ h },
    { rw h, exact ⟨_, e⟩ } },
  { exact ⟨m, ⟨_, e⟩, al⟩ }
end

end rfind

def rfind (p : ℕ →. bool) : part ℕ :=
⟨_, λ h, (rfind_x p h).1⟩

theorem rfind_spec {p : ℕ →. bool} {n : ℕ} (h : n ∈ rfind p) : tt ∈ p n :=
h.snd ▸ (rfind_x p h.fst).2.1

theorem rfind_min {p : ℕ →. bool} {n : ℕ} (h : n ∈ rfind p) :
  ∀ {m : ℕ}, m < n → ff ∈ p m :=
h.snd ▸ (rfind_x p h.fst).2.2

@[simp] theorem rfind_dom {p : ℕ →. bool} :
  (rfind p).dom ↔ ∃ n, tt ∈ p n ∧ ∀ {m : ℕ}, m < n → (p m).dom :=
iff.rfl

theorem rfind_dom' {p : ℕ →. bool} :
  (rfind p).dom ↔ ∃ n, tt ∈ p n ∧ ∀ {m : ℕ}, m ≤ n → (p m).dom :=
exists_congr $ λ n, and_congr_right $ λ pn,
⟨λ H m h, (decidable.eq_or_lt_of_le h).elim (λ e, e.symm ▸ pn.fst) (H _),
 λ H m h, H (le_of_lt h)⟩

@[simp] theorem mem_rfind {p : ℕ →. bool} {n : ℕ} :
  n ∈ rfind p ↔ tt ∈ p n ∧ ∀ {m : ℕ}, m < n → ff ∈ p m :=
⟨λ h, ⟨rfind_spec h, @rfind_min _ _ h⟩,
  λ ⟨h₁, h₂⟩, let ⟨m, hm⟩ := dom_iff_mem.1 $
    (@rfind_dom p).2 ⟨_, h₁, λ m mn, (h₂ mn).fst⟩ in
  begin
    rcases lt_trichotomy m n with h|h|h,
    { injection mem_unique (h₂ h) (rfind_spec hm) },
    { rwa ← h },
    { injection mem_unique h₁ (rfind_min hm h) },
  end⟩

theorem rfind_min' {p : ℕ → bool} {m : ℕ} (pm : p m) :
  ∃ n ∈ rfind p, n ≤ m :=
have tt ∈ (p : ℕ →. bool) m, from ⟨trivial, pm⟩,
let ⟨n, hn⟩ := dom_iff_mem.1 $
  (@rfind_dom p).2 ⟨m, this, λ k h, ⟨⟩⟩ in
⟨n, hn, not_lt.1 $ λ h,
  by injection mem_unique this (rfind_min hn h)⟩

theorem rfind_zero_none
  (p : ℕ →. bool) (p0 : p 0 = none) : rfind p = none :=
eq_none_iff.2 $ λ a h,
let ⟨n, h₁, h₂⟩ := rfind_dom'.1 h.fst in
(p0 ▸ h₂ (zero_le _) : (@part.none bool).dom)

def rfind_opt {α} (f : ℕ → option α) : part α :=
(rfind (λ n, (f n).is_some)).bind (λ n, f n)

theorem rfind_opt_spec {α} {f : ℕ → option α} {a}
 (h : a ∈ rfind_opt f) : ∃ n, a ∈ f n :=
let ⟨n, h₁, h₂⟩ := mem_bind_iff.1 h in ⟨n, mem_coe.1 h₂⟩

theorem rfind_opt_dom {α} {f : ℕ → option α} :
  (rfind_opt f).dom ↔ ∃ n a, a ∈ f n :=
⟨λ h, (rfind_opt_spec ⟨h, rfl⟩).imp (λ n h, ⟨_, h⟩),
 λ h, begin
  have h' : ∃ n, (f n).is_some :=
    h.imp (λ n, option.is_some_iff_exists.2),
  have s := nat.find_spec h',
  have fd : (rfind (λ n, (f n).is_some)).dom :=
    ⟨nat.find h', by simpa using s.symm, λ _ _, trivial⟩,
  refine ⟨fd, _⟩,
  have := rfind_spec (get_mem fd),
  simp at this ⊢,
  cases option.is_some_iff_exists.1 this.symm with a e,
  rw e, trivial
end⟩

theorem rfind_opt_mono {α} {f : ℕ → option α}
  (H : ∀ {a m n}, m ≤ n → a ∈ f m → a ∈ f n)
  {a} : a ∈ rfind_opt f ↔ ∃ n, a ∈ f n :=
⟨rfind_opt_spec, λ ⟨n, h⟩, begin
  have h' := rfind_opt_dom.2 ⟨_, _, h⟩,
  cases rfind_opt_spec ⟨h', rfl⟩ with k hk,
  have := (H (le_max_left _ _) h).symm.trans
          (H (le_max_right _ _) hk),
  simp at this, simp [this, get_mem]
end⟩

inductive partrec : (ℕ →. ℕ) → Prop
| zero : partrec (pure 0)
| succ : partrec succ
| left : partrec ↑(λ n : ℕ, n.unpair.1)
| right : partrec ↑(λ n : ℕ, n.unpair.2)
| pair {f g} : partrec f → partrec g → partrec (λ n, mkpair <$> f n <*> g n)
| comp {f g} : partrec f → partrec g → partrec (λ n, g n >>= f)
| prec {f g} : partrec f → partrec g → partrec (unpaired (λ a n,
    n.elim (f a) (λ y IH, do i ← IH, g (mkpair a (mkpair y i)))))
| rfind {f} : partrec f → partrec (λ a,
    rfind (λ n, (λ m, m = 0) <$> f (mkpair a n)))

namespace partrec

theorem of_eq {f g : ℕ →. ℕ} (hf : partrec f) (H : ∀ n, f n = g n) : partrec g :=
(funext H : f = g) ▸ hf

theorem of_eq_tot {f : ℕ →. ℕ} {g : ℕ → ℕ}
  (hf : partrec f) (H : ∀ n, g n ∈ f n) : partrec g :=
hf.of_eq (λ n, eq_some_iff.2 (H n))

theorem of_primrec {f : ℕ → ℕ} (hf : primrec f) : partrec f :=
begin
  induction hf,
  case nat.primrec.zero { exact zero },
  case nat.primrec.succ { exact succ },
  case nat.primrec.left { exact left },
  case nat.primrec.right { exact right },
  case nat.primrec.pair : f g hf hg pf pg
  { refine (pf.pair pg).of_eq_tot (λ n, _),
    simp [has_seq.seq] },
  case nat.primrec.comp : f g hf hg pf pg
  { refine (pf.comp pg).of_eq_tot (λ n, _),
    simp },
  case nat.primrec.prec : f g hf hg pf pg
  { refine (pf.prec pg).of_eq_tot (λ n, _),
    simp,
    induction n.unpair.2 with m IH, {simp},
    simp, exact ⟨_, IH, rfl⟩ },
end

protected theorem some : partrec some := of_primrec primrec.id

theorem none : partrec (λ n, none) :=
(of_primrec (nat.primrec.const 1)).rfind.of_eq $
λ n, eq_none_iff.2 $ λ a ⟨h, e⟩, by simpa using h

theorem prec' {f g h}
  (hf : partrec f) (hg : partrec g) (hh : partrec h) :
  partrec (λ a, (f a).bind (λ n, n.elim (g a)
    (λ y IH, do i ← IH, h (mkpair a (mkpair y i))))) :=
((prec hg hh).comp (pair partrec.some hf)).of_eq $
λ a, ext $ λ s, by simp [(<*>)]; exact
⟨λ ⟨n, h₁, h₂⟩, ⟨_, ⟨_, h₁, rfl⟩, by simpa using h₂⟩,
 λ ⟨_, ⟨n, h₁, rfl⟩, h₂⟩, ⟨_, h₁, by simpa using h₂⟩⟩

theorem ppred : partrec (λ n, ppred n) :=
have primrec₂ (λ n m, if n = nat.succ m then 0 else 1),
from (primrec.ite
  (@@primrec_rel.comp _ _ _ _ _ _ _ primrec.eq
    primrec.fst
    (_root_.primrec.succ.comp primrec.snd))
  (_root_.primrec.const 0) (_root_.primrec.const 1)).to₂,
(of_primrec (primrec₂.unpaired'.2 this)).rfind.of_eq $
λ n, begin
  cases n; simp,
  { exact eq_none_iff.2 (λ a ⟨⟨m, h, _⟩, _⟩,
      by simpa [show 0 ≠ m.succ, by intro h; injection h] using h) },
  { refine eq_some_iff.2 _,
    simp, intros m h, simp [ne_of_gt h] }
end

end partrec

end nat

def partrec {α σ} [primcodable α] [primcodable σ]
  (f : α →. σ) := nat.partrec (λ n,
  part.bind (decode α n) (λ a, (f a).map encode))

def partrec₂ {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  (f : α → β →. σ) := partrec (λ p : α × β, f p.1 p.2)

def computable {α σ} [primcodable α] [primcodable σ] (f : α → σ) := partrec (f : α →. σ)

def computable₂ {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  (f : α → β → σ) := computable (λ p : α × β, f p.1 p.2)

theorem primrec.to_comp {α σ} [primcodable α] [primcodable σ]
  {f : α → σ} (hf : primrec f) : computable f :=
(nat.partrec.ppred.comp (nat.partrec.of_primrec hf)).of_eq $
λ n, by simp; cases decode α n; simp

theorem primrec₂.to_comp {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  {f : α → β → σ} (hf : primrec₂ f) : computable₂ f := hf.to_comp

protected theorem computable.partrec {α σ} [primcodable α] [primcodable σ]
  {f : α → σ} (hf : computable f) : partrec (f : α →. σ) := hf

protected theorem computable₂.partrec₂ {α β σ} [primcodable α] [primcodable β] [primcodable σ]
  {f : α → β → σ} (hf : computable₂ f) : partrec₂ (λ a, (f a : β →. σ)) := hf

namespace computable
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

theorem of_eq {f g : α → σ} (hf : computable f) (H : ∀ n, f n = g n) : computable g :=
(funext H : f = g) ▸ hf

theorem const (s : σ) : computable (λ a : α, s) :=
(primrec.const _).to_comp

theorem of_option {f : α → option β} (hf : computable f) :
  partrec (λ a, (f a : part β)) :=
(nat.partrec.ppred.comp hf).of_eq $ λ n, begin
  cases decode α n with a; simp,
  cases f a with b; simp
end

theorem to₂ {f : α × β → σ} (hf : computable f) : computable₂ (λ a b, f (a, b)) :=
hf.of_eq $ λ ⟨a, b⟩, rfl

protected theorem id : computable (@id α) := primrec.id.to_comp

theorem fst : computable (@prod.fst α β) := primrec.fst.to_comp

theorem snd : computable (@prod.snd α β) := primrec.snd.to_comp

theorem pair {f : α → β} {g : α → γ}
  (hf : computable f) (hg : computable g) : computable (λ a, (f a, g a)) :=
(hf.pair hg).of_eq $
λ n, by cases decode α n; simp [(<*>)]

theorem unpair : computable nat.unpair := primrec.unpair.to_comp

theorem succ : computable nat.succ := primrec.succ.to_comp
theorem pred : computable nat.pred := primrec.pred.to_comp
theorem nat_bodd : computable nat.bodd := primrec.nat_bodd.to_comp
theorem nat_div2 : computable nat.div2 := primrec.nat_div2.to_comp

theorem sum_inl : computable (@sum.inl α β) := primrec.sum_inl.to_comp
theorem sum_inr : computable (@sum.inr α β) := primrec.sum_inr.to_comp

theorem list_cons : computable₂ (@list.cons α) := primrec.list_cons.to_comp
theorem list_reverse : computable (@list.reverse α) := primrec.list_reverse.to_comp
theorem list_nth : computable₂ (@list.nth α) := primrec.list_nth.to_comp
theorem list_append : computable₂ ((++) : list α → list α → list α) := primrec.list_append.to_comp
theorem list_concat : computable₂ (λ l (a:α), l ++ [a]) := primrec.list_concat.to_comp
theorem list_length : computable (@list.length α) := primrec.list_length.to_comp

theorem vector_cons {n} : computable₂ (@vector.cons α n) := primrec.vector_cons.to_comp
theorem vector_to_list {n} : computable (@vector.to_list α n) := primrec.vector_to_list.to_comp
theorem vector_length {n} : computable (@vector.length α n) := primrec.vector_length.to_comp
theorem vector_head {n} : computable (@vector.head α n) := primrec.vector_head.to_comp
theorem vector_tail {n} : computable (@vector.tail α n) := primrec.vector_tail.to_comp
theorem vector_nth {n} : computable₂ (@vector.nth α n) := primrec.vector_nth.to_comp
theorem vector_nth' {n} : computable (@vector.nth α n) := primrec.vector_nth'.to_comp
theorem vector_of_fn' {n} : computable (@vector.of_fn α n) := primrec.vector_of_fn'.to_comp

theorem fin_app {n} : computable₂ (@id (fin n → σ)) := primrec.fin_app.to_comp

protected theorem encode : computable (@encode α _) :=
primrec.encode.to_comp

protected theorem decode : computable (decode α) :=
primrec.decode.to_comp

protected theorem of_nat (α) [denumerable α] : computable (of_nat α) :=
(primrec.of_nat _).to_comp

theorem encode_iff {f : α → σ} : computable (λ a, encode (f a)) ↔ computable f :=
iff.rfl

theorem option_some : computable (@option.some α) :=
primrec.option_some.to_comp

end computable

namespace partrec
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

open computable

theorem of_eq {f g : α →. σ} (hf : partrec f) (H : ∀ n, f n = g n) : partrec g :=
(funext H : f = g) ▸ hf

theorem of_eq_tot {f : α →. σ} {g : α → σ}
  (hf : partrec f) (H : ∀ n, g n ∈ f n) : computable g :=
hf.of_eq (λ a, eq_some_iff.2 (H a))

theorem none : partrec (λ a : α, @part.none σ) :=
nat.partrec.none.of_eq $ λ n, by cases decode α n; simp

protected theorem some : partrec (@part.some α) := computable.id

theorem _root_.decidable.partrec.const' (s : part σ) [decidable s.dom] : partrec (λ a : α, s) :=
(of_option (const (to_option s))).of_eq (λ a, of_to_option s)

theorem const' (s : part σ) : partrec (λ a : α, s) :=
by haveI := classical.dec s.dom; exact decidable.partrec.const' s

protected

theorem map {f : α →. β} {g : α → β → σ}
  (hf : partrec f) (hg : computable₂ g) : partrec (λ a, (f a).map (g a)) :=
by simpa [bind_some_eq_map] using
   @@partrec.bind _ _ _ (λ a b, part.some (g a b)) hf hg

theorem to₂ {f : α × β →. σ} (hf : partrec f) : partrec₂ (λ a b, f (a, b)) :=
hf.of_eq $ λ ⟨a, b⟩, rfl

theorem nat_elim
  {f : α → ℕ} {g : α →. σ} {h : α → ℕ × σ →. σ}
  (hf : computable f) (hg : partrec g) (hh : partrec₂ h) :
  partrec (λ a, (f a).elim (g a) (λ y IH, IH.bind (λ i, h a (y, i)))) :=
(nat.partrec.prec' hf hg hh).of_eq $ λ n, begin
  cases e : decode α n with a; simp [e],
  induction f a with m IH; simp,
  rw [IH, bind_map],
  congr, funext s,
  simp [encodek]
end

theorem comp {f : β →. σ} {g : α → β}
  (hf : partrec f) (hg : computable g) : partrec (λ a, f (g a)) :=
(hf.comp hg).of_eq $
λ n, by simp; cases e : decode α n with a;
  simp [e, encodek]

theorem nat_iff {f : ℕ →. ℕ} : partrec f ↔ nat.partrec f :=
by simp [partrec, map_id']

theorem map_encode_iff {f : α →. σ} : partrec (λ a, (f a).map encode) ↔ partrec f :=
iff.rfl

end partrec

namespace partrec₂
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ]

theorem unpaired {f : ℕ → ℕ →. α} : partrec (nat.unpaired f) ↔ partrec₂ f :=
⟨λ h, by simpa using h.comp primrec₂.mkpair.to_comp,
 λ h, h.comp primrec.unpair.to_comp⟩

theorem unpaired' {f : ℕ → ℕ →. ℕ} : nat.partrec (nat.unpaired f) ↔ partrec₂ f :=
partrec.nat_iff.symm.trans unpaired

theorem comp
  {f : β → γ →. σ} {g : α → β} {h : α → γ}
  (hf : partrec₂ f) (hg : computable g) (hh : computable h) :
  partrec (λ a, f (g a) (h a)) := hf.comp (hg.pair hh)

theorem comp₂
  {f : γ → δ →. σ} {g : α → β → γ} {h : α → β → δ}
  (hf : partrec₂ f) (hg : computable₂ g) (hh : computable₂ h) :
  partrec₂ (λ a b, f (g a b) (h a b)) := hf.comp hg hh

end partrec₂

namespace computable
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

theorem comp {f : β → σ} {g : α → β}
  (hf : computable f) (hg : computable g) :
  computable (λ a, f (g a)) := hf.comp hg

theorem comp₂ {f : γ → σ} {g : α → β → γ}
  (hf : computable f) (hg : computable₂ g) :
  computable₂ (λ a b, f (g a b)) := hf.comp hg

end computable

namespace computable₂
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ]

theorem comp
  {f : β → γ → σ} {g : α → β} {h : α → γ}
  (hf : computable₂ f) (hg : computable g) (hh : computable h) :
  computable (λ a, f (g a) (h a)) := hf.comp (hg.pair hh)

theorem comp₂
  {f : γ → δ → σ} {g : α → β → γ} {h : α → β → δ}
  (hf : computable₂ f) (hg : computable₂ g) (hh : computable₂ h) :
  computable₂ (λ a b, f (g a b) (h a b)) := hf.comp hg hh

end computable₂

namespace partrec
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

open computable

theorem rfind {p : α → ℕ →. bool} (hp : partrec₂ p) :
  partrec (λ a, nat.rfind (p a)) :=
(nat.partrec.rfind $ hp.map
  ((primrec.dom_bool (λ b, cond b 0 1))
    .comp primrec.snd).to₂.to_comp).of_eq $
λ n, begin
  cases e : decode α n with a;
    simp [e, nat.rfind_zero_none, map_id'],
  congr, funext n,
  simp [part.map_map, (∘)],
  apply map_id' (λ b, _),
  cases b; refl
end

theorem rfind_opt {f : α → ℕ → option σ} (hf : computable₂ f) :
  partrec (λ a, nat.rfind_opt (f a)) :=
(rfind (primrec.option_is_some.to_comp.comp hf).partrec.to₂).bind
  (of_option hf)

theorem nat_cases_right
  {f : α → ℕ} {g : α → σ} {h : α → ℕ →. σ}
  (hf : computable f) (hg : computable g) (hh : partrec₂ h) :
  partrec (λ a, (f a).cases (some (g a)) (h a)) :=
(nat_elim hf hg (hh.comp fst (pred.comp $ hf.comp fst)).to₂).of_eq $
λ a, begin
  simp, cases f a; simp,
  refine ext (λ b, ⟨λ H, _, λ H, _⟩),
  { rcases mem_bind_iff.1 H with ⟨c, h₁, h₂⟩, exact h₂ },
  { have : ∀ m, (nat.elim (part.some (g a))
      (λ y IH, IH.bind (λ _, h a n)) m).dom,
    { intro, induction m; simp [*, H.fst] },
    exact ⟨⟨this n, H.fst⟩, H.snd⟩ }
end

theorem bind_decode₂_iff {f : α →. σ} : partrec f ↔
  nat.partrec (λ n, part.bind (decode₂ α n) (λ a, (f a).map encode)) :=
⟨λ hf, nat_iff.1 $ (of_option primrec.decode₂.to_comp).bind $
  (map hf (computable.encode.comp snd).to₂).comp snd,
λ h, map_encode_iff.1 $ by simpa [encodek₂]
  using (nat_iff.2 h).comp (@computable.encode α _)⟩

theorem vector_m_of_fn : ∀ {n} {f : fin n → α →. σ}, (∀ i, partrec (f i)) →
  partrec (λ (a : α), vector.m_of_fn (λ i, f i a))
| 0     f hf := const _
| (n+1) f hf := by simp [vector.m_of_fn]; exact
  (hf 0).bind (partrec.bind ((vector_m_of_fn (λ i, hf i.succ)).comp fst)
    (primrec.vector_cons.to_comp.comp (snd.comp fst) snd))

end partrec

@[simp] theorem vector.m_of_fn_part_some {α n} : ∀ (f : fin n → α),
  vector.m_of_fn (λ i, part.some (f i)) = part.some (vector.of_fn f) :=
vector.m_of_fn_pure

namespace computable
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

theorem option_some_iff {f : α → σ} : computable (λ a, some (f a)) ↔ computable f :=
⟨λ h, encode_iff.1 $ primrec.pred.to_comp.comp $ encode_iff.2 h,
 option_some.comp⟩

theorem bind_decode_iff {f : α → β → option σ} : computable₂ (λ a n,
  (decode β n).bind (f a)) ↔ computable₂ f :=
⟨λ hf, nat.partrec.of_eq
    (((partrec.nat_iff.2 (nat.partrec.ppred.comp $
        nat.partrec.of_primrec $ primcodable.prim β)).comp snd).bind
      (computable.comp hf fst).to₂.partrec₂) $
  λ n, by simp;
    cases decode α n.unpair.1; simp;
    cases decode β n.unpair.2; simp,
λ hf, begin
  have : partrec (λ a : α × ℕ, (encode (decode β a.2)).cases
    (some option.none) (λ n, part.map (f a.1) (decode β n))) :=
  partrec.nat_cases_right (primrec.encdec.to_comp.comp snd)
    (const none) ((of_option (computable.decode.comp snd)).map
      (hf.comp (fst.comp $ fst.comp fst) snd).to₂),
  refine this.of_eq (λ a, _),
  simp, cases decode β a.2; simp [encodek]
end⟩

theorem map_decode_iff {f : α → β → σ} : computable₂ (λ a n,
  (decode β n).map (f a)) ↔ computable₂ f :=
bind_decode_iff.trans option_some_iff

theorem nat_elim
  {f : α → ℕ} {g : α → σ} {h : α → ℕ × σ → σ}
  (hf : computable f) (hg : computable g) (hh : computable₂ h) :
  computable (λ a, (f a).elim (g a) (λ y IH, h a (y, IH))) :=
(partrec.nat_elim hf hg hh.partrec₂).of_eq $
λ a, by simp; induction f a; simp *

theorem nat_cases {f : α → ℕ} {g : α → σ} {h : α → ℕ → σ}
  (hf : computable f) (hg : computable g) (hh : computable₂ h) :
  computable (λ a, (f a).cases (g a) (h a)) :=
nat_elim hf hg (hh.comp fst $ fst.comp snd).to₂

theorem cond {c : α → bool} {f : α → σ} {g : α → σ}
  (hc : computable c) (hf : computable f) (hg : computable g) :
  computable (λ a, cond (c a) (f a) (g a)) :=
(nat_cases (encode_iff.2 hc) hg (hf.comp fst).to₂).of_eq $
λ a, by cases c a; refl

theorem option_cases {o : α → option β} {f : α → σ} {g : α → β → σ}
  (ho : computable o) (hf : computable f) (hg : computable₂ g) :
  @computable _ σ _ _ (λ a, option.cases_on (o a) (f a) (g a)) :=
option_some_iff.1 $
(nat_cases (encode_iff.2 ho) (option_some_iff.2 hf)
    (map_decode_iff.2 hg)).of_eq $
λ a, by cases o a; simp [encodek]; refl

theorem option_bind {f : α → option β} {g : α → β → option σ}
  (hf : computable f) (hg : computable₂ g) :
  computable (λ a, (f a).bind (g a)) :=
(option_cases hf (const option.none) hg).of_eq $
λ a, by cases f a; refl

theorem option_map {f : α → option β} {g : α → β → σ}
  (hf : computable f) (hg : computable₂ g) : computable (λ a, (f a).map (g a)) :=
option_bind hf (option_some.comp₂ hg)

theorem option_get_or_else {f : α → option β} {g : α → β}
  (hf : computable f) (hg : computable g) :
  computable (λ a, (f a).get_or_else (g a)) :=
(computable.option_cases hf hg (show computable₂ (λ a b, b), from computable.snd)).of_eq $
λ a, by cases f a; refl

theorem subtype_mk {f : α → β} {p : β → Prop} [decidable_pred p] {h : ∀ a, p (f a)}
    (hp : primrec_pred p) (hf : computable f) :
  @computable _ _ _ (primcodable.subtype hp) (λ a, (⟨f a, h a⟩ : subtype p)) :=
hf

theorem sum_cases
  {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ → σ}
  (hf : computable f) (hg : computable₂ g) (hh : computable₂ h) :
  @computable _ σ _ _ (λ a, sum.cases_on (f a) (g a) (h a)) :=
option_some_iff.1 $
(cond (nat_bodd.comp $ encode_iff.2 hf)
  (option_map (computable.decode.comp $ nat_div2.comp $ encode_iff.2 hf) hh)
  (option_map (computable.decode.comp $ nat_div2.comp $ encode_iff.2 hf) hg)).of_eq $
λ a, by cases f a with b c;
  simp [nat.div2_bit, nat.bodd_bit, encodek]; refl

theorem nat_strong_rec
  (f : α → ℕ → σ) {g : α → list σ → option σ} (hg : computable₂ g)
  (H : ∀ a n, g a ((list.range n).map (f a)) = some (f a n)) : computable₂ f :=
suffices computable₂ (λ a n, (list.range n).map (f a)), from
  option_some_iff.1 $
  (list_nth.comp (this.comp fst (succ.comp snd)) snd).to₂.of_eq $
  λ a, by simp [list.nth_range (nat.lt_succ_self a.2)]; refl,
option_some_iff.1 $
(nat_elim snd (const (option.some [])) (to₂ $
  option_bind (snd.comp snd) $ to₂ $
  option_map
    (hg.comp (fst.comp $ fst.comp fst) snd)
    (to₂ $ list_concat.comp (snd.comp fst) snd))).of_eq $
λ a, begin
  simp, induction a.2 with n IH, {refl},
  simp [IH, H, list.range_succ]
end

theorem list_of_fn : ∀ {n} {f : fin n → α → σ},
  (∀ i, computable (f i)) → computable (λ a, list.of_fn (λ i, f i a))
| 0     f hf := const []
| (n+1) f hf := by simp [list.of_fn_succ]; exact
  list_cons.comp (hf 0) (list_of_fn (λ i, hf i.succ))

theorem vector_of_fn {n} {f : fin n → α → σ}
  (hf : ∀ i, computable (f i)) : computable (λ a, vector.of_fn (λ i, f i a)) :=
(partrec.vector_m_of_fn hf).of_eq $ λ a, by simp

end computable

namespace partrec
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

open computable

theorem option_some_iff {f : α →. σ} :
  partrec (λ a, (f a).map option.some) ↔ partrec f :=
⟨λ h, (nat.partrec.ppred.comp h).of_eq $
   λ n, by simp [part.bind_assoc, bind_some_eq_map],
 λ hf, hf.map (option_some.comp snd).to₂⟩

theorem option_cases_right {o : α → option β} {f : α → σ} {g : α → β →. σ}
  (ho : computable o) (hf : computable f) (hg : partrec₂ g) :
  @partrec _ σ _ _ (λ a, option.cases_on (o a) (some (f a)) (g a)) :=
have partrec (λ (a : α), nat.cases (part.some (f a))
  (λ n, part.bind (decode β n) (g a)) (encode (o a))) :=
nat_cases_right (encode_iff.2 ho) hf.partrec $
  ((@computable.decode β _).comp snd).of_option.bind
    (hg.comp (fst.comp fst) snd).to₂,
this.of_eq $ λ a, by cases o a with b; simp [encodek]

theorem sum_cases_right {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ →. σ}
  (hf : computable f) (hg : computable₂ g) (hh : partrec₂ h) :
  @partrec _ σ _ _ (λ a, sum.cases_on (f a) (λ b, some (g a b)) (h a)) :=
have partrec (λ a, (option.cases_on
  (sum.cases_on (f a) (λ b, option.none) option.some : option γ)
  (some (sum.cases_on (f a) (λ b, some (g a b))
     (λ c, option.none)))
  (λ c, (h a c).map option.some) : part (option σ))) :=
option_cases_right
  (sum_cases hf (const option.none).to₂ (option_some.comp snd).to₂)
  (sum_cases hf (option_some.comp hg) (const option.none).to₂)
  (option_some_iff.2 hh),
option_some_iff.1 $ this.of_eq $ λ a, by cases f a; simp

theorem sum_cases_left {f : α → β ⊕ γ} {g : α → β →. σ} {h : α → γ → σ}
  (hf : computable f) (hg : partrec₂ g) (hh : computable₂ h) :
  @partrec _ σ _ _ (λ a, sum.cases_on (f a) (g a) (λ c, some (h a c))) :=
(sum_cases_right (sum_cases hf
  (sum_inr.comp snd).to₂ (sum_inl.comp snd).to₂) hh hg).of_eq $
λ a, by cases f a; simp

lemma fix_aux {α σ} (f : α →. σ ⊕ α) (a : α) (b : σ) :
  let F : α → ℕ →. σ ⊕ α := λ a n,
    n.elim (some (sum.inr a)) $ λ y IH, IH.bind $ λ s,
    sum.cases_on s (λ _, part.some s) f in
  (∃ (n : ℕ), ((∃ (b' : σ), sum.inl b' ∈ F a n) ∧
        ∀ {m : ℕ}, m < n → (∃ (b : α), sum.inr b ∈ F a m)) ∧
      sum.inl b ∈ F a n) ↔ b ∈ pfun.fix f a :=
begin
  intro, refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨n, ⟨_x, h₁⟩, h₂⟩,
    have : ∀ m a' (_: sum.inr a' ∈ F a m)
      (_: b ∈ pfun.fix f a'), b ∈ pfun.fix f a,
    { intros m a' am ba,
      induction m with m IH generalizing a'; simp [F] at am,
      { rwa ← am },
      rcases am with ⟨a₂, am₂, fa₂⟩,
      exact IH _ am₂ (pfun.mem_fix_iff.2 (or.inr ⟨_, fa₂, ba⟩)) },
    cases n; simp [F] at h₂, {cases h₂},
    rcases h₂ with h₂ | ⟨a', am', fa'⟩,
    { cases h₁ (nat.lt_succ_self _) with a' h,
      injection mem_unique h h₂ },
    { exact this _ _ am' (pfun.mem_fix_iff.2 (or.inl fa')) } },
  { suffices : ∀ a' (_: b ∈ pfun.fix f a') k (_: sum.inr a' ∈ F a k),
       ∃ n, sum.inl b ∈ F a n ∧
         ∀ (m < n) (_ : k ≤ m), ∃ a₂, sum.inr a₂ ∈ F a m,
    { rcases this _ h 0 (by simp [F]) with ⟨n, hn₁, hn₂⟩,
      exact ⟨_, ⟨⟨_, hn₁⟩, λ m mn, hn₂ m mn (nat.zero_le _)⟩, hn₁⟩ },
    intros a₁ h₁,
    apply pfun.fix_induction h₁, intros a₂ h₂ IH k hk,
    rcases pfun.mem_fix_iff.1 h₂ with h₂ | ⟨a₃, am₃, fa₃⟩,
    { refine ⟨k.succ, _, λ m mk km, ⟨a₂, _⟩⟩,
      { simp [F], exact or.inr ⟨_, hk, h₂⟩ },
      { rwa le_antisymm (nat.le_of_lt_succ mk) km } },
    { rcases IH _ am₃ k.succ _ with ⟨n, hn₁, hn₂⟩,
      { refine ⟨n, hn₁, λ m mn km, _⟩,
        cases km.lt_or_eq_dec with km km,
        { exact hn₂ _ mn km },
        { exact km ▸ ⟨_, hk⟩ } },
      { simp [F], exact ⟨_, hk, am₃⟩ } } }
end

theorem fix {f : α →. σ ⊕ α} (hf : partrec f) : partrec (pfun.fix f) :=
let F : α → ℕ →. σ ⊕ α := λ a n,
  n.elim (some (sum.inr a)) $ λ y IH, IH.bind $ λ s,
  sum.cases_on s (λ _, part.some s) f in
have hF : partrec₂ F :=
partrec.nat_elim snd (sum_inr.comp fst).partrec
  (sum_cases_right (snd.comp snd)
    (snd.comp $ snd.comp fst).to₂
    (hf.comp snd).to₂).to₂,
let p := λ a n, @part.map _ bool
  (λ s, sum.cases_on s (λ_, tt) (λ _, ff)) (F a n) in
have hp : partrec₂ p := hF.map ((sum_cases computable.id
  (const tt).to₂ (const ff).to₂).comp snd).to₂,
(hp.rfind.bind (hF.bind
  (sum_cases_right snd snd.to₂ none.to₂).to₂).to₂).of_eq $
λ a, ext $ λ b, by simp; apply fix_aux f

end partrec


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

! This file was ported from Lean 3 source module topology.sheaves.sheafify
! leanprover-community/mathlib commit bb103f356534a9a7d3596a672097e375290a4c3a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.LocalPredicate
import Mathbin.Topology.Sheaves.Stalks

/-!
# Sheafification of `Type` valued presheaves

We construct the sheafification of a `Type` valued presheaf,
as the subsheaf of dependent functions into the stalks
consisting of functions which are locally germs.

We show that the stalks of the sheafification are isomorphic to the original stalks,
via `stalk_to_fiber` which evaluates a germ of a dependent function at a point.

We construct a morphism `to_sheafify` from a presheaf to (the underlying presheaf of)
its sheafification, given by sending a section to its collection of germs.

## Future work
Show that the map induced on stalks by `to_sheafify` is the inverse of `stalk_to_fiber`.

Show sheafification is a functor from presheaves to sheaves,
and that it is the left adjoint of the forgetful functor,
following <https://stacks.math.columbia.edu/tag/007X>.
-/

universe v

noncomputable section

open TopCat

open Opposite

open TopologicalSpace

variable {X : TopCat.{v}} (F : Presheaf (Type v) X)

namespace TopCat.Presheaf

namespace Sheafify

/--
The prelocal predicate on functions into the stalks, asserting that the function is equal to a germ.
-/
def isGerm : PrelocalPredicate fun x => F.stalk x
    where
  pred U f := ∃ g : F.obj (op U), ∀ x : U, f x = F.germ x g
  res := fun V U i f ⟨g, p⟩ =>
    ⟨F.map i.op g, fun x => (p (i x)).trans (F.germ_res_apply _ _ _).symm⟩
#align Top.presheaf.sheafify.is_germ TopCat.Presheaf.Sheafify.isGerm

/-- The local predicate on functions into the stalks,
asserting that the function is locally equal to a germ.
-/
def isLocallyGerm : LocalPredicate fun x => F.stalk x :=
  (isGerm F).sheafify
#align Top.presheaf.sheafify.is_locally_germ TopCat.Presheaf.Sheafify.isLocallyGerm

end Sheafify

/-- The sheafification of a `Type` valued presheaf, defined as the functions into the stalks which
are locally equal to germs.
-/
def sheafify : Sheaf (Type v) X :=
  subsheafToTypes (Sheafify.isLocallyGerm F)
#align Top.presheaf.sheafify TopCat.Presheaf.sheafify

/-- The morphism from a presheaf to its sheafification,
sending each section to its germs.
(This forms the unit of the adjunction.)
-/
def toSheafify : F ⟶ F.sheafify.1
    where
  app U f := ⟨fun x => F.germ x f, PrelocalPredicate.sheafify_of ⟨f, fun x => rfl⟩⟩
  naturality' U U' f := by
    ext (x⟨u, m⟩)
    exact germ_res_apply F f.unop ⟨u, m⟩ x
#align Top.presheaf.to_sheafify TopCat.Presheaf.toSheafify

/-- The natural morphism from the stalk of the sheafification to the original stalk.
In `sheafify_stalk_iso` we show this is an isomorphism.
-/
def stalkToFiber (x : X) : F.sheafify.Presheaf.stalk x ⟶ F.stalk x :=
  stalkToFiber (Sheafify.isLocallyGerm F) x
#align Top.presheaf.stalk_to_fiber TopCat.Presheaf.stalkToFiber

theorem stalkToFiber_surjective (x : X) : Function.Surjective (F.stalkToFiber x) :=
  by
  apply stalk_to_fiber_surjective
  intro t
  obtain ⟨U, m, s, rfl⟩ := F.germ_exist _ t
  · use ⟨U, m⟩
    fconstructor
    · exact fun y => F.germ y s
    · exact ⟨prelocal_predicate.sheafify_of ⟨s, fun _ => rfl⟩, rfl⟩
#align Top.presheaf.stalk_to_fiber_surjective TopCat.Presheaf.stalkToFiber_surjective

theorem stalkToFiber_injective (x : X) : Function.Injective (F.stalkToFiber x) :=
  by
  apply stalk_to_fiber_injective
  intros
  rcases hU ⟨x, U.2⟩ with ⟨U', mU, iU, gU, wU⟩
  rcases hV ⟨x, V.2⟩ with ⟨V', mV, iV, gV, wV⟩
  have wUx := wU ⟨x, mU⟩
  dsimp at wUx; erw [wUx] at e; clear wUx
  have wVx := wV ⟨x, mV⟩
  dsimp at wVx; erw [wVx] at e; clear wVx
  rcases F.germ_eq x mU mV gU gV e with ⟨W, mW, iU', iV', e'⟩
  dsimp at e'
  use ⟨W ⊓ (U' ⊓ V'), ⟨mW, mU, mV⟩⟩
  refine' ⟨_, _, _⟩
  · change W ⊓ (U' ⊓ V') ⟶ U.obj
    exact opens.inf_le_right _ _ ≫ opens.inf_le_left _ _ ≫ iU
  · change W ⊓ (U' ⊓ V') ⟶ V.obj
    exact opens.inf_le_right _ _ ≫ opens.inf_le_right _ _ ≫ iV
  · intro w
    dsimp
    specialize wU ⟨w.1, w.2.2.1⟩
    dsimp at wU
    specialize wV ⟨w.1, w.2.2.2⟩
    dsimp at wV
    erw [wU, ← F.germ_res iU' ⟨w, w.2.1⟩, wV, ← F.germ_res iV' ⟨w, w.2.1⟩,
      CategoryTheory.types_comp_apply, CategoryTheory.types_comp_apply, e']
#align Top.presheaf.stalk_to_fiber_injective TopCat.Presheaf.stalkToFiber_injective

/-- The isomorphism betweeen a stalk of the sheafification and the original stalk.
-/
def sheafifyStalkIso (x : X) : F.sheafify.Presheaf.stalk x ≅ F.stalk x :=
  (Equiv.ofBijective _ ⟨stalkToFiber_injective _ _, stalkToFiber_surjective _ _⟩).toIso
#align Top.presheaf.sheafify_stalk_iso TopCat.Presheaf.sheafifyStalkIso

-- PROJECT functoriality, and that sheafification is the left adjoint of the forgetful functor.
end TopCat.Presheaf


import algebra.comm_rings.basic

namespace comm_ring

universes u v

structure mul_closed_set (R : Type u) [comm_ring R] : Type u :=
  (body : set R)
  (contains_one : (1:R) ∈ body)
  (mul_closed : ∀ s₁ s₂, s₁ ∈ body → s₂ ∈ body → (s₁ * s₂) ∈ body)

instance mul_closed_set_coe (R : Type u) [comm_ring R] : has_coe (mul_closed_set R) (set R)
  := ⟨λ S, S.body⟩

structure mcs_type {R: Type u} [comm_ring R] (S : mul_closed_set R) : Type u :=
  (val : R)
  (property : val ∈ S.body)

instance mcs_as_type {R: Type u} [comm_ring R]
  : has_coe_to_sort (mul_closed_set R) (Type u) := ⟨mcs_type⟩

instance mcs_val {R: Type u} [comm_ring R] {S: mul_closed_set R} : has_coe S R := ⟨λ s : S, s.val⟩

def mcs_mul {R: Type u} [comm_ring R] {S: mul_closed_set R} : S → S → S :=
begin
  intros s₁ s₂,
  split,
  apply S.mul_closed,
  exact s₁.property,
  exact s₂.property,
end

instance mcs_has_mul {R: Type u} [comm_ring R] {S: mul_closed_set R} : has_mul S := ⟨mcs_mul⟩

@[simp]
lemma mcs_mul_coe {R: Type u} [comm_ring R] {S: mul_closed_set R} : ∀ s₁ s₂ : S, ↑(s₁ * s₂) = (↑s₁) * (↑s₂ :R) := λ _ _,rfl

def equal_as_fractions {R: Type u} [comm_ring R] (S: mul_closed_set R) : R × S → R × S → Prop :=
  λ  p₁ p₂,  ∃ (s : S), ↑s * (p₁.1 * p₂.2 + -(p₂.1 * p₁.2)) = 0

lemma equal_as_fractions_refl {R: Type u} [comm_ring R] (S: mul_closed_set R) : ∀ f : R × S, equal_as_fractions S f f :=
begin
  intro f,
  existsi (⟨(1:R),S.contains_one⟩ : S),
  rw [minus_inverse,mul_zero],
end

lemma equal_as_fractions_symm {R: Type u} [comm_ring R] (S : mul_closed_set R)
  : ∀ f g : R × S, equal_as_fractions S f g → equal_as_fractions S g f :=
begin
  intros f g hfg,
  cases hfg with s hs,
  existsi s,
  rw [← minus_minus (g.fst * ↑f.snd),← minus_dis,add_comm],
  rw [mul_comm,← minus_mul,mul_comm,hs,minus_zero_zero],
end

lemma equal_as_fractions_trans {R: Type u} [comm_ring R] (S : mul_closed_set R)
  : ∀ f₁ f₂ f₃ : R × S, equal_as_fractions S f₁ f₂ → equal_as_fractions S f₂ f₃ → equal_as_fractions S f₁ f₃ :=
begin
  intros f₁ f₂ f₃ hf₁f₂ hf₂f₃,
  cases f₁ with r₁ s₁,
  cases f₂ with r₂ s₂,
  cases f₃ with r₃ s₃,
  cases hf₁f₂ with s₁₂ hs₁₂,
  simp at hs₁₂,
  cases hf₂f₃ with s₂₃ hs₂₃,
  simp at hs₂₃,
  existsi s₁₂ * s₂₃ * s₂,
  simp,
  have hrw : ↑((s₁₂ * s₂₃) * s₃) * (r₁ * s₂ + - r₂ * s₁) + ↑ ((s₁₂ * s₂₃) * s₁) * (r₂ * s₃ + - r₃ * s₂) =
      ↑s₁₂ * ↑s₂₃ * ↑s₂ * (r₁ * ↑s₃ + - (r₃ * ↑s₁)),
    simp,
    let α : R := ↑s₁₂ * ↑s₂₃,
    have trv : ↑s₁₂ * ↑s₂₃ = α := rfl,
    rw trv,
    have hrw₁ : α * ↑s₃ * (r₁ * ↑s₂ + - r₂ * ↑s₁) = (α * ↑s₂) * (r₁ * ↑s₃) + -r₂ * (α * s₃ * s₁),
      rw mul_comm (-r₂) (α * ↑s₃ * ↑s₁),
      rw [← mul_assoc α,← mul_assoc α,← mul_assoc α,← mul_assoc α],
      rw ← mul_dis α ,
      rw [mul_assoc ↑s₂, mul_comm (↑s₂ * r₁)],
      rw [← mul_assoc ↑s₃ ↑s₁,← mul_dis ↑s₃],
      simp [mul_comm],
    have hrw₂ : α * ↑s₁ * (r₂ * ↑s₃ + - r₃ * ↑s₂) = r₂ * (α * s₃ * s₁) + - (α * ↑s₂) * (r₃ * ↑s₁),
      rw mul_comm r₂ (α * s₃ * s₁),
      rw [mul_comm α s₂,minus_mul,mul_comm (-↑s₂) α],
      rw [← mul_assoc α,← mul_assoc α,← mul_assoc α,← mul_assoc α],
      rw ← mul_dis α,
      rw [mul_assoc (-↑s₂), mul_comm ((-↑s₂) * r₃)],
      rw [mul_comm ↑s₃ ↑s₁, ← mul_assoc ↑s₁,← mul_dis ↑s₁],
      rw [← minus_mul,← minus_mul],
      simp [mul_comm],
    rw [hrw₁,hrw₂],
    rw [← minus_mul,← minus_mul],
    let β₁: R := α * ↑s₂ * (r₁ * ↑s₃),
    have hβ₁ : α * ↑s₂ * (r₁ * ↑s₃) = β₁ := rfl,
    let β₂ : R := r₂ * (α * ↑s₃ * ↑s₁),
    have hβ₂ : r₂ * (α * ↑s₃ * ↑s₁) = β₂ := rfl,
    let β₃ : R := α * ↑s₂ * (r₃ * ↑s₁),
    have hβ₃ : α * ↑s₂ * (r₃ * ↑s₁) = β₃ := rfl,
    rw [hβ₁,hβ₂,hβ₃],
    have hrw₃ : β₁ + -β₂ + (β₂ + -β₃) = β₁ + (-β₂ + β₂) + -β₃,
      simp [add_assoc],
    rw hrw₃,
    rw [add_comm (-β₂),minus_inverse, add_zero],
    rw mul_dis,
    rw [hβ₁, mul_comm (α * ↑s₂), ← minus_mul, mul_comm (r₃ * ↑s₁)],
  rw ← hrw,
  rw [← minus_mul, ← minus_mul],
  let δ₁₂ := r₁ * ↑s₂ + -(r₂ * ↑s₁),
  have hδ₁₂ : r₁ * ↑s₂ + -(r₂ * ↑s₁) = δ₁₂ := rfl,
  let δ₂₃ := r₂ * ↑s₃ + - (r₃ * ↑s₂),
  have hδ₂₃ : r₂ * ↑s₃ + - (r₃ * ↑s₂) = δ₂₃ := rfl,
  rw [hδ₁₂,hδ₂₃],
  rw hδ₁₂ at hs₁₂,
  rw hδ₂₃ at hs₂₃,
  simp,
  clear hrw hδ₁₂ hδ₂₃,
  have hz₁ : ↑s₁₂ * ↑s₂₃ * ↑s₁ * δ₂₃ = 0,
    rw mul_comm ↑s₁₂,
    rw mul_comm,
    rw mul_assoc,
    rw mul_assoc,
    rw mul_comm δ₂₃,
    rw hs₂₃,
    repeat {
      rw mul_comm (0:R),
      rw mul_zero,
    },
  have hz₂ : ↑s₁₂ * ↑s₂₃ * ↑s₃ * δ₁₂ = 0,
    rw ←mul_assoc,
    rw ← mul_assoc,
    rw mul_comm ↑s₁₂,
    rw ← mul_assoc,
    rw ← mul_assoc,
    rw mul_comm δ₁₂,
    rw hs₁₂,
    simp [mul_zero],
  rw [hz₁,hz₂,add_zero],
end

instance fraction_setoid (R : Type u) [comm_ring R] (S : mul_closed_set R) : setoid (R × S)
  := ⟨equal_as_fractions S, equal_as_fractions_refl S, equal_as_fractions_symm S, equal_as_fractions_trans S⟩

def localisation (R : Type u) [comm_ring R] (S : mul_closed_set R) := quotient (comm_ring.fraction_setoid R S)

notation R `[`S `⁻¹]` := localisation R S

def localisation_pre_add {R : Type u} [comm_ring R] (S : mul_closed_set R) : R × S → R × S → R[S⁻¹]
  | (x₁,s₁) (x₂,s₂) := ⟦(x₁ * s₂ + x₂ * s₁, s₁ * s₂)⟧

theorem localisation_pre_add_lifts {R : Type u} [comm_ring R] (S : mul_closed_set R)
  : ∀ a₁ a₂ b₁ b₂ : R × S, a₁ ≈ b₁ → a₂ ≈ b₂ → localisation_pre_add S a₁ a₂ = localisation_pre_add S b₁ b₂ :=
begin
  intros a₁ a₂ b₁ b₂ h₁ h₂,
  cases a₁ with ax₁ as₁,
  cases a₂ with ax₂ as₂,
  cases b₁ with bx₁ bs₁,
  cases b₂ with bx₂ bs₂,
  simp [localisation_pre_add],
  apply quotient.sound,
  cases h₁ with s₁ hs₁,
  cases h₂ with s₂ hs₂,
  simp at hs₁,
  simp at hs₂,
  let s := s₁ * s₂,
  have hs : ↑s = ↑s₁ * ↑s₂,
    simp[s],
    rw mcs_mul_coe,
  let as := as₁ * as₂,
  have has : ↑as = ↑as₁ * ↑as₂,
    simp[as],
  let bs := bs₁ * bs₂,
  have hbs : ↑bs = ↑bs₁ * ↑bs₂,
    simp[bs],
  have v₁ : ↑s * (ax₁ * bs₁ + -(bx₁ * as₁)) = 0,
    simp [s],
    rw mul_comm (↑s₁ : R) s₂,
    rw [← mul_assoc, hs₁, mul_zero],
  have v₂ : ↑s * (ax₂ * bs₂ + -(bx₂ * as₂)) = 0,
    simp [s],
    rw [← mul_assoc, hs₂, mul_zero],
  existsi s,
  simp,
  rw ← hs,
  have sub₁ : (ax₁ * as₂ + ax₂ * as₁) * (↑bs₁ * ↑bs₂) = (ax₁ * bs₁) * bs +

end

end comm_ring


import temporal_logic.basic

universe variables u u₀ u₁ u₂

namespace temporal
open predicate

section pair

variables {α : Type u} {β : Type u₀} {γ : Type u₁} {ω : Type u₂}
variables (x : tvar α) (y : tvar β) (z : tvar γ)

@[tl_simp, simp]
lemma pair_model (i : ℕ) :
i ⊨ ⦃x,y⦄ = (i ⊨ x,i ⊨ y) :=
by { cases x, cases y, refl }

@[reducible]
def pair.fst : var (α × β) α :=
⟨ @prod.fst α β ⟩

@[reducible]
def pair.snd : var (α × β) β :=
⟨ @prod.snd α β ⟩

abbreviation tvar.fst (p : var γ (α × β)) : var γ α :=
pair.fst!p

abbreviation tvar.snd (p : var γ (α × β)) : var γ β :=
pair.snd!p

@[tl_simp, simp]
def pair.fst_mk (x : tvar α) (y : tvar β)
: pair.fst ! ⦃x,y⦄ = x :=
by lifted_pred

@[tl_simp, simp]
def pair.fst_mk' (x : tvar α) (y : tvar β)
: ⟨ @prod.fst α β ⟩ ! ⦃x,y⦄ = x :=
pair.fst_mk _ _

@[tl_simp, simp]
def pair.snd_mk (x : tvar α) (y : tvar β)
: pair.snd ! ⦃x,y⦄ = y :=
by lifted_pred

@[tl_simp, simp]
def pair.snd_mk' (x : tvar α) (y : tvar β)
: ⟨ @prod.snd α β ⟩ ! ⦃x,y⦄ = y :=
by lifted_pred

@[tl_simp, simp]
def prod.map_left {α β γ} (f : α → β) : α × γ → β × γ
 | (x,y) := (f x, y)

@[tl_simp, simp]
def prod.map_right {α β γ} (f : β → γ) : α × β → α × γ
 | (x,y) := (x,f y)
open temporal.prod

@[tl_simp, simp]
lemma map_right_proj_pair (f : β → γ)
: ⟨map_right f⟩ ! ⦃x,y⦄ = ⦃x, ⟨f⟩ ! y⦄ :=
by ext i ; simp [map_right] with tl_simp

@[tl_simp, simp]
lemma map_left_proj_pair (f : α → γ)
: ⟨map_left f⟩ ! ⦃x,y⦄ = ⦃⟨f⟩ ! x, y⦄ :=
by ext i ; simp [map_left] with tl_simp

@[tl_simp, simp]
lemma map_proj_pair (f : α → γ) (g : β → ω)
: ⟨prod.map f g⟩ ! ⦃x,y⦄ = ⦃⟨f⟩ ! x,⟨g⟩ ! y⦄ :=
by ext i ; simp [prod.map] with tl_simp

@[tl_simp, simp]
lemma eta_pair (w : tvar (α × β))
: ⦃w.fst, w.snd⦄ = w :=
by ext i ; simp [prod.map] with tl_simp

@[tl_simp, simp]
lemma next_pair (v₀ : tvar α) (v₁ : tvar β)
: ⊙⦃v₀,v₁⦄ = ⦃⊙v₀,⊙v₁⦄ :=
by lifted_pred [next]

@[tl_simp, simp, predicate]
lemma to_fun_var_pair (f : tvar α → tvar β) (g : tvar α → tvar γ) (w : tvar α)
: to_fun_var (λ w : tvar α, ⦃f w,g w⦄) w = ⦃to_fun_var f w,to_fun_var g w⦄ :=
by { lifted_pred, simp! }

end pair

end temporal


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.preserves.basic

/-!
# Isomorphisms about functors which preserve (co)limits

If `G` preserves limits, and `C` and `D` have limits, then for any diagram `F : J ⥤ C` we have a
canonical isomorphism `preserves_limit_iso : G.obj (limit F) ≅ limit (F ⋙ G)`.
We also show that we can commute `is_limit.lift` of a preserved limit with `functor.map_cone`:
`(preserves_limit.preserves t).lift (G.map_cone c₂) = G.map (t.lift c₂)`.

The duals of these are also given. For functors which preserve (co)limits of specific shapes, see
`preserves/shapes.lean`.
-/

universes v u₁ u₂

noncomputable theory

namespace category_theory

open category limits

variables {C : Type u₁} [category.{v} C]
variables {D : Type u₂} [category.{v} D]
variables (G : C ⥤ D)
variables {J : Type v} [small_category J]
variables (F : J ⥤ C)

section
variables [preserves_limit F G]

@[simp]
lemma preserves_lift_map_cone (c₁ c₂ : cone F) (t : is_limit c₁) :
  (preserves_limit.preserves t).lift (G.map_cone c₂) = G.map (t.lift c₂) :=
((preserves_limit.preserves t).uniq (G.map_cone c₂) _ (by simp [← G.map_comp])).symm

variables [has_limit F] [has_limit (F ⋙ G)]
/--
If `G` preserves limits, we have an isomorphism from the image of the limit of a functor `F`
to the limit of the functor `F ⋙ G`.
-/
def preserves_limit_iso : G.obj (limit F) ≅ limit (F ⋙ G) :=
(preserves_limit.preserves (limit.is_limit _)).cone_point_unique_up_to_iso (limit.is_limit _)

@[simp, reassoc]
lemma preserves_limits_iso_hom_π (j) :
  (preserves_limit_iso G F).hom ≫ limit.π _ j = G.map (limit.π F j) :=
is_limit.cone_point_unique_up_to_iso_hom_comp _ _ j

@[simp, reassoc]
lemma preserves_limits_iso_inv_π (j) :
  (preserves_limit_iso G F).inv ≫ G.map (limit.π F j) = limit.π _ j :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ j

@[simp, reassoc]
lemma lift_comp_preserves_limits_iso_hom (t : cone F) :
  G.map (limit.lift _ t) ≫ (preserves_limit_iso G F).hom = limit.lift (F ⋙ G) (G.map_cone _) :=
by { ext, simp [← G.map_comp] }
end

section
variables [preserves_colimit F G]

@[simp]
lemma preserves_desc_map_cocone (c₁ c₂ : cocone F) (t : is_colimit c₁) :
  (preserves_colimit.preserves t).desc (G.map_cocone _) = G.map (t.desc c₂) :=
((preserves_colimit.preserves t).uniq (G.map_cocone _) _ (by simp [← G.map_comp])).symm

variables [has_colimit F] [has_colimit (F ⋙ G)]
/--
If `G` preserves colimits, we have an isomorphism from the image of the colimit of a functor `F`
to the colimit of the functor `F ⋙ G`.
-/
-- TODO: think about swapping the order here
def preserves_colimit_iso : G.obj (colimit F) ≅ colimit (F ⋙ G) :=
(preserves_colimit.preserves (colimit.is_colimit _)).cocone_point_unique_up_to_iso
  (colimit.is_colimit _)

@[simp, reassoc]
lemma ι_preserves_colimits_iso_inv (j : J) :
  colimit.ι _ j ≫ (preserves_colimit_iso G F).inv = G.map (colimit.ι F j) :=
is_colimit.comp_cocone_point_unique_up_to_iso_inv _ (colimit.is_colimit (F ⋙ G)) j

@[simp, reassoc]
lemma ι_preserves_colimits_iso_hom (j : J) :
  G.map (colimit.ι F j) ≫ (preserves_colimit_iso G F).hom = colimit.ι (F ⋙ G) j :=
(preserves_colimit.preserves (colimit.is_colimit _)).comp_cocone_point_unique_up_to_iso_hom _ j

@[simp, reassoc]
lemma preserves_colimits_iso_inv_comp_desc (t : cocone F) :
  (preserves_colimit_iso G F).inv ≫ G.map (colimit.desc _ t) = colimit.desc _ (G.map_cocone t) :=
by { ext, simp [← G.map_comp] }
end

end category_theory


import data.fintype.basic
import data.finset
import tactic
import finset_extra

noncomputable theory
open_locale classical
open set

universes u v

def size {γ : Type u} (X: set γ) := (sorry : ℤ) -- need to fix this to actually be the size

lemma finsize {γ : Type u} {hfin: fintype γ} (X: set γ) : size X = (fintype.card ↥X : ℤ) := sorry

structure matroid_on (γ : Type u)[fintype γ]  :=

(r : set γ → ℤ)
(R1l : ∀ (X : set γ), 0 ≤ r X)
(R1u : ∀ (X:  set γ), r X ≤ size X)
(R2 : ∀ {X Y : set γ}, X ⊆ Y → r X ≤ r Y)
(R3 : ∀ (X Y : set γ), r (X ∪ Y) + r (X ∩ Y) ≤ r X + r Y)

class matroids (α : Type v)  :=
(type_map : α → Σ (γ : Type u), fintype γ)
(to_matroid : Π (M : α), @matroid_on (type_map M).1 (type_map M).2)
-- M is the name of the matroid and has type α.
-- (γ M) is the 'ground type' of the matroid M;
--the function to_matroid maps the name M to the structure of -- matroid M (i.e. a rank function and proofs of axioms).

instance matroid_on.matroids (γ  : Type u)[h: fintype γ]  : matroids (matroid_on γ) :=
{ type_map := λ (M: matroid_on γ), ⟨γ, h⟩,
  to_matroid := id }

namespace matroid

local attribute [simp] image_union image_inter

variables {α : Type v} [matroids α]
-- Accessor functions for terms that have a matroid representation

def γ (M : α) := (matroids.type_map M).1 -- matroid elements have type γ
def E (M: α) : (set (γ M)) := set.univ  -- E is the ground set viewed as a set, not a type.
def r (M : α) (X : set (γ M) ) : ℤ := (matroids.to_matroid M).r X
def R1l (M : α) (X : set (γ M)) : 0 ≤ r M X := (matroids.to_matroid M).R1l X
def R1u (M:  α) (X: set (γ M))  : r M X ≤ size X := (matroids.to_matroid M).R1u X
def R2 (M : α) {X Y : set (γ M)} (h : X ⊆ Y) : r M X ≤ r M Y := (matroids.to_matroid M).R2 h
def R3 (M : α) (X Y : set (γ M)) : r M (X ∪ Y) + r M (X ∩ Y) ≤ r M X + r M Y := (matroids.to_matroid M).R3 X Y

@[simp] lemma r_empty_eq_zero (M : α) : r M (∅ : set (γ M)) = 0 :=
begin
    have := R1u M ∅,
    have := R1l M ∅,
    have := finsize (∅ : set (γ M)),
    sorry,
    --simp only [card_empty, int.coe_nat_zero] at this,
    --linarith,
end
--by { have h := R1 M ∅, rwa [card_empty, le_zero_iff_eq] at h }

lemma rank_subadditive (M : α) (X Y : set (γ M)) : r M (X ∪ Y) ≤ r M X + r M Y := by linarith [R3 M X Y, (R1 M (X ∩ Y)).1]

lemma r_le_union (M : α) (X Y : set (γ M)) : r M X ≤ r M (X ∪ Y) :=
by { apply R2 M, apply subset_union_left }

lemma r_le_union_right (M : α) (X Y : set (γ M)) : r M Y ≤ r M (X ∪ Y) :=
by { rw union_comm, apply r_le_union }

instance coe_subtype_set {α : Type*} {Y: set α} :
    has_coe (set Y) (set α) := ⟨λ X, X.image subtype.val⟩

@[simp] lemma coe_subtype_size {α : Type*} {Y: set α} (X: set Y) :
    size X = size (X: set α) := sorry

@[simp] lemma coe_subtype_union {α: Type*} {Y: set α} (X₁ X₂ : set Y) :
    (((X₁ ∪ X₂ : set Y)) :set α ) = X₁ ∪ X₂ := by apply image_union

@[simp] lemma coe_subtype_inter {α: Type*} {Y: set α} (X₁ X₂ : set Y) :
    (((X₁ ∩ X₂ : set Y)) :set α) = X₁ ∩ X₂ :=
begin
    sorry,
end

structure submatroid (M : α) :=
(F : set (γ M))

--set_option pp.beta true
--set_option pp.universes true
instance submatroid.matroid (M : α) : matroids (submatroid M) :=
{ γ := λ (M' : submatroid M), ↥(M'.F),
  to_matroid := λ (M' : submatroid M),
  { r := λ X, r M X,
    R1 := λ X,
    begin
        split,
        apply (R1 M X).1,
        simp only [coe_subtype_size],
        exact (R1 M X).2,
    end,
    R2 := λ X₁ X₂ h, R2 M (image_subset _ h),
    R3 := λ X₁ X₂,
    begin
        convert (R3 M X₁ X₂),
        simp,
        simp,
    end, }}

def delete (M : α) (F : set (γ M)) : submatroid M :=
submatroid.mk F

structure matroid_contraction (M : α) :=
(C : set (γ M))

--def contract (M : α) (C : set (γ M)) : matroid_contraction M :=
--matroid_contraction.mk C

instance matroid_contraction.matroid (M : α) : matroids (matroid_contraction M) :=
{ γ := λ M', ↥((M'.C : set (γ M))ᶜ),
  to_matroid := λ M',
  { r := λ X, r M (X ∪ M'.C) - r M M'.C,
    R1 := λ X,
    begin

      split,
      linarith [R2 M (subset_union_right ↑X M'.C)],

      have h1 := rank_subadditive M X M'.C,
      have := (R1 M X).2,
      rw coe_subtype_size X,
      --unfold size,
      linarith,
    end,
    R2 := λ X,
    begin
        intros Y hXY,
        have hXYC: (X ∪ M'.C: set (γ M)) ⊆ (Y ∪ M'.C: set (γ M)),
        {
            apply union_subset_union_left,
            apply image_subset,
            exact hXY,
        },
        linarith [R2 M hXYC],
    end,
    R3 :=
    begin
        intros X Y,
        --rw ← coe_subtype_union,
        suffices : r M (↑(X ∪ Y) ∪ M'.C) + r M (↑(X ∩ Y) ∪ M'.C) ≤ r M (↑X ∪ M'.C) + r M (↑Y ∪ M'.C), by linarith,

        --calc r M (↑(X ∪ Y) ∪ M'.C) - r M M'.C + (r M (↑(X ∩ Y) ∪ M'.C) - r M M'.C) ≤ r M (↑(X ∪ Y) ∪ M'.C) + (r M (↑(X ∩ Y) ∪ M'.C) - 2*(r M M'.C) : by linarith
        --... = r M (↑X ∪ M'.C) - r M M'.C + (r M (↑Y ∪ M'.C) - r M M'.C) : sorry,
        --... =

        --sorry,
        --exact this,

        --{linarith,},
        --rw @image_union (finset (↑(M'.C))ᶜ) () _ _ _ X Y ,
        --sorry,

        /-intros X Y,
        let X' := X.image subtype.val,
        let Y' := Y.image subtype.val,
        rw [image_union, image_inter],
        have := R3 M (X' ∪ M'.C) (Y' ∪ M'.C),
        simp only [@union_unions _ _ X' Y' _, inter_unions]  at this,

        linarith,
        intros x y,
        exact subtype.eq,-/
    end,
    }
 }

def dual (M : α) [fintype (γ M)] : matroid_on (γ M) :=
{ r := λ X, size X - r M (E M) + r M (Xᶜ),
  R1 :=
  begin
    sorry,
    /-intros X,
    split,
    have h1 : r X ≤ size X := (R1 M X).2,
    have h2 := rank_subadditive M X (Xᶜ),
    have h3 := lambda_conn_nonegative M X,
    --unfold lambda_conn at h3,

    calc size X - r (E M) + r Xᶜ = size X - r X + (r X + r Xᶜ - r (E M)) : by linarith
                        ...      ≥ size X - r X                          : by linarith [lambda_conn_nonegative M X]
                        ...      ≥ 0                                     : by linarith [(R1 M X).2],

    linarith[ R2 M ((by simp) :(Xᶜ ⊆ E M))], -/
  end,
  R2 := sorry,
  R3 := sorry }

end matroid


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

! This file was ported from Lean 3 source module category_theory.adjunction.reflective
! leanprover-community/mathlib commit 239d882c4fb58361ee8b3b39fb2091320edef10a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Adjunction.FullyFaithful
import Mathlib.CategoryTheory.Functor.ReflectsIso
import Mathlib.CategoryTheory.EpiMono

/-!
# Reflective functors

Basic properties of reflective functors, especially those relating to their essential image.

Note properties of reflective functors relating to limits and colimits are included in
`CategoryTheory.Monad.Limits`.
-/

universe v₁ v₂ v₃ u₁ u₂ u₃

noncomputable section

namespace CategoryTheory

open Category Adjunction

variable {C : Type u₁} {D : Type u₂} {E : Type u₃}

variable [Category.{v₁} C] [Category.{v₂} D] [Category.{v₃} E]

/--
A functor is *reflective*, or *a reflective inclusion*, if it is fully faithful and right adjoint.
-/
class Reflective (R : D ⥤ C) extends IsRightAdjoint R, Full R, Faithful R
#align category_theory.reflective CategoryTheory.Reflective

variable {i : D ⥤ C}

-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
/-- For a reflective functor `i` (with left adjoint `L`), with unit `η`, we have `η_iL = iL η`.
-/
theorem unit_obj_eq_map_unit [Reflective i] (X : C) :
    (ofRightAdjoint i).unit.app (i.obj ((leftAdjoint i).obj X)) =
      i.map ((leftAdjoint i).map ((ofRightAdjoint i).unit.app X)) := by
  rw [← cancel_mono (i.map ((ofRightAdjoint i).counit.app ((leftAdjoint i).obj X))), ←
    i.map_comp]
  simp
#align category_theory.unit_obj_eq_map_unit CategoryTheory.unit_obj_eq_map_unit

/--
When restricted to objects in `D` given by `i : D ⥤ C`, the unit is an isomorphism. In other words,
`η_iX` is an isomorphism for any `X` in `D`.
More generally this applies to objects essentially in the reflective subcategory, see
`Functor.essImage.unit_isIso`.
-/
instance isIso_unit_obj [Reflective i] {B : D} : IsIso ((ofRightAdjoint i).unit.app (i.obj B)) := by
  have :
    (ofRightAdjoint i).unit.app (i.obj B) = inv (i.map ((ofRightAdjoint i).counit.app B)) :=
    by
    rw [← comp_hom_eq_id]
    apply (ofRightAdjoint i).right_triangle_components
  rw [this]
  exact IsIso.inv_isIso
#align category_theory.is_iso_unit_obj CategoryTheory.isIso_unit_obj

/-- If `A` is essentially in the image of a reflective functor `i`, then `η_A` is an isomorphism.
This gives that the "witness" for `A` being in the essential image can instead be given as the
reflection of `A`, with the isomorphism as `η_A`.

(For any `B` in the reflective subcategory, we automatically have that `ε_B` is an iso.)
-/
theorem Functor.essImage.unit_isIso [Reflective i] {A : C} (h : A ∈ i.essImage) :
    IsIso ((ofRightAdjoint i).unit.app A) := by
  suffices
    (ofRightAdjoint i).unit.app A =
      h.getIso.inv ≫
        (ofRightAdjoint i).unit.app (i.obj (Functor.essImage.witness h)) ≫
          (leftAdjoint i ⋙ i).map h.getIso.hom
    by
    rw [this]
    infer_instance
  rw [← NatTrans.naturality]
  simp
#align category_theory.functor.ess_image.unit_is_iso CategoryTheory.Functor.essImage.unit_isIso

/-- If `η_A` is an isomorphism, then `A` is in the essential image of `i`. -/

/-- If `η_A` is a split monomorphism, then `A` is in the reflective subcategory. -/
theorem mem_essImage_of_unit_isSplitMono [Reflective i] {A : C}
    [IsSplitMono ((ofRightAdjoint i).unit.app A)] : A ∈ i.essImage := by
  let η : 𝟭 C ⟶ leftAdjoint i ⋙ i := (ofRightAdjoint i).unit
  haveI : IsIso (η.app (i.obj ((leftAdjoint i).obj A))) :=
    Functor.essImage.unit_isIso ((i.obj_mem_essImage _))
  have : Epi (η.app A) := by
    refine @epi_of_epi _ _ _ _ _ (retraction (η.app A)) (η.app A) ?_
    rw [show retraction _ ≫ η.app A = _ from η.naturality (retraction (η.app A))]
    apply epi_comp (η.app (i.obj ((leftAdjoint i).obj A)))
  skip
  haveI := isIso_of_epi_of_isSplitMono (η.app A)
  exact mem_essImage_of_unit_isIso A
#align category_theory.mem_ess_image_of_unit_is_split_mono CategoryTheory.mem_essImage_of_unit_isSplitMono

/-- Composition of reflective functors. -/
instance Reflective.comp (F : C ⥤ D) (G : D ⥤ E) [Reflective F] [Reflective G] :
    Reflective (F ⋙ G) where toFaithful := Faithful.comp F G
#align category_theory.reflective.comp CategoryTheory.Reflective.comp

/-- (Implementation) Auxiliary definition for `unitCompPartialBijective`. -/
def unitCompPartialBijectiveAux [Reflective i] (A : C) (B : D) :
    (A ⟶ i.obj B) ≃ (i.obj ((leftAdjoint i).obj A) ⟶ i.obj B) :=
  ((Adjunction.ofRightAdjoint i).homEquiv _ _).symm.trans (equivOfFullyFaithful i)
#align category_theory.unit_comp_partial_bijective_aux CategoryTheory.unitCompPartialBijectiveAux

/-- The description of the inverse of the bijection `unitCompPartialBijectiveAux`. -/
theorem unitCompPartialBijectiveAux_symm_apply [Reflective i] {A : C} {B : D}
    (f : i.obj ((leftAdjoint i).obj A) ⟶ i.obj B) :
    (unitCompPartialBijectiveAux _ _).symm f = (ofRightAdjoint i).unit.app A ≫ f := by
  simp [unitCompPartialBijectiveAux]
#align category_theory.unit_comp_partial_bijective_aux_symm_apply CategoryTheory.unitCompPartialBijectiveAux_symm_apply

/-- If `i` has a reflector `L`, then the function `(i.obj (L.obj A) ⟶ B) → (A ⟶ B)` given by
precomposing with `η.app A` is a bijection provided `B` is in the essential image of `i`.
That is, the function `λ (f : i.obj (L.obj A) ⟶ B), η.app A ≫ f` is bijective, as long as `B` is in
the essential image of `i`.
This definition gives an equivalence: the key property that the inverse can be described
nicely is shown in `unitCompPartialBijective_symm_apply`.

This establishes there is a natural bijection `(A ⟶ B) ≃ (i.obj (L.obj A) ⟶ B)`. In other words,
from the point of view of objects in `D`, `A` and `i.obj (L.obj A)` look the same: specifically
that `η.app A` is an isomorphism.
-/
def unitCompPartialBijective [Reflective i] (A : C) {B : C} (hB : B ∈ i.essImage) :
    (A ⟶ B) ≃ (i.obj ((leftAdjoint i).obj A) ⟶ B) :=
  calc
    (A ⟶ B) ≃ (A ⟶ i.obj (Functor.essImage.witness hB)) := Iso.homCongr (Iso.refl _) hB.getIso.symm
    _ ≃ (i.obj _ ⟶ i.obj (Functor.essImage.witness hB)) := unitCompPartialBijectiveAux _ _
    _ ≃ (i.obj ((leftAdjoint i).obj A) ⟶ B) :=
      Iso.homCongr (Iso.refl _) (Functor.essImage.getIso hB)
#align category_theory.unit_comp_partial_bijective CategoryTheory.unitCompPartialBijective

@[simp]
theorem unitCompPartialBijective_symm_apply [Reflective i] (A : C) {B : C} (hB : B ∈ i.essImage)
    (f) : (unitCompPartialBijective A hB).symm f = (ofRightAdjoint i).unit.app A ≫ f := by
  simp [unitCompPartialBijective, unitCompPartialBijectiveAux_symm_apply]
#align category_theory.unit_comp_partial_bijective_symm_apply CategoryTheory.unitCompPartialBijective_symm_apply

theorem unitCompPartialBijective_symm_natural [Reflective i] (A : C) {B B' : C} (h : B ⟶ B')
    (hB : B ∈ i.essImage) (hB' : B' ∈ i.essImage) (f : i.obj ((leftAdjoint i).obj A) ⟶ B) :
    (unitCompPartialBijective A hB').symm (f ≫ h) = (unitCompPartialBijective A hB).symm f ≫ h := by
  simp
#align category_theory.unit_comp_partial_bijective_symm_natural CategoryTheory.unitCompPartialBijective_symm_natural

theorem unitCompPartialBijective_natural [Reflective i] (A : C) {B B' : C} (h : B ⟶ B')
    (hB : B ∈ i.essImage) (hB' : B' ∈ i.essImage) (f : A ⟶ B) :
    (unitCompPartialBijective A hB') (f ≫ h) = unitCompPartialBijective A hB f ≫ h := by
  rw [← Equiv.eq_symm_apply, unitCompPartialBijective_symm_natural A h, Equiv.symm_apply_apply]
#align category_theory.unit_comp_partial_bijective_natural CategoryTheory.unitCompPartialBijective_natural

instance [Reflective i] (X : Functor.EssImageSubcategory i) :
  IsIso (NatTrans.app (ofRightAdjoint i).unit X.obj) :=
Functor.essImage.unit_isIso X.property

-- porting note: the following auxiliary definition and the next two lemmas were
-- introduced in order to ease the port
/-- The counit isomorphism of the equivalence `D ≌ i.EssImageSubcategory` given
by `equivEssImageOfReflective` when the functor `i` is reflective. -/
def equivEssImageOfReflective_counitIso_app [Reflective i] (X : Functor.EssImageSubcategory i) :
  ((Functor.essImageInclusion i ⋙ leftAdjoint i) ⋙ Functor.toEssImage i).obj X ≅ X := by
  refine' Iso.symm (@asIso _ _ X _ ((ofRightAdjoint i).unit.app X.obj) ?_)
  refine @isIso_of_reflects_iso _ _ _ _ _ _ _ i.essImageInclusion ?_ _
  dsimp
  exact inferInstance

lemma equivEssImageOfReflective_map_counitIso_app_hom [Reflective i]
  (X : Functor.EssImageSubcategory i) :
  (Functor.essImageInclusion i).map (equivEssImageOfReflective_counitIso_app X).hom =
    inv (NatTrans.app (ofRightAdjoint i).unit X.obj) := by
    simp [equivEssImageOfReflective_counitIso_app, asIso]
    rfl

lemma equivEssImageOfReflective_map_counitIso_app_inv [Reflective i]
  (X : Functor.EssImageSubcategory i) :
  (Functor.essImageInclusion i).map (equivEssImageOfReflective_counitIso_app X).inv =
    (NatTrans.app (ofRightAdjoint i).unit X.obj) := rfl

/-- If `i : D ⥤ C` is reflective, the inverse functor of `i ≌ F.essImage` can be explicitly
defined by the reflector. -/
@[simps]
def equivEssImageOfReflective [Reflective i] : D ≌ i.EssImageSubcategory
    where
  functor := i.toEssImage
  inverse := i.essImageInclusion ⋙ (leftAdjoint i : _)
  unitIso :=
    NatIso.ofComponents (fun X => (asIso <| (ofRightAdjoint i).counit.app X).symm)
      (by
        intro X Y f
        dsimp
        rw [IsIso.comp_inv_eq, Category.assoc, IsIso.eq_inv_comp]
        exact ((ofRightAdjoint i).counit.naturality f).symm)
  counitIso :=
    NatIso.ofComponents equivEssImageOfReflective_counitIso_app
      (by
        intro X Y f
        apply (Functor.essImageInclusion i).map_injective
        have h := ((ofRightAdjoint i).unit.naturality f).symm
        rw [Functor.id_map] at h
        erw [Functor.map_comp, Functor.map_comp,
          equivEssImageOfReflective_map_counitIso_app_hom,
          equivEssImageOfReflective_map_counitIso_app_hom,
          IsIso.comp_inv_eq, assoc, ← h, IsIso.inv_hom_id_assoc, Functor.comp_map])
  functor_unitIso_comp := fun X => by
    -- porting note: this proof was automatically handled by the automation in mathlib
    apply (Functor.essImageInclusion i).map_injective
    erw [Functor.map_comp, equivEssImageOfReflective_map_counitIso_app_hom]
    aesop_cat
#align category_theory.equiv_ess_image_of_reflective CategoryTheory.equivEssImageOfReflective

end CategoryTheory


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import algebra.hom.group_instances
import topology.algebra.uniform_group
import topology.algebra.uniform_mul_action
import topology.uniform_space.completion

/-!
# Completion of topological groups:

This files endows the completion of a topological abelian group with a group structure.
More precisely the instance `uniform_space.completion.add_group` builds an abelian group structure
on the completion of an abelian group endowed with a compatible uniform structure.
Then the instance `uniform_space.completion.uniform_add_group` proves this group structure is
compatible with the completed uniform structure. The compatibility condition is `uniform_add_group`.

## Main declarations:

Beyond the instances explained above (that don't have to be explicitly invoked),
the main constructions deal with continuous group morphisms.

* `add_monoid_hom.extension`: extends a continuous group morphism from `G`
  to a complete separated group `H` to `completion G`.
* `add_monoid_hom.completion`: promotes a continuous group morphism
  from `G` to `H` into a continuous group morphism
  from `completion G` to `completion H`.
-/

noncomputable theory

variables {M R α β : Type*}

section group
open uniform_space Cauchy filter set
variables [uniform_space α]

instance [has_zero α] : has_zero (completion α) := ⟨(0 : α)⟩
instance [has_neg α] : has_neg (completion α) := ⟨completion.map (λa, -a : α → α)⟩
instance [has_add α] : has_add (completion α) := ⟨completion.map₂ (+)⟩
instance [has_sub α] : has_sub (completion α) := ⟨completion.map₂ has_sub.sub⟩

@[norm_cast]
lemma uniform_space.completion.coe_zero [has_zero α] : ((0 : α) : completion α) = 0 := rfl
end group

namespace uniform_space.completion
open uniform_space

section has_zero

instance [uniform_space α] [monoid_with_zero M] [has_zero α] [mul_action_with_zero M α]
  [has_uniform_continuous_const_smul M α] :
  mul_action_with_zero M (completion α) :=
{ smul := (•),
  smul_zero := λ r, by rw [← coe_zero, ← coe_smul, mul_action_with_zero.smul_zero r],
  zero_smul := ext' (continuous_const_smul _) continuous_const $ λ a,
    by rw [← coe_smul, zero_smul, coe_zero],
  .. completion.mul_action M α }

end has_zero

section uniform_add_group
variables [uniform_space α] [add_group α] [uniform_add_group α]

@[norm_cast]
lemma coe_neg (a : α) : ((- a : α) : completion α) = - a :=
(map_coe uniform_continuous_neg a).symm

@[norm_cast]
lemma coe_sub (a b : α) : ((a - b : α) : completion α) = a - b :=
(map₂_coe_coe a b has_sub.sub uniform_continuous_sub).symm

@[norm_cast]
lemma coe_add (a b : α) : ((a + b : α) : completion α) = a + b :=
(map₂_coe_coe a b (+) uniform_continuous_add).symm

instance : add_monoid (completion α) :=
{ zero_add     := assume a, completion.induction_on a
   (is_closed_eq (continuous_map₂ continuous_const continuous_id) continuous_id)
    (assume a, show 0 + (a : completion α) = a, by rw_mod_cast zero_add),
  add_zero     := assume a, completion.induction_on a
    (is_closed_eq (continuous_map₂ continuous_id continuous_const) continuous_id)
    (assume a, show (a : completion α) + 0 = a, by rw_mod_cast add_zero),
  add_assoc    := assume a b c, completion.induction_on₃ a b c
    (is_closed_eq
      (continuous_map₂
        (continuous_map₂ continuous_fst (continuous_fst.comp continuous_snd))
        (continuous_snd.comp continuous_snd))
      (continuous_map₂ continuous_fst
        (continuous_map₂
          (continuous_fst.comp continuous_snd)
          (continuous_snd.comp continuous_snd))))
    (assume a b c, show (a : completion α) + b + c = a + (b + c),
      by repeat { rw_mod_cast add_assoc }),
  nsmul := (•),
  nsmul_zero' := λ a, completion.induction_on a (is_closed_eq continuous_map continuous_const)
    (λ a, by rw [←coe_smul, ←coe_zero, zero_smul]),
  nsmul_succ' := λ n a, completion.induction_on a
    (is_closed_eq continuous_map $ continuous_map₂ continuous_id continuous_map)
    (λ a, by rw_mod_cast succ_nsmul ),
  .. completion.has_zero, ..completion.has_add, }

instance : sub_neg_monoid (completion α) :=
{ sub_eq_add_neg := λ a b, completion.induction_on₂ a b
    (is_closed_eq (continuous_map₂ continuous_fst continuous_snd)
      (continuous_map₂ continuous_fst (completion.continuous_map.comp continuous_snd)))
   (λ a b, by exact_mod_cast congr_arg coe (sub_eq_add_neg a b)),
  zsmul := (•),
  zsmul_zero' := λ a, completion.induction_on a (is_closed_eq continuous_map continuous_const)
    (λ a, by { rw_mod_cast zero_smul, refl} ),
  zsmul_succ' := λ n a, completion.induction_on a
    (is_closed_eq continuous_map $ continuous_map₂ continuous_id continuous_map)
    (λ a, by rw_mod_cast (show int.of_nat n.succ • a = a + int.of_nat n • a,
                          from sub_neg_monoid.zsmul_succ' n a) ),
  zsmul_neg' := λ n a, completion.induction_on a
    (is_closed_eq continuous_map $ completion.continuous_map.comp continuous_map)
    (λ a, by rw [←coe_smul, ←coe_smul, ←coe_neg, show -[1+ n] • a = -((n.succ : ℤ) • a),
                                                 from sub_neg_monoid.zsmul_neg' n a]),
  .. completion.add_monoid, .. completion.has_neg, .. completion.has_sub }

instance : add_group (completion α) :=
{ add_left_neg := assume a, completion.induction_on a
    (is_closed_eq (continuous_map₂ completion.continuous_map continuous_id) continuous_const)
    (assume a, show - (a : completion α) + a = 0, by { rw_mod_cast add_left_neg, refl }),
  .. completion.sub_neg_monoid }

instance : uniform_add_group (completion α) :=
⟨uniform_continuous_map₂ has_sub.sub⟩

instance {M} [monoid M] [distrib_mul_action M α] [has_uniform_continuous_const_smul M α] :
  distrib_mul_action M (completion α) :=
{ smul := (•),
  smul_add := λ r x y, induction_on₂ x y
    (is_closed_eq ((continuous_fst.add continuous_snd).const_smul _)
      ((continuous_fst.const_smul _).add (continuous_snd.const_smul _)))
    (λ a b, by simp only [← coe_add, ← coe_smul, smul_add]),
  smul_zero := λ r, by rw [← coe_zero, ← coe_smul, smul_zero r],
  .. completion.mul_action M α }

/-- The map from a group to its completion as a group hom. -/
@[simps] def to_compl : α →+ completion α :=
{ to_fun := coe,
  map_add' := coe_add,
  map_zero' := coe_zero }

lemma continuous_to_compl : continuous (to_compl : α → completion α) :=
continuous_coe α

end uniform_add_group

section uniform_add_comm_group
variables [uniform_space α] [add_comm_group α] [uniform_add_group α]

instance : add_comm_group (completion α) :=
{ add_comm  := assume a b, completion.induction_on₂ a b
    (is_closed_eq (continuous_map₂ continuous_fst continuous_snd)
      (continuous_map₂ continuous_snd continuous_fst))
    (assume x y, by { change ↑x + ↑y = ↑y + ↑x, rw [← coe_add, ← coe_add, add_comm]}),
  .. completion.add_group }

instance [semiring R] [module R α] [has_uniform_continuous_const_smul R α] :
  module R (completion α) :=
{ smul := (•),
  add_smul := λ a b, ext' (continuous_const_smul _)
    ((continuous_const_smul _).add (continuous_const_smul _)) $ λ x, by { norm_cast, rw add_smul },
  .. completion.distrib_mul_action, .. completion.mul_action_with_zero }

end uniform_add_comm_group

end uniform_space.completion

section add_monoid_hom
variables [uniform_space α] [add_group α] [uniform_add_group α]
          [uniform_space β] [add_group β] [uniform_add_group β]

open uniform_space uniform_space.completion

/-- Extension to the completion of a continuous group hom. -/
def add_monoid_hom.extension [complete_space β] [separated_space β] (f : α →+ β)
  (hf : continuous f) : completion α →+ β :=
have hf : uniform_continuous f, from uniform_continuous_add_monoid_hom_of_continuous hf,
{ to_fun := completion.extension f,
  map_zero' := by rw [← coe_zero, extension_coe hf, f.map_zero],
  map_add' := assume a b, completion.induction_on₂ a b
  (is_closed_eq
    (continuous_extension.comp continuous_add)
    ((continuous_extension.comp continuous_fst).add (continuous_extension.comp continuous_snd)))
  (λ a b, by rw_mod_cast [extension_coe hf, extension_coe hf, extension_coe hf,
    f.map_add]) }

lemma add_monoid_hom.extension_coe [complete_space β] [separated_space β] (f : α →+ β)
  (hf : continuous f) (a : α) : f.extension hf a = f a :=
extension_coe (uniform_continuous_add_monoid_hom_of_continuous hf) a

@[continuity]
lemma add_monoid_hom.continuous_extension [complete_space β] [separated_space β] (f : α →+ β)
  (hf : continuous f) : continuous (f.extension hf) :=
continuous_extension

/-- Completion of a continuous group hom, as a group hom. -/
def add_monoid_hom.completion (f : α →+ β) (hf : continuous f) : completion α →+ completion β :=
(to_compl.comp f).extension (continuous_to_compl.comp hf)

@[continuity]
lemma add_monoid_hom.continuous_completion (f : α →+ β)
  (hf : continuous f) : continuous (f.completion hf : completion α → completion β) :=
continuous_map

lemma add_monoid_hom.completion_coe (f : α →+ β)
  (hf : continuous f) (a : α) : f.completion hf a = f a :=
map_coe (uniform_continuous_add_monoid_hom_of_continuous hf) a

lemma add_monoid_hom.completion_zero : (0 : α →+ β).completion continuous_const = 0 :=
begin
  ext x,
  apply completion.induction_on x,
  { apply is_closed_eq ((0 : α →+ β).continuous_completion continuous_const),
    simp [continuous_const] },
  { intro a,
    simp [(0 : α →+ β).completion_coe continuous_const, coe_zero] }
end

lemma add_monoid_hom.completion_add {γ : Type*} [add_comm_group γ] [uniform_space γ]
  [uniform_add_group γ] (f g : α →+ γ) (hf : continuous f) (hg : continuous g) :
  (f + g).completion (hf.add hg) = f.completion hf + g.completion hg :=
begin
  have hfg := hf.add hg,
  ext x,
  apply completion.induction_on x,
  { exact is_closed_eq ((f+g).continuous_completion hfg)
    ((f.continuous_completion hf).add (g.continuous_completion hg)) },
  { intro a,
    simp [(f+g).completion_coe hfg, coe_add, f.completion_coe hf, g.completion_coe hg] }
end

end add_monoid_hom


import ring_theory.matrix
import .row_equivalence

universes u
variables {m n : ℕ}
variable {α : Type u}
variable [division_ring α]
variable [decidable_eq α]

def ge_aux_findpivot : (fin m) → (fin m) → (fin n) → (matrix (fin m) (fin n) α) → (matrix (fin m) (fin n) α)
| ⟨0, h₁⟩        i₀ j₀ M := M
| ⟨(k + 1), h₁⟩ i₀ j₀ M :=
        if k ≥ i₀.val then
            if M ⟨k+1, h₁⟩ j₀ ≠ 0
                then matrix.mul (elementary.swap α ⟨k+1, h₁⟩ i₀).to_matrix M
            else ge_aux_findpivot ⟨k, nat.lt_of_succ_lt h₁⟩ i₀ j₀ M
        else M

def ge_aux_improvepivot : (fin m) → (fin n) → (matrix (fin m) (fin n) α) → (matrix (fin m) (fin n) α) :=
λ i₀ j₀ M, if h : M i₀ j₀ ≠ 0
    then matrix.mul (elementary.scale i₀ ((M i₀ j₀)⁻¹) (inv_ne_zero h)).to_matrix M
    else M

def ge_aux_eliminate : Π (k : fin m) (i : fin m) (j : fin n) (M : matrix (fin m) (fin n) α) (h : M i j = 1), (matrix (fin m) (fin n) α) :=
λ k i j M h, if h₀ : k≠i then matrix.mul (elementary.linear_add k (-(M k j)) i h₀).to_matrix M else M

def ge_aux_eliminatecolumn : Π (k : fin m) (i : fin m) (j : fin n) (M : matrix (fin m) (fin n) α), (matrix (fin m) (fin n) α)
| ⟨0,h₁⟩ i j M := M
| ⟨k+1, h₁⟩ i j M := begin
    from if h : k < i.val then M else begin
        apply ge_aux_eliminatecolumn ⟨k, nat.lt_of_succ_lt h₁⟩ i j _ ,
        -- show matrix (fin m) (fin n) α,
        -- clear ge_aux_eliminatecolumn,
        -- cases n,
        -- exfalso,
        -- from nat.not_lt_zero j.val j.is_lt,
        -- cases m,
        -- exfalso,
        -- from nat.not_lt_zero i.val i.is_lt,
        -- have h₂, from (iff.elim_left nat.lt_iff_le_not_le),
        have h_ne : fin.mk (k+1) h₁ ≠ i,
        intros h_eq,
        apply h,
        cases h_eq,
        simp[nat.lt_succ_self 0],

        from matrix.mul (elementary.linear_add ⟨k+1, h₁⟩ (-(M ⟨k+1,h₁⟩ j)) i h_ne).to_matrix M,
        end
end

inductive row_reduction_step : (fin m) → (fin n) → matrix (fin m) (fin n) α → matrix (fin m) (fin n) α → Type u
| findpivot : Π (i : fin m) (j : fin n) (M : matrix (fin m) (fin n) α) (i₀ : fin m), row_reduction_step i j M (ge_aux_findpivot i₀ i j M)
| improvepivot : Π (i : fin m) (j : fin n) (M : matrix (fin m) (fin n) α), row_reduction_step i j M (ge_aux_improvepivot i j M)
| eliminate : Π (i : fin m) (j : fin n) (M : matrix (fin m) (fin n) α) (i₀ : fin m) (h : M i j = 1), row_reduction_step i j M (ge_aux_eliminate i₀ i j M h)

def ge_aux_findpivot_row_equivalent : Π (i : fin m) (i₀ : fin m) (j₀ : fin n) (M : matrix (fin m) (fin n) α), row_equivalent M (ge_aux_findpivot i i₀ j₀ M)
| ⟨0, h₀⟩   i₀ j₀ M :=
begin
    simp[ge_aux_findpivot],
    from row_equivalent.nil,
end
| ⟨k+1, h₀⟩ i₀ j₀ M := begin
    unfold ge_aux_findpivot,
    split_ifs,
    from @row_equivalent_step.of_elementary m n α _ _ M (elementary.swap α ⟨k + 1, h₀⟩ i₀),
    apply ge_aux_findpivot_row_equivalent,
    from row_equivalent.nil,
end

-- set_option pp.proofs true

def ge_aux_improvepivot_row_equivalent : Π (i₀ : fin m) (j₀ : fin n) (M : matrix (fin m) (fin n) α), row_equivalent M (ge_aux_improvepivot i₀ j₀ M)
| i₀ j₀ M :=
begin
    simp[ge_aux_improvepivot],
    split_ifs,
    from @row_equivalent_step.of_elementary m n α _ _ M (elementary.scale i₀ (M i₀ j₀)⁻¹ (ge_aux_improvepivot._proof_1 i₀ j₀ M h)),
    from row_equivalent.nil
end

def ge_aux_eliminate_row_equivalent : Π (i : fin m) (i₀ : fin m) (j₀ : fin n) (M : matrix (fin m) (fin n) α) (h : M i₀ j₀ = 1), row_equivalent M (ge_aux_eliminate i i₀ j₀ M h)
| i i₀ j₀ M h :=
begin
    unfold ge_aux_eliminate,
    split_ifs,
    from @row_equivalent_step.of_elementary m n α _ _ M (elementary.linear_add i (-M i j₀) i₀ h_1),
    from row_equivalent.nil,
end

def ge_aux_eliminatecolumn_row_equivalent : Π (i : fin m) (i₀ : fin m) (j₀ : fin n) (M : matrix (fin m) (fin n) α), row_equivalent M (ge_aux_eliminatecolumn i i₀ j₀ M)
| ⟨0, h₀⟩ i₀ j₀ M :=
begin
    unfold ge_aux_eliminatecolumn,
    from row_equivalent.nil,
end
| ⟨k+1, h₀⟩ i₀ j₀ M :=
begin
    unfold ge_aux_eliminatecolumn,
    split_ifs,
    from row_equivalent.nil,
    apply row_equivalent.trans,
    show matrix (fin m) (fin n) α,
    from (matrix.mul
          (elementary.to_matrix
             (elementary.linear_add ⟨k + 1, h₀⟩ (-M ⟨k + 1, h₀⟩ j₀) i₀
                (ge_aux_eliminatecolumn._main._pack._proof_1 k h₀ i₀ h)))
          M),
    from @row_equivalent_step.of_elementary m n α _ _ M (elementary.linear_add ⟨k + 1, h₀⟩ (-M ⟨k + 1, h₀⟩ j₀) i₀
             (ge_aux_eliminatecolumn._main._pack._proof_1 k h₀ i₀ h)),
    apply ge_aux_eliminatecolumn_row_equivalent,
end

-- TODO: Why does bytecode generation fail?
-- def row_reduction_step.to_row_equivalent : Π {j : fin n} {i : fin m} {M N :  matrix (fin m) (fin n) α} (r : row_reduction_step i j M N), row_equivalent M N :=
-- begin
--     intros _ _ _ _ r,
--     induction r with i j M i₀ i j M i j M i₀ h,
--     from @ge_aux_findpivot_row_equivalent m n α _ _ i₀ i j M,
--     from @ge_aux_improvepivot_row_equivalent m n α _ _ i j M,
--     from @ge_aux_eliminate_row_equivalent m n α _ _ i₀ i j M h,
-- end

-- Note that bytecode generation fails even more seriously here! (Because they choose a red underline?)
-- def to_row_equivalent : Π {j : fin n} {i : fin m} {M N :  matrix (fin m) (fin n) α} (r : row_reduction_step i j M N), row_equivalent M N
-- | _ _ _ _ (row_reduction_step.findpivot i j M i₀) :=  @ge_aux_findpivot_row_equivalent m n α _ _ i₀ i j M
-- | _ _ _ _ (row_reduction_step.improvepivot i j M) :=  @ge_aux_improvepivot_row_equivalent m n α _ _ i j M
-- | _ _ _ _ (row_reduction_step.eliminate i j M i₀ h) := @ge_aux_eliminate_row_equivalent m n α _ _ i₀ i j M h

lemma nat.sub_lt_succ_of_lt_succ {a b : ℕ} : a < (nat.succ b) → b - a < (nat.succ b) :=
begin
    intro h,
    cases a,
    from nat.lt_succ_self b,
    from nat.lt_trans ((nat.sub_lt_of_pos_le (nat.succ a) b (nat.zero_lt_succ a)) (nat.le_of_lt_succ h)) (nat.lt_succ_self b),
end

@[simp] lemma nat.pred_lt_of_ne_zero {n : ℕ} : n ≠ 0 → nat.succ (nat.pred n) = n :=
begin
    intros h_nz,
    apply nat.succ_pred_eq_of_pos,
    have H₁, from @nat.eq_or_lt_of_le 0 n (nat.zero_le n),
    cases H₁,
    exfalso,
    from h_nz (eq.symm H₁),
    assumption,
end

lemma nat.pred_sub_lt {a b : ℕ} : b ≠ 0 → a < b → (nat.pred b) - a < b :=
begin
    intros h_n h,
    rw ←nat.pred_lt_of_ne_zero h_n,
    apply nat.sub_lt_succ_of_lt_succ,
    simp[nat.pred_lt_of_ne_zero h_n],
    from h,
end

lemma nat.lt_succ_of_succ_lt {a b : ℕ} : nat.succ a < b → a < nat.succ b :=
begin
    intros h,
    have ha, from nat.lt_succ_self a,
    have hb, from nat.lt_succ_self b,
    apply nat.lt_trans ha,
    apply nat.lt_trans,
    swap,
    from hb,
    from h
end

lemma nat.pred_pred_sub_lt_of_lt : Π {a b : ℕ}, nat.succ a < b → (nat.pred b) - a - 1 < b :=
begin
    intros a b h,
    have H₁, from @nat.sub_lt_succ_of_lt_succ (nat.succ a) (nat.pred b),
    rw nat.pred_lt_of_ne_zero at H₁,
    have H₂,
    from H₁ h,
    have H₃ : nat.pred b - nat.succ a = nat.pred b - a - 1,
    refl,
    rw ←H₃,
    from H₂,

    intros h₁,
    have H₂, from @nat.zero_lt_succ a,
    have H₃, from nat.lt_trans H₂ h,
    subst h₁,
    from nat.not_lt_zero 0 H₃,
end

lemma nat.lt_succ_pred : Π {n : ℕ}, (n ≠ 0) → (nat.pred n) < n :=
begin
    intros n h,
    have : (nat.pred n < nat.succ (nat.pred n)) = (nat.pred n < n),
    congr,
    from nat.pred_lt_of_ne_zero h,
    rw ←this,
    from nat.lt_succ_self (nat.pred n),
end

def ge_aux : Π (j : fin n) (i : fin m) (h_n : n ≠ 0) (h_m : m ≠ 0) (M : matrix (fin m) (fin n) α), (matrix (fin m) (fin n) α)
|     ⟨k₂, h₂⟩  ⟨0, h₁⟩  h_n h_m    M       :=
        begin  -- If we're on the last row, all we need to do is improve the pivot if we can
            from if M ⟨0, h₁⟩ ⟨k₂, h₂⟩ ≠ 0 then
                begin
                    apply ge_aux_improvepivot,
                    from ⟨nat.pred m, nat.pred_lt h_m⟩,

                    from ⟨(nat.pred n) - k₂, nat.pred_sub_lt h_n h₂⟩,
                    from M,
                end
            else M,
        end
|  ⟨0, h₂⟩  ⟨k₁+1, h₁⟩ h_n h_m   M    :=
        begin  -- If we're in the last column, all we need to do is eliminate that column

            -- have H₁, from @nat.sub_lt_succ_of_lt_succ k₁ (nat.pred m) (nat.lt_of_succ_lt h₁),
            let toplefti : fin m := ⟨(nat.pred m)-k₁-1, nat.pred_pred_sub_lt_of_lt h₁⟩,
            let topleftj : fin n := ⟨nat.pred n, nat.pred_lt h_n⟩,

            let bottomrow : fin m := ⟨nat.pred m, nat.pred_lt h_m⟩,

            have M₁ : matrix (fin m) (fin n) α,
            apply ge_aux_findpivot bottomrow toplefti topleftj M,

            from if H₁ : (M₁ toplefti topleftj ≠ 0) then begin
                apply ge_aux_eliminatecolumn,
                from bottomrow,
                from toplefti,
                from topleftj,

                apply ge_aux_improvepivot,
                from toplefti,
                from topleftj,

                from M₁,
                repeat {assumption},
            end else M₁,
        end
| ⟨k₂+1, h₂⟩  ⟨k₁+1, h₁⟩ h_n h_m  M   :=
        begin
            apply ge_aux,
            show matrix (fin m) (fin n) α,

            let toplefti : (fin m) := ⟨(nat.pred m)-k₁-1, nat.pred_pred_sub_lt_of_lt h₁⟩,
            let topleftj : (fin n) := ⟨(nat.pred n)-k₂-1, nat.pred_pred_sub_lt_of_lt h₂⟩,

            let bottomrow : fin (m) := ⟨nat.pred m, nat.pred_lt h_m⟩,

            have M₁ : matrix (fin m) (fin n) α,
            from ge_aux_findpivot bottomrow toplefti topleftj M,

            from if H₁ : (M₁ toplefti topleftj ≠ 0) then begin
                apply ge_aux_eliminatecolumn,
                from bottomrow,
                from toplefti,
                from topleftj,

                -- show matrix _ _ α,
                apply ge_aux_improvepivot,
                from toplefti,
                from topleftj,

                from M₁,
                repeat {assumption},
            end else M₁,

            from ⟨k₂, nat.lt_of_succ_lt h₂⟩,

            let toplefti : fin m := ⟨(nat.pred m)-k₁-1, nat.pred_pred_sub_lt_of_lt h₁⟩,
            let topleftj : fin n := ⟨(nat.pred n)-k₂-1, nat.pred_pred_sub_lt_of_lt h₂⟩,

            let bottomrow : fin m := ⟨nat.pred m, nat.pred_lt h_m⟩,

            have M₁ : matrix (fin m) (fin n) α,
            from ge_aux_findpivot bottomrow toplefti topleftj M,

            from if H₁ : (M₁ toplefti topleftj ≠ 0)
            then ⟨k₁, nat.lt_of_succ_lt h₁⟩
            else ⟨k₁+1, h₁⟩,
            from h_n,
            from h_m,
        end

def gaussian_elimination : Π {m n : ℕ}, matrix (fin m) (fin n) α → matrix (fin m) (fin n) α
| 0 _ M := M
| _ 0 M := M
| (m+1) (n+1) M :=
begin
refine ge_aux ⟨ n, nat.lt_succ_self _ ⟩ ⟨ m, nat.lt_succ_self _ ⟩ _ _ M,
sorry, sorry
end

-- def gaussian_elimination (M : matrix (fin m) (fin n) α) : matrix (fin m) (fin n) α :=
-- begin
--     by_cases h_m : m = 0,
--     from M,
--     by_cases h_n : n = 0,
--     from M,

--     have h₁, from nat.pred_lt_of_ne_zero h_m,
--     have h₂, from nat.pred_lt_of_ne_zero h_n,

--     apply ge_aux,
--     from ⟨nat.pred n, nat.lt_succ_pred h_n⟩,
--     from ⟨nat.pred m, nat.lt_succ_pred h_m⟩,
--     from h_n,
--     from h_m,
--     from M,
-- end

def ge_aux_row_equivalent : Π (j : fin n) (i : fin m) (h_n : n ≠ 0) (h_m : m ≠ 0) (M : matrix (fin m) (fin n) α), row_equivalent M (ge_aux j i h_n h_m M)
| ⟨0, j_is_lt⟩ ⟨0, i_is_lt⟩ h_n h_m M :=
begin
    simp[ge_aux],
    split_ifs,
    from row_equivalent.nil,
    apply row_equivalent.trans,

    swap,
    apply ge_aux_improvepivot_row_equivalent,
    from row_equivalent.nil,
end
| ⟨j+1, j_is_lt⟩ ⟨0, i_is_lt⟩ h_n h_m M :=
begin
    simp[ge_aux],
    split_ifs,
    from row_equivalent.nil,

    apply row_equivalent.trans,
    swap,
    apply ge_aux_improvepivot_row_equivalent,
    from row_equivalent.nil,
end
| ⟨0, j_is_lt⟩ ⟨i+1, i_is_lt⟩ h_n h_m M :=
begin
    simp[ge_aux],
    split_ifs,
    apply ge_aux_findpivot_row_equivalent,

    apply row_equivalent.trans,
    show row_equivalent M (ge_aux_findpivot ⟨nat.pred m, _⟩ ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n, _⟩ M),
    apply ge_aux_findpivot_row_equivalent,
    apply row_equivalent.trans,
    show row_equivalent _ (ge_aux_improvepivot ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n, _⟩
          (ge_aux_findpivot ⟨nat.pred m, _⟩ ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n, _⟩ M)),
    apply ge_aux_improvepivot_row_equivalent,
    apply ge_aux_eliminatecolumn_row_equivalent,
end
| ⟨j + 1, j_is_lt⟩ ⟨i + 1, i_is_lt⟩ h_n h_m M :=
begin
    simp[ge_aux],
    split_ifs,
    apply row_equivalent.trans,
    swap,
    apply ge_aux_row_equivalent,
    apply ge_aux_findpivot_row_equivalent,

    apply row_equivalent.trans,
    show row_equivalent M (ge_aux_findpivot ⟨nat.pred m, _⟩ ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n - j - 1, _⟩ M),
    apply ge_aux_findpivot_row_equivalent,
    apply row_equivalent.trans,
    show row_equivalent _  (ge_aux_improvepivot ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n - j - 1, _⟩
             (ge_aux_findpivot ⟨nat.pred m, _⟩ ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n - j - 1, _⟩ M)),
    apply ge_aux_improvepivot_row_equivalent,
    apply row_equivalent.trans,
    show row_equivalent _ (ge_aux_eliminatecolumn ⟨nat.pred m, _⟩ ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n - j - 1, _⟩
          (ge_aux_improvepivot ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n - j - 1, _⟩
             (ge_aux_findpivot ⟨nat.pred m, _⟩ ⟨nat.pred m - i - 1, _⟩ ⟨nat.pred n - j - 1, _⟩ M))),
    apply ge_aux_eliminatecolumn_row_equivalent,
    apply ge_aux_row_equivalent,
end

def gaussian_elimination.row_equivalent : Π (M : matrix (fin m) (fin n) α), row_equivalent M (gaussian_elimination M) :=
begin
    intros,
    cases m;cases n;
    simp[gaussian_elimination],
    from row_equivalent.nil,
    from row_equivalent.nil,
    from row_equivalent.nil,
    apply ge_aux_row_equivalent,
end


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

! This file was ported from Lean 3 source module algebra.order.positive.ring
! leanprover-community/mathlib commit 655994e298904d7e5bbd1e18c95defd7b543eb94
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Ring.Defs
import Mathlib.Algebra.Ring.InjSurj

/-!
# Algebraic structures on the set of positive numbers

In this file we define various instances (`AddSemigroup`, `OrderedCommMonoid` etc) on the
type `{x : R // 0 < x}`. In each case we try to require the weakest possible typeclass
assumptions on `R` but possibly, there is a room for improvements.
-/

open Function

namespace Positive

variable {M R K : Type _}

section AddBasic

variable [AddMonoid M] [Preorder M] [CovariantClass M M (· + ·) (· < ·)]

instance : Add { x : M // 0 < x } :=
  ⟨fun x y => ⟨x + y, add_pos x.2 y.2⟩⟩

@[simp, norm_cast]
theorem coe_add (x y : { x : M // 0 < x }) : ↑(x + y) = (x + y : M) :=
  rfl
#align positive.coe_add Positive.coe_add

instance addSemigroup : AddSemigroup { x : M // 0 < x } :=
  Subtype.coe_injective.addSemigroup _ coe_add
#align positive.subtype.add_semigroup Positive.addSemigroup

instance addCommSemigroup {M : Type _} [AddCommMonoid M] [Preorder M]
    [CovariantClass M M (· + ·) (· < ·)] : AddCommSemigroup { x : M // 0 < x } :=
  Subtype.coe_injective.addCommSemigroup _ coe_add
#align positive.subtype.add_comm_semigroup Positive.addCommSemigroup

instance addLeftCancelSemigroup {M : Type _} [AddLeftCancelMonoid M] [Preorder M]
    [CovariantClass M M (· + ·) (· < ·)] : AddLeftCancelSemigroup { x : M // 0 < x } :=
  Subtype.coe_injective.addLeftCancelSemigroup _ coe_add
#align positive.subtype.add_left_cancel_semigroup Positive.addLeftCancelSemigroup

instance addRightCancelSemigroup {M : Type _} [AddRightCancelMonoid M] [Preorder M]
    [CovariantClass M M (· + ·) (· < ·)] : AddRightCancelSemigroup { x : M // 0 < x } :=
  Subtype.coe_injective.addRightCancelSemigroup _ coe_add
#align positive.subtype.add_right_cancel_semigroup Positive.addRightCancelSemigroup

instance covariantClass_add_lt :
    CovariantClass { x : M // 0 < x } { x : M // 0 < x } (· + ·) (· < ·) :=
  ⟨fun _ y z hyz => Subtype.coe_lt_coe.1 <| add_lt_add_left (show (y : M) < z from hyz) _⟩
#align positive.covariant_class_add_lt Positive.covariantClass_add_lt

instance covariantClass_swap_add_lt [CovariantClass M M (swap (· + ·)) (· < ·)] :
    CovariantClass { x : M // 0 < x } { x : M // 0 < x } (swap (· + ·)) (· < ·) :=
  ⟨fun _ y z hyz => Subtype.coe_lt_coe.1 <| add_lt_add_right (show (y : M) < z from hyz) _⟩
#align positive.covariant_class_swap_add_lt Positive.covariantClass_swap_add_lt

instance contravariantClass_add_lt [ContravariantClass M M (· + ·) (· < ·)] :
    ContravariantClass { x : M // 0 < x } { x : M // 0 < x } (· + ·) (· < ·) :=
  ⟨fun _ _ _ h => Subtype.coe_lt_coe.1 <| lt_of_add_lt_add_left h⟩
#align positive.contravariant_class_add_lt Positive.contravariantClass_add_lt

instance contravariantClass_swap_add_lt [ContravariantClass M M (swap (· + ·)) (· < ·)] :
    ContravariantClass { x : M // 0 < x } { x : M // 0 < x } (swap (· + ·)) (· < ·) :=
  ⟨fun _ _ _ h => Subtype.coe_lt_coe.1 <| lt_of_add_lt_add_right h⟩
#align positive.contravariant_class_swap_add_lt Positive.contravariantClass_swap_add_lt

instance contravariantClass_add_le [ContravariantClass M M (· + ·) (· ≤ ·)] :
    ContravariantClass { x : M // 0 < x } { x : M // 0 < x } (· + ·) (· ≤ ·) :=
  ⟨fun _ _ _ h => Subtype.coe_le_coe.1 <| le_of_add_le_add_left h⟩
#align positive.contravariant_class_add_le Positive.contravariantClass_add_le

instance contravariantClass_swap_add_le [ContravariantClass M M (swap (· + ·)) (· ≤ ·)] :
    ContravariantClass { x : M // 0 < x } { x : M // 0 < x } (swap (· + ·)) (· ≤ ·) :=
  ⟨fun _ _ _ h => Subtype.coe_le_coe.1 <| le_of_add_le_add_right h⟩
#align positive.contravariant_class_swap_add_le Positive.contravariantClass_swap_add_le

end AddBasic

instance covariantClass_add_le [AddMonoid M] [PartialOrder M]
    [CovariantClass M M (· + ·) (· < ·)] :
    CovariantClass { x : M // 0 < x } { x : M // 0 < x } (· + ·) (· ≤ ·) :=
  ⟨@fun _ _ _ h₁ => StrictMono.monotone (fun _ _ h => add_lt_add_left h _) h₁⟩
#align positive.covariant_class_add_le Positive.covariantClass_add_le

section Mul

variable [StrictOrderedSemiring R]

instance : Mul { x : R // 0 < x } :=
  ⟨fun x y => ⟨x * y, mul_pos x.2 y.2⟩⟩

@[simp]
theorem val_mul (x y : { x : R // 0 < x }) : ↑(x * y) = (x * y : R) :=
  rfl
#align positive.coe_mul Positive.val_mul

instance : Pow { x : R // 0 < x } ℕ :=
  ⟨fun x n => ⟨(x : R) ^ n , pow_pos x.2 n⟩⟩

@[simp]
theorem val_pow (x : { x : R // 0 < x }) (n : ℕ) :
    (x ^ n : R) = (x : R) ^ n :=
  rfl
#align positive.coe_pow Positive.val_pow

instance : Semigroup { x : R // 0 < x } :=
  Subtype.coe_injective.semigroup Subtype.val val_mul

instance : Distrib { x : R // 0 < x } :=
  Subtype.coe_injective.distrib _ coe_add val_mul

instance [Nontrivial R] : One { x : R // 0 < x } :=
  ⟨⟨1, one_pos⟩⟩

@[simp]
theorem val_one [Nontrivial R] : ((1 : { x : R // 0 < x }) : R) = 1 :=
  rfl
#align positive.coe_one Positive.val_one

instance [Nontrivial R] : Monoid { x : R // 0 < x } :=
  Subtype.coe_injective.monoid _ val_one val_mul val_pow

end Mul

section mul_comm

instance orderedCommMonoid [StrictOrderedCommSemiring R] [Nontrivial R] :
    OrderedCommMonoid { x : R // 0 < x } :=
  { Subtype.partialOrder _,
    Subtype.coe_injective.commMonoid (M₂ := R) (Subtype.val) val_one val_mul val_pow with
    mul_le_mul_left := fun _ _ hxy c =>
      Subtype.coe_le_coe.1 <| mul_le_mul_of_nonneg_left hxy c.2.le }
#align positive.subtype.ordered_comm_monoid Positive.orderedCommMonoid

/-- If `R` is a nontrivial linear ordered commutative semiring, then `{x : R // 0 < x}` is a linear
ordered cancellative commutative monoid. -/
instance linearOrderedCancelCommMonoid [LinearOrderedCommSemiring R] :
    LinearOrderedCancelCommMonoid { x : R // 0 < x } :=
  { Subtype.linearOrder _, Positive.orderedCommMonoid with
    le_of_mul_le_mul_left := fun a _ _ h => Subtype.coe_le_coe.1 <| (mul_le_mul_left a.2).1 h }
#align positive.subtype.linear_ordered_cancel_comm_monoid Positive.linearOrderedCancelCommMonoid

end mul_comm

end Positive