/-
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, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.complete_lattice
import Mathlib.dynamics.fixed_points.basic
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Fixed point construction on complete lattices
-/

/-- Least fixed point of a monotone function -/
/-- Greatest fixed point of a monotone function -/
def lfp {α : Type u} [complete_lattice α] (f : α → α) : α := Inf (set_of fun (a : α) => f a ≤ a)

def gfp {α : Type u} [complete_lattice α] (f : α → α) : α := Sup (set_of fun (a : α) => a ≤ f a)

theorem lfp_le {α : Type u} [complete_lattice α] {f : α → α} {a : α} (h : f a ≤ a) : lfp f ≤ a :=
  Inf_le h

theorem le_lfp {α : Type u} [complete_lattice α] {f : α → α} {a : α}
    (h : ∀ (b : α), f b ≤ b → a ≤ b) : a ≤ lfp f :=
  le_Inf h

theorem lfp_eq {α : Type u} [complete_lattice α] {f : α → α} (m : monotone f) : lfp f = f (lfp f) :=
  (fun (this : f (lfp f) ≤ lfp f) => le_antisymm (lfp_le (m this)) this)
    (le_lfp fun (b : α) (h : f b ≤ b) => le_trans (m (lfp_le h)) h)

theorem lfp_induct {α : Type u} [complete_lattice α] {f : α → α} {p : α → Prop} (m : monotone f)
    (step : ∀ (a : α), p a → a ≤ lfp f → p (f a))
    (sup : ∀ (s : set α), (∀ (a : α), a ∈ s → p a) → p (Sup s)) : p (lfp f) :=
  sorry

theorem monotone_lfp {α : Type u} [complete_lattice α] : monotone lfp :=
  fun (f g : α → α) (this : f ≤ g) =>
    le_lfp fun (a : α) (this_1 : g a ≤ a) => lfp_le (le_trans (this a) this_1)

theorem le_gfp {α : Type u} [complete_lattice α] {f : α → α} {a : α} (h : a ≤ f a) : a ≤ gfp f :=
  le_Sup h

theorem gfp_le {α : Type u} [complete_lattice α] {f : α → α} {a : α}
    (h : ∀ (b : α), b ≤ f b → b ≤ a) : gfp f ≤ a :=
  Sup_le h

theorem gfp_eq {α : Type u} [complete_lattice α] {f : α → α} (m : monotone f) : gfp f = f (gfp f) :=
  (fun (this : gfp f ≤ f (gfp f)) => le_antisymm this (le_gfp (m this)))
    (gfp_le fun (b : α) (h : b ≤ f b) => le_trans h (m (le_gfp h)))

theorem gfp_induct {α : Type u} [complete_lattice α] {f : α → α} {p : α → Prop} (m : monotone f)
    (step : ∀ (a : α), p a → gfp f ≤ a → p (f a))
    (inf : ∀ (s : set α), (∀ (a : α), a ∈ s → p a) → p (Inf s)) : p (gfp f) :=
  sorry

theorem monotone_gfp {α : Type u} [complete_lattice α] : monotone gfp :=
  fun (f g : α → α) (this : f ≤ g) =>
    gfp_le fun (a : α) (this_1 : a ≤ f a) => le_gfp (le_trans this_1 (this a))

-- Rolling rule

theorem lfp_comp {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : β → α}
    {g : α → β} (m_f : monotone f) (m_g : monotone g) : lfp (f ∘ g) = f (lfp (g ∘ f)) :=
  sorry

