import .basic
import ..mynat.lt
import ..logic

namespace hidden

class ordered_myring (α : Type) extends myring α, has_le α :=
(decidable_le: ∀ a b: α, decidable (a ≤ b))
(le_add_right {a b} (c : α) : a ≤ b → a + c ≤ b + c)
(zero_le_mul {a b : α} : 0 ≤ a → 0 ≤ b → 0 ≤ a * b)
(le_trans {a} (b : α) {c}: a ≤ b → b ≤ c → a ≤ c)
(le_total_order (a b: α): a ≤ b ∨ b ≤ a)
(le_antisymm {a b: α}: a ≤ b → b ≤ a → a = b)

namespace ordered_myring

-- Add the [trans] attribute to le_trans
attribute [trans] le_trans

open myring

variables {α : Type} [ordered_myring α] (a b c d: α)

instance: ∀ a b: α, decidable (a ≤ b) := decidable_le

-- ≤ THEOREMS

theorem le_add_cancel_right : a ≤ b ↔ a + c ≤ b + c :=
begin
  apply iff.intro (le_add_right _),
  assume hacbc,
  have := le_add_right (-c) hacbc,
  repeat {rw [myring.add_assoc, myring.add_neg, myring.add_zero] at this},
  assumption,
end

theorem le_add_left {a b} (c : α): a ≤ b → c + a ≤ c + b :=
begin
  repeat {rw add_comm c},
  from le_add_right _,
end

theorem le_add_cancel_left: a ≤ b ↔ c + a ≤ c + b :=
begin
  repeat {rw add_comm c},
  rw le_add_cancel_right,
end

theorem le_neg_switch {a b : α}: a ≤ b → -b ≤ -a :=
begin
  assume hab,
  rw le_add_cancel_right _ _ (a + b),
  rw add_comm (-b),
  rw add_assoc,
  rw add_neg,
  rw add_zero,
  rw ←add_assoc,
  rw neg_add,
  rw zero_add,
  assumption,
end

theorem le_neg_switch_iff: a ≤ b ↔ -b ≤ -a :=
begin
  apply iff.intro le_neg_switch,
  assume hba,
  rw ←neg_neg a,
  rw ←neg_neg b,
  from le_neg_switch hba,
end

theorem zero_le_neg_switch_iff: 0 ≤ a ↔ -a ≤ 0 :=
begin
  conv {
    to_rhs,
    rw ←neg_zero,
  },
  rw le_neg_switch_iff,
end

theorem le_zero_neg_switch_iff: a ≤ 0 ↔ 0 ≤ -a :=
begin
  conv {
    to_rhs,
    rw ←neg_zero,
  },
  rw le_neg_switch_iff,
end

theorem le_neg_switch_neg: a ≤ -b ↔ b ≤ -a :=
begin
  conv {
    to_rhs,
    rw ←neg_neg b,
  },
  rw le_neg_switch_iff,
end

theorem square_nonneg: 0 ≤ a * a :=
begin
  cases le_total_order 0 a with ha ha, {
    from zero_le_mul ha ha,
  }, {
    rw ←neg_mul_neg a a,
    rw le_neg_switch_iff at ha,
    rw neg_zero at ha,
    apply zero_le_mul; assumption,
  },
end

theorem zero_le_one: (0 : α) ≤ 1 :=
begin
  rw ←mul_one (1: α),
  from square_nonneg _,
end

@[refl]
theorem le_refl: a ≤ a :=
begin
  cases le_total_order a a; assumption,
end

theorem wlogle
(p: α → α → Prop)
(hsymm: ∀ a b: α, p a b → p b a) : (∀ a b: α, a ≤ b → p a b) → (∀ a b: α, p a b) :=
begin
  assume hwlog,
  intros a b,
  cases le_total_order a b with hmn hnm, {
    from hwlog a b hmn,
  }, {
    from hsymm _ _ (hwlog b a hnm),
  },
end

theorem le_iff_diff_nonneg: a ≤ b ↔ 0 ≤ b - a :=
begin
  have := le_add_cancel_right a b (-a),
  rw add_neg at this,
  from this,
end

theorem le_add_comb: a ≤ b → c ≤ d → a + c ≤ b + d :=
begin
  assume hab hcd,
  transitivity (a + d), {
    from le_add_left _ hcd,
  }, {
    from le_add_right _ hab,
  },
end

theorem le_mul_nonneg_left: 0 ≤ c → a ≤ b → c * a ≤ c * b :=
begin
  assume h0z hxy,
  rw le_iff_diff_nonneg,
  rw ←mul_sub,
  apply zero_le_mul, {
    assumption,
  }, {
    rw ←le_iff_diff_nonneg,
    assumption,
  },
end

-- this is a succ le succ original. very good vintage
theorem le_mul_nonneg_right: 0 ≤ c → a ≤ b → a * c ≤ b * c :=
λ hc hab, by rw [mul_comm, mul_comm b]; from le_mul_nonneg_left _ _ _ hc hab

theorem le_mul_comb_nonneg
(hx : 0 ≤ a) (hz : 0 ≤ c) (hxy : a ≤ b) (hzw : c ≤ d):  a * c ≤ b * d :=
begin
  transitivity (b * c),
    apply le_mul_nonneg_right; assumption,
  apply le_mul_nonneg_left,
    transitivity a; assumption,
  assumption,
end

theorem le_mul_nonpos_left: c ≤ 0 → a ≤ b → c * b ≤ c * a :=
begin
  assume hz0 hxy,
  rw le_neg_switch_iff at hz0,
  rw le_neg_switch_iff at hxy,
  rw neg_zero at hz0,
  have := le_mul_nonneg_left _ _ _ hz0 hxy,
  repeat {rw neg_mul_neg at this},
  assumption,
end

theorem le_mul_nonpos_right : c ≤ 0 → a ≤ b → b * c ≤ a * c :=
λ hc hab, by rw [mul_comm, mul_comm a]; from le_mul_nonpos_left _ _ _ hc hab

-- < THEOREMS

def lt : α → α → Prop := λ a b, ¬(b ≤ a)
instance: has_lt α := ⟨lt⟩

-- probably not needed with `change` etc
theorem lt_iff_nle: a < b ↔ ¬b ≤ a := iff.rfl

theorem lt_impl_ne {a b : α}: a < b → a ≠ b :=
begin
  assume hxy hxeqy,
  subst hxeqy,
  apply hxy,
  refl,
end

theorem lt_nrefl: ¬(a < a) :=
begin
  assume h,
  from lt_impl_ne h rfl,
end

theorem lt_impl_le {a b : α}: a < b → a ≤ b :=
begin
  assume hxy,
  cases le_total_order a b with h h, {
    assumption,
  }, {
    contradiction,
  },
end

theorem lt_very_antisymmetric: ¬(a < b ∧ b < a) :=
begin
  assume h,
  cases h with hxy hyx,
  cases le_total_order a b; contradiction,
end

-- still works without decidability, so not the same at lt_impl_le
theorem lt_very_antisymm_impl {a b : α}: a < b → ¬(b < a) :=
begin
  assume hab hba,
  apply lt_very_antisymmetric a b,
  split; assumption,
end

theorem lt_neg_switch_iff: a < b ↔ -b < -a :=
iff_to_contrapositive (le_neg_switch_iff b a)

theorem zero_lt_neg_switch_iff: 0 < a ↔ -a < 0 :=
begin
  conv {
    to_rhs,
    rw ←neg_zero,
  },
  from lt_neg_switch_iff _ _,
end

theorem lt_zero_neg_switch_iff: a < 0 ↔ 0 < -a :=
begin
  conv {
    to_rhs,
    rw ←neg_zero,
  },
  from lt_neg_switch_iff _ _,
end

theorem lt_neg_switch_neg {a b : α}: a < -b ↔ b < -a :=
begin
  conv {
    to_rhs,
    rw ←neg_neg b,
  },
  from lt_neg_switch_iff _ _,
end

