import fol
import Rings.Notation
import Rings.ToMathlib
import Rings.ToMathlib.fol
import Rings.ToMathlib.dvector
import Rings.ToMathlib.fin
import Rings.ToMathlib.list
import Rings.ToMathlib.nat
import data.polynomial.eval
import data.mv_polynomial

universe u

local infix ` ≃ `:64 := fol.bounded_preformula.bd_equal

namespace Rings

local notation h :: t  := dvector.cons h t
local notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l

/-- The constant symbols in RingSignature -/
inductive ring_consts : Type*
| zero : ring_consts
| one : ring_consts

/-- The unary function symbols in RingSignature-/
inductive ring_unaries : Type*
| neg : ring_unaries

/-- The binary function symbols in RingSignature-/
inductive ring_binaries : Type*
| add : ring_binaries
| mul : ring_binaries

/-- All function symbols in RingSignature-/
def ring_funcs : ℕ → Type*
| 0 := ring_consts
| 1 := ring_unaries
| 2 := ring_binaries
| (n + 3) := pempty

instance : inhabited ring_consts := ⟨ ring_consts.zero ⟩
instance : inhabited ring_unaries := ⟨ ring_unaries.neg ⟩
instance : inhabited ring_binaries := ⟨ ring_binaries.add ⟩

/-- The type bool is equivalent to the type of constant symbols -/
def bool_equiv_ring_consts : equiv bool ring_consts :=
{ to_fun := λ x, match x with | ff := ring_consts.zero | tt := ring_consts.one end,
  inv_fun := λ c, match c with | ring_consts.zero := ff | ring_consts.one := tt end,
  left_inv := λ x, match x with | ff := rfl | tt := rfl end,
  right_inv := λ c, match c with | ring_consts.zero := rfl | ring_consts.one := rfl end }

open fol

/-- The language of rings -/
def ring_signature : Language :=
(Language.mk) (ring_funcs) (λ n, pempty)

/-- The language of rings is empty -/
instance : Language.is_algebraic ring_signature :=
{ empty_relations := λ _, pempty.elim }

/-- To show two ring structures are equal it suffices that they are
    equal on carrier sets and heterogeneously equal on fun_map -/
lemma Structure.ext {A B : Structure ring_signature} :
  A.carrier = B.carrier → A.fun_map == B.fun_map → A = B :=
begin
  obtain ⟨ A , A_fun , A_rel ⟩ := A, obtain ⟨ B , B_fun , B_rel ⟩ := B,
  simp only,
  intros hcarrier hfun, subst hcarrier,
  refine ⟨ rfl, hfun, _ ⟩,
  rw heq_iff_eq,
  funext _ mem_empty,
  cases mem_empty,
end

/-- Shorter name for bounded_term ring_signature -/
@[reducible] def bounded_ring_term := bounded_term ring_signature

/-- Shorter name for bounded_preterm ring_signature n 0 -/
@[reducible] def bounded_ring_term' (n : ℕ) := bounded_preterm ring_signature n 0

/-- Shorter name for bounded_formula ring_signature -/
@[reducible] def bounded_ring_formula := bounded_formula ring_signature

/-- Shorter name for realize_bounded_term ring_signature -/
@[reducible] def realize_bounded_ring_term := @realize_bounded_term ring_signature

namespace ring_signature

/- The following instances allow us to use symbols 0 1 - + * ^ -/
/- to write terms in the language-/

@[reducible] instance bounded_ring_term_has_zero {n} :
  has_zero (bounded_ring_term n) := ⟨ bd_func ring_consts.zero ⟩
@[reducible] instance bounded_ring_term_has_zero' {n} :
  has_zero (bounded_ring_term' n) := ⟨ bd_func ring_consts.zero ⟩

@[reducible] instance bounded_ring_term_has_one {n} :
  has_one (bounded_ring_term n) := ⟨ bd_func ring_consts.one ⟩
@[reducible] instance bounded_ring_term_has_one' {n} :
  has_one (bounded_ring_term' n) := ⟨ bd_func ring_consts.one ⟩

@[reducible] instance bounded_ring_term_has_neg {n} : has_neg (bounded_ring_term n) :=
⟨ bd_app (bd_func ring_unaries.neg) ⟩
@[reducible] instance bounded_ring_term_has_neg' {n} : has_neg (bounded_ring_term' n) :=
⟨ bd_app (bd_func ring_unaries.neg) ⟩

@[reducible] instance bounded_ring_term_has_add {n} : has_add (bounded_ring_term n) :=
⟨ λ x, bd_app (bd_app (bd_func ring_binaries.add) x) ⟩
@[reducible] instance bounded_ring_term_has_add' {n} : has_add (bounded_ring_term'  n) :=
⟨ λ x, bd_app (bd_app (bd_func ring_binaries.add) x) ⟩

@[reducible] instance bounded_ring_term_has_mul {n} : has_mul (bounded_ring_term n) :=
⟨ λ x, bd_app (bd_app (bd_func ring_binaries.mul) x) ⟩
@[reducible] instance bounded_ring_term_has_mul' {n} : has_mul (bounded_ring_term' n) :=
⟨ λ x, bd_app (bd_app (bd_func ring_binaries.mul) x) ⟩

@[reducible] instance bounded_ring_term_has_pow {n} : has_pow (bounded_ring_term n) ℕ :=
⟨ λ t n, npow_rec n t ⟩

@[simp] lemma pow_zero {n} (t : bounded_ring_term n) : t ^ 0 = 1 := rfl
@[simp] lemma pow_succ {n m} (t : bounded_ring_term m) :
  t ^ (n + 1) = t * t ^ n := rfl

/-
-- variables x0 , x1 in the signature
-- (they are only variables in bounded terms that have up to n + 1, n + 2 variables)
example {n} : bounded_term ring_signature (n + 1) := x_ 0
-- for example {n} : bounded_term ring_signature n := x_ 0 doesn't work
-- since fin n doesn't have an instance of 0 in general (when n = 0)
example {n} : bounded_term ring_signature (n + 2) := x_ 1
-- actually example {n} : bounded_term ring_signature (n + 1) := x_ 1 also works because
-- fin (n + 1) is implemented mod (n + 1), in particular 1 = 0 ∈ fin 1
-- but let's avoid that

-- neg x
example {n} : bounded_ring_term (n + 1) := - (x_ 0)
example {n} : bounded_ring_term (n + 1) := (x_ 0) + 1
example {n} : bounded_ring_term (n + 2):= (- x_ 0) * x_ 1
example {n} : bounded_ring_term (n + 1) := x_ 0 + x_ 0
-/

/-- Part of the definition of ring_term_rec -/
@[simp] def ring_func_rec {n} {C : bounded_term ring_signature n → Sort*}
  (cvar : Π (k : fin n), C (x_ k))
  (c0 : C 0) (c1 : C 1)
  (cneg : Π {t}, C t → C (- t))
  (cadd : Π {s t}, C s → C t → C (s + t)) (cmul : Π {s t}, C s → C t → C (s * t)) :
  Π {l : ℕ} (f : ring_signature.functions l) (ts : dvector (bounded_term ring_signature n) l),
  (Π (t : bounded_ring_term n), dvector.pmem t ts → C t)
  → C (bd_apps (bd_func f) ts)
| 0 (ring_consts.zero) ([]) h := c0
| 0 (ring_consts.one) ([]) h := c1
| 1 (ring_unaries.neg) ([t]) h := cneg (h t (psum.inl rfl))
| 2 (ring_binaries.add) ([s,t]) h := cadd (h s (psum.inl rfl)) (h t (psum.inr (psum.inl rfl)))
| 2 (ring_binaries.mul) ([s,t]) h := cmul (h s (psum.inl rfl)) (h t (psum.inr (psum.inl rfl)))
| (n + 3) f ts h := pempty.elim f

/-- An interface for mapping out of bounded_ring_term n (basically bounded_term.rec) -/
def ring_term_rec {n : ℕ} {C : bounded_ring_term n → Sort*}
  (cvar : Π (k : fin n), C (x_ k))
  (c0 : C 0) (c1 : C 1)
  (cneg : Π {t}, C t → C (- t))
  (cadd : Π {s t}, C s → C t → C (s + t)) (cmul : Π {s t}, C s → C t → C (s * t))
  : Π (t : bounded_ring_term n), C t :=
@bounded_term.rec ring_signature n C
(λ k, cvar k)
(λ l, ring_func_rec cvar c0 c1 @cneg @cadd @cmul)

-- def ring_term_ind {n : ℕ} {C : bounded_ring_term n → Prop}
--   (cvar : Π (k : fin n), C (x_ k))
--   (c0 : C 0) (c1 : C 1)
--   (cneg : Π {t}, C t → C (- t))
--   (cadd : Π {s t}, C s → C t → C (s + t)) (cmul : Π {s t}, C s → C t → C (s * t))
--   : Π (t : bounded_ring_term n), C t :=
-- @bounded_term.rec ring_signature n C
-- (λ k, cvar k)
-- (λ l, ring_func_rec cvar c0 c1 @cneg @cadd @cmul)

/- Sentences for the theory of rings: commutative group under addition -/

/-- Assosiativity of addition -/
def add_assoc : sentence ring_signature :=
  ∀' ∀' ∀' ( (x_ 0 + x_ 1) + x_ 2 ≃ x_ 0 + (x_ 1 + x_ 2) )

/-- Identity for addition -/
def add_id : sentence ring_signature := ∀' ( x_ 0 + 0 ≃ x_ 0 )
-- def add_id : sentence ring_signature := ∀' (   &'0 r+ r0 ≃ &'0   ⊓   r0 r+ &'0 ≃ &'0   )

/-- Inverse for addition -/
def add_inv : sentence ring_signature := ∀' ( - x_ 0 + x_ 0 ≃ 0 )
-- def add_inv : sentence ring_signature := ∀' (  &'0 r+ r- &'0 ≃ r0  ⊓  r- &'0 r+ &'0 ≃ r0  )

/-- Commutativity of addition-/
def add_comm : sentence ring_signature := ∀' ∀' ( x_ 0 + x_ 1 ≃ x_ 1 + x_ 0 )

/- Sentences for theory of rings: commutative monoid under multiplication -/

/-- Associativity of multiplication -/
def mul_assoc : sentence ring_signature :=
∀' ∀' ∀' ( (x_ 0 * x_ 1) * x_ 2 ≃ x_ 0 * (x_ 1 * x_ 2) )

/-- Identity of multiplication -/
def mul_id : sentence ring_signature :=  ∀' ( x_ 0 * 1 ≃ x_ 0 )
-- def mul_id : sentence ring_signature :=  ∀' (   &'0 r× r1 ≃ &'0   )

/-- Commutativity of multiplication -/
def mul_comm : sentence ring_signature := ∀' ∀' ( x_ 0 * x_ 1 ≃ x_ 1 * x_ 0   )

/-- Distributibity -/
def add_mul : sentence ring_signature := ∀' ∀' ∀' ( (x_ 0 + x_ 1) * x_ 2 ≃ x_ 0 * x_ 2 + x_ 1 * x_ 2 )

/-- The theory of rings -/
def ring_theory : Theory ring_signature :=
{add_assoc, add_id, add_inv, add_comm, mul_assoc, mul_id, mul_comm, add_mul}

lemma add_assoc_in_ring_theory : add_assoc ∈ ring_theory :=
begin left, refl end

lemma add_id_in_ring_theory : add_id ∈ ring_theory :=
begin apply_rules [set.mem_insert, set.mem_insert_of_mem] end

lemma add_inv_in_ring_theory : add_inv ∈ ring_theory :=
begin apply_rules [set.mem_insert, set.mem_insert_of_mem] end

