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

Ordered monoids and groups.
-/
import algebra.group order.bounded_lattice tactic.basic

universe u
variable {α : Type u}

section old_structure_cmd

set_option old_structure_cmd true

/-- An ordered (additive) commutative monoid is a commutative monoid
  with a partial order such that addition is an order embedding, i.e.
  `a + b ≤ a + c ↔ b ≤ c`. These monoids are automatically cancellative. -/
class ordered_comm_monoid (α : Type*) extends add_comm_monoid α, partial_order α :=
(add_le_add_left       : ∀ a b : α, a ≤ b → ∀ c : α, c + a ≤ c + b)
(lt_of_add_lt_add_left : ∀ a b c : α, a + b < a + c → b < c)

/-- A canonically ordered monoid is an ordered commutative monoid
  in which the ordering coincides with the divisibility relation,
  which is to say, `a ≤ b` iff there exists `c` with `b = a + c`.
  This is satisfied by the natural numbers, for example, but not
  the integers or other ordered groups. -/
class canonically_ordered_monoid (α : Type*) extends ordered_comm_monoid α :=
(le_iff_exists_add : ∀a b:α, a ≤ b ↔ ∃c, b = a + c)

end old_structure_cmd

section ordered_comm_monoid
variables [ordered_comm_monoid α] {a b c d : α}

lemma add_le_add_left' (h : a ≤ b) : c + a ≤ c + b :=
ordered_comm_monoid.add_le_add_left a b h c

lemma add_le_add_right' (h : a ≤ b) : a + c ≤ b + c :=
add_comm c a ▸ add_comm c b ▸ add_le_add_left' h

lemma lt_of_add_lt_add_left' : a + b < a + c → b < c :=
ordered_comm_monoid.lt_of_add_lt_add_left a b c

lemma add_le_add' (h₁ : a ≤ b) (h₂ : c ≤ d) : a + c ≤ b + d :=
le_trans (add_le_add_right' h₁) (add_le_add_left' h₂)

lemma le_add_of_nonneg_right' (h : b ≥ 0) : a ≤ a + b :=
have a + b ≥ a + 0, from add_le_add_left' h,
by rwa add_zero at this

lemma le_add_of_nonneg_left' (h : b ≥ 0) : a ≤ b + a :=
have 0 + a ≤ b + a, from add_le_add_right' h,
by rwa zero_add at this

lemma lt_of_add_lt_add_right' (h : a + b < c + b) : a < c :=
lt_of_add_lt_add_left'
  (show b + a < b + c, begin rw [add_comm b a, add_comm b c], assumption end)

-- here we start using properties of zero.
lemma le_add_of_nonneg_of_le' (ha : 0 ≤ a) (hbc : b ≤ c) : b ≤ a + c :=
zero_add b ▸ add_le_add' ha hbc

lemma le_add_of_le_of_nonneg' (hbc : b ≤ c) (ha : 0 ≤ a) : b ≤ c + a :=
add_zero b ▸ add_le_add' hbc ha

lemma add_nonneg' (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a + b :=
le_add_of_nonneg_of_le' ha hb

lemma add_pos_of_pos_of_nonneg' (ha : 0 < a) (hb : 0 ≤ b) : 0 < a + b :=
lt_of_lt_of_le ha $ le_add_of_nonneg_right' hb

lemma add_pos' (ha : 0 < a) (hb : 0 < b) : 0 < a + b :=
add_pos_of_pos_of_nonneg' ha $ le_of_lt hb

lemma add_pos_of_nonneg_of_pos' (ha : 0 ≤ a) (hb : 0 < b) : 0 < a + b :=
lt_of_lt_of_le hb $ le_add_of_nonneg_left' ha

