import Mathlib.Algebra.Group.Basic
import Mathlib.Algebra.Group.Defs

structure Graph(V: Type) (E: Type) where
  null : E
  init : E → V
  bar : E → E
  barInv : bar ∘ bar = id
  barNoFP : ∀ e: E, bar e ≠ e

variable {V: Type}{E: Type}[DecidableEq V][DecidableEq E]{x₁ x₂ : V}

@[inline] def term (graph: Graph V E): E → V :=
  fun e => graph.init (graph.bar e)

inductive EdgePath (graph: Graph V E): V → V → Type where
  | single : (x: V) → EdgePath graph x x
  | cons : {x y z : V} → (e : E) → graph.init e = x → term graph e = y →
        EdgePath graph y z → EdgePath graph x z

def EdgePath.length {graph: Graph V E}{x y: V}: EdgePath graph x y → Nat
  | EdgePath.single x => 0
  | EdgePath.cons  _ _ _ path => length path + 1

/--proves that bar is an involution-/
theorem bar_involution {G : Graph V E} : (ex : E) → G.bar (G.bar ex) = ex := by
  intro ex
  apply congr G.barInv (Eq.refl ex)

open EdgePath

/-- concatenates two edgepaths -/
def multiply {G : Graph V E} {x y z : V}: (EdgePath G x y) → (EdgePath G y z) → (EdgePath G x z) := by
intro p q
match p with
| single x => exact q
| cons ex h1 h2 exy => exact (cons ex h1 h2 (multiply exy q))

/--proves that the endpoint of the reverse of an edge is the start point of the edge-/
theorem term_bar_equals_init {G : Graph V E} {x : V}{e : E}: G.init e = x → (term G (G.bar e) = x) :=
by
intro h
have h₁ : G.bar (G.bar e) = e := congr G.barInv (Eq.refl e)
have h₂ : G.init (G.bar (G.bar e)) = G.init e := congrArg G.init h₁
apply Eq.trans h₂ h

/--proves that initial vertex of reversed edge is the terminal vertex of the original edge-/
theorem init_bar_equals_term {G : Graph V E} {x :V} {e : E}: (term G e = x) → G.init (G.bar e) = x:= by
intro hyp
have : G.init (G.bar e) = term G e := by rfl
exact Eq.trans this hyp

/-- proves associativity of path multiplication-/
theorem mult_assoc {G : Graph V E} (p : EdgePath G w x) (q : EdgePath G x y) (r : EdgePath G y z):
      (multiply (multiply p q) r) = (multiply p (multiply q r)) := by
      induction p with
      | single w => simp[multiply]
      | cons ex h1 h2 exy ih => simp[multiply, ih]

/--proves that "single x" is an identity element for multiplication-/
theorem mult_const {G : Graph V E} (p : EdgePath G x y) :
      (multiply p (single y)) = p := by
      induction p with
      | single x => simp [multiply]
      | cons ex h1 h2 exy ih => simp[multiply, ih]

/-- reverses an edgepath-/
def inverse {G : Graph V E} {x y : V}: (EdgePath G x y) → (EdgePath G y x)
| single x => single x
| cons ex h₁ h₂ exy => multiply (inverse exy) (cons (G.bar (ex)) h₂ (term_bar_equals_init h₁) (single x))

/--defines an edgepath with a single edge-/
def basicpath {G : Graph V E} (x : V) (ex : E) (h₁ : G.init ex = x) (h₂ : term G ex = y): EdgePath G x y := cons ex h₁ h₂ (single y)

/--proves that multiplication with a basicpath gives inductive definition of edgepath-/
theorem basicpath_mult {G : Graph V E} {x y z : V} (ex : E) (h₁ : G.init ex = x) (h₂ : term G ex = y) (exy : EdgePath G y z) : multiply (basicpath x ex h₁ h₂) exy = cons ex h₁ h₂ exy := by
    simp[basicpath, multiply]

/--defines inverse in terms of basicpath-/
theorem inverse_lemma {G : Graph V E} {x y z : V} (ex : E) (h₁ : G.init ex = x) (h₂ : term G ex = y) (exy : EdgePath G y z) : inverse (cons ex h₁ h₂ exy) = multiply (inverse exy) (basicpath y (G.bar ex) h₂ (term_bar_equals_init h₁) ) := by rfl

/--proves the basic relation between inverse and multiply-/
theorem inverse_mult {G : Graph V E} (x y z : V) (p : EdgePath G x y) (q : EdgePath G y z) :
      inverse (multiply p q) = multiply (inverse q) (inverse p) := by
      induction p with
      | single x =>
            have p₁ : multiply (single x) q = q := by rfl
            rw[p₁]
            have p₂ : @inverse V E G x x (single x) = single x := by simp[inverse]
            rw[p₂]
            rw[mult_const (inverse q)]
      | cons ex t₁ t₂ exy ih =>
          have p₃ : multiply (cons ex t₁ t₂ exy) q = cons ex t₁ t₂ (multiply exy q) := by simp[mult_assoc, basicpath_mult, multiply]
          rw[p₃]
          have p₄ : inverse (cons ex t₁ t₂ exy) = multiply (inverse exy) (basicpath _ (G.bar ex)  t₂ (term_bar_equals_init t₁)) := by simp[inverse_lemma]
          rw[p₄]
          have p₅ : multiply (inverse q) (inverse exy) = inverse ( multiply exy q) := by simp[ih q]
          let p₆ := inverse_lemma ex t₁ t₂ (multiply exy q)
          rw[p₆]
          simp[Eq.symm (p₅), mult_assoc]

/--proves that inverse is an involution on paths-/
theorem inverse_involution  {G : Graph V E} {x y : V} (p : EdgePath G x y) : inverse (inverse p) = p := by
  induction p with
  | single x => rfl
  | cons ex h₁ h₂ exy ih =>
    have p₁ : inverse (cons ex h₁ h₂ exy) = multiply (inverse exy) (inverse (basicpath _ ex h₁ h₂)) := by rfl
    rw[p₁]
    let k := inverse_mult _ _ _ (inverse exy)  (inverse (basicpath _ ex h₁ h₂))
    rw[k]
    have p₂ : inverse (inverse (basicpath _ ex h₁ h₂)) = basicpath _ ex h₁ h₂ := by
      simp[basicpath, inverse]
      have p₃ : G.bar (G.bar ex) = ex := by apply congr G.barInv (Eq.refl ex)
      simp[p₃]
      rfl
    rw[p₂]
    simp[basicpath_mult ex h₁ h₂ exy, ih]