@[trans]
theorem lt_trans {a} (b : α) {c}: a < b → b < c → a < c :=
begin
  assume hab hbc hac,
  have := le_trans _ (lt_impl_le hab) (lt_impl_le hbc),
  have h := le_antisymm hac this,
  subst h,
  from lt_very_antisymmetric _ _ ⟨hbc, hab⟩,
end

theorem lt_add_cancel_left: a < b ↔ c + a < c + b :=
iff_to_contrapositive (le_add_cancel_left _ _ _)

theorem lt_add_cancel_right: a < b ↔ a + c < b + c :=
iff_to_contrapositive (le_add_cancel_right _ _ _)

theorem lt_iff_diff_pos: a < b ↔ 0 < b - a :=
begin
  have := lt_add_cancel_right a b (-a),
  rw add_neg at this,
  from this,
end

theorem lt_comb {a b c d: α}: a < b → c < d → a + c < b + d :=
begin
  assume hab hcd,
  transitivity a + d,
  rw ←lt_add_cancel_left,
  assumption,
  rw ←lt_add_cancel_right,
  assumption,
end

theorem lt_le_chain {a} (b : α) {c}: a < b → b ≤ c → a < c :=
begin
  assume hab hbc hac,
  have := le_trans _ (lt_impl_le hab) hbc,
  have h := le_antisymm this hac,
  subst h,
  clear hac this,
  have := le_antisymm (lt_impl_le hab) hbc,
  subst this,
  from lt_nrefl _ hab,
end

theorem le_lt_chain {a : α} (b : α) {c : α}: a ≤ b → b < c → a < c :=
begin
  assume hab hbc hac,
  have := le_trans _ hab (lt_impl_le hbc),
  have h := le_antisymm this hac,
  subst h,
  clear hac this,
  have := le_antisymm (lt_impl_le hbc) hab,
  subst this,
  from lt_nrefl _ hbc,
end

theorem lt_le_comb {a b c d: α}: a < b → c ≤ d → a + c < b + d :=
begin
  assume hab hcd,
  apply le_lt_chain (a + d),
  rw ←le_add_cancel_left,
  assumption,
  rw ←lt_add_cancel_right,
  assumption,
end

theorem le_lt_comb {a b c d: α}: a ≤ b → c < d → a + c < b + d :=
begin
  assume hab hcd,
  rw [add_comm, add_comm b],
  apply lt_le_comb; assumption,
end

-- worth a different type class?
-- condition is necessary since = makes
-- the trivial ring into an ordered ring
theorem nontrivial_zero_lt_one: (0: α) ≠ 1 → (0: α) < 1 :=
begin
  assume nontrivial h,
  from nontrivial (le_antisymm zero_le_one h),
end

theorem nontrivial_zero_lt_two: (0: α) ≠ 1 → (0: α) < 2 :=
begin
  assume nontrivial,
  change (0: α) < 1 + 1,
  rw ←add_zero (0: α),
  apply lt_comb; from nontrivial_zero_lt_one nontrivial,
end

-- Water
theorem nontrivial_zero_ne_two : (0 : α) ≠ 1 → (0 : α) ≠ 2 :=
begin
  assume nontrivial,
  apply lt_impl_ne,
  apply nontrivial_zero_lt_two,
  assumption,
end

-- Doesn't need ordering
theorem nontrivial_one_ne_two : (0 : α) ≠ 1 → (1 : α) ≠ 2 :=
begin
  sorry,
end

-- can't figure out hot to make decidability a typeclass thing
-- if we do a separate typeclass for decidably ordered rings
-- eg so we can do max/abs, move this there
theorem le_iff_lt_or_eq : a ≤ b ↔ a < b ∨ a = b :=
begin
  split, {
    assume hxy,
    by_cases h: b ≤ a, {
      right,
      from  le_antisymm hxy h,
    }, {
      left,
      assumption,
    },
  }, {
    assume h,
    cases h with h1 h2, {
      from lt_impl_le h1,
    }, {
      rw h2,
    },
  },
end

theorem lt_trichotomy : a = b ∨ a < b ∨ b < a :=
begin
  by_cases h: a ≤ b, {
    rw le_iff_lt_or_eq at h,
    cases h with h h, {
      right, left, assumption,
    }, {
      left, assumption,
    },
  }, {
    right, right, assumption,
  },
end

-- basically de Morgan
theorem lt_iff_le_and_neq : a < b ↔ a ≤ b ∧ a ≠ b :=
begin
  split, {
    assume h,
    split, {
      from lt_impl_le h,
    }, {
      from lt_impl_ne h,
    },
  }, {
    assume h,
    rw le_iff_lt_or_eq at h,
    cases h with h1 h2,
    cases h1 with h h, {
      assumption,
    }, {
      contradiction,
    },
  },
end

theorem le_iff_lt_impl_lt : a ≤ b ↔ ∀ c, b < c → a < c :=
begin
  split; assume h, {
    intros c hbc,
    apply le_lt_chain b; assumption,
  }, {
    by_contradiction hba,
    change b < a at hba,
    apply lt_nrefl a,
    apply h a hba,
  },
end

theorem le_iff_le_impl_le : a ≤ b ↔ ∀ c, b ≤ c → a ≤ c :=
begin
  split; assume h, {
    intros c hbc,
    transitivity b; assumption,
  }, {
    by_contradiction hab,
    apply hab,
    apply h b,
    refl,
  },
end

section abs_max

def max (a b: α): α :=
if a ≤ b then b else a

def min (a b: α): α :=
if a ≤ b then a else b

def abs (a: α) :=
max a (-a)

instance decidable_lt : ∀ a b: α, decidable (a < b) :=
λ a b, not.decidable

def sign
(a: α): α :=
if 0 < a then 1
  else if a < 0 then -1
    else 0

@[simp]
theorem max_self : max a a = a :=
by apply if_pos; refl

theorem le_impl_max_right
(hmn: a ≤ b): max a b = b :=
begin
  unfold max,
  rw if_pos hmn,
end

theorem le_impl_max_left
(hnm: b ≤ a): max a b = a :=
begin
  by_cases a ≤ b, {
    rw [le_antisymm h hnm, max_self],
  }, {
    unfold max,
    rw if_neg h,
  },
end

theorem lt_impl_max_right
(hmn: a < b): max a b = b :=
le_impl_max_right _ _ (lt_impl_le hmn)

theorem lt_impl_max_left
(hnm: b < a): max a b = a :=
le_impl_max_left _ _ (lt_impl_le hnm)

theorem le_iff_max : a ≤ b ↔ max a b = b :=
begin
  split; assume h, {
    from le_impl_max_right _ _ h,
  }, {
    by_cases hmn : a ≤ b,
      assumption,
    rw ←lt_iff_nle at hmn,
    rw lt_impl_max_left _ _ hmn at h,
    exfalso,
    from lt_impl_ne hmn h.symm,
  },
end

theorem max_comm : max a b = max b a :=
begin
  by_cases a ≤ b,
    rw [le_impl_max_right _ _ h, le_impl_max_left _ _ h],
  rw ←lt_iff_nle at h,
  rw [lt_impl_max_right _ _ h, lt_impl_max_left _ _ h],
end

theorem le_iff_max_reverse : b ≤ a ↔ max a b = a :=
begin
  rw max_comm,
  from le_iff_max _ _,
end

theorem le_max_right : b ≤ max a b :=
begin
  by_cases b ≤ a,
    have := (le_iff_max _ _).mp h,
    rw max_comm at this,
    rwa this,
  rw ←lt_iff_nle at h,
  rw lt_impl_max_right _ _ h,
end

theorem le_max_left : a ≤ max a b :=
by rw max_comm; from le_max_right _ _

instance : is_commutative α max := ⟨λ a b, max_comm _ _⟩

