import logic

universes u v
open_locale logic_symbol
namespace logic
section

class translation (α : Type u) (β : Type v) :=
(tr : α → β)

namespace translation
variables (α : Type*) (β : Type*) (γ : Type*)

instance : translation α α := ⟨id⟩

def comp [translation α β] [translation β γ] : translation α γ := ⟨(tr : β → γ) ∘ (tr : α → β)⟩

end translation

end

variables (F : Type u) (G : Type v) [has_logic_symbol F] [has_logic_symbol G]

set_option old_structure_cmd true
structure homomorphism :=
(to_fun : F → G)
(map_neg' : ∀ a, to_fun (∼a) = ∼to_fun a)
(map_imply' : ∀ a b, to_fun (a ⟶ b) = to_fun a ⟶ to_fun b)
(map_and' : ∀ a b, to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)
(map_or' : ∀ a b, to_fun (a ⊔ b) = to_fun a ⊔ to_fun b)
(map_top' : to_fun ⊤ = ⊤)
(map_bot' : to_fun ⊥ = ⊥)

infix ` →ₗ `:25 := homomorphism
#check homomorphism

instance : has_coe_to_fun (F →ₗ G) (λ _, F → G) := ⟨homomorphism.to_fun⟩

namespace homomorphism
variables {F} {G} (f g : F →ₗ G) (a b : F)

lemma eq_to_fun (a : F) : f a = f.to_fun a := rfl

@[simp] lemma eq_to_fun' {f map_neg' map_imply' map_and' map_or' map_top' map_bot'} (a : F) :
 ({ to_fun := f, map_neg' := map_neg', map_imply' := map_imply',
    map_and' := map_and', map_or' := map_or', map_top' := map_top', map_bot' := map_bot' } : F →ₗ G) a = f a := rfl

@[ext] lemma ext (h : ∀ x, f x = g x) : f = g :=
by rcases f; rcases g; simp; funext x; by simpa using h x

@[simp] lemma map_neg : f (∼a) = ∼f a := map_neg' f a

@[simp] lemma map_imply : f (a ⟶ b) = f a ⟶ f b := map_imply' f a b

@[simp] lemma map_and : f (a ⊓ b) = f a ⊓ f b := map_and' f a b

@[simp] lemma map_or : f (a ⊔ b) = f a ⊔ f b := map_or' f a b

@[simp] lemma map_top : f ⊤ = ⊤ := map_top' f

@[simp] lemma map_bot : f ⊥ = ⊥ := map_bot' f

@[simp] lemma map_iff : f (a ⟷ b) = f a ⟷ f b := by simp[lrarrow_def]

@[simp] lemma map_list_disjunction (P : list F) :
  f P.disjunction = (P.map f).disjunction :=
by induction P; simp*

@[simp] lemma map_list_conjunction (P : list F) :
  f P.conjunction = (P.map f).conjunction :=
by induction P; simp*

@[simp] lemma map_finitary_disjunction {n} (P : finitary F n) :
  f (finitary.disjunction n P) = ⋁ i, f (P i) :=
by induction n with n IH; simp*

@[simp] lemma map_finitary_conjunction {n} (P : finitary F n) :
  f (finitary.conjunction n P) = ⋀ i, f (P i) :=
by induction n with n IH; simp*

protected def id : F →ₗ F :=
{ to_fun := id,
  map_neg' := by simp,
  map_imply' := by simp,
  map_and' := by simp,
  map_or' := by simp,
  map_top' := by simp,
  map_bot' := by simp }

@[simp] lemma app_id (a : F) : homomorphism.id a = a := by refl

variables {F₁ : Type*} {F₂ : Type*} {F₃ : Type*}
  [has_logic_symbol F₁] [has_logic_symbol F₂] [has_logic_symbol F₃]
  (f₂ : F₂ →ₗ F₃) (f₁ : F₁ →ₗ F₂)

def comp : F₁ →ₗ F₃ :=
{ to_fun := f₂.to_fun ∘ f₁.to_fun,
  map_neg' := by simp[←eq_to_fun],
  map_imply' := by simp[←eq_to_fun],
  map_and' := by simp[←eq_to_fun],
  map_or' := by simp[←eq_to_fun],
  map_top' := by simp[←eq_to_fun],
  map_bot' := by simp[←eq_to_fun] }

@[simp] lemma app_comp (a) : (f₂.comp f₁) a = f₂ (f₁ a) :=
by simp[eq_to_fun, comp]

section prop

instance : has_logic_symbol Prop :=
{ arrow := (→),
  neg := not }

@[simp] lemma top_to_true : (⊤ : Prop) ↔ true := by refl

@[simp] lemma bot_to_false : (⊥ : Prop) ↔ false := by refl

@[simp] lemma arrow_to_to (p q : Prop) : (p ⟶ q) ↔ (p → q) := by refl

@[simp] lemma lrarrow_to_iff (p q : Prop) : (p ⟷ q) ↔ (p ↔ q) := by simp[lrarrow_def]; exact iff_def.symm

@[simp] lemma neg_to_not (p : Prop) : ∼p ↔ ¬p := by refl

@[simp] lemma prop_finitary_conj {n} (p : finitary Prop n) : finitary.conjunction n p ↔ ∀ x, p x :=
by{ induction n with n IH, { simp },
    { simp[IH], split,
      { rintros ⟨hlast, h⟩, intros x, refine fin.last_cases hlast h x },
      { rintros h, simp[h] } } }

@[simp] lemma prop_finitary_disj {n} (p : finitary Prop n) : finitary.disjunction n p ↔ ∃ x, p x :=
by{ induction n with n IH, { simp },
    { simp[IH], split,
      { rintros (⟨_, h⟩ | hlast), { exact ⟨_, h⟩ }, { exact ⟨_, hlast⟩ } },
      { rintros ⟨x, h⟩, rcases fin.eq_last_or_eq_cast_succ x with (rfl | ⟨x, rfl⟩),
        { exact or.inr h }, { exact or.inl ⟨x, h⟩ } } } }

@[simp] lemma prop_list_conj {α} (l : list α) (p : α → Prop) : list.conjunction (l.map p) ↔ ∀ a ∈ l, p a :=
by induction l with a l IH; simp*

@[simp] lemma prop_list_disj {α} (l : list α) (p : α → Prop) : list.disjunction (l.map p) ↔ ∃ a ∈ l, p a :=
begin
  induction l with a l IH; simp*,
  split,
  { rintros (⟨b, hl, hb⟩ | h),
    { refine ⟨b, by simp[hb, hl]⟩ },
    { exact ⟨a, by simp[h]⟩ } },
  { rintros ⟨b, (rfl | hl), hb⟩, { simp[hb] }, { exact or.inl ⟨b, hl, hb⟩ } }
end

end prop

end homomorphism

variables (F G)

class iso :=
(to_fun : F →ₗ G)
(inv_fun : G →ₗ F)
(left_inv : function.left_inverse inv_fun to_fun)
(right_inv : function.right_inverse inv_fun to_fun)

namespace iso
variables {F G} [iso F G] {a a₁ a₂ a₃ : F} {b b₁ b₂ b₃ : G}

instance coe : has_coe F G := ⟨to_fun⟩

instance inv_coe : has_coe G F := ⟨inv_fun⟩

@[simp] lemma to_fun_inv_fun : ((a : G) : F) = a := left_inv a

@[simp] lemma inv_fun_to_fun : ((b : F) : G) = b := right_inv b

lemma coe_to_fun (a : F) : (a : G) = to_fun a := rfl

lemma coe_inv_fun (b : G) : (b : F) = inv_fun b := rfl

@[simp] lemma coe_neg : (↑(∼a) : G) = ∼(a : G) := by simp[coe_to_fun]

@[simp] lemma inv_coe_neg : (↑(∼b) : F) = ∼(b : F) := by simp[coe_inv_fun]

end iso

variables {Ω : Type u} (Φ : Ω → Type v) [∀ L, has_logic_symbol (Φ L)] [∀ L, axiomatic_classical_logic (Φ L)]

structure system :=
(language : Ω)
(theory : Theory (Φ language))

class system_has_le :=
(language_translation {} : Ω → Ω → Type*)
(sentence_translation : Π {L₁ L₂ : Ω}, language_translation L₁ L₂ → (Φ L₁ →ₗ Φ L₂))
(provability_translation : Π {L₁ L₂ : Ω} {l : language_translation L₁ L₂} {T : Theory (Φ L₁)} {p : Φ L₁},
  T ⊢ p → sentence_translation l '' T ⊢ sentence_translation l p)

namespace system
open system_has_le
variables {Φ} [system_has_le Φ] (S₁ S₂ : system Φ)

structure le :=
(tr : language_translation Φ S₁.language S₂.language)
(h : ∀ p ∈ S₁.theory, S₂.theory ⊢ sentence_translation tr p)

end system

end logic


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.reverse
import Mathlib.algebra.associated
import Mathlib.tactic.omega.default
import Mathlib.PostPort

universes u v y

namespace Mathlib

/-!
# Theory of monic polynomials

We give several tools for proving that polynomials are monic, e.g.
`monic_mul`, `monic_map`.
-/

namespace polynomial

theorem monic.as_sum {R : Type u} [semiring R] {p : polynomial R} (hp : monic p) :
    p =
        X ^ nat_degree p +
          finset.sum (finset.range (nat_degree p)) fun (i : ℕ) => coe_fn C (coeff p i) * X ^ i :=
  sorry

theorem ne_zero_of_monic_of_zero_ne_one {R : Type u} [semiring R] {p : polynomial R} (hp : monic p)
    (h : 0 ≠ 1) : p ≠ 0 :=
  sorry

theorem ne_zero_of_ne_zero_of_monic {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R}
    (hp : p ≠ 0) (hq : monic q) : q ≠ 0 :=
  sorry

theorem monic_map {R : Type u} {S : Type v} [semiring R] {p : polynomial R} [semiring S]
    (f : R →+* S) (hp : monic p) : monic (map f p) :=
  sorry

theorem monic_mul_C_of_leading_coeff_mul_eq_one {R : Type u} [semiring R] {p : polynomial R}
    [nontrivial R] {b : R} (hp : leading_coeff p * b = 1) : monic (p * coe_fn C b) :=
  sorry

theorem monic_of_degree_le {R : Type u} [semiring R] {p : polynomial R} (n : ℕ) (H1 : degree p ≤ ↑n)
    (H2 : coeff p n = 1) : monic p :=
  sorry

theorem monic_X_pow_add {R : Type u} [semiring R] {p : polynomial R} {n : ℕ} (H : degree p ≤ ↑n) :
    monic (X ^ (n + 1) + p) :=
  sorry

theorem monic_X_add_C {R : Type u} [semiring R] (x : R) : monic (X + coe_fn C x) :=
  pow_one X ▸ monic_X_pow_add degree_C_le

theorem monic_mul {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R} (hp : monic p)
    (hq : monic q) : monic (p * q) :=
  sorry

theorem monic_pow {R : Type u} [semiring R] {p : polynomial R} (hp : monic p) (n : ℕ) :
    monic (p ^ n) :=
  sorry

theorem monic_add_of_left {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R}
    (hp : monic p) (hpq : degree q < degree p) : monic (p + q) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (monic (p + q))) (monic.equations._eqn_1 (p + q))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (leading_coeff (p + q) = 1)) (add_comm p q)))
      (eq.mpr
        (id (Eq._oldrec (Eq.refl (leading_coeff (q + p) = 1)) (leading_coeff_add_of_degree_lt hpq)))
        hp))

theorem monic_add_of_right {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R}
    (hq : monic q) (hpq : degree p < degree q) : monic (p + q) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (monic (p + q))) (monic.equations._eqn_1 (p + q))))
    (eq.mpr
      (id (Eq._oldrec (Eq.refl (leading_coeff (p + q) = 1)) (leading_coeff_add_of_degree_lt hpq)))
      hq)