lemma add_comm_in_ring_theory : add_comm ∈ ring_theory :=
begin apply_rules [set.mem_insert, set.mem_insert_of_mem] end

lemma mul_assoc_in_ring_theory : mul_assoc ∈ ring_theory :=
begin apply_rules [set.mem_insert, set.mem_insert_of_mem] end

lemma mul_id_in_ring_theory : mul_id ∈ ring_theory :=
begin apply_rules [set.mem_insert, set.mem_insert_of_mem] end

lemma mul_comm_in_ring_theory : mul_comm ∈ ring_theory :=
begin apply_rules [set.mem_insert, set.mem_insert_of_mem] end

lemma add_mul_in_ring_theory : add_mul ∈ ring_theory :=
begin apply_rules [set.mem_insert, set.mem_insert_of_mem, set.mem_singleton] end

end ring_signature

namespace struc_to_ring_struc
-- We make any (type theoretic) structure A,0,1,-,+,* into a
-- (model theoretic) Structure in ring_signature

variable {A : Type*}

/-- Interpreting consant symbols from ring_signature -/
@[simp] def const_map [has_zero A] [has_one A] : ring_consts → (dvector A 0) → A
| ring_consts.zero _ := 0
| ring_consts.one  _ := 1

/-- Interpreting unary function symbols from ring_signature -/
@[simp] def unaries_map [has_neg A] : ring_unaries → (dvector A 1) → A
| ring_unaries.neg a := - (dvector.last a)

/-- Interpreting binary function symbols from ring_signature -/
@[simp] def binaries_map [has_add A] [has_mul A] : ring_binaries → (dvector A 2) → A
| ring_binaries.add   (a :: b) := a + dvector.last b
| ring_binaries.mul  (a :: b) := a * dvector.last b

variables [has_zero A] [has_one A] [has_neg A] [has_add A] [has_mul A]

/-- Interpreting all symbols from ring_signature-/
@[simp] def func_map : Π (n : ℕ), (ring_funcs n) → (dvector A n) → A
| 0       := const_map
| 1       := unaries_map
| 2       := binaries_map
| (n + 3) := pempty.elim

variable (A)

/-- Interpreting the symbols -/
@[reducible] def Structure : Structure ring_signature :=
Structure.mk A func_map (λ n, pempty.elim)

variable {A}

@[simp] lemma realize_zero {n} {vec : dvector A n} :
  @realize_bounded_ring_term (struc_to_ring_struc.Structure A) n vec 0
    (@bd_func ring_signature _ 0 ring_consts.zero) dvector.nil = 0 := rfl

lemma apps_zero {n} : Π {t_ : dvector (bounded_ring_term n) 0},
  bd_apps (@bd_func ring_signature _ 0 ring_consts.zero) t_ = 0
| [] := rfl

@[simp] lemma realize_one {n} {vec : dvector A n} :
  @realize_bounded_ring_term (Structure A) n vec 0
    (@bd_func ring_signature _ 0 ring_consts.one) dvector.nil = 1 := rfl

@[simp] lemma realize_nat {as} : Π (n : ℕ),
@realize_bounded_term _ (Structure A) _ as _ (n : bounded_ring_term 0) dvector.nil
= n
| 0 := rfl
| (n+1) :=
by simpa only [const_map, realize_bounded_term,
      nat.cast_succ, realize_nat n]

lemma realize_nat_succ {n : ℕ} : (n.succ : A) = (n : A) + 1 := rfl

lemma realize_nat_eq_zero {n : ℕ} (h : n = 0) : (n : A) = 0 := by simp [h]

lemma apps_one {n} : Π {t_ : dvector (bounded_ring_term n) 0},
  bd_apps (@bd_func ring_signature _ 0 ring_consts.one) t_ = 1
| [] := rfl

lemma app_neg {n} {t : bounded_ring_term n} :
  bd_app (@bd_func ring_signature _ 1 ring_unaries.neg) t = - t := rfl

lemma apps_neg {n} {t : bounded_ring_term n} :
   bd_apps (@bd_func ring_signature _ 1 ring_unaries.neg) ([t]) = - t := rfl

lemma app_add {n} {s t : bounded_ring_term n} :
  ((@bd_func ring_signature _ 2 ring_binaries.add).bd_app t).bd_app s = t + s := rfl

lemma apps_add {n} {s t : bounded_ring_term n} :
   bd_apps (@bd_func ring_signature _ 2 ring_binaries.add) ([s,t]) = s + t := rfl

lemma app_mul {n} {s t : bounded_ring_term n} :
  ((@bd_func ring_signature _ 2 ring_binaries.mul).bd_app t).bd_app s = t * s := rfl

lemma apps_mul {n} {s t : bounded_ring_term n} :
   bd_apps (@bd_func ring_signature _ 2 ring_binaries.mul) ([s,t]) = s * t := rfl

  -- lemma preterm_upper_bound {n} : bounded_preterm ring_signature n 3 → false := _

end struc_to_ring_struc

namespace comm_ring_to_model

variables (A : Type*) [comm_ring A]

lemma realize_ring_theory :
  (struc_to_ring_struc.Structure A) ⊨ ring_signature.ring_theory :=
begin
  intros ϕ h,
  repeat {cases h},
  { intros a b c, simp [add_assoc] },
  { intro a, simp }, -- add_zero
  { intro a, simp }, -- add_left_neg
  { intros a b, simp [add_comm] },
  { intros a b c, simp [mul_assoc] },
  { intro a, simp [mul_one] },
  { intros a b, simp [mul_comm] },
  { intros a b c, simp [add_mul] }
end

/-- Commutative rings model the theory of rings -/
def model : Model ring_signature.ring_theory :=
⟨ struc_to_ring_struc.Structure A ,  realize_ring_theory A ⟩

end comm_ring_to_model

namespace mv_polynomial

variable {σ : Type}

open ring_signature

/-- Terms in the ring_signature are multivariable polynomials over ℤ -/
noncomputable def term {n} :
  bounded_ring_term n → mv_polynomial (fin n) ℤ :=
@ring_term_rec n (λ _, mv_polynomial (fin n) ℤ)
  mv_polynomial.X 0 1
  (λ _ p, - p)
  (λ _ _ p q, p + q)
  (λ _ _ p q, p * q)

@[simp] lemma term_x {n} {k : fin n} : term (x_ k) = mv_polynomial.X k := rfl
@[simp] lemma term_zero {n} : @term n (bd_func ring_consts.zero) = 0 := rfl
@[simp] lemma term_one {n} : @term n (bd_func ring_consts.one) = 1 := rfl
@[simp] lemma term_neg {n} {t : bounded_ring_term n} :
  term (- t) = - term t := rfl
@[simp] lemma term_add {n} {s t : bounded_ring_term n} :
  term (s + t) = term s + term t := rfl
@[simp] lemma term_mul {n} {s t : bounded_ring_term n} :
  term (s * t) = term s * term t := rfl

variables {A : Type*} [comm_ring A]

@[reducible] private def AStruc := struc_to_ring_struc.Structure A

/-- terms realized at values in A are the corresponding polynomials -/
/- evaluated at those values -/
lemma realized_term_is_evaluated_poly {n} {as : dvector A n} :
Π (t : bounded_ring_term n),
  @realize_bounded_term _ AStruc _ as _ t dvector.nil
  = mv_polynomial.eval (dvector.fin_val as) (term t) :=
@ring_term_rec n (λ (t : bounded_ring_term n),
  @realize_bounded_term _ AStruc _ as _ t dvector.nil
    = mv_polynomial.eval (dvector.fin_val as) (term t))
  (begin intro k, simpa, end) -- variables
  (by simpa)
  (by simp)
  (by { intros t h, unfold_coes at h ⊢, simp [h] } ) -- neg
  (by { intros s t hs ht, unfold_coes at hs ht ⊢, simp [hs, ht] }) -- add
  (by { intros s t hs ht, unfold_coes at hs ht ⊢, simp [hs, ht] }) -- mul

end mv_polynomial

