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

/-!
# Preserving terminal object

Constructions to relate the notions of preserving terminal objects and reflecting terminal objects
to concrete objects.

In particular, we show that `terminal_comparison G` is an isomorphism iff `G` preserves terminal
objects.
-/

universes v v₁ v₂ u u₁ u₂

noncomputable theory

open category_theory category_theory.category category_theory.limits

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

namespace category_theory.limits

variables (X : C)

section terminal

/--
The map of an empty cone is a limit iff the mapped object is terminal.
-/
def is_limit_map_cone_empty_cone_equiv :
  is_limit (G.map_cone (as_empty_cone.{v₁} X)) ≃ is_terminal (G.obj X) :=
is_limit_empty_cone_equiv D _ _ (eq_to_iso rfl)

/-- The property of preserving terminal objects expressed in terms of `is_terminal`. -/
def is_terminal.is_terminal_obj [preserves_limit (functor.empty.{v₁} C) G]
  (l : is_terminal X) : is_terminal (G.obj X) :=
is_limit_map_cone_empty_cone_equiv G X (preserves_limit.preserves l)

/-- The property of reflecting terminal objects expressed in terms of `is_terminal`. -/
def is_terminal.is_terminal_of_obj [reflects_limit (functor.empty.{v₁} C) G]
  (l : is_terminal (G.obj X)) : is_terminal X :=
reflects_limit.reflects ((is_limit_map_cone_empty_cone_equiv G X).symm l)

variables [has_terminal C]
/--
If `G` preserves the terminal object and `C` has a terminal object, then the image of the terminal
object is terminal.
-/
def is_limit_of_has_terminal_of_preserves_limit [preserves_limit (functor.empty.{v₁} C) G] :
  is_terminal (G.obj (⊤_ C)) :=
terminal_is_terminal.is_terminal_obj G (⊤_ C)

/--
If `C` has a terminal object and `G` preserves terminal objects, then `D` has a terminal object
also.
Note this property is somewhat unique to (co)limits of the empty diagram: for general `J`, if `C`
has limits of shape `J` and `G` preserves them, then `D` does not necessarily have limits of shape
`J`.
-/
lemma has_terminal_of_has_terminal_of_preserves_limit [preserves_limit (functor.empty.{v₁} C) G] :
  has_terminal D :=
⟨λ F,
begin
  haveI := has_limit.mk ⟨_, is_limit_of_has_terminal_of_preserves_limit G⟩,
  apply has_limit_of_iso F.unique_from_empty.symm,
end⟩

variable [has_terminal D]
/--
If the terminal comparison map for `G` is an isomorphism, then `G` preserves terminal objects.
-/
def preserves_terminal.of_iso_comparison
  [i : is_iso (terminal_comparison G)] : preserves_limit (functor.empty C) G :=
begin
  apply preserves_limit_of_preserves_limit_cone terminal_is_terminal,
  apply (is_limit_map_cone_empty_cone_equiv _ _).symm _,
  apply is_limit.of_point_iso (limit.is_limit (functor.empty.{v₂} D)),
  apply i,
end

/-- If there is any isomorphism `G.obj ⊤ ⟶ ⊤`, then `G` preserves terminal objects. -/
def preserves_terminal_of_is_iso
  (f : G.obj (⊤_ C) ⟶ ⊤_ D) [i : is_iso f] : preserves_limit (functor.empty C) G :=
begin
  rw subsingleton.elim f (terminal_comparison G) at i,
  exactI preserves_terminal.of_iso_comparison G,
end

/-- If there is any isomorphism `G.obj ⊤ ≅ ⊤`, then `G` preserves terminal objects. -/
def preserves_terminal_of_iso
  (f : G.obj (⊤_ C) ≅ ⊤_ D) : preserves_limit (functor.empty C) G :=
preserves_terminal_of_is_iso G f.hom

variables [preserves_limit (functor.empty.{v₁} C) G]

/--
If `G` preserves terminal objects, then the terminal comparison map for `G` is an isomorphism.
-/
def preserves_terminal.iso : G.obj (⊤_ C) ≅ ⊤_ D :=
(is_limit_of_has_terminal_of_preserves_limit G).cone_point_unique_up_to_iso (limit.is_limit _)

@[simp]
lemma preserves_terminal.iso_hom : (preserves_terminal.iso G).hom = terminal_comparison G :=
rfl

instance : is_iso (terminal_comparison G) :=
begin
  rw ← preserves_terminal.iso_hom,
  apply_instance,
end

end terminal

section initial

/--
The map of an empty cocone is a colimit iff the mapped object is initial.
-/
def is_colimit_map_cocone_empty_cocone_equiv :
  is_colimit (G.map_cocone (as_empty_cocone.{v₁} X)) ≃ is_initial (G.obj X) :=
is_colimit_empty_cocone_equiv D _ _ (eq_to_iso rfl)

/-- The property of preserving initial objects expressed in terms of `is_initial`. -/
def is_initial.is_initial_obj [preserves_colimit (functor.empty.{v₁} C) G]
  (l : is_initial X) : is_initial (G.obj X) :=
is_colimit_map_cocone_empty_cocone_equiv G X (preserves_colimit.preserves l)

/-- The property of reflecting initial objects expressed in terms of `is_initial`. -/
def is_initial.is_initial_of_obj [reflects_colimit (functor.empty.{v₁} C) G]
  (l : is_initial (G.obj X)) : is_initial X :=
reflects_colimit.reflects ((is_colimit_map_cocone_empty_cocone_equiv G X).symm l)

variables [has_initial C]
/--
If `G` preserves the initial object and `C` has a initial object, then the image of the initial
object is initial.
-/
def is_colimit_of_has_initial_of_preserves_colimit [preserves_colimit (functor.empty.{v₁} C) G] :
  is_initial (G.obj (⊥_ C)) :=
initial_is_initial.is_initial_obj G (⊥_ C)

/--
If `C` has a initial object and `G` preserves initial objects, then `D` has a initial object
also.
Note this property is somewhat unique to colimits of the empty diagram: for general `J`, if `C`
has colimits of shape `J` and `G` preserves them, then `D` does not necessarily have colimits of
shape `J`.
-/
lemma has_initial_of_has_initial_of_preserves_colimit [preserves_colimit (functor.empty.{v₁} C) G] :
  has_initial D :=
⟨λ F,
begin
  haveI := has_colimit.mk ⟨_, is_colimit_of_has_initial_of_preserves_colimit G⟩,
  apply has_colimit_of_iso F.unique_from_empty,
end⟩

variable [has_initial D]
/--
If the initial comparison map for `G` is an isomorphism, then `G` preserves initial objects.
-/
def preserves_initial.of_iso_comparison
  [i : is_iso (initial_comparison G)] : preserves_colimit (functor.empty C) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone initial_is_initial,
  apply (is_colimit_map_cocone_empty_cocone_equiv _ _).symm _,
  apply is_colimit.of_point_iso (colimit.is_colimit (functor.empty.{v₂} D)),
  apply i,
end

/-- If there is any isomorphism `⊥ ⟶ G.obj ⊥`, then `G` preserves initial objects. -/
def preserves_initial_of_is_iso
  (f : ⊥_ D ⟶ G.obj (⊥_ C)) [i : is_iso f] : preserves_colimit (functor.empty C) G :=
begin
  rw subsingleton.elim f (initial_comparison G) at i,
  exactI preserves_initial.of_iso_comparison G,
end

/-- If there is any isomorphism `⊥ ≅ G.obj ⊥ `, then `G` preserves initial objects. -/
def preserves_initial_of_iso
  (f : ⊥_ D ≅ G.obj (⊥_ C)) : preserves_colimit (functor.empty C) G :=
preserves_initial_of_is_iso G f.hom

variables [preserves_colimit (functor.empty.{v₁} C) G]

/-- If `G` preserves initial objects, then the initial comparison map for `G` is an isomorphism. -/
def preserves_initial.iso : G.obj (⊥_ C) ≅ ⊥_ D :=
(is_colimit_of_has_initial_of_preserves_colimit G).cocone_point_unique_up_to_iso
  (colimit.is_colimit _)

@[simp]
lemma preserves_initial.iso_hom : (preserves_initial.iso G).inv = initial_comparison G :=
rfl

instance : is_iso (initial_comparison G) :=
begin
  rw ← preserves_initial.iso_hom,
  apply_instance,
end

end initial

end category_theory.limits


import Mathlib.Tactic.RunCmd
import Mathlib.Data.List.Basic

namespace Keller

def hasEdge' : List Nat → List Nat → Bool → Bool → Bool
| a::l, b::r, found, n => if a = b then hasEdge' l r found n else
  bif found || (b - a == 2 || a - b == 2) then
    n || hasEdge' l r true true
  else
    hasEdge' l r false true
| a, b, c, d => false