-- Max distributes over itself
theorem max_max : max a (max b c) = max (max a b) (max a c) :=
begin
  unfold max,
  by_cases hmmxnk: a ≤ (max b c); unfold max at hmmxnk, {
    rw if_pos hmmxnk,
    by_cases hnk: b ≤ c, {
      rw if_pos hnk,
      rw if_pos hnk at hmmxnk,
      repeat {rw if_pos hmmxnk},
      by_cases hmn: a ≤ b, {
        repeat {rw if_pos hmn},
        rw if_pos hnk,
      }, {
        repeat {rw if_neg hmn},
        rw if_pos hmmxnk,
      },
    }, {
      rw if_neg hnk,
      rw if_neg hnk at hmmxnk,
      repeat {rw if_pos hmmxnk},
      by_cases hmk: a ≤ c, {
        repeat {rw if_pos hmk},
        rw if_neg hnk,
      }, {
        repeat {rw if_neg hmk},
        have := max_comm,
        unfold max at this,
        rw this,
        rw if_pos hmmxnk,
      },
    },
  }, {
    rw if_neg hmmxnk,
    have hmk: ¬a ≤ c, {
      assume hmk,
      have := le_trans _ hmk (le_max_right b c),
      from hmmxnk this,
    },
    have hmn: ¬a ≤ b, {
      assume hmk,
      have := le_trans _ hmk (le_max_left b c),
      from hmmxnk this,
    },
    repeat {rw if_neg hmk <|> rw if_neg hmn},
    rw if_pos (le_refl a),
  },
end

theorem max_eq_either : max a b = a ∨ max a b = b :=
begin
  by_cases a ≤ b,
    right, rwa le_impl_max_right,
  left,
  rw ←lt_iff_nle at h,
  rwa lt_impl_max_left,
end

theorem max_assoc : max (max a b) c = max a (max b c) :=
begin
  by_cases a ≤ b, {
    rw le_impl_max_right _ _ h,
    have : a ≤ max b c,
      transitivity b,
        assumption,
      from le_max_left _ _,
    rw le_impl_max_right _ _ this,
  }, {
    rw ←lt_iff_nle at h,
    rw max_comm a b,
    rw le_impl_max_right _ _ (lt_impl_le h),
    by_cases h': a ≤ c, {
      rw le_impl_max_right _ _ h',
      have := le_trans _ (lt_impl_le h) h',
      rw le_impl_max_right _ _ this,
      rw le_impl_max_right _ _ h',
    }, {
      rw ←lt_iff_nle at h',
      rw max_comm a c,
      rw le_impl_max_right _ _ (lt_impl_le h'),
      cases max_eq_either b c with h h; rw h; clear h,
      rw max_comm a b,
      rw le_impl_max_right _ _ (lt_impl_le h),
      rw max_comm a c,
      rw le_impl_max_right _ _ (lt_impl_le h'),
    },
  },
end

instance : is_associative α max := ⟨λ a b c, max_assoc _ _ _⟩

theorem max_sum_le : max (a + c) (b + d) ≤ max a b + max c d :=
begin
  cases max_eq_either (a + c) (b + d) with h; rw h; clear h, {
    from le_add_comb _ _ _ _ (le_max_left _  _) (le_max_left _ _),
  }, {
    from le_add_comb _ _ _ _ (le_max_right _  _) (le_max_right _ _),
  },
end

-- yes it takes longer this way abut it's a matter of principle
theorem nonneg_mul_max : 0 ≤ a → a * max b c = max (a * b) (a * c) :=
begin
  assume h0m,
  revert b c,
  apply wlogle, {
    intros b c,
    assume h,
    rw max_comm c b,
    rw max_comm (a * c) (a * b),
    assumption,
  }, {
    intros b c,
    assume hnk,
    rw le_impl_max_right _ _ hnk,
    rw le_impl_max_right _ _ (le_mul_nonneg_left _ _ _ h0m hnk),
  },
end

theorem abs_neg : abs (-b) = abs b :=
begin
  unfold abs,
  rw neg_neg,
  from max_comm _ _,
end

-- Rename to abs_sub?
theorem abs_sub_switch : abs (a - b) = abs (b - a) :=
by rw [sub_def, ←abs_neg, neg_distr, neg_neg, add_comm, ←sub_def]

theorem abs_of_nonneg (h : 0 ≤ a): abs a = a :=
begin
  unfold abs,
  rw max_comm,
  rw ←le_iff_max,
  transitivity (0: α), {
    rw le_neg_switch_iff,
    rw neg_zero,
    rw neg_neg,
    assumption,
  }, {
    assumption,
  },
end

theorem abs_one : abs (1 : α) = 1 :=
begin
  apply abs_of_nonneg,
  exact zero_le_one,
end

theorem abs_of_pos : 0 < a → abs a = a :=
begin
  assume h,
  apply abs_of_nonneg,
  apply lt_impl_le,
  assumption,
end

theorem abs_of_neg : a < 0 → abs a = -a :=
begin
  assume ha0,
  rw ←abs_neg,
  rw lt_neg_switch_iff at ha0,
  rw neg_zero at ha0,
  rw abs_of_pos _ ha0,
end

theorem abs_of_nonpos : a ≤ 0 → abs a = -a :=
begin
  assume ha0,
  rw ←abs_neg,
  rw le_neg_switch_iff at ha0,
  rw neg_zero at ha0,
  rw abs_of_nonneg _ ha0,
end

theorem abs_nonneg : 0 ≤ abs a :=
begin
  by_cases h0a: 0 ≤ a, {
    rw abs_of_nonneg _ h0a,
    assumption,
  }, {
    rw ←abs_neg,
    change a < 0 at h0a,
    rw lt_neg_switch_iff at h0a,
    rw neg_zero at h0a,
    rw abs_of_pos _ h0a,
    apply lt_impl_le, assumption,
  },
end

private theorem abs_cancel_abs_mul_within: abs (abs a * b) = abs (a * b) :=
begin
  unfold abs,
  by_cases h: -a ≤ a,
    rw le_impl_max_left _ _ h,
  rw ←lt_iff_nle at h,
  rw [lt_impl_max_right _ _ h, max_comm, neg_mul, neg_neg],
end

-- Short lemma above avoids any casework
theorem abs_mul : abs (a * b) = abs a * abs b :=
begin
  have: abs a * abs b = abs (abs a * abs b),
    have : 0 ≤ abs a * abs b,
      rw ←zero_mul (0: α),
      apply le_mul_comb_nonneg, any_goals { refl },
        from abs_nonneg _,
        from abs_nonneg _,
      rw abs_of_nonneg _ this,
  rw this,
  rw [abs_cancel_abs_mul_within, mul_comm a (abs b), abs_cancel_abs_mul_within, mul_comm],
end

-- The following three theorems are practically equivalent, needs reorganising a bit
theorem abs_nonneg_mul : 0 ≤ a → ∀ b, a * abs b = abs (a * b) :=
begin
  assume h0m,
  intro b,
  conv {
    to_lhs,
    congr,
    rw ←abs_of_nonneg _ h0m,
  },
  rw abs_mul,
end

-- le_sqrt_nonneg?
-- theorem abs_le_square : -- abs a ≤ abs b ↔ a * a ≤ b * b :=
-- begin
--   split; assume h, {
--     have := le_mul_comb_nonneg _ _ _ _ (abs_nonneg _) (abs_nonneg _) h h,
--     rw [←abs_mul, ←abs_mul] at this,
--     rwa [abs_of_nonneg _ (square_nonneg a), abs_of_nonneg _ (square_nonneg b)] at this,
--   }, {
--     rw [←abs_of_nonneg _ (square_nonneg a), ←abs_of_nonneg _ (square_nonneg b)] at h,
--     rwa [abs_mul, abs_mul, ←le_sqrt_nonneg (abs_nonneg _) (abs_nonneg _)] at h,
--   },
-- end

theorem self_le_abs : a ≤ abs a := le_max_left _ _

theorem triangle_ineq : abs (a + b) ≤ abs a + abs b :=
begin
  unfold abs,
  rw neg_distr,
  from max_sum_le _ _ _ _,
end

theorem neg_max : -max a b = max (-a) (-b) :=
begin
  sorry,
end

theorem abs_abs : abs (abs a) = abs a :=
begin
  unfold abs,
  rw [max_comm, neg_max, neg_neg, max_comm (-a), max_self],
end

theorem triangle_ineq_sub : abs (abs a - abs b) ≤ abs (a - b) :=
begin
  sorry,
end

theorem abs_eq_plusminus : abs a = a ∨ abs a = -a := max_eq_either a (-a)

theorem abs_zero : abs (0: α) = 0 :=
begin
  cases abs_eq_plusminus (0: α) with h h, {
    assumption,
  }, {
    rw h,
    rw neg_zero,
  },
end

-- I renamed this because it's so handy to have `abs` at the front to help find it
theorem abs_zero_iff_zero : abs a = 0 ↔ a = 0 :=
begin
  split, tactic.swap, {
    assume hm0,
    rw hm0,
    rw abs_zero,
  }, {
    assume habs,
    unfold abs at habs,
    unfold max at habs,
    by_cases hmm: (a ≤ -a), {
      rw if_pos hmm at habs,
      apply add_cancel_right _ _ (-a),
      rw add_neg,
      rw zero_add,
      rw habs,
    }, {
      rw if_neg hmm at habs,
      assumption,
    },
  },
end

theorem sign_of_pos: 0 < a → sign a = 1 :=
begin
  assume h0a,
  unfold sign,
  rw if_pos h0a,
end

theorem sign_of_neg : a < 0 → sign a = -1 :=
begin
  assume ha0,
  unfold sign,
  rw if_neg (lt_very_antisymm_impl ha0),
  rw if_pos ha0,
end

theorem sign_zero : sign (0: α) = 0 :=
begin
  unfold sign,
  rw if_neg (lt_nrefl _),
  rw if_neg (lt_nrefl _),
end

theorem sign_mul_self_abs : a * sign a = abs a :=
begin
  by_cases h0m: 0 < a, {
    rw sign_of_pos _ h0m,
    rw mul_one,
    rw abs_of_pos _ h0m,
  }, {
    by_cases hm0: a < 0, {
      rw sign_of_neg _ hm0,
      rw mul_neg,
      rw mul_one,
      rw lt_add_cancel_right _ _ (-a) at hm0,
      rw add_neg at hm0,
      rw zero_add at hm0,
      rw ←abs_neg,
      rw abs_of_pos _ hm0,
    }, {
      cases lt_trichotomy 0 a, {
        rw ←h,
        rw zero_mul,
        rw abs_zero,
      }, {
        cases h; contradiction,
      },
    },
  },
end

theorem sign_zero_iff_zero : sign a = 0 ↔ a = 0 :=
begin
  split, {
    assume hsgnm,
    rw ←abs_zero_iff_zero,
    rw ←sign_mul_self_abs,
    rw hsgnm,
    rw mul_zero,
  }, {
    assume h, rw h,
    rw sign_zero,
  },
end

theorem sign_abs_mul : sign a * abs a = a :=
begin
  by_cases ha: 0 < a, {
    rw sign_of_pos _ ha,
    rw abs_of_pos _ ha,
    rw one_mul,
  }, {
    change ¬¬a ≤ 0 at ha,
    rw decidable.not_not_iff at ha,
    rw abs_of_nonpos _ ha,
    by_cases ha': a < 0, {
      rw sign_of_neg _ ha',
      rw neg_mul_neg,
      rw one_mul,
    }, {
      change ¬¬0 ≤ a at ha',
      rw decidable.not_not_iff at ha',
      have ha0 := le_antisymm ha ha',
      rw ha0,
      rw sign_zero,
      rw zero_mul,
    },
  },
