import data.finsupp
import algebra.ring
import .to_finset
import .to_multiset
import to_comm_semiring

noncomputable theory

local infix ^ := monoid.pow

open classical multiset
local attribute [instance] prop_decidable
local notation a `~ᵤ` b : 50 := associated a b
universe u
variable {α : Type u}
variable [integral_domain α]

--Should be placed elsewhere
lemma prod_eq_zero_iff_zero_mem' {s : multiset α} : prod s = 0 ↔ (0 : α) ∈ s :=
begin
  split,
  {
    apply multiset.induction_on s,
    {
      simp * at *,
    },
    {
      intros a s h1 h2,
      simp * at *,
      by_cases ha : a = 0,
      {
        simp * at *,
      },
      {
        have h3 : prod s = 0,
        {
          by_contradiction h4,
          have : a * prod s ≠ 0,
          from mul_ne_zero ha h4,
          contradiction,
        },
        simp [h1 h3],
      }
    }
  },
  {
    intro h,
    rcases (exists_cons_of_mem h) with ⟨t, ht⟩,
    subst ht,
    simp * at *,
  }
end

lemma associated_of_dvd_dvd {a b : α}
  (h1 : a ∣ b) (h2 : b ∣ a) : a ~ᵤ b :=
begin
  rcases h2 with ⟨c, h3⟩,
  rcases h1 with ⟨d, h4⟩,
  by_cases h6 : (a = 0),
  {
    have h7 : (b = 0),
    {
      simp [h6] at h4,
      assumption,
    },
    simp * at *,
  },
  {
    have h3b : a = a * (d * c),
    { rwa [h4, mul_assoc] at h3},
    have h5 : a * 1 = a * (d * c),
    { simpa},
    have h7 : 1 = (d * c),
      from eq_of_mul_eq_mul_left h6 h5,
    rw mul_comm _ _ at h7,
    exact ⟨unit_of_mul_eq_one (h7.symm), by rw [h4, unit_of_mul_eq_one, units.val_coe, ←mul_assoc, mul_comm c, mul_assoc, ←h7, mul_one]⟩,
  }
end

lemma dvd_dvd_iff_associated {a b : α}
   : (a ~ᵤ b) ↔ ( a ∣ b) ∧ ( b ∣ a):=
⟨dvd_dvd_of_associated, assume h1, associated_of_dvd_dvd h1.1 h1.2⟩

--irreducible, prime and coprime

def prime (p : α) : Prop :=
p ≠ 0 ∧ ¬ is_unit p ∧ ∀ a b, p ∣ (a * b) → (p ∣ a ∨ p ∣ b)

def irreducible  (p : α) : Prop :=
p ≠ 0 ∧ ¬ is_unit p ∧ ∀d, d∣p → (is_unit d ∨ (d ~ᵤ p))

def irreducible'  (p : α) : Prop :=
p ≠ 0 ∧ ¬ is_unit p ∧ ∀ a b : α, p = a * b → (is_unit a ∨ is_unit b)

lemma irreducible'_of_irreducible {p : α} (h1 : irreducible p): irreducible' p :=
begin
  have : ∀ (a b : α), p = a * b → is_unit a ∨ is_unit b,
  {
    intros a b h5,
    have h7 : (is_unit a ∨ (a ~ᵤ p)),
      from h1.2.2 a ⟨b, h5⟩,
    cases h7,
    {
      simp *
    },
    {
      rcases h7 with ⟨u, h8⟩,
      have h9 : p * 1 = p * (↑u * b),
      {
        subst h8,
        rw [mul_comm _ p, mul_assoc] at h5,
        simpa *,
      },
      have h11 : is_unit b,
      {
        exact ⟨u⁻¹, eq.symm
            (calc ↑(u⁻¹) = ↑u⁻¹ * 1 : by simp
            ... = ↑u⁻¹ * (↑u * b) : by rw [eq_of_mul_eq_mul_left h1.1 h9]
            ... = _ : by rw [←mul_assoc, units.inv_mul, one_mul])⟩,
      },
      simp [h11]
    }
  },
  exact ⟨h1.1, h1.2.1, this⟩,
end

lemma irreducible_of_irreducible' {p : α} (h1 : irreducible' p): irreducible p :=
begin
  have : ∀ (d : α), d ∣ p → is_unit d ∨ (d~ᵤ p),
  {
    intros a h5,
    rcases h5 with ⟨b, h6⟩,
    have h7 : is_unit a ∨ is_unit b,
      from h1.2.2 _ _ h6,
    cases h7,
    {
      simp *,
    },
    {
      have h8 : (a ~ᵤ p),
      {
        rcases h7 with ⟨u ,hu⟩,
        apply exists.intro u⁻¹,
        subst h6,
        subst hu,
        rw [mul_comm a, ←mul_assoc, units.inv_mul, one_mul],
      },
      simp [h8]
    }
  },
  exact ⟨h1.1, h1.2.1, this⟩,
end

lemma irreducible_iff_irreducible'  {p : α} : irreducible p ↔ irreducible' p :=
iff.intro irreducible'_of_irreducible irreducible_of_irreducible'

lemma not_is_unit_of_irreducible {a : α} (h : irreducible a) : ¬ (is_unit a) := h.2.1

lemma dvd_irreducible_of_dvd_mul_unit_irreducible {a b c: α} (h2 : is_unit b)(h3 : irreducible c)(h4 : a ∣ (b * c)) : a ∣ c :=
let ⟨bᵤ, hb⟩ := h2 in
let ⟨d, h5⟩ := h4 in exists.intro ( d*bᵤ.inv)
    (calc c = 1 * c : by simp
    ... = (↑bᵤ⁻¹* ↑bᵤ) * c : by rw [←units.inv_mul _]
    ... = ↑bᵤ⁻¹ * (↑bᵤ * c) : by simp [mul_assoc]
    ... = ↑bᵤ⁻¹ * (b * c): by rw [hb]
    ... = ↑bᵤ⁻¹ * (a * d): by rw h5
    ... = bᵤ.inv * (a * d): by rw [units.inv_coe]
    ... = (a * d) * bᵤ.inv : by simp [mul_assoc, mul_comm]
    ... = a * (d * bᵤ.inv) : by simp [mul_assoc])

--correct simp?
@[simp] lemma not_irreducible_one : ¬ irreducible (1 : α) :=
begin
  by_contradiction h,
  have : ¬is_unit (1 : α),
    from h.2.1,
  have : is_unit (1 : α),
    from is_unit_one,
  contradiction,
end

@[simp] lemma not_irreducible_zero : ¬ irreducible (0 : α) :=
begin
  by_contradiction h1,
  have : (0 : α) ≠ 0,
    from h1.1,
  contradiction,
end

--Problem with 'a' in the namespace
lemma irreducible_of_associated {p b : α}(h1 : irreducible p)(h2 : p ~ᵤ b) : irreducible b :=
begin
  rcases h2 with ⟨u, hu⟩,
  have h7 : (b ≠ 0),
  {
    intro h6,
    simp * at *,
  },
  have h8 : (¬ is_unit b),
  {
    intro h8,
    have h9 : is_unit p,
      from hu.symm ▸ (is_unit_mul_of_is_unit_of_is_unit (is_unit_unit u) h8),
    exact h1.2.1 h9
  },
  have h9 : (∀c, (c∣b → (is_unit c ∨ (c ~ᵤ b)))),
  {
    intros c h9,
    by_cases h10 : is_unit c,
    { simp [h10]},
    {
      have h15 : (c~ᵤ p),
      {
        have h14 : c ∣ p,
        {
          rcases h9 with ⟨d, h11⟩,
          exact ⟨u * d, by {subst h11, subst hu, rw [←mul_assoc, ←mul_assoc, mul_comm c]}⟩
        },
        have h16: is_unit c ∨ (c~ᵤ p),
          from h1.2.2 c h14,
        simp * at *,
      },
      have h16 : (c~ᵤ b),
        from h15.trans ⟨u, hu⟩,
      simp *,
    }
  },
  exact ⟨h7,h8,h9⟩,
end

lemma unit_mul_irreducible_is_irreducible'  {a b : α}: is_unit a → irreducible b → irreducible (a * b)
| ⟨aᵤ, ha⟩ h2 :=
  have h3 : (b ~ᵤ (a*b)),
    from ⟨aᵤ⁻¹, by {rw [ha, ←mul_assoc, units.inv_mul, one_mul]}⟩,
  irreducible_of_associated h2 h3

lemma irreducible_of_prime  {p : α} (h1 : prime p) : irreducible p :=
begin
  rw prime at h1,
  --rw irreducible,
  have h2 : (p ≠ 0),
  {
    from and.elim_left h1,
  },
  have h3 : (¬ is_unit p),
  from and.elim_left (and.elim_right h1),
  rw [irreducible_iff_irreducible', irreducible'],
  have h4 : ∀ (a b : α), p = a * b → is_unit a ∨ is_unit b,
  {
    intros b c h4a,
    by_cases h4b : (b = 0),
    {
      simp [h4b] at h4a,
      contradiction,
    },
    {
      by_cases h4c : (c = 0),
      {
        simp [h4c] at h4a,
        contradiction,
      }, --no indent here
      have h4 : p ∣ (b * c),
      {
        simp *,
      },
      have h5 : p ∣ b ∨ p ∣ c,
      from and.elim_right (and.elim_right h1) b c h4,
      cases h5,
      {
        have h6 : b ∣ b * c,
        {simp},
        have h7 : b ∣ p,
        {
          apply dvd.trans h6,
          simp *,
        },
        have h8 : (p ~ᵤ b),
        from associated_of_dvd_dvd h5 h7,
        rw associated at h8,
        let u := some h8,
        have h9 : p = ↑u * b,
        from some_spec h8,
        rw [h9, mul_comm b c] at h4a,
        have h10 : ↑u = c,
        from eq_of_mul_eq_mul_right_of_ne_zero h4b h4a,
        have h11 : is_unit c,
        {
          fapply exists.intro u,
          exact eq.symm h10,
        },
        simp *,
      },
      {
        have h6 : c ∣ b * c,
        {simp},
        have h7 : c ∣ p,
        {
          apply dvd.trans h6,
          simp *,
        },
        have h8 : (p ~ᵤ c),
        from associated_of_dvd_dvd h5 h7,
        rw associated at h8,
        let u := some h8,
        have h9 : p = ↑u * c,
        from some_spec h8,
        rw [h9] at h4a,
        have h10 : ↑u = b,
        from eq_of_mul_eq_mul_right_of_ne_zero h4c h4a,
        have h11 : is_unit b,
        {
          fapply exists.intro u,
          exact eq.symm h10,
        },
        simp *,
      }
    }
  },
  exact ⟨h2, h3, h4 ⟩
end

lemma irreducible_of_mul_is_unit {a b c : α} (h1 : irreducible a) (h2 : is_unit b) (h3 : a * b = c) : irreducible c :=
begin
  apply irreducible_of_associated h1,
  exact associated_of_mul_is_unit h2 h3,
end

private lemma succ_eq_succ_iff_eq {n m : ℕ} : nat.succ n = nat.succ m ↔ n = m :=
begin
  split,
    exact nat.succ_inj,
    intro h,
    simp *,
end

private lemma eq_zero_or_exists_eq_succ_succ_of_ne_one {n : ℕ} (h : n ≠ 1) : n = 0 ∨ ∃ m, n = nat.succ (nat.succ m) :=
begin
  by_cases h2 : n = 0,
    {simp *},
    {
      rcases (nat.exists_eq_succ_of_ne_zero h2) with ⟨m, hm⟩,
      subst hm,
      simp * at *,
      rw succ_eq_succ_iff_eq at h,
      rcases (nat.exists_eq_succ_of_ne_zero h) with ⟨s, hs⟩,
      subst hs,
      exact ⟨s, rfl⟩,
    }
end

lemma irreducible_pow {a : α} {n : ℕ} (h : irreducible a) : irreducible (a^n) ↔ n = 1 :=
begin
  split,
  {
    intros h1,
    by_contradiction h2,
    have h3 : n = 0 ∨ ∃ m, n = nat.succ (nat.succ m),
    from eq_zero_or_exists_eq_succ_succ_of_ne_one h2,
    cases h3,
    {
      simp * at *,
    },
    {
      rcases h3 with ⟨m, hm⟩,
      subst hm,
      rw pow_succ at *,
      rw irreducible_iff_irreducible' at h1,
      unfold irreducible' at h1,
      have h4: is_unit a ∨ is_unit (a ^ nat.succ m),
      from h1.2.2 _ _ rfl,
      cases h4,
      {
        have : ¬is_unit a,
        from h.2.1,
        contradiction,
      },
      {
        rw pow_succ at h4,
        rw is_unit_mul_iff_is_unit_and_is_unit at h4,
        have : ¬is_unit a,
        from h.2.1,
        exact this h4.1,
      }
    }

  },
  {
    intro h,
    simp * at *,
  }
end

lemma not_is_unit_prod_of_ne_zero_of_forall_mem_irreducible {s : multiset α} (h1 : s ≠ 0) (h2 : ∀x : α, x ∈ s → irreducible x) : ¬is_unit s.prod :=
begin
  rcases (exists_mem_of_ne_zero h1) with ⟨x, hx⟩,
  have h2b : x ∣ (s.prod),
    from dvd_prod_of_mem _ hx,
  have h3: irreducible x,
    from h2 x hx,
  have h4: ¬is_unit x,
    from not_is_unit_of_irreducible h3,
  exact not_is_unit_of_not_is_unit_dvd h4 h2b,
end

--- GCDs

section gcd_id
variables [has_gcd α] {a b c : α}

lemma gcd_zero_associated_left {f : α} : (gcd f (0 : α)) ~ᵤ f :=
begin
  apply associated_of_dvd_dvd,
  exact gcd_left,
  apply gcd_min,
  simp,
  simp
end

lemma gcd_zero_associated_right {α : Type u} [integral_domain α][has_gcd α] {f : α} : (gcd (0 : α) f) ~ᵤ f :=
begin
  apply associated_of_dvd_dvd,
  exact gcd_right,
  apply gcd_min,
  simp,
  simp
