/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.submodule
import algebra.lie.of_associative
import linear_algebra.isomorphisms

/-!
# Quotients of Lie algebras and Lie modules

Given a Lie submodule of a Lie module, the quotient carries a natural Lie module structure. In the
special case that the Lie module is the Lie algebra itself via the adjoint action, the submodule
is a Lie ideal and the quotient carries a natural Lie algebra structure.

We define these quotient structures here. A notable omission at the time of writing (February 2021)
is a statement and proof of the universal property of these quotients.

## Main definitions

  * `lie_submodule.quotient.lie_quotient_lie_module`
  * `lie_submodule.quotient.lie_quotient_lie_algebra`

## Tags

lie algebra, quotient
-/

universes u v w w₁ w₂

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]
variables (N N' : lie_submodule R L M) (I J : lie_ideal R L)

/-- The quotient of a Lie module by a Lie submodule. It is a Lie module. -/
instance : has_quotient M (lie_submodule R L M) :=
⟨λ N, M ⧸ N.to_submodule⟩

namespace quotient

variables {N I}

instance add_comm_group : add_comm_group (M ⧸ N) := submodule.quotient.add_comm_group _
instance module' {S : Type*} [semiring S] [has_scalar S R] [module S M] [is_scalar_tower S R M] :
  module S (M ⧸ N) := submodule.quotient.module' _
instance module : module R (M ⧸ N) := submodule.quotient.module _
instance is_central_scalar {S : Type*} [semiring S]
  [has_scalar S R] [module S M] [is_scalar_tower S R M]
  [has_scalar Sᵐᵒᵖ R] [module Sᵐᵒᵖ M] [is_scalar_tower Sᵐᵒᵖ R M]
  [is_central_scalar S M] : is_central_scalar S (M ⧸ N) :=
submodule.quotient.is_central_scalar _
instance inhabited : inhabited (M ⧸ N) := ⟨0⟩

/-- Map sending an element of `M` to the corresponding element of `M/N`, when `N` is a
lie_submodule of the lie_module `N`. -/
abbreviation mk : M → M ⧸ N := submodule.quotient.mk

lemma is_quotient_mk (m : M) :
  quotient.mk' m = (mk m : M ⧸ N) := rfl

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there
is a natural linear map from `L` to the endomorphisms of `M` leaving `N` invariant. -/
def lie_submodule_invariant : L →ₗ[R] submodule.compatible_maps N.to_submodule N.to_submodule :=
  linear_map.cod_restrict _ (lie_module.to_endomorphism R L M) N.lie_mem

variables (N)

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there
is a natural Lie algebra morphism from `L` to the linear endomorphism of the quotient `M/N`. -/
def action_as_endo_map : L →ₗ⁅R⁆ module.End R (M ⧸ N) :=
{ map_lie' := λ x y, by { ext m,
                          change mk ⁅⁅x, y⁆, m⁆ = mk (⁅x, ⁅y, m⁆⁆ - ⁅y, ⁅x, m⁆⁆),
                          congr, apply lie_lie, },
  ..linear_map.comp (submodule.mapq_linear (N : submodule R M) ↑N) lie_submodule_invariant }

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there is
a natural bracket action of `L` on the quotient `M/N`. -/
def action_as_endo_map_bracket : has_bracket L (M ⧸ N) := ⟨λ x n, action_as_endo_map N x n⟩

instance lie_quotient_lie_ring_module : lie_ring_module L (M ⧸ N) :=
{ bracket     := λ x n, (action_as_endo_map N : L →ₗ[R] module.End R (M ⧸ N)) x n,
  add_lie     := λ x y n, by { simp only [linear_map.map_add, linear_map.add_apply], },
  lie_add     := λ x m n, by { simp only [linear_map.map_add, linear_map.add_apply], },
  leibniz_lie := λ x y m, show action_as_endo_map _ _ _ = _,
  { simp only [lie_hom.map_lie, lie_ring.of_associative_ring_bracket, sub_add_cancel,
      lie_hom.coe_to_linear_map, linear_map.mul_apply, linear_map.sub_apply], } }

/-- The quotient of a Lie module by a Lie submodule, is a Lie module. -/
instance lie_quotient_lie_module : lie_module R L (M ⧸ N) :=
{ smul_lie := λ t x m, show (_ : L →ₗ[R] module.End R (M ⧸ N)) _ _ = _,
  { simp only [linear_map.map_smul], refl, },
  lie_smul := λ x t m, show (_ : L →ₗ[R] module.End R (M ⧸ N)) _ _ = _,
  { simp only [linear_map.map_smul], refl, }, }

instance lie_quotient_has_bracket : has_bracket (L ⧸ I) (L ⧸ I) :=
⟨begin
  intros x y,
  apply quotient.lift_on₂' x y (λ x' y', mk ⁅x', y'⁆),
  intros x₁ x₂ y₁ y₂ h₁ h₂,
  apply (submodule.quotient.eq I.to_submodule).2,
  have h : ⁅x₁, x₂⁆ - ⁅y₁, y₂⁆ = ⁅x₁, x₂ - y₂⁆ + ⁅x₁ - y₁, y₂⁆,
    by simp [-lie_skew, sub_eq_add_neg, add_assoc],
  rw h,
  apply submodule.add_mem,
  { apply lie_mem_right R L I x₁ (x₂ - y₂) h₂, },
  { apply lie_mem_left R L I (x₁ - y₁) y₂ h₁, },
end⟩

@[simp] lemma mk_bracket (x y : L) :
  mk ⁅x, y⁆ = ⁅(mk x : L ⧸ I), (mk y : L ⧸ I)⁆ := rfl

instance lie_quotient_lie_ring : lie_ring (L ⧸ I) :=
{ add_lie  := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply add_lie, },
  lie_add  := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply lie_add, },
  lie_self := by { intros x', apply quotient.induction_on' x', intros x,
                   rw [is_quotient_mk, ←mk_bracket],
                   apply congr_arg, apply lie_self, },
  leibniz_lie := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply leibniz_lie, } }

instance lie_quotient_lie_algebra : lie_algebra R (L ⧸ I) :=
{ lie_smul := by { intros t x' y', apply quotient.induction_on₂' x' y', intros x y,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_smul, },
                   apply congr_arg, apply lie_smul, } }

/-- `lie_submodule.quotient.mk` as a `lie_module_hom`. -/
@[simps]
def mk' : M →ₗ⁅R,L⁆ M ⧸ N :=
{ to_fun := mk, map_lie' := λ r m, rfl, ..N.to_submodule.mkq}

@[simp] lemma mk_eq_zero {m : M} : mk' N m = 0 ↔ m ∈ N :=
submodule.quotient.mk_eq_zero N.to_submodule

@[simp] lemma mk'_ker : (mk' N).ker = N :=
by { ext, simp, }

