/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Coinductive formalization of unbounded computations.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.stream
import Mathlib.tactic.basic
import Mathlib.PostPort

universes u u_1 v w

namespace Mathlib

/-
coinductive computation (α : Type u) : Type u
| return : α → computation α
| think : computation α → computation α
-/

/-- `computation α` is the type of unbounded computations returning `α`.
  An element of `computation α` is an infinite sequence of `option α` such
  that if `f n = some a` for some `n` then it is constantly `some a` after that. -/
def computation (α : Type u) :=
  Subtype fun (f : stream (Option α)) => ∀ {n : ℕ} {a : α}, f n = some a → f (n + 1) = some a

namespace computation

-- constructors

/-- `return a` is the computation that immediately terminates with result `a`. -/
def return {α : Type u} (a : α) : computation α :=
  { val := stream.const (some a), property := sorry }

protected instance has_coe_t {α : Type u} : has_coe_t α (computation α) :=
  has_coe_t.mk return

/-- `think c` is the computation that delays for one "tick" and then performs
  computation `c`. -/
def think {α : Type u} (c : computation α) : computation α :=
  { val := none :: subtype.val c, property := sorry }

/-- `thinkN c n` is the computation that delays for `n` ticks and then performs
  computation `c`. -/
def thinkN {α : Type u} (c : computation α) : ℕ → computation α :=
  sorry

-- check for immediate result

/-- `head c` is the first step of computation, either `some a` if `c = return a`
  or `none` if `c = think c'`. -/
def head {α : Type u} (c : computation α) : Option α :=
  stream.head (subtype.val c)

-- one step of computation

/-- `tail c` is the remainder of computation, either `c` if `c = return a`
  or `c'` if `c = think c'`. -/
def tail {α : Type u} (c : computation α) : computation α :=
  { val := stream.tail (subtype.val c), property := sorry }

/-- `empty α` is the computation that never returns, an infinite sequence of
  `think`s. -/
def empty (α : Type u_1) : computation α :=
  { val := stream.const none, property := sorry }

protected instance inhabited {α : Type u} : Inhabited (computation α) :=
  { default := empty α }

/-- `run_for c n` evaluates `c` for `n` steps and returns the result, or `none`
  if it did not terminate after `n` steps. -/
def run_for {α : Type u} : computation α → ℕ → Option α :=
  subtype.val

/-- `destruct c` is the destructor for `computation α` as a coinductive type.
  It returns `inl a` if `c = return a` and `inr c'` if `c = think c'`. -/
def destruct {α : Type u} (c : computation α) : α ⊕ computation α :=
  sorry

/-- `run c` is an unsound meta function that runs `c` to completion, possibly
  resulting in an infinite loop in the VM. -/
theorem destruct_eq_ret {α : Type u} {s : computation α} {a : α} : destruct s = sum.inl a → s = return a := sorry

theorem destruct_eq_think {α : Type u} {s : computation α} {s' : computation α} : destruct s = sum.inr s' → s = think s' := sorry

@[simp] theorem destruct_ret {α : Type u} (a : α) : destruct (return a) = sum.inl a :=
  rfl

@[simp] theorem destruct_think {α : Type u} (s : computation α) : destruct (think s) = sum.inr s := sorry

@[simp] theorem destruct_empty {α : Type u} : destruct (empty α) = sum.inr (empty α) :=
  rfl

@[simp] theorem head_ret {α : Type u} (a : α) : head (return a) = some a :=
  rfl

@[simp] theorem head_think {α : Type u} (s : computation α) : head (think s) = none :=
  rfl

@[simp] theorem head_empty {α : Type u} : head (empty α) = none :=
  rfl

@[simp] theorem tail_ret {α : Type u} (a : α) : tail (return a) = return a :=
  rfl

@[simp] theorem tail_think {α : Type u} (s : computation α) : tail (think s) = s := sorry

@[simp] theorem tail_empty {α : Type u} : tail (empty α) = empty α :=
  rfl

theorem think_empty {α : Type u} : empty α = think (empty α) :=
  destruct_eq_think destruct_empty

def cases_on {α : Type u} {C : computation α → Sort v} (s : computation α) (h1 : (a : α) → C (return a)) (h2 : (s : computation α) → C (think s)) : C s :=
  (fun (_x : α ⊕ computation α) (H : destruct s = _x) =>
      sum.rec (fun (v : α) (H : destruct s = sum.inl v) => eq.mpr sorry (h1 v))
        (fun (v : computation α) (H : destruct s = sum.inr v) =>
          subtype.cases_on v
            (fun (a : stream (Option α)) (s' : ∀ {n : ℕ} {a_1 : α}, a n = some a_1 → a (n + 1) = some a_1)
              (H : destruct s = sum.inr { val := a, property := s' }) => eq.mpr sorry (h2 { val := a, property := s' }))
            H)
        _x H)
    (destruct s) sorry

def corec.F {α : Type u} {β : Type v} (f : β → α ⊕ β) : α ⊕ β → Option α × (α ⊕ β) :=
  sorry

/-- `corec f b` is the corecursor for `computation α` as a coinductive type.
  If `f b = inl a` then `corec f b = return a`, and if `f b = inl b'` then
  `corec f b = think (corec f b')`. -/
def corec {α : Type u} {β : Type v} (f : β → α ⊕ β) (b : β) : computation α :=
  { val := stream.corec' sorry (sum.inr b), property := sorry }

/-- left map of `⊕` -/
@[simp] def lmap {α : Type u} {β : Type v} {γ : Type w} (f : α → β) : α ⊕ γ → β ⊕ γ :=
  sorry

/-- right map of `⊕` -/
@[simp] def rmap {α : Type u} {β : Type v} {γ : Type w} (f : β → γ) : α ⊕ β → α ⊕ γ :=
  sorry

@[simp] theorem corec_eq {α : Type u} {β : Type v} (f : β → α ⊕ β) (b : β) : destruct (corec f b) = rmap (corec f) (f b) := sorry

@[simp] def bisim_o {α : Type u} (R : computation α → computation α → Prop) : α ⊕ computation α → α ⊕ computation α → Prop :=
  sorry

def is_bisimulation {α : Type u} (R : computation α → computation α → Prop) :=
  ∀ {s₁ s₂ : computation α}, R s₁ s₂ → bisim_o R (destruct s₁) (destruct s₂)

theorem eq_of_bisim {α : Type u} (R : computation α → computation α → Prop) (bisim : is_bisimulation R) {s₁ : computation α} {s₂ : computation α} (r : R s₁ s₂) : s₁ = s₂ := sorry

-- It's more of a stretch to use ∈ for this relation, but it

-- asserts that the computation limits to the given value.

protected def mem {α : Type u} (a : α) (s : computation α) :=
  some a ∈ subtype.val s

protected instance has_mem {α : Type u} : has_mem α (computation α) :=
  has_mem.mk computation.mem

theorem le_stable {α : Type u} (s : computation α) {a : α} {m : ℕ} {n : ℕ} (h : m ≤ n) : subtype.val s m = some a → subtype.val s n = some a := sorry

theorem mem_unique {α : Type u} : relator.left_unique has_mem.mem := sorry

/-- `terminates s` asserts that the computation `s` eventually terminates with some value. -/
def terminates {α : Type u} (s : computation α) :=
  ∃ (a : α), a ∈ s

theorem terminates_of_mem {α : Type u} {s : computation α} {a : α} : a ∈ s → terminates s :=
  exists.intro a

theorem terminates_def {α : Type u} (s : computation α) : terminates s ↔ ∃ (n : ℕ), ↥(option.is_some (subtype.val s n)) := sorry

theorem ret_mem {α : Type u} (a : α) : a ∈ return a :=
  exists.intro 0 rfl

theorem eq_of_ret_mem {α : Type u} {a : α} {a' : α} (h : a' ∈ return a) : a' = a :=
  mem_unique h (ret_mem a)

protected instance ret_terminates {α : Type u} (a : α) : terminates (return a) :=
  terminates_of_mem (ret_mem a)

theorem think_mem {α : Type u} {s : computation α} {a : α} : a ∈ s → a ∈ think s := sorry

protected instance think_terminates {α : Type u} (s : computation α) [terminates s] : terminates (think s) :=
  sorry

theorem of_think_mem {α : Type u} {s : computation α} {a : α} : a ∈ think s → a ∈ s := sorry

theorem of_think_terminates {α : Type u} {s : computation α} : terminates (think s) → terminates s :=
  fun (ᾰ : terminates (think s)) =>
    Exists.dcases_on ᾰ
      fun (ᾰ_w : α) (ᾰ_h : ᾰ_w ∈ think s) => idRhs (∃ (a : α), a ∈ s) (Exists.intro ᾰ_w (of_think_mem ᾰ_h))

theorem not_mem_empty {α : Type u} (a : α) : ¬a ∈ empty α := sorry

theorem not_terminates_empty {α : Type u} : ¬terminates (empty α) := sorry

theorem eq_empty_of_not_terminates {α : Type u} {s : computation α} (H : ¬terminates s) : s = empty α := sorry

theorem thinkN_mem {α : Type u} {s : computation α} {a : α} (n : ℕ) : a ∈ thinkN s n ↔ a ∈ s := sorry

protected instance thinkN_terminates {α : Type u} (s : computation α) [terminates s] (n : ℕ) : terminates (thinkN s n) :=
  sorry

theorem of_thinkN_terminates {α : Type u} (s : computation α) (n : ℕ) : terminates (thinkN s n) → terminates s :=
  fun (ᾰ : terminates (thinkN s n)) =>
    Exists.dcases_on ᾰ
      fun (ᾰ_w : α) (ᾰ_h : ᾰ_w ∈ thinkN s n) => idRhs (∃ (a : α), a ∈ s) (Exists.intro ᾰ_w (iff.mp (thinkN_mem n) ᾰ_h))

/-- `promises s a`, or `s ~> a`, asserts that although the computation `s`
  may not terminate, if it does, then the result is `a`. -/
def promises {α : Type u} (s : computation α) (a : α) :=
  ∀ {a' : α}, a' ∈ s → a = a'

infixl:50 " ~> " => Mathlib.computation.promises

theorem mem_promises {α : Type u} {s : computation α} {a : α} : a ∈ s → s ~> a :=
  fun (h : a ∈ s) (a' : α) => mem_unique h

theorem empty_promises {α : Type u} (a : α) : empty α ~> a :=
  fun (a' : α) (h : a' ∈ empty α) => absurd h (not_mem_empty a')

/-- `length s` gets the number of steps of a terminating computation -/
def length {α : Type u} (s : computation α) [h : terminates s] : ℕ :=
  nat.find sorry

/-- `get s` returns the result of a terminating computation -/
def get {α : Type u} (s : computation α) [h : terminates s] : α :=
  option.get sorry

theorem get_mem {α : Type u} (s : computation α) [h : terminates s] : get s ∈ s :=
  exists.intro (length s) (Eq.symm (option.eq_some_of_is_some (get._proof_2 s)))

theorem get_eq_of_mem {α : Type u} (s : computation α) [h : terminates s] {a : α} : a ∈ s → get s = a :=
  mem_unique (get_mem s)

theorem mem_of_get_eq {α : Type u} (s : computation α) [h : terminates s] {a : α} : get s = a → a ∈ s :=
  fun (h_1 : get s = a) => eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ s)) (Eq.symm h_1))) (get_mem s)

@[simp] theorem get_think {α : Type u} (s : computation α) [h : terminates s] : get (think s) = get s := sorry

@[simp] theorem get_thinkN {α : Type u} (s : computation α) [h : terminates s] (n : ℕ) : get (thinkN s n) = get s :=
  get_eq_of_mem (thinkN s n) (iff.mpr (thinkN_mem n) (get_mem s))

theorem get_promises {α : Type u} (s : computation α) [h : terminates s] : s ~> get s :=
  fun (a : α) => get_eq_of_mem s

theorem mem_of_promises {α : Type u} (s : computation α) [h : terminates s] {a : α} (p : s ~> a) : a ∈ s :=
  Exists.dcases_on h fun (a' : α) (h : a' ∈ s) => eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ s)) (p h))) h

theorem get_eq_of_promises {α : Type u} (s : computation α) [h : terminates s] {a : α} : s ~> a → get s = a :=
  get_eq_of_mem s ∘ mem_of_promises s

/-- `results s a n` completely characterizes a terminating computation:
  it asserts that `s` terminates after exactly `n` steps, with result `a`. -/
def results {α : Type u} (s : computation α) (a : α) (n : ℕ) :=
  ∃ (h : a ∈ s), length s = n

theorem results_of_terminates {α : Type u} (s : computation α) [T : terminates s] : results s (get s) (length s) :=
  Exists.intro (get_mem s) rfl

theorem results_of_terminates' {α : Type u} (s : computation α) [T : terminates s] {a : α} (h : a ∈ s) : results s a (length s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (results s a (length s))) (Eq.symm (get_eq_of_mem s h)))) (results_of_terminates s)

theorem results.mem {α : Type u} {s : computation α} {a : α} {n : ℕ} : results s a n → a ∈ s :=
  fun (ᾰ : results s a n) => Exists.dcases_on ᾰ fun (ᾰ_w : a ∈ s) (ᾰ_h : length s = n) => idRhs (a ∈ s) ᾰ_w

theorem results.terminates {α : Type u} {s : computation α} {a : α} {n : ℕ} (h : results s a n) : terminates s :=
  terminates_of_mem (results.mem h)

theorem results.length {α : Type u} {s : computation α} {a : α} {n : ℕ} [T : terminates s] : results s a n → length s = n :=
  fun (ᾰ : results s a n) => Exists.dcases_on ᾰ fun (ᾰ_w : a ∈ s) (ᾰ_h : length s = n) => idRhs (length s = n) ᾰ_h