end

lemma gcd_eq_zero_iff_eq_zero_and_eq_zero {α : Type u} [integral_domain α][has_gcd α] {f g : α}  : gcd f g = 0 ↔ f = 0 ∧ g = 0:=
begin
  constructor,
  {
     intro h1,
     by_contradiction h2,
     have h3 : ¬(g = 0 ∧ f = 0),
     {
       rw and.comm at h2,
       exact h2
     },
     simp at *,
     by_cases h4 : (f = 0),
     {
       have h5 : g ≠ 0,
       from h2 h4,
       rw h4 at h1,
       have h6 : ((gcd 0 g) ~ᵤ g),
       from gcd_zero_associated_right,
       rw [h1] at h6,
       have h7 : (g ~ᵤ 0),
       from associated.symm h6,
       rw [associated_zero_iff_eq_zero] at h7,
       contradiction,
     },
     {
       apply h4,
       apply eq_zero_of_zero_dvd,
       rw ← h1,
       exact gcd_left,
     }

  },
  {
    intro h1,
    have h2 : f = 0,
    from and.elim_left h1,
    have h3 : g = 0,
    from and.elim_right h1,
    rw [h2, h3],
    exact gcd_zero_zero_eq_zero
  }
end

--Isn't it associated?
lemma gcd_comm : (gcd a b ~ᵤ  gcd b a) :=
begin
  apply associated_of_dvd_dvd,
  {
    have h1 : gcd a b ∣ a,
    from gcd_left,
    have h2 : gcd a b ∣ b,
    from gcd_right,
    exact gcd_min h2 h1,
  },
  {
    have h1 : gcd b a ∣ b,
    from gcd_left,
    have h2 : gcd b a ∣ a,
    from gcd_right,
    exact gcd_min h2 h1,
  }
end

end gcd_id


import linear_algebra.affine_space.basic
import linear_algebra.basis

open_locale affine

universes u v w x

variables
    (K : Type v)
    (n : ℕ)
    [inhabited K]
    [field K]

open list
--open vecl

@[ext]
structure aff_vec_coord_tuple :=
(vec : fin n → K)

/-- type of affine points represented by coordinate tuples -/
@[ext]
structure aff_pt_coord_tuple :=
(pt : fin n → K)

instance vec_coe : has_coe (aff_vec_coord_tuple K n) (fin n → K) := ⟨λv,v.1⟩
instance pt_coe : has_coe (aff_pt_coord_tuple K n) (fin n → K) := ⟨λp,p.1⟩

variables (x y : aff_vec_coord_tuple K n) (a b : aff_pt_coord_tuple K n)

def fin_add : (fin n → K) → (fin n → K) → (fin n → K) := λ x y, (λ m : fin n, x m + y m)

/-! ### abelian group operations -/
def vec_add : aff_vec_coord_tuple K n → aff_vec_coord_tuple K n → aff_vec_coord_tuple K n :=
    λ x y, ⟨λ m : fin n, x.1 m + y.1 m⟩
def vec_zero : aff_vec_coord_tuple K n := ⟨λ m : fin n, 0⟩
def vec_neg : aff_vec_coord_tuple K n → aff_vec_coord_tuple K n
| x := ⟨λ m : fin n, -(x.1 m)⟩

/-! ### type class instances for the abelian group operations -/
instance : has_add (aff_vec_coord_tuple K n) := ⟨vec_add K n⟩
instance : has_zero (aff_vec_coord_tuple K n) := ⟨vec_zero K n⟩
instance : has_neg (aff_vec_coord_tuple K n) := ⟨vec_neg K n⟩

-- misc
def pt_zero : aff_pt_coord_tuple K n := ⟨λ m : fin n, 0⟩

lemma vec_zero_id : (0 : aff_vec_coord_tuple K n) = vec_zero K n := rfl

lemma vec_zero_is_zero (m : fin n) : (vec_zero K n).vec m = 0 := rfl

-- properties necessary to show aff_vec_coord_tuple K n is an instance of add_comm_group
#print add_comm_group
lemma vec_add_assoc : ∀ x y z : aff_vec_coord_tuple K n, x + y + z = x + (y + z) :=
begin
intros,
cases x,
cases y,
cases z,
ext m,
exact add_assoc (x m) (y m) (z m),
end

lemma vec_zero_add : ∀ x : aff_vec_coord_tuple K n, 0 + x = x :=
begin
intro x,
cases x,
ext m,
exact zero_add (x m),
end

lemma vec_add_zero : ∀ x : aff_vec_coord_tuple K n, x + 0 = x :=
begin
intro x,
cases x,
ext m,
exact add_zero (x m),
end

lemma vec_add_left_neg : ∀ x : aff_vec_coord_tuple K n, -x + x = 0 :=
begin
intro x,
cases x,
ext m,
exact add_left_neg (x m),
end

lemma vec_add_comm : ∀ x y : aff_vec_coord_tuple K n, x + y = y + x :=
begin
intros x y,
cases x,
cases y,
ext m,
exact add_comm (x m) (y m),
end

/-! ### Type class instance for abelian group -/
instance aff_comm_group : add_comm_group (aff_vec_coord_tuple K n) :=
begin
split,
exact vec_add_left_neg K n,
exact vec_add_comm K n,
exact vec_add_assoc K n,
exact vec_zero_add K n,
exact vec_add_zero K n,
end

/-! ### Scalar action -/

@[ext]
def vec_scalar : K → aff_vec_coord_tuple K n → aff_vec_coord_tuple K n :=
    λ a x, ⟨λ m : fin n, a * x.1 m⟩

instance : has_scalar K (aff_vec_coord_tuple K n) := ⟨vec_scalar K n⟩

lemma vec_one_smul : (1 : K) • x = x :=
begin
cases x,
ext m,
exact one_mul (x m),
end

lemma vec_mul_smul : ∀ g h : K, ∀ x : aff_vec_coord_tuple K n, (g * h) • x = g • h • x :=
begin
intros,
cases x,
ext m,
exact mul_assoc g h (x m),
end

instance : mul_action K (aff_vec_coord_tuple K n) := ⟨vec_one_smul K n, vec_mul_smul K n⟩

lemma vec_smul_add : ∀ g : K, ∀ x y : aff_vec_coord_tuple K n, g • (x + y) = g•x + g•y :=
begin
intros,
cases x,
cases y,
ext m,
exact left_distrib g (x m) (y m),
end

lemma vec_smul_zero : ∀ g : K, g • (0 : aff_vec_coord_tuple K n) = 0 :=
begin
intros,
dsimp [vec_zero_id, vec_zero, has_scalar.smul, vec_scalar],
rw mul_zero g,
end

instance : distrib_mul_action K (aff_vec_coord_tuple K n) := ⟨vec_smul_add K n, vec_smul_zero K n⟩

lemma vec_add_smul : ∀ g h : K, ∀ x : aff_vec_coord_tuple K n, (g + h) • x = g•x + h•x :=
begin
intros,
cases x,
ext m,
exact right_distrib g h (x m),
end

lemma vec_zero_smul : ∀ x : aff_vec_coord_tuple K n, (0 : K) • x = 0 :=
begin
intros,
cases x,
ext m,
exact zero_mul (x m),
end

instance aff_semimod : semimodule K (aff_vec_coord_tuple K n) := ⟨vec_add_smul K n, vec_zero_smul K n⟩

instance aff_module : module K (aff_vec_coord_tuple K n) := aff_semimod K n

/-! ### group action of aff_vec_coord_tuple on aff_pt_coord_tuple -/

def aff_group_action : aff_vec_coord_tuple K n → aff_pt_coord_tuple K n → aff_pt_coord_tuple K n :=
    λ x y, ⟨λ m : fin n, x.1 m + y.1 m⟩

def aff_group_sub : aff_pt_coord_tuple K n → aff_pt_coord_tuple K n → aff_vec_coord_tuple K n :=
    λ x y, ⟨λ m : fin n, x.1 m - y.1 m⟩

#check add_action

instance : has_vadd (aff_vec_coord_tuple K n) (aff_pt_coord_tuple K n) := ⟨aff_group_action K n⟩

instance : has_vsub (aff_vec_coord_tuple K n) (aff_pt_coord_tuple K n) := ⟨aff_group_sub K n⟩

lemma aff_zero_sadd : ∀ x : aff_pt_coord_tuple K n, (0 : aff_vec_coord_tuple K n) +ᵥ x = x :=
begin
intro x,
cases x,
ext m,
exact zero_add (x m),
end

lemma aff_add_sadd : ∀ x y : aff_vec_coord_tuple K n, ∀ a : aff_pt_coord_tuple K n, x +ᵥ (y +ᵥ a) = x + y +ᵥ a :=
begin
intros,
cases x,
cases y,
cases a,
ext m,
exact eq.symm (add_assoc (x m) (y m) (a m)),
end

lemma aff_vadd_vsub : ∀ (x : aff_vec_coord_tuple K n) (a : aff_pt_coord_tuple K n), x +ᵥ a -ᵥ a = x :=
begin
intros,
ext m,
exact add_sub_cancel (x.vec m) (a.pt m),
end

instance : add_action (aff_vec_coord_tuple K n) (aff_pt_coord_tuple K n) := ⟨aff_group_action K n, aff_zero_sadd K n, aff_add_sadd K n⟩

lemma aff_vsub_vadd : ∀ a b : aff_pt_coord_tuple K n, (a -ᵥ b) +ᵥ b = a :=
begin
intros,
ext m,
exact sub_add_cancel (a.pt m) (b.pt m),
end

lemma aff_add_trans : ∀ a b : aff_pt_coord_tuple K n, ∃ x : aff_vec_coord_tuple K n, x +ᵥ a = b :=
by {intros, apply exists.intro (b -ᵥ a), exact aff_vsub_vadd K n b a}

lemma aff_add_free : ∀ a : aff_pt_coord_tuple K n, ∀ g h : aff_vec_coord_tuple K n, g +ᵥ a = h +ᵥ a → g = h :=
begin
intros a g h h₀,
have h₁ : g +ᵥ a -ᵥ a = h +ᵥ a -ᵥ a := by rw h₀,
rw [aff_vadd_vsub K n g a, aff_vadd_vsub K n h a] at h₁,
exact h₁,
end

instance : nonempty (aff_pt_coord_tuple K n) := ⟨pt_zero K n⟩

instance aff_torsor : add_torsor (aff_vec_coord_tuple K n) (aff_pt_coord_tuple K n) :=
⟨aff_group_action K n,
aff_zero_sadd K n,
aff_add_sadd K n,
aff_group_sub K n,
aff_vsub_vadd K n,
aff_vadd_vsub K n⟩

instance aff_coord_is :
    affine_space
        (aff_vec_coord_tuple K n)
        (aff_pt_coord_tuple K n) :=
    aff_torsor K n

def pt_plus_vec
    {X : Type u}
    {K : Type v}
    {V : Type w}
    {n : ℕ}
    {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X] :
    (aff_pt_coord_tuple K n) →
    (aff_vec_coord_tuple K n) →
    (aff_pt_coord_tuple K n)
| p v := aff_group_action K n v p

notation
 pt +ᵥ v := pt_plus_vec pt v

def vec_mul_scalar
    {X : Type u}
    {K : Type v}
    {V : Type w}
    {n : ℕ}
    {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X] :
    (aff_vec_coord_tuple K n) →
    K →
    (aff_vec_coord_tuple K n)
| v s := s • v

notation
 v • s := vec_mul_scalar v s

def pt_minus_vec
    {X : Type u}
    {K : Type v}
    {V : Type w}
    {n : ℕ}
    {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X]:
    (aff_pt_coord_tuple K n) →
    (aff_vec_coord_tuple K n) →
    (aff_pt_coord_tuple K n)
| p v := aff_group_action K n (-v) p

notation
 pt -ᵥ v := pt_minus_vec pt v
/-
NEW FILE
-/


/-!
# Polynomials

In this module we define univariate polynomials over a type `R`, together with basic functions
defining their evaluation, arithmetic, and divisibility.
-/

/--
The type of a polynomial with coefficients in `R`.

NOTE : We encode polynomials in such a way so that the `i`th entry of the array corresponds to the
degree `i-1` coefficient. For example `#[a,b,c]` <--> `a + b x + c x^2`
-/
def Polynomial R := Array R

namespace Polynomial

def ofArray : Array R → Polynomial R := id

def toArray : Polynomial R → Array R := id

/-- A useful coercion to write polynomial literals in terms of elements of type `R` -/
instance : Coe (Array R) (Polynomial R) where
  coe := id

instance [Inhabited R] : Inhabited (Polynomial R) where
  default := #[default]

instance : Append (Polynomial A) where
  append := .append

private def tail (ar : Polynomial A) : Polynomial A := ar.eraseIdx 0

variable {A : Type _ } [Add A] [Mul A] [HPow A Nat A] [OfNat A (nat_lit 1)] [OfNat A (nat_lit 0)]
                       [BEq A] [Div A] [Neg A]

/-- Returns a "normalized" form for a polynomial, dropping the leading zeroes -/
def norm (f : Polynomial A) : Polynomial A :=
  let ans := f.popWhile (· == 0)
  if ans.size == 0 then #[0] else ans

instance : BEq $ Polynomial A where
  beq a b := a.norm.toArray == b.norm.toArray

/-- Returns the degree of a polynomial -/
def degree (f : Polynomial A) : Nat :=
  Array.size (norm f) - 1

/-- Tests whether a polynomial is zero -/
def isZero (f : Polynomial A) : Bool := f.norm.size == 1 && f.getD 0 0 == 0

/-- Returns the constant term of a polynomial -/
def constant (f : Polynomial A) : A := if f.isZero then 0 else f.getD 0 0

/-- Returns the leading coefficient of a polynomial -/
def lead (f : Polynomial A) : A := f.getD f.degree 0

/-- Tests whether a polynomial is monic-/
def isMonic (f : Polynomial A) : Bool := f.lead == 1