/--helper function for reducePath, that reduces the first two edges of the path-/
def reducePathAux {G : Graph V E} {x y z : V} (ex : E) (h₁ : G.init ex = x) (h₂ : term G ex = y) (exy : EdgePath G y z) : { rp : EdgePath G x z // rp.length ≤ (cons ex h₁ h₂ exy).length} := by
cases exy with
 | single x => exact ⟨cons ex h₁ h₂ (single y), by simp⟩
 | cons ey h₃ h₄ eyz =>
   apply
  if c : (x = term G ey) ∧ (ey = G.bar (ex)) then
  ⟨ Eq.symm (Eq.trans (And.left c) h₄) ▸ eyz, by
      have h₅ : (Eq.symm (Eq.trans (And.left c) h₄) ▸ eyz).length = eyz.length := by
        let ih := Eq.symm (Eq.trans (And.left c) h₄)
        cases ih with
        | refl => rfl
      simp[EdgePath.length, h₅, Nat.le_trans (Nat.le_succ (length eyz)) (Nat.le_succ (length eyz +1))]
  ⟩
  else
  ⟨ cons ex h₁ h₂ (cons ey h₃ h₄ (eyz)), by apply Nat.le_refl⟩

/-- reduces given path such that no two consecutive edges are inverses of each other-/
def reducePath {G : Graph V E} : (p : EdgePath G x y ) →
  {rp : EdgePath G x y // rp.length ≤ p.length}
| single x => ⟨single x, by simp⟩
| cons ex h₁ h₂ ey'y =>
  let ⟨ey'z, ih1⟩ := reducePath ey'y
  let ⟨ ez, ih⟩ := reducePathAux ex h₁ h₂ ey'z
  ⟨ ez , by
          have : length (cons ex h₁ h₂ ey'z) = length ey'z + 1 := by simp[length]
          let k := this ▸ ih
          have pr : length ey'z +1 ≤ length ey'y +1 := by apply Nat.succ_le_succ ih1
          simp[length, Nat.le_trans k pr] ⟩

  termination_by _ _ _ _ p => p.length
  decreasing_by
  simp_wf
  simp[EdgePath.length, Nat.lt_succ_self]

/--defines moves allowing homotopy of edgepaths-/
inductive basicht {G : Graph V E} : EdgePath G x y → EdgePath G x y → Sort where
  | consht : (x : V) → (basicht (single x) (single x)) -- constant homotopy
  | cancel : (ex ex' : E) → { x w y : V} → (p : EdgePath G x y) → -- cancelling consecutive opposite edges from a path
            (h : G.init ex = x) → (h' : term G ex = w) → (t : G.bar ex = ex') →
            basicht p (cons ex h h' (cons ex' (t ▸ init_bar_equals_term h') (t ▸ term_bar_equals_init h) p))
  | mult : {x y z : V} → {p q : EdgePath G y z} →   -- adding an edge to homotopic paths
          basicht p q → (ex : E) →(h' : G.init ex = x) → ( h : term G ex = y)→
          basicht (cons ex h' h p) (cons ex h' h q)

--defines the set of homotopy classes of edgepaths from x to y
def ht (G : Graph V E) (x y : V) := Quot (@basicht V E G x y )

def htclass {G : Graph V E} {x y : V} ( p : EdgePath G x y) : ht G x y :=
  Quot.mk (@basicht V E G x y ) p

def homotopy {G : Graph V E} {x y : V} ( p' q' : EdgePath G x y) : Prop :=
  htclass p' = htclass q'

/--proves that homotopy is a transitive relation-/
theorem homotopy_trans {G : Graph V E} {x y : V} (p q r : EdgePath G x y) : homotopy p q → homotopy q r → homotopy p r := by
  intro h₁ h₂
  simp[homotopy, htclass]
  have p₁ : Quot.mk basicht p = Quot.mk basicht q := by apply h₁
  have p₂ : Quot.mk basicht q = Quot.mk basicht r := by apply h₂
  apply Eq.trans p₁ p₂

/--proves that homotopy is preserved by multiplying an edge to the left-/
theorem homotopy_left_mult_edge {G : Graph V E} {x y z : V}: (p q : EdgePath G y z) → homotopy p q → (ex : E) →(h1 : G.init ex = x) → ( h : term G ex = y)→ homotopy (cons ex h1 h p) (cons ex h1 h q) := by
  intro p q h ex h1 h2
  let func (r : EdgePath G y z) : ht G x z := htclass (cons ex h1 h2 r)
  have g : (r₁ r₂ : EdgePath G y z) →  basicht r₁ r₂ → func r₁ = func r₂ := by
     intro r₁ r₂ h₁
     let t := basicht.mult h₁ ex h1 h2
     have : htclass (cons ex h1 h2 r₁) = htclass (cons ex h1 h2 r₂) := by simp[htclass]; apply Quot.sound t
     simp[this]
  simp[homotopy]
  let k := Quot.lift func g
  apply congrArg k h

/--proves that homotopy is left multiplicative-/
theorem homotopy_left_mult {G : Graph V E} {x y z : V} (p1 p2 : EdgePath G y z) (q : EdgePath G x y) (h :homotopy p1 p2):
         (homotopy (multiply q p1) (multiply q p2)) := by
         induction q with
        | single w  =>
          simp [multiply, h]
        | cons ex h1 h2 exy ih =>
          let c := ih p1 p2 h
          have t₁ : multiply (cons ex h1 h2 exy) p1 = cons ex h1 h2 (multiply exy p1) := by simp[multiply, mult_assoc]
          have t₂ : multiply (cons ex h1 h2 exy) p2 = cons ex h1 h2 (multiply exy p2) := by simp[multiply, mult_assoc]
          rw[t₁, t₂]
          simp[homotopy_left_mult_edge, c]

/--proves that homotopy is reflexive-/
theorem homotopy_rfl {G :Graph V E} {x y : V} (p : EdgePath G x y) : homotopy p p := by rfl

/--proves that path is homotopic to itself after appending cancelling pair of edges at its end-/
theorem induct_homotopy_inverse_cancel {G : Graph V E}  (ey ey' : E)  { x w y : V} (p : EdgePath G x y) (h₁ : G.init ey = y) (h₂ : term G ey = w) (t : G.bar ey = ey') (h₃ : G.init ey' = w) (h₄ : term G ey' = y) :
           homotopy p (multiply p (cons ey h₁ h₂ (cons ey' h₃ h₄ (single y)) )) := by
           induction p with
           | single x => simp[multiply, basicpath, homotopy, htclass, Quot.sound (basicht.cancel ey ey' (single x) h₁ h₂ t)]
           | cons ex t₁ t₂ exy ih =>
            let x := ih h₁ h₄
            have p₁ : homotopy (cons ex t₁ t₂ exy) (cons ex t₁ t₂ (multiply exy (cons ey h₁ h₂ (cons ey' h₃ h₄ (single _))))) := by simp[homotopy_left_mult_edge _ _ x ex t₁ t₂]
            have :  cons ex t₁ t₂ (multiply exy (cons ey h₁ h₂ (cons ey' h₃ h₄ (single _)))) = multiply (cons ex t₁ t₂ exy) (cons ey h₁ h₂ (cons ey' h₃ h₄ (single _))) := by simp[multiply]
            simp[basicpath_mult ey h₁ h₂, basicpath_mult ey' h₃ h₄]
            apply this ▸ p₁

/--proves that a pair of paths remains homotopic after appending a single edge at their ends-/
theorem induct_homotopy_inverse_mult {G : Graph V E} {x y z : V} (p q : EdgePath G x y) (ey : E) (h₁ : G.init ey = y) (h₂ : term G ey = z) : homotopy p q → homotopy (multiply p (basicpath y ey h₁ h₂)) (multiply q (basicpath y ey h₁ h₂)) := by
    intro h
    let func : EdgePath G x y → ht G x z := by intro p ; exact htclass (multiply p (basicpath y ey h₁ h₂))
    have g : (s₁ s₂ : EdgePath G x y) → (basicht s₁ s₂) → func s₁ = func s₂ := by
      intro s₁ s₂ ht
      simp
      induction ht with
      | consht x => simp[homotopy_rfl]
      | cancel ex ex' r t₁ t₂ t₃ =>
        let x := basicht.cancel ex ex' (multiply r (basicpath _ ey h₁ h₂)) t₁ t₂ t₃
        simp[multiply, htclass]
        apply Quot.sound x
      | @mult _ _ _ p₁ p₂ b ex t₁ t₂ ih =>
        let x := homotopy_left_mult_edge _ _ (ih p₁ p₂ h₁ (Quot.sound b)) ex t₁ t₂
        simp[multiply, x]
        apply x
    simp[homotopy]
    let k := Quot.lift func g
    apply congrArg k h

/--proves that homotopy of paths implies homotopy of their inverses-/
theorem homotopy_inverse {G : Graph V E} {x y : V} (p₁ p₂: EdgePath G x y) (q₁ q₂ : EdgePath G y x) (h₁ : q₁ = inverse p₁) (h₂ : q₂ = inverse p₂) : homotopy p₁ p₂ → homotopy q₁ q₂ := by
  intro h₀
  let func : EdgePath G x y → ht G y x := by intro p ; exact htclass (inverse p)
  have g : (s₁ s₂ : EdgePath G x y) → (h : basicht s₁ s₂) →  homotopy (inverse s₁) (inverse s₂) := by
      intro s₁ s₂ h
      induction h with
        | consht x => simp[inverse, homotopy_rfl]

        | cancel ex ex' p t₁ t₂ t₃ =>
          simp[htclass, inverse, mult_assoc]
          apply induct_homotopy_inverse_cancel (G.bar ex') (G.bar ex) (inverse p) (by rw[← t₃]; rw[bar_involution ex]; apply t₁) (by rw[← t₃]; rw[(bar_involution ex)]; apply t₂) (by rw[bar_involution ex']; apply (Eq.symm t₃)) (init_bar_equals_term t₂) (term_bar_equals_init t₁)

        | @mult _ _ _ s₁ s₂ b ex t₁ t₂ ih =>
          simp[homotopy, inverse]
          let c := ih s₁ s₂ (inverse s₁) (inverse s₂) rfl rfl (Quot.sound b)
          let k := induct_homotopy_inverse_mult (inverse s₁) (inverse s₂) (G.bar ex) t₂ (term_bar_equals_init t₁) c
          apply k
  let k₂ := Quot.lift func g
  apply h₁ ▸ h₂ ▸ (congrArg k₂ h₀)

/--homotopy_inverse with lesser arguments-/
theorem homotopy_inverse_quick  {G : Graph V E} {x y : V} {p₁ p₂: EdgePath G x y} : homotopy p₁ p₂ → homotopy (inverse p₁) (inverse p₂) := by
 apply homotopy_inverse p₁ p₂ (inverse p₁) (inverse p₂) rfl rfl

/-- proves that homotopy is right multiplicative-/
theorem homotopy_right_mult {G : Graph V E} {x y z : V} (p₁ p₂ : EdgePath G x y) (q : EdgePath G y z) (h :homotopy p₁ p₂):
         (homotopy (multiply p₁ q) (multiply p₂ q)) := by
         have r₁ : homotopy (inverse p₁) (inverse p₂) := by apply homotopy_inverse_quick h
         have r₂ : homotopy (multiply (inverse q) (inverse p₁)) (multiply (inverse q) (inverse p₂)) := by apply homotopy_left_mult ; apply r₁
         have r₃ : homotopy (inverse (multiply (inverse q) (inverse p₁))) (inverse (multiply (inverse q) (inverse p₂))) := by apply homotopy_inverse_quick r₂
         let s₁ := inverse_mult x y z p₁ q
         let s₂ := inverse_involution (multiply p₁ q)
         let s₃ := Eq.trans (Eq.symm s₂) (congrArg inverse s₁)
         let t₁ := inverse_mult x y z p₂ q
         let t₂ := inverse_involution (multiply p₂ q)
         let t₃ := Eq.trans (Eq.symm t₂) (congrArg inverse t₁)
         apply s₃ ▸ t₃ ▸ r₃

/--defines multiplication of homotopy class with a path to its left-/
def homotopy_left_multiplication {G :Graph V E} {x y z : V} (p₁ : EdgePath G x y) : ht G y z →  ht G x z := by
  let func: EdgePath G y z → ht G x z := by intro p ; exact htclass (multiply p₁ p)
  have g : (q₁ q₂ : EdgePath G y z) → basicht q₁ q₂ → func q₁ = func q₂ := by
          intro q₁ q₂ h
          simp
          have h' : homotopy q₁ q₂ := by simp[homotopy, htclass, Quot.sound h ]
          apply homotopy_left_mult q₁ q₂ p₁ h'
  apply Quot.lift func g

/--proves that the multiplication defined above equals homotopy class of multiplied paths -/
theorem homotopy_left_multiplication_class {G :Graph V E} {x y z : V} (p₁ : EdgePath G x y) (p₂ : EdgePath G y z): homotopy_left_multiplication p₁ (htclass p₂) = htclass (multiply p₁ p₂) := by
  simp[htclass, homotopy_left_multiplication]

/--defines multiplication of homotopy-/
def homotopy_multiplication : ht G x y → ht G y z → ht G x z := by
  intro p₁ p₂
  let func (p : EdgePath G x y) : ht G x z := homotopy_left_multiplication p p₂
  have g : (q₁ q₂ : EdgePath G x y) → basicht q₁ q₂ → func q₁ = func q₂  := by
      intro q₁ q₂ h
      let crop (p : ht G y z) : Prop := homotopy_left_multiplication q₁ p = homotopy_left_multiplication q₂ p
      have g' : (p : ht G y z) → crop p := by
        intro p
        have g'' : (p' : EdgePath G y z) → crop (htclass p') := by
          intro p'
          have h' : homotopy q₁ q₂ := by simp[homotopy, htclass, Quot.sound h]
          have : htclass (multiply q₁ p') = htclass (multiply q₂ p') := by
            let prop := homotopy_right_mult q₁ q₂ p' h'
            rw[prop]
          simp[homotopy_left_multiplication_class, this]
        apply Quot.ind g''
      let hh := g' p₂
      have : homotopy_left_multiplication q₁ p₂ = homotopy_left_multiplication q₂ p₂ := by simp[hh]
      simp[this]
  let k := (Quot.lift (fun x => func x) g)
  apply k p₁

infixl: 65 " # " => homotopy_multiplication

/--proves that # is associative up to multiplication by a pair of paths and one homotopy class-/
theorem homotopy_mult_path_path_assoc {G :Graph V E} {w x y z : V} (p : EdgePath G w x) (q : EdgePath G x y): (r : ht G y z) → (htclass (multiply p q)) # r = (htclass p) # ((htclass q) # r) := by
  apply Quot.ind
  intro b
  simp[htclass, homotopy_multiplication]
  have p₁ : homotopy_left_multiplication (multiply p q) (Quot.mk basicht b) = htclass ( multiply (multiply p q) b) := by rfl
  have p₂ : (homotopy_left_multiplication q (Quot.mk basicht b)) = htclass (multiply q b) := by rfl
  have p₃ : (homotopy_left_multiplication p (homotopy_left_multiplication q (Quot.mk basicht b))) = htclass (multiply p (multiply q b)) := by rw[p₂] ; rfl
  rw[p₁,p₃]
  simp[mult_assoc]

/--proves that # is associative up to multiplication by one path and a pair of homotopy classes -/
theorem homotopy_mult_path_assoc {G :Graph V E} {w x y z : V} (p : EdgePath G w x) (r : ht G y z): (q : ht G x y) → (htclass p # q) # r = (htclass p) # (q # r) := by
  apply Quot.ind
  intro a
  simp[htclass]
  have p₁ : Quot.mk basicht p # Quot.mk basicht a = htclass (multiply p a) := by rfl
  rw[p₁]
  apply homotopy_mult_path_path_assoc p a r

/--proves that # is associative on homotopy classes-/
theorem homotopy_mult_assoc {G :Graph V E} {w x y z : V} (b : ht G x y) (c : ht G y z) : (a : ht G w x) → ((a # b) # c ) = (a # (b # c) )  := by
  apply Quot.ind
  intro a
  apply homotopy_mult_path_assoc a c b

/--proves that reducePathAux preserves the homotopy class-/
theorem homotopy_reducePathAux {G : Graph V E} {x y z : V} (ex : E) (h₁ : G.init ex = x) (h₂ : term G ex = y) (exy : EdgePath G y z) : homotopy (cons ex h₁ h₂ exy) (reducePathAux ex h₁ h₂ exy) := by
  simp[homotopy, htclass]
  cases exy with
  | single y =>
      have : reducePathAux ex h₁ h₂ (single y) = cons ex h₁ h₂ (single y) := by rfl
      rfl
  | cons ey h₃ h₄ eyz => apply
    if c : (x = term G ey) ∧ (ey = G.bar (ex)) then by
      let ih := Eq.symm (Eq.trans (And.left c) h₄)
      cases ih with
      |refl =>
          have : basicht (ih ▸ eyz)  (cons ex h₁ h₂ (cons ey h₃ h₄ eyz))  := by
            let j := @basicht.cancel V E G ex ey x y _ (ih ▸ eyz) h₁ h₂ (Eq.symm c.2)
            apply j
          have pr : (reducePathAux ex h₁ h₂ (cons ey h₃ h₄ eyz)).1 = (ih ▸ eyz) := by simp[reducePathAux, c]
          let k := Quot.sound (Eq.symm pr ▸ this)
          exact (Eq.symm k)
    else by
      have : reducePathAux ex h₁ h₂ (cons ey h₃ h₄ eyz) = cons ex h₁ h₂ (cons ey h₃ h₄ (eyz)) := by simp[reducePathAux, c]
      simp [this]

/--proves that reducePath preserves the homotopy class-/
theorem homotopy_reducePath {G : Graph V E} {x y : V} (p₁ : EdgePath G x y): homotopy p₁ (reducePath p₁) := by
        induction p₁ with
        | single x =>
          simp[homotopy, htclass]
          have h₁ : ( @reducePath V E _ _ x x G (single x)).1 = single x  := by rfl
          have h₂ : single x = (reducePath (single x)).1 := by exact (Eq.symm h₁)
          apply Quot.sound (h₂ ▸ basicht.consht x)

        | cons ex h₁ h₂ exy ih' =>
          let p₃ := reducePath exy
          let q := p₃.1
          let p₄ := reducePathAux ex h₁ h₂ q
          have : p₄.1 = (reducePath (cons ex h₁ h₂ exy)).1 := by rfl
          have t₁ : homotopy (cons ex h₁ h₂ q) (p₄.1) := by apply homotopy_reducePathAux ex h₁ h₂ q
          have t₂ : homotopy exy q := by apply ih'
          have t₃ : homotopy (cons ex h₁ h₂ exy) (cons ex h₁ h₂ q) := by apply homotopy_left_mult_edge exy q t₂ ex h₁ h₂
          apply homotopy_trans (cons ex h₁ h₂ exy) (cons ex h₁ h₂ q) (reducePath (cons ex h₁ h₂ exy)) t₃ (this ▸ t₁)

instance ht_mul {G : Graph V E} {x : V} :  Mul (ht G x x) where
mul : ht G x x → ht G x x → ht G x x := fun a b => homotopy_multiplication a b

--defines the identity homotopy class
instance ht_one {G : Graph V E} {x : V} : One (ht G x x) where
one : ht G x x := htclass (single x)

/--proves that multiplication of homotopy classes is associative-/
theorem ht_mult_assoc {G : Graph V E} {x : V} (a b c : ht G x x) : ((a # b) # c) = (a # ( b # c)) := by
let k := @homotopy_mult_assoc V E G x x x x
let l (a b c : ht G x x) := k b c a
apply (l a b c)

/--proves that the identity homotopy class is the right multiplicative identity-/
theorem ht_right_identity {G : Graph V E} {x : V} : (a₀ : ht G x x) → ht_mul.mul a₀  (@ht_one V E G x).one = a₀ := by
have  k (b : EdgePath G x x) : homotopy_multiplication (htclass b) (htclass (single x)) = (htclass b) := by
    let l :=mult_const b ▸ homotopy_left_multiplication_class b (single x)
    have : (htclass b) # (htclass (single x)) = homotopy_left_multiplication b (htclass (single x)) := by rfl
    apply Eq.trans this l
have k₂ (b : EdgePath G x x) : ht_mul.mul (htclass b) (@ht_one V E G x).one = htclass b := by
  apply k
apply Quot.ind
apply k₂

/--proves that the identity homotopy class is the left multiplicative identity-/
theorem ht_left_identity {G : Graph V E} {x : V} : (a₀ : ht G x x) → ht_mul.mul (@ht_one V E G x).one a₀ = a₀ := by
have  k (b : EdgePath G x x) : homotopy_multiplication (htclass (single x)) (htclass b) = (htclass b) := by
    have : (htclass b) # (htclass (single x)) = (htclass (multiply b (single x))) := by rfl
    apply (mult_const b) ▸ this
have k₂ (b : EdgePath G x x) : ht_mul.mul (@ht_one V E G x).one (htclass b)  = htclass b := by
  apply k
apply Quot.ind
apply k₂

instance ht_semigroup {G : Graph V E} {x : V} : Semigroup (ht G x x) where
mul := (@ht_mul V E G x).mul
mul_assoc := by apply ht_mult_assoc

def ht_monoid (G : Graph V E) (x : V) := @Monoid.mk (ht G x x) (ht_semigroup) (ht_one) (ht_right_identity) (ht_left_identity) (npow_rec) (by simp[npow_rec]) (by simp[npow_rec])


/-
Copyright (c) 2020 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard
-/

import ring_theory.principal_ideal_domain
import order.conditionally_complete_lattice
import ring_theory.ideal.local_ring
import ring_theory.multiplicity
import ring_theory.valuation.basic
import linear_algebra.adic_completion

/-!
# Discrete valuation rings

This file defines discrete valuation rings (DVRs) and develops a basic interface
for them.

## Important definitions

There are various definitions of a DVR in the literature; we define a DVR to be a local PID
which is not a field (the first definition in Wikipedia) and prove that this is equivalent
to being a PID with a unique non-zero prime ideal (the definition in Serre's
book "Local Fields").

Let R be an integral domain, assumed to be a principal ideal ring and a local ring.

* `discrete_valuation_ring R` : a predicate expressing that R is a DVR

### Definitions

* `add_val R : add_valuation R enat` : the additive valuation on a DVR.

## Implementation notes

It's a theorem that an element of a DVR is a uniformizer if and only if it's irreducible.
We do not hence define `uniformizer` at all, because we can use `irreducible` instead.

## Tags

discrete valuation ring
-/

open_locale classical

universe u

open ideal local_ring

/-- An integral domain is a *discrete valuation ring* (DVR) if it's a local PID which
  is not a field. -/
class discrete_valuation_ring (R : Type u) [comm_ring R] [is_domain R]
  extends is_principal_ideal_ring R, local_ring R : Prop :=
(not_a_field' : maximal_ideal R ≠ ⊥)

namespace discrete_valuation_ring

variables (R : Type u) [comm_ring R] [is_domain R] [discrete_valuation_ring R]

lemma not_a_field : maximal_ideal R ≠ ⊥ := not_a_field'

variable {R}

open principal_ideal_ring

/-- An element of a DVR is irreducible iff it is a uniformizer, that is, generates the
  maximal ideal of R -/
theorem irreducible_iff_uniformizer (ϖ : R) :
  irreducible ϖ ↔ maximal_ideal R = ideal.span {ϖ} :=
⟨λ hϖ, (eq_maximal_ideal (is_maximal_of_irreducible hϖ)).symm,
begin
  intro h,
  have h2 : ¬(is_unit ϖ) := show ϖ ∈ maximal_ideal R,
    from h.symm ▸ submodule.mem_span_singleton_self ϖ,
  refine ⟨h2, _⟩,
  intros a b hab,
  by_contra h,
  push_neg at h,
  obtain ⟨ha : a ∈ maximal_ideal R, hb : b ∈ maximal_ideal R⟩ := h,
  rw h at ha hb,
  rw mem_span_singleton' at ha hb,
  rcases ha with ⟨a, rfl⟩,
  rcases hb with ⟨b, rfl⟩,
  rw (show a * ϖ * (b * ϖ) = ϖ * (ϖ * (a * b)), by ring) at hab,
  have h3 := eq_zero_of_mul_eq_self_right _ hab.symm,
  { apply not_a_field R,
    simp [h, h3] },
  { intro hh, apply h2,
    refine is_unit_of_dvd_one ϖ _,
    use a * b, exact hh.symm }
end⟩

lemma _root_.irreducible.maximal_ideal_eq {ϖ : R} (h : irreducible ϖ) :
  maximal_ideal R = ideal.span {ϖ} :=
(irreducible_iff_uniformizer _).mp h

variable (R)

/-- Uniformisers exist in a DVR -/
theorem exists_irreducible : ∃ ϖ : R, irreducible ϖ :=
by {simp_rw [irreducible_iff_uniformizer],
    exact (is_principal_ideal_ring.principal $ maximal_ideal R).principal}

/-- Uniformisers exist in a DVR -/
theorem exists_prime : ∃ ϖ : R, prime ϖ :=
(exists_irreducible R).imp (λ _, principal_ideal_ring.irreducible_iff_prime.1)

/-- an integral domain is a DVR iff it's a PID with a unique non-zero prime ideal -/
theorem iff_pid_with_one_nonzero_prime (R : Type u) [comm_ring R] [is_domain R] :
  discrete_valuation_ring R ↔ is_principal_ideal_ring R ∧ ∃! P : ideal R, P ≠ ⊥ ∧ is_prime P :=
begin
  split,
  { intro RDVR,
    rcases id RDVR with ⟨RPID, Rlocal, Rnotafield⟩,
    split, assumption,
    resetI,
    use local_ring.maximal_ideal R,
    split, split,
    { assumption },
    { apply_instance } ,
    { rintro Q ⟨hQ1, hQ2⟩,
      obtain ⟨q, rfl⟩ := (is_principal_ideal_ring.principal Q).1,
      have hq : q ≠ 0,
      { rintro rfl,
        apply hQ1,
        simp },
      erw span_singleton_prime hq at hQ2,
      replace hQ2 := hQ2.irreducible,
      rw irreducible_iff_uniformizer at hQ2,
      exact hQ2.symm } },
  { rintro ⟨RPID, Punique⟩,
    haveI : local_ring R := local_of_unique_nonzero_prime R Punique,
    refine {not_a_field' := _},
    rcases Punique with ⟨P, ⟨hP1, hP2⟩, hP3⟩,
    have hPM : P ≤ maximal_ideal R := le_maximal_ideal (hP2.1),
    intro h, rw [h, le_bot_iff] at hPM, exact hP1 hPM }
end

lemma associated_of_irreducible {a b : R} (ha : irreducible a) (hb : irreducible b) :
  associated a b :=
begin
  rw irreducible_iff_uniformizer at ha hb,
  rw [←span_singleton_eq_span_singleton, ←ha, hb],
end

end discrete_valuation_ring

namespace discrete_valuation_ring

variable (R : Type*)

/-- Alternative characterisation of discrete valuation rings. -/
def has_unit_mul_pow_irreducible_factorization [comm_ring R] : Prop :=
∃ p : R, irreducible p ∧ ∀ {x : R}, x ≠ 0 → ∃ (n : ℕ), associated (p ^ n) x

namespace has_unit_mul_pow_irreducible_factorization

variables {R} [comm_ring R] (hR : has_unit_mul_pow_irreducible_factorization R)
include hR

lemma unique_irreducible ⦃p q : R⦄ (hp : irreducible p) (hq : irreducible q) :
  associated p q :=
begin
  rcases hR with ⟨ϖ, hϖ, hR⟩,
  suffices : ∀ {p : R} (hp : irreducible p), associated p ϖ,
  { apply associated.trans (this hp) (this hq).symm, },
  clear hp hq p q,
  intros p hp,
  obtain ⟨n, hn⟩ := hR hp.ne_zero,
  have : irreducible (ϖ ^ n) := hn.symm.irreducible hp,
  rcases lt_trichotomy n 1 with (H|rfl|H),
  { obtain rfl : n = 0, { clear hn this, revert H n, exact dec_trivial },
    simpa only [not_irreducible_one, pow_zero] using this, },
  { simpa only [pow_one] using hn.symm, },
  { obtain ⟨n, rfl⟩ : ∃ k, n = 1 + k + 1 := nat.exists_eq_add_of_lt H,
    rw pow_succ at this,
    rcases this.is_unit_or_is_unit rfl with H0|H0,
    { exact (hϖ.not_unit H0).elim, },
    { rw [add_comm, pow_succ] at H0,
      exact (hϖ.not_unit (is_unit_of_mul_is_unit_left H0)).elim } }
end

variables [is_domain R]

/-- An integral domain in which there is an irreducible element `p`
such that every nonzero element is associated to a power of `p` is a unique factorization domain.
See `discrete_valuation_ring.of_has_unit_mul_pow_irreducible_factorization`. -/
theorem to_unique_factorization_monoid : unique_factorization_monoid R :=
let p := classical.some hR in
let spec := classical.some_spec hR in
unique_factorization_monoid.of_exists_prime_factors $ λ x hx,
begin
  use multiset.repeat p (classical.some (spec.2 hx)),
  split,
  { intros q hq,
    have hpq := multiset.eq_of_mem_repeat hq,
    rw hpq,
    refine ⟨spec.1.ne_zero, spec.1.not_unit, _⟩,
    intros a b h,
    by_cases ha : a = 0,
    { rw ha, simp only [true_or, dvd_zero], },
    obtain ⟨m, u, rfl⟩ := spec.2 ha,
    rw [mul_assoc, mul_left_comm, is_unit.dvd_mul_left _ _ _ (units.is_unit _)] at h,
    rw is_unit.dvd_mul_right (units.is_unit _),
    by_cases hm : m = 0,
    { simp only [hm, one_mul, pow_zero] at h ⊢, right, exact h },
    left,
    obtain ⟨m, rfl⟩ := nat.exists_eq_succ_of_ne_zero hm,
    rw pow_succ,
    apply dvd_mul_of_dvd_left dvd_rfl _ },
  { rw [multiset.prod_repeat], exact (classical.some_spec (spec.2 hx)), }
end

omit hR

lemma of_ufd_of_unique_irreducible [unique_factorization_monoid R]
  (h₁ : ∃ p : R, irreducible p)
  (h₂ : ∀ ⦃p q : R⦄, irreducible p → irreducible q → associated p q) :
  has_unit_mul_pow_irreducible_factorization R :=
begin
  obtain ⟨p, hp⟩ := h₁,
  refine ⟨p, hp, _⟩,
  intros x hx,
  cases wf_dvd_monoid.exists_factors x hx with fx hfx,
  refine ⟨fx.card, _⟩,
  have H := hfx.2,
  rw ← associates.mk_eq_mk_iff_associated at H ⊢,
  rw [← H, ← associates.prod_mk, associates.mk_pow, ← multiset.prod_repeat],
  congr' 1,
  symmetry,
  rw multiset.eq_repeat,
  simp only [true_and, and_imp, multiset.card_map, eq_self_iff_true,
    multiset.mem_map, exists_imp_distrib],
  rintros _ q hq rfl,
  rw associates.mk_eq_mk_iff_associated,
  apply h₂ (hfx.1 _ hq) hp,
end

end has_unit_mul_pow_irreducible_factorization

lemma aux_pid_of_ufd_of_unique_irreducible
  (R : Type u) [comm_ring R] [is_domain R] [unique_factorization_monoid R]
  (h₁ : ∃ p : R, irreducible p)
  (h₂ : ∀ ⦃p q : R⦄, irreducible p → irreducible q → associated p q) :
  is_principal_ideal_ring R :=
begin
  constructor,
  intro I,
  by_cases I0 : I = ⊥, { rw I0, use 0, simp only [set.singleton_zero, submodule.span_zero], },
  obtain ⟨x, hxI, hx0⟩ : ∃ x ∈ I, x ≠ (0:R) := I.ne_bot_iff.mp I0,
  obtain ⟨p, hp, H⟩ :=
    has_unit_mul_pow_irreducible_factorization.of_ufd_of_unique_irreducible h₁ h₂,
  have ex : ∃ n : ℕ, p ^ n ∈ I,
  { obtain ⟨n, u, rfl⟩ := H hx0,
    refine ⟨n, _⟩,
    simpa only [units.mul_inv_cancel_right] using I.mul_mem_right ↑u⁻¹ hxI, },
  constructor,
  use p ^ (nat.find ex),
  show I = ideal.span _,
  apply le_antisymm,
  { intros r hr,
    by_cases hr0 : r = 0,
    { simp only [hr0, submodule.zero_mem], },
    obtain ⟨n, u, rfl⟩ := H hr0,
    simp only [mem_span_singleton, units.is_unit, is_unit.dvd_mul_right],
    apply pow_dvd_pow,
    apply nat.find_min',
    simpa only [units.mul_inv_cancel_right] using I.mul_mem_right ↑u⁻¹ hr, },
  { erw submodule.span_singleton_le_iff_mem,
    exact nat.find_spec ex, },
end

/--
A unique factorization domain with at least one irreducible element
in which all irreducible elements are associated
is a discrete valuation ring.
-/
lemma of_ufd_of_unique_irreducible
  {R : Type u} [comm_ring R] [is_domain R] [unique_factorization_monoid R]
  (h₁ : ∃ p : R, irreducible p)
  (h₂ : ∀ ⦃p q : R⦄, irreducible p → irreducible q → associated p q) :
  discrete_valuation_ring R :=
begin
  rw iff_pid_with_one_nonzero_prime,
  haveI PID : is_principal_ideal_ring R := aux_pid_of_ufd_of_unique_irreducible R h₁ h₂,
  obtain ⟨p, hp⟩ := h₁,
  refine ⟨PID, ⟨ideal.span {p}, ⟨_, _⟩, _⟩⟩,
  { rw submodule.ne_bot_iff,
    refine ⟨p, ideal.mem_span_singleton.mpr (dvd_refl p), hp.ne_zero⟩, },
  { rwa [ideal.span_singleton_prime hp.ne_zero,
        ← unique_factorization_monoid.irreducible_iff_prime], },
  { intro I,
    rw ← submodule.is_principal.span_singleton_generator I,
    rintro ⟨I0, hI⟩,
    apply span_singleton_eq_span_singleton.mpr,
    apply h₂ _ hp,
    erw [ne.def, span_singleton_eq_bot] at I0,
    rwa [unique_factorization_monoid.irreducible_iff_prime, ← ideal.span_singleton_prime I0],
    apply_instance, },
end

/--
An integral domain in which there is an irreducible element `p`
such that every nonzero element is associated to a power of `p`
is a discrete valuation ring.
-/
lemma of_has_unit_mul_pow_irreducible_factorization {R : Type u} [comm_ring R] [is_domain R]
  (hR : has_unit_mul_pow_irreducible_factorization R) :
  discrete_valuation_ring R :=
begin
  letI : unique_factorization_monoid R := hR.to_unique_factorization_monoid,
  apply of_ufd_of_unique_irreducible _ hR.unique_irreducible,
  unfreezingI { obtain ⟨p, hp, H⟩ := hR, exact ⟨p, hp⟩, },
end

section

variables [comm_ring R] [is_domain R] [discrete_valuation_ring R]

variable {R}

lemma associated_pow_irreducible {x : R} (hx : x ≠ 0) {ϖ : R} (hirr : irreducible ϖ) :
  ∃ (n : ℕ), associated x (ϖ ^ n) :=
begin
  have : wf_dvd_monoid R := is_noetherian_ring.wf_dvd_monoid,
  cases wf_dvd_monoid.exists_factors x hx with fx hfx,
  unfreezingI { use fx.card },
  have H := hfx.2,
  rw ← associates.mk_eq_mk_iff_associated at H ⊢,
  rw [← H, ← associates.prod_mk, associates.mk_pow, ← multiset.prod_repeat],
  congr' 1,
  rw multiset.eq_repeat,
  simp only [true_and, and_imp, multiset.card_map, eq_self_iff_true,
             multiset.mem_map, exists_imp_distrib],
  rintros _ _ _ rfl,
  rw associates.mk_eq_mk_iff_associated,
  refine associated_of_irreducible _ _ hirr,
  apply hfx.1,
  assumption
end

lemma eq_unit_mul_pow_irreducible {x : R} (hx : x ≠ 0) {ϖ : R} (hirr : irreducible ϖ) :
  ∃ (n : ℕ) (u : units R), x = u * ϖ ^ n :=
begin
  obtain ⟨n, hn⟩ := associated_pow_irreducible hx hirr,
  obtain ⟨u, rfl⟩ := hn.symm,
  use [n, u],
  apply mul_comm,
end

open submodule.is_principal

lemma ideal_eq_span_pow_irreducible {s : ideal R} (hs : s ≠ ⊥) {ϖ : R} (hirr : irreducible ϖ) :
  ∃ n : ℕ, s = ideal.span {ϖ ^ n} :=
begin
  have gen_ne_zero : generator s ≠ 0,
  { rw [ne.def, ← eq_bot_iff_generator_eq_zero], assumption },
  rcases associated_pow_irreducible gen_ne_zero hirr with ⟨n, u, hnu⟩,
  use n,
  have : span _ = _ := span_singleton_generator s,
  rw [← this, ← hnu, span_singleton_eq_span_singleton],
  use u
end

lemma unit_mul_pow_congr_pow {p q : R} (hp : irreducible p) (hq : irreducible q)
  (u v : units R) (m n : ℕ) (h : ↑u * p ^ m = v * q ^ n) :
  m = n :=
begin
  have key : associated (multiset.repeat p m).prod (multiset.repeat q n).prod,
  { rw [multiset.prod_repeat, multiset.prod_repeat, associated],
    refine ⟨u * v⁻¹, _⟩,
    simp only [units.coe_mul],
    rw [mul_left_comm, ← mul_assoc, h, mul_right_comm, units.mul_inv, one_mul], },
  have := multiset.card_eq_card_of_rel (unique_factorization_monoid.factors_unique _ _ key),
  { simpa only [multiset.card_repeat] },
  all_goals
  { intros x hx, replace hx := multiset.eq_of_mem_repeat hx,
    unfreezingI { subst hx, assumption } },
end

lemma unit_mul_pow_congr_unit {ϖ : R} (hirr : irreducible ϖ) (u v : units R) (m n : ℕ)
  (h : ↑u * ϖ ^ m = v * ϖ ^ n) :
  u = v :=
begin
  obtain rfl : m = n := unit_mul_pow_congr_pow hirr hirr u v m n h,
  rw ← sub_eq_zero at h,
  rw [← sub_mul, mul_eq_zero] at h,
  cases h,
  { rw sub_eq_zero at h, exact_mod_cast h },
  { apply (hirr.ne_zero (pow_eq_zero h)).elim, }
end

/-!
## The additive valuation on a DVR
-/

open multiplicity

/-- The `enat`-valued additive valuation on a DVR -/
noncomputable def add_val
  (R : Type u) [comm_ring R] [is_domain R] [discrete_valuation_ring R] :
  add_valuation R enat :=
add_valuation (classical.some_spec (exists_prime R))

lemma add_val_def (r : R) (u : units R) {ϖ : R} (hϖ : irreducible ϖ) (n : ℕ) (hr : r = u * ϖ ^ n) :
  add_val R r = n :=
by rw [add_val, add_valuation_apply, hr,
    eq_of_associated_left (associated_of_irreducible R hϖ
      (classical.some_spec (exists_prime R)).irreducible),
    eq_of_associated_right (associated.symm ⟨u, mul_comm _ _⟩),
    multiplicity_pow_self_of_prime (principal_ideal_ring.irreducible_iff_prime.1 hϖ)]

lemma add_val_def' (u : units R) {ϖ : R} (hϖ : irreducible ϖ) (n : ℕ) :
  add_val R ((u : R) * ϖ ^ n) = n :=
add_val_def _ u hϖ n rfl

@[simp] lemma add_val_zero : add_val R 0 = ⊤ :=
(add_val R).map_zero

@[simp] lemma add_val_one : add_val R 1 = 0 :=
(add_val R).map_one

@[simp] lemma add_val_uniformizer {ϖ : R} (hϖ : irreducible ϖ) : add_val R ϖ = 1 :=
by simpa only [one_mul, eq_self_iff_true, units.coe_one, pow_one, forall_true_left, nat.cast_one]
  using add_val_def ϖ 1 hϖ 1

@[simp] lemma add_val_mul {a b : R} :
  add_val R (a * b) = add_val R a + add_val R b :=
(add_val R).map_mul _ _

lemma add_val_pow (a : R) (n : ℕ) : add_val R (a ^ n) = n • add_val R a :=
(add_val R).map_pow _ _

lemma _root_.irreducible.add_val_pow {ϖ : R} (h : irreducible ϖ) (n : ℕ) :
  add_val R (ϖ ^ n) = n :=
by rw [add_val_pow, add_val_uniformizer h, nsmul_one]

lemma add_val_eq_top_iff {a : R} : add_val R a = ⊤ ↔ a = 0 :=
begin
  have hi := (classical.some_spec (exists_prime R)).irreducible,
  split,
  { contrapose,
    intro h,
    obtain ⟨n, ha⟩ := associated_pow_irreducible h hi,
    obtain ⟨u, rfl⟩ := ha.symm,
    rw [mul_comm, add_val_def' u hi n],
    exact enat.coe_ne_top _ },
  { rintro rfl,
    exact add_val_zero }
end

lemma add_val_le_iff_dvd {a b : R} : add_val R a ≤ add_val R b ↔ a ∣ b :=
begin
  have hp := classical.some_spec (exists_prime R),
  split; intro h,
  { by_cases ha0 : a = 0,
    { rw [ha0, add_val_zero, top_le_iff, add_val_eq_top_iff] at h,
      rw h,
      apply dvd_zero },
    obtain ⟨n, ha⟩ := associated_pow_irreducible ha0 hp.irreducible,
    rw [add_val, add_valuation_apply, add_valuation_apply,
      multiplicity_le_multiplicity_iff] at h,
    exact ha.dvd.trans (h n ha.symm.dvd), },
  { rw [add_val, add_valuation_apply, add_valuation_apply],
    exact multiplicity_le_multiplicity_of_dvd_right h }
end

lemma add_val_add {a b : R} :
  min (add_val R a) (add_val R b) ≤ add_val R (a + b) :=
(add_val R).map_add _ _

end

instance (R : Type*) [comm_ring R] [is_domain R] [discrete_valuation_ring R] :
  is_Hausdorff (maximal_ideal R) R :=
{ haus' := λ x hx,
  begin
    obtain ⟨ϖ, hϖ⟩ := exists_irreducible R,
    simp only [← ideal.one_eq_top, smul_eq_mul, mul_one, smodeq.zero,
      hϖ.maximal_ideal_eq, ideal.span_singleton_pow, ideal.mem_span_singleton,
      ← add_val_le_iff_dvd, hϖ.add_val_pow] at hx,
    rwa [← add_val_eq_top_iff, enat.eq_top_iff_forall_le],
  end }

end discrete_valuation_ring


import algebra.archimedean
import data.real.basic

definition completeness_axiom (k : Type*) [preorder k] : Prop :=
∀ (S : set k), (∃ x, x ∈ S) → (∃ x, ∀ y ∈ S, y ≤ x) →
  ∃ x, ∀ y, x ≤ y ↔ ∀ z ∈ S, z ≤ y

open function

theorem characterisation_of_reals (k : Type*) [discrete_linear_ordered_field k] [archimedean k] :
completeness_axiom k → ∃ f : k → ℝ, is_ring_hom f ∧ bijective f ∧ ∀ x y : k, x < y → f x < f y := sorry


import data.fp.basic

open fp

variable [C : float_cfg]
include C

theorem float.one.valid : valid_finite emin 1 :=
⟨begin
  -- Can we make linarith work here?
  rw add_sub_assoc,
  apply le_add_of_nonneg_right,
  apply sub_nonneg_of_le,
  apply int.coe_nat_le_coe_nat_of_le,
  exact C.prec_pos,
end,
begin
   suffices hsuff : prec ≤ 2 * emax,
   { rw ←int.coe_nat_le at hsuff,
     rw ←sub_nonneg at *,
     simp only [emin, emax] at *,
     ring,
     assumption, },
    exact (le_trans C.prec_max (nat.le_mul_of_pos_left dec_trivial)),
end,
begin
    rw max_eq_right,
    simp [sub_eq_add_neg, add_comm],
    exact (int.coe_nat_le_coe_nat_of_le C.prec_pos),
end⟩

def float.one (s : bool) : float :=
float.finite s emin 1 float.one.valid


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import ring_theory.localization.basic

/-!
# Integer elements of a localization

## Main definitions

 * `is_localization.is_integer` is a predicate stating that `x : S` is in the image of `R`

## Implementation notes

See `src/ring_theory/localization/basic.lean` for a design overview.

## Tags
localization, ring localization, commutative ring localization, characteristic predicate,
commutative ring, field of fractions
-/

variables {R : Type*} [comm_ring R] {M : submonoid R} {S : Type*} [comm_ring S]
variables [algebra R S] {P : Type*} [comm_ring P]

open function
open_locale big_operators

namespace is_localization

section

variables (R) {M S}

-- TODO: define a subalgebra of `is_integer`s
/-- Given `a : S`, `S` a localization of `R`, `is_integer R a` iff `a` is in the image of
the localization map from `R` to `S`. -/
def is_integer (a : S) : Prop := a ∈ (algebra_map R S).range

end

lemma is_integer_zero : is_integer R (0 : S) := subring.zero_mem _
lemma is_integer_one : is_integer R (1 : S) := subring.one_mem _

lemma is_integer_add {a b : S} (ha : is_integer R a) (hb : is_integer R b) :
  is_integer R (a + b) :=
subring.add_mem _ ha hb

lemma is_integer_mul {a b : S} (ha : is_integer R a) (hb : is_integer R b) :
  is_integer R (a * b) :=
subring.mul_mem _ ha hb

lemma is_integer_smul {a : R} {b : S} (hb : is_integer R b) :
  is_integer R (a • b) :=
begin
  rcases hb with ⟨b', hb⟩,
  use a * b',
  rw [←hb, (algebra_map R S).map_mul, algebra.smul_def]
end

variables (M) {S} [is_localization M S]

/-- Each element `a : S` has an `M`-multiple which is an integer.

This version multiplies `a` on the right, matching the argument order in `localization_map.surj`.
-/
lemma exists_integer_multiple' (a : S) :
  ∃ (b : M), is_integer R (a * algebra_map R S b) :=
let ⟨⟨num, denom⟩, h⟩ := is_localization.surj _ a in ⟨denom, set.mem_range.mpr ⟨num, h.symm⟩⟩

/-- Each element `a : S` has an `M`-multiple which is an integer.

This version multiplies `a` on the left, matching the argument order in the `has_scalar` instance.
-/
lemma exists_integer_multiple (a : S) :
  ∃ (b : M), is_integer R ((b : R) • a) :=
by { simp_rw [algebra.smul_def, mul_comm _ a], apply exists_integer_multiple' }

/-- We can clear the denominators of a `finset`-indexed family of fractions. -/
lemma exist_integer_multiples {ι : Type*} (s : finset ι) (f : ι → S) :
  ∃ (b : M), ∀ i ∈ s, is_localization.is_integer R ((b : R) • f i) :=
begin
  haveI := classical.prop_decidable,
  refine ⟨∏ i in s, (sec M (f i)).2, λ i hi, ⟨_, _⟩⟩,
  { exact (∏ j in s.erase i, (sec M (f j)).2) * (sec M (f i)).1 },
  rw [ring_hom.map_mul, sec_spec', ←mul_assoc, ←(algebra_map R S).map_mul, ← algebra.smul_def],
  congr' 2,
  refine trans _ ((submonoid.subtype M).map_prod _ _).symm,
  rw [mul_comm, ←finset.prod_insert (s.not_mem_erase i), finset.insert_erase hi],
  refl
end

/-- We can clear the denominators of a `fintype`-indexed family of fractions. -/
lemma exist_integer_multiples_of_fintype {ι : Type*} [fintype ι] (f : ι → S) :
  ∃ (b : M), ∀ i, is_localization.is_integer R ((b : R) • f i) :=
begin
  obtain ⟨b, hb⟩ := exist_integer_multiples M finset.univ f,
  exact ⟨b, λ i, hb i (finset.mem_univ _)⟩
end

/-- We can clear the denominators of a finite set of fractions. -/
lemma exist_integer_multiples_of_finset (s : finset S) :
  ∃ (b : M), ∀ a ∈ s, is_integer R ((b : R) • a) :=
exist_integer_multiples M s id

/-- A choice of a common multiple of the denominators of a `finset`-indexed family of fractions. -/
noncomputable
def common_denom {ι : Type*} (s : finset ι) (f : ι → S) : M :=
(exist_integer_multiples M s f).some

/-- The numerator of a fraction after clearing the denominators
of a `finset`-indexed family of fractions. -/
noncomputable
def integer_multiple {ι : Type*} (s : finset ι) (f : ι → S) (i : s) : R :=
((exist_integer_multiples M s f).some_spec i i.prop).some

@[simp]
lemma map_integer_multiple {ι : Type*} (s : finset ι) (f : ι → S) (i : s) :
  algebra_map R S (integer_multiple M s f i) = common_denom M s f • f i :=
((exist_integer_multiples M s f).some_spec _ i.prop).some_spec

/-- A choice of a common multiple of the denominators of a finite set of fractions. -/
noncomputable
def common_denom_of_finset (s : finset S) : M :=
common_denom M s id

/-- The finset of numerators after clearing the denominators of a finite set of fractions. -/
noncomputable
def finset_integer_multiple [decidable_eq R] (s : finset S) : finset R :=
s.attach.image (λ t, integer_multiple M s id t)

open_locale pointwise

lemma finset_integer_multiple_image [decidable_eq R] (s : finset S) :
  algebra_map R S '' (finset_integer_multiple M s) =
    common_denom_of_finset M s • s :=
begin
  delta finset_integer_multiple common_denom,
  rw finset.coe_image,
  ext,
  split,
  { rintro ⟨_, ⟨x, -, rfl⟩, rfl⟩,
    rw map_integer_multiple,
    exact set.mem_image_of_mem _ x.prop },
  { rintro ⟨x, hx, rfl⟩,
    exact ⟨_, ⟨⟨x, hx⟩, s.mem_attach _, rfl⟩, map_integer_multiple M s id _⟩ }
end

end is_localization


import pq_induction_principles

universes u1 u2

section pq_hom_group_property

variables {G : Type u1} [group G] {H : Type u2} [group H]

theorem pq_hom_group_property (f : G → H) (hf : is_pq_morphism f)
: (∀ x y : G, f (x * y) = (f x) * (f y))
↔ (∀ x : pq_group G, counit (L_of_morph f hf x) = f (counit x)) :=
begin
  split,
  {
    intros hf1,
    apply pq_group_word_induction,
    {
      simp only [monoid_hom.map_one],
      specialize hf1 1 1,
      simp only [mul_one] at hf1,
      symmetry,
      apply eq_one_of_left_cancel_mul_self,
      assumption,
    },
    {
      intros x y hx,
      simp only [monoid_hom.map_mul, hf1, counit_of, L_of_morph_of, hx],
    },
  },
  {
    intros hf1 x y,
    specialize hf1 ((of x) * (of y)),
    simp only [monoid_hom.map_mul, L_of_morph_of, counit_of] at hf1,
    symmetry,
    assumption,
  },
end

end pq_hom_group_property

/-

section pq_hom_group_property_dual

variables {Q1 : Type u1} [power_quandle Q1] {Q2 : Type u2} [power_quandle Q2] [inhabited Q2]

lemma L_of_morph_of_eq_of_imp_eq_of (x : pq_group Q2) (hx : of x = L_of_morph of of_is_pq_morphism x) : ∃ y, x = of y :=
begin
  /-
  induction x,
  {
    rw quot_mk_helper at *,
    induction x,
    {
      rw incl_unit_eq_unit at *,
      use (arbitrary Q2) ^ (0 : ℤ),
      rw of_pow_eq_pow_of,
      simp only [gpow_zero],
    },
    {
      rw ←of_def at *,
      use x,
    },
    {
      rw ←mul_def at *,
    },
    {
      rw ←inv_def at *,
      sorry,
    },
  },
  {refl,},
  -/

  revert x,
  refine pq_group_word_induction _ _,
  {
    intro hx,
    use (arbitrary Q2) ^ (0 : ℤ),
    rw of_pow_eq_pow_of,
    simp only [gpow_zero],
  },
  {
    intros x y hx hxy,
    simp only [monoid_hom.map_mul, L_of_morph_of] at hxy,
    --have hxy1 := congr_arg counit hxy,
    --simp only [monoid_hom.map_mul, counit_of, mul_right_inj] at hxy1,

  },

end

theorem pq_hom_group_property_dual' (f : pq_group Q1 →* pq_group Q2)
: (∀ x : Q1, ∃ y : Q2, f (of x) = of y)
↔ (∀ x : pq_group Q1, (L_of_morph (of : Q2 → pq_group Q2) of_is_pq_morphism) (f x)
= (L_of_morph f (functoriality_group_bundled_to_pq f)) ((L_of_morph (of : Q1 → pq_group Q1) of_is_pq_morphism) x))
:=
begin
  split,
  {
    intro hf,
    apply pq_group_word_induction,
    {
      simp only [monoid_hom.map_one],
    },
    {
      intros x y hx,
      specialize hf y,
      cases hf with z hz,
      simp only [monoid_hom.map_mul, hx, L_of_morph_of, mul_left_inj],
      rw hz,
      refl,
    },
  },
  {
    intro hf,
    intro q,
    specialize hf (of q),
    simp only [monoid_hom.map_mul, L_of_morph_of] at hf,
    apply L_of_morph_of_eq_of_imp_eq_of,
    symmetry,
    assumption,
  },
end

theorem pq_hom_group_property_dual (f : pq_group Q1 →* pq_group Q2)
: (∃ g : Q1 → Q2, ∃ hg : is_pq_morphism g, f = L_of_morph g hg)
↔ (∀ x : pq_group Q1, (L_of_morph (of : Q2 → pq_group Q2) of_is_pq_morphism) (f x)
= (L_of_morph f (functoriality_group_bundled_to_pq f)) ((L_of_morph (of : Q1 → pq_group Q1) of_is_pq_morphism) x))
:=
begin
  split,
  {
    intro hf,
    cases hf with g hg,
    cases hg with hgpq hg,
    rw hg,
    apply pq_group_word_induction,
    {
      simp only [monoid_hom.map_one],
    },
    {
      intros x y hx,
      simp only [monoid_hom.map_mul, hx, L_of_morph_of],
    },
  },
  {
    intro hf,
    fconstructor,
    intro q,
    specialize hf (of q),
    simp only [monoid_hom.map_mul, L_of_morph_of] at hf,
  },
end

end pq_hom_group_property_dual

-/


import challenge_notations
import challenge_prerequisites

import algebra.order.complete_field

/-!

This file shows that `ℝ` is a conditionally complete linearly ordered field.

Key result from mathlib:
[#3292](https://github.com/leanprover-community/mathlib/pull/3292)

-/

noncomputable theory

open_locale liquid_tensor_experiment nnreal zero_object
open liquid_tensor_experiment category_theory category_theory.limits opposite

/-!
The real numbers `ℝ` are a conditionally complete linearly ordered field.
-/
example : conditionally_complete_linear_ordered_field ℝ :=
infer_instance

/-!
The type of nonnegative real numbers is denoted by `ℝ≥0`.
-/
example : ℝ≥0 = {r : ℝ // r ≥ 0} :=
rfl

/-!
Any conditionally complete linear ordered field is isomorphic (as an ordered ring) to `ℝ`.
-/
example {R : Type} [conditionally_complete_linear_ordered_field R] : R ≃+*o ℝ :=
default

/-!
The isomorphism above is unique.
-/
example {R : Type} [conditionally_complete_linear_ordered_field R] (e₁ e₂ : R ≃+*o ℝ) :
  e₁ = e₂ :=
subsingleton.elim _ _


/-
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 data.polynomial.ring_division
import data.polynomial.derivative
import algebra.gcd_monoid

/-!
# Theory of univariate polynomials

This file starts looking like the ring theory of $ R[X] $

-/

noncomputable theory
open_locale classical big_operators

namespace polynomial
universes u v w y z
variables {R : Type u} {S : Type v} {k : Type y} {A : Type z} {a b : R} {n : ℕ}

section integral_domain
variables [integral_domain R] [normalization_monoid R]
instance : normalization_monoid (polynomial R) :=
{ norm_unit := λ p, ⟨C ↑(norm_unit (p.leading_coeff)), C ↑(norm_unit (p.leading_coeff))⁻¹,
    by rw [← ring_hom.map_mul, units.mul_inv, C_1], by rw [← ring_hom.map_mul, units.inv_mul, C_1]⟩,
  norm_unit_zero := units.ext (by simp),
  norm_unit_mul := λ p q hp0 hq0, units.ext (begin
      dsimp,
      rw [ne.def, ← leading_coeff_eq_zero] at *,
      rw [leading_coeff_mul, norm_unit_mul hp0 hq0, units.coe_mul, C_mul],
    end),
  norm_unit_coe_units := λ u,
    units.ext begin
      rw [← mul_one u⁻¹, units.coe_mul, units.eq_inv_mul_iff_mul_eq],
      dsimp,
      rcases polynomial.is_unit_iff.1 ⟨u, rfl⟩ with ⟨_, ⟨w, rfl⟩, h2⟩,
      rw [← h2, leading_coeff_C, norm_unit_coe_units, ← C_mul, units.mul_inv, C_1],
    end }

@[simp]
lemma coe_norm_unit {p : polynomial R} :
  (norm_unit p : polynomial R) = C ↑(norm_unit p.leading_coeff) :=
by simp [norm_unit]

lemma leading_coeff_normalize (p : polynomial R) :
  leading_coeff (normalize p) = normalize (leading_coeff p) := by simp

end integral_domain

section field
variables [field R] {p q : polynomial R}

lemma is_unit_iff_degree_eq_zero : is_unit p ↔ degree p = 0 :=
⟨degree_eq_zero_of_is_unit,
  λ h, have degree p ≤ 0, by simp [*, le_refl],
    have hc : coeff p 0 ≠ 0, from λ hc,
        by rw [eq_C_of_degree_le_zero this, hc] at h;
        simpa using h,
    is_unit_iff_dvd_one.2 ⟨C (coeff p 0)⁻¹, begin
      conv in p { rw eq_C_of_degree_le_zero this },
      rw [← C_mul, _root_.mul_inv_cancel hc, C_1]
    end⟩⟩

lemma degree_pos_of_ne_zero_of_nonunit (hp0 : p ≠ 0) (hp : ¬is_unit p) :
  0 < degree p :=
lt_of_not_ge (λ h, by rw [eq_C_of_degree_le_zero h] at hp0 hp;
  exact (hp $ is_unit.map' C $
    is_unit.mk0 (coeff p 0) (mt C_inj.2 (by simpa using hp0))))

lemma monic_mul_leading_coeff_inv (h : p ≠ 0) :
  monic (p * C (leading_coeff p)⁻¹) :=
by rw [monic, leading_coeff_mul, leading_coeff_C,
  mul_inv_cancel (show leading_coeff p ≠ 0, from mt leading_coeff_eq_zero.1 h)]

lemma degree_mul_leading_coeff_inv (p : polynomial R) (h : q ≠ 0) :
  degree (p * C (leading_coeff q)⁻¹) = degree p :=
have h₁ : (leading_coeff q)⁻¹ ≠ 0 :=
  inv_ne_zero (mt leading_coeff_eq_zero.1 h),
by rw [degree_mul, degree_C h₁, add_zero]

theorem irreducible_of_monic {p : polynomial R} (hp1 : p.monic) (hp2 : p ≠ 1) :
  irreducible p ↔ (∀ f g : polynomial R, f.monic → g.monic → f * g = p → f = 1 ∨ g = 1) :=
⟨λ hp3 f g hf hg hfg, or.cases_on (hp3.is_unit_or_is_unit hfg.symm)
  (assume huf : is_unit f, or.inl $ eq_one_of_is_unit_of_monic hf huf)
  (assume hug : is_unit g, or.inr $ eq_one_of_is_unit_of_monic hg hug),
λ hp3, ⟨mt (eq_one_of_is_unit_of_monic hp1) hp2, λ f g hp,
have hf : f ≠ 0, from λ hf, by { rw [hp, hf, zero_mul] at hp1, exact not_monic_zero hp1 },
have hg : g ≠ 0, from λ hg, by { rw [hp, hg, mul_zero] at hp1, exact not_monic_zero hp1 },
or.imp (λ hf, is_unit_of_mul_eq_one _ _ hf) (λ hg, is_unit_of_mul_eq_one _ _ hg) $
hp3 (f * C f.leading_coeff⁻¹) (g * C g.leading_coeff⁻¹)
  (monic_mul_leading_coeff_inv hf) (monic_mul_leading_coeff_inv hg) $
by rw [mul_assoc, mul_left_comm _ g, ← mul_assoc, ← C_mul, ← mul_inv', ← leading_coeff_mul,
    ← hp, monic.def.1 hp1, inv_one, C_1, mul_one]⟩⟩

/-- Division of polynomials. See polynomial.div_by_monic for more details.-/
def div (p q : polynomial R) :=
C (leading_coeff q)⁻¹ * (p /ₘ (q * C (leading_coeff q)⁻¹))

/-- Remainder of polynomial division, see the lemma `quotient_mul_add_remainder_eq_aux`.
See polynomial.mod_by_monic for more details. -/
def mod (p q : polynomial R) :=
p %ₘ (q * C (leading_coeff q)⁻¹)

private lemma quotient_mul_add_remainder_eq_aux (p q : polynomial R) :
  q * div p q + mod p q = p :=
if h : q = 0 then by simp only [h, zero_mul, mod, mod_by_monic_zero, zero_add]
else begin
  conv {to_rhs, rw ← mod_by_monic_add_div p (monic_mul_leading_coeff_inv h)},
  rw [div, mod, add_comm, mul_assoc]
end

private lemma remainder_lt_aux (p : polynomial R) (hq : q ≠ 0) :
  degree (mod p q) < degree q :=
by rw ← degree_mul_leading_coeff_inv q hq; exact
  degree_mod_by_monic_lt p (monic_mul_leading_coeff_inv hq)
    (mul_ne_zero hq (mt leading_coeff_eq_zero.2 (by rw leading_coeff_C;
      exact inv_ne_zero (mt leading_coeff_eq_zero.1 hq))))

instance : has_div (polynomial R) := ⟨div⟩

instance : has_mod (polynomial R) := ⟨mod⟩

lemma div_def : p / q = C (leading_coeff q)⁻¹ * (p /ₘ (q * C (leading_coeff q)⁻¹)) := rfl

lemma mod_def : p % q = p %ₘ (q * C (leading_coeff q)⁻¹) := rfl

lemma mod_by_monic_eq_mod (p : polynomial R) (hq : monic q) : p %ₘ q = p % q :=
show p %ₘ q = p %ₘ (q * C (leading_coeff q)⁻¹), by simp only [monic.def.1 hq, inv_one, mul_one, C_1]

lemma div_by_monic_eq_div (p : polynomial R) (hq : monic q) : p /ₘ q = p / q :=
show p /ₘ q = C (leading_coeff q)⁻¹ * (p /ₘ (q * C (leading_coeff q)⁻¹)),
by simp only [monic.def.1 hq, inv_one, C_1, one_mul, mul_one]

lemma mod_X_sub_C_eq_C_eval (p : polynomial R) (a : R) : p % (X - C a) = C (p.eval a) :=
mod_by_monic_eq_mod p (monic_X_sub_C a) ▸ mod_by_monic_X_sub_C_eq_C_eval _ _

lemma mul_div_eq_iff_is_root : (X - C a) * (p / (X - C a)) = p ↔ is_root p a :=
div_by_monic_eq_div p (monic_X_sub_C a) ▸ mul_div_by_monic_eq_iff_is_root

instance : euclidean_domain (polynomial R) :=
{ quotient := (/),
  quotient_zero := by simp [div_def],
  remainder := (%),
  r := _,
  r_well_founded := degree_lt_wf,
  quotient_mul_add_remainder_eq := quotient_mul_add_remainder_eq_aux,
  remainder_lt := λ p q hq, remainder_lt_aux _ hq,
  mul_left_not_lt := λ p q hq, not_lt_of_ge (degree_le_mul_left _ hq),
  .. polynomial.comm_ring,
  .. polynomial.nontrivial }

lemma mod_eq_self_iff (hq0 : q ≠ 0) : p % q = p ↔ degree p < degree q :=
⟨λ h, h ▸ euclidean_domain.mod_lt _ hq0,
λ h, have ¬degree (q * C (leading_coeff q)⁻¹) ≤ degree p :=
  not_le_of_gt $ by rwa degree_mul_leading_coeff_inv q hq0,
begin
  rw [mod_def, mod_by_monic, dif_pos (monic_mul_leading_coeff_inv hq0)],
  unfold div_mod_by_monic_aux,
  simp only [this, false_and, if_false]
end⟩

lemma div_eq_zero_iff (hq0 : q ≠ 0) : p / q = 0 ↔ degree p < degree q :=
⟨λ h, by have := euclidean_domain.div_add_mod p q;
  rwa [h, mul_zero, zero_add, mod_eq_self_iff hq0] at this,
λ h, have hlt : degree p < degree (q * C (leading_coeff q)⁻¹),
    by rwa degree_mul_leading_coeff_inv q hq0,
  have hm : monic (q * C (leading_coeff q)⁻¹) := monic_mul_leading_coeff_inv hq0,
  by rw [div_def, (div_by_monic_eq_zero_iff hm (ne_zero_of_monic hm)).2 hlt, mul_zero]⟩

lemma degree_add_div (hq0 : q ≠ 0) (hpq : degree q ≤ degree p) :
  degree q + degree (p / q) = degree p :=
have degree (p % q) < degree (q * (p / q)) :=
  calc degree (p % q) < degree q : euclidean_domain.mod_lt _ hq0
  ... ≤ _ : degree_le_mul_left _ (mt (div_eq_zero_iff hq0).1 (not_lt_of_ge hpq)),
by conv_rhs { rw [← euclidean_domain.div_add_mod p q,
    degree_add_eq_left_of_degree_lt this, degree_mul] }

lemma degree_div_le (p q : polynomial R) : degree (p / q) ≤ degree p :=
if hq : q = 0 then by simp [hq]
else by rw [div_def, mul_comm, degree_mul_leading_coeff_inv _ hq];
  exact degree_div_by_monic_le _ _

lemma degree_div_lt (hp : p ≠ 0) (hq : 0 < degree q) : degree (p / q) < degree p :=
have hq0 : q ≠ 0, from λ hq0, by simpa [hq0] using hq,
by rw [div_def, mul_comm, degree_mul_leading_coeff_inv _ hq0];
  exact degree_div_by_monic_lt _ (monic_mul_leading_coeff_inv hq0) hp
    (by rw degree_mul_leading_coeff_inv _ hq0; exact hq)

@[simp] lemma degree_map [field k] (p : polynomial R) (f : R →+* k) :
  degree (p.map f) = degree p :=
p.degree_map_eq_of_injective f.injective

@[simp] lemma nat_degree_map [field k] (f : R →+* k) :
  nat_degree (p.map f) = nat_degree p :=
nat_degree_eq_of_degree_eq (degree_map _ f)

@[simp] lemma leading_coeff_map [field k] (f : R →+* k) :
  leading_coeff (p.map f) = f (leading_coeff p) :=
by simp only [← coeff_nat_degree, coeff_map f, nat_degree_map]

theorem monic_map_iff [field k] {f : R →+* k} {p : polynomial R} :
  (p.map f).monic ↔ p.monic :=
by rw [monic, leading_coeff_map, ← f.map_one, function.injective.eq_iff f.injective, monic]

theorem is_unit_map [field k] (f : R →+* k) :
  is_unit (p.map f) ↔ is_unit p :=
by simp_rw [is_unit_iff_degree_eq_zero, degree_map]

lemma map_mod [field k] (f : R →+* k) :
  (p % q).map f = p.map f % q.map f :=
if hq0 : q = 0 then by simp [hq0]
else by rw [mod_def, mod_def, leading_coeff_map f, ← f.map_inv, ← map_C f,
  ← map_mul f, map_mod_by_monic f (monic_mul_leading_coeff_inv hq0)]

section
open euclidean_domain
local attribute [-instance] finsupp.finsupp.decidable_eq
theorem gcd_map [field k] (f : R →+* k) :
  gcd (p.map f) (q.map f) = (gcd p q).map f :=
gcd.induction p q (λ x, by simp_rw [map_zero, euclidean_domain.gcd_zero_left]) $ λ x y hx ih,
by rw [gcd_val, ← map_mod, ih, ← gcd_val]
end

lemma eval₂_gcd_eq_zero [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k}
  (hf : f.eval₂ ϕ α = 0) (hg : g.eval₂ ϕ α = 0) : (euclidean_domain.gcd f g).eval₂ ϕ α = 0 :=
by rw [euclidean_domain.gcd_eq_gcd_ab f g, polynomial.eval₂_add, polynomial.eval₂_mul,
       polynomial.eval₂_mul, hf, hg, zero_mul, zero_mul, zero_add]

lemma eval_gcd_eq_zero {f g : polynomial R} {α : R} (hf : f.eval α = 0) (hg : g.eval α = 0) :
  (euclidean_domain.gcd f g).eval α = 0 := eval₂_gcd_eq_zero hf hg

lemma root_left_of_root_gcd [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k}
  (hα : (euclidean_domain.gcd f g).eval₂ ϕ α = 0) : f.eval₂ ϕ α = 0 :=
by { cases euclidean_domain.gcd_dvd_left f g with p hp,
     rw [hp, polynomial.eval₂_mul, hα, zero_mul] }

lemma root_right_of_root_gcd [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k}
  (hα : (euclidean_domain.gcd f g).eval₂ ϕ α = 0) : g.eval₂ ϕ α = 0 :=
by { cases euclidean_domain.gcd_dvd_right f g with p hp,
     rw [hp, polynomial.eval₂_mul, hα, zero_mul] }

lemma root_gcd_iff_root_left_right [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k} :
  (euclidean_domain.gcd f g).eval₂ ϕ α = 0 ↔ (f.eval₂ ϕ α = 0) ∧ (g.eval₂ ϕ α = 0) :=
⟨λ h, ⟨root_left_of_root_gcd h, root_right_of_root_gcd h⟩, λ h, eval₂_gcd_eq_zero h.1 h.2⟩

lemma is_root_gcd_iff_is_root_left_right {f g : polynomial R} {α : R} :
  (euclidean_domain.gcd f g).is_root α ↔ f.is_root α ∧ g.is_root α :=
root_gcd_iff_root_left_right

theorem is_coprime_map [field k] (f : R →+* k) :
  is_coprime (p.map f) (q.map f) ↔ is_coprime p q :=
by rw [← gcd_is_unit_iff, ← gcd_is_unit_iff, gcd_map, is_unit_map]

@[simp] lemma map_eq_zero [semiring S] [nontrivial S] (f : R →+* S) :
  p.map f = 0 ↔ p = 0 :=
by simp only [polynomial.ext_iff, f.map_eq_zero, coeff_map, coeff_zero]

lemma map_ne_zero [semiring S] [nontrivial S] {f : R →+* S} (hp : p ≠ 0) : p.map f ≠ 0 :=
mt (map_eq_zero f).1 hp

lemma mem_roots_map [field k] {f : R →+* k} {x : k} (hp : p ≠ 0) :
  x ∈ (p.map f).roots ↔ p.eval₂ f x = 0 :=
begin
  rw mem_roots (show p.map f ≠ 0, by exact map_ne_zero hp),
  dsimp only [is_root],
  rw polynomial.eval_map,
end

lemma mem_root_set [field k] [algebra R k] {x : k} (hp : p ≠ 0) :
  x ∈ p.root_set k ↔ aeval x p = 0 :=
iff.trans multiset.mem_to_finset (mem_roots_map hp)

lemma exists_root_of_degree_eq_one (h : degree p = 1) : ∃ x, is_root p x :=
⟨-(p.coeff 0 / p.coeff 1),
  have p.coeff 1 ≠ 0,
    by rw ← nat_degree_eq_of_degree_eq_some h;
    exact mt leading_coeff_eq_zero.1 (λ h0, by simpa [h0] using h),
  by conv in p { rw [eq_X_add_C_of_degree_le_one (show degree p ≤ 1, by rw h; exact le_refl _)] };
    simp [is_root, mul_div_cancel' _ this]⟩

lemma coeff_inv_units (u : units (polynomial R)) (n : ℕ) :
  ((↑u : polynomial R).coeff n)⁻¹ = ((↑u⁻¹ : polynomial R).coeff n) :=
begin
  rw [eq_C_of_degree_eq_zero (degree_coe_units u), eq_C_of_degree_eq_zero (degree_coe_units u⁻¹),
    coeff_C, coeff_C, inv_eq_one_div],
  split_ifs,
  { rw [div_eq_iff_mul_eq (coeff_coe_units_zero_ne_zero u), coeff_zero_eq_eval_zero,
      coeff_zero_eq_eval_zero, ← eval_mul, ← units.coe_mul, inv_mul_self];
    simp },
  { simp }
end

lemma monic_normalize (hp0 : p ≠ 0) : monic (normalize p) :=
begin
  rw [ne.def, ← leading_coeff_eq_zero, ← ne.def, ← is_unit_iff_ne_zero] at hp0,
  rw [monic, leading_coeff_normalize, normalize_eq_one],
  apply hp0,
end

lemma coe_norm_unit_of_ne_zero (hp : p ≠ 0) : (norm_unit p : polynomial R) = C p.leading_coeff⁻¹ :=
by simp [hp]

lemma normalize_monic (h : monic p) : normalize p = p := by simp [h]

theorem map_dvd_map' [field k] (f : R →+* k) {x y : polynomial R} : x.map f ∣ y.map f ↔ x ∣ y :=
if H : x = 0 then by rw [H, map_zero, zero_dvd_iff, zero_dvd_iff, map_eq_zero]
else by rw [← normalize_dvd_iff, ← @normalize_dvd_iff (polynomial R),
    normalize_apply, normalize_apply,
    coe_norm_unit_of_ne_zero H, coe_norm_unit_of_ne_zero (mt (map_eq_zero f).1 H),
    leading_coeff_map, ← f.map_inv, ← map_C, ← map_mul,
    map_dvd_map _ f.injective (monic_mul_leading_coeff_inv H)]

lemma degree_normalize : degree (normalize p) = degree p := by simp

lemma prime_of_degree_eq_one (hp1 : degree p = 1) : prime p :=
have prime (normalize p),
  from prime_of_degree_eq_one_of_monic (hp1 ▸ degree_normalize)
    (monic_normalize (λ hp0, absurd hp1 (hp0.symm ▸ by simp; exact dec_trivial))),
prime_of_associated normalize_associated this

lemma irreducible_of_degree_eq_one (hp1 : degree p = 1) : irreducible p :=
irreducible_of_prime (prime_of_degree_eq_one hp1)

theorem not_irreducible_C (x : R) : ¬irreducible (C x) :=
if H : x = 0 then by { rw [H, C_0], exact not_irreducible_zero }
else λ hx, irreducible.not_unit hx $ is_unit_C.2 $ is_unit_iff_ne_zero.2 H

theorem degree_pos_of_irreducible (hp : irreducible p) : 0 < p.degree :=
lt_of_not_ge $ λ hp0, have _ := eq_C_of_degree_le_zero hp0,
  not_irreducible_C (p.coeff 0) $ this ▸ hp

theorem pairwise_coprime_X_sub {α : Type u} [field α] {I : Type v}
  {s : I → α} (H : function.injective s) :
  pairwise (is_coprime on (λ i : I, polynomial.X - polynomial.C (s i))) :=
λ i j hij, have h : s j - s i ≠ 0, from sub_ne_zero_of_ne $ function.injective.ne H hij.symm,
⟨polynomial.C (s j - s i)⁻¹, -polynomial.C (s j - s i)⁻¹,
by rw [neg_mul_eq_neg_mul_symm, ← sub_eq_add_neg, ← mul_sub, sub_sub_sub_cancel_left,
    ← polynomial.C_sub, ← polynomial.C_mul, inv_mul_cancel h, polynomial.C_1]⟩

/-- If `f` is a polynomial over a field, and `a : K` satisfies `f' a ≠ 0`,
then `f / (X - a)` is coprime with `X - a`.
Note that we do not assume `f a = 0`, because `f / (X - a) = (f - f a) / (X - a)`. -/
lemma is_coprime_of_is_root_of_eval_derivative_ne_zero {K : Type*} [field K]
  (f : polynomial K) (a : K) (hf' : f.derivative.eval a ≠ 0) :
  is_coprime (X - C a : polynomial K) (f /ₘ (X - C a)) :=
begin
  refine or.resolve_left (dvd_or_coprime (X - C a) (f /ₘ (X - C a))
    (irreducible_of_degree_eq_one (polynomial.degree_X_sub_C a))) _,
  contrapose! hf' with h,
  have key : (X - C a) * (f /ₘ (X - C a)) = f - (f %ₘ (X - C a)),
  { rw [eq_sub_iff_add_eq, ← eq_sub_iff_add_eq', mod_by_monic_eq_sub_mul_div],
    exact monic_X_sub_C a },
  replace key := congr_arg derivative key,
  simp only [derivative_X, derivative_mul, one_mul, sub_zero, derivative_sub,
    mod_by_monic_X_sub_C_eq_C_eval, derivative_C] at key,
  have : (X - C a) ∣ derivative f := key ▸ (dvd_add h (dvd_mul_right _ _)),
  rw [← dvd_iff_mod_by_monic_eq_zero (monic_X_sub_C _), mod_by_monic_X_sub_C_eq_C_eval] at this,
  rw [← C_inj, this, C_0],
end

lemma prod_multiset_root_eq_finset_root {p : polynomial R} (hzero : p ≠ 0) :
  (multiset.map (λ (a : R), X - C a) p.roots).prod =
  ∏ a in (multiset.to_finset p.roots), (λ (a : R), (X - C a) ^ (root_multiplicity a p)) a :=
by simp only [count_roots hzero, finset.prod_multiset_map_count]

/-- The product `∏ (X - a)` for `a` inside the multiset `p.roots` divides `p`. -/
lemma prod_multiset_X_sub_C_dvd (p : polynomial R) :
  (multiset.map (λ (a : R), X - C a) p.roots).prod ∣ p :=
begin
  by_cases hp0 : p = 0,
  { simp only [hp0, roots_zero, is_unit_one, multiset.prod_zero, multiset.map_zero, is_unit.dvd] },
  rw prod_multiset_root_eq_finset_root hp0,
  have hcoprime : pairwise (is_coprime on λ (a : R), polynomial.X - C (id a)) :=
    pairwise_coprime_X_sub function.injective_id,
  have H : pairwise (is_coprime on λ (a : R), (polynomial.X - C (id a)) ^ (root_multiplicity a p)),
  { intros a b hdiff, exact (hcoprime a b hdiff).pow },
  apply finset.prod_dvd_of_coprime (pairwise.pairwise_on H (↑(multiset.to_finset p.roots) : set R)),
  intros a h,
  rw multiset.mem_to_finset at h,
  exact pow_root_multiplicity_dvd p a
end

lemma roots_C_mul (p : polynomial R) {a : R} (hzero : a ≠ 0) : (C a * p).roots = p.roots :=
begin
  by_cases hpzero : p = 0,
  { simp only [hpzero, mul_zero] },
  rw multiset.ext,
  intro b,
  have prodzero : C a * p ≠ 0,
  { simp only [hpzero, or_false, ne.def, mul_eq_zero, C_eq_zero, hzero, not_false_iff] },
  rw [count_roots hpzero, count_roots prodzero, root_multiplicity_mul prodzero],
  have mulzero : root_multiplicity b (C a) = 0,
  { simp only [hzero, root_multiplicity_eq_zero, eval_C, is_root.def, not_false_iff] },
  simp only [mulzero, zero_add]
end

lemma roots_normalize : (normalize p).roots = p.roots :=
begin
  by_cases hzero : p = 0,
  { rw [hzero, normalize_zero], },
  { have hcoeff : p.leading_coeff ≠ 0,
    { intro h, exact hzero (leading_coeff_eq_zero.1 h) },
    rw [normalize_apply, mul_comm, coe_norm_unit_of_ne_zero hzero,
      roots_C_mul _ (inv_ne_zero hcoeff)], },
end

end field
end polynomial


open expr tactic classical

variables {p q r s : Prop}
variables {a b c d e : Prop}

section

local attribute [instance] classical.prop_decidable

  theorem not_or_of_imp (h : a → b) : ¬ a ∨ b := sorry

  theorem imp_iff_not_or : (a → b) ↔ (¬ a ∨ b) := sorry

  theorem iff_def : (a ↔ b) ↔ (a → b) ∧ (b → a) := sorry

  theorem not_not : ¬¬a ↔ a := sorry

  theorem not_or_distrib : ¬ (a ∨ b) ↔ ¬ a ∧ ¬ b := sorry

  theorem not_and_of_not_or_not (h : ¬ a ∨ ¬ b) : ¬ (a ∧ b) := sorry

  theorem not_and_distrib : ¬ (a ∧ b) ↔ ¬a ∨ ¬b := sorry

end

meta def normalize : tactic unit :=
`[ try { simp only
   [ not_or_distrib,
     not_and_distrib,
     not_not,
     imp_iff_not_or,
     not_true_iff,
     not_false_iff,
     iff_def ] at *} ]

/- Given a list of expr of hypotheses, find an expr of a
   conjunctive hypothesis in the list and return it. -/
meta def find_conj : list expr → tactic expr := sorry

/- Given a list of expr of hypotheses, find an expr of a
   disjunctive hypothesis in the list and return it. -/
meta def find_disj : list expr → tactic expr := sorry

/- Find and split a conjunction. -/
meta def split_conj : tactic unit := sorry

/- Split all conjunctions using split_conj. -/
meta def split_conjs : tactic unit := sorry

/- Find and split a disjunction. -/
meta def split_disj : tactic unit := sorry

/- Given a goal of the form Γ ⊢ φ, reduce it to the goal Γ, ¬φ ⊢ ⊥ -/
meta def go_by_contradiction : tactic unit := sorry

/- The main proof search loop. First, split all conjunctions.
   If the result has complementary literals, discharge the goal.
   If not, find a disjunction, split it, and discharge the new
   subgoals by entering the proof search loop again. -/
meta def tab_aux : tactic unit := sorry

/- Normalize goal and enter proof search loop. -/
meta def tab : tactic unit := sorry

#exit

example : a ∧ b → b ∧ a := by tab
example : a ∧ (a → b) → b := by tab

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p := by tab
example : p ∨ q ↔ q ∨ p := by tab

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) := by tab
example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) := by tab

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := by tab
example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) := by tab

-- other properties
example : (p → (q → r)) ↔ (p ∧ q → r) := by tab
example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) := by tab
example : ¬(p ∨ q) ↔ ¬p ∧ ¬q := by tab
example : ¬p ∨ ¬q → ¬(p ∧ q) := by tab
example : ¬(p ∧ ¬p) := by tab
example : p ∧ ¬q → ¬(p → q) := by tab
example : ¬p → (p → q) := by tab
example : (¬p ∨ q) → (p → q) := by tab
example : p ∨ false ↔ p := by tab
example : p ∧ false ↔ false := by tab
example : ¬(p ↔ ¬p) := by tab
example : (p → q) → (¬q → ¬p) := by tab

example : (p → r ∨ s) → ((p → r) ∨ (p → s)) := by tab
example : ¬(p ∧ q) → ¬p ∨ ¬q := by tab
example : ¬(p → q) → p ∧ ¬q := by tab
example : (p → q) → (¬p ∨ q) := by tab
example : (¬q → ¬p) → (p → q) := by tab
example : p ∨ ¬p := by tab
example : (((p → q) → p) → p) := by tab

example (h₁ : a ∧ b) (h₂ : b ∧ ¬ c) : a ∨ c :=
by tab

example (h₁ : a ∧ b) (h₂ : b ∧ ¬ c) : a ∧ ¬ c :=
by tab

example : ((a → b) → a) → a :=
by tab

example : (a → b) ∧ (b → c) → a → c :=
by tab

example (α : Type) (x y z w : α) :
  x = y ∧ (x = y → z = w) → z = w :=
by tab

example : ¬ (a ↔ ¬ a) :=
by tab


/- ------------------------------------------------------------------------- -|
| @project: riemann_hypothesis                                                |
| @file:    dirichlet_eta.lean                                                |
| @authors: Brandon H. Gomes, Alex Kontorovich                                |
| @affil:   Rutgers University                                                |
|- ------------------------------------------------------------------------- -/

import .complex
import .riemann_zeta

/-!
-/

namespace riemann_hypothesis --——————————————————————————————————————————————————————————--
variables {ℂ : Type*} {ℝ : Type*}
          [has_lift_t nat ℝ] [has_lift_t ℝ ℂ] [preorder ℝ] [Algebra ℝ] [Algebra ℂ]
          (ℭ : Complex ℂ ℝ)

namespace dirichlet_eta --———————————————————————————————————————————————————————————————--

open algebra

/--
-/
def term_pair
    [has_lift_zero_same nat ℝ]
    [has_lift_lt_comm nat ℝ]
    (s n)
    := riemann_zeta.term ℭ.pow s (2 * n) - riemann_zeta.term ℭ.pow s (2 * n).succ

namespace term_pair --———————————————————————————————————————————————————————————————————--

/--
-/
def riemann_zeta_bound (s)
    := ↑4 * ℭ.real_exp (ℭ.abs s) + ↑3 * ℭ.abs s

namespace riemann_zeta_bound --——————————————————————————————————————————————————————————--
variables [has_zero_mul_is_zero ℝ] [has_nonneg_mul_nonneg_is_nonneg ℝ]
          [has_lt_add_of_le_of_pos ℝ] [has_lt_pos_mul_preserves_right ℝ]
          [has_lift_zero_same nat ℝ] [has_lift_one_same nat ℝ]
          [has_lift_add_comm nat ℝ] [has_lift_lt_comm nat ℝ]

/--
-/
def positive (s)
    : 0 < riemann_zeta_bound ℭ s :=
    begin
        refine has_lt_add_of_le_of_pos.lt _
            (has_nonneg_mul_nonneg_is_nonneg.le
                (le_of_lt (nat.lift.succ_pos ℝ _)) (ℭ.abs_nonneg _)),

        let four_exponentials_are_positive
            := has_lt_pos_mul_preserves_right.lt
                (ℭ.real_explog.exp_positive _) (nat.lift.succ_pos ℝ _),

        rw has_zero_mul_is_zero.eq at four_exponentials_are_positive,

        refine four_exponentials_are_positive,
    end

/--
-/
def abs_positive
    (ge_zero_to_abs : Π z, 0 ≤ z → ℭ.abs ↑z = z)
    (s)
    : 0 < ℭ.abs ↑(riemann_zeta_bound ℭ s) :=
    begin
        rw ge_zero_to_abs _ (le_of_lt (positive ℭ _)),
        refine positive ℭ _,
    end

end riemann_zeta_bound --————————————————————————————————————————————————————————————————--

/--
-/
def bounded_by_riemann_zeta
    [has_add_le_add ℝ]
    [has_inv_mul_reverse ℝ]
    [has_inv_mul_right_cancel_self ℝ]
    [has_inv_reverses_le ℝ]
    [has_le_nonneg_mul_preserves_left ℝ]
    [has_le_nonneg_mul_preserves_right ℝ]
    [has_le_pos_mul_preserves_left ℝ]
    [has_le_pos_mul_preserves_right ℝ]
    [has_left_add_distributivity ℝ]
    [has_left_sub_distributivity ℝ]
    [has_left_unit ℝ]
    [has_lt_add_of_le_of_pos ℝ]
    [has_lt_pos_mul_preserves_right ℝ]
    [has_mul_assoc ℝ]
    [has_nonneg_mul_nonneg_is_nonneg ℝ]
    [has_right_add_distributivity ℝ]
    [has_right_inv_pos_lt ℝ]
    [has_right_sub_distributivity ℝ]
    [has_right_unit ℝ]
    [has_squared_le_monotonic ℝ]
    [has_zero_mul_is_zero ℝ]
    [has_mul_zero_is_zero ℝ]
    [has_zero_right_add_cancel ℝ]
    [has_zero_sub_is_neg ℝ]
    [has_mul_pos ℝ]
    [has_inv_pos ℝ]

    [has_lift_add_comm nat ℝ]
    [has_lift_le_comm nat ℝ]
    [has_lift_lt_comm nat ℝ]
    [has_lift_ne_comm nat ℝ]
    [has_lift_sub_comm nat ℝ]
    [has_lift_one_same nat ℝ]
    [has_lift_zero_same nat ℝ]

    [has_add_sub_assoc ℂ]
    [has_inv_mul_left_cancel_self ℂ]
    [has_left_sub_distributivity ℂ]
    [has_left_unit ℂ]
    [has_mul_assoc ℂ]
    [has_right_sub_distributivity ℂ]
    [has_right_unit ℂ]
    [has_sub_add_sub_cancel ℂ]
    [has_sub_self_is_zero ℂ]
    [has_mul_zero_is_zero ℂ]
    [has_zero_right_add_cancel ℂ]
    [has_zero_sub_is_neg ℂ]

    [has_lift_sub_comm ℝ ℂ]

    (abs_mul        : Π a b, ℭ.abs (a * b) = ℭ.abs (a) * ℭ.abs (b))
    (abs_sub        : Π a b, ℭ.abs (a - b) = ℭ.abs (b - a))
    (abs_inv        : Π z, ℭ.abs (z⁻¹) = (ℭ.abs z)⁻¹)
    (abs_add        : Π a b, ℭ.abs (a + b) ≤ ℭ.abs a + ℭ.abs b)
    (ge_zero_to_abs : Π x, 0 ≤ x → ℭ.abs ↑x = x)

    (s n)

    : ℭ.abs (term_pair ℭ s n)
        ≤ riemann_zeta.term.on_reals ℭ.real_explog (1 + ℭ.real_part s) (2 * n)
        * riemann_zeta_bound ℭ s :=

    begin
        rw [term_pair, riemann_zeta.term.on_reals],
        rw [riemann_zeta.term, riemann_zeta.term, riemann_zeta.term],
        rw [← has_zero_sub_is_neg.eq, ← has_zero_sub_is_neg.eq],
        rw ExpLog.pow_neg_exponent_inverts,
        rw ExpLog.pow_homomorphism,
        rw has_inv_mul_reverse.eq,
        rw ℭ.real_explog.pow_id_at_one _ (nat.lift.succ_pos ℝ _),
        rw Complex.pow_neg_exponent_inverts,
        rw Complex.pow_neg_exponent_inverts,
        rw inv_sub_inv_lemma' (ℭ.pow_nonzero _ _ _),
        rw abs_mul,
        rw abs_inv,
        rw Complex.abs_pow_is_real_pow,
        rw has_mul_assoc.eq,
        rw ← ExpLog.pow_neg_exponent_inverts,

        let K := (↑(2 * n).succ.succ : ℝ),

        have Kinv_ge_zero : K⁻¹ ≥ 0,
        {
            let ineq
                := has_right_inv_pos_lt.lt
                    (nat.lift.succ_pos ℝ _) (nat.lift.zero_lt_one ℝ),

            rw [has_zero_mul_is_zero.eq, has_left_unit.eq] at ineq,

            refine le_of_lt ineq,
        },

        let remove_abs
            := ge_zero_to_abs _ Kinv_ge_zero,

        refine has_le_pos_mul_preserves_left.le
            (ℭ.real_explog.pow_positivity _ (nat.lift.succ_pos ℝ _) _) _,

        rw [Complex.pow, Complex.pow],
        rw ← Complex.exp_homomorphism_inv,
        rw ← has_right_sub_distributivity.eq,
        rw ← has_lift_sub_comm.eq,

        rw ← ℭ.real_explog.log_homomorphism_inv
            (nat.lift.succ_pos ℝ _) (nat.lift.succ_pos ℝ _),

        rw ← Complex.pow,

        rw ℭ.pow_domain_irrel
            (↑((2 * n).succ) * (↑((2 * n).succ.succ))⁻¹) _
            (1 - (↑(2 * n).succ.succ)⁻¹) _
            _ (by rw mul_inv_add_one_lemma),

        refine le_trans _
            (has_le_pos_mul_preserves_right.le (riemann_zeta_bound.positive _ _)
            (has_inv_reverses_le.le (le_of_lt (has_lift_lt_comm.lt
                (nat.lt_succ_self _))))),

        rw ← mul_inv_add_one_lemma,

        refine has_mul_pos.lt
            (nat.lift.succ_pos ℝ _)
            (has_inv_pos.lt (nat.lift.succ_pos ℝ _)),

        rw abs_sub,
        rw riemann_zeta_bound,
        rw has_left_add_distributivity.eq,

        refine le_trans (Complex.one_minus_pow_bound _ _ _ abs_mul abs_add _ _ _ _) _,

        rw two_is_lifted_two_lemma nat ℝ,

        refine nat.lift.succ_pos ℝ _,

        rw two_is_lifted_two_lemma nat ℝ,
        rw one_is_lifted_one_lemma nat ℝ,

        refine has_lift_le_comm.le (le_of_lt (nat.lt_succ_self _)),

        rw remove_abs,
        rw two_is_lifted_two_lemma nat ℝ,

        refine has_inv_reverses_le.le
            (has_lift_le_comm.le (nat.smallest_positive_even _)),

        rw remove_abs,
        rw ← has_left_add_distributivity.eq,

        rw four_is_lifted_four_lemma nat ℝ,
        rw ← two_mul_lemma,

        refine has_le_nonneg_mul_preserves_left.le
            Kinv_ge_zero
            (has_add_le_add.le
                (le_refl _) (has_le_nonneg_mul_preserves_right.le (ℭ.abs_nonneg _) _)),

        rw two_is_lifted_two_lemma nat ℝ,

        refine has_lift_le_comm.le (le_of_lt (nat.lt_succ_self _)),
    end

end term_pair --—————————————————————————————————————————————————————————————————————————--

/--
-/
def partial_pairs
    [has_lift_lt_comm nat ℝ]
    [has_lift_zero_same nat ℝ]
    (s)
    := partial_sum (term_pair ℭ s)

/--
-/
def partial_pairs.is_cauchy
    [has_add_le_add ℝ]
    [has_add_left_lt ℝ]
    [has_add_lt_add ℝ]
    [has_add_nonneg ℝ]
    [has_add_sub_assoc ℝ]
    [has_add_sub_exchange ℝ]
    [has_inv_mul_left_cancel_self ℝ]
    [has_inv_mul_reverse ℝ]
    [has_inv_mul_right_cancel_self ℝ]
    [has_inv_reverses_le ℝ]
    [has_inv_reverses_lt ℝ]
    [has_inv_right_mul_lt_pos ℝ]
    [has_le_add_of_nonneg_of_le ℝ]
    [has_le_nonneg_mul_preserves_left ℝ]
    [has_le_nonneg_mul_preserves_right ℝ]
    [has_le_pos_mul_preserves_left ℝ]
    [has_le_pos_mul_preserves_right ℝ]
    [has_le_sub_add_le ℝ]
    [has_left_add_distributivity ℝ]
    [has_left_mul_inv_lt_neg ℝ]
    [has_left_mul_inv_lt_pos ℝ]
    [has_left_sub_distributivity ℝ]
    [has_left_unit ℝ]
    [has_lt_add_of_le_of_pos ℝ]
    [has_lt_pos_mul_preserves_right ℝ]
    [has_lt_sub_neg ℝ]
    [has_mul_assoc ℝ]
    [has_nonneg_mul_nonneg_is_nonneg ℝ]
    [has_pos_mul_neg_is_neg ℝ]
    [has_right_add_distributivity ℝ]
    [has_right_inv_pos_lt ℝ]
    [has_right_sub_distributivity ℝ]
    [has_right_unit ℝ]
    [has_squared_le_monotonic ℝ]
    [has_sub_add_sub_cancel ℝ]
    [has_sub_self_is_zero ℝ]
    [has_sub_ne_zero_of_ne ℝ]
    [has_sub_sub ℝ]
    [has_zero_mul_is_zero ℝ]
    [has_mul_zero_is_zero ℝ]
    [has_zero_left_add_cancel ℝ]
    [has_zero_right_add_cancel ℝ]
    [has_zero_sub_is_neg ℝ]
    [has_mul_pos ℝ]
    [has_inv_pos ℝ]
    [has_sub_pos ℝ]

    [has_lift_zero_same nat ℝ]
    [has_lift_one_same nat ℝ]
    [has_lift_add_comm nat ℝ]
    [has_lift_mul_comm nat ℝ]
    [has_lift_sub_comm nat ℝ]
    [has_lift_le_comm nat ℝ]
    [has_lift_lt_comm nat ℝ]
    [has_lift_ne_comm nat ℝ]

    [has_add_sub_assoc ℂ]
    [has_inv_mul_left_cancel_self ℂ]
    [has_left_sub_distributivity ℂ]
    [has_left_unit ℂ]
    [has_mul_assoc ℂ]
    [has_right_sub_distributivity ℂ]
    [has_right_unit ℂ]
    [has_sub_add_sub_cancel ℂ]
    [has_sub_self_is_zero ℂ]
    [has_mul_zero_is_zero ℂ]
    [has_zero_right_add_cancel ℂ]
    [has_zero_sub_is_neg ℂ]

    [has_lift_zero_same ℝ ℂ]
    [has_lift_one_same ℝ ℂ]
    [has_lift_add_comm ℝ ℂ]
    [has_lift_sub_comm ℝ ℂ]
    [has_lift_mul_comm ℝ ℂ]
    [has_lift_inv_comm ℝ ℂ]

    (abs_zero abs_one)
    (abs_add : Π w z, ℭ.abs (w + z) ≤ ℭ.abs w + ℭ.abs z)
    (abs_sub : Π w z, ℭ.abs (w - z) = ℭ.abs (z - w))
    (abs_mul : Π w z, ℭ.abs (w * z) = ℭ.abs w * ℭ.abs z)
    (abs_inv : Π z, ℭ.abs (z⁻¹) = (ℭ.abs z)⁻¹)
    (abs_ge_zero)

    (pos_to_absℝ abs_monoℝ)

    (half ceil)

    (s) (σpos : 0 < ℭ.real_part s)

    : is_cauchy ℭ.abs (partial_pairs ℭ s) :=

    begin
        let one_plus_σ_gt_one := has_add_left_lt.lt _ _ 1 σpos,

        rw has_zero_right_add_cancel.eq at one_plus_σ_gt_one,

        have abs_zeroℝ : ℭ.abs ↑(0 : ℝ) = 0,
            rw has_lift_zero_same.eq,
            refine abs_zero,

        have abs_oneℝ : ℭ.abs ↑(1 : ℝ) = 1,
            rw has_lift_one_same.eq,
            refine abs_one,

        have abs_addℝ : Π x y : ℝ, ℭ.abs ↑(x + y) ≤ ℭ.abs ↑x + ℭ.abs ↑y,
            intros,
            rw has_lift_add_comm.eq,
            refine abs_add _ _,

        have abs_subℝ : Π x y : ℝ, ℭ.abs ↑(x - y) = ℭ.abs ↑(y - x),
            intros,
            rw [has_lift_sub_comm.eq, has_lift_sub_comm.eq],
            refine abs_sub _ _,

        have abs_mulℝ : Π x y : ℝ, ℭ.abs ↑(x * y) = ℭ.abs ↑x * ℭ.abs ↑y,
            intros,
            rw has_lift_mul_comm.eq,
            refine abs_mul _ _,

        have abs_invℝ : Π x : ℝ, ℭ.abs ↑(x⁻¹) = (ℭ.abs ↑x)⁻¹,
            intros,
            rw has_lift_inv_comm.eq,
            refine abs_inv _,

        refine is_cauchy.comparison _ pos_to_absℝ _ abs_zero abs_add abs_ge_zero _ _
            (term_pair.bounded_by_riemann_zeta _
                abs_mul abs_sub abs_inv abs_add pos_to_absℝ _)
            (is_cauchy.closed.partial_sum_right_mul _ abs_mulℝ _ _
                (term_pair.riemann_zeta_bound.abs_positive _ pos_to_absℝ _)
                (is_cauchy.closed.scaled_sequence_partial_sum _ abs_monoℝ _
                    (riemann_zeta.term.on_reals.nonneg _ _) _ (nat.zero_lt_one_add _)
                    (riemann_zeta.partial.on_reals.is_cauchy _ _
                        abs_zeroℝ abs_oneℝ abs_addℝ abs_subℝ abs_mulℝ abs_invℝ
                        (λ _, abs_ge_zero _) pos_to_absℝ
                        half ceil _
                        one_plus_σ_gt_one))),
    end

end dirichlet_eta --—————————————————————————————————————————————————————————————————————--
end riemann_hypothesis --————————————————————————————————————————————————————————————————--


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Mon.basic
import category_theory.limits.has_limits
import category_theory.concrete_category.elementwise

/-!
# The category of monoids has all colimits.

We do this construction knowing nothing about monoids.
In particular, I want to claim that this file could be produced by a python script
that just looks at the output of `#print monoid`:

  -- structure monoid : Type u → Type u
  -- fields:
  -- monoid.mul : Π {α : Type u} [c : monoid α], α → α → α
  -- monoid.mul_assoc : ∀ {α : Type u} [c : monoid α] (a b c_1 : α), a * b * c_1 = a * (b * c_1)
  -- monoid.one : Π (α : Type u) [c : monoid α], α
  -- monoid.one_mul : ∀ {α : Type u} [c : monoid α] (a : α), 1 * a = a
  -- monoid.mul_one : ∀ {α : Type u} [c : monoid α] (a : α), a * 1 = a

and if we'd fed it the output of `#print comm_ring`, this file would instead build
colimits of commutative rings.

A slightly bolder claim is that we could do this with tactics, as well.
-/

universes v

open category_theory
open category_theory.limits

namespace Mon.colimits
/-!
We build the colimit of a diagram in `Mon` by constructing the
free monoid on the disjoint union of all the monoids in the diagram,
then taking the quotient by the monoid laws within each monoid,
and the identifications given by the morphisms in the diagram.
-/

variables {J : Type v} [small_category J] (F : J ⥤ Mon.{v})

/--
An inductive type representing all monoid expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
inductive prequotient
-- There's always `of`
| of : Π (j : J) (x : F.obj j), prequotient
-- Then one generator for each operation
| one : prequotient
| mul : prequotient → prequotient → prequotient

instance : inhabited (prequotient F) := ⟨prequotient.one⟩

open prequotient

/--
The relation on `prequotient` saying when two expressions are equal
because of the monoid laws, or
because one element is mapped to another by a morphism in the diagram.
-/
inductive relation : prequotient F → prequotient F → Prop
-- Make it an equivalence relation:
| refl : Π (x), relation x x
| symm : Π (x y) (h : relation x y), relation y x
| trans : Π (x y z) (h : relation x y) (k : relation y z), relation x z
-- There's always a `map` relation
| map : Π (j j' : J) (f : j ⟶ j') (x : F.obj j), relation (of j' ((F.map f) x)) (of j x)
-- Then one relation per operation, describing the interaction with `of`
| mul : Π (j) (x y : F.obj j), relation (of j (x * y)) (mul (of j x) (of j y))
| one : Π (j), relation (of j 1) one
-- Then one relation per argument of each operation
| mul_1 : Π (x x' y) (r : relation x x'), relation (mul x y) (mul x' y)
| mul_2 : Π (x y y') (r : relation y y'), relation (mul x y) (mul x y')
-- And one relation per axiom
| mul_assoc : Π (x y z), relation (mul (mul x y) z) (mul x (mul y z))
| one_mul : Π (x), relation (mul one x) x
| mul_one : Π (x), relation (mul x one) x

/--
The setoid corresponding to monoid expressions modulo monoid relations and identifications.
-/
def colimit_setoid : setoid (prequotient F) :=
{ r := relation F, iseqv := ⟨relation.refl, relation.symm, relation.trans⟩ }
attribute [instance] colimit_setoid

/--
The underlying type of the colimit of a diagram in `Mon`.
-/
@[derive inhabited]
def colimit_type : Type v := quotient (colimit_setoid F)

instance monoid_colimit_type : monoid (colimit_type F) :=
{ mul :=
  begin
    fapply @quot.lift _ _ ((colimit_type F) → (colimit_type F)),
    { intro x,
      fapply @quot.lift,
      { intro y,
        exact quot.mk _ (mul x y) },
      { intros y y' r,
        apply quot.sound,
        exact relation.mul_2 _ _ _ r } },
    { intros x x' r,
      funext y,
      induction y,
      dsimp,
      apply quot.sound,
      { exact relation.mul_1 _ _ _ r },
      { refl } },
  end,
  one :=
  begin
    exact quot.mk _ one
  end,
  mul_assoc := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.mul_assoc,
    refl,
    refl,
    refl,
  end,
  one_mul := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.one_mul,
    refl,
  end,
  mul_one := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.mul_one,
    refl,
  end }

@[simp] lemma quot_one : quot.mk setoid.r one = (1 : colimit_type F) := rfl
@[simp] lemma quot_mul (x y) : quot.mk setoid.r (mul x y) =
  ((quot.mk setoid.r x) * (quot.mk setoid.r y) : colimit_type F) := rfl

/-- The bundled monoid giving the colimit of a diagram. -/
def colimit : Mon := ⟨colimit_type F, by apply_instance⟩

/-- The function from a given monoid in the diagram to the colimit monoid. -/
def cocone_fun (j : J) (x : F.obj j) : colimit_type F :=
quot.mk _ (of j x)

/-- The monoid homomorphism from a given monoid in the diagram to the colimit monoid. -/
def cocone_morphism (j : J) : F.obj j ⟶ colimit F :=
{ to_fun := cocone_fun F j,
  map_one' := quot.sound (relation.one _),
  map_mul' := λ x y, quot.sound (relation.mul _ _ _) }

@[simp] lemma cocone_naturality {j j' : J} (f : j ⟶ j') :
  F.map f ≫ (cocone_morphism F j') = cocone_morphism F j :=
begin
  ext,
  apply quot.sound,
  apply relation.map,
end

@[simp] lemma cocone_naturality_components (j j' : J) (f : j ⟶ j') (x : F.obj j):
  (cocone_morphism F j') (F.map f x) = (cocone_morphism F j) x :=
by { rw ←cocone_naturality F f, refl }

/-- The cocone over the proposed colimit monoid. -/
def colimit_cocone : cocone F :=
{ X := colimit F,
  ι :=
  { app := cocone_morphism F, } }.

/-- The function from the free monoid on the diagram to the cone point of any other cocone. -/
@[simp] def desc_fun_lift (s : cocone F) : prequotient F → s.X
| (of j x)  := (s.ι.app j) x
| one       := 1
| (mul x y) := desc_fun_lift x * desc_fun_lift y

/-- The function from the colimit monoid to the cone point of any other cocone. -/
def desc_fun (s : cocone F) : colimit_type F → s.X :=
begin
  fapply quot.lift,
  { exact desc_fun_lift F s },
  { intros x y r,
    induction r; try { dsimp },
    -- refl
    { refl },
    -- symm
    { exact r_ih.symm },
    -- trans
    { exact eq.trans r_ih_h r_ih_k },
    -- map
    { simp, },
    -- mul
    { simp, },
    -- one
    { simp, },
    -- mul_1
    { rw r_ih, },
    -- mul_2
    { rw r_ih, },
    -- mul_assoc
    { rw mul_assoc, },
    -- one_mul
    { rw one_mul, },
    -- mul_one
    { rw mul_one, } }
end

/-- The monoid homomorphism from the colimit monoid to the cone point of any other cocone. -/
def desc_morphism (s : cocone F) : colimit F ⟶ s.X :=
{ to_fun := desc_fun F s,
  map_one' := rfl,
  map_mul' := λ x y, by { induction x; induction y; refl }, }

/-- Evidence that the proposed colimit is the colimit. -/
def colimit_is_colimit : is_colimit (colimit_cocone F) :=
{ desc := λ s, desc_morphism F s,
  uniq' := λ s m w,
  begin
    ext,
    induction x,
    induction x,
    { have w' := congr_fun (congr_arg (λ f : F.obj x_j ⟶ s.X, (f : F.obj x_j → s.X)) (w x_j)) x_x,
      erw w',
      refl, },
    { simp *, },
    { simp *, },
    refl
  end }.

instance has_colimits_Mon : has_colimits Mon :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone := colimit_cocone F,
      is_colimit := colimit_is_colimit F } } }

end Mon.colimits


import .aff_coord_space .affine .list_stuff data.real.basic

namespace aff_basis
universes u v w x

variables (X : Type u) (K : Type v) (V : Type w) (n : ℕ) (k : K)
[inhabited K] [field K] [add_comm_group V] [vector_space K V] [affine_space X K V]

abbreviation zero := list.field_zero K n

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

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

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

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

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

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

noncomputable def r3_std_frame := std_frame ℝ 3

def std_origin : pt_with_frame (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) (fin n) (std_frame K n) := ⟨pt_zero K n⟩
--TODO: fix this

-- nothing in the phys layer should be called "aff_pt_coord_tuple K n" or "aff_vec_coord_tuple K n"
end aff_basis