@[simp] lemma map_mk'_eq_bot_le : map (mk' N) N' = ⊥ ↔ N' ≤ N :=
by rw [← lie_module_hom.le_ker_iff_map, mk'_ker]

/-- Two `lie_module_hom`s from a quotient lie module are equal if their compositions with
`lie_submodule.quotient.mk'` are equal.

See note [partially-applied ext lemmas]. -/
@[ext]
lemma lie_module_hom_ext ⦃f g : M ⧸ N →ₗ⁅R,L⁆ M⦄ (h : f.comp (mk' N) = g.comp (mk' N)) :
  f = g :=
lie_module_hom.ext $ λ x, quotient.induction_on' x $ lie_module_hom.congr_fun h

end quotient

end lie_submodule

namespace lie_hom

variables {R L L' : Type*}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
variables (f : L →ₗ⁅R⁆ L')

/-- The first isomorphism theorem for morphisms of Lie algebras. -/
@[simps] noncomputable def quot_ker_equiv_range : L ⧸ f.ker ≃ₗ⁅R⁆ f.range :=
{ to_fun := (f : L →ₗ[R] L').quot_ker_equiv_range,
  map_lie' :=
  begin
    rintros ⟨x⟩ ⟨y⟩,
    rw [← set_like.coe_eq_coe, lie_subalgebra.coe_bracket],
    simp only [submodule.quotient.quot_mk_eq_mk, linear_map.quot_ker_equiv_range_apply_mk,
      ← lie_submodule.quotient.mk_bracket, coe_to_linear_map, map_lie],
  end,
  .. (f : L →ₗ[R] L').quot_ker_equiv_range, }

end lie_hom


import data.real.basic

def even_fun (f : ℝ → ℝ) := ∀ x, f (-x) = f x

example (
  f g : ℝ → ℝ)
  : even_fun f → even_fun g →  even_fun (f + g) :=
begin
  intros hf hg,
  intros x,
  calc (f + g) (-x) = f (-x) + g (-x) : rfl
                ... = f x + g (-x)    : by rw hf
                ... = f x + g x       : by rw hg
                ... = (f + g) x       : rfl,
end


variables p q : Prop

example (h : p ∨ q) : q ∨ p :=
  or.elim h
    (assume hp : p,
      show q ∨ p, from or.intro_right q hp)
    (assume hq : q,
      show q ∨ p, from or.intro_left p hq)


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

! This file was ported from Lean 3 source module data.set.intervals.infinite
! leanprover-community/mathlib commit 4d392a6c9c4539cbeca399b3ee0afea398fbd2eb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Set.Finite

/-!
# Infinitude of intervals

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

Bounded intervals in dense orders are infinite, as are unbounded intervals
in orders that are unbounded on the appropriate side. We also prove that an unbounded
preorder is an infinite type.
-/

variable {α : Type _} [Preorder α]

#print NoMaxOrder.infinite /-
/-- A nonempty preorder with no maximal element is infinite. This is not an instance to avoid
a cycle with `infinite α → nontrivial α → nonempty α`. -/
theorem NoMaxOrder.infinite [Nonempty α] [NoMaxOrder α] : Infinite α :=
  let ⟨f, hf⟩ := Nat.exists_strictMono α
  Infinite.of_injective f hf.Injective
#align no_max_order.infinite NoMaxOrder.infinite
-/

#print NoMinOrder.infinite /-
/-- A nonempty preorder with no minimal element is infinite. This is not an instance to avoid
a cycle with `infinite α → nontrivial α → nonempty α`. -/
theorem NoMinOrder.infinite [Nonempty α] [NoMinOrder α] : Infinite α :=
  @NoMaxOrder.infinite αᵒᵈ _ _ _
#align no_min_order.infinite NoMinOrder.infinite
-/

namespace Set

section DenselyOrdered

variable [DenselyOrdered α] {a b : α} (h : a < b)

#print Set.Ioo.infinite /-
theorem Ioo.infinite : Infinite (Ioo a b) :=
  @NoMaxOrder.infinite _ _ (nonempty_Ioo_subtype h) _
#align set.Ioo.infinite Set.Ioo.infinite
-/

#print Set.Ioo_infinite /-
theorem Ioo_infinite : (Ioo a b).Infinite :=
  infinite_coe_iff.1 <| Ioo.infinite h
#align set.Ioo_infinite Set.Ioo_infinite
-/

#print Set.Ico_infinite /-
theorem Ico_infinite : (Ico a b).Infinite :=
  (Ioo_infinite h).mono Ioo_subset_Ico_self
#align set.Ico_infinite Set.Ico_infinite
-/

#print Set.Ico.infinite /-
theorem Ico.infinite : Infinite (Ico a b) :=
  infinite_coe_iff.2 <| Ico_infinite h
#align set.Ico.infinite Set.Ico.infinite
-/

#print Set.Ioc_infinite /-
theorem Ioc_infinite : (Ioc a b).Infinite :=
  (Ioo_infinite h).mono Ioo_subset_Ioc_self
#align set.Ioc_infinite Set.Ioc_infinite
-/

#print Set.Ioc.infinite /-
theorem Ioc.infinite : Infinite (Ioc a b) :=
  infinite_coe_iff.2 <| Ioc_infinite h
#align set.Ioc.infinite Set.Ioc.infinite
-/

#print Set.Icc_infinite /-
theorem Icc_infinite : (Icc a b).Infinite :=
  (Ioo_infinite h).mono Ioo_subset_Icc_self
#align set.Icc_infinite Set.Icc_infinite
-/

#print Set.Icc.infinite /-
theorem Icc.infinite : Infinite (Icc a b) :=
  infinite_coe_iff.2 <| Icc_infinite h
#align set.Icc.infinite Set.Icc.infinite
-/

end DenselyOrdered

instance [NoMinOrder α] {a : α} : Infinite (Iio a) :=
  NoMinOrder.infinite

#print Set.Iio_infinite /-
theorem Iio_infinite [NoMinOrder α] (a : α) : (Iio a).Infinite :=
  infinite_coe_iff.1 Iio.infinite
#align set.Iio_infinite Set.Iio_infinite
-/

instance [NoMinOrder α] {a : α} : Infinite (Iic a) :=
  NoMinOrder.infinite

#print Set.Iic_infinite /-
theorem Iic_infinite [NoMinOrder α] (a : α) : (Iic a).Infinite :=
  infinite_coe_iff.1 Iic.infinite
#align set.Iic_infinite Set.Iic_infinite
-/

instance [NoMaxOrder α] {a : α} : Infinite (Ioi a) :=
  NoMaxOrder.infinite

#print Set.Ioi_infinite /-
theorem Ioi_infinite [NoMaxOrder α] (a : α) : (Ioi a).Infinite :=
  infinite_coe_iff.1 Ioi.infinite
#align set.Ioi_infinite Set.Ioi_infinite
-/

instance [NoMaxOrder α] {a : α} : Infinite (Ici a) :=
  NoMaxOrder.infinite

#print Set.Ici_infinite /-
theorem Ici_infinite [NoMaxOrder α] (a : α) : (Ici a).Infinite :=
  infinite_coe_iff.1 Ici.infinite
#align set.Ici_infinite Set.Ici_infinite
-/

end Set


namespace TBA

-- Let's work with some inductive types other than `Nat`!

-- Here is our very own definition of `List`:
inductive List (α : Type) where
  | nil : List α
  | cons (head : α) (tail : List α) : List α

notation  (priority := high) "[" "]" => List.nil   -- `[]`
infixr:67 (priority := high) " :: "  => List.cons  -- `a :: as`

-- as a warm-up exercise, let's define concatenation of two lists
def append (as bs : List α) : List α :=
  match as with
  | []      => bs
  | a :: as => a :: append as bs

infixl:65 (priority := high) " ++ " => append

example : 1::2::[] ++ 3::4::[] = 1::2::3::4::[] := rfl

-- as with associativity on `Nat`, think twice about what induction variable to use!
theorem append_assoc : (as ++ bs) ++ cs = as ++ (bs ++ cs) := by
  induction as with
  | nil => rfl
  | cons a as ih => simp [append, ih]

open Decidable

/-
One important special case of `Decidable` is decidability of equalities:
```
abbrev DecidableEq (α : Type) :=
  (a b : α) → Decidable (a = b)

def decEq [s : DecidableEq α] (a b : α) : Decidable (a = b) :=
  s a b
```
Note: `DecidableEq` is defined using `abbrev` instead of `def` because typeclass resolution only
unfolds the former for performance reasons.

Let's try to prove that `List` equality is decidable!
-/
-- hint: Something is still missing. Do we need to assume anything about `α`?
-- hint: Apply `match` case distinctions until the the appropriate `Decidable` constructor is clear,
--   then fill in its proof argument with `by`.
--   We could also do everything in a `by` block, but it's nicer to reserve tactics for proofs so we have
--   more control about the code of programs, i.e. the part that is actually executed
def ldecEq [DecidableEq α] (as bs : List α) : Decidable (as = bs) := /-SOL_-/
  match as, bs with
  | [],      []      => isTrue rfl
  | [],      b :: bs => isFalse (by intro h; contradiction)  -- or simply:
  | a :: as, []      => isFalse (by simp)
  | a :: as, b :: bs =>
    match decEq a b, ldecEq as bs with
    | isTrue _,  isTrue _  => isTrue (by simp_all)
    | isFalse _, _         => isFalse (by intro h; injection h; simp_all)
    | _,         isFalse _ => isFalse (by intro h; injection h; simp_all)

-- Let's declare the instance:
instance [DecidableEq α] : DecidableEq (List α) := /-SOL_-/ldecEq/-END-/

-- This should now work:
#eval decEq (1::2::[]) (1::3::[])

/-
`DecidabePred` is another convenient abbreviation of `Decidable`
```
abbrev DecidablePred (r : α → Prop) :=
  (a : α) → Decidable (r a)
```
If we have `[DecidablePred p]`, we can e.g. use `if p a then ...` for some `a : α`.

`filter p as` is a simple list function that should remove all elements `a` for which `p a` does not hold.
-/
def filter (p : α → Prop) [DecidablePred p] (as : List α) : List α :=
  match as with
  | [] => []
  | a::as => if p a then a :: filter p as else filter p as

example : filter (fun x => x % 2 = 0) (1::2::3::4::[]) = 2::4::[] := rfl

variable {p : α → Prop} [DecidablePred p] {as bs : List α}

-- These helper theorems can be useful, also for manual rewriting
@[simp] theorem filter_cons_true (h : p a) : filter p (a :: as) = a :: filter p as :=
  by simp [filter, h]
@[simp] theorem filter_cons_false (h : ¬ p a) : filter p (a :: as) = filter p as :=
  by simp [filter, h]
-- It's worthwhile thinking about what's actually happening here:
-- * first, `filter p (a :: as)` is unfolded to `if p a then a :: filter p as else filter p as`
--   (note that the second `filter` cannot be unfolded)
-- * then `if p a then ...` is rewritten to `if True then ...` using `h`
-- * finally, `if True then a :: filter p as else ...` is rewritten to `a :: filter p as` using
--   the built-in simp theorem `Lean.Simp.ite_true`

-- useful tactic: `by_cases h : q` for a decidable proposition `q`
theorem filter_idem : filter p (filter p as) = filter p as := by
  induction as with
  | nil => rfl
  | cons a as ih => by_cases h : p a <;> simp [ih, h]

theorem filter_append : filter p (as ++ bs) = filter p as ++ filter p bs := by
  induction as with
  | nil => rfl
  | cons a as ih => by_cases h : p a <;> simp [append, ih, h]

-- list membership as an inductive predicate:
inductive Mem (a : α) : List α → Prop where
  -- either it's the first element...
  | head {as} : Mem a (a::as)
  -- or it's in the remainder list
  | tail {as} : Mem a as → Mem a (a'::as)

infix:50 " ∈ " => Mem

-- recall that `a ≠ b` is the same as `a = b → False`
theorem mem_of_nonempty_filter (h : ∀ a, p a → a = x) : filter p as ≠ [] → x ∈ as := by
  intro hfil
  induction as with
  | nil => contradiction
  | cons a as ih =>
    by_cases hpa : p a
    case inl =>
      rw [h _ hpa]
      exact Mem.head
    case inr =>
      rw [filter_cons_false hpa] at hfil
      exact Mem.tail (ih hfil)

-- This proof is pretty long! Some hints:
-- * If you have an assumption `h : a ∈ []`, you can solve the current goal by `cases h`:
--   since there is no `Mem` constructor that could possibly match `[]`, there is nothing left to prove!
--   This exclusion of cases, and case analysis on inductive predicates in general,
--   is also called *rule inversion* since we (try to) apply the introduction rules (constructors)
--   "in reverse".
-- * On the other hand, if you try to do case analysis on a proof of e.g. `a ∈ filter p as`,
--   Lean will complain with "dependent elimination failed" since it *doesn't* know yet if
--   the argument `filter p as` is of the form `_ :: _` as demanded by the `Mem` constructors.
--   You need to get the assumption into the shape `_ ∈ []` or `_ ∈ _ :: _` before applying
--   `(no)match/cases` to it.
theorem mem_filter : a ∈ filter p as ↔ a ∈ as ∧ p a := by
  apply Iff.intro
  case mp =>
    intro h
    induction as with
    | nil => cases h
    | cons a' as ih =>
      by_cases ha' : p a'
      case inl =>
        rw [filter_cons_true ha'] at h
        cases h with
        | head => exact ⟨Mem.head, ha'⟩
        | tail h => exact ⟨Mem.tail (ih h).1, (ih h).2⟩
      case inr =>
        rw [filter_cons_false ha'] at h
        exact ⟨Mem.tail (ih h).1, (ih h).2⟩
  case mpr =>
    intro ⟨h, hpa⟩
    induction as with
    | nil => cases h
    | cons a' as ih =>
      cases h with
      | head =>
        rw [filter_cons_true hpa]
        constructor
      | tail ha =>
        by_cases hpa' : p a'
        case inl =>
          rw [filter_cons_true hpa']
          exact Mem.tail (ih ha)
        case inr =>
          rw [filter_cons_false hpa']
          exact ih ha

-- Here is an alternative definition of list membership via `append`
inductive Mem' (a : α) : List α → Prop where
  | intro (as bs) : Mem' a (as ++ (a :: bs))

infix:50 " ∈' " => Mem'

-- Let's prove that they are equivalent!
theorem mem_mem' : a ∈ as ↔ a ∈' as := by
  constructor
  case mp =>
    intro h
    induction h with
    | head => exact ⟨[], _⟩
    | tail h ih =>
      have ⟨as', bs'⟩ := ih
      exact ⟨_::as', _⟩
  case mpr =>
    intro ⟨as', bs'⟩
    induction as' with
    | nil => exact Mem.head
    | cons a' as' ih => exact Mem.tail ih

end TBA


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Andrew Zipperer, Haitao Zhang, Minchao Wu

Functions over sets.
-/
import data.set.basic
open function

namespace set
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {ι : Sort x}

/- maps to -/

/-- `maps_to f a b` means that the image of `a` is contained in `b`. -/
@[reducible] def maps_to (f : α → β) (a : set α) (b : set β) : Prop := a ⊆ f ⁻¹' b

theorem maps_to_of_eq_on {f1 f2 : α → β} {a : set α} {b : set β} (h₁ : eq_on f1 f2 a)
    (h₂ : maps_to f1 a b) :
  maps_to f2 a b :=
λ x h, by rw [mem_preimage_eq, ← h₁ _ h]; exact h₂ h

theorem maps_to_comp {g : β → γ} {f : α → β} {a : set α} {b : set β} {c : set γ}
   (h₁ : maps_to g b c) (h₂ : maps_to f a b) : maps_to (g ∘ f) a c :=
λ x h, h₁ (h₂ h)

theorem maps_to_univ (f : α → β) (a) : maps_to f a univ :=
λ x h, trivial

theorem image_subset_of_maps_to_of_subset {f : α → β} {a c : set α} {b : set β} (h₁ : maps_to f a b)
  (h₂ : c ⊆ a) :
  f '' c ⊆ b :=
λ y hy, let ⟨x, hx, heq⟩ := hy in
by rw [←heq]; apply h₁; apply h₂; assumption

theorem image_subset_of_maps_to {f : α → β} {a : set α} {b : set β} (h : maps_to f a b) :
  f '' a ⊆ b :=
image_subset_of_maps_to_of_subset h (subset.refl _)

/- injectivity -/

/-- `f` is injective on `a` if the restriction of `f` to `a` is injective. -/
@[reducible] def inj_on (f : α → β) (a : set α) : Prop :=
∀⦃x1 x2 : α⦄, x1 ∈ a → x2 ∈ a → f x1 = f x2 → x1 = x2

theorem inj_on_empty (f : α → β) : inj_on f ∅ :=
λ _ _ h₁ _ _, false.elim h₁

theorem inj_on_of_eq_on {f1 f2 : α → β} {a : set α} (h₁ : eq_on f1 f2 a)
    (h₂ : inj_on f1 a) :
  inj_on f2 a :=
λ _ _ h₁' h₂' heq, by apply h₂ h₁' h₂'; rw [h₁, heq, ←h₁]; repeat {assumption}

theorem inj_on_comp {g : β → γ} {f : α → β} {a : set α} {b : set β}
    (h₁ : maps_to f a b) (h₂ : inj_on g b) (h₃: inj_on f a) :
  inj_on (g ∘ f) a :=
λ _ _ h₁' h₂' heq,
by apply h₃ h₁' h₂'; apply h₂; repeat {apply h₁, assumption}; assumption

theorem inj_on_of_inj_on_of_subset {f : α → β} {a b : set α} (h₁ : inj_on f b) (h₂ : a ⊆ b) :
  inj_on f a :=
λ _ _ h₁' h₂' heq, h₁ (h₂ h₁') (h₂ h₂') heq

lemma injective_iff_inj_on_univ {f : α → β} : injective f ↔ inj_on f univ :=
iff.intro (λ h _ _ _ _ heq, h heq) (λ h _ _ heq, h trivial trivial heq)

lemma inj_on_iff_injective {f : α → β} {s : set α} : inj_on f s ↔ injective (λ x:s, f x.1) :=
⟨λ H a b h, subtype.eq $ H a.2 b.2 h,
 λ H a b as bs h, congr_arg subtype.val $ @H ⟨a, as⟩ ⟨b, bs⟩ h⟩

/- surjectivity -/

/-- `f` is surjective from `a` to `b` if `b` is contained in the image of `a`. -/
@[reducible] def surj_on (f : α → β) (a : set α) (b : set β) : Prop := b ⊆ f '' a

theorem surj_on_of_eq_on {f1 f2 : α → β} {a : set α} {b : set β} (h₁ : eq_on f1 f2 a)
    (h₂ : surj_on f1 a b) :
  surj_on f2 a b :=
λ _ h, let ⟨x, hx⟩ := h₂ h in
⟨x, hx.left, by rw [←h₁ _ hx.left]; exact hx.right⟩

theorem surj_on_comp {g : β → γ} {f : α → β} {a : set α} {b : set β} {c : set γ}
  (h₁ : surj_on g b c) (h₂ : surj_on f a b) :
  surj_on (g ∘ f) a c :=
λ z h, let ⟨y, hy⟩ := h₁ h, ⟨x, hx⟩ := h₂ hy.left in
       ⟨x, hx.left, calc g (f x) = g y : by rw [hx.right]
                          ...    = z   : hy.right⟩

lemma surjective_iff_surj_on_univ {f : α → β} : surjective f ↔ surj_on f univ univ :=
by simp [surjective, surj_on, subset_def]

lemma surj_on_iff_surjective {f : α → β} {s : set α} : surj_on f s univ ↔ surjective (λ x:s, f x.1) :=
⟨λ H b, let ⟨a, as, e⟩ := @H b trivial in ⟨⟨a, as⟩, e⟩,
 λ H b _, let ⟨⟨a, as⟩, e⟩ := H b in ⟨a, as, e⟩⟩

lemma image_eq_of_maps_to_of_surj_on {f : α → β} {a : set α} {b : set β}
    (h₁ : maps_to f a b) (h₂ : surj_on f a b) :
  f '' a = b :=
eq_of_subset_of_subset (image_subset_of_maps_to h₁) h₂

/- bijectivity -/

/-- `f` is bijective from `a` to `b` if `f` is injective on `a` and `f '' a = b`. -/
@[reducible] def bij_on (f : α → β) (a : set α) (b : set β) : Prop :=
maps_to f a b ∧ inj_on f a ∧ surj_on f a b

lemma maps_to_of_bij_on {f : α → β} {a : set α} {b : set β} (h : bij_on f a b) :
      maps_to f a b :=
h.left

lemma inj_on_of_bij_on {f : α → β} {a : set α} {b : set β} (h : bij_on f a b) :
      inj_on f a :=
h.right.left

lemma surj_on_of_bij_on {f : α → β} {a : set α} {b : set β} (h : bij_on f a b) :
      surj_on f a b :=
h.right.right

lemma bij_on.mk {f : α → β} {a : set α} {b : set β}
                (h₁ : maps_to f a b) (h₂ : inj_on f a) (h₃ : surj_on f a b) :
      bij_on f a b :=
⟨h₁, h₂, h₃⟩

theorem bij_on_of_eq_on {f1 f2 : α → β} {a : set α} {b : set β} (h₁ : eq_on f1 f2 a)
     (h₂ : bij_on f1 a b) : bij_on f2 a b :=
let ⟨map, inj, surj⟩ := h₂ in
⟨maps_to_of_eq_on h₁ map, inj_on_of_eq_on h₁ inj, surj_on_of_eq_on h₁ surj⟩

lemma image_eq_of_bij_on {f : α → β} {a : set α} {b : set β} (h : bij_on f a b) :
  f '' a = b :=
image_eq_of_maps_to_of_surj_on h.left h.right.right

theorem bij_on_comp {g : β → γ} {f : α → β} {a : set α} {b : set β} {c : set γ}
  (h₁ : bij_on g b c) (h₂: bij_on f a b) :
  bij_on (g ∘ f) a c :=
let ⟨gmap, ginj, gsurj⟩ := h₁, ⟨fmap, finj, fsurj⟩ := h₂ in
⟨maps_to_comp gmap fmap, inj_on_comp fmap ginj finj, surj_on_comp gsurj fsurj⟩

lemma bijective_iff_bij_on_univ {f : α → β} : bijective f ↔ bij_on f univ univ :=
iff.intro
(λ h, let ⟨inj, surj⟩ := h in
⟨maps_to_univ f _, iff.mp injective_iff_inj_on_univ inj, iff.mp surjective_iff_surj_on_univ surj⟩)
(λ h, let ⟨map, inj, surj⟩ := h in
⟨iff.mpr injective_iff_inj_on_univ inj, iff.mpr surjective_iff_surj_on_univ surj⟩)

/- left inverse -/

/-- `g` is a left inverse to `f` on `a` means that `g (f x) = x` for all `x ∈ a`. -/
@[reducible] def left_inv_on (g : β → α) (f : α → β) (a : set α) : Prop :=
∀ x ∈ a, g (f x) = x

theorem left_inv_on_of_eq_on_left {g1 g2 : β → α} {f : α → β} {a : set α} {b : set β}
  (h₁ : maps_to f a b) (h₂ : eq_on g1 g2 b) (h₃ : left_inv_on g1 f a) : left_inv_on g2 f a :=
λ x h,
calc
  g2 (f x) = g1 (f x) : eq.symm $ h₂ _ (h₁ h)
       ... = x        : h₃ _ h

theorem left_inv_on_of_eq_on_right {g : β → α} {f1 f2 : α → β} {a : set α}
  (h₁ : eq_on f1 f2 a) (h₂ : left_inv_on g f1 a) : left_inv_on g f2 a :=
λ x h,
calc
  g (f2 x) = g (f1 x) : congr_arg g (h₁ _ h).symm
       ... = x        : h₂ _ h

theorem inj_on_of_left_inv_on {g : β → α} {f : α → β} {a : set α} (h : left_inv_on g f a) :
  inj_on f a :=
λ x₁ x₂ h₁ h₂ heq,
calc
  x₁    = g (f x₁) : eq.symm $ h _ h₁
  ...   = g (f x₂) : congr_arg g heq
  ...   = x₂       : h _ h₂

theorem left_inv_on_comp {f' : β → α} {g' : γ → β} {g : β → γ} {f : α → β}
   {a : set α} {b : set β} (h₁ : maps_to f a b)
    (h₂ : left_inv_on f' f a) (h₃ : left_inv_on g' g b) : left_inv_on (f' ∘ g') (g ∘ f) a :=
λ x h,
calc
  (f' ∘ g') ((g ∘ f) x) = f' (f x) : congr_arg f' (h₃ _ (h₁ h))
  ...                   = x        : h₂ _ h

/- right inverse -/

/-- `g` is a right inverse to `f` on `b` if `f (g x) = x` for all `x ∈ b`. -/
@[reducible] def right_inv_on (g : β → α) (f : α → β) (b : set β) : Prop :=
left_inv_on f g b

theorem right_inv_on_of_eq_on_left {g1 g2 : β → α} {f : α → β} {a : set α} {b : set β}
  (h₁ : eq_on g1 g2 b) (h₂ : right_inv_on g1 f b) : right_inv_on g2 f b :=
left_inv_on_of_eq_on_right h₁ h₂

theorem right_inv_on_of_eq_on_right {g : β → α} {f1 f2 : α → β} {a : set α} {b : set β}
  (h₁ : maps_to g b a) (h₂ : eq_on f1 f2 a) (h₃ : right_inv_on g f1 b) : right_inv_on g f2 b :=
left_inv_on_of_eq_on_left h₁ h₂ h₃

theorem surj_on_of_right_inv_on {g : β → α} {f : α → β} {a : set α} {b : set β}
    (h₁ : maps_to g b a) (h₂ : right_inv_on g f b) :
  surj_on f a b :=
λ y h, ⟨g y, h₁ h, h₂ _ h⟩

theorem right_inv_on_comp {f' : β → α} {g' : γ → β} {g : β → γ} {f : α → β}
   {c : set γ} {b : set β} (g'cb : maps_to g' c b)
    (h₁ : right_inv_on f' f b) (h₂ : right_inv_on g' g c) : right_inv_on (f' ∘ g') (g ∘ f) c :=
left_inv_on_comp g'cb h₂ h₁

theorem right_inv_on_of_inj_on_of_left_inv_on {f : α → β} {g : β → α} {a : set α} {b : set β}
    (h₁ : maps_to f a b) (h₂ : maps_to g b a) (h₃ : inj_on f a) (h₄ : left_inv_on f g b) :
  right_inv_on f g a :=
λ x h, h₃ (h₂ $ h₁ h) h (h₄ _ (h₁ h))

theorem eq_on_of_left_inv_of_right_inv {g₁ g₂ : β → α} {f : α → β} {a : set α} {b : set β}
  (h₁ : maps_to g₂ b a) (h₂ : left_inv_on g₁ f a) (h₃ : right_inv_on g₂ f b) : eq_on g₁ g₂ b :=
λ y h,
calc
  g₁ y = (g₁ ∘ f ∘ g₂) y : congr_arg g₁ (h₃ _ h).symm
  ...  = g₂ y            : h₂ _ (h₁ h)

theorem left_inv_on_of_surj_on_right_inv_on {f : α → β} {g : β → α} {a : set α} {b : set β}
    (h₁ : surj_on f a b) (h₂ : right_inv_on f g a) :
  left_inv_on f g b :=
λ y h, let ⟨x, hx, heq⟩ := h₁ h in
calc
  (f ∘ g) y = (f ∘ g ∘ f) x : congr_arg (f ∘ g) heq.symm
  ...     = f x             : congr_arg f (h₂ _ hx)
  ...     = y               : heq

/- inverses -/

/-- `g` is an inverse to `f` viewed as a map from `a` to `b` -/
@[reducible] def inv_on (g : β → α) (f : α → β) (a : set α) (b : set β) : Prop :=
left_inv_on g f a ∧ right_inv_on g f b

theorem bij_on_of_inv_on {g : β → α} {f : α → β} {a : set α} {b : set β} (h₁ : maps_to f a b)
  (h₂ : maps_to g b a) (h₃ : inv_on g f a b) : bij_on f a b :=
⟨h₁, inj_on_of_left_inv_on h₃.left, surj_on_of_right_inv_on h₂ h₃.right⟩

end set


/-
Copyright (c) 2019 Rohan Mitta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rohan Mitta, Kevin Buzzard, Alistair Tucker, Johannes Hölzl, Yury Kudryashov

! This file was ported from Lean 3 source module topology.metric_space.contracting
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecificLimits.Basic
import Mathbin.Data.Setoid.Basic
import Mathbin.Dynamics.FixedPoints.Topology

/-!
# Contracting maps

A Lipschitz continuous self-map with Lipschitz constant `K < 1` is called a *contracting map*.
In this file we prove the Banach fixed point theorem, some explicit estimates on the rate
of convergence, and some properties of the map sending a contracting map to its fixed point.

## Main definitions

* `contracting_with K f` : a Lipschitz continuous self-map with `K < 1`;
* `efixed_point` : given a contracting map `f` on a complete emetric space and a point `x`
  such that `edist x (f x) ≠ ∞`, `efixed_point f hf x hx` is the unique fixed point of `f`
  in `emetric.ball x ∞`;
* `fixed_point` : the unique fixed point of a contracting map on a complete nonempty metric space.

## Tags

contracting map, fixed point, Banach fixed point theorem
-/

open NNReal Topology Classical ENNReal

open Filter Function

variable {α : Type _}

/-- A map is said to be `contracting_with K`, if `K < 1` and `f` is `lipschitz_with K`. -/
def ContractingWith [EMetricSpace α] (K : ℝ≥0) (f : α → α) :=
  K < 1 ∧ LipschitzWith K f
#align contracting_with ContractingWith

namespace ContractingWith

variable [EMetricSpace α] [cs : CompleteSpace α] {K : ℝ≥0} {f : α → α}

open Emetric Set

theorem to_lipschitzWith (hf : ContractingWith K f) : LipschitzWith K f :=
  hf.2
#align contracting_with.to_lipschitz_with ContractingWith.to_lipschitzWith

theorem one_sub_K_pos' (hf : ContractingWith K f) : (0 : ℝ≥0∞) < 1 - K := by simp [hf.1]
#align contracting_with.one_sub_K_pos' ContractingWith.one_sub_K_pos'

theorem one_sub_K_ne_zero (hf : ContractingWith K f) : (1 : ℝ≥0∞) - K ≠ 0 :=
  ne_of_gt hf.one_sub_K_pos'
#align contracting_with.one_sub_K_ne_zero ContractingWith.one_sub_K_ne_zero

theorem one_sub_K_ne_top : (1 : ℝ≥0∞) - K ≠ ∞ :=
  by
  norm_cast
  exact ENNReal.coe_ne_top
#align contracting_with.one_sub_K_ne_top ContractingWith.one_sub_K_ne_top

theorem edist_inequality (hf : ContractingWith K f) {x y} (h : edist x y ≠ ∞) :
    edist x y ≤ (edist x (f x) + edist y (f y)) / (1 - K) :=
  suffices edist x y ≤ edist x (f x) + edist y (f y) + K * edist x y by
    rwa [ENNReal.le_div_iff_mul_le (Or.inl hf.one_sub_K_ne_zero) (Or.inl one_sub_K_ne_top),
      mul_comm, ENNReal.sub_mul fun _ _ => h, one_mul, tsub_le_iff_right]
  calc
    edist x y ≤ edist x (f x) + edist (f x) (f y) + edist (f y) y := edist_triangle4 _ _ _ _
    _ = edist x (f x) + edist y (f y) + edist (f x) (f y) := by rw [edist_comm y, add_right_comm]
    _ ≤ edist x (f x) + edist y (f y) + K * edist x y := add_le_add le_rfl (hf.2 _ _)

#align contracting_with.edist_inequality ContractingWith.edist_inequality

theorem edist_le_of_fixed_point (hf : ContractingWith K f) {x y} (h : edist x y ≠ ∞)
    (hy : IsFixedPt f y) : edist x y ≤ edist x (f x) / (1 - K) := by
  simpa only [hy.eq, edist_self, add_zero] using hf.edist_inequality h
#align contracting_with.edist_le_of_fixed_point ContractingWith.edist_le_of_fixed_point

theorem eq_or_edist_eq_top_of_fixed_points (hf : ContractingWith K f) {x y} (hx : IsFixedPt f x)
    (hy : IsFixedPt f y) : x = y ∨ edist x y = ∞ :=
  by
  refine' or_iff_not_imp_right.2 fun h => edist_le_zero.1 _
  simpa only [hx.eq, edist_self, add_zero, ENNReal.zero_div] using hf.edist_le_of_fixed_point h hy
#align contracting_with.eq_or_edist_eq_top_of_fixed_points ContractingWith.eq_or_edist_eq_top_of_fixed_points

/-- If a map `f` is `contracting_with K`, and `s` is a forward-invariant set, then
restriction of `f` to `s` is `contracting_with K` as well. -/
theorem restrict (hf : ContractingWith K f) {s : Set α} (hs : MapsTo f s s) :
    ContractingWith K (hs.restrict f s s) :=
  ⟨hf.1, fun x y => hf.2 x y⟩
#align contracting_with.restrict ContractingWith.restrict

include cs

/-- Banach fixed-point theorem, contraction mapping theorem, `emetric_space` version.
A contracting map on a complete metric space has a fixed point.
We include more conclusions in this theorem to avoid proving them again later.

The main API for this theorem are the functions `efixed_point` and `fixed_point`,
and lemmas about these functions. -/
theorem exists_fixed_point (hf : ContractingWith K f) (x : α) (hx : edist x (f x) ≠ ∞) :
    ∃ y,
      IsFixedPt f y ∧
        Tendsto (fun n => (f^[n]) x) atTop (𝓝 y) ∧
          ∀ n : ℕ, edist ((f^[n]) x) y ≤ edist x (f x) * K ^ n / (1 - K) :=
  have : CauchySeq fun n => (f^[n]) x :=
    cauchySeq_of_edist_le_geometric K (edist x (f x)) (ENNReal.coe_lt_one_iff.2 hf.1) hx
      (hf.to_lipschitzWith.edist_iterate_succ_le_geometric x)
  let ⟨y, hy⟩ := cauchySeq_tendsto_of_complete this
  ⟨y, isFixedPt_of_tendsto_iterate hy hf.2.Continuous.ContinuousAt, hy,
    edist_le_of_edist_le_geometric_of_tendsto K (edist x (f x))
      (hf.to_lipschitzWith.edist_iterate_succ_le_geometric x) hy⟩
#align contracting_with.exists_fixed_point ContractingWith.exists_fixed_point

variable (f)

-- avoid `efixed_point _` in pretty printer
/-- Let `x` be a point of a complete emetric space. Suppose that `f` is a contracting map,
and `edist x (f x) ≠ ∞`. Then `efixed_point` is the unique fixed point of `f`
in `emetric.ball x ∞`. -/
noncomputable def efixedPoint (hf : ContractingWith K f) (x : α) (hx : edist x (f x) ≠ ∞) : α :=
  Classical.choose <| hf.exists_fixed_point x hx
#align contracting_with.efixed_point ContractingWith.efixedPoint

variable {f}

theorem efixedPoint_isFixedPt (hf : ContractingWith K f) {x : α} (hx : edist x (f x) ≠ ∞) :
    IsFixedPt f (efixedPoint f hf x hx) :=
  (Classical.choose_spec <| hf.exists_fixed_point x hx).1
#align contracting_with.efixed_point_is_fixed_pt ContractingWith.efixedPoint_isFixedPt

theorem tendsto_iterate_efixedPoint (hf : ContractingWith K f) {x : α} (hx : edist x (f x) ≠ ∞) :
    Tendsto (fun n => (f^[n]) x) atTop (𝓝 <| efixedPoint f hf x hx) :=
  (Classical.choose_spec <| hf.exists_fixed_point x hx).2.1
#align contracting_with.tendsto_iterate_efixed_point ContractingWith.tendsto_iterate_efixedPoint

theorem apriori_edist_iterate_efixedPoint_le (hf : ContractingWith K f) {x : α}
    (hx : edist x (f x) ≠ ∞) (n : ℕ) :
    edist ((f^[n]) x) (efixedPoint f hf x hx) ≤ edist x (f x) * K ^ n / (1 - K) :=
  (Classical.choose_spec <| hf.exists_fixed_point x hx).2.2 n
#align contracting_with.apriori_edist_iterate_efixed_point_le ContractingWith.apriori_edist_iterate_efixedPoint_le

theorem edist_efixedPoint_le (hf : ContractingWith K f) {x : α} (hx : edist x (f x) ≠ ∞) :
    edist x (efixedPoint f hf x hx) ≤ edist x (f x) / (1 - K) :=
  by
  convert hf.apriori_edist_iterate_efixed_point_le hx 0
  simp only [pow_zero, mul_one]
#align contracting_with.edist_efixed_point_le ContractingWith.edist_efixedPoint_le

theorem edist_efixedPoint_lt_top (hf : ContractingWith K f) {x : α} (hx : edist x (f x) ≠ ∞) :
    edist x (efixedPoint f hf x hx) < ∞ :=
  (hf.edist_efixedPoint_le hx).trans_lt
    (ENNReal.mul_lt_top hx <| ENNReal.inv_ne_top.2 hf.one_sub_K_ne_zero)
#align contracting_with.edist_efixed_point_lt_top ContractingWith.edist_efixedPoint_lt_top

theorem efixedPoint_eq_of_edist_lt_top (hf : ContractingWith K f) {x : α} (hx : edist x (f x) ≠ ∞)
    {y : α} (hy : edist y (f y) ≠ ∞) (h : edist x y ≠ ∞) :
    efixedPoint f hf x hx = efixedPoint f hf y hy :=
  by
  refine'
      (hf.eq_or_edist_eq_top_of_fixed_points _ _).elim id fun h' => False.elim (ne_of_lt _ h') <;>
    try apply efixed_point_is_fixed_pt
  change edist_lt_top_setoid.rel _ _
  trans x;
  · symm
    exact hf.edist_efixed_point_lt_top hx
  trans y
  exacts[lt_top_iff_ne_top.2 h, hf.edist_efixed_point_lt_top hy]
#align contracting_with.efixed_point_eq_of_edist_lt_top ContractingWith.efixedPoint_eq_of_edist_lt_top

omit cs

/-- Banach fixed-point theorem for maps contracting on a complete subset. -/
theorem exists_fixed_point' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
    ∃ y ∈ s,
      IsFixedPt f y ∧
        Tendsto (fun n => (f^[n]) x) atTop (𝓝 y) ∧
          ∀ n : ℕ, edist ((f^[n]) x) y ≤ edist x (f x) * K ^ n / (1 - K) :=
  by
  haveI := hsc.complete_space_coe
  rcases hf.exists_fixed_point ⟨x, hxs⟩ hx with ⟨y, hfy, h_tendsto, hle⟩
  refine' ⟨y, y.2, Subtype.ext_iff_val.1 hfy, _, fun n => _⟩
  · convert(continuous_subtype_coe.tendsto _).comp h_tendsto
    ext n
    simp only [(· ∘ ·), maps_to.iterate_restrict, maps_to.coe_restrict_apply, Subtype.coe_mk]
  · convert hle n
    rw [maps_to.iterate_restrict, eq_comm, maps_to.coe_restrict_apply, Subtype.coe_mk]
#align contracting_with.exists_fixed_point' ContractingWith.exists_fixed_point'

variable (f)

-- avoid `efixed_point _` in pretty printer
/-- Let `s` be a complete forward-invariant set of a self-map `f`. If `f` contracts on `s`
and `x ∈ s` satisfies `edist x (f x) ≠ ∞`, then `efixed_point'` is the unique fixed point
of the restriction of `f` to `s ∩ emetric.ball x ∞`. -/
noncomputable def efixedPoint' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) (x : α) (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
    α :=
  Classical.choose <| hf.exists_fixed_point' hsc hsf hxs hx
#align contracting_with.efixed_point' ContractingWith.efixedPoint'

variable {f}

theorem efixed_point_mem' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
    efixedPoint' f hsc hsf hf x hxs hx ∈ s :=
  (Classical.choose_spec <| hf.exists_fixed_point' hsc hsf hxs hx).fst
#align contracting_with.efixed_point_mem' ContractingWith.efixed_point_mem'

theorem efixed_point_is_fixed_pt' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
    IsFixedPt f (efixedPoint' f hsc hsf hf x hxs hx) :=
  (Classical.choose_spec <| hf.exists_fixed_point' hsc hsf hxs hx).snd.1
#align contracting_with.efixed_point_is_fixed_pt' ContractingWith.efixed_point_is_fixed_pt'

theorem tendsto_iterate_efixedPoint' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
    Tendsto (fun n => (f^[n]) x) atTop (𝓝 <| efixedPoint' f hsc hsf hf x hxs hx) :=
  (Classical.choose_spec <| hf.exists_fixed_point' hsc hsf hxs hx).snd.2.1
#align contracting_with.tendsto_iterate_efixed_point' ContractingWith.tendsto_iterate_efixedPoint'

theorem apriori_edist_iterate_efixed_point_le' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞)
    (n : ℕ) :
    edist ((f^[n]) x) (efixedPoint' f hsc hsf hf x hxs hx) ≤ edist x (f x) * K ^ n / (1 - K) :=
  (Classical.choose_spec <| hf.exists_fixed_point' hsc hsf hxs hx).snd.2.2 n
#align contracting_with.apriori_edist_iterate_efixed_point_le' ContractingWith.apriori_edist_iterate_efixed_point_le'

theorem edist_efixed_point_le' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
    edist x (efixedPoint' f hsc hsf hf x hxs hx) ≤ edist x (f x) / (1 - K) :=
  by
  convert hf.apriori_edist_iterate_efixed_point_le' hsc hsf hxs hx 0
  rw [pow_zero, mul_one]
#align contracting_with.edist_efixed_point_le' ContractingWith.edist_efixed_point_le'

theorem edist_efixed_point_lt_top' {s : Set α} (hsc : IsComplete s) (hsf : MapsTo f s s)
    (hf : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
    edist x (efixedPoint' f hsc hsf hf x hxs hx) < ∞ :=
  (hf.edist_efixed_point_le' hsc hsf hxs hx).trans_lt
    (ENNReal.mul_lt_top hx <| ENNReal.inv_ne_top.2 hf.one_sub_K_ne_zero)
#align contracting_with.edist_efixed_point_lt_top' ContractingWith.edist_efixed_point_lt_top'

/-- If a globally contracting map `f` has two complete forward-invariant sets `s`, `t`,
and `x ∈ s` is at a finite distance from `y ∈ t`, then the `efixed_point'` constructed by `x`
is the same as the `efixed_point'` constructed by `y`.

This lemma takes additional arguments stating that `f` contracts on `s` and `t` because this way
it can be used to prove the desired equality with non-trivial proofs of these facts. -/
theorem efixed_point_eq_of_edist_lt_top' (hf : ContractingWith K f) {s : Set α} (hsc : IsComplete s)
    (hsf : MapsTo f s s) (hfs : ContractingWith K <| hsf.restrict f s s) {x : α} (hxs : x ∈ s)
    (hx : edist x (f x) ≠ ∞) {t : Set α} (htc : IsComplete t) (htf : MapsTo f t t)
    (hft : ContractingWith K <| htf.restrict f t t) {y : α} (hyt : y ∈ t) (hy : edist y (f y) ≠ ∞)
    (hxy : edist x y ≠ ∞) :
    efixedPoint' f hsc hsf hfs x hxs hx = efixedPoint' f htc htf hft y hyt hy :=
  by
  refine'
      (hf.eq_or_edist_eq_top_of_fixed_points _ _).elim id fun h' => False.elim (ne_of_lt _ h') <;>
    try apply efixed_point_is_fixed_pt'
  change edist_lt_top_setoid.rel _ _
  trans x;
  · symm
    apply edist_efixed_point_lt_top'
  trans y
  exact lt_top_iff_ne_top.2 hxy
  apply edist_efixed_point_lt_top'
#align contracting_with.efixed_point_eq_of_edist_lt_top' ContractingWith.efixed_point_eq_of_edist_lt_top'

end ContractingWith

namespace ContractingWith

variable [MetricSpace α] {K : ℝ≥0} {f : α → α} (hf : ContractingWith K f)

include hf

theorem one_sub_K_pos (hf : ContractingWith K f) : (0 : ℝ) < 1 - K :=
  sub_pos.2 hf.1
#align contracting_with.one_sub_K_pos ContractingWith.one_sub_K_pos

theorem dist_le_mul (x y : α) : dist (f x) (f y) ≤ K * dist x y :=
  hf.to_lipschitzWith.dist_le_mul x y
#align contracting_with.dist_le_mul ContractingWith.dist_le_mul

theorem dist_inequality (x y) : dist x y ≤ (dist x (f x) + dist y (f y)) / (1 - K) :=
  suffices dist x y ≤ dist x (f x) + dist y (f y) + K * dist x y by
    rwa [le_div_iff hf.one_sub_K_pos, mul_comm, sub_mul, one_mul, sub_le_iff_le_add]
  calc
    dist x y ≤ dist x (f x) + dist y (f y) + dist (f x) (f y) := dist_triangle4_right _ _ _ _
    _ ≤ dist x (f x) + dist y (f y) + K * dist x y := add_le_add_left (hf.dist_le_mul _ _) _

#align contracting_with.dist_inequality ContractingWith.dist_inequality

theorem dist_le_of_fixed_point (x) {y} (hy : IsFixedPt f y) : dist x y ≤ dist x (f x) / (1 - K) :=
  by simpa only [hy.eq, dist_self, add_zero] using hf.dist_inequality x y
#align contracting_with.dist_le_of_fixed_point ContractingWith.dist_le_of_fixed_point

theorem fixed_point_unique' {x y} (hx : IsFixedPt f x) (hy : IsFixedPt f y) : x = y :=
  (hf.eq_or_edist_eq_top_of_fixed_points hx hy).resolve_right (edist_ne_top _ _)
#align contracting_with.fixed_point_unique' ContractingWith.fixed_point_unique'

/-- Let `f` be a contracting map with constant `K`; let `g` be another map uniformly
`C`-close to `f`. If `x` and `y` are their fixed points, then `dist x y ≤ C / (1 - K)`. -/
theorem dist_fixed_point_fixed_point_of_dist_le' (g : α → α) {x y} (hx : IsFixedPt f x)
    (hy : IsFixedPt g y) {C} (hfg : ∀ z, dist (f z) (g z) ≤ C) : dist x y ≤ C / (1 - K) :=
  calc
    dist x y = dist y x := dist_comm x y
    _ ≤ dist y (f y) / (1 - K) := (hf.dist_le_of_fixed_point y hx)
    _ = dist (f y) (g y) / (1 - K) := by rw [hy.eq, dist_comm]
    _ ≤ C / (1 - K) := (div_le_div_right hf.one_sub_K_pos).2 (hfg y)

#align contracting_with.dist_fixed_point_fixed_point_of_dist_le' ContractingWith.dist_fixed_point_fixed_point_of_dist_le'

noncomputable section

variable [Nonempty α] [CompleteSpace α]

variable (f)

/-- The unique fixed point of a contracting map in a nonempty complete metric space. -/
def fixedPoint : α :=
  efixedPoint f hf _ (edist_ne_top (Classical.choice ‹Nonempty α›) _)
#align contracting_with.fixed_point ContractingWith.fixedPoint

variable {f}

/-- The point provided by `contracting_with.fixed_point` is actually a fixed point. -/
theorem fixedPoint_isFixedPt : IsFixedPt f (fixedPoint f hf) :=
  hf.efixedPoint_isFixedPt _
#align contracting_with.fixed_point_is_fixed_pt ContractingWith.fixedPoint_isFixedPt

theorem fixedPoint_unique {x} (hx : IsFixedPt f x) : x = fixedPoint f hf :=
  hf.fixed_point_unique' hx hf.fixedPoint_isFixedPt
#align contracting_with.fixed_point_unique ContractingWith.fixedPoint_unique

theorem dist_fixedPoint_le (x) : dist x (fixedPoint f hf) ≤ dist x (f x) / (1 - K) :=
  hf.dist_le_of_fixed_point x hf.fixedPoint_isFixedPt
#align contracting_with.dist_fixed_point_le ContractingWith.dist_fixedPoint_le

/-- Aposteriori estimates on the convergence of iterates to the fixed point. -/
theorem aposteriori_dist_iterate_fixedPoint_le (x n) :
    dist ((f^[n]) x) (fixedPoint f hf) ≤ dist ((f^[n]) x) ((f^[n + 1]) x) / (1 - K) :=
  by
  rw [iterate_succ']
  apply hf.dist_fixed_point_le
#align contracting_with.aposteriori_dist_iterate_fixed_point_le ContractingWith.aposteriori_dist_iterate_fixedPoint_le

theorem apriori_dist_iterate_fixedPoint_le (x n) :
    dist ((f^[n]) x) (fixedPoint f hf) ≤ dist x (f x) * K ^ n / (1 - K) :=
  le_trans (hf.aposteriori_dist_iterate_fixedPoint_le x n) <|
    (div_le_div_right hf.one_sub_K_pos).2 <| hf.to_lipschitzWith.dist_iterate_succ_le_geometric x n
#align contracting_with.apriori_dist_iterate_fixed_point_le ContractingWith.apriori_dist_iterate_fixedPoint_le

theorem tendsto_iterate_fixedPoint (x) :
    Tendsto (fun n => (f^[n]) x) atTop (𝓝 <| fixedPoint f hf) :=
  by
  convert tendsto_iterate_efixed_point hf (edist_ne_top x _)
  refine' (fixed_point_unique _ _).symm
  apply efixed_point_is_fixed_pt
#align contracting_with.tendsto_iterate_fixed_point ContractingWith.tendsto_iterate_fixedPoint

theorem fixedPoint_lipschitz_in_map {g : α → α} (hg : ContractingWith K g) {C}
    (hfg : ∀ z, dist (f z) (g z) ≤ C) : dist (fixedPoint f hf) (fixedPoint g hg) ≤ C / (1 - K) :=
  hf.dist_fixed_point_fixed_point_of_dist_le' g hf.fixedPoint_isFixedPt hg.fixedPoint_isFixedPt hfg
#align contracting_with.fixed_point_lipschitz_in_map ContractingWith.fixedPoint_lipschitz_in_map

omit hf

/-- If a map `f` has a contracting iterate `f^[n]`, then the fixed point of `f^[n]` is also a fixed
point of `f`. -/
theorem isFixedPt_fixedPoint_iterate {n : ℕ} (hf : ContractingWith K (f^[n])) :
    IsFixedPt f (hf.fixedPoint (f^[n])) :=
  by
  set x := hf.fixed_point (f^[n])
  have hx : (f^[n]) x = x := hf.fixed_point_is_fixed_pt
  have := hf.to_lipschitz_with.dist_le_mul x (f x)
  rw [← iterate_succ_apply, iterate_succ_apply', hx] at this
  contrapose! this
  have := dist_pos.2 (Ne.symm this)
  simpa only [NNReal.coe_one, one_mul, NNReal.val_eq_coe] using (mul_lt_mul_right this).mpr hf.left
#align contracting_with.is_fixed_pt_fixed_point_iterate ContractingWith.isFixedPt_fixedPoint_iterate

end ContractingWith


universe u

/-- Well-known definition of Rings, found e.g. here:
    https://en.wikipedia.org/wiki/Ring_(mathematics)
    i've chosen to include the axioms altogether in one block, this doesn't make too much of a
    difference for how i use my rings, i'll do a similar thing when defining Ideals, but make the
    other choice, to include each axiom seperately, when defining Semi-Rings -/
structure Ring :=
(R : Type u)
(ring_struct : (R → R → R) × (R → R → R) × R × R)
(plus_assoc : ∀ x y z : R, ring_struct.1 x (ring_struct.1 y z)
                         = ring_struct.1 (ring_struct.1 x y) z)
(plus_comm  : ∀ x y : R, ring_struct.1 x y = ring_struct.1 y x)
(plus_iden  : ∀ x : R, ring_struct.1 x ring_struct.2.2.1 = x)
(plus_inv   : ∀ x : R, ∃ x' : R, ring_struct.1 x x' = ring_struct.2.2.1)
(mult_assoc : ∀ x y z : R, ring_struct.2.1 x (ring_struct.2.1 y z)
                         = ring_struct.2.1 (ring_struct.2.1 x y) z)
(mult_riden : ∀ x : R, ring_struct.2.1 x ring_struct.2.2.2 = x)
(mult_liden : ∀ x : R, ring_struct.2.1 ring_struct.2.2.2 x = x)
(left_distributivity : ∀ x y z : R, ring_struct.2.1 x (ring_struct.1 y z)
                                  = ring_struct.1 (ring_struct.2.1 x y) (ring_struct.2.1 x z))
(right_distributivity : ∀ x y z : R, ring_struct.2.1 (ring_struct.1 x y) z
                                   = ring_struct.1 (ring_struct.2.1 x z) (ring_struct.2.1 y z))

-- it's because of the following definitions and lemmas that i can use rings in a natural way

def plus {R : Ring} :=
R.ring_struct.1
local infixr ` + ` : 80 := plus

def mult {R : Ring} :=
R.ring_struct.2.1
local infixr ` * ` : 80 := mult

def zero {R : Ring} :=
R.ring_struct.2.2.1

def one {R : Ring} :=
R.ring_struct.2.2.2

def plus_assoc {R : Ring} : ∀ x y z : R.R, x + y + z = (x + y) + z :=
R.plus_assoc

def plus_comm {R : Ring} : ∀ x y : R.R, x + y = y + x :=
R.plus_comm

def plus_inv {R : Ring} : ∀ x : R.R, ∃ x' : R.R, x + x' = zero :=
R.plus_inv

def zero_plus_neutral {R : Ring} : ∀ x : R.R, x + zero = x :=
R.plus_iden

lemma zero_plus_neutral' {R : Ring} : ∀ x : R.R, x = x + zero :=
begin
 intro x,
 symmetry,
 exact zero_plus_neutral x,
end

def mult_assoc {R : Ring} : ∀ x y z : R.R, x * y * z = (x * y) * z :=
R.mult_assoc

def one_mult_neutral_right {R : Ring} : ∀ x : R.R, x * one = x :=
R.mult_riden

def one_mult_neutral_left {R : Ring} : ∀ x : R.R, one * x = x :=
R.mult_liden

def left_distributivity {R : Ring} : ∀ x y z : R.R, x * (y + z) = (x * y) + (x * z) :=
R.left_distributivity

def right_distributivity {R : Ring} : ∀ x y z : R.R, (x + y) * z = (x * z) + (y * z) :=
R.right_distributivity

lemma plus_inv_unique {R : Ring} : ∀ x y z : R.R, (x + y = zero ∧ x + z = zero) → y = z :=
begin
 intros x y z h,
 cases h with hy hz,
 calc
  y     = y + zero    : by exact zero_plus_neutral' y
    ... = y + x + z   : by rw hz
    ... = (y + x) + z : by rw plus_assoc y x z
    ... = (x + y) + z : by rw plus_comm y x
    ... = zero + z    : by rw hy
    ... = z + zero    : by exact plus_comm zero z
    ... = z           : by exact zero_plus_neutral z,
end

lemma zero_annihilates_left {R : Ring} : ∀ x : R.R, zero * x = zero :=
begin
 intro x,
 symmetry,
 have h : zero * x = (zero * x) + (zero * x),
 {
  calc
   zero * x     = (zero + zero) * x       : by rw zero_plus_neutral zero
            ... = (zero * x) + (zero * x) : by exact right_distributivity zero zero x,
 },
 have h' : ∃ c : R.R, (zero * x) + c = zero,
 { exact plus_inv (zero * x), },
 cases h' with c hc,
 calc
  zero     = (zero * x) + c                : by { symmetry, exact hc }
       ... = ((zero * x) + (zero * x)) + c : by rw ← h
       ... = (zero * x) + ((zero * x) + c) : by rw plus_assoc (zero * x) (zero * x) c
       ... = (zero * x) + zero             : by rw hc
       ... = zero * x                      : by exact zero_plus_neutral (zero * x),
end

lemma zero_annihilates_right {R : Ring} : ∀ x : R.R, x * zero = zero :=
begin
 intro x,
 symmetry,
 have h : x * zero = (x * zero) + (x * zero),
 {
  calc
   x * zero     = x * zero + zero         : by rw zero_plus_neutral
            ... = (x * zero) + (x * zero) : by exact left_distributivity x zero zero,
 },
 have h' : ∃ c : R.R, (x * zero) + c = zero,
 { exact plus_inv (x * zero), },
 cases h' with c hc,
 calc
  zero     = (x * zero) + c                : by { symmetry, exact hc }
       ... = ((x * zero) + (x * zero)) + c : by rw ← h
       ... = (x * zero) + ((x * zero) + c) : by rw plus_assoc (x * zero) (x * zero) c
       ... = (x * zero) + zero             : by rw hc
       ... = x * zero                      : by exact zero_plus_neutral (x * zero),
end

lemma negative_one {R : Ring} : ∀ x y : R.R, one + x = zero → y + x * y = zero :=
begin
 intros x y hx,
 have h : y = one * y,
 { symmetry,
   exact one_mult_neutral_left y, },
 calc
  y + x * y     = (one * y) + (x * y) : by rw ← h
            ... = (one + x) * y       : by { symmetry, exact right_distributivity one x y }
            ... = zero * y            : by rw hx
            ... = zero                : by exact zero_annihilates_left y,
end


/-
Copyright (c) 2022 Tomaz Gomes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Tomaz Gomes.
-/
import data.list.sort tactic
import data.nat.log
import init.data.nat

import MergeSort.LogLemmas
import MergeSort.Split
import MergeSort.Merge
/-
# Timed Merge Sort
  This file defines a new version of Merge Sort that, besides sorting the input list, counts the
  number of operations made through the execution of the algorithm. Also, it presents proofs of
  it's time complexity and it's equivalence to the one defined in data/list/sort.lean
## Main Definition:
  - Timed.merge_sort : list α → (list α × ℕ)
## Main Results:
  - Timed.merge_sort_complexity :
      ∀ l : list α, (Timed.merge_sort r l).snd ≤ 8 * l.length * nat.log 2 l.length
  - Timed.merge_sort_equivalence :
      ∀ l : list α, (Timed.merge_sort r l).fst = list.merge_sort r l

-/

variables {α : Type} (r : α → α → Prop) [decidable_rel r]
local infix ` ≼ ` : 50 := r

namespace Timed

include r

def merge_sort : list α → (list α × ℕ)
| []            := ([],  0)
| [a]           := ([a], 0)
| (a :: b :: l) := begin
  cases e : split (a :: b :: l) with l₁ l₂n,
  cases l₂n with l₂ n,
  cases length_split_lt e with h₁ h₂,
  have ms₁ := merge_sort l₁,
  have ms₂ := merge_sort l₂,
  have merged := merge r ms₁.fst ms₂.fst,
  have split_ops := (split (a :: b :: l)).snd.snd,
  exact (merged.fst , split_ops + ms₁.snd + ms₂.snd + merged.snd),
end
using_well_founded {
  rel_tac := λ_ _, `[exact ⟨_, inv_image.wf list.length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

theorem merge_sort_cons_cons_fst {a b n} {l l₁ l₂ : list α}
  (h : split (a :: b :: l) = (l₁, l₂, n)) :
  (merge_sort r (a :: b :: l)).fst = (merge r (merge_sort r l₁).fst (merge_sort r l₂).fst).fst :=
begin
  suffices : ∀ (L : list α × ℕ) h1, (@@and.rec
    (λ a a (_ : list.length l₁ < list.length l + 1 + 1 ∧
      list.length l₂ < list.length l + 1 + 1), L) h1 h1).fst = L.fst,
    { simp [merge_sort, h], apply this, },
  intros, cases h1, refl,
end

theorem merge_sort_equivalence : ∀ l : list α , (merge_sort r l).fst = list.merge_sort r l
| []       := by { unfold merge_sort, unfold list.merge_sort }
| [a]      := by { unfold merge_sort, unfold list.merge_sort }
| (a₁ :: a₂ :: t) :=
  have (split (a₁ :: a₂ :: t)).fst.length < (a₁ :: a₂ :: t).length :=
  begin
    cases e : split (a₁ :: a₂ :: t) with l₁ l₂n,
    cases l₂n with l₂ n,
    cases length_split_lt e with h₁ h₂,
    exact h₁,
  end,
  have (split (a₁ :: a₂ :: t)).snd.fst.length < (a₁ :: a₂ :: t).length :=
  begin
    cases e : split (a₁ :: a₂ :: t) with l₁ l₂n,
    cases l₂n with l₂ n,
    cases length_split_lt e with h₁ h₂,
    exact h₂,
  end,
begin
  rw list.merge_sort_cons_cons r (prod.ext rfl rfl),
  rw merge_sort_cons_cons_fst r (prod.ext rfl (prod.ext rfl rfl)),
  rw merge_equivalence,
  rw merge_sort_equivalence,
  rw merge_sort_equivalence,
  rw (split_equivalence (a₁ :: a₂ :: t)).left,
  rw (split_equivalence (a₁ :: a₂ :: t)).right,
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf list.length⟩]}

theorem merge_sort_cons_cons_snd {a b n} {l l₁ l₂ : list α}
  (hs : split (a :: b :: l) = (l₁, l₂, n)) :
  (merge_sort r (a :: b :: l)).snd =
    (split (a :: b :: l)).snd.snd +
    (merge_sort r l₁).snd +
    (merge_sort r l₂).snd +
    (merge r (merge_sort r l₁).fst (merge_sort r l₂).fst).snd :=
begin
  suffices : ∀ (L : list α × ℕ) h1, (@@and.rec
    (λ a a (_ : list.length l₁ < list.length l + 1 + 1 ∧
      list.length l₂ < list.length l + 1 + 1), L) h1 h1).snd = L.snd,
    { simp [merge_sort, hs], apply this, },
  intros, cases h1, refl,
end

theorem merge_sort_complexity : ∀ l : list α,
  (merge_sort r l).snd ≤ 8 * l.length * nat.log 2 l.length
| []  := by { unfold merge_sort, simp only [nat.log_zero_right, list.length, mul_zero] }
| [a] := by { unfold merge_sort, simp only [nat.log_one_right, list.length_singleton, mul_zero] }
| (a₁ :: a₂ :: t) :=
let l := (a₁ :: a₂ :: t) in
begin
  rw merge_sort_cons_cons_snd r (prod.ext rfl (prod.ext rfl rfl)),
  rw split_complexity,
  cases hs : split l with l₁ l₂n,
  cases l₂n with l₂ n,
  have l₁_length : 2 * l₁.length ≤ l.length + 1 := (split_halves_length hs).1,
  have l₂_length : 2 * l₂.length ≤ l.length     := (split_halves_length hs).2,
  have l₂_length_half : l₂.length ≤ l.length / 2 := div_two l.length l₂.length l₂_length,
  have ih₁ := merge_sort_complexity l₁,
  have ih₂ := merge_sort_complexity l₂,
  have t_len_l_len : t.length + 2 = l.length := rfl,
  have l₁_length_weak : l₁.length ≤ l.length := by linarith,
  cases length_split_lt hs with hh₁ hh₂,
  cases h₁ : merge_sort r l₁ with l₁s ns,
  cases h₂ : merge_sort r l₂ with l₂s ms,

  have ms_bound : ms ≤ 4 * l.length * (nat.log 2 l.length - 1) :=
  begin
    have ms_id : (merge_sort r l₂).snd = ms := (congr_arg prod.snd h₂).trans rfl,
    rw ← ms_id,
    refine le_trans ih₂ _,
    rw log_pred l.length,
    calc 8 * l₂.length * nat.log 2 l₂.length
                = 4 * (2 * l₂.length) * nat.log 2 l₂.length :
                      by linarith
            ... ≤ 4 * l.length * nat.log 2 l₂.length :
                      begin
                        rw mul_assoc,
                        rw mul_assoc 4 l.length (nat.log 2 l₂.length),
                        refine (mul_le_mul_left zero_lt_four).mpr _,
                        exact nat.mul_le_mul_right (nat.log 2 l₂.length) l₂_length,
                      end
            ... ≤ 4 * l.length * nat.log 2 (l.length / 2) :
                      begin
                        refine nat.mul_le_mul_left (4 * l.length) _,
                        exact @nat.log_monotone 2 l₂.length (l.length / 2) l₂_length_half,
                      end
  end,

  have ns_bound : ns ≤ 4 * (l.length + 1) * nat.log 2 l.length :=
  begin
    have ns_id : (merge_sort r l₁).snd = ns := (congr_arg prod.snd h₁).trans rfl,
    rw ← ns_id,
    refine le_trans ih₁ _,
    calc 8 * l₁.length * nat.log 2 l₁.length
                = 4 * (2 * l₁.length) * nat.log 2 l₁.length :
                      by linarith
            ... ≤ 4 * (l.length + 1) * nat.log 2 l₁.length :
                      begin
                        rw mul_assoc,
                        rw mul_assoc 4 (l.length + 1) (nat.log 2 l₁.length),
                        refine (mul_le_mul_left zero_lt_four).mpr _,
                        exact nat.mul_le_mul_right (nat.log 2 l₁.length) l₁_length,
                      end
            ... ≤ 4 * (l.length + 1) * nat.log 2 l.length :
                      begin
                        refine nat.mul_le_mul_left (4 * (l.length + 1)) _,
                        exact @nat.log_monotone 2 l₁.length l.length l₁_length_weak,
                      end
  end,

  have split_length : l₁s.length + l₂s.length = l.length :=
  begin
    have l₁s_id : (merge_sort r l₁).fst = l₁s := (congr_arg prod.fst h₁).trans rfl,
    rw merge_sort_equivalence at l₁s_id,
    have same_lengths₁ := list.length_merge_sort r l₁,
    have l₁s_len_l₁_len : l₁s.length = l₁.length :=
    begin
      rw l₁s_id at same_lengths₁,
      exact same_lengths₁,
    end,

    have l₂s_id : (merge_sort r l₂).fst = l₂s := (congr_arg prod.fst h₂).trans rfl,
    rw merge_sort_equivalence at l₂s_id,
    have same_lengths₂ := list.length_merge_sort r l₂,
    have l₂s_len_l₂_len : l₂s.length = l₂.length :=
    begin
      rw l₂s_id at same_lengths₂,
      exact same_lengths₂,
    end,
    rw l₁s_len_l₁_len,
    rw l₂s_len_l₂_len,

    exact split_lengths r l l₁ l₂ hs,
  end,

  simp only [list.length],
  rw t_len_l_len,

  have log_l_length : 1 ≤ nat.log 2 l.length :=
  begin
    calc 1 = nat.log 2 2 : log_2_val.symm
         ... ≤ nat.log 2 l.length : begin
                                      refine @nat.log_monotone 2 2 l.length _,
                                      linarith,
                                    end
  end,

  have four_log_l_length : 4 * 1 * l.length ≤ 4 * nat.log 2 l.length * l.length :=
  begin
    simp only [mul_le_mul_right, nat.succ_pos', mul_one, list.length],
    rw t_len_l_len,
    calc 4 = 4 * 1 : rfl
         ... ≤ 4 * nat.log 2 l.length : begin
                                          refine mul_le_mul' _ log_l_length,
                                          exact le_refl 4,
                                        end
  end,

  calc l.length + ns + ms + (merge r l₁s l₂s).snd
     ≤ l.length + ns + ms + (l₁s.length + l₂s.length) :
          add_le_add_left (merge_complexity r l₁s l₂s) (l.length + ns + ms)
 ... = l.length + ns + ms + l.length :
          congr_arg (has_add.add (list.length l + ns + ms)) split_length
 ... = 2 * l.length + ns + ms :
          by ring
 ... ≤ 2 * l.length + ns + 4 * l.length * (nat.log 2 l.length - 1) :
          begin
            refine add_le_add_left _ (2 * l.length + ns),
            exact ms_bound,
          end
 ... ≤ 2 * l.length + 4 * l.length * (nat.log 2 l.length - 1) + ns :
          by ring_nf
 ... ≤ 2 * l.length + 4 * l.length * (nat.log 2 l.length - 1) + 4 * (l.length + 1) *
       nat.log 2 l.length :
          begin
            refine add_le_add_left _ (2 * l.length + 4 * l.length * (nat.log 2 l.length - 1)),
            exact ns_bound,
          end
 ... ≤ 8 * l.length * nat.log 2 l.length :
          begin
            ring_nf,
            rw [ nat.mul_sub_left_distrib
               , add_mul
               , add_mul
               , nat.mul_sub_right_distrib
               ],
            refine (add_le_add_iff_left (4 * 1 * l.length)).mp _,
            rw [ ← add_assoc
               , ← add_assoc
               , ← add_assoc
               , ← nat.add_sub_assoc four_log_l_length (4 * 1 * l.length)
               , add_comm (4 * 1 * l.length) (4 * nat.log 2 l.length * l.length)
               , nat.add_sub_assoc rfl.ge (4 * nat.log 2 l.length * l.length)
               , nat.sub_self (4 * 1 * l.length)
               ],
            simp only [add_zero, mul_one, list.length],
            rw t_len_l_len,
            ring_nf,
            rw [ add_mul
               , mul_assoc
               , mul_comm l.length (nat.log 2 l.length)
               , ← mul_assoc
               , add_assoc
               ],
            refine (add_le_add_iff_left (8 * nat.log 2 l.length * l.length)).mpr _,
            refine sum_2b (4 * nat.log 2 l.length) l.length _,
            rw ← t_len_l_len,
            have four_two_two: 4 = 2 * 2 := rfl,
            rw four_two_two,
            rw mul_assoc,
            refine mul_le_mul' (le_refl 2) _,
            exact log_2_times t.length,
          end,
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf list.length⟩]}

end Timed


/-
Copyright (c) 2015 Nathaniel Thomas. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nathaniel Thomas, Jeremy Avigad, Johannes Hölzl, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.linear_map
import Mathlib.group_theory.group_action.sub_mul_action
import Mathlib.PostPort

universes u v l w

namespace Mathlib

/-!

# Submodules of a module

In this file we define

* `submodule R M` : a subset of a `module` `M` that contains zero and is closed with respect to addition and
  scalar multiplication.

* `subspace k M` : an abbreviation for `submodule` assuming that `k` is a `field`.

## Tags

submodule, subspace, linear map
-/

/-- A submodule of a module is one which is closed under vector operations.
  This is a sufficient condition for the subset of vectors in the submodule
  to themselves form a module. -/
structure submodule (R : Type u) (M : Type v) [semiring R] [add_comm_monoid M] [semimodule R M]
    extends add_submonoid M, sub_mul_action R M where

/-- Reinterpret a `submodule` as an `add_submonoid`. -/
/-- Reinterpret a `submodule` as an `sub_mul_action`. -/
namespace submodule

protected instance set.has_coe_t {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : has_coe_t (submodule R M) (set M) :=
  has_coe_t.mk fun (s : submodule R M) => carrier s

protected instance has_mem {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : has_mem M (submodule R M) :=
  has_mem.mk fun (x : M) (p : submodule R M) => x ∈ ↑p

protected instance has_coe_to_sort {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : has_coe_to_sort (submodule R M) :=
  has_coe_to_sort.mk (Type (max 0 v)) fun (p : submodule R M) => Subtype fun (x : M) => x ∈ p

@[simp] theorem coe_sort_coe {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] (p : submodule R M) : ↥↑p = ↥p :=
  rfl

protected theorem exists {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M]
    {p : submodule R M} {q : ↥p → Prop} :
    (∃ (x : ↥p), q x) ↔ ∃ (x : M), ∃ (H : x ∈ p), q { val := x, property := H } :=
  set_coe.exists

protected theorem forall {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M]
    {p : submodule R M} {q : ↥p → Prop} :
    (∀ (x : ↥p), q x) ↔ ∀ (x : M) (H : x ∈ p), q { val := x, property := H } :=
  set_coe.forall

theorem coe_injective {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M] :
    function.injective coe :=
  sorry

@[simp] theorem coe_set_eq {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] {p : submodule R M} {q : submodule R M} : ↑p = ↑q ↔ p = q :=
  function.injective.eq_iff coe_injective

@[simp] theorem mk_coe {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M]
    (S : set M) (h₁ : 0 ∈ S) (h₂ : ∀ {a b : M}, a ∈ S → b ∈ S → a + b ∈ S)
    (h₃ : ∀ (c : R) {x : M}, x ∈ S → c • x ∈ S) : ↑(mk S h₁ h₂ h₃) = S :=
  rfl

theorem ext'_iff {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M]
    {p : submodule R M} {q : submodule R M} : p = q ↔ ↑p = ↑q :=
  iff.symm coe_set_eq

theorem ext {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M]
    {p : submodule R M} {q : submodule R M} (h : ∀ (x : M), x ∈ p ↔ x ∈ q) : p = q :=
  coe_injective (set.ext h)

theorem to_add_submonoid_injective {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : function.injective to_add_submonoid :=
  fun (p q : submodule R M) (h : to_add_submonoid p = to_add_submonoid q) =>
    iff.mpr ext'_iff (iff.mp add_submonoid.ext'_iff h)

@[simp] theorem to_add_submonoid_eq {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] {p : submodule R M} {q : submodule R M} :
    to_add_submonoid p = to_add_submonoid q ↔ p = q :=
  function.injective.eq_iff to_add_submonoid_injective

theorem to_sub_mul_action_injective {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : function.injective to_sub_mul_action :=
  fun (p q : submodule R M) (h : to_sub_mul_action p = to_sub_mul_action q) =>
    iff.mpr ext'_iff (iff.mp sub_mul_action.ext'_iff h)

@[simp] theorem to_sub_mul_action_eq {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] {p : submodule R M} {q : submodule R M} :
    to_sub_mul_action p = to_sub_mul_action q ↔ p = q :=
  function.injective.eq_iff to_sub_mul_action_injective

end submodule

namespace submodule

-- We can infer the module structure implicitly from the bundled submodule,

-- rather than via typeclass resolution.

@[simp] theorem mem_carrier {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} : x ∈ carrier p ↔ x ∈ ↑p :=
  iff.rfl

@[simp] theorem mem_coe {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} : x ∈ ↑p ↔ x ∈ p :=
  iff.rfl

@[simp] theorem zero_mem {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : 0 ∈ p :=
  zero_mem' p

theorem add_mem {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} {y : M} (h₁ : x ∈ p) (h₂ : y ∈ p) :
    x + y ∈ p :=
  add_mem' p h₁ h₂

theorem smul_mem {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} (r : R) (h : x ∈ p) : r • x ∈ p :=
  smul_mem' p r h

theorem sum_mem {R : Type u} {M : Type v} {ι : Type w} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {t : finset ι} {f : ι → M} :
    (∀ (c : ι), c ∈ t → f c ∈ p) → (finset.sum t fun (i : ι) => f i) ∈ p :=
  add_submonoid.sum_mem (to_add_submonoid p)

theorem sum_smul_mem {R : Type u} {M : Type v} {ι : Type w} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {t : finset ι} {f : ι → M} (r : ι → R)
    (hyp : ∀ (c : ι), c ∈ t → f c ∈ p) : (finset.sum t fun (i : ι) => r i • f i) ∈ p :=
  sum_mem p fun (i : ι) (hi : i ∈ t) => smul_mem p (r i) (hyp i hi)

@[simp] theorem smul_mem_iff' {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} (u : units R) :
    ↑u • x ∈ p ↔ x ∈ p :=
  sub_mul_action.smul_mem_iff' (to_sub_mul_action p) u

protected instance has_add {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : Add ↥p :=
  { add := fun (x y : ↥p) => { val := subtype.val x + subtype.val y, property := sorry } }

protected instance has_zero {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : HasZero ↥p :=
  { zero := { val := 0, property := zero_mem p } }

protected instance inhabited {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : Inhabited ↥p :=
  { default := 0 }

protected instance has_scalar {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : has_scalar R ↥p :=
  has_scalar.mk fun (c : R) (x : ↥p) => { val := c • subtype.val x, property := sorry }

protected theorem nonempty {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : set.nonempty ↑p :=
  Exists.intro 0 (zero_mem p)

@[simp] theorem mk_eq_zero {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} (h : x ∈ p) :
    { val := x, property := h } = 0 ↔ x = 0 :=
  subtype.ext_iff_val

@[simp] theorem coe_eq_coe {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} {x : ↥p} {y : ↥p} : ↑x = ↑y ↔ x = y :=
  iff.symm subtype.ext_iff_val

@[simp] theorem coe_eq_zero {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} {x : ↥p} : ↑x = 0 ↔ x = 0 :=
  coe_eq_coe

@[simp] theorem coe_add {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} (x : ↥p) (y : ↥p) : ↑(x + y) = ↑x + ↑y :=
  rfl

@[simp] theorem coe_zero {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} : ↑0 = 0 :=
  rfl

@[simp] theorem coe_smul {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} (r : R) (x : ↥p) : ↑(r • x) = r • ↑x :=
  rfl

@[simp] theorem coe_mk {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} (x : M) (hx : x ∈ p) :
    ↑{ val := x, property := hx } = x :=
  rfl

@[simp] theorem coe_mem {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} (x : ↥p) : ↑x ∈ p :=
  subtype.property x

@[simp] protected theorem eta {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} {p : submodule R M} (x : ↥p) (hx : ↑x ∈ p) :
    { val := ↑x, property := hx } = x :=
  subtype.eta x hx

protected instance add_comm_monoid {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : add_comm_monoid ↥p :=
  add_comm_monoid.mk Add.add sorry 0 sorry sorry sorry

protected instance semimodule {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : semimodule R ↥p :=
  semimodule.mk sorry sorry

/-- Embedding of a submodule `p` to the ambient space `M`. -/
protected def subtype {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : linear_map R (↥p) M :=
  linear_map.mk coe sorry sorry

@[simp] theorem subtype_apply {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) (x : ↥p) :
    coe_fn (submodule.subtype p) x = ↑x :=
  rfl

theorem subtype_eq_val {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    {semimodule_M : semimodule R M} (p : submodule R M) : ⇑(submodule.subtype p) = subtype.val :=
  rfl

theorem neg_mem {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} (hx : x ∈ p) : -x ∈ p :=
  sub_mul_action.neg_mem (to_sub_mul_action p) hx

/-- Reinterpret a submodule as an additive subgroup. -/
def to_add_subgroup {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) : add_subgroup M :=
  add_subgroup.mk (add_submonoid.carrier (to_add_submonoid p)) sorry sorry sorry

@[simp] theorem coe_to_add_subgroup {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) : ↑(to_add_subgroup p) = ↑p :=
  rfl

theorem sub_mem {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} {y : M} :
    x ∈ p → y ∈ p → x - y ∈ p :=
  add_subgroup.sub_mem (to_add_subgroup p)

@[simp] theorem neg_mem_iff {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} : -x ∈ p ↔ x ∈ p :=
  add_subgroup.neg_mem_iff (to_add_subgroup p)

theorem add_mem_iff_left {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} {y : M} :
    y ∈ p → (x + y ∈ p ↔ x ∈ p) :=
  add_subgroup.add_mem_cancel_right (to_add_subgroup p)

theorem add_mem_iff_right {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) {x : M} {y : M} :
    x ∈ p → (x + y ∈ p ↔ y ∈ p) :=
  add_subgroup.add_mem_cancel_left (to_add_subgroup p)

protected instance has_neg {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) : Neg ↥p :=
  { neg := fun (x : ↥p) => { val := -subtype.val x, property := sorry } }

@[simp] theorem coe_neg {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) (x : ↥p) : ↑(-x) = -↑x :=
  rfl

protected instance add_comm_group {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) : add_comm_group ↥p :=
  add_comm_group.mk Add.add sorry 0 sorry sorry Neg.neg add_comm_group.sub sorry sorry

@[simp] theorem coe_sub {R : Type u} {M : Type v} [ring R] [add_comm_group M]
    {semimodule_M : semimodule R M} (p : submodule R M) (x : ↥p) (y : ↥p) : ↑(x - y) = ↑x - ↑y :=
  rfl

end submodule

namespace submodule

theorem smul_mem_iff {R : Type u} {M : Type v} [division_ring R] [add_comm_group M] [module R M]
    (p : submodule R M) {r : R} {x : M} (r0 : r ≠ 0) : r • x ∈ p ↔ x ∈ p :=
  sub_mul_action.smul_mem_iff (to_sub_mul_action p) r0

end submodule

/-- Subspace of a vector space. Defined to equal `submodule`. -/
def subspace (R : Type u) (M : Type v) [field R] [add_comm_group M] [vector_space R M] :=
  submodule R M

end Mathlib


theorem le_total (a b : mynat) : a ≤ b ∨ b ≤ a :=
begin
revert a,
induction b with c hc,
intro h,
right,
apply zero_le,
intro h,
cases h with d hd,
left,
apply zero_le,
cases hc d,
left,
exact succ_le_succ d c h,
right,
exact succ_le_succ c d h,
end


import group_theory.group_action

variables {X : Type*} {G : Type*} [group G] (ρ : G → X → X) [is_group_action ρ]

lemma is_group_action.inverse_left (g : G) : (ρ g⁻¹) ∘ ρ g = id :=
begin
  ext x,
  change ρ g⁻¹ (ρ g x) =  x,
  rw ← is_monoid_action.mul ρ g⁻¹ g x,
  simp [is_monoid_action.one ρ]
end

lemma is_group_action.inverse_right (g : G) : (ρ g) ∘ ρ g⁻¹ = id :=
by simpa using is_group_action.inverse_left ρ g⁻¹

def action_rel : setoid X :=
⟨λ x y, ∃ g, ρ g x = y, ⟨λ x, ⟨(1 : G),  is_monoid_action.one ρ x⟩,
  begin
  { split,
    { rintros x y ⟨g, h⟩,
      existsi g⁻¹,
      rw ←h,
      exact congr_fun (is_group_action.inverse_left ρ g) x },
    { rintros x y z ⟨g, h⟩ ⟨g', h'⟩,
      existsi g'*g,
      rw [is_monoid_action.mul ρ, h, h'] } }
  end⟩⟩


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import order.lattice
import data.option.basic

/-!
# ⊤ and ⊥, bounded lattices and variants

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

This file defines top and bottom elements (greatest and least elements) of a type, the bounded
variants of different kinds of lattices, sets up the typeclass hierarchy between them and provides
instances for `Prop` and `fun`.

## Main declarations

* `has_<top/bot> α`: Typeclasses to declare the `⊤`/`⊥` notation.
* `order_<top/bot> α`: Order with a top/bottom element.
* `bounded_order α`: Order with a top and bottom element.

## Common lattices

* Distributive lattices with a bottom element. Notated by `[distrib_lattice α] [order_bot α]`
  It captures the properties of `disjoint` that are common to `generalized_boolean_algebra` and
  `distrib_lattice` when `order_bot`.
* Bounded and distributive lattice. Notated by `[distrib_lattice α] [bounded_order α]`.
  Typical examples include `Prop` and `set α`.
-/

open function order_dual

set_option old_structure_cmd true

universes u v

variables {α : Type u} {β : Type v} {γ δ : Type*}

/-! ### Top, bottom element -/

/-- Typeclass for the `⊤` (`\top`) notation -/
@[notation_class] class has_top (α : Type u) := (top : α)
/-- Typeclass for the `⊥` (`\bot`) notation -/
@[notation_class] class has_bot (α : Type u) := (bot : α)

notation `⊤` := has_top.top
notation `⊥` := has_bot.bot

@[priority 100] instance has_top_nonempty (α : Type u) [has_top α] : nonempty α := ⟨⊤⟩
@[priority 100] instance has_bot_nonempty (α : Type u) [has_bot α] : nonempty α := ⟨⊥⟩

attribute [pattern] has_bot.bot has_top.top

/-- An order is an `order_top` if it has a greatest element.
We state this using a data mixin, holding the value of `⊤` and the greatest element constraint. -/
@[ancestor has_top]
class order_top (α : Type u) [has_le α] extends has_top α :=
(le_top : ∀ a : α, a ≤ ⊤)

section order_top

/-- An order is (noncomputably) either an `order_top` or a `no_order_top`. Use as
`casesI bot_order_or_no_bot_order α`. -/
noncomputable def top_order_or_no_top_order (α : Type*) [has_le α] :
  psum (order_top α) (no_top_order α) :=
begin
  by_cases H : ∀ a : α, ∃ b, ¬ b ≤ a,
  { exact psum.inr ⟨H⟩ },
  { push_neg at H,
    exact psum.inl ⟨_, classical.some_spec H⟩ }
end

section has_le
variables [has_le α] [order_top α] {a : α}

@[simp] lemma le_top : a ≤ ⊤ := order_top.le_top a
@[simp] lemma is_top_top : is_top (⊤ : α) := λ _, le_top

end has_le

section preorder
variables [preorder α] [order_top α] {a b : α}

@[simp] lemma is_max_top : is_max (⊤ : α) := is_top_top.is_max
@[simp] lemma not_top_lt : ¬ ⊤ < a := is_max_top.not_lt

lemma ne_top_of_lt (h : a < b) : a ≠ ⊤ := (h.trans_le le_top).ne

alias ne_top_of_lt ← has_lt.lt.ne_top

end preorder

variables [partial_order α] [order_top α] [preorder β] {f : α → β} {a b : α}

@[simp] lemma is_max_iff_eq_top : is_max a ↔ a = ⊤ :=
⟨λ h, h.eq_of_le le_top, λ h b _, h.symm ▸ le_top⟩

@[simp] lemma is_top_iff_eq_top : is_top a ↔ a = ⊤ :=
⟨λ h, h.is_max.eq_of_le le_top, λ h b, h.symm ▸ le_top⟩

lemma not_is_max_iff_ne_top : ¬ is_max a ↔ a ≠ ⊤ := is_max_iff_eq_top.not
lemma not_is_top_iff_ne_top : ¬ is_top a ↔ a ≠ ⊤ := is_top_iff_eq_top.not

alias is_max_iff_eq_top ↔ is_max.eq_top _
alias is_top_iff_eq_top ↔ is_top.eq_top _

@[simp] lemma top_le_iff : ⊤ ≤ a ↔ a = ⊤ := le_top.le_iff_eq.trans eq_comm
lemma top_unique (h : ⊤ ≤ a) : a = ⊤ := le_top.antisymm h
lemma eq_top_iff : a = ⊤ ↔ ⊤ ≤ a := top_le_iff.symm
lemma eq_top_mono (h : a ≤ b) (h₂ : a = ⊤) : b = ⊤ := top_unique $ h₂ ▸ h
lemma lt_top_iff_ne_top : a < ⊤ ↔ a ≠ ⊤ := le_top.lt_iff_ne
@[simp] lemma not_lt_top_iff : ¬ a < ⊤ ↔ a = ⊤ := lt_top_iff_ne_top.not_left
lemma eq_top_or_lt_top (a : α) : a = ⊤ ∨ a < ⊤ := le_top.eq_or_lt
lemma ne.lt_top (h : a ≠ ⊤) : a < ⊤ := lt_top_iff_ne_top.mpr h
lemma ne.lt_top' (h : ⊤ ≠ a) : a < ⊤ := h.symm.lt_top
lemma ne_top_of_le_ne_top (hb : b ≠ ⊤) (hab : a ≤ b) : a ≠ ⊤ := (hab.trans_lt hb.lt_top).ne

lemma strict_mono.apply_eq_top_iff (hf : strict_mono f) : f a = f ⊤ ↔ a = ⊤ :=
⟨λ h, not_lt_top_iff.1 $ λ ha, (hf ha).ne h, congr_arg _⟩

lemma strict_anti.apply_eq_top_iff (hf : strict_anti f) : f a = f ⊤ ↔ a = ⊤ :=
⟨λ h, not_lt_top_iff.1 $ λ ha, (hf ha).ne' h, congr_arg _⟩

variables [nontrivial α]

lemma not_is_min_top : ¬ is_min (⊤ : α) :=
λ h, let ⟨a, ha⟩ := exists_ne (⊤ : α) in ha $ top_le_iff.1 $ h le_top

end order_top

lemma strict_mono.maximal_preimage_top [linear_order α] [preorder β] [order_top β]
  {f : α → β} (H : strict_mono f) {a} (h_top : f a = ⊤) (x : α) :
  x ≤ a :=
H.maximal_of_maximal_image (λ p, by { rw h_top, exact le_top }) x

theorem order_top.ext_top {α} {hA : partial_order α} (A : order_top α)
  {hB : partial_order α} (B : order_top α)
  (H : ∀ x y : α, (by haveI := hA; exact x ≤ y) ↔ x ≤ y) :
  (by haveI := A; exact ⊤ : α) = ⊤ :=
top_unique $ by rw ← H; apply le_top

theorem order_top.ext {α} [partial_order α] {A B : order_top α} : A = B :=
begin
  have tt := order_top.ext_top A B (λ _ _, iff.rfl),
  casesI A with _ ha, casesI B with _ hb,
  congr,
  exact le_antisymm (hb _) (ha _)
end

/-- An order is an `order_bot` if it has a least element.
We state this using a data mixin, holding the value of `⊥` and the least element constraint. -/
@[ancestor has_bot]
class order_bot (α : Type u) [has_le α] extends has_bot α :=
(bot_le : ∀ a : α, ⊥ ≤ a)

section order_bot

/-- An order is (noncomputably) either an `order_bot` or a `no_order_bot`. Use as
`casesI bot_order_or_no_bot_order α`. -/
noncomputable def bot_order_or_no_bot_order (α : Type*) [has_le α] :
  psum (order_bot α) (no_bot_order α) :=
begin
  by_cases H : ∀ a : α, ∃ b, ¬ a ≤ b,
  { exact psum.inr ⟨H⟩ },
  { push_neg at H,
    exact psum.inl ⟨_, classical.some_spec H⟩ }
end

section has_le
variables [has_le α] [order_bot α] {a : α}

@[simp] lemma bot_le : ⊥ ≤ a := order_bot.bot_le a
@[simp] lemma is_bot_bot : is_bot (⊥ : α) := λ _, bot_le

end has_le

namespace order_dual
variable (α)

instance [has_bot α] : has_top αᵒᵈ := ⟨(⊥ : α)⟩
instance [has_top α] : has_bot αᵒᵈ := ⟨(⊤ : α)⟩

instance [has_le α] [order_bot α] : order_top αᵒᵈ :=
{ le_top := @bot_le α _ _,
  .. order_dual.has_top α }

instance [has_le α] [order_top α] : order_bot αᵒᵈ :=
{ bot_le := @le_top α _ _,
  .. order_dual.has_bot α }

@[simp] lemma of_dual_bot [has_top α] : of_dual ⊥ = (⊤ : α) := rfl
@[simp] lemma of_dual_top [has_bot α] : of_dual ⊤ = (⊥ : α) := rfl
@[simp] lemma to_dual_bot [has_bot α] : to_dual (⊥ : α) = ⊤ := rfl
@[simp] lemma to_dual_top [has_top α] : to_dual (⊤ : α) = ⊥ := rfl

end order_dual

section preorder
variables [preorder α] [order_bot α] {a b : α}

@[simp] lemma is_min_bot : is_min (⊥ : α) := is_bot_bot.is_min
@[simp] lemma not_lt_bot : ¬ a < ⊥ := is_min_bot.not_lt

lemma ne_bot_of_gt (h : a < b) : b ≠ ⊥ := (bot_le.trans_lt h).ne'

alias ne_bot_of_gt ← has_lt.lt.ne_bot

end preorder

variables [partial_order α] [order_bot α] [preorder β] {f : α → β} {a b : α}

@[simp] lemma is_min_iff_eq_bot : is_min a ↔ a = ⊥ :=
⟨λ h, h.eq_of_ge bot_le, λ h b _, h.symm ▸ bot_le⟩

@[simp] lemma is_bot_iff_eq_bot : is_bot a ↔ a = ⊥ :=
⟨λ h, h.is_min.eq_of_ge bot_le, λ h b, h.symm ▸ bot_le⟩

lemma not_is_min_iff_ne_bot : ¬ is_min a ↔ a ≠ ⊥ := is_min_iff_eq_bot.not
lemma not_is_bot_iff_ne_bot : ¬ is_bot a ↔ a ≠ ⊥ := is_bot_iff_eq_bot.not

alias is_min_iff_eq_bot ↔ is_min.eq_bot _
alias is_bot_iff_eq_bot ↔ is_bot.eq_bot _

@[simp] lemma le_bot_iff : a ≤ ⊥ ↔ a = ⊥ := bot_le.le_iff_eq
lemma bot_unique (h : a ≤ ⊥) : a = ⊥ := h.antisymm bot_le
lemma eq_bot_iff : a = ⊥ ↔ a ≤ ⊥ := le_bot_iff.symm
lemma eq_bot_mono (h : a ≤ b) (h₂ : b = ⊥) : a = ⊥ := bot_unique $ h₂ ▸ h
lemma bot_lt_iff_ne_bot : ⊥ < a ↔ a ≠ ⊥ := bot_le.lt_iff_ne.trans ne_comm
@[simp] lemma not_bot_lt_iff : ¬ ⊥ < a ↔ a = ⊥ := bot_lt_iff_ne_bot.not_left
lemma eq_bot_or_bot_lt (a : α) : a = ⊥ ∨ ⊥ < a := bot_le.eq_or_gt
lemma eq_bot_of_minimal (h : ∀ b, ¬ b < a) : a = ⊥ := (eq_bot_or_bot_lt a).resolve_right (h ⊥)
lemma ne.bot_lt (h : a ≠ ⊥) : ⊥ < a := bot_lt_iff_ne_bot.mpr h
lemma ne.bot_lt' (h : ⊥ ≠ a) : ⊥ < a := h.symm.bot_lt
lemma ne_bot_of_le_ne_bot (hb : b ≠ ⊥) (hab : b ≤ a) : a ≠ ⊥ := (hb.bot_lt.trans_le hab).ne'

lemma strict_mono.apply_eq_bot_iff (hf : strict_mono f) : f a = f ⊥ ↔ a = ⊥ :=
hf.dual.apply_eq_top_iff

lemma strict_anti.apply_eq_bot_iff (hf : strict_anti f) : f a = f ⊥ ↔ a = ⊥ :=
hf.dual.apply_eq_top_iff

variables [nontrivial α]

lemma not_is_max_bot : ¬ is_max (⊥ : α) := @not_is_min_top αᵒᵈ _ _ _

end order_bot

lemma strict_mono.minimal_preimage_bot [linear_order α] [partial_order β] [order_bot β]
  {f : α → β} (H : strict_mono f) {a} (h_bot : f a = ⊥) (x : α) :
  a ≤ x :=
H.minimal_of_minimal_image (λ p, by { rw h_bot, exact bot_le }) x

theorem order_bot.ext_bot {α} {hA : partial_order α} (A : order_bot α)
  {hB : partial_order α} (B : order_bot α)
  (H : ∀ x y : α, (by haveI := hA; exact x ≤ y) ↔ x ≤ y) :
  (by haveI := A; exact ⊥ : α) = ⊥ :=
bot_unique $ by rw ← H; apply bot_le

theorem order_bot.ext {α} [partial_order α] {A B : order_bot α} : A = B :=
begin
  have tt := order_bot.ext_bot A B (λ _ _, iff.rfl),
  casesI A with a ha, casesI B with b hb,
  congr,
  exact le_antisymm (ha _) (hb _)
end

section semilattice_sup_top
variables [semilattice_sup α] [order_top α] {a : α}

@[simp] theorem top_sup_eq : ⊤ ⊔ a = ⊤ :=
sup_of_le_left le_top

@[simp] theorem sup_top_eq : a ⊔ ⊤ = ⊤ :=
sup_of_le_right le_top

end semilattice_sup_top

section semilattice_sup_bot
variables [semilattice_sup α] [order_bot α] {a b : α}

@[simp] theorem bot_sup_eq : ⊥ ⊔ a = a :=
sup_of_le_right bot_le

@[simp] theorem sup_bot_eq : a ⊔ ⊥ = a :=
sup_of_le_left bot_le

@[simp] theorem sup_eq_bot_iff : a ⊔ b = ⊥ ↔ (a = ⊥ ∧ b = ⊥) :=
by rw [eq_bot_iff, sup_le_iff]; simp

end semilattice_sup_bot

section semilattice_inf_top
variables [semilattice_inf α] [order_top α] {a b : α}

@[simp] theorem top_inf_eq : ⊤ ⊓ a = a :=
inf_of_le_right le_top

@[simp] theorem inf_top_eq : a ⊓ ⊤ = a :=
inf_of_le_left le_top

@[simp] theorem inf_eq_top_iff : a ⊓ b = ⊤ ↔ (a = ⊤ ∧ b = ⊤) :=
@sup_eq_bot_iff αᵒᵈ _ _ _ _

end semilattice_inf_top

section semilattice_inf_bot
variables [semilattice_inf α] [order_bot α] {a : α}

@[simp] theorem bot_inf_eq : ⊥ ⊓ a = ⊥ :=
inf_of_le_left bot_le

@[simp] theorem inf_bot_eq : a ⊓ ⊥ = ⊥ :=
inf_of_le_right bot_le

end semilattice_inf_bot

/-! ### Bounded order -/

/-- A bounded order describes an order `(≤)` with a top and bottom element,
  denoted `⊤` and `⊥` respectively. -/
@[ancestor order_top order_bot]
class bounded_order (α : Type u) [has_le α] extends order_top α, order_bot α.

instance (α : Type u) [has_le α] [bounded_order α] : bounded_order αᵒᵈ :=
{ .. order_dual.order_top α, .. order_dual.order_bot α }

theorem bounded_order.ext {α} [partial_order α] {A B : bounded_order α} : A = B :=
begin
  have ht : @bounded_order.to_order_top α _ A = @bounded_order.to_order_top α _ B := order_top.ext,
  have hb : @bounded_order.to_order_bot α _ A = @bounded_order.to_order_bot α _ B := order_bot.ext,
  casesI A,
  casesI B,
  injection ht with h,
  injection hb with h',
  convert rfl,
  { exact h.symm },
  { exact h'.symm }
end

section logic
/-!
#### In this section we prove some properties about monotone and antitone operations on `Prop`
-/
section preorder

variable [preorder α]

theorem monotone_and {p q : α → Prop} (m_p : monotone p) (m_q : monotone q) :
  monotone (λ x, p x ∧ q x) :=
λ a b h, and.imp (m_p h) (m_q h)
-- Note: by finish [monotone] doesn't work

theorem monotone_or {p q : α → Prop} (m_p : monotone p) (m_q : monotone q) :
  monotone (λ x, p x ∨ q x) :=
λ a b h, or.imp (m_p h) (m_q h)

lemma monotone_le {x : α}: monotone ((≤) x) :=
λ y z h' h, h.trans h'

lemma monotone_lt {x : α}: monotone ((<) x) :=
λ y z h' h, h.trans_le h'

lemma antitone_le {x : α}: antitone (≤ x) :=
λ y z h' h, h'.trans h

lemma antitone_lt {x : α}: antitone (< x) :=
λ y z h' h, h'.trans_lt h

lemma monotone.forall {P : β → α → Prop} (hP : ∀ x, monotone (P x)) :
  monotone (λ y, ∀ x, P x y) :=
λ y y' hy h x, hP x hy $ h x

lemma antitone.forall {P : β → α → Prop} (hP : ∀ x, antitone (P x)) :
  antitone (λ y, ∀ x, P x y) :=
λ y y' hy h x, hP x hy (h x)

lemma monotone.ball {P : β → α → Prop} {s : set β} (hP : ∀ x ∈ s, monotone (P x)) :
  monotone (λ y, ∀ x ∈ s, P x y) :=
λ y y' hy h x hx, hP x hx hy (h x hx)

lemma antitone.ball {P : β → α → Prop} {s : set β} (hP : ∀ x ∈ s, antitone (P x)) :
  antitone (λ y, ∀ x ∈ s, P x y) :=
λ y y' hy h x hx, hP x hx hy (h x hx)

end preorder

section semilattice_sup
variables [semilattice_sup α]

lemma exists_ge_and_iff_exists {P : α → Prop} {x₀ : α} (hP : monotone P) :
  (∃ x, x₀ ≤ x ∧ P x) ↔ ∃ x, P x :=
⟨λ h, h.imp $ λ x h, h.2, λ ⟨x, hx⟩, ⟨x ⊔ x₀, le_sup_right, hP le_sup_left hx⟩⟩

end semilattice_sup

section semilattice_inf
variables [semilattice_inf α]

lemma exists_le_and_iff_exists {P : α → Prop} {x₀ : α} (hP : antitone P) :
  (∃ x, x ≤ x₀ ∧ P x) ↔ ∃ x, P x :=
exists_ge_and_iff_exists hP.dual_left

end semilattice_inf
end logic

/-! ### Function lattices -/

namespace pi
variables {ι : Type*} {α' : ι → Type*}

instance [Π i, has_bot (α' i)] : has_bot (Π i, α' i) := ⟨λ i, ⊥⟩

@[simp] lemma bot_apply [Π i, has_bot (α' i)] (i : ι) : (⊥ : Π i, α' i) i = ⊥ := rfl

lemma bot_def [Π i, has_bot (α' i)] : (⊥ : Π i, α' i) = λ i, ⊥ := rfl

instance [Π i, has_top (α' i)] : has_top (Π i, α' i) := ⟨λ i, ⊤⟩

@[simp] lemma top_apply [Π i, has_top (α' i)] (i : ι) : (⊤ : Π i, α' i) i = ⊤ := rfl

lemma top_def [Π i, has_top (α' i)] : (⊤ : Π i, α' i) = λ i, ⊤ := rfl

instance [Π i, has_le (α' i)] [Π i, order_top (α' i)] : order_top (Π i, α' i) :=
{ le_top := λ _ _, le_top, ..pi.has_top }

instance [Π i, has_le (α' i)] [Π i, order_bot (α' i)] : order_bot (Π i, α' i) :=
{ bot_le := λ _ _, bot_le, ..pi.has_bot }

instance [Π i, has_le (α' i)] [Π i, bounded_order (α' i)] :
  bounded_order (Π i, α' i) :=
{ ..pi.order_top, ..pi.order_bot }

end pi

section subsingleton

variables [partial_order α] [bounded_order α]

lemma eq_bot_of_bot_eq_top (hα : (⊥ : α) = ⊤) (x : α) :
  x = (⊥ : α) :=
eq_bot_mono le_top (eq.symm hα)

lemma eq_top_of_bot_eq_top (hα : (⊥ : α) = ⊤) (x : α) :
  x = (⊤ : α) :=
eq_top_mono bot_le hα

lemma subsingleton_of_top_le_bot (h : (⊤ : α) ≤ (⊥ : α)) :
  subsingleton α :=
⟨λ a b, le_antisymm (le_trans le_top $ le_trans h bot_le) (le_trans le_top $ le_trans h bot_le)⟩

lemma subsingleton_of_bot_eq_top (hα : (⊥ : α) = (⊤ : α)) :
  subsingleton α :=
subsingleton_of_top_le_bot (ge_of_eq hα)

lemma subsingleton_iff_bot_eq_top :
  (⊥ : α) = (⊤ : α) ↔ subsingleton α :=
⟨subsingleton_of_bot_eq_top, λ h, by exactI subsingleton.elim ⊥ ⊤⟩

end subsingleton

section lift

/-- Pullback an `order_top`. -/
@[reducible] -- See note [reducible non-instances]
def order_top.lift [has_le α] [has_top α] [has_le β] [order_top β] (f : α → β)
  (map_le : ∀ a b, f a ≤ f b → a ≤ b) (map_top : f ⊤ = ⊤) :
  order_top α :=
⟨⊤, λ a, map_le _ _ $ by { rw map_top, exact le_top }⟩

/-- Pullback an `order_bot`. -/
@[reducible] -- See note [reducible non-instances]
def order_bot.lift [has_le α] [has_bot α] [has_le β] [order_bot β] (f : α → β)
  (map_le : ∀ a b, f a ≤ f b → a ≤ b) (map_bot : f ⊥ = ⊥) :
  order_bot α :=
⟨⊥, λ a, map_le _ _ $ by { rw map_bot, exact bot_le }⟩

/-- Pullback a `bounded_order`. -/
@[reducible] -- See note [reducible non-instances]
def bounded_order.lift [has_le α] [has_top α] [has_bot α] [has_le β] [bounded_order β] (f : α → β)
  (map_le : ∀ a b, f a ≤ f b → a ≤ b) (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥) :
  bounded_order α :=
{ ..order_top.lift f map_le map_top, ..order_bot.lift f map_le map_bot }

end lift

/-! ### Subtype, order dual, product lattices -/

namespace subtype
variables {p : α → Prop}

/-- A subtype remains a `⊥`-order if the property holds at `⊥`. -/
@[reducible] -- See note [reducible non-instances]
protected def order_bot [has_le α] [order_bot α] (hbot : p ⊥) : order_bot {x : α // p x} :=
{ bot := ⟨⊥, hbot⟩,
  bot_le := λ _, bot_le }

/-- A subtype remains a `⊤`-order if the property holds at `⊤`. -/
@[reducible] -- See note [reducible non-instances]
protected def order_top [has_le α] [order_top α] (htop : p ⊤) : order_top {x : α // p x} :=
{ top := ⟨⊤, htop⟩,
  le_top := λ _, le_top }

/-- A subtype remains a bounded order if the property holds at `⊥` and `⊤`. -/
@[reducible] -- See note [reducible non-instances]
protected def bounded_order [has_le α] [bounded_order α] (hbot : p ⊥) (htop : p ⊤) :
  bounded_order (subtype p) :=
{ ..subtype.order_top htop, ..subtype.order_bot hbot }

variables [partial_order α]

@[simp] lemma mk_bot [order_bot α] [order_bot (subtype p)] (hbot : p ⊥) : mk ⊥ hbot = ⊥ :=
le_bot_iff.1 $ coe_le_coe.1 bot_le

@[simp] lemma mk_top [order_top α] [order_top (subtype p)] (htop : p ⊤) : mk ⊤ htop = ⊤ :=
top_le_iff.1 $ coe_le_coe.1 le_top

lemma coe_bot [order_bot α] [order_bot (subtype p)] (hbot : p ⊥) : ((⊥ : subtype p) : α) = ⊥ :=
congr_arg coe (mk_bot hbot).symm

lemma coe_top [order_top α] [order_top (subtype p)] (htop : p ⊤) : ((⊤ : subtype p) : α) = ⊤ :=
congr_arg coe (mk_top htop).symm

@[simp] lemma coe_eq_bot_iff [order_bot α] [order_bot (subtype p)] (hbot : p ⊥) {x : {x // p x}} :
  (x : α) = ⊥ ↔ x = ⊥ :=
by rw [←coe_bot hbot, ext_iff]

@[simp] lemma coe_eq_top_iff [order_top α] [order_top (subtype p)] (htop : p ⊤) {x : {x // p x}} :
  (x : α) = ⊤ ↔ x = ⊤ :=
by rw [←coe_top htop, ext_iff]

@[simp] lemma mk_eq_bot_iff [order_bot α] [order_bot (subtype p)] (hbot : p ⊥) {x : α} (hx : p x) :
  (⟨x, hx⟩ : subtype p) = ⊥ ↔ x = ⊥ :=
(coe_eq_bot_iff hbot).symm

@[simp] lemma mk_eq_top_iff [order_top α] [order_top (subtype p)] (htop : p ⊤) {x : α} (hx : p x) :
  (⟨x, hx⟩ : subtype p) = ⊤ ↔ x = ⊤ :=
(coe_eq_top_iff htop).symm

end subtype

namespace prod
variables (α β)

instance [has_top α] [has_top β] : has_top (α × β) := ⟨⟨⊤, ⊤⟩⟩
instance [has_bot α] [has_bot β] : has_bot (α × β) := ⟨⟨⊥, ⊥⟩⟩

instance [has_le α] [has_le β] [order_top α] [order_top β] : order_top (α × β) :=
{ le_top := λ a, ⟨le_top, le_top⟩,
  .. prod.has_top α β }

instance [has_le α] [has_le β] [order_bot α] [order_bot β] : order_bot (α × β) :=
{ bot_le := λ a, ⟨bot_le, bot_le⟩,
  .. prod.has_bot α β }

instance [has_le α] [has_le β] [bounded_order α] [bounded_order β] : bounded_order (α × β) :=
{ .. prod.order_top α β, .. prod.order_bot α β }

end prod

section linear_order
variables [linear_order α]

-- `simp` can prove these, so they shouldn't be simp-lemmas.
lemma min_bot_left [order_bot α] (a : α) : min ⊥ a = ⊥ := bot_inf_eq
lemma max_top_left [order_top α] (a : α) : max ⊤ a = ⊤ := top_sup_eq
lemma min_top_left [order_top α] (a : α) : min ⊤ a = a := top_inf_eq
lemma max_bot_left [order_bot α] (a : α) : max ⊥ a = a := bot_sup_eq
lemma min_top_right [order_top α] (a : α) : min a ⊤ = a := inf_top_eq
lemma max_bot_right [order_bot α] (a : α) : max a ⊥ = a := sup_bot_eq
lemma min_bot_right [order_bot α] (a : α) : min a ⊥ = ⊥ := inf_bot_eq
lemma max_top_right [order_top α] (a : α) : max a ⊤ = ⊤ := sup_top_eq

@[simp] lemma min_eq_bot [order_bot α] {a b : α} : min a b = ⊥ ↔ a = ⊥ ∨ b = ⊥ :=
by simp only [←inf_eq_min, ←le_bot_iff, inf_le_iff]

@[simp] lemma max_eq_top [order_top α] {a b : α} : max a b = ⊤ ↔ a = ⊤ ∨ b = ⊤ :=
@min_eq_bot αᵒᵈ _ _ a b

@[simp] lemma max_eq_bot [order_bot α] {a b : α} : max a b = ⊥ ↔ a = ⊥ ∧ b = ⊥ := sup_eq_bot_iff
@[simp] lemma min_eq_top [order_top α] {a b : α} : min a b = ⊤ ↔ a = ⊤ ∧ b = ⊤ := inf_eq_top_iff

end linear_order

section nontrivial

variables [partial_order α] [bounded_order α] [nontrivial α]

@[simp] lemma bot_ne_top : (⊥ : α) ≠ ⊤ := λ h, not_subsingleton _ $ subsingleton_of_bot_eq_top h
@[simp] lemma top_ne_bot : (⊤ : α) ≠ ⊥ := bot_ne_top.symm
@[simp] lemma bot_lt_top : (⊥ : α) < ⊤ := lt_top_iff_ne_top.2 bot_ne_top

end nontrivial

section bool

open bool

instance : bounded_order bool :=
{ top := tt,
  le_top := λ x, le_tt,
  bot := ff,
  bot_le := λ x, ff_le }

@[simp] lemma top_eq_tt : ⊤ = tt := rfl
@[simp] lemma bot_eq_ff : ⊥ = ff := rfl

end bool