theorem results.val_unique {α : Type u} {s : computation α} {a : α} {b : α} {m : ℕ} {n : ℕ} (h1 : results s a m) (h2 : results s b n) : a = b :=
  mem_unique (results.mem h1) (results.mem h2)

theorem results.len_unique {α : Type u} {s : computation α} {a : α} {b : α} {m : ℕ} {n : ℕ} (h1 : results s a m) (h2 : results s b n) : m = n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (m = n)) (Eq.symm (results.length h1))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length s = n)) (results.length h2))) (Eq.refl n))

theorem exists_results_of_mem {α : Type u} {s : computation α} {a : α} (h : a ∈ s) : ∃ (n : ℕ), results s a n :=
  Exists.intro (length s) (results_of_terminates' s h)

@[simp] theorem get_ret {α : Type u} (a : α) : get (return a) = a :=
  get_eq_of_mem (return a) (Exists.intro 0 rfl)

@[simp] theorem length_ret {α : Type u} (a : α) : length (return a) = 0 :=
  let h : terminates (return a) := computation.ret_terminates a;
  nat.eq_zero_of_le_zero (nat.find_min' (iff.mp (terminates_def (return a)) h) rfl)

theorem results_ret {α : Type u} (a : α) : results (return a) a 0 :=
  Exists.intro (ret_mem a) (length_ret a)

@[simp] theorem length_think {α : Type u} (s : computation α) [h : terminates s] : length (think s) = length s + 1 := sorry

theorem results_think {α : Type u} {s : computation α} {a : α} {n : ℕ} (h : results s a n) : results (think s) a (n + 1) :=
  Exists.intro (think_mem (results.mem h))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length (think s) = n + 1)) (length_think s)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (length s + 1 = n + 1)) (results.length h))) (Eq.refl (n + 1))))

