/-
Copyright (c) 2022 Flemming Hermansen.
Released under Apache 2.0 license as described in
https://www.apache.org/licenses/LICENSE-2.0
Authors: Flemming Hermansen
-/

import tactic
import tactic.basic
import field_theory.separable

import boolean_algebra_of_comm_ring_idempotents
import strict_mono_seq
import rel_inv

/-
lemma ideal_of_idempotent_strictly_increasing {A : Type*} [comm_ring A]
{e' e : idempotent_cri A} (hlt : e' < e)
: (ideal.span {e'.val} : ideal A) < (ideal.span {e.val} : ideal A)

theorem maxideal_from_atom' {A : Type*} [comm_ring A] {e a : A}
(hcov : covers_0 e) (h_inv : all_rel_inv A) (hnI : a * (1-e) ≠ a)
: ∃ b, b * a = e :=
-- Given a commutative ring A in which all elements have relative inverses,
-- and given an atom e.
-- Let a be an element outside the ideal generated by the complement of e.
-- Then there exists an element b such that a*b=e.
-- It follows that if the ideal is expanded by any element then it contains e
-- and thus 1.
-- In other words: an ideal generated by a coatom is a maximal ideal:

lemma maxideal_from_atom {A : Type*} [comm_ring A] {e x: A}
(hcov : covers_0 e) (h_inv : all_rel_inv A)  :
(ideal.span {1 - e} : ideal A).is_maximal
An ideal generated from a coatom is maximal.

theorem no_strict_mono_to_ideals_from_finite_dimensional (K : Type*)
[hK : field K] {A : Type*}
  [h_comm_A : comm_ring A] [h_alg : algebra K A] (h_fin : finite_dimensional K A) :
( ¬( ∃ (strict_mono_seq : ℕ → ideal A), strict_mono strict_mono_seq ) )
-- When the K-algebra is finite dimensional then there does not exist
-- a strictly increasing sequence of ideals.

-- The first main theorem states that a finite dimensional algebra has a
-- finite set of atoms with sup = ⊤:
theorem ex_fin_atomset_of_finite_dimensional (K : Type*)
[hK : field K] {A : Type*}
  [h_comm_A : comm_ring A] [h_alg : algebra K A] (h_fin : finite_dimensional K A) :
∃ (s : finset (idempotent_cri A)), (∀ e ∈ s, ⊥ ⋖ e) ∧ boolean_algebra_finset_sup s = ⊤

The second main theorem states that if e is an atom then e is the one-element in the ideal,
and each non-zero element in the ideal has an inverse within the ideal.
This means that an ideal generated by an atom is a field.
lemma field_from_atom {A : Type*} [hA : comm_ring A]  (h_inv : all_rel_inv A)
{e a : A} (hnz_a : a ≠ 0) (hcov : covers_0 e) (ha_in_span : a ∈ ((ideal.span {e} : ideal A)) ) :
a * e = a ∧
( ∃ (b : A), b ∈ ((ideal.span {e} : ideal A)) ∧ a * b = e)

-/

-------------------------------
-- Conversion from a strictly increasing sequence of ideals
-- to a strictly increasing sequence of submodules over the scalar field

def submodule_KA_of_AA_smul {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] [hKA : algebra K A] (submod_AA : submodule A A)
  {k : K} {a : A} (h_sm_a : a ∈ submod_AA.carrier) :
  (((algebra.to_ring_hom k) : A) * a) ∈ submod_AA.carrier :=
  begin
    have h : ∀ (aa : A), aa * a ∈ submod_AA.carrier,
    begin
      intros aa, exact submod_AA.smul_mem' aa h_sm_a,
    end,
    exact h (algebra.to_ring_hom k),
end

def submodule_KA_of_AA {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] (hKA : algebra K A) (submod_AA : submodule A A) :
  submodule K A :=
  begin
    have add_mem' : ∀ (a b : A), a ∈ submod_AA.carrier →
    b ∈ submod_AA.carrier → a + b ∈ submod_AA.carrier,
    begin
      intros a b ha hb,
      exact submod_AA.add_mem' ha hb,
    end,
    have smul' : ∀ (k : K) (a : A), a ∈ submod_AA.carrier →
    (((algebra.to_ring_hom k) : A) * a) ∈ submod_AA.carrier,
    begin
       intros k a,
       exact submodule_KA_of_AA_smul submod_AA,
    end,
     have smul'' : ∀ (k : K) (a : A), a ∈ submod_AA.carrier →
    (k • a) ∈ submod_AA.carrier,
    begin
       intros k a h0,
       rw algebra.smul_def',
       exact smul' k a h0,
    end,
    exact { carrier := submod_AA.carrier,
      add_mem' := add_mem',
      zero_mem' := submod_AA.zero_mem',
      smul_mem' := smul'' },
end

lemma submodule_AA_lt_of_subset {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] (hKA : algebra K A) {A1 A2 : submodule A A}
    : A1 < A2 ↔ submodule.carrier A1 ⊂ A2.carrier :=
  begin
    exact set_like.coe_ssubset_coe,
  end

lemma submodule_KA_lt_of_subset {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] (hKA : algebra K A) {A1 A2 : submodule K A}
    : submodule.carrier A1 ⊂ A2.carrier → A1 < A2 :=
  begin
    rw ← set_like.coe_ssubset_coe, intros h, exact h,
  end

lemma eq_carrier {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] (hKA : algebra K A) (submod_AA : submodule A A) :
  submod_AA.carrier = (submodule_KA_of_AA hKA submod_AA).carrier :=
  begin
    let g := submod_AA.carrier,
    let gg := (submodule_KA_of_AA hKA submod_AA).carrier,
    --simp at gg {proj := true},
    unfold submodule_KA_of_AA,
  end

lemma submodule_KA_lt_of_ideal_lt {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] (hKA : algebra K A) {A1 A2 : submodule A A}
    : A1 < A2 → (submodule_KA_of_AA hKA A1) < (submodule_KA_of_AA hKA A2) :=
  begin
    intros hA1_lt_A2,
    let ss_A1_A2 := (submodule_AA_lt_of_subset hKA).1 hA1_lt_A2,
    rw eq_carrier hKA at ss_A1_A2, rw eq_carrier hKA at ss_A1_A2,
    exact (submodule_KA_lt_of_subset hKA ss_A1_A2) ,
  end

def submodule_seq_KA_lt_of_ideal_lt {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] [hKA : algebra K A] (f : ℕ → ideal A) :  ℕ → submodule K A :=
begin
  intros n,
  exact submodule_KA_of_AA hKA (f n),
end

/-
The following lemma says that a strictly increasing sequence of ideals
is also a strictly increasing sequence of submodules over the scalar field.
-/
lemma ex_strict_mono_submodule_of_ideal {K : Type*} [hK : field K] {A : Type*}
  [hA : comm_ring A] [hKA : algebra K A] (f : ℕ → ideal A) (f_strict_mono : strict_mono f):
  ∃ (g : ℕ → submodule K A), strict_mono g :=
  begin
    unfold strict_mono at *,
    use submodule_seq_KA_lt_of_ideal_lt f,
    intros n1 n2 h_lt,
    unfold submodule_seq_KA_lt_of_ideal_lt,
    apply submodule_KA_lt_of_ideal_lt,
    exact f_strict_mono h_lt,
end

----------------------------

section inv_a

variables {K : Type*} [field K] {A : Type*}
  [comm_ring A] [algebra K A] {a : A} -- {he : e * e = e}
  [finite_dimensional K A] [is_separable K A]
  (P : polynomial K)

-----
variables {B : Type*} -- (idempotent_cri A)

def ortho_e [comm_ring A] (e1 e2 : (idempotent_cri A)): Prop := e1 ⊓ e2 = ⊥

def nz_e (e:idempotent_cri A) := ⊥ < e
def idem_e (a : A) := a * a = a
def ortho_s (s:finset (idempotent_cri A)) := ∀ (e e' ∈ s), e ≠ e' → ortho_e e e'
def atom_s (s:finset (idempotent_cri A)) := ∀ (e ∈ s), ⊥ ⋖ e
def nz_s (s:finset (idempotent_cri A)) := ∀ (e ∈ s), nz_e e
--------------------------------

open_locale classical
open_locale big_operators
noncomputable theory

---------------------------------------------------------
def covers_0 (e : A) : Prop := e ≠ 0 ∧ e * e = e ∧
∀ (e' : A), e' * e' = e' → e' * e = e' → (e' = 0 ∨ e' = e)

theorem maxideal_from_atom' {A : Type*} [comm_ring A] {e a : A}
(hcov : covers_0 e) (h_inv : all_rel_inv A) (hnI : a * (1-e) ≠ a)
: ∃ b, b * a = e :=
begin
-- Given a commutative ring A in which all elements have relative inverses,
-- and given an atom e.
-- Let a be an element outside the ideal generated by the complement of e.
-- Then there exists an element b such that a*b=e.
-- It follows that if the ideal is expanded by any element then it contains e
-- and thus 1.
-- In other words: an ideal generated by a coatom is a maximal ideal.

  unfold all_rel_inv at h_inv,
  cases hcov with he_nz h, cases h with he_idem he'_covby_e,
  have hae_nz : a * e ≠ 0,
  begin
    by_contradiction hae0,
    have kk : a * (1 - e) = a,
    begin
      calc a * (1 - e) = a - (a * e) : by ring
      ... = a - 0 : by rw hae0
      ... = a : by ring,
    end,
    contradiction,
  end,
  specialize h_inv (a * e), cases h_inv with b h_rel_inv,
  unfold is_rel_inv at h_rel_inv,
  cases h_rel_inv with he h_rel_inv, cases h_rel_inv with ha hb,
  specialize he'_covby_e (a * e * b),
  have he'_le_e : a * e * b * e = a * e * b,
  begin
    calc a * e * b * e = a * (e * e) * b : by ring
    ... = a * e * b : by rw he_idem,
  end,
  have hae_0_or_e : a * e * b = 0 ∨ a * e * b = e,
  begin
    exact he'_covby_e he he'_le_e,
  end,
  have haeb_nz : a * e * b ≠ 0,
  begin
    by_contradiction haeb0,
    rw haeb0 at ha, simp at ha, rw ← ha at hae_nz,
    contradiction,
  end,
  use e * b,
  have haeb_nz' : (e * b) * a = a * e * b, by ring,
  cases hae_0_or_e,
  contradiction,
  rw hae_0_or_e at haeb_nz', exact haeb_nz',
end

lemma orthog_not_dvd {A : Type*} [comm_ring A] {e e': A}
(h_idem : idem_e e) (h_nz : e ≠ 0) (h_orthog : e' * e = 0)
: ¬ e' ∣ e + e' :=
begin
  unfold has_dvd.dvd, push_neg, intros c,
  by_contradiction, unfold idem_e at  h_idem,
  have h_contra : c * 0 = e,
  begin
    rw ← h_orthog, rw ← mul_assoc, conv {to_lhs, congr, rw mul_comm,}, rw ← h,
    rw right_distrib, rw h_orthog, rw h_idem, ring,
  end,
  simp at h_contra, rw ← h_contra at h_nz, contradiction,
end

lemma ideal_orthog_not_mem {A : Type*} [comm_ring A] {e e': A}
(h_idem : idem_e e) (h_nz : e' ≠ 0) (h_orthog : e' * e = 0)
: e' ∉ (ideal.span {e} : ideal A) :=
begin
  have h_no_aee' : ¬ ∃ (a : A), a * e = e',
  begin
    by_contradiction haee',
    cases haee' with a haee',
    have he'0 : e' = 0,
    begin
      unfold idem_e at h_idem,
      rw ← haee',
      rw ← h_idem,
      rw ← mul_assoc, rw haee', assumption,
    end,
    contradiction,
  end,
  unfold ideal.span,
  rw submodule.mem_span_singleton, exact h_no_aee',
end

lemma ideal_gt_of_orthog_sum {A : Type*} [comm_ring A] {e' f : A}
(h_idem_e' : e' * e' = e') (h_idem_f : f * f = f)
(h_lt : e' * f = e') (h_ne : e' ≠ f)
: (ideal.span {e'} : ideal A) < (ideal.span {f} : ideal A) :=
begin
  --unfold idem_e at h_idem_e',
  -- First prove that (ideal.span {e'} : ideal A) ≤ (ideal.span {f})
  have hdvd : f ∣ e',
  begin
    unfold has_dvd.dvd, use e', rw mul_comm, rw h_lt,
  end,
  have ideal_e'_le_ideal_epe'_iff_epe'_dvd_e' :
  (ideal.span {e'} : ideal A) ≤ ideal.span {f} ↔ f ∣ e',
  begin
    exact ideal.span_singleton_le_span_singleton,
  end,
  have ideal_e'_le_ideal_e_e' : (ideal.span {e'} : ideal A) ≤ (ideal.span {f}) ,
  begin
    rw ideal.span_singleton_le_span_singleton, exact hdvd,
  end,
  -- Next, prove ¬ (ideal.span {e + e'}) ≤ (ideal.span {e'} : ideal A)
  have not_dvd : ¬ e' ∣ f,
  begin
    unfold has_dvd.dvd, push_neg,
    intros c,
    by_contradiction,
    have h_contra : f = e',
    begin
      rw [h, ← h_idem_e', mul_assoc, ← h, h_lt, h_idem_e'],
    end,
    rw h_contra at h_ne,
    contradiction,
  end,
  have ideal_epe'_le_ideal_e'_iff_e'_dvd_epe' :
  (ideal.span {f} : ideal A) ≤ ideal.span {e'} ↔ e' ∣ f,
  begin
    exact ideal.span_singleton_le_span_singleton,
  end,
  rw ← ideal_epe'_le_ideal_e'_iff_e'_dvd_epe' at not_dvd,
    -- ¬ideal.span {e + e'} ≤ ideal.span {e'}
  rw preorder.lt_iff_le_not_le,
   exact and.intro ideal_e'_le_ideal_e_e' not_dvd,
end

section convert_cri

open idempotent_cri

lemma eq_bot_iff_val_eq_cri {A : Type*} [comm_ring A]
{e : idempotent_cri A} : ( e = (⊥ : idempotent_cri A) ) ↔ ↑e = (0:A) :=
begin
  split,
  -- ->
  intros hz,
  let gg := congr_arg subtype.val hz, -- e.val = ⊥.val
  exact gg,
  -- <-
  intros hz,
  -- exact subtype.eq hz,
  apply subtype.eq,
  exact hz,
end

lemma eq_iff_val_eq_cri {A : Type*} [comm_ring A]
(e' e : idempotent_cri A) : ( e' = e ) ↔ (↑e' : A) = ↑e :=
begin
  split,
  -- ->
  intros hz,
  let gg := congr_arg subtype.val hz,
  exact gg,
  -- <-
  intros hz,
  -- exact subtype.eq hz,
  apply subtype.eq,
  exact hz,
end

-- Some coercian lemmas:
lemma coe_eq_val (e : idempotent_cri A) : (↑e : A) = e.val :=
begin
  refl,
end

lemma coe_eq_val' (e : idempotent_cri A) : e.val = ↑e :=
begin
  refl,
end

lemma val_of' {A : Type*} [comm_ring A] (v : A) (h : v * v = v)
 : ↑(⟨ v, h ⟩ : idempotent_cri A) = v :=
begin
  refl,
end

lemma val_of_cri {A : Type*} [comm_ring A] (e : idempotent_cri A)
 : ↑(⟨ e.val, e.property ⟩ : idempotent_cri A) = e.val :=
begin
  refl,
end

lemma coe_inf' {A : Type*} [comm_ring A] (e e': idempotent_cri A)
(p : (e.val * e'.val) * (e.val * e'.val) = e.val * e'.val)
 : (e ⊓ e' : idempotent_cri A) = ⟨ e.val * e'.val, p ⟩ :=
begin
  refl,
end

lemma ideal_of_idempotent_strictly_increasing {A : Type*} [comm_ring A]
{e' e : idempotent_cri A} (hlt : e' < e)
: (ideal.span {e'.val} : ideal A) < (ideal.span {e.val} : ideal A) :=
begin
  let pe' := e'.property'', -- e'.val * e'.val = e'.val
  let pe := e.property'', -- e.val * e.val = e.val
  --unfold has_
  have h_lt_e : e'.val * e.val = e'.val, by exact (le_of_lt hlt),
  let hne := ne_of_lt hlt, -- e' ≠ e
  have h_ne_e : e'.val ≠ e.val,
  begin
    by_contradiction,
    rw (subtype.eq h) at hne,
    contradiction,
  end,
  exact ideal_gt_of_orthog_sum pe' pe h_lt_e h_ne_e,
end

lemma monotone_of_strict_mono {B : Type*} [hB : boolean_algebra B] {K : Type*} {f : ℕ → B}
(h_strict : strict_mono f)
: monotone f :=
begin
  unfold strict_mono at h_strict,
  unfold monotone,
  intros a b h_le,
  have lt_or_eq : a < b ∨ a = b, by exact lt_or_eq_of_le h_le,
  cases lt_or_eq,
  -- lt_or_eq: a < b
  exact le_of_lt (h_strict lt_or_eq),
  -- lt_or_eq: a = b
  apply le_of_eq,
  rw lt_or_eq,
end

lemma not_strict_mono_of_stabilizing_sequence {B : Type*} [hB : partial_order B]
{f : ℕ → B} {stabilizes : ∃ (n : ℕ), ∀ (m : ℕ), n ≤ m → f n = f m}
: ¬ strict_mono f :=
begin
  unfold strict_mono,
  by_contradiction h_strict_mono,
  cases stabilizes with k stabilizes',
  let h_stab := stabilizes' k.succ (nat.le_succ k),
  let h_strict := @h_strict_mono k k.succ (lt_add_one k),
  rw h_stab at h_strict,
  let h_contra := ne_of_lt h_strict,
  contradiction,
end

def order_hom_of_str {B : Type*} [hB : partial_order B] {f : ℕ → B} (h_strict_mono : strict_mono f) :
ℕ →o B :=
begin
  have h_monotone : monotone f,
  begin
    unfold monotone,
    intros a b h_le,
    unfold strict_mono at h_strict_mono,
    have eq_or_lt : a = b ∨ a < b, by exact eq_or_lt_of_le h_le,
    cases eq_or_lt,
    -- a = b
    rw eq_or_lt,
    -- a < b
    let fa_lt_fb := @h_strict_mono a b eq_or_lt,
    exact le_of_lt fa_lt_fb,
  end,
  exact { to_fun := f, monotone' := h_monotone },
end

lemma helper {K : Type*} [field K] {A : Type*} [comm_ring A] [algebra K A]
(g : ℕ → submodule K A) (g_strict: ∀ ⦃a b : ℕ⦄, a < b → g a < g b)
(g_stab: ∃ (n : ℕ), ∀ (m : ℕ), n ≤ m → g n = g m ) : false :=
begin
  cases g_stab with n g_stab',
  let g_stab'' := g_stab' n.succ (nat.le_succ n), -- g.to_fun n = g.to_fun n.succ
  let g_strict' := g_strict (lt_add_one n),
  rw g_stab'' at g_strict',
  let h_ne := ne_of_lt g_strict',
  simp at h_ne, -- false
  contradiction,
end

-- When the K-algebra is finite dimensional then there does not exist
-- a strictly increasing sequence of ideals.
theorem no_strict_mono_to_ideals_from_finite_dimensional (K : Type*)
[hK : field K] {A : Type*}
  [h_comm_A : comm_ring A] [h_alg : algebra K A] (h_fin : finite_dimensional K A) :
( ¬( ∃ (strict_mono_seq : ℕ → ideal A), strict_mono strict_mono_seq ) ) :=
begin
  rw finite_dimensional at h_fin, --  module.finite K A
  rw ← is_noetherian.iff_fg at h_fin, -- is_noetherian K A
  rw ← monotone_stabilizes_iff_noetherian at h_fin,
    -- ∀ (f : ℕ →o submodule K A), ∃ (n : ℕ), ∀ (m : ℕ), n ≤ m → ⇑f n = ⇑f m
  by_contradiction h_ex_strict_mono', -- By contradiction we get a strictly monotone sequence of ideals
  -- From this we a strictly monotone sequence of submodules:
  cases h_ex_strict_mono' with f f_strict,
  have ex_strict_mono_submodule :  ∃ (g : ℕ → submodule K A), strict_mono g,
  by exact ex_strict_mono_submodule_of_ideal f f_strict,
  cases ex_strict_mono_submodule with g g_strict,
  unfold strict_mono at g_strict,
  let g_stab := h_fin (order_hom_of_str g_strict),
  let dd := helper g g_strict g_stab,
  assumption,
end

def ideal_of_idempotent
(A : Type*) [h_comm_A : comm_ring A] : idempotent_cri A → ideal A :=
λ (e : idempotent_cri A), ideal.span {e.val}

lemma  ideal_of_idempotent_stric_mono (A : Type*) [comm_ring A]
: strict_mono (ideal_of_idempotent A) :=
begin
  unfold strict_mono,
  intros e' e hlt,
  exact ideal_of_idempotent_strictly_increasing hlt,
end

theorem strict_mono_to_ideals_of_strict_mono_to_idempotent
{A : Type*} [h_comm_A : comm_ring A]
(ex_strict_mono_to_idempotent : ∃ (strict_mono_seq : ℕ → (idempotent_cri A)), strict_mono strict_mono_seq) :
∃ (f : ℕ → ideal A), strict_mono f :=
begin
  cases ex_strict_mono_to_idempotent with f f_strict,
  use (ideal_of_idempotent A ) ∘ f,
  exact strict_mono.comp (ideal_of_idempotent_stric_mono A ) f_strict,
end

theorem no_strict_mono_to_idempotents_from_finite_dimensional (K : Type*)
[hK : field K] {A : Type*}
  [h_comm_A : comm_ring A] [h_alg : algebra K A] (h_fin : finite_dimensional K A) :
( ¬( ∃ (strict_mono_seq : ℕ → idempotent_cri A), strict_mono strict_mono_seq ) ) :=
begin
  by_contradiction ex_strict_mono,
  let ex_strict_mono_to_ideals :=
  @strict_mono_to_ideals_of_strict_mono_to_idempotent A h_comm_A ex_strict_mono,
  let no_strict_mono_ideals :=
  @no_strict_mono_to_ideals_from_finite_dimensional K hK A h_comm_A h_alg h_fin,
  contradiction,
end

-- The main theorem states that a finite dimensional algebra has a
-- finite set of atoms with sup = ⊤:
theorem ex_fin_atomset_of_finite_dimensional (K : Type*)
[hK : field K] {A : Type*}
  [h_comm_A : comm_ring A] [h_alg : algebra K A] (h_fin : finite_dimensional K A) :
∃ (s : finset (idempotent_cri A)), (∀ e ∈ s, ⊥ ⋖ e) ∧ boolean_algebra_finset_sup s = ⊤ :=
begin
  let no_strict_mono_to_idempotents :=
  @no_strict_mono_to_idempotents_from_finite_dimensional K hK A h_comm_A h_alg h_fin,
  exact exists_fin_atomset_sup_top_of_not_strict_mono no_strict_mono_to_idempotents,
end

end convert_cri

lemma not_top_from_coatom {A : Type*} [comm_ring A] {e : A}
(hcov : covers_0 e)
: (1 : A) ∉ (ideal.span {1 - e} : ideal A) :=
begin
  cases hcov with he_nz h, cases h with he_idem he'_covby_e,

  have h_no_inv : ∀ (a : A), a * (1 - e) ≠ 1,
  begin
    by_contradiction h_contra,
    push_neg at h_contra, cases h_contra with a h_contra,
    have hc : e * (a * (1 - e)) = a * (e - e * e), by ring,
    rw h_contra at hc, rw mul_one at hc, rw he_idem at hc,
    have hc1 : a * (e - e) = 0, by ring,
    rw hc1 at hc,
    contradiction,
  end,
  have h : is_unit (1 - e : A) ↔ (∃ (b : A), (1 - e) * b = 1), by exact is_unit_iff_exists_inv,
  have hn : (∀ (b : A), b * (1 - e) ≠ 1) → ¬is_unit (1 - e : A),
  begin
    contrapose, push_neg, rw h, intros hh,
    cases hh with a hh, use a, rw mul_comm, assumption,
  end,
  specialize hn h_no_inv, -- ¬is_unit (1 - e)
  rw ← ideal.span_singleton_eq_top at hn, -- ¬ideal.span {1 - e} = ⊤
  rw ← ideal.eq_top_iff_one, assumption,
end

lemma maxideal_from_atom {A : Type*} [comm_ring A] {e : A}
(hcov : covers_0 e) (h_inv : all_rel_inv A)  :
(ideal.span {1 - e} : ideal A).is_maximal :=
begin
  unfold all_rel_inv at h_inv, unfold is_rel_inv at h_inv,
  let I := (ideal.span {1 - e} : ideal A),
  have h1me_in_I : (1 - e) ∈ I, by exact submodule.mem_span_singleton_self (1 - e),
  have hJtop : (∀ (J : ideal A) (a : A), I ≤ J → a ∉ I → a ∈ J → (1 : A) ∈ J) :=
  begin
    intros J a hIleJ ha_nin_I ha_in_J,
    have hIssJ : ↑I ⊆ ↑J ↔ I ≤ J, by exact set_like.coe_subset_coe,
    rw ← hIssJ at hIleJ, -- ↑I ⊆ ↑J
    rw set.subset_def at hIleJ, -- ∀ (x : A), x ∈ ↑I → x ∈ ↑J
    specialize hIleJ (1 - e),
    have h1me_in_J : 1 - e ∈ J, by exact hIleJ h1me_in_I,
    have hnI : a * (1-e) ≠ a,
    begin
      by_contradiction,
      have h1 : a * (1 - e) ∈ I, by exact ideal.mul_mem_left I (a : A) h1me_in_I,
      rw h at h1,
      contradiction,
    end,
    have hexb : ∃ b, b * a = e , by exact maxideal_from_atom' hcov h_inv hnI,
    cases hexb with b hbae,
    have hba_in_J : b * a ∈ J, by exact ideal.mul_mem_left J b ha_in_J,
    rw hbae at hba_in_J, -- e ∈ J
    have he1me_in_J : e + (1 - e) ∈ J, by exact ideal.add_mem J hba_in_J h1me_in_J,
    have h1eqe1me : 1 = e + (1 - e), by ring,
    rw h1eqe1me, assumption,
  end,
  have h1_nin_I : (1 : A) ∉ I, by exact not_top_from_coatom hcov,
  have hImax : (1 : A) ∉ I ∧ (∀ (J : ideal A) (a : A), I ≤ J → a ∉ I → a ∈ J → (1 : A) ∈ J),
  by exact and.intro h1_nin_I hJtop,
  rw ← ideal.is_maximal_iff at hImax,
  assumption,
end

lemma ae_eq_a_of_a_in_ideal_span_e {A : Type*} [comm_ring A]  (h_inv : all_rel_inv A)
{e a : A} (hcov : covers_0 e) (ha : a ∈ ((ideal.span {e} : ideal A)) ) :
a * e = a :=
begin
  have hb : ∃ a' : A, a' * e = a, by exact ideal.mem_span_singleton'.mp ha,
  cases hb with a' a'e,
  rw ← a'e,
  rw mul_assoc,
  cases hcov with h h1, cases h1 with h_idempotent h1,
  rw h_idempotent,
end

lemma ae_in_span {A : Type*} [comm_ring A]
{e a : A} :  a * e ∈ ((ideal.span {e} : ideal A))  :=
begin
  rw ideal.mem_span_singleton,
  unfold has_dvd.dvd, use a, rw mul_comm,
end

def to_cri {A : Type*} [hA : comm_ring A] {a : A} (h : a * a = a) : idempotent_cri A :=
 ⟨ a, h ⟩

lemma to_cri_eq {A : Type*} [hA : comm_ring A] {a : A} (h : a * a = a) :
(to_cri h).property = h :=
begin
  unfold to_cri,
end

def to_cri_covers0 {A : Type*} [hA : comm_ring A] {a : A} (h : covers_0 a) :
idempotent_cri A :=
begin
  unfold covers_0 at h,
  cases h with hnz_a h, cases h with ha h,
  exact to_cri ha,
end

lemma covers0_le {A : Type*} [hA : comm_ring A] {a e: A} (h : covers_0 e)
(ha : a * a = a) (haea : a * e = a):
a = 0 ∨ a = e :=
begin
  unfold covers_0 at h,
  cases h with hnz h1, cases h1 with he h2,
  exact h2 a ha haea,
end

lemma field_from_atom {A : Type*} [hA : comm_ring A]  (h_inv : all_rel_inv A)
{e a : A} (hnz_a : a ≠ 0) (hcov : covers_0 e) (ha_in_span : a ∈ ((ideal.span {e} : ideal A)) ) :
 a * e = a ∧
 ( ∃ (b : A), b ∈ ((ideal.span {e} : ideal A)) ∧ a * b = e) :=
begin
  split,
  -- goal : a * e = a
  exact @ae_eq_a_of_a_in_ideal_span_e A hA h_inv e a hcov ha_in_span,
  -- ∃ (b : A), b ∈ ideal.span {e} ∧ a * b = e
  unfold all_rel_inv at h_inv,
  have  hex_rel : ∃ (b : A), is_rel_inv a b, by exact h_inv a,
  cases hex_rel with b h_rel_inv,
  unfold is_rel_inv at h_rel_inv,
  cases h_rel_inv with he' h, cases h with ha hb,
  have haea : a * e = a, by exact ae_eq_a_of_a_in_ideal_span_e h_inv hcov ha_in_span,
  have hae : (a * e) * e = a * e,
  begin
    rw haea, exact haea,
  end,
  have habe_ab : a * b * e = a * b,
  begin
    conv {to_rhs, rw ← haea}, ring,
  end,
  have hab_0_or_e : a * b = 0 ∨ a * b = e, by exact covers0_le hcov he' habe_ab,
  use b * e,
  split,
  -- goal : b * e e ∈ ideal.span {e}
  exact ae_in_span,
  -- a * (b * e) = e
  have hnz_ab : a * b ≠ 0,
  begin
    by_contradiction,
    rw h at ha, simp at ha, -- 0 = a,
    rw ha at hnz_a,
    contradiction,
  end,
  cases hab_0_or_e,
  contradiction,
  -- goal a * (b * e) = e
  rw ← mul_assoc,
  rw hab_0_or_e,
  unfold covers_0 at hcov,
  cases hcov with h1 h2, cases h2 with he h3,
  exact he,
end

end inv_a


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.module.basic
import algebra.module.ulift
import algebra.ne_zero
import algebra.punit_instances
import algebra.ring.aut
import algebra.ring.ulift
import algebra.char_zero.lemmas
import linear_algebra.basic
import ring_theory.subring.basic
import tactic.abel

/-!
# Algebras over commutative semirings

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

In this file we define associative unital `algebra`s over commutative (semi)rings, algebra
homomorphisms `alg_hom`, and algebra equivalences `alg_equiv`.

`subalgebra`s are defined in `algebra.algebra.subalgebra`.

For the category of `R`-algebras, denoted `Algebra R`, see the file
`algebra/category/Algebra/basic.lean`.

See the implementation notes for remarks about non-associative and non-unital algebras.

## Main definitions:

* `algebra R A`: the algebra typeclass.
* `algebra_map R A : R →+* A`: the canonical map from `R` to `A`, as a `ring_hom`. This is the
  preferred spelling of this map, it is also available as:
  * `algebra.linear_map R A : R →ₗ[R] A`, a `linear_map`.
  * `algebra.of_id R A : R →ₐ[R] A`, an `alg_hom` (defined in a later file).
* Instances of `algebra` in this file:
  * `algebra.id`
  * `algebra_nat`
  * `algebra_int`
  * `algebra_rat`
  * `mul_opposite.algebra`
  * `module.End.algebra`

## Implementation notes

Given a commutative (semi)ring `R`, there are two ways to define an `R`-algebra structure on a
(possibly noncommutative) (semi)ring `A`:
* By endowing `A` with a morphism of rings `R →+* A` denoted `algebra_map R A` which lands in the
  center of `A`.
* By requiring `A` be an `R`-module such that the action associates and commutes with multiplication
  as `r • (a₁ * a₂) = (r • a₁) * a₂ = a₁ * (r • a₂)`.

We define `algebra R A` in a way that subsumes both definitions, by extending `has_smul R A` and
requiring that this scalar action `r • x` must agree with left multiplication by the image of the
structure morphism `algebra_map R A r * x`.

As a result, there are two ways to talk about an `R`-algebra `A` when `A` is a semiring:
1. ```lean
   variables [comm_semiring R] [semiring A]
   variables [algebra R A]
   ```
2. ```lean
   variables [comm_semiring R] [semiring A]
   variables [module R A] [smul_comm_class R A A] [is_scalar_tower R A A]
   ```

The first approach implies the second via typeclass search; so any lemma stated with the second set
of arguments will automatically apply to the first set. Typeclass search does not know that the
second approach implies the first, but this can be shown with:
```lean
example {R A : Type*} [comm_semiring R] [semiring A]
  [module R A] [smul_comm_class R A A] [is_scalar_tower R A A] : algebra R A :=
algebra.of_module smul_mul_assoc mul_smul_comm
```

The advantage of the first approach is that `algebra_map R A` is available, and `alg_hom R A B` and
`subalgebra R A` can be used. For concrete `R` and `A`, `algebra_map R A` is often definitionally
convenient.

The advantage of the second approach is that `comm_semiring R`, `semiring A`, and `module R A` can
all be relaxed independently; for instance, this allows us to:
* Replace `semiring A` with `non_unital_non_assoc_semiring A` in order to describe non-unital and/or
  non-associative algebras.
* Replace `comm_semiring R` and `module R A` with `comm_group R'` and `distrib_mul_action R' A`,
  which when `R' = Rˣ` lets us talk about the "algebra-like" action of `Rˣ` on an
  `R`-algebra `A`.

While `alg_hom R A B` cannot be used in the second approach, `non_unital_alg_hom R A B` still can.

You should always use the first approach when working with associative unital algebras, and mimic
the second approach only when you need to weaken a condition on either `R` or `A`.

-/

universes u v w u₁ v₁

open_locale big_operators

section prio
-- We set this priority to 0 later in this file
set_option extends_priority 200 /- control priority of
`instance [algebra R A] : has_smul R A` -/

/--
An associative unital `R`-algebra is a semiring `A` equipped with a map into its center `R → A`.

See the implementation notes in this file for discussion of the details of this definition.
-/
@[nolint has_nonempty_instance]
class algebra (R : Type u) (A : Type v) [comm_semiring R] [semiring A]
  extends has_smul R A, R →+* A :=
(commutes' : ∀ r x, to_fun r * x = x * to_fun r)
(smul_def' : ∀ r x, r • x = to_fun r * x)
end prio

/-- Embedding `R →+* A` given by `algebra` structure. -/
def algebra_map (R : Type u) (A : Type v) [comm_semiring R] [semiring A] [algebra R A] : R →+* A :=
algebra.to_ring_hom

namespace algebra_map

def has_lift_t (R A : Type*) [comm_semiring R] [semiring A] [algebra R A] :
  has_lift_t R A := ⟨λ r, algebra_map R A r⟩

attribute [instance, priority 900] algebra_map.has_lift_t

section comm_semiring_semiring

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]

@[simp, norm_cast] lemma coe_zero : (↑(0 : R) : A) = 0 := map_zero (algebra_map R A)
@[simp, norm_cast] lemma coe_one : (↑(1 : R) : A) = 1 := map_one (algebra_map R A)
@[norm_cast] lemma coe_add (a b : R) : (↑(a + b : R) : A) = ↑a + ↑b :=
map_add (algebra_map R A) a b
@[norm_cast] lemma coe_mul (a b : R) : (↑(a * b : R) : A) = ↑a * ↑b :=
map_mul (algebra_map R A) a b
@[norm_cast] lemma coe_pow (a : R) (n : ℕ) : (↑(a ^ n : R) : A) = ↑a ^ n :=
map_pow (algebra_map R A) _ _

end comm_semiring_semiring

section comm_ring_ring

variables {R A : Type*} [comm_ring R] [ring A] [algebra R A]

@[norm_cast] lemma coe_neg (x : R) : (↑(-x : R) : A) = -↑x :=
map_neg (algebra_map R A) x

end comm_ring_ring

section comm_semiring_comm_semiring

variables {R A : Type*} [comm_semiring R] [comm_semiring A] [algebra R A]

open_locale big_operators

-- direct to_additive fails because of some mix-up with polynomials
@[norm_cast] lemma coe_prod {ι : Type*} {s : finset ι} (a : ι → R) :
  (↑( ∏ (i : ι) in s, a i : R) : A) = ∏ (i : ι) in s, (↑(a i) : A) :=
map_prod (algebra_map R A) a s

-- to_additive fails for some reason
@[norm_cast] lemma coe_sum {ι : Type*} {s : finset ι} (a : ι → R) :
  ↑(( ∑ (i : ι) in s, a i)) = ∑ (i : ι) in s, (↑(a i) : A) :=
map_sum (algebra_map R A) a s

attribute [to_additive] coe_prod

end comm_semiring_comm_semiring

section field_nontrivial
variables {R A : Type*} [field R] [comm_semiring A] [nontrivial A] [algebra R A]

@[norm_cast, simp] lemma coe_inj {a b : R} : (↑a : A) = ↑b ↔ a = b :=
(algebra_map R A).injective.eq_iff

@[norm_cast, simp] lemma lift_map_eq_zero_iff (a : R) : (↑a : A) = 0 ↔ a = 0 :=
map_eq_zero_iff _ (algebra_map R A).injective

end field_nontrivial

section semifield_semidivision_ring
variables {R : Type*} (A : Type*) [semifield R] [division_semiring A] [algebra R A]

@[norm_cast] lemma coe_inv (r : R) : ↑(r⁻¹) = ((↑r)⁻¹ : A) :=
map_inv₀ (algebra_map R A) r

@[norm_cast] lemma coe_div (r s : R) : ↑(r / s) = (↑r / ↑s : A) :=
map_div₀ (algebra_map R A) r s

@[norm_cast] lemma coe_zpow (r : R) (z : ℤ) : ↑(r ^ z) = (↑r ^ z : A) :=
map_zpow₀ (algebra_map R A) r z

end semifield_semidivision_ring

section field_division_ring
variables (R A : Type*) [field R] [division_ring A] [algebra R A]

@[norm_cast] lemma coe_rat_cast (q : ℚ) : ↑(q : R) = (q : A) :=
map_rat_cast (algebra_map R A) q

end field_division_ring

end algebra_map

/-- Creating an algebra from a morphism to the center of a semiring. -/
def ring_hom.to_algebra' {R S} [comm_semiring R] [semiring S] (i : R →+* S)
  (h : ∀ c x, i c * x = x * i c) :
  algebra R S :=
{ smul := λ c x, i c * x,
  commutes' := h,
  smul_def' := λ c x, rfl,
  to_ring_hom := i}

/-- Creating an algebra from a morphism to a commutative semiring. -/
def ring_hom.to_algebra {R S} [comm_semiring R] [comm_semiring S] (i : R →+* S) :
  algebra R S :=
i.to_algebra' $ λ _, mul_comm _

lemma ring_hom.algebra_map_to_algebra {R S} [comm_semiring R] [comm_semiring S]
  (i : R →+* S) :
  @algebra_map R S _ _ i.to_algebra = i :=
rfl

namespace algebra

variables {R : Type u} {S : Type v} {A : Type w} {B : Type*}

/-- Let `R` be a commutative semiring, let `A` be a semiring with a `module R` structure.
If `(r • 1) * x = x * (r • 1) = r • x` for all `r : R` and `x : A`, then `A` is an `algebra`
over `R`.

See note [reducible non-instances]. -/
@[reducible]
def of_module' [comm_semiring R] [semiring A] [module R A]
  (h₁ : ∀ (r : R) (x : A), (r • 1) * x = r • x)
  (h₂ : ∀ (r : R) (x : A), x * (r • 1) = r • x) : algebra R A :=
{ to_fun := λ r, r • 1,
  map_one' := one_smul _ _,
  map_mul' := λ r₁ r₂, by rw [h₁, mul_smul],
  map_zero' := zero_smul _ _,
  map_add' := λ r₁ r₂, add_smul r₁ r₂ 1,
  commutes' := λ r x, by simp only [h₁, h₂],
  smul_def' := λ r x, by simp only [h₁] }

/-- Let `R` be a commutative semiring, let `A` be a semiring with a `module R` structure.
If `(r • x) * y = x * (r • y) = r • (x * y)` for all `r : R` and `x y : A`, then `A`
is an `algebra` over `R`.

See note [reducible non-instances]. -/
@[reducible]
def of_module [comm_semiring R] [semiring A] [module R A]
  (h₁ : ∀ (r : R) (x y : A), (r • x) * y = r • (x * y))
  (h₂ : ∀ (r : R) (x y : A), x * (r • y) = r • (x * y)) : algebra R A :=
of_module' (λ r x, by rw [h₁, one_mul]) (λ r x, by rw [h₂, mul_one])

section semiring

variables [comm_semiring R] [comm_semiring S]
variables [semiring A] [algebra R A] [semiring B] [algebra R B]

/-- We keep this lemma private because it picks up the `algebra.to_has_smul` instance
which we set to priority 0 shortly. See `smul_def` below for the public version. -/
private lemma smul_def'' (r : R) (x : A) : r • x = algebra_map R A r * x :=
algebra.smul_def' r x

/--
To prove two algebra structures on a fixed `[comm_semiring R] [semiring A]` agree,
it suffices to check the `algebra_map`s agree.
-/
-- We'll later use this to show `algebra ℤ M` is a subsingleton.
@[ext]
lemma algebra_ext {R : Type*} [comm_semiring R] {A : Type*} [semiring A] (P Q : algebra R A)
  (w : ∀ (r : R), by { haveI := P, exact algebra_map R A r } =
    by { haveI := Q, exact algebra_map R A r }) :
  P = Q :=
begin
  unfreezingI { rcases P with @⟨⟨P⟩⟩, rcases Q with @⟨⟨Q⟩⟩ },
  congr,
  { funext r a,
    replace w := congr_arg (λ s, s * a) (w r),
    simp only [←smul_def''] at w,
    apply w, },
  { ext r,
    exact w r, },
  { apply proof_irrel_heq, },
  { apply proof_irrel_heq, },
end

@[priority 200] -- see Note [lower instance priority]
instance to_module : module R A :=
{ one_smul := by simp [smul_def''],
  mul_smul := by simp [smul_def'', mul_assoc],
  smul_add := by simp [smul_def'', mul_add],
  smul_zero := by simp [smul_def''],
  add_smul := by simp [smul_def'', add_mul],
  zero_smul := by simp [smul_def''] }

-- From now on, we don't want to use the following instance anymore.
-- Unfortunately, leaving it in place causes deterministic timeouts later in mathlib.
attribute [instance, priority 0] algebra.to_has_smul

lemma smul_def (r : R) (x : A) : r • x = algebra_map R A r * x :=
algebra.smul_def' r x

lemma algebra_map_eq_smul_one (r : R) : algebra_map R A r = r • 1 :=
calc algebra_map R A r = algebra_map R A r * 1 : (mul_one _).symm
                   ... = r • 1                 : (algebra.smul_def r 1).symm

lemma algebra_map_eq_smul_one' : ⇑(algebra_map R A) = λ r, r • (1 : A) :=
funext algebra_map_eq_smul_one

/-- `mul_comm` for `algebra`s when one element is from the base ring. -/
theorem commutes (r : R) (x : A) : algebra_map R A r * x = x * algebra_map R A r :=
algebra.commutes' r x

/-- `mul_left_comm` for `algebra`s when one element is from the base ring. -/
theorem left_comm (x : A) (r : R) (y : A) :
  x * (algebra_map R A r * y) = algebra_map R A r * (x * y) :=
by rw [← mul_assoc, ← commutes, mul_assoc]

/-- `mul_right_comm` for `algebra`s when one element is from the base ring. -/
theorem right_comm (x : A) (r : R) (y : A) :
  (x * algebra_map R A r) * y = (x * y) * algebra_map R A r :=
by rw [mul_assoc, commutes, ←mul_assoc]

instance _root_.is_scalar_tower.right : is_scalar_tower R A A :=
⟨λ x y z, by rw [smul_eq_mul, smul_eq_mul, smul_def, smul_def, mul_assoc]⟩

/-- This is just a special case of the global `mul_smul_comm` lemma that requires less typeclass
search (and was here first). -/
@[simp] protected lemma mul_smul_comm (s : R) (x y : A) :
  x * (s • y) = s • (x * y) :=
-- TODO: set up `is_scalar_tower.smul_comm_class` earlier so that we can actually prove this using
-- `mul_smul_comm s x y`.
by rw [smul_def, smul_def, left_comm]

/-- This is just a special case of the global `smul_mul_assoc` lemma that requires less typeclass
search (and was here first). -/
@[simp] protected lemma smul_mul_assoc (r : R) (x y : A) :
  (r • x) * y = r • (x * y) :=
smul_mul_assoc r x y

@[simp]
lemma _root_.smul_algebra_map {α : Type*} [monoid α] [mul_distrib_mul_action α A]
  [smul_comm_class α R A] (a : α) (r : R) : a • algebra_map R A r = algebra_map R A r :=
by rw [algebra_map_eq_smul_one, smul_comm a r (1 : A), smul_one]

section
variables {r : R} {a : A}

@[simp] lemma bit0_smul_one : bit0 r • (1 : A) = bit0 (r • (1 : A)) :=
by simp [bit0, add_smul]
lemma bit0_smul_one' : bit0 r • (1 : A) = r • 2 :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit0_smul_bit0 : bit0 r • bit0 a = r • (bit0 (bit0 a)) :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit0_smul_bit1 : bit0 r • bit1 a = r • (bit0 (bit1 a)) :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit1_smul_one : bit1 r • (1 : A) = bit1 (r • (1 : A)) :=
by simp [bit1, add_smul]

end

variables (R A)

/--
The canonical ring homomorphism `algebra_map R A : R →* A` for any `R`-algebra `A`,
packaged as an `R`-linear map.
-/
protected def linear_map : R →ₗ[R] A :=
{ map_smul' := λ x y, by simp [algebra.smul_def],
  ..algebra_map R A }

@[simp]
lemma linear_map_apply (r : R) : algebra.linear_map R A r = algebra_map R A r := rfl

lemma coe_linear_map : ⇑(algebra.linear_map R A) = algebra_map R A := rfl

instance id : algebra R R := (ring_hom.id R).to_algebra

variables {R A}

namespace id

@[simp] lemma map_eq_id : algebra_map R R = ring_hom.id _ := rfl

lemma map_eq_self (x : R) : algebra_map R R x = x := rfl

@[simp] lemma smul_eq_mul (x y : R) : x • y = x * y := rfl

end id

section punit

instance _root_.punit.algebra : algebra R punit :=
{ to_fun := λ x, punit.star,
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  map_zero' := rfl,
  map_add' := λ _ _, rfl,
  commutes' := λ _ _, rfl,
  smul_def' := λ _ _, rfl }

@[simp] lemma algebra_map_punit (r : R) : algebra_map R punit r = punit.star := rfl

end punit

section ulift

instance _root_.ulift.algebra : algebra R (ulift A) :=
{ to_fun := λ r, ulift.up (algebra_map R A r),
  commutes' := λ r x, ulift.down_injective $ algebra.commutes r x.down,
  smul_def' := λ r x, ulift.down_injective $ algebra.smul_def' r x.down,
  .. ulift.module',
  .. (ulift.ring_equiv : ulift A ≃+* A).symm.to_ring_hom.comp (algebra_map R A) }

lemma _root_.ulift.algebra_map_eq (r : R) :
  algebra_map R (ulift A) r = ulift.up (algebra_map R A r) := rfl

@[simp] lemma _root_.ulift.down_algebra_map (r : R) :
  (algebra_map R (ulift A) r).down = algebra_map R A r := rfl

end ulift

/-- Algebra over a subsemiring. This builds upon `subsemiring.module`. -/
instance of_subsemiring (S : subsemiring R) : algebra S A :=
{ smul := (•),
  commutes' := λ r x, algebra.commutes r x,
  smul_def' := λ r x, algebra.smul_def r x,
  .. (algebra_map R A).comp S.subtype }

lemma algebra_map_of_subsemiring (S : subsemiring R) :
  (algebra_map S R : S →+* R) = subsemiring.subtype S := rfl

lemma coe_algebra_map_of_subsemiring (S : subsemiring R) :
  (algebra_map S R : S → R) = subtype.val := rfl

lemma algebra_map_of_subsemiring_apply (S : subsemiring R) (x : S) :
  algebra_map S R x = x := rfl

/-- Algebra over a subring. This builds upon `subring.module`. -/
instance of_subring {R A : Type*} [comm_ring R] [ring A] [algebra R A]
  (S : subring R) : algebra S A :=
{ smul := (•),
  .. algebra.of_subsemiring S.to_subsemiring,
  .. (algebra_map R A).comp S.subtype }

lemma algebra_map_of_subring {R : Type*} [comm_ring R] (S : subring R) :
  (algebra_map S R : S →+* R) = subring.subtype S := rfl

lemma coe_algebra_map_of_subring {R : Type*} [comm_ring R] (S : subring R) :
  (algebra_map S R : S → R) = subtype.val := rfl

lemma algebra_map_of_subring_apply {R : Type*} [comm_ring R] (S : subring R) (x : S) :
  algebra_map S R x = x := rfl

/-- Explicit characterization of the submonoid map in the case of an algebra.
`S` is made explicit to help with type inference -/
def algebra_map_submonoid (S : Type*) [semiring S] [algebra R S]
  (M : submonoid R) : submonoid S :=
M.map (algebra_map R S)

lemma mem_algebra_map_submonoid_of_mem {S : Type*} [semiring S] [algebra R S] {M : submonoid R}
  (x : M) : (algebra_map R S x) ∈ algebra_map_submonoid S M :=
set.mem_image_of_mem (algebra_map R S) x.2

end semiring

section comm_semiring

variables [comm_semiring R]

lemma mul_sub_algebra_map_commutes [ring A] [algebra R A] (x : A) (r : R) :
  x * (x - algebra_map R A r) = (x - algebra_map R A r) * x :=
by rw [mul_sub, ←commutes, sub_mul]

lemma mul_sub_algebra_map_pow_commutes [ring A] [algebra R A] (x : A) (r : R) (n : ℕ) :
  x * (x - algebra_map R A r) ^ n = (x - algebra_map R A r) ^ n * x :=
begin
  induction n with n ih,
  { simp },
  { rw [pow_succ, ←mul_assoc, mul_sub_algebra_map_commutes, mul_assoc, ih, ←mul_assoc] }
end

end comm_semiring

section ring
variables [comm_ring R]

variables (R)

/-- A `semiring` that is an `algebra` over a commutative ring carries a natural `ring` structure.
See note [reducible non-instances]. -/
@[reducible]
def semiring_to_ring [semiring A] [algebra R A] : ring A :=
{ ..module.add_comm_monoid_to_add_comm_group R,
  ..(infer_instance : semiring A) }

end ring

end algebra

namespace mul_opposite

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]

instance : algebra R Aᵐᵒᵖ :=
{ to_ring_hom := (algebra_map R A).to_opposite $ λ x y, algebra.commutes _ _,
  smul_def' := λ c x, unop_injective $
    by { dsimp, simp only [op_mul, algebra.smul_def, algebra.commutes, op_unop] },
  commutes' := λ r, mul_opposite.rec $ λ x, by dsimp; simp only [← op_mul, algebra.commutes],
  .. mul_opposite.has_smul A R }

@[simp] lemma algebra_map_apply (c : R) : algebra_map R Aᵐᵒᵖ c = op (algebra_map R A c) := rfl

end mul_opposite

namespace module
variables (R : Type u) (M : Type v) [comm_semiring R] [add_comm_monoid M] [module R M]

instance : algebra R (module.End R M) :=
algebra.of_module smul_mul_assoc (λ r f g, (smul_comm r f g).symm)

lemma algebra_map_End_eq_smul_id (a : R) :
  (algebra_map R (End R M)) a = a • linear_map.id := rfl

@[simp] lemma algebra_map_End_apply (a : R) (m : M) :
  (algebra_map R (End R M)) a m = a • m := rfl

@[simp] lemma ker_algebra_map_End (K : Type u) (V : Type v)
  [field K] [add_comm_group V] [module K V] (a : K) (ha : a ≠ 0) :
  ((algebra_map K (End K V)) a).ker = ⊥ :=
linear_map.ker_smul _ _ ha

section

variables {R M}

lemma End_is_unit_apply_inv_apply_of_is_unit {f : module.End R M} (h : is_unit f) (x : M) :
  f (h.unit.inv x) = x :=
show (f * h.unit.inv) x = x, by simp

lemma End_is_unit_inv_apply_apply_of_is_unit {f : module.End R M} (h : is_unit f) (x : M) :
  h.unit.inv (f x) = x :=
(by simp : (h.unit.inv * f) x = x)

lemma End_is_unit_iff (f : module.End R M) :
  is_unit f ↔ function.bijective f :=
⟨λ h, function.bijective_iff_has_inverse.mpr $
  ⟨h.unit.inv, ⟨End_is_unit_inv_apply_apply_of_is_unit h,
    End_is_unit_apply_inv_apply_of_is_unit h⟩⟩,
 λ H, let e : M ≃ₗ[R] M := { ..f, ..(equiv.of_bijective f H)} in
  ⟨⟨_, e.symm, linear_map.ext e.right_inv, linear_map.ext e.left_inv⟩, rfl⟩⟩

lemma End_algebra_map_is_unit_inv_apply_eq_iff
  {x : R} (h : is_unit (algebra_map R (module.End R M) x)) (m m' : M) :
  h.unit⁻¹ m = m' ↔ m = x • m' :=
{ mp := λ H, ((congr_arg h.unit H).symm.trans (End_is_unit_apply_inv_apply_of_is_unit h _)).symm,
  mpr := λ H, H.symm ▸
  begin
    apply_fun h.unit using ((module.End_is_unit_iff _).mp h).injective,
    erw [End_is_unit_apply_inv_apply_of_is_unit],
    refl,
  end }

lemma End_algebra_map_is_unit_inv_apply_eq_iff'
  {x : R} (h : is_unit (algebra_map R (module.End R M) x)) (m m' : M) :
  m' = h.unit⁻¹ m ↔ m = x • m' :=
{ mp := λ H, ((congr_arg h.unit H).trans (End_is_unit_apply_inv_apply_of_is_unit h _)).symm,
  mpr := λ H, H.symm ▸
  begin
    apply_fun h.unit using ((module.End_is_unit_iff _).mp h).injective,
    erw [End_is_unit_apply_inv_apply_of_is_unit],
    refl,
  end }

end

end module

namespace linear_map

variables {R : Type*} {A : Type*} {B : Type*} [comm_semiring R] [semiring A] [semiring B]
  [algebra R A] [algebra R B]

/-- An alternate statement of `linear_map.map_smul` for when `algebra_map` is more convenient to
work with than `•`. -/
lemma map_algebra_map_mul (f : A →ₗ[R] B) (a : A) (r : R) :
  f (algebra_map R A r * a) = algebra_map R B r * f a :=
by rw [←algebra.smul_def, ←algebra.smul_def, map_smul]

lemma map_mul_algebra_map (f : A →ₗ[R] B) (a : A) (r : R) :
  f (a * algebra_map R A r) = f a * algebra_map R B r :=
by rw [←algebra.commutes, ←algebra.commutes, map_algebra_map_mul]

end linear_map

@[simp] lemma rat.smul_one_eq_coe {A : Type*} [division_ring A] [algebra ℚ A] (m : ℚ) :
  @@has_smul.smul algebra.to_has_smul m (1 : A) = ↑m :=
by rw [algebra.smul_def, mul_one, eq_rat_cast]

section nat

variables {R : Type*} [semiring R]

-- Lower the priority so that `algebra.id` is picked most of the time when working with
-- `ℕ`-algebras. This is only an issue since `algebra.id` and `algebra_nat` are not yet defeq.
-- TODO: fix this by adding an `of_nat` field to semirings.
/-- Semiring ⥤ ℕ-Alg -/
@[priority 99] instance algebra_nat : algebra ℕ R :=
{ commutes' := nat.cast_commute,
  smul_def' := λ _ _, nsmul_eq_mul _ _,
  to_ring_hom := nat.cast_ring_hom R }

instance nat_algebra_subsingleton : subsingleton (algebra ℕ R) :=
⟨λ P Q, by { ext, simp, }⟩

end nat

namespace ring_hom

variables {R S : Type*}

-- note that `R`, `S` could be `semiring`s but this is useless mathematically speaking -
-- a ℚ-algebra is a ring. furthermore, this change probably slows down elaboration.
@[simp] lemma map_rat_algebra_map [ring R] [ring S] [algebra ℚ R] [algebra ℚ S]
  (f : R →+* S) (r : ℚ) : f (algebra_map ℚ R r) = algebra_map ℚ S r :=
ring_hom.ext_iff.1 (subsingleton.elim (f.comp (algebra_map ℚ R)) (algebra_map ℚ S)) r

end ring_hom

section rat

instance algebra_rat {α} [division_ring α] [char_zero α] : algebra ℚ α :=
{ smul := (•),
  smul_def' := division_ring.qsmul_eq_mul',
  to_ring_hom := rat.cast_hom α,
  commutes' := rat.cast_commute }

/-- The two `algebra ℚ ℚ` instances should coincide. -/
example : algebra_rat = algebra.id ℚ := rfl

@[simp] theorem algebra_map_rat_rat : algebra_map ℚ ℚ = ring_hom.id ℚ :=
subsingleton.elim _ _

instance algebra_rat_subsingleton {α} [semiring α] :
  subsingleton (algebra ℚ α) :=
⟨λ x y, algebra.algebra_ext x y $ ring_hom.congr_fun $ subsingleton.elim _ _⟩

end rat

section int

variables (R : Type*) [ring R]

-- Lower the priority so that `algebra.id` is picked most of the time when working with
-- `ℤ`-algebras. This is only an issue since `algebra.id ℤ` and `algebra_int ℤ` are not yet defeq.
-- TODO: fix this by adding an `of_int` field to rings.
/-- Ring ⥤ ℤ-Alg -/
@[priority 99] instance algebra_int : algebra ℤ R :=
{ commutes' := int.cast_commute,
  smul_def' := λ _ _, zsmul_eq_mul _ _,
  to_ring_hom := int.cast_ring_hom R }

/-- A special case of `eq_int_cast'` that happens to be true definitionally -/
@[simp] lemma algebra_map_int_eq : algebra_map ℤ R = int.cast_ring_hom R := rfl

variables {R}

instance int_algebra_subsingleton : subsingleton (algebra ℤ R) :=
⟨λ P Q, by { ext, simp, }⟩

end int

namespace no_zero_smul_divisors

variables {R A : Type*}

open algebra

/-- If `algebra_map R A` is injective and `A` has no zero divisors,
`R`-multiples in `A` are zero only if one of the factors is zero.

Cannot be an instance because there is no `injective (algebra_map R A)` typeclass.
-/
lemma of_algebra_map_injective
  [comm_semiring R] [semiring A] [algebra R A] [no_zero_divisors A]
  (h : function.injective (algebra_map R A)) : no_zero_smul_divisors R A :=
⟨λ c x hcx, (mul_eq_zero.mp ((smul_def c x).symm.trans hcx)).imp_left
  (map_eq_zero_iff (algebra_map R A) h).mp⟩

variables (R A)
lemma algebra_map_injective [comm_ring R] [ring A] [nontrivial A]
  [algebra R A] [no_zero_smul_divisors R A] :
  function.injective (algebra_map R A) :=
suffices function.injective (λ (c : R), c • (1 : A)),
by { convert this, ext, rw [algebra.smul_def, mul_one] },
smul_left_injective R one_ne_zero

lemma _root_.ne_zero.of_no_zero_smul_divisors (n : ℕ) [comm_ring R] [ne_zero (n : R)] [ring A]
  [nontrivial A] [algebra R A] [no_zero_smul_divisors R A] : ne_zero (n : A) :=
ne_zero.nat_of_injective $ no_zero_smul_divisors.algebra_map_injective R A

variables {R A}
lemma iff_algebra_map_injective [comm_ring R] [ring A] [is_domain A] [algebra R A] :
  no_zero_smul_divisors R A ↔ function.injective (algebra_map R A) :=
⟨@@no_zero_smul_divisors.algebra_map_injective R A _ _ _ _,
 no_zero_smul_divisors.of_algebra_map_injective⟩

@[priority 100] -- see note [lower instance priority]
instance char_zero.no_zero_smul_divisors_nat [semiring R] [no_zero_divisors R] [char_zero R] :
  no_zero_smul_divisors ℕ R :=
no_zero_smul_divisors.of_algebra_map_injective $ (algebra_map ℕ R).injective_nat

@[priority 100] -- see note [lower instance priority]
instance char_zero.no_zero_smul_divisors_int [ring R] [no_zero_divisors R] [char_zero R] :
  no_zero_smul_divisors ℤ R :=
no_zero_smul_divisors.of_algebra_map_injective $ (algebra_map ℤ R).injective_int

section field

variables [field R] [semiring A] [algebra R A]

@[priority 100] -- see note [lower instance priority]
instance algebra.no_zero_smul_divisors [nontrivial A] [no_zero_divisors A] :
  no_zero_smul_divisors R A :=
no_zero_smul_divisors.of_algebra_map_injective (algebra_map R A).injective

end field

end no_zero_smul_divisors

section is_scalar_tower

variables {R : Type*} [comm_semiring R]
variables (A : Type*) [semiring A] [algebra R A]
variables {M : Type*} [add_comm_monoid M] [module A M] [module R M] [is_scalar_tower R A M]
variables {N : Type*} [add_comm_monoid N] [module A N] [module R N] [is_scalar_tower R A N]

lemma algebra_compatible_smul (r : R) (m : M) : r • m = ((algebra_map R A) r) • m :=
by rw [←(one_smul A m), ←smul_assoc, algebra.smul_def, mul_one, one_smul]

@[simp] lemma algebra_map_smul (r : R) (m : M) : ((algebra_map R A) r) • m = r • m :=
(algebra_compatible_smul A r m).symm

lemma int_cast_smul {k V : Type*} [comm_ring k] [add_comm_group V] [module k V] (r : ℤ) (x : V) :
  (r : k) • x = r • x :=
algebra_map_smul k r x

lemma no_zero_smul_divisors.trans (R A M : Type*) [comm_ring R] [ring A] [is_domain A] [algebra R A]
  [add_comm_group M] [module R M] [module A M] [is_scalar_tower R A M] [no_zero_smul_divisors R A]
  [no_zero_smul_divisors A M] : no_zero_smul_divisors R M :=
begin
  refine ⟨λ r m h, _⟩,
  rw [algebra_compatible_smul A r m] at h,
  cases smul_eq_zero.1 h with H H,
  { have : function.injective (algebra_map R A) :=
      no_zero_smul_divisors.iff_algebra_map_injective.1 infer_instance,
    left,
    exact (injective_iff_map_eq_zero _).1 this _ H },
  { right,
    exact H }
end

variable {A}

@[priority 100] -- see Note [lower instance priority]
instance is_scalar_tower.to_smul_comm_class : smul_comm_class R A M :=
⟨λ r a m, by rw [algebra_compatible_smul A r (a • m), smul_smul, algebra.commutes, mul_smul,
  ←algebra_compatible_smul]⟩

@[priority 100] -- see Note [lower instance priority]
instance is_scalar_tower.to_smul_comm_class' : smul_comm_class A R M :=
smul_comm_class.symm _ _ _

lemma smul_algebra_smul_comm (r : R) (a : A) (m : M) : a • r • m = r • a • m :=
smul_comm _ _ _

namespace linear_map

instance coe_is_scalar_tower : has_coe (M →ₗ[A] N) (M →ₗ[R] N) :=
⟨restrict_scalars R⟩

variables (R) {A M N}

@[simp, norm_cast squash] lemma coe_restrict_scalars_eq_coe (f : M →ₗ[A] N) :
  (f.restrict_scalars R : M → N) = f := rfl

@[simp, norm_cast squash] lemma coe_coe_is_scalar_tower (f : M →ₗ[A] N) :
  ((f : M →ₗ[R] N) : M → N) = f := rfl

/-- `A`-linearly coerce a `R`-linear map from `M` to `A` to a function, given an algebra `A` over
a commutative semiring `R` and `M` a module over `R`. -/
def lto_fun (R : Type u) (M : Type v) (A : Type w)
  [comm_semiring R] [add_comm_monoid M] [module R M] [comm_ring A] [algebra R A] :
  (M →ₗ[R] A) →ₗ[A] (M → A) :=
{ to_fun := linear_map.to_fun,
  map_add' := λ f g, rfl,
  map_smul' := λ c f, rfl }

end linear_map

end is_scalar_tower

/-! TODO: The following lemmas no longer involve `algebra` at all, and could be moved closer
to `algebra/module/submodule.lean`. Currently this is tricky because `ker`, `range`, `⊤`, and `⊥`
are all defined in `linear_algebra/basic.lean`. -/
section module
open module

variables (R S M N : Type*) [semiring R] [semiring S] [has_smul R S]
variables [add_comm_monoid M] [module R M] [module S M] [is_scalar_tower R S M]
variables [add_comm_monoid N] [module R N] [module S N] [is_scalar_tower R S N]

variables {S M N}

@[simp]
lemma linear_map.ker_restrict_scalars (f : M →ₗ[S] N) :
  (f.restrict_scalars R).ker = f.ker.restrict_scalars R :=
rfl

end module

example {R A} [comm_semiring R] [semiring A]
  [module R A] [smul_comm_class R A A] [is_scalar_tower R A A] : algebra R A :=
algebra.of_module smul_mul_assoc mul_smul_comm


import tactic

noncomputable theory
open_locale classical
open set function

@[protect_proj]
class subset (A : Type*) (B : out_param $ Type*) :=
(mem : B → A → Prop)

namespace subset
-- The following allows us to use the symbol `∈`
instance {A : Type*} {B : Type*} [subset A B] : has_mem B A := ⟨subset.mem⟩

-- This says that two "subset"s are equivalent (written `≈`, type with \approx) when
-- they have the same points.
instance {A : Type*} {B : Type*} [subset A B] : has_equiv A := ⟨λ X Y, ∀ t, t ∈ X ↔ t ∈ Y⟩
@[simp] lemma equiv_iff {A : Type*} {B : Type*} [subset A B] (X Y : A) : X ≈ Y ↔ ∀ t, t ∈ X ↔ t ∈ Y := iff.rfl

-- A "subset" can always be considered as an actual subset, in Lean this is `set B`
instance {A : Type*} {B : Type*} [subset A B] : has_coe_t A (set B) := ⟨λ x p, p ∈ x⟩

@[simp] lemma mem_pts  {A : Type*} {B : Type*} [subset A B] (a : A) (P : B) : P ∈ (a : set B) ↔ P ∈ a
:= iff.rfl

end subset

@[simp] def pts {A : Type*} {B : Type*} [subset A B] : A → set B := λ a, {x : B | x ∈ a}

notation p `xor` q := (p ∧ ¬ q) ∨ (q ∧ ¬ p)
def xor3 (p q r : Prop) : Prop := (p ∧ ¬ q ∧ ¬ r) ∨ (¬ p ∧ q ∧ ¬ r) ∨ (¬ p ∧ ¬ q ∧ r)

/--
We define an incidence plane as having the undefined terms `Point` and `Line`,
a function `distance` that takes every two points to a real number, and a predicate
`belongs` that relates points and lines.

There are essentially two axioms: existence of two distinct points, and the incidence postulate.
-/
class IncidencePlane (Point : Type*) :=
	(Line : Type*)

	-- Belongs is an undefined concept
  (belongs : Point → Line → Prop)
	(infix `∈`:100 := belongs)

	-- A1 postulate is divided into 4 statements
	(line_through : Point → Point → Line)
	(line_through_left' (P Q : Point) : P ∈ (line_through P Q))
	(line_through_right' (P Q : Point) : Q ∈ (line_through P Q))
	(incidence' {P Q : Point} {ℓ : Line} : P ≠ Q → P ∈ ℓ → Q ∈ ℓ → ℓ = line_through P Q)

	-- A2 postulate
	(line_contains_two_points' (ℓ : Line) : ∃ P Q : Point, P ≠ Q ∧ ℓ = line_through P Q)

	-- A3 postulate (existence postulate)
	(existence' : ∃ P Q R : Point, P ≠ Q ∧ P ≠ R ∧ Q ≠ R ∧ ¬ R ∈ (line_through P Q))

	-- Betweenness is an undefined concept
	(between : Point → Point → Point → Prop)
	(notation A `*` B `*` C := between A B C)

	/- Betweenness is symmetric -/
	(between_symmetric' {A B C : Point} : (A * B * C) ↔ (C * B * A))
	/- If A * B * C then the three points are distinct and collinear. -/
	(different_of_between' {A B C : Point} : (A * B * C) → (A ≠ B ∧ A ≠ C ∧ B ≠ C))
	(collinear_of_between' {A B C : Point} : (A * B * C) → ∃ ℓ, A ∈ ℓ ∧ B ∈ ℓ ∧ C ∈ ℓ)

	/- Given two distinct points A, B, there is a third point C such that A * B * C.-/
	(point_on_ray' {A B : Point} (h: A ≠ B) : ∃ C, A * B * C)

	/- Given 3 distinct collinear points A B C, exactly one of them is between the other two.-/
	(between_of_collinear' {A B C : Point} (h: ∃ℓ, A ∈ ℓ ∧ B ∈ ℓ ∧ C ∈ ℓ) : xor3 (A * B * C) ( B * A * C ) (A * C * B))

	/- Pasch -/
	(pasch' {A B C D : Point} {ℓ : Line}
		(hnc: ¬ C ∈ line_through A B)
		(hnAl: ¬ (A ∈ ℓ)) (hnBl: ¬ B ∈ ℓ) (hnCl: ¬ C ∈ ℓ)
		(hDl: D ∈ ℓ) (hADB: A * D * B) : (∃ E ,  E ∈ ℓ ∧ (A * E * C)) xor (∃ E, E ∈ ℓ ∧ (B * E * C)))

namespace IncidencePlane
variables {Ω Point : Type*} [IncidencePlane Ω] [IncidencePlane Point]

-- From here on, we can use the symbol `∈` for Lines
instance : subset (Line Ω) Ω := {mem := belongs}

notation A `*` B `*` C := IncidencePlane.between A B C

-- LIST OF ALL AXIOMS

-- A1
@[simp] lemma line_through_left (P Q : Ω) : P ∈ (line_through P Q) := line_through_left' P Q
@[simp] lemma line_through_right (P Q : Ω) : Q ∈ (line_through P Q) := line_through_right' P Q
lemma incidence {P Q : Ω} {ℓ : Line Ω} : P ≠ Q → P ∈ ℓ → Q ∈ ℓ → ℓ = line_through P Q := incidence'

-- A2
lemma line_contains_two_points (ℓ : Line Ω) : ∃ P Q : Ω, P ≠ Q ∧ ℓ = line_through P Q
:= line_contains_two_points' ℓ

-- A3
lemma existence (Ω : Type*) [IncidencePlane Ω] : ∃ P Q R : Ω, P ≠ Q ∧ P ≠ R ∧ Q ≠ R ∧
R ∉ (line_through P Q) := existence'

lemma between_symmetric {A B C : Ω} : (A * B * C) ↔ (C * B * A)  := between_symmetric'
lemma different_of_between {A B C : Ω} : (A * B * C) → (A ≠ B ∧ A ≠ C ∧ B ≠ C) := different_of_between'
lemma collinear_of_between {A B C : Ω} : (A * B * C) → ∃ ℓ : Line Ω, A ∈ ℓ ∧ B ∈ ℓ ∧ C ∈ ℓ := collinear_of_between'
lemma point_on_ray {A B : Ω} (h: A ≠ B) : ∃ (C : Ω), A * B * C := point_on_ray' h
lemma between_of_collinear {A B C : Ω} (h: ∃(ℓ : Line Ω), A ∈ ℓ ∧ B ∈ ℓ ∧ C ∈ ℓ) : xor3 (A * B * C) ( B * A * C ) (A * C * B)
:= between_of_collinear' h
lemma pasch {A B C D : Ω} {ℓ : Line Ω} (hnc: ¬ C ∈ line_through A B)
(hnAl: ¬ (A ∈ ℓ)) (hnBl: ¬ B ∈ ℓ) (hnCl: ¬ C ∈ ℓ) (hDl: D ∈ ℓ) (hADB: A * D * B) :
(∃ E ,  E ∈ ℓ ∧ (A * E * C)) xor (∃ E, E ∈ ℓ ∧ (B * E * C)) := pasch' hnc hnAl hnBl hnCl hDl hADB

-- END OF AXIOMS

/--
A set of points is collinear if they all lie on some line
-/
def collinear (S : set Ω) : Prop := ∃ (ℓ : Line Ω), ∀ {P : Ω}, P ∈ S → P ∈ ℓ

-- Next we introduce the notion of a Segment.

/--
A segment is the giving two points, A and B.
We will use the notation A⬝B to denote the segment denoted by A and B. The segment A⬝B consists
of all the points X such that A * X * B.
-/
structure Segment (Ω : Type*) :=
(A : Ω) (B : Ω)

infix `⬝`:100 := Segment.mk

namespace Segment

-- Declare when P ∈ A⬝B
instance : subset (Segment Ω) Ω := { mem := λ P S, P = S.A ∨ P = S.B ∨ S.A * P * S.B }
@[simp] lemma mem_pts (S : Segment Ω) (P : Ω) : P ∈ S ↔ P = S.A ∨ P = S.B ∨ (S.A * P * S.B) := iff.rfl

end Segment

/--
This lemma is a rephrasing of the incidence axiom that
doesn't mention `line_through`
-/
lemma equal_lines_of_contain_two_points {A B : Ω}	{r s : Line Ω}
(hAB: A ≠ B)	(hAr: A ∈ r) (hAs: A ∈ s) (hBr: B ∈ r) (hBs: B ∈ s) :	r = s :=
by rw [incidence hAB hAr hBr, incidence hAB hAs hBs]

-- The next lemmas allow us to deal with collinearity of sets
meta def extfinish : tactic unit := `[ext, finish]
lemma collinear_of_equal (S T : set Ω) (h : S = T . extfinish) : (collinear S ↔ collinear T) :=
iff_of_eq (congr_arg collinear h)

lemma collinear_subset (S T : set Ω) (hST : S ⊆ T) : collinear T → collinear S :=
begin
	intro h,
	obtain ⟨ℓ, hℓ⟩ := h,
	exact ⟨ℓ, λ P hP, hℓ (hST hP)⟩,
end

lemma collinear_union (S T : set Ω) {P Q : Ω} (h : P ≠ Q) (hS : collinear S) (hT : collinear T)
(hPS : P ∈ S) (hPT : P ∈ T) (hQS : Q ∈ S) (hQT : Q ∈ T) : collinear (S ∪ T) :=
begin
	obtain ⟨u, hu⟩ := hS,
	obtain ⟨v, hv⟩ := hT,
	use u,
	have huv : u = v := equal_lines_of_contain_two_points h (hu hPS) (hv hPT) (hu hQS) (hv hQT),
	simp [←huv] at hv,
	finish,
end

/--
Two points P and Q lie on the same side of a line ℓ if the segment P⬝Q doesn't intersect ℓ
-/
def same_side (ℓ : Line Ω) (P Q : Ω) :=  pts (P⬝Q) ∩ ℓ = ∅

end IncidencePlane


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.logic
import Mathlib.Lean3Lib.init.classical
import Mathlib.Lean3Lib.init.meta.name
import Mathlib.Lean3Lib.init.algebra.classes

universes u l u_1

namespace Mathlib

/- Make sure instances defined in this file have lower priority than the ones
   defined for concrete structures -/

/-!
### Definition of `preorder` and lemmas about types with a `preorder`
-/

/-- A preorder is a reflexive, transitive relation `≤` with `a < b` defined in the obvious way. -/
class preorder (α : Type u) extends HasLess α, HasLessEq α where
  le : α → α → Prop
  lt : α → α → Prop
  le_refl : ∀ (a : α), a ≤ a
  le_trans : ∀ (a b c : α), a ≤ b → b ≤ c → a ≤ c
  lt_iff_le_not_le :
    autoParam (∀ (a b : α), a < b ↔ a ≤ b ∧ ¬b ≤ a)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.order_laws_tac")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "order_laws_tac") [])

/-- The relation `≤` on a preorder is reflexive. -/
theorem le_refl {α : Type u} [preorder α] (a : α) : a ≤ a := preorder.le_refl

/-- The relation `≤` on a preorder is transitive. -/
theorem le_trans {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a ≤ b → b ≤ c → a ≤ c :=
  preorder.le_trans

theorem lt_iff_le_not_le {α : Type u} [preorder α] {a : α} {b : α} : a < b ↔ a ≤ b ∧ ¬b ≤ a :=
  preorder.lt_iff_le_not_le

theorem lt_of_le_not_le {α : Type u} [preorder α] {a : α} {b : α} : a ≤ b → ¬b ≤ a → a < b :=
  fun (ᾰ : a ≤ b) (ᾰ_1 : ¬b ≤ a) =>
    idRhs (a < b) (iff.mpr lt_iff_le_not_le { left := ᾰ, right := ᾰ_1 })

theorem le_not_le_of_lt {α : Type u} [preorder α] {a : α} {b : α} : a < b → a ≤ b ∧ ¬b ≤ a :=
  fun (ᾰ : a < b) => idRhs (a ≤ b ∧ ¬b ≤ a) (iff.mp lt_iff_le_not_le ᾰ)

theorem le_of_eq {α : Type u} [preorder α] {a : α} {b : α} : a = b → a ≤ b :=
  fun (h : a = b) => h ▸ le_refl a

theorem ge_trans {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a ≥ b → b ≥ c → a ≥ c :=
  fun (h₁ : a ≥ b) (h₂ : b ≥ c) => le_trans h₂ h₁

theorem lt_irrefl {α : Type u} [preorder α] (a : α) : ¬a < a := sorry

theorem gt_irrefl {α : Type u} [preorder α] (a : α) : ¬a > a := lt_irrefl

theorem lt_trans {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a < b → b < c → a < c := sorry

theorem gt_trans {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a > b → b > c → a > c :=
  fun (h₁ : a > b) (h₂ : b > c) => lt_trans h₂ h₁

theorem ne_of_lt {α : Type u} [preorder α] {a : α} {b : α} (h : a < b) : a ≠ b :=
  fun (he : a = b) => absurd h (he ▸ lt_irrefl a)

theorem ne_of_gt {α : Type u} [preorder α] {a : α} {b : α} (h : a > b) : a ≠ b :=
  fun (he : a = b) => absurd h (he ▸ lt_irrefl a)

theorem lt_asymm {α : Type u} [preorder α] {a : α} {b : α} (h : a < b) : ¬b < a :=
  fun (h1 : b < a) => lt_irrefl a (lt_trans h h1)

theorem le_of_lt {α : Type u} [preorder α] {a : α} {b : α} : a < b → a ≤ b :=
  fun (ᾰ : a < b) => idRhs (a ≤ b) (and.left (le_not_le_of_lt ᾰ))

theorem lt_of_lt_of_le {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a < b → b ≤ c → a < c :=
  sorry

theorem lt_of_le_of_lt {α : Type u} [preorder α] {a : α} {b : α} {c : α} : a ≤ b → b < c → a < c :=
  sorry

theorem gt_of_gt_of_ge {α : Type u} [preorder α] {a : α} {b : α} {c : α} (h₁ : a > b) (h₂ : b ≥ c) :
    a > c :=
  lt_of_le_of_lt h₂ h₁

theorem gt_of_ge_of_gt {α : Type u} [preorder α] {a : α} {b : α} {c : α} (h₁ : a ≥ b) (h₂ : b > c) :
    a > c :=
  lt_of_lt_of_le h₂ h₁

theorem not_le_of_gt {α : Type u} [preorder α] {a : α} {b : α} (h : a > b) : ¬a ≤ b :=
  and.right (le_not_le_of_lt h)

theorem not_lt_of_ge {α : Type u} [preorder α] {a : α} {b : α} (h : a ≥ b) : ¬a < b :=
  fun (hab : a < b) => not_le_of_gt hab h

theorem le_of_lt_or_eq {α : Type u} [preorder α] {a : α} {b : α} : a < b ∨ a = b → a ≤ b :=
  fun (ᾰ : a < b ∨ a = b) =>
    or.dcases_on ᾰ (fun (ᾰ : a < b) => idRhs (a ≤ b) (le_of_lt ᾰ))
      fun (ᾰ : a = b) => idRhs ((fun (_x : α) => a ≤ _x) b) (ᾰ ▸ le_refl a)

theorem le_of_eq_or_lt {α : Type u} [preorder α] {a : α} {b : α} (h : a = b ∨ a < b) : a ≤ b :=
  or.elim h le_of_eq le_of_lt

protected instance decidable_lt_of_decidable_le {α : Type u} [preorder α] [DecidableRel LessEq] :
    DecidableRel Less :=
  sorry

/-!
### Definition of `partial_order` and lemmas about types with a partial order
-/

/-- A partial order is a reflexive, transitive, antisymmetric relation `≤`. -/
class partial_order (α : Type u) extends preorder α where
  le_antisymm : ∀ (a b : α), a ≤ b → b ≤ a → a = b

theorem le_antisymm {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b → b ≤ a → a = b :=
  partial_order.le_antisymm

theorem le_antisymm_iff {α : Type u} [partial_order α] {a : α} {b : α} : a = b ↔ a ≤ b ∧ b ≤ a :=
  sorry

theorem lt_or_eq_of_le {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b → a < b ∨ a = b :=
  sorry

theorem le_iff_lt_or_eq {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b ↔ a < b ∨ a = b :=
  idRhs (a ≤ b ↔ a < b ∨ a = b) { mp := lt_or_eq_of_le, mpr := le_of_lt_or_eq }

theorem lt_of_le_of_ne {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b → a ≠ b → a < b :=
  fun (h₁ : a ≤ b) (h₂ : a ≠ b) => lt_of_le_not_le h₁ (mt (le_antisymm h₁) h₂)

protected instance decidable_eq_of_decidable_le {α : Type u} [partial_order α]
    [DecidableRel LessEq] : DecidableEq α :=
  sorry

/-!
### Definition of `linear_order` and lemmas about types with a linear order
-/

/-- A linear order is reflexive, transitive, antisymmetric and total relation `≤`.
We assume that every linear ordered type has decidable `(≤)`, `(<)`, and `(=)`. -/
class linear_order (α : Type u) extends partial_order α where
  le_total : ∀ (a b : α), a ≤ b ∨ b ≤ a
  decidable_le : DecidableRel LessEq
  decidable_eq : DecidableEq α
  decidable_lt : DecidableRel Less

theorem le_total {α : Type u} [linear_order α] (a : α) (b : α) : a ≤ b ∨ b ≤ a :=
  linear_order.le_total

theorem le_of_not_ge {α : Type u} [linear_order α] {a : α} {b : α} : ¬a ≥ b → a ≤ b :=
  or.resolve_left (le_total b a)

theorem le_of_not_le {α : Type u} [linear_order α] {a : α} {b : α} : ¬a ≤ b → b ≤ a :=
  or.resolve_left (le_total a b)

theorem not_lt_of_gt {α : Type u} [linear_order α] {a : α} {b : α} (h : a > b) : ¬a < b :=
  lt_asymm h

theorem lt_trichotomy {α : Type u} [linear_order α] (a : α) (b : α) : a < b ∨ a = b ∨ b < a := sorry

theorem le_of_not_gt {α : Type u} [linear_order α] {a : α} {b : α} (h : ¬a > b) : a ≤ b := sorry

theorem lt_of_not_ge {α : Type u} [linear_order α] {a : α} {b : α} (h : ¬a ≥ b) : a < b :=
  lt_of_le_not_le (or.resolve_right (le_total a b) h) h

theorem lt_or_ge {α : Type u} [linear_order α] (a : α) (b : α) : a < b ∨ a ≥ b := sorry

theorem le_or_gt {α : Type u} [linear_order α] (a : α) (b : α) : a ≤ b ∨ a > b :=
  or.swap (lt_or_ge b a)

theorem lt_or_gt_of_ne {α : Type u} [linear_order α] {a : α} {b : α} (h : a ≠ b) : a < b ∨ a > b :=
  sorry

theorem ne_iff_lt_or_gt {α : Type u} [linear_order α] {a : α} {b : α} : a ≠ b ↔ a < b ∨ a > b :=
  { mp := lt_or_gt_of_ne, mpr := fun (o : a < b ∨ a > b) => or.elim o ne_of_lt ne_of_gt }

theorem lt_iff_not_ge {α : Type u} [linear_order α] (x : α) (y : α) : x < y ↔ ¬x ≥ y :=
  { mp := not_le_of_gt, mpr := lt_of_not_ge }

@[simp] theorem not_lt {α : Type u} [linear_order α] {a : α} {b : α} : ¬a < b ↔ b ≤ a :=
  { mp := le_of_not_gt, mpr := not_lt_of_ge }

@[simp] theorem not_le {α : Type u} [linear_order α] {a : α} {b : α} : ¬a ≤ b ↔ b < a :=
  iff.symm (lt_iff_not_ge b a)

protected instance has_lt.lt.decidable {α : Type u} [linear_order α] (a : α) (b : α) :
    Decidable (a < b) :=
  linear_order.decidable_lt a b

protected instance has_le.le.decidable {α : Type u} [linear_order α] (a : α) (b : α) :
    Decidable (a ≤ b) :=
  linear_order.decidable_le a b

protected instance eq.decidable {α : Type u} [linear_order α] (a : α) (b : α) : Decidable (a = b) :=
  linear_order.decidable_eq a b

theorem eq_or_lt_of_not_lt {α : Type u} [linear_order α] {a : α} {b : α} (h : ¬a < b) :
    a = b ∨ b < a :=
  dite (a = b) (fun (h₁ : a = b) => Or.inl h₁)
    fun (h₁ : ¬a = b) => Or.inr (lt_of_not_ge fun (hge : b ≥ a) => h (lt_of_le_of_ne hge h₁))

protected instance has_le.le.is_total_preorder {α : Type u} [linear_order α] :
    is_total_preorder α LessEq :=
  is_total_preorder.mk

/- TODO(Leo): decide whether we should keep this instance or not -/

protected instance is_strict_weak_order_of_linear_order {α : Type u} [linear_order α] :
    is_strict_weak_order α Less :=
  is_strict_weak_order_of_is_total_preorder lt_iff_not_ge

/- TODO(Leo): decide whether we should keep this instance or not -/

protected instance is_strict_total_order_of_linear_order {α : Type u} [linear_order α] :
    is_strict_total_order α Less :=
  is_strict_total_order.mk

namespace decidable

theorem lt_or_eq_of_le {α : Type u} [partial_order α] [DecidableRel LessEq] {a : α} {b : α}
    (hab : a ≤ b) : a < b ∨ a = b :=
  dite (b ≤ a) (fun (hba : b ≤ a) => Or.inr (le_antisymm hab hba))
    fun (hba : ¬b ≤ a) => Or.inl (lt_of_le_not_le hab hba)

theorem eq_or_lt_of_le {α : Type u} [partial_order α] [DecidableRel LessEq] {a : α} {b : α}
    (hab : a ≤ b) : a = b ∨ a < b :=
  or.swap (lt_or_eq_of_le hab)

theorem le_iff_lt_or_eq {α : Type u} [partial_order α] [DecidableRel LessEq] {a : α} {b : α} :
    a ≤ b ↔ a < b ∨ a = b :=
  { mp := lt_or_eq_of_le, mpr := le_of_lt_or_eq }

theorem le_of_not_lt {α : Type u} [linear_order α] {a : α} {b : α} (h : ¬b < a) : a ≤ b :=
  by_contradiction fun (h' : ¬a ≤ b) => h (lt_of_le_not_le (or.resolve_right (le_total b a) h') h')

theorem not_lt {α : Type u} [linear_order α] {a : α} {b : α} : ¬a < b ↔ b ≤ a :=
  { mp := le_of_not_lt, mpr := not_lt_of_ge }

theorem lt_or_le {α : Type u} [linear_order α] (a : α) (b : α) : a < b ∨ b ≤ a :=
  dite (b ≤ a) (fun (hba : b ≤ a) => Or.inr hba) fun (hba : ¬b ≤ a) => Or.inl (lt_of_not_ge hba)

theorem le_or_lt {α : Type u} [linear_order α] (a : α) (b : α) : a ≤ b ∨ b < a :=
  or.swap (lt_or_le b a)

theorem lt_trichotomy {α : Type u} [linear_order α] (a : α) (b : α) : a < b ∨ a = b ∨ b < a :=
  or.imp_right (fun (h : b ≤ a) => or.imp_left Eq.symm (eq_or_lt_of_le h)) (lt_or_le a b)

theorem lt_or_gt_of_ne {α : Type u} [linear_order α] {a : α} {b : α} (h : a ≠ b) : a < b ∨ b < a :=
  or.imp_right (fun (h' : a = b ∨ b < a) => or.resolve_left h' h) (lt_trichotomy a b)

/-- Perform a case-split on the ordering of `x` and `y` in a decidable linear order. -/
def lt_by_cases {α : Type u} [linear_order α] (x : α) (y : α) {P : Sort u_1} (h₁ : x < y → P)
    (h₂ : x = y → P) (h₃ : y < x → P) : P :=
  dite (x < y) (fun (h : x < y) => h₁ h)
    fun (h : ¬x < y) => dite (y < x) (fun (h' : y < x) => h₃ h') fun (h' : ¬y < x) => h₂ sorry

theorem ne_iff_lt_or_gt {α : Type u} [linear_order α] {a : α} {b : α} : a ≠ b ↔ a < b ∨ b < a :=
  { mp := lt_or_gt_of_ne, mpr := fun (o : a < b ∨ b < a) => or.elim o ne_of_lt ne_of_gt }

theorem le_imp_le_of_lt_imp_lt {α : Type u} {β : Type u_1} [preorder α] [linear_order β] {a : α}
    {b : α} {c : β} {d : β} (H : d < c → b < a) (h : a ≤ b) : c ≤ d :=
  le_of_not_lt fun (h' : d < c) => not_le_of_gt (H h') h

end Mathlib