namespace monic

@[simp] theorem degree_eq_zero_iff_eq_one {R : Type u} [semiring R] {p : polynomial R}
    (hp : monic p) : nat_degree p = 0 ↔ p = 1 :=
  sorry

theorem nat_degree_mul {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R}
    (hp : monic p) (hq : monic q) : nat_degree (p * q) = nat_degree p + nat_degree q :=
  sorry

theorem next_coeff_mul {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R}
    (hp : monic p) (hq : monic q) : next_coeff (p * q) = next_coeff p + next_coeff q :=
  sorry

end monic

theorem monic_prod_of_monic {R : Type u} {ι : Type y} [comm_semiring R] (s : finset ι)
    (f : ι → polynomial R) (hs : ∀ (i : ι), i ∈ s → monic (f i)) :
    monic (finset.prod s fun (i : ι) => f i) :=
  finset.prod_induction (fun (x : ι) => f x) monic monic_mul monic_one hs

theorem is_unit_C {R : Type u} [comm_semiring R] {x : R} : is_unit (coe_fn C x) ↔ is_unit x := sorry

theorem eq_one_of_is_unit_of_monic {R : Type u} [comm_semiring R] {p : polynomial R} (hm : monic p)
    (hpu : is_unit p) : p = 1 :=
  sorry

theorem monic.next_coeff_prod {R : Type u} {ι : Type y} [comm_semiring R] (s : finset ι)
    (f : ι → polynomial R) (h : ∀ (i : ι), i ∈ s → monic (f i)) :
    next_coeff (finset.prod s fun (i : ι) => f i) = finset.sum s fun (i : ι) => next_coeff (f i) :=
  sorry

theorem monic_X_sub_C {R : Type u} [ring R] (x : R) : monic (X - coe_fn C x) := sorry

theorem monic_X_pow_sub {R : Type u} [ring R] {p : polynomial R} {n : ℕ} (H : degree p ≤ ↑n) :
    monic (X ^ (n + 1) - p) :=
  sorry

/-- `X ^ n - a` is monic. -/
theorem monic_X_pow_sub_C {R : Type u} [ring R] (a : R) {n : ℕ} (h : n ≠ 0) :
    monic (X ^ n - coe_fn C a) :=
  sorry

theorem monic_sub_of_left {R : Type u} [ring R] {p : polynomial R} {q : polynomial R} (hp : monic p)
    (hpq : degree q < degree p) : monic (p - q) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (monic (p - q))) (sub_eq_add_neg p q)))
    (monic_add_of_left hp
      (eq.mpr (id (Eq._oldrec (Eq.refl (degree (-q) < degree p)) (degree_neg q))) hpq))

theorem monic_sub_of_right {R : Type u} [ring R] {p : polynomial R} {q : polynomial R}
    (hq : leading_coeff q = -1) (hpq : degree p < degree q) : monic (p - q) :=
  sorry

theorem leading_coeff_of_injective {R : Type u} {S : Type v} [ring R] [semiring S] {f : R →+* S}
    (hf : function.injective ⇑f) (p : polynomial R) :
    leading_coeff (map f p) = coe_fn f (leading_coeff p) :=
  sorry

theorem monic_of_injective {R : Type u} {S : Type v} [ring R] [semiring S] {f : R →+* S}
    (hf : function.injective ⇑f) {p : polynomial R} (hp : monic (map f p)) : monic p :=
  sorry

@[simp] theorem not_monic_zero {R : Type u} [semiring R] [nontrivial R] : ¬monic 0 := sorry

theorem ne_zero_of_monic {R : Type u} [semiring R] [nontrivial R] {p : polynomial R} (h : monic p) :
    p ≠ 0 :=
  fun (h₁ : p = 0) => not_monic_zero (h₁ ▸ h)

end Mathlib


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

definition {u v} transport {A : Type u} { P : A → Type v} {x y : A} (u : P x) (p : x = y) : P y :=
by induction p; exact u

@[simp] lemma {u v} congr_arg_refl {α : Sort u} {β : Sort v} (f : α → β) (a : α) : congr_arg f (eq.refl a) = eq.refl (f a) :=
begin
  refl,
end

@[simp] lemma {u v} congr_fun_refl {α : Sort u} {β : Sort v} (f : α → β) (a : α) : congr_fun (eq.refl f) a = eq.refl (f a) :=
begin
  refl,
end

@[simp] lemma {u v} congr_refl_arg {α : Sort u} {f₁ f₂ : α → Prop} (h₁ : f₁ = f₂) (a : α) : congr h₁ (eq.refl a) = congr_fun h₁ a :=
begin
  refl,
end

@[simp] lemma {u v} congr_refl_fun {α : Sort u} {f : α → Prop} (a b : α) (h : a = b) : congr (eq.refl f) h = congr_arg f h :=
begin
  refl,
end

@[simp] lemma symm_propext {a b : Prop} (p : a ↔ b) : eq.symm (propext p) = propext (p.symm) := by refl

@[simp] lemma {u} symm_refl {α : Sort u} (a : α) : eq.symm (eq.refl a) = eq.refl a := by refl

