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

/-!
# Lemmas about inequalities

This file contains some lemmas about `≤`/`≥`/`<`/`>`, and `cmp`.

* We simplify `a ≥ b` and `a > b` to `b ≤ a` and `b < a`, respectively. This way we can formulate
  all lemmas using `≤`/`<` avoiding duplication.

* In some cases we introduce dot syntax aliases so that, e.g., from
  `(hab : a ≤ b) (hbc : b ≤ c) (hbc' : b < c)` one can prove `hab.trans hbc : a ≤ c` and
  `hab.trans_lt hbc' : a < c`.
-/

universe u
variables {α : Type u}

alias le_trans        ← has_le.le.trans
alias lt_of_le_of_lt  ← has_le.le.trans_lt
alias le_antisymm     ← has_le.le.antisymm
alias lt_of_le_of_ne  ← has_le.le.lt_of_ne
alias lt_of_le_not_le ← has_le.le.lt_of_not_le
alias lt_or_eq_of_le  ← has_le.le.lt_or_eq

alias le_of_lt        ← has_lt.lt.le
alias lt_trans        ← has_lt.lt.trans
alias lt_of_lt_of_le  ← has_lt.lt.trans_le
alias ne_of_lt        ← has_lt.lt.ne
alias lt_asymm        ← has_lt.lt.asymm has_lt.lt.not_lt

alias le_of_eq        ← eq.le

/-- A version of `le_refl` where the argument is implicit -/
lemma le_rfl [preorder α] {x : α} : x ≤ x := le_refl x

namespace eq
/--
If `x = y` then `y ≤ x`. Note: this lemma uses `y ≤ x` instead of `x ≥ y`,
because `le` is used almost exclusively in mathlib.
-/
protected lemma ge [preorder α] {x y : α} (h : x = y) : y ≤ x := h.symm.le

lemma trans_le [preorder α] {x y z : α} (h1 : x = y) (h2 : y ≤ z) : x ≤ z := h1.le.trans h2
end eq

namespace has_le.le

@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma ge [has_le α] {x y : α} (h : x ≤ y) : y ≥ x := h

lemma trans_eq [preorder α] {x y z : α} (h1 : x ≤ y) (h2 : y = z) : x ≤ z := h1.trans h2.le

lemma lt_iff_ne [partial_order α] {x y : α} (h : x ≤ y) : x < y ↔ x ≠ y := ⟨λ h, h.ne, h.lt_of_ne⟩

lemma le_iff_eq [partial_order α] {x y : α} (h : x ≤ y) : y ≤ x ↔ y = x :=
⟨λ h', h'.antisymm h, eq.le⟩

lemma lt_or_le [linear_order α] {a b : α} (h : a ≤ b) (c : α) : a < c ∨ c ≤ b :=
(lt_or_ge a c).imp id $ λ hc, le_trans hc h

lemma le_or_lt [linear_order α] {a b : α} (h : a ≤ b) (c : α) : a ≤ c ∨ c < b :=
(le_or_gt a c).imp id $ λ hc, lt_of_lt_of_le hc h

lemma le_or_le [linear_order α] {a b : α} (h : a ≤ b) (c : α) : a ≤ c ∨ c ≤ b :=
(h.le_or_lt c).elim or.inl (λ h, or.inr $ le_of_lt h)

end has_le.le

namespace has_lt.lt

@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma gt [has_lt α] {x y : α} (h : x < y) : y > x := h
protected lemma false [preorder α] {x : α} : x < x → false := lt_irrefl x

lemma ne' [preorder α] {x y : α} (h : x < y) : y ≠ x := h.ne.symm

lemma lt_or_lt [linear_order α] {x y : α} (h : x < y) (z : α) : x < z ∨ z < y :=
(lt_or_ge z y).elim or.inr (λ hz, or.inl $ h.trans_le hz)

end has_lt.lt

namespace ge
@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma le [has_le α] {x y : α} (h : x ≥ y) : y ≤ x := h
end ge

namespace gt
@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma lt [has_lt α] {x y : α} (h : x > y) : y < x := h
end gt

@[nolint ge_or_gt] -- see Note [nolint_ge]
theorem ge_of_eq [preorder α] {a b : α} (h : a = b) : a ≥ b :=
h.ge

@[simp, nolint ge_or_gt] -- see Note [nolint_ge]
lemma ge_iff_le [preorder α] {a b : α} : a ≥ b ↔ b ≤ a := iff.rfl
@[simp, nolint ge_or_gt] -- see Note [nolint_ge]
lemma gt_iff_lt [preorder α] {a b : α} : a > b ↔ b < a := iff.rfl

lemma not_le_of_lt [preorder α] {a b : α} (h : a < b) : ¬ b ≤ a :=
(le_not_le_of_lt h).right

alias not_le_of_lt ← has_lt.lt.not_le

lemma not_lt_of_le [preorder α] {a b : α} (h : a ≤ b) : ¬ b < a
| hab := hab.not_le h

alias not_lt_of_le ← has_le.le.not_lt

lemma le_iff_eq_or_lt [partial_order α] {a b : α} : a ≤ b ↔ a = b ∨ a < b :=
le_iff_lt_or_eq.trans or.comm

lemma lt_iff_le_and_ne [partial_order α] {a b : α} : a < b ↔ a ≤ b ∧ a ≠ b :=
⟨λ h, ⟨le_of_lt h, ne_of_lt h⟩, λ ⟨h1, h2⟩, h1.lt_of_ne h2⟩

lemma eq_iff_le_not_lt [partial_order α] {a b : α} : a = b ↔ a ≤ b ∧ ¬ a < b :=
⟨λ h, ⟨h.le, h ▸ lt_irrefl _⟩, λ ⟨h₁, h₂⟩, h₁.antisymm $
  classical.by_contradiction $ λ h₃, h₂ (h₁.lt_of_not_le h₃)⟩

lemma eq_or_lt_of_le [partial_order α] {a b : α} (h : a ≤ b) : a = b ∨ a < b :=
h.lt_or_eq.symm

alias eq_or_lt_of_le ← has_le.le.eq_or_lt

lemma ne.le_iff_lt [partial_order α] {a b : α} (h : a ≠ b) : a ≤ b ↔ a < b :=
⟨λ h', lt_of_le_of_ne h' h, λ h, h.le⟩

@[simp] lemma ne_iff_lt_iff_le [partial_order α] {a b : α} : (a ≠ b ↔ a < b) ↔ a ≤ b :=
⟨λ h, classical.by_cases le_of_eq (le_of_lt ∘ h.mp), λ h, ⟨lt_of_le_of_ne h, ne_of_lt⟩⟩

lemma lt_of_not_ge' [linear_order α] {a b : α} (h : ¬ b ≤ a) : a < b :=
((le_total _ _).resolve_right h).lt_of_not_le h

lemma lt_iff_not_ge' [linear_order α] {x y : α} : x < y ↔ ¬ y ≤ x :=
⟨not_le_of_gt, lt_of_not_ge'⟩

lemma ne.lt_or_lt [linear_order α] {a b : α} (h : a ≠ b) : a < b ∨ b < a :=
lt_or_gt_of_ne h

lemma not_lt_iff_eq_or_lt [linear_order α] {a b : α} : ¬ a < b ↔ a = b ∨ b < a :=
not_lt.trans $ le_iff_eq_or_lt.trans $ or_congr eq_comm iff.rfl

lemma exists_ge_of_linear [linear_order α] (a b : α) : ∃ c, a ≤ c ∧ b ≤ c :=
match le_total a b with
| or.inl h := ⟨_, h, le_rfl⟩
| or.inr h := ⟨_, le_rfl, h⟩
end

lemma lt_imp_lt_of_le_imp_le {β} [linear_order α] [preorder β] {a b : α} {c d : β}
  (H : a ≤ b → c ≤ d) (h : d < c) : b < a :=
lt_of_not_ge' $ λ h', (H h').not_lt h

lemma le_imp_le_iff_lt_imp_lt {β} [linear_order α] [linear_order β] {a b : α} {c d : β} :
  (a ≤ b → c ≤ d) ↔ (d < c → b < a) :=
⟨lt_imp_lt_of_le_imp_le, le_imp_le_of_lt_imp_lt⟩

lemma lt_iff_lt_of_le_iff_le' {β} [preorder α] [preorder β] {a b : α} {c d : β}
  (H : a ≤ b ↔ c ≤ d) (H' : b ≤ a ↔ d ≤ c) : b < a ↔ d < c :=
lt_iff_le_not_le.trans $ (and_congr H' (not_congr H)).trans lt_iff_le_not_le.symm

lemma lt_iff_lt_of_le_iff_le {β} [linear_order α] [linear_order β] {a b : α} {c d : β}
  (H : a ≤ b ↔ c ≤ d) : b < a ↔ d < c :=
not_le.symm.trans $ (not_congr H).trans $ not_le

lemma le_iff_le_iff_lt_iff_lt {β} [linear_order α] [linear_order β] {a b : α} {c d : β} :
  (a ≤ b ↔ c ≤ d) ↔ (b < a ↔ d < c) :=
⟨lt_iff_lt_of_le_iff_le, λ H, not_lt.symm.trans $ (not_congr H).trans $ not_lt⟩

lemma eq_of_forall_le_iff [partial_order α] {a b : α}
  (H : ∀ c, c ≤ a ↔ c ≤ b) : a = b :=
le_antisymm ((H _).1 (le_refl _)) ((H _).2 (le_refl _))

lemma le_of_forall_le [preorder α] {a b : α}
  (H : ∀ c, c ≤ a → c ≤ b) : a ≤ b :=
H _ (le_refl _)

lemma le_of_forall_le' [preorder α] {a b : α}
  (H : ∀ c, a ≤ c → b ≤ c) : b ≤ a :=
H _ (le_refl _)

lemma le_of_forall_lt [linear_order α] {a b : α}
  (H : ∀ c, c < a → c < b) : a ≤ b :=
le_of_not_lt $ λ h, lt_irrefl _ (H _ h)

lemma forall_lt_iff_le [linear_order α] {a b : α} :
  (∀ ⦃c⦄, c < a → c < b) ↔ a ≤ b :=
⟨le_of_forall_lt, λ h c hca, lt_of_lt_of_le hca h⟩

lemma le_of_forall_lt' [linear_order α] {a b : α}
  (H : ∀ c, a < c → b < c) : b ≤ a :=
le_of_not_lt $ λ h, lt_irrefl _ (H _ h)

lemma forall_lt_iff_le' [linear_order α] {a b : α} :
  (∀ ⦃c⦄, a < c → b < c) ↔ b ≤ a :=
⟨le_of_forall_lt', λ h c hac, lt_of_le_of_lt h hac⟩

lemma eq_of_forall_ge_iff [partial_order α] {a b : α}
  (H : ∀ c, a ≤ c ↔ b ≤ c) : a = b :=
le_antisymm ((H _).2 (le_refl _)) ((H _).1 (le_refl _))

/-- monotonicity of `≤` with respect to `→` -/
lemma le_implies_le_of_le_of_le {a b c d : α} [preorder α] (h₀ : c ≤ a) (h₁ : b ≤ d) :
  a ≤ b → c ≤ d :=
assume h₂ : a ≤ b,
calc  c
    ≤ a : h₀
... ≤ b : h₂
... ≤ d : h₁

namespace decidable

-- See Note [decidable namespace]
lemma le_imp_le_iff_lt_imp_lt {β} [linear_order α] [linear_order β]
  {a b : α} {c d : β} : (a ≤ b → c ≤ d) ↔ (d < c → b < a) :=
⟨lt_imp_lt_of_le_imp_le, le_imp_le_of_lt_imp_lt⟩

-- See Note [decidable namespace]
lemma le_iff_le_iff_lt_iff_lt {β} [linear_order α] [linear_order β]
  {a b : α} {c d : β} : (a ≤ b ↔ c ≤ d) ↔ (b < a ↔ d < c) :=
⟨lt_iff_lt_of_le_iff_le, λ H, not_lt.symm.trans $ (not_congr H).trans $ not_lt⟩

end decidable

/-- Like `cmp`, but uses a `≤` on the type instead of `<`. Given two elements
`x` and `y`, returns a three-way comparison result `ordering`. -/
def cmp_le {α} [has_le α] [@decidable_rel α (≤)] (x y : α) : ordering :=
if x ≤ y then
  if y ≤ x then ordering.eq else ordering.lt
else ordering.gt

theorem cmp_le_swap {α} [has_le α] [is_total α (≤)] [@decidable_rel α (≤)] (x y : α) :
  (cmp_le x y).swap = cmp_le y x :=
begin
  by_cases xy : x ≤ y; by_cases yx : y ≤ x; simp [cmp_le, *, ordering.swap],
  cases not_or xy yx (total_of _ _ _)
end

theorem cmp_le_eq_cmp {α} [preorder α] [is_total α (≤)]
  [@decidable_rel α (≤)] [@decidable_rel α (<)] (x y : α) : cmp_le x y = cmp x y :=
begin
  by_cases xy : x ≤ y; by_cases yx : y ≤ x;
    simp [cmp_le, lt_iff_le_not_le, *, cmp, cmp_using],
  cases not_or xy yx (total_of _ _ _)
end

namespace ordering

/-- `compares o a b` means that `a` and `b` have the ordering relation
  `o` between them, assuming that the relation `a < b` is defined -/
@[simp] def compares [has_lt α] : ordering → α → α → Prop
| lt a b := a < b
| eq a b := a = b
| gt a b := a > b

theorem compares_swap [has_lt α] {a b : α} {o : ordering} :
  o.swap.compares a b ↔ o.compares b a :=
by { cases o, exacts [iff.rfl, eq_comm, iff.rfl] }

alias compares_swap ↔ ordering.compares.of_swap ordering.compares.swap

theorem swap_eq_iff_eq_swap {o o' : ordering} : o.swap = o' ↔ o = o'.swap :=
⟨λ h, by rw [← swap_swap o, h], λ h, by rw [← swap_swap o', h]⟩

theorem compares.eq_lt [preorder α] :
  ∀ {o} {a b : α}, compares o a b → (o = lt ↔ a < b)
| lt a b h := ⟨λ _, h, λ _, rfl⟩
| eq a b h := ⟨λ h, by injection h, λ h', (ne_of_lt h' h).elim⟩
| gt a b h := ⟨λ h, by injection h, λ h', (lt_asymm h h').elim⟩

theorem compares.ne_lt [preorder α] :
  ∀ {o} {a b : α}, compares o a b → (o ≠ lt ↔ b ≤ a)
| lt a b h := ⟨absurd rfl, λ h', (not_le_of_lt h h').elim⟩
| eq a b h := ⟨λ _, ge_of_eq h, λ _ h, by injection h⟩
| gt a b h := ⟨λ _, le_of_lt h, λ _ h, by injection h⟩

theorem compares.eq_eq [preorder α] :
  ∀ {o} {a b : α}, compares o a b → (o = eq ↔ a = b)
| lt a b h := ⟨λ h, by injection h, λ h', (ne_of_lt h h').elim⟩
| eq a b h := ⟨λ _, h, λ _, rfl⟩
| gt a b h := ⟨λ h, by injection h, λ h', (ne_of_gt h h').elim⟩