end

theorem sign_neg : sign (-a) = -sign a :=
begin
  by_cases h0a: 0 < a, {
    rw sign_of_pos _ h0a,
    rw zero_lt_neg_switch_iff at h0a,
    rw sign_of_neg _ h0a,
  }, {
    unfold sign,
    rw if_neg h0a,
    rw zero_lt_neg_switch_iff at h0a,
    rw if_neg h0a,
    by_cases ha0: a < 0, {
      rw if_pos ha0,
      rw lt_zero_neg_switch_iff at ha0,
      rw if_pos ha0,
      rw neg_neg,
    }, {
      rw if_neg ha0,
      rw lt_zero_neg_switch_iff at ha0,
      rw if_neg ha0,
      rw neg_zero,
    },
  },
end

theorem zero_le_self_mul_sign : 0 ≤ a * sign a :=
begin
  rw sign_mul_self_abs,
  from abs_nonneg _,
end

theorem zero_lt_self_mul_sign : a ≠ 0 → 0 < a * sign a :=
begin
  assume han0,
  unfold sign,
  by_cases h0a: 0 < a, {
    rw if_pos h0a,
    rw mul_one,
    assumption,
  }, {
    rw if_neg h0a,
    by_cases ha0: a < 0, {
      rw if_pos ha0,
      rw mul_neg,
      rw mul_one,
      rw lt_neg_switch_iff,
      rw neg_neg,
      rw neg_zero,
      assumption,
    }, {
      exfalso,
      apply han0,
      apply le_antisymm, {
        from decidable.of_not_not h0a,
      }, {
        from decidable.of_not_not ha0,
      },
    },
  },
end

theorem zero_lt_sign_mul_self : a ≠ 0 → 0 < sign a * a :=
begin
  assume han0,
  rw mul_comm,
  apply zero_lt_self_mul_sign,
  assumption,
end

theorem abs_lt_iff_lt_both : abs a < b ↔ -b < a ∧ a < b :=
begin
  split; assume h, {
    split, {
      rw lt_neg_switch_iff,
      rw neg_neg,
      apply le_lt_chain (abs a), {
        rw ←abs_neg,
        from self_le_abs _,
      }, {
        assumption,
      },
    }, {
      apply le_lt_chain (abs a), {
        from self_le_abs _,
      }, {
        assumption,
      },
    },
  }, {
    cases (abs_eq_plusminus a) with habs habs; rw habs, {
      from h.right,
    }, {
      rw lt_neg_switch_iff,
      rw neg_neg,
      from h.left,
    },
  },
end

theorem abs_lt_left : abs a < b → -b < a :=
λ h, by rw abs_lt_iff_lt_both at h; from h.left

theorem abs_lt_right : abs a < b → a < b :=
λ h, by rw abs_lt_iff_lt_both at h; from h.right

theorem lt_abs_impl_lt_either : a < abs b → b < -a ∨ a < b :=
begin
  assume hab,
  cases abs_eq_plusminus b with h h, {
    rw ←h,
    right, assumption,
  }, {
    left,
    rw lt_neg_switch_iff,
    rw neg_neg,
    rw ←h,
    assumption,
  },
end

-- abs_diff refers to the pattern `abs (a - b) < c` which often shows up in analysis

theorem abs_diff_lt_left : abs (a - b) < c → b - c < a :=
begin
  assume h,
  have habs := abs_lt_left _ _ h,
  rw lt_add_cancel_left _ _ (-b),
  conv {
    congr, {
      change -b + (b + -c),
      rw ←add_assoc,
      rw neg_add,
      rw zero_add,
    }, {
      rw add_comm,
    },
  },
  from habs,
end

theorem abs_diff_lt_right :abs (a - b) < c → a < b + c :=
begin
  assume h,
  rw lt_neg_switch_iff,
  rw ←abs_neg at h,
  change abs (-(a + -b)) < c at h,
  rw neg_distr at h,
  rw neg_distr,
  from abs_diff_lt_left _ _ _ h,
end

open mynat

-- Should be somewhere else
def max_upto : mynat → (mynat → α) → α
| 0        f := f 0
| (succ M) f := max (f (succ M)) (max_upto M f)

theorem max_upto_ge_before {N n : mynat} (hnN : n ≤ N) (f  : mynat → α): f n ≤ max_upto N f :=
begin
  induction N with N hN,
    dsimp at *,
    have hn := mynat.le_zero hnN,
    subst hn,
    refl,
  change _ ≤ max (f (succ N)) (max_upto N f),
  rw mynat.le_iff_lt_or_eq at hnN,
  cases hnN with hlt heq, {
    rw ←le_iff_lt_succ at hlt,
    transitivity max_upto N f,
      apply hN,
      assumption,
    apply le_max_right,
  }, {
    subst heq,
    apply le_max_left,
  },
end

end abs_max

end ordered_myring

end hidden