@[simp] lemma {u v} symm_congr {α : Sort u} {β : Sort v} {f g : α → β} (h : f = g) {a b : α} (h' : a = b) : eq.symm (congr h h') = congr (eq.symm h) (eq.symm h') :=
begin
  refl,
end

@[simp] lemma {u v} symm_congr_fun {α : Sort u} {β : α → Sort v} {f g : Π x, β x} (h : f = g) (a : α) : eq.symm (congr_fun h a) = congr_fun (eq.symm h) a :=
begin
  refl,
end

@[simp] lemma {u v} symm_congr_arg {α : Sort u} {β : Sort v} {f : α → β} (a b : α) (h : a = b) : eq.symm (congr_arg f h) = congr_arg f (eq.symm h) :=
begin
  refl,
end

@[simp] lemma {u} symm_trans (a b c : Prop) (p : a = b) (q : b = c) : @eq.symm Prop a c (eq.trans p q) = @eq.trans Prop c b a (eq.symm q) (eq.symm p) := by refl

@[simp] lemma {u v w} eq.rec.congr_arg {α : Sort u} {β : Sort v} (f : α → β) {x y : α}  {C : β → Sort w} (p : C (f x)) (w : x = y): @eq.rec β (f x) C p _ (congr_arg f w) = @eq.rec α x (λ z, C (f z)) p _ w :=
begin
  induction w,
  refl,
end

@[simp] lemma {u v} parallel_transport_for_trivial_bundles {α : Sort u} {a b : α} {β : Sort v} (p : a = b) (x : β) : @eq.rec α a (λ a, β) x b p = x :=
begin
  induction p,
  refl,
end

@[simp] lemma {u l} eq.rec.trans {a b c : Prop} {C : Prop → Sort l} (z : C a) (p : a = b) (q : b = c) : @eq.rec _ a C z c (eq.trans p q) = @eq.rec _ b C (@eq.rec _ a C z b p) c q :=
begin
  induction p,
  induction q,
  refl,
end

@[simp] lemma {u} eq.rec.refl {α : Sort u} (a : α) (p : true = (a = a)): @eq.rec Prop true (λ (_x : Prop), _x) trivial (@eq α a a) p = eq.refl a := by refl

@[simp] lemma eq.mpr.trans {α β γ: Prop} (p : α = β) (q : β = γ) (g : γ) : eq.mpr (eq.trans p q) g = eq.mpr p (eq.mpr q g) :=
begin
  induction p,
  induction q,
  refl,
end

@[simp] lemma {u} eq.mpr.propext {α : Sort u} (a : α) : eq.mpr (propext (eq_self_iff_true a)) trivial = eq.refl a :=
begin
  refl,
end

@[simp] lemma {u} eq.mpr.refl {α : Sort u} (a b : α) (p : a = b) : (eq.mpr (congr_fun (congr_arg eq p) b) (eq.refl b)) = p :=
begin
  induction p,
  refl,
end


import Mathlib.Algebra.Ring.Basic
import ECTate.Algebra.CharP.Basic

/-- A perfect ring is one where raising to the power of the ring characteristic is a bijection
-/
class PerfectRing (R : Type _) [CommSemiring R] :=
(pth_power_bijective : ring_char R = 0 ∨ Function.Bijective (fun x : R => x ^ (ring_char R)))

namespace PerfectRing
variable {R : Type _} [CommSemiring R]

lemma pth_power_bijective_of_char_nonzero [PerfectRing R] (h : ring_char R ≠ 0) :
  Function.Bijective (fun x : R => x ^ (ring_char R)) :=
Or.resolve_left pth_power_bijective h

noncomputable
def pth_root [PerfectRing R] : R → R :=
if h : ring_char R = 0 then id else Function.surjInv (pth_power_bijective_of_char_nonzero h).2

lemma pth_root_pow_char [PerfectRing R] (h : ring_char R ≠ 0) (x : R) :
  pth_root x ^ (ring_char R) = x :=
by
  simp only [pth_root, h, dite_false]
  exact Function.rightInverse_surjInv (pth_power_bijective_of_char_nonzero h).2 x

@[simp]
lemma pth_root_zero [PerfectRing R] : pth_root (0 : R) = 0 :=
by
  rw [pth_root]
  split
  . simp
  . sorry

end PerfectRing


import tactic -- hide

/-
If we know `P`, and we also know `P → Q`, we can deduce `Q`.
This is called "Modus Ponens" by logicians.
-/

/- Lemma
If $P$ is true and $P \implies Q$ is true, then $Q$ is true.
-/
lemma Modus_Ponens (P Q : Prop) : P → (P → Q) → Q :=
begin
  intros hP hPQ,
  apply hPQ,
  exact hP,

end


import tactic.find tactic.ring data.int.basic data.fintype data.nat.modeq data.set.finite data.nat.prime algebra.ordered_ring
universe u
local attribute [instance, priority 0] classical.prop_decidable

open fintype finset

private noncomputable def fintype_subtype {α : Type*} (p : α → Prop) [fintype α] : fintype {a // p a} :=
set_fintype p
local attribute [instance] fintype_subtype

noncomputable lemma fintype_of_injective {α β : Type*} {f : α → β} [fintype β]
  (hf : function.injective f) : fintype α :=
if h : nonempty α
then have i : inhabited α := classical.inhabited_of_nonempty h,
  of_surjective (@function.inv_fun _ i _ f) $ @function.inv_fun_surjective _ i _ _ hf
else ⟨∅, λ x, h ⟨x⟩⟩

lemma bijective_of_involution {α : Type*} {f : α → α} (hf : ∀ x, f (f x) = x) : function.bijective f :=
⟨λ x y hxy, by rw [← hf x, ← hf y, hxy], λ x, ⟨f x, hf x⟩⟩

lemma int.coe_nat_nonneg (n : ℕ) : (0 : ℤ) ≤ n := int.coe_nat_le_coe_nat_of_le $ nat.zero_le n

lemma finset_even_card_of_involution {α : Type*} {f : α → α} (s : finset α) : (∀ x ∈ s, f x ≠ x)
    → (∀ x ∈ s, f (f x) = x) → (∀ x : α, x ∈ s → f x ∈ s) → 2 ∣ card s :=
finset.strong_induction_on s $ λ s ht hf₁ hf₂ hs, or.by_cases (decidable.em (s = ∅)) (by simp {contextual := tt}) $
λ h, let ⟨x, hx⟩ := exists_mem_of_ne_empty h in
let t := filter (λ y, y ≠ x ∧ y ≠ f x) s in
have hts : t ⊂ s := ⟨filter_subset _, λ h, by have := subset_iff.1 h hx; simp * at *⟩,
have ht₂ : ∀ y, y ∈ t → f y ∈ t := λ y hyt,
  have hys : y ∈ s := mem_of_subset hts.1 hyt,
  have h₁ : f y ≠ x := λ h₂,
    have h₃ : y = f x := by rw [← h₂, hf₂ _ hys],
    by rw h₃ at hyt; simp * at *,
  have h₂ : f y ≠ f x := λ h₂,
    have hxy : y = x := by rw [← hf₂ _ hys, ← hf₂ _ hx, h₂],
    by simpa [hxy] using hyt,
  by simp * at *,
have hst : s = insert (f x) (insert x t) :=
  ext.2 $ λ z, ⟨λ h, by simp [*, or_iff_not_and_not] at * {contextual := tt},
  λ h, by rw [mem_insert, mem_insert] at h; exact or.by_cases h (λ h, h.symm ▸ hs _ hx)
  (λ h, or.by_cases h (λ h, h.symm ▸ hx) (λ h, mem_of_subset hts.1 h))⟩,
have hxt : x ∉ t := by simp [t],
have hfxt : f x ∉ insert x t := by simp [t, hf₁ x hx],
have hft₁ : ∀ y ∈ t, f y ≠ y := λ y hyt, hf₁ y (mem_of_subset hts.1 hyt),
have hft₂ : ∀ y ∈ t, f (f y) = y := λ y hyt, hf₂ y (mem_of_subset hts.1 hyt),
by rw [hst, card_insert_of_not_mem hfxt, card_insert_of_not_mem hxt, add_assoc];
  exact (nat.dvd_add_iff_right (ht _ hts hft₁ hft₂ ht₂)).1 dec_trivial

lemma fintype_even_card_of_involution {α : Type*} {f : α → α} [fintype α] (hf₁ : ∀ x : α, f x ≠ x)
    (hf₂ : ∀ x : α, f (f x) = x) : 2 ∣ card α :=
finset_even_card_of_involution _ (λ x hx, hf₁ x) (λ x hx, hf₂ x) (λ x hx, mem_univ _)

lemma set.card_univ {α : Type*} [fintype α] :  fintype.card (set.univ : set α) = fintype.card α :=
card_congr ⟨λ a, a.1, λ a, ⟨a, set.mem_univ _⟩, λ ⟨_, _⟩, rfl, λ _, rfl⟩
#print set.card_univ

lemma odd_card_of_involution_of_unique_fixed_point {α : Type*} {f : α → α} [fintype α]
    (hf₂ : ∀ x : α, f (f x) = x) (hf₃ : ∃! a : α, f a = a) : card α % 2 = 1 :=
let ⟨a, (ha₁ : f a = a), ha₂⟩ := hf₃ in
let f' : {b : α // b ≠ a} → {b : α // b ≠ a} :=
λ x, ⟨f x, λ h, x.2 ((bijective_of_involution hf₂).1 (h.trans ha₁.symm))⟩ in
have hf'₁ : ∀ x, f' x ≠ x := λ ⟨x, hx⟩ hx',
  have hx₂ : f x = x := subtype.mk.inj hx',
  hx (ha₂ x hx₂),
have hf'₂ : ∀ x, f' (f' x) = x := λ ⟨x, hx⟩, subtype.eq (hf₂ x),
have hab : a ∉ {b : α | b ≠ a} := by simp,
have hα : fintype.card α = fintype.card {b : α | b ≠ a} + 1 :=
  by rw [← set.card_fintype_insert' _ hab, ← set.card_univ];
  congr;
  exact set.ext (λ x, by simp [classical.em]),
let ⟨c, (hc : card {b : α | b ≠ a} = c * 2)⟩ := exists_eq_mul_left_of_dvd
    (fintype_even_card_of_involution hf'₁ hf'₂) in
by rw [hα, hc, add_comm]; exact nat.add_mul_mod_self_right _ _ _

lemma exists_fixed_point_of_involution_of_odd_card {α : Type*} {f : α → α} [fintype α]
    (ha : card α % 2 = 1) (hf₂ : ∀ x : α, f (f x) = x) : ∃ x, f x = x :=
by_contradiction $ λ hf₁, (dec_trivial : 0 ≠ 1) $ (nat.mod_eq_zero_of_dvd
(fintype_even_card_of_involution (forall_not_of_not_exists hf₁) hf₂)).symm.trans ha

open nat

private def S (p : ℕ) : set (ℤ × ℤ × ℤ) := {v | ((v.1) * (v.1) + 4 * v.2.1 * v.2.2 = ↑p)
    ∧ 0 ≤ v.1 ∧ 0 ≤ v.2.1 ∧ 0 ≤ v.2.2}

lemma nat.prime_not_square (n : ℕ) : ¬prime (n * n) :=
λ h, or.by_cases (h.2 _ $ dvd_mul_right n n)
(λ h₁, (dec_trivial : ¬ 1 ≥ 2) (h₁ ▸ h : prime (1 * 1)).1) $
λ h₁, have h₂ : n * 1 = n * n := by rwa mul_one,
have h₃ : 1 = n := (@nat.mul_left_inj n 1 n (prime.pos (h₁.symm ▸ h))).1 h₂,
(dec_trivial : ¬ 1 ≥ 2) (h₃.symm ▸ h : prime (1 * 1)).1

@[reducible] private def f₁ : ℤ × ℤ × ℤ → ℤ × ℤ × ℤ := λ ⟨x, y, z⟩, (x, z, y)

@[reducible] private def f₂ : ℤ × ℤ × ℤ → ℤ × ℤ × ℤ :=
λ ⟨x, y, z⟩, if x + z < y
  then (x + 2 * z, z, y - x - z)
  else (if 2 * y < x
      then (x - 2 * y, x - y + z, y)
      else (2 * y - x, y, x - y + z))

variables {p : ℕ} (hp : prime p) (hp₁ : p % 4 = 1)
include hp hp₁

private lemma x_pos : ∀ v : ℤ × ℤ × ℤ, v ∈ S p → (0 : ℤ) < v.1 :=
λ ⟨x, y, z⟩ ⟨hv, hx, hy, hz⟩,
lt_of_le_of_ne hx $ λ (h : 0 = x), have hp₂ : 4 * y * z = p := by simp [h.symm, hv.symm],
absurd (show (4 : ℤ) ∣ -1, from add_sub_cancel' (4 * (y * z)) (-1 : ℤ) ▸
dvd_sub (mul_assoc 4 y z ▸ hp₂.symm ▸ modeq.dvd_of_modeq hp₁.symm) (dvd_mul_right _ _)) dec_trivial

private lemma yz_pos : ∀ v : ℤ × ℤ × ℤ, v ∈ S p → (0 : ℤ) < v.2.1 ∧ (0 : ℤ) < v.2.2 :=
λ ⟨x, y, z⟩ ⟨hv, hx, hy, hz⟩,
have hxx : ↑p ≠ x * x := @int.nat_abs_mul_self x ▸ (λ h, nat.prime_not_square (int.nat_abs x)
  (by rwa ← int.coe_nat_inj h)),
⟨lt_of_le_of_ne hy $ λ (h : 0 = y), hxx $ eq.symm (by simpa [h.symm] using hv),
lt_of_le_of_ne hz $ λ (h : 0 = z), hxx $ eq.symm (by simpa [h.symm] using hv)⟩

private lemma v_lt_p_add_one : ∀ v : ℤ × ℤ × ℤ, v ∈ S p → int.nat_abs v.1 < p + 1 ∧
    int.nat_abs v.2.1 < p + 1 ∧ int.nat_abs v.2.2 < p + 1 :=
λ ⟨x, y, z⟩ ⟨(hv : x * x + 4 * y * z = p), (hx : 0 ≤ x), (hy : 0 ≤ y), (hz : 0 ≤ z)⟩,
begin
  suffices : (int.nat_abs x : ℤ) ≤ p ∧ (int.nat_abs y : ℤ) ≤ p ∧ (int.nat_abs z : ℤ) ≤ p,
    repeat {rw int.coe_nat_le at this},
    exact ⟨lt_succ_of_le this.1, lt_succ_of_le this.2.1, lt_succ_of_le this.2.2⟩,
  have hyz := yz_pos hp hp₁ (x, y, z) ⟨hv, hx, hy, hz⟩,
  rw [← int.nat_abs_mul_self, ← int.nat_abs_of_nonneg hy, ← int.nat_abs_of_nonneg hz] at hv,
  rw ← hv,
  exact ⟨le_add_of_le_of_nonneg (int.coe_nat_le.2 $ le_mul_self _)
      (mul_nonneg (mul_nonneg dec_trivial (int.coe_nat_nonneg _)) (int.coe_nat_nonneg _)),
    le_add_of_nonneg_of_le (int.coe_nat_nonneg _) (by rw mul_right_comm;
      exact le_mul_of_ge_one_left' (int.coe_nat_nonneg _) (@int.add_one_le_of_lt 0 _ $
      mul_pos (dec_trivial : (4 : ℤ) > 0) $ by rw int.nat_abs_of_nonneg hz; exact hyz.2)),
    le_add_of_nonneg_of_le (int.coe_nat_nonneg _)
      (le_mul_of_ge_one_left' (int.coe_nat_nonneg _) (@int.add_one_le_of_lt 0 _
      (mul_pos (dec_trivial : (4 : ℤ) > 0) (by rw int.nat_abs_of_nonneg hy; exact hyz.1))))⟩
end

private noncomputable lemma fintype_S : fintype (S p) :=
fintype_of_injective $ show function.injective (λ v, ⟨⟨int.nat_abs v.1.1,
(v_lt_p_add_one hp hp₁ v.1 v.2).1⟩, ⟨int.nat_abs v.1.2.1, (v_lt_p_add_one hp hp₁ v.1 v.2).2.1⟩,
⟨int.nat_abs v.1.2.2, (v_lt_p_add_one hp hp₁ v.1 v.2).2.2⟩⟩ :
S p → fin (p+1) × fin (p+1) × fin (p+1)), from λ ⟨⟨a₁, a₂, a₃⟩, ⟨ha, ha₁, ha₂, ha₃⟩⟩
⟨⟨b₁, b₂, b₃⟩, ⟨hb, hb₁, hb₂, hb₃⟩⟩ h,
have h : int.nat_abs a₁ = int.nat_abs b₁ ∧ int.nat_abs a₂ = int.nat_abs b₂
  ∧ int.nat_abs a₃ = int.nat_abs b₃ := by simpa [subtype.mk.inj_eq,
    iff.intro fin.veq_of_eq fin.eq_of_veq] using h,
subtype.eq $ by
  repeat {rw [← int.coe_nat_eq_coe_nat_iff, int.nat_abs_of_nonneg, int.nat_abs_of_nonneg] at h};
  finish

private lemma f₁_S : ∀ v : ℤ × ℤ × ℤ, v ∈ S p → f₁ v ∈ S p :=
λ ⟨x, y, z⟩, by simp [S, mul_comm, *, mul_assoc, mul_left_comm, *, f₁] {contextual := tt}

private lemma f₁_invo_on_S : ∀ v : ℤ × ℤ × ℤ, f₁ (f₁ v) = v := λ ⟨x, y, z⟩, rfl

private lemma f₂_S : ∀ v : ℤ × ℤ × ℤ, v ∈ S p → f₂ v ∈ S p :=
λ ⟨x, y, z⟩ ⟨hv, hx, hy, hz⟩, or.by_cases (decidable.em (x + z < y))
(λ h, ⟨by simp [f₂, h, hv.symm, S, mul_add, add_mul]; ring,
by unfold f₂; rw if_pos h; exact add_nonneg hx (mul_nonneg dec_trivial hz),
by unfold f₂; rw if_pos h; exact hz, le_of_lt (by have h₂ := sub_pos.2 h; simpa [f₂, h] using h₂)⟩)
$ λ h, have h' : y ≤ x + z := le_of_not_gt h,
or.by_cases (decidable.em (2 * y < x)) (λ h₁, ⟨by simp [f₂, h, h₁, hv.symm, S, mul_add, add_mul]; ring,
le_of_lt (by have h₃ := sub_pos.2 h₁; simpa [f₂, h₃, h, h₁] using h₃),
by have h₃ := sub_nonneg.2 h'; simpa [f₂, h, h₁, h₃] using h₃, by simpa [f₂, h, h₁] using hy⟩) $
λ h₁, have h₁' : x ≤ 2 * y := le_of_not_gt h₁,
⟨by simp [f₂, h, h₁, hv.symm, S, mul_add, add_mul]; ring,
by have h₃ := sub_nonneg.2 h₁'; simpa [f₂, h, h₁, h₃] using h₃,
by simpa [f₂, h, h₁] using hy,
by have h₃ := sub_nonneg.2 h'; simpa [f₂, h, h₁] using h₃⟩

private lemma f₂_invo_on_S : ∀ v : ℤ × ℤ × ℤ, v ∈ S p → f₂ (f₂ v) = v :=
λ ⟨x, y, z⟩ hv,
have xp : 0 < x := x_pos hp hp₁ (x, y, z) hv,
have yzp : 0 < y ∧ 0 < z :=  yz_pos hp hp₁ (x, y, z) hv,
 or.by_cases (decidable.em (x + z < y)) (λ h,
have h₁ : ¬ x + (y + (2 * z + (-x + -z))) < z :=
  have h₁ : x + (y + (2 * z + (-x + -z))) = y + z := by ring,
  not_lt_of_ge (h₁.symm ▸ le_add_of_nonneg_left hv.2.2.1),
by simp[f₂, h, h₁, xp]; ring) $
λ h, or.by_cases (decidable.em (2 * y < x))
(λ h₁, have h₂ : y + -(2 * y) < z + -y :=
  have h₂ : y + -(2 * y) = -y := by ring,
  h₂.symm ▸ lt_add_of_pos_left _ yzp.2,
by simp[f₂, h, h₁, h₂]; ring) $
λ h₁, have h₂ : ¬ x + (z + (2 * y + (-x + -y))) < y :=
  have h₁ : x + (z + (2 * y + (-x + -y))) = z + y := by ring,
  not_lt_of_ge (h₁.symm ▸ le_add_of_nonneg_left hv.2.2.2),
have h₃ : ¬ 0 < -x := not_lt_of_ge $ le_of_lt $ neg_neg_of_pos xp,
by simp [f₂, h, h₁, h₂, h₃]; ring

private lemma f₂_fixed_point : ∃! v : S p, f₂ v = v :=
have hp4 : (0 : ℤ) ≤ p / 4 := int.div_nonneg (int.coe_nat_nonneg _) dec_trivial,
have h : ¬ (1 : ℤ) + p / 4 < 1 := not_lt_of_ge $ le_add_of_nonneg_right hp4,
⟨⟨(1, 1, (p / 4 : ℤ)),
⟨show (1 : ℤ) + 4 * (p / 4) = p,
from have h : (p : ℤ) % 4 = 1 := (int.coe_nat_eq_coe_nat_iff _ _).2 hp₁,
have h₁ : (p : ℤ) = p % 4 + 4 * (p / 4) := (int.mod_add_div _ _).symm,
by rw [h₁] {occs := occurrences.pos [2]}; rw h,
dec_trivial, dec_trivial, hp4 ⟩⟩,
⟨by simp [f₂, h, (dec_trivial : ¬ (2 : ℤ) < 1)]; refl,
λ ⟨⟨x, y, z⟩, ⟨hv, hx, hy, hz⟩ ⟩ hf,
have xp : 0 < x := x_pos hp hp₁ (x, y, z) ⟨hv, hx, hy, hz⟩,
have yzp : 0 < y ∧ 0 < z := yz_pos hp hp₁ (x, y, z) ⟨hv, hx, hy, hz⟩,
or.by_cases (decidable.em (x + z < y))
(λ h₁,
have h₂ : x + 2 * z ≠ x := λ h₃,
  have h₄ : x + 2 * z = x + 0 := by rwa add_zero,
  not_or dec_trivial (ne_of_lt yzp.2).symm (mul_eq_zero.1 ((add_left_inj _).1 h₄)),
by simpa [f₂, h₁, h₂] using hf) $ λ h₁,
or.by_cases (decidable.em (2 * y < x))
(λ h₂,
have h₃ : x + -(2 * y) ≠ x := λ h₄,
  have h₅ : x + -2 * y = x + 0 := by rwa [← neg_mul_eq_neg_mul, add_zero],
  not_or dec_trivial (ne_of_lt yzp.1).symm (mul_eq_zero.1 ((add_left_inj _).1 h₅)),
by simp [f₂, h₁, h₂, h₃] at hf; trivial) $ λ h₂,
have hf₁ : 2 * y - x = x ∧ x + (z + -y) = z := by simp [f₂, h₁, h₂] at hf; assumption,
have hxy : y = x := by rw [sub_eq_iff_eq_add, ← two_mul] at hf₁;
  exact eq_of_mul_eq_mul_left dec_trivial hf₁.1,
subtype.eq $ show (x, y, z) = (1, 1, p / 4), from
begin
  rw [hxy, mul_comm (4 : ℤ), mul_assoc] at hv,
  have hxp : int.nat_abs x ∣ p := int.coe_nat_dvd.1 (int.nat_abs_dvd.2 (hv ▸ dvd_add (dvd_mul_right _ _) (dvd_mul_right _ _))),
  have h4 : ((4 : ℕ) : ℤ) = 4 := rfl,
  cases hp.2 _ (hxp) with h₃ h₃,
  { have h₄ : x = 1 := by rwa [← int.coe_nat_eq_coe_nat_iff, int.nat_abs_of_nonneg hx] at h₃,
    rw [← mod_add_div p 4, hp₁, h₄, int.coe_nat_add, int.coe_nat_one, mul_one, one_mul, add_left_cancel_iff,
        int.coe_nat_mul] at hv,
    have : z = p / 4 := eq_of_mul_eq_mul_left_of_ne_zero dec_trivial hv,
    rw [hxy, h₄, this] },
  { have h4 : ((4 : ℕ) : ℤ) = 4 := rfl,
    rw [← int.nat_abs_of_nonneg hx, ← int.nat_abs_of_nonneg hz, h₃, ← mul_add] at hv,
    have := int.eq_one_of_mul_eq_self_right (int.coe_nat_ne_zero.2 (ne_of_lt (prime.pos hp)).symm) hv,
    rw [← h4, ← int.coe_nat_mul, ← int.coe_nat_add, ← int.coe_nat_one, int.coe_nat_eq_coe_nat_iff] at this,
    have : p ≤ 1 := this ▸ (le_add_right p (4 * int.nat_abs z)),
    exact absurd (prime.gt_one hp) (not_lt_of_ge this) }
end ⟩ ⟩

theorem fermat_sum_two_squares : ∃ a b : ℕ, a^2 + b^2 = p :=
have fS : fintype (S p) := fintype_S hp hp₁,
let f₁' : S p → S p := λ ⟨v, hv⟩, ⟨f₁ v, f₁_S hp hp₁ _ hv⟩ in
let f₂' : S p → S p := λ ⟨v, hv⟩, ⟨f₂ v, f₂_S hp hp₁ _ hv⟩ in
have hf₁ : ∀ v, f₁' (f₁' v) = v := λ ⟨v, hv⟩, subtype.eq $ f₁_invo_on_S hp hp₁ v,
have hf₂ : ∀ v, f₂' (f₂' v) = v := λ ⟨v, hv⟩, subtype.eq $ f₂_invo_on_S hp hp₁ v hv,
have hf₂u : ∃! v : S p, f₂' v = v :=
  let ⟨⟨v, vS⟩, ⟨hv₁, hv₂⟩⟩ := f₂_fixed_point hp hp₁ in
  ⟨⟨v, vS⟩, ⟨subtype.eq hv₁, λ ⟨w, wS⟩ hw, hv₂ ⟨w, wS⟩ (subtype.mk.inj hw) ⟩ ⟩,
let h := @odd_card_of_involution_of_unique_fixed_point _ _ fS hf₂ hf₂u in
let ⟨⟨⟨x, y, z⟩, hvp, ⟨hx, hy, hz⟩⟩, h⟩ := @exists_fixed_point_of_involution_of_odd_card _ _ fS h hf₁ in
have h : y = z := (prod.eq_iff_fst_eq_snd_eq.1 (prod.eq_iff_fst_eq_snd_eq.1 (subtype.mk.inj h)).2).2,
⟨int.nat_abs x, 2 * int.nat_abs y,
begin
  simp only [nat.pow_succ, nat.pow_zero, one_mul],
  rw [mul_right_comm 2, mul_assoc, mul_assoc, ← int.coe_nat_eq_coe_nat_iff, int.coe_nat_add,
      int.nat_abs_mul_self, int.coe_nat_mul, int.coe_nat_mul, int.nat_abs_mul_self, ← hvp, h],
  simp,
  ring,
end⟩
#print axioms fermat_sum_two_squares


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.stream.defs
import tactic.ext

/-!
# Streams a.k.a. infinite lists a.k.a. infinite sequences

This file used to be in the core library. It was moved to `mathlib` and renamed to `init` to avoid
name clashes.  -/

open nat function option

universes u v w

namespace stream
variables {α : Type u} {β : Type v} {δ : Type w}

instance {α} [inhabited α] : inhabited (stream α) :=
⟨stream.const default⟩

protected theorem eta (s : stream α) : head s :: tail s = s :=
funext (λ i, begin cases i; refl end)

theorem nth_zero_cons (a : α) (s : stream α) : nth (a :: s) 0 = a := rfl

theorem head_cons (a : α) (s : stream α) : head (a :: s) = a := rfl

theorem tail_cons (a : α) (s : stream α) : tail (a :: s) = s := rfl

theorem tail_drop (n : nat) (s : stream α) : tail (drop n s) = drop n (tail s) :=
funext (λ i, begin unfold tail drop, simp [nth, nat.add_comm, nat.add_left_comm] end)

theorem nth_drop (n m : nat) (s : stream α) : nth (drop m s) n = nth s (n + m) := rfl

theorem tail_eq_drop (s : stream α) : tail s = drop 1 s := rfl

theorem drop_drop (n m : nat) (s : stream α) : drop n (drop m s) = drop (n+m) s :=
funext (λ i, begin unfold drop, rw nat.add_assoc end)

theorem nth_succ (n : nat) (s : stream α) : nth s (succ n) = nth (tail s) n := rfl

theorem drop_succ (n : nat) (s : stream α) : drop (succ n) s = drop n (tail s) := rfl

@[simp] lemma head_drop {α} (a : stream α) (n : ℕ) : (a.drop n).head = a.nth n :=
by simp only [drop, head, nat.zero_add, stream.nth]

@[ext] protected theorem ext {s₁ s₂ : stream α} : (∀ n, nth s₁ n = nth s₂ n) → s₁ = s₂ :=
assume h, funext h

theorem all_def (p : α → Prop) (s : stream α) : all p s = ∀ n, p (nth s n) := rfl

theorem any_def (p : α → Prop) (s : stream α) : any p s = ∃ n, p (nth s n) := rfl

theorem mem_cons (a : α) (s : stream α) : a ∈ (a::s) :=
exists.intro 0 rfl

theorem mem_cons_of_mem {a : α} {s : stream α} (b : α) : a ∈ s → a ∈ b :: s :=
assume ⟨n, h⟩,
exists.intro (succ n) (by rw [nth_succ, tail_cons, h])

theorem eq_or_mem_of_mem_cons {a b : α} {s : stream α} : a ∈ b::s → a = b ∨ a ∈ s :=
assume ⟨n, h⟩,
begin
  cases n with n',
  { left, exact h },
  { right, rw [nth_succ, tail_cons] at h, exact ⟨n', h⟩ }
end

theorem mem_of_nth_eq {n : nat} {s : stream α} {a : α} : a = nth s n → a ∈ s :=
assume h, exists.intro n h

section map
variable (f : α → β)

theorem drop_map (n : nat) (s : stream α) : drop n (map f s) = map f (drop n s) :=
stream.ext (λ i, rfl)

theorem nth_map (n : nat) (s : stream α) : nth (map f s) n = f (nth s n) := rfl

theorem tail_map (s : stream α) : tail (map f s) = map f (tail s) :=
begin rw tail_eq_drop, refl end

theorem head_map (s : stream α) : head (map f s) = f (head s) := rfl

theorem map_eq (s : stream α) : map f s = f (head s) :: map f (tail s) :=
by rw [← stream.eta (map f s), tail_map, head_map]

theorem map_cons (a : α) (s : stream α) : map f (a :: s) = f a :: map f s :=
begin rw [← stream.eta (map f (a :: s)), map_eq], refl end

theorem map_id (s : stream α) : map id s = s := rfl

theorem map_map (g : β → δ) (f : α → β) (s : stream α) : map g (map f s) = map (g ∘ f) s := rfl

theorem map_tail (s : stream α) : map f (tail s) = tail (map f s) := rfl

theorem mem_map {a : α} {s : stream α} : a ∈ s → f a ∈ map f s :=
assume ⟨n, h⟩,
exists.intro n (by rw [nth_map, h])

theorem exists_of_mem_map {f} {b : β} {s : stream α} : b ∈ map f s → ∃ a, a ∈ s ∧ f a = b :=
assume ⟨n, h⟩, ⟨nth s n, ⟨n, rfl⟩, h.symm⟩
end map

section zip
variable (f : α → β → δ)

theorem drop_zip (n : nat) (s₁ : stream α) (s₂ : stream β) :
  drop n (zip f s₁ s₂) = zip f (drop n s₁) (drop n s₂) :=
stream.ext (λ i, rfl)

theorem nth_zip (n : nat) (s₁ : stream α) (s₂ : stream β) :
  nth (zip f s₁ s₂) n = f (nth s₁ n) (nth s₂ n) := rfl

theorem head_zip (s₁ : stream α) (s₂ : stream β) : head (zip f s₁ s₂) = f (head s₁) (head s₂) := rfl

theorem tail_zip (s₁ : stream α) (s₂ : stream β) :
  tail (zip f s₁ s₂) = zip f (tail s₁) (tail s₂) := rfl

theorem zip_eq (s₁ : stream α) (s₂ : stream β) :
  zip f s₁ s₂ = f (head s₁) (head s₂) :: zip f (tail s₁) (tail s₂) :=
begin rw [← stream.eta (zip f s₁ s₂)], refl end

end zip

theorem mem_const (a : α) : a ∈ const a :=
exists.intro 0 rfl

theorem const_eq (a : α) : const a = a :: const a :=
begin
  apply stream.ext, intro n,
  cases n; refl
end

theorem tail_const (a : α) : tail (const a) = const a :=
suffices tail (a :: const a) = const a, by rwa [← const_eq] at this, rfl

theorem map_const (f : α → β) (a : α) : map f (const a) = const (f a) := rfl

theorem nth_const (n : nat) (a : α) : nth (const a) n = a := rfl

theorem drop_const (n : nat) (a : α) : drop n (const a) = const a :=
stream.ext (λ i, rfl)

theorem head_iterate (f : α → α) (a : α) : head (iterate f a) = a := rfl

theorem tail_iterate (f : α → α) (a : α) : tail (iterate f a) = iterate f (f a) :=
begin
  funext n,
  induction n with n' ih,
  { refl },
  { unfold tail iterate,
    unfold tail iterate at ih,
    rw add_one at ih, dsimp at ih,
    rw add_one, dsimp, rw ih }
end

theorem iterate_eq (f : α → α) (a : α) : iterate f a = a :: iterate f (f a) :=
begin
  rw [← stream.eta (iterate f a)],
  rw tail_iterate, refl
end

theorem nth_zero_iterate (f : α → α) (a : α) : nth (iterate f a) 0 = a := rfl

theorem nth_succ_iterate (n : nat) (f : α → α) (a : α) :
  nth (iterate f a) (succ n) = nth (iterate f (f a)) n :=
by rw [nth_succ, tail_iterate]

section bisim
  variable (R : stream α → stream α → Prop)
  local infix ` ~ `:50 := R

  def is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → head s₁ = head s₂ ∧ tail s₁ ~ tail s₂

  theorem nth_of_bisim (bisim : is_bisimulation R) :
    ∀ {s₁ s₂} n, s₁ ~ s₂ → nth s₁ n = nth s₂ n ∧ drop (n+1) s₁ ~ drop (n+1) s₂
  | s₁ s₂ 0     h := bisim h
  | s₁ s₂ (n+1) h :=
    match bisim h with
    | ⟨h₁, trel⟩ := nth_of_bisim n trel
    end

  -- If two streams are bisimilar, then they are equal
  theorem eq_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂}, s₁ ~ s₂ → s₁ = s₂ :=
  λ s₁ s₂ r, stream.ext (λ n, and.elim_left (nth_of_bisim R bisim n r))
end bisim

theorem bisim_simple (s₁ s₂ : stream α) :
  head s₁ = head s₂ → s₁ = tail s₁ → s₂ = tail s₂ → s₁ = s₂ :=
assume hh ht₁ ht₂, eq_of_bisim
  (λ s₁ s₂, head s₁ = head s₂ ∧ s₁ = tail s₁ ∧ s₂ = tail s₂)
  (λ s₁ s₂ ⟨h₁, h₂, h₃⟩,
    begin
      constructor, exact h₁, rw [← h₂, ← h₃], repeat { constructor }; assumption
    end)
  (and.intro hh (and.intro ht₁ ht₂))

theorem coinduction {s₁ s₂ : stream α} :
  head s₁ = head s₂ → (∀ (β : Type u) (fr : stream α → β), fr s₁ = fr s₂ →
    fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ :=
assume hh ht,
  eq_of_bisim
    (λ s₁ s₂, head s₁ = head s₂ ∧ ∀ (β : Type u) (fr : stream α → β), fr s₁ = fr s₂ →
      fr (tail s₁) = fr (tail s₂))
    (λ s₁ s₂ h,
      have h₁ : head s₁ = head s₂,               from and.elim_left h,
      have h₂ : head (tail s₁) = head (tail s₂), from and.elim_right h α (@head α) h₁,
      have h₃ : ∀ (β : Type u) (fr : stream α → β),
        fr (tail s₁) = fr (tail s₂) → fr (tail (tail s₁)) = fr (tail (tail s₂)),
      from λ β fr, and.elim_right h β (λ s, fr (tail s)),
      and.intro h₁ (and.intro h₂ h₃))
    (and.intro hh ht)

theorem iterate_id (a : α) : iterate id a = const a :=
coinduction
  rfl
  (λ β fr ch, begin rw [tail_iterate, tail_const], exact ch end)

local attribute [reducible] stream
theorem map_iterate (f : α → α) (a : α) : iterate f (f a) = map f (iterate f a) :=
begin
  funext n,
  induction n with n' ih,
  { refl },
  { unfold map iterate nth, dsimp,
    unfold map iterate nth at ih, dsimp at ih,
    rw ih }
end

section corec
theorem corec_def (f : α → β) (g : α → α) (a : α) : corec f g a = map f (iterate g a) := rfl

theorem corec_eq (f : α → β) (g : α → α) (a : α) : corec f g a = f a :: corec f g (g a) :=
begin rw [corec_def, map_eq, head_iterate, tail_iterate], refl end

theorem corec_id_id_eq_const (a : α) : corec id id a = const a :=
by rw [corec_def, map_id, iterate_id]

theorem corec_id_f_eq_iterate (f : α → α) (a : α) : corec id f a = iterate f a := rfl
end corec

section corec'

theorem corec'_eq (f : α → β × α) (a : α) : corec' f a = (f a).1 :: corec' f (f a).2 :=
corec_eq _ _ _

end corec'

theorem unfolds_eq (g : α → β) (f : α → α) (a : α) : unfolds g f a = g a :: unfolds g f (f a) :=
begin unfold unfolds, rw [corec_eq] end

theorem nth_unfolds_head_tail : ∀ (n : nat) (s : stream α), nth (unfolds head tail s) n = nth s n :=
begin
  intro n, induction n with n' ih,
  { intro s, refl },
  { intro s, rw [nth_succ, nth_succ, unfolds_eq, tail_cons, ih] }
end

theorem unfolds_head_eq : ∀ (s : stream α), unfolds head tail s = s :=
λ s, stream.ext (λ n, nth_unfolds_head_tail n s)

theorem interleave_eq (s₁ s₂ : stream α) : s₁ ⋈ s₂ = head s₁ :: head s₂ :: (tail s₁ ⋈ tail s₂) :=
begin
  unfold interleave corec_on, rw corec_eq, dsimp, rw corec_eq, refl
end

theorem tail_interleave (s₁ s₂ : stream α) : tail (s₁ ⋈ s₂) = s₂ ⋈ (tail s₁) :=
begin unfold interleave corec_on, rw corec_eq, refl end

theorem interleave_tail_tail (s₁ s₂ : stream α) : tail s₁ ⋈ tail s₂ = tail (tail (s₁ ⋈ s₂)) :=
begin rw [interleave_eq s₁ s₂], refl end

theorem nth_interleave_left : ∀ (n : nat) (s₁ s₂ : stream α), nth (s₁ ⋈ s₂) (2 * n) = nth s₁ n
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (s₁ ⋈ s₂) (succ (succ (2*n))) = nth s₁ (succ n),
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons, nth_interleave_left],
    refl
  end

theorem nth_interleave_right : ∀ (n : nat) (s₁ s₂ : stream α), nth (s₁ ⋈ s₂) (2*n+1) = nth s₂ n
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (s₁ ⋈ s₂) (succ (succ (2*n+1))) = nth s₂ (succ n),
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons, nth_interleave_right],
    refl
  end