lemma add_nonpos' (ha : a ≤ 0) (hb : b ≤ 0) : a + b ≤ 0 :=
zero_add (0:α) ▸ (add_le_add' ha hb)

lemma add_le_of_nonpos_of_le' (ha : a ≤ 0) (hbc : b ≤ c) : a + b ≤ c :=
zero_add c ▸ add_le_add' ha hbc

lemma add_le_of_le_of_nonpos' (hbc : b ≤ c) (ha : a ≤ 0) : b + a ≤ c :=
add_zero c ▸ add_le_add' hbc ha

lemma add_neg_of_neg_of_nonpos' (ha : a < 0) (hb : b ≤ 0) : a + b < 0 :=
lt_of_le_of_lt (add_le_of_le_of_nonpos' (le_refl _) hb) ha

lemma add_neg_of_nonpos_of_neg' (ha : a ≤ 0) (hb : b < 0) : a + b < 0 :=
lt_of_le_of_lt (add_le_of_nonpos_of_le' ha (le_refl _)) hb

lemma add_neg' (ha : a < 0) (hb : b < 0) : a + b < 0 :=
add_neg_of_nonpos_of_neg' (le_of_lt ha) hb

lemma lt_add_of_nonneg_of_lt' (ha : 0 ≤ a) (hbc : b < c) : b < a + c :=
lt_of_lt_of_le hbc $ le_add_of_nonneg_left' ha

lemma lt_add_of_lt_of_nonneg' (hbc : b < c) (ha : 0 ≤ a) : b < c + a :=
lt_of_lt_of_le hbc $ le_add_of_nonneg_right' ha

lemma lt_add_of_pos_of_lt' (ha : 0 < a) (hbc : b < c) : b < a + c :=
lt_add_of_nonneg_of_lt' (le_of_lt ha) hbc

lemma lt_add_of_lt_of_pos' (hbc : b < c) (ha : 0 < a) : b < c + a :=
lt_add_of_lt_of_nonneg' hbc (le_of_lt ha)

lemma add_lt_of_nonpos_of_lt' (ha : a ≤ 0) (hbc : b < c) : a + b < c :=
lt_of_le_of_lt (add_le_of_nonpos_of_le' ha (le_refl _)) hbc

lemma add_lt_of_lt_of_nonpos' (hbc : b < c) (ha : a ≤ 0)  : b + a < c :=
lt_of_le_of_lt (add_le_of_le_of_nonpos' (le_refl _) ha) hbc

lemma add_lt_of_neg_of_lt' (ha : a < 0) (hbc : b < c) : a + b < c :=
add_lt_of_nonpos_of_lt' (le_of_lt ha) hbc

lemma add_lt_of_lt_of_neg' (hbc : b < c) (ha : a < 0) : b + a < c :=
add_lt_of_lt_of_nonpos' hbc (le_of_lt ha)

lemma add_eq_zero_iff_eq_zero_and_eq_zero_of_nonneg_of_nonneg'
  (ha : 0 ≤ a) (hb : 0 ≤ b) : a + b = 0 ↔ a = 0 ∧ b = 0 :=
iff.intro
  (assume hab : a + b = 0,
   have a ≤ 0, from hab ▸ le_add_of_le_of_nonneg' (le_refl _) hb,
   have a = 0, from le_antisymm this ha,
   have b ≤ 0, from hab ▸ le_add_of_nonneg_of_le' ha (le_refl _),
   have b = 0, from le_antisymm this hb,
   and.intro ‹a = 0› ‹b = 0›)
  (assume ⟨ha', hb'⟩, by rw [ha', hb', add_zero])

lemma bit0_pos {a : α} (h : 0 < a) : 0 < bit0 a :=
add_pos' h h

end ordered_comm_monoid

namespace units

instance [monoid α] [preorder α] : preorder (units α) :=
{ le := λ a b, (a:α) ≤ b,
  lt := λ a b, (a:α) < b,
  le_refl := λ a, @le_refl α _ _,
  le_trans := λ a b c, @le_trans α _ _ _ _,
  lt_iff_le_not_le := λ a b, @lt_iff_le_not_le α _ _ _ }

@[simp] theorem coe_le_coe [monoid α] [preorder α] {a b : units α} :
  (a : α) ≤ b ↔ a ≤ b := iff.rfl

@[simp] theorem coe_lt_coe [monoid α] [preorder α] {a b : units α} :
  (a : α) < b ↔ a < b := iff.rfl

instance [monoid α] [partial_order α] : partial_order (units α) :=
{ le_antisymm := λ a b h₁ h₂, ext $ le_antisymm h₁ h₂, ..units.preorder }

instance [monoid α] [linear_order α] : linear_order (units α) :=
{ le_total := λ a b, @le_total α _ _ _, ..units.partial_order }

instance [monoid α] [decidable_linear_order α] : decidable_linear_order (units α) :=
{ decidable_le := by apply_instance,
  decidable_lt := by apply_instance,
  decidable_eq := by apply_instance,
  ..units.linear_order }

theorem max_coe [monoid α] [decidable_linear_order α] {a b : units α} :
  (↑(max a b) : α) = max a b :=
by by_cases a ≤ b; simp [max, h]

theorem min_coe [monoid α] [decidable_linear_order α] {a b : units α} :
  (↑(min a b) : α) = min a b :=
by by_cases a ≤ b; simp [min, h]

end units

namespace with_zero
open lattice

instance [partial_order α] : partial_order (with_zero α) := with_bot.partial_order
instance [partial_order α] : order_bot (with_zero α) := with_bot.order_bot
instance [lattice α] : lattice (with_zero α) := with_bot.lattice
instance [linear_order α] : linear_order (with_zero α) := with_bot.linear_order
instance [decidable_linear_order α] :
 decidable_linear_order (with_zero α) := with_bot.decidable_linear_order

def ordered_comm_monoid [ordered_comm_monoid α]
  (zero_le : ∀ a : α, 0 ≤ a) : ordered_comm_monoid (with_zero α) :=
begin
  suffices, refine {
    add_le_add_left := this,
    ..with_zero.partial_order,
    ..with_zero.add_comm_monoid, ..},
  { intros a b c h,
    refine ⟨λ b h₂, _, λ h₂, h.2 $ this _ _ h₂ _⟩,
    cases h₂, cases c with c,
    { cases h.2 (this _ _ bot_le a) },
    { refine ⟨_, rfl, _⟩,
      cases a with a,
      { exact with_bot.some_le_some.1 h.1 },
      { exact le_of_lt (lt_of_add_lt_add_left' $
          with_bot.some_lt_some.1 h), } } },
  { intros a b h c ca h₂,
    cases b with b,
    { rw le_antisymm h bot_le at h₂,
      exact ⟨_, h₂, le_refl _⟩ },
    cases a with a,
    { change c + 0 = some ca at h₂,
      simp at h₂, simp [h₂],
      exact ⟨_, rfl, by simpa using add_le_add_left' (zero_le b)⟩ },
    { simp at h,
      cases c with c; change some _ = _ at h₂;
        simp [-add_comm] at h₂; subst ca; refine ⟨_, rfl, _⟩,
      { exact h },
      { exact add_le_add_left' h } } }
end

end with_zero

namespace with_top
open lattice

instance [add_semigroup α] : add_semigroup (with_top α) :=
{ add := λ o₁ o₂, o₁.bind (λ a, o₂.map (λ b, a + b)),
  ..@additive.add_semigroup _ $ @with_zero.semigroup (multiplicative α) _ }

lemma coe_add [add_semigroup α] {a b : α} : ((a + b : α) : with_top α) = a + b :=
rfl

instance [add_comm_semigroup α] : add_comm_semigroup (with_top α) :=
{ ..@additive.add_comm_semigroup _ $
    @with_zero.comm_semigroup (multiplicative α) _ }

instance [add_monoid α] : add_monoid (with_top α) :=
{ zero := some 0,
  ..@additive.add_monoid _ $ @with_zero.monoid (multiplicative α) _ }

instance [add_comm_monoid α] : add_comm_monoid (with_top α) :=
{ ..@additive.add_comm_monoid _ $
    @with_zero.comm_monoid (multiplicative α) _ }

instance [ordered_comm_monoid α] : ordered_comm_monoid (with_top α) :=
begin
  suffices, refine {
    add_le_add_left := this,
    ..with_top.partial_order,
    ..with_top.add_comm_monoid, ..},
  { intros a b c h,
    refine ⟨λ c h₂, _, λ h₂, h.2 $ this _ _ h₂ _⟩,
    cases h₂, cases a with a,
    { exact (not_le_of_lt h).elim le_top },
    cases b with b,
    { exact (not_le_of_lt h).elim le_top },
    { exact ⟨_, rfl, le_of_lt (lt_of_add_lt_add_left' $
        with_top.some_lt_some.1 h)⟩ } },
  { intros a b h c cb h₂,
    cases c with c, {cases h₂},
    cases b with b; cases h₂,
    cases a with a, {cases le_antisymm h le_top},
    simp at h,
    exact ⟨_, rfl, add_le_add_left' h⟩, }
end

@[simp] lemma zero_lt_top [ordered_comm_monoid α] : (0 : with_top α) < ⊤ :=
coe_lt_top 0

@[simp] lemma zero_lt_coe [ordered_comm_monoid α] (a : α) : (0 : with_top α) < a ↔ 0 < a :=
coe_lt_coe

@[simp] lemma add_top [ordered_comm_monoid α] : ∀{a : with_top α}, a + ⊤ = ⊤
| none := rfl
| (some a) := rfl

@[simp] lemma top_add [ordered_comm_monoid α] {a : with_top α} : ⊤ + a = ⊤ := rfl

lemma add_eq_top [ordered_comm_monoid α] (a b : with_top α) : a + b = ⊤ ↔ a = ⊤ ∨ b = ⊤ :=
by cases a; cases b; simp [none_eq_top, some_eq_coe, coe_add.symm]

instance [canonically_ordered_monoid α] : canonically_ordered_monoid (with_top α) :=
{ le_iff_exists_add := assume a b,
  match a, b with
  | a, none     := show a ≤ ⊤ ↔ ∃c, ⊤ = a + c, by simp; refine ⟨⊤, _⟩; cases a; refl
  | (some a), (some b) := show (a:with_top α) ≤ ↑b ↔ ∃c:with_top α, ↑b = ↑a + c,
    begin
      simp [canonically_ordered_monoid.le_iff_exists_add, -add_comm],
      split,
      { rintro ⟨c, rfl⟩, refine ⟨c, _⟩, simp [coe_add] },
      { exact assume h, match b, h with _, ⟨some c, rfl⟩ := ⟨_, rfl⟩ end }
    end
  | none, some b := show (⊤ : with_top α) ≤ b ↔ ∃c:with_top α, ↑b = ⊤ + c, by simp
  end,
  .. with_top.ordered_comm_monoid }

end with_top

namespace with_bot
open lattice

instance [add_semigroup α] : add_semigroup (with_bot α) := with_top.add_semigroup
instance [add_comm_semigroup α] : add_comm_semigroup (with_bot α) := with_top.add_comm_semigroup
instance [add_monoid α] : add_monoid (with_bot α) := with_top.add_monoid
instance [add_comm_monoid α] : add_comm_monoid (with_bot α) :=  with_top.add_comm_monoid

instance [ordered_comm_monoid α] : ordered_comm_monoid (with_bot α) :=
begin
  suffices, refine {
    add_le_add_left := this,
    ..with_bot.partial_order,
    ..with_bot.add_comm_monoid, ..},
  { intros a b c h,
    refine ⟨λ b h₂, _, λ h₂, h.2 $ this _ _ h₂ _⟩,
    cases h₂, cases a with a,
    { exact (not_le_of_lt h).elim bot_le },
    cases c with c,
    { exact (not_le_of_lt h).elim bot_le },
    { exact ⟨_, rfl, le_of_lt (lt_of_add_lt_add_left' $
        with_bot.some_lt_some.1 h)⟩ } },
  { intros a b h c ca h₂,
    cases c with c, {cases h₂},
    cases a with a; cases h₂,
    cases b with b, {cases le_antisymm h bot_le},
    simp at h,
    exact ⟨_, rfl, add_le_add_left' h⟩, }
end

@[simp] lemma coe_add [add_semigroup α] (a b : α) : ((a + b : α) : with_bot α) = a + b := rfl

@[simp] lemma bot_add [ordered_comm_monoid α] (a : with_bot α) : ⊥ + a = ⊥ := rfl

@[simp] lemma add_bot [ordered_comm_monoid α] (a : with_bot α) : a + ⊥ = ⊥ := by cases a; refl

instance has_one [has_one α] : has_one (with_bot α) := ⟨(1 : α)⟩

end with_bot

section canonically_ordered_monoid
variables [canonically_ordered_monoid α] {a b c d : α}

lemma le_iff_exists_add : a ≤ b ↔ ∃c, b = a + c :=
canonically_ordered_monoid.le_iff_exists_add a b

@[simp] lemma zero_le (a : α) : 0 ≤ a := le_iff_exists_add.mpr ⟨a, by simp⟩

@[simp] lemma add_eq_zero_iff : a + b = 0 ↔ a = 0 ∧ b = 0 :=
add_eq_zero_iff_eq_zero_and_eq_zero_of_nonneg_of_nonneg' (zero_le _) (zero_le _)

@[simp] lemma le_zero_iff_eq : a ≤ 0 ↔ a = 0 :=
iff.intro
  (assume h, le_antisymm h (zero_le a))
  (assume h, h ▸ le_refl a)

protected lemma zero_lt_iff_ne_zero : 0 < a ↔ a ≠ 0 :=
iff.intro ne_of_gt $ assume hne, lt_of_le_of_ne (zero_le _) hne.symm

lemma le_add_left (h : a ≤ c) : a ≤ b + c :=
calc a = 0 + a : by simp
  ... ≤ b + c : add_le_add' (zero_le _) h

lemma le_add_right (h : a ≤ b) : a ≤ b + c :=
calc a = a + 0 : by simp
  ... ≤ b + c : add_le_add' h (zero_le _)

instance with_zero.canonically_ordered_monoid :
  canonically_ordered_monoid (with_zero α) :=
{ le_iff_exists_add := λ a b, begin
    cases a with a,
    { exact iff_of_true lattice.bot_le ⟨b, (zero_add b).symm⟩ },
    cases b with b,
    { exact iff_of_false
        (mt (le_antisymm lattice.bot_le) (by simp))
        (λ ⟨c, h⟩, by cases c; cases h) },
    { simp [le_iff_exists_add, -add_comm],
      split; intro h; rcases h with ⟨c, h⟩,
      { exact ⟨some c, congr_arg some h⟩ },
      { cases c; cases h,
        { exact ⟨_, (add_zero _).symm⟩ },
        { exact ⟨_, rfl⟩ } } }
  end,
  ..with_zero.ordered_comm_monoid zero_le }

end canonically_ordered_monoid

instance ordered_cancel_comm_monoid.to_ordered_comm_monoid
  [H : ordered_cancel_comm_monoid α] : ordered_comm_monoid α :=
{ lt_of_add_lt_add_left := @lt_of_add_lt_add_left _ _, ..H }

section ordered_cancel_comm_monoid
variables [ordered_cancel_comm_monoid α] {a b c : α}

@[simp] lemma add_le_add_iff_left (a : α) {b c : α} : a + b ≤ a + c ↔ b ≤ c :=
⟨le_of_add_le_add_left, λ h, add_le_add_left h _⟩

@[simp] lemma add_le_add_iff_right (c : α) : a + c ≤ b + c ↔ a ≤ b :=
add_comm c a ▸ add_comm c b ▸ add_le_add_iff_left c

@[simp] lemma add_lt_add_iff_left (a : α) {b c : α} : a + b < a + c ↔ b < c :=
⟨lt_of_add_lt_add_left, λ h, add_lt_add_left h _⟩

@[simp] lemma add_lt_add_iff_right (c : α) : a + c < b + c ↔ a < b :=
add_comm c a ▸ add_comm c b ▸ add_lt_add_iff_left c

@[simp] lemma le_add_iff_nonneg_right (a : α) {b : α} : a ≤ a + b ↔ 0 ≤ b :=
have a + 0 ≤ a + b ↔ 0 ≤ b, from add_le_add_iff_left a,
by rwa add_zero at this

@[simp] lemma le_add_iff_nonneg_left (a : α) {b : α} : a ≤ b + a ↔ 0 ≤ b :=
by rw [add_comm, le_add_iff_nonneg_right]

@[simp] lemma lt_add_iff_pos_right (a : α) {b : α} : a < a + b ↔ 0 < b :=
have a + 0 < a + b ↔ 0 < b, from add_lt_add_iff_left a,
by rwa add_zero at this

@[simp] lemma lt_add_iff_pos_left (a : α) {b : α} : a < b + a ↔ 0 < b :=
by rw [add_comm, lt_add_iff_pos_right]

lemma add_eq_zero_iff_eq_zero_of_nonneg
  (ha : 0 ≤ a) (hb : 0 ≤ b) : a + b = 0 ↔ a = 0 ∧ b = 0 :=
⟨λ hab : a + b = 0,
by split; apply le_antisymm; try {assumption};
   rw ← hab; simp [ha, hb],
λ ⟨ha', hb'⟩, by rw [ha', hb', add_zero]⟩

lemma with_top.add_lt_add_iff_left :
  ∀{a b c : with_top α}, a < ⊤ → (a + c < a + b ↔ c < b)
| none := assume b c h, (lt_irrefl ⊤ h).elim
| (some a) :=
  begin
    assume b c h,
    cases b; cases c;
      simp [with_top.none_eq_top, with_top.some_eq_coe, with_top.coe_lt_top, with_top.coe_lt_coe],
    { rw [← with_top.coe_add], exact with_top.coe_lt_top _ },
    { rw [← with_top.coe_add, ← with_top.coe_add, with_top.coe_lt_coe],
      exact add_lt_add_iff_left _ }
  end

end ordered_cancel_comm_monoid

section ordered_comm_group
variables [ordered_comm_group α] {a b c : α}

@[simp] lemma neg_le_neg_iff : -a ≤ -b ↔ b ≤ a :=
have a + b + -a ≤ a + b + -b ↔ -a ≤ -b, from add_le_add_iff_left _,
by simp at this; simp [this]

lemma neg_le : -a ≤ b ↔ -b ≤ a :=
have -a ≤ -(-b) ↔ -b ≤ a, from neg_le_neg_iff,
by rwa neg_neg at this

lemma le_neg : a ≤ -b ↔ b ≤ -a :=
have -(-a) ≤ -b ↔ b ≤ -a, from neg_le_neg_iff,
by rwa neg_neg at this

@[simp] lemma neg_nonpos : -a ≤ 0 ↔ 0 ≤ a :=
have -a ≤ -0 ↔ 0 ≤ a, from neg_le_neg_iff,
by rwa neg_zero at this

@[simp] lemma neg_nonneg : 0 ≤ -a ↔ a ≤ 0 :=
have -0 ≤ -a ↔ a ≤ 0, from neg_le_neg_iff,
by rwa neg_zero at this

@[simp] lemma neg_lt_neg_iff : -a < -b ↔ b < a :=
have a + b + -a < a + b + -b ↔ -a < -b, from add_lt_add_iff_left _,
by simp at this; simp [this]

lemma neg_lt_zero : -a < 0 ↔ 0 < a :=
have -a < -0 ↔ 0 < a, from neg_lt_neg_iff,
by rwa neg_zero at this

lemma neg_pos : 0 < -a ↔ a < 0 :=
have -0 < -a ↔ a < 0, from neg_lt_neg_iff,
by rwa neg_zero at this

lemma neg_lt : -a < b ↔ -b < a :=
have -a < -(-b) ↔ -b < a, from neg_lt_neg_iff,
by rwa neg_neg at this

lemma lt_neg : a < -b ↔ b < -a :=
have -(-a) < -b ↔ b < -a, from neg_lt_neg_iff,
by rwa neg_neg at this

lemma sub_le_sub_iff_left (a : α) {b c : α} : a - b ≤ a - c ↔ c ≤ b :=
(add_le_add_iff_left _).trans neg_le_neg_iff

lemma sub_le_sub_iff_right (c : α) : a - c ≤ b - c ↔ a ≤ b :=
add_le_add_iff_right _

lemma sub_lt_sub_iff_left (a : α) {b c : α} : a - b < a - c ↔ c < b :=
(add_lt_add_iff_left _).trans neg_lt_neg_iff

lemma sub_lt_sub_iff_right (c : α) : a - c < b - c ↔ a < b :=
add_lt_add_iff_right _

@[simp] lemma sub_nonneg : 0 ≤ a - b ↔ b ≤ a :=
have a - a ≤ a - b ↔ b ≤ a, from sub_le_sub_iff_left a,
by rwa sub_self at this

@[simp] lemma sub_nonpos : a - b ≤ 0 ↔ a ≤ b :=
have a - b ≤ b - b ↔ a ≤ b, from sub_le_sub_iff_right b,
by rwa sub_self at this

@[simp] lemma sub_pos : 0 < a - b ↔ b < a :=
have a - a < a - b ↔ b < a, from sub_lt_sub_iff_left a,
by rwa sub_self at this

@[simp] lemma sub_lt_zero : a - b < 0 ↔ a < b :=
have a - b < b - b ↔ a < b, from sub_lt_sub_iff_right b,
by rwa sub_self at this

lemma le_neg_add_iff_add_le : b ≤ -a + c ↔ a + b ≤ c :=
have -a + (a + b) ≤ -a + c ↔ a + b ≤ c, from add_le_add_iff_left _,
by rwa neg_add_cancel_left at this

lemma le_sub_iff_add_le' : b ≤ c - a ↔ a + b ≤ c :=
by rw [sub_eq_add_neg, add_comm, le_neg_add_iff_add_le]

lemma le_sub_iff_add_le : a ≤ c - b ↔ a + b ≤ c :=
by rw [le_sub_iff_add_le', add_comm]

@[simp] lemma neg_add_le_iff_le_add : -b + a ≤ c ↔ a ≤ b + c :=
have -b + a ≤ -b + (b + c) ↔ a ≤ b + c, from add_le_add_iff_left _,
by rwa neg_add_cancel_left at this

lemma sub_le_iff_le_add' : a - b ≤ c ↔ a ≤ b + c :=
by rw [sub_eq_add_neg, add_comm, neg_add_le_iff_le_add]

lemma sub_le_iff_le_add : a - c ≤ b ↔ a ≤ b + c :=
by rw [sub_le_iff_le_add', add_comm]

@[simp] lemma add_neg_le_iff_le_add : a + -c ≤ b ↔ a ≤ b + c :=
sub_le_iff_le_add

@[simp] lemma add_neg_le_iff_le_add' : a + -b ≤ c ↔ a ≤ b + c :=
sub_le_iff_le_add'

lemma neg_add_le_iff_le_add' : -c + a ≤ b ↔ a ≤ b + c :=
by rw [neg_add_le_iff_le_add, add_comm]

@[simp] lemma neg_le_sub_iff_le_add : -b ≤ a - c ↔ c ≤ a + b :=
le_sub_iff_add_le.trans neg_add_le_iff_le_add'

lemma neg_le_sub_iff_le_add' : -a ≤ b - c ↔ c ≤ a + b :=
by rw [neg_le_sub_iff_le_add, add_comm]

lemma sub_le : a - b ≤ c ↔ a - c ≤ b :=
sub_le_iff_le_add'.trans sub_le_iff_le_add.symm

theorem le_sub : a ≤ b - c ↔ c ≤ b - a :=
le_sub_iff_add_le'.trans le_sub_iff_add_le.symm

@[simp] lemma lt_neg_add_iff_add_lt : b < -a + c ↔ a + b < c :=
have -a + (a + b) < -a + c ↔ a + b < c, from add_lt_add_iff_left _,
by rwa neg_add_cancel_left at this

lemma lt_sub_iff_add_lt' : b < c - a ↔ a + b < c :=
by rw [sub_eq_add_neg, add_comm, lt_neg_add_iff_add_lt]

lemma lt_sub_iff_add_lt : a < c - b ↔ a + b < c :=
by rw [lt_sub_iff_add_lt', add_comm]

@[simp] lemma neg_add_lt_iff_lt_add : -b + a < c ↔ a < b + c :=
have -b + a < -b + (b + c) ↔ a < b + c, from add_lt_add_iff_left _,
by rwa neg_add_cancel_left at this

lemma sub_lt_iff_lt_add' : a - b < c ↔ a < b + c :=
by rw [sub_eq_add_neg, add_comm, neg_add_lt_iff_lt_add]

lemma sub_lt_iff_lt_add : a - c < b ↔ a < b + c :=
by rw [sub_lt_iff_lt_add', add_comm]

lemma neg_add_lt_iff_lt_add_right : -c + a < b ↔ a < b + c :=
by rw [neg_add_lt_iff_lt_add, add_comm]

@[simp] lemma neg_lt_sub_iff_lt_add : -b < a - c ↔ c < a + b :=
lt_sub_iff_add_lt.trans neg_add_lt_iff_lt_add_right

lemma neg_lt_sub_iff_lt_add' : -a < b - c ↔ c < a + b :=
by rw [neg_lt_sub_iff_lt_add, add_comm]

lemma sub_lt : a - b < c ↔ a - c < b :=
sub_lt_iff_lt_add'.trans sub_lt_iff_lt_add.symm

theorem lt_sub : a < b - c ↔ c < b - a :=
lt_sub_iff_add_lt'.trans lt_sub_iff_add_lt.symm

lemma sub_le_self_iff (a : α) {b : α} : a - b ≤ a ↔ 0 ≤ b :=
sub_le_iff_le_add'.trans (le_add_iff_nonneg_left _)

lemma sub_lt_self_iff (a : α) {b : α} : a - b < a ↔ 0 < b :=
sub_lt_iff_lt_add'.trans (lt_add_iff_pos_left _)

end ordered_comm_group

set_option old_structure_cmd true
/-- This is not so much a new structure as a construction mechanism
  for ordered groups, by specifying only the "positive cone" of the group. -/
class nonneg_comm_group (α : Type*) extends add_comm_group α :=
(nonneg : α → Prop)
(pos : α → Prop := λ a, nonneg a ∧ ¬ nonneg (neg a))
(pos_iff : ∀ a, pos a ↔ nonneg a ∧ ¬ nonneg (-a) . order_laws_tac)
(zero_nonneg : nonneg 0)
(add_nonneg : ∀ {a b}, nonneg a → nonneg b → nonneg (a + b))
(nonneg_antisymm : ∀ {a}, nonneg a → nonneg (-a) → a = 0)

namespace nonneg_comm_group
variable [s : nonneg_comm_group α]
include s

@[reducible] instance to_ordered_comm_group : ordered_comm_group α :=
{ le := λ a b, nonneg (b - a),
  lt := λ a b, pos (b - a),
  lt_iff_le_not_le := λ a b, by simp; rw [pos_iff]; simp,
  le_refl := λ a, by simp [zero_nonneg],
  le_trans := λ a b c nab nbc, by simp [-sub_eq_add_neg];
    rw ← sub_add_sub_cancel; exact add_nonneg nbc nab,
  le_antisymm := λ a b nab nba, eq_of_sub_eq_zero $
    nonneg_antisymm nba (by rw neg_sub; exact nab),
  add_le_add_left := λ a b nab c, by simpa [(≤), preorder.le] using nab,
  add_lt_add_left := λ a b nab c, by simpa [(<), preorder.lt] using nab, ..s }

theorem nonneg_def {a : α} : nonneg a ↔ 0 ≤ a :=
show _ ↔ nonneg _, by simp

theorem pos_def {a : α} : pos a ↔ 0 < a :=
show _ ↔ pos _, by simp

theorem not_zero_pos : ¬ pos (0 : α) :=
mt pos_def.1 (lt_irrefl _)

theorem zero_lt_iff_nonneg_nonneg {a : α} :
  0 < a ↔ nonneg a ∧ ¬ nonneg (-a) :=
pos_def.symm.trans (pos_iff α _)

theorem nonneg_total_iff :
  (∀ a : α, nonneg a ∨ nonneg (-a)) ↔
  (∀ a b : α, a ≤ b ∨ b ≤ a) :=
⟨λ h a b, by have := h (b - a); rwa [neg_sub] at this,
 λ h a, by rw [nonneg_def, nonneg_def, neg_nonneg]; apply h⟩

def to_decidable_linear_ordered_comm_group
  [decidable_pred (@nonneg α _)]
  (nonneg_total : ∀ a : α, nonneg a ∨ nonneg (-a))
  : decidable_linear_ordered_comm_group α :=
{ le := (≤),
  lt := (<),
  lt_iff_le_not_le := @lt_iff_le_not_le _ _,
  le_refl := @le_refl _ _,
  le_trans := @le_trans _ _,
  le_antisymm := @le_antisymm _ _,
  le_total := nonneg_total_iff.1 nonneg_total,
  decidable_le := by apply_instance,
  decidable_eq := by apply_instance,
  decidable_lt := by apply_instance,
  ..@nonneg_comm_group.to_ordered_comm_group _ s }

end nonneg_comm_group


import analysis.topology.topological_space
import analysis.topology.continuity

open set function

local notation f`⁻¹` := f.symm

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
  [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

theorem equiv.left_inverse (f : equiv α β) : left_inverse f⁻¹ f := f.left_inv

theorem equiv.right_inverse (f : equiv α β) : function.right_inverse f⁻¹ f := f.right_inv

structure homeo (α β) [topological_space α] [topological_space β] extends equiv α β :=
(fun_con : continuous to_fun)
(inv_con : continuous inv_fun)

instance : has_coe_to_fun (homeo α β) := ⟨_, λ f, f.to_fun⟩

theorem homeo.bijective (f : homeo α β) : bijective f := f.to_equiv.bijective

def homeo.comp : homeo α β → homeo β γ → homeo α γ
| ⟨e1@⟨f₁, g₁, _, _⟩, f₁_con, g₁_con⟩ ⟨e2@⟨f₂, g₂, _, _⟩, f₂_con, g₂_con⟩ :=
⟨e1.trans e2,
  continuous.comp f₁_con f₂_con,
  continuous.comp g₂_con g₁_con⟩

def homeo.symm (h : homeo α β) : homeo β α :=
{ fun_con := h.inv_con, inv_con := h.fun_con, .. h.to_equiv.symm }

lemma homeo.subset_image (e : homeo α β) (s : set α) (t : set β) : t ⊆ e '' s ↔ e.symm '' t ⊆ s :=
equiv.subset_image _ _ _

lemma homeo.symm_image_image (f : homeo α β) (s : set α) : f.symm '' (f '' s) = s :=
equiv.symm_image_image _ _

lemma homeo.image_closure (f : homeo α β) (s : set α) : f '' closure s = closure (f '' s) :=
subset.antisymm
  (image_closure_subset_closure_image f.fun_con)
  ((homeo.subset_image _ _ _).2 $
    calc f.symm '' closure (f '' s) ⊆ closure (f.symm '' (f '' s)) :
        image_closure_subset_closure_image f.inv_con
      ... = closure s : by rw f.symm_image_image s)

lemma homeo.image_compl (f : homeo α β) (s : set α) : f '' -s = -(f '' s)  :=
equiv.image_compl _ _

--instance : has_inv (homeo α α) := ⟨λ f, f.symm⟩
local notation f`⁻¹` := f.symm
local notation f ∘ g := homeo.comp g f

theorem homeo.left_inverse (f : homeo α β) : left_inverse f⁻¹ f := f.left_inv

theorem homeo.right_inverse (f : homeo α β) : function.right_inverse f⁻¹ f := f.right_inv

@[simp] lemma homeo.comp_val (f : homeo α β) (g : homeo β γ) (x) : homeo.comp f g x = g (f x) :=
by cases f with e₁; cases g with e₂; cases e₁; cases e₂; refl

def homeo.id (α) [topological_space α] : homeo α α :=
{ fun_con := continuous_id, inv_con := continuous_id, .. equiv.refl α }

@[simp]
lemma home.id_apply : (homeo.id α : α → α) = id := rfl

@[simp] lemma homeo.id_val (x : α) : (homeo.id α) x = x := rfl

@[extensionality]
theorem homeo.ext {f g : homeo α β} (H : ∀ x, f x = g x) : f = g :=
by cases f; cases g; congr;
   exact equiv.eq_of_to_fun_eq (funext H)

lemma id_circ_f (f : homeo α β) : (homeo.id β) ∘ f = f :=
homeo.ext $ by simp

lemma f_circ_id (f : homeo α β) : f ∘ (homeo.id α) = f :=
homeo.ext $ by simp

lemma homeo_comp_assoc (f: homeo α β) (g : homeo β γ) (h : homeo γ δ) : (h ∘ g) ∘ f = h ∘ (g ∘ f) :=
homeo.ext $ by simp

lemma homeo.mul_left_inv (f: homeo α β) : f ∘ f⁻¹ = homeo.id β :=
homeo.ext
begin
  suffices : ∀ (x : β), f (f⁻¹ x) = x,
    simp [this],
  intro,
  cases f,
  rw homeo.symm,
  apply equiv.apply_inverse_apply,
end

lemma homeo.symm_comp (h : homeo α β) : h⁻¹ ∘ h = homeo.id α :=
begin
  apply homeo.ext,
  simp,
  intros,
  cases h with f f_con f_inv_con,
  rw homeo.symm,
  apply equiv.apply_inverse_apply,
end
universe u
instance aut (α : Type u) [topological_space α] : group (homeo α α) :=
{ mul := (∘),
  mul_assoc := λ a b c, homeo.ext $ by simp,
  one := homeo.id α,
  one_mul := id_circ_f,
  mul_one := f_circ_id,
  inv := homeo.symm,
  mul_left_inv := homeo.symm_comp }

@[simp] theorem aut_mul_val (f g : homeo α α) (x) : (f * g) x = f (g x) :=
homeo.comp_val _ _ _

@[simp] theorem perm_mul_val (f g : equiv.perm α) (x) : (f * g) x = f (g x) :=
equiv.trans_apply _ _ _

@[simp] theorem perm_one_val (x) : (1 : equiv.perm α) x = x := rfl

@[simp] theorem aut_one_val (x) : (1 : homeo α α) x = x := rfl

theorem aut_inv (f : homeo α α) : f⁻¹ = f.symm := rfl


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Keeley Hoek, Patrick Massot
-/
import tactic.monotonicity

namespace tactic

/-- Apply the function `f` given by `e : pexpr` to the local hypothesis `hyp`, which must either be
of the form `a = b` or `a ≤ b`, replacing the type of `hyp` with `f a = f b` or `f a ≤ f b`. If
`hyp` names an inequality then a new goal `monotone f` is created, unless the name of a proof of
this fact is passed as the optional argument `mono_lem`, or the `mono` tactic can prove it.
-/
meta def apply_fun_to_hyp (e : pexpr) (mono_lem : option pexpr) (hyp : expr) : tactic unit :=
do
{ t ← infer_type hyp,
  prf ← match t with
  | `(%%l = %%r) := do
      ltp ← infer_type l,
      mv ← mk_mvar,
      to_expr ``(congr_arg (%%e : %%ltp → %%mv) %%hyp)
  | `(%%l ≤ %%r) := do
       Hmono ← match mono_lem with
        | some mono_lem :=
          tactic.i_to_expr mono_lem
        | none := do
          n ← get_unused_name `mono,
          to_expr ``(monotone %%e) >>= assert n,
          -- In order to resolve implicit arguments in `%%e`,
          -- we build (and discard) the expression `%%n %%hyp` before calling the `mono` tactic.
          swap,
          n ← get_local n,
          to_expr ``(%%n %%hyp),
          swap,
          do { intro_lst [`x, `y, `h], `[try { dsimp }, mono] } <|> swap,
          return n
        end,
       to_expr ``(%%Hmono %%hyp)
  | _ := fail!"failed to apply {e} at {hyp}"
  end,
  clear hyp,
  hyp ← note hyp.local_pp_name none prf,
  -- let's try to force β-reduction at `h`
  try $ tactic.dsimp_hyp hyp simp_lemmas.mk [] { eta := false, beta := true } }

/--
Attempt to "apply" a function `f` represented by the argument `e : pexpr` to the goal.

If the goal is of the form `a ≠ b`, we obtain the new goal `f a ≠ f b`.
If the goal is of the form `a = b`, we obtain a new goal `f a = f b`, and a subsidiary goal
`injective f`.
(We attempt to discharge this subsidiary goal automatically, or using the optional argument.)
If the goal is of the form `a ≤ b` (or similarly for `a < b`), and `f` is an `order_iso`,
we obtain a new goal `f a ≤ f b`.
-/
meta def apply_fun_to_goal (e : pexpr) (lem : option pexpr) : tactic unit :=
do t ← target,
  match t with
  | `(%%l ≠ %%r) := to_expr ``(ne_of_apply_ne %%e) >>= apply >> skip
  | `(¬%%l = %%r) := to_expr ``(ne_of_apply_ne %%e) >>= apply >> skip
  | `(%%l ≤ %%r) := to_expr ``((order_iso.le_iff_le %%e).mp) >>= apply >> skip
  | `(%%l < %%r) := to_expr ``((order_iso.lt_iff_lt %%e).mp) >>= apply >> skip
  | `(%%l = %%r) := focus1 (do
      to_expr ``(%%e %%l), -- build and discard an application, to fill in implicit arguments
      n ← get_unused_name `inj,
      to_expr ``(function.injective %%e) >>= assert n,
      -- Attempt to discharge the `injective f` goal
      (focus1 $
      assumption <|>
        (to_expr ``(equiv.injective) >>= apply >> done) <|>
        -- We require that applying the lemma closes the goal, not just makes progress:
        (lem.mmap (λ l, to_expr l >>= apply) >> done))
        <|> swap, -- return to the main goal if we couldn't discharge `injective f`.
      n ← get_local n,
      apply n,
      clear n)
  | _ := fail!"failed to apply {e} to the goal"
  end

namespace interactive

setup_tactic_parser

/--
Apply a function to an equality or inequality in either a local hypothesis or the goal.

* If we have `h : a = b`, then `apply_fun f at h` will replace this with `h : f a = f b`.
* If we have `h : a ≤ b`, then `apply_fun f at h` will replace this with `h : f a ≤ f b`,
  and create a subsidiary goal `monotone f`.
  `apply_fun` will automatically attempt to discharge this subsidiary goal using `mono`,
  or an explicit solution can be provided with `apply_fun f at h using P`, where `P : monotone f`.
* If the goal is `a ≠ b`, `apply_fun f` will replace this with `f a ≠ f b`.
* If the goal is `a = b`, `apply_fun f` will replace this with `f a = f b`,
  and create a subsidiary goal `injective f`.
  `apply_fun` will automatically attempt to discharge this subsidiary goal using local hypotheses,
  or if `f` is actually an `equiv`,
  or an explicit solution can be provided with `apply_fun f using P`, where `P : injective f`.
* If the goal is `a ≤ b` (or similarly for `a < b`), and `f` is actually an `order_iso`,
  `apply_fun f` will replace the goal with `f a ≤ f b`.
  If `f` is anything else (e.g. just a function, or an `equiv`), `apply_fun` will fail.

Typical usage is:
```lean
open function

example (X Y Z : Type) (f : X → Y) (g : Y → Z) (H : injective $ g ∘ f) :
  injective f :=
begin
  intros x x' h,
  apply_fun g at h,
  exact H h
end
```
 -/
meta def apply_fun (q : parse texpr) (locs : parse location) (lem : parse (tk "using" *> texpr)?)
  : tactic unit :=
locs.apply (apply_fun_to_hyp q lem) (apply_fun_to_goal q lem)

add_tactic_doc
{ name       := "apply_fun",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.apply_fun],
  tags       := ["context management"] }

end interactive

end tactic


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.fintype.card
import data.finset.lattice

/-!
# Lemmas relating fintypes and order/lattice structure.

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

open function
open_locale nat

universes u v

variables {α β γ : Type*}

namespace finset
variables [fintype α] {s : finset α}

/-- A special case of `finset.sup_eq_supr` that omits the useless `x ∈ univ` binder. -/
lemma sup_univ_eq_supr [complete_lattice β] (f : α → β) : finset.univ.sup f = supr f :=
(sup_eq_supr _ f).trans $ congr_arg _ $ funext $ λ a, supr_pos (mem_univ _)

/-- A special case of `finset.inf_eq_infi` that omits the useless `x ∈ univ` binder. -/
lemma inf_univ_eq_infi [complete_lattice β] (f : α → β) : finset.univ.inf f = infi f :=
sup_univ_eq_supr (by exact f : α → βᵒᵈ)

@[simp] lemma fold_inf_univ [semilattice_inf α] [order_bot α] (a : α) :
  finset.univ.fold (⊓) a (λ x, x) = ⊥ :=
eq_bot_iff.2 $ ((finset.fold_op_rel_iff_and $ @_root_.le_inf_iff α _).1 le_rfl).2 ⊥ $
  finset.mem_univ _

@[simp] lemma fold_sup_univ [semilattice_sup α] [order_top α] (a : α) :
  finset.univ.fold (⊔) a (λ x, x) = ⊤ :=
@fold_inf_univ αᵒᵈ ‹fintype α› _ _ _

end finset

open finset function

lemma finite.exists_max [finite α] [nonempty α] [linear_order β] (f : α → β) :
 ∃ x₀ : α, ∀ x, f x ≤ f x₀ :=
by { casesI nonempty_fintype α, simpa using exists_max_image univ f univ_nonempty }

lemma finite.exists_min [finite α] [nonempty α] [linear_order β] (f : α → β) :
  ∃ x₀ : α, ∀ x, f x₀ ≤ f x :=
by { casesI nonempty_fintype α, simpa using exists_min_image univ f univ_nonempty }


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

import data.fintype.card
import data.polynomial.ring_division
import group_theory.specific_groups.cyclic
import algebra.geom_sum

/-!
# Integral domains

Assorted theorems about integral domains.

## Main theorems

* `is_cyclic_of_subgroup_is_domain` : A finite subgroup of the units of an integral domain
                                            is cyclic.
* `field_of_is_domain`              : A finite integral domain is a field.

## Tags

integral domain, finite integral domain, finite field
-/

section

open finset polynomial function
open_locale big_operators nat

section cancel_monoid_with_zero
-- There doesn't seem to be a better home for these right now
variables {M : Type*} [cancel_monoid_with_zero M] [fintype M]

lemma mul_right_bijective_of_fintype₀ {a : M} (ha : a ≠ 0) : bijective (λ b, a * b) :=
fintype.injective_iff_bijective.1 $ mul_right_injective₀ ha

lemma mul_left_bijective_of_fintype₀ {a : M} (ha : a ≠ 0) : bijective (λ b, b * a) :=
fintype.injective_iff_bijective.1 $ mul_left_injective₀ ha

/-- Every finite nontrivial cancel_monoid_with_zero is a group_with_zero. -/
def group_with_zero_of_fintype (M : Type*) [cancel_monoid_with_zero M] [decidable_eq M] [fintype M]
  [nontrivial M] : group_with_zero M :=
{ inv := λ a, if h : a = 0 then 0 else fintype.bij_inv (mul_right_bijective_of_fintype₀ h) 1,
  mul_inv_cancel := λ a ha,
    by { simp [has_inv.inv, dif_neg ha], exact fintype.right_inverse_bij_inv _ _ },
  inv_zero := by { simp [has_inv.inv, dif_pos rfl] },
  ..‹nontrivial M›,
  ..‹cancel_monoid_with_zero M› }

end cancel_monoid_with_zero

variables {R : Type*} {G : Type*}

section ring

variables [ring R] [is_domain R] [fintype R]

/-- Every finite domain is a division ring.

TODO: Prove Wedderburn's little theorem,
which shows a finite domain is in fact commutative, hence a field. -/
def division_ring_of_is_domain (R : Type*) [ring R] [is_domain R] [decidable_eq R] [fintype R] :
  division_ring R :=
{ ..show group_with_zero R, from group_with_zero_of_fintype R,
  ..‹ring R› }

end ring

variables [comm_ring R] [is_domain R] [group G] [fintype G]

lemma card_nth_roots_subgroup_units (f : G →* R) (hf : injective f) {n : ℕ} (hn : 0 < n) (g₀ : G) :
  ({g ∈ univ | g ^ n = g₀} : finset G).card ≤ (nth_roots n (f g₀)).card :=
begin
  haveI : decidable_eq R := classical.dec_eq _,
  refine le_trans _ (nth_roots n (f g₀)).to_finset_card_le,
  apply card_le_card_of_inj_on f,
  { intros g hg,
    rw [sep_def, mem_filter] at hg,
    rw [multiset.mem_to_finset, mem_nth_roots hn, ← f.map_pow, hg.2] },
  { intros, apply hf, assumption }
end

/-- A finite subgroup of the unit group of an integral domain is cyclic. -/
lemma is_cyclic_of_subgroup_is_domain (f : G →* R) (hf : injective f) : is_cyclic G :=
begin
  classical,
  apply is_cyclic_of_card_pow_eq_one_le,
  intros n hn,
  convert (le_trans (card_nth_roots_subgroup_units f hf hn 1) (card_nth_roots n (f 1)))
end

/-- The unit group of a finite integral domain is cyclic.

To support `units ℤ` and other infinite monoids with finite groups of units, this requires only
`fintype (units R)` rather than deducing it from `fintype R`. -/
instance [fintype (units R)] : is_cyclic (units R) :=
is_cyclic_of_subgroup_is_domain (units.coe_hom R) $ units.ext

/-- Every finite integral domain is a field. -/
def field_of_is_domain [decidable_eq R] [fintype R] : field R :=
{ ..division_ring_of_is_domain R, ..‹comm_ring R› }

section

variables (S : subgroup (units R)) [fintype S]

/-- A finite subgroup of the units of an integral domain is cyclic. -/
instance subgroup_units_cyclic : is_cyclic S :=
begin
  refine is_cyclic_of_subgroup_is_domain ⟨(coe : S → R), _, _⟩
    (units.ext.comp subtype.val_injective),
  { simp },
  { intros, simp },
end

end

lemma card_fiber_eq_of_mem_range {H : Type*} [group H] [decidable_eq H]
  (f : G →* H) {x y : H} (hx : x ∈ set.range f) (hy : y ∈ set.range f) :
  (univ.filter $ λ g, f g = x).card = (univ.filter $ λ g, f g = y).card :=
begin
  rcases hx with ⟨x, rfl⟩,
  rcases hy with ⟨y, rfl⟩,
  refine card_congr (λ g _, g * x⁻¹ * y) _ _ (λ g hg, ⟨g * y⁻¹ * x, _⟩),
  { simp only [mem_filter, one_mul, monoid_hom.map_mul, mem_univ, mul_right_inv,
      eq_self_iff_true, monoid_hom.map_mul_inv, and_self, forall_true_iff] {contextual := tt} },
  { simp only [mul_left_inj, imp_self, forall_2_true_iff], },
  { simp only [true_and, mem_filter, mem_univ] at hg,
    simp only [hg, mem_filter, one_mul, monoid_hom.map_mul, mem_univ, mul_right_inv,
      eq_self_iff_true, exists_prop_of_true, monoid_hom.map_mul_inv, and_self,
      mul_inv_cancel_right, inv_mul_cancel_right], }
end

/-- In an integral domain, a sum indexed by a nontrivial homomorphism from a finite group is zero.
-/
lemma sum_hom_units_eq_zero (f : G →* R) (hf : f ≠ 1) : ∑ g : G, f g = 0 :=
begin
  classical,
  obtain ⟨x, hx⟩ : ∃ x : monoid_hom.range f.to_hom_units,
    ∀ y : monoid_hom.range f.to_hom_units, y ∈ submonoid.powers x,
    from is_cyclic.exists_monoid_generator,
  have hx1 : x ≠ 1,
  { rintro rfl,
    apply hf,
    ext g,
    rw [monoid_hom.one_apply],
    cases hx ⟨f.to_hom_units g, g, rfl⟩ with n hn,
    rwa [subtype.ext_iff, units.ext_iff, subtype.coe_mk, monoid_hom.coe_to_hom_units,
      one_pow, eq_comm] at hn, },
  replace hx1 : (x : R) - 1 ≠ 0,
    from λ h, hx1 (subtype.eq (units.ext (sub_eq_zero.1 h))),
  let c := (univ.filter (λ g, f.to_hom_units g = 1)).card,
  calc ∑ g : G, f g
      = ∑ g : G, f.to_hom_units g : rfl
  ... = ∑ u : units R in univ.image f.to_hom_units,
    (univ.filter (λ g, f.to_hom_units g = u)).card • u : sum_comp (coe : units R → R) f.to_hom_units
  ... = ∑ u : units R in univ.image f.to_hom_units, c • u :
    sum_congr rfl (λ u hu, congr_arg2 _ _ rfl) -- remaining goal 1, proven below
  ... = ∑ b : monoid_hom.range f.to_hom_units, c • ↑b : finset.sum_subtype _
      (by simp ) _
  ... = c • ∑ b : monoid_hom.range f.to_hom_units, (b : R) : smul_sum.symm
  ... = c • 0 : congr_arg2 _ rfl _            -- remaining goal 2, proven below
  ... = 0 : smul_zero _,
  { -- remaining goal 1
    show (univ.filter (λ (g : G), f.to_hom_units g = u)).card = c,
    apply card_fiber_eq_of_mem_range f.to_hom_units,
    { simpa only [mem_image, mem_univ, exists_prop_of_true, set.mem_range] using hu, },
    { exact ⟨1, f.to_hom_units.map_one⟩ } },
  -- remaining goal 2
  show ∑ b : monoid_hom.range f.to_hom_units, (b : R) = 0,
  calc ∑ b : monoid_hom.range f.to_hom_units, (b : R)
      = ∑ n in range (order_of x), x ^ n :
    eq.symm $ sum_bij (λ n _, x ^ n)
      (by simp only [mem_univ, forall_true_iff])
      (by simp only [implies_true_iff, eq_self_iff_true, subgroup.coe_pow, units.coe_pow, coe_coe])
      (λ m n hm hn, pow_injective_of_lt_order_of _
        (by simpa only [mem_range] using hm)
        (by simpa only [mem_range] using hn))
      (λ b hb, let ⟨n, hn⟩ := hx b in ⟨n % order_of x, mem_range.2 (nat.mod_lt _ (order_of_pos _)),
        by rw [← pow_eq_mod_order_of, hn]⟩)
  ... = 0 : _,
  rw [← mul_left_inj' hx1, zero_mul, ← geom_sum, geom_sum_mul, coe_coe],
  norm_cast,
  simp [pow_order_of_eq_one],
end

/-- In an integral domain, a sum indexed by a homomorphism from a finite group is zero,
unless the homomorphism is trivial, in which case the sum is equal to the cardinality of the group.
-/
lemma sum_hom_units (f : G →* R) [decidable (f = 1)] :
  ∑ g : G, f g = if f = 1 then fintype.card G else 0 :=
begin
  split_ifs with h h,
  { simp [h, card_univ] },
  { exact sum_hom_units_eq_zero f h }
end

end


import analysis.topology.continuity
import analysis.topology.topological_space
import analysis.topology.infinite_sum
import analysis.topology.topological_structures
import analysis.topology.uniform_space
import analysis.real
import data.real.basic tactic.norm_num
import data.set.basic
import Topology.Material.subsets

universe u

open set filter lattice classical

noncomputable theory

namespace path

variables {α  : Type*} [topological_space α ] ( x y : α )

---- PATH and I01 DEFINITION
/- The following definition of path was created by Mario Carneiro -/

def I01 := {x : ℝ | 0 ≤ x ∧ x ≤ 1}

instance : topological_space I01 := by unfold I01; apply_instance
instance : has_zero I01 := ⟨⟨0, le_refl _, zero_le_one⟩⟩
instance : has_one I01 := ⟨⟨1, zero_le_one, le_refl _⟩⟩

structure path {α} [topological_space α] (x y : α) :=
(to_fun : I01 → α)
(at_zero : to_fun 0 = x)
(at_one : to_fun 1 = y)
(cont : continuous to_fun)

instance {α} [topological_space α] (x y : α) :
has_coe_to_fun (path x y) := ⟨_, path.to_fun⟩

----------

--attribute [class] path

variables ( z w x0 : α )
variables ( g1 : path x y ) ( g2 : path z w)
variable l : I01 → α

-- PATH INTERFACE

@[simp]
lemma start_pt_path {α} [topological_space α ] { x y : α } ( f : path x y) : f.to_fun 0 = x := f.2

@[simp]
lemma end_pt_path {α} [topological_space α ] { x y : α } ( f : path x y) : f.to_fun 1 = y := f.3

-- for later paths homotopy -- checking ending points -- Can Remove
def equal_of_pts (f g : I01 → α ) : Prop := f 0 = g 0 ∧ f 1 = g 1

def equal_of_pts_path : Prop := equal_of_pts g1 g2

def check_pts ( x y : α ) ( g : I01 → α ) := g 0 = x ∧ g 1 = y

def check_pts_of_path ( x y : α ) ( h : path z w ) := check_pts x y h.to_fun

def equal_of_path  : Prop := g1.to_fun = g2.to_fun  -- == ?

------

theorem path_equal {α} [topological_space α ] { x y : α } {f  g: path x y} : f = g ↔ f.to_fun = g.to_fun :=
begin split, intro H, rw H, intro H2, cases f, cases g, cc,  end

-- for later paths homotopy (do not Remove)
def is_path ( x y : α ) ( f : I01 → α ) : Prop := f 0 = x ∧ f 1 = y ∧ continuous f

def to_path { x y : α} ( f : I01 → α ) ( H : is_path x y f) : path x y :=
{  to_fun := f,
    at_zero := H.left,
    at_one := H.right.left,
    cont := H.right.right
}

--- Can Remove
lemma cont_of_path ( g : path z w ) : continuous g.to_fun := g.cont

--- Can Remove
def fun_of_path {α} [topological_space α ]  { x1 x2 : α  } ( g : path x1 x2 ) : I01 → α    := g.to_fun

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

--- COMPOSITION OF PATHS

variable A : set ℝ
variables a b : I01
variable Hab : a.val < b.val

----- Can Remove (unneded with T _ _ _ layering )
definition S (a b : ℝ) : set ℝ := {x : ℝ | a ≤ x ∧ x ≤ b}

lemma lemma1 {a : I01} {b : I01} (Hab : a.val < b.val) :  a.val ∈ (S a.val b.val) :=
begin
  show a.val ≤ a.val ∧ a.val ≤ b.val,
  split,
    exact le_of_eq rfl,
    exact le_of_lt Hab,
end
lemma lemma2 {a : I01} {b : I01} (Hab : a.val < b.val) :  b.val ∈ (S a.val b.val) :=
begin
  show a.val ≤ b.val ∧ b.val ≤ b.val,
  split,
    exact le_of_lt Hab,
    exact le_of_eq rfl,
end

lemma I01_bound (a : I01) (b : I01) (x : S a.val b.val) :
0 ≤ x.val ∧ x.val ≤ 1 :=
begin
  have H := x.property,
  split,
    exact le_trans (a.property.1 : 0 ≤ a.val) (x.property.1 : a.val ≤ x.val),
    exact le_trans (x.property.2 : x.val ≤ b.val) (b.property.2)
end

lemma lemma_sub_ba (a b : I01) {Hab : a.val < b.val } : b.val - a.val ∈ S 0 (b.val - a.val) :=
begin split, exact sub_nonneg.2 (le_of_lt Hab), trivial end
--------------------------------------------

-------------------------------------
-- Useful ℝ result

--- Continuity of linear functions

theorem real.continuous_add_const (r : ℝ) : continuous (λ x : ℝ, x + r) :=
begin
  have H₁ : continuous (λ x, (x,r) : ℝ → ℝ × ℝ),
    exact continuous.prod_mk continuous_id continuous_const,
  exact continuous.comp H₁ continuous_add',
end

theorem real.continuous_div_const (r : ℝ) : continuous (λ x : ℝ, x / r) :=
begin
  conv in (_ / r) begin
    rw div_eq_mul_inv,
  end,
  have H₁ : continuous (λ x, (x,r⁻¹) : ℝ → ℝ × ℝ),
    exact continuous.prod_mk continuous_id continuous_const,
  exact continuous.comp H₁ continuous_mul',
end

theorem real.continuous_scale (a b : ℝ) : continuous (λ x : ℝ, (x + a) / b) :=
continuous.comp (real.continuous_add_const a) (real.continuous_div_const b)

theorem real.continuous_mul_const (r : ℝ) : continuous (λ x : ℝ, r*x) :=
begin
    have H₁ : continuous (λ x, (r,x) : ℝ → ℝ × ℝ),
        exact continuous.prod_mk continuous_const continuous_id,
    show continuous ( (λ p : ℝ × ℝ , p.1 * p.2)  ∘  (λ (x : ℝ), (r,x))),
    refine continuous.comp H₁  continuous_mul' ,

end

theorem real.continuous_mul_const_right (r : ℝ) : continuous (λ x : ℝ, x*r) :=
begin
    have H₁ : continuous (λ x, (x,r) : ℝ → ℝ × ℝ),
        exact continuous.prod_mk continuous_id continuous_const,
    refine continuous.comp H₁ continuous_mul' ,

end

theorem real.continuous_linear (m q : ℝ) : continuous (λ x : ℝ, m*x + q) :=
begin
    exact continuous.comp (real.continuous_mul_const m) (real.continuous_add_const q),
end

--- Definition of closed intervals in ℝ

def int_clos { r s : ℝ } ( Hrs : r < s ) : set ℝ := {x : ℝ  | r ≤ x ∧ x ≤ s}

theorem is_closed_int_clos { r s : ℝ } ( Hrs : r < s ) : is_closed (int_clos Hrs) :=
begin
let L := {x : ℝ | x ≤ s} ,
let R := {x : ℝ | r ≤ x} ,
have C1 : is_closed L, exact is_closed_le' s,
have C2 : is_closed R, exact is_closed_ge' r,
have Int : int_clos Hrs =  R ∩ L,
    unfold has_inter.inter set.inter , unfold int_clos, simp,
rw Int, exact is_closed_inter C2 C1,
end

lemma is_closed_I01 : is_closed I01 :=
begin exact @is_closed_int_clos 0 1 (by norm_num) end

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

-- Define closed subintervals of I01 = [0, 1]
definition T ( a b : ℝ ) ( Hab : a < b ) : set I01 :=  { x : I01 | a ≤ x.val ∧ x.val ≤ b }

-- Prove any T r s Hrs is closed in I01
lemma T_is_closed  { r s : ℝ } ( Hrs : r < s )  : is_closed (T r s Hrs) :=
begin
let R := {x : ↥I01 | r ≤ x.val }, let L := {x : ↥I01 |  x.val ≤ s } ,
have C1 : is_closed L,
  rw is_closed_induced_iff,
  existsi {x : ℝ | 0 ≤ x ∧ x ≤ (min 1 s)},
  split,
    exact is_closed_inter (is_closed_ge' 0)  (is_closed_le' _),
    apply set.ext,intro x,
    show x.val ≤ s ↔ 0 ≤ x.val ∧ x.val ≤ min 1 s,
    split,
      intro H,
      split,
        exact x.property.1,
        apply le_min,exact x.property.2,assumption,
      intro H,
    exact le_trans H.2 (min_le_right _ _),
have C2 : is_closed R,
    rw is_closed_induced_iff,
    existsi {x : ℝ | (max 0 r) ≤ x ∧ x ≤ 1},
    split,
      exact is_closed_inter (is_closed_ge' _)  (is_closed_le' 1),
      apply set.ext, intro x,
      show r ≤ x.val ↔ max 0 r ≤ x.val ∧ x.val ≤ 1,
      split,
        intro H,
        split,
          exact max_le x.2.1 H,
          exact x.2.2,
        intro H, exact (max_le_iff.1 H.1).2,

have Int : T r s Hrs = set.inter R L, unfold T set.inter, simp,
exact (is_closed_inter C2 C1),
end

-- Reparametrisation from T _ _ _ to I01
definition par {r s : ℝ} (Hrs : r < s) : T r s Hrs → I01 :=
λ x, ⟨ (x.val - r)/(s - r) , begin
have D1 : 0 < (s - r) ,
    apply sub_pos.2 Hrs,
have D2 : 0 < (s - r)⁻¹,
    exact inv_pos D1,
have N1 : 0 ≤ ((x.val : ℝ ) - r),
    exact sub_nonneg.2 (x.property.1),
have N2 : (x.val : ℝ )- r ≤ s - r,
    have this : -r ≤ -r, trivial,
    show (x.val : ℝ ) + - r ≤ s + - r,
    exact add_le_add (x.property.2) this,
split,
    show  0 ≤ ((x.val : ℝ ) - r) * (s - r)⁻¹,
        exact mul_nonneg N1 (le_of_lt D2),
    have H1 : 0 < (s - r),
        exact sub_pos.2 Hrs,
    have H2 : ((x.val : ℝ ) - r) / (s - r) ≤ (s - r) / (s - r),
    exact @div_le_div_of_le_of_pos _ _ ((x.val : ℝ ) - r) (s - r) (s - r) N2 H1,
    rwa [@div_self _ _ (s - r) (ne.symm ( @ne_of_lt _ _ 0 (s - r) H1) ) ] at H2

end ⟩

-- Continuity of reparametrisation (later employed in compositions of path/homotopy)
lemma continuous_par {r s : ℝ} (Hrs : r < s) : continuous ( par Hrs ) :=
begin unfold par,
  apply continuous_subtype_mk,
  show continuous (λ (x :  ↥(T r s Hrs)), ((x.1:ℝ ) - r) / (s - r)),
  show continuous ((λ ( y: ℝ ), (y - r) / (s - r)) ∘ (λ (x : ↥(T r s Hrs)), x.val.val)),
  have H : continuous (λ (x : ↥(T r s Hrs)), x.val.val),
    exact continuous.comp continuous_subtype_val continuous_subtype_val ,
  exact continuous.comp H (real.continuous_scale (-r) (s-r)),

end

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

-- Define T1 = [0, 1/2] and  T2 = [1/2, 1]

def T1 : set I01 := T 0 (1/2: ℝ ) ( by norm_num  )

def T2 : set I01 := T (1/2: ℝ ) 1 ( by norm_num  )

lemma T1_is_closed : is_closed T1 :=
begin unfold T1, exact T_is_closed _, end

lemma T2_is_closed : is_closed T2 :=
begin unfold T2, exact T_is_closed _, end

lemma help_T1 : (0 : I01) ∈ T 0 (1/2) T1._proof_1 :=
begin unfold T, rw mem_set_of_eq, show 0 ≤ (0:ℝ)  ∧ ( 0:ℝ ) ≤ 1 / 2, norm_num,  end

lemma help_T2 : (1 : I01) ∈ T (1 / 2) 1 T2._proof_1 :=
begin unfold T, rw mem_set_of_eq, split, show 1/2 ≤ (1:ℝ) , norm_num, show (1:ℝ )≤ 1, norm_num,  end

lemma help_01 : (1 / 2 :ℝ) ∈ I01 := begin unfold I01, rw mem_set_of_eq, norm_num end

lemma help_02 : (1:I01) ∉ T1 := begin unfold T1 T,rw mem_set_of_eq, show ¬(0 ≤ (1:ℝ ) ∧ (1:ℝ) ≤ 1 / 2) , norm_num,  end

lemma help_half_T1 : ( ⟨ 1/2, help_01⟩  : I01) ∈ T 0 (1/2) T1._proof_1 :=
begin unfold T, exact set.mem_sep
    (begin simp [has_mem.mem, -one_div_eq_inv], unfold set.mem, norm_num, end )
    (begin norm_num end ),
end

lemma help_half_T2 : ( ⟨ 1/2, help_01⟩  : I01) ∈ T (1/2) 1 T2._proof_1 :=
begin unfold T, exact set.mem_sep
    (begin simp [has_mem.mem, -one_div_eq_inv], unfold set.mem, norm_num, end )
    (begin norm_num end ),
end

--- Intersection and covering of T1, T2

lemma inter_T : set.inter T1 T2 = { x : I01 | x.val = 1/2 }
:=
begin unfold T1 T2 T set.inter, simp [mem_set_of_eq, -one_div_eq_inv], apply set.ext, intro x, split,
    rw mem_set_of_eq , rw mem_set_of_eq, simp [-one_div_eq_inv], intros A B C D, have H : x.val < 1 / 2 ∨ x.val = 1/2,
        exact  lt_or_eq_of_le B, exact le_antisymm  B C,
    rw mem_set_of_eq , rw mem_set_of_eq, intro H, rw H, norm_num,
end

lemma cover_I01 : T1 ∪ T2 = set.univ :=
begin
unfold univ, unfold has_union.union , unfold T1 T2 T, apply set.ext, intro x,unfold set.union,  simp [mem_set_of_eq , -one_div_eq_inv],
    split, intro H, simp [has_mem.mem],
intro B, simp [has_mem.mem] at B, unfold set.mem at B, --unfold I01 at x,
have H : 0≤ x.val ∧ x.val ≤ 1, exact x.property, simp [or_iff_not_imp_left, -one_div_eq_inv],
intro nL, have H2 : (1 / 2 :ℝ )< x.val, exact nL H.1, exact ⟨ le_of_lt H2, H.2 ⟩ ,
end

---- Lemmas to simplify evaluations of par
@[simp]
lemma eqn_start : par T1._proof_1 ⟨0, help_T1⟩ = 0 :=
begin unfold par, simp [-one_div_eq_inv], exact subtype.mk_eq_mk.2 (begin exact zero_div _,  end  ), end

@[simp]
lemma eqn_1 : par T1._proof_1 ⟨⟨1 / 2, begin unfold I01, rw mem_set_of_eq, norm_num end⟩, begin unfold T, rw mem_set_of_eq, show 0 ≤ (1/2 : ℝ ) ∧ (1/2 : ℝ ) ≤ 1 / 2 ,  norm_num end ⟩
= 1 :=  begin unfold par, simp [-one_div_eq_inv], exact subtype.mk_eq_mk.2 (begin exact div_self (begin norm_num, end), end) end

@[simp]
lemma eqn_2 : par T2._proof_1 ⟨⟨1 / 2, help_01  ⟩, begin unfold T, rw mem_set_of_eq, show 1/2 ≤ (1/2 : ℝ ) ∧ (1/2 : ℝ ) ≤ 1  ,  norm_num end⟩
= 0 := begin unfold par, simp [-one_div_eq_inv], exact subtype.mk_eq_mk.2 (by refl) end

@[simp]
lemma eqn_end : par T2._proof_1 ⟨1, help_T2 ⟩ = 1 :=
begin unfold par, exact subtype.mk_eq_mk.2 ( begin show ( ( 1:ℝ ) - 1 / 2) / (1 - 1 / 2) = 1,  norm_num, end ),  end

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

-- Definition and continuity of general / T1 / T2 reparametrisation of path function (path.to_fun)
---------- to be used with cont_of_paste for path/homotopy composition

def fgen_path {α } [topological_space α ] { x y : α }{r s : ℝ} (Hrs : r < s)(f : path x y ) : T r s Hrs → α :=
λ t, f.to_fun ( par Hrs t)

lemma pp_cont { x y : α }{r s : ℝ} (Hrs : r < s)(f : path x y ) : continuous (fgen_path Hrs f) := begin
unfold fgen_path,
exact continuous.comp (continuous_par Hrs) f.cont,
end

definition fa_path { x y : α } (f : path x y ) : T1 → α := λ t, f.to_fun (par T1._proof_1  t)

lemma CA { x y : α } (f : path x y ) : continuous ( fa_path f):=
begin
unfold fa_path, exact continuous.comp (continuous_par T1._proof_1 ) f.cont,
end

definition fb_path { x y : α }(f : path x y ) : T2 → α := λ t, f.to_fun (par T2._proof_1  t)

lemma CB { x y : α } (f : path x y ) :  continuous ( fb_path f):=
begin
unfold fb_path, exact continuous.comp (continuous_par T2._proof_1 ) f.cont,
end

----- Composition of Path function

definition comp_of_path {α} [topological_space α] { x y z : α } ( f : path x y )( g : path y z ) : path x z :=
{   to_fun := λ t, ( paste  cover_I01 ( fa_path f ) ( fb_path g ) ) t ,

    at_zero :=
    begin unfold paste, rw dif_pos,
    unfold fa_path,
    rw eqn_start, exact f.at_zero,
    end,

    at_one :=
    begin unfold paste, rw dif_neg,
    unfold fb_path, show @path.to_fun α _inst_2 y z g (par  T2._proof_1 (@subtype.mk ↥I01 (λ (x : ↥I01), x ∈ T2) 1 help_T2)) = z,
    simp [eqn_end], --- exact g.at_one,
    exact help_02,
    end,

    cont :=
    begin
    -- both images are f.to_fun 1 = g.to_fun 0 = y
    have HM :  match_of_fun (fa_path f) (fb_path g),
        unfold match_of_fun,  intros x B1 B2,
        have Int : x ∈ set.inter T1 T2, exact ⟨ B1 , B2 ⟩ ,
        rwa [inter_T] at Int,
        have V : x.val = 1/2, rwa [mem_set_of_eq] at Int,
        have xeq : x = (⟨ 1/2 , help_01 ⟩ : I01 ) , apply subtype.eq, rw V,
        unfold fa_path fb_path, simp [xeq, -one_div_eq_inv],
        show f.to_fun (par T1._proof_1 ⟨⟨1 / 2, help_01⟩, help_half_T1⟩) = g.to_fun (par T2._proof_1 ⟨⟨1 / 2, help_01⟩, help_half_T2⟩),
        simp [eqn_1, eqn_2, -one_div_eq_inv],  --rw [f.at_one, g.at_zero],
    -- Use pasting lemma via closed T1, T2
    exact cont_of_paste T1_is_closed T2_is_closed HM (CA f) (CB g),
    end
}

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

--- INVERSE OF PATH

--- Similarly to Composition of Path: define par_inv, prove continuity and create some [simp] lemmas

lemma inv_in_I01 (x : I01) : 1 - x.val ∈ I01 :=
begin unfold I01, rw mem_set_of_eq, split, simp [-sub_eq_add_neg] , exact x.2.2, simp, exact x.2.1, end

definition par_inv : I01 → I01 :=  λ x, ⟨ 1 - x.val , inv_in_I01 x ⟩

@[simp] lemma eqn_1_par_inv : par_inv 0 = 1 :=  by refl

@[simp] lemma eqn_2_par_inv : par_inv 1 = 0 := by refl

lemma help_inv (y : ℝ ) : ( 1 - y) = (-1) * y + 1 := by simp

theorem continuous_par_inv : continuous (par_inv ) :=
begin unfold par_inv, apply continuous_subtype_mk,
show continuous ((λ ( y: ℝ ), 1 - y ) ∘ (λ (x : ↥I01), x.val)),
refine continuous.comp continuous_subtype_val _, --
conv in ( (1:ℝ)-_)
    begin
    rw help_inv,
    end ,
exact continuous.comp (real.continuous_mul_const (-1) ) (real.continuous_add_const 1),
end

definition inv_of_path {α} [topological_space α] { x y : α } ( f : path x y ) : path y x :=
{   to_fun := λ t , f.to_fun ( par_inv t ) , --  or better f.to_fun ∘ par_inv

    at_zero := begin rw eqn_1_par_inv, exact f.at_one end ,

    at_one := begin rw eqn_2_par_inv, exact f.at_zero end,

    cont := by exact continuous.comp continuous_par_inv f.cont

}

-- LOOP

-- Definition of loop
--- (Extends path?)
------------

/-
structure loop {α} [topological_space α] (x : α) { y : α } extends  path x y  :=
(base_pt : to_fun 0 = x ∧ to_fun 1 = x) -/

/- structure loop {α} [topological_space α] (x : α) :=
(to_fun : I01 → α)
(base_pt : to_fun 0 = x ∧ to_fun 1 = x)
(cont : continuous to_fun)
-/

def is_loop ( g : path x y) : Prop := x = y -- function to check loop

/-
structure loop3 {α} [topological_space α] (x : α) extends path x x :=
(base_pt : to_fun 0 = x ∧ to_fun 1 = x) -/
--(base_pt : is_loop )

--@[simp]
def loop {α} [topological_space α] (x0 : α) : Type* := path x0 x0

def loop_const {α} [topological_space α] (x0 : α) : loop x0 :=
{   to_fun:= λ t, x0 ,
    at_zero :=  by refl ,
    at_one := by refl,
    cont := continuous_const
}

-- lemma
-- instance loop_is_path (l1 : loop3 x0) : path x0 x0  := l1.to_path

end path

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

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

namespace homotopy
open path

variables {α  : Type*} [topological_space α ]
variables {β  : Type*} [topological_space β ] ( x y : β  )
variables ( z w x0 : β  )
variable s : I01

def P := topological_space (I01 × α )

-- HOMOTOPY

-- General Homotopy
structure homotopy {α} {β} [topological_space α] [topological_space β] (f : α → β)
( hcf : continuous f) (g : α → β) ( hcg : continuous g) :=
(to_fun : I01 × α →  β ) -- for product topology
(at_zero : ( λ x, to_fun ( 0 , x) ) = f )
(at_one : ( λ x, to_fun ( 1 , x) ) = g)
(cont :  continuous  to_fun )   -- w.r.t product topology

structure path_homotopy {β} [topological_space β] { x y : β } ( f : path x y) ( g : path x y) :=
(to_fun : I01 × I01 →  β )
(path_s : ∀ s : I01, is_path x y ( λ t, to_fun (s, t) ) )
(at_zero : ∀ y, to_fun (0,y) = f.to_fun y )
(at_one :  ∀ y, to_fun (1,y) = g.to_fun y)
(cont : continuous to_fun)

@[simp]
lemma at_zero_path_hom {β} [topological_space β] { x y : β } { f : path x y} { g : path x y} {F : path_homotopy f g} (y : I01) :
F.to_fun (0, y) = path.to_fun f y := F.3 y

@[simp]
lemma at_one_path_hom {β} [topological_space β] { x y : β } { f : path x y} { g : path x y} {F : path_homotopy f g} (y : I01) :
F.to_fun (1, y) = path.to_fun g y := F.4 y

@[simp]
lemma at_pt_zero_hom {β} [topological_space β] { x y : β } { f : path x y} { g : path x y} {F : path_homotopy f g} (s : I01) :
F.to_fun (s, 0) = x :=  begin exact (F.2 s).1 end

@[simp]
lemma at_pt_one_hom {β} [topological_space β] { x y : β } { f : path x y} { g : path x y} {F : path_homotopy f g} (s : I01) :
F.to_fun (s, 1) = y :=  begin exact (F.2 s).2.1  end

/- Alternative definitions
structure path_homotopy2 {β} [topological_space β] { x y : β } ( f : path x y) ( g : path x y) :=
(to_fun : I01 ×  I01 →  β )
(path_s : ∀ s : I01,  to_fun (s ,0) = x ∧ to_fun (s, 1) = y  )
(at_zero : ∀ y, to_fun 0 y = f.to_fun y )
(at_one :  ∀ y, to_fun 1 y = g.to_fun y)
(cont : continuous to_fun)

structure path_homotopy3 {β} [topological_space β] { x y : β } ( f : path x y) ( g : path x y) :=
(to_fun : I01 → I01 →  β )
(path_s : ∀ s : I01, is_path x y ( λ t, to_fun s t ) )  -- ∀ s, points match and continuous (λ t, to_fun s t )
(at_zero : to_fun 0  = f.to_fun  )
(at_one :  to_fun 1  = g.to_fun )
(cont : continuous to_fun) -/

variables (f : path x y) (g : path x y)
variable F : path_homotopy f g

def hom_to_path { x y : β } { f g : path x y }
( F : path_homotopy f g ) (s : I01) : path x y :=
to_path ( λ t,  F.to_fun (s, t)) (F.path_s s)

-- Ending points of path_homotopy are fixed  (Can Remove - not Used)
lemma hom_eq_of_pts { x y : β } { f g : path x y } ( F : path_homotopy f g ) :
∀ s : I01, check_pts x y ( λ t,  F.to_fun (s, t)) :=
begin
    intro s, unfold check_pts, split,
        have H1: F.to_fun (s, 0) =  ( λ t,  F.to_fun (s, t)) 0,
            simp,
        rw H1, exact (F.path_s s).left,
        have H1: F.to_fun (s, 1) =  ( λ t,  F.to_fun (s, t)) 1,
            simp,
        rw H1, exact (F.path_s s).right.left
end

--- (Can Remove - not Used)
lemma hom_path_is_cont { x y : β } { f g : path x y } ( F : path_homotopy f g ) :
∀ s : I01, continuous ( λ t,  F.to_fun (s, t)) :=
begin
intro s, exact (F.path_s s).right.right
end

--------------------------------------------
-- IDENTITY / INVERSE / COMPOSITION of HOMOTOPY

--- Identity homotopy
def path_homotopy_id { x y : β} (f : path x y) : path_homotopy f f :=
{   to_fun :=  λ st  , f.to_fun (prod.snd st) ,
    path_s := begin  intro s, unfold is_path,
    exact ⟨ f.at_zero,  f.at_one, f.cont ⟩ end,
    at_zero := by simp ,
    at_one := by simp ,
    cont := begin
    let h := λ st, f.to_fun ( @prod.snd I01 I01 st ) ,
    have hc : continuous h,
        exact continuous.comp  continuous_snd f.cont,
    exact hc,
    end
}

--- Inverse homotopy
lemma help_hom_inv : (λ (st : ↥I01 × ↥I01), F.to_fun (par_inv (st.fst), st.snd)) = ((λ (st : ↥I01 × ↥I01), F.to_fun (st.fst , st.snd)) ∘ (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01))) :=
begin trivial, end

def path_homotopy_inverse { x y : β} (f : path x y) (g : path x y) ( F : path_homotopy f g) : path_homotopy g f :=
{   to_fun :=   λ st  , F.to_fun ( par_inv st.1 , st.2 ),
    path_s := begin
    intro s, unfold is_path, split,
        exact (F.path_s (par_inv s)).1, split,
          exact (F.path_s (par_inv s)).2.1,
            exact (F.path_s (par_inv s)).2.2
    end,
    at_zero := begin intro t, simp,   end, --exact F.at_one t
    at_one := begin intro t, simp, end,   --exact F.at_zero t
    cont := begin
    show continuous ((λ (st : ↥I01 × ↥I01), F.to_fun (st.fst , st.snd)) ∘ (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01))),
    have H : continuous (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01)),
      exact continuous.prod_mk ( @continuous.comp (I01×I01) I01 I01 _ _ _ (λ x : I01×I01, x.1) _ continuous_fst continuous_par_inv) ( @continuous.comp (I01×I01) I01 I01 _ _ _ (λ x : I01×I01, x.2) _ continuous_snd continuous_id),
    simp [continuous.comp H F.cont],
    end
}

---- Composition of homotopy

local notation `I` := @set.univ I01

lemma cover_prod_I01 : ( (set.prod T1 (@set.univ I01)) ∪  (set.prod T2 (@set.univ I01)) ) = @set.univ (I01 × I01) :=
begin apply set.ext, intro x, split,
  simp [mem_set_of_eq],
  intro H, simp, have H : 0≤ x.1.val ∧ x.1.val ≤ 1, exact x.1.property, unfold T1 T2 T, simp [mem_set_of_eq, or_iff_not_imp_left, -one_div_eq_inv],
  intro nL, have H2 : (1 / 2 :ℝ )< x.1.val, exact nL H.1, exact ⟨ le_of_lt H2, H.2 ⟩ ,
end

def fgen_hom {α } [topological_space α ] { x y : α }{r s : ℝ}{f g: path x y } (Hrs : r < s)
 ( F : path_homotopy f g) : (set.prod (T r s Hrs ) I) → α :=
λ st, F.to_fun (( par Hrs ⟨st.1.1, (mem_prod.1 st.2).1 ⟩) , st.1.2 )

theorem p_hom_cont {α } [topological_space α ]{ x y : α }{r s : ℝ} {f g : path x y } (Hrs : r < s) ( F : path_homotopy f g)  : continuous (fgen_hom Hrs F) :=
begin unfold fgen_hom,
 refine continuous.comp _ F.cont ,
 refine continuous.prod_mk _ (continuous.comp continuous_subtype_val continuous_snd),
 refine continuous.comp _ (continuous_par Hrs),
 refine continuous_subtype_mk _ _,
 exact continuous.comp continuous_subtype_val continuous_fst,
end

def fa_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : (set.prod T1 I) → α  := @fgen_hom _ _ _ _ 0 (1/2 : ℝ ) _ _  T1._proof_1 F

lemma CA_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : continuous (fa_hom F) := p_hom_cont T1._proof_1 F

def fb_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : (set.prod T2 I) → α  := @fgen_hom _ _ _ _ (1/2 : ℝ ) 1 _ _  T2._proof_1 F

lemma CB_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : continuous (fb_hom F) := p_hom_cont T2._proof_1 F

lemma help_hom_1 {s t : I01} (H : s ∈ T1) : (s, t) ∈ set.prod T1 I := by simpa

lemma prod_T1_is_closed : is_closed (set.prod T1 I) := begin simp [T1_is_closed, is_closed_prod]  end

lemma prod_T2_is_closed : is_closed (set.prod T2 I) := begin simp [T2_is_closed, is_closed_prod] end

lemma prod_inter_T : set.inter (set.prod T1 I) (set.prod T2 I) = set.prod  { x : I01 | x.val = 1/2 } I :=
begin unfold T1 T2 T set.inter set.prod, simp [mem_set_of_eq, -one_div_eq_inv], apply set.ext, intro x, split,
  {rw mem_set_of_eq , rw mem_set_of_eq, simp [-one_div_eq_inv], intros A B C D, have H : x.1.val < 1 / 2 ∨ x.1.val = 1/2,
        exact  lt_or_eq_of_le B, exact le_antisymm  B C,
  }, { rw mem_set_of_eq , rw mem_set_of_eq, intro H, rw H, norm_num }
end

local attribute [instance] classical.prop_decidable

@[simp]
lemma cond_start { x y : β} {f : path x y} {g : path x y} {h : path x y}
( F : path_homotopy f g) ( G : path_homotopy g h) : paste cover_prod_I01 (fa_hom F) (fb_hom G) (s, 0) = x :=
begin  unfold paste, split_ifs, unfold fa_hom fgen_hom, simp, unfold fb_hom fgen_hom, simp, end

@[simp]
lemma cond_end { x y : β} {f : path x y} {g : path x y} {h : path x y}
( F : path_homotopy f g) ( G : path_homotopy g h) : paste cover_prod_I01 (fa_hom F) (fb_hom G) (s, 1) = y :=
begin unfold paste, split_ifs, unfold fa_hom fgen_hom, simp, unfold fb_hom fgen_hom, simp, end

lemma part_CA_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) (s : I01) (H : s ∈ T1) : continuous (λ (t: ↥I01), (fa_hom F) ⟨ (s, t), (help_hom_1 H ) ⟩   ) :=
begin unfold fa_hom fgen_hom, simp, exact (F.path_s (par T1._proof_1 ⟨ s, H ⟩  )).2.2,
end

lemma T2_of_not_T1 { s : I01} : (s ∉ T1) → s ∈ T2 :=
begin intro H, have H2 : T1 ∪ T2 = @set.univ I01, exact cover_I01, unfold T1 T2 T at *, simp [-one_div_eq_inv],
 rw mem_set_of_eq at H, rw not_and at H, have H3 : 1/2 < s.val, have H4 : ¬s.val ≤ 1 / 2, exact  H (s.2.1), exact lt_of_not_ge H4,
 exact ⟨ le_of_lt H3, s.2.2⟩ ,
end

--set_option trace.simplify.rewrite true
def path_homotopy_comp { x y : β} {f : path x y} {g : path x y} {h : path x y} ( F : path_homotopy f g) ( G : path_homotopy g h) :
path_homotopy f h :=
{   to_fun := λ st, ( @paste (I01 × I01) β (set.prod T1 I) (set.prod T2 I)  cover_prod_I01 ( λ st , (fa_hom F ) st ) ) ( λ st, (fb_hom G ) st  )  st  ,

    path_s := begin intro s, unfold is_path, split,
        simp, --exact cond_start s F G,
        split,  ---exact cond_end s F G,
        simp, simp, --refine cont_of_paste cover_prod_I01  prod_T1_is_closed prod_T2_is_closed (part_CA_hom F s _) _,

        unfold paste, unfold fa_hom fb_hom fgen_hom, simp,  --rw  (F.path_s (par T1._proof_1 s)).2.2 ,
        by_cases H : ∀ t : I01, (s, t) ∈ set.prod T1 I, simp [H],
          refine (F.path_s (par T1._proof_1 ⟨ s, _ ⟩  )).2.2, unfold set.prod at H,
          have H2 : (s, s) ∈ {p : ↥I01 × ↥I01 | p.fst ∈ T1 ∧ p.snd ∈ univ}, exact H s, simp [mem_set_of_eq] at H2, exact H2,
          simp at H,
          have H3:  s ∉ T1, simp [not_forall] at H, exact H.2,
          simp [H3], refine (G.path_s (par T2._proof_1 ⟨ s, _ ⟩  )).2.2,
          exact T2_of_not_T1 H3,
           --simp [mem_set_of_eq]  at H,
        --exact F.cont,
        end,

    at_zero := begin  intro y, simp, unfold paste, rw dif_pos, unfold fa_hom fgen_hom, simp ,
        simp [mem_set_of_eq], exact help_T1,  end,

    at_one := begin intro y, simp, unfold paste, rw dif_neg, unfold fb_hom fgen_hom, simp ,
        simp [mem_set_of_eq], exact help_02, end,

    cont := begin simp, refine cont_of_paste _ _ _ (CA_hom F) (CB_hom G) ,
      exact prod_T1_is_closed,
      exact prod_T2_is_closed,
      unfold match_of_fun, intros x B1 B2,
        have Int : x ∈ set.inter (set.prod T1 I) (set.prod T2 I), exact ⟨ B1 , B2 ⟩ ,
        rwa [prod_inter_T] at Int,
        have V : x.1.1 = 1/2, rwa [set.prod, mem_set_of_eq] at Int, rwa [mem_set_of_eq] at Int, exact Int.1, cases x,
        have xeq : x_fst = ⟨ 1/2 , help_01 ⟩ , apply subtype.eq, rw V,
        simp [xeq, -one_div_eq_inv],
        show fa_hom F ⟨(⟨1 / 2, help_01⟩, x_snd), _⟩ = fb_hom G ⟨(⟨1 / 2, help_01⟩, x_snd), _⟩ , unfold fa_hom fb_hom fgen_hom,
        simp [eqn_1, eqn_2, -one_div_eq_inv],
    end
}

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

---- EQUIVALENCE OF HOMOTOPY

definition is_homotopic_to { x y : β } (f : path x y) ( g : path x y) : Prop := nonempty ( path_homotopy f g)

theorem is_reflexive {β  : Type*} [topological_space β ] { x y : β  } : @reflexive (path x y) ( is_homotopic_to ) :=
begin
  unfold reflexive, intro f, unfold is_homotopic_to,
    have H : path_homotopy f f,
        exact path_homotopy_id f ,
    exact ⟨ H ⟩
end

theorem is_symmetric {β  : Type*} [topological_space β ] { x y : β  } : @symmetric (path x y)  (is_homotopic_to) :=
begin
    unfold symmetric, intros f g H, unfold is_homotopic_to,
    cases H with F, exact ⟨path_homotopy_inverse f g F⟩,
end

theorem is_transitive {β  : Type*} [topological_space β ] { x y : β  } : @transitive (path x y)  (is_homotopic_to) :=
begin
    unfold transitive, intros f g h Hfg Hgh, unfold is_homotopic_to at *,
      cases Hfg  with F,  cases Hgh with G,
    exact ⟨ path_homotopy_comp F G⟩ ,
end

theorem is_equivalence : @equivalence (path x y)  (is_homotopic_to) :=
⟨ is_reflexive, is_symmetric, is_transitive⟩

---- Reparametrisation of path and homotopies

-- (Formalise paragraph 2 pg 27 of AT, https://pi.math.cornell.edu/~hatcher/AT/AT.pdf )

structure repar_I01  :=
(to_fun : I01 → I01 )
(at_zero : to_fun 0 = 0 )
(at_one : to_fun 1 = 1 )
(cont : continuous to_fun )

@[simp]
lemma repar_I01_at_zero (f : repar_I01) : f.to_fun 0 = 0 := f.2

@[simp]
lemma repar_I01_at_one ( f  : repar_I01) : f.to_fun 1 = 1 := f.3

def repar_path {α : Type*} [topological_space α ] {x y : α } ( f : path x y)( φ : repar_I01 ) : path x y :=
{   to_fun := λ t , f.to_fun ( φ.to_fun t) ,
    at_zero := by simp,
    at_one := by simp,
    cont := continuous.comp φ.cont f.cont
}

def rep_hom (φ : repar_I01) : I01 × I01 → I01 := λ st, ⟨ ((1 : ℝ ) - st.1.1)*(φ.to_fun st.2).1 + st.1.1 * st.2.1,
begin unfold I01, rw mem_set_of_eq, split,
    { suffices H1 : 0 ≤ (1 - (st.fst).val) * (φ.to_fun (st.snd)).val ,
      suffices H2 : 0 ≤ (st.fst).val * (st.snd).val, exact add_le_add H1 H2,
        refine mul_nonneg _ _, exact st.1.2.1, exact st.2.2.1,
        refine mul_nonneg _ _, show 0 ≤ 1 - (st.fst).val , refine sub_nonneg.2  _ , exact st.1.2.2, exact (φ.to_fun (st.snd)).2.1,
    }, rw (@mul_comm _ _ (1 - (st.fst).val)  (φ.to_fun (st.snd)).val),
    simp [@mul_add ℝ _ ((φ.to_fun (st.snd)).val )  (1:ℝ ) (- st.fst.val) ], rw mul_comm ((φ.to_fun (st.snd)).val ) ((st.fst).val),
    simpa,

      sorry, --rw mul_add
    --have H1: (φ.to_fun (st.snd)).val + ((st.fst).val * (st.snd).val + -((φ.to_fun (st.snd)).val * (st.fst).val)) ≤

/- refine calc
(st.fst).val * (st.snd).val + (φ.to_fun (st.snd)).val * (1 + -(st.fst).val) =  (st.fst).val * (st.snd).val + (φ.to_fun (st.snd)).val* (1:ℝ ) + (φ.to_fun (st.snd)).val * - (st.fst).val  : begin     end---rw [@mul_add ℝ _ ((φ.to_fun (st.snd)).val )  (1:ℝ ) (- st.fst.val) _], end
... ≤ 1-/

    --( 1-s )φ t + s t =
    -- φ t + s (t - φ t) ≤
    -- φ t + (t - φ t) =
    -- t ≤ 1

end ⟩

@[simp]
lemma rep_hom_at_zero {φ : repar_I01} ( y : I01) : rep_hom φ (0, y) = φ.to_fun y :=
begin unfold rep_hom, simp, apply subtype.eq, simp [mul_comm, mul_zero],
  show  y.val * 0 + (φ.to_fun y).val * (1 + -0) = (φ.to_fun y).val, simp [mul_zero, mul_add, add_zero]
end

@[simp]
lemma rep_hom_at_one {φ : repar_I01} ( y : I01) : rep_hom φ (1, y) =  y :=
begin unfold rep_hom, apply subtype.eq, simp [-sub_eq_add_neg],
  show  1 * y.val + (1 - 1) * (φ.to_fun y).val = y.val, simp
end

@[simp]
lemma rep_hom_pt_at_zero {φ : repar_I01} ( s : I01) : rep_hom φ (s, 0) = 0 :=
begin unfold rep_hom, simp, apply subtype.eq, simp,  show s.val * 0+ (1 + -s.val) * 0 = 0, simp, end

@[simp]
lemma rep_hom_pt_at_one {φ : repar_I01} ( s : I01) : rep_hom φ (s, 1) = 1 :=
begin unfold rep_hom, simp, apply subtype.eq, simp, show s.val * 1 + (1 + -s.val) * 1 = 1, simp end

lemma cont_rep_hom (φ : repar_I01) : continuous (rep_hom φ ) :=
begin unfold rep_hom, refine continuous_subtype_mk _ _,
refine @continuous_add _ _ _ _ _ _ (λ st: I01×I01 , (1 - (st.fst).val) * (φ.to_fun (st.snd)).val ) _ _ _,
 { refine continuous_mul _ _, refine continuous_add _ _, exact continuous_const,
     show continuous (( λ x : ℝ , - x ) ∘ (λ (st : ↥I01 × ↥I01), (st.fst).val) ),
     refine continuous.comp (continuous.comp continuous_fst continuous_subtype_val) (continuous_neg continuous_id),
   exact continuous.comp (continuous.comp continuous_snd φ.cont) continuous_subtype_val
 },
   refine continuous_mul _ _ , exact continuous.comp continuous_fst continuous_subtype_val,
    exact continuous.comp continuous_snd continuous_subtype_val
end

-- Define homtopy from f φ to f , for any repar φ
def hom_repar_path_to_path {α : Type*} [topological_space α ] {x y : α } ( f : path x y)( φ : repar_I01 ) : path_homotopy (repar_path f φ ) f :=
{   to_fun :=  λ st, f.to_fun ( (rep_hom φ) st),
    path_s := begin intro s, unfold is_path, split, simp, split, simp,
      show continuous ( (λ (st : I01×I01), f.to_fun (rep_hom φ st )) ∘ ( λ t : I01, ((s, t) : I01 × I01) )    ),
      refine continuous.comp _ (continuous.comp (cont_rep_hom φ ) f.cont ),
      exact continuous.prod_mk continuous_const continuous_id
    end,
    at_zero := by simp,
    at_one := by simp,
    cont :=  continuous.comp (cont_rep_hom φ ) f.cont
}

theorem repar_path_is_homeq {α : Type*} [topological_space α ] {x y : α } ( f : path x y)( φ : repar_I01 )
: is_homotopic_to (repar_path f φ ) f :=
begin unfold is_homotopic_to, exact nonempty.intro (hom_repar_path_to_path f φ ),  end

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

end homotopy

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

---- FUNDAMENTAL GROUP

namespace fundamental_group
open homotopy
open path
variables {α  : Type*} [topological_space α ] {x : α }

--- Underlying Notions

def setoid_hom {α : Type*} [topological_space α ] (x : α )  : setoid (loop x) := setoid.mk is_homotopic_to (is_equivalence x x)

--@[simp]
def space_π_1 {α : Type*} [topological_space α ] (x : α ) := quotient (setoid_hom x)

---#print prefix quotient

/- def hom_eq_class2 {α : Type*} [topological_space α ] {x : α } ( f : loop x ) : set (path x x) :=
{ g : path x x | is_homotopic_to f g } -/

def eq_class {α : Type*} [topological_space α ] {x : α } ( f : loop x ) : space_π_1 x := @quotient.mk _ (setoid_hom x) f

def out_loop {α : Type*} [topological_space α ] {x : α } ( F : space_π_1 x ) : loop x := @quotient.out (loop x) (setoid_hom x)  F

def id_eq_class {α : Type*} [topological_space α ] (x : α )  : space_π_1 x := eq_class (loop_const x)

def inv_eq_class {α : Type*} [topological_space α ] {x : α } (F : space_π_1 x) : space_π_1 x := eq_class (inv_of_path (out_loop F))

-- Multiplication

def und_mul {α : Type*} [topological_space α ] (x : α )  ( f : loop x ) ( g : loop x ) :  space_π_1 x :=
eq_class (comp_of_path f g)

def mul2 {α : Type*} [topological_space α ] {x : α }  : space_π_1 x → space_π_1 x → space_π_1 x :=
begin
intros F G, let f := out_loop F , let g := out_loop G,
exact eq_class ( comp_of_path f g )
end

def mul {α : Type*} [topological_space α ] {x : α } : space_π_1 x → space_π_1 x → space_π_1 x :=
λ F G,  und_mul x (out_loop  F) (out_loop  G)

/-
#print prefix quotient
#print ≈
#print has_equiv.equiv
#print setoid.r -/

--------

-- Identity Elememt

-- right identity - mul_one

def p1 : repar_I01 :=
{   to_fun :=  λ  t, (paste cover_I01 (λ s, par T1._proof_1 s ) (λ s, 1) ) t ,
    at_zero := begin unfold paste, rw dif_pos, swap, exact help_T1, simp   end,
    at_one := begin unfold paste, rw dif_neg, exact help_02 end,
    cont := begin simp, refine cont_of_paste _ _ _ (continuous_par _) continuous_const,
        exact T1_is_closed,
        exact T2_is_closed,
        unfold match_of_fun,  intros x B1 B2,
        have Int : x ∈ set.inter T1 T2, exact ⟨ B1 , B2 ⟩ ,
        rwa [inter_T] at Int,
        have V : x.val = 1/2, rwa [mem_set_of_eq] at Int,
        have xeq : x = (⟨ 1/2 , help_01 ⟩ : I01 ) , apply subtype.eq, rw V,
        simp [xeq, -one_div_eq_inv],
        show par T1._proof_1 ⟨⟨1 / 2, help_01⟩, help_half_T1⟩  = 1, exact eqn_1,
    end
}

local attribute [instance] classical.prop_decidable

--mul a (id_eq_class x) = a
def hom_f_to_f_const {α : Type*} [topological_space α ] {x y : α } ( f : path x y) : path_homotopy (comp_of_path f (loop_const y)) f:=
begin
have H : comp_of_path f (loop_const y) = repar_path f p1,
  { apply path_equal.2, unfold comp_of_path repar_path, simp, unfold fa_path fb_path fgen_path loop_const p1, simp, unfold par, funext,
  unfold paste,  split_ifs, simp [-one_div_eq_inv], simp,
     },
rw H, exact hom_repar_path_to_path f p1,
end

-- f ⬝ c ≈ f by using homotopy f → f ⬝ c above
lemma path_const_homeq_path {α : Type*} [topological_space α ] {x y : α } ( f : path x y)  : is_homotopic_to (comp_of_path f (loop_const y)) f :=
begin  unfold is_homotopic_to, refine nonempty.intro (hom_f_to_f_const f), end

/-
#check quotient.exists_rep
#check quotient.induction_on
#check quotient.out_eq
#check setoid -/

-- Now prove [f][c] = [f]

theorem mul_one {α : Type*} [topological_space α ] {x : α } ( F : space_π_1 x) : mul F (id_eq_class x) = F :=
begin unfold mul und_mul eq_class, --have H : F = ⟦ quotient.out _ (setoid_hom x) F ⟧,
--- Code below does not lead to much progress atm
 /- refine quotient.induction_on _ (setoid_hom x) _ F ,
 have f := @quotient.out (loop x) (setoid_hom x) F ,
 have H : F = @quotient.mk _ (setoid_hom x) f ,
 refine eq.symm _ , refine quotient.out_eq _ (setoid_hom x) F ,

 simp [@quotient.exists_rep (loop x) (setoid_hom x) F],
apply @quotient.out (loop x) (setoid_hom x) ,

unfold mul und_mul  eq_class, let f := out_loop F , have H : F = eq_class f, unfold eq_class,   -- simp [@quotient.out_eq F, eq.symm],

--have Hf: f = out_loop F, trivial, subst Hf, -/
sorry
end

--set_option trace.simplify.rewrite true
--set_option pp.implicit true

-----

-- Group π₁ (α  , x)

def π_1_group {α : Type*} [topological_space α ] (x : α ) : group (space_π_1 x) :=
{   mul := mul,

    mul_assoc := begin sorry end,

    one := id_eq_class x ,

    one_mul := begin sorry end ,
    mul_one := begin sorry end ,

    inv :=  inv_eq_class  ,
    mul_left_inv :=  begin
    intro F, simp,
    sorry end

}

--------------------- Next things after identity for π_1 group

-- Inverse

lemma hom_comp_inv_to_const {α : Type*} [topological_space α ] {x : α } (f : loop x) : path_homotopy (comp_of_path (inv_of_path f) f) (loop_const x) :=
{   to_fun := sorry,
    path_s := sorry,
    at_zero := sorry,
    at_one := sorry,
    cont := sorry

----- NEED STOP FUNCTION

}

--instance : @topological_semiring I01 (by apply_instance )  :=

lemma comp_inv_eqv_const {α : Type*} [topological_space α ] {x : α } (F : space_π_1 x) : is_homotopic_to (comp_of_path (out_loop (inv_eq_class F)) (out_loop F) ) (loop_const x) :=
begin
unfold is_homotopic_to,
sorry,

end

theorem mul_left_inv {α : Type*} [topological_space α ] {x : α } (F : space_π_1 x) : mul (inv_eq_class F) F = id_eq_class x :=
begin
unfold mul und_mul, unfold id_eq_class, unfold eq_class, simp [quotient.eq], unfold inv_eq_class out_loop,  unfold has_equiv.equiv,
--suffices H : is_homotopic_to (comp_of_path (out_loop (inv_eq_class F)) (out_loop F) ) (loop_const x)
sorry,
end

--- out lemma ,

-- (or define multiplication given loops (mul_1) )

-- Ignore below

/- def space_π_1 {α : Type*} [topological_space α ] {x : α } :=  --: set (hom_eq_class x)
{ h : hom_eq_class ( path x x) } -/

/-
def space_π_1 {α : Type*} [topological_space α ] {x : α } : set (set (path x x)) :=
{ ∀ f : loop3 x,  hom_eq_class ( f)   } -/

/- {   to_fun := sorry,
    path_s := sorry,
    at_zero := sorry,
    at_one := sorry,
    cont := sorry-/

--set_option trace.simplify.rewrite true
--set_option pp.implicit true

-- Associativity of homotopy

-- Homotopy as a class ????

end fundamental_group


import tactic
import data.nat.parity
import data.set
import data.set.basic

namespace lecture6

open set

example : {n | 4 ∣ n + 1} ⊆ {k | odd k} :=
begin
  rw set.subset_def,
  intros x hx,
  simp at hx,
  simp,
  cases nat.even_or_odd x,
  {
    apply nat.even_succ.symm.mpr,
    refine dvd_of_mul_left_dvd _,
    use 2,
    exact hx,
  },
  exact nat.odd_iff_not_even.mp h,
end

example : Π {α : Type} (s t : set α), s = t ↔ s ∪ t = s ∩ t :=
begin
  intros a s t,
  split,
  {
    intro s_eq_t,
    rw [s_eq_t, union_self, inter_self],
  },
  intro union_eq_intersect,
  apply le_antisymm,
  {
    calc s ⊆ s ∪ t : subset_union_left s t
    ...    = s ∩ t  : union_eq_intersect
    ...    ⊆ t     : inter_subset_right s t,
  },
  calc t ⊆ s ∪ t : subset_union_right s t
  ...    = s ∩ t  : union_eq_intersect
  ...    ⊆ s     : inter_subset_left s t,
end

end lecture6