/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.abel
import Mathlib.category_theory.limits.shapes.biproducts
import Mathlib.category_theory.preadditive.default
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Basic facts about morphisms between biproducts in preadditive categories.

* In any category (with zero morphisms), if `biprod.map f g` is an isomorphism,
  then both `f` and `g` are isomorphisms.

The remaining lemmas hold in any preadditive category.

* If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
  so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
  via Gaussian elimination.

* As a corollary of the previous two facts,
  if we have an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  we can construct an isomorphism `X₂ ≅ Y₂`.

* If `f : W ⊞ X ⟶ Y ⊞ Z` is an isomorphism, either `𝟙 W = 0`,
  or at least one of the component maps `W ⟶ Y` and `W ⟶ Z` is nonzero.

* If `f : ⨁ S ⟶ ⨁ T` is an isomorphism,
  then every column (corresponding to a nonzero summand in the domain)
  has some nonzero matrix entry.
-/

namespace category_theory

/--
If
```
(f 0)
(0 g)
```
is invertible, then `f` is invertible.
-/
def is_iso_left_of_is_iso_biprod_map {C : Type u} [category C] [limits.has_zero_morphisms C] [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [is_iso (limits.biprod.map f g)] : is_iso f :=
  is_iso.mk (limits.biprod.inl ≫ inv (limits.biprod.map f g) ≫ limits.biprod.fst)

/--
If
```
(f 0)
(0 g)
```
is invertible, then `g` is invertible.
-/
def is_iso_right_of_is_iso_biprod_map {C : Type u} [category C] [limits.has_zero_morphisms C] [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [is_iso (limits.biprod.map f g)] : is_iso g :=
  let _inst : is_iso (limits.biprod.map g f) := eq.mpr sorry is_iso.comp_is_iso;
  is_iso_left_of_is_iso_biprod_map g f

/--
The "matrix" morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` with specified components.
-/
def biprod.of_components {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂ :=
  limits.biprod.fst ≫ f₁₁ ≫ limits.biprod.inl + limits.biprod.fst ≫ f₁₂ ≫ limits.biprod.inr +
      limits.biprod.snd ≫ f₂₁ ≫ limits.biprod.inl +
    limits.biprod.snd ≫ f₂₂ ≫ limits.biprod.inr

@[simp] theorem biprod.inl_of_components {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : limits.biprod.inl ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ = f₁₁ ≫ limits.biprod.inl + f₁₂ ≫ limits.biprod.inr := sorry

@[simp] theorem biprod.inr_of_components {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : limits.biprod.inr ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ = f₂₁ ≫ limits.biprod.inl + f₂₂ ≫ limits.biprod.inr := sorry

@[simp] theorem biprod.of_components_fst {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ limits.biprod.fst = limits.biprod.fst ≫ f₁₁ + limits.biprod.snd ≫ f₂₁ := sorry

@[simp] theorem biprod.of_components_snd {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ limits.biprod.snd = limits.biprod.fst ≫ f₁₂ + limits.biprod.snd ≫ f₂₂ := sorry

@[simp] theorem biprod.of_components_eq {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) : biprod.of_components (limits.biprod.inl ≫ f ≫ limits.biprod.fst) (limits.biprod.inl ≫ f ≫ limits.biprod.snd)
    (limits.biprod.inr ≫ f ≫ limits.biprod.fst) (limits.biprod.inr ≫ f ≫ limits.biprod.snd) =
  f := sorry

@[simp] theorem biprod.of_components_comp {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} {Z₁ : C} {Z₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) (g₁₁ : Y₁ ⟶ Z₁) (g₁₂ : Y₁ ⟶ Z₂) (g₂₁ : Y₂ ⟶ Z₁) (g₂₂ : Y₂ ⟶ Z₂) : biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.of_components g₁₁ g₁₂ g₂₁ g₂₂ =
  biprod.of_components (f₁₁ ≫ g₁₁ + f₁₂ ≫ g₂₁) (f₁₁ ≫ g₁₂ + f₁₂ ≫ g₂₂) (f₂₁ ≫ g₁₁ + f₂₂ ≫ g₂₁) (f₂₁ ≫ g₁₂ + f₂₂ ≫ g₂₂) := sorry

/--
The unipotent upper triangular matrix
```
(1 r)
(0 1)
```
as an isomorphism.
-/
@[simp] theorem biprod.unipotent_upper_hom {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} (r : X₁ ⟶ X₂) : iso.hom (biprod.unipotent_upper r) = biprod.of_components 𝟙 r 0 𝟙 :=
  Eq.refl (iso.hom (biprod.unipotent_upper r))

/--
The unipotent lower triangular matrix
```
(1 0)
(r 1)
```
as an isomorphism.
-/
@[simp] theorem biprod.unipotent_lower_hom {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} (r : X₂ ⟶ X₁) : iso.hom (biprod.unipotent_lower r) = biprod.of_components 𝟙 0 r 𝟙 :=
  Eq.refl (iso.hom (biprod.unipotent_lower r))

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.

(This is the version of `biprod.gaussian` written in terms of components.)
-/
def biprod.gaussian' {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) [is_iso f₁₁] : psigma
  fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
    psigma
      fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
        psigma
          fun (g₂₂ : X₂ ⟶ Y₂) =>
            iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g₂₂ :=
  psigma.mk (biprod.unipotent_lower (-f₂₁ ≫ inv f₁₁))
    (psigma.mk (biprod.unipotent_upper (-inv f₁₁ ≫ f₁₂)) (psigma.mk (f₂₂ - f₂₁ ≫ inv f₁₁ ≫ f₁₂) sorry))

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.
-/
def biprod.gaussian {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) [is_iso (limits.biprod.inl ≫ f ≫ limits.biprod.fst)] : psigma
  fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
    psigma
      fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
        psigma
          fun (g₂₂ : X₂ ⟶ Y₂) =>
            iso.hom L ≫ f ≫ iso.hom R = limits.biprod.map (limits.biprod.inl ≫ f ≫ limits.biprod.fst) g₂₂ :=
  let this :
    psigma
      fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
        psigma
          fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
            psigma
              fun (g₂₂ : X₂ ⟶ Y₂) =>
                iso.hom L ≫
                    biprod.of_components (limits.biprod.inl ≫ f ≫ limits.biprod.fst)
                        (limits.biprod.inl ≫ f ≫ limits.biprod.snd) (limits.biprod.inr ≫ f ≫ limits.biprod.fst)
                        (limits.biprod.inr ≫ f ≫ limits.biprod.snd) ≫
                      iso.hom R =
                  limits.biprod.map (limits.biprod.inl ≫ f ≫ limits.biprod.fst) g₂₂ :=
    biprod.gaussian' (limits.biprod.inl ≫ f ≫ limits.biprod.fst) (limits.biprod.inl ≫ f ≫ limits.biprod.snd)
      (limits.biprod.inr ≫ f ≫ limits.biprod.fst) (limits.biprod.inr ≫ f ≫ limits.biprod.snd);
  eq.mpr sorry (eq.mp sorry this)

/--
If `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` via a two-by-two matrix whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim' {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) [is_iso f₁₁] [is_iso (biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂)] : X₂ ≅ Y₂ :=
  psigma.cases_on (biprod.gaussian' f₁₁ f₁₂ f₂₁ f₂₂)
    fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂)
      (snd :
      psigma
        fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
          psigma
            fun (g₂₂ : X₂ ⟶ Y₂) =>
              iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g₂₂) =>
      psigma.cases_on snd
        fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂)
          (snd_snd :
          psigma
            fun (g₂₂ : X₂ ⟶ Y₂) =>
              iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g₂₂) =>
          psigma.cases_on snd_snd
            fun (g : X₂ ⟶ Y₂)
              (w : iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g) =>
              let _inst : is_iso (limits.biprod.map f₁₁ g) := eq.mpr sorry is_iso.comp_is_iso;
              let _inst_6 : is_iso g := is_iso_right_of_is_iso_biprod_map f₁₁ g;
              as_iso g

/--
If `f` is an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂) [is_iso (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst)] : X₂ ≅ Y₂ :=
  let _inst :
    is_iso
      (biprod.of_components (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst)
        (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.snd) (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.fst)
        (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.snd)) :=
    eq.mpr sorry (is_iso.of_iso f);
  biprod.iso_elim' (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst) (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.snd)
    (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.fst) (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.snd)

theorem biprod.column_nonzero_of_iso {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⊞ X ⟶ Y ⊞ Z) [is_iso f] : 𝟙 = 0 ∨ limits.biprod.inl ≫ f ≫ limits.biprod.fst ≠ 0 ∨ limits.biprod.inl ≫ f ≫ limits.biprod.snd ≠ 0 := sorry

theorem biproduct.column_nonzero_of_iso' {C : Type u} [category C] [preadditive C] {σ : Type v} {τ : Type v} [DecidableEq σ] [DecidableEq τ] [fintype τ] {S : σ → C} [limits.has_biproduct S] {T : τ → C} [limits.has_biproduct T] (s : σ) (f : ⨁ S ⟶ ⨁ T) [is_iso f] : (∀ (t : τ), limits.biproduct.ι S s ≫ f ≫ limits.biproduct.π T t = 0) → 𝟙 = 0 := sorry

/--
If `f : ⨁ S ⟶ ⨁ T` is an isomorphism, and `s` is a non-trivial summand of the source,
then there is some `t` in the target so that the `s, t` matrix entry of `f` is nonzero.
-/
def biproduct.column_nonzero_of_iso {C : Type u} [category C] [preadditive C] {σ : Type v} {τ : Type v} [DecidableEq σ] [DecidableEq τ] [fintype τ] {S : σ → C} [limits.has_biproduct S] {T : τ → C} [limits.has_biproduct T] (s : σ) (nz : 𝟙 ≠ 0) [(t : τ) → DecidableEq (S s ⟶ T t)] (f : ⨁ S ⟶ ⨁ T) [is_iso f] : trunc (psigma fun (t : τ) => limits.biproduct.ι S s ≫ f ≫ limits.biproduct.π T t ≠ 0) :=
  trunc_sigma_of_exists sorry


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

/-!
# Extra definitions on `option`

This file defines more operations involving `option α`. Lemmas about them are located in other
files under `data.option.`.
Other basic operations on `option` are defined in the core library.
-/

namespace option
variables {α : Type*} {β : Type*}

attribute [inline] option.is_some option.is_none

/-- An elimination principle for `option`. It is a nondependent version of `option.rec`. -/
@[simp] protected def elim (b : β) (f : α → β) : option α → β
| (some a) := f a
| none     := b

instance has_mem : has_mem α (option α) := ⟨λ a b, b = some a⟩

@[simp] theorem mem_def {a : α} {b : option α} : a ∈ b ↔ b = some a :=
iff.rfl

lemma mem_iff {a : α} {b : option α} : a ∈ b ↔ b = a := iff.rfl

theorem is_none_iff_eq_none {o : option α} : o.is_none = tt ↔ o = none :=
⟨option.eq_none_of_is_none, λ e, e.symm ▸ rfl⟩

theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp

lemma mem_some_iff {α : Type*} {a b : α} : a ∈ some b ↔ b = a :=
by simp

/--
`o = none` is decidable even if the wrapped type does not have decidable equality.

This is not an instance because it is not definitionally equal to `option.decidable_eq`.
Try to use `o.is_none` or `o.is_some` instead.
-/
@[inline]
def decidable_eq_none {o : option α} : decidable (o = none) :=
decidable_of_decidable_of_iff (bool.decidable_eq _ _) is_none_iff_eq_none

instance decidable_forall_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∀ a ∈ o, p a)
| none     := is_true (by simp [false_implies_iff])
| (some a) := if h : p a
  then is_true $ λ o e, some_inj.1 e ▸ h
  else is_false $ mt (λ H, H _ rfl) h

instance decidable_exists_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∃ a ∈ o, p a)
| none     := is_false (λ ⟨a, ⟨h, _⟩⟩, by cases h)
| (some a) := if h : p a
  then is_true $ ⟨_, rfl, h⟩
  else is_false $ λ ⟨_, ⟨rfl, hn⟩⟩, h hn

/-- Inhabited `get` function. Returns `a` if the input is `some a`, otherwise returns `default`. -/
@[reducible] def iget [inhabited α] : option α → α
| (some x) := x
| none     := default

@[simp] theorem iget_some [inhabited α] {a : α} : (some a).iget = a := rfl

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [decidable_pred p] (a : α) : option α :=
if p a then some a else none

/-- `filter p o` returns `some a` if `o` is `some a` and `p a` holds, otherwise `none`. -/
def filter (p : α → Prop) [decidable_pred p] (o : option α) : option α :=
o.bind (guard p)

/-- Cast of `option` to `list `. Returns `[a]` if the input is `some a`, and `[]` if it is
`none`. -/
def to_list : option α → list α
| none     := []
| (some a) := [a]

@[simp] theorem mem_to_list {a : α} {o : option α} : a ∈ to_list o ↔ a ∈ o :=
by cases o; simp [to_list, eq_comm]

/-- Two arguments failsafe function. Returns `f a b` if the inputs are `some a` and `some b`, and
"does nothing" otherwise. -/
def lift_or_get (f : α → α → α) : option α → option α → option α
| none     none     := none
| (some a) none     := some a       -- get a
| none     (some b) := some b       -- get b
| (some a) (some b) := some (f a b) -- lift f

instance lift_or_get_comm (f : α → α → α) [h : is_commutative α f] :
  is_commutative (option α) (lift_or_get f) :=
⟨λ a b, by cases a; cases b; simp [lift_or_get, h.comm]⟩

instance lift_or_get_assoc (f : α → α → α) [h : is_associative α f] :
  is_associative (option α) (lift_or_get f) :=
⟨λ a b c, by cases a; cases b; cases c; simp [lift_or_get, h.assoc]⟩

instance lift_or_get_idem (f : α → α → α) [h : is_idempotent α f] :
  is_idempotent (option α) (lift_or_get f) :=
⟨λ a, by cases a; simp [lift_or_get, h.idempotent]⟩

instance lift_or_get_is_left_id (f : α → α → α) :
  is_left_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

instance lift_or_get_is_right_id (f : α → α → α) :
  is_right_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

/-- Lifts a relation `α → β → Prop` to a relation `option α → option β → Prop` by just adding
`none ~ none`. -/
inductive rel (r : α → β → Prop) : option α → option β → Prop
/-- If `a ~ b`, then `some a ~ some b` -/
| some {a b} : r a b → rel (some a) (some b)
/-- `none ~ none` -/
| none       : rel none none

/-- Partial bind. If for some `x : option α`, `f : Π (a : α), a ∈ x → option β` is a
  partial function defined on `a : α` giving an `option β`, where `some a = x`,
  then `pbind x f h` is essentially the same as `bind x f`
  but is defined only when all `x = some a`, using the proof to apply `f`. -/
@[simp] def pbind : Π (x : option α), (Π (a : α), a ∈ x → option β) → option β
| none     _ := none
| (some a) f := f a rfl

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on `a : α` satisfying `p`,
then `pmap f x h` is essentially the same as `map f x` but is defined only when all members of `x`
satisfy `p`, using the proof to apply `f`. -/
@[simp] def pmap {p : α → Prop} (f : Π (a : α), p a → β) :
  Π x : option α, (∀ a ∈ x, p a) → option β
| none     _ := none
| (some a) H := some (f a (H a (mem_def.mpr rfl)))

/-- Flatten an `option` of `option`, a specialization of `mjoin`. -/
@[simp] def join : option (option α) → option α :=
λ x, bind x id

protected def {u v} traverse {F : Type u → Type v} [applicative F] {α β : Type*} (f : α → F β) :
  option α → F (option β)
| none     := pure none
| (some x) := some <$> f x

/- By analogy with `monad.sequence` in `init/category/combinators.lean`. -/

/-- If you maybe have a monadic computation in a `[monad m]` which produces a term of type `α`, then
there is a naturally associated way to always perform a computation in `m` which maybe produces a
result. -/
def {u v} maybe {m : Type u → Type v} [monad m] {α : Type u} : option (m α) → m (option α)
| none      := return none
| (some fn) := some <$> fn

/-- Map a monadic function `f : α → m β` over an `o : option α`, maybe producing a result. -/
def {u v w} mmap {m : Type u → Type v} [monad m] {α : Type w} {β : Type u} (f : α → m β)
  (o : option α) : m (option β) := (o.map f).maybe

/-- A monadic analogue of `option.elim`. -/
def melim {α β : Type*} {m : Type* → Type*} [monad m] (y : m β) (z : α → m β) (x : m (option α)) :
  m β :=
x >>= option.elim y z

/-- A monadic analogue of `option.get_or_else`. -/
def mget_or_else {α : Type*} {m : Type* → Type*} [monad m] (x : m (option α)) (y : m α) : m α :=
melim y pure x

end option


/- This file contains the construction of the presheaf of rings on Spec(R) and the proof
   that it satisfies the sheaf axiom for finite covers by basic open sets.

   We seem to need to explicitly tell Lean that something canonically isomorphic
   to an exact sequence is an exact sequence.

   We start with Kenny's non-canonical proof that something iso to a three term exact seq is exact.

   We then use my ghastly application coming from localization.

   This file corresponds to the line in tag01HR:
   "Thus we may apply Algebra, Lemma 10.22.2 to the module Mf over Rf and the elements g1,…,gn.
   We conclude that the sequence is exact."
   The issue is that there are a lot of diagrams which commute, but this needs checking.

-/
import algebra.group data.set data.equiv.basic -- for comm diag stuff
import tag00DY -- definition of standard basis on Spec(R) plus proof it's a basis
import tag00E0
import tag00EJ -- finite cover by basic opens sheaf axiom
import tag009I -- definition of presheaf of types on basis
import tag009L -- definition of basis_is_compact
--import group_theory.submonoid
import ring_theory.localization
import Kenny_comm_alg.Zariski
--import tag00E0
import tag01HS -- for "lemma_standard_open" giving map R[1/f] -> R[1/g] from D(g) ⊆ D(f)
--import tag009I -- presheaf of types on a basis
--import tag00DY -- claim that D(f) form a basis
--import tag006N -- presheaves / sheaves of rings on a basis
--import tag009P -- presheaf of rings on a basis
--import tag009L -- sheaf for finite covers on basis -> sheaf for basis
import tag00EJ
import linear_algebra -- for span

local attribute [instance] classical.prop_decidable

universes u0 u v w

definition Pi_lift_map₁ {γ : Type u} {F : γ → Type u} {G : γ → Type u}
  (H : ∀ i : γ, F i → G i) : (Π i, F i) → Π i, G i := λ Fi i, H i (Fi i)

definition Pi_lift_map₂ {γ : Type u} {X : Type u} {G : γ → Type u}
  (H : ∀ i : γ, X → G i) : X → Π i, G i := λ x i, H i x

namespace is_add_group_hom

variables {α : Type*} {β : Type*} [add_group α] [add_group β] (f : α → β) [hf : is_add_group_hom f]

instance ring_hom_is_add_group_hom {α β : Type u} [ring α] [ring β] (f : α → β) [is_ring_hom f] : is_add_group_hom f :=
⟨λ _ _, is_ring_hom.map_add f⟩

def ker : set α :=
{ x | f x = 0 }

instance Pi_lift {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, add_group (F i)]
[∀ i, add_group (G i)] (H : ∀ i : γ, F i → G i) [∀ i, is_add_group_hom (H i)] :
 is_add_group_hom (Pi_lift_map₁ H) := ⟨λ a b, funext $ λ i,
show H i ((a i) + (b i)) = H i (a i) + H i (b i),
by rw (add (H i))⟩

instance equiv.Pi_congr_right {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, add_group (F i)]
[∀ i, add_group (G i)] (H : ∀ i : γ, F i ≃ G i) [∀ i, is_add_group_hom (H i)] :
 is_add_group_hom (equiv.Pi_congr_right H) :=
-- is_add_group_hom.Pi_lift H
 is_add_group_hom.Pi_lift (λ i, H i)

end is_add_group_hom

namespace equiv

theorem to_fun.injective {α β : Type u} (e : α ≃ β) : function.injective e :=
function.injective_of_has_left_inverse ⟨e.symm,e.inverse_apply_apply⟩

end equiv

--class is_alg_hom (R : Type u) [ring R] {A B : Type u} [ring A] [ring B] (sA : R → A) (sB : R → B)
--[is_ring_hom sA] [is_ring_hom sB] (f : A → B) extends is_ring_hom f : Prop :=
--(commutes : ∀ r, f (sA r) = sB r)

namespace is_ring_hom

instance Pi_lift_map₁ {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, ring (F i)]
[∀ i, ring (G i)] (H : ∀ i : γ, F i → G i) [H' : ∀ i, is_ring_hom (H i)] :
 is_ring_hom (Pi_lift_map₁ H) :=
{ map_add := λ a b, funext $ λ x,begin
    show H x (a x + b x) = H x (a x) + H x (b x),
    rw (H' x).map_add,
    end,
  map_mul := λ a b, funext $ λ x,begin
    show H x (a x * b x) = H x (a x) * H x (b x),
    rw (H' x).map_mul,
    end,
  map_one := funext $ λ x,begin
    show H x 1 = 1,
    exact (H' x).map_one
  end
}

instance equiv.Pi_congr_right {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, ring (F i)]
[∀ i, ring (G i)] (H : ∀ i : γ, F i ≃ G i) [H' : ∀ i, is_ring_hom (H i)] :
 is_ring_hom (equiv.Pi_congr_right H) := is_ring_hom.Pi_lift_map₁ (λ i, H i)

end is_ring_hom

-- If A -> B -> C is isomorphic to A' -> B' -> C' and first sequence is exact then second is.
-- But I don't ever use this now.
/-
theorem three (A B C A' B' C' : Type*)
  [add_comm_group A] [add_comm_group A']
  [add_comm_group B] [add_comm_group B']
  [add_comm_group C] [add_comm_group C']
  (ab : A → B) [is_add_group_hom ab]
  (bc : B → C) [is_add_group_hom bc]
  (Habc : set.range ab = is_add_group_hom.ker bc)
  (fa : A ≃ A') [is_add_group_hom fa]
  (fb : B ≃ B') [is_add_group_hom fb]
  (fc : C ≃ C') [is_add_group_hom fc]

  (ab' : A' → B') [is_add_group_hom ab']
  (bc' : B' → C') [is_add_group_hom bc']
  (H1 : fb ∘ ab = ab' ∘ fa)
  (H2 : fc ∘ bc = bc' ∘ fb) :

  set.range ab' = is_add_group_hom.ker bc' :=
begin
  apply set.ext,
  intro b',
  split,
  { intro hb',
    cases hb' with a' ha',
    simp [is_add_group_hom.ker],
    let a := fa.symm a',
    have ha : fa a = a',
    { simp [a] },
    rw [← ha', ← ha],
    change bc' ((ab' ∘ fa) a) = 0,
    rw ← H1,
    change (bc' ∘ fb) (ab a) = 0,
    rw ← H2,
    have H3 : ab a ∈ is_add_group_hom.ker bc,
    { rw ← Habc, existsi a, simp },
    simp [is_add_group_hom.ker] at H3 ⊢,
    rw H3,
    apply is_add_group_hom.zero },
  { intro hb',
    let b := fb.symm b',
    have hb : fb b = b',
    { simp [b] },
    simp [is_add_group_hom.ker] at hb',
    rw ← hb at hb',
    change (bc' ∘ fb) b = 0 at hb',
    rw ← H2 at hb',
    rw ← is_add_group_hom.zero fc at hb',
    replace hb' := congr_arg fc.symm hb',
    simp at hb',
    have H3 : b ∈ set.range ab,
    { rwa Habc },
    cases H3 with a ha,
    existsi fa a,
    change (ab' ∘ fa) a = b',
    rw ← H1,
    simp [ha] }
end

-- Thanks Kenny.
-/

-- Now start moving stuff from tag01HR.lean which has got really
-- unwieldy. Here I am going to prove the sheaf on a finite basis
-- statement from the ring theory lemma tag00EJ

-- First here's the choice-free definition of the structure presheaf

def is_zariski.standard_open {R : Type u} [comm_ring R] (U : set (X R)) := ∃ f : R, U = Spec.D'(f)

def non_zero_on_U {R : Type u} [comm_ring R] (U : set (X R)) : set R := {g : R | U ⊆ Spec.D'(g)}

instance nonzero_on_U_is_mult_set {R : Type u} [comm_ring R] (U : set (X R)) : is_submonoid (non_zero_on_U U) :=
{ one_mem := λ P HP, @is_proper_ideal.one_not_mem _ _ P.1 P.2.1,
  mul_mem := begin
    intros f g Hf Hg,
    show U ⊆ Spec.D'(f*g),
    rw [tag00E0.lemma15 R f g],
    exact set.subset_inter Hf Hg
    end
}

lemma nonzero_on_U_mono {R : Type u} [comm_ring R] {U V : set (X R)} : V ⊆ U → non_zero_on_U U ⊆ non_zero_on_U V :=
λ H _,set.subset.trans H

def zariski.structure_presheaf_on_standard {R : Type u} [comm_ring R] (U : set (X R)) (H : is_zariski.standard_open U) : Type u :=
  @localization.loc R _ (non_zero_on_U U) (nonzero_on_U_is_mult_set U)

instance zariski.structure_presheaf_on_standard.comm_ring {R : Type u} [comm_ring R] (U : set (X R)) (H : is_zariski.standard_open U) :
comm_ring (zariski.structure_presheaf_on_standard U H) :=
@localization.comm_ring _ _ _ (nonzero_on_U_is_mult_set U)

-- A key notion for us is that of a canonical R-algebra isomorphism.
-- Because I still don't quite understand what makes an isomorphism
-- canonical let's just start with the notion of an R-algebra isomorphism.

structure R_alg_equiv {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  (sα : R → α) (sβ : R → β) extends ring_equiv α β :=
(R_alg_hom : sβ = to_fun ∘ sα)

instance R_alg_equiv_coe_to_fun {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  (sα : R → α) (sβ : R → β) : has_coe_to_fun (R_alg_equiv sα sβ) := ⟨_,λ h,h.to_fun⟩

instance R_alg_equiv_is_ring_hom {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  (sα : R → α) (sβ : R → β) (H : R_alg_equiv sα sβ) : is_ring_hom H := H.is_ring_hom

namespace R_alg_equiv

lemma symm {R : Type u} {α : Type v} {β : Type w}
  [comm_ring R] [comm_ring α] [comm_ring β]
  {sα : R → α} {sβ : R → β} :
  R_alg_equiv sα sβ → R_alg_equiv sβ sα :=
  λ H, { R_alg_hom := begin
         let f := H.to_fun,
         have H2 : sβ = f ∘ sα := H.R_alg_hom,
         let g := H.inv_fun,
         show sα = g ∘ sβ,
         rw H2,
         funext,
         show _ = g (f (sα x)),
         conv begin
           to_lhs,
           rw ←H.left_inv (sα x),
         end,
       end,
    ..(H.to_ring_equiv).symm
  }

/- we have his for ring_equiv and I've never implemented this version here
  lemma inv_fun_is_ring_hom {R : Type u} {α : Type v} {β : Type w}
  [comm_ring R] [comm_ring α] [comm_ring β]
  {sα : R → α} {sβ : R → β} (H : R_alg_equiv sα sβ) : is_ring_hom H.inv_fun := sorry
-/
lemma trans {R : Type u0} {α : Type u} {β : Type v} {γ : Type w}
  [comm_ring R] [comm_ring α] [comm_ring β] [comm_ring γ]
  {sα : R → α} {sβ : R → β} {sγ : R → γ} :
  R_alg_equiv sα sβ → R_alg_equiv sβ sγ → R_alg_equiv sα sγ :=
λ H1 H2,
{ R_alg_hom := begin
     show sγ = H2.to_fun ∘ (H1.to_fun ∘ sα),
     funext,
     have H3 : sγ = H2.to_fun ∘ sβ := H2.R_alg_hom,
     have H4 : sβ = H1.to_fun ∘ sα := H1.R_alg_hom,
     conv begin
       to_lhs,
       rw H3,
       change H2.to_fun (sβ x),
     end,
     conv in (sβ x) begin
       rw H4,
     end,
  end,
  ..(ring_equiv.trans H1.to_ring_equiv H2.to_ring_equiv)
}

-- TODO
-- I need to now give easy access to "inv_fun is ring hom".

open localization

definition of_unique_homs {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  {sα : R → α} {sβ : R → β} {f : α → β} {g : β → α} {hα : α → α} {hβ : β → β}
  [is_ring_hom sα] [is_ring_hom sβ] [H : is_ring_hom f] [is_ring_hom g] [is_ring_hom hα] [is_ring_hom hβ] :
is_unique_R_alg_hom sα sβ f → is_unique_R_alg_hom sβ sα g → is_unique_R_alg_hom sα sα hα → is_unique_R_alg_hom sβ sβ hβ
  → R_alg_equiv sα sβ := λ Hαβ Hβα Hαα Hββ,
{ to_fun := f,
  inv_fun := g,
  left_inv := λ x, begin
    have Hα : id = hα,
      exact Hαα.is_unique id rfl,
    show (g ∘ f) x = x,
    rw [comp_unique sα sβ sα f g hα Hαβ Hβα Hαα,←Hα],
    refl
  end,
  right_inv := λ x, begin
    have Hβ : id = hβ,
      exact Hββ.is_unique id rfl,
    show (f ∘ g) x = x,
    rw [comp_unique sβ sα sβ g f hβ Hβα Hαβ Hββ,←Hβ],
    refl
  end,
  is_ring_hom := H,
  R_alg_hom := show sβ = f ∘ sα, from Hαβ.R_alg_hom
}

end R_alg_equiv -- namespace

-- The proof below (is_loc) could be simpler: a lot of the definitions would follow from
-- universal properties, but Kenny just proved them directly anyway.
-- It's the proof that if U=D(f) and S=S(U) is the functions which are non-vanishing
-- on U then R[1/S]=R[1/f] as R-algebras.

open localization

noncomputable definition zariski.structure_presheaf_on_standard_is_loc {R : Type u} [comm_ring R] (f : R) :
  R_alg_equiv (of_comm_ring R _ : R → zariski.structure_presheaf_on_standard (Spec.D'(f)) (⟨f,rfl⟩))
    (of_comm_ring R (powers f) : R → away f) :=
{ to_fun      := extend_map_of_im_unit
    (of_comm_ring R (powers f))
    (λ s hs, lemma_standard_open_1a R _ _ hs),
  is_ring_hom := extend_map_of_im_unit.is_ring_hom _ _,
  inv_fun     := away.extend_map_of_im_unit
    (of_comm_ring R _)
    ⟨mk _ _ ⟨1, f, set.subset.refl _⟩,
     quotient.sound ⟨1, is_submonoid.one_mem _, by simp⟩⟩,
  left_inv    := @unique _ _ _ _ _ _ _ _
    (@@is_ring_hom.comp _ _ _
       (extend_map_of_im_unit.is_ring_hom _ _) _ _
       (extend_map_of_im_unit.is_ring_hom _ _))
    (ring_equiv.refl _).is_ring_hom
    (by intro x; dsimp [ring_equiv.refl, equiv.refl]; rw [extend_map_extends, extend_map_extends]),
  right_inv   := @localization.unique _ _ _ _ _ _ _ _
    (@@is_ring_hom.comp _ _ _
       (extend_map_of_im_unit.is_ring_hom _ _) _ _
       (extend_map_of_im_unit.is_ring_hom _ _))
    (ring_equiv.refl _).is_ring_hom
    (by intro x; dsimp [ring_equiv.refl, equiv.refl]; rw [localization.extend_map_extends, localization.extend_map_extends]),
  R_alg_hom := (funext (λ r, (localization.extend_map_extends
     (_ : R → localization.loc R (powers f))
     _ r
       ).symm)
  : localization.of_comm_ring R (powers f) =
    localization.extend_map_of_im_unit (localization.of_comm_ring R (powers f)) _ ∘
      localization.of_comm_ring R (non_zero_on_U (Spec.D' f)))
}

-- we now need some universal properties coming from localization.

set_option class.instance_max_depth 52 -- !!

/-- universal property of inverting one element and then another -/
theorem away_away_universal_property {R : Type u} [comm_ring R] (f : R)
(g : loc R (powers f)) {γ : Type v} [comm_ring γ] (sγ : R → γ) [is_ring_hom sγ] (Hf : is_unit (sγ f))
(Hg : is_unit (away.extend_map_of_im_unit sγ Hf g)) :
is_unique_R_alg_hom
  ((of_comm_ring (away f) (powers g)) ∘ (of_comm_ring R (powers f)))
  sγ
  (away.extend_map_of_im_unit (away.extend_map_of_im_unit sγ Hf) Hg) :=
begin
  let α := loc R (powers f),
  let β := loc α (powers g),
  let sα := of_comm_ring R (powers f),
  let fαβ := of_comm_ring α (powers g),
  let sβ := fαβ ∘ sα,
  let fαγ := away.extend_map_of_im_unit sγ Hf,
  let fβγ := away.extend_map_of_im_unit fαγ Hg,
  have HUαγ : is_unique_R_alg_hom sα sγ fαγ := away_universal_property f sγ Hf,
  have HUβγ : is_unique_R_alg_hom fαβ fαγ fβγ := away_universal_property g fαγ Hg,
  have Hαγ : sγ = fαγ ∘ sα := HUαγ.R_alg_hom,
  have Hβγ : fαγ = fβγ ∘ fαβ := HUβγ.R_alg_hom,
  -- it's the next line which needs class.instance_max_depth 52
  have Htemp : is_unique_R_alg_hom sα sγ fαγ ↔ is_unique_R_alg_hom sα (fβγ ∘ fαβ ∘ sα) (fβγ ∘ fαβ),
    simp [Hαγ,Hβγ],
  have Htemp2 : is_unique_R_alg_hom fαβ fαγ fβγ ↔ is_unique_R_alg_hom fαβ (fβγ ∘ fαβ) fβγ,
    simp [Hβγ],
  have H : is_unique_R_alg_hom (fαβ ∘ sα) (fβγ ∘ fαβ ∘ sα) fβγ := unique_R_of_unique_R_of_unique_Rloc sα fαβ fβγ (Htemp.1 HUαγ) (Htemp2.1 HUβγ),
  have Htemp3 : is_unique_R_alg_hom (fαβ ∘ sα) (fβγ ∘ fαβ ∘ sα) fβγ ↔ is_unique_R_alg_hom (fαβ ∘ sα) sγ fβγ,
    simp [Hαγ,Hβγ],
  exact Htemp3.1 H
end

/-- universal property of inverting two elements of R one by one -/
theorem away_away_universal_property' {R : Type u} [comm_ring R] (f g : R)
{γ : Type v} [comm_ring γ] (sγ : R → γ) [is_ring_hom sγ] (Hf : is_unit (sγ f))
(Hg : is_unit (sγ g)) :
is_unique_R_alg_hom
  ((of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ∘ (of_comm_ring R (powers f)))
  sγ
  (away.extend_map_of_im_unit (away.extend_map_of_im_unit sγ Hf) (begin rwa away.extend_map_extends end)) :=
away_away_universal_property f (of_comm_ring R (powers f) g) sγ Hf (begin rwa away.extend_map_extends end)

-- To get Chris' lemma to apply to covers of D(f) (rather than a cover of R)
-- we need R[1/f][1/g] = R[1/g] if D(g) ⊆ D(f), so let's prove this from the
-- universal property.

noncomputable definition localization.loc_loc_is_loc {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
  let sα := (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ∘ (of_comm_ring R (powers f)) in
  let sβ := of_comm_ring R (powers g) in
R_alg_equiv sα sβ :=
begin
  have Htemp : is_ring_hom (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) := by apply_instance,
  letI := Htemp,
  let sα : R → loc (away f) (powers (of_comm_ring R (powers f) g)) :=
    (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ∘ (of_comm_ring R (powers f)),
  let sβ := of_comm_ring R (powers g),
  have HUfα : is_unit (sα f),
    show is_unit ((of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ((of_comm_ring R (powers f)) f)),
    exact im_unit_of_unit (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) (unit_of_in_S (away.in_powers f)),
  have HUfβ : is_unit (sβ f) := lemma_standard_open_1a R f g H,
  have HUgα : is_unit (sα g) := unit_of_in_S (away.in_powers (of_comm_ring R (powers f) g)),
  have HUgβ : is_unit (sβ g) := unit_of_in_S (away.in_powers g),
  exact R_alg_equiv.of_unique_homs
    (away_away_universal_property' f g sβ HUfβ HUgβ)
    (away_universal_property g sα HUgα : is_unique_R_alg_hom sβ sα _)
    (away_away_universal_property' f g sα HUfα HUgα)
    (away_universal_property g sβ HUgβ)
end

-- Now I need the following technical result:
-- If V = D(g) ⊆ U = D(f) in Spec(R)
-- then structure sheaf evaluated on V (R[1/S(V)]) is R-isomorphic to R[1/f][1/gbar]
-- with gbar = image of g. The map is from R[1/S(V)] to R[1/f][1/gbar]
-- The proof goes via R[1/g]
-- It is also true that the R-isomorphism is the unique R-homomorphism
-- between these rings -- see the lemma after this.
noncomputable definition canonical_iso {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
let gbar := of_comm_ring R (powers f) g in
let sα : R → loc (away f) (powers gbar) :=
  of_comm_ring (away f) (powers gbar) ∘ of_comm_ring R (powers f) in
let sγ := (of_comm_ring R (non_zero_on_U (Spec.D' g))) in
R_alg_equiv sγ sα :=
R_alg_equiv.trans
  (zariski.structure_presheaf_on_standard_is_loc g )
  (R_alg_equiv.symm (localization.loc_loc_is_loc H))

-- and we also need that the canonical iso is the unique R-alg hom.
-- From R[1/S(V)] to R[1/f][1/gbar] the result is here:

-- NB Chris suggests I remove the first three let's.
theorem canonical_iso_is_canonical_hom₁ {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
let gbar := of_comm_ring R (powers f) g in
let sα : R → loc (away f) (powers gbar) :=
  of_comm_ring (away f) (powers gbar) ∘ of_comm_ring R (powers f) in
let sγ := (of_comm_ring R (non_zero_on_U (Spec.D' g))) in
let H3 : is_ring_hom sα := by apply_instance in
let H2 := (canonical_iso H).is_ring_hom in
let H4 : is_ring_hom sγ := by apply_instance in
@is_unique_R_alg_hom _ _ _ _ _ _ sγ sα (canonical_iso H).to_fun H4 H3 H2 :=
begin
letI := (canonical_iso H).is_ring_hom,
have H5 := unique_R_alg_from_loc (canonical_iso H).to_fun,
have H6 := (canonical_iso H).R_alg_hom.symm,
simp [H6] at H5,
exact H5,
end

-- now let's go the other way -- but do I need this?
/-
theorem canonical_iso_is_canonical_hom₂ {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
let gbar := of_comm_ring R (powers f) g in
let sα : R → loc (away f) (powers gbar) :=
  of_comm_ring (away f) (powers gbar) ∘ of_comm_ring R (powers f) in
let sγ := (of_comm_ring R (non_zero_on_U (Spec.D' g))) in
let H3 : is_ring_hom sα := by apply_instance in
let H2 : is_ring_hom (canonical_iso H).inv_fun := ring_equiv.inv_fun_is_ring_hom (canonical_iso H).to_ring_equiv in
let H4 : is_ring_hom sγ := by apply_instance in
@is_unique_R_alg_hom _ _ _ _ _ _ sα sγ (canonical_iso H).inv_fun H3 H4 H2 := sorry
-/

-- Chris has proved that 0-> A -> sum A_{g_i} -> sum A_{g_i g_j} is exact
-- if Spec(A) is covered by D(g_i) (a finite cover).

-- I want to prove that if U = D(f) is open and covered by U_i = D(g_i)
-- and if A = R[1/S(U)] then
-- 0 -> A -> sum R[1/S(U_i)] -> sum R[1/S(U_i intersect U_j)] is exact

-- Let's formulate exactly what we need.

theorem fourexact_from_iso_to_fourexact {A B C A' B' C' : Type u}
  [add_comm_group A] [add_comm_group A']
  [add_comm_group B] [add_comm_group B']
  [add_comm_group C] [add_comm_group C']
  (ab : A → B) [is_add_group_hom ab]
  (bc : B → C) [is_add_group_hom bc]
--  (Habc : set.range ab = is_add_group_hom.ker bc)
  (H4exact : ∀ b : B, bc b = 0 → ∃! a : A, ab a = b)
  (fa : A ≃ A') [is_add_group_hom fa]
  (fb : B ≃ B') [is_add_group_hom fb]
  (fc : C ≃ C') [is_add_group_hom fc]

  (ab' : A' → B') [is_add_group_hom ab']
  (bc' : B' → C') [is_add_group_hom bc']
  (H1 : ∀ a, fb (ab a) = ab' (fa a))
  (H2 : ∀ b, fc (bc b) = bc' (fb b))
  : ∀ b' : B', (bc' b' = 0 → ∃! a' : A', ab' a' = b') :=
begin
  intros b' Hb',
  let b := fb.symm b',
    have H3 : fc (bc b) = 0,
    rw H2 b,
    simp [Hb'],
  have Hb : bc b = 0,
    have H4 : fc.symm (fc (bc b)) = 0,
      rw H3,
      have H5 : fc (0 : C) = 0 := is_add_group_hom.zero fc,
      rw ←H5,
      simp,
    simp only [equiv.inverse_apply_apply fc] at H4,
    exact H4,
  cases H4exact b Hb with a Ha,
  existsi (fa a),
  split,
  { show ab' (fa a) = b',
    rw ←H1,
    rw Ha.1,
    exact equiv.apply_inverse_apply fb b'
  },
  intros a₁' Ha₁',
  have H4 := Ha.2 (fa.symm a₁'),
  suffices H5 : ab (fa.symm a₁') = b,
    rw ←(H4 H5),simp,
  apply equiv.to_fun.injective fb,
  rw H1,
  simp [Ha₁'],
end


import tactic --hide

/-Lemma
A nested chain ofimplications.
-/
lemma lemma_7 (P Q: Prop) : (P → Q) → ((P → Q) → P) → Q :=
begin
  intros hPQ hPQP,
  apply hPQ,
  apply hPQP,
  exact hPQ,

end


import computability.partrec
import computability.partrec_code
import data.pfun
import tactic
import rpartrec
import rcomputability_tactic

open encodable denumerable part

@[simp] lemma eval_eval_opt {α β} (f : α →. β) [D : decidable_pred f.dom] {x} :
  @pfun.eval_opt _ _ f D x = @part.to_option _ (f x) (D x) := rfl

@[simp] theorem mem_to_option' {α} {o : part α} [decidable o.dom] {a : α} :
  to_option o = some a ↔ a ∈ o := mem_to_option

theorem mem_to_option_none {α} {o : part α} [D : decidable o.dom] {a : α} :
  to_option o = none ↔ o = none :=
by { unfold to_option, by_cases h : o.dom; simp [h],
     { exact λ h0, part.eq_none_iff'.mp h0 h },
     { exact part.eq_none_iff'.mpr h } }

namespace nat.rpartrec

inductive code : Type
| oracle : code
| zero   : code
| succ   : code
| left   : code
| right  : code
| pair   : code → code → code
| comp   : code → code → code
| prec   : code → code → code
| rfind' : code → code

end nat.rpartrec

namespace nat.rpartrec.code
open nat (mkpair unpair) nat.rpartrec (code)

protected def const : ℕ → code
| 0     := zero
| (n+1) := comp succ (const n)

protected def id : code := pair left right

def curry (c : code) (n : ℕ) : code :=
comp c (pair (code.const n) code.id)

def ctrans (c : code) : code → code
| oracle       := c
| zero         := zero
| succ         := succ
| left         := left
| right        := right
| (pair cf cg) := pair (ctrans cf) (ctrans cg)
| (comp cf cg) := comp (ctrans cf) (ctrans cg)
| (prec cf cg) := prec (ctrans cf) (ctrans cg)
| (rfind' cf)  := rfind' (ctrans cf)

def encode_code : code → ℕ
| oracle       := 0
| zero         := 1
| succ         := 2
| left         := 3
| right        := 4
| (pair cf cg) := (bit0 $ bit0 (mkpair (encode_code cf) (encode_code cg))) + 5
| (comp cf cg) := (bit0 $ bit1 (mkpair (encode_code cf) (encode_code cg))) + 5
| (prec cf cg) := (bit1 $ bit0 (mkpair (encode_code cf) (encode_code cg))) + 5
| (rfind' cf)  := (bit1 $ bit1 (encode_code cf)) + 5

def of_nat_code : ℕ → code
| 0 := oracle
| 1 := zero
| 2 := succ
| 3 := left
| 4 := right
| (e+5) :=
  have div8 : e.div2.div2 ≤ e :=
    by { simp[nat.div2_val], exact le_trans (nat.div_le_self (e/2) 2) (nat.div_le_self e 2) },
  have e.div2.div2 < e + 5 := nat.lt_succ_iff.mpr (le_trans div8 (nat.le.intro rfl)),
  have e.div2.div2.unpair.1 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_left_le _) div8) (nat.le.intro rfl)),
  have e.div2.div2.unpair.2 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_right_le _) div8) (nat.le.intro rfl)),
  match e.bodd, e.div2.bodd with
  | ff, ff := pair (of_nat_code e.div2.div2.unpair.1)
    (of_nat_code e.div2.div2.unpair.2)
  | ff, tt := comp (of_nat_code e.div2.div2.unpair.1)
    (of_nat_code e.div2.div2.unpair.2)
  | tt, ff := prec (of_nat_code e.div2.div2.unpair.1)
    (of_nat_code e.div2.div2.unpair.2)
  | tt, tt := rfind' (of_nat_code e.div2.div2)
  end

private lemma encode_of_nat_code : ∀ e, encode_code (of_nat_code e) = e
| 0     := by simp[of_nat_code, encode_code]
| 1     := by simp[of_nat_code, encode_code]
| 2     := by simp[of_nat_code, encode_code]
| 3     := by simp[of_nat_code, encode_code]
| 4     := by simp[of_nat_code, encode_code]
| (e+5) :=
have div8 : e.div2.div2 ≤ e :=
    by { simp[nat.div2_val],
         exact le_trans (nat.div_le_self (e/2) 2) (nat.div_le_self e 2) },
  have e.div2.div2 < e + 5 := nat.lt_succ_iff.mpr (le_trans div8 (nat.le.intro rfl)),
  have e.div2.div2.unpair.1 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_left_le _) div8) (nat.le.intro rfl)),
  have e.div2.div2.unpair.2 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_right_le _) div8) (nat.le.intro rfl)),
  have IH : _ := encode_of_nat_code e.div2.div2,
  have IH1 : _ := encode_of_nat_code e.div2.div2.unpair.1,
  have IH2 : _ := encode_of_nat_code e.div2.div2.unpair.2,
  begin
    suffices :
      (of_nat_code (e + 5)).encode_code =
      nat.bit e.bodd (nat.bit e.div2.bodd e.div2.div2) + 5,
    { simp[nat.bit_decomp, this] },
    simp [encode_code, of_nat_code],
    cases e.bodd; cases e.div2.bodd;
    simp [encode_code, of_nat_code, nat.bit, IH, IH1, IH2],
  end

private lemma of_nat_code_encode : ∀ c, of_nat_code (encode_code c) = c
| oracle       := by simp[of_nat_code, encode_code]
| zero         := by simp[of_nat_code, encode_code]
| succ         := by simp[of_nat_code, encode_code]
| left         := by simp[of_nat_code, encode_code]
| right        := by simp[of_nat_code, encode_code]
| (pair cf cg) := by { simp[encode_code, of_nat_code],
    exact ⟨of_nat_code_encode cf, of_nat_code_encode cg⟩ }
| (comp cf cg) := by { simp[encode_code, of_nat_code],
    exact ⟨of_nat_code_encode cf, of_nat_code_encode cg⟩ }
| (prec cf cg) := by { simp[encode_code, of_nat_code],
    exact ⟨of_nat_code_encode cf, of_nat_code_encode cg⟩ }
| (rfind' cf)  := by { simp[encode_code, of_nat_code],
    exact of_nat_code_encode cf }

instance : denumerable code := mk' ⟨encode_code, of_nat_code, of_nat_code_encode, encode_of_nat_code⟩

def evaln : ℕ → (ℕ → option ℕ) → code → ℕ → option ℕ
| 0     f _            := λ _, none
| (s+1) f oracle       := λ n, guard (n ≤ s) >> f n
| (s+1) f zero         := λ n, guard (n ≤ s) >> pure 0
| (s+1) f succ         := λ n, guard (n ≤ s) >> pure (nat.succ n)
| (s+1) f left         := λ n, guard (n ≤ s) >> pure n.unpair.1
| (s+1) f right        := λ n, guard (n ≤ s) >> pure n.unpair.2
| (s+1) f (pair cf cg) := λ n, guard (n ≤ s) >>
    mkpair <$> evaln (s+1) f cf n <*> evaln (s+1) f cg n
| (s+1) f (comp cf cg) := λ n, guard (n ≤ s) >>
    do x ← evaln (s+1) f cg n, evaln (s+1) f cf x
| (s+1) f (prec cf cg) := λ n, guard (n ≤ s) >>
    n.unpaired (λ a n,
    n.cases (evaln (s+1) f cf a) $ λ y, do
    i ← evaln s f (prec cf cg) (mkpair a y),
    evaln (s+1) f cg (mkpair a (mkpair y i)))
| (s+1) f (rfind' cf)  := λ n, guard (n ≤ s) >>
    n.unpaired (λ a m, do
    x ← evaln (s+1) f cf (mkpair a m),
    if x = 0 then pure m else
    evaln s f (rfind' cf) (mkpair a (m+1)))
-- evaln s f c x = { c }ᶠₛ (x)

@[simp] theorem evaln_0 {f c n} : evaln 0 f c n = none :=
by induction c; simp [evaln]

theorem evaln_inclusion : ∀ {s c} {f g : ℕ → option ℕ},
  (∀ x y, x < s → f x = some y → g x = some y) →
  ∀ {x y}, evaln s f c x = some y →  evaln s g c x = some y
| 0 c _ _ := by simp[evaln]
| (s+1) oracle f g := λ h n y,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega,
         cases this; simp[(>>), this], exact h _ _ (nat.lt_succ_iff.mpr this),
         intros _ c, exfalso, exact option.not_mem_none _ c }
| (s+1) zero         f g := by simp[evaln]
| (s+1) succ         f g := by simp[evaln]
| (s+1) left         f g := by simp[evaln]
| (s+1) right        f g := by simp[evaln]
| (s+1) (pair cf cg) f g := λ h n y,
    have IH₀ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_inclusion (s+1) cg _ _ h,
    by { simp[evaln, (>>)], assume e hf,
         have : ∃ y, evaln (s + 1) f cf n = some y,
         { cases evaln (s + 1) f cf n; simp, simp[(<*>), hf] at hf ⊢, exact hf },
         rcases this with ⟨y0, hy0⟩, have IH₀' := IH₀ hy0,
          have : ∃ y, evaln (s + 1) f cg n = some y,
         { cases evaln (s + 1) f cg n; simp, simp[(<*>), hf] at hf ⊢, exact hf },
         rcases this with ⟨y1, hy1⟩, have IH₁' := IH₁ hy1,
         simp[hy0, hy1, IH₀', IH₁'] at hf ⊢, exact ⟨e, hf⟩ }
| (s+1) (comp cf cg) f g := λ h n y,
    have IH₀ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_inclusion (s+1) cg _ _ h,
    by { simp[evaln, (>>)], assume e z hz hy,
         refine ⟨e, z, IH₁ hz, IH₀ hy⟩ }
| (s+1) (prec cf cg) f g := λ h n y,
    have l0 : ∀ x y, x < s → f x = some y → g x = some y :=
      λ x y e, h x y (nat.lt.step e),
    have IH₀ : _ := @evaln_inclusion s (cf.prec cg) _ _ l0,
    have IH₁ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₂ : _ := @evaln_inclusion (s+1) cg _ _ h,
    by { simp[evaln, (>>)], assume e hf,
         cases n.unpair.snd with n0; simp at hf ⊢, exact ⟨e, IH₁ hf⟩,
         rcases hf with ⟨z, hz0, hz1⟩,
         refine ⟨e, z, IH₀ hz0, IH₂ hz1⟩ }
| (s+1) (rfind' cf)  f g := λ h n y,
    have l0 : ∀ x y, x < s → f x = some y → g x = some y :=
      λ x y e, h x y (nat.lt.step e),
    have IH₀ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_inclusion s cf.rfind' _ _ l0,
    by { simp[evaln, (>>)], assume e z ez ey,
         refine ⟨e, z, IH₀ ez, _⟩,
         cases z with z0; simp at ey ⊢, exact ey, exact IH₁ ey }

theorem evaln_use : ∀ {s c} {f g : ℕ → option ℕ},
  (∀ x, x < s → f x = g x) → evaln s f c = evaln s g c
| 0     c            _ _  := by simp[evaln]
| (s+1) oracle       _ _  := λ h, funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega,
         cases this; simp[(>>), this], exact h _ (nat.lt_succ_iff.mpr this), refl }
| (s+1) zero         f g := by simp[evaln]
| (s+1) succ         f g := by simp[evaln]
| (s+1) left         f g := by simp[evaln]
| (s+1) right        f g := by simp[evaln]
| (s+1) (pair cf cg) f g := λ h,
    have IH₀ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_use (s+1) cg _ _ h,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁] }
| (s+1) (comp cf cg) f g := λ h,
    have IH₀ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_use (s+1) cg _ _ h,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁] }
| (s+1) (prec cf cg) f g := λ h,
    have l0 : ∀ (x : ℕ), x < s → f x = g x := λ x e, h x (nat.lt.step e),
    have IH₀ : _ := @evaln_use s (cf.prec cg) _ _ l0,
    have IH₁ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₂ : _ := @evaln_use (s+1) cg _ _ h,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁, IH₂] }
| (s+1) (rfind' cf)  f g := λ h,
    have l0 : ∀ (x : ℕ), x < s → f x = g x := λ x e, h x (nat.lt.step e),
    have IH₀ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_use s cf.rfind' _ _ l0,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁] }

theorem evaln_use' {s} {f g : ℕ → option ℕ} (h : ∀ x, x < s → f x = g x) :
  evaln s f = evaln s g :=
funext $ λ c, evaln_use h

theorem evaln_bound {f} : ∀ {k c n x}, x ∈ evaln k f c n → n < k
| 0     c n x h := by simp [evaln] at h; cases h
| (k+1) c n x h := begin
  suffices : ∀ {o : option ℕ}, x ∈ guard (n ≤ k) >> o → n < k + 1,
  { cases c; rw [evaln] at h; try { exact this h } },
  simpa [(>>)] using nat.lt_succ_of_le
end

theorem evaln_bound_none {f k c n} (h : k ≤ n) : evaln k f c n = none :=
by { cases e : evaln k f c n with v; simp,
     have := evaln_bound e, exact nat.lt_le_antisymm this h }

theorem evaln_mono : ∀ {s₁ s₂ c f n x},
  s₁ ≤ s₂ → evaln s₁ f c n = some x → evaln s₂ f c n = some x
| 0      _      _            _ _ _ := λ _ h, by simp [evaln] at h; cases h
| (s₀+1) 0      _            _ _ _ := λ e h, by exfalso; exact nat.not_succ_le_zero s₀ e
| (s₀+1) (s₁+1) oracle       f n x := λ hs,
    by { simp[evaln], have : n ≤ s₀ ∨ ¬ n ≤ s₀, omega,
         cases this; simp[(>>), this], exact λ e, ⟨by omega, e⟩,
         intros _ c, exfalso, exact option.not_mem_none _ c }
| (s₀+1) (s₁+1) zero         f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) succ         f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) left         f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) right        f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) (pair cf cg) f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₁ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cg f n y hs,
    by { simp[evaln, (>>)], assume e0 ex,
         have : ∃ y, evaln (s₀ + 1) f cf n = some y,
         { cases evaln (s₀ + 1) f cf n; simp[(<*>)] at ex ⊢, exact ex },
         rcases this with ⟨y₀, hy₀⟩,
         have : ∃ y, evaln (s₀ + 1) f cg n = some y,
         { cases evaln (s₀ + 1) f cg n; simp[(<*>)] at ex ⊢, exact ex },
         rcases this with ⟨y₁, hy₁⟩,
         simp[hy₀, hy₁, IH₀ _ _ hy₀, IH₁ _ _ hy₁] at ex ⊢,
         exact ⟨le_trans e0 (nat.le_of_succ_le_succ hs), ex⟩ }
| (s₀+1) (s₁+1) (comp cf cg) f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₁ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cg f n y hs,
    by { simp[evaln, (>>)], assume e0 y ey ex,
         refine ⟨le_trans e0 (nat.le_of_succ_le_succ hs), y, IH₁ _ _ ey, IH₀ _ _ ex⟩ }
| (s₀+1) (s₁+1) (prec cf cg) f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono s₀ s₁ (cf.prec cg) f n y (nat.le_of_succ_le_succ hs),
    have IH₁ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₂ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cg f n y hs,
    by { simp[evaln, (>>)],
         cases n.unpair.snd with n0; simp,
         assume e0 ex,
         exact ⟨le_trans e0 (nat.le_of_succ_le_succ hs), IH₁ _ _ ex⟩,
         assume e0 y ey ex,
         refine ⟨le_trans e0 (nat.le_of_succ_le_succ hs), y, IH₀ _ _ ey, IH₂ _ _ ex⟩ }
| (s₀+1) (s₁+1) (rfind' cf)  f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₁ : _ := λ n y, @evaln_mono s₀ s₁ cf.rfind' f n y (nat.le_of_succ_le_succ hs),
    by { simp[evaln, (>>), pure],
         assume e0 y ey ex,
         refine ⟨by omega, y, IH₀ _ _ ey, _⟩,
         cases y with y0; simp at ex ⊢, exact ex, exact IH₁ _ _ ex }

def eval (f : ℕ → option ℕ) : code → ℕ →. ℕ
| oracle       := λ n, f n
| zero         := pure 0
| succ         := nat.succ
| left         := ↑(λ n : ℕ, n.unpair.1)
| right        := ↑(λ n : ℕ, n.unpair.2)
| (pair cf cg) := λ n, mkpair <$> eval cf n <*> eval cg n
| (comp cf cg) := λ n, eval cg n >>= eval cf
| (prec cf cg) := nat.unpaired (λ a n,
    n.elim (eval cf a) (λ y IH, do i ← IH, eval cg (mkpair a (mkpair y i))))
| (rfind' cf) := nat.unpaired (λ a m,
    (nat.rfind (λ n, (λ m, m = 0) <$>
      eval cf (mkpair a (n + m)))).map (+ m))

theorem evaln_sound {f} : ∀ {s c n x},
  x ∈ evaln s f c n → x ∈ eval f c n
| 0     _ _ _ h := by simp [evaln] at h; cases h
| (s + 1) oracle n x h := by { simp [eval, evaln, (>>)] at h ⊢, exact h.2 }
| (s + 1) zero   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) succ   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) left   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) right   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) (pair cf cg) n x h :=
    have IH₀ : _ := @evaln_sound (s + 1) cf,
    have IH₁ : _ := @evaln_sound (s + 1) cg,
    by{ simp [eval, evaln, (>>), (<*>)] at h ⊢,
        rcases h with ⟨_, y, hy, z, hz, ex⟩,
        refine ⟨y, IH₀ hy, z, IH₁ hz, ex⟩ }
| (s + 1) (comp cf cg) n x h :=
    have IH₀ : _ := @evaln_sound (s + 1) cf,
    have IH₁ : _ := @evaln_sound (s + 1) cg,
    by{ simp [eval, evaln, (>>), (<*>)] at h ⊢,
        rcases h with ⟨_, y, hy, hz⟩,
        refine ⟨y, IH₁ hy, IH₀ hz⟩ }
| (s + 1) (prec cf cg) n x h :=
    have IH₀ : _ := @evaln_sound (s + 1) cf,
    have IH₁ : _ := @evaln_sound (s + 1) cg,
    by{ simp [eval, evaln, (>>)] at h ⊢,
        rcases h with ⟨_, hx⟩, revert hx,
        induction n.unpair.2 with m IH generalizing x; simp,
        { exact IH₀ },
        { refine λ y h₁ h₂, ⟨y, IH _ _, _⟩,
          { have := evaln_mono s.le_succ h₁,
        simp [evaln, (>>)] at this,
        exact this.2 },
        { exact IH₁ h₂ } } }
| (s + 1) (rfind' cf) n x h :=
    have IH₀ : _ := @evaln_sound (s+1) cf,
    have IH₁ : _ := @evaln_sound s cf.rfind',
  begin
    simp [eval, evaln, (>>)] at h ⊢,
    rcases h with ⟨_, m, hm, h⟩,
    cases e : m with m0; simp[e, pure] at hm h,
    { refine ⟨0, ⟨by simp; exact IH₀ hm, by simp⟩, by simp[h]⟩ },
    { have := IH₁ h,  simp[eval] at this,
      rcases this with ⟨y, ⟨hc0, hc1⟩, ex⟩,
      refine ⟨y+1, ⟨
        by simpa [add_comm, add_left_comm] using hc0, λ b eb, _⟩,
        by simpa [add_comm, add_left_comm] using ex⟩,
      { cases b with b0, refine ⟨m0 + 1, by simp; exact IH₀ hm, by simp⟩,
        have : b0.succ + n.unpair.snd = b0 + (n.unpair.snd + 1), omega,
        rw this, exact hc1 (nat.lt_of_succ_lt_succ eb) } }
  end

theorem evaln_complete {f : ℕ → option ℕ} {c n x} :
  x ∈ eval (λ x, f x) c n ↔ ∃ k, x ∈ evaln k f c n := ⟨λ h,
begin
  suffices : ∃ k, x ∈ evaln (k+1) f c n,
  { exact let ⟨k, h⟩ := this in ⟨k+1, h⟩ },
    induction c generalizing n x;
    simp [eval, evaln, pure, pfun.pure, (<*>), (>>)] at h ⊢,
    { exact ⟨⟨n, by refl⟩, h⟩ },
    { use n, have : min n n.unpair.fst.unpair.fst = n.unpair.fst.unpair.fst,
      { simp, exact le_trans (nat.unpair_left_le _) (nat.unpair_left_le _) }, simp [this,h] },
    { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
    { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
    { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
    case nat.rpartrec.code.pair : cf cg hf hg
    { rcases h with ⟨x, hx, y, hy, rfl⟩,
      rcases hf hx with ⟨k₁, hk₁⟩, rcases hg hy with ⟨k₂, hk₂⟩,
      refine ⟨max k₁ k₂, le_max_of_le_left $ nat.le_of_lt_succ $ evaln_bound hk₁, x, _, y, _, rfl⟩,
      exact evaln_mono (nat.succ_le_succ $ le_max_left _ _) hk₁,
      exact evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂ },
    case nat.rpartrec.code.comp : cf cg hf hg
    { rcases h with ⟨y, hy, hx⟩,
      rcases hf hx with ⟨k₁, hk₁⟩, rcases hg hy with ⟨k₂, hk₂⟩,
      refine ⟨max k₂ k₁, le_max_of_le_left $ nat.le_of_lt_succ $ evaln_bound hk₂, y, _, _⟩,
      exact evaln_mono (nat.succ_le_succ $ le_max_left _ _) hk₂,
      exact evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₁ },
    case nat.rpartrec.code.prec : cf cg hf hg
    { revert h,
      generalize : n.unpair.1 = n₁, generalize : n.unpair.2 = n₂,
      induction n₂ with m IH generalizing x n; simp,
      { intro, rcases hf h with ⟨k, hk⟩,
        exact ⟨_, le_max_left _ _,
          evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk⟩ },
      { intros y hy hx,
        rcases IH hy with ⟨k₁, nk₁, hk₁⟩, rcases hg hx with ⟨k₂, hk₂⟩,
        refine ⟨(max k₁ k₂).succ, nat.le_succ_of_le $ le_max_of_le_left $
          le_trans (le_max_left _ (mkpair n₁ m)) nk₁, y,
          evaln_mono (nat.succ_le_succ $ le_max_left _ _) _,
          evaln_mono (nat.succ_le_succ $ nat.le_succ_of_le $ le_max_right _ _) hk₂⟩,
        simp [evaln, (>>)],
        exact ⟨le_trans (le_max_right _ _) nk₁, hk₁⟩ } },
    case nat.rpartrec.code.rfind' : cf hf
    { rcases h with ⟨y, ⟨hy₁, hy₂⟩, rfl⟩,
      suffices : ∃ k, y + n.unpair.2 ∈ evaln (k+1) f (rfind' cf)
        (mkpair n.unpair.1 n.unpair.2), {simpa [evaln, (>>)]},
      revert hy₁ hy₂, generalize : n.unpair.2 = m, intros,
      induction y with y IH generalizing m; simp [evaln, (>>)],
      { simp at hy₁, rcases hf hy₁ with ⟨k, hk⟩,
        exact ⟨_, nat.le_of_lt_succ $ evaln_bound hk, _, hk, by simp; refl⟩ },
      { rcases hy₂ (nat.succ_pos _) with ⟨a, ha, a0⟩,
        rcases hf ha with ⟨k₁, hk₁⟩,
        rcases IH m.succ
            (by simpa [nat.succ_eq_add_one, add_comm, add_left_comm] using hy₁)
            (λ i hi, by simpa [nat.succ_eq_add_one, add_comm, add_left_comm] using
              hy₂ (nat.succ_lt_succ hi))
          with ⟨k₂, hk₂⟩,
        use (max k₁ k₂).succ,
        rw [zero_add] at hk₁,
        use (nat.le_succ_of_le $ le_max_of_le_left $ nat.le_of_lt_succ $ evaln_bound hk₁),
        use a,
        use evaln_mono (nat.succ_le_succ $ nat.le_succ_of_le $ le_max_left _ _) hk₁,
        simpa [nat.succ_eq_add_one, a0, -max_eq_left, -max_eq_right, add_comm, add_left_comm] using
            evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂ } },
end, λ ⟨k, h⟩, evaln_sound h⟩

theorem evaln_complete_dec {c f} [D : decidable_pred (eval f c).dom] : ∀ m, ∃ s₀,
  ∀ n a, n < m → eval f c n = some a → evaln s₀ f c n = some a := λ m,
begin
  induction m with m0 ih, simp,
  rcases ih with ⟨s₀, hs₀⟩,
  have e : eval f c m0 = none ∨ ∃ v, eval f c m0 = some v := eq_none_or_eq_some (eval f c m0),
  cases e,
  { refine ⟨s₀, λ n a en ha, _⟩,
    have : n < m0 ∨ n = m0, from nat.lt_succ_iff_lt_or_eq.mp en,
    cases this, { exact hs₀ _ _ this ha },
    { exfalso, rw this at ha, rw e at ha, exact part.some_ne_none _ (eq.symm ha) } },
  { rcases e with ⟨v, e⟩,
    have : v ∈ eval f c m0, simp[e],
    have : ∃ k, v ∈ evaln k f c m0 := evaln_complete.mp this, rcases this with ⟨s₁, hs₁⟩,
    refine ⟨max s₀ s₁, _⟩,
    intros n a en ha,
    have en' : n < m0 ∨ n = m0, from nat.lt_succ_iff_lt_or_eq.mp en,
    cases en',
    { have : evaln s₀ f c n = option.some a := hs₀ _ _ en' ha,
      show evaln (max s₀ s₁) f c n = option.some a,
        from evaln_mono (le_max_left s₀ s₁) this },
    { rw en',
      have : a = v, from part.some_inj.mp (by simp only [←e, ←ha, en']),
      show evaln (max s₀ s₁) f c m0 = option.some a, rw this,
        from evaln_mono (le_max_right s₀ s₁) hs₁ } }
end

theorem eval_inclusion {c x y} {f : ℕ → option ℕ} (h : y ∈ eval f c x) : ∃ s, ∀ {g : ℕ → option ℕ},
  (∀ x y, x < s → f x = some y → g x = some y) → y ∈ eval g c x :=
by { have : ∃ s, y ∈ evaln s f c x := evaln_complete.mp h, rcases this with ⟨s, hs⟩,
     refine ⟨s, λ g h, evaln_complete.mpr ⟨s, evaln_inclusion h hs⟩⟩ }

@[simp] theorem evaln_const (s f) :
  ∀ n m, evaln (s+1) f (code.const n) m = guard (n ≤ s+1) >> guard (m ≤ s) >> option.some n
| 0     m := by { simp[code.const, evaln, (>>), pure], }
| (n+1) m := have IH : _ := evaln_const n m,
  by { simp [code.const, evaln, IH, pure, (>>)],
    by_cases e1 : n ≤ s; simp[e1, failure, alternative.failure],
    by_cases e2 : m ≤ s; simp[e1, e2, failure, alternative.failure],
    refine ⟨n, ⟨⟨(le_add_right e1), (), rfl⟩, rfl⟩, e1, rfl⟩ }

@[simp] theorem eval_const (f) : ∀ n m, eval f (code.const n) m = part.some n
| 0     m := rfl
| (n+1) m := by simp! *

@[simp] theorem eval_id (f n) : eval f code.id n = part.some n := by simp! [(<*>)]

@[simp] theorem eval_curry (f c n x) : eval f (curry c n) x = eval f c (mkpair n x) :=
by simp! [(<*>)]

--@[simp] theorem eval_ctrans (f c₁ c₂ x) : eval (eval f c₁) c₂ x = eval f (ctrans c₁ c₂) x :=
--by simp! [(<*>)]

@[simp] theorem evaln_curry (s f c n x) :
  evaln s f (curry c n) x = evaln s f c (n.mkpair x) :=
begin
  cases s, simp,
  simp [curry, evaln],
  by_cases e0 : x ≤ s; simp [code.id, evaln, e0, pure, (>>), failure, alternative.failure],
  by_cases e1 : n ≤ s+1; simp [e0, e1, pure, (>>), (<*>), failure, alternative.failure],
  { cases e : evaln (s + 1) f c (n.mkpair x) with y; simp,
    have : n.mkpair x < s + 1, from evaln_bound e,
    have : n ≤ s + 1, from le_of_lt
      (gt_of_gt_of_ge this (nat.left_le_mkpair n x)),
    contradiction },
  { cases e : evaln (s + 1) f c (n.mkpair x) with y; simp,
    have : n.mkpair x ≤ s := nat.lt_succ_iff.mp (evaln_bound e),
    have : x ≤ s := le_trans (nat.right_le_mkpair _ _) this,
    contradiction }
end

section
open primrec

theorem pair_prim : primrec₂ pair :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 5)

theorem comp_prim : primrec₂ comp :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit1.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 5)

theorem prec_prim : primrec₂ prec :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 5)

theorem rfind_prim : primrec rfind' :=
of_nat_iff.2 $ encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit1.comp $
    encode_iff.2 $ primrec.of_nat code)
  (const 5)

theorem const_prim : primrec code.const :=
(primrec.id.nat_iterate (primrec.const zero)
  (comp_prim.comp (primrec.const succ) primrec.snd).to₂).of_eq $
λ n, by simp; induction n; simp [*, code.const, function.iterate_succ']

theorem curry_prim : primrec₂ curry :=
comp_prim.comp primrec.fst $
pair_prim.comp (const_prim.comp primrec.snd) (primrec.const code.id)

end

theorem rpartrec_rfind' {f} : nat.rpartrec f (nat.unpaired (λ a m,
  (nat.rfind (λ n, (λ m, m = 0) <$> f (nat.mkpair a (n + m)))).map (+ m))) :=
rpartrec.nat_iff.mp $
begin
  simp,
  have c₀ : primrec (λ (x : (ℕ × ℕ) × ℕ), x.2 + x.1.2) :=
  primrec.nat_add.comp primrec.snd (primrec.snd.comp primrec.fst),
  have c₁ : primrec (λ (m : ((ℕ × ℕ) × ℕ) × ℕ), to_bool (m.2 = 0)) :=
  primrec₂.comp primrec.eq primrec.snd (primrec.const 0),
  have c₂ : (λ (x : (ℕ × ℕ) × ℕ), f (x.1.1.mkpair (x.2 + x.1.2))) partrec_in f :=
  rpartrec.refl.comp (primrec₂.mkpair.comp (primrec.fst.comp primrec.fst) $
    primrec.nat_add.comp primrec.snd (primrec.snd.comp primrec.fst)).to_comp.to_rpart,
  have := (rpartrec.rfind (c₂.map c₁.to_rcomp.to₂).to₂).map c₀.to_rcomp.to₂,
  simp at this,
  exact this.comp primrec.unpair.to_rcomp
end

theorem exists_code {f g : ℕ →. ℕ} [D : decidable_pred (λ x, x ∈ g.dom)] :
  nat.rpartrec g f ↔ ∃ c, eval (g.eval_opt) c = f := ⟨λ h,
begin
  induction h,
  case nat.rpartrec.oracle
  { exact ⟨oracle, by { simp[eval], funext n, exact of_to_option (g n) }⟩ },
  case nat.rpartrec.zero   { exact ⟨zero, rfl⟩ },
  case nat.rpartrec.succ   { exact ⟨succ, rfl⟩ },
  case nat.rpartrec.left   { exact ⟨left, rfl⟩ },
  case nat.rpartrec.right  { exact ⟨right, rfl⟩ },
  case nat.rpartrec.pair : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨pair e₀ e₁, rfl⟩ },
  case nat.rpartrec.comp : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨comp e₀ e₁, rfl⟩ },
  case nat.rpartrec.prec : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨prec e₀ e₁, rfl⟩ },
  case nat.rpartrec.rfind : f₀ pf₀ hf₀
  { rcases hf₀ with ⟨e₀, rfl⟩,
    refine ⟨comp (rfind' e₀) (pair nat.rpartrec.code.id zero), _⟩,
    simp [eval, (<*>), pure, pfun.pure, part.map_id'],  },
end,λ h, begin
  rcases h with ⟨c, rfl⟩, induction c,
  case nat.rpartrec.code.oracle
  { simp[eval], unfold_coes, simp, exact nat.rpartrec.oracle },
  case nat.rpartrec.code.zero { exact nat.rpartrec.zero },
  case nat.rpartrec.code.succ { exact nat.rpartrec.succ },
  case nat.rpartrec.code.left { exact nat.rpartrec.left },
  case nat.rpartrec.code.right { exact nat.rpartrec.right },
  case nat.rpartrec.code.pair : cf cg pf pg { exact pf.pair pg },
  case nat.rpartrec.code.comp : cf cg pf pg { exact pf.comp pg },
  case nat.rpartrec.code.prec : cf cg pf pg { exact pf.prec pg },
  case nat.rpartrec.code.rfind' : cf pf { exact nat.rpartrec.trans rpartrec_rfind' pf },
end⟩

theorem exists_code_opt {f : ℕ →. ℕ} {g : ℕ → option ℕ} :
  nat.rpartrec ↑ʳg f ↔ ∃ c, eval g c = f := ⟨λ h,
begin
  induction h,
  case nat.rpartrec.oracle
  { exact ⟨oracle, rfl⟩ },
  case nat.rpartrec.zero   { exact ⟨zero, rfl⟩ },
  case nat.rpartrec.succ   { exact ⟨succ, rfl⟩ },
  case nat.rpartrec.left   { exact ⟨left, rfl⟩ },
  case nat.rpartrec.right  { exact ⟨right, rfl⟩ },
  case nat.rpartrec.pair : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨pair e₀ e₁, rfl⟩ },
  case nat.rpartrec.comp : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨comp e₀ e₁, rfl⟩ },
  case nat.rpartrec.prec : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨prec e₀ e₁, rfl⟩ },
  case nat.rpartrec.rfind : f₀ pf₀ hf₀
  { rcases hf₀ with ⟨e₀, rfl⟩,
    refine ⟨comp (rfind' e₀) (pair nat.rpartrec.code.id zero), _⟩,
    simp [eval, (<*>), pure, pfun.pure, part.map_id'],  },
end,λ h, begin
  rcases h with ⟨c, rfl⟩, induction c,
  case nat.rpartrec.code.oracle
  { simp[eval], exact nat.rpartrec.oracle },
  case nat.rpartrec.code.zero { exact nat.rpartrec.zero },
  case nat.rpartrec.code.succ { exact nat.rpartrec.succ },
  case nat.rpartrec.code.left { exact nat.rpartrec.left },
  case nat.rpartrec.code.right { exact nat.rpartrec.right },
  case nat.rpartrec.code.pair : cf cg pf pg { exact pf.pair pg },
  case nat.rpartrec.code.comp : cf cg pf pg { exact pf.comp pg },
  case nat.rpartrec.code.prec : cf cg pf pg { exact pf.prec pg },
  case nat.rpartrec.code.rfind' : cf pf { exact nat.rpartrec.trans rpartrec_rfind' pf },
end⟩

end nat.rpartrec.code
open nat.rpartrec

variables {α : Type*} {σ : Type*} {β : Type*} {τ : Type*} {γ : Type*} {μ : Type*}
variables [primcodable α] [primcodable σ] [primcodable β] [primcodable τ] [primcodable γ] [primcodable μ]

def univn (α σ) [primcodable α] [primcodable σ] (s : ℕ) (f : β → option τ) (e : ℕ) :
  α → option σ := (λ a,
(code.evaln s
  (λ n, (decode β n).bind (λ a, (f a).map encode ))
  (of_nat code e) (encode a))
.bind (λ x, (decode σ x)))

notation `⟦`e`⟧*`f:max` [`s`]` := univn _ _ s f e
notation `⟦`e`⟧^`f:max` [`s`]` := univn _ _ s ↑ₒf e

def univ (α σ) [primcodable α] [primcodable σ] (f : β → option τ) (e : ℕ) : α →. σ := (λ a,
(code.eval
  (λ n, (decode β n).bind (λ a, (f a).map encode))
  (of_nat code e) (encode a))
.bind (λ x, (decode σ x)))

notation `⟦`e`⟧*`f:max := univ _ _ f e
notation `⟦`e`⟧^`f:max := univ _ _ ↑ₒf e

notation `⟦`e`⟧ᵪ*`f:max` [`s`]` := univn ℕ bool s f e
notation `⟦`e`⟧ₙ*`f:max` [`s`]` := univn ℕ ℕ s f e
notation `⟦`e`⟧ᵪ*`f:max := univ ℕ bool f e
notation `⟦`e`⟧ₙ*`f:max := univ ℕ ℕ f e

notation `⟦`e`⟧ᵪ^`f:max` [`s`]` := univn ℕ bool s ↑ₒf e
notation `⟦`e`⟧ₙ^`f:max` [`s`]` := univn ℕ ℕ s ↑ₒf e
notation `⟦`e`⟧ᵪ^`f:max := univ ℕ bool ↑ₒf e
notation `⟦`e`⟧ₙ^`f:max := univ ℕ ℕ ↑ₒf e

def univn0 (α σ) [primcodable α] [primcodable σ] (s : ℕ) (e : ℕ) : α → option σ :=
univn α σ s (λ x, none : ℕ → option ℕ) e

def univ0 (α σ) [primcodable α] [primcodable σ] (e : ℕ) : α →. σ :=
univ α σ (λ x, some 0 : ℕ → option ℕ) e

notation `⟦`e`⟧⁰`:max` [`s`]` := univn0 _ _ s e
notation `⟦`e`⟧⁰`:max := univ0 _ _ e

def re_set (α σ) [primcodable α] [primcodable σ] (p : β → option τ) (e : ℕ) : set α :=
{x | (⟦e⟧*p x : part σ).dom}

def re_set0 (α σ) [primcodable α] [primcodable σ] (e : ℕ) : set α :=
{x | (univ0 α σ e x : part σ).dom}

notation `W⟦`e`⟧^`f:max := re_set _ _ ↑ₒf e

notation `W⟦`e`⟧ᵪ^`f:max := re_set ℕ bool ↑ₒf e
notation `W⟦`e`⟧ₙ^`f:max := re_set ℕ ℕ ↑ₒf e
notation `W⟦`e`⟧ᵪ⁰`:max := re_set0 ℕ bool e
notation `W⟦`e`⟧ₙ⁰`:max := re_set0 ℕ ℕ e

def curry {α} [primcodable α] (e : ℕ) (n : α) : ℕ := encode (code.curry (of_nat _ e) (encode n))

-- smn定理
@[simp] theorem eval_curry (f : γ → option τ) (e : ℕ) (n : β) (x : α) :
  (⟦curry e n⟧*f x : part σ) = (⟦e⟧*f (n, x) : part σ) :=
by { simp[curry, univ] }

namespace rpartrec

theorem curry_prim {α} [primcodable α] : primrec₂ (@curry α _) :=
(primrec.encode.comp $ code.curry_prim.comp
  ((primrec.of_nat code).comp primrec.fst) ((@primrec.encode α _).comp primrec.snd))

open primrec

theorem univn_sound {e} {p : β → option τ} {x : α} {y : σ} {s : ℕ} :
  ⟦e⟧*p [s] x = some y → ⟦e⟧*p x = some y :=
by { simp[univn, univ, part.eq_some_iff],
     exact λ s h e, ⟨s, code.evaln_sound h, e⟩ }

theorem univn_complete {p : β → option τ} {e x} {n : α} :
  x ∈ (⟦e⟧*p n : part σ) ↔ ∃ s, ⟦e⟧*p [s] n = some x :=
by { simp[univn, univ, part.eq_some_iff], split,
     { rintros ⟨a, ha, ea⟩,
       rcases code.evaln_complete.mp ha with ⟨s, hs⟩,
       refine ⟨s, a, hs, ea⟩ },
     { rintros ⟨s, a, ha, ea⟩,
       have := code.evaln_complete.mpr ⟨s, ha⟩,
       refine ⟨a, this, ea⟩ } }

theorem univn_dom_complete {p : β → option τ} {e} {n : α} :
  (⟦e⟧*p n : part σ).dom ↔ ∃ s, (⟦e⟧*p [s] n : option σ).is_some :=
by { simp[part.dom_iff_mem, option.is_some_iff_exists], split,
     { rintros ⟨y, h⟩, rcases univn_complete.mp h with ⟨s, h⟩, refine ⟨s, y, h⟩ },
     { rintros ⟨s, y, h⟩, have := univn_complete.mpr ⟨s, h⟩, refine ⟨y, this⟩ } }

theorem univn_mono {e} {p : β → option τ} {s₀ s₁ : ℕ} {x : α} {y : σ}
  (eqn : s₀ ≤ s₁) : ⟦e⟧*p [s₀] x = some y → ⟦e⟧*p [s₁] x = some y :=
by { simp [univn], intros z h eqn_z,
     refine ⟨z, code.evaln_mono eqn h, eqn_z⟩ }

theorem univn_dom_mono {e} {p : β → option τ} {s₀ s₁ : ℕ} {x : α}
  (eqn : s₀ ≤ s₁) : (⟦e⟧*p [s₀] x : option σ).is_some → (⟦e⟧*p [s₁] x : option σ).is_some :=
begin
  cases C : (⟦e⟧*p [s₀] x : option σ) with y; simp,
  simp[univn_mono eqn C]
end

theorem univn_mono_eq {e} {p : β → option τ} {s₀ s₁ : ℕ} {x : α} {y₀ y₁ : σ}
  (h₀ : ⟦e⟧*p [s₀] x = some y₀) (h₁ : ⟦e⟧*p [s₁] x = some y₁) : y₀ = y₁ :=
begin
  have : s₀ ≤ s₁ ∨ s₁ ≤ s₀, from le_total _ _,
  cases this,
  { have := univn_mono this h₀, simp [this] at h₁, exact h₁ },
  { have := univn_mono this h₁, simp [this] at h₀, exact eq.symm h₀ }
end

theorem univn_use {s e} {p q : ℕ → option β}
  (h : ∀ x, x < s → p x = q x) : (⟦e⟧*p [s] : α → option σ) = ⟦e⟧*q [s] :=
begin
  simp [univn],
  suffices :
    code.evaln s (λ n, option.map encode (p n)) (of_nat code e) =
    code.evaln s (λ n, option.map encode (q n)) (of_nat code e),
  { funext, rw this },
  apply code.evaln_use, intros u eqn, congr, exact h _ eqn
end

theorem univn_tot_use {s e} {f g : ℕ → β}
  (h : ∀ x, x < s → f x = g x) : (⟦e⟧^f [s] : α → option σ) = ⟦e⟧^g [s] :=
univn_use (λ x lt, by simp[h x lt])

theorem univn_mono_use {e} {p q : ℕ → option τ} {s₀ s₁ : ℕ} {x : α} {y : σ}
  (h : ∀ x < s₀, p x = q x) (eqn : s₀ ≤ s₁) : ⟦e⟧*p [s₀] x = some y → ⟦e⟧*q [s₁] x = some y := λ eq_y,
  have (⟦e⟧*p [s₀] x : option σ) = ⟦e⟧*q [s₀] x, from congr_fun (univn_use h) x,
univn_mono eqn (by simp[←this, eq_y])

theorem univn_tot_mono_use {e} {f g : ℕ → τ} {s₀ s₁ : ℕ} {x : α} {y : σ}
  (h : ∀ x < s₀, f x = g x) (eqn : s₀ ≤ s₁) : ⟦e⟧^f [s₀] x = some y → ⟦e⟧^g [s₁] x = some y :=
univn_mono_use (by simp; exact h) eqn

theorem eval_inclusion {e} {x : α} {y : σ} {p : ℕ → option τ}
  (h : y ∈ (⟦e⟧*p x : part σ)) : ∃ s, ∀ {q : ℕ → option τ},
  (∀ x y, x < s → p x = some y → q x = some y) → y ∈ (⟦e⟧*q x : part σ) :=
by { simp [part.eq_some_iff, univ] at h ⊢, rcases h with ⟨a, h, e⟩,
     rcases nat.rpartrec.code.eval_inclusion h with ⟨s, hs⟩,
     refine ⟨s, λ g h, ⟨a, hs (λ x y e ey, _), e⟩⟩, simp at ey, rcases ey with ⟨a, ea, ey⟩,
     have := h _ _ e ea, simp[this, ey] }

theorem eval_inclusion_tot {e} {x : α} {y : σ}
  {f : ℕ → τ} (h : y ∈ (⟦e⟧^f x : part σ)) : ∃ s, ∀ {g : ℕ → τ},
  (∀ x y, x < s → f x = y → g x = y) → y ∈ (⟦e⟧^g x : part σ) :=
by { rcases eval_inclusion h with ⟨s, hs⟩, refine ⟨s, λ g hfg, hs _⟩,
     simp, exact hfg }

end rpartrec

theorem rcomputable.curry {α} [primcodable α] {σ : Type*} {τ : Type*} [primcodable σ] [primcodable τ]
  {o : σ →. τ} : (@curry α _) computable₂_in o := rpartrec.curry_prim.to_rcomp


import tactic data.nat.digits .yeet

theorem unyeetable_3p2 : ¬ ∃ b, yeet b 3 2 :=
begin
  rintro ⟨b, h⟩,
  unfold yeet at h,
  cases b, { change 9 = 3 at h, norm_num at h },
  cases b, { change 9 = 5 at h, norm_num at h },
  cases b, { norm_num [nat.of_digits] at h },
  cases b, { norm_num [nat.of_digits] at h },
  have h2b : 2 < b + 4 := by linarith,
  have h3b : 3 < b + 4 := by linarith,
  rw nat.digits_of_lt _ _ dec_trivial h2b at h,
  rw nat.digits_of_lt _ _ dec_trivial h3b at h,
  change 9 = nat.of_digits _ [3, 2] at h,
  change 9 = 3 + (b + 4) * 2 at h,
  rw [add_mul, ←add_assoc, add_comm, ←add_assoc] at h,
  exact absurd (le_trans (le_add_right (le_refl _)) (ge_of_eq h)) dec_trivial
end

theorem unyeetable_3p4 : ¬ ∃ b, yeet b 3 4 :=
begin
  rintro ⟨b, h⟩,
  unfold yeet at h,
  cases b, { change _ = 3 at h, norm_num at h },
  cases b, { change _ = 7 at h, norm_num at h },
  cases b, { norm_num [nat.of_digits] at h },
  cases b, { norm_num [nat.of_digits] at h },
  cases b, { norm_num [nat.of_digits] at h },
  have h3b : 3 < b + 5 := by linarith,
  have h4b : 4 < b + 5 := by linarith,
  rw nat.digits_of_lt _ _ dec_trivial h3b at h,
  rw nat.digits_of_lt _ _ dec_trivial h4b at h,
  norm_num [nat.of_digits] at h,
  apply_fun (% 4) at h,
  norm_num at h
end


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.uliftable
import Mathlib.Lean3Lib.system.random
import Mathlib.system.random.basic
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# `gen` Monad

This monad is used to formulate randomized computations with a parameter
to specify the desired size of the result.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `gen` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/

namespace slim_check

/-- Monad to generate random examples to test properties with.
It has a `nat` parameter so that the caller can decide on the
size of the examples. -/
def gen (α : Type u) :=
  reader_t (ulift ℕ) rand α

/-- Execute a `gen` inside the `io` monad using `i` as the example
size and with a fresh random number generator. -/
def io.run_gen {α : Type} (x : gen α) (i : ℕ) : io α :=
  io.run_rand (reader_t.run x (ulift.up i))

namespace gen

/-- Lift `random.random` to the `gen` monad. -/
def choose_any (α : Type u) [random α] : gen α :=
  reader_t.mk fun (_x : ulift ℕ) => rand.random α

/-- Lift `random.random_r` to the `gen` monad. -/
def choose {α : Type u} [preorder α] [bounded_random α] (x : α) (y : α) (p : x ≤ y) : gen ↥(set.Icc x y) :=
  reader_t.mk fun (_x : ulift ℕ) => rand.random_r x y p

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat (x : ℕ) (y : ℕ) (p : x ≤ y) : gen ↥(set.Icc x y) :=
  choose x y p

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat' (x : ℕ) (y : ℕ) (p : x < y) : gen ↥(set.Ico x y) :=
  (fun (this : ∀ (i : ℕ), x < i → i ≤ y → Nat.pred i < y) => subtype.map Nat.pred sorry <$> choose (x + 1) y p) sorry

protected instance uliftable : uliftable gen gen :=
  reader_t.uliftable' (equiv.trans equiv.ulift (equiv.symm equiv.ulift))

protected instance has_orelse : has_orelse gen :=
  has_orelse.mk
    fun (α : Type u) (x y : gen α) =>
      do
        let b ← uliftable.up (choose_any Bool)
        ite (↥(ulift.down b)) x y

/-- Get access to the size parameter of the `gen` monad. For
reasons of universe polymorphism, it is specified in
continuation passing style. -/
def sized {α : Type u} (cmd : ℕ → gen α) : gen α :=
  reader_t.mk fun (_x : ulift ℕ) => sorry

/-- Apply a function to the size parameter. -/
def resize {α : Type u} (f : ℕ → ℕ) (cmd : gen α) : gen α :=
  reader_t.mk fun (_x : ulift ℕ) => sorry

/-- Create `n` examples using `cmd`. -/
def vector_of {α : Type u} (n : ℕ) (cmd : gen α) : gen (vector α n) :=
  sorry

/-- Create a list of examples using `cmd`. The size is controlled
by the size parameter of `gen`. -/
def list_of {α : Type u} (cmd : gen α) : gen (List α) :=
  sized
    fun (sz : ℕ) =>
      do
        uliftable.up (choose_nat 0 (sz + 1) sorry)
        sorry

/-- Given a list of example generators, choose one to create an example. -/
def one_of {α : Type u} (xs : List (gen α)) (pos : 0 < list.length xs) : gen α :=
  do
    uliftable.up (choose_nat' 0 (list.length xs) pos)
    sorry

/-- Given a list of example generators, choose one to create an example. -/
def elements {α : Type u} (xs : List α) (pos : 0 < list.length xs) : gen α :=
  do
    uliftable.up (choose_nat' 0 (list.length xs) pos)
    sorry

/--
`freq_aux xs i _` takes a weighted list of generator and a number meant to select one of the generators.

If we consider `freq_aux [(1, gena), (3, genb), (5, genc)] 4 _`, we choose a generator by splitting
the interval 1-9 into 1-1, 2-4, 5-9 so that the width of each interval corresponds to one of the
number in the list of generators. Then, we check which interval 4 falls into: it selects `genb`.
-/
def freq_aux {α : Type u} (xs : List (ℕ+ × gen α)) (i : ℕ) : i < list.sum (list.map (subtype.val ∘ prod.fst) xs) → gen α :=
  sorry

/--
`freq [(1, gena), (3, genb), (5, genc)] _` will choose one of `gena`, `genb`, `genc` with
probabiities proportional to the number accompanying them. In this example, the sum of
those numbers is 9, `gena` will be chosen with probability ~1/9, `genb` with ~3/9 (i.e. 1/3)
and `genc` with probability 5/9.
-/
def freq {α : Type u} (xs : List (ℕ+ × gen α)) (pos : 0 < list.length xs) : gen α :=
  let s : ℕ := list.sum (list.map (subtype.val ∘ prod.fst) xs);
  (fun (ha : 1 ≤ s) =>
      (fun (this : 0 ≤ s - 1) =>
          uliftable.adapt_up gen gen (choose_nat 0 (s - 1) this)
            fun (i : ↥(set.Icc 0 (s - 1))) => freq_aux xs (subtype.val i) sorry)
        sorry)
    sorry

/-- Generate a random permutation of a given list. -/
def permutation_of {α : Type u} (xs : List α) : gen (Subtype (list.perm xs)) :=
  sorry


import topology.basic
import topology.compact_open
import data.nat.prime
import data.real.basic
import data.real.irrational
import data.complex.basic
import data.fin.basic
import geometry.euclidean.basic
import analysis.inner_product_space.pi_L2
import algebra.group.defs
import algebra.field.basic
import combinatorics.configuration
import ring_theory.polynomial.basic
import group_theory.free_group
import combinatorics.simple_graph.basic
import ring_theory.integral_closure
import data.fintype.card
import category_theory.category.basic
import ring_theory.discrete_valuation_ring
import group_theory.torsion
import linear_algebra.matrix.charpoly.basic
import algebra.order.absolute_value
import analysis.convex.basic
import topology.uniform_space.uniform_convergence_topology
import topology.sequences
import analysis.normed.group.infinite_sum
import data.nat.choose.sum
import group_theory.specific_groups.cyclic
import group_theory.order_of_element
import analysis.mean_inequalities
import analysis.normed_space.banach
import topology.algebra.continuous_monoid_hom
import linear_algebra.matrix.symmetric
import analysis.inner_product_space.spectrum
import ring_theory.class_group
import ring_theory.dedekind_domain.basic
import ring_theory.principal_ideal_domain
import model_theory.satisfiability
import probability.integration
import ring_theory.simple_module
import category_theory.preadditive.schur
import representation_theory.maschke
import topology.paracompact
import combinatorics.simple_graph.coloring
--Prove that Absolute Value Function is Convex in Lean mathlib

--OUTPUT 1
theorem abs_convex : convex_on (λ x : ℝ, abs x) (Icc 0 ∞) :=
begin
  intros x y λ hx hy,
  have hx' : 0 ≤ x, from hx.left,
  have hy' : 0 ≤ y, from hy.left,
  have hx'' : 0 ≤ x + y, from add_nonneg hx' hy',
  have hx''' : 0 ≤ λ * x + (1 - λ) * y, from add_nonneg (mul_nonneg (le_of_lt hx) hx') (mul_nonneg (le_of_lt hy) hy'),
  have hx'''' : 0 ≤ abs (λ * x + (1 - λ) * y), from abs_nonneg.2 hx''',
  have hx''''' : 0 ≤ abs (λ * x) + abs ((1 - λ) * y), from add_nonneg (abs_mul_nonneg (le_of_lt hx) hx') (abs_mul_nonneg (le_of_lt hy) hy'),
  have hx'''''' : 0 ≤ λ * abs x + (1 - λ) * abs y, from add_nonneg (mul_nonneg (le_of_lt hx) (abs_nonneg.2 hx')) (mul_nonneg (le_of_lt hy) (abs_nonneg.2 hy')),
  have hx''''''' : abs (λ * x + (1 - λ) * y) ≤ λ * abs x + (1 - λ) * abs y, from abs_add_le_abs_add_abs (le_of_lt hx) (le_of_lt hy),
  have hx'''''''' : λ * abs x + (1 - λ) * abs y ≤ abs (λ * x + (1 - λ) * y), from le_of_lt hx''''''',
  show abs (λ * x + (1 - λ) * y) ≤ λ * abs x + (1 - λ) * abs y, from le_trans hx'''''' hx''''''''

--OUTPUT 2
theorem abs_convex : convex_on abs set.Ioo (-1,1) :=
begin
  intros x y λ hx hy,
  have hx' : x ≠ 0,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hy' : y ≠ 0,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hy this },
  have hx'y' : x ≠ y,
  { intro h,
    have : x ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨by linarith,by linarith⟩ },
    exact hx this },
  have hx'y' : x ≠ y,
  { intro h,
    have : y ∈ set.Ioo (-1,1),
    { rw h,
      exact set.mem_Ioo.2 ⟨

--OUTPUT 3
theorem abs_convex : convex_on (λ x, abs x) (Icc 0 1) :=
begin
  intros x y λ hx hy,
  have hx' : 0 ≤ x, from hx.1,
  have hy' : 0 ≤ y, from hy.1,
  have hx'' : x ≤ 1, from hx.2,
  have hy'' : y ≤ 1, from hy.2,
  have hx''' : abs x = x, from abs_of_nonneg hx',
  have hy''' : abs y = y, from abs_of_nonneg hy',
  have hxy : 0 ≤ x + y, from add_nonneg hx' hy',
  have hxy' : x + y ≤ 2, from add_le_add hx'' hy'',
  have hxy'' : abs (x + y) = x + y, from abs_of_nonneg hxy,
  have hxy''' : abs (x + y) ≤ 2, from hxy'',
  have hxy'''' : abs (x + y) ≤ 1, from le_trans hxy'' hxy',
  have hxy''''' : abs (x + y) ∈ Icc 0 1, from ⟨hxy, hxy''''⟩,
  have hxy'''''' : abs (x + y) ≤ λ hx hy, abs (x + y), from le_refl _,
  have hxy''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''',
  have hxy'''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''',
  have hxy''''''''' : abs (x + y) ≤ λ hx hy, abs x + abs y, from abs_add_le_abs_add_abs hx' hy',
  have hxy'''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''',
  have hxy''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''',
  have hxy'''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''',
  have hxy''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''',
  have hxy'''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''',
  have hxy''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''',
  have hxy'''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''',
  have hxy''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''',
  have hxy'''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''',
  have hxy''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''',
  have hxy'''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''',
  have hxy''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''',
  have hxy'''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''',
  have hxy''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''',
  have hxy'''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy'''''''''''''''''''''''''''''''''''''''''''',
  have hxy'''''''''''''''''''''''''''''''''''''''''''''' : abs (x + y) ≤ λ hx hy, x + y, from hxy''''''''''''''''''''''''''''''''''''''''''''',
  have hxy''''''''''''''''''''''''''''''''''''''''''''''' : abs


import syntax.syntaxCLK
import syntax.axiomsCLK
import semantics.semanticsCLK

local attribute [instance] classical.prop_decidable

open set

---------------------- Soundness ----------------------

noncomputable theorem soundnessCLK {agents : Type} [hN: fintype agents] (φ : formCLK agents) : axCLK φ → global_valid φ :=
begin
intro h,
induction h,

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  exact h1, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2 h3,
  apply h1,
    { exact h3,},

    { apply h2,
      exact h3 }, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  by_contradiction hf,
  exact (h1 hf) (h2 hf), },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  exact and.intro h1 h2, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  exact h1.left, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  exact h1.right, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  by_contradiction hf,
  exact h1 hf h2, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  exact m.f.E.liveness s h h1, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s,
  simp [s_entails_CLK],
  exact m.f.E.safety s h, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  apply m.f.E.N_max,
  by_contradiction,
  exact h1 h, },

{ unfold global_valid valid_m,
  intros m s,
  have := m.f.E.monoticity s h_G {t: m.f.states | s_entails_CLK m t (h_φ & h_ψ)} {t: m.f.states | s_entails_CLK m t h_φ} _,
  { unfold s_entails_CLK s_entails_CLK.aux at ⊢ this,
    exact this },
  intros t h1,
  unfold s_entails_CLK s_entails_CLK.aux at h1,
  exact h1.left, },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h1,
    exact m.f.E.superadd s h_G h_F {t: m.f.states | s_entails_CLK m t h_φ} {t: m.f.states | s_entails_CLK m t h_ψ} h1.left h1.right h_hInt, },

  { unfold global_valid valid_m,
    intros m s,
    have := h_ih_hImp m s,
    unfold s_entails_CLK s_entails_CLK.aux at ⊢ this,
    apply this,
    exact h_ih_hL m s, },

  { intros m s,
    have heq: {t: m.f.states | s_entails_CLK m t h_φ} = {t: m.f.states | s_entails_CLK m t h_ψ}, from
      begin
        apply set.ext,
        intros u,
        have h_ih := h_ih m u,
        unfold s_entails_CLK s_entails_CLK.aux at h_ih,
        cases h_ih,
        apply iff.intro,

        { intro hu,
          exact h_ih_left hu, },

        { intro hu,
          exact h_ih_right hu, }
      end,
    unfold s_entails_CLK s_entails_CLK.aux,
    apply and.intro,

    { intro h1,
      unfold s_entails_CLK s_entails_CLK.aux at *,
      rw ← heq,
      exact h1, },

    { intro h1,
      unfold s_entails_CLK s_entails_CLK.aux at *,
      rw heq,
      exact h1, } },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h1 h2 t ht,
    exact h1 t ht (h2 t ht), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h,
    exact h s (m.f.rfl h_i s), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h t ht u hu,
    exact h u (m.f.trans h_i s t u ht hu), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h1 h2,
    exact h1 (h2 s (m.f.rfl h_i s)), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s t h2,
    apply h_ih, },
end

inductive single : Type
  | one: single

lemma univ_single : (set.univ: set single) = {single.one} :=
begin
  rw eq_comm,
  rw set.eq_univ_iff_forall,
  intro x,
  cases x,
  simp,
end

lemma single_nonempty : nonempty single :=
begin
  apply exists_true_iff_nonempty.mp,
  apply exists.intro single.one,
  exact trivial,
end

def m_ex (ha: nonempty agents) : modelCLK agents  :=

{ f :=
  { states := single,
    hs := single_nonempty,
    ha := ha,
    E  :=
    { E := λ s G, {{single.one}},
      liveness :=
      begin
        intros _ _ hf,
        simp at hf,
        rw set.ext_iff at hf,
        simp at hf,
        apply hf single.one,
        refl,
      end,
      safety:=
        begin
          intros _ _, simp at *,
          exact univ_single,
        end,
      N_max :=
        begin
          intros _ _ hxc, simp at *,
          rw ←univ_single at *,
          have hcond : {single.one} ≠ (∅: set single),

            { intro hf,
              rw set.ext_iff at hf,
              simp at *,
              apply hf single.one,
              refl, },
          simp [hcond] at *, by_contradiction,
          have hex: ∃ x, x ∈ X, from nonempty_def.mp (ne_empty_iff_nonempty.mp hxc),
          cases hex with s hs,
          cases s,
          rw ←singleton_subset_iff at hs,
          rw ←univ_single at hs,
          exact h (univ_subset_iff.mp hs),
        end,
      monoticity:=
        begin
          intros _ _ _ _ hxy hx,
          simp [←univ_single] at *,
          rw hx at hxy,
          exact univ_subset_iff.mp hxy,
        end,
      superadd:=
      begin
        intros _ _ _ _ _ hX hY hGF,
        simp at *,
        simp[hX, hY],
      end },
    rel := λ a s, {s},
    rfl := by simp,
    sym :=
    begin
      intros i s t h,
      simp at *,
      rw h,
    end,
    trans :=
    begin
      intros i s t u hst htu,
      simp at *,
      simp[hst, htu],
    end, },
  v := λ _, {}, }

lemma nprfalseCLK {agents: Type} (ha: nonempty agents) [fintype agents] : ¬ @axCLK agents (⊥) :=
begin
apply (mt (soundnessCLK (@formCLK.bot agents))),
intro hf ,
simp[global_valid, valid_m, s_entails_CLK] at hf,
apply hf (m_ex ha),
exact single.one,
end