theorem mem_interleave_left {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₁ → a ∈ s₁ ⋈ s₂ :=
assume ⟨n, h⟩,
exists.intro (2*n) (by rw [h, nth_interleave_left])

theorem mem_interleave_right {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₂ → a ∈ s₁ ⋈ s₂ :=
assume ⟨n, h⟩,
exists.intro (2*n+1) (by rw [h, nth_interleave_right])

theorem odd_eq (s : stream α) : odd s = even (tail s) := rfl

theorem head_even (s : stream α) : head (even s) = head s := rfl

theorem tail_even (s : stream α) : tail (even s) = even (tail (tail s)) :=
begin unfold even, rw corec_eq, refl end

theorem even_cons_cons (a₁ a₂ : α) (s : stream α) : even (a₁ :: a₂ :: s) = a₁ :: even s :=
begin unfold even, rw corec_eq, refl end

theorem even_tail (s : stream α) : even (tail s) = odd s := rfl

theorem even_interleave (s₁ s₂ : stream α) : even (s₁ ⋈ s₂) = s₁ :=
eq_of_bisim
  (λ s₁' s₁, ∃ s₂, s₁' = even (s₁ ⋈ s₂))
  (λ s₁' s₁ ⟨s₂, h₁⟩,
    begin
      rw h₁,
      constructor,
       {refl},
       {exact ⟨tail s₂, by rw [interleave_eq, even_cons_cons, tail_cons]⟩}
    end)
  (exists.intro s₂ rfl)

theorem interleave_even_odd (s₁ : stream α) : even s₁ ⋈ odd s₁ = s₁ :=
eq_of_bisim
  (λ s' s, s' = even s ⋈ odd s)
  (λ s' s (h : s' = even s ⋈ odd s),
    begin
      rw h, constructor,
       {refl},
       {simp [odd_eq, odd_eq, tail_interleave, tail_even]}
    end)
  rfl

theorem nth_even : ∀ (n : nat) (s : stream α), nth (even s) n = nth s (2*n)
| 0        s := rfl
| (succ n) s :=
  begin
    change nth (even s) (succ n) = nth s (succ (succ (2 * n))),
    rw [nth_succ, nth_succ, tail_even, nth_even], refl
  end

theorem nth_odd : ∀ (n : nat) (s : stream α), nth (odd s) n = nth s (2 * n + 1) :=
λ n s, begin rw [odd_eq, nth_even], refl end

theorem mem_of_mem_even (a : α) (s : stream α) : a ∈ even s → a ∈ s :=
assume ⟨n, h⟩,
exists.intro (2*n) (by rw [h, nth_even])

theorem mem_of_mem_odd (a : α) (s : stream α) : a ∈ odd s → a ∈ s :=
assume ⟨n, h⟩,
exists.intro (2*n+1) (by rw [h, nth_odd])

theorem nil_append_stream (s : stream α) : append_stream [] s = s := rfl

theorem cons_append_stream (a : α) (l : list α) (s : stream α) :
  append_stream (a::l) s = a :: append_stream l s := rfl

theorem append_append_stream :
  ∀ (l₁ l₂ : list α) (s : stream α), (l₁ ++ l₂) ++ₛ s = l₁ ++ₛ (l₂ ++ₛ s)
| []               l₂ s := rfl
| (list.cons a l₁) l₂ s := by rw [list.cons_append, cons_append_stream, cons_append_stream,
                                  append_append_stream]

theorem map_append_stream (f : α → β) :
  ∀ (l : list α) (s : stream α), map f (l ++ₛ s) = list.map f l ++ₛ map f s
| []              s := rfl
| (list.cons a l) s := by rw [cons_append_stream, list.map_cons, map_cons, cons_append_stream,
                              map_append_stream]

theorem drop_append_stream : ∀ (l : list α) (s : stream α), drop l.length (l ++ₛ s) = s
| []              s := by refl
| (list.cons a l) s := by rw [list.length_cons, add_one, drop_succ, cons_append_stream, tail_cons,
                              drop_append_stream]

theorem append_stream_head_tail (s : stream α) : [head s] ++ₛ tail s = s :=
by rw [cons_append_stream, nil_append_stream, stream.eta]

theorem mem_append_stream_right : ∀ {a : α} (l : list α) {s : stream α}, a ∈ s → a ∈ l ++ₛ s
| a []              s h := h
| a (list.cons b l) s h :=
  have ih : a ∈ l ++ₛ s, from mem_append_stream_right l h,
  mem_cons_of_mem _ ih

theorem mem_append_stream_left : ∀ {a : α} {l : list α} (s : stream α), a ∈ l → a ∈ l ++ₛ s
| a []     s h := absurd h (list.not_mem_nil _)
| a (list.cons b l) s h :=
  or.elim (list.eq_or_mem_of_mem_cons h)
    (λ (aeqb : a = b), exists.intro 0 aeqb)
    (λ (ainl : a ∈ l), mem_cons_of_mem b (mem_append_stream_left s ainl))

@[simp] theorem take_zero (s : stream α) : take 0 s = [] := rfl

@[simp] theorem take_succ (n : nat) (s : stream α) :
  take (succ n) s = head s :: take n (tail s) := rfl

@[simp] theorem length_take (n : ℕ) (s : stream α) : (take n s).length = n :=
by induction n generalizing s; simp *

theorem nth_take_succ : ∀ (n : nat) (s : stream α), list.nth (take (succ n) s) n = some (nth s n)
| 0     s := rfl
| (n+1) s := begin rw [take_succ, add_one, list.nth, nth_take_succ], refl end

theorem append_take_drop :
  ∀ (n : nat) (s : stream α), append_stream (take n s) (drop n s) = s :=
begin
  intro n,
  induction n with n' ih,
  { intro s, refl },
  { intro s, rw [take_succ, drop_succ, cons_append_stream, ih (tail s), stream.eta] }
end

-- Take theorem reduces a proof of equality of infinite streams to an
-- induction over all their finite approximations.
theorem take_theorem (s₁ s₂ : stream α) : (∀ (n : nat), take n s₁ = take n s₂) → s₁ = s₂ :=
begin
  intro h, apply stream.ext, intro n,
  induction n with n ih,
  { have aux := h 1, simp [take] at aux, exact aux },
  { have h₁ : some (nth s₁ (succ n)) = some (nth s₂ (succ n)),
    { rw [← nth_take_succ, ← nth_take_succ, h (succ (succ n))] },
    injection h₁ }
end

protected lemma cycle_g_cons (a : α) (a₁ : α) (l₁ : list α) (a₀ : α) (l₀ : list α) :
              stream.cycle_g (a, a₁::l₁, a₀, l₀) = (a₁, l₁, a₀, l₀) := rfl

theorem cycle_eq : ∀ (l : list α) (h : l ≠ []), cycle l h = l ++ₛ cycle l h
| []              h := absurd rfl h
| (list.cons a l) h :=
  have gen : ∀ l' a', corec stream.cycle_f stream.cycle_g (a', l', a, l) =
    (a' :: l') ++ₛ corec stream.cycle_f stream.cycle_g (a, l, a, l),
    begin
      intro l',
      induction l' with a₁ l₁ ih,
        {intros, rw [corec_eq], refl},
        {intros, rw [corec_eq, stream.cycle_g_cons, ih a₁], refl}
    end,
  gen l a

theorem mem_cycle {a : α} {l : list α} : ∀ (h : l ≠ []), a ∈ l → a ∈ cycle l h :=
assume h ainl, begin rw [cycle_eq], exact mem_append_stream_left _ ainl end

theorem cycle_singleton (a : α) (h : [a] ≠ []) : cycle [a] h = const a :=
coinduction
  rfl
  (λ β fr ch, by rwa [cycle_eq, const_eq])

theorem tails_eq (s : stream α) : tails s = tail s :: tails (tail s) :=
by unfold tails; rw [corec_eq]; refl

theorem nth_tails : ∀ (n : nat) (s : stream α), nth (tails s) n = drop n (tail s) :=
begin
  intro n, induction n with n' ih,
  { intros, refl },
  { intro s, rw [nth_succ, drop_succ, tails_eq, tail_cons, ih] }
end

theorem tails_eq_iterate (s : stream α) : tails s = iterate tail (tail s) := rfl

theorem inits_core_eq (l : list α) (s : stream α) :
  inits_core l s = l :: inits_core (l ++ [head s]) (tail s) :=
begin unfold inits_core corec_on, rw [corec_eq], refl end

theorem tail_inits (s : stream α) :
  tail (inits s) = inits_core [head s, head (tail s)] (tail (tail s)) :=
begin unfold inits, rw inits_core_eq, refl end

theorem inits_tail (s : stream α) :
  inits (tail s) = inits_core [head (tail s)] (tail (tail s)) := rfl

theorem nth_inits : ∀ (n : nat) (s : stream α), nth (inits s) n = take (succ n) s  :=
begin
  intro n, induction n with n' ih,
  { intros, refl },
  { intros, rw [nth_succ, take_succ, ← ih, tail_inits, inits_tail, cons_nth_inits_core] }
end

theorem inits_eq (s : stream α) : inits s = [head s] :: map (list.cons (head s)) (inits (tail s)) :=
begin
  apply stream.ext, intro n,
  cases n,
  { refl },
  { rw [nth_inits, nth_succ, tail_cons, nth_map, nth_inits], refl }
end

theorem zip_inits_tails (s : stream α) : zip append_stream (inits s) (tails s) = const s :=
begin
  apply stream.ext, intro n,
  rw [nth_zip, nth_inits, nth_tails, nth_const, take_succ,
      cons_append_stream, append_take_drop, stream.eta]
end

theorem identity (s : stream α) : pure id ⊛ s = s := rfl
theorem composition (g : stream (β → δ)) (f : stream (α → β)) (s : stream α) :
  pure comp ⊛ g ⊛ f ⊛ s = g ⊛ (f ⊛ s) := rfl
theorem homomorphism (f : α → β) (a : α) : pure f ⊛ pure a = pure (f a) := rfl
theorem interchange (fs : stream (α → β)) (a : α) :
  fs ⊛ pure a = pure (λ f : α → β, f a) ⊛ fs := rfl
theorem map_eq_apply (f : α → β) (s : stream α) : map f s = pure f ⊛ s := rfl

theorem nth_nats (n : nat) : nth nats n = n := rfl

theorem nats_eq : nats = 0 :: map succ nats :=
begin
  apply stream.ext, intro n,
  cases n, refl, rw [nth_succ], refl
end

end stream


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

! This file was ported from Lean 3 source module category_theory.pi.basic
! leanprover-community/mathlib commit e97cf15cd1aec9bd5c193b2ffac5a6dc9118912b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.NaturalIsomorphism
import Mathbin.CategoryTheory.EqToHom
import Mathbin.Data.Sum.Basic

/-!
# Categories of indexed families of objects.

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

We define the pointwise category structure on indexed families of objects in a category
(and also the dependent generalization).

-/

namespace CategoryTheory

universe w₀ w₁ w₂ v₁ v₂ u₁ u₂

variable {I : Type w₀} (C : I → Type u₁) [∀ i, Category.{v₁} (C i)]

#print CategoryTheory.pi /-
/-- `pi C` gives the cartesian product of an indexed family of categories.
-/
instance pi : Category.{max w₀ v₁} (∀ i, C i)
    where
  Hom X Y := ∀ i, X i ⟶ Y i
  id X i := 𝟙 (X i)
  comp X Y Z f g i := f i ≫ g i
#align category_theory.pi CategoryTheory.pi
-/

#print CategoryTheory.pi' /-
/-- This provides some assistance to typeclass search in a common situation,
which otherwise fails. (Without this `category_theory.pi.has_limit_of_has_limit_comp_eval` fails.)
-/
abbrev pi' {I : Type v₁} (C : I → Type u₁) [∀ i, Category.{v₁} (C i)] : Category.{v₁} (∀ i, C i) :=
  CategoryTheory.pi C
#align category_theory.pi' CategoryTheory.pi'
-/

attribute [instance] pi'

namespace Pi

#print CategoryTheory.Pi.id_apply /-
@[simp]
theorem id_apply (X : ∀ i, C i) (i) : (𝟙 X : ∀ i, X i ⟶ X i) i = 𝟙 (X i) :=
  rfl
#align category_theory.pi.id_apply CategoryTheory.Pi.id_apply
-/

#print CategoryTheory.Pi.comp_apply /-
@[simp]
theorem comp_apply {X Y Z : ∀ i, C i} (f : X ⟶ Y) (g : Y ⟶ Z) (i) :
    (f ≫ g : ∀ i, X i ⟶ Z i) i = f i ≫ g i :=
  rfl
#align category_theory.pi.comp_apply CategoryTheory.Pi.comp_apply
-/

#print CategoryTheory.Pi.eval /-
/--
The evaluation functor at `i : I`, sending an `I`-indexed family of objects to the object over `i`.
-/
@[simps]
def eval (i : I) : (∀ i, C i) ⥤ C i where
  obj f := f i
  map f g α := α i
#align category_theory.pi.eval CategoryTheory.Pi.eval
-/

section

variable {J : Type w₁}

#print CategoryTheory.Pi.comap /-
/-- Pull back an `I`-indexed family of objects to an `J`-indexed family, along a function `J → I`.
-/
@[simps]
def comap (h : J → I) : (∀ i, C i) ⥤ ∀ j, C (h j)
    where
  obj f i := f (h i)
  map f g α i := α (h i)
#align category_theory.pi.comap CategoryTheory.Pi.comap
-/

variable (I)

#print CategoryTheory.Pi.comapId /-
/-- The natural isomorphism between
pulling back a grading along the identity function,
and the identity functor. -/
@[simps]
def comapId : comap C (id : I → I) ≅ 𝟭 (∀ i, C i)
    where
  Hom := { app := fun X => 𝟙 X }
  inv := { app := fun X => 𝟙 X }
#align category_theory.pi.comap_id CategoryTheory.Pi.comapId
-/

variable {I}

variable {K : Type w₂}

#print CategoryTheory.Pi.comapComp /-
/-- The natural isomorphism comparing between
pulling back along two successive functions, and
pulling back along their composition
-/
@[simps]
def comapComp (f : K → J) (g : J → I) : comap C g ⋙ comap (C ∘ g) f ≅ comap C (g ∘ f)
    where
  Hom := { app := fun X b => 𝟙 (X (g (f b))) }
  inv := { app := fun X b => 𝟙 (X (g (f b))) }
#align category_theory.pi.comap_comp CategoryTheory.Pi.comapComp
-/

#print CategoryTheory.Pi.comapEvalIsoEval /-
/-- The natural isomorphism between pulling back then evaluating, and just evaluating. -/
@[simps]
def comapEvalIsoEval (h : J → I) (j : J) : comap C h ⋙ eval (C ∘ h) j ≅ eval C (h j) :=
  NatIso.ofComponents (fun f => Iso.refl _) (by tidy)
#align category_theory.pi.comap_eval_iso_eval CategoryTheory.Pi.comapEvalIsoEval
-/

end

section

variable {J : Type w₀} {D : J → Type u₁} [∀ j, Category.{v₁} (D j)]

/- warning: category_theory.pi.sum_elim_category -> CategoryTheory.Pi.sumElimCategoryₓ is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} (C : I -> Type.{u3}) [_inst_1 : forall (i : I), CategoryTheory.Category.{u2, u3} (C i)] {J : Type.{u1}} {D : J -> Type.{u3}} [_inst_2 : forall (j : J), CategoryTheory.Category.{u2, u3} (D j)] (s : Sum.{u1, u1} I J), CategoryTheory.Category.{u2, u3} (Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s)
but is expected to have type
  forall {I : Type.{u3}} (C : I -> Type.{u1}) [_inst_1 : forall (i : I), CategoryTheory.Category.{u2, u1} (C i)] {J : Type.{u3}} {D : J -> Type.{u1}} [_inst_2 : forall (j : J), CategoryTheory.Category.{u2, u1} (D j)] (s : Sum.{u3, u3} I J), CategoryTheory.Category.{u2, u1} (Sum.elim.{u3, u3, succ (succ u1)} I J Type.{u1} C D s)