import GMLInit.Data.Fin
import GMLInit.Data.List.Basic
import GMLInit.Data.List.HList
import GMLInit.Data.Nat

def LList (α) (n : Nat) := HList (List.replicate n α)

@[match_pattern] protected def LList.nil {α} : LList α 0 := HList.nil

@[match_pattern] protected def LList.cons {α n} (a : α) : LList α n → LList α (n+1) := HList.cons a

def List.toLList {α} : (xs : List α) → LList α xs.length
| [] => LList.nil
| x::xs => LList.cons x (toLList xs)

namespace LList

scoped infixr:67 " :: " => LList.cons
scoped syntax (name := llist) "[" term,* "]"  : term
scoped macro_rules (kind := llist)
  | `([ ])           => `(LList.nil)
  | `([ $a ])        => `(LList.cons $a LList.nil)
  | `([ $a, $as,* ]) => `(LList.cons $a [$as,*])

protected theorem cons_hcongr {α β} {n m} {a : α} {b : β} {as : LList α n} {bs : LList β m} : α = β → n = m → a ≅ b → as ≅ bs → LList.cons a as ≅ LList.cons b bs
| rfl, rfl, HEq.rfl, HEq.rfl => HEq.rfl

@[eliminator] protected def rec {α} {motive : (n : Nat) → LList α n → Sort _} (nil : motive 0 LList.nil) (cons : {n : Nat} → (a : α) → (as : LList α n) → motive n as → motive (n+1) (LList.cons a as))
: {n : Nat} → (as : LList α n) → motive n as
| 0, .nil => nil
| _+1, .cons a as => cons a as (LList.rec nil cons as)

protected def recOn {α n} (as : LList α n) {motive : (n : Nat) → LList α n → Sort _} (nil : motive 0 HList.nil) (cons : {n : Nat} → (a : α) → (as : LList α n) → motive n as → motive (n+1) (LList.cons a as))
: motive n as := LList.rec nil cons as

protected def casesOn {α n} (as : LList α n) {motive : (n : Nat) → LList α n → Sort _} (nil : motive 0 HList.nil) (cons : {n : Nat} → (a : α) → (as : LList α n) → motive (n+1) (LList.cons a as))
: motive n as := LList.rec nil (fun a as _ => cons a as) as

protected def append {α n} (as : LList α n) (bs : LList α m) : LList α (m + n) :=
show HList (List.replicate (m + n) α) from List.replicate_add α m n ▸ HList.append as bs

protected theorem nil_append {α m} (bs : LList α m) : LList.append [] bs = bs := rfl

protected theorem cons_append {α n m} (a : α) (as : LList α n) (bs : LList α m) : LList.append (a :: as) bs = a :: (LList.append as bs) := by
  apply eq_of_heq
  clean unfold LList.append LList.cons
  elim_casts
  rw [HList.cons_append]
  apply HList.cons_hcongr
  · reflexivity
  · rw [List.replicate_add]
  · reflexivity using (.≅.)
  · elim_casts
    reflexivity using (.≅.)

protected theorem append_nil {α n} (as : LList α n) : LList.append as [] ≅ as := by
  induction as with
  | nil => rw [LList.nil_append]
  | cons _ _ ih =>
    rw [LList.cons_append]
    apply LList.cons_hcongr
    · reflexivity
    · rw [Nat.zero_add]
    · reflexivity using (.≅.)
    · exact ih ..

protected theorem append_assoc {α l m n} (as : LList α l) (bs : LList α m) (cs : LList α n) : LList.append (LList.append as bs) cs ≅ LList.append as (LList.append bs cs) := by
  induction as with
  | nil => rw [LList.nil_append, LList.nil_append]
  | cons _ _ ih =>
    rw [LList.cons_append, LList.cons_append, LList.cons_append]
    apply LList.cons_hcongr
    · reflexivity
    · rw [Nat.add_assoc]
    · reflexivity using (.≅.)
    · exact ih ..

protected def mk {α} : {n : Nat} → (Fin n → α) → LList α n
| 0, _ => LList.nil
| _+1, v => v Fin.zero :: LList.mk fun i => v (Fin.succ i)

theorem mk_zero {α} (f : Fin 0 → α) : LList.mk f = LList.nil := rfl

theorem mk_succ {α n} (f : Fin (n+1) → α) : LList.mk f = f Fin.zero :: LList.mk fun i => f (Fin.succ i) := rfl

protected def eval {α} : {n : Nat} → LList α n → (i : Fin n) → α
| _+1, a::_, ⟨0, _⟩ => a
| _+1, _::as, ⟨i+1, hi⟩ => LList.eval as ⟨i, Nat.lt_of_succ_lt_succ hi⟩

theorem eval_cons_zero {α n} (a : α) (as : LList α n) : (a :: as).eval Fin.zero = a := by
  simp only [Fin.zero, LList.eval]

theorem eval_cons_succ {α n} (a : α) (as : LList α n) (i : Fin n) : (a :: as).eval (Fin.succ i) = as.eval i := by
  simp only [Fin.succ, LList.eval]
  apply congrArg
  apply Fin.eq
  rfl

def equiv (α n) : Equiv (LList α n) (Fin n → α) where
  fwd := LList.eval
  rev := LList.mk
  spec := by
    intros as f
    constr
    · intro h
      cases h
      induction as with
      | nil => rfl
      | cons a as ih =>
        rw [LList.mk_succ]
        rw [LList.eval_cons_zero]
        apply congrArg
        transitivity (LList.mk (LList.eval as))
        · apply congrArg
          funext i
          rw [LList.eval_cons_succ]
        · exact ih ..
    · intro h
      cases h
      induction n with
      | zero =>
        funext i
        cases i
        contradiction
      | succ n ih =>
        funext i
        rw [LList.mk_succ]
        cases i using Fin.casesIndOn with
        | zero => rw [LList.eval_cons_zero]
        | succ i => rw [LList.eval_cons_succ, ih]

end LList


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Scott Morrison

! This file was ported from Lean 3 source module data.finset.functor
! leanprover-community/mathlib commit bcfa726826abd57587355b4b5b7e78ad6527b7e4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finset.Lattice
import Mathlib.Data.Finset.NAry
import Mathlib.Data.Multiset.Functor

/-!
# Functoriality of `Finset`

This file defines the functor structure of `Finset`.

## TODO

Currently, all instances are classical because the functor classes want to run over all types. If
instead we could state that a functor is lawful/applicative/traversable... between two given types,
then we could provide the instances for types with decidable equality.
-/

universe u

open Function

namespace Finset

/-! ### Functor -/

section Functor

variable {α β : Type u} [∀ P, Decidable P]

/-- Because `Finset.image` requires a `DecidableEq` instance for the target type, we can only
construct `Functor Finset` when working classically. -/
protected instance functor : Functor Finset where map f s := s.image f

instance lawfulFunctor : LawfulFunctor Finset where
  id_map s := image_id
  comp_map f g s := image_image.symm
  map_const {α} {β} := by simp only [Functor.mapConst, Functor.map]

@[simp]
theorem fmap_def {s : Finset α} (f : α → β) : f <$> s = s.image f := rfl
#align finset.fmap_def Finset.fmap_def

end Functor

/-! ### Pure -/

protected instance pure : Pure Finset :=
  ⟨fun x => {x}⟩

@[simp]
theorem pure_def {α} : (pure : α → Finset α) = singleton := rfl
#align finset.pure_def Finset.pure_def

/-! ### Applicative functor -/

section Applicative

variable {α β : Type u} [∀ P, Decidable P]

protected instance applicative : Applicative Finset :=
  { Finset.functor, Finset.pure with
    seq := fun t s => t.sup fun f => (s ()).image f
    seqLeft := fun s t => if t () = ∅ then ∅ else s
    seqRight := fun s t => if s = ∅ then ∅ else t () }

@[simp]
theorem seq_def (s : Finset α) (t : Finset (α → β)) : t <*> s = t.sup fun f => s.image f :=
  rfl
#align finset.seq_def Finset.seq_def

@[simp]
theorem seqLeft_def (s : Finset α) (t : Finset β) : s <* t = if t = ∅ then ∅ else s :=
  rfl