theorem of_results_think {α : Type u} {s : computation α} {a : α} {n : ℕ} (h : results (think s) a n) : ∃ (m : ℕ), results s a m ∧ n = m + 1 :=
  Exists.intro (length s)
    { left := results_of_terminates' s (of_think_mem (results.mem h)),
      right := results.len_unique h (results_think (results_of_terminates' s (of_think_mem (results.mem h)))) }

@[simp] theorem results_think_iff {α : Type u} {s : computation α} {a : α} {n : ℕ} : results (think s) a (n + 1) ↔ results s a n := sorry

theorem results_thinkN {α : Type u} {s : computation α} {a : α} {m : ℕ} (n : ℕ) : results s a m → results (thinkN s n) a (m + n) := sorry

theorem results_thinkN_ret {α : Type u} (a : α) (n : ℕ) : results (thinkN (return a) n) a n :=
  eq.mp (Eq._oldrec (Eq.refl (results (thinkN (return a) n) a (0 + n))) (nat.zero_add n))
    (results_thinkN n (results_ret a))

@[simp] theorem length_thinkN {α : Type u} (s : computation α) [h : terminates s] (n : ℕ) : length (thinkN s n) = length s + n :=
  results.length (results_thinkN n (results_of_terminates s))

theorem eq_thinkN {α : Type u} {s : computation α} {a : α} {n : ℕ} (h : results s a n) : s = thinkN (return a) n := sorry

theorem eq_thinkN' {α : Type u} (s : computation α) [h : terminates s] : s = thinkN (return (get s)) (length s) :=
  eq_thinkN (results_of_terminates s)

def mem_rec_on {α : Type u} {C : computation α → Sort v} {a : α} {s : computation α} (M : a ∈ s) (h1 : C (return a)) (h2 : (s : computation α) → C s → C (think s)) : C s :=
  eq.mpr sorry
    (eq.mpr sorry (Nat.rec h1 (fun (n : ℕ) (IH : C (thinkN (return a) n)) => h2 (thinkN (return a) n) IH) (length s)))

def terminates_rec_on {α : Type u} {C : computation α → Sort v} (s : computation α) [terminates s] (h1 : (a : α) → C (return a)) (h2 : (s : computation α) → C s → C (think s)) : C s :=
  mem_rec_on (get_mem s) (h1 (get s)) h2

/-- Map a function on the result of a computation. -/
def map {α : Type u} {β : Type v} (f : α → β) : computation α → computation β :=
  sorry

def bind.G {α : Type u} {β : Type v} : β ⊕ computation β → β ⊕ computation α ⊕ computation β :=
  sorry

def bind.F {α : Type u} {β : Type v} (f : α → computation β) : computation α ⊕ computation β → β ⊕ computation α ⊕ computation β :=
  sorry

/-- Compose two computations into a monadic `bind` operation. -/
def bind {α : Type u} {β : Type v} (c : computation α) (f : α → computation β) : computation β :=
  corec sorry (sum.inl c)

protected instance has_bind : Bind computation :=
  { bind := bind }

theorem has_bind_eq_bind {α : Type u} {β : Type u} (c : computation α) (f : α → computation β) : c >>= f = bind c f :=
  rfl

/-- Flatten a computation of computations into a single computation. -/
def join {α : Type u} (c : computation (computation α)) : computation α :=
  c >>= id

@[simp] theorem map_ret {α : Type u} {β : Type v} (f : α → β) (a : α) : map f (return a) = return (f a) :=
  rfl

@[simp] theorem map_think {α : Type u} {β : Type v} (f : α → β) (s : computation α) : map f (think s) = think (map f s) := sorry

@[simp] theorem destruct_map {α : Type u} {β : Type v} (f : α → β) (s : computation α) : destruct (map f s) = lmap f (rmap (map f) (destruct s)) := sorry

@[simp] theorem map_id {α : Type u} (s : computation α) : map id s = s := sorry

theorem map_comp {α : Type u} {β : Type v} {γ : Type w} (f : α → β) (g : β → γ) (s : computation α) : map (g ∘ f) s = map g (map f s) := sorry

@[simp] theorem ret_bind {α : Type u} {β : Type v} (a : α) (f : α → computation β) : bind (return a) f = f a := sorry

@[simp] theorem think_bind {α : Type u} {β : Type v} (c : computation α) (f : α → computation β) : bind (think c) f = think (bind c f) := sorry

@[simp] theorem bind_ret {α : Type u} {β : Type v} (f : α → β) (s : computation α) : bind s (return ∘ f) = map f s := sorry

@[simp] theorem bind_ret' {α : Type u} (s : computation α) : bind s return = s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (bind s return = s)) (bind_ret (fun (x : α) => x) s)))
    (id (eq.mpr (id (Eq._oldrec (Eq.refl (map id s = s)) (map_id s))) (Eq.refl s)))

@[simp] theorem bind_assoc {α : Type u} {β : Type v} {γ : Type w} (s : computation α) (f : α → computation β) (g : β → computation γ) : bind (bind s f) g = bind s fun (x : α) => bind (f x) g := sorry

theorem results_bind {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {a : α} {b : β} {m : ℕ} {n : ℕ} (h1 : results s a m) (h2 : results (f a) b n) : results (bind s f) b (n + m) := sorry

theorem mem_bind {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {a : α} {b : β} (h1 : a ∈ s) (h2 : b ∈ f a) : b ∈ bind s f := sorry

protected instance terminates_bind {α : Type u} {β : Type v} (s : computation α) (f : α → computation β) [terminates s] [terminates (f (get s))] : terminates (bind s f) :=
  terminates_of_mem (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem get_bind {α : Type u} {β : Type v} (s : computation α) (f : α → computation β) [terminates s] [terminates (f (get s))] : get (bind s f) = get (f (get s)) :=
  get_eq_of_mem (bind s f) (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem length_bind {α : Type u} {β : Type v} (s : computation α) (f : α → computation β) [T1 : terminates s] [T2 : terminates (f (get s))] : length (bind s f) = length (f (get s)) + length s :=
  results.len_unique (results_of_terminates (bind s f))
    (results_bind (results_of_terminates s) (results_of_terminates (f (get s))))

theorem of_results_bind {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {b : β} {k : ℕ} : results (bind s f) b k → ∃ (a : α), ∃ (m : ℕ), ∃ (n : ℕ), results s a m ∧ results (f a) b n ∧ k = n + m := sorry

theorem exists_of_mem_bind {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {b : β} (h : b ∈ bind s f) : ∃ (a : α), ∃ (H : a ∈ s), b ∈ f a := sorry

theorem bind_promises {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {a : α} {b : β} (h1 : s ~> a) (h2 : f a ~> b) : bind s f ~> b := sorry

protected instance monad : Monad computation :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β },
        toPure := { pure := return },
        toSeq :=
          { seq :=
              fun (α β : Type u_1) (f : computation (α → β)) (x : computation α) => bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : computation α) (b : computation β) =>
                (fun (α β : Type u_1) (f : computation (α → β)) (x : computation α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β α (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : computation α) (b : computation β) =>
                (fun (α β : Type u_1) (f : computation (α → β)) (x : computation α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β β (map (function.const α id) a) b } },
    toBind := { bind := bind } }

protected instance is_lawful_monad : is_lawful_monad computation :=
  is_lawful_monad.mk ret_bind bind_assoc

theorem has_map_eq_map {α : Type u} {β : Type u} (f : α → β) (c : computation α) : f <$> c = map f c :=
  rfl

@[simp] theorem return_def {α : Type u} (a : α) : return a = return a :=
  rfl

@[simp] theorem map_ret' {α : Type u_1} {β : Type u_1} (f : α → β) (a : α) : f <$> return a = return (f a) :=
  map_ret

@[simp] theorem map_think' {α : Type u_1} {β : Type u_1} (f : α → β) (s : computation α) : f <$> think s = think (f <$> s) :=
  map_think

theorem mem_map {α : Type u} {β : Type v} (f : α → β) {a : α} {s : computation α} (m : a ∈ s) : f a ∈ map f s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f a ∈ map f s)) (Eq.symm (bind_ret f s)))) (mem_bind m (ret_mem (f a)))

theorem exists_of_mem_map {α : Type u} {β : Type v} {f : α → β} {b : β} {s : computation α} (h : b ∈ map f s) : ∃ (a : α), a ∈ s ∧ f a = b := sorry

protected instance terminates_map {α : Type u} {β : Type v} (f : α → β) (s : computation α) [terminates s] : terminates (map f s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (terminates (map f s))) (Eq.symm (bind_ret f s))))
    (computation.terminates_bind s (return ∘ f))

theorem terminates_map_iff {α : Type u} {β : Type v} (f : α → β) (s : computation α) : terminates (map f s) ↔ terminates s := sorry

-- Parallel computation

/-- `c₁ <|> c₂` calculates `c₁` and `c₂` simultaneously, returning
  the first one that gives a result. -/
def orelse {α : Type u} (c₁ : computation α) (c₂ : computation α) : computation α :=
  corec (fun (_x : computation α × computation α) => sorry) (c₁, c₂)

protected instance alternative : alternative computation :=
  alternative.mk empty

@[simp] theorem ret_orelse {α : Type u} (a : α) (c₂ : computation α) : (return a <|> c₂) = return a := sorry

@[simp] theorem orelse_ret {α : Type u} (c₁ : computation α) (a : α) : (think c₁ <|> return a) = return a := sorry

@[simp] theorem orelse_think {α : Type u} (c₁ : computation α) (c₂ : computation α) : (think c₁ <|> think c₂) = think (c₁ <|> c₂) := sorry

@[simp] theorem empty_orelse {α : Type u} (c : computation α) : (empty α <|> c) = c := sorry

@[simp] theorem orelse_empty {α : Type u} (c : computation α) : (c <|> empty α) = c := sorry

/-- `c₁ ~ c₂` asserts that `c₁` and `c₂` either both terminate with the same result,
  or both loop forever. -/
def equiv {α : Type u} (c₁ : computation α) (c₂ : computation α) :=
  ∀ (a : α), a ∈ c₁ ↔ a ∈ c₂

infixl:50 " ~ " => Mathlib.computation.equiv

theorem equiv.refl {α : Type u} (s : computation α) : s ~ s :=
  fun (_x : α) => iff.rfl

theorem equiv.symm {α : Type u} {s : computation α} {t : computation α} : s ~ t → t ~ s :=
  fun (h : s ~ t) (a : α) => iff.symm (h a)

theorem equiv.trans {α : Type u} {s : computation α} {t : computation α} {u : computation α} : s ~ t → t ~ u → s ~ u :=
  fun (h1 : s ~ t) (h2 : t ~ u) (a : α) => iff.trans (h1 a) (h2 a)

theorem equiv.equivalence {α : Type u} : equivalence equiv :=
  { left := equiv.refl, right := { left := equiv.symm, right := equiv.trans } }

theorem equiv_of_mem {α : Type u} {s : computation α} {t : computation α} {a : α} (h1 : a ∈ s) (h2 : a ∈ t) : s ~ t :=
  fun (a' : α) =>
    { mp := fun (ma : a' ∈ s) => eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ t)) (mem_unique ma h1))) h2,
      mpr := fun (ma : a' ∈ t) => eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ s)) (mem_unique ma h2))) h1 }

theorem terminates_congr {α : Type u} {c₁ : computation α} {c₂ : computation α} (h : c₁ ~ c₂) : terminates c₁ ↔ terminates c₂ :=
  exists_congr h

theorem promises_congr {α : Type u} {c₁ : computation α} {c₂ : computation α} (h : c₁ ~ c₂) (a : α) : c₁ ~> a ↔ c₂ ~> a :=
  forall_congr fun (a' : α) => imp_congr (h a') iff.rfl

theorem get_equiv {α : Type u} {c₁ : computation α} {c₂ : computation α} (h : c₁ ~ c₂) [terminates c₁] [terminates c₂] : get c₁ = get c₂ :=
  get_eq_of_mem c₁ (iff.mpr (h (get c₂)) (get_mem c₂))

theorem think_equiv {α : Type u} (s : computation α) : think s ~ s :=
  fun (a : α) => { mp := of_think_mem, mpr := think_mem }

theorem thinkN_equiv {α : Type u} (s : computation α) (n : ℕ) : thinkN s n ~ s :=
  fun (a : α) => thinkN_mem n

theorem bind_congr {α : Type u} {β : Type v} {s1 : computation α} {s2 : computation α} {f1 : α → computation β} {f2 : α → computation β} (h1 : s1 ~ s2) (h2 : ∀ (a : α), f1 a ~ f2 a) : bind s1 f1 ~ bind s2 f2 := sorry

theorem equiv_ret_of_mem {α : Type u} {s : computation α} {a : α} (h : a ∈ s) : s ~ return a :=
  equiv_of_mem h (ret_mem a)

/-- `lift_rel R ca cb` is a generalization of `equiv` to relations other than
  equality. It asserts that if `ca` terminates with `a`, then `cb` terminates with
  some `b` such that `R a b`, and if `cb` terminates with `b` then `ca` terminates
  with some `a` such that `R a b`. -/
def lift_rel {α : Type u} {β : Type v} (R : α → β → Prop) (ca : computation α) (cb : computation β) :=
  (∀ {a : α}, a ∈ ca → Exists fun {b : β} => b ∈ cb ∧ R a b) ∧ ∀ {b : β}, b ∈ cb → Exists fun {a : α} => a ∈ ca ∧ R a b

theorem lift_rel.swap {α : Type u} {β : Type v} (R : α → β → Prop) (ca : computation α) (cb : computation β) : lift_rel (function.swap R) cb ca ↔ lift_rel R ca cb :=
  and_comm (∀ {a : β}, a ∈ cb → Exists fun {b : α} => b ∈ ca ∧ function.swap R a b)
    (∀ {b : α}, b ∈ ca → Exists fun {a : β} => a ∈ cb ∧ function.swap R a b)

theorem lift_eq_iff_equiv {α : Type u} (c₁ : computation α) (c₂ : computation α) : lift_rel Eq c₁ c₂ ↔ c₁ ~ c₂ := sorry

theorem lift_rel.refl {α : Type u} (R : α → α → Prop) (H : reflexive R) : reflexive (lift_rel R) :=
  fun (s : computation α) =>
    { left := fun (a : α) (as : a ∈ s) => Exists.intro a { left := as, right := H a },
      right := fun (b : α) (bs : b ∈ s) => Exists.intro b { left := bs, right := H b } }

theorem lift_rel.symm {α : Type u} (R : α → α → Prop) (H : symmetric R) : symmetric (lift_rel R) := sorry

theorem lift_rel.trans {α : Type u} (R : α → α → Prop) (H : transitive R) : transitive (lift_rel R) := sorry

theorem lift_rel.equiv {α : Type u} (R : α → α → Prop) : equivalence R → equivalence (lift_rel R) := sorry

theorem lift_rel.imp {α : Type u} {β : Type v} {R : α → β → Prop} {S : α → β → Prop} (H : ∀ {a : α} {b : β}, R a b → S a b) (s : computation α) (t : computation β) : lift_rel R s t → lift_rel S s t := sorry

theorem terminates_of_lift_rel {α : Type u} {β : Type v} {R : α → β → Prop} {s : computation α} {t : computation β} : lift_rel R s t → (terminates s ↔ terminates t) := sorry

theorem rel_of_lift_rel {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α} {cb : computation β} : lift_rel R ca cb → ∀ {a : α} {b : β}, a ∈ ca → b ∈ cb → R a b := sorry

theorem lift_rel_of_mem {α : Type u} {β : Type v} {R : α → β → Prop} {a : α} {b : β} {ca : computation α} {cb : computation β} (ma : a ∈ ca) (mb : b ∈ cb) (ab : R a b) : lift_rel R ca cb := sorry

theorem exists_of_lift_rel_left {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α} {cb : computation β} (H : lift_rel R ca cb) {a : α} (h : a ∈ ca) : Exists fun {b : β} => b ∈ cb ∧ R a b :=
  and.left H a h

theorem exists_of_lift_rel_right {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α} {cb : computation β} (H : lift_rel R ca cb) {b : β} (h : b ∈ cb) : Exists fun {a : α} => a ∈ ca ∧ R a b :=
  and.right H b h

theorem lift_rel_def {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α} {cb : computation β} : lift_rel R ca cb ↔ (terminates ca ↔ terminates cb) ∧ ∀ {a : α} {b : β}, a ∈ ca → b ∈ cb → R a b := sorry

theorem lift_rel_bind {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop) (S : γ → δ → Prop) {s1 : computation α} {s2 : computation β} {f1 : α → computation γ} {f2 : β → computation δ} (h1 : lift_rel R s1 s2) (h2 : ∀ {a : α} {b : β}, R a b → lift_rel S (f1 a) (f2 b)) : lift_rel S (bind s1 f1) (bind s2 f2) := sorry

@[simp] theorem lift_rel_return_left {α : Type u} {β : Type v} (R : α → β → Prop) (a : α) (cb : computation β) : lift_rel R (return a) cb ↔ Exists fun {b : β} => b ∈ cb ∧ R a b := sorry

@[simp] theorem lift_rel_return_right {α : Type u} {β : Type v} (R : α → β → Prop) (ca : computation α) (b : β) : lift_rel R ca (return b) ↔ Exists fun {a : α} => a ∈ ca ∧ R a b := sorry

@[simp] theorem lift_rel_return {α : Type u} {β : Type v} (R : α → β → Prop) (a : α) (b : β) : lift_rel R (return a) (return b) ↔ R a b := sorry

@[simp] theorem lift_rel_think_left {α : Type u} {β : Type v} (R : α → β → Prop) (ca : computation α) (cb : computation β) : lift_rel R (think ca) cb ↔ lift_rel R ca cb := sorry

@[simp] theorem lift_rel_think_right {α : Type u} {β : Type v} (R : α → β → Prop) (ca : computation α) (cb : computation β) : lift_rel R ca (think cb) ↔ lift_rel R ca cb := sorry

theorem lift_rel_mem_cases {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α} {cb : computation β} (Ha : ∀ (a : α), a ∈ ca → lift_rel R ca cb) (Hb : ∀ (b : β), b ∈ cb → lift_rel R ca cb) : lift_rel R ca cb :=
  { left := fun (a : α) (ma : a ∈ ca) => and.left (Ha a ma) a ma,
    right := fun (b : β) (mb : b ∈ cb) => and.right (Hb b mb) b mb }

theorem lift_rel_congr {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α} {ca' : computation α} {cb : computation β} {cb' : computation β} (ha : ca ~ ca') (hb : cb ~ cb') : lift_rel R ca cb ↔ lift_rel R ca' cb' :=
  and_congr (forall_congr fun (a : α) => imp_congr (ha a) (exists_congr fun (b : β) => and_congr (hb b) iff.rfl))
    (forall_congr fun (b : β) => imp_congr (hb b) (exists_congr fun (a : α) => and_congr (ha a) iff.rfl))

theorem lift_rel_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop) (S : γ → δ → Prop) {s1 : computation α} {s2 : computation β} {f1 : α → γ} {f2 : β → δ} (h1 : lift_rel R s1 s2) (h2 : ∀ {a : α} {b : β}, R a b → S (f1 a) (f2 b)) : lift_rel S (map f1 s1) (map f2 s2) := sorry

theorem map_congr {α : Type u} {β : Type v} (R : α → α → Prop) (S : β → β → Prop) {s1 : computation α} {s2 : computation α} {f : α → β} (h1 : s1 ~ s2) : map f s1 ~ map f s2 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (map f s1 ~ map f s2)) (Eq.symm (propext (lift_eq_iff_equiv (map f s1) (map f s2))))))
    (lift_rel_map Eq Eq (iff.mpr (lift_eq_iff_equiv s1 s2) h1) fun (a b : α) => congr_arg fun (a : α) => f a)

@[simp] def lift_rel_aux {α : Type u} {β : Type v} (R : α → β → Prop) (C : computation α → computation β → Prop) : α ⊕ computation α → β ⊕ computation β → Prop :=
  sorry

@[simp] theorem lift_rel_aux.ret_left {α : Type u} {β : Type v} (R : α → β → Prop) (C : computation α → computation β → Prop) (a : α) (cb : computation β) : lift_rel_aux R C (sum.inl a) (destruct cb) ↔ Exists fun {b : β} => b ∈ cb ∧ R a b := sorry

theorem lift_rel_aux.swap {α : Type u} {β : Type v} (R : α → β → Prop) (C : computation α → computation β → Prop) (a : α ⊕ computation α) (b : β ⊕ computation β) : lift_rel_aux (function.swap R) (function.swap C) b a = lift_rel_aux R C a b := sorry

@[simp] theorem lift_rel_aux.ret_right {α : Type u} {β : Type v} (R : α → β → Prop) (C : computation α → computation β → Prop) (b : β) (ca : computation α) : lift_rel_aux R C (destruct ca) (sum.inl b) ↔ Exists fun {a : α} => a ∈ ca ∧ R a b := sorry

theorem lift_rel_rec.lem {α : Type u} {β : Type v} {R : α → β → Prop} (C : computation α → computation β → Prop) (H : ∀ {ca : computation α} {cb : computation β}, C ca cb → lift_rel_aux R C (destruct ca) (destruct cb)) (ca : computation α) (cb : computation β) (Hc : C ca cb) (a : α) (ha : a ∈ ca) : lift_rel R ca cb := sorry

theorem lift_rel_rec {α : Type u} {β : Type v} {R : α → β → Prop} (C : computation α → computation β → Prop) (H : ∀ {ca : computation α} {cb : computation β}, C ca cb → lift_rel_aux R C (destruct ca) (destruct cb)) (ca : computation α) (cb : computation β) (Hc : C ca cb) : lift_rel R ca cb :=
  lift_rel_mem_cases sorry fun (b : β) (hb : b ∈ cb) => iff.mpr (lift_rel.swap (fun (x : β) (y : α) => R y x) cb ca) sorry


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

Enumerate elements of a set with a select function.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.lattice
import Mathlib.tactic.wlog
import Mathlib.PostPort

universes u_1

namespace Mathlib

namespace set

def enumerate {α : Type u_1} (sel : set α → Option α) : set α → ℕ → Option α :=
  sorry

theorem enumerate_eq_none_of_sel {α : Type u_1} (sel : set α → Option α) {s : set α} (h : sel s = none) {n : ℕ} : enumerate sel s n = none := sorry

theorem enumerate_eq_none {α : Type u_1} (sel : set α → Option α) {s : set α} {n₁ : ℕ} {n₂ : ℕ} : enumerate sel s n₁ = none → n₁ ≤ n₂ → enumerate sel s n₂ = none := sorry

theorem enumerate_mem {α : Type u_1} (sel : set α → Option α) (h_sel : ∀ (s : set α) (a : α), sel s = some a → a ∈ s) {s : set α} {n : ℕ} {a : α} : enumerate sel s n = some a → a ∈ s := sorry

theorem enumerate_inj {α : Type u_1} (sel : set α → Option α) {n₁ : ℕ} {n₂ : ℕ} {a : α} {s : set α} (h_sel : ∀ (s : set α) (a : α), sel s = some a → a ∈ s) (h₁ : enumerate sel s n₁ = some a) (h₂ : enumerate sel s n₂ = some a) : n₁ = n₂ := sorry


import Mathlib.Algebra.Group.Defs
import Mathlib.Init.Algebra.Order
import ECTate.Algebra.Ring.Basic
import Mathlib.Init.Data.Nat.Lemmas
import ECTate.Init.Data.Int.Lemmas
import ECTate.Data.Nat.Enat
import ECTate.Algebra.EllipticCurve.Kronecker
import Mathlib.Tactic.LibrarySearch
import Mathlib.Tactic.Ring
import Mathlib.Tactic.Convert
import Mathlib.Data.Nat.Prime
import Mathlib.Data.Int.GCD

--class ValueMonoid (A : Type u) extends AddCommMonoid A, LinearOrder A

open Enat

section Obvious

lemma match_non_zero (x : ℕ∪∞) {c1 c2 : β} : x ≠ 0 → (match x with | 0 => c1 | _ => c2) = c2 := by
  intro h
  match x with
  | ofN 0 => exact False.elim (h (Eq.refl 0))
  | ∞ => simp
  | ofN (_ + 1) => simp

theorem nat_mul_left_cancel (a b c : Nat) (h : a ≠ 0) : a * b = a * c → b = c :=
Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero h)

end Obvious

@[ext]
structure SurjVal {R : Type u} (p : R) [CommRing R] [IsDomain R] where
  v : R → ℕ∪∞
  v_uniformizer' : v p = 1
  v_mul_eq_add_v' (a b : R) : v (a * b) = v a + v b
  v_add_ge_min_v' (a b : R) : v (a + b) ≥ min (v a) (v b)
  v_eq_top_iff_zero' (a : R) : v a = ∞ ↔ a = 0

instance {R : Type u} (p : R) [CommRing R] [IsDomain R] : FunLike (SurjVal p) R (λ _ => ℕ∪∞) :=
{ coe := SurjVal.v
  coe_injective' := by
    intro x y h
    ext :1
    assumption }

instance {R : Type u} (p : R) [CommRing R] [IsDomain R] : CoeFun (SurjVal p) (λ _ => R → ℕ∪∞) := ⟨SurjVal.v⟩

namespace SurjVal
variable {R : Type u} {p : R} [CommRing R] [IsDomain R] (v : SurjVal p)
-- TODO make naming consistent
@[simp]
theorem v_uniformizer : v p = 1 := v.v_uniformizer'
@[simp]
theorem v_mul_eq_add_v (a b : R) : v (a * b) = v a + v b := v.v_mul_eq_add_v' a b
theorem v_add_ge_min_v (a b : R) : v (a + b) ≥ min (v a) (v b) := v.v_add_ge_min_v' a b

@[simp]
theorem v_eq_top_iff_zero (a : R) : v a = ∞ ↔ a = 0 := v.v_eq_top_iff_zero' a
end SurjVal

variable {R : Type u} [CommRing R] [IsDomain R]

namespace SurjVal

-- TODO namespace these
lemma p_non_zero {p : R} (nav : SurjVal p) : ¬p = 0 := by
  rw [←nav.v_eq_top_iff_zero, nav.v_uniformizer]
  simp

@[simp]
lemma val_zero {p : R} (nav : SurjVal p) : nav 0 = ∞ := (nav.v_eq_top_iff_zero 0).2 rfl

lemma val_mul_ge_left {p : R} (nav : SurjVal p) (a b : R) : nav (a * b) ≥ nav a :=
le_trans (le_add_right (nav a) (nav b)) (le_of_eq (nav.v_mul_eq_add_v a b).symm)

lemma val_mul_ge_right {p : R} (nav : SurjVal p) (a b : R) : nav (a * b) ≥ nav b := by
  rw [mul_comm]
  exact val_mul_ge_left nav b a

lemma val_mul_ge_of_left_ge {p : R} (nav : SurjVal p) {a b : R} (ha : nav a ≥ n) :
  nav (a * b) ≥ n :=
le_trans ha (val_mul_ge_left nav a b)

lemma val_mul_ge_of_right_ge {p : R} (nav : SurjVal p) {a b : R} (hb : nav b ≥ n) :
  nav (a * b) ≥ n :=
le_trans hb (val_mul_ge_right nav a b)

lemma val_mul_ge_of_both_ge {p : R} (nav : SurjVal p) {a b : R} (ha : nav a ≥ m) (hb : nav b ≥ n) :
  nav (a * b) ≥ m + n := by
  rw [nav.v_mul_eq_add_v]
  exact add_le_add ha hb

@[simp]
lemma val_of_one {p : R} (nav : SurjVal p) : nav 1 = 0 := by
  apply Enat.add_right_cancel_ofN 1
  simp only [Nat.cast_one, zero_add]
  rw [←SurjVal.v_uniformizer nav, ←SurjVal.v_mul_eq_add_v nav, one_mul]

lemma val_pow_ge_of_ge {p : R} (nav : SurjVal p) {a : R} (k : ℕ) (ha : nav a ≥ m) :
  nav (a ^ k) ≥ k • m := by
  induction k with
  | zero => simp [zero_nsmul]
  | succ k ih =>
    simp only [succ_nsmul, pow_succ]
    apply val_mul_ge_of_both_ge _ ha ih

lemma val_pow_eq_of_eq {p : R} (nav : SurjVal p) {a : R} (k : ℕ) (ha : nav a = m) :
  nav (a ^ k) = k * m := by
  induction k with
  | zero => simp
  | succ k ih =>
    simp only [pow_succ, Nat.cast_succ, add_mul, one_mul, add_comm]
    rw [nav.v_mul_eq_add_v, ha, ih]

@[simp]
lemma val_pow_eq {p : R} (nav : SurjVal p) {a : R} (k : ℕ)  :
  nav (a ^ k) = k * nav a := val_pow_eq_of_eq nav k rfl

lemma val_add_ge_of_ge {p : R} (nav : SurjVal p) {a b : R} (ha : nav a ≥ n) (hb : nav b ≥ n) :
  nav (a + b) ≥ n := le_trans (le_min ha hb) (nav.v_add_ge_min_v a b)

def nat_of_val {p : R} (nav : SurjVal p) {a : R} (h : a ≠ 0) : ℕ :=
  to_nat ((not_iff_not.2 (nav.v_eq_top_iff_zero a)).2 h)

/-
lemma val_of_add_one {p : R} (nav : SurjVal p) (h : nav x ≥ 1): nav (x + 1) = 0 := by
  apply le_antisymm
  . apply le_of_not_lt
    intro h'
    sorry
  . apply le_trans _ (nav.v_add_ge_min_v x 1)
    apply le_min (le_trans (le_succ 0) h) (le_of_eq (val_of_one nav).symm)
-/

lemma val_of_minus_one {p : R} (nav : SurjVal p) : nav (-1) = 0 := by
  cases Enat.eq_zero_or_pos (nav (-1)) with
  | inl h => exact h
  | inr h =>
    have contradiction : nav 1 > 0 := by
      rw [←neg_neg 1, ←one_mul 1, neg_mul_eq_neg_mul, neg_mul_eq_mul_neg, nav.v_mul_eq_add_v]
      apply Enat.lt_add_right _ _ _ h
    rw [val_of_one] at contradiction
    exact False.elim ((lt_irrefl 0) contradiction)

@[simp]
lemma val_neg {p : R} (nav : SurjVal p) : nav (-x) = nav x := by
  rw [←one_mul x, neg_mul_eq_neg_mul, nav.v_mul_eq_add_v, val_of_minus_one, one_mul, zero_add]

theorem v_sub_ge_min_v (nav : SurjVal p) (a b : R) : nav (a - b) ≥ min (nav a) (nav b) := by
  rw [sub_eq_add_neg]
  convert nav.v_add_ge_min_v a (-b) using 2
  simp

lemma val_sub_ge_of_ge {p : R} (nav : SurjVal p) {a b : R} (ha : nav a ≥ n) (hb : nav b ≥ n) :
  nav (a - b) ≥ n := by
  rw [sub_eq_add_neg]
  apply val_add_ge_of_ge
  assumption
  simpa

theorem v_add_eq_min_v {p : R} (nav : SurjVal p) {a b : R} (h : nav a < nav b) :
  nav (a + b) = nav a := by
  apply le_antisymm
  . apply le_of_not_lt
    intro h'
    have hm : nav a < nav (-b) := by rwa [val_neg]
    apply lt_irrefl (nav a)
    apply lt_of_lt_of_le (lt_min h' hm)
    rw [(show nav a = nav (a + b + -b) by simp)]
    exact nav.v_add_ge_min_v (a + b) (-b)
  . exact le_trans (le_min (le_of_eq rfl) (le_of_lt h)) (SurjVal.v_add_ge_min_v nav a b)

theorem val_of_pow_uniformizer {p : R} (nav : SurjVal p) {n : ℕ} : nav (p ^ n) = n := by
  induction n with
  | zero      =>
    rw [pow_zero]
    exact val_of_one nav
  | succ n ih =>
    rw [pow_succ, SurjVal.v_mul_eq_add_v nav, ih, SurjVal.v_uniformizer nav]
    simp [Nat.succ_eq_add_one, add_comm]

end SurjVal

structure EnatValRing {R : Type u} (p : R) [CommRing R] [IsDomain R] where
  valtn : SurjVal p
  decr_val : R → R
  /-- reduce the element x by valuation n (by dividing by an appropriate power of the uniformizer) -/
  sub_val : ℕ → R → R := Nat.iterate decr_val
  sub_val_eq : sub_val = Nat.iterate decr_val := by rfl
  zero_valtn_decr {x : R} (h : valtn x = 0) : decr_val x = x
  pos_valtn_decr {x : R} (h : valtn x > 0) : x = p * decr_val x -- TODO remove
  residue_char : ℕ
  norm_repr : R → R --generalization of modulo
  norm_repr_spec : ∀ r, valtn (r - norm_repr r) > 0
  inv_mod : R → R
  inv_mod_spec : ∀ r, valtn r = 0 → valtn (r * inv_mod r - 1) > 0
  inv_mod_spec' : ∀ r, valtn r > 0 → valtn (inv_mod r) > 0
  inv_mod_spec'' : ∀ r s, valtn (r - s) > 0 → inv_mod r = inv_mod s
  pth_root : R → R
  pth_root_spec : residue_char = 0 ∨ ∀ r, valtn (pth_root r ^ residue_char - r) > 0
  count_roots_cubic : (a b c d : R) → Nat
  -- count_roots_cubic_spec : ∀ (a b c d : R), exists a smallest finset of elts solving
  quad_roots_in_residue_field : R → R → R → Bool

namespace EnatValRing
open SurjVal

@[simp]
lemma decr_val_zero {p : R} (evr : EnatValRing p) : evr.decr_val 0 = 0 := by
  have v_decr_zero : p * evr.decr_val 0 = 0 := by
    apply Eq.symm
    apply evr.pos_valtn_decr
    rw [val_zero]
    exact Enat.lt_top 0
  rw [mul_eq_zero] at v_decr_zero
  exact Or.resolve_left v_decr_zero (p_non_zero evr.valtn)

@[simp]
lemma decr_val_neg {p : R} (evr : EnatValRing p) (x : R) : evr.decr_val (-x) = -evr.decr_val x := by
  cases @eq_zero_or_pos _ _ (evr.valtn x) with
  | inl h =>
    have hm : evr.valtn (-x) = 0 := by simp [h]
    rw [evr.zero_valtn_decr h, evr.zero_valtn_decr hm]
  | inr h =>
    have hm : evr.valtn (-x) > 0 := by simp [h]
    apply nzero_mul_left_cancel p _ _ (p_non_zero evr.valtn)
    rw [←neg_mul_eq_mul_neg, ←evr.pos_valtn_decr h, ←evr.pos_valtn_decr hm]

@[simp]
lemma decr_val_p_mul {p : R} (evr : EnatValRing p) (x : R) : evr.decr_val (p * x) = x := by
  have h : (p * x) = p * decr_val evr (p * x) := by
    apply evr.pos_valtn_decr
    rw [evr.valtn.v_mul_eq_add_v, evr.valtn.v_uniformizer]
    rw [add_comm, ← Enat.succ_eq_add_one]
    apply Enat.succ_pos
  apply nzero_mul_left_cancel p _ _ (p_non_zero evr.valtn)
  exact h.symm

@[simp]
lemma sub_val_zero_n {p : R} (evr : EnatValRing p) (n : ℕ) : sub_val evr n 0 = 0 := by
  induction n with
  | zero => simp [sub_val_eq]
  | succ n ih => simpa [sub_val_eq, decr_val_zero] using ih

@[simp]
lemma sub_val_x_zero {p : R} (evr : EnatValRing p) (x : R) : sub_val evr 0 x = x := by simp [sub_val_eq]

lemma sub_val_val_zero {p : R} (evr : EnatValRing p) (x : R) (m : ℕ) (h : evr.valtn x = 0) :
  sub_val evr m x = x := by
  induction m with
  | zero => exact sub_val_x_zero evr x
  | succ m ih => simpa [sub_val_eq, zero_valtn_decr _ h] using ih

lemma sub_val_val_pos_succ {p : R} (evr : EnatValRing p) (x : R) (m : ℕ) :
  sub_val evr (Nat.succ m) x = sub_val evr m (evr.decr_val x) := by
  simp [sub_val_eq]

lemma val_decr_val {p : R} (evr : EnatValRing p) {m : Nat} (x : R) (h : evr.valtn x = m) :
  evr.valtn (evr.decr_val x) = ↑(m - 1) := by
  cases m with
  | zero => rwa [evr.zero_valtn_decr h]
  | succ m =>
    have x_pos_val : evr.valtn x > 0 := by
      rw [h]
      exact succ_pos m
    apply add_right_cancel_ofN 1
    simp at * -- TODO fix nonterminal
    rw [←evr.valtn.v_uniformizer, ←evr.valtn.v_mul_eq_add_v, mul_comm,
      ←evr.pos_valtn_decr x_pos_val, h, evr.valtn.v_uniformizer]

lemma sub_val_decr_val_comm {p : R} (evr : EnatValRing p) (x : R) (n : ℕ) :
  sub_val evr n (evr.decr_val x) = evr.decr_val (sub_val evr n x) := by
  simp [sub_val_eq]
  rw [← Function.iterate_succ_apply' evr.decr_val]
  rw [← Function.iterate_succ_apply evr.decr_val]

lemma val_sub_val_eq {p : R} (evr : EnatValRing p) (x : R) {m : ℕ} (n : ℕ) (h : evr.valtn x = m) :
  evr.valtn (sub_val evr n x) = ↑(m - n) := by
  induction n with
  | zero => rwa [sub_val_x_zero, Nat.sub_zero]
  | succ n ih =>
    cases m with
    | zero =>
      rw [Nat.zero_sub] at ih
      rw [Nat.zero_sub, sub_val_val_zero evr x n.succ h]
      exact h
    | succ m =>
      rw [sub_val_val_pos_succ, sub_val_decr_val_comm, val_decr_val evr (sub_val evr n x) ih,
        Nat.succ_eq_add_one n, Nat.sub_sub]

lemma val_sub_val_le {p : R} (evr : EnatValRing p) (x : R) {m : ℕ} (n : ℕ) (h : evr.valtn x ≥ m) :
  evr.valtn (sub_val evr n x) ≥ ↑(m - n) := by
  cases enat_disjunction (evr.valtn x) with
  | inl h' =>
    have topcase : x = 0 := (evr.valtn.v_eq_top_iff_zero x).1 h'
    rw [topcase, sub_val_zero_n, (evr.valtn.v_eq_top_iff_zero 0).2 rfl]
    exact le.below_top
  | inr h' =>
    have H : ∀ (a : ℕ), evr.valtn x = a → evr.valtn (sub_val evr n x) ≥ (m - n) := by
      intro a ha
      have h'' := val_sub_val_eq evr x n ha
      rw [h'']
      apply (le_ofN (m - n) (a - n)).2
      rw [ha] at h
      apply Nat.sub_le_sub_right ((le_ofN m a).1 h)
    exact Exists.elim h' H

lemma factor_p_of_le_val {p : R} (evr : EnatValRing p) {x : R} {n : ℕ} (h : evr.valtn x ≥ n) :
  x = p ^ n * sub_val evr n x := by
  induction n with
  | zero => simp [sub_val_eq]
  | succ n ih =>
    rw [sub_val_val_pos_succ, sub_val_decr_val_comm, pow_succ', mul_assoc]
    have pos_val : evr.valtn (sub_val evr n x) > 0 := by
      have h' := val_sub_val_le evr x n h
      rw [Nat.succ_eq_add_one, Nat.add_sub_self_left] at h'
      exact lt_of_succ_le h'
    rw [←evr.pos_valtn_decr pos_val]
    apply ih
    exact le_of_succ_le h

lemma factor_p_of_eq_val {p : R} (evr : EnatValRing p) {x : R} {n : ℕ} (h : evr.valtn x = n) :
  x = p ^ n * sub_val evr n x := factor_p_of_le_val evr (le_of_eq (Eq.symm h))

lemma sub_val_p_mul {p : R} (evr : EnatValRing p) (x : R) (n : ℕ) : sub_val evr n (p ^ n * x) = x :=
by
  induction n with
  | zero      =>
    rw [pow_zero, one_mul]
    exact sub_val_x_zero evr x
  | succ n ih =>
    rwa [sub_val_val_pos_succ evr, pow_succ, mul_assoc, decr_val_p_mul]

lemma sub_val_neg {p : R} (evr : EnatValRing p) {x : R} {n : ℕ} : sub_val evr n (-x) = -sub_val evr n x := by
  induction n with
  | zero => simp [sub_val_x_zero]
  | succ n ih =>
    cases @eq_zero_or_pos _ _ (evr.valtn x) with
    | inl h' =>
      have h'm : evr.valtn (-x) = 0 := by simp [h']
      rw [sub_val_val_zero evr _ _ h', sub_val_val_zero evr _ _ h'm]
    | inr h' =>
      rw [sub_val_val_pos_succ evr _ _, sub_val_val_pos_succ evr _ _, sub_val_decr_val_comm, ih,
      decr_val_neg, sub_val_decr_val_comm]

lemma sub_val_add {p : R} (evr : EnatValRing p) {x y : R} {n : ℕ} (hx : evr.valtn x ≥ n)
  (hy : evr.valtn y ≥ n) : sub_val evr n (x + y) = sub_val evr n x + sub_val evr n y := by
  apply nzero_mul_left_cancel (p ^ n)
  . exact pow_ne_zero n (p_non_zero evr.valtn)
  . rw [←factor_p_of_le_val evr (_ : evr.valtn (x + y) ≥ n), mul_add, ←factor_p_of_le_val evr hx, ←factor_p_of_le_val evr hy]
    exact le_trans (le_min hx hy) (evr.valtn.v_add_ge_min_v x y)

lemma sub_val_sub {p : R} (evr : EnatValRing p) {x y : R} {n : ℕ} (hx : evr.valtn x ≥ n)
  (hy : evr.valtn y ≥ n) : sub_val evr n (x - y) = sub_val evr n x - sub_val evr n y :=
by
  rw [sub_eq_add_neg, sub_eq_add_neg, sub_val_add evr hx, sub_val_neg]
  simpa

lemma sub_val_mul_left {p : R} (evr : EnatValRing p) {x y : R} {n : ℕ} (hx : evr.valtn x ≥ n) :
  sub_val evr n (x * y) = sub_val evr n x * y := by
  apply nzero_mul_left_cancel (p ^ n)
  . exact pow_ne_zero n (p_non_zero evr.valtn)
  . rw [←factor_p_of_le_val evr (_ : evr.valtn (x * y) ≥ n), ←mul_assoc, ←factor_p_of_le_val evr hx]
    exact le_trans hx (val_mul_ge_left evr.valtn x y)

lemma sub_val_mul_right {p : R} (evr : EnatValRing p) {x y : R} {n : ℕ} (hy : evr.valtn y ≥ n) :
  sub_val evr n (x * y) = x * sub_val evr n y :=
by rw [mul_comm x y, sub_val_mul_left evr hy, mul_comm]

lemma sub_val_mul_sub_val {p : R} (evr : EnatValRing p) {x y : R} (n m : ℕ)
  (hx : evr.valtn x ≥ n) (hy : evr.valtn y ≥ m) :
  sub_val evr n x * sub_val evr m y = sub_val evr (n + m) (x * y) := by
  apply nzero_mul_left_cancel (p ^ (n + m)) _ _ (pow_ne_zero _ (p_non_zero evr.valtn))
  rw [←factor_p_of_le_val evr (_ : evr.valtn (x * y) ≥ (n + m)), pow_add, mul_assoc,
    mul_comm (p ^ m), ← mul_assoc,
    ← mul_assoc,
    ←factor_p_of_le_val evr (_ : evr.valtn x ≥ n), mul_assoc, mul_comm _ (p ^ m),
    ←factor_p_of_le_val evr (_ : evr.valtn y ≥ m)]
  . assumption
  . assumption
  . rw [SurjVal.v_mul_eq_add_v]
    exact add_le_add hx hy

lemma sub_val_mul {p : R} (evr : EnatValRing p) {x y : R} (n m : ℕ) {nm : ℕ} (h : n + m = nm)
  (hx : evr.valtn x ≥ n) (hy : evr.valtn y ≥ m) :
  sub_val evr nm (x * y) = sub_val evr n x * sub_val evr m y := by
  rw [← h, sub_val_mul_sub_val _ _ _ hx hy]

lemma sub_val_pow {p : R} (evr : EnatValRing p) {x : R} (n k : ℕ) {nm : ℕ} (h : k * n = nm)
  (hx : evr.valtn x ≥ n) :
  sub_val evr nm (x ^ k) = sub_val evr n x ^ k := by
  induction k generalizing nm with
  | zero => simp [← h]
  | succ k ih =>
    rw [pow_succ, sub_val_mul _ n (k * n), pow_succ, ← ih]
    rfl
    rw [← h, Nat.succ_mul, add_comm]
    exact hx
    convert val_pow_ge_of_ge evr.valtn k hx
    exact ofNat_mul_eq_smul k n

lemma sub_val_sub_val {p : R} (evr : EnatValRing p) {x : R} {m n : ℕ} :
  sub_val evr n (sub_val evr m x) = sub_val evr (m + n) x := by
  have general : ∀ y : R, sub_val evr n (sub_val evr m y) = sub_val evr (m + n) y := by
    induction m with
    | zero => simp [sub_val_x_zero]
    | succ m ih =>
      intro y
      cases @eq_zero_or_pos _ _ (evr.valtn y) with
      | inl h' => simp [sub_val_val_zero evr y _ h']
      | inr h' =>
        rw [sub_val_val_pos_succ evr y m, Nat.succ_add, sub_val_val_pos_succ evr y _]
        exact ih (evr.decr_val y)
  exact general x

def has_double_root {p : R} (evr : EnatValRing p) (a b c : R) :=
  evr.valtn a = 0 ∧ evr.valtn (b ^ 2 - 4 * a * c) > 0

def double_root {p : R} (evr : EnatValRing p) (a b c : R) :=
  if evr.residue_char = 2 then
    evr.norm_repr c
  else
    evr.norm_repr (-b * evr.inv_mod (2 * a))

lemma val_poly_of_double_root {p : R} (evr : EnatValRing p) (a b c : R)
  (H : has_double_root evr a b c) :
  evr.valtn (a * (double_root evr a b c)^2 + b * (double_root evr a b c) + c) > 0 ∧
  evr.valtn (2*a*(double_root evr a b c) + b) > 0 := by sorry

lemma pth_root_pos_of_pos {p : R} (evr : EnatValRing p) (r : R) (ha : 0 < evr.valtn r)
  (hchar : evr.residue_char ≠ 0) :
  evr.valtn (evr.pth_root r) > 0 :=
by
  suffices 0 < evr.valtn (evr.pth_root r ^ evr.residue_char) by
    . simp at this
      exact this.2
  have :
    min (SurjVal.v evr.valtn (pth_root evr r ^ evr.residue_char - r)) (SurjVal.v evr.valtn r) > 0 :=
  min_rec' (LT.lt 0) (evr.pth_root_spec.resolve_left hchar r) ha -- TODO ew
  have := this.trans_le (evr.valtn.v_add_ge_min_v (evr.pth_root r ^ evr.residue_char - r) r)
  simpa using this

end EnatValRing

lemma ndiv_mul_left (a b p : ℕ) : (a * b) % p ≠ 0 → a % p ≠ 0 := by
  intro hab ha
  apply hab
  simp [Nat.mul_mod, ha]

lemma ndiv_mul_right (a b p : ℕ) : (a * b) % p ≠ 0 → b % p ≠ 0 := by
  rw [Nat.mul_comm]
  exact ndiv_mul_left b a p

-- lemma Nat.Prime_test (p : ℕ) : Nat.Prime p ↔ (1 < p ∧ (∀ a b : ℕ, a < p → b < p → (a * b) % p = 0 → a % p = 0 ∨ b % p = 0)) := by
--   apply Iff.intro
--   . intro H
--     apply And.intro (H.left)
--     intro a b _ _
--     apply H.right a b
--   . intro H
--     apply And.intro (H.left)
--     intro a b p_div_ab
--     rw [Nat.mul_mod] at p_div_ab
--     have p_pos : p > 0 := lt_trans Nat.zero_lt_one H.left;
--     have h := H.right (a % p) (b % p) (Nat.mod_lt a p_pos) (Nat.mod_lt b p_pos) p_div_ab;
--     rwa [Nat.mod_mod _ p, Nat.mod_mod _ p] at h

instance : DecidablePred (Nat.Prime . : ℕ → Prop) := Nat.decidablePrime
--match p with
  --| 0 => sorry --isFalse (not_and_of_not_left _ (not_lt_of_ge (le_of_lt Nat.zero_lt_one)))
  --| 1 => isFalse (not_and_of_not_left _ (not_lt_of_ge (le_of_eq rfl)))
  --| Nat.succ (Nat.succ p') => sorry

--def fmul_eq_addf {R R' : Type u} [Mul R] [Add R'] (f : R → R') (x y : R) : Prop := f (x * y) = f x + f y

-- @[extern "blah"]
-- def nat_valuation_aux : ℕ → ℕ → ℕ
--   | _, 0 => 0
--   | 0, (_+1) => 0
--   | 1, (_+1) => 0
--   | (q+2), (m+1) => if (m+1) % (q+2) ≠ 0 then 0 else Nat.succ (nat_valuation_aux (q+2) ((m+1) / (q+2)))
-- termination_by nat_valuation_aux p k => k
-- decreasing_by
--   simp [WellFoundedRelation.rel, measure, invImage, InvImage, Nat.lt_wfRel]
--   exact Nat.div_lt_self (Nat.zero_lt_succ m) (Nat.succ_lt_succ (Nat.zero_lt_succ q))

lemma Nat.div_pos_of_mod {a b : ℕ} (ha : 0 < a) (hb : 1 < b) (hab : a % b = 0) : 0 < a / b :=
Nat.div_pos (Nat.le_of_dvd ha (dvd_of_mod_eq_zero hab)) (lt_of_succ_lt hb)

def nat_valuation_aux'' (q : ℕ) (hq : 1 < q) : (m : ℕ) → 0 < m → ℕ → ℕ
  | m, hm, n => if hmq : m % q == 0 then (nat_valuation_aux'' q hq (m / q) (Nat.div_pos_of_mod hm hq (by simpa using hmq)) (n + 1)) else n
decreasing_by
  simp [WellFoundedRelation.rel, measure, invImage, InvImage, Nat.lt_wfRel]
  exact Nat.div_lt_self hm hq

-- TODO unusedVariable linter fails
lemma nat_valuation_aux''_of_dvd_induction : ∀ (M m : ℕ) (hM : m ≤ M) (hm : 0 < m) (n : ℕ)
  (hmq : m % q = 0), ↑(nat_valuation_aux'' q hq m hm n) = succ ↑(nat_valuation_aux'' q hq (m / q)
    (Nat.div_pos_of_mod hm hq hmq) n) := by
  intro M
  induction M with
  | zero =>
    intro m mle0 hm n hmq
    rw [Nat.le_zero] at mle0
    exact ((ne_of_gt hm) mle0).elim
  | succ M IH =>
    intro m m_le_sM hm n hmq
    cases LE.le.lt_or_eq m_le_sM with
    | inl mltsM =>
      exact IH m (Nat.le_of_lt_succ mltsM) hm n hmq
    | inr meqsM =>
      cases em ((m / q) % q == 0) with
      | inl h =>
        rw [nat_valuation_aux'', nat_valuation_aux'', dif_pos h]
        simp only [beq_iff_eq, succ_ofNat, Nat.cast_succ]
        rw [dif_pos hmq]
        simp only [meqsM]
        rw [meqsM] at hm h hmq
        exact IH (M.succ/q) (Nat.le_of_lt_succ (Nat.div_lt_self hm hq))
          (Nat.div_pos_of_mod hm hq hmq) (n+1) (by simpa using h)
      | inr h =>
        rw [nat_valuation_aux'', nat_valuation_aux'', dif_neg h, dif_pos, nat_valuation_aux'', dif_neg h]
        . simp
        . simp only [hmq]

lemma nat_valuation_aux''_of_dvd (q : ℕ) (hq : 1 < q) (m : ℕ) (hm : 0 < m) (n : ℕ) (hmq : m % q = 0) :
nat_valuation_aux'' q hq m hm n = succ (nat_valuation_aux'' q hq (m / q) (Nat.div_pos_of_mod hm hq hmq) n) :=
nat_valuation_aux''_of_dvd_induction m m (le_refl m) hm n hmq

lemma nat_valuation_aux''_of_not_dvd (q : ℕ) (hq : 1 < q) (m : ℕ) (hm : 0 < m)
  (hmq : m % q ≠ 0) : nat_valuation_aux'' q hq m hm 0 = 0 :=
by
  have hmq_bool : ¬m % q == 0 := by
    intro H
    apply hmq (eq_of_beq H)
  rw [nat_valuation_aux'', dif_neg hmq_bool]

-- set_option trace.compiler.ir.result true in
def nat_valuation_aux' (q : ℕ) (hq : 1 < q) : (m : ℕ) → 0 < m → ℕ∪∞
  | m, hm => nat_valuation_aux'' q hq m hm 0

lemma nat_valuation_aux'_of_not_dvd (q : ℕ) (hq : 1 < q) (m : ℕ) (hm : 0 < m)
  (hmq : m % q ≠ 0) : nat_valuation_aux' q hq m hm = 0 :=
by
  rw [nat_valuation_aux']
  simp [nat_valuation_aux''_of_not_dvd q hq m hm hmq]

lemma nat_valuation_aux'_of_dvd (q : ℕ) (hq : 1 < q) (m : ℕ) (hm : 0 < m)
  (hmq : m % q = 0) : nat_valuation_aux' q hq m hm = succ (nat_valuation_aux' q hq (m / q)
  (Nat.div_pos_of_mod hm hq hmq)) :=
by
  simp [nat_valuation_aux', nat_valuation_aux''_of_dvd q hq m hm 0 hmq]

lemma nat_val_aux'_succ (q m : ℕ) (hq) : nat_valuation_aux' (q+2) hq (m+1) (Nat.zero_lt_succ _) =
  if hmq : (m+1) % (q+2) ≠ 0 then 0 else succ (nat_valuation_aux' (q+2) hq ((m+1) / (q+2)) (Nat.div_pos_of_mod (Nat.zero_lt_succ _) hq (not_not.mp hmq))) :=
by
  simp only [Nat.succ_ne_zero, dite_false, ne_eq, ite_not]
  cases em ((m + 1) % (q + 2) = 0) with
  | inl h =>
    rw [dif_neg (not_not_intro h)]
    exact nat_valuation_aux'_of_dvd _ _ _ _ h
  | inr h =>
    rw [dif_pos h]
    exact nat_valuation_aux'_of_not_dvd _ _ _ _ h

def nat_valuation_aux (q : ℕ) (hq : 1 < q) : ℕ → ℕ∪∞ :=
  λ m => if hm : m = 0 then ∞ else nat_valuation_aux' q hq m (Nat.pos_of_ne_zero hm)

@[simp]
lemma nat_val_aux_zero (p : ℕ) (hp) : nat_valuation_aux p hp 0 = ∞ := by
  simp [nat_valuation_aux]

lemma x' {a b : Nat} (h : (a+1) % (b+1) = 0) : (a+1) ≥ (b+1) := Nat.le_of_dvd (Nat.succ_pos _) (Nat.dvd_of_mod_eq_zero h)

lemma nat_val_aux_succ (q m : ℕ) (hq) : nat_valuation_aux (q+2) hq (m+1) =
  if (m+1) % (q+2) ≠ 0 then 0 else succ (nat_valuation_aux (q+2) hq ((m+1) / (q+2))) := by
  simp only [nat_valuation_aux, Nat.succ_ne_zero, dite_false, ne_eq, ite_not]
  by_cases hmq : (m + 1) % (q + 2) = 0
  . have h : (m + 1) / (q + 2) ≠ 0 := by
      apply Nat.ne_of_gt
      apply Nat.div_pos (x' hmq) (lt_trans (Nat.lt_succ_self 0) hq)
    rw [if_pos hmq, dif_neg h]
    exact nat_valuation_aux'_of_dvd (q+2) hq (m+1) _ hmq
  . rw [if_neg hmq]
    exact nat_valuation_aux'_of_not_dvd (q+2) hq (m+1) _ hmq

/-
def nat_valuation : ℕ → ℕ → ℕ∪∞
  | _, 0 => ∞
  | 0, (_+1) => 0
  | 1, (_+1) => ∞
  | (q+2), (m+1) => if (m+1) % (q+2) ≠ 0 then 0 else succ (nat_valuation (q+2) ((m+1) / (q+2)))
termination_by nat_valuation p k => k
decreasing_by
  simp [WellFoundedRelation.rel, measure, invImage, InvImage, Nat.lt_wfRel]
  exact Nat.div_lt_self (Nat.zero_lt_succ m) (Nat.succ_lt_succ (Nat.zero_lt_succ q))
-/
def nat_valuation : ℕ → ℕ → ℕ∪∞
  | _, 0 => ∞
  | 0, (_+1) => 0
  | 1, (_+1) => ∞
  | (q+2), (m+1) => nat_valuation_aux (q+2) (Nat.succ_lt_succ (Nat.zero_lt_succ q)) (m+1)

lemma nat_valuation_add_two (q m : ℕ) :
  nat_valuation (q+2) m = nat_valuation_aux (q+2) (Nat.succ_lt_succ (Nat.zero_lt_succ q)) m := by
  cases m
  . rfl
  . simp [nat_valuation]

lemma nat_valuation_of_one_lt (p m : ℕ) (hp : 1 < p) : nat_valuation p m = nat_valuation_aux p hp m :=
  by cases p
     case zero => cases hp
     case succ p =>
       cases p
       case zero => cases hp.ne rfl
       case succ q =>
         cases m
         . rfl
         . simp [nat_valuation]

@[simp]
lemma nat_val_zero (p : ℕ) : nat_valuation p 0 = ∞ := by
  simp [nat_valuation]
lemma nat_val_succ (q m : ℕ) : nat_valuation (q+2) (m+1) = if (m+1) % (q+2) ≠ 0 then 0 else succ (nat_valuation (q+2) ((m+1) / (q+2))) :=
  by simp [nat_valuation_add_two, nat_val_aux_succ]

namespace Int

def int_val (p : ℕ) (k : ℤ) : ℕ∪∞ :=
  nat_valuation p (natAbs k)

@[simp]
lemma int_val_uniformizer {p : ℕ} (gt1 : 1 < p) : int_val p p = 1 := by
  simp only [natAbs_cast, int_val]
  match p with
  | 0 =>
    apply False.elim
    apply Nat.not_lt_zero 1
    assumption
  | Nat.succ 0 =>
    apply False.elim
    apply Nat.lt_irrefl 1
    assumption
  | q+2 =>
    rw [nat_val_succ, Nat.mod_self, if_neg _]
    rw [Nat.div_self, nat_val_succ, if_pos, succ_zero]
    rw [Nat.mod_eq_of_lt]
    exact Nat.succ_ne_zero 0
    assumption
    exact lt_trans (Nat.lt_succ_self 0) gt1
    exact Ne.irrefl

@[simp]
lemma int_val_zero {p : ℕ} : int_val p 0 = ∞ := by simp [natAbs_cast, int_val]

lemma mod_mul (a b c : Nat) (h : a % c = 0) : (a * b) % c = 0 :=
by rw [Nat.mul_mod, h, zero_mul, Nat.zero_mod]

lemma nat_mul_div_assoc' (a b c : Nat) : c > 0 → a % c = 0 → a * b / c = a / c * b := by
  intro hc hmod
  apply nat_mul_left_cancel c _ _ (ne_of_gt hc)
  rw [Nat.mul_div_cancel' (Nat.dvd_of_mod_eq_zero _), ←mul_assoc, Nat.mul_div_cancel' (Nat.dvd_of_mod_eq_zero hmod)]
  exact mod_mul a b c hmod

lemma nat_mul_div_assoc (a b c : Nat) : c > 0 → b % c = 0 → a * b / c = a * (b / c) := by
  intro hc hmod
  rw [mul_comm, nat_mul_div_assoc' b a c hc hmod, mul_comm]

lemma nat_val_aux'_mul_eq_add (p : ℕ) (prime : Nat.Prime p) (hp : 1 < p := prime.one_lt) (a b : ℕ)
  (ha : 0 < a) (hb : 0 < b) :
  nat_valuation_aux' p hp (a * b) (Nat.mul_pos ha hb) = nat_valuation_aux' p hp a ha + nat_valuation_aux' p hp b hb := by
  have general (n : ℕ) : ∀ c d hc hd, c + d ≤ n → nat_valuation_aux' p hp (c * d) (Nat.mul_pos hc hd) = nat_valuation_aux' p hp c hc + nat_valuation_aux' p hp d hd := by
    induction n with
    | zero =>
      intro c d hc hd h_sum
      rw [Nat.eq_zero_of_add_eq_zero_right (Nat.eq_zero_of_le_zero h_sum)] at hc
      exact (lt_irrefl 0 hc).elim
    | succ n ih =>
      intro c d hc hd h_sum
      cases c with
      | zero => cases hc
      | succ c => cases d with
        | zero => cases hd
        | succ d =>
          match Nat.le.dest (Nat.succ_le_of_lt prime.one_lt) with
          | ⟨q, hq⟩ =>
            rw [(show Nat.succ 1 = 2 by rfl), Nat.add_comm] at hq
            have mul_s_s : c.succ * d.succ = (c * d + c + d).succ := by simp [Nat.succ_mul, Nat.mul_succ, Nat.add_succ]
            simp only [←hq, mul_s_s, nat_valuation_add_two, nat_valuation_aux]
            simp only [hq, (show c * d + c + d + 1 = (c + 1) * (d + 1) by ring)]
            cases Nat.eq_zero_or_pos ((c + 1) * (d + 1) % p) with
            | inl h =>
              have hh : (c + 1) % p = 0 ∨(d + 1) % p = 0 := sorry
              cases  hh with
              | inl h' =>
                subst hq
                rw [nat_valuation_aux'_of_dvd _ _ _ _ h', succ_add]
                have sum_le_n : (c + 1) / (q + 2) + (d + 1) ≤ n := by
                  apply Nat.le_of_lt_succ
                  apply lt_of_lt_of_le _ h_sum
                  apply Nat.add_lt_add_right
                  apply Nat.div_lt_self _ prime.one_lt
                  rw [Nat.add_comm]
                  apply Nat.lt_add_right 0 1 c (Nat.lt_succ_self 0)
                rw [←ih ((c + 1) / (q + 2)) (d + 1) _ _ sum_le_n]
                have hey := nat_mul_div_assoc' (c+1) (d+1) (q+2) (lt_trans (Nat.lt_succ_self 0) prime.one_lt) h'
                simp only [hey.symm, mul_s_s.symm]
                apply nat_valuation_aux'_of_dvd (q+2) hp ((c+1) * (d+1)) _ h
              | inr h' =>
                subst hq
                rw [nat_valuation_aux'_of_dvd _ _ _ _ h', add_succ]
                have sum_le_n : (c + 1) + (d + 1) / (q + 2) ≤ n := by
                  apply Nat.le_of_lt_succ
                  apply lt_of_lt_of_le _ h_sum
                  apply Nat.add_lt_add_left
                  apply Nat.div_lt_self _ prime.one_lt
                  rw [Nat.add_comm]
                  apply Nat.lt_add_right 0 1 d (Nat.lt_succ_self 0)
                rw [←ih (c + 1) ((d + 1) / (q + 2)) _ _ sum_le_n]
                have hey := nat_mul_div_assoc (c+1) (d+1) (q+2) (lt_trans (Nat.lt_succ_self 0) prime.one_lt) h'
                simp only [hey.symm, mul_s_s.symm]
                apply nat_valuation_aux'_of_dvd (q+2) hp ((c+1) * (d+1)) _ h
            | inr h =>
              have hc := ndiv_mul_left _ _ _ (ne_of_gt h)
              have hd := ndiv_mul_right _ _ _ (ne_of_gt h)
              simp [nat_valuation_aux'_of_not_dvd _ _ _ _ hc, nat_valuation_aux'_of_not_dvd _ _ _ _ hd]
              simp [←mul_s_s, nat_valuation_aux'_of_not_dvd _ _ _ _ (ne_of_gt h)]
  apply general (a + b) a b ha hb (le_refl _)

lemma nat_val_aux_mul_eq_add (p : ℕ) (prime : Nat.Prime p) (hp : 1 < p := prime.one_lt) (a b : ℕ) :
  nat_valuation_aux p hp (a * b) = nat_valuation_aux p hp a + nat_valuation_aux p hp b := by
cases a with
  | zero => simp [nat_valuation_aux]
  | succ a => cases b with
    | zero => simp [nat_valuation_aux]
    | succ b =>
      exact nat_val_aux'_mul_eq_add p prime prime.one_lt a.succ b.succ _ _

lemma nat_val_mul_eq_add (p : ℕ) (prime : Nat.Prime p) (a b : ℕ) :
  nat_valuation p (a * b) = nat_valuation p a + nat_valuation p b := by
convert nat_val_aux_mul_eq_add p prime prime.one_lt a b <;>
ext <;>
rw [(nat_valuation_of_one_lt p _ prime.one_lt)]

lemma int_val_mul_eq_add {p : ℕ} (prime : Nat.Prime p) (a b : ℤ) :
  int_val p (a * b) = int_val p a + int_val p b := by
  simp [int_val, natAbs_mul]
  exact nat_val_mul_eq_add p prime (natAbs a) (natAbs b)

lemma nat_val_add_eq_min (p a b : ℕ) (h : nat_valuation p a < nat_valuation p b) :
  nat_valuation p (a + b) = nat_valuation p a := by sorry

lemma nat_val_add_ge_min (p a b : ℕ) : nat_valuation p (a + b) ≥ min (nat_valuation p a) (nat_valuation p b) := by
  cases lt_trichotomy (nat_valuation p a) (nat_valuation p b) with -- TODO use rcases
  | inl h =>
    simp only [min, if_pos (le_of_lt h)]
    exact le_of_eq (nat_val_add_eq_min p a b h).symm
  | inr h => cases h with
    | inl h =>
      simp only [min, if_pos (le_of_eq h)]
      sorry
    | inr h =>
      simp only [add_comm a b, min, if_neg (not_le_of_lt h)]
      exact le_of_eq (nat_val_add_eq_min p b a h).symm

--lemma natAbs_add (a b : ℤ) : natAbs (a + b) = max (natAbs a) (natAbs b) - min (natAbs a) (natAbs b) := by sorry

lemma natAbs_add (a b : ℤ) : natAbs (a + b) = max (natAbs a) (natAbs b) - min (natAbs a) (natAbs b) := by sorry

lemma int_val_add_ge_min (p : ℕ) (a b : ℤ) : int_val p (a + b) ≥ min (int_val p a) (int_val p b) := by
  simp [int_val, natAbs_add]
  -- exact nat_val_add_ge_min p (natAbs a) (natAbs b)
  sorry

lemma int_val_add_eq_min (p : ℕ) (a b : ℤ) (h : int_val p a < int_val p b) :
  int_val p (a + b) = int_val p a := by sorry

@[simp]
lemma int_val_eq_top_iff_zero {p : ℕ} (gt1 : 1 < p) (a : ℤ) : int_val p a = ∞ ↔ a = 0 := by
  apply Iff.intro
  . intro hval
    simp [int_val, nat_valuation] at hval
    cases abs_a : (natAbs a) with
    | zero => exact natAbs_eq_zero.1 abs_a
    | succ n =>
      cases hp : p with
      | zero =>
        rw [hp] at gt1
        apply False.elim ((of_decide_eq_true rfl : ¬1 < 0) gt1)
      | succ p' =>
        cases hp' : p' with
        | zero =>
          rw [hp, hp'] at gt1
          apply False.elim ((of_decide_eq_true rfl : ¬1 < 1) gt1)
        | succ n =>
          simp [hp, hp', abs_a, nat_valuation_aux, nat_valuation_aux'] at hval
  . intro ha
    simp [ha, int_val, nat_valuation]

def primeVal {p : ℕ} (hp : Nat.Prime p) : SurjVal (p : ℤ) := {
  v := int_val p
  v_uniformizer' := int_val_uniformizer hp.one_lt
  v_mul_eq_add_v' := int_val_mul_eq_add hp
  v_add_ge_min_v' := int_val_add_ge_min p
  v_eq_top_iff_zero' := int_val_eq_top_iff_zero hp.one_lt }

def decr_val_p (p : ℕ) (k : ℤ) : ℤ :=
  if k % p == 0 then k / p else k

def sub_val_p (p : ℕ) (val : ℤ → ℕ∪∞) (n : ℕ) (k : ℤ) : ℤ :=
  k / (p ^ ((min (n : ℕ∪∞) (val k)).to_nat sorry) : ℕ)

@[simp]
lemma nat_valuation_eq_zero_iff {p : ℕ} (hp : 1 < p) {k : ℕ} : nat_valuation p k = 0 ↔ k % p ≠ 0 :=
by
  have := nat_val_aux_succ
  simp only [nat_valuation, ne_eq]
  aesop
  -- change (Enat.succ _ = 0) at a -- TODO doesn't work

@[simp]
lemma int_valuation_eq_zero_iff {p : ℕ} {k : ℤ} (hp : 1 < p) : int_val p k = 0 ↔ k % p ≠ 0 :=
by
  simp [int_val]
  rw [nat_valuation_eq_zero_iff hp]
  rw [not_iff_not]
  aesop
  . cases k
    . aesop
      exact eq_zero_of_natAbs_eq_zero a
    . aesop
      rw [← Int.natAbs_eq_zero]
      sorry
  sorry

@[simp]
lemma primeVal_eq_zero_iff {p : ℕ} {k : ℤ} (hp : Nat.Prime p) : primeVal hp k = 0 ↔ k % p ≠ 0 :=
by rw [primeVal, int_valuation_eq_zero_iff hp.one_lt]

lemma zero_valtn_decr_p {p : ℕ} {k : ℤ} {hp : Nat.Prime p} (h : primeVal hp k = 0) :
  decr_val_p p k = k :=
by
  simp [decr_val_p] at *
  aesop

def norm_repr_p (p : ℕ) (x : ℤ) : ℤ := x % (p : ℤ)

def modulo (x : ℤ) (p : ℕ) := x % (p:ℤ)

def inv_mod (x : ℤ) (p : ℕ) := gcdA x p

def count_roots_cubic_aux (a b c d : ℤ) (p : ℕ) (x : ℕ) : ℕ := match x with
  | Nat.zero => if d = 0 then 1 else 0
  | Nat.succ x' => (if (a * (x^3 : ℕ) + b * (x^2 : ℕ) + c * x + d) % (p : ℤ) = 0 then 1 else 0) + count_roots_cubic_aux a b c d p x'

def count_roots_cubic (a b c d : ℤ) (p : ℕ) : ℕ :=
  count_roots_cubic_aux (modulo a p) (modulo b p) (modulo c p) (modulo d p) p (p - 1)

def primeEVR {p : ℕ} (hp : Nat.Prime p) : EnatValRing (p : ℤ) := {
  valtn := primeVal hp
  decr_val := decr_val_p p
  -- sub_val := sub_val_p p (primeVal hp).v
  -- sub_val_eq := sorry
  zero_valtn_decr := zero_valtn_decr_p -- todo we really shouldn't need this!
  pos_valtn_decr := sorry
  residue_char := p
  norm_repr := (. % p)
  norm_repr_spec := by
    intro r
    simp [pos_iff_ne_zero, Int.sub_emod]
  inv_mod := (inv_mod . p)
  inv_mod_spec := by
    intro r h
    simp [inv_mod, pos_iff_ne_zero, Int.sub_emod]
    rw [Int.emod_emod]
    rw [Int.emod_emod] -- TODO why doesn't simp do this?
    sorry
  inv_mod_spec' := sorry
  inv_mod_spec'' := sorry

  pth_root := id
  pth_root_spec := by
    right
    intro r
    simp [inv_mod, pos_iff_ne_zero, Int.sub_emod]
    rw [Int.emod_emod]
    rw [Int.emod_emod] -- TODO why doesn't simp do this?
    rw [←Int.sub_emod]
    sorry -- needs fermat's little theorem

  count_roots_cubic :=
    -- TODO fix this, should we way quicker to count roots, probably in cohen
    (Int.count_roots_cubic . . . . p)
  -- count_roots_cubic_spec := sorry

  quad_roots_in_residue_field := fun a b c => Int.quad_root_in_ZpZ a b c p }

#eval (primeEVR (sorry : Nat.Prime 2)).valtn 4
#eval (primeEVR (sorry : Nat.Prime 2)).norm_repr 4
#eval (primeEVR (sorry : Nat.Prime 2)).decr_val 4
#eval (primeEVR (sorry : Nat.Prime 3)).inv_mod 2
#eval (primeEVR (sorry : Nat.Prime 3)).pth_root 2
#eval (primeEVR (sorry : Nat.Prime 3)).count_roots_cubic 1 0 2 0
#eval (primeEVR (sorry : Nat.Prime 3)).quad_roots_in_residue_field 1 0 1

def has_double_root (a b c : ℤ) {p : ℕ} (hp : Nat.Prime p) :=
  let v_p := (primeEVR hp).valtn.v
  v_p a = 0 ∧ v_p (b ^ 2 - 4 * a * c) > 0

def double_root (a b c : ℤ) (p : ℕ) :=
  -- dbg_trace (a,b,c)
  if p = 2 then
    modulo c 2
  else
    modulo (-b * inv_mod (2 * a) p) p

lemma val_poly_of_double_root {p : ℕ} (hp : Nat.Prime p) (a b c : ℤ)
  (H : has_double_root a b c hp) :
  (primeEVR hp).valtn (a * (double_root a b c p)^2 + b * (double_root a b c p) + c) > 0 ∧
  (primeEVR hp).valtn (2*a*(double_root a b c p) + b) > 0 := by sorry

end Int

-- #lint


universe u
variable {α : Sort u} {p : α → Prop}

@[simp]
theorem Subtype.coe_mk  (x : α) (h : p x) : (Subtype.mk x h).val = x :=
 rfl

example (x : Nat) (h : x > 0) : (Subtype.mk x h).val = x := by
  simp

set_option trace.Meta.Tactic.simp.discharge true
example : True := by simp


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

/-!
# Differential objects in a category.

A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.

We build the category of differential objects, and some basic constructions
such as the forgetful functor, zero morphisms and zero objects, and the shift functor
on differential objects.
-/

open category_theory.limits

universes v u

namespace category_theory

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

-- TODO: generaize to `has_shift C A` for an arbitrary `[add_monoid A]` `[has_one A]`.
variables [has_zero_morphisms C] [has_shift C ℤ]

/--
A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.
-/
@[nolint has_inhabited_instance]
structure differential_object :=
(X : C)
(d : X ⟶ X⟦1⟧)
(d_squared' : d ≫ d⟦(1:ℤ)⟧' = 0 . obviously)

restate_axiom differential_object.d_squared'
attribute [simp] differential_object.d_squared

variables {C}

namespace differential_object

/--
A morphism of differential objects is a morphism commuting with the differentials.
-/
@[ext, nolint has_inhabited_instance]
structure hom (X Y : differential_object C) :=
(f : X.X ⟶ Y.X)
(comm' : X.d ≫ f⟦1⟧' = f ≫ Y.d . obviously)

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm

namespace hom

/-- The identity morphism of a differential object. -/
@[simps]
def id (X : differential_object C) : hom X X :=
{ f := 𝟙 X.X }

/-- The composition of morphisms of differential objects. -/
@[simps]
def comp {X Y Z : differential_object C} (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ f := f.f ≫ g.f, }

end hom

instance category_of_differential_objects : category (differential_object C) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z f g, hom.comp f g, }

@[simp]

@[simp]
lemma comp_f {X Y Z : differential_object C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).f = f.f ≫ g.f :=
rfl

@[simp]
lemma eq_to_hom_f {X Y : differential_object C} (h : X = Y) :
  hom.f (eq_to_hom h) = eq_to_hom (congr_arg _ h) :=
by { subst h, rw [eq_to_hom_refl, eq_to_hom_refl], refl }

variables (C)

/-- The forgetful functor taking a differential object to its underlying object. -/
def forget : (differential_object C) ⥤ C :=
{ obj := λ X, X.X,
  map := λ X Y f, f.f, }

instance forget_faithful : faithful (forget C) :=
{ }

instance has_zero_morphisms : has_zero_morphisms (differential_object C) :=
{ has_zero := λ X Y,
  ⟨{ f := 0 }⟩}

variables {C}

@[simp]
lemma zero_f (P Q : differential_object C) : (0 : P ⟶ Q).f = 0 := rfl

/--
An isomorphism of differential objects gives an isomorphism of the underlying objects.
-/
@[simps] def iso_app {X Y : differential_object C} (f : X ≅ Y) : X.X ≅ Y.X :=
⟨f.hom.f, f.inv.f, by { dsimp, rw [← comp_f, iso.hom_inv_id, id_f] },
  by { dsimp, rw [← comp_f, iso.inv_hom_id, id_f] }⟩

@[simp] lemma iso_app_refl (X : differential_object C) : iso_app (iso.refl X) = iso.refl X.X := rfl
@[simp] lemma iso_app_symm {X Y : differential_object C} (f : X ≅ Y) :
  iso_app f.symm = (iso_app f).symm := rfl
@[simp] lemma iso_app_trans {X Y Z : differential_object C} (f : X ≅ Y) (g : Y ≅ Z) :
  iso_app (f ≪≫ g) = iso_app f ≪≫ iso_app g := rfl

/-- An isomorphism of differential objects can be constructed
from an isomorphism of the underlying objects that commutes with the differentials. -/
@[simps] def mk_iso {X Y : differential_object C}
  (f : X.X ≅ Y.X) (hf : X.d ≫ f.hom⟦1⟧' = f.hom ≫ Y.d) : X ≅ Y :=
{ hom := ⟨f.hom, hf⟩,
  inv := ⟨f.inv, by { dsimp, rw [← functor.map_iso_inv, iso.comp_inv_eq, category.assoc,
    iso.eq_inv_comp, functor.map_iso_hom, hf] }⟩,
  hom_inv_id' := by { ext1, dsimp, exact f.hom_inv_id },
  inv_hom_id' := by { ext1, dsimp, exact f.inv_hom_id } }

end differential_object

namespace functor

universes v' u'
variables (D : Type u') [category.{v'} D]
variables [has_zero_morphisms D] [has_shift D ℤ]

/--
A functor `F : C ⥤ D` which commutes with shift functors on `C` and `D` and preserves zero morphisms
can be lifted to a functor `differential_object C ⥤ differential_object D`.
-/
@[simps]
def map_differential_object (F : C ⥤ D)
  (η : (shift_functor C (1:ℤ)).comp F ⟶ F.comp (shift_functor D (1:ℤ)))
  (hF : ∀ c c', F.map (0 : c ⟶ c') = 0) :
  differential_object C ⥤ differential_object D :=
{ obj := λ X, { X := F.obj X.X,
    d := F.map X.d ≫ η.app X.X,
    d_squared' := begin
      rw [functor.map_comp, ← functor.comp_map F (shift_functor D (1:ℤ))],
      slice_lhs 2 3 { rw [← η.naturality X.d] },
      rw [functor.comp_map],
      slice_lhs 1 2 { rw [← F.map_comp, X.d_squared, hF] },
      rw [zero_comp, zero_comp],
    end },
  map := λ X Y f, { f := F.map f.f,
    comm' := begin
      dsimp,
      slice_lhs 2 3 { rw [← functor.comp_map F (shift_functor D (1:ℤ)), ← η.naturality f.f] },
      slice_lhs 1 2 { rw [functor.comp_map, ← F.map_comp, f.comm, F.map_comp] },
      rw [category.assoc]
    end },
  map_id' := by { intros, ext, simp },
  map_comp' := by { intros, ext, simp }, }

end functor

end category_theory

namespace category_theory

namespace differential_object

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

variables [has_zero_object C] [has_zero_morphisms C] [has_shift C ℤ]

open_locale zero_object

instance has_zero_object : has_zero_object (differential_object C) :=
{ zero :=
  { X := (0 : C),
    d := 0, },
  unique_to := λ X, ⟨⟨{ f := 0 }⟩, λ f, (by ext)⟩,
  unique_from := λ X, ⟨⟨{ f := 0 }⟩, λ f, (by ext)⟩, }

end differential_object

namespace differential_object

variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_zero_morphisms C] [has_shift C ℤ]

instance concrete_category_of_differential_objects :
  concrete_category (differential_object C) :=
{ forget := forget C ⋙ category_theory.forget C }

instance : has_forget₂ (differential_object C) C :=
{ forget₂ := forget C }

end differential_object

/-! The category of differential objects itself has a shift functor. -/
namespace differential_object

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

noncomputable theory

/-- The shift functor on `differential_object C`. -/
@[simps]
def shift_functor (n : ℤ) : differential_object C ⥤ differential_object C :=
{ obj := λ X,
  { X := X.X⟦n⟧,
    d := X.d⟦n⟧' ≫ (shift_comm _ _ _).hom,
    d_squared' := by rw [functor.map_comp, category.assoc, shift_comm_hom_comp_assoc,
        ←functor.map_comp_assoc, X.d_squared, is_equivalence_preserves_zero_morphisms, zero_comp] },
  map := λ X Y f,
  { f := f.f⟦n⟧',
    comm' := by { dsimp, rw [category.assoc, shift_comm_hom_comp, ← functor.map_comp_assoc,
      f.comm, functor.map_comp_assoc], }, },
  map_id' := by { intros X, ext1, dsimp, rw functor.map_id },
  map_comp' := by { intros X Y Z f g, ext1, dsimp, rw functor.map_comp } }

local attribute [instance] endofunctor_monoidal_category discrete.add_monoidal
local attribute [reducible] endofunctor_monoidal_category discrete.add_monoidal shift_comm

/-- The shift functor on `differential_object C` is additive. -/
@[simps] def shift_functor_add (m n : ℤ) :
  shift_functor C (m + n) ≅ shift_functor C m ⋙ shift_functor C n :=
begin
  refine nat_iso.of_components (λ X, mk_iso (shift_add X.X _ _) _) _,
  { dsimp,
    simp only [obj_μ_app, μ_naturality_assoc, μ_naturalityₗ_assoc, μ_inv_hom_app_assoc,
      category.assoc, obj_μ_inv_app, functor.map_comp, μ_inv_naturalityᵣ_assoc],
    simp [opaque_eq_to_iso] },
  { intros X Y f, ext, dsimp, exact nat_trans.naturality _ _ }
end

/-- The shift by zero is naturally isomorphic to the identity. -/
@[simps]
def shift_ε : 𝟭 (differential_object C) ≅ shift_functor C 0 :=
begin
  refine nat_iso.of_components (λ X, mk_iso ((shift_monoidal_functor C ℤ).ε_iso.app X.X) _) _,
  { dsimp, simp, dsimp, simp },
  { introv, ext, dsimp, simp }
end

instance : has_shift (differential_object C) ℤ :=
has_shift_mk _ _
{ F := shift_functor C,
  ε := shift_ε C,
  μ := λ m n, (shift_functor_add C m n).symm }

end differential_object

end category_theory


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

! This file was ported from Lean 3 source module control.ulift
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/

/-!
# Monadic instances for `ulift` and `plift`

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

In this file we define `monad` and `is_lawful_monad` instances on `plift` and `ulift`. -/

universe u v

namespace PLift

variable {α : Sort u} {β : Sort v}

#print PLift.map /-
/-- Functorial action. -/
protected def map (f : α → β) (a : PLift α) : PLift β :=
  PLift.up (f a.down)
#align plift.map PLift.map
-/

#print PLift.map_up /-
@[simp]
theorem map_up (f : α → β) (a : α) : (PLift.up a).map f = PLift.up (f a) :=
  rfl
#align plift.map_up PLift.map_up
-/

#print PLift.pure /-
/-- Embedding of pure values. -/
@[simp]
protected def pure : α → PLift α :=
  up
#align plift.pure PLift.pure
-/

/- warning: plift.seq -> PLift.seq is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}}, (PLift.{imax u1 u2} (α -> β)) -> (PLift.{u1} α) -> (PLift.{u2} β)
but is expected to have type
  forall {α : Sort.{u1}} {β : Sort.{u2}}, (PLift.{imax u1 u2} (α -> β)) -> (Unit -> (PLift.{u1} α)) -> (PLift.{u2} β)
Case conversion may be inaccurate. Consider using '#align plift.seq PLift.seqₓ'. -/
/-- Applicative sequencing. -/
protected def seq (f : PLift (α → β)) (x : PLift α) : PLift β :=
  PLift.up (f.down x.down)
#align plift.seq PLift.seq

#print PLift.seq_up /-
@[simp]
theorem seq_up (f : α → β) (x : α) : (PLift.up f).seq (PLift.up x) = PLift.up (f x) :=
  rfl
#align plift.seq_up PLift.seq_up
-/

#print PLift.bind /-
/-- Monadic bind. -/
protected def bind (a : PLift α) (f : α → PLift β) : PLift β :=
  f a.down
#align plift.bind PLift.bind
-/

#print PLift.bind_up /-
@[simp]
theorem bind_up (a : α) (f : α → PLift β) : (PLift.up a).bind f = f a :=
  rfl
#align plift.bind_up PLift.bind_up
-/

instance : Monad PLift where
  map := @PLift.map
  pure := @PLift.pure
  seq := @PLift.seq
  bind := @PLift.bind

instance : LawfulFunctor PLift where
  id_map := fun α ⟨x⟩ => rfl
  comp_map := fun α β γ g h ⟨x⟩ => rfl

instance : LawfulApplicative PLift
    where
  pure_seq := fun α β g ⟨x⟩ => rfl
  map_pure α β g x := rfl
  seq_pure := fun α β ⟨g⟩ x => rfl
  seq_assoc := fun α β γ ⟨x⟩ ⟨g⟩ ⟨h⟩ => rfl

instance : LawfulMonad PLift
    where
  bind_pure_comp_eq_map := fun α β f ⟨x⟩ => rfl
  bind_map_eq_seq := fun α β ⟨a⟩ ⟨b⟩ => rfl
  pure_bind α β x f := rfl
  bind_assoc := fun α β γ ⟨x⟩ f g => rfl

#print PLift.rec.constant /-
@[simp]
theorem rec.constant {α : Sort u} {β : Type v} (b : β) :
    (@PLift.rec α (fun _ => β) fun _ => b) = fun _ => b :=
  funext fun x => PLift.casesOn x fun a => Eq.refl (PLift.rec (fun a' => b) { down := a })
#align plift.rec.constant PLift.rec.constant
-/

end PLift

namespace ULift

variable {α : Type u} {β : Type v}

/- warning: ulift.map -> ULift.map is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u}} {β : Type.{v}}, (α -> β) -> (ULift.{u_1, u} α) -> (ULift.{u_2, v} β)
but is expected to have type
  forall {α : Type.{u}} {β : Type.{v}}, (α -> β) -> (ULift.{u_1, u} α) -> (ULift.{u, v} β)
Case conversion may be inaccurate. Consider using '#align ulift.map ULift.mapₓ'. -/
/-- Functorial action. -/
protected def map (f : α → β) (a : ULift α) : ULift β :=
  ULift.up (f a.down)
#align ulift.map ULift.map

/- warning: ulift.map_up -> ULift.map_up is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u}} {β : Type.{v}} (f : α -> β) (a : α), Eq.{succ (max v u_1)} (ULift.{u_1, v} β) (ULift.map.{u, v, u_2, u_1} α β f (ULift.up.{u_2, u} α a)) (ULift.up.{u_1, v} β (f a))
but is expected to have type
  forall {α : Type.{u}} {β : Type.{v}} (f : α -> β) (a : α), Eq.{max (succ u) (succ v)} (ULift.{u, v} β) (ULift.map.{u, v, u} α β f (ULift.up.{u, u} α a)) (ULift.up.{u, v} β (f a))
Case conversion may be inaccurate. Consider using '#align ulift.map_up ULift.map_upₓ'. -/
@[simp]
theorem map_up (f : α → β) (a : α) : (ULift.up a).map f = ULift.up (f a) :=
  rfl
#align ulift.map_up ULift.map_up

#print ULift.pure /-
/-- Embedding of pure values. -/
@[simp]
protected def pure : α → ULift α :=
  up
#align ulift.pure ULift.pure
-/

/- warning: ulift.seq -> ULift.seq is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}}, (ULift.{u3, max u1 u2} (α -> β)) -> (ULift.{u4, u1} α) -> (ULift.{u5, u2} β)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u3}}, (ULift.{u4, max u2 u3} (α -> β)) -> (Unit -> (ULift.{u5, u2} α)) -> (ULift.{u1, u3} β)
Case conversion may be inaccurate. Consider using '#align ulift.seq ULift.seqₓ'. -/
/-- Applicative sequencing. -/
protected def seq (f : ULift (α → β)) (x : ULift α) : ULift β :=
  ULift.up (f.down x.down)
#align ulift.seq ULift.seq

/- warning: ulift.seq_up -> ULift.seq_up is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β) (x : α), Eq.{succ (max u2 u3)} (ULift.{u3, u2} β) (ULift.seq.{u1, u2, u4, u5, u3} α β (ULift.up.{u4, max u1 u2} (α -> β) f) (ULift.up.{u5, u1} α x)) (ULift.up.{u3, u2} β (f x))
but is expected to have type
  forall {α : Type.{u4}} {β : Type.{u5}} (f : α -> β) (x : α), Eq.{max (succ u5) (succ u3)} (ULift.{u3, u5} β) (ULift.seq.{u3, u4, u5, u2, u1} α β (ULift.up.{u2, max u4 u5} (α -> β) f) (fun (x._@.Mathlib.Control.ULift._hyg.808 : Unit) => ULift.up.{u1, u4} α x)) (ULift.up.{u3, u5} β (f x))
Case conversion may be inaccurate. Consider using '#align ulift.seq_up ULift.seq_upₓ'. -/
@[simp]
theorem seq_up (f : α → β) (x : α) : (ULift.up f).seq (ULift.up x) = ULift.up (f x) :=
  rfl
#align ulift.seq_up ULift.seq_up

#print ULift.bind /-
/-- Monadic bind. -/
protected def bind (a : ULift α) (f : α → ULift β) : ULift β :=
  f a.down
#align ulift.bind ULift.bind
-/

/- warning: ulift.bind_up -> ULift.bind_up is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (a : α) (f : α -> (ULift.{u3, u2} β)), Eq.{succ (max u2 u3)} (ULift.{u3, u2} β) (ULift.bind.{u1, u2, u4, u3} α β (ULift.up.{u4, u1} α a) f) (f a)
but is expected to have type
  forall {α : Type.{u3}} {β : Type.{u4}} (a : α) (f : α -> (ULift.{u2, u4} β)), Eq.{max (succ u4) (succ u2)} (ULift.{u2, u4} β) (ULift.bind.{u3, u4, u1, u2} α β (ULift.up.{u1, u3} α a) f) (f a)
Case conversion may be inaccurate. Consider using '#align ulift.bind_up ULift.bind_upₓ'. -/
@[simp]
theorem bind_up (a : α) (f : α → ULift β) : (ULift.up a).bind f = f a :=
  rfl
#align ulift.bind_up ULift.bind_up

instance : Monad ULift where
  map := @ULift.map
  pure := @ULift.pure
  seq := @ULift.seq
  bind := @ULift.bind

instance : LawfulFunctor ULift where
  id_map := fun α ⟨x⟩ => rfl
  comp_map := fun α β γ g h ⟨x⟩ => rfl

instance : LawfulApplicative ULift
    where
  to_lawfulFunctor := ULift.lawfulFunctor
  pure_seq := fun α β g ⟨x⟩ => rfl
  map_pure α β g x := rfl
  seq_pure := fun α β ⟨g⟩ x => rfl
  seq_assoc := fun α β γ ⟨x⟩ ⟨g⟩ ⟨h⟩ => rfl

instance : LawfulMonad ULift
    where
  bind_pure_comp_eq_map := fun α β f ⟨x⟩ => rfl
  bind_map_eq_seq := fun α β ⟨a⟩ ⟨b⟩ => rfl
  pure_bind α β x f := by
    dsimp only [bind, pure, ULift.pure, ULift.bind]
    cases f x
    rfl
  bind_assoc := fun α β γ ⟨x⟩ f g =>
    by
    dsimp only [bind, pure, ULift.pure, ULift.bind]
    cases f x
    rfl

/- warning: ulift.rec.constant -> ULift.rec.constant is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Sort.{u2}} (b : β), Eq.{imax (succ (max u1 u3)) u2} (forall (n : ULift.{u3, u1} α), (fun (_x : ULift.{u3, u1} α) => β) n) (ULift.rec.{u2, u3, u1} α (fun (_x : ULift.{u3, u1} α) => β) (fun (_x : α) => b)) (fun (_x : ULift.{u3, u1} α) => b)
but is expected to have type
  forall {α : Type.{u2}} {β : Sort.{u3}} (b : β), Eq.{imax (max (succ u2) (succ u1)) u3} ((ULift.{u1, u2} α) -> β) (ULift.rec.{u3, u1, u2} α (fun (_x : ULift.{u1, u2} α) => β) (fun (_x : α) => b)) (fun (_x : ULift.{u1, u2} α) => b)
Case conversion may be inaccurate. Consider using '#align ulift.rec.constant ULift.rec.constantₓ'. -/
@[simp]
theorem rec.constant {α : Type u} {β : Sort v} (b : β) :
    (@ULift.rec α (fun _ => β) fun _ => b) = fun _ => b :=
  funext fun x => ULift.casesOn x fun a => Eq.refl (ULift.rec (fun a' => b) { down := a })
#align ulift.rec.constant ULift.rec.constant

end ULift