theorem compares.eq_gt [preorder α] {o} {a b : α} (h : compares o a b) : (o = gt ↔ b < a) :=
swap_eq_iff_eq_swap.symm.trans h.swap.eq_lt

theorem compares.ne_gt [preorder α] {o} {a b : α} (h : compares o a b) : (o ≠ gt ↔ a ≤ b) :=
(not_congr swap_eq_iff_eq_swap.symm).trans h.swap.ne_lt

theorem compares.le_total [preorder α] {a b : α} :
  ∀ {o}, compares o a b → a ≤ b ∨ b ≤ a
| lt h := or.inl (le_of_lt h)
| eq h := or.inl (le_of_eq h)
| gt h := or.inr (le_of_lt h)

theorem compares.le_antisymm [preorder α] {a b : α} :
  ∀ {o}, compares o a b → a ≤ b → b ≤ a → a = b
| lt h _ hba := (not_le_of_lt h hba).elim
| eq h _ _   := h
| gt h hab _ := (not_le_of_lt h hab).elim

theorem compares.inj [preorder α] {o₁} :
  ∀ {o₂} {a b : α}, compares o₁ a b → compares o₂ a b → o₁ = o₂
| lt a b h₁ h₂ := h₁.eq_lt.2 h₂
| eq a b h₁ h₂ := h₁.eq_eq.2 h₂
| gt a b h₁ h₂ := h₁.eq_gt.2 h₂

theorem compares_iff_of_compares_impl {β : Type*} [linear_order α] [preorder β] {a b : α}
  {a' b' : β} (h : ∀ {o}, compares o a b → compares o a' b') (o) :
  compares o a b ↔ compares o a' b' :=
begin
  refine ⟨h, λ ho, _⟩,
  cases lt_trichotomy a b with hab hab,
  { change compares ordering.lt a b at hab,
    rwa [ho.inj (h hab)] },
  { cases hab with hab hab,
    { change compares ordering.eq a b at hab,
      rwa [ho.inj (h hab)] },
    { change compares ordering.gt a b at hab,
      rwa [ho.inj (h hab)] } }
end

theorem swap_or_else (o₁ o₂) : (or_else o₁ o₂).swap = or_else o₁.swap o₂.swap :=
by cases o₁; try {refl}; cases o₂; refl

theorem or_else_eq_lt (o₁ o₂) : or_else o₁ o₂ = lt ↔ o₁ = lt ∨ (o₁ = eq ∧ o₂ = lt) :=
by cases o₁; cases o₂; exact dec_trivial

end ordering

theorem cmp_compares [linear_order α] (a b : α) : (cmp a b).compares a b :=
begin
  unfold cmp cmp_using,
  by_cases a < b; simp [h],
  by_cases h₂ : b < a; simp [h₂, gt],
  exact (lt_or_eq_of_le (le_of_not_gt h₂)).resolve_left h
end

theorem cmp_swap [preorder α] [@decidable_rel α (<)] (a b : α) : (cmp a b).swap = cmp b a :=
begin
  unfold cmp cmp_using,
  by_cases a < b; by_cases h₂ : b < a; simp [h, h₂, gt, ordering.swap],
  exact lt_asymm h h₂
end

/-- Generate a linear order structure from a preorder and `cmp` function. -/
def linear_order_of_compares [preorder α] (cmp : α → α → ordering)
  (h : ∀ a b, (cmp a b).compares a b) :
  linear_order α :=
{ le_antisymm := λ a b, (h a b).le_antisymm,
  le_total := λ a b, (h a b).le_total,
  decidable_le := λ a b, decidable_of_iff _ (h a b).ne_gt,
  decidable_lt := λ a b, decidable_of_iff _ (h a b).eq_lt,
  decidable_eq := λ a b, decidable_of_iff _ (h a b).eq_eq,
  .. ‹preorder α› }

variables [linear_order α] (x y : α)

@[simp] lemma cmp_eq_lt_iff : cmp x y = ordering.lt ↔ x < y :=
ordering.compares.eq_lt (cmp_compares x y)

@[simp] lemma cmp_eq_eq_iff : cmp x y = ordering.eq ↔ x = y :=
ordering.compares.eq_eq (cmp_compares x y)

@[simp] lemma cmp_eq_gt_iff : cmp x y = ordering.gt ↔ y < x :=
ordering.compares.eq_gt (cmp_compares x y)

@[simp] lemma cmp_self_eq_eq : cmp x x = ordering.eq :=
by rw cmp_eq_eq_iff

variables {x y} {β : Type*} [linear_order β] {x' y' : β}