#align finset.seq_left_def Finset.seqLeft_def

@[simp]
theorem seqRight_def (s : Finset α) (t : Finset β) : s *> t = if s = ∅ then ∅ else t :=
  rfl
#align finset.seq_right_def Finset.seqRight_def

/-- `Finset.image₂` in terms of monadic operations. Note that this can't be taken as the definition
because of the lack of universe polymorphism. -/
theorem image₂_def {α β γ : Type _} (f : α → β → γ) (s : Finset α) (t : Finset β) :
    image₂ f s t = f <$> s <*> t := by
  ext
  simp [mem_sup]
#align finset.image₂_def Finset.image₂_def

instance lawfulApplicative : LawfulApplicative Finset :=
  { Finset.lawfulFunctor with
    seqLeft_eq := fun s t =>
      by
      rw [seq_def, fmap_def, seqLeft_def]
      obtain rfl | ht := t.eq_empty_or_nonempty
      · simp_rw [if_pos rfl, image_empty, if_true]
        exact (sup_bot _).symm
      · ext a
        rw [if_neg ht.ne_empty, mem_sup]
        refine' ⟨fun ha => ⟨const _ a, mem_image_of_mem _ ha, mem_image_const_self.2 ht⟩, _⟩
        rintro ⟨f, hf, ha⟩
        rw [mem_image] at hf ha
        obtain ⟨b, hb, rfl⟩ := hf
        obtain ⟨_, _, rfl⟩ := ha
        exact hb
    seqRight_eq := fun s t =>
      by
      rw [seq_def, fmap_def, seqRight_def]
      obtain rfl | hs := s.eq_empty_or_nonempty
      · rw [if_pos rfl, image_empty, sup_empty, bot_eq_empty]
      · ext a
        rw [if_neg hs.ne_empty, mem_sup]
        refine' ⟨fun ha => ⟨id, mem_image_const_self.2 hs, by rwa [image_id]⟩, _⟩
        rintro ⟨f, hf, ha⟩
        rw [mem_image] at hf ha
        obtain ⟨b, hb, rfl⟩ := ha
        obtain ⟨_, _, rfl⟩ := hf
        exact hb
    pure_seq := fun f s => by simp only [pure_def, seq_def, sup_singleton, fmap_def]
    map_pure := fun f a => image_singleton _ _
    seq_pure := fun s a => sup_singleton'' _ _
    seq_assoc := fun s t u => by
      ext a
      simp_rw [seq_def, fmap_def]
      simp only [exists_prop, mem_sup, mem_image]
      constructor
      · rintro ⟨g, hg, b, ⟨f, hf, a, ha, rfl⟩, rfl⟩
        exact ⟨g ∘ f, ⟨comp g, ⟨g, hg, rfl⟩, f, hf, rfl⟩, a, ha, rfl⟩
      · rintro ⟨c, ⟨_, ⟨g, hg, rfl⟩, f, hf, rfl⟩, a, ha, rfl⟩
        exact ⟨g, hg, f a, ⟨f, hf, a, ha, rfl⟩, rfl⟩ }

instance commApplicative : CommApplicative Finset :=
  { Finset.lawfulApplicative with
    commutative_prod := fun s t => by
      simp_rw [seq_def, fmap_def, sup_image, sup_eq_bunionᵢ]
      change (s.bunionᵢ fun a => t.image fun b => (a, b))
        = t.bunionᵢ fun b => s.image fun a => (a, b)
      trans s.product t <;> [rw [product_eq_bunionᵢ], rw [product_eq_bunionᵢ_right]] }

end Applicative

/-! ### Monad -/

section Monad

variable [∀ P, Decidable P]

instance : Monad Finset :=
  { Finset.applicative with bind := sup }

@[simp]
theorem bind_def {α β} : (· >>= ·) = sup (α := Finset α) (β := β) :=
  rfl
#align finset.bind_def Finset.bind_def

instance : LawfulMonad Finset :=
  { Finset.lawfulApplicative with
    bind_pure_comp := fun f s => sup_singleton'' _ _
    bind_map := fun t s => rfl
    pure_bind := fun t s => sup_singleton
    bind_assoc := fun s f g => by simp only [bind, ←sup_bunionᵢ, sup_eq_bunionᵢ, bunionᵢ_bunionᵢ] }

end Monad

/-! ### Alternative functor -/

section Alternative

variable [∀ P, Decidable P]

instance : Alternative Finset :=
  { Finset.applicative with
    orElse := fun s t => (s ∪ t ())
    failure := ∅ }

end Alternative

/-! ### Traversable functor -/

section Traversable

variable {α β γ : Type u} {F G : Type u → Type u} [Applicative F] [Applicative G]
  [CommApplicative F] [CommApplicative G]

/-- Traverse function for `Finset`. -/
def traverse [DecidableEq β] (f : α → F β) (s : Finset α) : F (Finset β) :=
  Multiset.toFinset <$> Multiset.traverse f s.1
#align finset.traverse Finset.traverse

@[simp]
theorem id_traverse [DecidableEq α] (s : Finset α) : traverse (pure : α → Id α) s = s := by
  rw [traverse, Multiset.id_traverse]
  exact s.val_toFinset
#align finset.id_traverse Finset.id_traverse

open Classical

@[simp]
theorem map_comp_coe (h : α → β) :
    Functor.map h ∘ Multiset.toFinset = Multiset.toFinset ∘ Functor.map h :=
  funext fun _ => image_toFinset
#align finset.map_comp_coe Finset.map_comp_coe

theorem map_traverse (g : α → G β) (h : β → γ) (s : Finset α) :
    Functor.map h <$> traverse g s = traverse (Functor.map h ∘ g) s := by
  unfold traverse
  simp only [map_comp_coe, functor_norm]
  rw [LawfulFunctor.comp_map, Multiset.map_traverse]
#align finset.map_traverse Finset.map_traverse

end Traversable

end Finset


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

import data.nat.multiplicity
import ring_theory.witt_vector.basic
import ring_theory.witt_vector.is_poly
import field_theory.perfect_closure

/-!
## The Frobenius operator

If `R` has characteristic `p`, then there is a ring endomorphism `frobenius R p`
that raises `r : R` to the power `p`.
By applying `witt_vector.map` to `frobenius R p`, we obtain a ring endomorphism `𝕎 R →+* 𝕎 R`.
It turns out that this endomorphism can be described by polynomials over `ℤ`
that do not depend on `R` or the fact that it has characteristic `p`.
In this way, we obtain a Frobenius endomorphism `witt_vector.frobenius_fun : 𝕎 R → 𝕎 R`
for every commutative ring `R`.

Unfortunately, the aforementioned polynomials can not be obtained using the machinery
of `witt_structure_int` that was developed in `structure_polynomial.lean`.
We therefore have to define the polynomials by hand, and check that they have the required property.

In case `R` has characteristic `p`, we show in `frobenius_fun_eq_map_frobenius`
that `witt_vector.frobenius_fun` is equal to `witt_vector.map (frobenius R p)`.

### Main definitions and results

* `frobenius_poly`: the polynomials that describe the coefficients of `frobenius_fun`;
* `frobenius_fun`: the Frobenius endomorphism on Witt vectors;
* `frobenius_fun_is_poly`: the tautological assertion that Frobenius is a polynomial function;
* `frobenius_fun_eq_map_frobenius`: the fact that in characteristic `p`, Frobenius is equal to
  `witt_vector.map (frobenius R p)`.

TODO: Show that `witt_vector.frobenius_fun` is a ring homomorphism,
and bundle it into `witt_vector.frobenius`.

## References

* [Hazewinkel, *Witt Vectors*][Haze09]

* [Commelin and Lewis, *Formalizing the Ring of Witt Vectors*][CL21]
-/

namespace witt_vector

variables {p : ℕ} {R S : Type*} [hp : fact p.prime] [comm_ring R] [comm_ring S]
local notation `𝕎` := witt_vector p -- type as `\bbW`

noncomputable theory
open mv_polynomial finset
open_locale big_operators

variables (p)
include hp