theorem gfp_comp {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {f : β → α}
    {g : α → β} (m_f : monotone f) (m_g : monotone g) : gfp (f ∘ g) = f (gfp (g ∘ f)) :=
  sorry

-- Diagonal rule

theorem lfp_lfp {α : Type u} [complete_lattice α] {h : α → α → α}
    (m : ∀ {a b c d : α}, a ≤ b → c ≤ d → h a c ≤ h b d) :
    lfp (lfp ∘ h) = lfp fun (x : α) => h x x :=
  sorry

theorem gfp_gfp {α : Type u} [complete_lattice α] {h : α → α → α}
    (m : ∀ {a b c d : α}, a ≤ b → c ≤ d → h a c ≤ h b d) :
    gfp (gfp ∘ h) = gfp fun (x : α) => h x x :=
  sorry

/- The complete lattice of fixed points of a function f -/

namespace fixed_points

def prev {α : Type u} [complete_lattice α] (f : α → α) (x : α) : α := gfp fun (z : α) => x ⊓ f z

def next {α : Type u} [complete_lattice α] (f : α → α) (x : α) : α := lfp fun (z : α) => x ⊔ f z

theorem prev_le {α : Type u} [complete_lattice α] {f : α → α} {x : α} : prev f x ≤ x :=
  gfp_le fun (z : α) (hz : z ≤ x ⊓ f z) => le_trans hz inf_le_left

theorem prev_eq {α : Type u} [complete_lattice α] {f : α → α} (hf : monotone f) {a : α}
    (h : f a ≤ a) : prev f a = f (prev f a) :=
  sorry

def prev_fixed {α : Type u} [complete_lattice α] {f : α → α} (hf : monotone f) (a : α)
    (h : f a ≤ a) : ↥(function.fixed_points f) :=
  { val := prev f a, property := sorry }

theorem next_le {α : Type u} [complete_lattice α] {f : α → α} {x : α} : x ≤ next f x :=
  le_lfp fun (z : α) (hz : x ⊔ f z ≤ z) => le_trans le_sup_left hz

theorem next_eq {α : Type u} [complete_lattice α] {f : α → α} (hf : monotone f) {a : α}
    (h : a ≤ f a) : next f a = f (next f a) :=
  sorry

def next_fixed {α : Type u} [complete_lattice α] {f : α → α} (hf : monotone f) (a : α)
    (h : a ≤ f a) : ↥(function.fixed_points f) :=
  { val := next f a, property := sorry }

theorem sup_le_f_of_fixed_points {α : Type u} [complete_lattice α] (f : α → α) (hf : monotone f)
    (x : ↥(function.fixed_points f)) (y : ↥(function.fixed_points f)) :
    subtype.val x ⊔ subtype.val y ≤ f (subtype.val x ⊔ subtype.val y) :=
  sorry

theorem f_le_inf_of_fixed_points {α : Type u} [complete_lattice α] (f : α → α) (hf : monotone f)
    (x : ↥(function.fixed_points f)) (y : ↥(function.fixed_points f)) :
    f (subtype.val x ⊓ subtype.val y) ≤ subtype.val x ⊓ subtype.val y :=
  sorry

theorem Sup_le_f_of_fixed_points {α : Type u} [complete_lattice α] (f : α → α) (hf : monotone f)
    (A : set α) (HA : A ⊆ function.fixed_points f) : Sup A ≤ f (Sup A) :=
  Sup_le fun (x : α) (hxA : x ∈ A) => HA hxA ▸ hf (le_Sup hxA)

theorem f_le_Inf_of_fixed_points {α : Type u} [complete_lattice α] (f : α → α) (hf : monotone f)
    (A : set α) (HA : A ⊆ function.fixed_points f) : f (Inf A) ≤ Inf A :=
  le_Inf fun (x : α) (hxA : x ∈ A) => HA hxA ▸ hf (Inf_le hxA)

/-- The fixed points of `f` form a complete lattice.
This cannot be an instance, since it depends on the monotonicity of `f`. -/
protected def complete_lattice {α : Type u} [complete_lattice α] (f : α → α) (hf : monotone f) :
    complete_lattice ↥(function.fixed_points f) :=
  complete_lattice.mk
    (fun (x y : ↥(function.fixed_points f)) =>
      next_fixed hf (subtype.val x ⊔ subtype.val y) (sup_le_f_of_fixed_points f hf x y))
    (fun (x y : ↥(function.fixed_points f)) => subtype.val x ≤ subtype.val y)
    (bounded_lattice.lt._default
      fun (x y : ↥(function.fixed_points f)) => subtype.val x ≤ subtype.val y)
    sorry sorry sorry sorry sorry sorry
    (fun (x y : ↥(function.fixed_points f)) =>
      prev_fixed hf (subtype.val x ⊓ subtype.val y) (f_le_inf_of_fixed_points f hf x y))
    sorry sorry sorry (prev_fixed hf ⊤ sorry) sorry (next_fixed hf ⊥ sorry) sorry
    (fun (A : set ↥(function.fixed_points f)) => next_fixed hf (Sup (subtype.val '' A)) sorry)
    (fun (A : set ↥(function.fixed_points f)) => prev_fixed hf (Inf (subtype.val '' A)) sorry) sorry
    sorry sorry sorry

end Mathlib


/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import ring_theory.localization.at_prime
import ring_theory.valuation.basic

/-!

# Extending valuations to a localization

We show that, given a valuation `v` taking values in a linearly ordered commutative *group*
with zero `Γ`, and a submonoid `S` of `v.supp.prime_compl`, the valuation `v` can be naturally
extended to the localization `S⁻¹A`.

-/

variables
  {A : Type*} [comm_ring A]
  {Γ : Type*} [linear_ordered_comm_group_with_zero Γ] (v : valuation A Γ)
  {S : submonoid A} (hS : S ≤ v.supp.prime_compl)
  (B : Type*) [comm_ring B] [algebra A B] [is_localization S B]

/-- We can extend a valuation `v` on a ring to a localization at a submonoid of
the complement of `v.supp`. -/
noncomputable
def valuation.extend_to_localization : valuation B Γ :=
let f := is_localization.to_localization_map S B,
    h : ∀ s : S, is_unit (v.1.to_monoid_hom s) := λ s, is_unit_iff_ne_zero.2 (hS s.2) in
{ map_zero' := by convert f.lift_eq _ 0; simp,
  map_add_le_max' := λ x y, begin
    obtain ⟨a,b,s,rfl,rfl⟩ : ∃ (a b : A) (s : S), f.mk' a s = x ∧ f.mk' b s = y,
    { obtain ⟨a,s,rfl⟩ := f.mk'_surjective x,
      obtain ⟨b,t,rfl⟩ := f.mk'_surjective y,
      use [a * t, b * s, s * t], split;
      { rw [f.mk'_eq_iff_eq, submonoid.coe_mul], ring_nf } },
    convert_to f.lift h (f.mk' (a+b) s) ≤ max (f.lift h _) (f.lift h _),
    { refine congr_arg (f.lift h) (is_localization.eq_mk'_iff_mul_eq.2 _),
      rw [add_mul, map_add], iterate 2 { erw is_localization.mk'_spec } },
    iterate 3 { rw f.lift_mk' }, rw max_mul_mul_right,
    apply mul_le_mul_right' (v.map_add a b),
  end,
..f.lift h }

@[simp]
lemma valuation.extend_to_localization_apply_map_apply (a : A) :
  v.extend_to_localization hS B (algebra_map A B a) = v a :=
submonoid.localization_map.lift_eq _ _ a


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

! This file was ported from Lean 3 source module data.nat.sqrt
! leanprover-community/mathlib commit ba2245edf0c8bb155f1569fd9b9492a9b384cde6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Int.Order.Basic
import Mathlib.Data.Nat.Size
import Mathlib.Data.Nat.ForSqrt

/-!
# Square root of natural numbers

This file defines an efficient implementation of the square root function that returns the
unique `r` such that `r * r ≤ n < (r + 1) * (r + 1)`.

## Reference

See [Wikipedia, *Methods of computing square roots*]
(https://en.wikipedia.org/wiki/Methods_of_computing_square_roots#Binary_numeral_system_(base_2)).
-/

namespace Nat

#align nat.sqrt Nat.sqrt
-- Porting note: the implementation òf `Nat.sqrt` in `Std` no longer needs `sqrt_aux`.
#noalign nat.sqrt_aux_dec
#noalign nat.sqrt_aux
#noalign nat.sqrt_aux_0
#noalign nat.sqrt_aux_1
#noalign nat.sqrt_aux_2
private def IsSqrt (n q : ℕ) : Prop :=
  q * q ≤ n ∧ n < (q + 1) * (q + 1)
-- Porting note: as the definition of square root has changed,
-- the proof of `sqrt_isSqrt` is attempted from scratch.
/-
Sketch of proof:
Up to rounding, in terms of the definition of `sqrt.iter`,

* By AM-GM inequality, `next² ≥ n` giving one of the bounds.
* When we terminated, we have `guess ≥ next` from which we deduce the other bound `n ≥ next²`.

To turn this into a lean proof we need to manipulate, use properties of natural number division etc.
-/
private theorem sqrt_isSqrt (n : ℕ) : IsSqrt n (sqrt n) := by
  match n with
  | 0 => simp [IsSqrt]
  | 1 => simp [IsSqrt]
  | n + 2 =>
    have h : ¬ (n + 2) ≤ 1 := by simp
    simp only [IsSqrt, sqrt, h, ite_false]
    refine ⟨sqrt.iter_sq_le _ _, sqrt.lt_iter_succ_sq _ _ ?_⟩
    simp only [mul_add, add_mul, one_mul, mul_one, ← add_assoc]
    rw [lt_add_one_iff, add_assoc, ← mul_two]
    refine le_trans (div_add_mod' (n + 2) 2).ge ?_
    rw [add_comm, add_le_add_iff_right, add_mod_right]
    simp only [zero_lt_two, add_div_right, succ_mul_succ_eq]
    refine le_trans (b := 1) ?_ ?_
    · exact (lt_succ.1 $ mod_lt n zero_lt_two)
    · simp only [le_add_iff_nonneg_left]; exact zero_le _

theorem sqrt_le (n : ℕ) : sqrt n * sqrt n ≤ n :=
  (sqrt_isSqrt n).left
#align nat.sqrt_le Nat.sqrt_le

theorem sqrt_le' (n : ℕ) : sqrt n ^ 2 ≤ n :=
  Eq.trans_le (sq (sqrt n)) (sqrt_le n)
#align nat.sqrt_le' Nat.sqrt_le'

theorem lt_succ_sqrt (n : ℕ) : n < succ (sqrt n) * succ (sqrt n) :=
  (sqrt_isSqrt n).right
#align nat.lt_succ_sqrt Nat.lt_succ_sqrt

theorem lt_succ_sqrt' (n : ℕ) : n < succ (sqrt n) ^ 2 :=
  (sq (succ (sqrt n))).symm ▸ (lt_succ_sqrt n)
#align nat.lt_succ_sqrt' Nat.lt_succ_sqrt'

theorem sqrt_le_add (n : ℕ) : n ≤ sqrt n * sqrt n + sqrt n + sqrt n := by
  rw [← succ_mul]; exact le_of_lt_succ (lt_succ_sqrt n)
#align nat.sqrt_le_add Nat.sqrt_le_add

theorem le_sqrt {m n : ℕ} : m ≤ sqrt n ↔ m * m ≤ n :=
  ⟨fun h => le_trans (mul_self_le_mul_self h) (sqrt_le n),
   fun h => le_of_lt_succ <| mul_self_lt_mul_self_iff.2 <| lt_of_le_of_lt h (lt_succ_sqrt n)⟩
#align nat.le_sqrt Nat.le_sqrt

theorem le_sqrt' {m n : ℕ} : m ≤ sqrt n ↔ m ^ 2 ≤ n := by simpa only [pow_two] using le_sqrt
#align nat.le_sqrt' Nat.le_sqrt'

theorem sqrt_lt {m n : ℕ} : sqrt m < n ↔ m < n * n :=
  lt_iff_lt_of_le_iff_le le_sqrt
#align nat.sqrt_lt Nat.sqrt_lt

theorem sqrt_lt' {m n : ℕ} : sqrt m < n ↔ m < n ^ 2 :=
  lt_iff_lt_of_le_iff_le le_sqrt'
#align nat.sqrt_lt' Nat.sqrt_lt'

theorem sqrt_le_self (n : ℕ) : sqrt n ≤ n :=
  le_trans (le_mul_self _) (sqrt_le n)
#align nat.sqrt_le_self Nat.sqrt_le_self

theorem sqrt_le_sqrt {m n : ℕ} (h : m ≤ n) : sqrt m ≤ sqrt n :=
  le_sqrt.2 (le_trans (sqrt_le _) h)
#align nat.sqrt_le_sqrt Nat.sqrt_le_sqrt

@[simp]
theorem sqrt_zero : sqrt 0 = 0 := rfl
#align nat.sqrt_zero Nat.sqrt_zero

theorem sqrt_eq_zero {n : ℕ} : sqrt n = 0 ↔ n = 0 :=
  ⟨fun h =>
    Nat.eq_zero_of_le_zero <| le_of_lt_succ <| (@sqrt_lt n 1).1 <| by rw [h]; decide,
   by
    rintro rfl
    simp⟩
#align nat.sqrt_eq_zero Nat.sqrt_eq_zero

theorem eq_sqrt {n q} : q = sqrt n ↔ q * q ≤ n ∧ n < (q + 1) * (q + 1) :=
  ⟨fun e => e.symm ▸ sqrt_isSqrt n,
   fun ⟨h₁, h₂⟩ => le_antisymm (le_sqrt.2 h₁) (le_of_lt_succ <| sqrt_lt.2 h₂)⟩
#align nat.eq_sqrt Nat.eq_sqrt

theorem eq_sqrt' {n q} : q = sqrt n ↔ q ^ 2 ≤ n ∧ n < (q + 1) ^ 2 := by
  simpa only [pow_two] using eq_sqrt
#align nat.eq_sqrt' Nat.eq_sqrt'

theorem le_three_of_sqrt_eq_one {n : ℕ} (h : sqrt n = 1) : n ≤ 3 :=
  le_of_lt_succ <| (@sqrt_lt n 2).1 <| by rw [h]; decide
#align nat.le_three_of_sqrt_eq_one Nat.le_three_of_sqrt_eq_one

theorem sqrt_lt_self {n : ℕ} (h : 1 < n) : sqrt n < n :=
  sqrt_lt.2 <| by have := Nat.mul_lt_mul_of_pos_left h (lt_of_succ_lt h); rwa [mul_one] at this
#align nat.sqrt_lt_self Nat.sqrt_lt_self

theorem sqrt_add_eq (n : ℕ) {a : ℕ} (h : a ≤ n + n) : sqrt (n * n + a) = n :=
  le_antisymm
    (le_of_lt_succ <|
      sqrt_lt.2 <| by
        rw [succ_mul, mul_succ, add_succ, add_assoc];
          exact lt_succ_of_le (Nat.add_le_add_left h _))
    (le_sqrt.2 <| Nat.le_add_right _ _)
#align nat.sqrt_add_eq Nat.sqrt_add_eq

theorem sqrt_add_eq' (n : ℕ) {a : ℕ} (h : a ≤ n + n) : sqrt (n ^ 2 + a) = n :=
  (congr_arg (fun i => sqrt (i + a)) (sq n)).trans (sqrt_add_eq n h)
#align nat.sqrt_add_eq' Nat.sqrt_add_eq'

theorem sqrt_eq (n : ℕ) : sqrt (n * n) = n :=
  sqrt_add_eq n (zero_le _)
#align nat.sqrt_eq Nat.sqrt_eq

theorem sqrt_eq' (n : ℕ) : sqrt (n ^ 2) = n :=
  sqrt_add_eq' n (zero_le _)
#align nat.sqrt_eq' Nat.sqrt_eq'

@[simp]
theorem sqrt_one : sqrt 1 = 1 :=
  sqrt_eq 1
#align nat.sqrt_one Nat.sqrt_one

theorem sqrt_succ_le_succ_sqrt (n : ℕ) : sqrt n.succ ≤ n.sqrt.succ :=
  le_of_lt_succ <| sqrt_lt.2 <| lt_succ_of_le <|
  succ_le_succ <| le_trans (sqrt_le_add n) <| add_le_add_right
    (by refine' add_le_add (Nat.mul_le_mul_right _ _) _ <;> exact Nat.le_add_right _ 2) _
#align nat.sqrt_succ_le_succ_sqrt Nat.sqrt_succ_le_succ_sqrt

theorem exists_mul_self (x : ℕ) : (∃ n, n * n = x) ↔ sqrt x * sqrt x = x :=
  ⟨fun ⟨n, hn⟩ => by rw [← hn, sqrt_eq], fun h => ⟨sqrt x, h⟩⟩
#align nat.exists_mul_self Nat.exists_mul_self

theorem exists_mul_self' (x : ℕ) : (∃ n, n ^ 2 = x) ↔ sqrt x ^ 2 = x := by
  simpa only [pow_two] using exists_mul_self x
#align nat.exists_mul_self' Nat.exists_mul_self'

theorem sqrt_mul_sqrt_lt_succ (n : ℕ) : sqrt n * sqrt n < n + 1 :=
  lt_succ_iff.mpr (sqrt_le _)
#align nat.sqrt_mul_sqrt_lt_succ Nat.sqrt_mul_sqrt_lt_succ

theorem sqrt_mul_sqrt_lt_succ' (n : ℕ) : sqrt n ^ 2 < n + 1 :=
  lt_succ_iff.mpr (sqrt_le' _)
#align nat.sqrt_mul_sqrt_lt_succ' Nat.sqrt_mul_sqrt_lt_succ'

theorem succ_le_succ_sqrt (n : ℕ) : n + 1 ≤ (sqrt n + 1) * (sqrt n + 1) :=
  le_of_pred_lt (lt_succ_sqrt _)
#align nat.succ_le_succ_sqrt Nat.succ_le_succ_sqrt

theorem succ_le_succ_sqrt' (n : ℕ) : n + 1 ≤ (sqrt n + 1) ^ 2 :=
  le_of_pred_lt (lt_succ_sqrt' _)
#align nat.succ_le_succ_sqrt' Nat.succ_le_succ_sqrt'

/-- There are no perfect squares strictly between m² and (m+1)² -/
theorem not_exists_sq {n m : ℕ} (hl : m * m < n) (hr : n < (m + 1) * (m + 1)) :
    ¬∃ t, t * t = n := by
  rintro ⟨t, rfl⟩
  have h1 : m < t := Nat.mul_self_lt_mul_self_iff.mpr hl
  have h2 : t < m + 1 := Nat.mul_self_lt_mul_self_iff.mpr hr
  exact (not_lt_of_ge <| le_of_lt_succ h2) h1
#align nat.not_exists_sq Nat.not_exists_sq

theorem not_exists_sq' {n m : ℕ} (hl : m ^ 2 < n) (hr : n < (m + 1) ^ 2) : ¬∃ t, t ^ 2 = n := by
  simpa only [pow_two] using
    not_exists_sq (by simpa only [pow_two] using hl) (by simpa only [pow_two] using hr)
#align nat.not_exists_sq' Nat.not_exists_sq'

end Nat


/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import data.nat.enat
import data.set.intervals.ord_connected

/-!
# Theory of conditionally complete lattices.

A conditionally complete lattice is a lattice in which every non-empty bounded subset s
has a least upper bound and a greatest lower bound, denoted below by Sup s and Inf s.
Typical examples are real, nat, int with their usual orders.

The theory is very comparable to the theory of complete lattices, except that suitable
boundedness and nonemptiness assumptions have to be added to most statements.
We introduce two predicates bdd_above and bdd_below to express this boundedness, prove
their basic properties, and then go on to prove most useful properties of Sup and Inf
in conditionally complete lattices.

To differentiate the statements between complete lattices and conditionally complete
lattices, we prefix Inf and Sup in the statements by c, giving cInf and cSup. For instance,
Inf_le is a statement in complete lattices ensuring Inf s ≤ x, while cInf_le is the same
statement in conditionally complete lattices with an additional assumption that s is
bounded below.
-/

set_option old_structure_cmd true

open set

variables {α β : Type*} {ι : Sort*}

section

/-!
Extension of Sup and Inf from a preorder `α` to `with_top α` and `with_bot α`
-/

open_locale classical

noncomputable instance {α : Type*} [preorder α] [has_Sup α] : has_Sup (with_top α) :=
⟨λ S, if ⊤ ∈ S then ⊤ else
  if bdd_above (coe ⁻¹' S : set α) then ↑(Sup (coe ⁻¹' S : set α)) else ⊤⟩

noncomputable instance {α : Type*} [has_Inf α] : has_Inf (with_top α) :=
⟨λ S, if S ⊆ {⊤} then ⊤ else ↑(Inf (coe ⁻¹' S : set α))⟩

noncomputable instance {α : Type*} [has_Sup α] : has_Sup (with_bot α) :=
⟨(@with_top.has_Inf (order_dual α) _).Inf⟩

noncomputable instance {α : Type*} [preorder α] [has_Inf α] : has_Inf (with_bot α) :=
⟨(@with_top.has_Sup (order_dual α) _ _).Sup⟩

end -- section

/-- A conditionally complete lattice is a lattice in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete lattices, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_lattice (α : Type*) extends lattice α, has_Sup α, has_Inf α :=
(le_cSup : ∀s a, bdd_above s → a ∈ s → a ≤ Sup s)
(cSup_le : ∀ s a, set.nonempty s → a ∈ upper_bounds s → Sup s ≤ a)
(cInf_le : ∀s a, bdd_below s → a ∈ s → Inf s ≤ a)
(le_cInf : ∀s a, set.nonempty s → a ∈ lower_bounds s → a ≤ Inf s)

/-- A conditionally complete linear order is a linear order in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_linear_order (α : Type*)
  extends conditionally_complete_lattice α, linear_order α

/-- A conditionally complete linear order with `bot` is a linear order with least element, in which
every nonempty subset which is bounded above has a supremum, and every nonempty subset (necessarily
bounded below) has an infimum.  A typical example is the natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_linear_order_bot (α : Type*)
  extends conditionally_complete_linear_order α, order_bot α :=
(cSup_empty : Sup ∅ = ⊥)

/- A complete lattice is a conditionally complete lattice, as there are no restrictions
on the properties of Inf and Sup in a complete lattice.-/

@[priority 100] -- see Note [lower instance priority]
instance conditionally_complete_lattice_of_complete_lattice [complete_lattice α]:
  conditionally_complete_lattice α :=
{ le_cSup := by intros; apply le_Sup; assumption,
  cSup_le := by intros; apply Sup_le; assumption,
  cInf_le := by intros; apply Inf_le; assumption,
  le_cInf := by intros; apply le_Inf; assumption,
  ..‹complete_lattice α› }

@[priority 100] -- see Note [lower instance priority]
instance conditionally_complete_linear_order_of_complete_linear_order [complete_linear_order α]:
  conditionally_complete_linear_order α :=
{ ..conditionally_complete_lattice_of_complete_lattice, .. ‹complete_linear_order α› }

section conditionally_complete_lattice
variables [conditionally_complete_lattice α] {s t : set α} {a b : α}

theorem le_cSup (h₁ : bdd_above s) (h₂ : a ∈ s) : a ≤ Sup s :=
conditionally_complete_lattice.le_cSup s a h₁ h₂

theorem cSup_le (h₁ : s.nonempty) (h₂ : ∀b∈s, b ≤ a) : Sup s ≤ a :=
conditionally_complete_lattice.cSup_le s a h₁ h₂

theorem cInf_le (h₁ : bdd_below s) (h₂ : a ∈ s) : Inf s ≤ a :=
conditionally_complete_lattice.cInf_le s a h₁ h₂

theorem le_cInf (h₁ : s.nonempty) (h₂ : ∀b∈s, a ≤ b) : a ≤ Inf s :=
conditionally_complete_lattice.le_cInf s a h₁ h₂

theorem le_cSup_of_le (_ : bdd_above s) (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
le_trans h (le_cSup ‹bdd_above s› hb)

theorem cInf_le_of_le (_ : bdd_below s) (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
le_trans (cInf_le ‹bdd_below s› hb) h

theorem cSup_le_cSup (_ : bdd_above t) (_ : s.nonempty) (h : s ⊆ t) : Sup s ≤ Sup t :=
cSup_le ‹_› (assume (a) (ha : a ∈ s), le_cSup ‹bdd_above t› (h ha))

theorem cInf_le_cInf (_ : bdd_below t) (_ : s.nonempty) (h : s ⊆ t) : Inf t ≤ Inf s :=
le_cInf ‹_› (assume (a) (ha : a ∈ s), cInf_le ‹bdd_below t› (h ha))

lemma is_lub_cSup (ne : s.nonempty) (H : bdd_above s) : is_lub s (Sup s) :=
⟨assume x, le_cSup H, assume x, cSup_le ne⟩

lemma is_glb_cInf (ne : s.nonempty) (H : bdd_below s) : is_glb s (Inf s) :=
⟨assume x, cInf_le H, assume x, le_cInf ne⟩

lemma is_lub.cSup_eq (H : is_lub s a) (ne : s.nonempty) : Sup s = a :=
(is_lub_cSup ne ⟨a, H.1⟩).unique H

/-- A greatest element of a set is the supremum of this set. -/
lemma is_greatest.cSup_eq (H : is_greatest s a) : Sup s = a :=
H.is_lub.cSup_eq H.nonempty

lemma is_glb.cInf_eq (H : is_glb s a) (ne : s.nonempty) : Inf s = a :=
(is_glb_cInf ne ⟨a, H.1⟩).unique H

/-- A least element of a set is the infimum of this set. -/
lemma is_least.cInf_eq (H : is_least s a) : Inf s = a :=
H.is_glb.cInf_eq H.nonempty

lemma subset_Icc_cInf_cSup (hb : bdd_below s) (ha : bdd_above s) :
  s ⊆ Icc (Inf s) (Sup s) :=
λ x hx, ⟨cInf_le hb hx, le_cSup ha hx⟩

theorem cSup_le_iff (hb : bdd_above s) (ne : s.nonempty) : Sup s ≤ a ↔ (∀b ∈ s, b ≤ a) :=
is_lub_le_iff (is_lub_cSup ne hb)

theorem le_cInf_iff (hb : bdd_below s) (ne : s.nonempty) : a ≤ Inf s ↔ (∀b ∈ s, a ≤ b) :=
le_is_glb_iff (is_glb_cInf ne hb)

lemma cSup_lower_bounds_eq_cInf {s : set α} (h : bdd_below s) (hs : s.nonempty) :
  Sup (lower_bounds s) = Inf s :=
(is_lub_cSup h $ hs.mono $ λ x hx y hy, hy hx).unique (is_glb_cInf hs h).is_lub

lemma cInf_upper_bounds_eq_cSup {s : set α} (h : bdd_above s) (hs : s.nonempty) :
  Inf (upper_bounds s) = Sup s :=
(is_glb_cInf h $ hs.mono $ λ x hx y hy, hy hx).unique (is_lub_cSup hs h).is_glb

/--Introduction rule to prove that b is the supremum of s: it suffices to check that b
is larger than all elements of s, and that this is not the case of any `w<b`.-/
theorem cSup_intro (_ : s.nonempty) (_ : ∀a∈s, a ≤ b) (H : ∀w, w < b → (∃a∈s, w < a)) : Sup s = b :=
have bdd_above s := ⟨b, by assumption⟩,
have (Sup s < b) ∨ (Sup s = b) := lt_or_eq_of_le (cSup_le ‹_› ‹∀a∈s, a ≤ b›),
have ¬(Sup s < b) :=
  assume: Sup s < b,
  let ⟨a, _, _⟩ := (H (Sup s) ‹Sup s < b›) in  /- a ∈ s, Sup s < a-/
  have Sup s < Sup s := lt_of_lt_of_le ‹Sup s < a› (le_cSup ‹bdd_above s› ‹a ∈ s›),
  show false, by finish [lt_irrefl (Sup s)],
show Sup s = b, by finish

/--Introduction rule to prove that b is the infimum of s: it suffices to check that b
is smaller than all elements of s, and that this is not the case of any `w>b`.-/
theorem cInf_intro (_ : s.nonempty) (_ : ∀a∈s, b ≤ a) (H : ∀w, b < w → (∃a∈s, a < w)) : Inf s = b :=
have bdd_below s := ⟨b, by assumption⟩,
have (b < Inf s) ∨ (b = Inf s) := lt_or_eq_of_le (le_cInf ‹_› ‹∀a∈s, b ≤ a›),
have ¬(b < Inf s) :=
  assume: b < Inf s,
  let ⟨a, _, _⟩ := (H (Inf s) ‹b < Inf s›) in  /- a ∈ s, a < Inf s-/
  have Inf s < Inf s := lt_of_le_of_lt (cInf_le ‹bdd_below s› ‹a ∈ s›) ‹a < Inf s› ,
  show false, by finish [lt_irrefl (Inf s)],
show Inf s = b, by finish

/--b < Sup s when there is an element a in s with b < a, when s is bounded above.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness above for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
lemma lt_cSup_of_lt (_ : bdd_above s) (_ : a ∈ s) (_ : b < a) : b < Sup s :=
lt_of_lt_of_le ‹b < a› (le_cSup ‹bdd_above s› ‹a ∈ s›)

/--Inf s < b when there is an element a in s with a < b, when s is bounded below.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness below for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
lemma cInf_lt_of_lt (_ : bdd_below s) (_ : a ∈ s) (_ : a < b) : Inf s < b :=
lt_of_le_of_lt (cInf_le ‹bdd_below s› ‹a ∈ s›) ‹a < b›

/-- If all elements of a nonempty set `s` are less than or equal to all elements
of a nonempty set `t`, then there exists an element between these sets. -/
lemma exists_between_of_forall_le (sne : s.nonempty) (tne : t.nonempty)
  (hst : ∀ (x ∈ s) (y ∈ t), x ≤ y) :
  (upper_bounds s ∩ lower_bounds t).nonempty :=
⟨Inf t, λ x hx, le_cInf tne $ hst x hx, λ y hy, cInf_le (sne.mono hst) hy⟩

/--The supremum of a singleton is the element of the singleton-/
@[simp] theorem cSup_singleton (a : α) : Sup {a} = a :=
is_greatest_singleton.cSup_eq

/--The infimum of a singleton is the element of the singleton-/
@[simp] theorem cInf_singleton (a : α) : Inf {a} = a :=
is_least_singleton.cInf_eq

/--If a set is bounded below and above, and nonempty, its infimum is less than or equal to
its supremum.-/
theorem cInf_le_cSup (hb : bdd_below s) (ha : bdd_above s) (ne : s.nonempty) : Inf s ≤ Sup s :=
is_glb_le_is_lub (is_glb_cInf ne hb) (is_lub_cSup ne ha) ne

/--The sup of a union of two sets is the max of the suprema of each subset, under the assumptions
that all sets are bounded above and nonempty.-/
theorem cSup_union (hs : bdd_above s) (sne : s.nonempty) (ht : bdd_above t) (tne : t.nonempty) :
  Sup (s ∪ t) = Sup s ⊔ Sup t :=
((is_lub_cSup sne hs).union (is_lub_cSup tne ht)).cSup_eq sne.inl

/--The inf of a union of two sets is the min of the infima of each subset, under the assumptions
that all sets are bounded below and nonempty.-/
theorem cInf_union (hs : bdd_below s) (sne : s.nonempty) (ht : bdd_below t) (tne : t.nonempty) :
  Inf (s ∪ t) = Inf s ⊓ Inf t :=
((is_glb_cInf sne hs).union (is_glb_cInf tne ht)).cInf_eq sne.inl

/--The supremum of an intersection of two sets is bounded by the minimum of the suprema of each
set, if all sets are bounded above and nonempty.-/
theorem cSup_inter_le (_ : bdd_above s) (_ : bdd_above t) (hst : (s ∩ t).nonempty) :
  Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
begin
  apply cSup_le hst, simp only [le_inf_iff, and_imp, set.mem_inter_eq], intros b _ _, split,
  apply le_cSup ‹bdd_above s› ‹b ∈ s›,
  apply le_cSup ‹bdd_above t› ‹b ∈ t›
end

/--The infimum of an intersection of two sets is bounded below by the maximum of the
infima of each set, if all sets are bounded below and nonempty.-/
theorem le_cInf_inter (_ : bdd_below s) (_ : bdd_below t) (hst : (s ∩ t).nonempty) :
Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
begin
  apply le_cInf hst, simp only [and_imp, set.mem_inter_eq, sup_le_iff], intros b _ _, split,
  apply cInf_le ‹bdd_below s› ‹b ∈ s›,
  apply cInf_le ‹bdd_below t› ‹b ∈ t›
end

/-- The supremum of insert a s is the maximum of a and the supremum of s, if s is
nonempty and bounded above.-/
theorem cSup_insert (hs : bdd_above s) (sne : s.nonempty) : Sup (insert a s) = a ⊔ Sup s :=
((is_lub_cSup sne hs).insert a).cSup_eq (insert_nonempty a s)

/-- The infimum of insert a s is the minimum of a and the infimum of s, if s is
nonempty and bounded below.-/
theorem cInf_insert (hs : bdd_below s) (sne : s.nonempty) : Inf (insert a s) = a ⊓ Inf s :=
((is_glb_cInf sne hs).insert a).cInf_eq (insert_nonempty a s)

@[simp] lemma cInf_Icc (h : a ≤ b) : Inf (Icc a b) = a :=
(is_glb_Icc h).cInf_eq (nonempty_Icc.2 h)

@[simp] lemma cInf_Ici : Inf (Ici a) = a := is_least_Ici.cInf_eq

@[simp] lemma cInf_Ico (h : a < b) : Inf (Ico a b) = a :=
(is_glb_Ico h).cInf_eq (nonempty_Ico.2 h)

@[simp] lemma cInf_Ioc [densely_ordered α] (h : a < b) : Inf (Ioc a b) = a :=
(is_glb_Ioc h).cInf_eq (nonempty_Ioc.2 h)

@[simp] lemma cInf_Ioi [no_top_order α] [densely_ordered α] : Inf (Ioi a) = a :=
cInf_intro nonempty_Ioi (λ _, le_of_lt) (λ w hw, by simpa using exists_between hw)

@[simp] lemma cInf_Ioo [densely_ordered α] (h : a < b) : Inf (Ioo a b) = a :=
(is_glb_Ioo h).cInf_eq (nonempty_Ioo.2 h)

@[simp] lemma cSup_Icc (h : a ≤ b) : Sup (Icc a b) = b :=
(is_lub_Icc h).cSup_eq (nonempty_Icc.2 h)

@[simp] lemma cSup_Ico [densely_ordered α] (h : a < b) : Sup (Ico a b) = b :=
(is_lub_Ico h).cSup_eq (nonempty_Ico.2 h)

@[simp] lemma cSup_Iic : Sup (Iic a) = a := is_greatest_Iic.cSup_eq

@[simp] lemma cSup_Iio [no_bot_order α] [densely_ordered α] : Sup (Iio a) = a :=
cSup_intro nonempty_Iio (λ _, le_of_lt) (λ w hw, by simpa [and_comm] using exists_between hw)

@[simp] lemma cSup_Ioc (h : a < b) : Sup (Ioc a b) = b :=
(is_lub_Ioc h).cSup_eq (nonempty_Ioc.2 h)

@[simp] lemma cSup_Ioo [densely_ordered α] (h : a < b) : Sup (Ioo a b) = b :=
(is_lub_Ioo h).cSup_eq (nonempty_Ioo.2 h)

/--The indexed supremum of two functions are comparable if the functions are pointwise comparable-/
lemma csupr_le_csupr {f g : ι → α} (B : bdd_above (range g)) (H : ∀x, f x ≤ g x) :
  supr f ≤ supr g :=
begin
  classical, by_cases hι : nonempty ι,
  { have Rf : (range f).nonempty, { exactI range_nonempty _ },
    apply cSup_le Rf,
    rintros y ⟨x, rfl⟩,
    have : g x ∈ range g := ⟨x, rfl⟩,
    exact le_cSup_of_le B this (H x) },
  { have Rf : range f = ∅, from range_eq_empty.2 hι,
    have Rg : range g = ∅, from range_eq_empty.2 hι,
    unfold supr, rw [Rf, Rg] }
end

/--The indexed supremum of a function is bounded above by a uniform bound-/
lemma csupr_le [nonempty ι] {f : ι → α} {c : α} (H : ∀x, f x ≤ c) : supr f ≤ c :=
cSup_le (range_nonempty f) (by rwa forall_range_iff)

/--The indexed supremum of a function is bounded below by the value taken at one point-/
lemma le_csupr {f : ι → α} (H : bdd_above (range f)) (c : ι) : f c ≤ supr f :=
le_cSup H (mem_range_self _)

/--The indexed infimum of two functions are comparable if the functions are pointwise comparable-/
lemma cinfi_le_cinfi {f g : ι → α} (B : bdd_below (range f)) (H : ∀x, f x ≤ g x) :
  infi f ≤ infi g :=
begin
  classical, by_cases hι : nonempty ι,
  { have Rg : (range g).nonempty, { exactI range_nonempty _ },
    apply le_cInf Rg,
    rintros y ⟨x, rfl⟩,
    have : f x ∈ range f := ⟨x, rfl⟩,
    exact cInf_le_of_le B this (H x) },
  { have Rf : range f = ∅, from range_eq_empty.2 hι,
    have Rg : range g = ∅, from range_eq_empty.2 hι,
    unfold infi, rw [Rf, Rg] }
end

/--The indexed minimum of a function is bounded below by a uniform lower bound-/
lemma le_cinfi [nonempty ι] {f : ι → α} {c : α} (H : ∀x, c ≤ f x) : c ≤ infi f :=
le_cInf (range_nonempty f) (by rwa forall_range_iff)

/--The indexed infimum of a function is bounded above by the value taken at one point-/
lemma cinfi_le {f : ι → α} (H : bdd_below (range f)) (c : ι) : infi f ≤ f c :=
cInf_le H (mem_range_self _)

@[simp] theorem cinfi_const [hι : nonempty ι] {a : α} : (⨅ b:ι, a) = a :=
by rw [infi, range_const, cInf_singleton]

@[simp] theorem csupr_const [hι : nonempty ι] {a : α} : (⨆ b:ι, a) = a :=
by rw [supr, range_const, cSup_singleton]

theorem infi_unique [unique ι] {s : ι → α} : (⨅ i, s i) = s (default ι) :=
have ∀ i, s i = s (default ι) := λ i, congr_arg s (unique.eq_default i),
by simp only [this, cinfi_const]

theorem supr_unique [unique ι] {s : ι → α} : (⨆ i, s i) = s (default ι) :=
have ∀ i, s i = s (default ι) := λ i, congr_arg s (unique.eq_default i),
by simp only [this, csupr_const]

@[simp] theorem infi_unit {f : unit → α} : (⨅ x, f x) = f () :=
by { convert infi_unique, apply_instance }

@[simp] theorem supr_unit {f : unit → α} : (⨆ x, f x) = f () :=
by { convert supr_unique, apply_instance }

/-- Nested intervals lemma: if `f` is a monotonically increasing sequence, `g` is a monotonically
decreasing sequence, and `f n ≤ g n` for all `n`, then `⨆ n, f n` belongs to all the intervals
`[f n, g n]`. -/
lemma csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr [nonempty β] [semilattice_sup β]
  {f g : β → α} (hf : monotone f) (hg : ∀ ⦃m n⦄, m ≤ n → g n ≤ g m) (h : ∀ n, f n ≤ g n) :
  (⨆ n, f n) ∈ ⋂ n, Icc (f n) (g n) :=
begin
  inhabit β,
  refine mem_Inter.2 (λ n, ⟨le_csupr ⟨g $ default β, forall_range_iff.2 $ λ m, _⟩ _,
    csupr_le $ λ m, _⟩); exact forall_le_of_monotone_of_mono_decr hf hg h _ _
end

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
lemma csupr_mem_Inter_Icc_of_mono_decr_Icc [nonempty β] [semilattice_sup β]
  {f g : β → α} (h : ∀ ⦃m n⦄, m ≤ n → Icc (f n) (g n) ⊆ Icc (f m) (g m)) (h' : ∀ n, f n ≤ g n) :
  (⨆ n, f n) ∈ ⋂ n, Icc (f n) (g n) :=
csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr (λ m n hmn, ((Icc_subset_Icc_iff (h' n)).1 (h hmn)).1)
  (λ m n hmn, ((Icc_subset_Icc_iff (h' n)).1 (h hmn)).2) h'

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
lemma csupr_mem_Inter_Icc_of_mono_decr_Icc_nat
  {f g : ℕ → α} (h : ∀ n, Icc (f (n + 1)) (g (n + 1)) ⊆ Icc (f n) (g n)) (h' : ∀ n, f n ≤ g n) :
  (⨆ n, f n) ∈ ⋂ n, Icc (f n) (g n) :=
csupr_mem_Inter_Icc_of_mono_decr_Icc
  (@monotone_of_monotone_nat (order_dual $ set α) _ (λ n, Icc (f n) (g n)) h) h'

end conditionally_complete_lattice

instance pi.conditionally_complete_lattice {ι : Type*} {α : Π i : ι, Type*}
  [Π i, conditionally_complete_lattice (α i)] :
  conditionally_complete_lattice (Π i, α i) :=
{ le_cSup := λ s f ⟨g, hg⟩ hf i, le_cSup ⟨g i, set.forall_range_iff.2 $ λ ⟨f', hf'⟩, hg hf' i⟩
    ⟨⟨f, hf⟩, rfl⟩,
  cSup_le := λ s f hs hf i, cSup_le (by haveI := hs.to_subtype; apply range_nonempty) $
    λ b ⟨⟨g, hg⟩, hb⟩, hb ▸ hf hg i,
  cInf_le := λ s f ⟨g, hg⟩ hf i, cInf_le ⟨g i, set.forall_range_iff.2 $ λ ⟨f', hf'⟩, hg hf' i⟩
    ⟨⟨f, hf⟩, rfl⟩,
  le_cInf := λ s f hs hf i, le_cInf (by haveI := hs.to_subtype; apply range_nonempty) $
    λ b ⟨⟨g, hg⟩, hb⟩, hb ▸ hf hg i,
  .. pi.lattice, .. pi.has_Sup, .. pi.has_Inf }

section conditionally_complete_linear_order
variables [conditionally_complete_linear_order α] {s t : set α} {a b : α}

/-- When b < Sup s, there is an element a in s with b < a, if s is nonempty and the order is
a linear order. -/
lemma exists_lt_of_lt_cSup (hs : s.nonempty) (hb : b < Sup s) : ∃a∈s, b < a :=
begin
  classical, contrapose! hb,
  exact cSup_le hs hb
end

/--
Indexed version of the above lemma `exists_lt_of_lt_cSup`.
When `b < supr f`, there is an element `i` such that `b < f i`.
-/
lemma exists_lt_of_lt_csupr [nonempty ι] {f : ι → α} (h : b < supr f) :
  ∃i, b < f i :=
let ⟨_, ⟨i, rfl⟩, h⟩ := exists_lt_of_lt_cSup (range_nonempty f) h in ⟨i, h⟩

/--When Inf s < b, there is an element a in s with a < b, if s is nonempty and the order is
a linear order.-/
lemma exists_lt_of_cInf_lt (hs : s.nonempty) (hb : Inf s < b) : ∃a∈s, a < b :=
begin
  classical, contrapose! hb,
  exact le_cInf hs hb
end

/--
Indexed version of the above lemma `exists_lt_of_cInf_lt`
When `infi f < a`, there is an element `i` such that `f i < a`.
-/
lemma exists_lt_of_cinfi_lt [nonempty ι] {f : ι → α} (h : infi f < a) :
  (∃i, f i < a) :=
let ⟨_, ⟨i, rfl⟩, h⟩ := exists_lt_of_cInf_lt (range_nonempty f) h in ⟨i, h⟩

/--Introduction rule to prove that b is the supremum of s: it suffices to check that
1) b is an upper bound
2) every other upper bound b' satisfies b ≤ b'.-/
theorem cSup_intro' (_ : s.nonempty)
  (h_is_ub : ∀ a ∈ s, a ≤ b) (h_b_le_ub : ∀ub, (∀ a ∈ s, a ≤ ub) → (b ≤ ub)) : Sup s = b :=
le_antisymm
  (show Sup s ≤ b, from cSup_le ‹s.nonempty› h_is_ub)
  (show b ≤ Sup s, from h_b_le_ub _ $ assume a, le_cSup ⟨b, h_is_ub⟩)

end conditionally_complete_linear_order

section conditionally_complete_linear_order_bot

lemma cSup_empty [conditionally_complete_linear_order_bot α] : (Sup ∅ : α) = ⊥ :=
conditionally_complete_linear_order_bot.cSup_empty

end conditionally_complete_linear_order_bot

namespace nat

open_locale classical

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end nat

namespace with_top
open_locale classical

variables [conditionally_complete_linear_order_bot α]

/-- The Sup of a non-empty set is its least upper bound for a conditionally
complete lattice with a top. -/
lemma is_lub_Sup' {β : Type*} [conditionally_complete_lattice β]
  {s : set (with_top β)} (hs : s.nonempty) : is_lub s (Sup s) :=
begin
  split,
  { show ite _ _ _ ∈ _,
    split_ifs,
    { intros _ _, exact le_top },
    { rintro (⟨⟩|a) ha,
      { contradiction },
      apply some_le_some.2,
      exact le_cSup h_1 ha },
    { intros _ _, exact le_top } },
  { show ite _ _ _ ∈ _,
    split_ifs,
    { rintro (⟨⟩|a) ha,
      { exact _root_.le_refl _ },
      { exact false.elim (not_top_le_coe a (ha h)) } },
    { rintro (⟨⟩|b) hb,
      { exact le_top },
      refine some_le_some.2 (cSup_le _ _),
      { rcases hs with ⟨⟨⟩|b, hb⟩,
        { exact absurd hb h },
        { exact ⟨b, hb⟩ } },
      { intros a ha, exact some_le_some.1 (hb ha) } },
    { rintro (⟨⟩|b) hb,
      { exact _root_.le_refl _ },
      { exfalso, apply h_1, use b, intros a ha, exact some_le_some.1 (hb ha) } } }
end

lemma is_lub_Sup (s : set (with_top α)) : is_lub s (Sup s) :=
begin
  cases s.eq_empty_or_nonempty with hs hs,
  { rw hs,
    show is_lub ∅ (ite _ _ _),
    split_ifs,
    { cases h },
    { rw [preimage_empty, cSup_empty], exact is_lub_empty },
    { exfalso, apply h_1, use ⊥, rintro a ⟨⟩ } },
  exact is_lub_Sup' hs,
end

/-- The Inf of a bounded-below set is its greatest lower bound for a conditionally
complete lattice with a top. -/
lemma is_glb_Inf' {β : Type*} [conditionally_complete_lattice β]
  {s : set (with_top β)} (hs : bdd_below s) : is_glb s (Inf s) :=
begin
  split,
  { show ite _ _ _ ∈ _,
    split_ifs,
    { intros a ha, exact top_le_iff.2 (set.mem_singleton_iff.1 (h ha)) },
    { rintro (⟨⟩|a) ha,
      { exact le_top },
      refine some_le_some.2 (cInf_le _ ha),
      rcases hs with ⟨⟨⟩|b, hb⟩,
      { exfalso,
        apply h,
        intros c hc,
        rw [mem_singleton_iff, ←top_le_iff],
        exact hb hc },
      use b,
      intros c hc,
      exact some_le_some.1 (hb hc) } },
  { show ite _ _ _ ∈ _,
    split_ifs,
    { intros _ _, exact le_top },
    { rintro (⟨⟩|a) ha,
      { exfalso, apply h, intros b hb, exact set.mem_singleton_iff.2 (top_le_iff.1 (ha hb)) },
      { refine some_le_some.2 (le_cInf _ _),
        { classical, contrapose! h,
          rintros (⟨⟩|a) ha,
          { exact mem_singleton ⊤ },
          { exact (h ⟨a, ha⟩).elim }},
        { intros b hb,
          rw ←some_le_some,
          exact ha hb } } } }
end

lemma is_glb_Inf (s : set (with_top α)) : is_glb s (Inf s) :=
begin
  by_cases hs : bdd_below s,
  { exact is_glb_Inf' hs },
  { exfalso, apply hs, use ⊥, intros _ _, exact bot_le },
end

noncomputable instance : complete_linear_order (with_top α) :=
{ Sup := Sup, le_Sup := assume s, (is_lub_Sup s).1, Sup_le := assume s, (is_lub_Sup s).2,
  Inf := Inf, le_Inf := assume s, (is_glb_Inf s).2, Inf_le := assume s, (is_glb_Inf s).1,
  decidable_le := classical.dec_rel _,
  .. with_top.linear_order, ..with_top.lattice, ..with_top.order_top, ..with_top.order_bot }

lemma coe_Sup {s : set α} (hb : bdd_above s) : (↑(Sup s) : with_top α) = (⨆a∈s, ↑a) :=
begin
  cases s.eq_empty_or_nonempty with hs hs,
  { rw [hs, cSup_empty], simp only [set.mem_empty_eq, supr_bot, supr_false], refl },
  apply le_antisymm,
  { refine (coe_le_iff.2 $ assume b hb, cSup_le hs $ assume a has, coe_le_coe.1 $ hb ▸ _),
    exact (le_supr_of_le a $ le_supr_of_le has $ _root_.le_refl _) },
  { exact (supr_le $ assume a, supr_le $ assume ha, coe_le_coe.2 $ le_cSup hb ha) }
end

lemma coe_Inf {s : set α} (hs : s.nonempty) : (↑(Inf s) : with_top α) = (⨅a∈s, ↑a) :=
let ⟨x, hx⟩ := hs in
have (⨅a∈s, ↑a : with_top α) ≤ x, from infi_le_of_le x $ infi_le_of_le hx $ _root_.le_refl _,
let ⟨r, r_eq, hr⟩ := le_coe_iff.1 this in
le_antisymm
  (le_infi $ assume a, le_infi $ assume ha, coe_le_coe.2 $ cInf_le (order_bot.bdd_below s) ha)
  begin
    refine (r_eq.symm ▸ coe_le_coe.2 $ le_cInf hs $ assume a has, coe_le_coe.1 $ _),
    refine (r_eq ▸ infi_le_of_le a _),
    exact (infi_le_of_le has $ _root_.le_refl _),
  end

end with_top

namespace enat
open_locale classical

noncomputable instance : complete_linear_order enat :=
{ Sup := λ s, with_top_equiv.symm $ Sup (with_top_equiv '' s),
  Inf := λ s, with_top_equiv.symm $ Inf (with_top_equiv '' s),
  le_Sup := by intros; rw ← with_top_equiv_le; simp; apply le_Sup _; simpa,
  Inf_le := by intros; rw ← with_top_equiv_le; simp; apply Inf_le _; simpa,
  Sup_le := begin
    intros s a h1,
    rw [← with_top_equiv_le, with_top_equiv.right_inverse_symm],
    apply Sup_le _,
    rintros b ⟨x, h2, rfl⟩,
    rw with_top_equiv_le,
    apply h1,
    assumption
  end,
  le_Inf := begin
    intros s a h1,
    rw [← with_top_equiv_le, with_top_equiv.right_inverse_symm],
    apply le_Inf _,
    rintros b ⟨x, h2, rfl⟩,
    rw with_top_equiv_le,
    apply h1,
    assumption
  end,
  ..enat.linear_order,
  ..enat.bounded_lattice }

end enat

section order_dual

instance (α : Type*) [conditionally_complete_lattice α] :
  conditionally_complete_lattice (order_dual α) :=
{ le_cSup := @cInf_le α _,
  cSup_le := @le_cInf α _,
  le_cInf := @cSup_le α _,
  cInf_le := @le_cSup α _,
  ..order_dual.has_Inf α,
  ..order_dual.has_Sup α,
  ..order_dual.lattice α }

instance (α : Type*) [conditionally_complete_linear_order α] :
  conditionally_complete_linear_order (order_dual α) :=
{ ..order_dual.conditionally_complete_lattice α,
  ..order_dual.linear_order α }

end order_dual

namespace monotone
variables [preorder α] [conditionally_complete_lattice β] {f : α → β} (h_mono : monotone f)

/-! A monotone function into a conditionally complete lattice preserves the ordering properties of
`Sup` and `Inf`. -/

lemma le_cSup_image {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_above s) :
  f c ≤ Sup (f '' s) :=
le_cSup (map_bdd_above h_mono h_bdd) (mem_image_of_mem f hcs)

lemma cSup_image_le {s : set α} (hs : s.nonempty) {B : α} (hB: B ∈ upper_bounds s) :
  Sup (f '' s) ≤ f B :=
cSup_le (nonempty.image f hs) (h_mono.mem_upper_bounds_image hB)

lemma cInf_image_le {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_below s) :
  Inf (f '' s) ≤ f c :=
@le_cSup_image (order_dual α) (order_dual β) _ _ _ (λ x y hxy, h_mono hxy) _ _ hcs h_bdd

lemma le_cInf_image {s : set α} (hs : s.nonempty) {B : α} (hB: B ∈ lower_bounds s) :
  f B ≤ Inf (f '' s) :=
@cSup_image_le (order_dual α) (order_dual β) _ _ _ (λ x y hxy, h_mono hxy) _ hs _ hB

end monotone

section with_top_bot

/-!
### Complete lattice structure on `with_top (with_bot α)`

If `α` is a `conditionally_complete_lattice`, then we show that `with_top α` and `with_bot α`
also inherit the structure of conditionally complete lattices. Furthermore, we show
that `with_top (with_bot α)` naturally inherits the structure of a complete lattice. Note that
for α a conditionally complete lattice, `Sup` and `Inf` both return junk values
for sets which are empty or unbounded. The extension of `Sup` to `with_top α` fixes
the unboundedness problem and the extension to `with_bot α` fixes the problem with
the empty set.

This result can be used to show that the extended reals [-∞, ∞] are a complete lattice.
-/

open_locale classical

/-- Adding a top element to a conditionally complete lattice
gives a conditionally complete lattice -/
noncomputable instance with_top.conditionally_complete_lattice
  {α : Type*} [conditionally_complete_lattice α] :
  conditionally_complete_lattice (with_top α) :=
{ le_cSup := λ S a hS haS, (with_top.is_lub_Sup' ⟨a, haS⟩).1 haS,
  cSup_le := λ S a hS haS, (with_top.is_lub_Sup' hS).2 haS,
  cInf_le := λ S a hS haS, (with_top.is_glb_Inf' hS).1 haS,
  le_cInf := λ S a hS haS, (with_top.is_glb_Inf' ⟨a, haS⟩).2 haS,
  ..with_top.lattice,
  ..with_top.has_Sup,
  ..with_top.has_Inf }

/-- Adding a bottom element to a conditionally complete lattice
gives a conditionally complete lattice -/
noncomputable instance with_bot.conditionally_complete_lattice
  {α : Type*} [conditionally_complete_lattice α] :
  conditionally_complete_lattice (with_bot α) :=
{ le_cSup := (@with_top.conditionally_complete_lattice (order_dual α) _).cInf_le,
  cSup_le := (@with_top.conditionally_complete_lattice (order_dual α) _).le_cInf,
  cInf_le := (@with_top.conditionally_complete_lattice (order_dual α) _).le_cSup,
  le_cInf := (@with_top.conditionally_complete_lattice (order_dual α) _).cSup_le,
  ..with_bot.lattice,
  ..with_bot.has_Sup,
  ..with_bot.has_Inf }

/-- Adding a bottom and a top to a conditionally complete lattice gives a bounded lattice-/
noncomputable instance with_top.with_bot.bounded_lattice {α : Type*}
  [conditionally_complete_lattice α] : bounded_lattice (with_top (with_bot α)) :=
{ ..with_top.order_bot,
  ..with_top.order_top,
  ..conditionally_complete_lattice.to_lattice _ }

theorem with_bot.cSup_empty {α : Type*} [conditionally_complete_lattice α] :
  Sup (∅ : set (with_bot α)) = ⊥ :=
begin
  show ite _ _ _ = ⊥,
  split_ifs; finish,
end

noncomputable instance with_top.with_bot.complete_lattice {α : Type*}
  [conditionally_complete_lattice α] : complete_lattice (with_top (with_bot α)) :=
{ le_Sup := λ S a haS, (with_top.is_lub_Sup' ⟨a, haS⟩).1 haS,
  Sup_le := λ S a ha,
    begin
      cases S.eq_empty_or_nonempty with h,
      { show ite _ _ _ ≤ a,
        split_ifs,
        { rw h at h_1, cases h_1 },
        { convert bot_le, convert with_bot.cSup_empty, rw h, refl },
        { exfalso, apply h_2, use ⊥, rw h, rintro b ⟨⟩ } },
      { refine (with_top.is_lub_Sup' h).2 ha }
    end,
  Inf_le := λ S a haS,
    show ite _ _ _ ≤ a,
    begin
      split_ifs,
      { cases a with a, exact _root_.le_refl _,
        cases (h haS); tauto },
      { cases a,
        { exact le_top },
        { apply with_top.some_le_some.2, refine cInf_le _ haS, use ⊥, intros b hb, exact bot_le } }
    end,
  le_Inf := λ S a haS, (with_top.is_glb_Inf' ⟨a, haS⟩).2 haS,
  ..with_top.has_Inf,
  ..with_top.has_Sup,
  ..with_top.with_bot.bounded_lattice }

end with_top_bot

section subtype
variables (s : set α)

/-! ### Subtypes of conditionally complete linear orders

In this section we give conditions on a subset of a conditionally complete linear order, to ensure
that the subtype is itself conditionally complete.

We check that an `ord_connected` set satisfies these conditions.

TODO There are several possible variants; the `conditionally_complete_linear_order` could be changed
to `conditionally_complete_linear_order_bot` or `complete_linear_order`.
-/

open_locale classical

section has_Sup
variables [has_Sup α]

/-- `has_Sup` structure on a nonempty subset `s` of an object with `has_Sup`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
noncomputable def subset_has_Sup [inhabited s] : has_Sup s := {Sup := λ t,
if ht : Sup (coe '' t : set α) ∈ s then ⟨Sup (coe '' t : set α), ht⟩ else default s}

local attribute [instance] subset_has_Sup

@[simp] lemma subset_Sup_def [inhabited s] :
  @Sup s _ = λ t,
  if ht : Sup (coe '' t : set α) ∈ s then ⟨Sup (coe '' t : set α), ht⟩ else default s :=
rfl

lemma subset_Sup_of_within [inhabited s] {t : set s} (h : Sup (coe '' t : set α) ∈ s) :
  Sup (coe '' t : set α) = (@Sup s _ t : α) :=
by simp [dif_pos h]

end has_Sup

section has_Inf
variables [has_Inf α]

/-- `has_Inf` structure on a nonempty subset `s` of an object with `has_Inf`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
noncomputable def subset_has_Inf [inhabited s] : has_Inf s := {Inf := λ t,
if ht : Inf (coe '' t : set α) ∈ s then ⟨Inf (coe '' t : set α), ht⟩ else default s}

local attribute [instance] subset_has_Inf

@[simp] lemma subset_Inf_def [inhabited s] :
  @Inf s _ = λ t,
  if ht : Inf (coe '' t : set α) ∈ s then ⟨Inf (coe '' t : set α), ht⟩ else default s :=
rfl

lemma subset_Inf_of_within [inhabited s] {t : set s} (h : Inf (coe '' t : set α) ∈ s) :
  Inf (coe '' t : set α) = (@Inf s _ t : α) :=
by simp [dif_pos h]

end has_Inf

variables [conditionally_complete_linear_order α]

local attribute [instance] subset_has_Sup
local attribute [instance] subset_has_Inf

/-- For a nonempty subset of a conditionally complete linear order to be a conditionally complete
linear order, it suffices that it contain the `Sup` of all its nonempty bounded-above subsets, and
the `Inf` of all its nonempty bounded-below subsets. -/
noncomputable def subset_conditionally_complete_linear_order [inhabited s]
  (h_Sup : ∀ {t : set s} (ht : t.nonempty) (h_bdd : bdd_above t), Sup (coe '' t : set α) ∈ s)
  (h_Inf : ∀ {t : set s} (ht : t.nonempty) (h_bdd : bdd_below t), Inf (coe '' t : set α) ∈ s) :
  conditionally_complete_linear_order s :=
{ le_cSup := begin
    rintros t c h_bdd hct,
    -- The following would be a more natural way to finish, but gives a "deep recursion" error:
    -- simpa [subset_Sup_of_within (h_Sup t)] using
    --   (strict_mono_coe s).monotone.le_cSup_image hct h_bdd,
    have := (subtype.mono_coe s).le_cSup_image hct h_bdd,
    rwa subset_Sup_of_within s (h_Sup ⟨c, hct⟩ h_bdd) at this,
  end,
  cSup_le := begin
    rintros t B ht hB,
    have := (subtype.mono_coe s).cSup_image_le ht hB,
    rwa subset_Sup_of_within s (h_Sup ht ⟨B, hB⟩) at this,
  end,
  le_cInf := begin
    intros t B ht hB,
    have := (subtype.mono_coe s).le_cInf_image ht hB,
    rwa subset_Inf_of_within s (h_Inf ht ⟨B, hB⟩) at this,
  end,
  cInf_le := begin
    rintros t c h_bdd hct,
    have := (subtype.mono_coe s).cInf_image_le hct h_bdd,
    rwa subset_Inf_of_within s (h_Inf ⟨c, hct⟩ h_bdd) at this,
  end,
  ..subset_has_Sup s,
  ..subset_has_Inf s,
  ..distrib_lattice.to_lattice s,
  ..(infer_instance : linear_order s) }

section ord_connected

/-- The `Sup` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-above subsets of `s`. -/
lemma Sup_within_of_ord_connected
  {s : set α} [hs : ord_connected s] ⦃t : set s⦄ (ht : t.nonempty) (h_bdd : bdd_above t) :
  Sup (coe '' t : set α) ∈ s :=
begin
  obtain ⟨c, hct⟩ : ∃ c, c ∈ t := ht,
  obtain ⟨B, hB⟩ : ∃ B, B ∈ upper_bounds t := h_bdd,
  refine hs.out c.2 B.2 ⟨_, _⟩,
  { exact (subtype.mono_coe s).le_cSup_image hct ⟨B, hB⟩ },
  { exact (subtype.mono_coe s).cSup_image_le ⟨c, hct⟩ hB },
end

/-- The `Inf` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-below subsets of `s`. -/
lemma Inf_within_of_ord_connected
  {s : set α} [hs : ord_connected s] ⦃t : set s⦄ (ht : t.nonempty) (h_bdd : bdd_below t) :
  Inf (coe '' t : set α) ∈ s :=
begin
  obtain ⟨c, hct⟩ : ∃ c, c ∈ t := ht,
  obtain ⟨B, hB⟩ : ∃ B, B ∈ lower_bounds t := h_bdd,
  refine hs.out B.2 c.2 ⟨_, _⟩,
  { exact (subtype.mono_coe s).le_cInf_image ⟨c, hct⟩ hB },
  { exact (subtype.mono_coe s).cInf_image_le hct ⟨B, hB⟩ },
end

/-- A nonempty `ord_connected` set in a conditionally complete linear order is naturally a
conditionally complete linear order. -/
noncomputable instance ord_connected_subset_conditionally_complete_linear_order
  [inhabited s] [ord_connected s] :
  conditionally_complete_linear_order s :=
subset_conditionally_complete_linear_order s Sup_within_of_ord_connected Inf_within_of_ord_connected

end ord_connected

end subtype


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

! This file was ported from Lean 3 source module algebra.hom.embedding
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Group.Defs
import Mathbin.Logic.Embedding.Basic

/-!
# The embedding of a cancellative semigroup into itself by multiplication by a fixed element.

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

variable {R : Type _}

section LeftOrRightCancelSemigroup

#print mulLeftEmbedding /-
/-- The embedding of a left cancellative semigroup into itself
by left multiplication by a fixed element.
 -/
@[to_additive
      "The embedding of a left cancellative additive semigroup into itself\n   by left translation by a fixed element.",
  simps]
def mulLeftEmbedding {G : Type _} [LeftCancelSemigroup G] (g : G) : G ↪ G
    where
  toFun h := g * h
  inj' := mul_right_injective g
#align mul_left_embedding mulLeftEmbedding
#align add_left_embedding addLeftEmbedding
-/

#print mulRightEmbedding /-
/-- The embedding of a right cancellative semigroup into itself
by right multiplication by a fixed element.
 -/
@[to_additive
      "The embedding of a right cancellative additive semigroup into itself\n   by right translation by a fixed element.",
  simps]
def mulRightEmbedding {G : Type _} [RightCancelSemigroup G] (g : G) : G ↪ G
    where
  toFun h := h * g
  inj' := mul_left_injective g
#align mul_right_embedding mulRightEmbedding
#align add_right_embedding addRightEmbedding
-/

#print mul_left_embedding_eq_mul_right_embedding /-
@[to_additive]
theorem mul_left_embedding_eq_mul_right_embedding {G : Type _} [CancelCommMonoid G] (g : G) :
    mulLeftEmbedding g = mulRightEmbedding g := by
  ext
  exact mul_comm _ _
#align mul_left_embedding_eq_mul_right_embedding mul_left_embedding_eq_mul_right_embedding
#align add_left_embedding_eq_add_right_embedding add_left_embedding_eq_add_right_embedding
-/

end LeftOrRightCancelSemigroup


open string

constant category: Type
constant object: Π C: category, Type
constant hom: Π {C: category}, object C -> object C -> Type
constant comp: Π {C: category} {a b c: object C}, hom a b → hom b c → hom a c
constant e: Π {C: category} x:object C, hom x x
infix * := comp
constant leftId: Π {C: category} (x y: object C) (f: hom x y), e x * f = f
constant rightId: Π {C: category} (x y: object C) (f: hom x y), f * e y = f

variable C:category
variable x:object C
variable y:object C
variable z:object C
variable f:hom x y
variable g:hom y z
variable h:hom y z

#check leftId
#check f*g
#check e
#check f*(e y)

constant left_intro : Π {C: category} {x y z: object C} {f:hom x y} {g h : hom y z}, g=h → f*g = f*h
#check left_intro

variable Hcd : g=h

theorem trivia: f*g = f*h :=
    calc
        f*g = f*h : left_intro Hcd

#check trivia


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.nat.choose.basic
import data.nat.factorial.cast

/-!
# Cast of binomial coefficients

This file allows calculating the binomial coefficient `a.choose b` as an element of a division ring
of characteristic `0`.
-/

open_locale nat

variables (K : Type*) [division_ring K] [char_zero K]

namespace nat

lemma cast_choose {a b : ℕ} (h : a ≤ b) :
  (b.choose a : K) = b! / (a! * (b - a)!) :=
begin
  have : ∀ {n : ℕ}, (n! : K) ≠ 0 := λ n, nat.cast_ne_zero.2 (factorial_ne_zero _),
  rw eq_div_iff_mul_eq (mul_ne_zero this this),
  rw_mod_cast [← mul_assoc, choose_mul_factorial_mul_factorial h],
end

lemma cast_add_choose {a b : ℕ} :
  ((a + b).choose a : K) = (a + b)! / (a! * b!) :=
by rw [cast_choose K (le_add_right le_rfl), add_tsub_cancel_left]

lemma cast_choose_eq_pochhammer_div (a b : ℕ) :
  (a.choose b : K) = (pochhammer K b).eval (a - (b - 1) : ℕ) / b! :=
by rw [eq_div_iff_mul_eq (nat.cast_ne_zero.2 b.factorial_ne_zero : (b! : K) ≠ 0),
  ←nat.cast_mul, mul_comm, ←nat.desc_factorial_eq_factorial_mul_choose, ←cast_desc_factorial]

lemma cast_choose_two (a : ℕ) :
  (a.choose 2 : K) = a * (a - 1) / 2 :=
by rw [←cast_desc_factorial_two, desc_factorial_eq_factorial_mul_choose, factorial_two, mul_comm,
    cast_mul, cast_two, eq_div_iff_mul_eq (two_ne_zero' : (2 : K) ≠ 0)]

end nat


open Nat

/-
The code that is necessary to represent a SAT problem and the associated propositions
corresponding to its satisfiability. Also a theorem that `isSat` and `isUnsat` are
exclusive.
-/

def FinSeq (n: Nat) (α : Type) : Type := (k : Nat) → k < n → α

inductive Vector (α : Type) : Nat → Type where
  | nil : Vector α zero
  | cons{n: Nat}(head: α) (tail: Vector  α n) : Vector α  (n + 1)
  deriving Repr

infixr:66 "+:" => Vector.cons

def Vector.coords {α : Type}{n : Nat}(v: Vector α n) : FinSeq n α :=
  fun j jw =>
  match n, v, j, jw with
  | .(zero), nil, k, lt => nomatch lt
  | m + 1, cons head tail, zero, lt => head
  | m + 1, cons head tail, j + 1, w =>  tail.coords j (Nat.le_of_succ_le_succ w)

abbrev Clause(n : Nat) : Type := Vector (Option Bool) n

abbrev Valuation(n: Nat) : Type := Vector Bool n

abbrev varSat (clVal: Option Bool)(valuationVal : Bool) : Prop := clVal = some valuationVal

abbrev clauseSat {n: Nat}(clause : Clause n)(valuation: Valuation n) :=
  ∃ (k : Nat), ∃ (b : k < n), varSat (clause.coords k b) (valuation.coords k b)

def isSat{dom n: Nat}(clauses : Vector (Clause (n + 1)) dom) :=
          ∃ valuation : Valuation (n + 1),
           ∀ (p : Nat),
            ∀ pw : p < dom,
              ∃ (k : Nat), ∃ (kw : k < n + 1),
                ((clauses.coords p pw).coords k kw) = some (valuation.coords k kw)

def isUnSat{dom n: Nat}(clauses : Vector (Clause (n + 1)) dom) :=
          ∀ valuation : Valuation (n + 1),
           Not (∀ (p : Nat),
            ∀ pw : p < dom,
              ∃ (k : Nat), ∃ (kw : k < n + 1),
                ((clauses.coords p pw).coords k kw) = some (valuation.coords k kw))

theorem not_sat_and_unsat{dom n: Nat}(clauses : Vector (Clause (n + 1)) dom):
    isSat clauses → isUnSat clauses → False := by intro ⟨v, p⟩ h2 ; exact h2 v p


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.mul_add
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# `ulift` instances for groups and monoids

This file defines instances for group, monoid, semigroup and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)

We use `tactic.pi_instance_derive_field`, even though it wasn't intended for this purpose,
which seems to work fine.

We also provide `ulift.mul_equiv : ulift R ≃* R` (and its additive analogue).
-/

namespace ulift

protected instance has_one {α : Type u} [HasOne α] : HasOne (ulift α) :=
  { one := up 1 }

@[simp] theorem one_down {α : Type u} [HasOne α] : down 1 = 1 :=
  rfl

protected instance has_mul {α : Type u} [Mul α] : Mul (ulift α) :=
  { mul := fun (f g : ulift α) => up (down f * down g) }

@[simp] theorem add_down {α : Type u} {x : ulift α} {y : ulift α} [Add α] : down (x + y) = down x + down y :=
  rfl

protected instance has_sub {α : Type u} [Sub α] : Sub (ulift α) :=
  { sub := fun (f g : ulift α) => up (down f - down g) }

@[simp] theorem sub_down {α : Type u} {x : ulift α} {y : ulift α} [Sub α] : down (x - y) = down x - down y :=
  rfl

protected instance has_inv {α : Type u} [has_inv α] : has_inv (ulift α) :=
  has_inv.mk fun (f : ulift α) => up (down f⁻¹)

@[simp] theorem neg_down {α : Type u} {x : ulift α} [Neg α] : down (-x) = -down x :=
  rfl

protected instance add_semigroup {α : Type u} [add_semigroup α] : add_semigroup (ulift α) :=
  add_semigroup.mk Add.add sorry

/--
The multiplicative equivalence between `ulift α` and `α`.
-/
def mul_equiv {α : Type u} [semigroup α] : ulift α ≃* α :=
  mul_equiv.mk down up sorry sorry sorry

protected instance add_comm_semigroup {α : Type u} [add_comm_semigroup α] : add_comm_semigroup (ulift α) :=
  add_comm_semigroup.mk Add.add sorry sorry

protected instance monoid {α : Type u} [monoid α] : monoid (ulift α) :=
  monoid.mk Mul.mul sorry 1 sorry sorry

protected instance comm_monoid {α : Type u} [comm_monoid α] : comm_monoid (ulift α) :=
  comm_monoid.mk Mul.mul sorry 1 sorry sorry sorry

protected instance group {α : Type u} [group α] : group (ulift α) :=
  group.mk Mul.mul sorry 1 sorry sorry has_inv.inv Div.div sorry

protected instance comm_group {α : Type u} [comm_group α] : comm_group (ulift α) :=
  comm_group.mk Mul.mul sorry 1 sorry sorry has_inv.inv Div.div sorry sorry

protected instance left_cancel_semigroup {α : Type u} [left_cancel_semigroup α] : left_cancel_semigroup (ulift α) :=
  left_cancel_semigroup.mk Mul.mul sorry sorry

protected instance right_cancel_semigroup {α : Type u} [right_cancel_semigroup α] : right_cancel_semigroup (ulift α) :=
  right_cancel_semigroup.mk Mul.mul sorry sorry


import topology.basic

open topological_space set filter
localized "notation `𝓝` := nhds" in topological_space
localized "notation `𝓝[` s `] ` x:100 := nhds_within x s" in topological_space

noncomputable theory
open classical

variables {X : Type} [topological_space X] [nonempty X]

class t0_space (X : Type) [topological_space X] : Prop :=
(t0 : ∀ x y, x ≠ y → ∃ (U : set X), is_open U ∧ ((x ∈ U ∧ y ∉ U) ∨ (x ∉ U ∧ y ∈ U)) )

class t1_space (X : Type) [topological_space X] : Prop :=
(t1 : ∀ x y, x ≠ y → ∃ (U : set X), is_open U ∧ x ∈ U ∧ y ∉ U)

instance t1_space.t0_space [t1_space X] : t0_space X :=
begin
  -- sorry
  fconstructor,
  intros x y hxy,
  obtain ⟨U, hU, hh⟩  := t1_space.t1 x y hxy,
  use U,
  split,
  { exact hU },
  { exact or.inl hh }
  -- sorry
end

lemma t1_iff_singleton_closed : t1_space X ↔ ∀ x, is_closed ({x} : set X) :=
begin
  -- sorry
  split,
  {
    introI,
    intro x,
    rw ← is_open_compl_iff,
    have p : ⋃₀ {U : set X | (x ∉ U) ∧ (is_open U)} = {x}ᶜ,
    { apply subset.antisymm; intros t ht,
      { rcases ht with ⟨A, ⟨hxA, hA⟩, htA⟩,
        rw [mem_compl_eq, mem_singleton_iff],
        intro h,
        exact hxA (by rwa h at htA) },
      { obtain ⟨U, hU, hh⟩ := t1_space.t1 t x (mem_compl_singleton_iff.mp ht),
        use U,
        split,
        { exact ⟨hh.2, hU⟩ },
        { exact hh.1 } } },
    rw ← p,
    apply is_open_sUnion,
    intros B hB,
    exact hB.2,
  },
  {
    intro h,
    fconstructor,
    intros x y hxy,
    use {y}ᶜ,
    split,
    { exact is_open_compl_iff.mpr (h y) },
    split,
    { exact mem_compl_singleton_iff.mpr hxy },
    { exact not_not.mpr rfl }
  }
  -- sorry
end

class t2_space (X : Type) [topological_space X] : Prop :=
(t2 : ∀ x y, x ≠ y → ∃ (U V: set X) (hU : is_open U) (hV: is_open V) (hUV : U ∩ V = ∅), x ∈ U ∧ y ∈ V)

instance t2_space.t1_space [t2_space X] : t1_space X :=
begin
  -- sorry
  fconstructor,
  intros x y hxy,
  obtain ⟨U, V, hU, hV, hUV, h⟩ := t2_space.t2 x y hxy,
  use U,
  split,
  { exact hU },
  split,
  { exact h.1 },
  { intro con,
    have ht : y ∈ (∅ : set X),
    {
      rw ← hUV,
      exact ⟨con, h.2⟩
    },
    exact not_mem_empty y ht }
  -- sorry
end

variables (f : filter X) (x : X)

def filter_lim (f : filter X) (x : X) := f ≤ 𝓝 x ∧ f ≠ ⊥

def limit_unicity (X : Type) [topological_space X] [nonempty X] :=
      ∀ (x y : X) (f : filter X) (hx : filter_lim f x) (hy : filter_lim f y), x=y

lemma t2_iff_unicity : t2_space X ↔ limit_unicity X :=
begin
  -- sorry
  split,
  {
    introI,
    intros x y f hx hy,
    by_contradiction hxy,
    obtain ⟨U, V, hU, hV, hUV, hh⟩ := t2_space.t2 x y hxy,
    have hhU : U ∈ f,
    { exact le_def.1 hx.1 U (is_open.mem_nhds hU hh.left) },
    have hhV : V ∈ f,
    { exact le_def.1 hy.1 V (is_open.mem_nhds hV hh.right) },
    obtain hf := filter.inter_sets f hhU hhV,
    rw hUV at hf,
    exact hx.2 (empty_mem_iff_bot.1 hf)
  },
  {
    intro h1,
    fconstructor,
    intros x y hxy,
    by_contra,
    push_neg at h,
    have : 𝓝 x ⊓ 𝓝 y ≠ ⊥,
    { intro t,
      rw ← empty_mem_iff_bot at t,
      rw mem_inf_iff at t,
      obtain ⟨U₁, hU₁, V₁, hV₁, hUV₁⟩ := t,
      obtain ⟨U, hU, hU_op, hxU⟩ := mem_nhds_iff.1 hU₁,
      obtain ⟨V, hV, hV_op, hyV⟩ := mem_nhds_iff.1 hV₁,
      have : U ∩ V = ∅,
      { have : U ∩ V ⊆ ∅,
        { rw hUV₁,
          exact inter_subset_inter hU hV },
        exact subset_eq_empty this rfl },
      exact (h U V hU_op hV_op this hxU) hyV },
    have hx : 𝓝 x ⊓ 𝓝 y ≤ 𝓝 x,
    { apply le_def.2,
      intros T hT,
      exact mem_inf_of_left hT },
    have hy : 𝓝 x ⊓ 𝓝 y ≤ 𝓝 y,
    { apply le_def.2,
      intros T hT,
      exact mem_inf_of_right hT },
    exact hxy (h1 x y (𝓝 x ⊓ 𝓝 y) ⟨hx, this⟩ ⟨hy, this⟩),
  }
  -- sorry
end

class t2_5_space (X : Type) [topological_space X] : Prop :=
(t2_5 : ∀ x y  (h : x ≠ y), ∃ (U V: set X), is_open U ∧  is_open V ∧
                                            closure U ∩ closure V = ∅ ∧ x ∈ U ∧ y ∈ V)

instance t2_5_space.t2_space [t2_5_space X] : t2_space X :=
begin
  -- sorry
  fconstructor,
  intros x y hxy,
  obtain ⟨U, V, hU, hV, hUV, h⟩ := t2_5_space.t2_5 x y hxy,
  use U,
  use V,
  split,
  { exact hU },
  split,
  { exact hV },
  split,
  { have : U ∩ V ⊆ ∅,
    { rw ← hUV,
      exact inter_subset_inter subset_closure subset_closure },
    exact subset_eq_empty this rfl },
  { exact h }
  -- sorry
end

def regular_space (X : Type) [topological_space X] := ∀ (x : X) (F : set X) (hF : is_closed F) (hxF : x ∉ F),
  ∃ (U V : set X) (hU : is_open U) (hV : is_open V) (hUV : U ∩ V = ∅), x ∈ U ∧ F ⊆ V

class t3_space (X : Type) [topological_space X] extends t1_space X : Prop :=
(regular : regular_space X)

instance t3_space.t2_space [t3_space X] : t2_space X :=
begin
  -- sorry
  fconstructor,
  intros x y hxy,
  obtain hsingleton := (@t1_iff_singleton_closed X _ _).1 t3_space.to_t1_space,
  obtain ⟨U, V, hU, hV, hUV, h⟩ := t3_space.regular x {y} (hsingleton y) hxy,
  obtain hyV := singleton_subset_iff.mp h.2,
  exact ⟨U, V, hU, hV, hUV, h.1, hyV⟩,
  -- sorry
end

instance t2_space.t2_5_space [t3_space X] : t2_5_space X :=
begin
  -- sorry
  fconstructor,
  intros x y hxy,
  obtain ⟨U, V, hU, hV, hUV, hh⟩  := t2_space.t2 x y hxy,
  have hxcV : x ∉ closure V,
  { rw closure_eq_compl_interior_compl,
    have : U ⊆ interior Vᶜ,
    { have : U ⊆ Vᶜ,
      { exact subset_compl_iff_disjoint.mpr hUV },
      exact interior_maximal this hU },
    tauto },
  obtain ⟨A, B, hA, hB, hAB, hh2 ⟩ := t3_space.regular x (closure V) (is_closed_closure) hxcV,
  have t : closure A ∩ closure V = ∅,
  {
    have hABc : A ⊆ Bᶜ,
    { exact subset_compl_iff_disjoint.mpr hAB },
    have hBc_clos : is_closed Bᶜ,
    { exact is_closed_compl_iff.mpr hB },
    have hcA_B: closure A ⊆ Bᶜ,
    { exact closure_minimal hABc hBc_clos },
    have hB_emp : B ∩ Bᶜ = ∅,
    { exact sdiff_self },
    have : closure A ∩ closure V ⊆ ∅,
    { rw [← hB_emp, inter_comm B Bᶜ],
      exact inter_subset_inter hcA_B hh2.2 },
    exact subset_eq_empty this rfl
  },
  exact ⟨A, V, hA, hV, t, hh2.1, hh.2⟩,
  -- sorry
end

lemma inter_is_not_is_empty_intersection {X : Type} {x : X} {U V : set X}
  (hxU : x ∈ U) (hUV : U ∩ V = ∅ ) : x ∉ V := disjoint_left.1 (disjoint_iff_inter_eq_empty.2 hUV) hxU

lemma t3_iff_t0_regular : t3_space X ↔ t0_space X ∧ regular_space X :=
begin
  -- sorry
  split,
  {
    introI,
    split,
    { exact t1_space.t0_space },
    { exact t3_space.regular }
  },
  {
    intro h,
    haveI := h.1,
    exact { t1:=
    begin
      intros x y hxy,
      obtain ⟨U, hU, hh⟩ := t0_space.t0 x y hxy,
      cases hh,
      { exact ⟨U, hU, hh⟩ },
      {
        have h_not_in_com : y ∉ Uᶜ,
        { intro t,
          exact (not_mem_of_mem_compl t) hh.2 },
        obtain ⟨V, T, hV, hT, hVT, hhh⟩ := h.2 y Uᶜ (is_closed_compl_iff.mpr hU) h_not_in_com,
        use T,
        split,
        { exact hT },
        split,
        { exact hhh.2 hh.1 },
        { exact inter_is_not_is_empty_intersection hhh.1 hVT }
      }
    end, regular := h.2 },
  }
  -- sorry
end

lemma regular_iff_filter_def : regular_space X ↔ ∀{s:set X} {a}, is_closed s → a ∉ s → ∃t, is_open t ∧ s ⊆ t ∧ 𝓝[t] a = ⊥ :=
begin
  -- sorry
  split; intro h,
  {
    intros F x hF hxF,
    obtain ⟨U, V, hU, hV, hUV, hh⟩ := h x F hF hxF,
    use V,
    split,
    { exact hV },
    split,
    { exact hh.2 },
    { rw ← empty_mem_iff_bot,
      have : ∅ ∈ 𝓝 x ⊓ principal V,
      {
        rw mem_inf_iff,
        use U,
        split,
        { exact is_open.mem_nhds hU hh.1 },
        use V,
        split,
        { exact mem_principal_self V },
        { exact eq.symm hUV }
      },
      exact this }
  },
  {
    intros x F hF hxF,
    obtain ⟨U, hU, hh⟩ := h hF hxF,
    rw [← empty_mem_iff_bot] at hh,
    have hexU : ∅ ∈ 𝓝 x ⊓ principal U,
    { exact hh.2 },
    rw mem_inf_iff at hexU,
    obtain ⟨T₁, hT₁, V, hV, hTV₁⟩ := hexU,
    obtain ⟨T, hTT₁, hT⟩ := mem_nhds_iff.1 hT₁,
    use T,
    use U,
    split,
    { exact hT.1 },
    split,
    { exact hU },
    split,
    { have : T ∩ U ⊆ ∅,
      { rw hTV₁,
        exact inter_subset_inter hTT₁ (mem_principal.mp hV) },
      exact subset_eq_empty this rfl },
    { exact ⟨hT.2, hh.1⟩ }
  }
  -- sorry
end

lemma t3_iff_open_closure : t3_space X ↔ t1_space X ∧ (∀ (x : X) (U : set X) (hx : x ∈ U) (hU : is_open U),
    ∃ (V : set X) (hV : is_open V), x ∈ V ∧ closure V ⊆ U) :=
begin
  -- sorry
  split,
  {
    introsI,
    split,
    { exact t2_space.t1_space },
    {
      intros x U hx hU,
      obtain ⟨V, T, hV, hT, hVT, h⟩ := t3_space.regular x Uᶜ (is_closed_compl_iff.mpr hU) (not_not.mpr hx),
      use V,
      split,
      { exact hV },
      split,
      { exact h.1 },
      { have hclos_V_Tc : closure V ⊆ Tᶜ,
        { obtain HTc_clo := is_closed_compl_iff.mpr hT,
          exact closure_minimal (subset_compl_iff_disjoint.mpr hVT) HTc_clo },
        have hTc_U : Tᶜ ⊆ U,
        { exact compl_subset_comm.mp h.right },
        exact powerset_mono.mpr hTc_U hclos_V_Tc }
    },
  },
  {
    intro h,
    haveI := h.1,
    exact {t1 := t1_space.t1, regular :=
      begin
        intros x F hF hxF,
        obtain ⟨U, hU, hh⟩ := h.2 x Fᶜ (mem_compl hxF) (is_open_compl_iff.mpr hF),
        use U,
        use (closure U)ᶜ,
        split,
        { exact hU },
        split,
        { exact is_open_compl_iff.mpr is_closed_closure },
        split,
        { have sub_empt : U ∩ (closure U)ᶜ ⊆ ∅,
          { rw ← (closure U).inter_compl_self,
            exact (closure U)ᶜ.inter_subset_inter_left subset_closure },
          exact subset_eq_empty sub_empt rfl },
        split,
        { exact hh.1 },
        { exact subset_compl_comm.mp hh.right }
      end},
  }
  -- sorry
end

def normal_space (X : Type) [topological_space X] := ∀ (F T : set X) (hF : is_closed F) (hT : is_closed T) (hFT : F ∩ T = ∅),
        ∃ (U V : set X) (hU : is_open U) (hV : is_open V) (hUV : U ∩ V = ∅), F ⊆ U ∧ T ⊆ V

class t4_space (X : Type) [topological_space X] extends t1_space X : Prop :=
(normal : normal_space X)

instance t4_space.t3_space [t4_space X] : t3_space X :=
begin
  -- sorry
  exact {t1 := t1_space.t1, regular :=
  begin
    intros x F hF hxF,
    obtain hx := t1_iff_singleton_closed.1 t4_space.to_t1_space x,
    have : {x} ∩ F = ∅,
    { exact singleton_inter_eq_empty.2 hxF },
    obtain ⟨U, V, hU, hV, hUV, h⟩ := t4_space.normal {x} F hx hF this,
    have hhx : x ∈ U,
    { exact singleton_subset_iff.mp h.left },
    exact ⟨U, V, hU, hV, hUV, hhx, h.2⟩
  end },
  -- sorry
end

lemma t4_iff_open_closure : t4_space X ↔ t1_space X ∧ (∀ (U K : set X) (hK : is_closed K) (hU : is_open U) (hKU: K ⊆ U),
        ∃ (V : set X) (hV : is_open V), K ⊆ V ∧ closure V ⊆ U) :=
begin
  -- sorry
  split,
  {
    introI,
    split,
    { exact t4_space.to_t1_space },
    {
      intros U K hK hU hKU,
      have : K ∩ Uᶜ = ∅,
      { exact sdiff_eq_bot_iff.mpr hKU },
      obtain ⟨V, T, hV, hT, hVT, h⟩ := t4_space.normal K Uᶜ hK (is_closed_compl_iff.mpr hU) this,
      use V,
      split,
      { exact hV },
      split,
      { exact h.1 },
      { have hV_Tc : V ⊆ Tᶜ,
        { exact subset_compl_iff_disjoint.mpr hVT },
        have hT_clos : is_closed Tᶜ,
        { exact is_closed_compl_iff.mpr hT },
        obtain hVclos_T_com := closure_minimal hV_Tc hT_clos,
        obtain hTcom_U := compl_subset_comm.mp h.right,
        exact powerset_mono.mpr hTcom_U hVclos_T_com }
    },
  },
  {
    intro h,
    haveI := h.1,
    exact {t1 := t1_space.t1, normal :=
    begin
      intros F K hF hK hFK,
      have hF_Kcom : F ⊆ Kᶜ,
      { exact subset_compl_iff_disjoint.mpr hFK },
      obtain ⟨U, hU, hh⟩ := h.2 Kᶜ F hF (is_open_compl_iff.mpr hK) hF_Kcom,
      use U,
      use (closure U)ᶜ,
      split,
      { exact hU },
      split,
      { exact is_open_compl_iff.mpr is_closed_closure },
      split,
      { have : U ∩ (closure U)ᶜ ⊆ ∅,
        { rw ← (closure U).inter_compl_self,
          exact (closure U)ᶜ.inter_subset_inter_left subset_closure },
        exact subset_eq_empty this rfl },
      split,
      { exact hh.1 },
      { exact subset_compl_comm.mp hh.right }
    end}
  }
  -- sorry
end


-- ------------------
-- Demostrar que
--    s ∩ (s ∪ t) = s
-- ------------------

import data.set.basic
open set

variable {α : Type}
variables s t : set α

example : s ∩ (s ∪ t) = s :=
sorry


import tactic --hide

import game.sets.sets_level06 -- hide

variable X : Type --hide

open_locale classical -- hide

namespace xena -- hide

/-
# Chapter 1 : Sets

## Level 7 : The empty set
-/

/-

The way to handle the empty set is the following:

```
lemma mem_empty_iff (a : X) : a ∈ (∅ : set X) ↔ false
```
-/

/- Axiom : mem_empty_iff :
a ∈ (∅ : set X) ↔ false
-/

/- Hint : Stuck?
Remember that `exfalso` changes any goal to `false`. This can be
convenient if your hypotheses can prove `false`.

Another approach: if `hx : false` then `cases hx` will do a case
split into every proof of false -- but there are no proofs of
false! So there will be no cases left to do.
-/

/- Lemma
The empty set is a subset of any set $A$.
-/
theorem empty_set_subset (A : set X) : ∅ ⊆ A :=
begin
  rw subset_iff,
  intros x hx,
  exfalso,
  rw mem_empty_iff at hx,
  exact hx,

end

end xena


prelude
import Init.Data.List.Basic

@[simp] theorem map_comp_map (f : α → β) (g : β → γ) : List.map g ∘ List.map f = List.map (g ∘ f) :=
  sorry

theorem map_map (f : α → β) (g : β → γ) (xs : List α) : (xs.map f |>.map g) = xs.map (g ∘ f) :=
  sorry

theorem ex1 (f : Nat → Nat) (xs : List Nat) : (xs.map f |>.map f) = xs.map (f ∘ f) := by
  simp
  simp [map_map]
  done

theorem ex2 (f : Nat → Nat) : List.map f ∘ List.map f ∘ List.map f = List.map (f ∘ f ∘ f) := by
  simp

attribute [simp] map_map

theorem ex3 (f : Nat → Nat) (xs : List Nat) : (xs.map f |>.map f |>.map f) = xs.map (fun x => f (f (f x))) := by
  simp [Function.comp]


namespace induction

open nat

-- Exercise: 2 stars, recommended (basic_induction)
theorem mult_0_r : ∀ n, n * 0 = 0
| 0 := rfl
| (nat.succ n) := rfl

theorem plus_n_Sm : ∀ n m, succ (n + m) = n + (succ m) :=
λ n m, nat.rec_on m
  (show succ (n + 0) = n + 1, from rfl)
  (λ m' ih,
    show succ (n + succ m') = n + succ (succ m'), from rfl)

theorem plus_comm : ∀ n m : ℕ, n + m = m + n
| 0 m := by rw [add_zero, zero_add]
| (succ n) m := by rw [succ_add, add_succ, plus_comm]

theorem plus_assoc : ∀ n m p : ℕ, n + (m + p) = (n + m) + p
| 0 m p := by rw [zero_add, zero_add]
| (succ n) m p := by rw [succ_add, succ_add, succ_add, add_assoc]

-- Exercise: 2 stars (double_plus)
def double : ℕ → ℕ
| 0 := 0
| (succ n) := succ (succ (double n)).

lemma double_plus : ∀ n, double n = n + n
| 0 := rfl
| (succ n) := by rw [add_succ, succ_add, ←double_plus]; refl

-- Exercise: 2 stars, optional (evenb_S)
def evenb : ℕ → bool
| 0 := tt
| (succ 0) := ff
| (succ (succ n')) := evenb n'

theorem evenb_S : ∀ n : ℕ, evenb (succ n) = bnot (evenb n)
| 0 := rfl
| (succ n') := by simp [evenb]; rw [evenb_S, bnot_bnot]

end induction


import tactic.ring_exp
import algebra.module
import linear_algebra.basic
--infix  ` * `     := linear_map.comp
namespace Tools.module
universes u v v'

/-!
#   Goal :  explain how to deal with map between module :  for baby user !
*
*   Linear algebra is one of the first abstract theory seen at school. This tutorial try to answers to
*   the question : can i make my baby exercice using lean ?
*   Here we deal with `R-module`  and not with `k-vector space` there is nothing different
*   at the beginning.
*   This file try to explain the basic command to play with `linear_map`  `range` `kernel`.
*   We also study a special classe of linear endomorphism `Projector` i.e
*   endomorphism ` p : M →ₗ[R] M` satisfying  the relation `p * p = p`.
*   This classes is important to deal with decomposition a module into  `a direct sum`.
-/
variables {R : Type u}[comm_ring R]{M : Type v}[add_comm_group M] [module R M ](f : M →ₗ[R]M)
example (n : ℕ) (a : R)(hyp :  a * n = 1)(x : M) : a • ((n) •  x) = x := begin
    have R : n • x = (n : R) • x,
        exact semimodule.smul_eq_smul R n x,
    rw R,
    rw ← mul_smul,
    rw hyp,
    rw one_smul,
end
 open linear_map  submodule -- to write ker instead of linear_map.ker
/--
    We start with the axiom of linear_map !
-/
example (x y : M) : f ( x + y) = f x + f y := map_add f x y
/--
    For example
-/
example ( x y : M) :  f ( x + y) =  f y + f x := begin
    rw map_add f ,
    rw add_comm,        --- the addition in a module is commutative `[add_comm_group M]`
end
/--
*     The multiplication of a scalar by a vector is denoted by `•` and name `smul` !
-/
example (r  : R )(x : M) : f (r • x ) =  r • f( x) := f.map_smul r x
/--
    We give the definition of `ker f`. The standant definition is the subset
    `ker f := {x ∈ M | f x = 0}` and proof that is a submodule of `M`. In
    mathlib the definition is not this.
-/
example : ker f = comap f ⊥ := rfl
/--
    `rfl` mean that is the `mathlib definition`. We see that it's construct with a function
    `linear_map.comap` and with a notation `⊥`. We explain this.
    1. `⊥` refer to the bottom element of the set of `submodule` of `M` that mean `⊥ = {0}`
    2. `comap f ` is the inverse inmage `f⁻¹`.
    So `comap f ⊥ := f⁻¹ {0}` this is the set of element of ` x ∈ M` s.t `f x = 0`
-/
example (x : M) : x ∈ (⊥ : submodule R M)  ↔  x = 0 := mem_bot _
/--
    the classical definition of comap ` x ∈ f⁻¹ p ↔ f x ∈ p`
-/
example (x : M)(p : submodule R M) : x ∈ comap f p ↔ f x ∈ p := mem_comap
/--
    the standart for `ker f`
-/
example (x : M) : x ∈ ker f ↔ f x = 0 := begin
    unfold ker,
    rw mem_comap,
    rw mem_bot,
end
/--
*   This command is in mathlib !
-/
example (x : M ) : x ∈ ker f ↔ f x = 0 := mem_ker
variables (g : M→ₗ[R]M)
/--
*  a little exercice. I give two proof. The first use property of comap and is `ez` !
-/
lemma exercice (x : M) : x ∈ ker (g * f)  ↔  f x ∈ ker g := begin
    unfold ker,
    erw comap_comp,  --- the erw is important here to change linear map comp and  `*`
    rw mem_comap,
end
/--
* In the second, i split in detail ! The see an important fact : if you don't use the definition
    thing are harder !
-/
lemma exercice' (x : M) : x ∈ ker (g * f)  ↔  f x ∈ ker g := begin
    split, intros hyp,
    rw mem_ker at hyp,
    rw mem_ker,
    exact hyp,  -- here : important to look the tatic state ' hyp :  (g * f ) x = 0 and the goal in not the same !
                --  But by definition (g * f )x = g (f x) so it's good ,  you can  'rw mul_app at hyp,'
    intros hyp,
    rw mem_ker at hyp ⊢,   -- rewrite at hyp and at the goal !
    exact hyp,
    end
lemma Ker_zero : ker (0 : M→ₗ[R]M) = ⊤ :=
begin
    rw eq_top_iff',
        intros x,
        exact mem_ker.mpr rfl,
end
/--
* this function is yet in mathlib !
<-/
example  : ker f = ⊤ ↔ f  = 0 := ker_eq_top
/--
* Now we deal with `range f`. The definition is `map f ⊤`.
-/
example : range f = map f ⊤ := rfl
/--
    clasical definition
*  This command his in mathlib has `mem_range` -/

example : ker (0 : M→ₗ[R]M) = ⊤ := ker_zero
/--
* Another mathlib function : `ker_eq_top`
*    We `redo a proof` !
-/
lemma  ker_eq_top' : f  =  0 ↔ ker f = ⊤  :=
begin
    split,   -- separation ↔
        -- first part is the previous lemma
        {intros hyp, rw hyp, exact ker_zero},
        intros hyp,
            rw eq_top_iff' at hyp, ext, change f x  = 0, rw ← mem_ker,
            exact hyp x,
end

lemma ker_eq_top'' : (∀ x : M, f x = 0) ↔ ker f = ⊤  := begin
    split, intros,
    rw  ker_eq_top, ext, exact a  x,
    intros, rw  ker_eq_top at a, change f x = 0, rw a, exact rfl,
end
/-!
*       We see that it complicated for a triviality.
*       because we don't use realy the definition
-/
example : ker f = comap f ⊥  := rfl
example : range f  = map f ⊤ := rfl
/-!
*       We have to deal with this definition to make stuff simpler
-/
lemma ker_eq_top  : range f = ⊥  ↔  ker f = ⊤ := begin
    rw eq_top_iff,
    rw eq_bot_iff, -- unfold ker range,
    exact map_le_iff_le_comap,
end

lemma range_bot_iff {R : Type u} [ comm_ring R]{M : Type v}[add_comm_group M][module R M] (f: M →ₗ[R] M)
: (f = 0) ↔   linear_map.range f = ⊥   :=
 begin  rw eq_bot_iff, rw linear_map.range_le_bot_iff f,
 end
lemma linear_map.range_sub_ker (R : Type u) [ comm_ring R](M : Type v)[add_comm_group M][module R M] (f g : M →ₗ[R] M) :
                f * g = 0  ↔ range g ≤ ker f :=
begin
    rw range_bot_iff (f * g),
    rw linear_map.le_ker_iff_map,
    erw ← submodule.map_comp, exact iff.rfl,
end
end Tools.module

universes u v v'
variables {R : Type u}[comm_ring R]{M : Type v}[add_comm_group M] [module R M ]
open linear_map

def  is_projector (p : M →ₗ[R] M) := p * p = p

lemma is_projector_ext {p : M →ₗ[R]M} (hyp : is_projector p) : p * p = p :=
begin unfold is_projector at hyp,exact hyp, end
/--
    if `p² = p` then `(1-p)² = 1 - p - p +p² = ... = 1-p`
-/
lemma Complementary (p : M →ₗ[R]M) (hyp : is_projector p) : is_projector (id - p) := begin
    change linear_map.id - p with 1 -p,
    have R : ( 1- p) * (1 -p) = 1 - p -(p - p * p),
        exact mul_sub (1 - p) 1 p,
    unfold is_projector,
    rw R,
    rw is_projector_ext hyp,
    simp,
end
variables (p : M→ₗ[R]M)

lemma Projector_apply (x : M) :  p ∘ p =  ⇑(p * p) := rfl

lemma image_in_range (x : M) : p x ∈ range p := by apply mem_range.mpr; use x

lemma ker_eq_im_comp (hyp : is_projector p) : range p = ker (id-p) := begin
    apply submodule.ext,intros x,split,rintros ⟨y,hyp  ⟩, rw mem_ker, change x- p x = 0, rw ← hyp.2,
    change (p - p * p) y = 0, rw is_projector_ext, rw sub_self, exact rfl,assumption,
    intros hyp, rw mem_ker at hyp, change x-p x = 0 at hyp, rw mem_range, use x,
    have R : x - p x + p x = p x,
        rw hyp_1,
        rw zero_add,
    rw ← R,simp,
  end

def has_projector (P : submodule R M) :=
        ∃ p : M →ₗ[R]M, is_projector p ∧ linear_map.range (p : M→ₗ[R]M)  = P

lemma proj_ker (p : M →ₗ[R]M) (hyp : is_projector p) : ∀ m : M, p m ∈ ker (id - p) :=
begin
    rw ← ker_eq_im_comp, exact image_in_range p,assumption,
end
lemma  calcul : linear_map.id - (id - p) = p := begin exact sub_sub_self id p, end

lemma proj_im(p : M →ₗ[R]M) (hyp : is_projector p) : ∀ m : M, m - p m ∈ ker (p) :=
begin
    let H := proj_ker (id-p) (Complementary p hyp),
    -- let H := specialize (proj_ker (id - p)) (Complementary p hyp)  -- unknown identifier 'specialize'
    rw calcul at H,
    exact H,
end
lemma projector_decomp (p : M →ₗ[R]M) (hyp : is_projector p) :
    ∀ m : M,∃ m_im ∈ range p, ∃ m_ker ∈ ker p, m = m_ker+ m_im  := begin
        intros m,
        use p m,
        split, refine image_in_range _ m ,
        use m - p m,
        split,
        apply proj_im,
        assumption,simp,
     end
lemma Unicity (hyp : is_projector p) : (range p)  ⊓ (ker p)= ⊥ :=  begin
    rw eq_bot_iff,
    rw submodule.le_def', intros x, rw submodule.mem_bot, intros,
    rw submodule.mem_inf at H,
    rcases H with ⟨  IM, KER ⟩ ,
    rw mem_ker at KER, rw mem_range at IM, rcases IM with ⟨ y,hyp_y⟩ ,
    rw ← hyp_y at KER, change (p * p) y = 0 at KER, rw is_projector_ext at KER, rw hyp_y at KER,
assumption, assumption,
end
lemma projector.mem_range (x : M)(hyp : is_projector p) : x ∈ range p ↔  p x = x := begin
    split,
        intro hyp, rw mem_range at hyp, rcases hyp with ⟨y,hyp_y ⟩,
        rw ← hyp_y,
        change p( p y) with (p *p) y,
        rw (is_projector_ext hyp),
        intro hyp,
        rw ← hyp,
        apply image_in_range,
end

lemma projector_im_eq (p q : M→ₗ[R] M) (hyp_p : is_projector p) (hyp_q : is_projector q) :
            range  p =  range q ↔  ( p * q = q) ∧  (q * p = p) := begin
        split,
        intro hyp,
            split,
                {ext,rw mul_app, rw ← projector.mem_range, rw hyp,refine image_in_range q _, assumption},
                {ext, rw mul_app,rw ← projector.mem_range,rw ← hyp,refine image_in_range p _, assumption},
            intro,
            apply submodule.ext,
            intro x, split,
                {intro,rw ←  a.2 at a_1,rw mem_range at *,rcases a_1,use p a_1_w, exact a_1_h,},
                {intro,rw ←  a.1 at a_1,rw mem_range at *,rcases a_1,use q a_1_w, exact a_1_h,},
end

theorem projector.caract_image (p : M→ₗ[R]M) : (∀ x : range p, p x = x ) → is_projector p := begin
    intro hyp, unfold is_projector,
    ext,rw mul_app,
    exact hyp ⟨p x,image_in_range p x ⟩,
end
lemma range_le_submodule (p : M→ₗ[R]M) (W : submodule R M) : range p ≤ W ↔  ∀ x : M,  p x ∈ W := begin
    split, intros hyp, intro x, let R := image_in_range p x,
    rw submodule.le_def' at hyp,
    exact hyp (p x) R,
    intro,
    rw submodule.le_def', intro x, intro hyp_range, rw mem_range at hyp_range, rcases hyp_range,
    rw ← hyp_range_h, exact a hyp_range_w,
end
theorem projector.caract_image' (p : M→ₗ[R]M) (W : submodule R M) : (range p ≤ W ∧ ∀ w ∈ W, p w = w) → (is_projector p
∧ range p = W) :=
begin
    intros hyp,
    split,
        apply projector.caract_image,
        intro y,
        apply hyp.2 y,
        rw submodule.le_def' at hyp,
        apply hyp.1 y,
        exact y.property,
        apply le_antisymm ,
            exact hyp.1,
            rintros w,
            intro hyp_w,
            change w ∈ range p,
            change w ∈ W at hyp_w,
            rw mem_range,
            use w,
            rw hyp.2,assumption,
end
lemma projector.right_mul (p f : M →ₗ[R] M) [is_projector p] :
    p * f = f  ↔ ∀ x : M, (x ∈ range f →  p x = x) := begin
    split, intro hyp, intro x, rw mem_range, rintros ⟨a,b⟩,
    rw ← b, change (p * f) a = f a,
    rw hyp,
    intro hyp,
    ext, exact hyp _  (image_in_range f x),
end

variables (g : M ≃ₗ[R]M)
example (N : submodule R M) : N ≤ ⊤ := le_top
example  (N N' : submodule R M) : (N ≤ N') → (N' ≤ N) → N = N'  := le_antisymm

open submodule
lemma submodule.le_inf (W N N' : submodule R M) : W ≤ N ⊓ N' ↔  (W ≤ N ∧ W ≤ N') := le_inf_iff
lemma test' (p f : M →ₗ[R] M) : map f (ker (p * f)) = range f ⊓ ker p := begin
    apply le_antisymm,
        rw le_inf_iff,
            split,
                {apply map_mono , exact le_top},
                {rw linear_map.le_ker_iff_map,
                erw ← map_comp,
                rw ← linear_map.le_ker_iff_map,
                exact le_refl _},
            intros x, intros hyp, rcases hyp, erw mem_map,
            change x ∈ range f at hyp_left,
            rw mem_range at hyp_left, rcases hyp_left with ⟨y, hyp_y⟩ ,use y, split, swap, assumption,
            rw mem_ker, change  x ∈ ker p at hyp_right, change  p( f y) = 0, rw hyp_y, exact mem_ker.mp hyp_right,
end
lemma test'' (p f : M →ₗ[R] M) : map f (ker (p * f)) = range f ⊓ ker p := begin
    apply le_antisymm,
         rw le_inf_iff,
            split,  apply map_le_range,
                rw map_le_iff_le_comap,
                {   erw comap_comp, refine le_refl _,},
                rw le_def',
                intros x, intros hyp, rcases hyp, rw mem_map,
                erw mem_range at hyp_left, rcases hyp_left with ⟨y, hyp_y⟩ ,use y, split, swap, assumption,
                rw mem_ker, change  x ∈ ker p at hyp_right, change  p( f y) = 0, rw hyp_y, exact mem_ker.mp hyp_right,
end

open finset

lemma sum.range (X :Type v')[fintype X](φ : X → (M →ₗ[R] M))(W : submodule R M) :
    (∀ x : X, range (φ x) ≤ W)  → linear_map.range (finset.sum finset.univ φ ) ≤ W :=
begin
    intros hyp,
    rw le_def',
    intros m,
    intros, rw linear_map.mem_range at H,
    rcases H with ⟨y,hyp_y ⟩,
    rw ← hyp_y,
    rw linear_map.sum_apply,
    apply sum_mem,
    intros c,  intros,
    let hyp := hyp c, rw le_def' at hyp,
    apply hyp, exact image_in_range (φ c) y,
end

lemma range_smulll (a : R)(b : R) (hyp : a * b = 1)  : range (a • p) = range p := begin
    apply le_antisymm,
    rw le_def',
    intros x, intros hyp, rw linear_map.mem_range at *, rcases hyp with ⟨ y, hyp_y ⟩,
    use  a • y,
    rw linear_map.map_smul,  exact hyp_y,
    rw le_def',
     intros x, intros hyp, rw linear_map.mem_range at *, rcases hyp with ⟨y, hyp_y  ⟩,
     use b • y,
     rw linear_map.map_smul, erw ← mul_smul, rw mul_comm, rw hyp, rw one_smul, assumption,
end
lemma sum_proj (X  : Type v')[fintype X](W  : submodule R M)(a : R)
(inve : a * (((fintype.card X) : ℤ)  : R) = 1) (φ : X → (M →ₗ[R]M)) (hyp : ∀ x : X, is_projector (φ x))
(hyp_2 : ∀ x : X, range (φ x) = W) :
  is_projector ( a • (finset.sum finset.univ φ)) ∧ range ( a • (finset.sum finset.univ φ)) = W   :=
begin
    apply projector.caract_image',
    split,
    rw range_smulll,
    swap, use inve,
    apply sum.range,
    intros x,
    rw hyp_2 x,
    rw le_def,
    intros x, intros hyp',
    change a • _ =x,
    rw linear_map.sum_apply,
    have R' : (λ d, φ d x) = (λ d, x),
        funext,
        rw ← projector.mem_range (φ d) x (hyp d),
        rw hyp_2 d,
        assumption,
    rw R',
    rw sum_const,
    change a • (( fintype.card X) • x) = x,
    rw   semimodule.smul_eq_smul R,
    rw ← mul_smul,
    erw inve, rw one_smul,
end

/--
 from : http://desaintar.free.fr/exos/exos_ev.pdf
-/
lemma exercice_25 : ker (p ) ≤ ker (p * p) := begin
    unfold ker at *,
    change  _ ≤  comap (linear_map.comp p p) _  ,
    rw comap_comp,
    apply comap_mono,
    exact bot_le,
end
lemma exercice_25_2 : range (p * p) ≤ range p :=
begin
    unfold linear_map.range at  *,
    erw map_comp,
    apply map_mono,
    exact le_top,
end
lemma exercice_26' : ker (p *p) = ker p ↔ range p ⊓ ker (p) = ⊥ := begin
           rw ←  map_comap_eq,rw eq_bot_iff,
           rw map_le_iff_le_comap, unfold ker,
           rw ← comap_comp,
           split,
           intros, rw ← a, exact le_refl _,
           intros, apply le_antisymm, exact a,
           erw comap_comp, apply comap_mono, exact bot_le,
end

lemma exercice_33 (p q : M →ₗ[R]M)(hyp_p : is_projector p)(hyp_q : is_projector q) (comm : p * q = q * p) :
    is_projector (p*q) :=
begin
    unfold is_projector at  *,
    rw mul_assoc, rw comm, rw ← mul_assoc q q p, rw hyp_q, rw ← comm, rw ← mul_assoc, rw hyp_p,
end