lemma cmp_eq_cmp_symm : cmp x y = cmp x' y' ↔ cmp y x = cmp y' x' :=
by { split, rw [←cmp_swap _ y, ←cmp_swap _ y'], cc,
  rw [←cmp_swap _ x, ←cmp_swap _ x'], cc, }

lemma lt_iff_lt_of_cmp_eq_cmp (h : cmp x y = cmp x' y') : x < y ↔ x' < y' :=
by rw [←cmp_eq_lt_iff, ←cmp_eq_lt_iff, h]

lemma le_iff_le_of_cmp_eq_cmp (h : cmp x y = cmp x' y') : x ≤ y ↔ x' ≤ y' :=
by { rw [←not_lt, ←not_lt, not_iff_not],
  apply lt_iff_lt_of_cmp_eq_cmp, rwa cmp_eq_cmp_symm }


inductive day : Type
| sunday : day
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day

open day

def tues : day := tuesday

def tom : day → day
| sunday := monday
| monday := tuesday
| tuesday := wednesday
| wednesday := thursday
| thursday := friday
| friday := saturday
| saturday := sunday

def tom' (d : day) : day :=
match d with
| sunday := monday
| monday := tuesday
| tuesday := wednesday
| wednesday := thursday
| thursday := friday
| friday := saturday
| saturday := sunday
end

#check tom'

-- semantically the same, but not syntactically
example: tom = tom' :=
begin
  sorry,
--  exact eq.refl tom,
end

def isWeekday : day → bool
| monday := tt
| tuesday := tt
| wednesday := tt
| thursday := tt
| friday := tt
| _ := ff

def isWeekday' : day → bool
| saturday := ff
| sunday := ff
| _ := tt

example :
    ∀ d : day,
    tom (tom (tom (tom (tom (tom (tom d)))))) = d :=
begin
  intro d,
  induction d,
  exact rfl,
  exact rfl,
  exact rfl,
  exact rfl,
  exact rfl,
  exact rfl,
  exact rfl,
end

example :
    ∀ d : day,
    tom (tom (tom (tom (tom (tom (tom d)))))) = d :=
begin
  intro d,
  induction d,
  repeat {exact rfl},
end

inductive switch : Type
| On : switch
| Off : switch

open switch

def turnOn (s: switch) : switch :=
match s with
| _ := On
end

def turnOff (s: switch) : switch :=
match s with
| _ := Off
end

def toggle (s : switch) : switch :=
match s with
| On := Off
| Off := On
end

def toggle': switch → switch
  | On := Off
  | Off := On

example : ∀ s : switch, toggle (toggle s) = s :=
begin
  intro s,
  induction s,
  exact rfl,
  exact rfl,
end

#print list
#print prod

inductive myprod (S T : Type) : Type
| mk (s : S) (t : T) : myprod

def p1 := myprod.mk 1 "Hello"

def fst' : ∀ (S T : Type), myprod S T → S
| S T (myprod.mk f s) := f

#eval fst' nat string p1

def fst : ∀ { S T : Type }, myprod S T → S
| S T (myprod.mk f s ) := f

#eval fst p1

def snd' : ∀ (S T : Type), myprod S T → T
| S T (myprod.mk f s) := s

def snd : ∀ { S T : Type }, myprod S T → T
| S T (myprod.mk f s) := s

def swap' : ∀ (S T : Type), myprod S T → myprod T S
| S T (myprod.mk f s) := (myprod.mk s f)

def swap : ∀ { S T : Type }, myprod S T → myprod T S
| S T (myprod.mk f s) := (myprod.mk s f)

#check swap p1

theorem proj_ok :
    ∀ (S T : Type) (s : S) (t : T),
    myprod.mk
        (fst (myprod.mk s t))
        (snd (myprod.mk s t)) =
    (myprod.mk s t) :=
begin
intros S T s t,
exact rfl,
end

theorem proj_ok' :
    ∀ (S T : Type) (pr : myprod S T),
    myprod.mk
        (fst pr)
        (snd  pr) =
    pr :=
begin
intros S T pr,
cases pr with f s,
exact rfl,
end

theorem swap_involutive :
    ∀ (S T : Type) (pr : myprod S T),
    swap (swap pr) = pr :=
begin
  intros S T pr,
  sorry
  --exact rfl,      -- fix this proof
end

-- Let's test it  out
def p2 := myprod.mk 1 2
def p3 := myprod.mk 1 tt
#check p2
#check p3
#eval fst' nat nat (myprod.mk 1 1)
#eval fst (myprod.mk 1 1)
#eval snd' string bool (myprod.mk "Hello" tt)
#eval snd (myprod.mk "Hello" tt)
#eval swap' string bool (myprod.mk "Hello" tt)
#eval swap (myprod.mk "Hello" tt)

/-
BOOLEAN
-/

    inductive mybool : Type
    | ttt : mybool
    | fff : mybool

    open mybool

    -- unary functions (why four?)

    def id_mybool (b: mybool) : mybool := b
    def true_mybool (b: mybool) := ttt
    def false_mybool (b: mybool) := fff
    def not_mybool: mybool → mybool
    | ttt := fff
    | fff := ttt

    -- binary functions (how many are there total?)

    def and_mybool: mybool → mybool → mybool
        | ttt ttt := ttt
        | ttt fff := fff
        | fff ttt := fff
        | fff fff := fff

    def and_mybool': mybool → mybool → mybool
        | ttt ttt := ttt
        | _ _ := fff

    def or_mybool (b1 b2 : mybool) : mybool :=
      match b1, b2 with
        | fff, fff := fff
        | _, _ := ttt
      end

    def implies_mybool (b1 b2 : mybool) : mybool :=
      match b1, b2 with
        | ttt, fff := fff
        | _, _ := ttt
      end

    example: ∀(b1 b2: mybool),
      (implies_mybool b1 b2) = (or_mybool (not_mybool b1) b2) :=
    begin
      intros b1 b2,
      induction b1,
        induction b2,
          -- ttt ttt
          unfold implies_mybool,
          unfold not_mybool,
          unfold or_mybool,
          -- ttt fff
          unfold implies_mybool,
          unfold not_mybool,
          unfold or_mybool,
        -- fff _
        unfold implies_mybool,
        unfold not_mybool,
        unfold or_mybool,
    end

    def xor_mybool (b1 b2 : mybool) : mybool :=
      match b1, b2 with
        | ttt, fff := ttt
        | fff, ttt := ttt
        | _, _ := fff
      end

    -- For booleans, xnor is equality - why?
    def xnor_mybool (b1 b2 : mybool) : mybool :=
      match b1, b2 with
        | ttt, ttt := ttt
        | fff, fff := ttt
        | _, _ := fff
      end

    def eq_mybool (b1 b2 : mybool) : mybool :=
      match b1, b2 with
        | ttt, ttt := ttt
        | fff, fff := ttt
        | _, _ := fff
      end

    example: ∀(b1 b2: mybool),
      (xnor_mybool b1 b2) = (xor_mybool b1 (not_mybool b2)) :=
    begin
      intros,
      induction b1,
        induction b2,
          -- ttt ttt
          unfold xnor_mybool,
          unfold not_mybool,
          unfold xor_mybool,
          -- ttt fff
          unfold xnor_mybool,
          unfold not_mybool,
          unfold xor_mybool,
        induction b2,
          -- fff ttt
          unfold xnor_mybool,
          unfold not_mybool,
          unfold xor_mybool,
          -- fff fff
          unfold xnor_mybool,
          unfold not_mybool,
          unfold xor_mybool,
    end

    lemma xnor_is_eq: ∀(b1 b2: mybool),
      (xnor_mybool b1 b2) = (eq_mybool b1 b2) :=
    begin
      intros,
      exact rfl,
    end

    theorem and_mybool_comm :
        ∀ b1 b2 : mybool, and_mybool b1 b2 = and_mybool b2 b1 :=
    begin
      intros b1 b2,
      induction b1,
      induction b2,
      repeat {trivial},
      induction b2,
      repeat {trivial},
    end

    theorem and_mybool_implies_or_mybool :
        ∀ b1 b2 : mybool,
            implies_mybool (and_mybool b1 b2) (or_mybool b1 b2) = ttt :=
    begin
    intros b1 b2,
    induction b1,
    induction b2,
    trivial,
    trivial,
    induction b2,
    trivial,
    trivial,
    end

    theorem demorgan1 : ∀ b1 b2 : mybool,
        not_mybool (and_mybool b1 b2) =
        or_mybool
            (not_mybool b1)
            (not_mybool b2) :=
    begin
    intros b1 b2,
    induction b1,
    induction b2,
    apply rfl,
    apply rfl,
    induction b2,
    apply rfl,
    apply rfl,
    end

    theorem demorgan2 : ∀ b1 b2 : mybool,
        not_mybool (or_mybool b1 b2) =
        and_mybool
            (not_mybool b1)
            (not_mybool b2) :=
    begin
    intros b1 b2,
    induction b1,
    induction b2,
    apply rfl,
    apply rfl,
    induction b2,
    apply rfl,
    apply rfl,
    end

   -- NATURAL NUMBERS

    namespace mynat

    inductive mynat : Type
    | zero : mynat
    | succ : mynat → mynat

    def z := mynat.zero
    def one := mynat.succ (mynat.zero)
    def two := mynat.succ one
    def three := mynat.succ two
    def four :=     mynat.succ
                        (mynat.succ
                            (mynat.succ
                                (
                                    mynat.succ
                                        mynat.zero
                                )
                            )
                        )

    -- functions

    -- some unary functions
    def id_mynat (n: mynat) := n
    def zero_mynat (n: mynat) := mynat.zero

    def pred : mynat → mynat
    | mynat.zero := mynat.zero
    | (mynat.succ n') := n'

    #reduce pred four

    -- a binary function, and it's recursive
    def add_mynat: mynat → mynat → mynat
    | mynat.zero m := m
    | (mynat.succ n') m :=
        mynat.succ (add_mynat n' m)

    #reduce add_mynat three four

    def mul_mynat: mynat → mynat → mynat
      | mynat.zero m := mynat.zero
      | (mynat.succ n') m := add_mynat m (mul_mynat n' m)

    #reduce mul_mynat two three

    def exp_mynat: mynat → mynat → mynat
      | m mynat.zero := one
      | m (mynat.succ n') := mul_mynat m (exp_mynat m n')

    #reduce exp_mynat two three
    #reduce exp_mynat three two

    -- 3^2 = 2^3 + 1
    example: (exp_mynat three two) =
                mynat.succ(exp_mynat two three) := rfl

    -- tetration
    def tet_mynat: mynat → mynat → mynat
      | m mynat.zero := one
      | m (mynat.succ n') := exp_mynat m (tet_mynat m n')

    #reduce tet_mynat two three

    example: (tet_mynat two three) =
                (exp_mynat two four) := rfl

    -- a certificate

    -- zero is a left identify
    theorem zero_left_id :
        ∀ m : mynat, add_mynat mynat.zero m = m :=
    begin
      intro m,
      trivial,
    end

    -- zero is a right identity, requires induction
    theorem zero_right_id :
        ∀ m : mynat, add_mynat m mynat.zero = m :=
    begin
      intro m,
      -- proof by induction
      induction m with m' h,
        -- first the base case
        apply rfl,
        -- then the inductive case
        simp [add_mynat],
        assumption,
    end

    -- Prove n + (m + 1) = (n + m) + 1
   lemma add_n_succ_m :
     ∀ n m : mynat,
       add_mynat n (mynat.succ m) =
         mynat.succ (add_mynat n m) :=
    begin
      intros n m,
      induction n with n' h,
        apply rfl,  -- base case

        simp [add_mynat], -- inductive case
        assumption,
    end

    example: ∀(m n : mynat),
      add_mynat m n = add_mynat n m :=
    begin
      intros m n,
      -- by induction on m
      induction m with m' h,
        --base case: m = zero
        simp [add_mynat],
        rw zero_right_id,

        -- inductive case: if true for m then true for succ m
        simp [add_mynat],
        rw add_n_succ_m,
        -- rewrite using induction hypothesis!
        rw h,
    end

end mynat

#check nat.zero

example : ∀ n : ℕ, true :=
begin
  intro n,
  cases n with n',
  exact true.intro,
  exact true.intro,
end

example : ∀ (P Q : Prop), P ∨ Q → true :=
begin
  intros P Q pq,
  cases pq with p q,
  exact true.intro,
  exact true.intro,
end

namespace ll_ns

  inductive list : Type
    | empty : list
    | node : ℕ → list → list

  #reduce list.empty
  def list_9 := list.node 9 list.empty
  def list_5_9 := list.node 5 list_9
  def list_1_5_9 := list.node 1 list_5_9
  def list_4_1_5_9 := list.node 4 list_1_5_9
  def list_1_4_1_5_9 := list.node 1 list_4_1_5_9
  def list_pi := list.node 3 list_1_4_1_5_9
  #reduce list_pi

  def count: list → ℕ
    | list.empty := 0
    | (list.node _ next) := 1 + (count next)

  #reduce count list_pi

  -- Not really recursive!
  def count'(ll: list): ℕ :=
    match ll with
      | list.empty := 0
      | (list.node _ next) := 1 + (count next)
    end

  #reduce count' list_pi

  def last: list → ℕ
    | list.empty := 0  -- because we need a total function
    | (list.node val list.empty) := val
    | (list.node _ rem) := last rem

  #reduce last list_pi

  def sum: list → ℕ
    | list.empty := 0
    | (list.node val next) := val + (sum next)

  #reduce sum list_pi

  -- Returns a list devoid of its last node
  -- E.g., (head (list.node 5 (list.node 9 list.empty))) returns
  --         (list.node 5 list.empty)
  def head: list → list
    | list.empty := list.empty
    | (list.node _ list.empty) := list.empty
    | (list.node val rem) := (list.node val (head rem))

  #reduce head list_pi

  -- Lemma that adding an element to a list and then
  -- taking the head is the same as taking the head and
  -- then adding an element (unless the list is empty)
  lemma head_commutes_with_listnode:
    ∀(mylist: list)(val: ℕ),
      (mylist = list.empty) ∨
        (head (list.node val mylist)) =
           (list.node val (head mylist)) :=
  begin
    intros,
    induction mylist with val' mylist',
      -- base case
      apply or.inl,
      exact rfl,
      -- inductive case
      apply or.inr,
      cases mylist_ih,
        -- empty
        simp [head],
        -- non-empty
        simp [head],
  end

  lemma head_shortens_nonempty_list:
    ∀(mylist: list), (mylist = list.empty) ∨
      (count (head mylist)) = (count mylist) - 1 :=
  begin
    assume mylist,
    induction mylist with val mylist casen,
      -- base case
      apply or.inl,
      exact rfl,
      -- inductive case
      apply or.inr,
      cases casen,
        -- empty case
        rw casen,
        simp [head],
        simp [count],
        -- nonempty case
        simp [count],
        induction mylist with val' mylist casen',
          -- base case
          simp[head],
          -- inductive case
          have newfact := head_commutes_with_listnode (list.node val' mylist) val,
          cases newfact with impossibly_empty commutes,
            -- impossibly empty
            trivial,
            -- non-empty
            sorry
  end

  -- Returns a reversed list
  -- A reversed list is a list that starts with the last node
  -- in the original list and is followed by the reverse list
  -- of the head of the original list
--  def reverse: list → list
--    | list.empty := list.empty
--    | nonempty_list := (list.node
--                          (last nonempty_list)
--                          (reverse (head nonempty_list)))

end ll_ns


/-
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 algebra.algebra.pi
import ring_theory.adjoin.basic
import data.polynomial.eval

/-!
# Theory of univariate polynomials

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

We show that `A[X]` is an R-algebra when `A` is an R-algebra.
We promote `eval₂` to an algebra hom in `aeval`.
-/

noncomputable theory
open finset
open_locale big_operators polynomial

namespace polynomial
universes u v w z
variables {R : Type u} {S : Type v} {T : Type w} {A : Type z} {A' B' : Type*} {a b : R} {n : ℕ}
variables [comm_semiring A'] [semiring B']

section comm_semiring
variables [comm_semiring R] {p q r : R[X]}

variables [semiring A] [algebra R A]

/-- Note that this instance also provides `algebra R R[X]`. -/
instance algebra_of_algebra : algebra R A[X] :=
{ smul_def' := λ r p, to_finsupp_injective $ begin
    dsimp only [ring_hom.to_fun_eq_coe, ring_hom.comp_apply],
    rw [to_finsupp_smul, to_finsupp_mul, to_finsupp_C],
    exact algebra.smul_def' _ _,
  end,
  commutes' := λ r p, to_finsupp_injective $ begin
    dsimp only [ring_hom.to_fun_eq_coe, ring_hom.comp_apply],
    simp_rw [to_finsupp_mul, to_finsupp_C],
    convert algebra.commutes' r p.to_finsupp,
  end,
  to_ring_hom := C.comp (algebra_map R A) }

lemma algebra_map_apply (r : R) :
  algebra_map R A[X] r = C (algebra_map R A r) :=
rfl

@[simp] lemma to_finsupp_algebra_map (r : R) :
  (algebra_map R A[X] r).to_finsupp = algebra_map R _ r :=
show to_finsupp (C (algebra_map _ _ r)) = _, by { rw to_finsupp_C, refl }

lemma of_finsupp_algebra_map (r : R) :
  (⟨algebra_map R _ r⟩ : A[X]) = algebra_map R A[X] r :=
to_finsupp_injective (to_finsupp_algebra_map _).symm

/--
When we have `[comm_semiring R]`, the function `C` is the same as `algebra_map R R[X]`.

(But note that `C` is defined when `R` is not necessarily commutative, in which case
`algebra_map` is not available.)
-/
lemma C_eq_algebra_map (r : R) :
  C r = algebra_map R R[X] r :=
rfl

variables {R}

/--
  Extensionality lemma for algebra maps out of `A'[X]` over a smaller base ring than `A'`
-/
@[ext] lemma alg_hom_ext' [algebra R A'] [algebra R B']
  {f g : A'[X] →ₐ[R] B'}
  (h₁ : f.comp (is_scalar_tower.to_alg_hom R A' A'[X]) =
        g.comp (is_scalar_tower.to_alg_hom R A' A'[X]))
  (h₂ : f X = g X) : f = g :=
alg_hom.coe_ring_hom_injective (polynomial.ring_hom_ext'
  (congr_arg alg_hom.to_ring_hom h₁) h₂)

variable (R)

/-- Algebra isomorphism between `R[X]` and `add_monoid_algebra R ℕ`. This is just an
implementation detail, but it can be useful to transfer results from `finsupp` to polynomials. -/
@[simps]
def to_finsupp_iso_alg : R[X] ≃ₐ[R] add_monoid_algebra R ℕ :=
{ commutes' := λ r,
  begin
    dsimp,
    exact to_finsupp_algebra_map _,
  end,
  ..to_finsupp_iso R }

variable {R}

instance [nontrivial A] : nontrivial (subalgebra R A[X]) :=
⟨⟨⊥, ⊤, begin
  rw [ne.def, set_like.ext_iff, not_forall],
  refine ⟨X, _⟩,
  simp only [algebra.mem_bot, not_exists, set.mem_range, iff_true, algebra.mem_top,
    algebra_map_apply, not_forall],
  intro x,
  rw [ext_iff, not_forall],
  refine ⟨1, _⟩,
  simp [coeff_C],
end⟩⟩

@[simp]
lemma alg_hom_eval₂_algebra_map
  {R A B : Type*} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]
  (p : R[X]) (f : A →ₐ[R] B) (a : A) :
  f (eval₂ (algebra_map R A) a p) = eval₂ (algebra_map R B) (f a) p :=
begin
  dsimp [eval₂, sum],
  simp only [f.map_sum, f.map_mul, f.map_pow, eq_int_cast, map_int_cast,
    alg_hom.commutes],
end

@[simp]
lemma eval₂_algebra_map_X {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
  (p : R[X]) (f : R[X] →ₐ[R] A) :
  eval₂ (algebra_map R A) (f X) p = f p :=
begin
  conv_rhs { rw [←polynomial.sum_C_mul_X_pow_eq p], },
  dsimp [eval₂, sum],
  simp only [f.map_sum, f.map_mul, f.map_pow, eq_int_cast, map_int_cast],
  simp [polynomial.C_eq_algebra_map],
end

-- these used to be about `algebra_map ℤ R`, but now the simp-normal form is `int.cast_ring_hom R`.
@[simp]
lemma ring_hom_eval₂_cast_int_ring_hom {R S : Type*} [ring R] [ring S]
  (p : ℤ[X]) (f : R →+* S) (r : R) :
  f (eval₂ (int.cast_ring_hom R) r p) = eval₂ (int.cast_ring_hom S) (f r) p :=
alg_hom_eval₂_algebra_map p f.to_int_alg_hom r

@[simp]
lemma eval₂_int_cast_ring_hom_X {R : Type*} [ring R] (p : ℤ[X]) (f : ℤ[X] →+* R) :
  eval₂ (int.cast_ring_hom R) (f X) p = f p :=
eval₂_algebra_map_X p f.to_int_alg_hom

end comm_semiring

section aeval
variables [comm_semiring R] {p q : R[X]}

variables [semiring A] [algebra R A]
variables {B : Type*} [semiring B] [algebra R B]
variables (x : A)

/-- Given a valuation `x` of the variable in an `R`-algebra `A`, `aeval R A x` is
the unique `R`-algebra homomorphism from `R[X]` to `A` sending `X` to `x`.

This is a stronger variant of the linear map `polynomial.leval`. -/
def aeval : R[X] →ₐ[R] A :=
{ commutes' := λ r, eval₂_C _ _,
  ..eval₂_ring_hom' (algebra_map R A) x (λ a, algebra.commutes _ _) }

variables {R A}

@[simp] lemma adjoin_X : algebra.adjoin R ({X} : set R[X]) = ⊤ :=
begin
  refine top_unique (λ p hp, _),
  set S := algebra.adjoin R ({X} : set R[X]),
  rw [← sum_monomial_eq p], simp only [← smul_X_eq_monomial, sum],
  exact S.sum_mem (λ n hn, S.smul_mem (S.pow_mem (algebra.subset_adjoin rfl) _) _)
end

@[ext] lemma alg_hom_ext {f g : R[X] →ₐ[R] A} (h : f X = g X) : f = g :=
alg_hom.ext_of_adjoin_eq_top adjoin_X $ λ p hp, (set.mem_singleton_iff.1 hp).symm ▸ h

theorem aeval_def (p : R[X]) : aeval x p = eval₂ (algebra_map R A) x p := rfl

@[simp] lemma aeval_zero : aeval x (0 : R[X]) = 0 :=
alg_hom.map_zero (aeval x)

@[simp] lemma aeval_X : aeval x (X : R[X]) = x := eval₂_X _ x

@[simp] lemma aeval_C (r : R) : aeval x (C r) = algebra_map R A r := eval₂_C _ x

@[simp] lemma aeval_monomial {n : ℕ} {r : R} : aeval x (monomial n r) = (algebra_map _ _ r) * x^n :=
eval₂_monomial _ _

@[simp] lemma aeval_X_pow {n : ℕ} : aeval x ((X : R[X])^n) = x^n :=
eval₂_X_pow _ _

@[simp] lemma aeval_add : aeval x (p + q) = aeval x p + aeval x q :=
alg_hom.map_add _ _ _

@[simp] lemma aeval_one : aeval x (1 : R[X]) = 1 :=
alg_hom.map_one _

@[simp] lemma aeval_bit0 : aeval x (bit0 p) = bit0 (aeval x p) :=
alg_hom.map_bit0 _ _

@[simp] lemma aeval_bit1 : aeval x (bit1 p) = bit1 (aeval x p) :=
alg_hom.map_bit1 _ _

@[simp] lemma aeval_nat_cast (n : ℕ) : aeval x (n : R[X]) = n :=
map_nat_cast _ _

lemma aeval_mul : aeval x (p * q) = aeval x p * aeval x q :=
alg_hom.map_mul _ _ _

lemma aeval_comp {A : Type*} [comm_semiring A] [algebra R A] (x : A) :
  aeval x (p.comp q) = (aeval (aeval x q) p) :=
eval₂_comp (algebra_map R A)

theorem aeval_alg_hom (f : A →ₐ[R] B) (x : A) : aeval (f x) = f.comp (aeval x) :=
alg_hom_ext $ by simp only [aeval_X, alg_hom.comp_apply]

@[simp] theorem aeval_X_left : aeval (X : R[X]) = alg_hom.id R R[X] :=
alg_hom_ext $ aeval_X X

theorem aeval_X_left_apply (p : R[X]) : aeval X p = p :=
alg_hom.congr_fun (@aeval_X_left R _) p

theorem eval_unique (φ : R[X] →ₐ[R] A) (p) :
  φ p = eval₂ (algebra_map R A) (φ X) p :=
by rw [← aeval_def, aeval_alg_hom, aeval_X_left, alg_hom.comp_id]

theorem aeval_alg_equiv (f : A ≃ₐ[R] B) (x : A) : aeval (f x) = (f : A →ₐ[R] B).comp (aeval x) :=
aeval_alg_hom (f : A →ₐ[R] B) x

lemma aeval_algebra_map_apply_eq_algebra_map_eval (x : R) (p : R[X]) :
  aeval (algebra_map R A x) p = algebra_map R A (p.eval x) :=
aeval_alg_hom_apply (algebra.of_id R A) x p

@[simp] lemma coe_aeval_eq_eval (r : R) : (aeval r : R[X] → R) = eval r := rfl

@[simp] lemma coe_aeval_eq_eval_ring_hom (x : R) :
  ((aeval x : R[X] →ₐ[R] R) : R[X] →+* R) = eval_ring_hom x :=
rfl

@[simp] lemma aeval_fn_apply {X : Type*} (g : R[X]) (f : X → R) (x : X) :
  ((aeval f) g) x = aeval (f x) g :=
(aeval_alg_hom_apply (pi.eval_alg_hom R (λ _, R) x) f g).symm

@[norm_cast] lemma aeval_subalgebra_coe
  (g : R[X]) {A : Type*} [semiring A] [algebra R A] (s : subalgebra R A) (f : s) :
  (aeval f g : A) = aeval (f : A) g :=
(aeval_alg_hom_apply s.val f g).symm

lemma coeff_zero_eq_aeval_zero (p : R[X]) : p.coeff 0 = aeval 0 p :=
by simp [coeff_zero_eq_eval_zero]

lemma coeff_zero_eq_aeval_zero' (p : R[X]) :
  algebra_map R A (p.coeff 0) = aeval (0 : A) p :=
by simp [aeval_def]

lemma map_aeval_eq_aeval_map {S T U : Type*} [comm_semiring S] [comm_semiring T] [semiring U]
  [algebra R S] [algebra T U] {φ : R →+* T} {ψ : S →+* U}
  (h : (algebra_map T U).comp φ = ψ.comp (algebra_map R S)) (p : R[X]) (a : S) :
  ψ (aeval a p) = aeval (ψ a) (p.map φ) :=
begin
  conv_rhs {rw [aeval_def, ← eval_map]},
  rw [map_map, h, ← map_map, eval_map, eval₂_at_apply, aeval_def, eval_map],
end

lemma aeval_eq_zero_of_dvd_aeval_eq_zero [comm_semiring S] [comm_semiring T] [algebra S T]
  {p q : S[X]} (h₁ : p ∣ q) {a : T} (h₂ : aeval a p = 0) : aeval a q = 0 :=
begin
  rw [aeval_def, ← eval_map] at h₂ ⊢,
  exact eval_eq_zero_of_dvd_of_eval_eq_zero (polynomial.map_dvd (algebra_map S T) h₁) h₂,
end

variable (R)

theorem _root_.algebra.adjoin_singleton_eq_range_aeval (x : A) :
  algebra.adjoin R {x} = (polynomial.aeval x).range :=
by rw [← algebra.map_top, ← adjoin_X, alg_hom.map_adjoin, set.image_singleton, aeval_X]

variable {R}

section semiring

variables [semiring S] {f : R →+* S}

lemma aeval_eq_sum_range [algebra R S] {p : R[X]} (x : S) :
  aeval x p = ∑ i in finset.range (p.nat_degree + 1), p.coeff i • x ^ i :=
by { simp_rw algebra.smul_def, exact eval₂_eq_sum_range (algebra_map R S) x }

lemma aeval_eq_sum_range' [algebra R S] {p : R[X]} {n : ℕ} (hn : p.nat_degree < n) (x : S) :
  aeval x p = ∑ i in finset.range n, p.coeff i • x ^ i :=
by { simp_rw algebra.smul_def, exact eval₂_eq_sum_range' (algebra_map R S) hn x }

lemma is_root_of_eval₂_map_eq_zero
  (hf : function.injective f) {r : R} : eval₂ f (f r) p = 0 → p.is_root r :=
begin
  intro h,
  apply hf,
  rw [←eval₂_hom, h, f.map_zero],
end

lemma is_root_of_aeval_algebra_map_eq_zero [algebra R S] {p : R[X]}
  (inj : function.injective (algebra_map R S))
  {r : R} (hr : aeval (algebra_map R S r) p = 0) : p.is_root r :=
is_root_of_eval₂_map_eq_zero inj hr

end semiring

section comm_semiring

section aeval_tower

variables [comm_semiring S] [algebra S R] [algebra S A'] [algebra S B']

/-- Version of `aeval` for defining algebra homs out of `R[X]` over a smaller base ring
  than `R`. -/
def aeval_tower (f : R →ₐ[S] A') (x : A') : R[X] →ₐ[S] A' :=
{ commutes' := λ r, by simp [algebra_map_apply],
  ..eval₂_ring_hom ↑f x }

variables (g : R →ₐ[S] A') (y : A')

@[simp] lemma aeval_tower_X : aeval_tower g y X = y := eval₂_X _ _

@[simp] lemma aeval_tower_C (x : R) : aeval_tower g y (C x) = g x := eval₂_C _ _

@[simp] lemma aeval_tower_comp_C : ((aeval_tower g y : R[X] →+* A').comp C) = g :=
ring_hom.ext $ aeval_tower_C _ _

@[simp] lemma aeval_tower_algebra_map (x : R) :
  aeval_tower g y (algebra_map R R[X] x) = g x := eval₂_C _ _

@[simp] lemma aeval_tower_comp_algebra_map :
  (aeval_tower g y : R[X] →+* A').comp (algebra_map R R[X]) = g :=
aeval_tower_comp_C _ _

lemma aeval_tower_to_alg_hom (x : R) :
  aeval_tower g y (is_scalar_tower.to_alg_hom S R R[X] x) = g x :=
aeval_tower_algebra_map _ _ _

@[simp] lemma aeval_tower_comp_to_alg_hom :
  (aeval_tower g y).comp (is_scalar_tower.to_alg_hom S R R[X]) = g :=
alg_hom.coe_ring_hom_injective $ aeval_tower_comp_algebra_map _ _

@[simp] lemma aeval_tower_id : aeval_tower (alg_hom.id S S) = aeval :=
by { ext, simp only [eval_X, aeval_tower_X, coe_aeval_eq_eval], }

@[simp] lemma aeval_tower_of_id : aeval_tower (algebra.of_id S A') = aeval :=
by { ext, simp only [aeval_X, aeval_tower_X], }

end aeval_tower

end comm_semiring

section comm_ring

variables [comm_ring S] {f : R →+* S}

lemma dvd_term_of_dvd_eval_of_dvd_terms {z p : S} {f : S[X]} (i : ℕ)
  (dvd_eval : p ∣ f.eval z) (dvd_terms : ∀ (j ≠ i), p ∣ f.coeff j * z ^ j) :
  p ∣ f.coeff i * z ^ i :=
begin
  by_cases hi : i ∈ f.support,
  { rw [eval, eval₂, sum] at dvd_eval,
    rw [←finset.insert_erase hi, finset.sum_insert (finset.not_mem_erase _ _)] at dvd_eval,
    refine (dvd_add_left _).mp dvd_eval,
    apply finset.dvd_sum,
    intros j hj,
    exact dvd_terms j (finset.ne_of_mem_erase hj) },
  { convert dvd_zero p,
    rw not_mem_support_iff at hi,
    simp [hi] }
end

lemma dvd_term_of_is_root_of_dvd_terms {r p : S} {f : S[X]} (i : ℕ)
  (hr : f.is_root r) (h : ∀ (j ≠ i), p ∣ f.coeff j * r ^ j) : p ∣ f.coeff i * r ^ i :=
dvd_term_of_dvd_eval_of_dvd_terms i (eq.symm hr ▸ dvd_zero p) h

end comm_ring

end aeval

section ring
variables [ring R]

/--
The evaluation map is not generally multiplicative when the coefficient ring is noncommutative,
but nevertheless any polynomial of the form `p * (X - monomial 0 r)` is sent to zero
when evaluated at `r`.

This is the key step in our proof of the Cayley-Hamilton theorem.
-/
lemma eval_mul_X_sub_C {p : R[X]} (r : R) :
  (p * (X - C r)).eval r = 0 :=
begin
  simp only [eval, eval₂, ring_hom.id_apply],
  have bound := calc
    (p * (X - C r)).nat_degree
         ≤ p.nat_degree + (X - C r).nat_degree : nat_degree_mul_le
     ... ≤ p.nat_degree + 1 : add_le_add_left (nat_degree_X_sub_C_le _) _
     ... < p.nat_degree + 2 : lt_add_one _,
  rw sum_over_range' _ _ (p.nat_degree + 2) bound,
  swap,
  { simp, },
  rw sum_range_succ',
  conv_lhs
  { congr, apply_congr, skip,
    rw [coeff_mul_X_sub_C, sub_mul, mul_assoc, ←pow_succ], },
  simp [sum_range_sub', coeff_monomial],
end

theorem not_is_unit_X_sub_C [nontrivial R] (r : R) : ¬ is_unit (X - C r) :=
λ ⟨⟨_, g, hfg, hgf⟩, rfl⟩, zero_ne_one' R $ by erw [← eval_mul_X_sub_C, hgf, eval_one]

end ring

lemma aeval_endomorphism {M : Type*}
  [comm_ring R] [add_comm_group M] [module R M]
  (f : M →ₗ[R] M) (v : M) (p : R[X]) :
  aeval f p v = p.sum (λ n b, b • (f ^ n) v) :=
begin
  rw [aeval_def, eval₂],
  exact (linear_map.applyₗ v).map_sum,
end

end polynomial


/- Author: E.W.Ayers © 2019 -/
import ..equate tactic
open robot
universe u
section rings
    -- [TODO] one of the examples in `group` is to show this, so there should be a way of telling `equate` to omit rules.
    attribute [equate] neg_sub

    variables {α : Type u} [comm_ring α] {a b c d e p x y z : α}

    @[equate] lemma sub_minus : - (a - b) = - a - - b := by equate
    -- comparison with new lemma added
    lemma sumsq_with_equate : (a + b) * (a + b) = a * a + 2 * (a * b) + b * b :=
    by equate
    lemma sumsq_with_ring : (a + b) * (a + b) = a * a + 2 * (a * b) + b * b :=
    by ring
    -- compare proof terms:
    #print sumsq_with_equate
    #print sumsq_with_ring
    -- example : (a + b) * (a - b) = a * a - b * b :=
    -- by equate -- [FIXME]
    example : (a * d) * b + b * (c * e) = (a * d + c * e) * b :=
    by equate
    example : a * b + b * c = (a + c) * b :=
    by equate
    example : (a + c) * b = c * b + b * a := by equate
    example : (a + c) * b = c * b + b * a := by ring

    example : (a * -d - b * - c) * e = -((a * d - b * c) * e) :=
    by equate
    /- [NOTE] the below examples show that our system is not yet able to deal well
    with 'unbalanced' problems where more than one occurrence of a variable is present.
    We aim to fix this with the 'Merge' subtask. -/
    example : (a * b - c * d) = b * a - b * c + (b * c - d * c) :=
    by equate -- [FIXME]
    example : (a + b) * (a - b) = a * a - b * b :=
    by equate -- [FIXME]
    example : (a * b) - c + (b * a) = - c + 2 * (a *  b) :=
    by equate -- [FIXME]
    example : (a * b) - c + (b * a) = - c + (2 * a) *  b :=
    by equate -- [FIXME]
    example : (a * b) - c + (b * a) = - c + a * (b + b) :=
    by equate -- [FIXME]

    /- An extreme comparison of the differences in proof lengths and perils of normal form. -/
    lemma sum_cube_with_equate : (x+y)^3+(x+z)^3 = (z+x)^3+(y+x)^3 := by equate
    lemma sum_cube_with_acrefl : (x+y)^3+(x+z)^3 = (z+x)^3+(y+x)^3 :=
         by ac_refl
    /- `ring` does really badly because it puts the two expressions in to normal form. -/
    lemma sum_cube_with_ring : (x+y)^3+(x+z)^3 = (z+x)^3+(y+x)^3 :=
         by ring
    #print sum_cube_with_equate -- uses eq.trans 3 times
    #print sum_cube_with_acrefl -- uses eq.trans 9 times
    #print sum_cube_with_ring
end rings


variables (α : Type) (p q : α → Prop)

example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
  let ⟨w, hpw, hqw⟩ := h in ⟨w, hqw, hpw⟩


/-
Copyright (c) 2014 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Ported from Coq HoTT
Theorems about arrow types (function spaces)
-/

import hott.types.pi

universe u
hott_theory

namespace hott
open eq hott.equiv hott.is_equiv is_trunc

namespace pi

  variables {A : Type _} {A' : Type _} {B : Type _} {B' : Type _} {C : A → B → Type _} {D : A → Type _}
            {a a' a'' : A} {b b' b'' : B} {f g : A → B} {d : D a} {d' : D a'}

  -- all lemmas here are special cases of the ones for pi-types

  /- Functorial action -/
  variables (f0 : A' → A) (f1 : B → B')

  @[hott] def arrow_functor : (A → B) → (A' → B') := pi_functor f0 (λa, f1)

  /- Equivalences -/

  @[hott] def is_equiv_arrow_functor
    [H0 : is_equiv f0] [H1 : is_equiv f1] : is_equiv (arrow_functor f0 f1) :=
  is_equiv_pi_functor f0 (λa, f1)

  @[hott] def arrow_equiv_arrow_rev (f0 : A' ≃ A) (f1 : B ≃ B')
    : (A → B) ≃ (A' → B') :=
  equiv.mk _ (is_equiv_arrow_functor f0 f1)

  @[hott] def arrow_equiv_arrow (f0 : A ≃ A') (f1 : B ≃ B') : (A → B) ≃ (A' → B') :=
  arrow_equiv_arrow_rev (equiv.symm f0) f1

  variable (A)
  @[hott] def arrow_equiv_arrow_right (f1 : B ≃ B') : (A → B) ≃ (A → B') :=
  arrow_equiv_arrow_rev equiv.rfl f1

  variables {A} (B)
  @[hott] def arrow_equiv_arrow_left_rev (f0 : A' ≃ A) : (A → B) ≃ (A' → B) :=
  arrow_equiv_arrow_rev f0 equiv.rfl

  @[hott] def arrow_equiv_arrow_left (f0 : A ≃ A') : (A → B) ≃ (A' → B) :=
  arrow_equiv_arrow f0 equiv.rfl

  variables {B}
  @[hott] def arrow_equiv_arrow_right' (f1 : A → (B ≃ B')) : (A → B) ≃ (A → B') :=
  pi_equiv_pi_right f1

  /- Equivalence if one of the types is contractible -/

  variables (A B)
  -- we prove this separately from pi_equiv_of_is_contr_left,
  --   because the underlying inverse function is simpler here (no transport needed)
  @[hott] def arrow_equiv_of_is_contr_left [H : is_contr A] : (A → B) ≃ B :=
  begin
    fapply equiv.MK,
    { intro f, exact f (center A)},
    { intros b a, exact b},
    { intro b, reflexivity},
    { intro f, apply eq_of_homotopy, intro a, exact ap f (is_prop.elim _ _)}
  end

  @[hott] def arrow_equiv_of_is_contr_right [H : is_contr B] : (A → B) ≃ unit :=
  pi_equiv_of_is_contr_right _

  /- Interaction with other type constructors -/

  -- most of these are in the file of the other type constructor

  @[hott] def arrow_empty_left : (empty → B) ≃ unit :=
  pi_empty_left _

  @[hott] def arrow_unit_left : (unit → B) ≃ B :=
  arrow_equiv_of_is_contr_left _ _

  @[hott] def arrow_unit_right : (A → unit) ≃ unit :=
  arrow_equiv_of_is_contr_right _ _

  variables {A B}

  /- Transport -/

  @[hott] def arrow_transport {B C : A → Type _} (p : a = a') (f : B a → C a)
    : (transport (λa, B a → C a) p f) ~ (λb, p ▸ f (p⁻¹ ▸ b)) :=
  eq.rec_on p (λx, idp)

  /- Pathovers -/

  @[hott] def arrow_pathover {B C : A → Type _} {f : B a → C a} {g : B a' → C a'} {p : a = a'}
    (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[p] g b') : f =[p; λa, B a → C a] g :=
  begin
    induction p, apply pathover_idp_of_eq,
    apply eq_of_homotopy, hintro b,
    exact eq_of_pathover_idp (r b b idpo),
  end

  @[hott] def arrow_pathover_left {B C : A → Type _} {f : B a → C a} {g : B a' → C a'} {p : a = a'}
    (r : Π(b : B a), f b =[p] g (p ▸ b)) : f =[p; λa, B a → C a] g :=
  begin
    induction p, apply pathover_idp_of_eq,
    apply eq_of_homotopy, hintro b,
    exact eq_of_pathover_idp (r b),
  end

  @[hott] def arrow_pathover_right {B C : A → Type _} {f : B a → C a} {g : B a' → C a'} {p : a = a'}
    (r : Π(b' : B a'), f (p⁻¹ ▸ b') =[p] g b') : f =[p; λa, B a → C a] g :=
  begin
    induction p, apply pathover_idp_of_eq,
    apply eq_of_homotopy, hintro b,
    exact eq_of_pathover_idp (r b),
  end

  @[hott] def arrow_pathover_constant_left {B : Type _} {C : A → Type _} {f : B → C a} {g : B → C a'}
    {p : a = a'} (r : Π(b : B), f b =[p] g b) : f =[p; λa, B → C a] g :=
  pi_pathover_constant r

  @[hott] def arrow_pathover_constant_right' {B : A → Type _} {C : Type _}
    {f : B a → C} {g : B a' → C} {p : a = a'}
    (r : Π⦃b : B a⦄ ⦃b' : B a'⦄ (q : b =[p] b'), f b = g b') : f =[p; λa, B a → C] g :=
  arrow_pathover (λb b' q, pathover_of_eq p (r q))

  @[hott] def arrow_pathover_constant_right {B : A → Type _} {C : Type _} {f : B a → C}
    {g : B a' → C} {p : a = a'} (r : Π(b : B a), f b = g (p ▸ b)) : f =[p; λa, B a → C] g :=
  arrow_pathover_left (λb, pathover_of_eq p (r b))

  @[hott] def arrow_pathover_constant_right_rev {A : Type _} {B : A → Type _} {C : Type _} {a a' : A}
    {f : B a → C} {g : B a' → C} {p : a = a'} (r : Π(b : B a'), f (p⁻¹ ▸ b) = g b) : f =[p; λa, B a → C] g :=
  arrow_pathover_right (λb, pathover_of_eq p (r b))

  /- a @[hott] lemma used for the flattening lemma, and is also used in the colimits file -/
  @[hott] def apo11_arrow_pathover_constant_right {f : D a → A'} {g : D a' → A'} {p : a = a'}
    {q : d =[p; D] d'} (r : Π(d : D a), f d = g (p ▸ d))
    : apo11_constant_right (arrow_pathover_constant_right r) q = r d ⬝ ap g (tr_eq_of_pathover q)
      :=
  begin
    induction q,
    eapply homotopy.rec_on r, clear r, intro r, dsimp at r, induction r,
    dsimp [apd10, arrow_pathover_constant_right, arrow_pathover_left, pathover_of_eq, eq_of_pathover_idp, tr_eq_of_pathover],
    rwr [eq_of_homotopy_idp]
  end

  /-
     The fact that the arrow type preserves truncation level is a direct consequence
     of the fact that pi's preserve truncation level
  -/
  @[hott] def is_trunc_arrow (B : Type _) (n : ℕ₋₂) [H : is_trunc n B] : is_trunc n (A → B) :=
  by apply_instance

  section hsquare
  variables {A₀₀ : Type _} {A₂₀ : Type _} {A₄₀ : Type _}
            {A₀₂ : Type _} {A₂₂ : Type _} {A₄₂ : Type _}
            {A₀₄ : Type _} {A₂₄ : Type _} {A₄₄ : Type _}
            {f₁₀ : A₀₀ → A₂₀} {f₃₀ : A₂₀ → A₄₀}
            {f₀₁ : A₀₀ → A₀₂} {f₂₁ : A₂₀ → A₂₂} {f₄₁ : A₄₀ → A₄₂}
            {f₁₂ : A₀₂ → A₂₂} {f₃₂ : A₂₂ → A₄₂}
            {f₀₃ : A₀₂ → A₀₄} {f₂₃ : A₂₂ → A₂₄} {f₄₃ : A₄₂ → A₄₄}
            {f₁₄ : A₀₄ → A₂₄} {f₃₄ : A₂₄ → A₄₄}

  @[hott, reducible] def hsquare (f₁₀ : A₀₀ → A₂₀) (f₁₂ : A₀₂ → A₂₂)
                                 (f₀₁ : A₀₀ → A₀₂) (f₂₁ : A₂₀ → A₂₂) : Type _ :=
  f₂₁ ∘ f₁₀ ~ f₁₂ ∘ f₀₁

  @[hott] def hsquare_of_homotopy (p : f₂₁ ∘ f₁₀ ~ f₁₂ ∘ f₀₁) : hsquare f₁₀ f₁₂ f₀₁ f₂₁ :=
  p

  @[hott] def homotopy_of_hsquare (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) : f₂₁ ∘ f₁₀ ~ f₁₂ ∘ f₀₁ :=
  p

  @[hott] def homotopy_top_of_hsquare {f₂₁ : A₂₀ ≃ A₂₂} (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
    f₁₀ ~ f₂₁⁻¹ᶠ ∘ f₁₂ ∘ f₀₁ :=
  homotopy_inv_of_homotopy_post _ _ _ p

  @[hott] def homotopy_top_of_hsquare' [is_equiv f₂₁] (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
    f₁₀ ~ f₂₁⁻¹ᶠ ∘ f₁₂ ∘ f₀₁ :=
  homotopy_inv_of_homotopy_post _ _ _ p

  @[hott] def hhconcat (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) (q : hsquare f₃₀ f₃₂ f₂₁ f₄₁) :
    hsquare (f₃₀ ∘ f₁₀) (f₃₂ ∘ f₁₂) f₀₁ f₄₁ :=
  begin have h1 := hwhisker_right f₁₀ q, have h2 := hwhisker_left f₃₂ p, exact h1 ⬝hty h2 end

  @[hott] def hvconcat (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) (q : hsquare f₁₂ f₁₄ f₀₃ f₂₃) :
    hsquare f₁₀ f₁₄ (f₀₃ ∘ f₀₁) (f₂₃ ∘ f₂₁) :=
  begin have h1 := hwhisker_left f₂₃ p, have h2 := hwhisker_right f₀₁ q, exact h1 ⬝hty h2 end

  @[hott] def hhinverse {f₁₀ : A₀₀ ≃ A₂₀} {f₁₂ : A₀₂ ≃ A₂₂} (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
    hsquare f₁₀⁻¹ᵉ f₁₂⁻¹ᵉ f₂₁ f₀₁ :=
  λb, eq_inv_of_eq ((p (f₁₀⁻¹ᵉ b))⁻¹ ⬝ ap f₂₁ (to_right_inv f₁₀ b))

  @[hott] def hvinverse {f₀₁ : A₀₀ ≃ A₀₂} {f₂₁ : A₂₀ ≃ A₂₂} (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
    hsquare f₁₂ f₁₀ f₀₁⁻¹ᵉ f₂₁⁻¹ᵉ :=
  λa, inv_eq_of_eq (p (f₀₁⁻¹ᵉ a) ⬝ ap f₁₂ (to_right_inv f₀₁ a))⁻¹

  infix ` ⬝htyh `:73 := hhconcat
  infix ` ⬝htyv `:73 := hvconcat
  postfix `⁻¹ʰᵗʸʰ`:(max+1) := hhinverse
  postfix `⁻¹ʰᵗʸᵛ`:(max+1) := hvinverse

  end hsquare

end pi
end hott


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import analysis.normed.group.completion
import analysis.normed_space.operator_norm
import topology.algebra.uniform_mul_action

/-!
# Normed space structure on the completion of a normed space

If `E` is a normed space over `𝕜`, then so is `uniform_space.completion E`. In this file we provide
necessary instances and define `uniform_space.completion.to_complₗᵢ` - coercion
`E → uniform_space.completion E` as a bundled linear isometry.
-/

noncomputable theory

namespace uniform_space
namespace completion

variables (𝕜 E : Type*) [normed_field 𝕜] [normed_group E] [normed_space 𝕜 E]

@[priority 100]
instance normed_space.to_has_uniform_continuous_const_smul :
  has_uniform_continuous_const_smul 𝕜 E :=
⟨λ c, (lipschitz_with_smul c).uniform_continuous⟩

instance : normed_space 𝕜 (completion E) :=
{ smul := (•),
  norm_smul_le := λ c x, induction_on x
    (is_closed_le (continuous_const_smul _).norm (continuous_const.mul continuous_norm)) $
    λ y, by simp only [← coe_smul, norm_coe, norm_smul],
  .. completion.module }

variables {𝕜 E}

/-- Embedding of a normed space to its completion as a linear isometry. -/
def to_complₗᵢ : E →ₗᵢ[𝕜] completion E :=
{ to_fun := coe,
  map_smul' := coe_smul,
  norm_map' := norm_coe,
  .. to_compl }

@[simp] lemma coe_to_complₗᵢ : ⇑(to_complₗᵢ : E →ₗᵢ[𝕜] completion E) = coe := rfl

/-- Embedding of a normed space to its completion as a continuous linear map. -/
def to_complL : E →L[𝕜] completion E :=
to_complₗᵢ.to_continuous_linear_map

@[simp] lemma coe_to_complL : ⇑(to_complL : E →L[𝕜] completion E) = coe := rfl

@[simp] lemma norm_to_complL {𝕜 E : Type*} [nondiscrete_normed_field 𝕜]
  [normed_group E] [normed_space 𝕜 E] [nontrivial E] : ∥(to_complL : E →L[𝕜] completion E)∥ = 1 :=
(to_complₗᵢ : E →ₗᵢ[𝕜] completion E).norm_to_continuous_linear_map

end completion
end uniform_space


import data.fintype -- for finset and finset.sum
import data.real.basic

universe u

variables {R : Type u} [add_comm_monoid R]

-- my_sum_to_n eats a summand f(n) and returns the function sending t to f(0)+f(1)+...+f(t-1).
-- Chris says use finsets.
definition sum_to_n_minus_one (summand : ℕ → R) : ℕ → R :=
λ n, (finset.range n).sum summand

--#reduce sum_to_n_minus_one (λ n, n ^ 2) 1000000

#check finset.range 4 -- finset ℕ

#check @finset.sum

definition sum_from_a_to_b_minus_one (summand : ℕ → R) (a b : ℕ) : R :=
(finset.Ico a b).sum summand

#eval sum_from_a_to_b_minus_one (id) 4 7

theorem finset.polygon {α : Type*} [decidable_eq α] (X : finset α) (summand : α → ℝ) :
abs (X.sum summand) ≤ X.sum (λ a, abs (summand a)) :=
begin
  apply finset.induction_on X,
  { simp },
  { intro a,
    intro s,
    intro hs,
    intro ih,
    sorry
  }
end


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import bernoulli_measure.bernoulli_measure_def
import dirichlet_character.teichmuller_character
import topology.algebra.continuous_monoid_hom

/-!
# p-adic L-function
This file defines the p-adic L-function in terms of a p-adic integral with respect to the
Bernoulli measure. The p-adic L-function takes special values at negative integers, in terms
of generalized Bernoulli numbers. This result is proved in a separate file.

## Main definitions
 * `p_adic_L_function`
 * `mul_inv_pow_hom`

## Implementation notes
 * `pri_dir_char_extend'` replaced with `dir_char_extend`
 * Try to avoid `teichmuller_character_mod_p_change_level`
 * `neg_pow'_to_hom` replaced with `mul_inv_pow_hom`
 * `neg_pow'` replaced with `mul_inv_pow`
 * `clopen_from_units` replaced with `clopen_from.units`

## References
Introduction to Cyclotomic Fields, Washington (Chapter 12, Section 2)

## Tags
p-adic, L-function, Bernoulli measure, Dirichlet character
-/

open_locale big_operators
local attribute [instance] zmod.topological_space

open padic_int
variables {p : ℕ} [fact (nat.prime p)] {d : ℕ} {R : Type*} [normed_comm_ring R] (m : ℕ)
(hd : d.coprime p) (χ : dirichlet_character R (d*(p^m))) {c : ℕ} (hc : c.coprime p)
(hc' : c.coprime d) (na : ∀ (n : ℕ) (f : ℕ → R),
  ∥ ∑ (i : ℕ) in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f i.val∥)

variables (p d R c)
open locally_constant zmod nat

/-- Extending the Dirichlet character χ with level (d* p^m) ; We use the composition
  of χ with the Chinese remainder and `to_zmod_pow` -/
noncomputable abbreviation dirichlet_char_extend (hd : d.coprime p) (χ : (zmod (d*(p^m)))ˣ →* Rˣ) :
  ((zmod d)ˣ × ℤ_[p]ˣ) →* Rˣ :=
χ.comp (((units.map (zmod.chinese_remainder (coprime.pow_right m hd)).symm.to_monoid_hom).comp (mul_equiv.to_monoid_hom
(mul_equiv.symm mul_equiv.prod_units))).comp (monoid_hom.prod_map (monoid_hom.id (units (zmod d)))
(units.map (padic_int.to_zmod_pow m).to_monoid_hom)))

namespace dirichlet_char_extend
open zmod
@[continuity]
lemma continuous : continuous (dirichlet_char_extend p d R m hd χ) :=
continuous.comp continuous_of_discrete_topology (continuous.comp (continuous.comp
(continuous.comp continuous_of_discrete_topology continuous_of_discrete_topology)
begin
  simp only [monoid_hom.id_apply, ring_hom.to_monoid_hom_eq_coe, monoid_hom.coe_prod_map,
    prod_map],
  refine continuous_fst.prod_mk (continuous.comp (cont_units_map (cont_inv) induced_top_cont_inv
    (continuous_to_zmod_pow m)) continuous_snd), end) (continuous_id))

end dirichlet_char_extend

variables (p d R)
/-- Given a natural number s, defines the monoid homomorphism <a>^s taking a ∈ ℤ/dℤ* × ℤₚ* to
  (a * ω⁻¹ (a.2 (mod p)))^s in R. -/
noncomputable abbreviation mul_inv_pow_hom [algebra ℚ_[p] R] (s : ℕ) : (zmod d)ˣ × ℤ_[p]ˣ →* R :=
((algebra_map ℚ_[p] R).to_monoid_hom).comp (coe.ring_hom.to_monoid_hom.comp
((units.coe_hom ℤ_[p]).comp (((monoid_hom.snd (zmod d)ˣ ℤ_[p]ˣ) * (monoid_hom.comp
(monoid_hom.comp (teichmuller_character_mod_p p)⁻¹ (units.map to_zmod.to_monoid_hom))
(monoid_hom.snd ((zmod d)ˣ) (ℤ_[p]ˣ))))^s)))

namespace normed_algebra_map
lemma continuous {α β : Type*} [normed_field α] [semi_normed_ring β]
  [normed_algebra α β] : continuous (algebra_map α β) :=
by { rw algebra.algebra_map_eq_smul_one', exact continuous_id'.smul continuous_const, }
end normed_algebra_map

open zmod

@[continuity]
lemma mul_inv_pow_hom_continuous [normed_algebra ℚ_[p] R] (s : ℕ) :
  continuous (mul_inv_pow_hom p d R s) :=
continuous.comp normed_algebra_map.continuous (continuous.comp (continuous_induced_dom.comp
  (continuous.comp (units.continuous_coe.comp (continuous.comp ((continuous_pow s).comp
  (continuous.comp (continuous.mul continuous_snd (continuous.comp
  (continuous.comp (continuous.comp continuous_of_discrete_topology
  (continuous.comp (cont_units_map cont_inv induced_top_cont_inv continuous_to_zmod) continuous_id))
  continuous_snd) continuous_id)) continuous_id)) continuous_id)) continuous_id)) continuous_id)

/-- The element of weight space corresponding to `mul_inv_pow_hom`. -/
noncomputable abbreviation mul_inv_pow [normed_algebra ℚ_[p] R] (s : ℕ) :
  continuous_monoid_hom (units (zmod d) × units ℤ_[p]) R :=
continuous_monoid_hom.mk' (mul_inv_pow_hom p d R s) (mul_inv_pow_hom_continuous p d R s)

variables {p d R} (w : continuous_monoid_hom ((zmod d)ˣ × ℤ_[p]ˣ) R)

theorem cont_paLf : _root_.continuous ((units.coe_hom R).comp (dirichlet_char_extend p d R m hd χ) * w.to_monoid_hom) :=
continuous.mul (units.continuous_coe.comp (dirichlet_char_extend.continuous p d R m hd _))
  w.continuous_to_fun

open dirichlet_character
-- `helper_idk` changed to `helper_change_level_conductor`
lemma helper_change_level_conductor [algebra ℚ_[p] R] [fact(0 < m)] : (change_level (_root_.dvd_lcm_left (d * p^m) p) χ *
  change_level (_root_.dvd_lcm_right _ _) (teichmuller_character_mod_p' p R)).conductor ∣ d * p^m :=
(dvd_trans (conductor.dvd_lev _) (by { rw helper_4 m, }))

/-- The p-adic L- function, as defined in Thm 12.2, absorbing the (1 - χ(c)<c>^(-n)) term
  (since it appears as it is in the Iwasawa Main Conjecture). -/
noncomputable def p_adic_L_function [normed_algebra ℚ_[p] R] [nontrivial R] [complete_space R]
  [norm_one_class R] [fact (0 < d)] [fact (0 < m)] : R :=
(@measure.integral _ _ _ _ _ _ _ _ (bernoulli_measure R hc hc' hd na)
⟨(units.coe_hom R).comp (dirichlet_char_extend p d R m hd
(change_level (helper_change_level_conductor m χ) (χ.mul ((teichmuller_character_mod_p' p R))))) *
w.to_monoid_hom, cont_paLf m hd _ w⟩)
-- check variable match

instance {n : ℕ} : fact (0 < p^n) := fact_iff.2 (pow_pos (nat.prime.pos (fact.out _)) _)


import tactic.interactive

universes u v

class nbg (α : Type u) (β : Type v) :=
(set_mem_set : α → α → Prop)
(set_mem_class : α → β → Prop)
(set_ext : ∀ x y, (∀ z, set_mem_set z x ↔ set_mem_set z y) → x = y)
(set_pair : α → α → α)
(set_pair_prop : ∀ x y z, set_mem_set z (set_pair x y) ↔ (z = x ∨ z = y))
(set_union : α → α)
(set_union_prop : ∀ x y, set_mem_set y (set_union x) ↔ ∃ t, set_mem_set y t ∧ set_mem_set t x)
(set_powerset : α → α)
(set_powerset_prop : ∀ x y, set_mem_set y (set_union x) ↔ ∀ z, set_mem_set z y → set_mem_set z x)
(set_empty : α)
(set_empty_prop : ∀ x, ¬set_mem_set x set_empty)
(set_infinity : α)
(set_infinity_prop_empty : set_mem_set set_empty set_infinity)
(set_infinity_prop_succ : ∀ x, set_mem_set x set_infinity → set_mem_set (set_union (set_pair x (set_pair x x))) set_infinity)
(class_ext : ∀ X Y, (∀ z, set_mem_class z X ↔ set_mem_class z Y) → X = Y)
(class_reg : β → α)
(class_reg_prop : ∀ X, set_mem_class (class_reg X) X ∧ ∀ z, ¬(set_mem_class z X ∧ set_mem_set z (class_reg X)))
(limitation : ∀ C, xor (∃ c, ∀ z, set_mem_set z c ↔ set_mem_class z C) (∃ F, (∀ y, (∃ x, set_mem_class x C ∧ set_mem_class (set_pair (set_pair x x) (set_pair x y)) F)) ∧ (∀ x y z, set_mem_class x C → set_mem_class (set_pair (set_pair x x) (set_pair x y)) F → set_mem_class (set_pair (set_pair x x) (set_pair x z)) F → y = z)))
(set_to_class : α → β)
(set_to_class_prop : ∀ x y, set_mem_set y x ↔ set_mem_class y (set_to_class x))
(class_comp : β → β)
(class_comp_prop : ∀ X y, xor (set_mem_class y X) (set_mem_class y (class_comp X)))
(class_int : β → β → β)
(class_int_prop : ∀ X Y z, set_mem_class z (class_int X Y) ↔ set_mem_class z X ∧ set_mem_class z Y)
(class_prod : β → β → β)
(class_prod_prop : ∀ X Y z, set_mem_class z (class_prod X Y) ↔ ∃ x y, set_mem_class x X ∧ set_mem_class y Y ∧ z = (set_pair (set_pair x x) (set_pair x y)))
(class_prod_comm : β → β)
(class_prod_comm_prop : ∀ X y, set_mem_class y (class_prod_comm X) ↔ ∃ a b, set_mem_class (set_pair (set_pair a a) (set_pair a b)) X ∧ y = set_pair (set_pair b b) (set_pair b a))
(class_prod_comm' : β → β)
(class_prod_comm'_prop : ∀ X y, set_mem_class y (class_prod_comm' X) ↔ ∃ a b c, set_mem_class (set_pair (set_pair a a) (set_pair a (set_pair (set_pair b b) (set_pair b c)))) X ∧ y = set_pair (set_pair b b) (set_pair b (set_pair (set_pair a a) (set_pair a c))))
(class_prod_assoc : β → β)
(class_prod_assoc_prop : ∀ X y, set_mem_class y (class_prod_assoc X) ↔ ∃ a b c, set_mem_class (set_pair (set_pair a a) (set_pair a (set_pair (set_pair b b) (set_pair b c)))) X ∧ y = set_pair (set_pair (set_pair (set_pair a a) (set_pair a b)) (set_pair (set_pair a a) (set_pair a b))) (set_pair (set_pair (set_pair a a) (set_pair a b)) c))
(class_prod_assoc' : β → β)
(class_prod_assoc'_prop : ∀ X y, set_mem_class y (class_prod_assoc' X) ↔ ∃ a b c d, set_mem_class (set_pair (set_pair d d) (set_pair d (set_pair (set_pair a a) (set_pair a (set_pair (set_pair b b) (set_pair b c)))))) X ∧ y = set_pair (set_pair d d) (set_pair d (set_pair (set_pair (set_pair (set_pair a a) (set_pair a b)) (set_pair (set_pair a a) (set_pair a b))) (set_pair (set_pair (set_pair a a) (set_pair a b)) c))))
(class_range : β → β)
(class_range_prop : ∀ X y, set_mem_class y (class_range X) ↔ ∃ x, set_mem_class (set_pair (set_pair x x) (set_pair x y)) X)
(class_mem : β)
(class_mem_prop : ∀ z, set_mem_class z class_mem ↔ ∃ x y, set_mem_set x y ∧ z = set_pair (set_pair x x) (set_pair x y))
(class_eq : β)
(class_eq_prop : ∀ z, set_mem_class z class_eq ↔ ∃ x, z = set_pair (set_pair x x) (set_pair x x))

theorem classical.dne {p : Prop} : ¬¬p → p
| hp := or.cases_on (classical.em p) id (λ h, false.elim (hp h))

theorem xor.not_right_of_left {p q : Prop} : xor p q → p → ¬q
| hpq hp := or.cases_on hpq (λ h, h.2) (λ h, false.rec ¬q $ h.2 hp)

theorem xor.right_of_not_left {p q : Prop} : xor p q → ¬p → q
| hpq hp := or.cases_on hpq (λ h, false.rec q $ hp h.1) (λ h, h.1)

theorem xor.not_left_of_right {p q : Prop} : xor p q → q → ¬p
| hpq hq := or.cases_on hpq (λ h, false.rec ¬p $ h.2 hq) (λ h, h.2)

theorem xor.left_of_not_right {p q : Prop} : xor p q → ¬q → p
| hpq hq := or.cases_on hpq (λ h, h.1) (λ h, false.rec p $ hq h.1)

theorem forall_not_iff_not_exists {α : Sort u} {P : α → Prop} : (∀ a, ¬P a) ↔ (¬∃ a, P a) :=
{ mp := λ hf he, Exists.cases_on he (λ a ha, hf a ha),
  mpr := λ hne a ha, hne ⟨a, ha⟩ }

theorem not_xor_iff_iff {p q : Prop} : ¬xor p q ↔ (p ↔ q) :=
{ mp  := λ hnx,
  { mp  := λ hp, (classical.dne $ λ hnq, hnx $ or.inl ⟨hp, hnq⟩),
    mpr := λ hq, (classical.dne $ λ hnp, hnx $ or.inr ⟨hq, hnp⟩) },
  mpr := λ hi hx, or.cases_on hx
    (λ hpnq, hpnq.2 $ hi.1 hpnq.1)
    (λ hqnp, hqnp.2 $ hi.2 hqnp.1) }

namespace nbg

variables {α : Type u} (β : Type v) [nbg α β] (x y z a b c d : α) (X Y Z A B C D : β)

def pair := set_pair β (set_pair β x x) (set_pair β x y)

variables {β x y z a b c d X Y Z A B C D}

notation x ∈ X := set_mem_class x X

theorem set_pair_left : set_mem_set β x (set_pair β x y) :=
begin
  apply (set_pair_prop _ _ _ _).2, left, refl
end

theorem set_pair_right : set_mem_set β y (set_pair β x y) :=
begin
  apply (set_pair_prop _ _ _ _).2, right, refl
end

theorem pair_ext : pair β a b = pair β c d → a = c ∧ b = d :=
begin
  intro h,
  have hac : a = c,
  have : set_mem_set β (set_pair β a a) (pair β a b),
  apply set_pair_left,
  rw h at this,
  cases (set_pair_prop _ _ _ _).1 this,
  have : set_mem_set β a (set_pair β a a),
  apply set_pair_left,
  rw h_1 at this,
  cases (set_pair_prop _ _ _ _).1 this,
  exact h_2, exact h_2,
  have : set_mem_set β a (set_pair β a a),
  apply set_pair_left,
  rw h_1 at this,
  cases (set_pair_prop _ _ _ _).1 this,
  exact h_2,
  rw h_2,
  rw h_2 at h_1,
  have : set_mem_set β c (set_pair β c d),
  apply set_pair_left,
  rw ←h_1 at this,
  cases (set_pair_prop _ _ _ _).1 this,
  rw h_3, rw h_3,
  split, apply hac,
  have : set_mem_set β (set_pair β a b) (pair β a b),
  apply set_pair_right,
  rw h at this,
  cases (set_pair_prop _ _ _ _).1 this,
  have : set_mem_set β (set_pair β c d) (pair β c d),
  apply set_pair_right,
  rw ←h at this,
  cases (set_pair_prop _ _ _ _).1 this,
  have : set_mem_set β d (set_pair β c d),
  apply set_pair_right,
  rw h_2 at this,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this),
  rw this,
  have : set_mem_set β a (set_pair β a b),
  apply set_pair_left,
  rw h_1 at this,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this),
  rw this,
  have : set_mem_set β b (set_pair β a b),
  apply set_pair_right,
  rw h_1 at this,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this),
  rw this,
  have : set_mem_set β a (set_pair β a b),
  apply set_pair_left,
  rw h_1 at this,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this),
  have : set_mem_set β b (set_pair β a b),
  apply set_pair_right,
  rw h_1 at this,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this),
  dedup,
  rw [this_3, this_5] at h_2,
  rw this_5,
  have : set_mem_set β d (set_pair β c d),
  apply set_pair_right,
  rw h_2 at this,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this),
  rw this,
  have : set_mem_set β b (set_pair β a b),
  apply set_pair_right,
  rw h_1 at this,
  cases (set_pair_prop _ _ _ _).1 this,
  rw [hac,h_2] at h,
  rw h_2,
  have : set_mem_set β (set_pair β c d) (pair β c d),
  apply set_pair_right,
  rw ←h at this,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this),
  have : set_mem_set β d (set_pair β c d),
  apply set_pair_right,
  dedup,
  rw this_3 at this_4,
  have := (or_self _).1 ((set_pair_prop _ _ _ _).1 this_4),
  rw this,
  exact h_2
end

theorem class_int_ext : x ∈ X → x ∈ Y → x ∈ (class_int α X Y)
| hX hY := (class_int_prop X Y x).2 ⟨hX, hY⟩

theorem class_prod_ext : x ∈ X → y ∈ Y → set_mem_class (pair β x y) (class_prod α X Y)
| hX hY := (class_prod_prop X Y (pair β x y)).2 ⟨x, y, hX, hY, rfl⟩

theorem class_prod_left : set_mem_class (pair β x y) (class_prod α X Y) → x ∈ X
| hxy :=
begin
  have hab := (class_prod_prop X Y (pair β x y)).1 hxy,
  cases hab with a hb,
  cases hb with b h,
  cases pair_ext h.2.2,
  exact left.symm ▸ h.1
end

theorem class_prod_right : set_mem_class (pair β x y) (class_prod α X Y) → y ∈ Y
| hxy :=
begin
  have hab := (class_prod_prop X Y (pair β x y)).1 hxy,
  cases hab with a hb,
  cases hb with b h,
  cases pair_ext h.2.2,
  exact right.symm ▸ h.2.1
end

theorem class_prod_split : set_mem_class (pair β x y) (class_prod α X Y) → x ∈ X ∧ y ∈ Y
| hxy := ⟨class_prod_left hxy, class_prod_right hxy⟩

@[simp] theorem class_prod_iff : set_mem_class (pair β x y) (class_prod α X Y) ↔ x ∈ X ∧ y ∈ Y :=
⟨class_prod_split, λ h, class_prod_ext h.1 h.2⟩

theorem class_prod_comm_ext : set_mem_class (pair β x y) X → set_mem_class (pair β y x) (class_prod_comm α X)
| hxy := (class_prod_comm_prop X (pair β y x)).2 ⟨x, y, hxy, rfl⟩

theorem class_prod_of_prod_comm : set_mem_class (pair β y x) (class_prod_comm α X) → set_mem_class (pair β x y) X
| hyx :=
begin
  have hab := (class_prod_comm_prop X (pair β y x)).1 hyx,
  cases hab with a hb,
  cases hb with b h,
  cases pair_ext h.2,
  exact left.symm ▸ right.symm ▸ h.1
end

@[simp] theorem class_prod_comm_iff : set_mem_class (pair β y x) (class_prod_comm α X) ↔ set_mem_class (pair β x y) X :=
⟨class_prod_of_prod_comm, class_prod_comm_ext⟩

theorem class_prod_comm'_ext : set_mem_class (pair β x (pair β y z)) X → set_mem_class (pair β y (pair β x z)) (class_prod_comm' α X)
| hxyz := (class_prod_comm'_prop X (pair β y (pair β x z))).2 ⟨x, y, z, hxyz, rfl⟩

theorem class_prod_of_prod_comm' : set_mem_class (pair β y (pair β x z)) (class_prod_comm' α X) → set_mem_class (pair β x (pair β y z)) X
| hyxz :=
begin
  have habc := (class_prod_comm'_prop X (pair β y (pair β x z))).1 hyxz,
  cases habc with a hbc,
  cases hbc with b hc,
  cases hc with c h,
  cases pair_ext h.2,
  cases pair_ext right,
  exact left.symm ▸ left_1.symm ▸ right_1.symm ▸ h.1
end

@[simp] theorem class_prod_comm'_iff : set_mem_class (pair β y (pair β x z)) (class_prod_comm' α X) ↔ set_mem_class (pair β x (pair β y z)) X :=
⟨class_prod_of_prod_comm', class_prod_comm'_ext⟩

theorem class_prod_assoc_ext : set_mem_class (pair β x (pair β y z)) X → set_mem_class (pair β (pair β x y) z) (class_prod_assoc α X)
| hxyz := (class_prod_assoc_prop X (pair β (pair β x y) z)).2 ⟨x, y, z, hxyz, rfl⟩

theorem class_prod_of_prod_assoc : set_mem_class (pair β (pair β x y) z) (class_prod_assoc α X) → set_mem_class (pair β x (pair β y z)) X
| hxyz :=
begin
  have habc := (class_prod_assoc_prop X (pair β (pair β x y) z)).1 hxyz,
  cases habc with a hbc,
  cases hbc with b hc,
  cases hc with c h,
  cases pair_ext h.2,
  cases pair_ext left,
  exact right.symm ▸ left_1.symm ▸ right_1.symm ▸ h.1
end

@[simp] theorem class_prod_assoc_iff : set_mem_class (pair β (pair β x y) z) (class_prod_assoc α X) ↔ set_mem_class (pair β x (pair β y z)) X :=
⟨class_prod_of_prod_assoc, class_prod_assoc_ext⟩

theorem class_prod_assoc'_ext : set_mem_class (pair β d (pair β a (pair β b c))) X → set_mem_class (pair β d (pair β (pair β a b) c)) (class_prod_assoc' α X)
| habcd := (class_prod_assoc'_prop X _).2 ⟨a, b, c, d, habcd, rfl⟩

theorem class_prod_of_prod_assoc' : set_mem_class (pair β d (pair β (pair β a b) c)) (class_prod_assoc' α X) → set_mem_class (pair β d (pair β a (pair β b c))) X
| hdabc :=
begin
  have hdabc := (class_prod_assoc'_prop X _).1 hdabc,
  cases hdabc with d habc,
  cases habc with a hbc,
  cases hbc with b hc,
  cases hc with c h,
  cases pair_ext h.2,
  cases pair_ext right,
  cases pair_ext left_1,
  exact left.symm ▸ right_1.symm ▸ left_2.symm ▸ right_2.symm ▸ h.1
end

@[simp] theorem class_prod_assoc'_iff : set_mem_class (pair β d (pair β (pair β a b) c)) (class_prod_assoc' α X) ↔ set_mem_class (pair β d (pair β a (pair β b c))) X :=
⟨class_prod_of_prod_assoc', class_prod_assoc'_ext⟩

theorem class_range_ext : set_mem_class (pair β x y) X → y ∈ (class_range α X)
| hxy := (class_range_prop X y).2 ⟨x, hxy⟩

theorem class_mem_ext : set_mem_set β x y → set_mem_class (pair β x y) (class_mem α β)
| hxy := (class_mem_prop β (pair β x y)).2 ⟨x, y, hxy, rfl⟩

theorem class_mem_of_mem : set_mem_class (pair β x y) (class_mem α β) → set_mem_set β x y
| hxy :=
begin
  have hab := (class_mem_prop β (pair β x y)).1 hxy,
  cases hab with a hb,
  cases hb with b h,
  cases pair_ext h.2,
  exact left.symm ▸ right.symm ▸ h.1
end

@[simp] theorem class_mem_iff : set_mem_class (pair β x y) (class_mem α β) ↔ set_mem_set β x y :=
⟨class_mem_of_mem, class_mem_ext⟩

theorem class_eq_ext : x = y → set_mem_class (pair β x y) (class_eq α β)
| hxy := (class_eq_prop β (pair β x y)).2 ⟨x, hxy ▸ rfl⟩

theorem class_eq_of_eq : set_mem_class (pair β x y) (class_eq α β) → x = y
| hxy :=
begin
  have ha := (class_eq_prop β (pair β x y)).1 hxy,
  cases ha with a h,
  cases pair_ext h,
  exact right.symm ▸ left
end

@[simp] theorem class_eq_iff : set_mem_class (pair β x y) (class_eq α β) ↔ x = y :=
⟨class_eq_of_eq, class_eq_ext⟩

theorem set_to_class_ext : set_mem_set β x y → x ∈ (set_to_class β y) :=
(set_to_class_prop β y x).1

theorem class_mem_of_to_class : x ∈ (set_to_class β y) → set_mem_set β x y :=
(set_to_class_prop β y x).2

@[simp] theorem set_to_class_iff : x ∈ (set_to_class β y) ↔ set_mem_set β x y :=
⟨class_mem_of_to_class, set_to_class_ext⟩

theorem class_comp_prop1 : x ∈ (class_comp α X) ↔ ¬x ∈ X :=
⟨(class_comp_prop X x).not_left_of_right, (class_comp_prop X x).right_of_not_left⟩

theorem class_comp_prop2 : x ∈ X ↔ ¬x ∈ (class_comp α X) :=
⟨(class_comp_prop X x).not_right_of_left, (class_comp_prop X x).left_of_not_right⟩

variables (α X)

def class_prod_assoc'' : β := (class_prod_comm α $ class_prod_assoc α $ class_prod_comm α $ class_prod_assoc α $ class_prod_comm α X)

variables {α X}

@[simp] theorem class_prod_assoc''_iff : set_mem_class (pair β x (pair β y z)) (class_prod_assoc'' α X) ↔ set_mem_class (pair β (pair β x y) z) X :=
begin
  unfold class_prod_assoc'',
  rw class_prod_comm_iff,
  rw class_prod_assoc_iff,
  rw class_prod_comm_iff,
  rw class_prod_assoc_iff,
  rw class_prod_comm_iff
end

variables (α β)

def class_univ : β := class_comp α (set_to_class β (set_empty α β))

variables {α β}

theorem class_univ_prop : x ∈ (class_univ α β) :=
begin
  unfold class_univ,
  rw class_comp_prop1,
  rw set_to_class_iff,
  apply set_empty_prop
end

theorem no_set_univ : ¬∃ x:α, ∀ y, set_mem_set β y x :=
begin
  intro h,
  cases h,
  apply (limitation α $ set_to_class β h_w).not_left_of_right,
  existsi class_eq α β,
  split,
  intro y,
  existsi y,
  split,
  apply set_to_class_ext,
  exact h_h y,
  apply class_eq_ext,
  refl,
  intros x y z hx hxy hxz,
  rw ←class_eq_of_eq hxy,
  rw ←class_eq_of_eq hxz,
  existsi h_w,
  exact set_to_class_prop β h_w
end

theorem no_set_mem_self : ¬set_mem_set β x x :=
begin
  intro hx,
  cases class_reg_prop α (set_to_class β (@set_pair α β _ x x)),
  specialize right x,
  rw ←set_to_class_prop at left,
  rw set_pair_prop at left,
  rw or_self at left,
  rw left at right,
  rw ←set_to_class_prop at right,
  rw set_pair_prop at right,
  rw or_self at right,
  apply right,
  split, refl, exact hx
end

instance : has_emptyc α := ⟨set_empty α β⟩
instance : has_union α := ⟨λ x y, set_union β $ set_pair β x y⟩

@[simp] lemma univ_and (p : Prop) : x ∈ class_univ α β ∧ p ↔ p :=
and_iff_right class_univ_prop

@[simp] lemma and_univ (p : Prop) : p ∧ x ∈ class_univ α β ↔ p :=
and_iff_left class_univ_prop

variables (β x)

def singleton : α := set_pair β x x

variables {β x}

theorem singleton_prop : set_mem_set β y (singleton β x) ↔ y = x :=
begin
  unfold singleton,
  rw set_pair_prop,
  rw or_self
end

-- class of sets that contains x

variables (β x)

def contains_set : β := class_range α (class_int α (class_prod α (set_to_class β (singleton β x)) (class_univ α β)) (class_mem α β))

variables {β x}

theorem contains_set_prop : x ∈ (contains_set β c) ↔ set_mem_set β c x :=
begin
  unfold contains_set,
  rw class_range_prop,
  split,
  intro h,
  cases h with z hz,
  rw ←pair at hz,
  rw class_int_prop at hz,
  cases hz with h1 h2,
  rw class_prod_iff at h1,
  cases h1 with h3 h4,
  rw set_to_class_iff at h3,
  rw singleton_prop at h3,
  rw h3 at *,
  rw class_mem_iff at h2,
  exact h2,
  intro hx,
  existsi c,
  apply class_int_ext,
  apply class_prod_ext,
  apply set_to_class_ext,
  rw singleton_prop,
  apply class_univ_prop,
  apply class_mem_ext,
  exact hx
end

variables (α β)

def class_ne : β := class_int α (class_prod α (class_univ α β) (class_univ α β)) (class_comp α (class_eq α β))

def class_not_mem : β := class_int α (class_prod α (class_univ α β) (class_univ α β)) (class_comp α (class_mem α β))

variables {α β}

theorem class_ne_ext : x ≠ y → set_mem_class (pair β x y) (class_ne α β)
| hxy :=
begin
  unfold class_ne,
  apply class_int_ext,
  apply class_prod_ext class_univ_prop class_univ_prop,
  rw class_comp_prop1,
  rw class_eq_iff,
  exact hxy
end

theorem class_ne_of_ne : set_mem_class (pair β x y) (class_ne α β) → x ≠ y
| hxy :=
begin
  unfold class_ne at hxy,
  rw class_int_prop at hxy,
  cases hxy with h1 h2,
  rw class_comp_prop1 at h2,
  rw class_eq_iff at h2,
  exact h2
end

@[simp] theorem class_ne_iff : set_mem_class (pair β x y) (class_ne α β) ↔ x ≠ y :=
⟨class_ne_of_ne, class_ne_ext⟩

theorem class_not_mem_ext : ¬set_mem_set β x y → set_mem_class (pair β x y) (class_not_mem α β)
| hxy :=
begin
  unfold class_not_mem,
  apply class_int_ext,
  apply class_prod_ext class_univ_prop class_univ_prop,
  rw class_comp_prop1,
  rw class_mem_iff,
  exact hxy
end

theorem class_not_mem_of_not_mem : set_mem_class (pair β x y) (class_not_mem α β) → ¬set_mem_set β x y
| hxy :=
begin
  unfold class_not_mem at hxy,
  rw class_int_prop at hxy,
  cases hxy with h1 h2,
  rw class_comp_prop1 at h2,
  rw class_mem_iff at h2,
  exact h2
end

@[simp] theorem class_not_mem_iff : set_mem_class (pair β x y) (class_not_mem α β) ↔ ¬set_mem_set β x y :=
⟨class_not_mem_of_not_mem, class_not_mem_ext⟩

variables (α X Y)

def class_union : β := class_comp α (class_int α (class_comp α X) (class_comp α Y))

def class_xor : β := class_union α (class_int α X (class_comp α Y)) (class_int α Y (class_comp α X))

variables {α X Y}

theorem class_union_ext : x ∈ X ∨ x ∈ Y → x ∈ (class_union α X Y)
| hx :=
begin
  unfold class_union,
  rw class_comp_prop1,
  rw class_int_prop,
  rw class_comp_prop1,
  rw class_comp_prop1,
  cases hx,
  exact λ h, h.1 hx,
  exact λ h, h.2 hx
end

theorem class_or_of_union : x ∈ (class_union α X Y) → x ∈ X ∨ x ∈ Y
| hx :=
begin
  unfold class_union at hx,
  rw class_comp_prop1 at hx,
  rw class_int_prop at hx,
  rw class_comp_prop1 at hx,
  rw class_comp_prop1 at hx,
  apply classical.dne,
  exact λ h, hx ⟨λ hX, h $ or.inl hX, λ hY, h $ or.inr hY⟩
end

@[simp] theorem class_union_iff : x ∈ (class_union α X Y) ↔ x ∈ X ∨ x ∈ Y :=
⟨class_or_of_union, class_union_ext⟩

theorem class_xor_ext : xor (x ∈ X) (x ∈ Y) → x ∈ (class_xor α X Y)
| hx :=
begin
  unfold class_xor,
  rw class_union_iff,
  rw class_int_prop,
  rw class_int_prop,
  rw class_comp_prop1,
  rw class_comp_prop1,
  exact hx
end

theorem class_xor_of_xor : x ∈ (class_xor α X Y) → xor (x ∈ X) (x ∈ Y)
| hx :=
begin
  unfold class_xor at hx,
  rw class_union_iff at hx,
  rw class_int_prop at hx,
  rw class_int_prop at hx,
  rw class_comp_prop1 at hx,
  rw class_comp_prop1 at hx,
  exact hx
end

@[simp] theorem class_xor_iff : x ∈ (class_xor α X Y) ↔ xor (x ∈ X) (x ∈ Y) :=
⟨class_xor_of_xor, class_xor_ext⟩

variables (α β)

-- class of (a,(b,c)) where a in c and b in c
def class_two_mem : β := class_int α (class_prod α (class_univ α β) (class_mem α β)) (class_prod_comm' α ((class_prod α (class_univ α β) (class_mem α β))))
-- class of ((a,b),c) where a ≠ b and a ∈ c and b ∈ c
def class_ne_mem : β := class_int α (class_prod_assoc α $ class_two_mem α β) (class_prod α (class_ne α β) (class_univ α β))
-- class of singletons
def class_singleton : β := class_int α (class_comp α (set_to_class β (singleton β (@set_empty α β _)))) (class_comp α (class_range α (class_ne_mem α β)))

variables {α β}

theorem class_singleton_prop : x ∈ (class_singleton α β) ↔ ∃ y, x = singleton β y :=
begin
  unfold class_singleton, unfold class_ne_mem,
  split,
  intro h,
  rw class_int_prop at h,
  cases h with h1 h2,
  rw class_comp_prop1 at h1,
  rw ←set_to_class_prop at h1,
  rw singleton_prop at h1,
  rw class_comp_prop1 at h2,
  rw class_range_prop at h2,
  have : ∃ y, set_mem_set β y x,
  apply classical.dne,
  intro hy,
  apply h1,
  apply set_ext x (set_empty α β),
  intro z,
  split,
  intro h,
  exfalso,
  apply hy,
  existsi z,
  exact h,
  intro h,
  exfalso,
  apply set_empty_prop β z,
  exact h,
  cases this with y hy,
  existsi y,
  apply @set_ext _ β _ x,
  intro z,
  rw singleton_prop,
  split,
  intro hz,
  apply classical.dne,
  intro hzy,
  apply h2,
  existsi pair β y z,
  apply class_int_ext,
  apply class_prod_assoc_ext,
  unfold class_two_mem,
  apply class_int_ext,
  apply class_prod_ext,
  apply class_univ_prop,
  apply class_mem_ext,
  exact hz,
  apply class_prod_comm'_ext,
  apply class_prod_ext,
  apply class_univ_prop,
  apply class_mem_ext,
  exact hy,
  apply class_prod_ext,
  unfold class_ne,
  apply class_int_ext,
  apply class_prod_ext,
  apply class_univ_prop,
  apply class_univ_prop,
  rw class_comp_prop1,
  rw class_eq_prop,
  intro hx,
  cases hx with x hx,
  have := pair_ext hx,
  cases this,
  apply hzy,
  rw this_left,
  rw this_right,
  apply class_univ_prop,
  intro hzy,
  rw hzy,
  exact hy,
  intro hy,
  cases hy with y hy,
  rw hy at *,
  apply class_int_ext,
  apply class_comp_prop1.2,
  rw ←set_to_class_prop,
  rw singleton_prop,
  intro hx,
  have : set_mem_set β y (singleton β y),
  rw singleton_prop,
  rw hx at this,
  apply set_empty_prop β,
  exact this,
  apply class_comp_prop1.2,
  rw class_range_prop,
  intro hx,
  cases hx with z h,
  rw class_int_prop at h,
  cases h with h1 h2,
  have h3 := (and_iff_left class_univ_prop).1 (class_prod_split h2),
  unfold class_ne at h3,
  rw class_int_prop at h3,
  cases h3 with h3 h4,
  rw class_prod_prop at h3,
  cases h3 with a h3,
  cases h3 with b h3,
  have h3 := (and_iff_right class_univ_prop).1 ((and_iff_right class_univ_prop).1 h3),
  rw h3 at *,
  have h1 := class_prod_of_prod_assoc h1,
  unfold class_two_mem at h1,
  rw class_int_prop at h1,
  cases h1 with h1 h5,
  have h5 := class_mem_of_mem ((and_iff_right class_univ_prop).1 $ class_prod_split $ class_prod_of_prod_comm' h5),
  rw singleton_prop at h5,
  rw h5 at h2,
  have h1 := class_mem_of_mem ((and_iff_right class_univ_prop).1 $ class_prod_split h1),
  rw singleton_prop at h1,
  rw h1 at h2,
  have h2 := (and_iff_left class_univ_prop).1 (class_prod_split h2),
  unfold class_ne at h2,
  rw class_int_prop at h2,
  apply (class_comp_prop _ _).not_left_of_right h2.2,
  apply class_eq_ext,
  refl
end

variables (α β)

def class_pair_singleton : β := class_int α (class_mem α β) (class_prod α (class_univ α β) (class_singleton α β))

variables {α β}

theorem class_pair_singleton_prop : z ∈ (class_pair_singleton α β) ↔ ∃ x y, y = singleton β x ∧ z = pair β x y :=
begin
  unfold class_pair_singleton,
  split,
  intro h,
  rw class_int_prop at h,
  cases h with h1 h3,
  rw class_mem_prop at h1,
  cases h1 with x h1,
  cases h1 with y h1,
  cases h1 with h1 h2,
  rw h2 at *,
  rw ←pair at h3,
  rw class_prod_iff at h3,
  rw and_iff_right class_univ_prop at h3,
  rw class_singleton_prop at h3,
  cases h3 with a ha,
  existsi a,
  existsi y,
  split,
  exact ha,
  rw ha at *,
  rw singleton_prop at h1,
  rw h1 at *,
  refl,
  intro h,
  cases h with x h,
  cases h with y h,
  cases h with h1 h2,
  apply class_int_ext,
  rw h2,
  rw h1,
  rw class_mem_iff,
  rw singleton_prop,
  rw h2,
  apply class_prod_ext class_univ_prop,
  rw class_singleton_prop,
  existsi x,
  exact h1
end

theorem class_pair_singleton_pair : set_mem_class (pair β x y) (class_pair_singleton α β) ↔ y = singleton β x :=
begin
  rw class_pair_singleton_prop,
  split,
  intro h,
  cases h with a h,
  cases h with b h,
  cases pair_ext h.2,
  exact left.symm ▸ right.symm ▸ h.1,
  intro hyx,
  existsi x,
  existsi y,
  split,
  exact hyx,
  refl
end

theorem proper_class_singleton : ¬∃ x:α, ∀ y, set_mem_set β y x ↔ ∃ z, y = singleton β z :=
begin
  intro hx,
  cases hx with x h,
  apply (limitation α (class_singleton α β)).not_left_of_right,
  existsi class_prod_comm α (class_pair_singleton α β),
  split,
  intro y,
  existsi singleton β y,
  split,
  rw class_singleton_prop,
  existsi y,
  refl,
  apply class_prod_comm_ext,
  rw class_pair_singleton_pair,
  intros x y z hx hxy hxz,
  rw class_singleton_prop at hx,
  cases hx with a ha,
  rw ha at *,
  have hxy := class_prod_of_prod_comm hxy,
  rw class_pair_singleton_pair at hxy,
  have h1 := singleton_prop.2 (refl a),
  rw hxy at h1,
  rw singleton_prop at h1,
  rw ←h1,
  have hxz := class_prod_of_prod_comm hxz,
  rw class_pair_singleton_pair at hxz,
  have h1 := singleton_prop.2 (refl a),
  rw hxz at h1,
  rw singleton_prop at h1,
  rw ←h1,
  existsi x,
  intro z,
  rw h,
  rw class_singleton_prop
end

-- { (a,b) | b = a ∪ {a} }
-- { (a,b) | ∀ c, c ∈ b ↔ c ∈ a ∨ c = a }
-- { (a,b) | ¬ ∃ c, (c ∈ b ∧ c ∉ a ∧ c ≠ a) ∨ (c ∉ b ∧ (c ∈ a ∨ c = a)) }
-- { (a,b) | ¬ ∃ c, c ∈ b ⊕ c ∈ a ∨ c = a }

variables (β x)

def succ : α := (set_union β $ set_pair β x $ singleton β x)

variables {β x}

variables (α β)

def class_pair_succ : β := class_int α
(class_prod α (class_univ α β) (class_univ α β))
(class_comp α $ class_range α $ class_xor α
  (class_prod_comm' α $ class_prod α (class_univ α β) (class_mem α β))
  (class_prod_assoc'' α $ class_prod α (class_union α (class_mem α β) (class_eq α β)) (class_univ α β))
)

variables {α β}

@[simp] theorem class_pair_succ_iff : set_mem_class (pair β x y) (class_pair_succ α β) ↔ y = succ β x :=
begin
  unfold class_pair_succ,
  unfold succ,
  split,
  intro h,
  rw class_int_prop at h,
  rw class_prod_iff at h,
  rw and_iff_right class_univ_prop at h,
  rw and_iff_right class_univ_prop at h,
  rw class_comp_prop1 at h,
  rw class_range_prop at h,
  rw ←forall_not_iff_not_exists at h,
  apply set_ext y,
  intro z,
  split,
  intro hzy,
  rw set_union_prop,
  specialize h z,
  rw class_xor_iff at h,
  rw not_xor_iff_iff at h,
  rw ←pair at h,
  cases h with h1 h2,
  rw class_prod_comm'_iff at h1,
  rw class_prod_iff at h1,
  rw and_iff_right class_univ_prop at h1,
  rw class_mem_iff at h1,
  specialize h1 hzy,
  rw class_prod_assoc''_iff at h1,
  rw class_prod_iff at h1,
  rw and_iff_left class_univ_prop at h1,
  rw class_union_iff at h1,
  cases h1 with hm he,
  rw class_mem_iff at hm,
  existsi x,
  split,
  exact hm,
  exact set_pair_left,
  rw class_eq_iff at he,
  existsi singleton β x,
  split,
  rw singleton_prop,
  exact he,
  exact set_pair_right,
  intro h1,
  rw set_union_prop at h1,
  cases h1 with t ht,
  cases ht with hm hp,
  specialize h z,
  rw class_xor_iff at h,
  rw not_xor_iff_iff at h,
  rw ←pair at h,
  cases h with h1 h2,
  rw class_prod_comm'_iff at h2,
  rw class_prod_iff at h2,
  rw and_iff_right class_univ_prop at h2,
  rw class_mem_iff at h2,
  apply h2,
  rw class_prod_assoc''_iff,
  rw class_prod_iff,
  rw and_iff_left class_univ_prop,
  rw class_union_iff,
  rw class_mem_iff,
  rw class_eq_iff,
  rw set_pair_prop at hp,
  cases hp with he hm2,
  rw ←he,
  left,
  exact hm,
  rw hm2 at hm,
  rw singleton_prop at hm,
  right,
  exact hm,
  intro hy,
  apply class_int_ext,
  exact class_prod_ext class_univ_prop class_univ_prop,
  rw class_comp_prop1,
  intro hx,
  rw class_range_prop at hx,
  cases hx with z h1,
  rw class_xor_iff at h1,
  rw ←pair at h1,
  rw class_prod_comm'_iff at h1,
  rw class_prod_iff at h1,
  rw class_prod_assoc''_iff at h1,
  rw class_prod_iff at h1,
  rw and_iff_right class_univ_prop at h1,
  rw and_iff_left class_univ_prop at h1,
  rw class_union_iff at h1,
  rw class_mem_iff at h1,
  rw class_mem_iff at h1,
  rw class_eq_iff at h1,
  rw hy at h1,
  rw set_union_prop at h1,
  cases h1 with h1 h1,
  cases h1 with h1 h2,
  cases h1 with t ht,
  cases ht with h3 h4,
  rw set_pair_prop at h4,
  cases h4 with he hm,
  rw he at h3,
  apply h2,
  left,
  exact h3,
  rw hm at h3,
  rw singleton_prop at h3,
  apply h2,
  right,
  exact h3,
  cases h1 with h1 h2,
  apply h2,
  cases h1 with hm he,
  existsi x,
  split,
  exact hm,
  apply set_pair_left,
  existsi singleton β x,
  split,
  rw singleton_prop,
  exact he,
  apply set_pair_right
end

variables (α β)

-- { A | 0 ∈ A ∧ ∀ n, n ∈ A → succ (n) ∈ A }
-- { A | 0 ∈ A ∧ ¬∃ n, n ∈ A ∧ succ (n) ∉ A }
def class_inductive : β :=
class_int α
  (contains_set β (set_empty α β))
  (class_comp α $ class_range α $ class_int α
    (class_prod α (class_pair_succ α β) (class_univ α β))
    (class_int α
      (class_prod_assoc α $ class_prod_comm' α $ class_prod α (class_univ α β) (class_mem α β))
      (class_prod_assoc α $ class_prod α (class_univ α β) (class_not_mem α β)) ) )

variables {α β}

@[simp] theorem class_inductive_iff : x ∈ (class_inductive α β) ↔ (set_mem_set β (set_empty α β) x ∧ ∀ y, set_mem_set β y x → set_mem_set β (succ β y) x) :=
begin
  unfold class_inductive,
  rw class_int_prop,
  rw class_comp_prop1,
  rw class_range_prop,
  rw contains_set_prop,
  apply and_congr,
  exact iff.rfl,
  split,
  intro h1,
  intros z hz,
  apply classical.dne,
  intro hsz,
  apply h1,
  existsi pair β z (succ β z),
  rw ←pair,
  apply class_int_ext,
  simp,
  apply class_int_ext,
  simpa,
  simpa,
  intros h h1,
  cases h1 with y h1,
  rw ←pair at h1,
  rw class_int_prop at h1,
  cases h1 with h1 h2,
  rw class_int_prop at h2,
  cases h2 with h2 h3,
  have h4 := h1,
  simp at h4,
  unfold class_pair_succ at h4,
  rw class_int_prop at h4,
  rw class_prod_prop at h4,
  cases h4.1 with u h5,
  clear h4,
  cases h5 with v h4,
  rw ←pair at h4,
  rw h4.2.2 at *,
  clear h4,
  simp at *,
  exact (h1 ▸ h3) (h u h2),
end

-- ℕ = { n | ∀ A, ({} ∈ A ∧ ∀ n, n ∈ A → n ∪ {n} ∈ A) → n ∈ A }

end nbg