@[implementedBy hasEdge'] def hasEdge : List Nat → List Nat → Bool → Bool → Bool := by
  intro l; induction l with
  | nil => exact fun _ _ _ => false
  | cons a l ih => intro r; induction r with
    | nil => exact fun _ _ => false
    | cons b r => exact
      bif a == b then ih r else fun found =>
        bif found || (b - a == 2 || a - b == 2) then
          fun n => n || ih r true true
        else
          fun _ => ih r false true

inductive Dim2
| _00 | _01 | _02 | _03
| _10 | _11 | _12 | _13
| _20 | _21 | _22 | _23
| _30 | _31 | _32 | _33
deriving DecidableEq, Repr

open Lean Elab Command in
run_cmd do
  let mut s := #[]
  for (a, arr) in #[
    (`_00, #[`_02, `_12, `_20, `_21, `_23, `_32]),
    (`_01, #[`_03, `_13, `_20, `_21, `_22, `_33]),
    (`_02, #[`_21, `_22, `_23]),
    (`_03, #[`_11, `_20, `_22, `_23, `_31]),
    (`_10, #[`_12, `_31, `_33]),
    (`_11, #[`_13, `_23, `_31]),
    (`_12, #[`_20, `_31, `_32, `_33]),
    (`_13, #[`_21, `_33]),
    (`_20, #[`_22, `_32]),
    (`_21, #[`_23, `_33]),
    (`_23, #[`_31]),
    (`_31, #[`_33])] do
    for b in arr do
      s := (s.push (a, b)).push (b, a)
  let stx := s.map fun x => mkIdent $ x.1.updatePrefix default ++ x.2.updatePrefix default
  let stx1 := s.map (mkIdent ·.1)
  let stx2 := s.map (mkIdent ·.2)
  elabCommand (← set_option hygiene false in `(
    def Dim2.keller' : Dim2 → Dim2 → Bool
    $[| $stx1, $stx2 => true]*
    | _, _ => false

    @[implementedBy Dim2.keller'] def Dim2.keller : Dim2 → Dim2 → Bool := by
      intro g1 g2
      induction g1 <;> induction g2
      $[case $stx => exact true]*
      all_goals exact false))

def Dim2.value : Dim2 → List (List Nat)
| _00 => [[0, 2, 1, 1], [1, 1, 3, 2], [2, 3, 0, 3], [3, 0, 2, 0]]
| _02 => [[2, 2, 1, 1], [1, 1, 3, 0], [0, 3, 0, 3], [3, 0, 2, 2]]
| _21 => [[1, 0, 1, 1], [1, 3, 3, 1], [3, 1, 0, 3], [3, 2, 2, 3]]
| _23 => [[1, 1, 1, 3], [1, 3, 2, 3], [3, 0, 0, 1], [3, 2, 3, 1]]
| _12 => [[0, 0, 0, 0], [0, 2, 3, 0], [2, 1, 1, 2], [2, 3, 2, 2]]
| _10 => [[0, 1, 0, 2], [0, 2, 2, 2], [2, 0, 1, 0], [2, 3, 3, 0]]
| _33 => [[1, 2, 1, 0], [3, 3, 0, 2], [0, 0, 2, 3], [2, 1, 3, 1]]
| _31 => [[3, 2, 1, 0], [1, 3, 0, 2], [0, 0, 2, 1], [2, 1, 3, 3]]
| _20 => [[0, 2, 1, 3], [3, 1, 3, 2], [2, 3, 0, 1], [1, 0, 2, 0]]
| _22 => [[2, 2, 1, 3], [3, 1, 3, 0], [0, 3, 0, 1], [1, 0, 2, 2]]
| _01 => [[3, 1, 1, 1], [3, 3, 2, 1], [1, 0, 0, 3], [1, 2, 3, 3]]
| _03 => [[3, 0, 1, 3], [3, 3, 3, 3], [1, 1, 0, 1], [1, 2, 2, 1]]
| _32 => [[0, 0, 1, 2], [0, 3, 3, 2], [2, 1, 0, 0], [2, 2, 2, 0]]
| _30 => [[0, 1, 1, 0], [0, 3, 2, 0], [2, 0, 0, 2], [2, 2, 3, 2]]
| _13 => [[0, 1, 3, 1], [2, 0, 2, 3], [1, 2, 1, 2], [3, 3, 0, 0]]
| _11 => [[0, 1, 3, 3], [2, 0, 2, 1], [3, 2, 1, 2], [1, 3, 0, 0]]

theorem Dim2.is_ok (g) : (Dim2.value g).Pairwise (fun a b => hasEdge a b false false) := by
  cases g <;> decide

def dim4 : List (Dim2 × Dim2) := open Dim2 in
[(_01, _00), (_03, _20), (_10, _12), (_10, _32),
 (_11, _20), (_12, _12), (_12, _32), (_13, _00),
 (_21, _00), (_23, _20), (_31, _02), (_31, _21),
 (_31, _23), (_33, _01), (_33, _03), (_33, _22)]

def Dim2.hasEdge (x y : Dim2) (found n : Bool) : Bool :=
  x.value.all fun x => y.value.all fun y => Keller.hasEdge x y found n

def Dim2.ok₂ : Dim2 × Dim2 → Dim2 × Dim2 → Bool
| (a1, a2), (b1, b2) =>
  if a1 = b1 then a2.hasEdge b2 false false
  else if a2 = b2 then a1.hasEdge b1 false false
  else
    let k1 := a1.keller b1
    let k2 := a2.keller b2
    let x1 := a1.hasEdge b1 (!k1) true
    let x2 := a2.hasEdge b2 (!k2) true
    x1 && x2 && (k1 || k2)

set_option profiler true in -- takes about 8 seconds
theorem dim4_ok₂ : dim4.Pairwise (Dim2.ok₂ · ·) := by decide

def dim8 : List (List Nat) :=
  dim4.bind (fun (a, b) => (a.value.bind fun a => (b.value.map fun b => a ++ b)))

def isClique (l : List (List Nat)) : Bool :=
  l.all fun a => l.all fun b => a == b || hasEdge a b false false

#eval isClique dim8 -- true


lemma at_most_two : ∀ (f : bool → bool) b x y z,
    x = f b → y = f x → z = f y → z = x :=
begin
    intros f b x y z h1 h2 h3,
    induction b,
        induction x,
            rw ←h1 at h2,
            rw h2 at h3,
            simp [h3],
            rw ←h1,
        rw h1,
        induction y,
            assumption,
        simp * at *,
        rw ←h2,
    induction x,
        induction y,
            rw ←h2 at h3,
            assumption,
        rw h3,
        rw ←h1,
    rw ←h1 at h2,
    rw [h2, ←h1] at h3,
    assumption,
end

example : ∀ (f : bool → bool) b, f (f (f b)) = f b :=
by intros; apply at_most_two; refl


import tactic

variables {X : Type}

def P (Q : X → X → Prop) : X → X → Prop := λ x y, Q x y ∧ ¬ Q y x

-- uniformily defines indifference for P and R relations
def I (Q : X → X → Prop) : X → X → Prop := λ x y, x = y ∨ (Q x y ∧ Q y x)

def N (Q : X → X → Prop) : X → X → Prop := λ x y, ¬x = y ∧ ¬ Q x y ∧ ¬ Q y x

lemma P_asymmetric (Q : X → X → Prop) {x y : X} : (P Q) x y → ¬ (P Q) y x :=
begin
  intros ᾰ ᾰ_1, cases ᾰ_1, cases ᾰ, solve_by_elim,
end

lemma P_irrefl (Q : X → X → Prop) {x : X} : ¬ (P Q) x x :=
begin
  intros ᾰ, cases ᾰ, solve_by_elim,
end

lemma I_refl (Q : X → X → Prop) {x : X} : (I Q) x x :=
begin
  unfold I,
  have e : x = x := by refl,
  use e,
end

lemma N_irrefl (Q : X → X → Prop) {x : X} : ¬(N Q) x x :=
begin
  unfold N,
  push_neg,
  intro n,
  exfalso,
  have e : x = x := by refl,
  exact n e,
end


import .global
import .Omega
import .Spec
import category_theory.functor_category
import category_theory.natural_transformation
open category_theory
open Omega
open Spec
universes u

local notation `Ring` := CommRing.{u}
local notation `Set` :=  Type u
local notation `Presheaf` := Ring ⥤ Set
variables (X : Presheaf)(Y : Presheaf)

structure open_imersion { Y X : Ring ⥤ Set} (ι : Y ⟶  X)  :=
(χ  : nat_trans X  Ω )
(mono_ι : ∀ A :  Ring, mono (ι.app A))
(Hyp_1 : ∀ A : Ring, ∀ y : Y.obj(A), χ.app(A)  ( ι.app(A) y ) = (⊤ : ideal A))
(Hyp_2 : ∀ A : Ring, ∀ x : X.obj(A), χ.app(A) x = (⊤ : ideal A) → ∃ y : Y.obj(A), ι.app A y = x)

structure closed_imersion {X Y : Ring ⥤ Set} (ι : nat_trans Y  X) :=
(χ  : nat_trans X  Ω )
(mono_ι : ∀ A :  Ring, mono (ι.app A))
(Hyp_1 : ∀ A : Ring, ∀ y : Y.obj(A), (χ.app(A) (ι.app(A) y)) = (⊥  : ideal A))
(Hyp_2 : ∀ A : Ring, ∀ x : X.obj(A), χ.app(A) x = (⊥ : ideal A) → ∃ y : Y.obj(A), ι.app A y = x)

lemma open_imersion_is_mono (ι : Y ⟶  X) : open_imersion  ι  →  ∀ A :  Ring, mono (ι.app A)  :=λ U, U.mono_ι
lemma closed_imersion_is_mono (ι : Y ⟶  X) : closed_imersion  ι  →  ∀ A :  Ring, mono (ι.app A)  :=λ U, U.mono_ι

structure sieves (X : Presheaf) :=
(Y : Presheaf)
(ι : nat_trans Y X)
(mono_ι : ∀ A : Ring, mono (ι.app A))

structure covering_familly (R : Ring) :=
(U : sieves $ Spec R)
(Hyp : ∃ S : set R, ∀ A : Ring, ∀ y : U.Y.obj A, ∃ s ∈ S,  ((U.ι.app A)(y)).to_fun (s) = 1)

structure matching_familly (X : Presheaf)(A : Ring) :=
(F : covering_familly A)
(β : nat_trans F.U.Y X)

---  Je dois définir quoi ?
---  Pour R un anneau, je dois définir la notion de sous-foncteur couvrant de (Spec R)
--- C'est  ∪ (s : S) D(s) pour s ⊂ R
--- definir la notion de topology de grothendieck sur Ring^(op) ≃ AFF = spec (Yoneda)

structure covers (X : Presheaf) :=
(U : sieves X)

structure Open (X : Presheaf) :=
(U : sieves X)
(χ  :  nat_trans X Ω )
(Hyp_1 : ∀ A : Ring, ∀ y : U.Y.obj(A), χ.app(A)  ( U.ι.app(A) y ) = (⊤ : ideal A))
(Hyp_2 : ∀ A : Ring, ∀ x : X.obj(A), χ.app(A) x = (⊤ : ideal A) → ∃ y : U.Y.obj(A), U.ι.app A y = x)

variables (ι : Y ⟶  X)
#check Open

-- variables (U1 : Open X)(U2 : Open X)
-- def  intersection : Open X → Open X →  Open X := λ U1 U2, begin sorry, end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Relator for functions, pairs, sums, and lists.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.reserved_notation
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂ u_1 u_2

namespace Mathlib

namespace relator

/- TODO(johoelzl):
 * should we introduce relators of datatypes as recursive function or as inductive
predicate? For now we stick to the recursor approach.
 * relation lift for datatypes, Π, Σ, set, and subtype types
 * proof composition and identity laws
 * implement method to derive relators from datatype
-/

def lift_fun {α : Sort u₁} {β : Sort u₂} {γ : Sort v₁} {δ : Sort v₂} (R : α → β → Prop)
    (S : γ → δ → Prop) (f : α → γ) (g : β → δ) :=
  ∀ {a : α} {b : β}, R a b → S (f a) (g b)

infixr:40 " ⇒ " => Mathlib.relator.lift_fun

def right_total {α : Type u₁} {β : outParam (Type u₂)} (R : outParam (α → β → Prop)) :=
  ∀ (b : β), ∃ (a : α), R a b

def left_total {α : Type u₁} {β : outParam (Type u₂)} (R : outParam (α → β → Prop)) :=
  ∀ (a : α), ∃ (b : β), R a b

def bi_total {α : Type u₁} {β : outParam (Type u₂)} (R : outParam (α → β → Prop)) :=
  left_total R ∧ right_total R

def left_unique {α : Type u₁} {β : Type u₂} (R : α → β → Prop) :=
  ∀ {a : α} {b : β} {c : α}, R a b → R c b → a = c

def right_unique {α : Type u₁} {β : Type u₂} (R : α → β → Prop) :=
  ∀ {a : α} {b c : β}, R a b → R a c → b = c

theorem rel_forall_of_right_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop)
    [t : right_total R] :
    lift_fun (R ⇒ implies) implies (fun (p : α → Prop) => ∀ (i : α), p i)
        fun (q : β → Prop) => ∀ (i : β), q i :=
  fun (p : α → Prop) (q : β → Prop) (Hrel : lift_fun R implies p q) (H : ∀ (i : α), p i) (b : β) =>
    exists.elim (t b) fun (a : α) (Rab : R a b) => Hrel Rab (H a)

theorem rel_exists_of_left_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop) [t : left_total R] :
    lift_fun (R ⇒ implies) implies (fun (p : α → Prop) => ∃ (i : α), p i)
        fun (q : β → Prop) => ∃ (i : β), q i :=
  sorry

theorem rel_forall_of_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop) [t : bi_total R] :
    lift_fun (R ⇒ Iff) Iff (fun (p : α → Prop) => ∀ (i : α), p i)
        fun (q : β → Prop) => ∀ (i : β), q i :=
  sorry

theorem rel_exists_of_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop) [t : bi_total R] :
    lift_fun (R ⇒ Iff) Iff (fun (p : α → Prop) => ∃ (i : α), p i)
        fun (q : β → Prop) => ∃ (i : β), q i :=
  sorry

theorem left_unique_of_rel_eq {α : Type u₁} {β : Type u₂} (R : α → β → Prop) {eq' : β → β → Prop}
    (he : lift_fun R (R ⇒ Iff) Eq eq') : left_unique R :=
  fun {a : α} {b : β} {c : α} (ᾰ : R a b) (ᾰ_1 : R c b) =>
    idRhs (a = c) ((fun (this : eq' b b) => iff.mpr (he ᾰ ᾰ_1) this) (iff.mp (he ᾰ ᾰ) rfl))

theorem rel_imp : lift_fun Iff (Iff ⇒ Iff) implies implies :=
  fun (p q : Prop) (h : p ↔ q) (r s : Prop) (l : r ↔ s) => imp_congr h l

theorem rel_not : lift_fun Iff Iff Not Not := fun (p q : Prop) (h : p ↔ q) => not_congr h

-- (this is an instance is always applies, since the relation is an out-param)

protected instance bi_total_eq {α : Type u₁} : bi_total Eq :=
  { left := fun (a : α) => Exists.intro a rfl, right := fun (a : α) => Exists.intro a rfl }

def bi_unique {α : Type u_1} {β : Type u_2} (r : α → β → Prop) := left_unique r ∧ right_unique r

theorem left_unique_flip {α : Type u_1} {β : Type u_2} {r : α → β → Prop} (h : left_unique r) :
    right_unique (flip r) :=
  fun {a : β} {b c : α} (ᾰ : flip r a b) (ᾰ_1 : flip r a c) => idRhs (b = c) (h ᾰ ᾰ_1)

theorem rel_and : lift_fun Iff (Iff ⇒ Iff) And And :=
  fun (a b : Prop) (h₁ : a ↔ b) (c d : Prop) (h₂ : c ↔ d) => and_congr h₁ h₂

theorem rel_or : lift_fun Iff (Iff ⇒ Iff) Or Or :=
  fun (a b : Prop) (h₁ : a ↔ b) (c d : Prop) (h₂ : c ↔ d) => or_congr h₁ h₂

theorem rel_iff : lift_fun Iff (Iff ⇒ Iff) Iff Iff :=
  fun (a b : Prop) (h₁ : a ↔ b) (c d : Prop) (h₂ : c ↔ d) => iff_congr h₁ h₂

theorem rel_eq {α : Type u_1} {β : Type u_2} {r : α → β → Prop} (hr : bi_unique r) :
    lift_fun r (r ⇒ Iff) Eq Eq :=
  fun (a : α) (b : β) (h₁ : r a b) (c : α) (d : β) (h₂ : r c d) =>
    { mp := fun (h : a = c) => Eq._oldrec (fun (h₂ : r a d) => and.right hr a b d h₁ h₂) h h₂,
      mpr := fun (h : b = d) => Eq._oldrec (fun (h₂ : r c b) => and.left hr a b c h₁ h₂) h h₂ }

end Mathlib


example (p q : Prop) : p ∧ ¬ p → q :=
begin
  intro h,
  cases h,
  contradiction
end


import .list_as_k_tuple linear_algebra.affine_space.basic
import linear_algebra.basis
import .affine_coordinate_space
import data.real.basic

set_option trace.app_builder true

open list
open vecl

namespace aff_fr

universes u v w

variables
    -- (id : ℕ)
    (X : Type u)
    (K : Type v)
    (V : Type w)
    (n : ℕ)
    (k : K)
    (ι : Type*)
    (s : finset ι)
    (g : ι → K)
    (v : ι → V)
    [inhabited K]
    [field K]
    [add_comm_group V]
  --  [module K V]
    [vector_space K V]
    [affine_space V X]
    [is_basis K v]
    [affine_space V X]

/-
An affine frame comprises an origin point
and a basis for the vector space.
-/
structure vector_basis :=
    (map : ι → V)
    (proof_is_basis : is_basis K map)

/-
inductive affine_frame
    (X : Type u)
    (K : Type v)
    (V : Type w)
    (ι : Type*)
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X] --: Type
| standard : affine_frame
| derived
(original : affine_frame)
(origin : X)
(basis : vector_basis K V ι )
: affine_frame
-/
/-
structure affine_frame  :=
(origin : X)
(basis : ι → V)
(proof_is_basis : is_basis K basis)
-/
/-
inductive affine_frame
| tuple
(origin : aff_pt_coord_tuple K n)
(basis : ι → aff_vec_coord_tuple K n)
(proof_is_basis : is_basis K basis) : affine_frame
| from_tuple
()

first you need a tuple frame
then you need points constructed from
-/

#check aff_pt_coord_tuple K n

structure affine_frame  :=
(origin : X)
(basis : ι → V)
(proof_is_basis : is_basis K basis)

def affine_tuple_frame
    (K : Type v)
    (n : ℕ)
    [inhabited K]
    [field K]
    :=
    affine_frame
        (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) (fin n)

structure aff_tuple_framed_pt (fr : affine_tuple_frame K n)
    extends aff_pt_coord_tuple K n :=
   -- (tuple : aff_pt_coord_tuple K n)
   mk ::

structure aff_tuple_framed_vec (fr : affine_tuple_frame K n) extends aff_vec_coord_tuple K n :=
   -- (tuple : aff_pt_coord_tuple K n)
   mk ::

instance (fr : affine_tuple_frame K n): has_add (aff_tuple_framed_vec K n fr) := sorry
instance (fr : affine_tuple_frame K n): has_zero (aff_tuple_framed_vec K n fr) := sorry
instance (fr : affine_tuple_frame K n): has_neg (aff_tuple_framed_vec K n fr) := sorry
instance aff_comm_group_coord (fr : affine_tuple_frame K n): add_comm_group (aff_tuple_framed_vec K n fr) := sorry
instance (fr : affine_tuple_frame K n) : has_scalar K (aff_tuple_framed_vec K n fr) := sorry
instance (fr : affine_tuple_frame K n) : mul_action K (aff_tuple_framed_vec K n fr) :=
    ⟨sorry, sorry⟩
instance (fr : affine_tuple_frame K n) : distrib_mul_action K (aff_tuple_framed_vec K n fr) :=
    sorry
instance aff_semimod_coord (fr : affine_tuple_frame K n) : semimodule K (aff_tuple_framed_vec K n fr)
    := ⟨sorry, sorry⟩
instance (fr : affine_tuple_frame K n)  : has_vadd (aff_tuple_framed_vec K n fr) (aff_tuple_framed_pt K n fr) := sorry
instance (fr : affine_tuple_frame K n)  : has_vsub (aff_tuple_framed_vec K n fr) (aff_tuple_framed_pt K n fr) := sorry
instance (fr : affine_tuple_frame K n)  : add_action (aff_tuple_framed_vec K n fr) (aff_tuple_framed_pt K n fr) := sorry--⟨aff_group_action K n, aff_zero_sadd K n, aff_add_sadd K n⟩
instance afc (fr : affine_tuple_frame K n)  : affine_space
    (aff_tuple_framed_vec K n fr)
    (aff_tuple_framed_pt K n fr) :=
    sorry

def affine_tuple_framed_frame
    {K : Type v}
    {n : ℕ}
    [inhabited K]
    [field K]
    (f : affine_tuple_frame K n)
   -- [add_comm_group (aff_tuple_framed_vec K n f)]
    --[module K (aff_tuple_framed_vec K n f)]
    --[affine_space (aff_tuple_framed_vec K n f) (aff_tuple_framed_pt K n f)]
    :=
    affine_frame
        (aff_tuple_framed_pt K n f) K (aff_tuple_framed_vec K n f) (fin n)

structure affine_framed_pt
    {f : affine_tuple_frame K n}
    (fr : affine_tuple_framed_frame f) extends aff_pt_coord_tuple K n
    :=
mk ::

structure affine_framed_vec
    {f : affine_tuple_frame K n}
    (fr : affine_tuple_framed_frame f) extends aff_vec_coord_tuple K n
    :=
mk ::

mutual inductive
 affine_coordinate_frame,
 aff_coord_pt,
 aff_coord_vec

    (K : Type w)
    [inhabited K]
    [field K]
    --[add_comm_group (aff_vec_coord_tuple K n)]
   -- [module K (aff_vec_coord_tuple K n)]
  --  [vector_space K (aff_vec_coord_tuple K n)]
   -- [affine_space (aff_vec_coord_tuple K n) (aff_pt_coord_tuple K n)]
    /-
with affine_coordinate_frame : Type v
| tuple
(origin : aff_pt_coord_tuple K n)
--(basis : ι → aff_vec_coord_tuple K n)
--(proof_is_basis : is_basis K basis)
: affine_coordinate_frame-//-
| gen_frame
    (origin : aff_coord_pt)
    (basis : ι → aff_coord_vec)
    (proof_is_basis : is_basis K basis) : affine_coordinate_frame-/
with aff_coord_pt :  aff_pt_coord_tuple K n → Type v
| mk (tuple : aff_pt_coord_tuple K n)
: aff_coord_pt tuple
with aff_coord_vec : aff_vec_coord_tuple K n → Type v
| mk (tuple : aff_vec_coord_tuple K n)
: aff_coord_vec  tuple

structure aff_coord_pt (fr : affine_frame X K V ι) extends aff_pt_coord_tuple K n :=
   -- (tuple : aff_pt_coord_tuple K n)
   mk ::

structure aff_coord_vec (fr : affine_frame X K V ι) extends aff_vec_coord_tuple K n  :=
   -- (tuple : aff_vec_coord_tuple K n)
   mk ::
/-
def affine_coordinate_frame_origin (frame : affine_coordinate_frame X K V ι) :=
match frame with
| std_frame := _
| gen_frame o b pf := o
end

def frame_basis : affine_frame X K V ι → (ι → V) :=
| (affine_frame.std_frame origin) := basis
| (affine_frame.gen_frame origin _ _) := origin
-/

variables
    (fr : affine_frame X K V ι)
    (cv1 cv2 : aff_coord_vec X K V n ι fr)
    (cp1 cp2 : aff_coord_pt  X K V n ι fr)

/-
-- lemmas so that the following operations are well-defined
/-- the length of the sum of two length n+1 vectors is n+1 -/
lemma aff_not_nil : x.1 ≠ [] :=
begin
intro h,
have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
have len_x_nil : length x.1 = length nil := by rw h,
have len_fixed : length nil = n + 1 := eq.trans (eq.symm len_x_nil) x.2,
have bad : 0 = n + 1 := eq.trans (eq.symm len_nil) len_fixed,
contradiction,
end

lemma aff_cons : ∃ x_hd : K, ∃ x_tl : list K, x.1 = x_hd :: x_tl :=
begin
cases x,
cases x_l,
{
    have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
    have bad := eq.trans (eq.symm len_nil) x_len_fixed,
    contradiction
},
{
    apply exists.intro x_l_hd,
    apply exists.intro x_l_tl,
    exact rfl
}
end

/-- head is compatible with addition -/
lemma head_sum : head x.1 + head y.1 = head (ladd x.1 y.1) :=
begin
cases x,
cases y,
cases x_l,
    have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
    have bad := eq.trans (eq.symm len_nil) x_len_fixed,
    contradiction,
cases y_l,
    have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
    have bad := eq.trans (eq.symm len_nil) y_len_fixed,
    contradiction,
have head_xh : head (x_l_hd :: x_l_tl) = x_l_hd := rfl,
have head_yh : head (y_l_hd :: y_l_tl) = y_l_hd := rfl,
rw head_xh at x_fst_zero,
rw head_yh at y_fst_zero,
simp [x_fst_zero, y_fst_zero, add_cons_cons 0 0 x_l_tl y_l_tl],
end

/-- the head of the sum of two vectors is 0 -/
lemma sum_fst_fixed : head (ladd x.1 y.1) = 0 :=
    by simp only [eq.symm (head_sum K n x y), x.3, y.3]; exact add_zero 0

/-- the length of the zero vector is n+1 -/
lemma len_zero : length (zero_vector K n) = n + 1 :=
begin
induction n with n',
refl,
{
have h₃ : nat.succ (n' + 1) = nat.succ n' + 1 := rfl,
have h₄ : length (zero_vector K (nat.succ n')) = nat.succ (n' + 1) :=
    by {rw eq.symm n_ih, refl},
rw eq.symm h₃,
exact h₄,
}
end

/-- the head of the zero vector is zero -/
lemma head_zero : head (zero_vector K n) = 0 := by {cases n, refl, refl}

lemma vec_len_neg : length (vecl_neg x.1) = n + 1 := by {simp only [len_neg], exact x.2}

lemma head_neg_0 : head (vecl_neg x.1) = 0 :=
begin
cases x,
cases x_l,
contradiction,
rw neg_cons x_l_hd x_l_tl,
have head_xh : head (x_l_hd :: x_l_tl) = x_l_hd := rfl,
have head_0 : head (0 :: vecl_neg x_l_tl) = 0 := rfl,
rw head_xh at x_fst_zero,
simp only [x_fst_zero, neg_zero, head_0],
end

-/
def vec_add_coord : aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr :=
    λ x y, ⟨⟨ladd x.1.l y.1.l, list_sum_fixed K n x.1 y.1, sum_fst_fixed K n x.1 y.1⟩⟩
def vec_zero_coord : aff_coord_vec X K V n ι fr := ⟨⟨zero_vector K n, len_zero K n, head_zero K n⟩⟩
def vec_neg_coord : aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr
| ⟨⟨l, len, fst⟩⟩ := ⟨⟨vecl_neg l, vec_len_neg K n ⟨l, len, fst⟩, head_neg_0 K n ⟨l, len, fst⟩⟩⟩

/-! ### type class instances for the abelian group operations -/
instance : has_add (aff_coord_vec X K V n ι fr) := ⟨vec_add_coord X K V n ι fr⟩
instance : has_zero (aff_coord_vec X K V n ι fr) := ⟨vec_zero_coord X K V n ι fr⟩
instance : has_neg (aff_coord_vec X K V n ι fr) := ⟨vec_neg_coord X K V n ι fr⟩
@[ext]
def vec_scalar_coord : K → aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr :=
    λ a x, ⟨⟨scalar_mul a x.1.1, trans (scale_len a x.1.1) x.1.2, sorry⟩⟩
/-! ### Type class instance for abelian group -/
instance aff_comm_group_coord : add_comm_group (aff_coord_vec X K V n ι fr) :=
begin
    sorry
end
instance : has_scalar K (aff_coord_vec X K V n ι fr) := ⟨vec_scalar_coord X K V n ι fr⟩

/-
lemma vec_one_smul_coord : (1 : K) • cv1 = cv1 :=
begin
cases cv1,

ext,
split,
intros,
dsimp only [has_scalar.smul, vec_scalar] at a_1,
rw one_smul_cons at a_1,
exact a_1,

intros,
dsimp only [has_scalar.smul, vec_scalar],
rw one_smul_cons,
exact a_1,
end
-/

lemma vec_mul_smul_coord : ∀ g h : K, ∀ x : aff_coord_vec X K V n ι fr, (g * h) • x = g • h • x := sorry

instance : mul_action K (aff_coord_vec X K V n ι fr) :=
    ⟨sorry, vec_mul_smul_coord X K V n ι fr⟩

instance : distrib_mul_action K (aff_coord_vec X K V n ι fr) :=
    sorry
instance aff_semimod_coord : semimodule K (aff_coord_vec X K V n ι fr)
    --[distrib_mul_action K (aff_coord_vec X K V n ι fr)]
    :=
    -- extremely odd that this doesnt work....
    ⟨sorry, sorry⟩

def aff_group_action_coord : (aff_coord_vec X K V n ι fr) → (aff_coord_pt X K V n ι fr) → (aff_coord_pt X K V n ι fr) :=
    λ x y, ⟨⟨ladd x.1.1 y.1.1, sorry, sorry⟩⟩

def aff_group_sub_coord : (aff_coord_pt X K V n ι fr) → (aff_coord_pt X K V n ι fr) → (aff_coord_vec X K V n ι fr) :=
    λ x y, ⟨⟨ladd x.1.1 (vecl_neg y.1.1), sorry, sorry⟩⟩

instance : has_vadd (aff_coord_vec X K V n ι fr) (aff_coord_pt X K V n ι fr) := ⟨aff_group_action_coord X K V n ι fr⟩

instance : has_vsub (aff_coord_vec X K V n ι fr) (aff_coord_pt X K V n ι fr) := ⟨aff_group_sub_coord X K V n ι fr⟩

instance : add_action (aff_coord_vec X K V n ι fr) (aff_coord_pt X K V n ι fr) := sorry--⟨aff_group_action K n, aff_zero_sadd K n, aff_add_sadd K n⟩

/-
We need proof that given a frame f,
⟨ aff_coord_pt f, aff_coord_vec f⟩ is
an affine space,
-/

/-

def vecptadd := r3_der2_pt1 +ᵥ r3_der2_vec2 --expected : pass
def vecptsub := r3_der2_pt1 -ᵥ r3_der2_vec2 --expected : pass
def ptvecsub := r3_der2_vec2 -ᵥ r3_der2_pt1 -- expected : pass
-/
def pt_plus_vec
    {X : Type u}
    {K : Type v}
    {V : Type w}
    {n : ℕ}
    {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X]
    {fr : affine_frame X K V ι} :
    (aff_coord_pt X K V n ι fr) →
    (aff_coord_vec X K V n ι fr) →
    (aff_coord_pt X K V n ι fr)
| p v := aff_group_action_coord X K V n ι fr v p

notation
 pt +ᵥ v := pt_plus_vec pt v

def pt_minus_vec
    {X : Type u}
    {K : Type v}
    {V : Type w}
    {n : ℕ}
    {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X]
    {fr : affine_frame X K V ι} :
    (aff_coord_pt X K V n ι fr) →
    (aff_coord_vec X K V n ι fr) →
    (aff_coord_pt X K V n ι fr)
| p v := aff_group_action_coord X K V n ι fr (vec_neg_coord X K V n ι fr v) p
.
notation
 pt -ᵥ v := pt_minus_vec pt v

def prf : affine_space (aff_coord_vec X K V n ι fr) (aff_coord_pt  X K V n ι fr) := sorry

instance afc : affine_space
    (aff_coord_vec X K V n ι fr)
    (aff_coord_pt  X K V n ι fr) :=
    prf X K V n ι fr

/-
KEEP?
-/
def affine_coord_tuple_space_type (K : Type v) (n : ℕ) [field K] [inhabited K] :=
    affine_space_type
        (aff_pt_coord_tuple K n)
        K
        (aff_vec_coord_tuple K n)

/-
-/

/-
Code to manufacture a standard basis for a given affine space.
-/
abbreviation zero := zero_vector K n

def list.to_basis_vec : fin n → list K := λ x, (zero K n).update_nth (x.1 + 1) 1

lemma len_basis_vec_fixed (x : fin n) : (list.to_basis_vec K n x).length = n + 1 := sorry

lemma head_basis_vec_fixed (x : fin n) : (list.to_basis_vec K n x).head = 0 := sorry

def std_basis : fin n → aff_vec_coord_tuple K n :=
λ x, ⟨list.to_basis_vec K n x, len_basis_vec_fixed K n x, head_basis_vec_fixed K n x⟩

lemma std_is_basis : is_basis K (std_basis K n) := sorry

def aff_coord_space_std_frame :
    affine_frame (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) (fin n) :=
        ⟨pt_zero K n, std_basis K n, std_is_basis K n⟩

--affine_frame (aff_coord_pt fr_n) K (aff_coord_pt fr_n) (iota)

end aff_fr


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Patrick Massot, Scott Morrison
-/
import category_theory.adjunction.reflective
import category_theory.concrete_category.unbundled_hom
import category_theory.monad.limits
import topology.category.Top.basic
import topology.uniform_space.completion

/-!
# The category of uniform spaces

We construct the category of uniform spaces, show that the complete separated uniform spaces
form a reflective subcategory, and hence possess all limits that uniform spaces do.

TODO: show that uniform spaces actually have all limits!
-/

universes u

open category_theory

/-- A (bundled) uniform space. -/
def UniformSpace : Type (u+1) := bundled uniform_space

namespace UniformSpace

/-- The information required to build morphisms for `UniformSpace`. -/
instance : unbundled_hom @uniform_continuous :=
⟨@uniform_continuous_id, @uniform_continuous.comp⟩

attribute [derive [large_category, concrete_category]] UniformSpace

instance : has_coe_to_sort UniformSpace Type* := bundled.has_coe_to_sort

instance (x : UniformSpace) : uniform_space x := x.str

/-- Construct a bundled `UniformSpace` from the underlying type and the typeclass. -/
def of (α : Type u) [uniform_space α] : UniformSpace := ⟨α⟩

instance : inhabited UniformSpace := ⟨UniformSpace.of empty⟩

@[simp] lemma coe_of (X : Type u) [uniform_space X] : (of X : Type u) = X := rfl

instance (X Y : UniformSpace) : has_coe_to_fun (X ⟶ Y) (λ _, X → Y) :=
⟨category_theory.functor.map (forget UniformSpace)⟩

@[simp] lemma coe_comp {X Y Z : UniformSpace} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g : X → Z) = g ∘ f := rfl
@[simp] lemma coe_id (X : UniformSpace) : (𝟙 X : X → X) = id := rfl
@[simp] lemma coe_mk {X Y : UniformSpace} (f : X → Y) (hf : uniform_continuous f) :
  ((⟨f, hf⟩ : X ⟶ Y) : X → Y) = f := rfl

lemma hom_ext {X Y : UniformSpace} {f g : X ⟶ Y} : (f : X → Y) = g → f = g := subtype.eq

/-- The forgetful functor from uniform spaces to topological spaces. -/
instance has_forget_to_Top : has_forget₂ UniformSpace.{u} Top.{u} :=
{ forget₂ :=
  { obj := λ X, Top.of X,
    map := λ X Y f, { to_fun := f,
                      continuous_to_fun := uniform_continuous.continuous f.property }, }, }

end UniformSpace

/-- A (bundled) complete separated uniform space. -/
structure CpltSepUniformSpace :=
(α : Type u)
[is_uniform_space : uniform_space α]
[is_complete_space : complete_space α]
[is_separated : separated_space α]

namespace CpltSepUniformSpace

instance : has_coe_to_sort CpltSepUniformSpace (Type u) := ⟨CpltSepUniformSpace.α⟩

attribute [instance] is_uniform_space is_complete_space is_separated

/-- The function forgetting that a complete separated uniform spaces is complete and separated. -/
def to_UniformSpace (X : CpltSepUniformSpace) : UniformSpace :=
UniformSpace.of X

instance complete_space (X : CpltSepUniformSpace) : complete_space ((to_UniformSpace X).α) :=
CpltSepUniformSpace.is_complete_space X

instance separated_space (X : CpltSepUniformSpace) : separated_space ((to_UniformSpace X).α) :=
CpltSepUniformSpace.is_separated X

/-- Construct a bundled `UniformSpace` from the underlying type and the appropriate typeclasses. -/
def of (X : Type u) [uniform_space X] [complete_space X] [separated_space X] :
CpltSepUniformSpace := ⟨X⟩

@[simp] lemma coe_of (X : Type u) [uniform_space X] [complete_space X] [separated_space X] :
  (of X : Type u) = X := rfl

instance : inhabited CpltSepUniformSpace :=
begin
  haveI : separated_space empty := separated_iff_t2.mpr (by apply_instance),
  exact ⟨CpltSepUniformSpace.of empty⟩
end

/-- The category instance on `CpltSepUniformSpace`. -/
instance category : large_category CpltSepUniformSpace :=
induced_category.category to_UniformSpace

/-- The concrete category instance on `CpltSepUniformSpace`. -/
instance concrete_category : concrete_category CpltSepUniformSpace :=
induced_category.concrete_category to_UniformSpace

instance has_forget_to_UniformSpace : has_forget₂ CpltSepUniformSpace UniformSpace :=
induced_category.has_forget₂ to_UniformSpace

end CpltSepUniformSpace

namespace UniformSpace

open uniform_space
open CpltSepUniformSpace

/-- The functor turning uniform spaces into complete separated uniform spaces. -/
noncomputable def completion_functor : UniformSpace ⥤ CpltSepUniformSpace :=
{ obj := λ X, CpltSepUniformSpace.of (completion X),
  map := λ X Y f, ⟨completion.map f.1, completion.uniform_continuous_map⟩,
  map_id' := λ X, subtype.eq completion.map_id,
  map_comp' := λ X Y Z f g, subtype.eq (completion.map_comp g.property f.property).symm, }.

/-- The inclusion of a uniform space into its completion. -/
def completion_hom (X : UniformSpace) :
  X ⟶ (forget₂ CpltSepUniformSpace UniformSpace).obj (completion_functor.obj X) :=
{ val := (coe : X → completion X),
  property := completion.uniform_continuous_coe X }

@[simp] lemma completion_hom_val (X : UniformSpace) (x) :
  (completion_hom X) x = (x : completion X) := rfl

/-- The mate of a morphism from a `UniformSpace` to a `CpltSepUniformSpace`. -/
noncomputable def extension_hom {X : UniformSpace} {Y : CpltSepUniformSpace}
  (f : X ⟶ (forget₂ CpltSepUniformSpace UniformSpace).obj Y) :
  completion_functor.obj X ⟶ Y :=
{ val := completion.extension f,
  property := completion.uniform_continuous_extension }

@[simp] lemma extension_hom_val {X : UniformSpace} {Y : CpltSepUniformSpace}
  (f : X ⟶ (forget₂ _ _).obj Y) (x) :
  (extension_hom f) x = completion.extension f x := rfl.

@[simp]

/-- The completion functor is left adjoint to the forgetful functor. -/
noncomputable def adj : completion_functor ⊣ forget₂ CpltSepUniformSpace UniformSpace :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, completion_hom X ≫ f,
    inv_fun := λ f, extension_hom f,
    left_inv := λ f, by { dsimp, erw extension_comp_coe },
    right_inv := λ f,
    begin
      apply subtype.eq, funext x, cases f,
      exact @completion.extension_coe _ _ _ _ _ (CpltSepUniformSpace.separated_space _) f_property _
    end },
  hom_equiv_naturality_left_symm' := λ X X' Y f g,
  begin
    apply hom_ext, funext x, dsimp,
    erw [coe_comp, ←completion.extension_map],
    refl, exact g.property, exact f.property,
  end }

noncomputable instance : is_right_adjoint (forget₂ CpltSepUniformSpace UniformSpace) :=
⟨completion_functor, adj⟩
noncomputable instance : reflective (forget₂ CpltSepUniformSpace UniformSpace) := {}

open category_theory.limits

-- TODO Once someone defines `has_limits UniformSpace`, turn this into an instance.
example [has_limits.{u} UniformSpace.{u}] : has_limits.{u} CpltSepUniformSpace.{u} :=
has_limits_of_reflective $ forget₂ CpltSepUniformSpace UniformSpace.{u}

end UniformSpace


-- import ring_theory.localization.localization_localization
-- import ring_theory.local_properties

-- variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T] (f : R →+* S) (g : S →+* T)

-- def ring_hom.essentially_surjective (f : R →+* S) : Prop :=
-- ∀ x : S, ∃ a b : R, is_unit (f b) ∧ x * f b = f a

-- lemma is_localization.range_lift_is_unit_submonoid_map {x} :
--   x ∈ (is_localization.lift (λ x : (is_unit.submonoid S).comap f, x.2) :
--     localization ((is_unit.submonoid S).comap f) →+* S).range ↔
--     ∃ a b : R, is_unit (f b) ∧ x * f b = f a :=
-- begin
--   split,
--   { rintro ⟨x, rfl⟩,
--     obtain ⟨x, s, rfl⟩ := is_localization.mk'_surjective ((is_unit.submonoid S).comap f) x,
--     refine ⟨x, s, s.2, _⟩,
--     rw [mul_comm, is_localization.lift_mk', ← mul_assoc, units.mul_inv_eq_iff_eq_mul, mul_comm],
--     refl },
--   { rintro ⟨a, b, hb, e⟩,
--     refine ⟨is_localization.mk' _ a ⟨b, show b ∈ (is_unit.submonoid S).comap f, from hb⟩, _⟩,
--     rw [is_localization.lift_mk', units.mul_inv_eq_iff_eq_mul, eq_comm, ← e], refl }
-- end

-- def fraction_subring : subring S :=
-- { ..(is_localization.lift (λ x : (is_unit.submonoid S).comap f, x.2) :
--   localization ((is_unit.submonoid S).comap f) →+* S).range.copy
--   { x | ∃ a b : R, is_unit (f b) ∧ x * f b = f a }
--   (set.ext $ λ x, (is_localization.range_lift_is_unit_submonoid_map f).symm) }

-- variables (R S)

-- def fraction_subalgebra [algebra R S] : subalgebra R S :=
-- { algebra_map_mem' := λ x, ⟨x, 1, (algebra_map R S).map_one.symm ▸ is_unit_one,
--     by rw [map_one, mul_one]⟩,
--   ..(fraction_subring $ algebra_map R S) }

-- variables {R S}

-- namespace ring_hom.essentially_surjective

-- variable {f}

-- lemma iff_surjective_comp_localization : f.essentially_surjective ↔
--   ∃ (M : submonoid R) (hM : ∀ x : M, is_unit (f x)),
--     function.surjective (is_localization.lift hM : localization M →+* S) :=
-- begin
--   split,
--   { intro H,
--     refine ⟨(is_unit.submonoid S).comap f, λ x, x.2, λ x, _⟩,
--     obtain ⟨a, b, hb, e⟩ := H x,
--     refine ⟨is_localization.mk' _ a ⟨b, show b ∈ (is_unit.submonoid S).comap f, from hb⟩, _⟩,
--     rw [is_localization.lift_mk', units.mul_inv_eq_iff_eq_mul, eq_comm, ← e],
--     refl },
--   { rintro ⟨M, hM, hM'⟩ x,
--     obtain ⟨x, rfl⟩ := hM' x,
--     obtain ⟨x, s, rfl⟩ := is_localization.mk'_surjective M x,
--     refine ⟨x, s, hM s, _⟩,
--     rw [mul_comm, is_localization.lift_mk', ← mul_assoc, units.mul_inv_eq_iff_eq_mul, mul_comm],
--     refl }
-- end

-- lemma iff_fraction_subring_eq_top :
--   f.essentially_surjective ↔ fraction_subring f = ⊤ :=
-- begin
--   rw eq_top_iff,
--   exact ⟨λ h x _, h x, λ h x, h trivial⟩
-- end

-- lemma of_surjective (hf : function.surjective f) :
--   f.essentially_surjective :=
-- begin
--   intro x, obtain ⟨x, rfl⟩ := hf x, refine ⟨x, 1, _, _⟩; simp only [map_one, mul_one, is_unit_one]
-- end

-- variable (S)

-- lemma of_localization [algebra R S] (M : submonoid R) [is_localization M S] :
--   (algebra_map R S).essentially_surjective :=
-- begin
--   intro x,
--   obtain ⟨⟨y, s⟩, e⟩ := is_localization.surj M x,
--   exact ⟨y, s, is_localization.map_units _ s, e⟩,
-- end

-- variables {S f g}

-- lemma comp (hg : g.essentially_surjective) (hf : f.essentially_surjective) :
--   (g.comp f).essentially_surjective :=
-- begin
--   intro x,
--   obtain ⟨y, s, hs, e₁⟩ := hg x,
--   obtain ⟨z, t, ht, e₂⟩ := hf y,
--   obtain ⟨u, v, hv, e₃⟩ := hf s,
--   refine ⟨z * v, t * u, _, _⟩,
--   { apply_fun g at e₃, simp only [ring_hom.comp_apply, map_mul] at e₃ ⊢, rw ← e₃,
--     exact (ht.map g).mul (hs.mul $ hv.map g) },
--   { apply_fun g at e₂ e₃, simp only [ring_hom.comp_apply, map_mul] at e₂ e₃ ⊢,
--     rw [← e₂, ← e₃, ← e₁], simp only [mul_assoc, mul_comm, mul_left_comm], rw mul_comm (g (f t)) }
-- end

-- lemma tensor_product [algebra R S] [algebra R T] (h : (algebra_map R T).essentially_surjective) :
--   (algebra_map S (tensor_product R S T)).essentially_surjective :=
-- begin
--   rw iff_surjective_comp_localization at h ⊢,
--   obtain ⟨M, hM, hM'⟩ := h,
--   refine ⟨M.map (algebra_map R S), _, _⟩,
--   { rintro ⟨_, x, hx, rfl⟩, rw [subtype.coe_mk, ← is_scalar_tower.algebra_map_apply,
--     ← algebra.tensor_product.include_right.comp_algebra_map, ring_hom.comp_apply],
--     exact (hM ⟨x, hx⟩).map _ },
--   { intro x,
--     induction x using tensor_product.induction_on with x y x y hx hy,
--     { exact ⟨0, map_zero _⟩ },
--     { obtain ⟨y, rfl⟩ := hM' y,
--       obtain ⟨y, s, rfl⟩ := is_localization.mk'_surjective M y,
--       refine ⟨is_localization.mk' _ (y • x)
--         ⟨_, submonoid.mem_map_of_mem (algebra_map R S) s.prop⟩, _⟩,
--       rw [is_localization.lift_mk', units.mul_inv_eq_iff_eq_mul,
--         is_unit.coe_lift_right],
--       simp only [algebra.tensor_product.tmul_mul_tmul, set_like.coe_mk, mul_one,
--         algebra.id.map_eq_id, ring_hom.coe_monoid_hom, ring_hom.to_monoid_hom_eq_coe,
--         algebra.tensor_product.algebra_map_apply, ring_hom.id_apply, monoid_hom.restrict_apply,
--         ring_hom_comp_triple.comp_apply, mul_comm x, ← algebra.smul_def, tensor_product.smul_tmul],
--       rw [algebra.smul_def, algebra.smul_def, mul_one,
--         mul_comm, is_localization.lift_mk', mul_assoc],
--       erw is_unit.lift_right_inv_mul,
--       rw mul_one },
--   { obtain ⟨⟨x, rfl⟩, ⟨y, rfl⟩⟩ := ⟨hx, hy⟩, exact ⟨x + y, map_add _ _ _⟩ } }
-- end

-- variables (f g)

-- lemma of_comp (h : (g.comp f).essentially_surjective) :
--   g.essentially_surjective :=
-- begin
--   rw iff_surjective_comp_localization at h ⊢,
--   obtain ⟨M, hM, hM'⟩ := h,
--   refine ⟨M.map f, _, _⟩,
--   { rintros ⟨_, x, hx, rfl⟩, exact hM ⟨x, hx⟩ },
--   { intro x,
--     obtain ⟨x, rfl⟩ := hM' x,
--     obtain ⟨x, s, rfl⟩ := is_localization.mk'_surjective M x,
--     refine ⟨is_localization.mk' _ (f x) ⟨_, submonoid.mem_map_of_mem f s.prop⟩, _⟩,
--     rw [is_localization.lift_mk', units.mul_inv_eq_iff_eq_mul,
--       mul_comm, is_localization.lift_mk', ← mul_assoc, units.eq_mul_inv_iff_mul_eq],
--     simp only [ring_hom.to_monoid_hom_eq_coe, function.comp_app, ring_hom.coe_comp,
--       is_unit.coe_lift_right, set_like.coe_mk, ring_hom.coe_monoid_hom,
--       monoid_hom.restrict_apply],
--     exact mul_comm _ _ }
-- end

-- noncomputable
-- abbreviation localization.at_prime.map (p : ideal S) [p.is_prime] :
--   localization.at_prime (p.comap f) →+* localization.at_prime p :=
-- is_localization.map (localization.at_prime p) f
--       (show (p.comap f).prime_compl ≤ p.prime_compl.comap f, from le_refl _)

-- lemma iff_stalk :
--   f.essentially_surjective ↔ ∀ (p : ideal S) [p.is_prime],
--     by exactI function.surjective (localization.at_prime.map f p) :=
-- begin
--   split,
--   sorry; { introsI H p hp x,
--     have : ((localization.at_prime.map f p).comp (algebra_map R _)).essentially_surjective,
--     { rw is_localization.map_comp,
--       exact (of_localization _ p.prime_compl).comp H },
--     replace this := of_comp _ _ this,
--     obtain ⟨a, b, hb, e⟩ := this x,
--     obtain ⟨a, s, rfl⟩ := is_localization.mk'_surjective (p.comap f).prime_compl a,
--     obtain ⟨b, t, rfl⟩ := is_localization.mk'_surjective (p.comap f).prime_compl b,
--     replace hb : b ∈ (ideal.comap f p).prime_compl,
--     { rwa [is_localization.map_mk', is_localization.at_prime.is_unit_mk'_iff] at hb },
--     refine ⟨is_localization.mk' _ (a * t) ⟨_, mul_mem s.prop hb⟩, _⟩,
--     rw [is_localization.map_mk', is_localization.map_mk',
--       is_localization.eq_mk'_iff_mul_eq, mul_right_comm, ← (is_localization.map_units
--       (localization.at_prime p) ⟨f t, show f t ∈ p.prime_compl, from t.2⟩).mul_left_inj, mul_assoc,
--       mul_comm (is_localization.mk' _ _ _), is_localization.mul_mk'_eq_mk'_of_mul] at e,
--     erw is_localization.mk'_mul_cancel_left at e,
--     simp_rw [subtype.coe_mk, mul_assoc, ← map_mul] at e,
--     rw [is_localization.map_mk', is_localization.mk'_eq_iff_eq_mul, ← e],
--     refl },
--   { intros H x,
--     have : ∀ (p : ideal S) [p.is_prime], ∃ a ∉ p.comap f, f a * x ∈ f.range,
--     { introsI p hp,
--       obtain ⟨y, hy⟩ := H p (is_localization.mk' _ x (1 : p.prime_compl)),
--       obtain ⟨y, s, rfl⟩ := is_localization.mk'_surjective (p.comap f).prime_compl y,
--       rw [is_localization.map_mk', is_localization.mk'_eq_iff_eq, submonoid.coe_one,
--         mul_one, subtype.coe_mk, is_localization.eq_iff_exists p.prime_compl] at hy,
--     }

--   }
-- end

-- end ring_hom.essentially_surjective

-- lemma ring_hom.localization_essentially_surjective :
--   ring_hom.localization_preserves @ring_hom.essentially_surjective :=
-- begin
--   introsI R S _ _ f M R' S' _ _ _ _ _ _ hf,
--   apply ring_hom.essentially_surjective.of_comp (algebra_map R R'),
--   rw is_localization.map_comp,
--   exact (ring_hom.essentially_surjective.of_localization _ $ M.map f).comp hf,
-- end

-- lemma ring_hom.essentially_surjective_of_localization_span :
--   ring_hom.of_localization_span @ring_hom.essentially_surjective :=
-- begin
--   -- rw ring_hom.of_localization_span_target_iff_finite,
--   introsI R S _ _ f s hs H x,
--   letI := f.to_algebra,
--   apply (fraction_subalgebra R S).to_submodule.mem_of_span_eq_top_of_smul_pow_mem _ hs,
--   intros r,
--   replace H := (H r).comp (ring_hom.essentially_surjective.of_localization
--     (localization.away (r : R)) (submonoid.powers (r : R))),
--   delta localization.away_map is_localization.away.map at H,
--   rw is_localization.map_comp at H,
--   obtain ⟨a, b, hb, e⟩ := H (algebra_map _ _ x),
--   simp only [ring_hom.comp_apply, ← map_mul] at e,
--   obtain ⟨⟨_, n, rfl⟩, e'⟩ := (is_localization.eq_iff_exists (submonoid.powers (f r)) _).mp e,
--   have : ∃ m : ℕ, is_unit (f (b * r ^ m)),
--   { obtain ⟨c, ⟨_, m, rfl⟩, hc⟩ := is_localization.mk'_surjective
--       (submonoid.powers (f r)) (↑(hb.unit⁻¹) : localization.away (f r)),
--     rw [← mul_one (↑(hb.unit⁻¹) : localization.away (f r)), units.eq_inv_mul_iff_mul_eq,
--       is_unit.unit_spec, ring_hom.comp_apply, is_localization.mul_mk'_eq_mk'_of_mul,
--       is_localization.mk'_eq_iff_eq_mul, one_mul, subtype.coe_mk, is_localization.eq_iff_exists
--         (submonoid.powers $ f r)] at hc,
--     have := is_localization.at_prime.is_unit_to_map_iff,
--     refine ⟨m, is_unit_of_mul_eq_one _ c _⟩,

--    },

--   have := is_localization.at_prime.is_unit_mk'_iff,
--   refine ⟨n, a * r ^ n, _⟩,
-- end

-- lemma ring_hom.essentially_surjective_is_local :
--   ring_hom.property_is_local @ring_hom.essentially_surjective :=
-- begin
--   constructor,
-- end

-- lemma ring_hom.essentially_surjective_of_localization_span :
--   ring_hom.of_localization_span @ring_hom.essentially_surjective :=
-- begin
--   introsI R S _ _ f s hs H,
--   letI := f.to_algebra,
--   apply (integral_closure R S).to_submodule.mem_of_span_eq_top_of_smul_pow_mem _ hs,
--   intros r,
--   letI := (localization.away_map f r).to_algebra,
--   haveI : is_scalar_tower R (localization.away (r : R)) (localization.away $ f r) :=
--     is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,
--   haveI : is_scalar_tower R S (localization.away $ f r) :=
--     is_scalar_tower.of_algebra_map_eq' rfl,
--   obtain ⟨⟨_, n, rfl⟩, p, hp, hp'⟩ := is_integral.exists_multiple_integral_of_is_localization
--     (submonoid.powers (r : R)) _ (H r (algebra_map _ _ x)),
--   simp only [submonoid.smul_def, subtype.coe_mk, algebra.smul_def, ring_hom.comp_apply,
--     is_scalar_tower.algebra_map_eq R S (localization.away $ f r), ← map_mul] at hp',
--   rw [eval₂_eq_eval_map, ← map_map, eval_map, eval₂_at_apply, ← @is_localization.mk'_one _ _
--     (submonoid.powers $ f r), is_localization.mk'_eq_zero_iff] at hp',
--   obtain ⟨⟨_, m, rfl⟩, H'⟩ := hp',
--   rw [subtype.coe_mk, mul_comm, ← map_pow, ← ring_hom.algebra_map_to_algebra f,
--     eval_map, ← eval₂_smul] at H',
--   by_cases (r : R) ^ m = 0, { use m, rw [h, zero_smul], exact zero_mem _ },
--   have hp'' : ((r : R) ^ m • p).leading_coeff = (r : R) ^ m,
--   { have hp'' : ((r : R) ^ m • p).coeff p.nat_degree = (r : R) ^ m,
--     { rw [coeff_smul, coeff_nat_degree, hp.leading_coeff, smul_eq_mul, mul_one] },
--     have : ((r : R) ^ m • p).nat_degree = p.nat_degree,
--     { exact (nat_degree_smul_le _ _).antisymm (le_nat_degree_of_ne_zero $ hp''.trans_ne h) },
--     rw [leading_coeff, this, hp''] },
--   have := is_integral_leading_coeff_smul _ _ H',
--   rw [hp'', ← algebra.smul_def, smul_smul, ← pow_add] at this,
--   exact ⟨m+n, this⟩
-- end


import GMLInit.Data.Basic
import GMLInit.Data.HVal
import GMLInit.Data.List.Basic
import GMLInit.Logic.ListConnectives
import GMLInit.Meta.Basic
import GMLInit.Meta.Relation

inductive HList.{u} : List (Sort u) → Type u
| nil : HList []
| cons {α αs} : α → HList αs → HList (α :: αs)

namespace HList

scoped infixr:67 " :: " => HList.cons
scoped syntax (name := hlist) "[" term,* "]"  : term
scoped macro_rules (kind := hlist)
  | `([ ])           => `(HList.nil)
  | `([ $a ])        => `(HList.cons $a HList.nil)
  | `([ $a, $as,* ]) => `(HList.cons $a [$as,*])

protected theorem cons_hcongr {α β} {αs βs : List (Sort _)} {a : α} {b : β} {as : HList αs} {bs : HList βs} : α = β → αs = βs → a ≅ b → as ≅ bs → HList.cons a as ≅ HList.cons b bs
| rfl, rfl, HEq.rfl, HEq.rfl => HEq.rfl

-- FIXME
-- def ofList {α : Type _} : (as : List α) → HList (as.map fun x => α)
-- | [] => []
-- | a::as => a :: ofList as

protected def ofListHVal : (vs : List HVal) → HList (vs.map HVal.sort)
| [] => []
| v::vs => v.val :: HList.ofListHVal vs

@[specialize, inline] protected def foldl : {αs : List (Sort _)} → {β : Sort _} → HList αs → HList (αs.map fun α => α → β → β) → β → β
| [], _, [], [], b => b
| _::_, _, x :: xs, f :: fs, b => HList.foldl xs fs (f x b)

protected def foldr : {αs : List (Sort _)} → {β : Sort _} → HList αs → HList (αs.map fun α => α → β → β) → β → β
| [], _, [], [], b => b
| _::_, _, x :: xs, f :: fs, b => f x (HList.foldr xs fs b)

protected def append : {αs βs : List (Sort _)} → HList αs → HList βs → HList (αs ++ βs)
| [], _, [], bs => bs
| α :: αs, βs, a::as, bs => List.cons_append α αs βs ▸ cons a (HList.append as bs)

protected theorem nil_append {βs : List (Sort _)} (bs : HList βs) : HList.append [] bs = bs := rfl

protected theorem cons_append {α : Sort _} {αs βs : List (Sort _)} (a : α) (as : HList αs) (bs : HList βs) : HList.append (a :: as) bs = a :: HList.append as bs := rfl

protected theorem append_nil {αs : List (Sort _)} (as : HList αs) : HList.append as [] ≅ as := by
  induction as with
  | nil => rw [HList.nil_append]
  | cons _ _ ih =>
    rw [HList.cons_append]
    apply HList.cons_hcongr
    · reflexivity
    · rw [List.append_nil]
    · reflexivity using (.≅.)
    · exact ih

protected theorem append_assoc {αs βs γs : List (Sort _)} (as : HList αs) (bs : HList βs) (cs : HList γs) : HList.append (HList.append as bs) cs ≅ HList.append as (HList.append bs cs) := by
  induction as with
  | nil => rw [HList.nil_append, HList.nil_append]
  | cons _ _ ih =>
    rw [HList.cons_append, HList.cons_append]
    apply HList.cons_hcongr
    · reflexivity
    · rw [List.append_assoc]
    · reflexivity using (.≅.)
    · exact ih

protected def mk : {αs : List (Sort _)} → ((i : Index αs) → i.val) → HList αs
| [], _ => []
| _::_, v => v .head :: HList.mk λ i => v (.tail i)

protected def eval : {αs : List (Sort _)} → HList αs → (i : Index αs) → i.val
| _::_, a::_, .head => a
| _::_, _::as, .tail i => HList.eval as i

def equiv (αs : List (Sort _)) : Equiv (HList αs) ((i : Index αs) → i.val) where
  fwd := HList.eval
  rev := HList.mk
  spec := by
    intros as f
    constr
    · intro h
      cases h
      induction as with
      | nil => rfl
      | cons a as H => clean unfold HList.mk HList.eval; rw [H]
    · intro h
      cases h
      funext i
      induction i with
      | head => rfl
      | tail i H => clean unfold HList.mk HList.eval; rw [H]

end HList


/-
Copyright (c) 2018 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import .basic

open prf

variable {σ : nat}

namespace prf

/- identity implication -/

lemma id {p : form σ} {Γ : ctx σ} :
  Γ ⊢ₛ₅ p ⊃ p :=
mp (mp (@pl2 σ Γ p (p ⊃ p) p) pl1) pl1

/- deduction metatheorem -/

theorem deduction {Γ : ctx σ} {p q : form σ} :
  (Γ ⸴ p ⊢ₛ₅ q) → (Γ ⊢ₛ₅ p ⊃ q) :=
begin
  generalize eq : (Γ ⸴ p) = Γ',
  intro h,
  induction h; subst eq,
  { repeat {cases h_h},
    exact id,
    { exact mp pl1 (ax h_h) } },
  { exact mp pl1 pl1 },
  { exact mp pl1 pl2 },
  { exact mp pl1 pl3 },
  { apply mp,
    { exact (mp pl2 (h_ih_hpq rfl)) },
    { exact h_ih_hp rfl } },
  { exact mp pl1 k },
  { exact mp pl1 t },
  { exact mp pl1 s4 },
  { exact mp pl1 b },
  { exact mp pl1 (nec h_h) }
end

/- structural rules -/

lemma sub_weak {Γ Δ : ctx σ} {p : form σ} :
  (Δ ⊢ₛ₅ p) → (Δ ⊆ Γ) → (Γ ⊢ₛ₅ p) :=
begin
  intros h s,
  induction h,
  { apply ax, exact s h_h },
  { exact pl1 },
  { exact pl2 },
  { exact pl3 },
  { apply mp,
    { exact h_ih_hpq s },
    {exact h_ih_hp s} },
  { exact k },
  { exact t },
  { exact s4 },
  { exact b },
  { exact nec h_h }
end

lemma weak {Γ : ctx σ} {p q : form σ} :
  (Γ ⊢ₛ₅ p) → (Γ ⸴ q ⊢ₛ₅ p) :=
begin
  intro h,
  induction h,
  { apply ax,
    exact (set.mem_insert_of_mem _ h_h) },
  { exact pl1 },
  { exact pl2 },
  { exact pl3 },
  { apply mp,
    { exact h_ih_hpq },
    { exact h_ih_hp } },
  { exact k },
  { exact t },
  { exact s4 },
  { exact b },
  { exact nec h_h }
end

lemma contr {Γ : ctx σ} {p q : form σ} :
  (Γ ⸴ p ⸴ p ⊢ₛ₅ q) → (Γ ⸴ p ⊢ₛ₅ q) :=
begin
  generalize eq : (Γ ⸴ p ⸴ p) = Γ',
  intro h,
  induction h; subst eq,
  { apply ax,
    cases set.eq_or_mem_of_mem_insert h_h,
    { rw h, apply set.mem_insert},
    { exact h } },
  { exact pl1 },
  { exact pl2 },
  { exact pl3 },
  { apply mp,
    { exact h_ih_hpq rfl },
    { exact h_ih_hp rfl } },
  { exact k },
  { exact t },
  { exact s4 },
  { exact b },
  { exact nec h_h }
end

lemma exg {p q r : form σ} {Γ : ctx σ} :
  (Γ ⸴ p ⸴ q ⊢ₛ₅ r) → (Γ ⸴ q ⸴ p ⊢ₛ₅ r) :=
begin
  generalize eq : (Γ ⸴ p ⸴ q) = Γ',
  intro h,
  induction h; subst eq,
  { apply ax,
    cases set.eq_or_mem_of_mem_insert h_h,
    { rw h, apply set.mem_insert_of_mem _ _,
      apply set.mem_insert _ _ },
      { cases set.eq_or_mem_of_mem_insert h with h' h',
        { rw h', apply set.mem_insert _ _ },
        { apply set.mem_insert_of_mem _ _,
          apply set.mem_insert_of_mem _ _,
          exact h' } } },
  { exact pl1 },
  { exact pl2 },
  { exact pl3 },
  { apply mp,
    { exact h_ih_hpq rfl },
    { exact h_ih_hp rfl } },
  { exact k },
  { exact t },
  { exact s4 },
  { exact b },
  { exact nec h_h }
end

/- subcontext operations -/

lemma subctx_ax {Γ Δ : ctx σ} {p : form σ} :
   Δ ⊆ Γ → (Δ ⊢ₛ₅ p) → (Γ ⊢ₛ₅ p) :=
begin
  intros s h,
  induction h,
  { apply ax (s h_h) },
  { exact pl1 },
  { exact pl2 },
  { exact pl3 },
  { apply mp,
    { exact h_ih_hpq s },
    { exact h_ih_hp s } },
  { exact k },
  { exact t },
  { exact s4 },
  { exact b },
  { exact nec h_h }
end

lemma subctx_contr {Γ Δ : ctx σ} {p : form σ}:
   Δ ⊆ Γ → (Γ ∪ Δ ⊢ₛ₅ p) → (Γ ⊢ₛ₅ p) :=
begin
  generalize eq : Γ ∪ Δ = Γ',
  intros s h,
  induction h; subst eq,
  { cases h_h,
    { exact ax h_h },
    { exact ax (s h_h) } },
  { exact pl1 },
  { exact pl2 },
  { exact pl3 },
  { apply mp,
    { exact h_ih_hpq rfl },
    { exact h_ih_hp rfl } },
  { exact k },
  { exact t },
  { exact s4 },
  { exact b },
  { exact nec h_h }
end

/- right-hand side basic rules of inference -/

lemma pr {Γ : ctx σ} {p : form σ} :
  Γ ⸴ p ⊢ₛ₅ p :=
by apply ax; apply or.intro_left; simp

lemma pr1 {Γ : ctx σ} {p q : form σ} :
  Γ ⸴ p ⸴ q ⊢ₛ₅ p :=
by apply ax; apply or.intro_right; apply or.intro_left; simp

lemma pr2 {Γ : ctx σ} {p q : form σ} :
  Γ ⸴ p ⸴ q ⊢ₛ₅ q :=
by apply ax; apply or.intro_left; simp

lemma by_mp1 {Γ : ctx σ} {p q : form σ} :
  Γ ⸴ p ⸴ p ⊃ q ⊢ₛ₅ q :=
mp pr2 pr1

lemma by_mp2 {Γ : ctx σ} {p q : form σ} :
  Γ ⸴ p ⊃ q ⸴ p ⊢ₛ₅ q :=
mp pr1 pr2

lemma cut {Γ : ctx σ} {p q r : form σ} :
  (Γ ⊢ₛ₅ p ⊃ q) → (Γ ⊢ₛ₅ q ⊃ r) → (Γ ⊢ₛ₅ p ⊃ r) :=
λ hpq hqr, mp (mp pl2 (mp pl1 hqr)) hpq

lemma conv_deduction {Γ : ctx σ} {p q : form σ} :
  (Γ ⊢ₛ₅ p ⊃ q) → (Γ ⸴ p ⊢ₛ₅ q) :=
λ h, mp (weak h) pr

/- left-hand side basic rules of inference -/

lemma mp_in_ctx_left {Γ : ctx σ} {p q r : form σ} :
  (Γ ⸴ p ⸴ q ⊢ₛ₅ r) → (Γ ⸴ p ⸴ p ⊃ q ⊢ₛ₅ r) :=
begin
  generalize eq : (Γ ⸴ p ⸴ q) = Γ',
  intros h,
  induction h; subst eq,
  { cases h_h,
    { rw h_h,
      exact by_mp1 },
    { cases h_h,
      { rw h_h,
        exact pr1 },
      { apply ax,
        apply set.mem_insert_of_mem _ _,
        apply set.mem_insert_of_mem _ _, exact h_h } } },
    { exact pl1 },
    { exact pl2 },
    { exact pl3 },
    { apply mp,
      { exact h_ih_hpq rfl },
      { exact h_ih_hp rfl } },
    { exact k },
    { exact t },
    { exact s4 },
    { exact b },
    { exact nec h_h }
end

lemma mp_in_ctx_right {Γ : ctx σ} {p q r : form σ} :
  (Γ ⸴ p ⸴ p ⊃ q ⊢ₛ₅ r) → (Γ ⸴ p ⸴ q ⊢ₛ₅ r) :=
begin
  generalize eq : (Γ ⸴ p ⸴ p ⊃ q) = Γ',
  intros h,
  induction h; subst eq,
  { cases h_h,
    { subst h_h,
      exact mp pl1 pr },
    { cases h_h,
      { subst h_h,
        exact pr1 },
      { exact weak (weak (ax h_h)) } } },
    { exact pl1 },
    { exact pl2 },
    { exact pl3 },
    { apply mp,
      { exact h_ih_hpq rfl },
      { exact h_ih_hp rfl } },
    { exact k },
    { exact t },
    { exact s4 },
    { exact b },
    { exact nec h_h }
end

/- basic lemmas -/

lemma contrap {Γ : ctx σ} {p q : form σ} :
  Γ ⊢ₛ₅ ((~q) ⊃ (~p)) ⊃ (p ⊃ q) :=
deduction (deduction (mp (mp pl3 pr1) (mp pl1 pr2) ))

lemma not_impl {Γ : ctx σ} {p q : form σ} :
  Γ ⊢ₛ₅ (p ⊃ q) ⊃ ((~q) ⊃ (~p)) :=
begin
  repeat { apply deduction },
  apply mp,
  { exact pr1 },
    apply mp,
    { apply ax,
      apply set.mem_insert_of_mem,
      apply set.mem_insert_of_mem,
      apply set.mem_insert },
    { exact pr2 }
end

lemma dne {p : form σ} {Γ : ctx σ} :
  Γ ⊢ₛ₅ (~~p) ⊃ p :=
have h : Γ ⊢ₛ₅ (~~p) ⊃ ((~p) ⊃ (~p)) := mp pl1 id,
mp (mp pl2 (cut pl1 pl3)) h

lemma dni {p : form σ} {Γ : ctx σ} :
  Γ ⊢ₛ₅ p ⊃ (~~p) :=
mp contrap dne

lemma lem {p : form σ} {Γ : ctx σ} :
  Γ ⊢ₛ₅ p ∨ ~p :=
mp dni (mp contrap dne)

lemma not_impl_to_and {p q : form σ} {Γ : ctx σ} :
  Γ ⊢ₛ₅ (~(p ⊃ q)) ⊃ (p & (~q)) :=
begin
  repeat {apply deduction},
  apply (mp pr1),
  { apply deduction,
    apply mp,
    { apply dne },
    { exact (mp pr1 pr2) } },
end

lemma and_not_to_not_impl {p q : form σ} {Γ : ctx σ} :
  Γ ⊢ₛ₅ (p & (~q)) ⊃ ~(p ⊃ q) :=
begin
  repeat {apply deduction},
  apply mp,
  { apply pr1 },
  { apply cut,
    { apply pr2 },
    { apply dni } }
end

/- basic modal lemmas (K and B) -/

lemma box_contrap {p q : form σ} :
 · ⊢ₛ₅ (◻(p ⊃ q)) ⊃ (◻((~q) ⊃ ~p)) :=
prf.mp (prf.k) (prf.nec prf.not_impl)

lemma diamond_k {p q : form σ} :
 · ⊢ₛ₅ (◻(p ⊃ q)) ⊃ ((◇p) ⊃ (◇q)) :=
prf.deduction $ prf.mp prf.not_impl
(prf.mp prf.k (prf.mp (prf.weak box_contrap) prf.pr ))

lemma box_dne {p : form σ} :
 · ⊢ₛ₅ (◻~~p) ⊃ (◻p) :=
prf.mp (prf.k) (prf.nec (prf.dne))

lemma box_dni {p : form σ} :
 · ⊢ₛ₅ (◻p) ⊃ (◻~~p) :=
prf.mp (prf.k) (prf.nec (prf.dni))

lemma not_box_dni {p : form σ} :
 · ⊢ₛ₅ (~◻p) ⊃ (~◻~~p) :=
prf.mp prf.not_impl box_dne

lemma not_box_dne {p : form σ} :
 · ⊢ₛ₅ (~◻~~p) ⊃ (~◻p) :=
prf.mp prf.not_impl box_dni

lemma diamond_dne {p : form σ} :
 · ⊢ₛ₅ (◇~~p) ⊃ (◇p) :=
not_box_dne

lemma diamond_dni {p : form σ} :
 · ⊢ₛ₅ (◇p) ⊃ (◇~~p) :=
not_box_dni

lemma contrap_b {p : form σ} :
 · ⊢ₛ₅ (◇◻p) ⊃ p :=
begin
  apply prf.cut,
  show (· ⊢ₛ₅ (◇◻p) ⊃ (~◻~◻~~p)),
    from @prf.mp _ _ (◻(◻p ⊃ ◻(~~p))) _ diamond_k (prf.nec box_dni),
  apply prf.cut,
  show (· ⊢ₛ₅ (~◻~◻~~p) ⊃ ~~p),
    from prf.mp prf.not_impl prf.b,
  apply prf.dne
end

/- notable introduction rules -/

lemma negintro {p q : form σ} {Γ : ctx σ} :
  (Γ ⊢ₛ₅ p ⊃ q) → (Γ ⊢ₛ₅ p ⊃ ~q) → (Γ ⊢ₛ₅ ~p) :=
have h : ∀ q, (Γ ⊢ₛ₅ p ⊃ q) → (Γ ⊢ₛ₅ (~~p) ⊃ q) := λ q h, cut dne h,
  λ hp hnp, mp (mp pl3 (h (~q) hnp)) (h q hp)

lemma ex_falso {Γ : ctx σ} {p : form σ} :
  (Γ ⊢ₛ₅ ⊥) → (Γ ⊢ₛ₅ p) :=
begin
  intro h,
  apply mp,
  { exact dne },
  { apply mp,
    { exact pl1 },
    { exact h } }
end

lemma ex_falso_and {Γ : ctx σ} {p q : form σ} :
  Γ ⊢ₛ₅ (~p) ⊃ (p ⊃ q) :=
begin
  repeat {apply deduction},
  apply ex_falso,
  exact (mp pr1 pr2)
end

lemma ex_falso_pos {Γ : ctx σ} {p q : form σ} :
  Γ ⊢ₛ₅ p ⊃ ((~p) ⊃ q) :=
begin
  repeat {apply deduction},
  apply mp,
  { apply mp,
    { apply ex_falso_and },
    { exact pr2 } },
  { exact pr1 },
end

lemma contr_conseq {Γ : ctx σ} {p r : form σ} :
  Γ ⊢ₛ₅ (p ⊃ r) ⊃ (((~p) ⊃ r) ⊃ r) :=
begin
  repeat {apply deduction},
  apply mp,
  { apply mp,
    { apply pl3, exact p },
    { apply mp,
      { apply not_impl },
      { exact pr1 } } },
  { apply cut,
    { apply mp,
      { apply not_impl,
        exact (~p) },
      { apply pr2 } },
        apply dne }
end

lemma impl_weak {p q r : form σ} {Γ : ctx σ} (h : (Γ ⸴ r ⊢ₛ₅ p) → (Γ ⊢ₛ₅ p)) :
  ((Γ ⊢ₛ₅ p) → (Γ ⊢ₛ₅ q)) → ((Γ ⸴ r ⊢ₛ₅ p) → (Γ ⸴ r ⊢ₛ₅ q)) :=
λ hpq hp, weak (hpq (h hp))

lemma and_intro {Γ : ctx σ} {p q : form σ} :
  (Γ ⊢ₛ₅ p) → (Γ ⊢ₛ₅ q) → (Γ ⊢ₛ₅ (p & q)) :=
begin
  intros hp hq,
  apply deduction,
  apply mp,
    apply mp,
    { apply pr },
    repeat { apply weak, assumption }
end

lemma and_elim_left {p q : form σ} {Γ : ctx σ} :
  (Γ ⸴ (p & q) ⊢ₛ₅ p) :=
begin
  apply mp,
  { apply dne },
  { apply mp,
    { apply mp,
      { apply pl2, exact (p ⊃ (q ⊃ ⊥)) },
      { apply mp,
        { apply pl1 },
        { exact pr } } },
    { exact ex_falso_and } }
end

lemma and_elim_right {p q : form σ} {Γ : ctx σ} :
  (Γ ⸴ (p & q) ⊢ₛ₅ q) :=
begin
  apply mp,
  { apply dne },
  { apply mp,
    { apply mp,
      { apply pl2, exact (p ⊃ (q ⊃ ⊥)) },
      { apply mp,
        { apply pl1 },
        { exact pr } } },
    repeat {apply deduction},
    apply mp,
    { apply ax,
      apply set.mem_insert_of_mem,
      apply set.mem_insert_of_mem,
      apply set.mem_insert },
    { exact pr2 } }
end

lemma or_intro_left {Γ : ctx σ} {p q r : form σ} :
  (Γ ⊢ₛ₅ p) → (Γ ⊢ₛ₅ (p ∨ q)) :=
begin
  intros hp, simp,
  apply mp,
  { apply dni },
  { apply deduction,
    { apply mp,
      { apply mp,
        { apply ex_falso_and },
        { exact pr } },
      { apply weak, assumption } } }
end

lemma or_intro_right {Γ : ctx σ} {p q r : form σ} :
  (Γ ⊢ₛ₅ q) → (Γ ⊢ₛ₅ (p ∨ q)) :=
begin
  intros hp, simp,
  apply mp,
  { apply dni },
  { apply deduction,
    { apply mp,
      { apply dni },
      {apply weak, assumption } } }
end

lemma or_elim {Γ : ctx σ} {p q r : form σ} :
  (Γ ⊢ₛ₅ (p ∨ q)) → (Γ ⊢ₛ₅ p ⊃ r) → (Γ ⊢ₛ₅ q ⊃ r) → (Γ ⊢ₛ₅ r) :=
begin
  intros hpq hpr hqr,
  apply mp,
    { apply mp,
      { apply contr_conseq, exact p },
      { assumption } },
    { apply cut,
      { apply mp,
        { apply dne },
        { assumption } },
      { apply cut,
        exact dne,
        assumption } }
end

lemma detach_pos {Γ : ctx σ} {p q : form σ} :
  (Γ ⸴ p ⊢ₛ₅ q) → (Γ ⸴ ~p ⊢ₛ₅ q) → (Γ ⊢ₛ₅ q) :=
begin
  intros hpq hnpq,
  apply or_elim,
  { apply lem },
  repeat {apply deduction, assumption}
end

lemma detach_neg {Γ : ctx σ} {p q : form σ} :
  (Γ ⸴ ~p ⊢ₛ₅ q) → (Γ ⸴ p ⊢ₛ₅ q) → (Γ ⊢ₛ₅ q) :=
begin
  intros hpq hnpq,
  apply or_elim,
  { apply lem },
  { apply deduction, exact hnpq },
  { apply deduction, assumption }
end

end prf


import lambda_calculus.utlc.basic
import lambda_calculus.utlc.identities
import lambda_calculus.utlc.reduction
import lambda_calculus.utlc.beta.basic
import lambda_calculus.utlc.beta.church_rosser
import lambda_calculus.utlc.eta.basic
import lambda_calculus.utlc.eta.normal
import lambda_calculus.utlc.eta.church_rosser
import lambda_calculus.utlc.beta_eta.basic
import logic.relation

namespace lambda_calculus
namespace utlc
namespace βη

local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

theorem βη_diamond_step {a b c: utlc}:
   a →β b → a →η c →
   ∃ x, b ↠η x ∧ (c = x ∨ c →β x) :=
begin
  induction a generalizing b c;
  simp;
  intros hab hac,
  { rcases β.lambda_step_exists hab with ⟨b₁, hb₁, hab⟩,
    cases η.lambda_step_cases' hac with hac hac;
    rcases hac with ⟨c₁, hc₁, hac⟩;
     rw [hb₁, hc₁],
    { rcases a_ih hab hac with ⟨x, hbx, hcx⟩,
      use Λ x,
      refine ⟨ η.lambda_reduction_lambda hbx, _ ⟩,
      simp [hcx] },
    rw [hac] at hab,
    obtain hab|hab|hab := β.dot_step_cases hab;
    rcases hab with ⟨b₂, hb₂, hab⟩,
    {
      cases shift_of_uses_zero (show b₂.uses 1 = 0, begin
        rw [← lambda_uses, ← hab],
        exact shift_uses_self _ _,
      end) with b₃ hb₃,
      rw [hb₃, ← lambda_shift, shift_inj_iff] at hab,
      rw [hab, hb₂, hb₃, shift_succ_substitiution_down],
      use Λ b₃,
      exact ⟨ by refl, or.inl rfl⟩ },
    { rw [hb₂],
      cases shift_of_uses_zero (β.uses_zero_step hab (shift_uses_self _ _)) with b₃ hb₃,
      rw [hb₃],
      rw [hb₃] at hab,
      use b₃,
      split,
      apply relation.refl_trans_gen.single,
      apply η.lambda_step_head,
      right,
      apply (shift_reduction_step_shift_iff _).mp,
      apply hab,
      apply β.shift_head_step_shift },
    { simp at hab, contradiction } },
  { obtain hab|hab|hab := β.dot_step_cases hab;
    cases η.dot_step_cases' hac with hac hac;
    rcases hab with ⟨x, hax, hxb⟩;
    rcases hac with ⟨y, z, hza, hcyz, hay⟩,
    { rw [hax, ←hza, hcyz],
      rw [hxb] at hay,
      cases η.lambda_step_cases' hay with hay hay;
      rcases hay with ⟨y₁, hy₁, hxy₁⟩,
      { rw [hy₁],
        use y₁[0:=z],
        split,
        apply substitution_reduction_step_left,
        apply η.head_step_substitution,
        apply hxy₁,
        right,
        apply β.lambda_dot_step_substitution },
      { simp [hxy₁, hy₁],
        use y₁·z,
        exact ⟨by refl, or.inl rfl⟩ } },
    { rw [hax, hcyz, hza, hxb],
      use x[0:=z],
      split,
      apply substitution_reduction_step_right,
      apply η.shift_head_step_shift,
      apply hay,
      right,
      apply β.lambda_dot_step_substitution, },
    { rw [hax, ← hza, hcyz],
      rcases a_ih_f hxb hay with ⟨m, hxm, hym⟩,
      use m·z,
      split,
      apply η.dot_reduction_dot_left hxm,
      cases hym,
      { simp [hym] },
      right,
      apply β.dot_step_dot_left hym },
    { rw [hax, hcyz, hza],
      use x·z,
      split,
      apply η.dot_reduction_dot_right,
      apply relation.refl_trans_gen.single hay,
      right,
      apply β.dot_step_dot_left hxb },
    { rw [hax, hcyz, hza],
      use y·x,
      split,
      apply η.dot_reduction_dot_left,
      apply relation.refl_trans_gen.single hay,
      right,
      apply β.dot_step_dot_right hxb },
    { rw [hax, ← hza, hcyz],
      rcases a_ih_g hxb hay with ⟨m, hxm, hym⟩,
      use y·m,
      split,
      apply η.dot_reduction_dot_right hxm,
      cases hym,
      { simp [hym] },
      right,
      apply β.dot_step_dot_right hym },
  }
end

theorem βη_diamond_step_reduction {a b c: utlc}: a →β b → a ↠η c →
  ∃ x, b ↠η x ∧ c ↠β x :=
begin
  intros hab hac,
  induction hac using relation.refl_trans_gen.head_induction_on with a f haf hfc ih generalizing b hab,
  exact ⟨b, by refl, relation.refl_trans_gen.single hab ⟩,
  rcases βη_diamond_step hab haf with ⟨g, hbg, hfg⟩,
  cases hfg,
  { refine ⟨ c, trans hbg _, by refl ⟩,
    rw [← hfg],
    exact hfc },
  rcases ih hfg with ⟨x, hgx, hcx⟩,
  refine ⟨x, trans hbg hgx, hcx⟩,
end

theorem βη_diamond_reduction {a b c: utlc}: a ↠β b → a ↠η c →
  ∃ x, b ↠η x ∧ c ↠β x :=
begin
  intros hab hac,
  induction hab using relation.refl_trans_gen.head_induction_on with a f haf hfb ih generalizing c hac,
  exact ⟨c, hac, by refl⟩,
  rcases βη_diamond_step_reduction haf hac with ⟨g, hfg, hcg⟩,
  rcases ih hfg with ⟨x, hbx, hgx⟩,
  refine ⟨x, hbx, trans hcg hgx⟩,
end

theorem β_diamond_reduction {a b c: utlc}: a ↠β b → a ↠βη c →
  ∃ x, b ↠βη x ∧ c ↠β x :=
begin
  intros hab hac,
  induction hac using relation.refl_trans_gen.head_induction_on with a f haf hfc ih generalizing b hab,
  exact ⟨b, by refl, hab⟩,
  rw [step_iff] at haf,
  cases haf,
  { rcases β.church_rosser hab (relation.refl_trans_gen.single haf) with ⟨x, hbx, hfx⟩,
    rcases ih hfx with ⟨y, hxy, hcy⟩,
    refine ⟨y, trans (reduction_of_beta hbx) hxy, hcy⟩ },
  { rcases βη_diamond_reduction hab (relation.refl_trans_gen.single haf) with ⟨x, hbx, hfx⟩,
    rcases ih hfx with ⟨y, hxy, hcy⟩,
    refine ⟨y, trans (reduction_of_eta hbx) hxy, hcy⟩ },
end

theorem η_diamond_reduction {a b c: utlc}: a ↠η b → a ↠βη c →
  ∃ x, b ↠βη x ∧ c ↠η x :=
begin
  intros hab hac,
  induction hac using relation.refl_trans_gen.head_induction_on with a f haf hfc ih generalizing b hab,
  exact ⟨b, by refl, hab⟩,
  rw [step_iff] at haf,
  cases haf,
  { rcases βη_diamond_reduction (relation.refl_trans_gen.single haf) hab with ⟨x, hfx, hbx⟩,
    rcases ih hfx with ⟨y, hxy, hcy⟩,
    refine ⟨y, trans (reduction_of_beta hbx) hxy, hcy⟩ },
  { rcases η.church_rosser hab (relation.refl_trans_gen.single haf) with ⟨x, hbx, hfx⟩,
    rcases ih hfx with ⟨y, hxy, hcy⟩,
    refine ⟨y, trans (reduction_of_eta hbx) hxy, hcy⟩ }
end

theorem church_rosser {a b c : utlc}:
  a ↠βη b → a ↠βη c → b ≡βη c :=
begin
  intros hab hac,
  induction hab using relation.refl_trans_gen.head_induction_on with a f haf hfb ih generalizing c hac,
  { use c,
    exact ⟨ hac, by refl⟩, },
  rw [step_iff] at haf,
  cases haf,
  { rcases β_diamond_reduction (relation.refl_trans_gen.single haf) hac with ⟨x, hfx, hcx⟩,
    rcases ih hfx with ⟨y, hby, hxy⟩,
    refine ⟨y, hby, trans (reduction_of_beta hcx) hxy ⟩ },
  { rcases η_diamond_reduction (relation.refl_trans_gen.single haf) hac with ⟨x, hfx, hcx⟩,
    rcases ih hfx with ⟨y, hby, hxy⟩,
    refine ⟨y, hby, trans (reduction_of_eta hcx) hxy ⟩ }
end

@[refl]
theorem equiv_refl (f : utlc): f ≡βη f :=
  ⟨f, relation.refl_trans_gen.refl, relation.refl_trans_gen.refl⟩

@[symm]
theorem equiv_symm {a b: utlc}: a ≡βη b → b ≡βη a :=
begin
  apply relation.symmetric_join
end

@[trans]
theorem equiv_trans {a b c : utlc}: a ≡βη b → b ≡βη c → a ≡βη c :=
begin
  apply relation.transitive_join,
  apply relation.refl_trans_gen.trans,
  apply @church_rosser,
end

theorem reduced_reduction_inj {f g: utlc}: reduced f → f ↠βη g → f = g :=
begin
  intros hf p,
  induction p with x y hx hy fx,
  { refl },
  rw [←fx] at *,
  exfalso,
  apply reduced_iff_no_reduction.mp hf _ hy
end

theorem reduced_equiv_inj {f g: utlc}: reduced f → reduced g → f ≡βη g → f = g :=
begin
  intros hf hg p,
  cases p with x p,
  rw [reduced_reduction_inj hf p.left, reduced_reduction_inj hg p.right]
end

end βη
end utlc
end lambda_calculus


lemma mul_left_comm (a b c : mynat) : a * (b * c) = b * (a * c) :=
begin
induction b with k Pk,
repeat { rw zero_mul },
rw mul_zero,
refl,
repeat { rw succ_mul },
rw mul_add,
rw Pk,
refl,

end


/- Provides simplification lemmas for monad laws. -/
universe variables u

@[simp]
lemma pure_bind {m : Type u → Type u} [hm : monad m] {α β : Type u} (x : α) (f : α → m β) : pure x >>= f = f x :=
  monad.pure_bind x f

lemma bind_assoc {m : Type u → Type u} [hm : monad m] {α β γ : Type u} (x : m α) (f : α → m β) (g : β → m γ) :
  x >>= f >>= g = x >>= λ x, f x >>= g := monad.bind_assoc x f g

lemma when_false_unit {m : Type → Type} [monad m] {c : Prop} [h : decidable c]
  {t : m unit} (H : ¬ c) : when c t = pure ()
:= begin
unfold when, rw (if_neg H)
end

lemma when_false {m : Type → Type} [monad m] {c : Prop} [h : decidable c]
  {t : m unit} {A : Type} {f : m A} (H : ¬ c) : when c t >>= (λ _, f) = f
:= begin
rw (when_false_unit H), rw pure_bind
end

lemma when_false_trans {m : Type → Type} [monad m] {c : Prop} [h : decidable c]
  {t : m unit} {A : Type} {f g : m A} (H : ¬ c)
  (H' : f = g) : when c t >>= (λ _, f) = g
:= begin
rw (when_false H), assumption
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Mario Carneiro, Reid Barton, Andrew Yang
-/
import category_theory.limits.kan_extension
import category_theory.adjunction
import topology.category.Top.opens

/-!
# Presheaves on a topological space

We define `presheaf C X` simply as `(opens X)ᵒᵖ ⥤ C`,
and inherit the category structure with natural transformations as morphisms.

We define
* `pushforward_obj {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) : Y.presheaf C`
with notation `f _* ℱ`
and for `ℱ : X.presheaf C` provide the natural isomorphisms
* `pushforward.id : (𝟙 X) _* ℱ ≅ ℱ`
* `pushforward.comp : (f ≫ g) _* ℱ ≅ g _* (f _* ℱ)`
along with their `@[simp]` lemmas.

We also define the functors `pushforward` and `pullback` between the categories
`X.presheaf C` and `Y.presheaf C`, and provide their adjunction at
`pushforward_pullback_adjunction`.
-/

universes w v u

open category_theory
open topological_space
open opposite

variables (C : Type u) [category.{v} C]

namespace Top

/-- The category of `C`-valued presheaves on a (bundled) topological space `X`. -/
@[derive category, nolint has_inhabited_instance]
def presheaf (X : Top.{w}) := (opens X)ᵒᵖ ⥤ C

variables {C}

namespace presheaf

/-- Pushforward a presheaf on `X` along a continuous map `f : X ⟶ Y`, obtaining a presheaf
on `Y`. -/
def pushforward_obj {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) : Y.presheaf C :=
(opens.map f).op ⋙ ℱ

infix ` _* `: 80 := pushforward_obj

@[simp] lemma pushforward_obj_obj {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) (U : (opens Y)ᵒᵖ) :
  (f _* ℱ).obj U = ℱ.obj ((opens.map f).op.obj U) := rfl

@[simp] lemma pushforward_obj_map {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C)
  {U V : (opens Y)ᵒᵖ} (i : U ⟶ V) :
  (f _* ℱ).map i = ℱ.map ((opens.map f).op.map i) := rfl

/--
An equality of continuous maps induces a natural isomorphism between the pushforwards of a presheaf
along those maps.
-/
def pushforward_eq {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) :
  f _* ℱ ≅ g _* ℱ :=
iso_whisker_right (nat_iso.op (opens.map_iso f g h).symm) ℱ

lemma pushforward_eq' {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) :
  f _* ℱ = g _* ℱ :=
by rw h

@[simp] lemma pushforward_eq_hom_app
  {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) (U) :
  (pushforward_eq h ℱ).hom.app U =
    ℱ.map (begin dsimp [functor.op], apply quiver.hom.op, apply eq_to_hom, rw h, end) :=
by simp [pushforward_eq]

lemma pushforward_eq'_hom_app
  {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) (U) :
  nat_trans.app (eq_to_hom (pushforward_eq' h ℱ)) U = ℱ.map (eq_to_hom (by rw h)) :=
by simpa [eq_to_hom_map]

@[simp]
lemma pushforward_eq_rfl {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) (U) :
  (pushforward_eq (rfl : f = f) ℱ).hom.app (op U) = 𝟙 _ :=
begin
  dsimp [pushforward_eq],
  simp,
end

lemma pushforward_eq_eq {X Y : Top.{w}} {f g : X ⟶ Y} (h₁ h₂ : f = g) (ℱ : X.presheaf C) :
  ℱ.pushforward_eq h₁ = ℱ.pushforward_eq h₂ :=
rfl

namespace pushforward
variables {X : Top.{w}} (ℱ : X.presheaf C)

/-- The natural isomorphism between the pushforward of a presheaf along the identity continuous map
and the original presheaf. -/
def id : (𝟙 X) _* ℱ ≅ ℱ :=
(iso_whisker_right (nat_iso.op (opens.map_id X).symm) ℱ) ≪≫ functor.left_unitor _

lemma id_eq : (𝟙 X) _* ℱ = ℱ :=
by { unfold pushforward_obj, rw opens.map_id_eq, erw functor.id_comp }

@[simp] lemma id_hom_app' (U) (p) :
  (id ℱ).hom.app (op ⟨U, p⟩) = ℱ.map (𝟙 (op ⟨U, p⟩)) :=
by { dsimp [id], simp, }

local attribute [tidy] tactic.op_induction'

@[simp, priority 990] lemma id_hom_app (U) :
  (id ℱ).hom.app U = ℱ.map (eq_to_hom (opens.op_map_id_obj U)) := by tidy

@[simp] lemma id_inv_app' (U) (p) : (id ℱ).inv.app (op ⟨U, p⟩) = ℱ.map (𝟙 (op ⟨U, p⟩)) :=
by { dsimp [id], simp, }

/-- The natural isomorphism between
the pushforward of a presheaf along the composition of two continuous maps and
the corresponding pushforward of a pushforward. -/
def comp {Y Z : Top.{w}} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g) _* ℱ ≅ g _* (f _* ℱ) :=
iso_whisker_right (nat_iso.op (opens.map_comp f g).symm) ℱ

lemma comp_eq {Y Z : Top.{w}} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g) _* ℱ = g _* (f _* ℱ) :=
rfl

@[simp] lemma comp_hom_app {Y Z : Top.{w}} (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (comp ℱ f g).hom.app U = 𝟙 _ :=
by { dsimp [comp], tidy, }

@[simp] lemma comp_inv_app {Y Z : Top.{w}} (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (comp ℱ f g).inv.app U = 𝟙 _ :=
by { dsimp [comp], tidy, }

end pushforward

/--
A morphism of presheaves gives rise to a morphisms of the pushforwards of those presheaves.
-/
@[simps]
def pushforward_map {X Y : Top.{w}} (f : X ⟶ Y) {ℱ 𝒢 : X.presheaf C} (α : ℱ ⟶ 𝒢) :
  f _* ℱ ⟶ f _* 𝒢 :=
{ app := λ U, α.app _,
  naturality' := λ U V i, by { erw α.naturality, refl, } }

open category_theory.limits
section pullback
variable [has_colimits C]
noncomputable theory

/--
Pullback a presheaf on `Y` along a continuous map `f : X ⟶ Y`, obtaining a presheaf on `X`.

This is defined in terms of left Kan extensions, which is just a fancy way of saying
"take the colimits over the open sets whose preimage contains U".
-/
@[simps]
def pullback_obj {X Y : Top.{v}} (f : X ⟶ Y) (ℱ : Y.presheaf C) : X.presheaf C :=
(Lan (opens.map f).op).obj ℱ

/-- Pulling back along continuous maps is functorial. -/
def pullback_map {X Y : Top.{v}} (f : X ⟶ Y) {ℱ 𝒢 : Y.presheaf C} (α : ℱ ⟶ 𝒢) :
  pullback_obj f ℱ ⟶ pullback_obj f 𝒢 :=
(Lan (opens.map f).op).map α

/-- If `f '' U` is open, then `f⁻¹ℱ U ≅ ℱ (f '' U)`.  -/
@[simps]
def pullback_obj_obj_of_image_open {X Y : Top.{v}} (f : X ⟶ Y) (ℱ : Y.presheaf C) (U : opens X)
  (H : is_open (f '' U)) : (pullback_obj f ℱ).obj (op U) ≅ ℱ.obj (op ⟨_, H⟩) :=
begin
  let x : costructured_arrow (opens.map f).op (op U) :=
  { left := op ⟨f '' U, H⟩,
    hom := ((@hom_of_le _ _ _ ((opens.map f).obj ⟨_, H⟩) (set.image_preimage.le_u_l _)).op :
    op ((opens.map f).obj (⟨⇑f '' ↑U, H⟩)) ⟶ op U) },
  have hx : is_terminal x :=
  { lift := λ s,
    begin
      fapply costructured_arrow.hom_mk,
      change op (unop _) ⟶ op (⟨_, H⟩ : opens _),
      refine (hom_of_le _).op,
      exact (set.image_subset f s.X.hom.unop.le).trans (set.image_preimage.l_u_le ↑(unop s.X.left)),
      simp
    end },
  exact is_colimit.cocone_point_unique_up_to_iso
    (colimit.is_colimit _)
    (colimit_of_diagram_terminal hx _),
end

namespace pullback
variables {X Y : Top.{v}} (ℱ : Y.presheaf C)

/-- The pullback along the identity is isomorphic to the original presheaf. -/
def id : pullback_obj (𝟙 _) ℱ ≅ ℱ :=
nat_iso.of_components
  (λ U, pullback_obj_obj_of_image_open (𝟙 _) ℱ (unop U) (by simpa using U.unop.2) ≪≫
    ℱ.map_iso (eq_to_iso (by simp)))
  (λ U V i,
  begin
      ext, simp,
      erw colimit.pre_desc_assoc,
      erw colimit.ι_desc_assoc,
      erw colimit.ι_desc_assoc,
      dsimp, simp only [←ℱ.map_comp], congr
  end)

lemma id_inv_app (U : opens Y) :
  (id ℱ).inv.app (op U) = colimit.ι (Lan.diagram (opens.map (𝟙 Y)).op ℱ (op U))
    (@costructured_arrow.mk _ _ _ _ _ (op U) _ (eq_to_hom (by simp))) :=
begin
  dsimp[id], simp, dsimp[colimit_of_diagram_terminal],
  delta Lan.diagram,
  refine eq.trans _ (category.id_comp _),
  rw ← ℱ.map_id,
  congr,
  any_goals { apply subsingleton.helim },
  all_goals { simp }
end

end pullback
end pullback
variable (C)

/--
The pushforward functor.
-/
def pushforward {X Y : Top.{v}} (f : X ⟶ Y) : X.presheaf C ⥤ Y.presheaf C :=
{ obj := pushforward_obj f,
  map := @pushforward_map _ _ X Y f }

@[simp]
lemma pushforward_map_app' {X Y : Top.{v}} (f : X ⟶ Y)
  {ℱ 𝒢 : X.presheaf C} (α : ℱ ⟶ 𝒢) {U : (opens Y)ᵒᵖ} :
  ((pushforward C f).map α).app U = α.app (op $ (opens.map f).obj U.unop) := rfl

lemma id_pushforward {X : Top.{v}} : pushforward C (𝟙 X) = 𝟭 (X.presheaf C) :=
begin
  apply category_theory.functor.ext,
  { intros,
    ext U,
    have h := f.congr, erw h (opens.op_map_id_obj U),
    simpa [eq_to_hom_map], },
  { intros, apply pushforward.id_eq },
end

section iso

/-- A homeomorphism of spaces gives an equivalence of categories of presheaves. -/
@[simps] def presheaf_equiv_of_iso {X Y : Top} (H : X ≅ Y) :
  X.presheaf C ≌ Y.presheaf C :=
equivalence.congr_left (opens.map_map_iso H).symm.op

variable {C}

/--
If `H : X ≅ Y` is a homeomorphism,
then given an `H _* ℱ ⟶ 𝒢`, we may obtain an `ℱ ⟶ H ⁻¹ _* 𝒢`.
-/
def to_pushforward_of_iso {X Y : Top} (H : X ≅ Y) {ℱ : X.presheaf C} {𝒢 : Y.presheaf C}
  (α : H.hom _* ℱ ⟶ 𝒢) : ℱ ⟶ H.inv _* 𝒢 :=
(presheaf_equiv_of_iso _ H).to_adjunction.hom_equiv ℱ 𝒢 α

@[simp]
lemma to_pushforward_of_iso_app {X Y : Top} (H₁ : X ≅ Y) {ℱ : X.presheaf C} {𝒢 : Y.presheaf C}
  (H₂ : H₁.hom _* ℱ ⟶ 𝒢) (U : (opens X)ᵒᵖ) :
(to_pushforward_of_iso H₁ H₂).app U =
  ℱ.map (eq_to_hom (by simp [opens.map, set.preimage_preimage])) ≫
  H₂.app (op ((opens.map H₁.inv).obj (unop U))) :=
begin
  delta to_pushforward_of_iso,
  simp only [equiv.to_fun_as_coe, nat_trans.comp_app, equivalence.equivalence_mk'_unit,
    eq_to_hom_map, eq_to_hom_op, eq_to_hom_trans, presheaf_equiv_of_iso_unit_iso_hom_app_app,
    equivalence.to_adjunction, equivalence.equivalence_mk'_counit,
    presheaf_equiv_of_iso_inverse_map_app, adjunction.mk_of_unit_counit_hom_equiv_apply],
  congr,
end

/--
If `H : X ≅ Y` is a homeomorphism,
then given an `H _* ℱ ⟶ 𝒢`, we may obtain an `ℱ ⟶ H ⁻¹ _* 𝒢`.
-/
def pushforward_to_of_iso {X Y : Top} (H₁ : X ≅ Y) {ℱ : Y.presheaf C} {𝒢 : X.presheaf C}
  (H₂ : ℱ ⟶ H₁.hom _* 𝒢) : H₁.inv _* ℱ ⟶ 𝒢 :=
((presheaf_equiv_of_iso _ H₁.symm).to_adjunction.hom_equiv ℱ 𝒢).symm H₂

@[simp]
lemma pushforward_to_of_iso_app {X Y : Top} (H₁ : X ≅ Y) {ℱ : Y.presheaf C} {𝒢 : X.presheaf C}
  (H₂ : ℱ ⟶ H₁.hom _* 𝒢) (U : (opens X)ᵒᵖ) :
(pushforward_to_of_iso H₁ H₂).app U =
  H₂.app (op ((opens.map H₁.inv).obj (unop U))) ≫
  𝒢.map (eq_to_hom (by simp [opens.map, set.preimage_preimage])) :=
by simpa [pushforward_to_of_iso, equivalence.to_adjunction]

end iso

variables (C) [has_colimits C]

/-- Pullback a presheaf on `Y` along a continuous map `f : X ⟶ Y`, obtaining a presheaf
on `X`. -/
@[simps map_app]
def pullback {X Y : Top.{v}} (f : X ⟶ Y) : Y.presheaf C ⥤ X.presheaf C := Lan (opens.map f).op

@[simp] lemma pullback_obj_eq_pullback_obj {C} [category C] [has_colimits C] {X Y : Top.{w}}
  (f : X ⟶ Y) (ℱ : Y.presheaf C) : (pullback C f).obj ℱ = pullback_obj f ℱ := rfl

/-- The pullback and pushforward along a continuous map are adjoint to each other. -/
@[simps unit_app_app counit_app_app]
def pushforward_pullback_adjunction {X Y : Top.{v}} (f : X ⟶ Y) :
  pullback C f ⊣ pushforward C f := Lan.adjunction _ _

/-- Pulling back along a homeomorphism is the same as pushing forward along its inverse. -/
def pullback_hom_iso_pushforward_inv {X Y : Top.{v}} (H : X ≅ Y) :
  pullback C H.hom ≅ pushforward C H.inv :=
adjunction.left_adjoint_uniq
  (pushforward_pullback_adjunction C H.hom)
  (presheaf_equiv_of_iso C H.symm).to_adjunction

/-- Pulling back along the inverse of a homeomorphism is the same as pushing forward along it. -/
def pullback_inv_iso_pushforward_hom {X Y : Top.{v}} (H : X ≅ Y) :
  pullback C H.inv ≅ pushforward C H.hom :=
adjunction.left_adjoint_uniq
  (pushforward_pullback_adjunction C H.inv)
  (presheaf_equiv_of_iso C H).to_adjunction

end presheaf
end Top