/-- The rational polynomials that give the coefficients of `frobenius x`,
in terms of the coefficients of `x`.
These polynomials actually have integral coefficients,
see `frobenius_poly` and `map_frobenius_poly`. -/
def frobenius_poly_rat (n : ℕ) : mv_polynomial ℕ ℚ :=
bind₁ (witt_polynomial p ℚ ∘ λ n, n + 1) (X_in_terms_of_W p ℚ n)

lemma bind₁_frobenius_poly_rat_witt_polynomial (n : ℕ) :
  bind₁ (frobenius_poly_rat p) (witt_polynomial p ℚ n) = (witt_polynomial p ℚ (n+1)) :=
begin
  delta frobenius_poly_rat,
  rw [← bind₁_bind₁, bind₁_X_in_terms_of_W_witt_polynomial, bind₁_X_right],
end

/-- An auxiliary definition, to avoid an excessive amount of finiteness proofs
for `multiplicity p n`. -/
private def pnat_multiplicity (n : ℕ+) : ℕ :=
(multiplicity p n).get $ multiplicity.finite_nat_iff.mpr $ ⟨ne_of_gt hp.1.one_lt, n.2⟩

local notation `v` := pnat_multiplicity

/-- An auxiliary polynomial over the integers, that satisfies
`p * (frobenius_poly_aux p n) + X n ^ p = frobenius_poly p n`.
This makes it easy to show that `frobenius_poly p n` is congruent to `X n ^ p`
modulo `p`. -/
noncomputable def frobenius_poly_aux : ℕ → mv_polynomial ℕ ℤ
| n := X (n + 1) - ∑ i : fin n, have _ := i.is_lt,
  ∑ j in range (p ^ (n - i)),
    (X i ^ p) ^ (p ^ (n - i) - (j + 1)) *
      (frobenius_poly_aux i) ^ (j + 1) *
      C ↑((p ^ (n - i)).choose (j + 1) / (p ^ (n - i - v p ⟨j + 1, nat.succ_pos j⟩)) *
      ↑p ^ (j - v p ⟨j + 1, nat.succ_pos j⟩) : ℕ)

lemma frobenius_poly_aux_eq (n : ℕ) :
  frobenius_poly_aux p n =
  X (n + 1) - ∑ i in range n, ∑ j in range (p ^ (n - i)),
    (X i ^ p) ^ (p ^ (n - i) - (j + 1)) *
    (frobenius_poly_aux p i) ^ (j + 1) *
    C ↑((p ^ (n - i)).choose (j + 1) / (p ^ (n - i - v p ⟨j + 1, nat.succ_pos j⟩)) *
      ↑p ^ (j - v p ⟨j + 1, nat.succ_pos j⟩) : ℕ) :=
by { rw [frobenius_poly_aux, ← fin.sum_univ_eq_sum_range] }

/-- The polynomials that give the coefficients of `frobenius x`,
in terms of the coefficients of `x`. -/
def frobenius_poly (n : ℕ) : mv_polynomial ℕ ℤ :=
X n ^ p + C ↑p * (frobenius_poly_aux p n)

/-
Our next goal is to prove
```
lemma map_frobenius_poly (n : ℕ) :
  mv_polynomial.map (int.cast_ring_hom ℚ) (frobenius_poly p n) = frobenius_poly_rat p n
```
This lemma has a rather long proof, but it mostly boils down to applying induction,
and then using the following two key facts at the right point.
-/

/-- A key divisibility fact for the proof of `witt_vector.map_frobenius_poly`. -/
lemma map_frobenius_poly.key₁ (n j : ℕ) (hj : j < p ^ (n)) :
  p ^ (n - v p ⟨j + 1, j.succ_pos⟩) ∣ (p ^ n).choose (j + 1) :=
begin
  apply multiplicity.pow_dvd_of_le_multiplicity,
  have aux : (multiplicity p ((p ^ n).choose (j + 1))).dom,
  { rw [← multiplicity.finite_iff_dom, multiplicity.finite_nat_iff],
    exact ⟨hp.1.ne_one, nat.choose_pos hj⟩, },
  rw [← enat.coe_get aux, enat.coe_le_coe, tsub_le_iff_left,
      ← enat.coe_le_coe, nat.cast_add, pnat_multiplicity, enat.coe_get, enat.coe_get, add_comm],
  exact (hp.1.multiplicity_choose_prime_pow hj j.succ_pos).ge,
end

/-- A key numerical identity needed for the proof of `witt_vector.map_frobenius_poly`. -/
lemma map_frobenius_poly.key₂ {n i j : ℕ} (hi : i < n) (hj : j < p ^ (n - i)) :
  j - (v p ⟨j + 1, j.succ_pos⟩) + n =
    i + j + (n - i - v p ⟨j + 1, j.succ_pos⟩) :=
begin
  generalize h : (v p ⟨j + 1, j.succ_pos⟩) = m,
  suffices : m ≤ n - i ∧ m ≤ j,
  { rw [tsub_add_eq_add_tsub this.2, add_comm i j,
      add_tsub_assoc_of_le (this.1.trans (nat.sub_le n i)), add_assoc, tsub_right_comm, add_comm i,
      tsub_add_cancel_of_le (le_tsub_of_add_le_right ((le_tsub_iff_left hi.le).mp this.1))] },
  split,
  { rw [← h, ← enat.coe_le_coe, pnat_multiplicity, enat.coe_get,
        ← hp.1.multiplicity_choose_prime_pow hj j.succ_pos],
    apply le_add_left, refl },
  { obtain ⟨c, hc⟩ : p ^ m ∣ j + 1,
    { rw [← h], exact multiplicity.pow_multiplicity_dvd _, },
    obtain ⟨c, rfl⟩ : ∃ k : ℕ, c = k + 1,
    { apply nat.exists_eq_succ_of_ne_zero, rintro rfl, simpa only using hc },
    rw [mul_add, mul_one] at hc,
    apply nat.le_of_lt_succ,
    calc m < p ^ m : nat.lt_pow_self hp.1.one_lt m
       ... ≤ j + 1 : by { rw ← tsub_eq_of_eq_add_rev hc, apply nat.sub_le } }
end

lemma map_frobenius_poly (n : ℕ) :
  mv_polynomial.map (int.cast_ring_hom ℚ) (frobenius_poly p n) = frobenius_poly_rat p n :=