/-- Scales a polynomial by an element of the base type -/
def mulByConst (a : A) (f : Polynomial A) : Polynomial A := f.map (· * a)

instance : HMul A (Polynomial A) (Polynomial A) where
  hMul := mulByConst

def makeMonic (f : Polynomial A) : Polynomial A := (1 / f.lead) * f

/-- Evaluates a polynomial at a particular value `a : A` -/
def eval (f : Polynomial A) (a : A) : A :=
  let f := f.norm
  let action (i : Fin f.size) c := c * a ^ (i : Nat)
  Array.foldr (. + .) 0 (f.mapIdx action)

private def zeros (n : Nat) : Polynomial A := mkArray n 0

/-- The zero polynomial -/
def zero : Polynomial A := #[0]

private def padZeroes (f : Polynomial A) (n : Nat) : Polynomial A :=
  f ++ zeros n

/-- Returns the addition addition of two polynomials -/
def polyAdd (f : Polynomial A) (g : Polynomial A) : Polynomial A :=
  let (f, g) := (f.norm, g.norm)
  let action (f₁ : Polynomial A) (f₂ : Polynomial A) := f₁.zip f₂ |>.map (fun (x, y) => x + y)
  if f.size < g.size
  then
    action (padZeroes f (g.size - f.size)) g
  else
    if f.size > g.size
    then action f (padZeroes g (f.size - g.size))
    else action f g

instance : Add (Polynomial A) where
  add := polyAdd

instance : Neg (Polynomial A) where
  neg := Array.map Neg.neg

/-- Returns the subtraction of two polynomials -/
def polySub (f : Polynomial A) (g : Polynomial A) : Polynomial A := f + (-g)

instance : Sub (Polynomial A) where
  sub := polySub