Case conversion may be inaccurate. Consider using '#align category_theory.pi.sum_elim_category CategoryTheory.Pi.sumElimCategoryₓₓ'. -/
instance sumElimCategory : ∀ s : Sum I J, Category.{v₁} (Sum.elim C D s)
  | Sum.inl i => by
    dsimp
    infer_instance
  | Sum.inr j => by
    dsimp
    infer_instance
#align category_theory.pi.sum_elim_category CategoryTheory.Pi.sumElimCategoryₓ

/- warning: category_theory.pi.sum -> CategoryTheory.Pi.sum is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} (C : I -> Type.{u3}) [_inst_1 : forall (i : I), CategoryTheory.Category.{u2, u3} (C i)] {J : Type.{u1}} {D : J -> Type.{u3}} [_inst_2 : forall (j : J), CategoryTheory.Category.{u2, u3} (D j)], CategoryTheory.Functor.{max u1 u2, max (max u1 u3) u1 u2, max u1 u3, max (max u1 u2) u1 u3} (forall (i : I), C i) (CategoryTheory.pi.{u1, u2, u3} I (fun (i : I) => C i) (fun (i : I) => _inst_1 i)) (CategoryTheory.Functor.{max u1 u2, max u1 u2, max u1 u3, max u1 u3} (forall (j : J), D j) (CategoryTheory.pi.{u1, u2, u3} J (fun (j : J) => D j) (fun (i : J) => _inst_2 i)) (forall (s : Sum.{u1, u1} I J), Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (CategoryTheory.pi.{u1, u2, u3} (Sum.{u1, u1} I J) (fun (s : Sum.{u1, u1} I J) => Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (fun (i : Sum.{u1, u1} I J) => CategoryTheory.Pi.sumElimCategoryₓ.{u1, u2, u3} I C (fun (i : I) => _inst_1 i) J D (fun (j : J) => _inst_2 j) i))) (CategoryTheory.Functor.category.{max u1 u2, max u1 u2, max u1 u3, max u1 u3} (forall (j : J), D j) (CategoryTheory.pi.{u1, u2, u3} J (fun (j : J) => D j) (fun (i : J) => _inst_2 i)) (forall (s : Sum.{u1, u1} I J), Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (CategoryTheory.pi.{u1, u2, u3} (Sum.{u1, u1} I J) (fun (s : Sum.{u1, u1} I J) => Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (fun (i : Sum.{u1, u1} I J) => CategoryTheory.Pi.sumElimCategoryₓ.{u1, u2, u3} I C (fun (i : I) => _inst_1 i) J D (fun (j : J) => _inst_2 j) i)))
but is expected to have type
  forall {I : Type.{u1}} (C : I -> Type.{u3}) [_inst_1 : forall (i : I), CategoryTheory.Category.{u2, u3} (C i)] {J : Type.{u1}} {D : J -> Type.{u3}} [_inst_2 : forall (j : J), CategoryTheory.Category.{u2, u3} (D j)], CategoryTheory.Functor.{max u2 u1, max (max u3 u2) u1, max u3 u1, max (max u3 u1) u2 u1} (forall (i : I), C i) (CategoryTheory.pi.{u1, u2, u3} I (fun (i : I) => C i) (fun (i : I) => _inst_1 i)) (CategoryTheory.Functor.{max u2 u1, max u2 u1, max u3 u1, max u3 u1} (forall (j : J), D j) (CategoryTheory.pi.{u1, u2, u3} J (fun (j : J) => D j) (fun (i : J) => _inst_2 i)) (forall (s : Sum.{u1, u1} I J), Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (CategoryTheory.pi.{u1, u2, u3} (Sum.{u1, u1} I J) (fun (s : Sum.{u1, u1} I J) => Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (fun (i : Sum.{u1, u1} I J) => CategoryTheory.Pi.sumElimCategory.{u1, u2, u3} I C (fun (i : I) => (fun (i : I) => _inst_1 i) i) J D (fun (j : J) => (fun (j : J) => _inst_2 j) j) i))) (CategoryTheory.Functor.category.{max u2 u1, max u2 u1, max u3 u1, max u3 u1} (forall (j : J), D j) (CategoryTheory.pi.{u1, u2, u3} J (fun (j : J) => D j) (fun (i : J) => _inst_2 i)) (forall (s : Sum.{u1, u1} I J), Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (CategoryTheory.pi.{u1, u2, u3} (Sum.{u1, u1} I J) (fun (s : Sum.{u1, u1} I J) => Sum.elim.{u1, u1, succ (succ u3)} I J Type.{u3} C D s) (fun (i : Sum.{u1, u1} I J) => CategoryTheory.Pi.sumElimCategory.{u1, u2, u3} I C (fun (i : I) => (fun (i : I) => _inst_1 i) i) J D (fun (j : J) => (fun (j : J) => _inst_2 j) j) i)))
Case conversion may be inaccurate. Consider using '#align category_theory.pi.sum CategoryTheory.Pi.sumₓ'. -/
/-- The bifunctor combining an `I`-indexed family of objects with a `J`-indexed family of objects
to obtain an `I ⊕ J`-indexed family of objects.
-/
@[simps]
def sum : (∀ i, C i) ⥤ (∀ j, D j) ⥤ ∀ s : Sum I J, Sum.elim C D s
    where
  obj f :=
    { obj := fun g s => Sum.rec f g s
      map := fun g g' α s => Sum.rec (fun i => 𝟙 (f i)) α s }
  map f f' α := { app := fun g s => Sum.rec α (fun j => 𝟙 (g j)) s }
#align category_theory.pi.sum CategoryTheory.Pi.sum

end

variable {C}

#print CategoryTheory.Pi.isoApp /-
/-- An isomorphism between `I`-indexed objects gives an isomorphism between each
pair of corresponding components. -/
@[simps]
def isoApp {X Y : ∀ i, C i} (f : X ≅ Y) (i : I) : X i ≅ Y i :=
  ⟨f.Hom i, f.inv i, by
    dsimp
    rw [← comp_apply, iso.hom_inv_id, id_apply],
    by
    dsimp
    rw [← comp_apply, iso.inv_hom_id, id_apply]⟩
#align category_theory.pi.iso_app CategoryTheory.Pi.isoApp
-/

#print CategoryTheory.Pi.isoApp_refl /-
@[simp]
theorem isoApp_refl (X : ∀ i, C i) (i : I) : isoApp (Iso.refl X) i = Iso.refl (X i) :=
  rfl
#align category_theory.pi.iso_app_refl CategoryTheory.Pi.isoApp_refl
-/

#print CategoryTheory.Pi.isoApp_symm /-
@[simp]
theorem isoApp_symm {X Y : ∀ i, C i} (f : X ≅ Y) (i : I) : isoApp f.symm i = (isoApp f i).symm :=
  rfl
#align category_theory.pi.iso_app_symm CategoryTheory.Pi.isoApp_symm
-/

#print CategoryTheory.Pi.isoApp_trans /-
@[simp]
theorem isoApp_trans {X Y Z : ∀ i, C i} (f : X ≅ Y) (g : Y ≅ Z) (i : I) :
    isoApp (f ≪≫ g) i = isoApp f i ≪≫ isoApp g i :=
  rfl
#align category_theory.pi.iso_app_trans CategoryTheory.Pi.isoApp_trans
-/

end Pi

namespace Functor

variable {C}

variable {D : I → Type u₁} [∀ i, Category.{v₁} (D i)] {A : Type u₁} [Category.{u₁} A]

#print CategoryTheory.Functor.pi /-
/-- Assemble an `I`-indexed family of functors into a functor between the pi types.
-/
@[simps]
def pi (F : ∀ i, C i ⥤ D i) : (∀ i, C i) ⥤ ∀ i, D i
    where
  obj f i := (F i).obj (f i)
  map f g α i := (F i).map (α i)
#align category_theory.functor.pi CategoryTheory.Functor.pi
-/

#print CategoryTheory.Functor.pi' /-
/-- Similar to `pi`, but all functors come from the same category `A`
-/
@[simps]
def pi' (f : ∀ i, A ⥤ C i) : A ⥤ ∀ i, C i
    where
  obj a i := (f i).obj a
  map a₁ a₂ h i := (f i).map h
#align category_theory.functor.pi' CategoryTheory.Functor.pi'
-/

section EqToHom

#print CategoryTheory.Functor.eqToHom_proj /-
@[simp]
theorem eqToHom_proj {x x' : ∀ i, C i} (h : x = x') (i : I) :
    (eqToHom h : x ⟶ x') i = eqToHom (Function.funext_iff.mp h i) :=
  by
  subst h
  rfl
#align category_theory.functor.eq_to_hom_proj CategoryTheory.Functor.eqToHom_proj
-/

end EqToHom

#print CategoryTheory.Functor.pi'_eval /-
-- One could add some natural isomorphisms showing
-- how `functor.pi` commutes with `pi.eval` and `pi.comap`.
@[simp]
theorem pi'_eval (f : ∀ i, A ⥤ C i) (i : I) : pi' f ⋙ Pi.eval C i = f i :=
  by
  apply Functor.ext <;> intros
  · simp; · rfl
#align category_theory.functor.pi'_eval CategoryTheory.Functor.pi'_eval
-/

#print CategoryTheory.Functor.pi_ext /-
/-- Two functors to a product category are equal iff they agree on every coordinate. -/
theorem pi_ext (f f' : A ⥤ ∀ i, C i) (h : ∀ i, f ⋙ Pi.eval C i = f' ⋙ Pi.eval C i) : f = f' :=
  by
  apply Functor.ext; swap
  · intro X
    ext i
    specialize h i
    have := congr_obj h X
    simpa
  · intro x y p
    ext i
    specialize h i
    have := congr_hom h p
    simpa
#align category_theory.functor.pi_ext CategoryTheory.Functor.pi_ext
-/

end Functor

namespace NatTrans

variable {C}

variable {D : I → Type u₁} [∀ i, Category.{v₁} (D i)]

variable {F G : ∀ i, C i ⥤ D i}

#print CategoryTheory.NatTrans.pi /-
/-- Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
@[simps]
def pi (α : ∀ i, F i ⟶ G i) : Functor.pi F ⟶ Functor.pi G where app f i := (α i).app (f i)
#align category_theory.nat_trans.pi CategoryTheory.NatTrans.pi
-/

end NatTrans

end CategoryTheory


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Scott Morrison, Adam Topaz
-/
import algebraic_topology.simplex_category
import category_theory.category.ulift
import category_theory.limits.functor_category
import category_theory.opposites
import category_theory.adjunction.limits

/-!
# Simplicial objects in a category.

A simplicial object in a category `C` is a `C`-valued presheaf on `simplex_category`.

Use the notation `X _[n]` in the `simplicial` locale to obtain the `n`-th term of a
simplicial object `X`, where `n` is a natural number.

-/

open opposite
open category_theory
open category_theory.limits

universes v u

namespace category_theory

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

/-- The category of simplicial objects valued in a category `C`.
This is the category of contravariant functors from `simplex_category` to `C`. -/
@[derive category, nolint has_inhabited_instance]
def simplicial_object := simplex_category.{v}ᵒᵖ ⥤ C

namespace simplicial_object

localized
  "notation X `_[`:1000 n `]` :=
    (X : category_theory.simplicial_object _).obj (opposite.op (simplex_category.mk n))"
  in simplicial

instance {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (simplicial_object C) := by {dsimp [simplicial_object], apply_instance}

instance [has_limits C] : has_limits (simplicial_object C) := ⟨infer_instance⟩

instance {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (simplicial_object C) := by {dsimp [simplicial_object], apply_instance}

instance [has_colimits C] : has_colimits (simplicial_object C) := ⟨infer_instance⟩

variables {C} (X : simplicial_object C)

/-- Face maps for a simplicial object. -/
def δ {n} (i : fin (n+2)) : X _[n+1] ⟶ X _[n] :=
X.map (simplex_category.δ i).op

/-- Degeneracy maps for a simplicial object. -/
def σ {n} (i : fin (n+1)) : X _[n] ⟶ X _[n+1] :=
X.map (simplex_category.σ i).op

/-- Isomorphisms from identities in ℕ. -/
def eq_to_iso {n m : ℕ} (h : n = m) : X _[n] ≅ X _[m] :=
X.map_iso (eq_to_iso (by rw h))

@[simp] lemma eq_to_iso_refl {n : ℕ} (h : n = n) : X.eq_to_iso h = iso.refl _ :=
by { ext, simp [eq_to_iso], }

/-- The generic case of the first simplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  X.δ j.succ ≫ X.δ i = X.δ i.cast_succ ≫ X.δ j :=
by { dsimp [δ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_δ H] }

/-- The special case of the first simplicial identity -/
lemma δ_comp_δ_self {n} {i : fin (n+2)} : X.δ i.cast_succ ≫ X.δ i = X.δ i.succ ≫ X.δ i :=
by { dsimp [δ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_δ_self] }

/-- The second simplicial identity -/
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  X.σ j.succ ≫ X.δ i.cast_succ = X.δ i ≫ X.σ j :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_of_le H] }

/-- The first part of the third simplicial identity -/
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  X.σ i ≫ X.δ i.cast_succ = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_self, op_id, X.map_id],
end

/-- The second part of the third simplicial identity -/
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  X.σ i ≫ X.δ i.succ = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_succ, op_id, X.map_id],
end

/-- The fourth simplicial identity -/
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  X.σ j.cast_succ ≫ X.δ i.succ = X.δ i ≫ X.σ j :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_of_gt H] }

/-- The fifth simplicial identity -/
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  X.σ j ≫ X.σ i.cast_succ = X.σ i ≫ X.σ j.succ :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.σ_comp_σ H] }

variable (C)
/-- Truncated simplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def truncated (n : ℕ) := (simplex_category.truncated.{v} n)ᵒᵖ ⥤ C
variable {C}

namespace truncated

instance {n} {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (simplicial_object.truncated C n) := by {dsimp [truncated], apply_instance}

instance {n} [has_limits C] : has_limits (simplicial_object.truncated C n) := ⟨infer_instance⟩

instance {n} {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (simplicial_object.truncated C n) :=
by {dsimp [truncated], apply_instance}

instance {n} [has_colimits C] : has_colimits (simplicial_object.truncated C n) := ⟨infer_instance⟩

end truncated

section skeleton

/-- The skeleton functor from simplicial objects to truncated simplicial objects. -/
def sk (n : ℕ) : simplicial_object C ⥤ simplicial_object.truncated C n :=
(whiskering_left _ _ _).obj (simplex_category.truncated.inclusion).op

end skeleton

end simplicial_object

end category_theory