--Examples of how to work with groups in Lean

-- TODO
-- order of element
-- order of group
-- some standard theorems about finite groups
-- making a subgroup
-- making a quotient group
-- isomorphism theorems

-- relevant files:

import algebra.group.basic -- stuff like mul_self_iff_eq_one, mul_inv_eq_iff_eq_mul etc
import algebra.group.hom -- unbundled group homs
import data.equiv.basic
import bundled_group_homs
import group_theory.quotient_group
import data.set.basic

/- e.g.

class is_group_hom [group α] [group β] (f : α → β) : Prop :=
(map_mul : ∀ a b : α, f (a * b) = f a * f b)
-/

import group_theory.perm.sign -- signature of a permutation

import group_theory.subgroup -- subgroups

/-
/-- `s` is a subgroup: a set containing 1 and closed under multiplication and inverse. -/
class is_subgroup (s : set α) extends is_submonoid s : Prop :=
(inv_mem {a} : a ∈ s → a⁻¹ ∈ s)

class normal_subgroup [group α] (s : set α) extends is_subgroup s : Prop :=
(normal : ∀ n ∈ s, ∀ g : α, g * n * g⁻¹ ∈ s)

-/

import group_theory.quotient_group -- quotient groups

import bundled_subgroup

-- This gives us four functions subgroup.carrier, subgroup.one_mem,
-- subgroup.mul_mem and subgroup.inv_mem. They each eat a term
-- of type `subgroup <something>` and spit out the relevant set or proof.

-- a variable G, plus proof it's a group.

-- Subsets of a type are already bundled: they're called `set G`.
-- There's a map from `subgroup G` to `set G` which just sends
-- a subgroup `H` to its carrier set `H.carrier`; this is
-- subgroup.carrier. Let's make Lean apply it by default whenever
-- it's expecting a set and we give it a subgroup.

import bundled_quotients

namespace subgroup
variables {G : Type*} [group G]

-- Two subgroups with same underlying subset are the same subgroup.
@[extensionality] def ext (H K : subgroup G) (h : (H : set G) = K) : H = K := by cases H; cases K; cases h; refl

-- Do you know what a partial order is? You can look it up on Wikipedia.
-- It's not hard to check that the set of subsets of a set is a partial order.
-- Because `set G` is already well-established in mathlib, it is unsurprising to
-- see that it has already been given the structure of a partial order.

example : partial_order (set G) := by apply_instance

-- that proof works because `partial_order` is like `group`, it's a typeclass,
-- so we expect Lean to keep track of the proofs. This example just gets the proof
-- that `set G` is a partial order from its big database of proofs.

-- We would like a partial order on the sub*groups* of G, not just the subsets.
-- So we have a map `subgroup G` -> `set G` and we would like to "pull back" the
-- structure of a partial order on the target of that map, of partial order on the source.

-- Can this be done? "pullback" in Lean is called `comap` -- the computer science name for it.
-- Can you put a partial order on `subgroup G` by pulling it back from the one on `set G`?
-- Or can you do it directly? You'll have to prove the axioms for a partial order.

theorem carrier_injective : function.injective (subgroup.carrier : subgroup G → set G) := by ext

instance : partial_order (subgroup G) :=
{ le := λ H K, (H : set G) ⊆ K,
  le_refl := begin
  intro,
  simp,
  end,
  le_trans := λ _ _ _, set.subset.trans,
  le_antisymm := λ H K h1 h2, ext H K $ set.subset.antisymm h1 h2
  }

-- If you do it directly you'll have to define the inequality you want, which will look something like this:
-- λ H K, H.carrier ⊆ K.carrier ; and then you'll have to prove all the theorems. If you pull it back you
-- won't need to prove the theorems.

theorem le {G : Type*} [group G] {H K : subgroup G} : H ≤ K ↔ ∀ x: G, x ∈ H → x ∈ K :=
iff.rfl

open lattice

-- so let's work up to lattices. "inf H K" is just H intersect K -- but we need to check it's a subgroup.

example (X : Type) (A B : set X) : A ∩ B ⊆ A := set.inter_subset_left A B

protected def inf (H K : subgroup G) : subgroup G :=
{ carrier := H.carrier ∩ K.carrier,
  one_mem := begin
--  unfold has_inter.inter,
--  unfold set.inter,
  split,
    apply subgroup.one_mem,
  apply subgroup.one_mem,
  end,
  mul_mem := begin
  intros,
  split,
    apply subgroup.mul_mem,
      unfold has_inter.inter at a_1,
      unfold set.inter at a_1,
      cases a_1 with Hh Hk,
      assumption,
    cases a_2 with Hh Hk,
    assumption,
  apply subgroup.mul_mem,
    cases a_1 with Hh Hk,
    assumption,
  cases a_2 with Hh Hk,
  assumption,
  end,
  inv_mem := begin
  intros,
  cases a_1 with Hh Hk,
  split,
    apply subgroup.inv_mem,
    assumption,
  apply subgroup.inv_mem,
  assumption,
  end
  }

-- notation for inf is ⊓ (\glb) and as you can see from the definition of "carrier" above (the carrier
-- is the underlying set), it's just the intersection. `inf` stands for "infimum" and "glb" for "greatest lower bound",
-- both rather pretentious names for the intersection.

instance : has_inf (subgroup G) := ⟨subgroup.inf⟩

-- half way to a lattice is a semilattice_inf: there are some axioms you need to check though.

instance : semilattice_inf (subgroup G) :=
{ inf := (⊓),
  inf_le_left := begin
  intros,
  show a.carrier ∩ b.carrier ⊆ a.carrier,
  simp,
  --exact set.inter_subset_left _ _,
  --unfold lattice.has_inf.inf,
  --unfold subgroup.inf,
  end,
  inf_le_right := begin
  intros,
  show a.carrier ∩ b.carrier ⊆ b.carrier,
  simp,
  end,
  le_inf := begin
  intros a b c,
  intros hab hac,
  change a.carrier ⊆ b.carrier at hab,
  change a.carrier ⊆ c.carrier at hac,
  show a.carrier ⊆ b.carrier ∩ c.carrier,
  simp,
  split,
    assumption,
  assumption,
  end,
  ..subgroup.partial_order}

-- Lean has quotients by normal subgroups.

-- old style method
example (G : Type*) [group G] (N : set G) [normal_subgroup N] := quotient_group.quotient N
-- This is G/N. Lean guesses G from N.

-- We want to make a term of type `equiv X Y` where X and Y are two collections of subgroups and the `equiv` is this
-- strong kind of bijection -- a map from X to Y, and a map from Y to X, and two proofs,
-- namely that the composite maps X->Y->X and Y->X->Y are the relevant identity maps.

-- To do this we need to make the two sets. First the variables we're going to have:

variables {N : subgroup G} (h : is_normal_subgroup N)

-- Now notation for the quotient:

local notation `Q` := quotient_group.quotient' h

-- Now the first set (or "type", as Nicola Gambino would say).

example := subgroup Q

-- That's the subgroups of G/N. The other set is the subgroups of G which contain N.

example := {H : subgroup G // N ≤ H}

-- Those two sets biject with each other in the stong way which I showed you today: you can construct maps
-- in both directions. Do you know how do to this in maths?

end subgroup

variables {G : Type*} [group G] {H : Type*} [group H]

namespace monoid_hom

def map (f : G →* H) (K : subgroup G) : subgroup H :=
{ carrier := f '' K,
  one_mem := begin
  use 1,
  split,
    apply subgroup.one_mem,
  apply monoid_hom.map_one,
  end,
  mul_mem := begin
  rintro j k ⟨j', hj', rfl⟩ ⟨k', hk', rfl⟩,
  rw [← monoid_hom.map_mul f j' k'],
  unfold set.image,
  dsimp,
  use j'*k',
  split,
    apply subgroup.mul_mem,
      assumption,
    assumption,
  refl,
  end,
  inv_mem := begin
  rintro j ⟨j', hj', rfl⟩,
  unfold set.image,
  dsimp,
  use j'⁻¹,
  split,
    apply subgroup.inv_mem,
    assumption,
  apply f.map_inv,
  end
}

def comap (f : G →* H) (K : subgroup H) : subgroup G :=
{ carrier := f ⁻¹' K,
  one_mem := begin
  unfold set.preimage,
  dsimp,
  rw monoid_hom.map_one f,
  apply subgroup.one_mem,
  end,
  mul_mem := begin
  intros,
  unfold set.preimage,
  dsimp,
  rw monoid_hom.map_mul f,
  apply subgroup.mul_mem,
    assumption,
  assumption,
  end,
  inv_mem := begin
  intros,
  unfold set.preimage,
  dsimp,
  rw f.map_inv,
  apply subgroup.inv_mem,
  assumption,
  end
}

-- We haven't make the kernel of a bundled hom into a bundled subgroup!
def ker (f : G →* H) : subgroup G :=
{ carrier := {g : G | f g = 1},
  one_mem := begin
  dsimp,
  apply monoid_hom.map_one,
  end,
  mul_mem := begin
  dsimp,
  intros,
  rw [monoid_hom.map_mul, a_1, a_2],
  simp,
  end,
  inv_mem := begin
  dsimp,
  intros,
  rw [f.map_inv, a_1],
  simp,
  end }

def mem_ker (f : G →* H) (x : G) : x ∈ f.ker ↔ f x = 1 := iff.rfl

theorem ker_normal (f : G →* H) : is_normal_subgroup (ker f) :=
begin
   constructor,
   -- see what you can do -- might not be logically necessary but it might also be good
   -- practice :-)
   intros n hn g,
   change n ∈ ker f at hn,
   rw mem_ker f n at hn,
   show g * n * g⁻¹ ∈ ker f,
   rw [mem_ker f (g * n * g⁻¹), mul_assoc g n g⁻¹, group_hom.map_mul f g (n * g⁻¹)],
   rw [group_hom.map_mul f n g⁻¹, hn, one_mul],
   rw [← group_hom.map_mul],
   simp,
end