namespace polynomial

  variables {A : Type*} [comm_ring A]

  @[reducible] private def AStruc := struc_to_ring_struc.Structure A

  /-- Takes a term in variables x₀ ⋯ xₙ and values a₁ ⋯ aₙ : A and returns
    a polynomial in A[X] such that x₀ ↦ X and otherwise xₙ ↦ aₙ -/
  @[reducible] noncomputable def term_evaluated_at_coeffs {n} (as : dvector A n)
    (t : bounded_ring_term n.succ) : polynomial A :=
  let σ : fin n.succ → polynomial A :=
  @fin.cases n (λ _, polynomial A) polynomial.X (λ i, polynomial.C (as.nth' i)) in
  mv_polynomial.eval σ (mv_polynomial.term t)

  /-- Evaluating the polynomial term_evaluated_at_coeffs at a₀ : A produces the same
    term in A as realising the term at a₀ a₁ ⋯ aₙ -/
  lemma eval_term_evaluated_at_coeffs_eq_realize_bounded_term
    {n} {as : dvector A n} {x : A} (t : bounded_term ring_signature n.succ) :
    (polynomial.eval x (term_evaluated_at_coeffs as t)
      = @realize_bounded_term _ AStruc n.succ (x::as) _ t dvector.nil) :=
  begin
    rw [mv_polynomial.realized_term_is_evaluated_poly,
      dvector.fin_val_eq_x_val,
      mv_polynomial.eval_eq_poly_eval_mv_coeffs],
    simp only [dvector.fin_val, function.comp_app, fin.x_val,
      mv_polynomial.to_polynomial, term_evaluated_at_coeffs],
    unfold_coes,
    have hcoes : int.cast_ring_hom (polynomial A) =
      polynomial.C.comp (int.cast_ring_hom AStruc) := by simp,
    rw hcoes,
    simp,
  end

  lemma term_evaluated_at_coeffs_X {n} {as : dvector A n} :
    term_evaluated_at_coeffs as (x_ ⟨ 0 , nat.zero_lt_succ _ ⟩) = polynomial.X :=
  begin
    simp only [term_evaluated_at_coeffs],
    unfold_coes,
    simp,
  end

lemma term_evaluated_at_coeffs_coeff
  {n} {as : dvector A n} {k : fin n} :
    term_evaluated_at_coeffs as (x_ ⟨ k.1.succ , nat.succ_lt_succ k.2 ⟩)
    = polynomial.C (dvector.nth' as k) :=
  begin
    simp only [term_evaluated_at_coeffs],
    unfold_coes,
    simp,
  end

  lemma term_evaluated_at_coeffs_zero {n} {as : dvector A n} :
    term_evaluated_at_coeffs as (bd_func ring_consts.zero) = 0 :=
  begin
    simp only [term_evaluated_at_coeffs],
    unfold_coes,
    simp,
  end

  lemma term_evaluated_at_coeffs_one {n} {as : dvector A n} :
    term_evaluated_at_coeffs as (bd_func ring_consts.one) = 1 :=
  begin
    simp only [term_evaluated_at_coeffs],
    unfold_coes,
    simp,
  end

  lemma term_evaluated_at_coeffs_neg {n} {as : dvector A n} {t : bounded_ring_term n.succ} :
    term_evaluated_at_coeffs as (- t) = - term_evaluated_at_coeffs as t :=
  begin
    simp only [term_evaluated_at_coeffs],
    unfold_coes,
    simp,
  end

  lemma term_evaluated_at_coeffs_add {n} {as : dvector A n} {s t : bounded_ring_term n.succ} :
    term_evaluated_at_coeffs as (s + t) = term_evaluated_at_coeffs as s + term_evaluated_at_coeffs as t :=
  begin
    simp only [term_evaluated_at_coeffs],
    unfold_coes,
    simp,
  end

  lemma term_evaluated_at_coeffs_mul {n} {as : dvector A n} {s t : bounded_ring_term n.succ} :
    term_evaluated_at_coeffs as (s * t) = term_evaluated_at_coeffs as s * term_evaluated_at_coeffs as t :=
  begin
    simp only [term_evaluated_at_coeffs],
    unfold_coes,
    simp,
  end

  lemma term_evaluated_at_coeffs_pow {n : ℕ} : Π {m : ℕ} {as : dvector A n},
    polynomial.term_evaluated_at_coeffs as (x_ ⟨ 0 , nat.zero_lt_succ _ ⟩ ^ m)
    = polynomial.X ^ m
  | 0       _ :=
  by simp [npow_rec, ring_signature.pow_zero, term_evaluated_at_coeffs_one]
  | (m + 1) as :=
  by rw [ring_signature.pow_succ, term_evaluated_at_coeffs_mul,
      @term_evaluated_at_coeffs_pow m as, pow_succ, term_evaluated_at_coeffs_X]

  lemma term_evaluated_at_coeffs_monomial {n : ℕ} {m : ℕ} {as : dvector A n} {k : fin n} :
    polynomial.term_evaluated_at_coeffs as
      (x_ ⟨ k.1.succ , nat.succ_lt_succ k.2 ⟩ *
      npow_rec m x_ ⟨ 0 , nat.zero_lt_succ _ ⟩)
      = polynomial.monomial m (dvector.nth' as k) :=
  by rw [term_evaluated_at_coeffs_mul, term_evaluated_at_coeffs_coeff,
     term_evaluated_at_coeffs_pow, polynomial.monomial_eq_C_mul_X]

  lemma term_evaluated_at_coeffs_monomial'
    {n m k : ℕ} {as : dvector A n} (hk : k < n) :
    polynomial.term_evaluated_at_coeffs as
      (x_ ⟨ k.succ , nat.succ_lt_succ hk ⟩ *
      x_ ⟨ 0 , nat.zero_lt_succ _ ⟩ ^ m)
      = polynomial.monomial m (dvector.nth as k hk) :=
  begin
    rw term_evaluated_at_coeffs_mul,
    have h : term_evaluated_at_coeffs as x_⟨k.succ, _⟩
      = polynomial.C (dvector.nth as k hk),
    { unfold_coes,
      simp [term_evaluated_at_coeffs, dvector.nth'] },
    rw [h, term_evaluated_at_coeffs_pow, polynomial.monomial_eq_C_mul_X],
  end

  lemma lift_succ_remove_last {n : ℕ} :
  Π {t : bounded_ring_term (n + 1)} {as : dvector A (n + 1)},
    polynomial.term_evaluated_at_coeffs as (lift_succ t)
    = polynomial.term_evaluated_at_coeffs (dvector.remove_mth (n + 2) as) t :=
  @ring_signature.ring_term_rec (n + 1)
  (λ {t : bounded_ring_term (n + 1)}, Π {as : dvector A (n + 1)},
    polynomial.term_evaluated_at_coeffs as (lift_succ t)
    = polynomial.term_evaluated_at_coeffs (dvector.remove_mth (n + 2) as) t)
    (begin -- variables
      intros k as,
      rw lift_succ_x_k,
      cases k with k hk,
      cases k,
      { simp [term_evaluated_at_coeffs] },
      {
        simp only [mv_polynomial.eval_X, polynomial.C_inj,
          fin.coe_eq_cast_succ, fin.cases_succ', mv_polynomial.coe_mv_poly_X,
          fin.cast_succ_mk, mv_polynomial.term_x, term_evaluated_at_coeffs,
          dvector.nth'],
        rw dvector.nth_eq_succ_nth,
      },
    end)
    (by { intro, simp [lift_succ, term_evaluated_at_coeffs_zero] })
    (by { intro, simp [lift_succ, term_evaluated_at_coeffs_one] })
    (by { intros _ h _,
      simp [lift_succ, struc_to_ring_struc.app_neg,
        term_evaluated_at_coeffs_neg, h] })
    (by { intros s t hs ht as,
      simp only [lift_succ, struc_to_ring_struc.app_add,
        term_evaluated_at_coeffs_add, hs, ht] })
    (by { intros s t hs ht as,
      simp only [lift_succ, struc_to_ring_struc.app_mul,
        term_evaluated_at_coeffs_mul, hs, ht] })

end polynomial

namespace models_ring_theory_to_comm_ring

variable {M : Structure ring_signature}

def zero : ↥ M := @Structure.fun_map _ M 0 ring_consts.zero dvector.nil
def one : ↥ M := @Structure.fun_map _ M 0 ring_consts.one dvector.nil
def neg (a : M.carrier) : M.carrier := @Structure.fun_map _ M 1 ring_unaries.neg ([a])
def add (a b : M.carrier) : M.carrier := @Structure.fun_map _ M 2 ring_binaries.add ([a , b])
def mul (a b : M.carrier) : M.carrier := @Structure.fun_map _ M 2 ring_binaries.mul ([a , b])

instance : has_zero M := ⟨ zero ⟩
instance : has_one M := ⟨ one ⟩
instance : has_neg M := ⟨ neg ⟩
instance : has_add M := ⟨ add ⟩
instance : has_mul M := ⟨ mul ⟩

@[simp] lemma realize_zero {n} {vec : dvector M.carrier n} :
  realize_bounded_term vec (@bd_func ring_signature _ 0 ring_consts.zero) dvector.nil = 0 := rfl

@[simp] lemma realize_one {n} {vec : dvector M.carrier n} :
  realize_bounded_term vec (@bd_func ring_signature _ 0 ring_consts.one) dvector.nil = 1 := rfl

@[simp] lemma realize_neg {a : M.carrier} :
  @Structure.fun_map _ M 1 ring_unaries.neg ([a]) = - a := rfl

@[simp] lemma realize_add {a b : M.carrier} :
  @Structure.fun_map _ M 2 ring_binaries.add ([a , b]) = a + b := rfl

@[simp] lemma realize_mul {a b : M.carrier} :
  @Structure.fun_map _ M 2 ring_binaries.mul ([a , b]) = a * b := rfl

lemma realize_pow {a : M.carrier} : ∀ {m n} {vec : dvector M.carrier n},
realize_bounded_term (a :: vec) (npow_rec m (x_ 0)) dvector.nil
= npow_rec m a
| 0 n vec := rfl
| (m+1) n vec :=
by simp only [npow_rec, realize_bounded_term, realize_mul,
      fin.val_zero, dvector.nth, @realize_pow m]

lemma realize_nat {M : fol.Structure ring_signature} {as : dvector M 0} :
Π (n : ℕ),
@realize_bounded_term _ M _ as _ (n : bounded_ring_term 0) dvector.nil
= n
| 0 := rfl
| (n+1) :=
by simpa only [realize_bounded_term, nat.cast_succ, realize_nat n, realize_one]

variable (h : M ⊨ ring_signature.ring_theory)

include h

lemma add_assoc (a b c : M) : (a + b) + c = a + (b + c) :=
begin
  have hAssoc := h ring_signature.add_assoc_in_ring_theory,
  have habc := hAssoc c b a,
  simpa [habc]
end

lemma add_comm (a b : M) : a + b = b + a :=
begin
  have hId := h ring_signature.add_comm_in_ring_theory,
  have hab := hId b a,
  simpa [hab]
end

lemma add_zero (a : M) : a + 0 = a :=
begin
  have hId := h ring_signature.add_id_in_ring_theory,
  have ha := hId a,
  simpa [ha]
end

lemma zero_add (a : M) : 0 + a = a :=
begin
  rw add_comm h, apply add_zero h,
end

lemma left_neg (a : M) : - a + a = 0 :=
begin
  have hInv := h ring_signature.add_inv_in_ring_theory,
  have ha := hInv a,
  simpa [ha]
end

lemma mul_assoc (a b c : M) : (a * b) * c = a * (b * c) :=
begin
  have hAssoc := h ring_signature.mul_assoc_in_ring_theory,
  have habc := hAssoc c b a,
  simpa [habc]
end

lemma mul_comm (a b : M) : a * b = b * a :=
begin
  have hId := h ring_signature.mul_comm_in_ring_theory,
  have hab := hId b a,
  simpa [hab]
end

lemma mul_one (a : M) : a * 1 = a :=
begin
  have hId := h ring_signature.mul_id_in_ring_theory, have ha := hId a, simpa using ha
end

lemma one_mul (a : M) : 1 * a = a :=
by rw [mul_comm h, mul_one h]

lemma add_mul (a b c : M) : (a + b) * c = a * c + b * c :=
begin
  have hAM := h ring_signature.add_mul_in_ring_theory,
  have habc := hAM c b a,
  simpa [habc]
end

lemma mul_add (c a b : M) : c * (a + b) = c * a + c * b :=
begin
  rw [mul_comm h c (a + b), mul_comm h c a, mul_comm h c b],
  exact add_mul h a b c,
end

def comm_ring : comm_ring M :=
{
  add            := add,
  add_assoc      := add_assoc h,
  zero           := zero,
  zero_add       := zero_add h,
  add_zero       := add_zero h,
  neg            := neg,
  add_left_neg   := left_neg h,
  add_comm       := add_comm h,
  mul            := mul,
  mul_assoc      := mul_assoc h,
  one            := one,
  one_mul        := one_mul h,
  mul_one        := mul_one h,
  left_distrib   := mul_add h,
  right_distrib  := add_mul h,
  mul_comm       := mul_comm h,
}

end models_ring_theory_to_comm_ring

instance models_ring_theory_to_comm_ring {M : Structure ring_signature}
  [h : fact (M ⊨ ring_signature.ring_theory)] : comm_ring M :=
models_ring_theory_to_comm_ring.comm_ring h.1

lemma Structure_ring_eq_self (A : Type*) [comm_ring A] :
  (struc_to_ring_struc.Structure A : Type*) = A := rfl

lemma Structure_structure_eq_self (M : Structure ring_signature) :
  struc_to_ring_struc.Structure M = M :=
begin
  apply Structure.ext,
  { refl },
  { simp only [struc_to_ring_struc.Structure, heq_iff_eq],
    funext n, cases n,
    { funext c, cases c; { funext nil, cases nil, refl }},
    cases n,
    { funext neg, cases neg, funext y, cases y with _ _ y, cases y, refl },
    cases n,
    {
      funext addmul, cases addmul; { funext y, repeat {cases y with _ _ y}, refl },
    },
    { funext mem_empty, cases mem_empty }}
end

namespace instances

open ulift

def pℕ : Type* := ulift ℕ

def nat_ring_consts :
  ring_consts → dvector pℕ 0 → pℕ
| ring_consts.zero as := up 0
| ring_consts.one as := up 1

def nat_ring_structure_funcs :
  Π {n}, ring_signature.functions n → dvector pℕ n → pℕ
| 0 ring_consts.zero as := up 0
| 0 ring_consts.one as := up 1
| 1 ring_unaries.neg as := up 0
| 2 ring_binaries.add (dvector.cons a (dvector.cons b nil)) :=
  up ( down a + down b)
| 2 ring_binaries.mul (dvector.cons a (dvector.cons b nil)) :=
  up ( down a * down b)
| (n+3) f as := pempty.elim f

def nat_ring_structure : fol.Structure ring_signature :=
⟨ pℕ , λ _, nat_ring_structure_funcs , λ _, pempty.elim ⟩

lemma nat_ring_structure_realize_nat :
  Π (n : ℕ) {k : ℕ} (v : dvector nat_ring_structure k),
  realize_bounded_ring_term v
    (n : fol.bounded_preterm ring_signature k 0) dvector.nil = up n
| 0 _ _ := rfl
| (n+1) k v :=
begin
  have h := @nat_ring_structure_realize_nat n k v,
  rw [realize_bounded_ring_term] at h,
  simpa only [nat.cast_succ, realize_bounded_ring_term,
    fol.realize_bounded_term, h],
end

lemma nat_cast_bd_ring_term_inj {k n m : ℕ} :
  (n : fol.bounded_preterm ring_signature.{u} k 0) = m → n = m :=
begin
  let v : dvector nat_ring_structure k := dvector.of_fn (λ i, 0),
  intro hnm,
  rw [← down_up n, ← down_up m, ← nat_ring_structure_realize_nat n v,
    ← nat_ring_structure_realize_nat m v],
  apply congr_arg down.{u},
  exact @congr_arg (fol.bounded_preterm ring_signature k 0)
    nat_ring_structure n m
    (λ t : fol.bounded_preterm ring_signature k 0,
      realize_bounded_ring_term v t dvector.nil) hnm,
end

end instances

section equiv

open dvector fol
open_locale fol

lemma equiv_of_ring_equiv_map_fun {M N : Structure Rings.ring_signature}
  [fact (M ⊨ ring_signature.ring_theory)]
  [fact (N ⊨ ring_signature.ring_theory)]
  (ϕ : M ≃+* N) : Π {n : ℕ} (f : ring_signature.functions n) (xs : dvector M n),
    ϕ (M.fun_map f xs) = N.fun_map f (xs.map ϕ)
| 0 ring_consts.zero nil := ring_equiv.map_zero ϕ
| 0 ring_consts.one nil := ring_equiv.map_one ϕ
| 1 ring_unaries.neg (x :: nil) := by simp [dvector.map]
| 2 ring_binaries.add (x :: y :: nil) := by simp [dvector.map]
| 2 ring_binaries.mul (x :: y :: nil) := by simp [dvector.map]
| (n+3) f xs := pempty.elim f

/--
We need the hypothesis that M and N are models of `ring_theory` since
`≃+*` alone lacks commuting proofs for `0` and `1`
-/
def equiv_of_ring_equiv {M N : Structure Rings.ring_signature}
  [fact (M ⊨ ring_signature.ring_theory)]
  [fact (N ⊨ ring_signature.ring_theory)]
  (ϕ : M ≃+* N) : M ≃[Rings.ring_signature] N :=
{ to_fun := ϕ.to_fun,
  inv_fun := ϕ.inv_fun,
  left_inv := ϕ.left_inv,
  right_inv := ϕ.right_inv,
  map_fun' := λ _, equiv_of_ring_equiv_map_fun ϕ,
  map_rel' := λ n r, pempty.elim r }

end equiv

end Rings

namespace realize_ring_term

open Rings fol

variables
  {A : Type*} [comm_ring A]
  {c : ℕ} (xs : dvector (struc_to_ring_struc.Structure A) c)

@[simp] lemma list_sumr :
  Π {l : list (bounded_ring_term c)},
  realize_bounded_term xs (list.sumr l) dvector.nil
  =
  list.sumr (list.map (λ t, realize_bounded_term xs t dvector.nil) l)
| list.nil := by simp
| (list.cons t ts) :=
begin
  simp only [list.map, models_ring_theory_to_comm_ring.realize_add,
    list.sumr, realize_bounded_term],
  simp only [struc_to_ring_struc.func_map, dvector.last,
    struc_to_ring_struc.binaries_map, add_right_inj, dvector.nth],
  rw list_sumr,
end

def add_zero_hom :
  add_zero_hom (bounded_ring_term c) A :=
⟨ λ t, realize_bounded_term xs t dvector.nil ,
  models_ring_theory_to_comm_ring.realize_zero ,
  λ t s, models_ring_theory_to_comm_ring.realize_add ⟩

lemma sumr
  {ts : list (bounded_ring_term c)} :
  realize_bounded_term xs (ts).sumr dvector.nil
  =
  (list.map (add_zero_hom xs).to_fun ts).sumr :=
begin
  rw ← list.add_zero_hom_sumr (add_zero_hom xs) ts,
  refl,
end

lemma nat_non_comm_prod :
  Π (n : ℕ) (ts : fin n → bounded_ring_term c),
  realize_bounded_term xs (nat.non_comm_prod _ ts) dvector.nil
  =
  nat.non_comm_prod n (λ i, realize_bounded_term xs (ts i) dvector.nil)
| nat.zero ts :=
begin
  simp only [nat.non_comm_prod],
  refl,
end
| (nat.succ n) ts :=
begin
  simp only [nat.non_comm_prod, struc_to_ring_struc.func_map,
    dvector.last, struc_to_ring_struc.binaries_map, realize_bounded_term,
    dvector.nth],
  rw nat_non_comm_prod n,
end

lemma pow (t : bounded_ring_term c) : Π (n : ℕ),
  realize_bounded_term xs (npow_rec n t) dvector.nil
  =
  (realize_bounded_term xs t dvector.nil) ^ n
| nat.zero := by simpa
| (nat.succ n) := by simp [npow_rec, pow n, pow_succ]

end realize_ring_term


import algebraic_geometry.limits
import algebraic_geometry.misc
import category_theory.limits.preserves.opposites

universes u v

open category_theory category_theory.limits topological_space

namespace algebraic_geometry

variables {J : Type u} [decidable_eq J] (X : J → Scheme.{u})

lemma comp_eq_of_is_initial {C : Type*} [category C] [has_strict_initial_objects C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (hY : is_initial Y) : f ≫ g = h :=
by { haveI := hY.is_iso_to f, rw ← is_iso.eq_inv_comp, exact hY.hom_ext _ _ }

@[simps]
noncomputable
def coproduct_glue_data : Scheme.glue_data :=
{ J := J,
  U := X,
  V := λ ij, if ij.1 = ij.2 then X ij.1 else ∅,
  f := λ i j, if h : i = j then eq_to_hom (if_pos h) else eq_to_hom (if_neg h) ≫ (X i).empty_to,
  f_mono := λ i j, by split_ifs; apply_instance,
  f_id := λ i, by { rw dif_pos rfl, apply_instance },
  t := λ i j, eq_to_hom (by { dsimp only, simp_rw @eq_comm _ i j, split_ifs, subst h, refl }),
  t_id := λ i, eq_to_hom_refl _ _,
  t' := λ i j k, if h₁ : i = j then if h₂ : j = k then eq_to_hom (by substs h₁ h₂)
      else pullback.snd ≫ eq_to_hom (by { subst h₁, exact dif_neg h₂ }) ≫ Scheme.empty_to _
      else pullback.fst ≫ eq_to_hom (dif_neg h₁) ≫ Scheme.empty_to _,
  t_fac := begin
    intros i j k,
    dsimp only,
    split_ifs with h₁,
    { subst h₁, rw [eq_to_hom_refl, category.comp_id],
      by_cases h₂ : i = k,
      { subst h₂, simp only [dif_pos rfl, eq_to_hom_refl, category.id_comp],
        rw ← cancel_mono (eq_to_hom (show ite (i = i) (X i) ∅ = X i, from dif_pos rfl)),
        convert pullback.condition.symm; rw dif_pos rfl; refl },
      { simp only [dif_neg h₂],
        rw [← category.assoc, category.assoc],
        exact comp_eq_of_is_initial _ _ _ is_initial_of_is_empty } },
    { rw [← category.assoc, category.assoc],
      exact comp_eq_of_is_initial _ _ _ is_initial_of_is_empty }
  end,
  cocycle := begin
    intros i j k,
    dsimp only,
    split_ifs with h₁,
    { subst h₁,
      by_cases h₂ : i = k,
      { subst h₂, simp only [dif_pos rfl, eq_to_hom_refl, category.id_comp] },
      { simp only [dif_neg h₂, category.assoc],
        rw ← category.assoc, exact comp_eq_of_is_initial _ _ _ is_initial_of_is_empty } },
    { simp only [category.assoc],
      rw ← category.assoc, exact comp_eq_of_is_initial _ _ _ is_initial_of_is_empty }
  end,
  f_open := λ i j, by { dsimp only at *, split_ifs; apply_instance } }
.

noncomputable
def multicoequalizer_is_coproduct_of_is_initial
  {C : Type*} [category C] (I : multispan_index C) [has_multicoequalizer I]
  (hI : ∀ i, (∃ h : I.fst_from i = I.snd_from i, I.fst i = I.snd i ≫ eq_to_hom (by rw h)) ∨
    nonempty (is_initial (I.left i))) :
  is_colimit (cofan.mk (multicoequalizer I) (multicoequalizer.π I)) :=
{ desc := λ s, multicoequalizer.desc I _ (λ b, s.ι.app ⟨b⟩)
    (by { intro i, rcases hI i with (⟨e₁, e₂⟩|⟨⟨h⟩⟩),
      { rw e₂, generalize_proofs e₃, revert e₃, rw e₁, simp }, { exact h.hom_ext _ _ } }),
  fac' := λ s ⟨j⟩, by rw [cofan.mk_ι_app, multicoequalizer.π_desc],
  uniq' := λ s m H, multicoequalizer.hom_ext I m _
    (λ j, (H ⟨j⟩).trans (multicoequalizer.π_desc I s.X _ _ j).symm) }

noncomputable
def coproduct_glue_data.is_coproduct :
  is_colimit (cofan.mk (coproduct_glue_data X).glued (coproduct_glue_data X).ι) :=
multicoequalizer_is_coproduct_of_is_initial _
begin
  rintro ⟨i, j⟩, dsimp at *, split_ifs,
  exacts [or.inl ⟨h, by simp [dif_pos h.symm]⟩, or.inr ⟨is_initial_of_is_empty⟩]
end

instance : has_coproducts.{u} Scheme :=
λ ι, ⟨λ J, by { classical, exact @@has_colimit_of_iso _ _
  ⟨⟨⟨_, coproduct_glue_data.is_coproduct (J.obj ∘ discrete.mk)⟩⟩⟩ discrete.nat_iso_functor }⟩

noncomputable
def coproduct_glue_data.iso_coproduct :
  (coproduct_glue_data X).glued ≅ sigma_obj X :=
(colimit.iso_colimit_cocone ⟨_, coproduct_glue_data.is_coproduct X⟩).symm

@[simp, reassoc]
lemma coproduct_glue_data.iso_coproduct_ι_inv (i) :
  sigma.ι X i ≫ (coproduct_glue_data.iso_coproduct X).inv =
    (coproduct_glue_data X).ι i :=
colimit.iso_colimit_cocone_ι_hom ⟨_, _⟩ ⟨i⟩

@[simp, reassoc]
lemma coproduct_glue_data.iso_coproduct_ι_hom (i) :
  (coproduct_glue_data X).ι i ≫ (coproduct_glue_data.iso_coproduct X).hom =
    sigma.ι X i :=
colimit.iso_colimit_cocone_ι_inv ⟨_, coproduct_glue_data.is_coproduct X⟩ ⟨i⟩

instance (i) : is_open_immersion (sigma.ι X i) :=
begin
  rw ← coproduct_glue_data.iso_coproduct_ι_hom,
  apply_instance
end

lemma sigma_ι_jointly_surjective (x : (∐ X).carrier) :
  ∃ i, x ∈ set.range (sigma.ι X i : _).1.base :=
begin
  obtain ⟨i, y, e⟩ := (coproduct_glue_data X).ι_jointly_surjective
    ((coproduct_glue_data.iso_coproduct X).inv.1.base x),
  refine ⟨i, y, _⟩,
  apply (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso $
    coproduct_glue_data.iso_coproduct X).symm.injective,
  change (sigma.ι X i ≫ (coproduct_glue_data.iso_coproduct X).inv).1.base y = _,
  rwa coproduct_glue_data.iso_coproduct_ι_inv,
end

lemma supr_opens_range_sigma_ι : (⨆ i, Scheme.hom.opens_range (sigma.ι X i)) = ⊤ :=
begin
  rw eq_top_iff,
  rintro x -,
  rw [opens.coe_supr, set.mem_Union],
  exact sigma_ι_jointly_surjective X x
end

lemma is_open_immersion_of_open_cover {X Y : Scheme} (f : X ⟶ Y) (𝒰 : X.open_cover)
  [H : ∀ i, is_open_immersion (𝒰.map i ≫ f)] (hf : function.injective f.1.base) :
  is_open_immersion f :=
begin
  have H' := 𝒰.is_open,
  simp_rw is_open_immersion.iff_stalk_iso at H H' ⊢,
  split,
  { refine open_embedding_iff_continuous_injective_open.mpr ⟨f.1.base.2, hf, λ U hU, _⟩,
    have : (⋃ i, set.range (𝒰.map i).1.base) = set.univ,
    { rw [← opens.coe_top, ← 𝒰.supr_opens_range,
        opens.coe_supr], refl },
    have : f.1.base '' U = ⋃ i, (𝒰.map i ≫ f).1.base '' ((𝒰.map i).1.base ⁻¹' U),
    { simp_rw [Scheme.comp_val_base, coe_comp, set.image_comp f.1.base ((𝒰.map _).1.base),
        set.image_preimage_eq_inter_range, ← set.image_Union, ← set.inter_Union, this,
        set.inter_univ] },
    rw this,
    exact is_open_Union (λ i, (H i).1.is_open_map _ (hU.preimage (𝒰.map i).1.base.2)) },
  { intro x,
    obtain ⟨y, hy⟩ := 𝒰.covers x,
    have := @@is_iso.comp_is_iso _ ((H $ 𝒰.f x).2 y) (@@is_iso.inv_is_iso _ $ (H' (𝒰.f x)).2 y),
    erw [PresheafedSpace.stalk_map.comp, category.assoc, @@is_iso.hom_inv_id,
      category.comp_id] at this,
    rwa ← hy }
end

noncomputable
def is_coproduct_of_is_open_immersion' {Y : Scheme}
  (f : ∀ i, X i ⟶ Y) [H : ∀ i, is_open_immersion (f i)]
  (hf : (⨆ i, (f i).opens_range) = ⊤)
  (hf' : ∀ i j, i ≠ j → disjoint (set.range (f i).1.base) (set.range (f j).1.base)) :
  is_colimit (cofan.mk Y f) :=
begin
  haveI : is_iso (colimit.cocone_morphism (cofan.mk Y f)),
  { apply_with cocones.cocone_iso_of_hom_iso { instances := ff },
    apply_with is_open_immersion.to_iso { instances := ff },
    { apply is_open_immersion_of_open_cover _
        ((Scheme.open_cover_of_is_iso.{u} (coproduct_glue_data.iso_coproduct X).hom).bind
        (λ _, (coproduct_glue_data X).open_cover)),
      { intros x y e,
        obtain ⟨i, x, rfl⟩ := sigma_ι_jointly_surjective X x,
        obtain ⟨j, y, rfl⟩ := sigma_ι_jointly_surjective X y,
        simp_rw [← Scheme.comp_val_base_apply, colimit.cocone_morphism_hom,
          colimit.ι_desc, cofan.mk_ι_app] at e,
        by_cases i = j,
        { subst h, rw (PresheafedSpace.is_open_immersion.base_open).inj e },
        { exact (set.disjoint_iff_forall_ne.mp (hf' _ _ h) _ ⟨x, rfl⟩ _ ⟨y, rfl⟩ e).elim } },
      { rintros ⟨⟨⟩, i⟩, convert H i, delta Scheme.glue_data.open_cover, simp } },
    { rw Top.epi_iff_surjective,
      intro x,
      have : x ∈ (⊤ : opens Y.carrier) := trivial,
      rw [← hf, opens.mem_supr] at this,
      obtain ⟨i, x, rfl⟩ := this,
      refine ⟨(sigma.ι X i : _).1.base x, _⟩,
      rw [← Scheme.comp_val_base_apply, colimit.cocone_morphism_hom, colimit.ι_desc,
        cofan.mk_ι_app] } },
  refine is_colimit.of_iso_colimit (colimit.is_colimit _)
    (as_iso $ colimit.cocone_morphism _),
end

noncomputable
def is_coproduct_of_is_open_immersion {ι : Type u} (X : ι → Scheme.{v}) {Y : Scheme.{v}}
  (f : ∀ i, X i ⟶ Y) [H : ∀ i, is_open_immersion (f i)]
  (hf : (⨆ i, (f i).opens_range) = ⊤)
  (hf' : ∀ i j, i ≠ j → disjoint (set.range (f i).1.base) (set.range (f j).1.base)) :
  is_colimit (cofan.mk Y f) :=
begin
  let s := set.range (λ i, set.range (f i).1.base),
  have : ∀ x : s, x.1 ∈ s := λ x, x.2, choose g hg,
  have hg' : function.injective g,
  { intros x y e, ext1, show x.val = y.val, rw [← hg x, ← hg y, e] },
  let g' : ι → s := λ i, ⟨_, i, rfl⟩,
  have hg₁ : ∀ i, g' (g i) = i := λ i, subtype.ext (hg i),
  have hg₂ : ∀ i, (g' i).1 = ∅ ∨ g (g' i) = i,
  { simp_rw or_iff_not_imp_right, intros i e, simpa only [hg, g', disjoint_self] using hf' _ _ e },
  let f' : ∀ (i : s), X (g i) ⟶ Y := λ i, f _,
  let : is_colimit (cofan.mk Y f'),
  { apply is_coproduct_of_is_open_immersion',
    { simp only [← opens.ext_iff, opens.coe_supr,
        opens.coe_top, Scheme.hom.opens_range_coe, hg,
        set.eq_univ_iff_forall, set.mem_Union] at hf ⊢,
      intro x, obtain ⟨i, hi⟩ := hf x, exact ⟨_, ⟨⟨_, _, rfl⟩, rfl⟩, hi⟩ },
    { exact λ i j e, hf' _ _ (hg'.ne e) } },
  refine ⟨λ c, this.desc ⟨_, discrete.nat_trans (λ i, c.ι.app ⟨_⟩)⟩, _, _⟩,
  { rintros c ⟨i⟩,
    cases hg₂ i,
    { exact (@@is_initial_of_is_empty (set.range_eq_empty_iff.mp h)).hom_ext _ _ },
    { rw eq_comm at h,
      have e := this.fac ⟨_, discrete.nat_trans (λ i, c.ι.app ⟨_⟩)⟩ ⟨g' i⟩,
      dsimp [cofan.mk_ι_app, f', discrete.nat_trans_app] at e ⊢,
      convert e } },
  { refine λ c m hm, this.uniq ⟨_, discrete.nat_trans (λ i, c.ι.app ⟨_⟩)⟩ _ (λ i, _),
    exact hm ⟨_⟩ }
end

open opposite

lemma bijective_local_ring_hom_fst (R S : Type*) [comm_ring R] [comm_ring S]
  (I : ideal R) [hx : I.is_prime] :
  function.bijective (localization.local_ring_hom
    (I.comap $ ring_hom.fst R S) I (ring_hom.fst R S) rfl) :=
begin
  split,
  { intros a b e,
    obtain ⟨⟨a₁, a₂⟩, ⟨⟨s₁, s₂⟩, hs⟩, rfl⟩ :=
      is_localization.mk'_surjective (I.comap $ ring_hom.fst R S).prime_compl a,
    obtain ⟨⟨b₁, b₂⟩, ⟨⟨t₁, t₂⟩, ht⟩, rfl⟩ :=
      is_localization.mk'_surjective (I.comap $ ring_hom.fst R S).prime_compl b,
    simp only [localization.local_ring_hom_mk', is_localization.eq, subtype.coe_mk,
      ring_hom.coe_fst] at e ⊢,
    obtain ⟨⟨c, hc⟩, e⟩ := e,
    refine ⟨⟨(c, 0), hc⟩, _⟩,
    simpa using e },
  { intro x,
    obtain ⟨x, ⟨s, hs⟩, rfl⟩ :=
      is_localization.mk'_surjective I.prime_compl x,
    refine ⟨is_localization.mk' _ (x, (1 : S))
      ⟨(s, (1 : S)), show (s, (1 : S)) ∈ (I.comap $ ring_hom.fst R S).prime_compl, from hs⟩, _⟩,
    simp only [localization.local_ring_hom_mk', subtype.coe_mk, ring_hom.coe_fst] }
end

lemma bijective_local_ring_hom_snd (R S : Type*) [comm_ring R] [comm_ring S]
  (I : ideal S) [hx : I.is_prime] :
  function.bijective (localization.local_ring_hom
    (I.comap $ ring_hom.snd R S) I (ring_hom.snd R S) rfl) :=
begin
  split,
  { intros a b e,
    obtain ⟨⟨a₁, a₂⟩, ⟨⟨s₁, s₂⟩, hs⟩, rfl⟩ :=
      is_localization.mk'_surjective (I.comap $ ring_hom.snd R S).prime_compl a,
    obtain ⟨⟨b₁, b₂⟩, ⟨⟨t₁, t₂⟩, ht⟩, rfl⟩ :=
      is_localization.mk'_surjective (I.comap $ ring_hom.snd R S).prime_compl b,
    simp only [localization.local_ring_hom_mk', is_localization.eq, subtype.coe_mk,
      ring_hom.coe_snd] at e ⊢,
    obtain ⟨⟨c, hc⟩, e⟩ := e,
    refine ⟨⟨(0, c), hc⟩, _⟩,
    simpa using e },
  { intro x,
    obtain ⟨x, ⟨s, hs⟩, rfl⟩ :=
      is_localization.mk'_surjective I.prime_compl x,
    refine ⟨is_localization.mk' _ ((1 : R), x)
      ⟨((1 : R), s), show ((1 : R), s) ∈ (I.comap $ ring_hom.snd R S).prime_compl, from hs⟩, _⟩,
    simp only [localization.local_ring_hom_mk', subtype.coe_mk, ring_hom.coe_snd] }
end

lemma prime_spectrum.range_comap_fst (R S : Type*) [comm_ring R] [comm_ring S] :
  set.range (prime_spectrum.comap (ring_hom.fst R S)) =
    ↑(prime_spectrum.basic_open ((1, 0) : R × S)) :=
begin
  ext x,
  simp only [set.mem_range, prime_spectrum.basic_open_eq_zero_locus_compl,
    set_like.mem_coe, set.mem_compl_iff, prime_spectrum.mem_zero_locus,
    set.singleton_subset_iff],
  split,
  { rintro ⟨y, rfl⟩, simpa [← ideal.eq_top_iff_one] using y.2.ne_top },
  { rcases (ideal.ideal_prod_prime x.as_ideal).mp x.2 with (⟨p, hp, e⟩|⟨p, hp, e⟩),
    { intro _, refine ⟨⟨p, hp⟩, prime_spectrum.ext.mpr (e.trans _).symm⟩, ext ⟨a, b⟩, simp },
    { rw e, intro h, exact (h ⟨trivial, zero_mem _⟩).elim } }
end

lemma prime_spectrum.range_comap_snd (R S : Type*) [comm_ring R] [comm_ring S] :
  set.range (prime_spectrum.comap (ring_hom.snd R S)) =
    ↑(prime_spectrum.basic_open ((0, 1) : R × S)) :=
begin
  ext x,
  simp only [set.mem_range, prime_spectrum.basic_open_eq_zero_locus_compl,
    set_like.mem_coe, set.mem_compl_iff, prime_spectrum.mem_zero_locus,
    set.singleton_subset_iff],
  split,
  { rintro ⟨y, rfl⟩, simpa [← ideal.eq_top_iff_one] using y.2.ne_top },
  { rcases (ideal.ideal_prod_prime x.as_ideal).mp x.2 with (⟨p, hp, e⟩|⟨p, hp, e⟩),
    { rw e, intro h, exact (h ⟨zero_mem _, trivial⟩).elim },
    { intro _, refine ⟨⟨p, hp⟩, prime_spectrum.ext.mpr (e.trans _).symm⟩, ext ⟨a, b⟩, simp } }
end

@[instance]
lemma is_open_immersion_Spec_prod_fst {R S : Type u} [comm_ring R] [comm_ring S] :
  is_open_immersion (Scheme.Spec.map (CommRing.of_hom $ ring_hom.fst R S).op) :=
begin
  apply_with is_open_immersion.of_stalk_iso { instances := ff },
  { refine ⟨(prime_spectrum.closed_embedding_comap_of_surjective _
      (ring_hom.fst R S) prod.fst_surjective).1, _⟩,
    erw prime_spectrum.range_comap_fst,
    exact prime_spectrum.is_open_basic_open },
  { rintro (x : prime_spectrum R),
    erw ← local_ring_hom_comp_stalk_iso,
    apply_with is_iso.comp_is_iso { instances := ff }, { apply_instance },
    apply_with is_iso.comp_is_iso { instances := ff }, swap, { apply_instance },
    rw CommRing.is_iso_iff_bijective,
    convert bijective_local_ring_hom_fst R S x.as_ideal, }
end

@[instance]
lemma is_open_immersion_Spec_prod_snd {R S : Type u} [comm_ring R] [comm_ring S] :
  is_open_immersion (Scheme.Spec.map (CommRing.of_hom $ ring_hom.snd R S).op) :=
begin
  apply_with is_open_immersion.of_stalk_iso { instances := ff },
  { refine ⟨(prime_spectrum.closed_embedding_comap_of_surjective _
      (ring_hom.snd R S) prod.snd_surjective).1, _⟩,
    erw prime_spectrum.range_comap_snd,
    exact prime_spectrum.is_open_basic_open },
  { rintro (x : prime_spectrum S),
    erw ← local_ring_hom_comp_stalk_iso,
    apply_with is_iso.comp_is_iso { instances := ff }, { apply_instance },
    apply_with is_iso.comp_is_iso { instances := ff }, swap, { apply_instance },
    rw CommRing.is_iso_iff_bijective,
    convert bijective_local_ring_hom_snd R S x.as_ideal, }
end

def binary_cofan_iso_cofan {C : Type*} [category C] {X Y Z : C}
  (f : X ⟶ Z) (g : Y ⟶ Z) :
  binary_cofan.mk f g ≅ cofan.mk Z (λ b, walking_pair.cases_on b f g) :=
{ hom := { hom := 𝟙 Z, w' := (by rintro ⟨_|_⟩; dsimp; simp) },
  inv := { hom := 𝟙 Z, w' := (by rintro ⟨_|_⟩; dsimp; simp) },
  hom_inv_id' := by { ext1, dsimp, simp },
  inv_hom_id' := by { ext1, dsimp, simp } }
.

noncomputable
def is_coprod_of_is_open_immersion_of_is_compl {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z)
  [is_open_immersion f] [is_open_immersion g]
    (h : is_compl (set.range f.1.base) (set.range g.1.base)) :
  is_colimit (binary_cofan.mk f g) :=
begin
  refine is_colimit.of_iso_colimit _ (binary_cofan_iso_cofan _ _).symm,
  fapply is_coproduct_of_is_open_immersion _ _,
  swap 3, { rintros (_|_); dsimp only; apply_instance },
  { ext1, convert h.2.eq_top using 1, rw opens.coe_supr,
    refine (supr_le _).antisymm (sup_le (le_trans _ $ le_supr _ walking_pair.left)
      (le_trans _ $ le_supr _ walking_pair.right)),
    { rintro (_|_); dsimp only, exacts [le_sup_left, le_sup_right] },
    exacts [le_rfl, le_rfl] },
  { rintro (_|_) (_|_) e; dsimp only, any_goals { exact (e rfl).elim }, exacts [h.1, h.1.symm] }
end

-- set_option trace.class_instances true

noncomputable
def is_coprod_Spec_prod (R S : CommRing.{u}) :
  is_colimit (binary_cofan.mk
    (Scheme.Spec.map (CommRing.of_hom $ ring_hom.fst R S).op)
    (Scheme.Spec.map (CommRing.of_hom $ ring_hom.snd R S).op)) :=
begin
  apply is_coprod_of_is_open_immersion_of_is_compl _ _,
  rotate,
  { exact is_open_immersion_Spec_prod_fst },
  { exact is_open_immersion_Spec_prod_snd },
  { erw [prime_spectrum.range_comap_fst, prime_spectrum.range_comap_snd],
    split,
    { rw [disjoint_iff, set.inf_eq_inter, ← opens.coe_inf, ← prime_spectrum.basic_open_mul,
        prod.mk_mul_mk, mul_zero, zero_mul, ← prod.zero_eq_mk, prime_spectrum.basic_open_zero,
        set.bot_eq_empty, opens.coe_bot] },
    { have : (1, 0) + (0, 1) = (1 : R × S) := by simp,
      rw [codisjoint_iff, set.sup_eq_union,
        prime_spectrum.basic_open_eq_zero_locus_compl,
        prime_spectrum.basic_open_eq_zero_locus_compl, ← set.compl_inter,
        ← prime_spectrum.zero_locus_union, set.top_eq_univ, compl_eq_comm, set.compl_univ,
        eq_comm, ← prime_spectrum.zero_locus_span, prime_spectrum.zero_locus_empty_iff_eq_top,
        ideal.eq_top_iff_one, ← this],
      refine add_mem (ideal.subset_span _) (ideal.subset_span _),
      exacts [or.inl rfl, or.inr rfl] } }
end

noncomputable
instance Scheme.Spec.preserves_binary_products_right_op
  (R S : CommRing) : preserves_limit (pair R S) Scheme.Spec.{u}.right_op :=
begin
  refine preserves_limit_of_preserves_limit_cone (CommRing.prod_fan_is_limit R S) _,
  refine ((is_limit.postcompose_hom_equiv _ _).symm (is_limit_cone_right_op_of_cocone _
    ((is_coprod_Spec_prod R S).whisker_equivalence (discrete.opposite _)))).of_iso_limit _,
  { apply discrete.nat_iso, rintro ⟨_|_⟩; exact iso.refl _ },
  { refine as_iso { hom := (𝟙 _), w' := _ },
    { rintro ⟨_|_⟩; dsimp; rw [category.id_comp, category.comp_id]; refl },
    { exact cones.cone_iso_of_hom_iso _ } }
end
.
noncomputable
instance Scheme.Spec.preserves_binary_coproducts :
  preserves_colimits_of_shape (discrete walking_pair) Scheme.Spec.{u} :=
begin
  apply preserves_colimits_of_shape_of_nat_iso Scheme.Spec.right_op_left_op_iso,
  apply_with preserves_colimits_of_shape_left_op { instances := ff },
  apply preserves_limits_of_shape_of_equiv (discrete.opposite _).symm _,
  constructor,
  intros K,
  apply preserves_limit_of_iso_diagram _ (diagram_iso_pair K).symm,
  exact Scheme.Spec.preserves_binary_products_right_op _ _
end

noncomputable
instance Scheme.Spec.preserves_initial :
  preserves_colimits_of_shape (discrete pempty) Scheme.Spec :=
begin
  apply preserves_colimits_of_shape_pempty_of_preserves_initial _,
  refine preserves_initial_of_iso _ (_ ≪≫ Scheme.Spec.map_iso
    (colimit.iso_colimit_cocone ⟨_, (initial_op_of_terminal CommRing.punit_is_terminal)⟩).symm),
  refine (as_iso $ empty_is_initial.to _).symm ≪≫ _,
  exact (as_iso (empty_is_initial.to (Scheme.Spec.obj (op $ CommRing.of punit))) : _)
end

noncomputable
instance {J : Type} [fintype J] : preserves_colimits_of_shape (discrete J) Scheme.Spec.{u} :=
preserves_finite_coproducts_of_preserves_binary_and_initial _ _

instance : has_finite_coproducts Scheme.{u} :=
has_finite_coproducts_of_has_coproducts.{u u} _

instance {X Y : Scheme.{u}} [is_affine X] [is_affine Y] : is_affine (X ⨿ Y) :=
is_affine_of_iso
  (coprod.map_iso X.iso_Spec Y.iso_Spec ≪≫ preserves_colimit_pair.iso Scheme.Spec _ _).hom

end algebraic_geometry


import data.list.func
import .list2d

namespace list2d

open list.func

variables {α : Type} {β : Type}

def find_indexes2d {α : Type} (P : α → Prop) [decidable_pred P] (l : list2d α) : list (ℕ × ℕ)
:= list.join (l.map_with_index (λ (y:ℕ) (row:list α),
   (list.join (row.map_with_index (λ (x:ℕ) (a:α), if P a then [(x,y)] else [])))
  ))

variables [inhabited α] [inhabited β]

lemma my_add_rearrange {n n0 : ℕ} : n + 1 + n0 = n + (n0 + 1) :=
begin rw add_assoc, rw add_comm 1 n0, end

theorem my_map_with_index_core_lemma1 (f : ℕ → α → β)
  : ∀ (n n0 : ℕ) (l : list α), n < l.length →
  f (n+n0) (get n l) ∈ list.map_with_index_core f n0 l
| _ _ [] H := by cases H
| 0 n0 (h::t) H := begin apply or.inl, simp, end
| (n+1) n0 (h::t) H := begin
  apply or.inr, simp,
  rw my_add_rearrange, apply my_map_with_index_core_lemma1,
  apply nat.lt_of_succ_lt_succ H,
end
theorem my_map_with_index_lemma1 (f : ℕ → α → β) (n : ℕ)
  : ∀ (l : list α), n < l.length →
  f n (get n l) ∈ list.map_with_index f l :=
my_map_with_index_core_lemma1 f n 0

theorem my_map_with_index_core_lemma2 (f : ℕ → α → β) (b : β)
  : ∀ (n0 : ℕ) (l : list α), b ∈ list.map_with_index_core f n0 l →
  ∃ n, b = f (n+n0) (get n l)
| _ [] H := begin simp [list.map_with_index_core] at H, exact H.elim, end
| n0 (h::t) H := begin
  simp [list.map_with_index_core] at H, cases H with H0 H1,
  { existsi 0, simp, exact H0, }, {
    cases my_map_with_index_core_lemma2 (n0+1) t H1 with n H,
    existsi n+1, simp! [my_add_rearrange, H],
  }
end

theorem my_map_with_index_lemma2 (f : ℕ → α → β) (b : β)
  : ∀ (l : list α), b ∈ list.map_with_index f l →
  ∃ n, b = f n (get n l) := my_map_with_index_core_lemma2 f b 0

theorem find_indexes2d_iff (P : α → Prop) [decidable_pred P] (Hnd : ¬ P (default α))
  : ∀ (l : list2d α) (xy : ℕ × ℕ), P (l.get2d xy) ↔ xy ∈ find_indexes2d P l :=
begin
  unfold find_indexes2d, intros l xy, cases xy with x y, unfold get2d,
  generalize Erow : (λ (y:ℕ) (row:list α),
    (list.join (row.map_with_index (λ (x:ℕ) (a:α), if P a then [(x,y)] else [])))
  ) = row_f,
  split, {
    generalize Eel : (λ (x:ℕ) (a:α), if P a then [(x,y)] else []) = el_f,
    intro H, apply list.mem_join.mpr,
    existsi row_f y (get y l), split, {
      apply my_map_with_index_lemma1,
      by_contradiction C,
      have := get_eq_default_of_le y (not_lt.mp C),
      rw this at H, simp [default] at H, exact Hnd H,
    }, {
      rw ←Erow, simp, rw Eel, existsi el_f x (get x (get y l)), split,
      apply my_map_with_index_lemma1, {
        by_contradiction C,
        have := get_eq_default_of_le x (not_lt.mp C),
        rw this at H, exact Hnd H,
      },
      rw ←Eel, simp [H],
    }
  }, {
    intros H, rcases list.mem_join.mp H with ⟨l2, H1, H2⟩, clear H,
    cases my_map_with_index_lemma2 row_f l2 l H1 with y' H1,
    rw ←Erow at H1, simp at H1,
    generalize Eel : (λ (x:ℕ) (a:α), if P a then [(x,y')] else []) = el_f,
    rw Eel at H1, rw H1 at H2,
    rcases list.mem_join.mp H2 with ⟨lxy, Hmi, Hxy⟩, clear H1 H2,
    cases my_map_with_index_lemma2 el_f lxy (get y' l) Hmi with x' Hxy',
    rw ←Eel at Hxy', rw Hxy' at Hxy, clear Hxy', simp at Hxy,
    by_cases H' : (P (get x' (get y' l))),
    { simp [H'] at Hxy, cases Hxy with Hx Hy, rw [Hx,Hy], exact H', },
    { simp [H'] at Hxy, exact false.elim Hxy, },
  }
end

end list2d


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

namespace tactic
namespace interactive

/-- A tactic for simplifying identities in not-necessarily-commutative rings.

An example:
```lean
example {R : Type*} [ring R] (a b c : R) : a * (b + c + c - b) = 2*a*c :=
by noncomm_ring
```
-/
meta def noncomm_ring :=
`[simp only [-- Expand everything out.
             add_mul, mul_add, sub_eq_add_neg,
             -- Right associate all products.
             mul_assoc,
             -- Expand powers to numerals.
             pow_bit0, pow_bit1, pow_one,
             -- Replace multiplication by numerals with `zsmul`.
             bit0_mul, mul_bit0, bit1_mul, mul_bit1, one_mul, mul_one, zero_mul, mul_zero,
             -- Pull `zsmul n` out the front so `abel` can see them.
             ←mul_zsmul_assoc, ←mul_zsmul_left,
             -- Pull out negations.
             neg_mul_eq_neg_mul_symm, mul_neg_eq_neg_mul_symm] {fail_if_unchanged := ff};
  abel]

add_tactic_doc
{ name       := "noncomm_ring",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.noncomm_ring],
  tags       := ["arithmetic", "simplification", "decision procedure"] }

end interactive
end tactic


def f (x : Nat) : IO Nat := do
IO.println "hello world"
let aux (y : Nat) (z : Nat) : IO Nat := do
  IO.println "aux started"
  IO.println s!"y: {y}, z: {z}"
  pure (x+y)
discard <| aux x
  (x + 1) -- It is part of the application since it is indented
discard <| aux x (x -- parentheses use `withoutPosition`
-1)
discard <| aux x x;
  aux x
 x

#eval f 10

def g (xs : List Nat) : StateT Nat Id Nat := do
let mut xs := xs
if xs.isEmpty then
  xs := [← get]
dbg_trace ">>> xs: {xs}"
return xs.length

#eval g [1, 2, 3] |>.run' 10
#eval g [] |>.run' 10

theorem ex1 : (g [1, 2, 4, 5] |>.run' 0) = 4 :=
rfl

theorem ex2 : (g [] |>.run' 0) = 1 :=
rfl

def h (x : Nat) (y : Nat) : Nat := Id.run <| do
let mut x := x
let mut y := y
if x > 0 then
  let y' := x + 1
  x := y'
else
  y := y + 1
return x + y

theorem ex3 (y : Nat) : h 0 y = 0 + (y + 1) :=
rfl

theorem ex4 (y : Nat) : h 1 y = (1 + 1) + y :=
rfl

def sumOdd (xs : List Nat) (threshold : Nat) : Nat := Id.run <| do
let mut sum := 0
for x in xs do
  if x % 2 == 1 then
    sum := sum + x
  if sum > threshold then
    break
  unless x % 2 == 1 do
    continue
  dbg_trace ">> x: {x}"
return sum

#eval sumOdd [1, 2, 3, 4, 5, 6, 7, 9, 11, 101] 10

theorem ex5 : sumOdd [1, 2, 3, 4, 5, 6, 7, 9, 11, 101] 10 = 16 :=
rfl

-- We need `Id.run` because we still have `Monad Option`
def find? (xs : List Nat) (p : Nat → Bool) : Option Nat := Id.run do
let mut result := none
for x in xs do
  if p x then
    result := x
    break
return result

def sumDiff (ps : List (Nat × Nat)) : Nat := Id.run do
let mut sum := 0
for (x, y) in ps do
  sum := sum + x - y
return sum

theorem ex7 : sumDiff [(2, 1), (10, 5)] = 6 :=
rfl

def f1 (x : Nat) : IO Unit := do
let rec loop : Nat → IO Unit
  | 0   => pure ()
  | x+1 => do IO.println x; loop x
loop x

#eval f1 10

partial def f2 (x : Nat) : IO Unit := do
let rec
  isEven : Nat → Bool
    | 0   => true
    | x+1 => isOdd x,
  isOdd : Nat → Bool
    | 0   => false
    | x+1 => isEven x
IO.println ("isOdd(" ++ toString x ++ "): " ++ toString (isOdd x))

#eval f2 11
#eval f2 10

def split (xs : List Nat) : List Nat × List Nat := Id.run do
let mut evens := []
let mut odds  := []
for x in xs.reverse do
  if x % 2 == 0 then
    evens := x :: evens
  else
    odds := x :: odds
return (evens, odds)

theorem ex8 : split [1, 2, 3, 4] = ([2, 4], [1, 3]) :=
rfl

def f3 (x : Nat) : IO Bool := do
let y ← cond (x == 0) (do IO.println "hello"; pure true) (pure false);
pure !y

def f4 (x y : Nat) : Nat × Nat := Id.run <| do
  let mut (x, y) := (x, y)
  match x with
  | 0 => y := y + 1
  | _ => x := x + y
  return (x, y)

#eval f4 0 10
#eval f4 5 10

theorem ex9 (y : Nat) : f4 0 y = (0, y+1) :=
rfl

theorem ex10 (x y : Nat) : f4 (x+1) y = ((x+1)+y, y) :=
rfl

def f5 (x y : Nat) : Nat × Nat := Id.run <| do
  let mut (x, y) := (x, y)
  match x with
  | 0   => y := y + 1
  | z+1 => dbg_trace "z: {z}"; x := x + y
  return (x, y)

#eval f5 5 6

theorem ex11 (x y : Nat) : f5 (x+1) y = ((x+1)+y, y) :=
rfl

def f6 (x : Nat) : Nat := Id.run <| do
  let mut x := x
  if x > 10 then
    return 0
  x := x + 1
  return x

theorem ex12 : f6 11 = 0 :=
rfl

theorem ex13 : f6 5 = 6 :=
rfl

def findOdd (xs : List Nat) : Nat := Id.run <| do
for x in xs do
  if x % 2 == 1 then
    return x
return 0

theorem ex14 : findOdd [2, 4, 5, 8, 7] = 5 :=
rfl

theorem ex15 : findOdd [2, 4, 8, 10] = 0 :=
rfl

def f7 (ref : IO.Ref (Option (Nat × Nat))) : IO Nat := do
let some (x, y) ← ref.get | pure 100
IO.println (toString x ++ ", " ++ toString y)
return x+y

def f7Test : IO Unit := do
unless (← f7 (← IO.mkRef (some (10, 20)))) == 30 do throw $ IO.userError "unexpected"
unless (← f7 (← IO.mkRef none)) == 100 do throw $ IO.userError "unexpected"

#eval f7Test

def f8 (x : Nat) : IO Nat := do
let y ←
  if x == 0 then
    IO.println "x is zero"
    return 100 --  returns from the `do`-block
  else
    pure (x + 1)
IO.println ("y: " ++ toString y)
return y

def f8Test : IO Unit := do
unless (← f8 0) == 100 do throw $ IO.userError "unexpected"
unless (← f8 1) == 2 do throw $ IO.userError "unexpected"

#eval f8Test


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

namespace tactic
namespace interactive

/-- A tactic for simplifying identities in not-necessarily-commutative rings.

An example:
```lean
example {R : Type*} [ring R] (a b c : R) : a * (b + c + c - b) = 2*a*c :=
by noncomm_ring
```
-/
meta def noncomm_ring :=
`[simp only [-- Expand everything out.
             add_mul, mul_add, sub_eq_add_neg,
             -- Right associate all products.
             mul_assoc,
             -- Expand powers to numerals.
             pow_bit0, pow_bit1, pow_one,
             -- Replace multiplication by numerals with `gsmul`.
             bit0_mul, mul_bit0, bit1_mul, mul_bit1, one_mul, mul_one, zero_mul, mul_zero,
             -- Pull `gsmul n` out the front so `abel` can see them.
             ←mul_gsmul_assoc, ←mul_gsmul_left,
             -- Pull out negations.
             neg_mul_eq_neg_mul_symm, mul_neg_eq_neg_mul_symm] {fail_if_unchanged := ff};
  abel]

add_tactic_doc
{ name       := "noncomm_ring",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.noncomm_ring],
  tags       := ["arithmetic", "simplification", "decision procedure"] }

end interactive
end tactic


import pseudo_normed_group.CLC
import prop_92.concrete

noncomputable theory

open_locale nnreal

namespace CLCFP

variables (r r' : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] (c c₁ c₂ : ℝ≥0) (n : ℕ)
variables [fact (0 < r)] [fact (0 < r')] [fact (r' ≤ 1)] [fact (c₂ ≤ r' * c₁)] [fact (c₂ ≤ c₁)]
variables (M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ)

include r

def T_inv_sub_Tinv :=
CLCFP.res V r' c₁ c₂ n ≫ CLCFP.T_inv r V r' c₂ n - CLCFP.Tinv V r' c₁ c₂ n

lemma norm_T_inv_sub_Tinv_le : ∥(T_inv_sub_Tinv r r' V c₁ c₂ n).app M∥ ≤ (1 + r⁻¹) :=
begin
  rw [T_inv_sub_Tinv, sub_eq_neg_add],
  refine le_trans (norm_add_le _ _) (add_le_add _ _),
  { rw [category_theory.nat_trans.app_neg, norm_neg],
    refine le_trans (normed_group_hom.norm_completion _).le _,
    exact normed_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.1
      (SemiNormedGroup.LocallyConstant_obj_map_norm_noninc _ _ _ _) },
  { refine normed_group_hom.norm_comp_le_of_le' 1 r⁻¹ r⁻¹ (mul_one _).symm _ _,
    { exact CLC.norm_T_inv_le r V _ },
    { exact normed_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.1
      (res_norm_noninc V r' c₁ c₂ n M) } },
end

variables {V c n M}

open profinitely_filtered_pseudo_normed_group profinitely_filtered_pseudo_normed_group_with_Tinv
  comphaus_filtered_pseudo_normed_group
open locally_constant category_theory

/-- 9.2 of Analytic.pdf -/
lemma T_inv_sub_Tinv_exists_preimage [hr1 : fact (r < 1)]
  (f : (CLCFP V r' (r' * c) n).obj M) (ε : ℝ≥0) (hε : 0 < ε) :
  ∃ g : (CLCFP V r' c n).obj M, (T_inv_sub_Tinv r r' V c (r' * c) n).app M g = f ∧
    (∥g∥ ≤ (r / (1 - r) + ε) * ∥f∥) :=
begin
  obtain ⟨g, hg1, hg2⟩ := @concrete_92 _ _ _ _ _ _ _ _
    ((FiltrationPow.cast_le _ _ _ _).app _) (embedding_cast_le _ _)
    ((FiltrationPow.Tinv r' (r' * c) c _).app _) r V _ (Tinv₀_continuous _ _) hr1 _ f ε hε,
  refine ⟨g, _, hg2⟩,
  rw ← hg1, clear hg1,
  dsimp only [T_inv_sub_Tinv, CLC, T_inv, CLC.T_inv, Tinv, CLCFP.res,
    whisker_left_app, nat_trans.app_sub, nat_trans.comp_app, whisker_right_app,
    normed_group_hom.sub_apply, whisker_right_app, functor.comp_map],
  rw [← SemiNormedGroup.Completion.map_comp,
      ← normed_group_hom.sub_apply, ← functor.map_sub],
  refl
end

variables (V c n M)

lemma T_inv_sub_Tinv_surjective [fact (r < 1)] :
  function.surjective ((T_inv_sub_Tinv r r' V c (r' * c) n).app M) :=
begin
  intros f,
  obtain ⟨g, hg, -⟩ := T_inv_sub_Tinv_exists_preimage r r' f 1 zero_lt_one,
  exact ⟨g, hg⟩
end

end CLCFP


/- This is a short tutorial on lean for the Logic in Computer Science course at the university
of Ljubljana. -/

namespace logika_v_racunalnistvu

/- Definitions of inductive types are made using the inductive keyword. Different constructors
   are separated by |. -/

inductive list (A : Type) : Type
| nil : list
| cons : A → list → list

/- We open the namespace list, so that we can use nil and cons directly. -/

namespace list

/- We will now define some basic operations on lists. -/

/- Direct definitions are made using the definition keyword, followed by := -/

definition unit {A : Type} (a : A) : list A :=
cons a nil

/- A shorthand for definition is def, which may also be used. -/

/- Since the type of lists is an inductive type, we can make inductive definitions on list
using pattern matching. The syntax is analogous to the syntax of the inductive type itself.
Note that in pattern matching definitions, we don't use := at the end of the specification. -/

def fold {A : Type} {B : Type} (b : B) (μ : A → B → B) : list A → B
| nil := b
| (cons a l) := μ a (fold l)

def map {A : Type} {B : Type} (f : A → B) : list A → list B  :=
fold nil (cons ∘ f)

def length {A : Type} : list A → ℕ :=
fold 0 (λ _ n, n + 1)

def sum_list_ℕ : list ℕ → ℕ := sorry

def concat {A : Type} : list A → list A → list A :=
fold id (λ a f l, cons a (f l))

/- The idea of the flattening operation is to transform a list of lists into an ordinary list
   by iterated concatenation. For example, we should have

   flatten (cons (cons 1 (cons 2 nil)) (cons (cons 3 nil) (cons 4 (cons 5 nil))))

   should evaluate to

   cons 1 (cons 2 (cons 3 (cons 4 (cons 5 nil))))
   -/

def flatten {A : Type} : list (list A) → list A := sorry

/- We have now finished defining our basic operations on lists. Let us check by some examples
   that the operations indeed do what they are supposed to do. With your mouse, hover over the
   #reduce keyword to see what each term reduces to. -/

#reduce concat (cons 1 (cons 2 (cons 3 nil))) (cons 4 (cons 5 nil))

#reduce flatten (cons (cons 1 (cons 2 nil)) (cons (cons 3 nil) (cons (cons 4 (cons 5 nil)) nil)))

/- Of course, if you really want to know that your operations behave as expected, you should
   prove the relevant properties about them. This is what we will do next. -/

/- When proving theorems, we can also proceed by pattern matching. In a pattern matching argument
   we can recursively call the object we are defining on earlier instances.

   The arguments that we want to pattern-match on, must appear after the colon (:) in the
   specification of the theorem. -/

theorem map_id {A : Type} :
    ∀ (x : list A), map id x = x
| nil := rfl
| (cons a x) :=
    calc
    map id (cons a x)
        = cons a (map id x) : rfl
    ... = cons a x : by rw map_id

theorem map_composition {A : Type} {B : Type} {C : Type} (f : A → B) (g : B → C) :
    ∀ (x : list A), map (g ∘ f) x = map g (map f x)
| nil := rfl
| (cons a x) :=
    calc
    map (g ∘ f) (cons a x)
        = cons (g (f a)) (map (g ∘ f) x) : rfl
    ... = cons (g (f a)) (map g (map f x)) : by rw map_composition
    ... = map g (map f (cons a x)) : rfl

/- Next, we prove some properties concatenation. Concatenation of lists is an associative
   operation, and it satisfies the left and right unit laws.universe

   In order to prove associativity, we note that since concatenation is defined by induction
   on the left argument, we will again use induction on the left argument to prove this
   propoerty. The proof is presented by pattern matching.

   In the proof we will use the built-in equation compiler. We just calculate as if we were
   working on a sheet of paper, and each time we mention the reason why the equality holds. -/

theorem assoc_concat {A : Type} :
    ∀ (x y z : list A), concat (concat x y) z = concat x (concat y z)
| nil _ _ := rfl
| (cons a l) y z :=
    calc
    concat (concat (cons a l) y) z
        = cons a (concat (concat l y) z) : by reflexivity
    ... = cons a (concat l (concat y z)) : by rw assoc_concat
    ... = concat (cons a l) (concat y z) : by reflexivity

theorem left_unit_concat {A : Type} :
    ∀ (x : list A), concat nil x = x :=
    eq.refl

theorem right_unit_concat {A : Type} :
    ∀ (x : list A), concat x nil = x
| nil := rfl
| (cons a x) :=
    show cons a (concat x nil) = cons a x,
    by rw right_unit_concat

/- Next, we prove the elementary properties of the length function. -/

theorem length_nil {A : Type} :
    length (@nil A) = 0 := rfl

theorem length_unit {A : Type} (a : A) :
    length (unit a) = 1 := rfl

theorem length_concat {A : Type} :
    ∀ (x y : list A), length (concat x y) = length x + length y
| nil y :=
    calc
    length (concat nil y)
        = length y : rfl
    ... = 0 + length y : by rw nat.zero_add
    ... = length nil + length y : by rw length_nil
| (cons a x) y :=
    calc
    length (concat (cons a x) y)
        = length (concat x y) + 1 : rfl
    ... = (length x + length y) + 1 : by rw length_concat
    ... = (length x + 1) + length y : by rw nat.succ_add
    ... = (length (cons a x)) + length y : rfl

/- Next, we prove the elemenatary properties of the flatten function. -/

theorem flatten_unit {A : Type} :
    ∀ (x : list A), flatten (unit x) = x
    := sorry

theorem flatten_map_unit {A : Type} :
    forall (x : list A), flatten (map unit x) = x
    := sorry

theorem length_flatten {A : Type} :
    ∀ (x : list (list A)), length (flatten x) = sum_list_ℕ (map length x)
    := sorry

theorem flatten_concat {A : Type} :
    ∀ (x y : list (list A)), flatten (concat x y) = concat (flatten x) (flatten y)
    := sorry

theorem flatten_flatten {A : Type} :
    ∀ (x : list (list (list A))), flatten (flatten x) = flatten (map flatten x)
    := sorry

/- This concludes our coverage of lists in Lean. -/

end list

/- Next, we study lists of a fixed length. They are a natural example of a dependent type.-/

inductive vector (A : Type) : ℕ → Type
| nil : vector 0
| cons : ∀ {n : ℕ}, A → vector n → vector (n+1)

namespace vector

def map {A : Type} {B : Type} (f : A → B) :
    ∀ {n : ℕ}, vector A n → vector B n
| 0 nil := nil
| (n+1) (cons a x) := cons (f a) (map x)

def concat {A : Type} :
    ∀ {m n : ℕ}, vector A m → vector A n → vector A (m+n)
| 0 n nil y :=
    begin
    rw nat.zero_add,
    exact y,
    end
| (m+1) n (cons a x) y :=
    begin
    rw nat.succ_add,
    exact cons a (concat x y),
    end

def head {A : Type} :
    ∀ {n : ℕ}, vector A (n+1) → A
| n (cons a x) := a

def tail {A : Type} :
    ∀ {n : ℕ}, vector A (n+1) → vector A n
| n (cons a x) := x

/- Using lists of fixed length, we can define matrices. The type
   Matrix m n A is the type of matrices with m rows and n columns
   and with coefficients in A. -/

def Matrix (m n : ℕ) (A : Type) : Type :=
vector (vector A n) m

def top_row {A : Type} {m n : ℕ} :
    Matrix (m+1) n A → vector A n :=
head

def tail_vertical {A : Type} {m n : ℕ} :
    Matrix (m+1) n A → Matrix m n A :=
tail

def left_column {A : Type} {m n : ℕ} :
    Matrix m (n+1) A → vector A m :=
map head

def tail_horizontal {A : Type} {m n : ℕ} :
    Matrix m (n+1) A → Matrix m n A :=
map tail

/- Since matrices are rectangular, we have a horizontal as well as vertical empty matrices. -/

def nil_vertical {A : Type} {n : ℕ} : Matrix 0 n A := nil

theorem eq_nil_vertical {A : Type} :
    ∀ {n : ℕ} (x : Matrix 0 n A), x = nil_vertical
| 0 nil := rfl
| (n+1) nil := rfl

def nil_horizontal {A : Type} : ∀ {m : ℕ}, Matrix m 0 A
| 0 := nil
| (m+1) := cons nil nil_horizontal

theorem eq_nil_horizontal {A : Type} :
    ∀ {m : ℕ} (x : Matrix m 0 A), x = nil_horizontal
| 0 nil := rfl
| (m+1) (cons nil M) :=
    calc
    cons nil M
        = cons nil nil_horizontal : by rw eq_nil_horizontal M
    ... = nil_horizontal : rfl

/- Similarly, there is a horizontal cons and a vertical cons. -/

/- cons_vertical adds a new row from the top. -/

def cons_vertical {A : Type} {m n : ℕ} :
    vector A n → Matrix m n A → Matrix (m+1) n A :=
cons

/- cons_horizontal adds a new column from the left. -/

def cons_horizontal {A : Type} :
    ∀ {m n : ℕ}, vector A m → Matrix m n A → Matrix m (n+1) A
| 0 n nil M := nil
| (m+1) n (cons a x) M :=
    cons (cons a (top_row M)) (cons_horizontal x (tail_vertical M))

/- We define the transposition of a matrix. -/

def transpose {A : Type} :
    ∀ {m n : ℕ}, Matrix m n A → Matrix n m A
| 0 n M := nil_horizontal
| (m+1) n (cons x M) := cons_horizontal x (transpose M)

/- The following two theorems show how transpose interacts with the basic operations on
   matrices. These will help to show that transposition is an involution. -/

theorem transpose_cons_horizontal {A : Type} :
    ∀ {m n : ℕ} (x : vector A m) (M : Matrix m n A),
    transpose (cons_horizontal x M) = cons_vertical x (transpose M)
    := sorry

theorem transpose_cons_vertical {A : Type} :
    ∀ {m n : ℕ} (x : vector A n) (M : Matrix m n A),
    transpose (cons_vertical x M) = cons_horizontal x (transpose M)
    := sorry

/- We finally show that transposition is an involution. -/

theorem transpose_transpose {A : Type} :
    ∀ {m n : ℕ} (M : Matrix m n A), transpose (transpose M) = M
    := sorry

end vector

end logika_v_racunalnistvu