begin
  rw [frobenius_poly, ring_hom.map_add, ring_hom.map_mul, ring_hom.map_pow, map_C, map_X,
      ring_hom.eq_int_cast, int.cast_coe_nat, frobenius_poly_rat],
  apply nat.strong_induction_on n, clear n,
  intros n IH,
  rw [X_in_terms_of_W_eq],
  simp only [alg_hom.map_sum, alg_hom.map_sub, alg_hom.map_mul, alg_hom.map_pow, bind₁_C_right],
  have h1 : (↑p ^ n) * (⅟ (↑p : ℚ) ^ n) = 1 := by rw [←mul_pow, mul_inv_of_self, one_pow],
  rw [bind₁_X_right, function.comp_app, witt_polynomial_eq_sum_C_mul_X_pow, sum_range_succ,
      sum_range_succ, tsub_self, add_tsub_cancel_left, pow_zero, pow_one, pow_one, sub_mul,
      add_mul, add_mul, mul_right_comm, mul_right_comm (C (↑p ^ (n + 1))), ←C_mul, ←C_mul, pow_succ,
      mul_assoc ↑p (↑p ^ n), h1, mul_one, C_1, one_mul, add_comm _ (X n ^ p), add_assoc, ←add_sub,
      add_right_inj, frobenius_poly_aux_eq, ring_hom.map_sub, map_X, mul_sub, sub_eq_add_neg,
      add_comm _ (C ↑p * X (n + 1)), ←add_sub, add_right_inj, neg_eq_iff_neg_eq, neg_sub],
  simp only [ring_hom.map_sum, mul_sum, sum_mul, ←sum_sub_distrib],
  apply sum_congr rfl,
  intros i hi,
  rw mem_range at hi,
  rw [← IH i hi],
  clear IH,
  rw [add_comm (X i ^ p), add_pow, sum_range_succ', pow_zero, tsub_zero, nat.choose_zero_right,
      one_mul, nat.cast_one, mul_one, mul_add, add_mul, nat.succ_sub (le_of_lt hi),
      nat.succ_eq_add_one (n - i), pow_succ, pow_mul, add_sub_cancel, mul_sum, sum_mul],
  apply sum_congr rfl,
  intros j hj,
  rw mem_range at hj,
  rw [ring_hom.map_mul, ring_hom.map_mul, ring_hom.map_pow, ring_hom.map_pow, ring_hom.map_pow,
      ring_hom.map_pow, ring_hom.map_pow, map_C, map_X, mul_pow],
  rw [mul_comm (C ↑p ^ i), mul_comm _ ((X i ^ p) ^ _), mul_comm (C ↑p ^ (j + 1)), mul_comm (C ↑p)],
  simp only [mul_assoc],
  apply congr_arg,
  apply congr_arg,
  rw [←C_eq_coe_nat],
  simp only [←ring_hom.map_pow, ←C_mul],
  rw C_inj,
  simp only [inv_of_eq_inv, ring_hom.eq_int_cast, inv_pow₀, int.cast_coe_nat, nat.cast_mul],
  rw [rat.coe_nat_div _ _ (map_frobenius_poly.key₁ p (n - i) j hj)],
  simp only [nat.cast_pow, pow_add, pow_one],
  suffices : ((p ^ (n - i)).choose (j + 1) * p ^ (j - v p ⟨j + 1, j.succ_pos⟩) * p * p ^ n : ℚ) =
    p ^ j * p * ((p ^ (n - i)).choose (j + 1) * p ^ i) * p ^ (n - i - v p ⟨j + 1, j.succ_pos⟩),
  { have aux : ∀ k : ℕ, (p ^ k : ℚ) ≠ 0,
    { intro, apply pow_ne_zero, exact_mod_cast hp.1.ne_zero },
    simpa [aux, -one_div] with field_simps using this.symm },
  rw [mul_comm _ (p : ℚ), mul_assoc, mul_assoc, ← pow_add, map_frobenius_poly.key₂ p hi hj],
  ring_exp
end

lemma frobenius_poly_zmod (n : ℕ) :
  mv_polynomial.map (int.cast_ring_hom (zmod p)) (frobenius_poly p n) = X n ^ p :=
begin
  rw [frobenius_poly, ring_hom.map_add, ring_hom.map_pow, ring_hom.map_mul, map_X, map_C],
  simp only [int.cast_coe_nat, add_zero, ring_hom.eq_int_cast, zmod.nat_cast_self, zero_mul, C_0],
end

@[simp]
lemma bind₁_frobenius_poly_witt_polynomial (n : ℕ) :
  bind₁ (frobenius_poly p) (witt_polynomial p ℤ n) = (witt_polynomial p ℤ (n+1)) :=
begin
  apply mv_polynomial.map_injective (int.cast_ring_hom ℚ) int.cast_injective,
  simp only [map_bind₁, map_frobenius_poly, bind₁_frobenius_poly_rat_witt_polynomial,
    map_witt_polynomial],
end

variables {p}

/-- `frobenius_fun` is the function underlying the ring endomorphism
`frobenius : 𝕎 R →+* frobenius 𝕎 R`. -/
def frobenius_fun (x : 𝕎 R) : 𝕎 R :=
mk p $ λ n, mv_polynomial.aeval x.coeff (frobenius_poly p n)

lemma coeff_frobenius_fun (x : 𝕎 R) (n : ℕ) :
  coeff (frobenius_fun x) n = mv_polynomial.aeval x.coeff (frobenius_poly p n) :=
by rw [frobenius_fun, coeff_mk]

variables (p)

/-- `frobenius_fun` is tautologically a polynomial function.

See also `frobenius_is_poly`. -/
@[is_poly] lemma frobenius_fun_is_poly : is_poly p (λ R _Rcr, @frobenius_fun p R _ _Rcr) :=
⟨⟨frobenius_poly p, by { introsI, funext n, apply coeff_frobenius_fun }⟩⟩

variable {p}

@[ghost_simps] lemma ghost_component_frobenius_fun (n : ℕ) (x : 𝕎 R) :
  ghost_component n (frobenius_fun x) = ghost_component (n + 1) x :=
by simp only [ghost_component_apply, frobenius_fun, coeff_mk,
    ← bind₁_frobenius_poly_witt_polynomial, aeval_bind₁]

/--
If `R` has characteristic `p`, then there is a ring endomorphism
that raises `r : R` to the power `p`.
By applying `witt_vector.map` to this endomorphism,
we obtain a ring endomorphism `frobenius R p : 𝕎 R →+* 𝕎 R`.

The underlying function of this morphism is `witt_vector.frobenius_fun`.
-/
def frobenius : 𝕎 R →+* 𝕎 R :=
{ to_fun := frobenius_fun,
  map_zero' :=
  begin
    refine is_poly.ext
      ((frobenius_fun_is_poly p).comp (witt_vector.zero_is_poly))
      ((witt_vector.zero_is_poly).comp (frobenius_fun_is_poly p)) _ _ 0,
    ghost_simp
  end,
  map_one' :=
  begin
    refine is_poly.ext
      ((frobenius_fun_is_poly p).comp (witt_vector.one_is_poly))
      ((witt_vector.one_is_poly).comp (frobenius_fun_is_poly p)) _ _ 0,
    ghost_simp
  end,
  map_add' := by ghost_calc _ _; ghost_simp,
  map_mul' := by ghost_calc _ _; ghost_simp }

lemma coeff_frobenius (x : 𝕎 R) (n : ℕ) :
  coeff (frobenius x) n = mv_polynomial.aeval x.coeff (frobenius_poly p n) :=
coeff_frobenius_fun _ _

@[ghost_simps] lemma ghost_component_frobenius (n : ℕ) (x : 𝕎 R) :
  ghost_component n (frobenius x) = ghost_component (n + 1) x :=
ghost_component_frobenius_fun _ _

variables (p)

/-- `frobenius` is tautologically a polynomial function. -/
@[is_poly] lemma frobenius_is_poly : is_poly p (λ R _Rcr, @frobenius p R _ _Rcr) :=
frobenius_fun_is_poly _

section char_p
variables [char_p R p]

@[simp]
lemma coeff_frobenius_char_p (x : 𝕎 R) (n : ℕ) :
  coeff (frobenius x) n = (x.coeff n) ^ p :=
begin
  rw [coeff_frobenius],
  -- outline of the calculation, proofs follow below
  calc aeval (λ k, x.coeff k) (frobenius_poly p n)
      = aeval (λ k, x.coeff k)
          (mv_polynomial.map (int.cast_ring_hom (zmod p)) (frobenius_poly p n)) : _
  ... = aeval (λ k, x.coeff k) (X n ^ p : mv_polynomial ℕ (zmod p)) : _
  ... = (x.coeff n) ^ p : _,
  { conv_rhs { rw [aeval_eq_eval₂_hom, eval₂_hom_map_hom] },
    apply eval₂_hom_congr (ring_hom.ext_int _ _) rfl rfl },
  { rw frobenius_poly_zmod },
  { rw [alg_hom.map_pow, aeval_X] }
end

lemma frobenius_eq_map_frobenius :
  @frobenius p R _ _ = map (_root_.frobenius R p) :=
begin
  ext x n,
  simp only [coeff_frobenius_char_p, map_coeff, frobenius_def],
end

@[simp]
lemma frobenius_zmodp (x : 𝕎 (zmod p)) :
  (frobenius x) = x :=
by simp only [ext_iff, coeff_frobenius_char_p, zmod.pow_card, eq_self_iff_true, forall_const]

variables (p R)
lemma frobenius_bijective [perfect_ring R p] :
  function.bijective (@witt_vector.frobenius p R _ _) :=
begin
  rw witt_vector.frobenius_eq_map_frobenius,
  exact ⟨witt_vector.map_injective _ (frobenius_equiv R p).injective,
    witt_vector.map_surjective _ (frobenius_equiv R p).surjective⟩,
end

end char_p

end witt_vector