theorem ker_mk' {G : Type*} [group G] {N : subgroup G} (h : is_normal_subgroup N) :
  ker (quotient_group.mk' h) = N :=
begin
  letI : normal_subgroup N.carrier := h,
  apply subgroup.ext,
  convert quotient_group.ker_mk N.carrier,
  sorry -- I'll fix this later
end

-- one lemma you'll need to prove that your map in the correspondence below is well-defined.
lemma ker_sub_comap (f : G →* H) (X : subgroup H): f.ker ≤ f.comap X := begin
  intro g,
  intro h,
  have h2 : f g = 1,
    exact h,
  show f g ∈ X,
  rw h2,
  exact X.one_mem,
end

end monoid_hom

-- OK here is the main theorem. First variables.

variables {N : subgroup G} (hN : is_normal_subgroup N)

-- notation Q for the quotient group G/N

local notation `Q` := quotient_group.quotient' hN

-- the kernel of the projection is N

open monoid_hom

open quotient_group

-- hey this Wikipedia page is great:
-- https://en.wikipedia.org/wiki/Correspondence_theorem_(group_theory)

/-- Correspondence theorem for group theory -- first version -/

def correspondence : {H : subgroup G // N ≤ H} ≃ (subgroup Q) :=
{ to_fun := λ HN, (quotient_group.mk' hN).map HN.1,
  inv_fun := λ K, ⟨(quotient_group.mk' hN).comap K, begin
  rw subgroup.le,
  intro g,
  intro hg,
  show (quotient_group.mk' hN) g ∈ K,
  rw ←(ker_mk' hN) at hg,
  rw mem_ker at hg,
  rw hg,
  exact K.one_mem,
  end⟩,
  left_inv := begin
  rintro ⟨K, HK⟩,
  dsimp,
  apply subtype.ext.2,
  dsimp,
  rw subgroup.ext_iff,
  intro x,
  split,
    intro hx,
    change (quotient_group.mk' hN) x ∈ (map (mk' hN)) K at hx,
    cases hx with k hxk,
    cases hxk with kK hxkx,
    let f := (mk' hN),
    have hxkone : f (x*k⁻¹) = 1,
      calc f(x*k⁻¹) = f(x)*f(k⁻¹) : by apply f.map_mul
      ...           = f(k)*f(k⁻¹) : by rw hxkx
      ...           = f(k*k⁻¹) : by rw f.map_mul
      ...           = f(1) : by rw mul_inv_self
      ...           = 1 : f.map_one,
    rw ←mem_ker at hxkone,
    rw ker_mk' at hxkone,
    have hfh : x*k⁻¹ ∈ K,
      apply HK,
      assumption,
    convert K.mul_mem hfh kK,
    rw mul_assoc,
    rw inv_mul_self k,
    rw mul_one,
      -- f is (mk' hN)
      -- f(x) ∈ F(K) => ∃ k ∈ K st. f(x) = f(k)
      -- K is a subgroup => k⁻¹ exists ∈ K -- K.inv_mem kK
      -- f(x) = f(k) => f(x)f(k⁻¹) = f(k)f(k⁻¹) => f(xk⁻¹) = f(1) = 1 change, group_hom.map_mul,
      -- So xk⁻¹ ∈ ker f ⊆ K
      -- But K is closed under multiplication and xk⁻¹ * k = x, so x ∈ K.
  intro hx,
  show (quotient_group.mk' hN) x ∈ (map (mk' hN)) K,
  exact set.mem_image_of_mem (λ (a : G), ⇑(mk' hN) a) hx,
  end,
  right_inv :=
  begin
  intro K,
  dsimp,
  rw subgroup.ext_iff,
  intro x,
  split,
    intro hx,
    cases hx with k hxk,
    cases hxk with kK hxkx,
    change (quotient_group.mk' hN) k ∈ K at kK,
    rw hxkx at kK,
    assumption,
  intro hx,
  have hxk := mk'.surjective hN x,
  cases hxk with g hxkx,
  use g,
  split,
    show (quotient_group.mk' hN) g ∈ K,
    rwa hxkx,
  assumption,
  --cases
  -- x ∈ K => ∃ j ∈ F⁻¹(K) st. f(j)=x (surjectivity)
  -- So f(j) ∈ F(F⁻¹(K)) => x ∈ F(F⁻¹(K))

  end
}

-- That theorem above (I know it says definition, that's because the functions are data) is a first
-- version of the correspondence theorem. It says that there's a bijection of sets:
-- subgroups of G containing N <-> subgroups of Q=G/N

-- The next thing to do is to check that the correspondence respects ⊓, but I haven't quite decided
-- the best way to formalise that...

-- H (containing N) is a normal subgroup of G iff H/N is a normal subgroup of G/N

theorem normal_iff_normal (hN : is_normal_subgroup N) (H : subgroup G) (hH : N ≤ H) :
  is_normal_subgroup H ↔ is_normal_subgroup (correspondence hN ⟨H, hH⟩) :=
begin
  split,
    intro nsH,
    rw is_normal_subgroup_def at nsH ⊢,
    intros,

    --have hHNG : quotient' (proof that N is a normal subgroup of H) ≤ quotient' hN,
    -- hN : N is a normal subgroup of G, hsH : H is a normal subgroup of G
    -- Then H/N is a subgroup of G/N : hHNG
    -- So gN*hN*g⁻¹N=ghg⁻¹N ∈ H/N ~~~~~~~~
    sorry,
  intro nscH,
  rw is_normal_subgroup_def at nscH ⊢,
  intros,
--choose nq gq using nscH,
  -- HAVE n ∈ H, g ∈ G
  -- H/N is normal => ghg⁻¹N ∈ H/N (nscH) => ghg⁻¹N=aN for some a ∈ H
  -- H/N is a subgroup => h⁻¹N ∈ H/N and h⁻¹ ∈ H
                 --let min_n : ∀ (h : quotient' hN), h⁻¹ ∈ (correspondence hN) ⟨H, hH⟩,
                 -- intro,
                 -- apply subgroup.inv_mem,

  -- So gh⁻¹g⁻¹ ∈ H/N => 1 = gh⁻¹g⁻¹ * a ∈ ker(H/N) = N
  -- N ≤ H => gh⁻¹g⁻¹ * a ∈ H
  -- H is a subgroup so a⁻¹ exists and gh⁻¹g⁻¹ * a * a⁻¹ ∈ H => gh⁻¹g⁻¹ ∈ H
  -- Hence H is a normal subgroup
  sorry
end
#print prefix quotient


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

Auxiliary lemmas used to compare int numerals.
-/
prelude
import init.data.int.order

namespace int
/- Auxiliary lemmas for proving that to int numerals are different -/

/- 1. Lemmas for reducing the problem to the case where the numerals are positive -/

/-* for integers a and b, if a is not equal to b, then negative a is not equal to negative b *-/
protected lemma ne_neg_of_ne {a b : ℤ} : a ≠ b → -a ≠ -b :=
λ h₁ h₂, absurd (int.neg_inj h₂) h₁

/-* for integer a, if a is not 0, so is negative a  *-/
protected lemma neg_ne_zero_of_ne {a : ℤ} : a ≠ 0 → -a ≠ 0 :=
λ h₁ h₂,
  have -a = -0, by rwa int.neg_zero,
  have a = 0, from int.neg_inj this,
  by contradiction

protected lemma zero_ne_neg_of_ne {a : ℤ} (h : 0 ≠ a) : 0 ≠ -a :=
ne.symm (int.neg_ne_zero_of_ne (ne.symm h))

/-* for integers a and b, if 0 < a and 0 < b, then -a is not equal to b  *-/
protected lemma neg_ne_of_pos {a b : ℤ} : 0 < a → 0 < b → -a ≠ b :=
λ h₁ h₂ h,
begin
  rw [← h] at h₂,
  change 0 < a at h₁,
  have := le_of_lt h₁,
  exact absurd (le_of_lt h₁) (not_le_of_gt (int.neg_of_neg_pos h₂))
end

protected lemma ne_neg_of_pos {a b : ℤ} : 0 < a → 0 < b → a ≠ -b :=
λ h₁ h₂, ne.symm (int.neg_ne_of_pos h₂ h₁)

/- 2. Lemmas for proving that positive int numerals are nonneg and positive -/

protected lemma one_pos : 0 < (1:int) :=
int.zero_lt_one

protected lemma bit0_pos {a : ℤ} : 0 < a → 0 < bit0 a :=
λ h, int.add_pos h h

protected lemma bit1_pos {a : ℤ} : 0 ≤ a → 0 < bit1 a :=
λ h, int.lt_add_of_le_of_pos (int.add_nonneg h h) int.zero_lt_one

protected lemma zero_nonneg : 0 ≤ (0 : ℤ) :=
le_refl 0

protected lemma one_nonneg : 0 ≤ (1 : ℤ) :=
le_of_lt (int.zero_lt_one)

protected lemma bit0_nonneg {a : ℤ} : 0 ≤ a → 0 ≤ bit0 a :=
λ h, int.add_nonneg h h

protected lemma bit1_nonneg {a : ℤ} : 0 ≤ a → 0 ≤ bit1 a :=
λ h, le_of_lt (int.bit1_pos h)

protected lemma nonneg_of_pos {a : ℤ} : 0 < a → 0 ≤ a :=
le_of_lt

/- 3. nat_abs auxiliary lemmas -/

lemma neg_succ_of_nat_lt_zero (n : ℕ) : neg_succ_of_nat n < 0 :=
@lt.intro _ _ n (by simp [neg_succ_of_nat_coe, int.coe_nat_succ, int.coe_nat_add, int.coe_nat_one,
  int.add_comm, int.add_left_comm, int.neg_add, int.add_right_neg, int.zero_add])

lemma zero_le_of_nat (n : ℕ) : 0 ≤ of_nat n :=
@le.intro _ _ n (by rw [int.zero_add, int.coe_nat_eq])

lemma of_nat_nat_abs_eq_of_nonneg : ∀ {a : ℤ}, 0 ≤ a → of_nat (nat_abs a) = a
| (of_nat n)          h := rfl
| (neg_succ_of_nat n) h := absurd (neg_succ_of_nat_lt_zero n) (not_lt_of_ge h)

lemma ne_of_nat_abs_ne_nat_abs_of_nonneg {a b : ℤ} (ha : 0 ≤ a) (hb : 0 ≤ b)
  (h : nat_abs a ≠ nat_abs b) : a ≠ b :=
assume h,
  have of_nat (nat_abs a) = of_nat (nat_abs b),
  by rwa [of_nat_nat_abs_eq_of_nonneg ha, of_nat_nat_abs_eq_of_nonneg hb],
  begin injection this, contradiction end

protected lemma ne_of_nat_ne_nonneg_case {a b : ℤ} {n m : nat} (ha : 0 ≤ a) (hb : 0 ≤ b)
  (e1 : nat_abs a = n) (e2 : nat_abs b = m) (h : n ≠ m) : a ≠ b :=
have nat_abs a ≠ nat_abs b, by rwa [e1, e2],
ne_of_nat_abs_ne_nat_abs_of_nonneg ha hb this

/- 4. Aux lemmas for pushing nat_abs inside numerals
   nat_abs_zero and nat_abs_one are defined at init/data/int/basic.lean -/

lemma nat_abs_of_nat_core (n : ℕ) : nat_abs (of_nat n) = n :=
rfl

lemma nat_abs_of_neg_succ_of_nat (n : ℕ) : nat_abs (neg_succ_of_nat n) = nat.succ n :=
rfl

protected lemma nat_abs_add_nonneg :
  ∀ {a b : int}, 0 ≤ a → 0 ≤ b → nat_abs (a + b) = nat_abs a + nat_abs b
| (of_nat n) (of_nat m)  h₁ h₂ :=
  have of_nat n + of_nat m = of_nat (n + m), from rfl,
  by simp [nat_abs_of_nat_core, this]
| _  (neg_succ_of_nat m) h₁ h₂ := absurd (neg_succ_of_nat_lt_zero m) (not_lt_of_ge h₂)
| (neg_succ_of_nat n) _  h₁ h₂ := absurd (neg_succ_of_nat_lt_zero n) (not_lt_of_ge h₁)

protected lemma nat_abs_add_neg :
  ∀ {a b : int}, a < 0 → b < 0 → nat_abs (a + b) = nat_abs a + nat_abs b
| (neg_succ_of_nat n) (neg_succ_of_nat m) h₁ h₂ :=
  have -[1+ n] + -[1+ m] = -[1+ nat.succ (n + m)], from rfl,
  begin simp [nat_abs_of_neg_succ_of_nat, this, nat.succ_add, nat.add_succ] end

protected lemma nat_abs_bit0 : ∀ (a : int), nat_abs (bit0 a) = bit0 (nat_abs a)
| (of_nat n)          := int.nat_abs_add_nonneg (zero_le_of_nat n) (zero_le_of_nat n)
| (neg_succ_of_nat n) := int.nat_abs_add_neg (neg_succ_of_nat_lt_zero n) (neg_succ_of_nat_lt_zero n)

protected

protected lemma nat_abs_bit1_nonneg {a : int} (h : 0 ≤ a) : nat_abs (bit1 a) = bit1 (nat_abs a) :=
show nat_abs (bit0 a + 1) = bit0 (nat_abs a) + nat_abs 1, from
by rw [int.nat_abs_add_nonneg (int.bit0_nonneg h) (le_of_lt (int.zero_lt_one)), int.nat_abs_bit0]

protected lemma nat_abs_bit1_nonneg_step {a : int} {n : nat} (h₁ : 0 ≤ a) (h₂ : nat_abs a = n) :
  nat_abs (bit1 a) = bit1 n :=
begin rw [← h₂], apply int.nat_abs_bit1_nonneg h₁ end

end int


import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Init.Data.Int.Basic
import Mathlib.Tactic.Spread

/-!
# Typeclasses for monoids and groups etc
-/

local macro "ofNat_class" Class:ident n:num : command =>
  let field := Lean.mkIdent <| Class.getId.eraseMacroScopes.getString!.toLower
  `(class $Class:ident.{u} (α : Type u) where
    $field:ident : α

  instance {α} [$Class α] : OfNat α (nat_lit $n) where
    ofNat := ‹$Class α›.1

  instance {α} [OfNat α (nat_lit $n)] : $Class α where
    $field:ident := $n)

ofNat_class Zero 0
ofNat_class One 1

class Inv (α : Type u) where
  inv : α → α

postfix:max "⁻¹" => Inv.inv

/-

## The trick for adding a natural action onto monoids

-/

section nat_action

variable {M : Type u}

-- see npow_rec comment for explanation about why not nsmul_rec n a + a
/-- The fundamental scalar multiplication in an additive monoid. `nsmul_rec n a = a+a+...+a` n
times. Use instead `n • a`, which has better definitional behavior. -/
def nsmul_rec [Zero M] [Add M] : ℕ → M → M
| 0  , a => 0
| n+1, a => a + nsmul_rec n a

-- use `x * npow_rec n x` and not `npow_rec n x * x` in the definition to make sure that
-- definitional unfolding of `npow_rec` is blocked, to avoid deep recursion issues.
/-- The fundamental power operation in a monoid. `npow_rec n a = a*a*...*a` n times.
Use instead `a ^ n`,  which has better definitional behavior. -/
def npow_rec [One M] [Mul M] : ℕ → M → M
| 0  , a => 1
| n+1, a => a * npow_rec n a

end nat_action

section int_action

/-- The fundamental scalar multiplication in an additive group. `gsmul_rec n a = a+a+...+a` n
times, for integer `n`. Use instead `n • a`, which has better definitional behavior. -/
def gsmul_rec {G : Type u} [Zero G] [Add G] [Neg G]: ℤ → G → G
| (Int.ofNat n)  , a => nsmul_rec n a
| (Int.negSucc n), a => - (nsmul_rec n.succ a)

/-- The fundamental power operation in a group. `gpow_rec n a = a*a*...*a` n times, for integer `n`.
Use instead `a ^ n`,  which has better definitional behavior. -/
def gpow_rec {G : Type u} [One G] [Mul G] [Inv G] : ℤ → G → G
| (Int.ofNat n)  , a => npow_rec n a
| (Int.negSucc n), a => (npow_rec n.succ a) ⁻¹

end int_action

/-

## Additive semigroups, monoids and groups

-/

/-

### Semigroups

-/

class AddSemigroup (A : Type u) extends Add A where
  add_assoc (a b c : A) : (a + b) + c = a + (b + c)

theorem add_assoc {G : Type u} [AddSemigroup G] :
  ∀ a b c : G, (a + b) + c = a + (b + c) :=
AddSemigroup.add_assoc

class AddCommSemigroup (A : Type u) extends AddSemigroup A where
  add_comm (a b : A) : a + b = b + a

theorem add_comm {A : Type u} [AddCommSemigroup A] (a b : A) : a + b = b + a :=
AddCommSemigroup.add_comm a b
/-

### Cancellative semigroups

-/

class IsAddLeftCancel (A : Type u) [Add A] where
  add_left_cancel (a b c : A) : a + b = a + c → b = c

class IsAddRightCancel (A : Type u) [Add A] where
  add_right_cancel (a b c : A) : b + a = c + a → b = c

section AddLeftCancel_lemmas

variable {A : Type u} [AddSemigroup A] [IsAddLeftCancel A] {a b c : A}

theorem add_left_cancel : a + b = a + c → b = c :=
IsAddLeftCancel.add_left_cancel a b c

theorem add_left_cancel_iff : a + b = a + c ↔ b = c :=
⟨add_left_cancel, congrArg _⟩

-- no `function.injective`?
--theorem add_right_injective (a : G) : function.injective (c * .) :=
--λ a b => add_left_cancel

@[simp] theorem add_right_inj (a : A) {b c : A} : a + b = a + c ↔ b = c :=
⟨add_left_cancel, congrArg _⟩

--theorem add_ne_add_right (a : A) {b c : A} : a + b ≠ a + c ↔ b ≠ c :=
--(add_right_injective a).ne_iff

end AddLeftCancel_lemmas

section AddRightCancel_lemmas

variable {A : Type u} [AddSemigroup A] [IsAddRightCancel A] {a b c : A}

theorem add_right_cancel : b + a = c + a → b = c :=
IsAddRightCancel.add_right_cancel a b c

theorem add_right_cancel_iff : b + a = c + a ↔ b = c :=
⟨add_right_cancel, λ h => h ▸ rfl⟩

@[simp] theorem add_left_inj (a : A) {b c : A} : b + a = c + a ↔ b = c :=
⟨add_right_cancel, λ h => h ▸ rfl⟩

end AddRightCancel_lemmas

/-

### Additive monoids

-/

class AddMonoid (A : Type u) extends AddSemigroup A, Zero A where
  add_zero (a : A) : a + 0 = a
  zero_add (a : A) : 0 + a = a
  nsmul : ℕ → A → A := nsmul_rec
  nsmul_zero' : ∀ x, nsmul 0 x = 0 -- fill in with tactic once we can do this
  nsmul_succ' : ∀ (n : ℕ) x, nsmul n.succ x = x + nsmul n x -- fill in with tactic

section AddMonoid_lemmas

variable  {A : Type u} [AddMonoid A] {a b c : A}

@[simp] theorem add_zero (a : A) : a + 0 = a :=
AddMonoid.add_zero a

@[simp] theorem zero_add (a : A) : 0 + a = a :=
AddMonoid.zero_add a

theorem left_neg_eq_right_neg (hba : b + a = 0) (hac : a + c = 0) : b = c :=
by rw [←zero_add c, ←hba, add_assoc, hac, add_zero b]

end AddMonoid_lemmas

/-! ### Additive monoids with one -/

class AddMonoidWithOne (R : Type u) extends AddMonoid R, One R where
  natCast : ℕ → R
  natCast_zero : natCast 0 = 0
  natCast_succ : ∀ n, natCast (n + 1) = natCast n + 1

@[coe]
def Nat.cast [AddMonoidWithOne R] : ℕ → R := AddMonoidWithOne.natCast

instance [AddMonoidWithOne R] : CoeTail ℕ R where coe := Nat.cast
instance [AddMonoidWithOne R] : CoeHTCT ℕ R where coe := Nat.cast

@[simp, norm_cast] theorem Nat.cast_zero [AddMonoidWithOne R] : ((0 : ℕ) : R) = 0 := AddMonoidWithOne.natCast_zero
@[simp 500, norm_cast 500]
theorem Nat.cast_succ [AddMonoidWithOne R] : ((Nat.succ n : ℕ) : R) = (n : R) + 1 := AddMonoidWithOne.natCast_succ _
@[simp, norm_cast]
theorem Nat.cast_one [AddMonoidWithOne R] : ((1 : ℕ) : R) = 1 := by simp

@[simp, norm_cast] theorem Nat.cast_add [AddMonoidWithOne R] : ((m + n : ℕ) : R) = (m : R) + n := by
  induction n <;> simp_all [add_succ, add_assoc]

class Nat.AtLeastTwo (n : Nat) : Prop where
  prop : n ≥ 2
instance : Nat.AtLeastTwo (n + 2) where
  prop := Nat.succ_le_succ $ Nat.succ_le_succ $ Nat.zero_le _

instance [AddMonoidWithOne R] [Nat.AtLeastTwo n] : OfNat R n where
  ofNat := n.cast

@[simp, norm_cast] theorem Nat.cast_ofNat [AddMonoidWithOne R] [Nat.AtLeastTwo n] :
  (Nat.cast (OfNat.ofNat n) : R) = OfNat.ofNat n := rfl

/-

### Commutative additive monoids

-/

class AddCommMonoid (A : Type u) extends AddMonoid A, AddCommSemigroup A where
  -- TODO: doesn't work
  zero_add a := (by rw [add_comm, add_zero])
  add_zero a := (by rw [add_comm, zero_add])

/-

### sub_neg_monoids

Additive groups can "pick up" several equal but not defeq actions of ℤ.
This trick isolates one such action, `gsmul`, and decrees it to
be "the canonical one".

-/

class SubNegMonoid (A : Type u) extends AddMonoid A, Neg A, Sub A where
  sub := λ a b => a + -b
  sub_eq_add_neg : ∀ a b : A, a - b = a + -b
  gsmul : ℤ → A → A := gsmul_rec
  gsmul_zero' : ∀ (a : A), gsmul 0 a = 0
  gsmul_succ' (n : ℕ) (a : A) : gsmul (Int.ofNat n.succ) a = a + gsmul (Int.ofNat n) a
  gsmul_neg' (n : ℕ) (a : A) : gsmul (Int.negSucc n) a = -(gsmul ↑(n.succ) a)

export SubNegMonoid (sub_eq_add_neg)

/-

### Additive groups

-/

class AddGroup (A : Type u) extends SubNegMonoid A where
  add_left_neg (a : A) : -a + a = 0

section AddGroup_lemmas

variable {A : Type u} [AddGroup A] {a b c : A}

@[simp] theorem add_left_neg : ∀ a : A, -a + a = 0 :=
AddGroup.add_left_neg

theorem neg_add_self (a : A) : -a + a = 0 := add_left_neg a

@[simp] theorem neg_add_cancel_left (a b : A) : -a + (a + b) = b :=
by rw [← add_assoc, add_left_neg, zero_add]

theorem neg_eq_of_add_eq_zero (h : a + b = 0) : -a = b :=
left_neg_eq_right_neg (neg_add_self a) h

@[simp] theorem neg_neg (a : A) : -(-a) = a :=
neg_eq_of_add_eq_zero (add_left_neg a)

@[simp] theorem add_right_neg (a : A) : a + -a = 0 := by
  rw [←add_left_neg (-a), neg_neg]

-- synonym
theorem add_neg_self (a : A) : a + -a = 0 := add_right_neg a

@[simp] theorem add_neg_cancel_right (a b : A) : a + b + -b = a :=
by rw [add_assoc, add_right_neg, add_zero]

instance (A : Type u) [AddGroup A] : IsAddRightCancel A where
  add_right_cancel a b c h := by
  rw [← add_neg_cancel_right b a, h, add_neg_cancel_right]

instance (A : Type u) [AddGroup A] : IsAddLeftCancel A where
  add_left_cancel a b c h := by
  rw [← neg_add_cancel_left a b, h, neg_add_cancel_left]

lemma eq_of_sub_eq_zero' (h : a - b = 0) : a = b :=
  add_right_cancel <| show a + (-b) = b + (-b) by rw [← sub_eq_add_neg, h, add_neg_self]

end AddGroup_lemmas

class AddCommGroup (A : Type u) extends AddGroup A, AddCommMonoid A

/-! ### Additive groups with one -/

class AddGroupWithOne (R : Type u) extends AddMonoidWithOne R, AddGroup R where
  intCast : ℤ → R
  intCast_ofNat : ∀ n : ℕ, intCast n = natCast n
  intCast_negSucc : ∀ n : ℕ, intCast (Int.negSucc n) = - natCast (n + 1)

@[coe]
def Int.cast [AddGroupWithOne R] : ℤ → R := AddGroupWithOne.intCast

instance [AddGroupWithOne R] : CoeTail ℤ R where coe := Int.cast

theorem Int.cast_ofNat [AddGroupWithOne R] : (Int.cast (Int.ofNat n) : R) = Nat.cast n :=
  AddGroupWithOne.intCast_ofNat _
@[simp, norm_cast]
theorem Int.cast_negSucc [AddGroupWithOne R] : (Int.cast (Int.negSucc n) : R) = (-(Nat.cast (n + 1)) : R) :=
  AddGroupWithOne.intCast_negSucc _

@[simp, norm_cast] theorem Int.cast_zero [AddGroupWithOne R] : ((0 : ℤ) : R) = 0 := by
  erw [Int.cast_ofNat, Nat.cast_zero]
@[simp, norm_cast] theorem Int.cast_one [AddGroupWithOne R] : ((1 : ℤ) : R) = 1 := by
  erw [Int.cast_ofNat, Nat.cast_one]

/-

## Multiplicative semigroups, monoids and groups

-/

/-

## Semigroups

-/

class Semigroup (G : Type u) extends Mul G where
  mul_assoc (a b c : G) : (a * b) * c = a * (b * c)

export Semigroup (mul_assoc)

class CommSemigroup (G : Type u) extends Semigroup G where
  mul_comm (a b : G) : a * b = b * a

export CommSemigroup (mul_comm)

lemma mul_left_comm {M} [CommSemigroup M] (a b c : M) : a * (b * c) = b * (a * c) :=
by rw [← mul_assoc, mul_comm a, mul_assoc]

-- Funky Lean 3 proof of the above:
--left_comm has_mul.mul mul_comm mul_assoc

lemma mul_right_comm {M} [CommSemigroup M] (a b c : M) : a * b * c = a * c * b :=
by rw [mul_assoc, mul_comm b c, mul_assoc]

/-- Typeclass for expressing that a type `M` with multiplication and a one satisfies
`1 * a = a` and `a * 1 = a` for all `a : M`. -/
class MulOneClass (M : Type u) extends One M, Mul M where
  one_mul : ∀ (a : M), 1 * a = a
  mul_one : ∀ (a : M), a * 1 = a

/-

### Cancellative semigroups

-/

class IsMulLeftCancel (G : Type u) [Mul G] where
  mul_left_cancel (a b c : G) : a * b = a * c → b = c

class IsMulRightCancel (G : Type u) [Mul G] where
  mul_right_cancel (a b c : G) : b * a = c * a → b = c
section MulLeftCancel

variable {G : Type u} [Semigroup G] [IsMulLeftCancel G] {a b c : G}

theorem mul_left_cancel : a * b = a * c → b = c :=
IsMulLeftCancel.mul_left_cancel a b c

theorem mul_left_cancel_iff : a * b = a * c ↔ b = c :=
⟨mul_left_cancel, congrArg _⟩

-- no `function.injective`?
--theorem mul_right_injective (a : G) : function.injective (c * .) :=
--λ a b => mul_left_cancel

@[simp] theorem mul_right_inj (a : G) {b c : G} : a * b = a * c ↔ b = c :=
⟨mul_left_cancel, congrArg _⟩

--theorem mul_ne_mul_right (a : G) {b c : G} : a * b ≠ a * c ↔ b ≠ c :=
--(mul_right_injective a).ne_iff

end MulLeftCancel

section MulRightCancel

variable {G : Type u} [Semigroup G] [IsMulRightCancel G] {a b c : G}

theorem mul_right_cancel : b * a = c * a → b = c :=
IsMulRightCancel.mul_right_cancel a b c

theorem mul_right_cancel_iff : b * a = c * a ↔ b = c :=
⟨mul_right_cancel, λ h => h ▸ rfl⟩

@[simp] theorem mul_left_inj (a : G) {b c : G} : b * a = c * a ↔ b = c :=
⟨mul_right_cancel, λ h => h ▸ rfl⟩

end MulRightCancel

/-

### Monoids

-/

class Monoid (M : Type u) extends Semigroup M, MulOneClass M where
  npow : ℕ → M → M := npow_rec
  npow_zero' : ∀ x, npow 0 x = 1 -- fill in with tactic once we can do this
  npow_succ' : ∀ (n : ℕ) x, npow n.succ x = x * npow n x -- fill in with tactic

section Monoid
variable {M : Type u} [Monoid M]

@[defaultInstance high] instance Monoid.HPow : HPow M ℕ M := ⟨λ a n => Monoid.npow n a⟩

@[simp] theorem mul_one : ∀ (a : M), a * 1 = a :=
Monoid.mul_one

@[simp] theorem one_mul : ∀ (a : M), 1 * a = a :=
Monoid.one_mul

theorem npow_eq_pow (n : ℕ) (a : M) : Monoid.npow n a = a^n := rfl

@[simp] theorem pow_zero : ∀ (a : M), a ^ (0:ℕ) = 1 :=
Monoid.npow_zero'

theorem pow_succ' : ∀ (n : ℕ) (a : M), a ^ n.succ = a * a ^ n :=
Monoid.npow_succ'

theorem pow_mul_comm (a : M) (n : ℕ) : a^n * a = a * a^n := by
  induction n with
  | zero => simp
  | succ n ih => simp [ih, pow_succ', mul_assoc]

theorem pow_succ (n : ℕ) (a : M) : a ^ n.succ = a ^ n * a :=
by rw [pow_succ', pow_mul_comm]

@[simp] theorem pow_one (a : M) : a ^ (1:ℕ) = a :=
by rw [Nat.one_eq_succ_zero, pow_succ, pow_zero, one_mul]

theorem pow_add (a : M) (m n : ℕ) : a^(m + n) = a^m * a^n := by
  induction n with
  | zero => simp
  | succ n ih =>
    rw [Nat.add_succ, pow_succ',ih, pow_succ', ← mul_assoc, ← mul_assoc, pow_mul_comm]

theorem pow_mul {M} [Monoid M] (a : M) (m n : ℕ) : a^(m * n) = (a^m)^n := by
  induction n with
  | zero => simp
  | succ n ih =>
    rw [Nat.mul_succ, pow_add, ih, pow_succ', pow_mul_comm]

theorem left_inv_eq_right_inv {M : Type u} [Monoid M] {a b c : M}
  (hba : b * a = 1) (hac : a * c = 1) : b = c :=
by rw [←one_mul c, ←hba, mul_assoc, hac, mul_one b]

end Monoid

/-

### Commutative monoids

-/

class CommMonoid (M : Type u) extends Monoid M where
  mul_comm (a b : M) : a * b = b * a

section CommMonoid
variable {M} [CommMonoid M]

instance : CommSemigroup M where
  __ := ‹CommMonoid M›

theorem mul_pow (a b : M) (n : ℕ)  : (a * b)^n= a^n * b^n := by
  induction n with
  | zero => simp
  | succ n ih =>
    simp only [pow_succ, ih, mul_assoc, mul_left_comm _ a]

end CommMonoid

/-

### Div inv monoids
-/

class DivInvMonoid (G : Type u) extends Monoid G, Inv G, Div G :=
(div := λ a b => a * b⁻¹)
(div_eq_mul_inv : ∀ a b : G, a / b = a * b⁻¹)
(gpow : ℤ → G → G := gpow_rec)
(gpow_zero' : ∀ (a : G), gpow 0 a = 1)
(gpow_succ' :
  ∀ (n : ℕ) (a : G), gpow (Int.ofNat n.succ) a = a * gpow (Int.ofNat n) a)
(gpow_neg' :
  ∀ (n : ℕ) (a : G), gpow (Int.negSucc n) a = (gpow (Int.ofNat n.succ) a) ⁻¹)

/-

### Groups

-/

class Group (G : Type u) extends DivInvMonoid G where
  mul_left_inv (a : G) : a⁻¹ * a = 1

section Group_lemmas

variable {G : Type u} [Group G] {a b c : G}

@[simp] theorem mul_left_inv : ∀ a : G, a⁻¹ * a = 1 :=
Group.mul_left_inv

theorem inv_mul_self (a : G) : a⁻¹ * a = 1 := mul_left_inv a

@[simp] theorem inv_mul_cancel_left (a b : G) : a⁻¹ * (a * b) = b :=
by rw [← mul_assoc, mul_left_inv, one_mul]

@[simp] theorem inv_eq_of_mul_eq_one (h : a * b = 1) : a⁻¹ = b :=
left_inv_eq_right_inv (inv_mul_self a) h

@[simp] theorem inv_inv (a : G) : (a⁻¹)⁻¹ = a :=
inv_eq_of_mul_eq_one (mul_left_inv a)

@[simp] theorem mul_right_inv (a : G) : a * a⁻¹ = 1 := by
  rw [←mul_left_inv (a⁻¹), inv_inv]

-- synonym
theorem mul_inv_self (a : G) : a * a⁻¹ = 1 := mul_right_inv a

@[simp] theorem mul_inv_cancel_right (a b : G) : a * b * b⁻¹ = a :=
by rw [mul_assoc, mul_right_inv, mul_one]

end Group_lemmas

class CommGroup (G : Type u) extends Group G where
  mul_comm (a b : G) : a * b = b * a

instance (G : Type u) [CommGroup G] : CommMonoid G where
  __ := ‹CommGroup G›


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Floris van Doorn, Gabriel Ebner, Yury Kudryashov
-/
import data.nat.enat
import order.conditionally_complete_lattice

/-!
# Conditionally complete linear order structure on `ℕ`

In this file we

* define a `conditionally_complete_linear_order_bot` structure on `ℕ`;
* define a `complete_linear_order` structure on `enat`;
* prove a few lemmas about `supr`/`infi`/`set.Union`/`set.Inter` and natural numbers.
-/

open set

namespace nat

open_locale classical

noncomputable instance : has_Inf ℕ :=
⟨λs, if h : ∃n, n ∈ s then @nat.find (λn, n ∈ s) _ h else 0⟩

noncomputable instance : has_Sup ℕ :=
⟨λs, if h : ∃n, ∀a∈s, a ≤ n then @nat.find (λn, ∀a∈s, a ≤ n) _ h else 0⟩

lemma Inf_def {s : set ℕ} (h : s.nonempty) : Inf s = @nat.find (λn, n ∈ s) _ h :=
dif_pos _

lemma Sup_def {s : set ℕ} (h : ∃n, ∀a∈s, a ≤ n) :
  Sup s = @nat.find (λn, ∀a∈s, a ≤ n) _ h :=
dif_pos _

lemma _root_.set.infinite.nat.Sup_eq_zero {s : set ℕ} (h : s.infinite) : Sup s = 0 :=
dif_neg $ λ ⟨n, hn⟩, let ⟨k, hks, hk⟩ := h.exists_nat_lt n in (hn k hks).not_lt hk

@[simp] lemma Inf_eq_zero {s : set ℕ} : Inf s = 0 ↔ 0 ∈ s ∨ s = ∅ :=
begin
  cases eq_empty_or_nonempty s,
  { subst h, simp only [or_true, eq_self_iff_true, iff_true, Inf, has_Inf.Inf,
      mem_empty_eq, exists_false, dif_neg, not_false_iff] },
  { have := ne_empty_iff_nonempty.mpr h,
    simp only [this, or_false, nat.Inf_def, h, nat.find_eq_zero] }
end

@[simp] lemma Inf_empty : Inf ∅ = 0 :=
by { rw Inf_eq_zero, right, refl }

lemma Inf_mem {s : set ℕ} (h : s.nonempty) : Inf s ∈ s :=
by { rw [nat.Inf_def h], exact nat.find_spec h }

lemma not_mem_of_lt_Inf {s : set ℕ} {m : ℕ} (hm : m < Inf s) : m ∉ s :=
begin
  cases eq_empty_or_nonempty s,
  { subst h, apply not_mem_empty },
  { rw [nat.Inf_def h] at hm, exact nat.find_min h hm }
end

protected lemma Inf_le {s : set ℕ} {m : ℕ} (hm : m ∈ s) : Inf s ≤ m :=
by { rw [nat.Inf_def ⟨m, hm⟩], exact nat.find_min' ⟨m, hm⟩ hm }

lemma nonempty_of_pos_Inf {s : set ℕ} (h : 0 < Inf s) : s.nonempty :=
begin
  by_contradiction contra, rw set.not_nonempty_iff_eq_empty at contra,
  have h' : Inf s ≠ 0, { exact ne_of_gt h, }, apply h',
  rw nat.Inf_eq_zero, right, assumption,
end

lemma nonempty_of_Inf_eq_succ {s : set ℕ} {k : ℕ} (h : Inf s = k + 1) : s.nonempty :=
nonempty_of_pos_Inf (h.symm ▸ (succ_pos k) : Inf s > 0)

lemma eq_Ici_of_nonempty_of_upward_closed {s : set ℕ} (hs : s.nonempty)
  (hs' : ∀ (k₁ k₂ : ℕ), k₁ ≤ k₂ → k₁ ∈ s → k₂ ∈ s) : s = Ici (Inf s) :=
ext (λ n, ⟨λ H, nat.Inf_le H, λ H, hs' (Inf s) n H (Inf_mem hs)⟩)

lemma Inf_upward_closed_eq_succ_iff {s : set ℕ}
  (hs : ∀ (k₁ k₂ : ℕ), k₁ ≤ k₂ → k₁ ∈ s → k₂ ∈ s) (k : ℕ) :
  Inf s = k + 1 ↔ k + 1 ∈ s ∧ k ∉ s :=
begin
  split,
  { intro H,
    rw [eq_Ici_of_nonempty_of_upward_closed (nonempty_of_Inf_eq_succ H) hs, H, mem_Ici, mem_Ici],
    exact ⟨le_rfl, k.not_succ_le_self⟩, },
  { rintro ⟨H, H'⟩,
    rw [Inf_def (⟨_, H⟩ : s.nonempty), find_eq_iff],
    exact ⟨H, λ n hnk hns, H' $ hs n k (lt_succ_iff.mp hnk) hns⟩, },
end

/-- This instance is necessary, otherwise the lattice operations would be derived via
conditionally_complete_linear_order_bot and marked as noncomputable. -/
instance : lattice ℕ := linear_order.to_lattice

noncomputable instance : conditionally_complete_linear_order_bot ℕ :=
{ Sup := Sup, Inf := Inf,
  le_cSup    := assume s a hb ha, by rw [Sup_def hb]; revert a ha; exact @nat.find_spec _ _ hb,
  cSup_le    := assume s a hs ha, by rw [Sup_def ⟨a, ha⟩]; exact nat.find_min' _ ha,
  le_cInf    := assume s a hs hb,
    by rw [Inf_def hs]; exact hb (@nat.find_spec (λn, n ∈ s) _ _),
  cInf_le    := assume s a hb ha, by rw [Inf_def ⟨a, ha⟩]; exact nat.find_min' _ ha,
  cSup_empty :=
  begin
    simp only [Sup_def, set.mem_empty_eq, forall_const, forall_prop_of_false, not_false_iff,
      exists_const],
    apply bot_unique (nat.find_min' _ _),
    trivial
  end,
  .. (infer_instance : order_bot ℕ), .. (linear_order.to_lattice : lattice ℕ),
  .. (infer_instance : linear_order ℕ) }

lemma Inf_add {n : ℕ} {p : ℕ → Prop} (hn : n ≤ Inf {m | p m}) :
  Inf {m | p (m + n)} + n = Inf {m | p m} :=
begin
  obtain h | ⟨m, hm⟩ := {m | p (m + n)}.eq_empty_or_nonempty,
  { rw [h, nat.Inf_empty, zero_add],
    obtain hnp | hnp := hn.eq_or_lt,
    { exact hnp },
    suffices hp : p (Inf {m | p m} - n + n),
    { exact (h.subset hp).elim },
    rw tsub_add_cancel_of_le hn,
    exact Inf_mem (nonempty_of_pos_Inf $ n.zero_le.trans_lt hnp) },
  { have hp : ∃ n, n ∈ {m | p m} := ⟨_, hm⟩,
    rw [nat.Inf_def ⟨m, hm⟩, nat.Inf_def hp],
    rw [nat.Inf_def hp] at hn,
    exact find_add hn }
end

section

variables {α : Type*} [complete_lattice α]

lemma supr_lt_succ (u : ℕ → α) (n : ℕ) : (⨆ k < n + 1, u k) = (⨆ k < n, u k) ⊔ u n :=
by simp [nat.lt_succ_iff_lt_or_eq, supr_or, supr_sup_eq]

lemma supr_lt_succ' (u : ℕ → α) (n : ℕ) : (⨆ k < n + 1, u k) = u 0 ⊔ (⨆ k < n, u (k + 1)) :=
by { rw ← sup_supr_nat_succ, simp }

lemma infi_lt_succ (u : ℕ → α) (n : ℕ) : (⨅ k < n + 1, u k) = (⨅ k < n, u k) ⊓ u n :=
@supr_lt_succ (order_dual α) _ _ _

lemma infi_lt_succ' (u : ℕ → α) (n : ℕ) : (⨅ k < n + 1, u k) = u 0 ⊓ (⨅ k < n, u (k + 1)) :=
@supr_lt_succ' (order_dual α) _ _ _

end

end nat

namespace set

variable {α : Type*}

lemma bUnion_lt_succ (u : ℕ → set α) (n : ℕ) : (⋃ k < n + 1, u k) = (⋃ k < n, u k) ∪ u n :=
nat.supr_lt_succ u n

lemma bUnion_lt_succ' (u : ℕ → set α) (n : ℕ) : (⋃ k < n + 1, u k) = u 0 ∪ (⋃ k < n, u (k + 1)) :=
nat.supr_lt_succ' u n

lemma bInter_lt_succ (u : ℕ → set α) (n : ℕ) : (⋂ k < n + 1, u k) = (⋂ k < n, u k) ∩ u n :=
nat.infi_lt_succ u n

lemma bInter_lt_succ' (u : ℕ → set α) (n : ℕ) : (⋂ k < n + 1, u k) = u 0 ∩ (⋂ k < n, u (k + 1)) :=
nat.infi_lt_succ' u n

end set

namespace enat
open_locale classical

noncomputable instance : complete_linear_order enat :=
{ inf := (⊓),
  sup := (⊔),
  top := ⊤,
  bot := ⊥,
  le := (≤),
  lt := (<),
  .. enat.lattice,
  .. with_top_order_iso.symm.to_galois_insertion.lift_complete_lattice,
  .. enat.linear_order, }

end enat


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

! This file was ported from Lean 3 source module group_theory.group_action.support
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Pointwise.SMul

/-!
# Support of an element under an action action

Given an action of a group `G` on a type `α`, we say that a set `s : Set α` supports an element
`a : α` if, for all `g` that fix `s` pointwise, `g` fixes `a`.

This is crucial in Fourier-Motzkin constructions.
-/

open Pointwise

variable {G H α β : Type _}

namespace MulAction

section SMul

variable (G) [SMul G α] [SMul G β]

/-- A set `s` supports `b` if `g • b = b` whenever `g • a = a` for all `a ∈ s`. -/
@[to_additive "A set `s` supports `b` if `g +ᵥ b = b` whenever `g +ᵥ a = a` for all `a ∈ s`."]
def Supports (s : Set α) (b : β) :=
  ∀ g : G, (∀ ⦃a⦄, a ∈ s → g • a = a) → g • b = b
#align mul_action.supports MulAction.Supports
#align add_action.supports AddAction.Supports

variable {s t : Set α} {a : α} {b : β}

@[to_additive]
theorem supports_of_mem (ha : a ∈ s) : Supports G s a := fun _ h => h ha
#align mul_action.supports_of_mem MulAction.supports_of_mem
#align add_action.supports_of_mem AddAction.supports_of_mem

variable {G}

@[to_additive]
theorem Supports.mono (h : s ⊆ t) (hs : Supports G s b) : Supports G t b := fun _ hg =>
  (hs _) fun _ ha => hg <| h ha
#align mul_action.supports.mono MulAction.Supports.mono
#align add_action.supports.mono AddAction.Supports.mono

end SMul

variable [Group H] [SMul G α] [SMul G β] [MulAction H α] [SMul H β] [SMulCommClass G H β]
  [SMulCommClass G H α] {s t : Set α} {b : β}

-- TODO: This should work without `SMulCommClass`
@[to_additive]

end MulAction


import .Preloaded data.nat.fib
import tactic

lemma lt_wrap {n m: nat} {h: n < m}: n.lt m
:= by assumption

lemma ind2 {C: ℕ → Prop} {n: ℕ}:
  C 0 → C 1 → (∀ k: ℕ, C k → C (k + 1) → C (k + 2)) → C n
:=
begin
  intros h0 h1 hstep,
  apply nat.lt_wf.induction,
  intros n ih,
  rcases n with _ | _ | n,
    assumption',
  apply hstep,
  apply ih n (by apply lt_wrap; omega),
  apply ih (n + 1) (by apply lt_wrap; omega),
end

lemma lem_phi2: phi^2 = phi + 1
:=
begin
  unfold phi,
  unfold pow monoid.pow,
  field_simp,
  ring_exp,
  rw [real.sqr_sqrt _],
  ring,
  linarith,
end

#check pow

lemma lem_psi2: psi^2 = psi + 1
:=
begin
  unfold psi,
  unfold pow monoid.pow,
  field_simp,
  ring_exp,
  rw [real.sqr_sqrt _],
  ring,
  linarith,
end

theorem binet (n : ℕ) : (nat.fib n : ℝ) = (phi^n - psi^n) / real.sqrt 5 :=
begin
  induction n using ind2 with n ihn1 ihn2,
  {
    simp,
  }, {
    simp,
    unfold phi psi,
    ring,
    symmetry,
    apply @inv_mul_cancel _ _ (real.sqrt 5) _,
    intro h,
    let h2 := (real.sqrt_eq_zero _).1 h,
    linarith,
    linarith,
  }, {
    rw nat.fib_succ_succ,
    simp,
    rw [ihn1, ihn2], clear ihn1 ihn2,
    conv {
      to_rhs,
      congr,
      rw [pow_add phi n 2, lem_phi2],
      rw [pow_add psi n 2, lem_psi2],
    },
    ring_exp,
  }
end


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import algebra.direct_sum.module
import data.finsupp.to_dfinsupp

/-!
# Results on direct sums and finitely supported functions.

1. The linear equivalence between finitely supported functions `ι →₀ M` and
the direct sum of copies of `M` indexed by `ι`.
-/

universes u v w

noncomputable theory
open_locale direct_sum

open linear_map submodule
variables {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]

section finsupp_lequiv_direct_sum

variables (R M) (ι : Type*) [decidable_eq ι]

/-- The finitely supported functions `ι →₀ M` are in linear equivalence with the direct sum of
copies of M indexed by ι. -/
def finsupp_lequiv_direct_sum : (ι →₀ M) ≃ₗ[R] ⨁ i : ι, M :=
by haveI : Π m : M, decidable (m ≠ 0) := classical.dec_pred _; exact finsupp_lequiv_dfinsupp R

@[simp] theorem finsupp_lequiv_direct_sum_single (i : ι) (m : M) :
  finsupp_lequiv_direct_sum R M ι (finsupp.single i m) = direct_sum.lof R ι _ i m :=
finsupp.to_dfinsupp_single i m

@[simp] theorem finsupp_lequiv_direct_sum_symm_lof (i : ι) (m : M) :
  (finsupp_lequiv_direct_sum R M ι).symm (direct_sum.lof R ι _ i m) = finsupp.single i m :=
begin
  letI : Π m : M, decidable (m ≠ 0) := classical.dec_pred _,
  exact (dfinsupp.to_finsupp_single i m),
end

end finsupp_lequiv_direct_sum


-- Notes 12/03/2019

/-
Continuing our journey of learning to prove propositions of the form P ∨ Q
-/

axiom Q : Prop
axiom q : Q -- axiomatically accept a proof of Q

axiom P : Prop

example : P ∨ Q :=
begin
    apply or.inr q
end

example : false ∨ Q :=
begin
    apply or.inr q
end

example : 0 = 1 ∨ 2 = 2 :=
begin
    apply or.inr,
    apply rfl,
end

example : 0 = 1 ∨ 2 = 2 := or.intro_right _ rfl

#check @or.intro_right
#check @or.inr -- shorthand version

example : P ∨ Q := or.intro_right P q

-- classical vs. constructive logic
example : P ∨ ¬P := sorry -- excluded middle: we can't prove this in constructive logic

-- in constructive logic, if we don't have a proof of P, but we also don't have a proof of ¬P, we can't construct a proof of P ∨ ¬P
-- c.f. the P=NP problem. We don't have a proof that P = NP, but we also don't have a proof that P != NP.

-- the excluded middle is a valid form of reasoning in classical logic
axiom excluded_middle : ∀ (P : Prop), P ∨ ¬P

example : P ∨ ¬P := excluded_middle P

example : P ∨ ¬P :=
begin
    apply classical.em
end

example : ∀ (P : Prop), ¬ ¬ P → P :=
begin
    assume P,
    assume nnp,
    cases (classical.em P) with hp hnp, -- we rely upon the law of the excluded middle to achieve this proof
    exact hp,
    contradiction,
end

/-
Proof by negation: when we want to show ¬P
Proof by negation: to prove ¬P, we show that P leads to a contradiction.

Assume P, show contradiction gives us ¬P
-/

/-
Proof by contradiction: prove P by showing ¬P → false (¬¬P → P)

If we want a proof that P is true, assume P is false, and show it leads to a contradiction

I.e. show that ¬P → false
i.e. ¬¬P holds

If we have the law of the excluded middle, we can show ¬¬P → P

Assume ¬P, show contradiction gives us P
-/

axiom Rational : nat → Prop

example : ¬¬(Rational 2) → Rational 2 :=
begin
    assume nnrt,
    cases (classical.em (Rational 2)),
    exact h,
    contradiction,
end


/-
Copyright (c) 2022 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa

! This file was ported from Lean 3 source module algebra.group.unique_prods
! leanprover-community/mathlib commit d6fad0e5bf2d6f48da9175d25c3dc5706b3834ce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finset.Preimage

/-!
#  Unique products and related notions

A group `G` has *unique products* if for any two non-empty finite subsets `A, B ⊂ G`, there is an
element `g ∈ A * B` that can be written uniquely as a product of an element of `A` and an element
of `B`.  We call the formalization this property `UniqueProds`.  Since the condition requires no
property of the group operation, we define it for a Type simply satisfying `Mul`.  We also
introduce the analogous "additive" companion, `UniqueSums` and link the two so that `to_additive`
converts `UniqueProds` into `UniqueSums`.

Here you can see several examples of Types that have `UniqueSums/Prods`
(`infer_instance` uses `covariants.to_uniqueProds` and `covariants.to_uniqueSums`).
```lean
import Mathlib.Data.Real.Basic
import Mathlib.Data.PNat.Basic
import Mathlib.Algebra.Group.UniqueProds

example : UniqueSums ℕ   := by infer_instance
example : UniqueSums ℕ+  := by infer_instance
example : UniqueSums ℤ   := by infer_instance
example : UniqueSums ℚ   := by infer_instance
example : UniqueSums ℝ   := by infer_instance
example : UniqueProds ℕ+ := by infer_instance
```
-/

/-- Let `G` be a Type with multiplication, let `A B : Finset G` be finite subsets and
let `a0 b0 : G` be two elements.  `UniqueMul A B a0 b0` asserts `a0 * b0` can be written in at
most one way as a product of an element of `A` and an element of `B`. -/
@[to_additive
      "Let `G` be a Type with addition, let `A B : Finset G` be finite subsets and
let `a0 b0 : G` be two elements.  `UniqueAdd A B a0 b0` asserts `a0 + b0` can be written in at
most one way as a sum of an element from `A` and an element from `B`."]
def UniqueMul {G} [Mul G] (A B : Finset G) (a0 b0 : G) : Prop :=
  ∀ ⦃a b⦄, a ∈ A → b ∈ B → a * b = a0 * b0 → a = a0 ∧ b = b0
#align unique_mul UniqueMul
#align unique_add UniqueAdd

namespace UniqueMul

variable {G H : Type _} [Mul G] [Mul H] {A B : Finset G} {a0 b0 : G}

theorem mt {G} [Mul G] {A B : Finset G} {a0 b0 : G} (h : UniqueMul A B a0 b0) :
    ∀ ⦃a b⦄, a ∈ A → b ∈ B → a ≠ a0 ∨ b ≠ b0 → a * b ≠ a0 * b0 := fun _ _ ha hb k ↦ by
  contrapose! k
  exact h ha hb k
#align unique_mul.mt UniqueMul.mt

@[to_additive]
theorem subsingleton (A B : Finset G) (a0 b0 : G) (h : UniqueMul A B a0 b0) :
    Subsingleton { ab : G × G // ab.1 ∈ A ∧ ab.2 ∈ B ∧ ab.1 * ab.2 = a0 * b0 } :=
  ⟨fun ⟨⟨_a, _b⟩, ha, hb, ab⟩ ⟨⟨_a', _b'⟩, ha', hb', ab'⟩ ↦
    Subtype.ext <|
      Prod.ext ((h ha hb ab).1.trans (h ha' hb' ab').1.symm) <|
        (h ha hb ab).2.trans (h ha' hb' ab').2.symm⟩
#align unique_mul.subsingleton UniqueMul.subsingleton
#align unique_add.subsingleton UniqueAdd.subsingleton

@[to_additive]
theorem set_subsingleton (A B : Finset G) (a0 b0 : G) (h : UniqueMul A B a0 b0) :
    Set.Subsingleton { ab : G × G | ab.1 ∈ A ∧ ab.2 ∈ B ∧ ab.1 * ab.2 = a0 * b0 } := by
  rintro ⟨x1, y1⟩ (hx : x1 ∈ A ∧ y1 ∈ B ∧ x1 * y1 = a0 * b0) ⟨x2, y2⟩
    (hy : x2 ∈ A ∧ y2 ∈ B ∧ x2 * y2 = a0 * b0)
  rcases h hx.1 hx.2.1 hx.2.2 with ⟨rfl, rfl⟩
  rcases h hy.1 hy.2.1 hy.2.2 with ⟨rfl, rfl⟩
  rfl
#align unique_mul.set_subsingleton UniqueMul.set_subsingleton
#align unique_add.set_subsingleton UniqueAdd.set_subsingleton

-- Porting note: mathport warning: expanding binder collection
--  (ab «expr ∈ » [finset.product/multiset.product/set.prod/list.product](A, B)) -/
-- Porting note: replaced `xˢ` by `xᶠ`
@[to_additive]
theorem iff_existsUnique (aA : a0 ∈ A) (bB : b0 ∈ B) :
    UniqueMul A B a0 b0 ↔ ∃! (ab : _)(_ : ab ∈ A ×ᶠ B), ab.1 * ab.2 = a0 * b0 :=
  ⟨fun _ ↦ ⟨(a0, b0), ⟨Finset.mem_product.mpr ⟨aA, bB⟩, rfl, by simp⟩, by simpa⟩,
    fun h ↦ h.elim₂
      (by
        rintro ⟨x1, x2⟩ _ _ J x y hx hy l
        rcases Prod.mk.inj_iff.mp (J (a0, b0) (Finset.mk_mem_product aA bB) rfl) with ⟨rfl, rfl⟩
        exact Prod.mk.inj_iff.mp (J (x, y) (Finset.mk_mem_product hx hy) l))⟩
#align unique_mul.iff_exists_unique UniqueMul.iff_existsUnique
#align unique_add.iff_exists_unique UniqueAdd.iff_existsUnique

-- Porting note: mathport warning: expanding binder collection
--  (ab «expr ∈ » [finset.product/multiset.product/set.prod/list.product](A, B)) -/
-- Porting note: replaced `xˢ` by `xᶠ`
@[to_additive]
theorem exists_iff_exists_existsUnique :
    (∃ a0 b0 : G, a0 ∈ A ∧ b0 ∈ B ∧ UniqueMul A B a0 b0) ↔
      ∃ g : G, ∃! (ab : _)(_ : ab ∈ A ×ᶠ B), ab.1 * ab.2 = g :=
  ⟨fun ⟨a0, b0, hA, hB, h⟩ ↦ ⟨_, (iff_existsUnique hA hB).mp h⟩, fun ⟨g, h⟩ ↦
    by
    have h' := h
    rcases h' with ⟨⟨a, b⟩, ⟨hab, rfl, -⟩, -⟩
    cases' Finset.mem_product.mp hab with ha hb
    exact ⟨a, b, ha, hb, (iff_existsUnique ha hb).mpr h⟩⟩
#align unique_mul.exists_iff_exists_exists_unique UniqueMul.exists_iff_exists_existsUnique
#align unique_add.exists_iff_exists_exists_unique UniqueAdd.exists_iff_exists_existsUnique

/-- `UniqueMul` is preserved by inverse images under injective, multiplicative maps. -/
@[to_additive "`UniqueAdd` is preserved by inverse images under injective, additive maps."]
theorem mulHom_preimage (f : G →ₙ* H) (hf : Function.Injective f) (a0 b0 : G) {A B : Finset H}
    (u : UniqueMul A B (f a0) (f b0)) :
    UniqueMul (A.preimage f (Set.injOn_of_injective hf _))
      (B.preimage f (Set.injOn_of_injective hf _)) a0 b0 := by
  intro a b ha hb ab
  rw [← hf.eq_iff, ← hf.eq_iff]
  rw [← hf.eq_iff, map_mul, map_mul] at ab
  exact u (Finset.mem_preimage.mp ha) (Finset.mem_preimage.mp hb) ab
#align unique_mul.mul_hom_preimage UniqueMul.mulHom_preimage
#align unique_add.add_hom_preimage UniqueAdd.addHom_preimage

/-- `Unique_Mul` is preserved under multiplicative maps that are injective.

See `UniqueMul.mulHom_map_iff` for a version with swapped bundling. -/
@[to_additive
      "`UniqueAdd` is preserved under additive maps that are injective.

See `UniqueAdd.addHom_map_iff` for a version with swapped bundling."]
theorem mulHom_image_iff [DecidableEq H] (f : G →ₙ* H) (hf : Function.Injective f) :
    UniqueMul (A.image f) (B.image f) (f a0) (f b0) ↔ UniqueMul A B a0 b0 := by
  refine' ⟨fun h ↦ _, fun h ↦ _⟩
  · intro a b ha hb ab
    rw [← hf.eq_iff, ← hf.eq_iff]
    rw [← hf.eq_iff, map_mul, map_mul] at ab
    exact h (Finset.mem_image.mpr ⟨_, ha, rfl⟩) (Finset.mem_image.mpr ⟨_, hb, rfl⟩) ab
  · intro a b aA bB ab
    obtain ⟨a, ha, rfl⟩ : ∃ a' ∈ A, f a' = a := Finset.mem_image.mp aA
    obtain ⟨b, hb, rfl⟩ : ∃ b' ∈ B, f b' = b := Finset.mem_image.mp bB
    rw [hf.eq_iff, hf.eq_iff]
    rw [← map_mul, ← map_mul, hf.eq_iff] at ab
    exact h ha hb ab
#align unique_mul.mul_hom_image_iff UniqueMul.mulHom_image_iff
#align unique_add.add_hom_image_iff UniqueAdd.addHom_image_iff

/-- `UniqueMul` is preserved under embeddings that are multiplicative.

See `UniqueMul.mulHom_image_iff` for a version with swapped bundling. -/
@[to_additive
      "`UniqueAdd` is preserved under embeddings that are additive.

See `UniqueAdd.addHom_image_iff` for a version with swapped bundling."]
theorem mulHom_map_iff (f : G ↪ H) (mul : ∀ x y, f (x * y) = f x * f y) :
    UniqueMul (A.map f) (B.map f) (f a0) (f b0) ↔ UniqueMul A B a0 b0 := by
  classical
  convert @mulHom_image_iff G H _ _ A B a0 b0 _ ⟨f, mul⟩ f.2 using 2 <;>
    · ext
      simp only [Finset.mem_map, MulHom.coe_mk, Finset.mem_image]
#align unique_mul.mul_hom_map_iff UniqueMul.mulHom_map_iff
#align unique_add.add_hom_map_iff UniqueAdd.addHom_map_iff

end UniqueMul

/-- Let `G` be a Type with addition.  `UniqueSums G` asserts that any two non-empty
finite subsets of `A` have the `UniqueAdd` property, with respect to some element of their
sum `A + B`. -/
class UniqueSums (G) [Add G] : Prop where
/-- For `A B` two nonempty finite sets, there always exist `a0 ∈ A, b0 ∈ B` such that
`UniqueAdd A B a0 b0` -/
  uniqueAdd_of_nonempty :
    ∀ {A B : Finset G} (_ : A.Nonempty) (_ : B.Nonempty), ∃ a0 ∈ A, ∃ b0 ∈ B, UniqueAdd A B a0 b0
#align unique_sums UniqueSums

/-- Let `G` be a Type with multiplication.  `UniqueProds G` asserts that any two non-empty
finite subsets of `G` have the `UniqueMul` property, with respect to some element of their
product `A * B`. -/
class UniqueProds (G) [Mul G] : Prop where
/-- For `A B` two nonempty finite sets, there always exist `a0 ∈ A, b0 ∈ B` such that
`UniqueMul A B a0 b0` -/
  uniqueMul_of_nonempty :
    ∀ {A B : Finset G} (_ : A.Nonempty) (_ : B.Nonempty), ∃ a0 ∈ A, ∃ b0 ∈ B, UniqueMul A B a0 b0
#align unique_prods UniqueProds

attribute [to_additive UniqueSums] UniqueProds

namespace Multiplicative

instance {M} [Add M] [UniqueSums M] : UniqueProds (Multiplicative M) where
  uniqueMul_of_nonempty {A} {B} hA hB := by
    let A' : Finset M := A
    have hA' : A'.Nonempty := hA
    obtain ⟨a0, hA0, b0, hB0, J⟩ := UniqueSums.uniqueAdd_of_nonempty hA' hB
    exact ⟨ofAdd a0, hA0, ofAdd b0, hB0, fun a b aA bB H ↦ J aA bB H⟩

end Multiplicative

namespace Additive

instance {M} [Mul M] [UniqueProds M] : UniqueSums (Additive M) where
  uniqueAdd_of_nonempty {A} {B} hA hB := by
    let A' : Finset M := A
    have hA' : A'.Nonempty := hA
    obtain ⟨a0, hA0, b0, hB0, J⟩ := UniqueProds.uniqueMul_of_nonempty hA' hB
    exact ⟨ofMul a0, hA0, ofMul b0, hB0, fun a b aA bB H ↦ J aA bB H⟩

end Additive

@[to_additive]
theorem eq_and_eq_of_le_of_le_of_mul_le {A} [Mul A] [LinearOrder A]
    [CovariantClass A A (· * ·) (· ≤ ·)] [CovariantClass A A (Function.swap (· * ·)) (· < ·)]
    [ContravariantClass A A (· * ·) (· ≤ ·)] {a b a0 b0 : A} (ha : a0 ≤ a) (hb : b0 ≤ b)
    (ab : a * b ≤ a0 * b0) : a = a0 ∧ b = b0 := by
  haveI := Mul.to_covariantClass_right A
  have ha' : ¬a0 * b0 < a * b → ¬a0 < a := mt fun h ↦ mul_lt_mul_of_lt_of_le h hb
  have hb' : ¬a0 * b0 < a * b → ¬b0 < b := mt fun h ↦ mul_lt_mul_of_le_of_lt ha h
  push_neg  at ha' hb'
  exact ⟨ha.antisymm' (ha' ab), hb.antisymm' (hb' ab)⟩
#align eq_and_eq_of_le_of_le_of_mul_le eq_and_eq_of_le_of_le_of_mul_le
#align eq_and_eq_of_le_of_le_of_add_le eq_and_eq_of_le_of_le_of_add_le

-- see Note [lower instance priority]
/-- This instance asserts that if `A` has a multiplication, a linear order, and multiplication
is 'very monotone', then `A` also has `UniqueProds`. -/
@[to_additive Covariants.to_uniqueSums
      "This instance asserts that if `A` has an addition, a linear order, and addition
is 'very monotone', then `A` also has `UniqueSums`."]
instance (priority := 100) Covariants.to_uniqueProds {A} [Mul A] [LinearOrder A]
    [CovariantClass A A (· * ·) (· ≤ ·)] [CovariantClass A A (Function.swap (· * ·)) (· < ·)]
    [ContravariantClass A A (· * ·) (· ≤ ·)] : UniqueProds A where
      uniqueMul_of_nonempty {A} {B} hA hB :=
        ⟨_, A.min'_mem ‹_›, _, B.min'_mem ‹_›, fun a b ha hb ab ↦
        eq_and_eq_of_le_of_le_of_mul_le (Finset.min'_le _ _ ‹_›) (Finset.min'_le _ _ ‹_›) ab.le⟩
#align covariants.to_unique_prods Covariants.to_uniqueProds
#align covariants.to_unique_sums Covariants.to_uniqueSums


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/
import algebra.big_operators.order
import data.mv_polynomial.monad

/-!
# Degrees and variables of polynomials

This file establishes many results about the degree and variable sets of a multivariate polynomial.

The *variable set* of a polynomial $P \in R[X]$ is a `finset` containing each $x \in X$
that appears in a monomial in $P$.

The *degree set* of a polynomial $P \in R[X]$ is a `multiset` containing, for each $x$ in the
variable set, $n$ copies of $x$, where $n$ is the maximum number of copies of $x$ appearing in a
monomial of $P$.

## Main declarations

* `mv_polynomial.degrees p` : the multiset of variables representing the union of the multisets
  corresponding to each non-zero monomial in `p`.
  For example if `7 ≠ 0` in `R` and `p = x²y+7y³` then `degrees p = {x, x, y, y, y}`

* `mv_polynomial.vars p` : the finset of variables occurring in `p`.
  For example if `p = x⁴y+yz` then `vars p = {x, y, z}`

* `mv_polynomial.degree_of n p : ℕ` : the total degree of `p` with respect to the variable `n`.
  For example if `p = x⁴y+yz` then `degree_of y p = 1`.

* `mv_polynomial.total_degree p : ℕ` :
  the max of the sizes of the multisets `s` whose monomials `X^s` occur in `p`.
  For example if `p = x⁴y+yz` then `total_degree p = 5`.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ τ : Type*` (indexing the variables)

+ `R : Type*` `[comm_semiring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `r : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

-/

noncomputable theory

open_locale classical big_operators

open set function finsupp add_monoid_algebra
open_locale big_operators

universes u v w
variables {R : Type u} {S : Type v}

namespace mv_polynomial
variables {σ τ : Type*} {r : R} {e : ℕ} {n m : σ} {s : σ →₀ ℕ}

section comm_semiring
variables [comm_semiring R] {p q : mv_polynomial σ R}

section degrees

/-! ### `degrees` -/

/--
The maximal degrees of each variable in a multi-variable polynomial, expressed as a multiset.

(For example, `degrees (x^2 * y + y^3)` would be `{x, x, y, y, y}`.)
-/
def degrees (p : mv_polynomial σ R) : multiset σ :=
p.support.sup (λs:σ →₀ ℕ, s.to_multiset)

lemma degrees_monomial (s : σ →₀ ℕ) (a : R) : degrees (monomial s a) ≤ s.to_multiset :=
finset.sup_le $ assume t h,
begin
  have := finsupp.support_single_subset h,
  rw [finset.mem_singleton] at this,
  rw this
end

lemma degrees_monomial_eq (s : σ →₀ ℕ) (a : R) (ha : a ≠ 0) :
  degrees (monomial s a) = s.to_multiset :=
le_antisymm (degrees_monomial s a) $ finset.le_sup $
  by rw [support_monomial, if_neg ha, finset.mem_singleton]

lemma degrees_C (a : R) : degrees (C a : mv_polynomial σ R) = 0 :=
multiset.le_zero.1 $ degrees_monomial _ _

lemma degrees_X' (n : σ) : degrees (X n : mv_polynomial σ R) ≤ {n} :=
le_trans (degrees_monomial _ _) $ le_of_eq $ to_multiset_single _ _

@[simp] lemma degrees_X [nontrivial R] (n : σ) : degrees (X n : mv_polynomial σ R) = {n} :=
(degrees_monomial_eq _ (1 : R) one_ne_zero).trans (to_multiset_single _ _)

@[simp] lemma degrees_zero : degrees (0 : mv_polynomial σ R) = 0 :=
by { rw ← C_0, exact degrees_C 0 }

@[simp] lemma degrees_one : degrees (1 : mv_polynomial σ R) = 0 := degrees_C 1

lemma degrees_add (p q : mv_polynomial σ R) : (p + q).degrees ≤ p.degrees ⊔ q.degrees :=
begin
  refine finset.sup_le (assume b hb, _),
  have := finsupp.support_add hb, rw finset.mem_union at this,
  cases this,
  { exact le_sup_of_le_left (finset.le_sup this) },
  { exact le_sup_of_le_right (finset.le_sup this) },
end

lemma degrees_sum {ι : Type*} (s : finset ι) (f : ι → mv_polynomial σ R) :
  (∑ i in s, f i).degrees ≤ s.sup (λi, (f i).degrees) :=
begin
  refine s.induction _ _,
  { simp only [finset.sum_empty, finset.sup_empty, degrees_zero], exact le_rfl },
  { assume i s his ih,
    rw [finset.sup_insert, finset.sum_insert his],
    exact le_trans (degrees_add _ _) (sup_le_sup_left ih _) }
end

lemma degrees_mul (p q : mv_polynomial σ R) : (p * q).degrees ≤ p.degrees + q.degrees :=
begin
  refine finset.sup_le (assume b hb, _),
  have := support_mul p q hb,
  simp only [finset.mem_bUnion, finset.mem_singleton] at this,
  rcases this with ⟨a₁, h₁, a₂, h₂, rfl⟩,
  rw [finsupp.to_multiset_add],
  exact add_le_add (finset.le_sup h₁) (finset.le_sup h₂)
end

lemma degrees_prod {ι : Type*} (s : finset ι) (f : ι → mv_polynomial σ R) :
  (∏ i in s, f i).degrees ≤ ∑ i in s, (f i).degrees :=
begin
  refine s.induction _ _,
  { simp only [finset.prod_empty, finset.sum_empty, degrees_one] },
  { assume i s his ih,
    rw [finset.prod_insert his, finset.sum_insert his],
    exact le_trans (degrees_mul _ _) (add_le_add_left ih _) }
end

lemma degrees_pow (p : mv_polynomial σ R) :
  ∀(n : ℕ), (p^n).degrees ≤ n • p.degrees
| 0       := begin rw [pow_zero, degrees_one], exact multiset.zero_le _ end
| (n + 1) := by { rw [pow_succ, add_smul, add_comm, one_smul],
    exact le_trans (degrees_mul _ _) (add_le_add_left (degrees_pow n) _) }

lemma mem_degrees {p : mv_polynomial σ R} {i : σ} :
  i ∈ p.degrees ↔ ∃ d, p.coeff d ≠ 0 ∧ i ∈ d.support :=
by simp only [degrees, multiset.mem_sup, ← mem_support_iff,
    finsupp.mem_to_multiset, exists_prop]

lemma le_degrees_add {p q : mv_polynomial σ R} (h : p.degrees.disjoint q.degrees) :
  p.degrees ≤ (p + q).degrees :=
begin
  apply finset.sup_le,
  intros d hd,
  rw multiset.disjoint_iff_ne at h,
  rw multiset.le_iff_count,
  intros i,
  rw [degrees, multiset.count_finset_sup],
  simp only [finsupp.count_to_multiset],
  by_cases h0 : d = 0,
  { simp only [h0, zero_le, finsupp.zero_apply], },
  { refine @finset.le_sup _ _ _ _ (p + q).support _ d _,
    rw [mem_support_iff, coeff_add],
    suffices : q.coeff d = 0,
    { rwa [this, add_zero, coeff, ← finsupp.mem_support_iff], },
    rw [← finsupp.support_eq_empty, ← ne.def, ← finset.nonempty_iff_ne_empty] at h0,
    obtain ⟨j, hj⟩ := h0,
    contrapose! h,
    rw mem_support_iff at hd,
    refine ⟨j, _, j, _, rfl⟩,
    all_goals { rw mem_degrees, refine ⟨d, _, hj⟩, assumption } }
end

lemma degrees_add_of_disjoint
  {p q : mv_polynomial σ R} (h : multiset.disjoint p.degrees q.degrees) :
  (p + q).degrees = p.degrees ∪ q.degrees :=
begin
  apply le_antisymm,
  { apply degrees_add },
  { apply multiset.union_le,
    { apply le_degrees_add h },
    { rw add_comm, apply le_degrees_add h.symm } }
end

lemma degrees_map [comm_semiring S] (p : mv_polynomial σ R) (f : R →+* S) :
  (map f p).degrees ⊆ p.degrees :=
begin
  dsimp only [degrees],
  apply multiset.subset_of_le,
  apply finset.sup_mono,
  apply mv_polynomial.support_map_subset
end

lemma degrees_rename (f : σ → τ) (φ : mv_polynomial σ R) :
  (rename f φ).degrees ⊆ (φ.degrees.map f) :=
begin
  intros i,
  rw [mem_degrees, multiset.mem_map],
  rintro ⟨d, hd, hi⟩,
  obtain ⟨x, rfl, hx⟩ := coeff_rename_ne_zero _ _ _ hd,
  simp only [map_domain, finsupp.mem_support_iff] at hi,
  rw [sum_apply, finsupp.sum] at hi,
  contrapose! hi,
  rw [finset.sum_eq_zero],
  intros j hj,
  simp only [exists_prop, mem_degrees] at hi,
  specialize hi j ⟨x, hx, hj⟩,
  rw [single_apply, if_neg hi],
end

lemma degrees_map_of_injective [comm_semiring S] (p : mv_polynomial σ R)
  {f : R →+* S} (hf : injective f) : (map f p).degrees = p.degrees :=
by simp only [degrees, mv_polynomial.support_map_of_injective _ hf]

lemma degrees_rename_of_injective {p : mv_polynomial σ R} {f : σ → τ} (h : function.injective f) :
  degrees (rename f p) = (degrees p).map f :=
begin
  simp only [degrees, multiset.map_finset_sup p.support finsupp.to_multiset f h,
             support_rename_of_injective h, finset.sup_image],
  refine finset.sup_congr rfl (λ x hx, _),
  exact (finsupp.to_multiset_map _ _).symm,
end

end degrees

section vars

/-! ### `vars` -/

/-- `vars p` is the set of variables appearing in the polynomial `p` -/
def vars (p : mv_polynomial σ R) : finset σ := p.degrees.to_finset

@[simp] lemma vars_0 : (0 : mv_polynomial σ R).vars = ∅ :=
by rw [vars, degrees_zero, multiset.to_finset_zero]

@[simp] lemma vars_monomial (h : r ≠ 0) : (monomial s r).vars = s.support :=
by rw [vars, degrees_monomial_eq _ _ h, finsupp.to_finset_to_multiset]

@[simp] lemma vars_C : (C r : mv_polynomial σ R).vars = ∅ :=
by rw [vars, degrees_C, multiset.to_finset_zero]

@[simp] lemma vars_X [nontrivial R] : (X n : mv_polynomial σ R).vars = {n} :=
by rw [X, vars_monomial (@one_ne_zero R _ _), finsupp.support_single_ne_zero (one_ne_zero : 1 ≠ 0)]

lemma mem_vars (i : σ) :
  i ∈ p.vars ↔ ∃ (d : σ →₀ ℕ) (H : d ∈ p.support), i ∈ d.support :=
by simp only [vars, multiset.mem_to_finset, mem_degrees, mem_support_iff,
  exists_prop]

lemma mem_support_not_mem_vars_zero
  {f : mv_polynomial σ R} {x : σ →₀ ℕ} (H : x ∈ f.support) {v : σ} (h : v ∉ vars f) :
  x v = 0 :=
begin
  rw [vars, multiset.mem_to_finset] at h,
  rw ← finsupp.not_mem_support_iff,
  contrapose! h,
  unfold degrees,
  rw (show f.support = insert x f.support, from eq.symm $ finset.insert_eq_of_mem H),
  rw finset.sup_insert,
  simp only [multiset.mem_union, multiset.sup_eq_union],
  left,
  rwa [←to_finset_to_multiset, multiset.mem_to_finset] at h,
end

lemma vars_add_subset (p q : mv_polynomial σ R) :
  (p + q).vars ⊆ p.vars ∪ q.vars :=
begin
  intros x hx,
  simp only [vars, finset.mem_union, multiset.mem_to_finset] at hx ⊢,
  simpa using multiset.mem_of_le (degrees_add _ _) hx,
end

section mul

lemma vars_mul (φ ψ : mv_polynomial σ R) : (φ * ψ).vars ⊆ φ.vars ∪ ψ.vars :=
begin
  intro i,
  simp only [mem_vars, finset.mem_union],
  rintro ⟨d, hd, hi⟩,
  rw [mem_support_iff, coeff_mul] at hd,
  contrapose! hd, cases hd,
  rw finset.sum_eq_zero,
  rintro ⟨d₁, d₂⟩ H,
  rw finsupp.mem_antidiagonal at H,
  subst H,
  obtain H|H : i ∈ d₁.support ∨ i ∈ d₂.support,
  { simpa only [finset.mem_union] using finsupp.support_add hi, },
  { suffices : coeff d₁ φ = 0, by simp [this],
    rw [coeff, ← finsupp.not_mem_support_iff], intro, solve_by_elim, },
  { suffices : coeff d₂ ψ = 0, by simp [this],
    rw [coeff, ← finsupp.not_mem_support_iff], intro, solve_by_elim, },
end

@[simp] lemma vars_one : (1 : mv_polynomial σ R).vars = ∅ :=
vars_C

lemma vars_pow (φ : mv_polynomial σ R) (n : ℕ) : (φ ^ n).vars ⊆ φ.vars :=
begin
  induction n with n ih,
  { simp },
  { rw pow_succ,
    apply finset.subset.trans (vars_mul _ _),
    exact finset.union_subset (finset.subset.refl _) ih }
end

/--
The variables of the product of a family of polynomials
are a subset of the union of the sets of variables of each polynomial.
-/
lemma vars_prod {ι : Type*} {s : finset ι} (f : ι → mv_polynomial σ R) :
  (∏ i in s, f i).vars ⊆ s.bUnion (λ i, (f i).vars) :=
begin
  apply s.induction_on,
  { simp },
  { intros a s hs hsub,
    simp only [hs, finset.bUnion_insert, finset.prod_insert, not_false_iff],
    apply finset.subset.trans (vars_mul _ _),
    exact finset.union_subset_union (finset.subset.refl _) hsub }
end

section is_domain
variables {A : Type*} [comm_ring A] [is_domain A]

lemma vars_C_mul (a : A) (ha : a ≠ 0) (φ : mv_polynomial σ A) : (C a * φ).vars = φ.vars :=
begin
  ext1 i,
  simp only [mem_vars, exists_prop, mem_support_iff],
  apply exists_congr,
  intro d,
  apply and_congr _ iff.rfl,
  rw [coeff_C_mul, mul_ne_zero_iff, eq_true_intro ha, true_and],
end

end is_domain

end mul

section sum

variables {ι : Type*} (t : finset ι) (φ : ι → mv_polynomial σ R)

lemma vars_sum_subset :
  (∑ i in t, φ i).vars ⊆ finset.bUnion t (λ i, (φ i).vars) :=
begin
  apply t.induction_on,
  { simp },
  { intros a s has hsum,
    rw [finset.bUnion_insert, finset.sum_insert has],
    refine finset.subset.trans (vars_add_subset _ _)
      (finset.union_subset_union (finset.subset.refl _) _),
    assumption }
end

lemma vars_sum_of_disjoint (h : pairwise $ disjoint on (λ i, (φ i).vars)) :
  (∑ i in t, φ i).vars = finset.bUnion t (λ i, (φ i).vars) :=
begin
  apply t.induction_on,
  { simp },
  { intros a s has hsum,
    rw [finset.bUnion_insert, finset.sum_insert has, vars_add_of_disjoint, hsum],
    unfold pairwise on_fun at h,
    rw hsum,
    simp only [finset.disjoint_iff_ne] at h ⊢,
    intros v hv v2 hv2,
    rw finset.mem_bUnion at hv2,
    rcases hv2 with ⟨i, his, hi⟩,
    refine h a i _ _ hv _ hi,
    rintro rfl,
    contradiction }
end

end sum

section map

variables [comm_semiring S] (f : R →+* S)
variable (p)

lemma vars_map : (map f p).vars ⊆ p.vars :=
by simp [vars, degrees_map]

variable {f}
lemma vars_map_of_injective (hf : injective f) :
  (map f p).vars = p.vars :=
by simp [vars, degrees_map_of_injective _ hf]

lemma vars_monomial_single (i : σ) {e : ℕ} {r : R} (he : e ≠ 0) (hr : r ≠ 0) :
  (monomial (finsupp.single i e) r).vars = {i} :=
by rw [vars_monomial hr, finsupp.support_single_ne_zero he]

lemma vars_eq_support_bUnion_support : p.vars = p.support.bUnion finsupp.support :=
by { ext i, rw [mem_vars, finset.mem_bUnion] }

end map

end vars

section degree_of

/-! ### `degree_of` -/

/-- `degree_of n p` gives the highest power of X_n that appears in `p` -/
def degree_of (n : σ) (p : mv_polynomial σ R) : ℕ := p.degrees.count n

lemma degree_of_eq_sup (n : σ) (f : mv_polynomial σ R) :
  degree_of n f = f.support.sup (λ m, m n) :=
begin
  rw [degree_of, degrees, multiset.count_finset_sup],
  congr,
  ext,
  simp,
end

lemma degree_of_lt_iff {n : σ} {f : mv_polynomial σ R} {d : ℕ} (h : 0 < d) :
  degree_of n f < d ↔ ∀ m : σ →₀ ℕ, m ∈ f.support → m n < d :=
by rwa [degree_of_eq_sup n f, finset.sup_lt_iff]

@[simp] lemma degree_of_zero (n : σ) :
  degree_of n (0 : mv_polynomial σ R) = 0 :=
by simp only [degree_of, degrees_zero, multiset.count_zero]

@[simp] lemma degree_of_C (a : R) (x : σ):
  degree_of x (C a : mv_polynomial σ R) = 0 := by simp [degree_of, degrees_C]

lemma degree_of_X (i j : σ) [nontrivial R] :
  degree_of i (X j : mv_polynomial σ R) = if i = j then 1 else 0 :=
begin
  by_cases c : i = j,
  { simp only [c, if_true, eq_self_iff_true, degree_of, degrees_X, multiset.count_singleton] },
  simp [c, if_false, degree_of, degrees_X],
end

lemma degree_of_add_le (n : σ) (f g : mv_polynomial σ R) :
  degree_of n (f + g) ≤ max (degree_of n f) (degree_of n g) :=
begin
  repeat {rw degree_of},
  apply (multiset.count_le_of_le n (degrees_add f g)).trans,
  dsimp,
  rw multiset.count_union,
end

lemma monomial_le_degree_of (i : σ) {f : mv_polynomial σ R} {m : σ →₀ ℕ}
  (h_m : m ∈ f.support) : m i ≤ degree_of i f :=
begin
  rw degree_of_eq_sup i,
  apply finset.le_sup h_m,
end

-- TODO we can prove equality here if R is a domain
lemma degree_of_mul_le (i : σ) (f g: mv_polynomial σ R) :
  degree_of i (f * g) ≤ degree_of i f + degree_of i g :=
begin
  repeat {rw degree_of},
  convert multiset.count_le_of_le i (degrees_mul f g),
  rw multiset.count_add,
end

lemma degree_of_mul_X_ne {i j : σ} (f : mv_polynomial σ R) (h : i ≠ j) :
  degree_of i (f * X j) = degree_of i f :=
begin
  repeat {rw degree_of_eq_sup i},
  rw support_mul_X,
  simp only [finset.sup_map],
  congr,
  ext,
  simp only [ single, nat.one_ne_zero, add_right_eq_self, add_right_embedding_apply, coe_mk,
              pi.add_apply, comp_app, ite_eq_right_iff, coe_add ],
  cc,
end

/- TODO in the following we have equality iff f ≠ 0 -/
lemma degree_of_mul_X_eq (j : σ) (f : mv_polynomial σ R) :
  degree_of j (f * X j) ≤ degree_of j f + 1 :=
begin
  repeat {rw degree_of},
  apply (multiset.count_le_of_le j (degrees_mul f (X j))).trans,
  simp only [multiset.count_add, add_le_add_iff_left],
  convert multiset.count_le_of_le j (degrees_X' j),
  rw multiset.count_singleton_self,
end

lemma degree_of_rename_of_injective {p : mv_polynomial σ R} {f : σ → τ} (h : function.injective f)
  (i : σ) : degree_of (f i) (rename f p) = degree_of i p :=
by simp only [degree_of, degrees_rename_of_injective h,
              multiset.count_map_eq_count' f (p.degrees) h]

end degree_of

section total_degree

/-! ### `total_degree` -/

/-- `total_degree p` gives the maximum |s| over the monomials X^s in `p` -/
def total_degree (p : mv_polynomial σ R) : ℕ := p.support.sup (λs, s.sum $ λn e, e)

lemma total_degree_eq (p : mv_polynomial σ R) :
  p.total_degree = p.support.sup (λm, m.to_multiset.card) :=
begin
  rw [total_degree],
  congr, funext m,
  exact (finsupp.card_to_multiset _).symm
end

lemma total_degree_le_degrees_card (p : mv_polynomial σ R) :
  p.total_degree ≤ p.degrees.card :=
begin
  rw [total_degree_eq],
  exact finset.sup_le (assume s hs, multiset.card_le_of_le $ finset.le_sup hs)
end

@[simp] lemma total_degree_C (a : R) : (C a : mv_polynomial σ R).total_degree = 0 :=
nat.eq_zero_of_le_zero $ finset.sup_le $ assume n hn,
  have _ := finsupp.support_single_subset hn,
  begin
    rw [finset.mem_singleton] at this,
    subst this,
    exact le_rfl
  end

@[simp] lemma total_degree_zero : (0 : mv_polynomial σ R).total_degree = 0 :=
by rw [← C_0]; exact total_degree_C (0 : R)

@[simp] lemma total_degree_one : (1 : mv_polynomial σ R).total_degree = 0 :=
total_degree_C (1 : R)

@[simp] lemma total_degree_X {R} [comm_semiring R] [nontrivial R] (s : σ) :
  (X s : mv_polynomial σ R).total_degree = 1 :=
begin
  rw [total_degree, support_X],
  simp only [finset.sup, sum_single_index, finset.fold_singleton, sup_bot_eq],
end

lemma total_degree_add (a b : mv_polynomial σ R) :
  (a + b).total_degree ≤ max a.total_degree b.total_degree :=
finset.sup_le $ assume n hn,
  have _ := finsupp.support_add hn,
  begin
    rw finset.mem_union at this,
    cases this,
    { exact le_max_of_le_left (finset.le_sup this) },
    { exact le_max_of_le_right (finset.le_sup this) }
  end

lemma total_degree_add_eq_left_of_total_degree_lt {p q : mv_polynomial σ R}
  (h : q.total_degree < p.total_degree) : (p + q).total_degree = p.total_degree :=
begin
  classical,
  apply le_antisymm,
  { rw ← max_eq_left_of_lt h,
    exact total_degree_add p q, },
  by_cases hp : p = 0,
  { simp [hp], },
  obtain ⟨b, hb₁, hb₂⟩ := p.support.exists_mem_eq_sup (finsupp.support_nonempty_iff.mpr hp)
    (λ (m : σ →₀ ℕ), m.to_multiset.card),
  have hb : ¬ b ∈ q.support,
  { contrapose! h,
    rw [total_degree_eq p, hb₂, total_degree_eq],
    apply finset.le_sup h, },
  have hbb : b ∈ (p + q).support,
  { apply support_sdiff_support_subset_support_add,
    rw finset.mem_sdiff,
    exact ⟨hb₁, hb⟩, },
  rw [total_degree_eq, hb₂, total_degree_eq],
  exact finset.le_sup hbb,
end

lemma total_degree_add_eq_right_of_total_degree_lt {p q : mv_polynomial σ R}
  (h : q.total_degree < p.total_degree) : (q + p).total_degree = p.total_degree :=
by rw [add_comm, total_degree_add_eq_left_of_total_degree_lt h]

lemma total_degree_mul (a b : mv_polynomial σ R) :
  (a * b).total_degree ≤ a.total_degree + b.total_degree :=
finset.sup_le $ assume n hn,
  have _ := add_monoid_algebra.support_mul a b hn,
  begin
    simp only [finset.mem_bUnion, finset.mem_singleton] at this,
    rcases this with ⟨a₁, h₁, a₂, h₂, rfl⟩,
    rw [finsupp.sum_add_index],
    { exact add_le_add (finset.le_sup h₁) (finset.le_sup h₂) },
    { assume a, refl },
    { assume a b₁ b₂, refl }
  end

lemma total_degree_pow (a : mv_polynomial σ R) (n : ℕ) :
  (a ^ n).total_degree ≤ n * a.total_degree :=
begin
  induction n with n ih,
  { simp only [nat.nat_zero_eq_zero, zero_mul, pow_zero, total_degree_one] },
  rw pow_succ,
  calc total_degree (a * a ^ n) ≤ a.total_degree + (a^n).total_degree : total_degree_mul _ _
    ... ≤ a.total_degree + n * a.total_degree : add_le_add_left ih _
    ... = (n+1) * a.total_degree : by rw [add_mul, one_mul, add_comm]
end

@[simp] lemma total_degree_monomial (s : σ →₀ ℕ) {c : R} (hc : c ≠ 0) :
  (monomial s c : mv_polynomial σ R).total_degree = s.sum (λ _ e, e) :=
by simp [total_degree, support_monomial, if_neg hc]

@[simp] lemma total_degree_X_pow [nontrivial R] (s : σ) (n : ℕ) :
  (X s ^ n : mv_polynomial σ R).total_degree = n :=
by simp [X_pow_eq_monomial, one_ne_zero]

lemma total_degree_list_prod :
  ∀(s : list (mv_polynomial σ R)), s.prod.total_degree ≤ (s.map mv_polynomial.total_degree).sum
| []        := by rw [@list.prod_nil (mv_polynomial σ R) _, total_degree_one]; refl
| (p :: ps) :=
  begin
    rw [@list.prod_cons (mv_polynomial σ R) _, list.map, list.sum_cons],
    exact le_trans (total_degree_mul _ _) (add_le_add_left (total_degree_list_prod ps) _)
  end

lemma total_degree_multiset_prod (s : multiset (mv_polynomial σ R)) :
  s.prod.total_degree ≤ (s.map mv_polynomial.total_degree).sum :=
begin
  refine quotient.induction_on s (assume l, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod, multiset.coe_map, multiset.coe_sum],
  exact total_degree_list_prod l
end

lemma total_degree_finset_prod {ι : Type*}
  (s : finset ι) (f : ι → mv_polynomial σ R) :
  (s.prod f).total_degree ≤ ∑ i in s, (f i).total_degree :=
begin
  refine le_trans (total_degree_multiset_prod _) _,
  rw [multiset.map_map],
  refl
end

lemma total_degree_finset_sum {ι : Type*} (s : finset ι) (f : ι → mv_polynomial σ R) :
  (s.sum f).total_degree ≤ finset.sup s (λ i, (f i).total_degree) :=
begin
  induction s using finset.cons_induction with a s has hind,
  { exact zero_le _ },
  { rw [finset.sum_cons, finset.sup_cons, sup_eq_max],
    exact (mv_polynomial.total_degree_add _ _).trans (max_le_max le_rfl hind), }
end

lemma exists_degree_lt [fintype σ] (f : mv_polynomial σ R) (n : ℕ)
  (h : f.total_degree < n * fintype.card σ) {d : σ →₀ ℕ} (hd : d ∈ f.support) :
  ∃ i, d i < n :=
begin
  contrapose! h,
  calc n * fintype.card σ
        = ∑ s:σ, n         : by rw [finset.sum_const, nat.nsmul_eq_mul, mul_comm, finset.card_univ]
    ... ≤ ∑ s, d s         : finset.sum_le_sum (λ s _, h s)
    ... ≤ d.sum (λ i e, e) : by { rw [finsupp.sum_fintype], intros, refl }
    ... ≤ f.total_degree   : finset.le_sup hd,
end

lemma coeff_eq_zero_of_total_degree_lt {f : mv_polynomial σ R} {d : σ →₀ ℕ}
  (h : f.total_degree < ∑ i in d.support, d i) :
  coeff d f = 0 :=
begin
  classical,
  rw [total_degree, finset.sup_lt_iff] at h,
  { specialize h d, rw mem_support_iff at h,
    refine not_not.mp (mt h _), exact lt_irrefl _, },
  { exact lt_of_le_of_lt (nat.zero_le _) h, }
end

lemma total_degree_rename_le (f : σ → τ) (p : mv_polynomial σ R) :
  (rename f p).total_degree ≤ p.total_degree :=
finset.sup_le $ assume b,
begin
  assume h,
  rw rename_eq at h,
  have h' := finsupp.map_domain_support h,
  rw finset.mem_image at h',
  rcases h' with ⟨s, hs, rfl⟩,
  rw finsupp.sum_map_domain_index,
  exact le_trans le_rfl (finset.le_sup hs),
  exact assume _, rfl,
  exact assume _ _ _, rfl
end

end total_degree

section eval_vars

/-! ### `vars` and `eval` -/

variables [comm_semiring S]

lemma eval₂_hom_eq_constant_coeff_of_vars (f : R →+* S) {g : σ → S}
  {p : mv_polynomial σ R} (hp : ∀ i ∈ p.vars, g i = 0) :
  eval₂_hom f g p = f (constant_coeff p) :=
begin
  conv_lhs { rw p.as_sum },
  simp only [ring_hom.map_sum, eval₂_hom_monomial],
  by_cases h0 : constant_coeff p = 0,
  work_on_goal 0
  { rw [h0, f.map_zero, finset.sum_eq_zero],
    intros d hd },
  work_on_goal 1
  { rw [finset.sum_eq_single (0 : σ →₀ ℕ)],
    { rw [finsupp.prod_zero_index, mul_one],
      refl },
    intros d hd hd0, },
  repeat
  { obtain ⟨i, hi⟩ : d.support.nonempty,
    { rw [constant_coeff_eq, coeff, ← finsupp.not_mem_support_iff] at h0,
      rw [finset.nonempty_iff_ne_empty, ne.def, finsupp.support_eq_empty],
      rintro rfl, contradiction },
    rw [finsupp.prod, finset.prod_eq_zero hi, mul_zero],
    rw [hp, zero_pow (nat.pos_of_ne_zero $ finsupp.mem_support_iff.mp hi)],
    rw [mem_vars],
    exact ⟨d, hd, hi⟩ },
  { rw [constant_coeff_eq, coeff, ← ne.def, ← finsupp.mem_support_iff] at h0,
    intro, contradiction }
end

lemma aeval_eq_constant_coeff_of_vars [algebra R S] {g : σ → S}
  {p : mv_polynomial σ R} (hp : ∀ i ∈ p.vars, g i = 0) :
  aeval g p = algebra_map _ _ (constant_coeff p) :=
eval₂_hom_eq_constant_coeff_of_vars _ hp

lemma eval₂_hom_congr' {f₁ f₂ : R →+* S} {g₁ g₂ : σ → S} {p₁ p₂ : mv_polynomial σ R} :
  f₁ = f₂ → (∀ i, i ∈ p₁.vars → i ∈ p₂.vars → g₁ i = g₂ i) → p₁ = p₂ →
   eval₂_hom f₁ g₁ p₁ = eval₂_hom f₂ g₂ p₂ :=
begin
  rintro rfl h rfl,
  rename [p₁ p, f₁ f],
  rw p.as_sum,
  simp only [ring_hom.map_sum, eval₂_hom_monomial],
  apply finset.sum_congr rfl,
  intros d hd,
  congr' 1,
  simp only [finsupp.prod],
  apply finset.prod_congr rfl,
  intros i hi,
  have : i ∈ p.vars, { rw mem_vars, exact ⟨d, hd, hi⟩ },
  rw h i this this,
end

/-- If `f₁` and `f₂` are ring homs out of the polynomial ring and `p₁` and `p₂` are polynomials,
  then `f₁ p₁ = f₂ p₂` if `p₁ = p₂` and `f₁` and `f₂` are equal on `R` and on the variables
  of `p₁`.  -/
lemma hom_congr_vars {f₁ f₂ : mv_polynomial σ R →+* S} {p₁ p₂ : mv_polynomial σ R}
  (hC : f₁.comp C = f₂.comp C) (hv : ∀ i, i ∈ p₁.vars → i ∈ p₂.vars → f₁ (X i) = f₂ (X i))
  (hp : p₁ = p₂) : f₁ p₁ = f₂ p₂ :=
calc f₁ p₁ = eval₂_hom (f₁.comp C) (f₁ ∘ X) p₁ : ring_hom.congr_fun (by ext; simp) _
... = eval₂_hom (f₂.comp C) (f₂ ∘ X) p₂ :
  eval₂_hom_congr' hC hv hp
... = f₂ p₂ : ring_hom.congr_fun (by ext; simp) _

lemma exists_rename_eq_of_vars_subset_range
  (p : mv_polynomial σ R) (f : τ → σ)
  (hfi : injective f) (hf : ↑p.vars ⊆ set.range f) :
  ∃ q : mv_polynomial τ R, rename f q = p :=
⟨bind₁ (λ i : σ, option.elim (partial_inv f i) 0 X) p,
  begin
    show (rename f).to_ring_hom.comp _ p = ring_hom.id _ p,
    refine hom_congr_vars _ _ _,
    { ext1,
      simp [algebra_map_eq] },
    { intros i hip _,
      rcases hf hip with ⟨i, rfl⟩,
      simp [partial_inv_left hfi] },
    { refl }
  end⟩

lemma vars_bind₁ (f : σ → mv_polynomial τ R) (φ : mv_polynomial σ R) :
  (bind₁ f φ).vars ⊆ φ.vars.bUnion (λ i, (f i).vars) :=
begin
  calc (bind₁ f φ).vars
      = (φ.support.sum (λ (x : σ →₀ ℕ), (bind₁ f) (monomial x (coeff x φ)))).vars :
        by { rw [← alg_hom.map_sum, ← φ.as_sum], }
  ... ≤ φ.support.bUnion (λ (i : σ →₀ ℕ), ((bind₁ f) (monomial i (coeff i φ))).vars) :
        vars_sum_subset _ _
  ... = φ.support.bUnion (λ (d : σ →₀ ℕ), (C (coeff d φ) * ∏ i in d.support, f i ^ d i).vars) :
        by simp only [bind₁_monomial]
  ... ≤ φ.support.bUnion (λ (d : σ →₀ ℕ), d.support.bUnion (λ i, (f i).vars)) : _ -- proof below
  ... ≤ φ.vars.bUnion (λ (i : σ), (f i).vars) : _, -- proof below
  { apply finset.bUnion_mono,
    intros d hd,
    calc (C (coeff d φ) * ∏ (i : σ) in d.support, f i ^ d i).vars
        ≤ (C (coeff d φ)).vars ∪ (∏ (i : σ) in d.support, f i ^ d i).vars : vars_mul _ _
    ... ≤ (∏ (i : σ) in d.support, f i ^ d i).vars :
      by simp only [finset.empty_union, vars_C, finset.le_iff_subset, finset.subset.refl]
    ... ≤ d.support.bUnion (λ (i : σ), (f i ^ d i).vars) : vars_prod _
    ... ≤ d.support.bUnion (λ (i : σ), (f i).vars) : _,
    apply finset.bUnion_mono,
    intros i hi,
    apply vars_pow, },
  { intro j,
    simp_rw finset.mem_bUnion,
    rintro ⟨d, hd, ⟨i, hi, hj⟩⟩,
    exact ⟨i, (mem_vars _).mpr ⟨d, hd, hi⟩, hj⟩ }
end

lemma mem_vars_bind₁ (f : σ → mv_polynomial τ R) (φ : mv_polynomial σ R) {j : τ}
  (h : j ∈ (bind₁ f φ).vars) :
  ∃ (i : σ), i ∈ φ.vars ∧ j ∈ (f i).vars :=
by simpa only [exists_prop, finset.mem_bUnion, mem_support_iff, ne.def] using vars_bind₁ f φ h

lemma vars_rename (f : σ → τ) (φ : mv_polynomial σ R) :
  (rename f φ).vars ⊆ (φ.vars.image f) :=
begin
  intros i hi,
  simp only [vars, exists_prop, multiset.mem_to_finset, finset.mem_image] at hi ⊢,
  simpa only [multiset.mem_map] using degrees_rename _ _ hi
end

lemma mem_vars_rename (f : σ → τ) (φ : mv_polynomial σ R) {j : τ} (h : j ∈ (rename f φ).vars) :
  ∃ (i : σ), i ∈ φ.vars ∧ f i = j :=
by simpa only [exists_prop, finset.mem_image] using vars_rename f φ h

end eval_vars

end comm_semiring

end mv_polynomial


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

! This file was ported from Lean 3 source module category_theory.linear.basic
! leanprover-community/mathlib commit 3dec44d0b621a174c56e994da4aae15ba60110a2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Preadditive.Basic
import Mathlib.Algebra.Module.LinearMap
import Mathlib.Algebra.Invertible
import Mathlib.Algebra.Algebra.Basic

/-!
# Linear categories

An `R`-linear category is a category in which `X ⟶ Y` is an `R`-module in such a way that
composition of morphisms is `R`-linear in both variables.

Note that sometimes in the literature a "linear category" is further required to be abelian.

## Implementation

Corresponding to the fact that we need to have an `AddCommGroup X` structure in place
to talk about a `Module R X` structure,
we need `Preadditive C` as a prerequisite typeclass for `Linear R C`.
This makes for longer signatures than would be ideal.

## Future work

It would be nice to have a usable framework of enriched categories in which this just became
a category enriched in `Module R`.

-/

universe w v u

open CategoryTheory.Limits

open LinearMap

namespace CategoryTheory

/-- A category is called `R`-linear if `P ⟶ Q` is an `R`-module such that composition is
    `R`-linear in both variables. -/
class Linear (R : Type w) [Semiring R] (C : Type u) [Category.{v} C] [Preadditive C] where
  homModule : ∀ X Y : C, Module R (X ⟶ Y) := by infer_instance
  /-- compatibility of the scalar multiplication with the post-composition -/
  smul_comp : ∀ (X Y Z : C) (r : R) (f : X ⟶ Y) (g : Y ⟶ Z), (r • f) ≫ g = r • f ≫ g := by
    aesop_cat
  /-- compatibility of the scalar multiplication with the pre-composition -/
  comp_smul : ∀ (X Y Z : C) (f : X ⟶ Y) (r : R) (g : Y ⟶ Z), f ≫ (r • g) = r • f ≫ g := by
    aesop_cat
#align category_theory.linear CategoryTheory.Linear

attribute [instance] Linear.homModule

attribute [simp] Linear.smul_comp Linear.comp_smul

-- (the linter doesn't like `simp` on the `_assoc` lemma)
end CategoryTheory

open CategoryTheory

namespace CategoryTheory.Linear

variable {C : Type u} [Category.{v} C] [Preadditive C]

instance preadditiveNatLinear : Linear ℕ C
    where
  smul_comp X Y Z r f g := by exact (Preadditive.rightComp X g).map_nsmul f r
  comp_smul X Y Z f r g := by exact (Preadditive.leftComp Z f).map_nsmul g r
#align category_theory.linear.preadditive_nat_linear CategoryTheory.Linear.preadditiveNatLinear

instance preadditiveIntLinear : Linear ℤ C
    where
  smul_comp X Y Z r f g := by exact (Preadditive.rightComp X g).map_zsmul f r
  comp_smul X Y Z f r g := by exact (Preadditive.leftComp Z f).map_zsmul g r
#align category_theory.linear.preadditive_int_linear CategoryTheory.Linear.preadditiveIntLinear

section End

variable {R : Type w}

instance [Semiring R] [Linear R C] (X : C) : Module R (End X) := by
  dsimp [End]
  infer_instance

instance [CommSemiring R] [Linear R C] (X : C) : Algebra R (End X) :=
  Algebra.ofModule (fun _ _ _ => comp_smul _ _ _ _ _ _) fun _ _ _ => smul_comp _ _ _ _ _ _

end End

section

variable {R : Type w} [Semiring R] [Linear R C]

section InducedCategory

universe u'

variable {D : Type u'} (F : D → C)

instance inducedCategory : Linear.{w, v} R (InducedCategory C F)
    where
  homModule X Y := @Linear.homModule R _ C _ _ _ (F X) (F Y)
  smul_comp _ _ _ _ _ _ := smul_comp _ _ _ _ _ _
  comp_smul _ _ _ _ _ _ := comp_smul _ _ _ _ _ _
#align category_theory.linear.induced_category CategoryTheory.Linear.inducedCategory

end InducedCategory

instance fullSubcategory (Z : C → Prop) : Linear.{w, v} R (FullSubcategory Z)
    where
  homModule X Y := @Linear.homModule R _ C _ _ _ X.obj Y.obj
  smul_comp _ _ _ _ _ _ := smul_comp _ _ _ _ _ _
  comp_smul _ _ _ _ _ _ := comp_smul _ _ _ _ _ _
#align category_theory.linear.full_subcategory CategoryTheory.Linear.fullSubcategory

variable (R)

/-- Composition by a fixed left argument as an `R`-linear map. -/
@[simps]
def leftComp {X Y : C} (Z : C) (f : X ⟶ Y) : (Y ⟶ Z) →ₗ[R] X ⟶ Z
    where
  toFun g := f ≫ g
  map_add' := by simp
  map_smul' := by simp
#align category_theory.linear.left_comp CategoryTheory.Linear.leftComp

/-- Composition by a fixed right argument as an `R`-linear map. -/
@[simps]
def rightComp (X : C) {Y Z : C} (g : Y ⟶ Z) : (X ⟶ Y) →ₗ[R] X ⟶ Z
    where
  toFun f := f ≫ g
  map_add' := by simp
  map_smul' := by simp
#align category_theory.linear.right_comp CategoryTheory.Linear.rightComp

instance {X Y : C} (f : X ⟶ Y) [Epi f] (r : R) [Invertible r] : Epi (r • f) :=
  ⟨fun g g' H =>
    by
    rw [smul_comp, smul_comp, ← comp_smul, ← comp_smul, cancel_epi] at H
    simpa [smul_smul] using congr_arg (fun f => ⅟ r • f) H⟩

instance {X Y : C} (f : X ⟶ Y) [Mono f] (r : R) [Invertible r] : Mono (r • f) :=
  ⟨fun g g' H =>
    by
    rw [comp_smul, comp_smul, ← smul_comp, ← smul_comp, cancel_mono] at H
    simpa [smul_smul] using congr_arg (fun f => ⅟ r • f) H⟩

/-- Given isomorphic objects `X ≅ Y, W ≅ Z` in a `k`-linear category, we have a `k`-linear
isomorphism between `Hom(X, W)` and `Hom(Y, Z).` -/
def homCongr (k : Type _) {C : Type _} [Category C] [Semiring k] [Preadditive C] [Linear k C]
    {X Y W Z : C} (f₁ : X ≅ Y) (f₂ : W ≅ Z) : (X ⟶ W) ≃ₗ[k] Y ⟶ Z :=
  {
    (rightComp k Y f₂.hom).comp
      (leftComp k W
        f₁.symm.hom) with
    invFun := (leftComp k W f₁.hom).comp (rightComp k Y f₂.symm.hom)
    left_inv := fun x => by
      simp only [Iso.symm_hom, LinearMap.toFun_eq_coe, LinearMap.coe_comp, Function.comp_apply,
        leftComp_apply, rightComp_apply, Category.assoc, Iso.hom_inv_id, Category.comp_id,
        Iso.hom_inv_id_assoc]
    right_inv := fun x => by
      simp only [Iso.symm_hom, LinearMap.coe_comp, Function.comp_apply, rightComp_apply,
        leftComp_apply, LinearMap.toFun_eq_coe, Iso.inv_hom_id_assoc, Category.assoc,
        Iso.inv_hom_id, Category.comp_id] }
#align category_theory.linear.hom_congr CategoryTheory.Linear.homCongr

theorem homCongr_apply (k : Type _) {C : Type _} [Category C] [Semiring k] [Preadditive C]
    [Linear k C] {X Y W Z : C} (f₁ : X ≅ Y) (f₂ : W ≅ Z) (f : X ⟶ W) :
    homCongr k f₁ f₂ f = (f₁.inv ≫ f) ≫ f₂.hom :=
  rfl
#align category_theory.linear.hom_congr_apply CategoryTheory.Linear.homCongr_apply

theorem homCongr_symm_apply (k : Type _) {C : Type _} [Category C] [Semiring k] [Preadditive C]
    [Linear k C] {X Y W Z : C} (f₁ : X ≅ Y) (f₂ : W ≅ Z) (f : Y ⟶ Z) :
    (homCongr k f₁ f₂).symm f = f₁.hom ≫ f ≫ f₂.inv :=
  rfl
#align category_theory.linear.hom_congr_symm_apply CategoryTheory.Linear.homCongr_symm_apply

end

section

variable {S : Type w} [CommSemiring S] [Linear S C]

/-- Composition as a bilinear map. -/
@[simps]
def comp (X Y Z : C) : (X ⟶ Y) →ₗ[S] (Y ⟶ Z) →ₗ[S] X ⟶ Z
    where
  toFun f := leftComp S Z f
  map_add' := by
    intros
    ext
    simp
  map_smul' := by
    intros
    ext
    simp
#align category_theory.linear.comp CategoryTheory.Linear.comp

end

end CategoryTheory.Linear