/-- Returns the multiplication of two polynomials -/
def polyMul (f : Polynomial A) : Polynomial A → Polynomial A :=
  Array.foldr (fun x (acc : Polynomial A) => (x * f) + (zero ++ acc)) (#[] : Polynomial A)

instance : Mul (Polynomial A) where
  mul := polyMul

/--
Returns `(q, r)` where `q` is the quotient of division of polynomial `f` by `g` and `r` is the
remainder
-/
def polyQuotRem (f : Polynomial A) (g : Polynomial A) : Polynomial A × Polynomial A :=
  let rec polyQRAux (f' g' : Polynomial A) (n : Nat) : Polynomial A × Polynomial A :=
    match n with
    | 0     => (#[], #[])
    | k + 1 =>
      if k + 1 < g'.size then (#[],f')
      else
        let x := f'.getD 0 0
        let y := g'.getD 0 0
        let z := x / y
        let (q', r') := polyQRAux (tail $ f' - g' * (ofArray #[z])) g' k
        (#[z] ++ q'.toArray, r')
  if g == #[0] then (#[0], f) else
  let (f, g) := (f.norm, g.norm)
  let (q, r) := polyQRAux (f.reverse) (g.reverse) (f.size)
  (q.reverse, r.reverse)

/-- Returns the quotient of the division of the polynomial `f` by `g` -/
def polyDiv (f g : Polynomial A) : Polynomial A := polyQuotRem f g |>.fst

/-- Returns the remainder of the division of the polynomial `f` by `g` -/
def polyMod (f g : Polynomial A) : Polynomial A := polyQuotRem f g |>.snd

/--
Returns `(a, b, d)` where `d` is the greatest common divisor of `f` and `g` and `a`, `b` satisfy

`a * f + b * g = d `

TODO : Eliminate `partial` using `termination_by _ => g.degree` and a proof that `polyQuotRem`
reduces degree.
-/
partial def polyEuc [Inhabited A] [Div A] (f g : Polynomial A) : Polynomial A × Polynomial A × Polynomial A
  := if g.isZero then
       (#[1 / f.lead], #[0], f.makeMonic) else
       let (q, r) := polyQuotRem f g
       let (s, t, d) := polyEuc g r
       (t, s - q * t, d)

/--
Returns the monic polynomial with the roots taken from the list `a`.
-/
def rootsToPoly (as : List A) : Polynomial A :=
  match as with
  | [] => #[1]
  | (root :: roots) =>
    let monom : Polynomial A := #[-root,1]
    monom * (rootsToPoly roots)

instance : OfNat (Polynomial A) (nat_lit 1) where
  ofNat := #[1]

instance : OfNat (Polynomial A) (nat_lit 0) where
  ofNat := zero

end Polynomial


import data.rat
       galois.logic
       galois.vector.lemmas

universes u

section
parameters {A : Type u} [comm_ring A]

def dot_product {n : ℕ} (x y : vector A n) : A
  := list.foldr (+) 0 (vector.map₂ (*) x y).to_list

lemma dot_product_cons {n : ℕ} (x y : A) (xs ys : vector A n)
  : dot_product (x :: xs) (y :: ys)
  = x * y + dot_product xs ys
:= begin
induction xs, induction ys,
reflexivity,
end

lemma dot_product_nil :  dot_product vector.nil vector.nil = 0
  := rfl

lemma dot_product_0_len (xs ys : vector A 0)
  : dot_product xs ys = 0
:= begin
rw vector.eq_nil xs, rw vector.eq_nil ys, reflexivity,
end

lemma dot_product_0 {n : ℕ} (xs : vector A n)
  : dot_product (vector.generate n (λ _, (0 : A))) xs = 0
:= begin
induction n,
rw vector.eq_nil xs,
rw dot_product_0_len,
dsimp [vector.generate],
have Hxs := xs.invert_succ, induction Hxs with x xs' Hxs,
subst xs, rw dot_product_cons,
rw ih_1, simp,
end

lemma dot_product_unit (n : ℕ) (i : fin n) (c : A) (v : vector A n)
  : dot_product (vector.generate n (λj, if i.val = j then c else 0)) v
  = c * v.nth i
:= begin
induction n; dsimp [vector.generate],
exfalso, apply fin.fin_0_empty, assumption,
have Hv := v.invert_succ,
induction Hv with x xs Hv, subst Hv,
rw dot_product_cons,
apply (if H : i.val = 0 then _ else _),
{ rw (if_pos H), rw (vector.nth_0 _ _ H),
  dsimp [function.comp],
  rw H,
  have Hf : (λ (x : ℕ), ite (0 = nat.succ x) c 0) = λ _, 0,
  apply funext; intros x,
  rw if_neg, intros contra, cases contra,
  rw Hf, clear Hf,
  rw dot_product_0, simp,
},
{ rw (if_neg H), simp,
  have H' : i ≠ 0,
  intros contra, apply H, rw contra, reflexivity,
  rw vector.nth_cons_nz _ H', dsimp [function.comp],
  rw ← ih_1, f_equal, f_equal,
  apply funext, intros n,
  f_equal, apply ite_iff,
  apply fin.succ_pred_equiv, }
end

lemma dot_product_scale_l {n : ℕ} (c : A) (xs ys : vector A n)
  : dot_product (vector.map (λ x, c * x) xs) ys
  = c * dot_product xs ys
:= begin
induction n,
{ rw (vector.eq_nil xs), rw (vector.eq_nil ys),
  rw vector.map_nil,
  rw dot_product_nil, simp, },
{ have Hx := xs.invert_succ, induction Hx with x xs' Hx, subst xs,
  have Hy := ys.invert_succ, induction Hy with y ys' Hy, subst ys,
  rw vector.map_cons, repeat { rw dot_product_cons },
  rw mul_add, rw ih_1, simp,
}
end

lemma dot_product_comm {n : ℕ} (x y : vector A n)
  : dot_product x y = dot_product y x
:= begin
dsimp [dot_product],
rw vector.map₂_comm, intros, apply mul_comm,
end

lemma dot_product_sum_r {n : ℕ} (x y z : vector A n)
  : dot_product x (vector.map₂ (+) y z)
  = dot_product x y + dot_product x z
:= begin
induction n,
{ repeat {rw dot_product_0_len },
  rw add_zero, },
{ have Hx := x.invert_succ, induction Hx with x' xs Hx, subst x,
  have Hy := y.invert_succ, induction Hy with y' ys Hy, subst y,
  have Hz := z.invert_succ, induction Hz with z' zs Hz, subst z,
  rw vector.map₂_cons, repeat { rw dot_product_cons },
  rw ih_1, rw mul_add, simp,
}
end

lemma dot_product_sum_l {n : ℕ} (x y z : vector A n)
  : dot_product (vector.map₂ (+) x y) z
  = dot_product x z + dot_product y z
:= begin
rw dot_product_comm, rw dot_product_sum_r,
rw dot_product_comm z x, rw dot_product_comm z y,
end

end


inductive Expr : Type
  | const (n : Nat)
  | plus (e₁ e₂ : Expr)
  | mul (e₁ e₂ : Expr)
  deriving BEq, Inhabited, Repr, DecidableEq

def Expr.eval : Expr → Nat
  | const n    => n
  | plus e₁ e₂ => eval e₁ + eval e₂
  | mul e₁ e₂  => eval e₁ * eval e₂

def Expr.times : Nat → Expr → Expr
  | k, const n    => const (k*n)
  | k, plus e₁ e₂ => plus (times k e₁) (times k e₂)
  | k, mul e₁ e₂  => mul (times k e₁) e₂

theorem eval_times (k : Nat) (e : Expr) : (e.times k |>.eval) = k * e.eval := by
  induction e with simp [Expr.times, Expr.eval]
  | plus e₁ e₂ ih₁ ih₂ => simp [ih₁, ih₂, Nat.left_distrib]
  | mul  _ _ ih₁ ih₂   => simp [ih₁, Nat.mul_assoc]

def Expr.reassoc : Expr → Expr
  | const n    => const n
  | plus e₁ e₂ =>
    let e₁' := e₁.reassoc
    let e₂' := e₂.reassoc
    match e₂' with
    | plus e₂₁ e₂₂ => plus (plus e₁' e₂₁) e₂₂
    | _            => plus e₁' e₂'
  | mul e₁ e₂ =>
    let e₁' := e₁.reassoc
    let e₂' := e₂.reassoc
    match e₂' with
    | mul e₂₁ e₂₂ => mul (mul e₁' e₂₁) e₂₂
    | _           => mul e₁' e₂'

theorem eval_reassoc (e : Expr) : e.reassoc.eval = e.eval := by
  induction e with simp [Expr.reassoc]
  | plus e₁ e₂ ih₁ ih₂ =>
    generalize h : (Expr.reassoc e₂) = e₂'
    cases e₂' <;> rw [h] at ih₂ <;> simp [Expr.eval] at * <;> rw [← ih₂, ih₁]; rw [Nat.add_assoc]
  | mul e₁ e₂ ih₁ ih₂ =>
    generalize h : (Expr.reassoc e₂) = e₂'
    cases e₂' <;> rw [h] at ih₂ <;> simp [Expr.eval] at * <;> rw [← ih₂, ih₁]; rw [Nat.mul_assoc]


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

import data.polynomial.coeff
import data.nat.choose.basic

/-!

# Vandermonde's identity

In this file we prove Vandermonde's identity (`nat.add_choose_eq`):
`(m + n).choose k = ∑ (ij : ℕ × ℕ) in antidiagonal k, m.choose ij.1 * n.choose ij.2`

We follow the algebraic proof from
https://en.wikipedia.org/wiki/Vandermonde%27s_identity#Algebraic_proof .

-/

open_locale big_operators

open polynomial finset.nat

/-- Vandermonde's identity -/
lemma nat.add_choose_eq (m n k : ℕ) :
  (m + n).choose k = ∑ (ij : ℕ × ℕ) in antidiagonal k, m.choose ij.1 * n.choose ij.2 :=
begin
  calc (m + n).choose k
      = ((X + 1) ^ (m + n)).coeff k : _
  ... = ((X + 1) ^ m * (X + 1) ^ n).coeff k : by rw pow_add
  ... = ∑ (ij : ℕ × ℕ) in antidiagonal k, m.choose ij.1 * n.choose ij.2 : _,
  { rw [coeff_X_add_one_pow, nat.cast_id], },
  { rw [coeff_mul, finset.sum_congr rfl],
    simp only [coeff_X_add_one_pow, nat.cast_id, eq_self_iff_true, imp_true_iff], }
end


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

import linear_algebra.charpoly.basic
import linear_algebra.matrix.basis

/-!

# Characteristic polynomial

## Main result

* `linear_map.charpoly_to_matrix f` : `charpoly f` is the characteristic polynomial of the matrix
of `f` in any basis.

-/

universes u v w

variables {R : Type u} {M : Type v} [comm_ring R] [nontrivial R]
variables [add_comm_group M] [module R M] [module.free R M] [module.finite R M] (f : M →ₗ[R] M)

open_locale classical matrix

noncomputable theory

open module.free polynomial matrix

namespace linear_map

section basic

/-- `charpoly f` is the characteristic polynomial of the matrix of `f` in any basis. -/
@[simp] lemma charpoly_to_matrix {ι : Type w} [fintype ι] (b : basis ι R M) :
  (to_matrix b b f).charpoly = f.charpoly :=
begin
  set A := to_matrix b b f,
  set b' := choose_basis R M,
  set ι' := choose_basis_index R M,
  set A' := to_matrix b' b' f,
  set e := basis.index_equiv b b',
  set φ := reindex_linear_equiv R R e e,
  set φ₁ := reindex_linear_equiv R R e (equiv.refl ι'),
  set φ₂ := reindex_linear_equiv R R (equiv.refl ι') (equiv.refl ι'),
  set φ₃ := reindex_linear_equiv R R (equiv.refl ι') e,
  set P := b.to_matrix b',
  set Q := b'.to_matrix b,

  have hPQ : C.map_matrix (φ₁ P) ⬝ (C.map_matrix (φ₃ Q)) = 1,
  { rw [ring_hom.map_matrix_apply, ring_hom.map_matrix_apply, ← matrix.map_mul, ←
      @reindex_linear_equiv_mul _ ι' _ _ _ _ R R, basis.to_matrix_mul_to_matrix_flip,
      reindex_linear_equiv_one, ← ring_hom.map_matrix_apply, ring_hom.map_one] },

  calc A.charpoly = (reindex e e A).charpoly : (charpoly_reindex _ _).symm
  ... = (scalar ι' X - C.map_matrix (φ A)).det : rfl
  ... = (scalar ι' X - C.map_matrix (φ (P ⬝ A' ⬝ Q))).det :
    by rw [basis_to_matrix_mul_linear_map_to_matrix_mul_basis_to_matrix]
  ... = (scalar ι' X - C.map_matrix (φ₁ P ⬝ φ₂ A' ⬝ φ₃ Q)).det :
    by rw [reindex_linear_equiv_mul R R _ _ e, reindex_linear_equiv_mul R R e _ _]
  ... = (scalar ι' X - (C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q))).det : by simp
  ... = (scalar ι' X ⬝ C.map_matrix (φ₁ P) ⬝ (C.map_matrix (φ₃ Q)) -
    (C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q))).det :
      by { rw [matrix.mul_assoc ((scalar ι') X), hPQ, matrix.mul_one] }
  ... = (C.map_matrix (φ₁ P) ⬝ scalar ι' X ⬝ (C.map_matrix (φ₃ Q)) -
    (C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q))).det : by simp
  ... = (C.map_matrix (φ₁ P) ⬝ (scalar ι' X - C.map_matrix A') ⬝ C.map_matrix (φ₃ Q)).det :
    by rw [← matrix.sub_mul, ← matrix.mul_sub]
  ... = (C.map_matrix (φ₁ P)).det * (scalar ι' X - C.map_matrix A').det *
    (C.map_matrix (φ₃ Q)).det : by rw [det_mul, det_mul]
  ... = (C.map_matrix (φ₁ P)).det * (C.map_matrix (φ₃ Q)).det *
    (scalar ι' X - C.map_matrix A').det : by ring
  ... = (scalar ι' X - C.map_matrix A').det : by rw [← det_mul, hPQ, det_one, one_mul]
  ... = f.charpoly : rfl
end

end basic

end linear_map


import data.finset

-- The Number of Subsets of a Set

open finset

theorem t052 {α} : Π (s : finset α), card (powerset s) = 2 ^ card s
:= finset.card_powerset


import data.real.basic

def fn_ub (f : ℝ → ℝ) (a : ℝ) : Prop := ∀ x, f x ≤ a
def fn_lb (f : ℝ → ℝ) (a : ℝ) : Prop := ∀ x, a ≤ f x

variables (f g : ℝ → ℝ) (a b : ℝ)

#check add_le_add
#check mul_nonneg
#check mul_le_mul

-- BEGIN
example (hfa : fn_lb f a) (hgb : fn_lb g b) :
  fn_lb (λ x, f x + g x) (a + b) :=
begin
  intro x,
  dsimp,
  apply add_le_add,
  apply hfa,
  apply hgb,
end

example (nnf : fn_lb f 0) (nng : fn_lb g 0) :
  fn_lb (λ x, f x * g x) 0 :=
begin
  intro x,
  dsimp,
  sorry,
end

example (hfa : fn_ub f a) (hfb : fn_ub g b)
    (nng : fn_lb g 0) (nna : 0 ≤ a) :
  fn_ub (λ x, f x * g x) (a * b) :=
begin
  intro x,
  dsimp,
  sorry,
end

-- END


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Chris Hughes, Mario Carneiro
-/

import algebra.algebra.basic
import ring_theory.ideal.operations
import ring_theory.jacobson_ideal
import logic.equiv.transfer_instance

/-!

# Local rings

Define local rings as commutative rings having a unique maximal ideal.

## Main definitions

* `local_ring`: A predicate on commutative semirings, stating that for any pair of elements that
  adds up to `1`, one of them is a unit. This is shown to be equivalent to the condition that there
  exists a unique maximal ideal.
* `local_ring.maximal_ideal`: The unique maximal ideal for a local rings. Its carrier set is the
  set of non units.
* `is_local_ring_hom`: A predicate on semiring homomorphisms, requiring that it maps nonunits
  to nonunits. For local rings, this means that the image of the unique maximal ideal is again
  contained in the unique maximal ideal.
* `local_ring.residue_field`: The quotient of a local ring by its maximal ideal.

-/

universes u v w u'

variables {R : Type u} {S : Type v} {T : Type w} {K : Type u'}

/-- A semiring is local if it is nontrivial and `a` or `b` is a unit whenever `a + b = 1`.
Note that `local_ring` is a predicate. -/
class local_ring (R : Type u) [semiring R] extends nontrivial R : Prop :=
of_is_unit_or_is_unit_of_add_one ::
(is_unit_or_is_unit_of_add_one {a b : R} (h : a + b = 1) : is_unit a ∨ is_unit b)

section comm_semiring
variables [comm_semiring R]

namespace local_ring

lemma of_is_unit_or_is_unit_of_is_unit_add [nontrivial R]
  (h : ∀ a b : R, is_unit (a + b) → is_unit a ∨ is_unit b) :
  local_ring R :=
⟨λ a b hab,  h a b $ hab.symm ▸ is_unit_one⟩

/-- A semiring is local if it is nontrivial and the set of nonunits is closed under the addition. -/
lemma of_nonunits_add [nontrivial R]
  (h : ∀ a b : R, a ∈ nonunits R → b ∈ nonunits R → a + b ∈ nonunits R) :
  local_ring R :=
⟨λ a b hab, or_iff_not_and_not.2 $ λ H, h a b H.1 H.2 $ hab.symm ▸ is_unit_one⟩

/-- A semiring is local if it has a unique maximal ideal. -/
lemma of_unique_max_ideal (h : ∃! I : ideal R, I.is_maximal) :
  local_ring R :=
@of_nonunits_add _ _ (nontrivial_of_ne (0 : R) 1 $
  let ⟨I, Imax, _⟩ := h in (λ (H : 0 = 1), Imax.1.1 $ I.eq_top_iff_one.2 $ H ▸ I.zero_mem)) $
  λ x y hx hy H,
    let ⟨I, Imax, Iuniq⟩ := h in
    let ⟨Ix, Ixmax, Hx⟩ := exists_max_ideal_of_mem_nonunits hx in
    let ⟨Iy, Iymax, Hy⟩ := exists_max_ideal_of_mem_nonunits hy in
    have xmemI : x ∈ I, from Iuniq Ix Ixmax ▸ Hx,
    have ymemI : y ∈ I, from Iuniq Iy Iymax ▸ Hy,
    Imax.1.1 $ I.eq_top_of_is_unit_mem (I.add_mem xmemI ymemI) H

lemma of_unique_nonzero_prime (h : ∃! P : ideal R, P ≠ ⊥ ∧ ideal.is_prime P) :
  local_ring R :=
of_unique_max_ideal begin
  rcases h with ⟨P, ⟨hPnonzero, hPnot_top, _⟩, hPunique⟩,
  refine ⟨P, ⟨⟨hPnot_top, _⟩⟩, λ M hM, hPunique _ ⟨_, ideal.is_maximal.is_prime hM⟩⟩,
  { refine ideal.maximal_of_no_maximal (λ M hPM hM, ne_of_lt hPM _),
    exact (hPunique _ ⟨ne_bot_of_gt hPM, ideal.is_maximal.is_prime hM⟩).symm },
  { rintro rfl,
    exact hPnot_top (hM.1.2 P (bot_lt_iff_ne_bot.2 hPnonzero)) },
end

variables [local_ring R]

lemma is_unit_or_is_unit_of_is_unit_add {a b : R} (h : is_unit (a + b)) :
  is_unit a ∨ is_unit b :=
begin
  rcases h with ⟨u, hu⟩,
  rw [←units.inv_mul_eq_one, mul_add] at hu,
  apply or.imp _ _ (is_unit_or_is_unit_of_add_one hu);
    exact is_unit_of_mul_is_unit_right,
end

lemma nonunits_add {a b : R} (ha : a ∈ nonunits R) (hb : b ∈ nonunits R) : a + b ∈ nonunits R:=
λ H, not_or ha hb (is_unit_or_is_unit_of_is_unit_add H)

variables (R)

/-- The ideal of elements that are not units. -/
def maximal_ideal : ideal R :=
{ carrier := nonunits R,
  zero_mem' := zero_mem_nonunits.2 $ zero_ne_one,
  add_mem' := λ x y hx hy, nonunits_add hx hy,
  smul_mem' := λ a x, mul_mem_nonunits_right }

instance maximal_ideal.is_maximal : (maximal_ideal R).is_maximal :=
begin
  rw ideal.is_maximal_iff,
  split,
  { intro h, apply h, exact is_unit_one },
  { intros I x hI hx H,
    erw not_not at hx,
    rcases hx with ⟨u,rfl⟩,
    simpa using I.mul_mem_left ↑u⁻¹ H }
end

lemma maximal_ideal_unique : ∃! I : ideal R, I.is_maximal :=
⟨maximal_ideal R, maximal_ideal.is_maximal R,
  λ I hI, hI.eq_of_le (maximal_ideal.is_maximal R).1.1 $
  λ x hx, hI.1.1 ∘ I.eq_top_of_is_unit_mem hx⟩

variable {R}

lemma eq_maximal_ideal {I : ideal R} (hI : I.is_maximal) : I = maximal_ideal R :=
unique_of_exists_unique (maximal_ideal_unique R) hI $ maximal_ideal.is_maximal R

lemma le_maximal_ideal {J : ideal R} (hJ : J ≠ ⊤) : J ≤ maximal_ideal R :=
begin
  rcases ideal.exists_le_maximal J hJ with ⟨M, hM1, hM2⟩,
  rwa ←eq_maximal_ideal hM1
end

@[simp] lemma mem_maximal_ideal (x) : x ∈ maximal_ideal R ↔ x ∈ nonunits R := iff.rfl

lemma is_field_iff_maximal_ideal_eq :
  is_field R ↔ maximal_ideal R = ⊥ :=
not_iff_not.mp ⟨ring.ne_bot_of_is_maximal_of_not_is_field infer_instance,
  λ h, ring.not_is_field_iff_exists_prime.mpr ⟨_, h, ideal.is_maximal.is_prime' _⟩⟩

end local_ring

end comm_semiring

section comm_ring
variables [comm_ring R]

namespace local_ring

lemma of_is_unit_or_is_unit_one_sub_self [nontrivial R]
  (h : ∀ a : R, is_unit a ∨ is_unit (1 - a)) : local_ring R :=
⟨λ a b hab, add_sub_cancel' a b ▸ hab.symm ▸ h a⟩

variables [local_ring R]

lemma is_unit_or_is_unit_one_sub_self (a : R) : is_unit a ∨ is_unit (1 - a) :=
is_unit_or_is_unit_of_is_unit_add $ (add_sub_cancel'_right a 1).symm ▸ is_unit_one

lemma is_unit_of_mem_nonunits_one_sub_self (a : R) (h : 1 - a ∈ nonunits R) :
  is_unit a :=
or_iff_not_imp_right.1 (is_unit_or_is_unit_one_sub_self a) h

lemma is_unit_one_sub_self_of_mem_nonunits (a : R) (h : a ∈ nonunits R) :
  is_unit (1 - a) :=
or_iff_not_imp_left.1 (is_unit_or_is_unit_one_sub_self a) h

lemma of_surjective' [comm_ring S] [nontrivial S] (f : R →+* S) (hf : function.surjective f) :
  local_ring S :=
of_is_unit_or_is_unit_one_sub_self
begin
  intros b,
  obtain ⟨a, rfl⟩ := hf b,
  apply (is_unit_or_is_unit_one_sub_self a).imp f.is_unit_map _,
  rw [← f.map_one, ← f.map_sub],
  apply f.is_unit_map,
end

lemma jacobson_eq_maximal_ideal (I : ideal R) (h : I ≠ ⊤) :
  I.jacobson = local_ring.maximal_ideal R :=
begin
  apply le_antisymm,
  { exact Inf_le ⟨local_ring.le_maximal_ideal h, local_ring.maximal_ideal.is_maximal R⟩ },
  { exact le_Inf (λ J (hJ : I ≤ J ∧ J.is_maximal),
      le_of_eq (local_ring.eq_maximal_ideal hJ.2).symm) }
end

end local_ring

end comm_ring

/-- A local ring homomorphism is a homomorphism `f` between local rings such that `a` in the domain
  is a unit if `f a` is a unit for any `a`. See `local_ring.local_hom_tfae` for other equivalent
  definitions. -/
class is_local_ring_hom [semiring R] [semiring S] (f : R →+* S) : Prop :=
(map_nonunit : ∀ a, is_unit (f a) → is_unit a)

section
variables [semiring R] [semiring S] [semiring T]

instance is_local_ring_hom_id (R : Type*) [semiring R] : is_local_ring_hom (ring_hom.id R) :=
{ map_nonunit := λ a, id }

@[simp] lemma is_unit_map_iff (f : R →+* S) [is_local_ring_hom f] (a) :
  is_unit (f a) ↔ is_unit a :=
⟨is_local_ring_hom.map_nonunit a, f.is_unit_map⟩

@[simp] lemma map_mem_nonunits_iff (f : R →+* S) [is_local_ring_hom f] (a) :
  f a ∈ nonunits S ↔ a ∈ nonunits R :=
⟨λ h ha, h $ (is_unit_map_iff f a).mpr ha, λ h ha, h $ (is_unit_map_iff f a).mp ha⟩

instance is_local_ring_hom_comp
  (g : S →+* T) (f : R →+* S) [is_local_ring_hom g] [is_local_ring_hom f] :
  is_local_ring_hom (g.comp f) :=
{ map_nonunit := λ a, is_local_ring_hom.map_nonunit a ∘ is_local_ring_hom.map_nonunit (f a) }

instance is_local_ring_hom_equiv (f : R ≃+* S) :
  is_local_ring_hom (f : R →+* S) :=
{ map_nonunit := λ a ha,
  begin
    convert (f.symm : S →+* R).is_unit_map ha,
    exact (ring_equiv.symm_apply_apply f a).symm,
  end }

@[simp] lemma is_unit_of_map_unit (f : R →+* S) [is_local_ring_hom f]
  (a) (h : is_unit (f a)) : is_unit a :=
is_local_ring_hom.map_nonunit a h

theorem of_irreducible_map (f : R →+* S) [h : is_local_ring_hom f] {x}
  (hfx : irreducible (f x)) : irreducible x :=
⟨λ h, hfx.not_unit $ is_unit.map f h, λ p q hx, let ⟨H⟩ := h in
or.imp (H p) (H q) $ hfx.is_unit_or_is_unit $ f.map_mul p q ▸ congr_arg f hx⟩

lemma is_local_ring_hom_of_comp (f : R →+* S) (g : S →+* T) [is_local_ring_hom (g.comp f)] :
  is_local_ring_hom f :=
⟨λ a ha, (is_unit_map_iff (g.comp f) _).mp (g.is_unit_map ha)⟩

/-- If `f : R →+* S` is a local ring hom, then `R` is a local ring if `S` is. -/
lemma _root_.ring_hom.domain_local_ring {R S : Type*} [comm_semiring R] [comm_semiring S]
  [H : _root_.local_ring S] (f : R →+* S)
  [is_local_ring_hom f] : _root_.local_ring R :=
begin
  haveI : nontrivial R := pullback_nonzero f f.map_zero f.map_one,
  apply local_ring.of_nonunits_add,
  intros a b,
  simp_rw [←map_mem_nonunits_iff f, f.map_add],
  exact local_ring.nonunits_add
end

end

section
open local_ring
variables [comm_semiring R] [local_ring R] [comm_semiring S] [local_ring S]

/--
The image of the maximal ideal of the source is contained within the maximal ideal of the target.
-/
lemma map_nonunit (f : R →+* S) [is_local_ring_hom f] (a : R) (h : a ∈ maximal_ideal R) :
  f a ∈ maximal_ideal S :=
λ H, h $ is_unit_of_map_unit f a H

end

namespace local_ring

section
variables [comm_semiring R] [local_ring R] [comm_semiring S] [local_ring S]

/--
A ring homomorphism between local rings is a local ring hom iff it reflects units,
i.e. any preimage of a unit is still a unit. https://stacks.math.columbia.edu/tag/07BJ
-/
theorem local_hom_tfae (f : R →+* S) :
  tfae [is_local_ring_hom f,
        f '' (maximal_ideal R).1 ⊆ maximal_ideal S,
        (maximal_ideal R).map f ≤ maximal_ideal S,
        maximal_ideal R ≤ (maximal_ideal S).comap f,
        (maximal_ideal S).comap f = maximal_ideal R] :=
begin
  tfae_have : 1 → 2, rintros _ _ ⟨a,ha,rfl⟩,
    resetI, exact map_nonunit f a ha,
  tfae_have : 2 → 4, exact set.image_subset_iff.1,
  tfae_have : 3 ↔ 4, exact ideal.map_le_iff_le_comap,
  tfae_have : 4 → 1, intro h, fsplit, exact λ x, not_imp_not.1 (@h x),
  tfae_have : 1 → 5, intro, resetI, ext,
    exact not_iff_not.2 (is_unit_map_iff f x),
  tfae_have : 5 → 4, exact λ h, le_of_eq h.symm,
  tfae_finish,
end

end

lemma of_surjective [comm_semiring R] [local_ring R] [comm_semiring S] [nontrivial S]
  (f : R →+* S) [is_local_ring_hom f] (hf : function.surjective f) :
  local_ring S :=
of_is_unit_or_is_unit_of_is_unit_add
begin
  intros a b hab,
  obtain ⟨a, rfl⟩ := hf a,
  obtain ⟨b, rfl⟩ := hf b,
  rw ←map_add at hab,
  exact (is_unit_or_is_unit_of_is_unit_add $ is_local_ring_hom.map_nonunit _ hab).imp
    f.is_unit_map f.is_unit_map
end

/-- If `f : R →+* S` is a surjective local ring hom, then the induced units map is surjective. -/
lemma surjective_units_map_of_local_ring_hom [comm_ring R] [comm_ring S]
  (f : R →+* S) (hf : function.surjective f) (h : is_local_ring_hom f) :
  function.surjective (units.map $ f.to_monoid_hom) :=
begin
  intro a,
  obtain ⟨b,hb⟩ := hf (a : S),
  use (is_unit_of_map_unit f _ (by { rw hb, exact units.is_unit _})).unit, ext, exact hb,
end

section
variables (R) [comm_ring R] [local_ring R] [comm_ring S] [local_ring S] [comm_ring T] [local_ring T]

/-- The residue field of a local ring is the quotient of the ring by its maximal ideal. -/
@[derive [ring, comm_ring, inhabited]]
def residue_field := R ⧸ maximal_ideal R

noncomputable instance residue_field.field : field (residue_field R) :=
ideal.quotient.field (maximal_ideal R)

/-- The quotient map from a local ring to its residue field. -/
def residue : R →+* (residue_field R) :=
ideal.quotient.mk _

instance residue_field.algebra : algebra R (residue_field R) :=
ideal.quotient.algebra _

lemma residue_field.algebra_map_eq : algebra_map R (residue_field R) = residue R := rfl

instance : is_local_ring_hom (local_ring.residue R) :=
⟨λ a ha, not_not.mp (ideal.quotient.eq_zero_iff_mem.not.mp (is_unit_iff_ne_zero.mp ha))⟩

variables {R}

namespace residue_field

/-- A local ring homomorphism into a field can be descended onto the residue field. -/
def lift {R S : Type*} [comm_ring R] [local_ring R] [field S]
  (f : R →+* S) [is_local_ring_hom f] : local_ring.residue_field R →+* S :=
ideal.quotient.lift _ f (λ a ha,
  classical.by_contradiction (λ h, ha (is_unit_of_map_unit f a (is_unit_iff_ne_zero.mpr h))))

lemma lift_comp_residue {R S : Type*} [comm_ring R] [local_ring R] [field S] (f : R →+* S)
  [is_local_ring_hom f] : (lift f).comp (residue R) = f :=
ring_hom.ext (λ _, rfl)

@[simp]
lemma lift_residue_apply {R S : Type*} [comm_ring R] [local_ring R] [field S] (f : R →+* S)
  [is_local_ring_hom f] (x) : lift f (residue R x) = f x :=
rfl

/-- The map on residue fields induced by a local homomorphism between local rings -/
def map (f : R →+* S) [is_local_ring_hom f] : residue_field R →+* residue_field S :=
ideal.quotient.lift (maximal_ideal R) ((ideal.quotient.mk _).comp f) $
λ a ha,
begin
  erw ideal.quotient.eq_zero_iff_mem,
  exact map_nonunit f a ha
end

/-- Applying `residue_field.map` to the identity ring homomorphism gives the identity
ring homomorphism. -/
@[simp] lemma map_id :
  local_ring.residue_field.map (ring_hom.id R) = ring_hom.id (local_ring.residue_field R) :=
ideal.quotient.ring_hom_ext $ ring_hom.ext $ λx, rfl

/-- The composite of two `residue_field.map`s is the `residue_field.map` of the composite. -/
lemma map_comp (f : T →+* R) (g : R →+* S) [is_local_ring_hom f] [is_local_ring_hom g] :
  local_ring.residue_field.map (g.comp f) =
  (local_ring.residue_field.map g).comp (local_ring.residue_field.map f) :=
ideal.quotient.ring_hom_ext $ ring_hom.ext $ λx, rfl

lemma map_comp_residue (f : R →+* S) [is_local_ring_hom f] :
  (residue_field.map f).comp (residue R) = (residue S).comp f := rfl

lemma map_residue (f : R →+* S) [is_local_ring_hom f] (r : R) :
  residue_field.map f (residue R r) = residue S (f r) := rfl

lemma map_id_apply (x : residue_field R) : map (ring_hom.id R) x = x :=
fun_like.congr_fun map_id x

@[simp] lemma map_map (f : R →+* S) (g : S →+* T) (x : residue_field R)
  [is_local_ring_hom f] [is_local_ring_hom g] :
  map g (map f x) = map (g.comp f) x :=
fun_like.congr_fun (map_comp f g).symm x

/-- A ring isomorphism defines an isomorphism of residue fields. -/
@[simps apply]
def map_equiv (f : R ≃+* S) : local_ring.residue_field R ≃+* local_ring.residue_field S :=
{ to_fun := map (f : R →+* S),
  inv_fun := map (f.symm : S →+* R),
  left_inv := λ x, by simp only [map_map, ring_equiv.symm_comp, map_id, ring_hom.id_apply],
  right_inv := λ x, by simp only [map_map, ring_equiv.comp_symm, map_id, ring_hom.id_apply],
  map_mul' := ring_hom.map_mul _,
  map_add' := ring_hom.map_add _ }

@[simp] lemma map_equiv.symm (f : R ≃+* S) : (map_equiv f).symm = map_equiv f.symm := rfl

@[simp] lemma map_equiv_trans (e₁ : R ≃+* S) (e₂ : S ≃+* T) :
  map_equiv (e₁.trans e₂) = (map_equiv e₁).trans (map_equiv e₂) :=
ring_equiv.to_ring_hom_injective $ map_comp (e₁ : R →+* S) (e₂ : S →+* T)

@[simp] lemma map_equiv_refl : map_equiv (ring_equiv.refl R) = ring_equiv.refl _ :=
ring_equiv.to_ring_hom_injective map_id

/-- The group homomorphism from `ring_aut R` to `ring_aut k` where `k`
is the residue field of `R`. -/
@[simps] def map_aut : ring_aut R →* ring_aut (local_ring.residue_field R) :=
{ to_fun := map_equiv,
  map_mul' := λ e₁ e₂, map_equiv_trans e₂ e₁,
  map_one' := map_equiv_refl }

section mul_semiring_action
variables (G : Type*) [group G] [mul_semiring_action G R]

/-- If `G` acts on `R` as a `mul_semiring_action`, then it also acts on `residue_field R`. -/
instance : mul_semiring_action G (local_ring.residue_field R) :=
mul_semiring_action.comp_hom _ $ map_aut.comp (mul_semiring_action.to_ring_aut G R)

@[simp] lemma residue_smul (g : G) (r : R) : residue R (g • r) = g • residue R r := rfl

end mul_semiring_action

end residue_field

lemma ker_eq_maximal_ideal [field K] (φ : R →+* K) (hφ : function.surjective φ) :
  φ.ker = maximal_ideal R :=
local_ring.eq_maximal_ideal $ (ring_hom.ker_is_maximal_of_surjective φ) hφ

lemma is_local_ring_hom_residue :
  is_local_ring_hom (local_ring.residue R) :=
begin
  constructor,
  intros a ha,
  by_contra,
  erw ideal.quotient.eq_zero_iff_mem.mpr ((local_ring.mem_maximal_ideal _).mpr h) at ha,
  exact ha.ne_zero rfl,
end

end

end local_ring

namespace field
variables (K) [field K]

open_locale classical

@[priority 100] -- see Note [lower instance priority]
instance : local_ring K :=
local_ring.of_is_unit_or_is_unit_one_sub_self $ λ a,
  if h : a = 0
  then or.inr (by rw [h, sub_zero]; exact is_unit_one)
  else or.inl $ is_unit.mk0 a h

end field

lemma local_ring.maximal_ideal_eq_bot {R : Type*} [field R] :
  local_ring.maximal_ideal R = ⊥ :=
local_ring.is_field_iff_maximal_ideal_eq.mp (field.to_is_field R)

namespace ring_equiv

@[reducible] protected

end ring_equiv


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.fiber_bundle
import geometry.manifold.smooth_manifold_with_corners

/-!
# Basic smooth bundles

In general, a smooth bundle is a bundle over a smooth manifold, whose fiber is a manifold, and
for which the coordinate changes are smooth. In this definition, there are charts involved at
several places: in the manifold structure of the base, in the manifold structure of the fibers, and
in the local trivializations. This makes it a complicated object in general. There is however a
specific situation where things are much simpler: when the fiber is a vector space (no need for
charts for the fibers), and when the local trivializations of the bundle and the charts of the base
coincide. Then everything is expressed in terms of the charts of the base, making for a much
simpler overall structure, which is easier to manipulate formally.

Most vector bundles that naturally occur in differential geometry are of this form:
the tangent bundle, the cotangent bundle, differential forms (used to define de Rham cohomology)
and the bundle of Riemannian metrics. Therefore, it is worth defining a specific constructor for
this kind of bundle, that we call basic smooth bundles.

A basic smooth bundle is thus a smooth bundle over a smooth manifold whose fiber is a vector space,
and which is trivial in the coordinate charts of the base. (We recall that in our notion of manifold
there is a distinguished atlas, which does not need to be maximal: we require the triviality above
this specific atlas). It can be constructed from a basic smooth bundled core, defined below,
specifying the changes in the fiber when one goes from one coordinate chart to another one. We do
not require that this changes in fiber are linear, but only diffeomorphisms.

## Main definitions

* `basic_smooth_bundle_core I M F`: assuming that `M` is a smooth manifold over the model with
  corners `I` on `(𝕜, E, H)`, and `F` is a normed vector space over `𝕜`, this structure registers,
  for each pair of charts of `M`, a smooth change of coordinates on `F`. This is the core structure
  from which one will build a smooth bundle with fiber `F` over `M`.

Let `Z` be a basic smooth bundle core over `M` with fiber `F`. We define
`Z.to_topological_fiber_bundle_core`, the (topological) fiber bundle core associated to `Z`. From
it, we get a space `Z.to_topological_fiber_bundle_core.total_space` (which as a Type is just `Σ (x :
M), F`), with the fiber bundle topology. It inherits a manifold structure (where the charts are in
bijection with the charts of the basis). We show that this manifold is smooth.

Then we use this machinery to construct the tangent bundle of a smooth manifold.

* `tangent_bundle_core I M`: the basic smooth bundle core associated to a smooth manifold `M` over a
  model with corners `I`.
* `tangent_bundle I M`     : the total space of `tangent_bundle_core I M`. It is itself a
  smooth manifold over the model with corners `I.tangent`, the product of `I` and the trivial model
  with corners on `E`.
* `tangent_space I x`      : the tangent space to `M` at `x`
* `tangent_bundle.proj I M`: the projection from the tangent bundle to the base manifold

## Implementation notes

In the definition of a basic smooth bundle core, we do not require that the coordinate changes of
the fibers are linear map, only that they are diffeomorphisms. Therefore, the fibers of the
resulting fiber bundle do not inherit a vector space structure (as an algebraic object) in general.
As the fiber, as a type, is just `F`, one can still always register the vector space structure, but
it does not make sense to do so (i.e., it will not lead to any useful theorem) unless this structure
is canonical, i.e., the coordinate changes are linear maps.

For instance, we register the vector space structure on the fibers of the tangent bundle. However,
we do not register the normed space structure coming from that of `F` (as it is not canonical, and
we also want to keep the possibility to add a Riemannian structure on the manifold later on without
having two competing normed space instances on the tangent spaces).

We require `F` to be a normed space, and not just a topological vector space, as we want to talk
about smooth functions on `F`. The notion of derivative requires a norm to be defined.

## TODO
construct the cotangent bundle, and the bundles of differential forms. They should follow
functorially from the description of the tangent bundle as a basic smooth bundle.

## Tags
Smooth fiber bundle, vector bundle, tangent space, tangent bundle
-/

noncomputable theory

universe u

open topological_space set
open_locale manifold topological_space

/-- Core structure used to create a smooth bundle above `M` (a manifold over the model with
corner `I`) with fiber the normed vector space `F` over `𝕜`, which is trivial in the chart domains
of `M`. This structure registers the changes in the fibers when one changes coordinate charts in the
base. We do not require the change of coordinates of the fibers to be linear, only smooth.
Therefore, the fibers of the resulting bundle will not inherit a canonical vector space structure
in general. -/
structure basic_smooth_bundle_core {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
(F : Type*) [normed_group F] [normed_space 𝕜 F] :=
(coord_change      : atlas H M → atlas H M → H → F → F)
(coord_change_self :
  ∀ i : atlas H M, ∀ x ∈ i.1.target, ∀ v, coord_change i i x v = v)
(coord_change_comp : ∀ i j k : atlas H M,
  ∀ x ∈ ((i.1.symm.trans j.1).trans (j.1.symm.trans k.1)).source, ∀ v,
  (coord_change j k ((i.1.symm.trans j.1) x)) (coord_change i j x v) = coord_change i k x v)
(coord_change_smooth : ∀ i j : atlas H M,
  times_cont_diff_on 𝕜 ∞ (λp : E × F, coord_change i j (I.symm p.1) p.2)
  ((I '' (i.1.symm.trans j.1).source).prod (univ : set F)))

/-- The trivial basic smooth bundle core, in which all the changes of coordinates are the
identity. -/
def trivial_basic_smooth_bundle_core {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
(F : Type*) [normed_group F] [normed_space 𝕜 F] : basic_smooth_bundle_core I M F :=
{ coord_change := λ i j x v, v,
  coord_change_self := λ i x hx v, rfl,
  coord_change_comp := λ i j k x hx v, rfl,
  coord_change_smooth := λ i j, times_cont_diff_snd.times_cont_diff_on }

namespace basic_smooth_bundle_core

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] {I : model_with_corners 𝕜 E H}
{M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
{F : Type*} [normed_group F] [normed_space 𝕜 F]
(Z : basic_smooth_bundle_core I M F)

instance : inhabited (basic_smooth_bundle_core I M F) :=
⟨trivial_basic_smooth_bundle_core I M F⟩

/-- Fiber bundle core associated to a basic smooth bundle core -/
def to_topological_fiber_bundle_core : topological_fiber_bundle_core (atlas H M) M F :=
{ base_set := λi, i.1.source,
  is_open_base_set := λi, i.1.open_source,
  index_at := λx, ⟨chart_at H x, chart_mem_atlas H x⟩,
  mem_base_set_at := λx, mem_chart_source H x,
  coord_change := λi j x v, Z.coord_change i j (i.1 x) v,
  coord_change_self := λi x hx v, Z.coord_change_self i (i.1 x) (i.1.map_source hx) v,
  coord_change_comp := λi j k x ⟨⟨hx1, hx2⟩, hx3⟩ v, begin
    have := Z.coord_change_comp i j k (i.1 x) _ v,
    convert this using 2,
    { simp only [hx1] with mfld_simps },
    { simp only [hx1, hx2, hx3] with mfld_simps }
  end,
  coord_change_continuous := λi j, begin
    have A : continuous_on (λp : E × F, Z.coord_change i j (I.symm p.1) p.2)
      ((I '' (i.1.symm.trans j.1).source).prod (univ : set F)) :=
      (Z.coord_change_smooth i j).continuous_on,
    have B : continuous_on (λx : M, I (i.1 x)) i.1.source :=
      I.continuous.comp_continuous_on i.1.continuous_on,
    have C : continuous_on (λp : M × F, (⟨I (i.1 p.1), p.2⟩ : E × F))
             (i.1.source.prod univ),
    { apply continuous_on.prod _ continuous_snd.continuous_on,
      exact B.comp continuous_fst.continuous_on (prod_subset_preimage_fst _ _) },
    have C' : continuous_on (λp : M × F, (⟨I (i.1 p.1), p.2⟩ : E × F))
              ((i.1.source ∩ j.1.source).prod univ) :=
      continuous_on.mono C (prod_mono (inter_subset_left _ _) (subset.refl _)),
    have D : (i.1.source ∩ j.1.source).prod univ ⊆ (λ (p : M × F),
      (I (i.1 p.1), p.2)) ⁻¹' ((I '' (i.1.symm.trans j.1).source).prod univ),
    { rintros ⟨x, v⟩ hx,
      simp only with mfld_simps at hx,
      simp only [hx] with mfld_simps },
    convert continuous_on.comp A C' D,
    ext p,
    simp only with mfld_simps
  end }

@[simp, mfld_simps] lemma base_set (i : atlas H M) :
  (Z.to_topological_fiber_bundle_core.local_triv i).base_set = i.1.source := rfl

/-- Local chart for the total space of a basic smooth bundle -/
def chart {e : local_homeomorph M H} (he : e ∈ atlas H M) :
  local_homeomorph (Z.to_topological_fiber_bundle_core.total_space) (model_prod H F) :=
(Z.to_topological_fiber_bundle_core.local_triv ⟨e, he⟩).to_local_homeomorph.trans
  (local_homeomorph.prod e (local_homeomorph.refl F))

@[simp, mfld_simps] lemma chart_source (e : local_homeomorph M H) (he : e ∈ atlas H M) :
  (Z.chart he).source = Z.to_topological_fiber_bundle_core.proj ⁻¹' e.source :=
by { simp only [chart, mem_prod], mfld_set_tac }

@[simp, mfld_simps] lemma chart_target (e : local_homeomorph M H) (he : e ∈ atlas H M) :
  (Z.chart he).target = e.target.prod univ :=
by { simp only [chart], mfld_set_tac }

/-- The total space of a basic smooth bundle is endowed with a charted space structure, where the
charts are in bijection with the charts of the basis. -/
instance to_charted_space :
  charted_space (model_prod H F) Z.to_topological_fiber_bundle_core.total_space :=
{ atlas := ⋃(e : local_homeomorph M H) (he : e ∈ atlas H M), {Z.chart he},
  chart_at := λp, Z.chart (chart_mem_atlas H p.1),
  mem_chart_source := λp, by simp [mem_chart_source],
  chart_mem_atlas := λp, begin
    simp only [mem_Union, mem_singleton_iff, chart_mem_atlas],
    exact ⟨chart_at H p.1, chart_mem_atlas H p.1, rfl⟩
  end }

lemma mem_atlas_iff
  (f : local_homeomorph Z.to_topological_fiber_bundle_core.total_space (model_prod H F)) :
  f ∈ atlas (model_prod H F) Z.to_topological_fiber_bundle_core.total_space ↔
  ∃(e : local_homeomorph M H) (he : e ∈ atlas H M), f = Z.chart he :=
by simp only [atlas, mem_Union, mem_singleton_iff]

@[simp, mfld_simps] lemma mem_chart_source_iff
  (p q : Z.to_topological_fiber_bundle_core.total_space) :
  p ∈ (chart_at (model_prod H F) q).source ↔ p.1 ∈ (chart_at H q.1).source :=
by simp only [chart_at] with mfld_simps

@[simp, mfld_simps] lemma mem_chart_target_iff
  (p : H × F) (q : Z.to_topological_fiber_bundle_core.total_space) :
  p ∈ (chart_at (model_prod H F) q).target ↔ p.1 ∈ (chart_at H q.1).target :=
by simp only [chart_at] with mfld_simps

@[simp, mfld_simps] lemma coe_chart_at_fst (p q : Z.to_topological_fiber_bundle_core.total_space) :
  ((chart_at (model_prod H F) q) p).1 = chart_at H q.1 p.1 := rfl

@[simp, mfld_simps] lemma coe_chart_at_symm_fst
  (p : H × F) (q : Z.to_topological_fiber_bundle_core.total_space) :
  ((chart_at (model_prod H F) q).symm p).1 = ((chart_at H q.1).symm : H → M) p.1 := rfl

/-- Smooth manifold structure on the total space of a basic smooth bundle -/
instance to_smooth_manifold :
  smooth_manifold_with_corners (I.prod (𝓘(𝕜, F))) Z.to_topological_fiber_bundle_core.total_space :=
begin
  /- We have to check that the charts belong to the smooth groupoid, i.e., they are smooth on their
  source, and their inverses are smooth on the target. Since both objects are of the same kind, it
  suffices to prove the first statement in A below, and then glue back the pieces at the end. -/
  let J := model_with_corners.to_local_equiv (I.prod (𝓘(𝕜, F))),
  have A : ∀ (e e' : local_homeomorph M H) (he : e ∈ atlas H M) (he' : e' ∈ atlas H M),
    times_cont_diff_on 𝕜 ∞
    (J ∘ ((Z.chart he).symm.trans (Z.chart he')) ∘ J.symm)
    (J.symm ⁻¹' ((Z.chart he).symm.trans (Z.chart he')).source ∩ range J),
  { assume e e' he he',
    have : J.symm ⁻¹' ((chart Z he).symm.trans (chart Z he')).source ∩ range J =
      (I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod univ,
      by { simp only [J, chart, model_with_corners.prod], mfld_set_tac },
    rw this,
    -- check separately that the two components of the coordinate change are smooth
    apply times_cont_diff_on.prod,
    show times_cont_diff_on 𝕜 ∞ (λ (p : E × F), (I ∘ e' ∘ e.symm ∘ I.symm) p.1)
         ((I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod (univ : set F)),
    { -- the coordinate change on the base is just a coordinate change for `M`, smooth since
      -- `M` is smooth
      have A : times_cont_diff_on 𝕜 ∞ (I ∘ (e.symm.trans e') ∘ I.symm)
        (I.symm ⁻¹' (e.symm.trans e').source ∩ range I) :=
      (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) he he').1,
      have B : times_cont_diff_on 𝕜 ∞ (λp : E × F, p.1)
        ((I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod univ) :=
      times_cont_diff_fst.times_cont_diff_on,
      exact times_cont_diff_on.comp A B (prod_subset_preimage_fst _ _) },
    show times_cont_diff_on 𝕜 ∞ (λ (p : E × F),
      Z.coord_change ⟨chart_at H (e.symm (I.symm p.1)), _⟩ ⟨e', he'⟩
         ((chart_at H (e.symm (I.symm p.1)) : M → H) (e.symm (I.symm p.1)))
      (Z.coord_change ⟨e, he⟩ ⟨chart_at H (e.symm (I.symm p.1)), _⟩
        (e (e.symm (I.symm p.1))) p.2))
      ((I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod (univ : set F)),
    { /- The coordinate change in the fiber is more complicated as its definition involves the
      reference chart chosen at each point. However, it appears with its inverse, so using the
      cocycle property one can get rid of it, and then conclude using the smoothness of the
      cocycle as given in the definition of basic smooth bundles. -/
      have := Z.coord_change_smooth ⟨e, he⟩ ⟨e', he'⟩,
      rw I.image_eq at this,
      apply times_cont_diff_on.congr this,
      rintros ⟨x, v⟩ hx,
      simp only with mfld_simps at hx,
      let f := chart_at H (e.symm (I.symm x)),
      have A : I.symm x ∈ ((e.symm.trans f).trans (f.symm.trans e')).source,
        by simp only [hx.1.1, hx.1.2] with mfld_simps,
      rw e.right_inv hx.1.1,
      have := Z.coord_change_comp ⟨e, he⟩ ⟨f, chart_mem_atlas _ _⟩ ⟨e', he'⟩ (I.symm x) A v,
      simpa only [] using this } },
  refine @smooth_manifold_with_corners.mk _ _ _ _ _ _ _ _ _ _ _ ⟨_⟩,
  assume e₀ e₀' he₀ he₀',
  rcases (Z.mem_atlas_iff _).1 he₀ with ⟨e, he, rfl⟩,
  rcases (Z.mem_atlas_iff _).1 he₀' with ⟨e', he', rfl⟩,
  rw [times_cont_diff_groupoid, mem_groupoid_of_pregroupoid],
  exact ⟨A e e' he he', A e' e he' he⟩
end

end basic_smooth_bundle_core

section tangent_bundle

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

/-- Basic smooth bundle core version of the tangent bundle of a smooth manifold `M` modelled over a
model with corners `I` on `(E, H)`. The fibers are equal to `E`, and the coordinate change in the
fiber corresponds to the derivative of the coordinate change in `M`. -/
def tangent_bundle_core : basic_smooth_bundle_core I M E :=
{ coord_change := λi j x v, (fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
                            (range I) (I x) : E → E) v,
  coord_change_smooth := λi j, begin
    /- To check that the coordinate change of the bundle is smooth, one should just use the
    smoothness of the charts, and thus the smoothness of their derivatives. -/
    rw I.image_eq,
    have A : times_cont_diff_on 𝕜 ∞
      (I ∘ (i.1.symm.trans j.1) ∘ I.symm)
      (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) :=
      (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) i.2 j.2).1,
    have B : unique_diff_on 𝕜 (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) :=
      I.unique_diff_preimage_source,
    have C : times_cont_diff_on 𝕜 ∞
      (λ (p : E × E), (fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
            (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) p.1 : E → E) p.2)
      ((I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I).prod univ) :=
      times_cont_diff_on_fderiv_within_apply A B le_top,
    have D : ∀ x ∈ (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I),
      fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
            (range I) x =
      fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
            (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) x,
    { assume x hx,
      have N : I.symm ⁻¹' (i.1.symm.trans j.1).source ∈ nhds x :=
        I.continuous_symm.continuous_at.preimage_mem_nhds
          (is_open.mem_nhds (local_homeomorph.open_source _) hx.1),
      symmetry,
      rw inter_comm,
      exact fderiv_within_inter N (I.unique_diff _ hx.2) },
    apply times_cont_diff_on.congr C,
    rintros ⟨x, v⟩ hx,
    have E : x ∈ I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I,
      by simpa only [prod_mk_mem_set_prod_eq, and_true, mem_univ] using hx,
    have : I (I.symm x) = x, by simp [E.2],
    dsimp [-subtype.val_eq_coe],
    rw [this, D x E],
    refl
  end,
  coord_change_self := λi x hx v, begin
    /- Locally, a self-change of coordinate is just the identity, thus its derivative is the
    identity. One just needs to write this carefully, paying attention to the sets where the
    functions are defined. -/
    have A : I.symm ⁻¹' (i.1.symm.trans i.1).source ∩ range I ∈
      𝓝[range I] (I x),
    { rw inter_comm,
      apply inter_mem_nhds_within,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (is_open.mem_nhds (local_homeomorph.open_source _) _),
      simp only [hx, i.1.map_target] with mfld_simps },
    have B : ∀ᶠ y in 𝓝[range I] (I x),
      (I ∘ i.1 ∘ i.1.symm ∘ I.symm) y = (id : E → E) y,
    { filter_upwards [A],
      assume y hy,
      rw ← I.image_eq at hy,
      rcases hy with ⟨z, hz⟩,
      simp only with mfld_simps at hz,
      simp only [hz.2.symm, hz.1] with mfld_simps },
    have C : fderiv_within 𝕜 (I ∘ i.1 ∘ i.1.symm ∘ I.symm) (range I) (I x) =
             fderiv_within 𝕜 (id : E → E) (range I) (I x) :=
      filter.eventually_eq.fderiv_within_eq I.unique_diff_at_image B
      (by simp only [hx] with mfld_simps),
    rw fderiv_within_id I.unique_diff_at_image at C,
    rw C,
    refl
  end,
  coord_change_comp := λi j u x hx, begin
    /- The cocycle property is just the fact that the derivative of a composition is the product of
    the derivatives. One needs however to check that all the functions one considers are smooth, and
    to pay attention to the domains where these functions are defined, making this proof a little
    bit cumbersome although there is nothing complicated here. -/
    have M : I x ∈
      (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I) :=
    ⟨by simpa only [mem_preimage, model_with_corners.left_inv] using hx, mem_range_self _⟩,
    have U : unique_diff_within_at 𝕜
      (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I) (I x) :=
      I.unique_diff_preimage_source _ M,
    have A : fderiv_within 𝕜 ((I ∘ u.1 ∘ j.1.symm ∘ I.symm) ∘ (I ∘ j.1 ∘ i.1.symm ∘ I.symm))
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x)
      = (fderiv_within 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm)
             (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I)
             ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x))).comp
        (fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x)),
    { apply fderiv_within.comp _ _ _ _ U,
      show differentiable_within_at 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
        (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
        (I x),
      { have A : times_cont_diff_on 𝕜 ∞
          (I ∘ (i.1.symm.trans j.1) ∘ I.symm)
          (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) :=
        (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) i.2 j.2).1,
        have B : differentiable_on 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
          (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I),
        { apply (A.differentiable_on le_top).mono,
          have : ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ⊆
            (i.1.symm.trans j.1).source := inter_subset_left _ _,
          exact inter_subset_inter (preimage_mono this) (subset.refl (range I)) },
        apply B,
        simpa only [] with mfld_simps using hx },
      show differentiable_within_at 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm)
        (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I)
        ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x)),
      { have A : times_cont_diff_on 𝕜 ∞
          (I ∘ (j.1.symm.trans u.1) ∘ I.symm)
          (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I) :=
        (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) j.2 u.2).1,
        apply A.differentiable_on le_top,
        rw [local_homeomorph.trans_source] at hx,
        simp only with mfld_simps,
        exact hx.2 },
      show (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
        ⊆ (I ∘ j.1 ∘ i.1.symm ∘ I.symm) ⁻¹' (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I),
      { assume y hy,
        simp only with mfld_simps at hy,
        rw [local_homeomorph.left_inv] at hy,
        { simp only [hy] with mfld_simps },
        { exact hy.1.1.2 } } },
    have B : fderiv_within 𝕜 ((I ∘ u.1 ∘ j.1.symm ∘ I.symm)
                          ∘ (I ∘ j.1 ∘ i.1.symm ∘ I.symm))
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x)
             = fderiv_within 𝕜 (I ∘ u.1 ∘ i.1.symm ∘ I.symm)
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x),
    { have E :
        ∀ y ∈ (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I),
          ((I ∘ u.1 ∘ j.1.symm ∘ I.symm) ∘ (I ∘ j.1 ∘ i.1.symm ∘ I.symm)) y =
            (I ∘ u.1 ∘ i.1.symm ∘ I.symm) y,
      { assume y hy,
        simp only [function.comp_app, model_with_corners.left_inv],
        rw [j.1.left_inv],
        exact hy.1.1.2 },
      exact fderiv_within_congr U E (E _ M) },
    have C : fderiv_within 𝕜 (I ∘ u.1 ∘ i.1.symm ∘ I.symm)
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x) =
             fderiv_within 𝕜 (I ∘ u.1 ∘ i.1.symm ∘ I.symm)
             (range I) (I x),
    { rw inter_comm,
      apply fderiv_within_inter _ I.unique_diff_at_image,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (is_open.mem_nhds (local_homeomorph.open_source _) _),
      simpa only [model_with_corners.left_inv] using hx },
    have D : fderiv_within 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm)
      (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I) ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x)) =
      fderiv_within 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm) (range I) ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x)),
    { rw inter_comm,
      apply fderiv_within_inter _ I.unique_diff_at_image,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (is_open.mem_nhds (local_homeomorph.open_source _) _),
      rw [local_homeomorph.trans_source] at hx,
      simp only with mfld_simps,
      exact hx.2 },
    have E : fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
               (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
               (I x) =
             fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm) (range I) (I x),
    { rw inter_comm,
      apply fderiv_within_inter _ I.unique_diff_at_image,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (is_open.mem_nhds (local_homeomorph.open_source _) _),
      simpa only [model_with_corners.left_inv] using hx },
    rw [B, C, D, E] at A,
    simp only [A, continuous_linear_map.coe_comp'] with mfld_simps
  end }

variable {M}
include I

/-- The tangent space at a point of the manifold `M`. It is just `E`. We could use instead
`(tangent_bundle_core I M).to_topological_fiber_bundle_core.fiber x`, but we use `E` to help the
kernel.
-/
@[nolint unused_arguments]
def tangent_space (x : M) : Type* := E

omit I
variable (M)

/-- The tangent bundle to a smooth manifold, as a plain type. We could use
`(tangent_bundle_core I M).to_topological_fiber_bundle_core.total_space`, but instead we use the
(definitionally equal) `Σ (x : M), tangent_space I x`, to make sure that rcasing an element of the
tangent bundle gives a second component in the tangent space. -/
@[nolint has_inhabited_instance, reducible] -- is empty if the base manifold is empty
def tangent_bundle := Σ (x : M), tangent_space I x

/-- The projection from the tangent bundle of a smooth manifold to the manifold. As the tangent
bundle is represented internally as a sigma type, the notation `p.1` also works for the projection
of the point `p`. -/
def tangent_bundle.proj : tangent_bundle I M → M :=
λ p, p.1

variable {M}

@[simp, mfld_simps] lemma tangent_bundle.proj_apply (x : M) (v : tangent_space I x) :
  tangent_bundle.proj I M ⟨x, v⟩ = x :=
rfl

section tangent_bundle_instances

/- In general, the definition of tangent_bundle and tangent_space are not reducible, so that type
class inference does not pick wrong instances. In this section, we record the right instances for
them, noting in particular that the tangent bundle is a smooth manifold. -/
variable (M)

instance : topological_space (tangent_bundle I M) :=
(tangent_bundle_core I M).to_topological_fiber_bundle_core.to_topological_space (atlas H M)

instance : charted_space (model_prod H E) (tangent_bundle I M) :=
(tangent_bundle_core I M).to_charted_space

instance : smooth_manifold_with_corners I.tangent (tangent_bundle I M) :=
(tangent_bundle_core I M).to_smooth_manifold

local attribute [reducible] tangent_space
variables {M} (x : M)

instance : has_continuous_smul 𝕜 (tangent_space I x) := by apply_instance
instance : topological_space (tangent_space I x) := by apply_instance
instance : add_comm_group (tangent_space I x) := by apply_instance
instance : topological_add_group (tangent_space I x) := by apply_instance
instance : module 𝕜 (tangent_space I x) := by apply_instance
instance : inhabited (tangent_space I x) := ⟨0⟩

end tangent_bundle_instances

variable (M)

/-- The tangent bundle projection on the basis is a continuous map. -/
lemma tangent_bundle_proj_continuous : continuous (tangent_bundle.proj I M) :=
topological_fiber_bundle_core.continuous_proj _

/-- The tangent bundle projection on the basis is an open map. -/
lemma tangent_bundle_proj_open : is_open_map (tangent_bundle.proj I M) :=
topological_fiber_bundle_core.is_open_map_proj _

/-- In the tangent bundle to the model space, the charts are just the canonical identification
between a product type and a sigma type, a.k.a. `equiv.sigma_equiv_prod`. -/
@[simp, mfld_simps] lemma tangent_bundle_model_space_chart_at (p : tangent_bundle I H) :
  (chart_at (model_prod H E) p).to_local_equiv = (equiv.sigma_equiv_prod H E).to_local_equiv :=
begin
  have A : ∀ x_fst, fderiv_within 𝕜 (I ∘ I.symm) (range I) (I x_fst) = continuous_linear_map.id 𝕜 E,
  { assume x_fst,
    have : fderiv_within 𝕜 (I ∘ I.symm) (range I) (I x_fst)
         = fderiv_within 𝕜 id (range I) (I x_fst),
    { refine fderiv_within_congr I.unique_diff_at_image (λy hy, _) (by simp),
      exact model_with_corners.right_inv _ hy },
    rwa fderiv_within_id I.unique_diff_at_image at this },
  ext x : 1,
  show (chart_at (model_prod H E) p : tangent_bundle I H → model_prod H E) x =
    (equiv.sigma_equiv_prod H E) x,
  { cases x,
    simp only [chart_at, basic_smooth_bundle_core.chart, tangent_bundle_core,
      basic_smooth_bundle_core.to_topological_fiber_bundle_core, A, prod.mk.inj_iff,
      continuous_linear_map.coe_id'] with mfld_simps, },
  show ∀ x, ((chart_at (model_prod H E) p).to_local_equiv).symm x =
    (equiv.sigma_equiv_prod H E).symm x,
  { rintros ⟨x_fst, x_snd⟩,
    simp only [chart_at, basic_smooth_bundle_core.chart, tangent_bundle_core,
      continuous_linear_map.coe_id', basic_smooth_bundle_core.to_topological_fiber_bundle_core, A]
      with mfld_simps },
  show ((chart_at (model_prod H E) p).to_local_equiv).source = univ,
    by simp only [chart_at] with mfld_simps,
end

@[simp, mfld_simps] lemma tangent_bundle_model_space_coe_chart_at (p : tangent_bundle I H) :
  ⇑(chart_at (model_prod H E) p) = equiv.sigma_equiv_prod H E :=
by { unfold_coes, simp only with mfld_simps }

@[simp, mfld_simps] lemma tangent_bundle_model_space_coe_chart_at_symm (p : tangent_bundle I H) :
  ((chart_at (model_prod H E) p).symm : model_prod H E → tangent_bundle I H) =
  (equiv.sigma_equiv_prod H E).symm :=
by { unfold_coes, simp only with mfld_simps }

variable (H)
/-- The canonical identification between the tangent bundle to the model space and the product,
as a homeomorphism -/
def tangent_bundle_model_space_homeomorph : tangent_bundle I H ≃ₜ model_prod H E :=
{ continuous_to_fun :=
  begin
    let p : tangent_bundle I H := ⟨I.symm (0 : E), (0 : E)⟩,
    have : continuous (chart_at (model_prod H E) p),
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  continuous_inv_fun :=
  begin
    let p : tangent_bundle I H := ⟨I.symm (0 : E), (0 : E)⟩,
    have : continuous (chart_at (model_prod H E) p).symm,
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  .. equiv.sigma_equiv_prod H E }

@[simp, mfld_simps] lemma tangent_bundle_model_space_homeomorph_coe :
  (tangent_bundle_model_space_homeomorph H I : tangent_bundle I H → model_prod H E)
  = equiv.sigma_equiv_prod H E :=
rfl

@[simp, mfld_simps] lemma tangent_bundle_model_space_homeomorph_coe_symm :
  ((tangent_bundle_model_space_homeomorph H I).symm : model_prod H E → tangent_bundle I H)
  = (equiv.sigma_equiv_prod H E).symm :=
rfl

end tangent_bundle


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Johannes Hölzl

! This file was ported from Lean 3 source module order.ord_continuous
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.ConditionallyCompleteLattice.Basic
import Mathlib.Order.RelIso.Basic

/-!
# Order continuity

We say that a function is *left order continuous* if it sends all least upper bounds
to least upper bounds. The order dual notion is called *right order continuity*.

For monotone functions `ℝ → ℝ` these notions correspond to the usual left and right continuity.

We prove some basic lemmas (`map_sup`, `map_supₛ` etc) and prove that a `RelIso` is both left
and right order continuous.
-/

universe u v w x

variable {α : Type u} {β : Type v} {γ : Type w} {ι : Sort x}

open Function OrderDual Set

/-!
### Definitions
-/

/-- A function `f` between preorders is left order continuous if it preserves all suprema.  We
define it using `is_lub` instead of `Sup` so that the proof works both for complete lattices and
conditionally complete lattices. -/
def LeftOrdContinuous [Preorder α] [Preorder β] (f : α → β) :=
  ∀ ⦃s : Set α⦄ ⦃x⦄, IsLUB s x → IsLUB (f '' s) (f x)
#align left_ord_continuous LeftOrdContinuous

/-- A function `f` between preorders is right order continuous if it preserves all infima.  We
define it using `is_glb` instead of `Inf` so that the proof works both for complete lattices and
conditionally complete lattices. -/
def RightOrdContinuous [Preorder α] [Preorder β] (f : α → β) :=
  ∀ ⦃s : Set α⦄ ⦃x⦄, IsGLB s x → IsGLB (f '' s) (f x)
#align right_ord_continuous RightOrdContinuous

namespace LeftOrdContinuous

section Preorder

variable (α) [Preorder α] [Preorder β] [Preorder γ] {g : β → γ} {f : α → β}

protected theorem id : LeftOrdContinuous (id : α → α) := fun s x h => by
  simpa only [image_id] using h
#align left_ord_continuous.id LeftOrdContinuous.id

variable {α}

-- porting note: not sure what is the correct name for this
protected theorem order_dual : LeftOrdContinuous f → RightOrdContinuous (toDual ∘ f ∘ ofDual) :=
  id
#align left_ord_continuous.order_dual LeftOrdContinuous.order_dual

theorem map_isGreatest (hf : LeftOrdContinuous f) {s : Set α} {x : α} (h : IsGreatest s x) :
    IsGreatest (f '' s) (f x) :=
  ⟨mem_image_of_mem f h.1, (hf h.isLUB).1⟩
#align left_ord_continuous.map_is_greatest LeftOrdContinuous.map_isGreatest

theorem mono (hf : LeftOrdContinuous f) : Monotone f := fun a₁ a₂ h =>
  have : IsGreatest {a₁, a₂} a₂ := ⟨Or.inr rfl, by simp [*]⟩
  (hf.map_isGreatest this).2 <| mem_image_of_mem _ (Or.inl rfl)
#align left_ord_continuous.mono LeftOrdContinuous.mono

theorem comp (hg : LeftOrdContinuous g) (hf : LeftOrdContinuous f) : LeftOrdContinuous (g ∘ f) :=
  fun s x h => by simpa only [image_image] using hg (hf h)
#align left_ord_continuous.comp LeftOrdContinuous.comp

-- PORTING NOTE: how to do this in non-tactic mode?
protected theorem iterate {f : α → α} (hf : LeftOrdContinuous f) (n : ℕ) :
    LeftOrdContinuous (f^[n]) :=
by induction n with
| zero => exact LeftOrdContinuous.id α
| succ n ihn => exact ihn.comp hf

#align left_ord_continuous.iterate LeftOrdContinuous.iterate

end Preorder

section SemilatticeSup

variable [SemilatticeSup α] [SemilatticeSup β] {f : α → β}

theorem map_sup (hf : LeftOrdContinuous f) (x y : α) : f (x ⊔ y) = f x ⊔ f y :=
  (hf isLUB_pair).unique <| by simp only [image_pair, isLUB_pair]
#align left_ord_continuous.map_sup LeftOrdContinuous.map_sup

theorem le_iff (hf : LeftOrdContinuous f) (h : Injective f) {x y} : f x ≤ f y ↔ x ≤ y := by
  simp only [← sup_eq_right, ← hf.map_sup, h.eq_iff]
#align left_ord_continuous.le_iff LeftOrdContinuous.le_iff

theorem lt_iff (hf : LeftOrdContinuous f) (h : Injective f) {x y} : f x < f y ↔ x < y := by
  simp only [lt_iff_le_not_le, hf.le_iff h]
#align left_ord_continuous.lt_iff LeftOrdContinuous.lt_iff

variable (f)

/-- Convert an injective left order continuous function to an order embedding. -/
def toOrderEmbedding (hf : LeftOrdContinuous f) (h : Injective f) : α ↪o β :=
  ⟨⟨f, h⟩, hf.le_iff h⟩
#align left_ord_continuous.to_order_embedding LeftOrdContinuous.toOrderEmbedding

variable {f}

@[simp]
theorem coe_toOrderEmbedding (hf : LeftOrdContinuous f) (h : Injective f) :
    ⇑(hf.toOrderEmbedding f h) = f :=
  rfl
#align left_ord_continuous.coe_to_order_embedding LeftOrdContinuous.coe_toOrderEmbedding

end SemilatticeSup

section CompleteLattice

variable [CompleteLattice α] [CompleteLattice β] {f : α → β}

theorem map_supₛ' (hf : LeftOrdContinuous f) (s : Set α) : f (supₛ s) = supₛ (f '' s) :=
  (hf <| isLUB_supₛ s).supₛ_eq.symm
#align left_ord_continuous.map_Sup' LeftOrdContinuous.map_supₛ'

theorem map_supₛ (hf : LeftOrdContinuous f) (s : Set α) : f (supₛ s) = ⨆ x ∈ s, f x := by
  rw [hf.map_supₛ', supₛ_image]
#align left_ord_continuous.map_Sup LeftOrdContinuous.map_supₛ

theorem map_supᵢ (hf : LeftOrdContinuous f) (g : ι → α) : f (⨆ i, g i) = ⨆ i, f (g i) := by
  simp only [supᵢ, hf.map_supₛ', ← range_comp]
  rfl
#align left_ord_continuous.map_supr LeftOrdContinuous.map_supᵢ

end CompleteLattice

section ConditionallyCompleteLattice

variable [ConditionallyCompleteLattice α] [ConditionallyCompleteLattice β] [Nonempty ι] {f : α → β}

theorem map_csupₛ (hf : LeftOrdContinuous f) {s : Set α} (sne : s.Nonempty) (sbdd : BddAbove s) :
    f (supₛ s) = supₛ (f '' s) :=
  ((hf <| isLUB_csupₛ sne sbdd).csupₛ_eq <| sne.image f).symm
#align left_ord_continuous.map_cSup LeftOrdContinuous.map_csupₛ

theorem map_csupᵢ (hf : LeftOrdContinuous f) {g : ι → α} (hg : BddAbove (range g)) :
    f (⨆ i, g i) = ⨆ i, f (g i) := by
  simp only [supᵢ, hf.map_csupₛ (range_nonempty _) hg, ← range_comp]
  rfl
#align left_ord_continuous.map_csupr LeftOrdContinuous.map_csupᵢ

end ConditionallyCompleteLattice

end LeftOrdContinuous

namespace RightOrdContinuous

section Preorder

variable (α) [Preorder α] [Preorder β] [Preorder γ] {g : β → γ} {f : α → β}

protected theorem id : RightOrdContinuous (id : α → α) := fun s x h => by
  simpa only [image_id] using h
#align right_ord_continuous.id RightOrdContinuous.id

variable {α}

protected theorem orderDual : RightOrdContinuous f → LeftOrdContinuous (toDual ∘ f ∘ ofDual) :=
  id
#align right_ord_continuous.order_dual RightOrdContinuous.orderDual

theorem map_isLeast (hf : RightOrdContinuous f) {s : Set α} {x : α} (h : IsLeast s x) :
    IsLeast (f '' s) (f x) :=
  hf.orderDual.map_isGreatest h
#align right_ord_continuous.map_is_least RightOrdContinuous.map_isLeast

theorem mono (hf : RightOrdContinuous f) : Monotone f :=
  hf.orderDual.mono.dual
#align right_ord_continuous.mono RightOrdContinuous.mono

theorem comp (hg : RightOrdContinuous g) (hf : RightOrdContinuous f) : RightOrdContinuous (g ∘ f) :=
  hg.orderDual.comp hf.orderDual
#align right_ord_continuous.comp RightOrdContinuous.comp

protected theorem iterate {f : α → α} (hf : RightOrdContinuous f) (n : ℕ) :
    RightOrdContinuous (f^[n]) :=
  hf.orderDual.iterate n
#align right_ord_continuous.iterate RightOrdContinuous.iterate

end Preorder

section SemilatticeInf

variable [SemilatticeInf α] [SemilatticeInf β] {f : α → β}

theorem map_inf (hf : RightOrdContinuous f) (x y : α) : f (x ⊓ y) = f x ⊓ f y :=
  hf.orderDual.map_sup x y
#align right_ord_continuous.map_inf RightOrdContinuous.map_inf

theorem le_iff (hf : RightOrdContinuous f) (h : Injective f) {x y} : f x ≤ f y ↔ x ≤ y :=
  hf.orderDual.le_iff h
#align right_ord_continuous.le_iff RightOrdContinuous.le_iff

theorem lt_iff (hf : RightOrdContinuous f) (h : Injective f) {x y} : f x < f y ↔ x < y :=
  hf.orderDual.lt_iff h
#align right_ord_continuous.lt_iff RightOrdContinuous.lt_iff

variable (f)

/-- Convert an injective left order continuous function to a `order_embedding`. -/
def toOrderEmbedding (hf : RightOrdContinuous f) (h : Injective f) : α ↪o β :=
  ⟨⟨f, h⟩, hf.le_iff h⟩
#align right_ord_continuous.to_order_embedding RightOrdContinuous.toOrderEmbedding

variable {f}

@[simp]
theorem coe_toOrderEmbedding (hf : RightOrdContinuous f) (h : Injective f) :
    ⇑(hf.toOrderEmbedding f h) = f :=
  rfl
#align right_ord_continuous.coe_to_order_embedding RightOrdContinuous.coe_toOrderEmbedding

end SemilatticeInf

section CompleteLattice

variable [CompleteLattice α] [CompleteLattice β] {f : α → β}

theorem map_infₛ' (hf : RightOrdContinuous f) (s : Set α) : f (infₛ s) = infₛ (f '' s) :=
  hf.orderDual.map_supₛ' s
#align right_ord_continuous.map_Inf' RightOrdContinuous.map_infₛ'

theorem map_infₛ (hf : RightOrdContinuous f) (s : Set α) : f (infₛ s) = ⨅ x ∈ s, f x :=
  hf.orderDual.map_supₛ s
#align right_ord_continuous.map_Inf RightOrdContinuous.map_infₛ

theorem map_infᵢ (hf : RightOrdContinuous f) (g : ι → α) : f (⨅ i, g i) = ⨅ i, f (g i) :=
  hf.orderDual.map_supᵢ g
#align right_ord_continuous.map_infi RightOrdContinuous.map_infᵢ

end CompleteLattice

section ConditionallyCompleteLattice

variable [ConditionallyCompleteLattice α] [ConditionallyCompleteLattice β] [Nonempty ι] {f : α → β}

theorem map_cinfₛ (hf : RightOrdContinuous f) {s : Set α} (sne : s.Nonempty) (sbdd : BddBelow s) :
    f (infₛ s) = infₛ (f '' s) :=
  hf.orderDual.map_csupₛ sne sbdd
#align right_ord_continuous.map_cInf RightOrdContinuous.map_cinfₛ

theorem map_cinfᵢ (hf : RightOrdContinuous f) {g : ι → α} (hg : BddBelow (range g)) :
    f (⨅ i, g i) = ⨅ i, f (g i) :=
  hf.orderDual.map_csupᵢ hg
#align right_ord_continuous.map_cinfi RightOrdContinuous.map_cinfᵢ

end ConditionallyCompleteLattice

end RightOrdContinuous

namespace OrderIso

section Preorder

variable [Preorder α] [Preorder β] (e : α ≃o β) {s : Set α} {x : α}

protected theorem leftOrdContinuous : LeftOrdContinuous e := fun _ _ hx =>
  ⟨Monotone.mem_upperBounds_image (fun _ _ => e.map_rel_iff.2) hx.1, fun _ hy =>
    e.rel_symm_apply.1 <|
      (isLUB_le_iff hx).2 fun _ hx' => e.rel_symm_apply.2 <| hy <| mem_image_of_mem _ hx'⟩
#align order_iso.left_ord_continuous OrderIso.leftOrdContinuous

protected

end Preorder

end OrderIso


variables A B C D : Prop

example : A ∧ (A → B) → B :=
assume h,
show B, from h.right h.left

example : A → ¬ (¬ A ∧ B) :=
assume h1 : A,
assume h2: ¬ A ∧ B,
show false, from h2.left h1

example : ¬ (A ∧ B) → (A → ¬ B) :=
λ h1 h2 h3, h1 (⟨ h2 , h3 ⟩)

example (h₁ : A ∨ B) (h₂ : A → C) (h₃ : B → D) : C ∨ D :=
or.elim h₁
  (assume h₄ : A, show C ∨ D, from or.inl (h₂ h₄))
  (assume h₄ : B, show C ∨ D, from or.inr (h₃ h₄))

example (h : ¬ A ∧ ¬ B) : ¬ (A ∨ B) :=
assume h1 : A ∨ B,
or.elim h1
  (assume h2 : A, show false, from h.left h2)
  (assume h3 : B, show false, from h.right h3)

example : ¬ (A ↔ ¬ A) :=
assume h,
have h1 : ¬ A, from
    assume a : A,
    show false, from (h.mp a) a,
show false, from h1 (h.mpr h1)