import pq_like
import pq_induction_principles

universes u1 u2

section pq_like_asymmetric

variables {Q1 : Type u1} [power_quandle Q1] {Q2 : Type u2} [power_quandle Q2]

def pq_like_homo (f : pq_group Q1 → pq_group Q2) (hf : is_pq_morphism f) : pq_group Q1 →* pq_group Q2 :=
begin
  fapply pq_morph_to_L_morph_adj,
  {
    exact f ∘ of,
  },
  {
    exact pq_morphism_comp of f of_is_pq_morphism hf,
  },
end

theorem pq_like_homo_surjective (f : pq_group Q1 ≃ pq_group Q2) (hf : is_pq_morphism f) (hf1 : ∀ x : Q2, ∃ z : Q1, f.symm (of x) = of z) : function.surjective (pq_like_homo f hf) :=
begin
  refine pq_group_word_induction _ _,
  {
    use 1,
    simp only [monoid_hom.map_one],
  },
  {
    intros x y hx,
    cases hx with z hz,
    use (f.symm (of y)) * z,
    simp only [monoid_hom.map_mul, hz],
    specialize hf1 y,
    cases hf1 with a ha,
    rw ha,
    unfold pq_like_homo,
    rw pq_morph_to_L_morph_adj_comm_of,
    simp only [function.comp_app, mul_left_inj],
    rw ←ha,
    simp only [equiv.apply_symm_apply],
  },
end

end pq_like_asymmetric


/-
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.topology.sheaves.sheaf
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.category.pairwise
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Equivalent formulations of the sheaf condition

We give an equivalent formulation of the sheaf condition.

Given any indexed type `ι`, we define `overlap ι`,
a category with objects corresponding to
* individual open sets, `single i`, and
* intersections of pairs of open sets, `pair i j`,
with morphisms from `pair i j` to both `single i` and `single j`.

Any open cover `U : ι → opens X` provides a functor `diagram U : overlap ι ⥤ (opens X)ᵒᵖ`.

There is a canonical cone over this functor, `cone U`, whose cone point is `supr U`,
and in fact this is a limit cone.

A presheaf `F : presheaf C X` is a sheaf precisely if it preserves this limit.
We express this in two equivalent ways, as
* `is_limit (F.map_cone (cone U))`, or
* `preserves_limit (diagram U) F`
-/

namespace Top.presheaf

/--
An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`sheaf_condition_equiv_sheaf_condition_pairwise_intersections`).

A presheaf is a sheaf if `F` sends the cone `(pairwise.cocone U).op` to a limit cone.
(Recall `pairwise.cocone U`, has cone point `supr U`, mapping down to the `U i` and the `U i ⊓ U j`.)
-/
def sheaf_condition_pairwise_intersections {X : Top} {C : Type u} [category_theory.category C]
    (F : presheaf C X) :=
  {ι : Type v} →
    (U : ι → topological_space.opens ↥X) →
      category_theory.limits.is_limit
        (category_theory.functor.map_cone F
          (category_theory.limits.cocone.op (category_theory.pairwise.cocone U)))

/--
An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`sheaf_condition_equiv_sheaf_condition_preserves_limit_pairwise_intersections`).

A presheaf is a sheaf if `F` preserves the limit of `pairwise.diagram U`.
(Recall `pairwise.diagram U` is the diagram consisting of the pairwise intersections
`U i ⊓ U j` mapping into the open sets `U i`. This diagram has limit `supr U`.)
-/
def sheaf_condition_preserves_limit_pairwise_intersections {X : Top} {C : Type u}
    [category_theory.category C] (F : presheaf C X) :=
  {ι : Type v} →
    (U : ι → topological_space.opens ↥X) →
      category_theory.limits.preserves_limit
        (category_theory.functor.op (category_theory.pairwise.diagram U)) F

/-!
The remainder of this file shows that these conditions are equivalent
to the usual sheaf condition.
-/

namespace sheaf_condition_pairwise_intersections

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
def cone_equiv_functor_obj {X : Top} {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v}
    (U : ι → topological_space.opens ↥X)
    (c :
      category_theory.limits.cone
        (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) :
    category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U) :=
  category_theory.limits.cone.mk (category_theory.limits.cone.X c)
    (category_theory.nat_trans.mk
      fun (Z : category_theory.limits.walking_parallel_pair) =>
        category_theory.limits.walking_parallel_pair.cases_on Z
          (category_theory.limits.pi.lift
            fun (i : ι) =>
              category_theory.nat_trans.app (category_theory.limits.cone.π c)
                (opposite.op (category_theory.pairwise.single i)))
          (category_theory.limits.pi.lift
            fun (b : ι × ι) =>
              category_theory.nat_trans.app (category_theory.limits.cone.π c)
                (opposite.op (category_theory.pairwise.pair (prod.fst b) (prod.snd b)))))

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
def cone_equiv_functor {X : Top} {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v}
    (U : ι → topological_space.opens ↥X) :
    category_theory.limits.cone
          (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F) ⥤
        category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U) :=
  category_theory.functor.mk
    (fun
      (c :
      category_theory.limits.cone
        (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) =>
      cone_equiv_functor_obj F U c)
    fun
      (c c' :
      category_theory.limits.cone
        (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F))
      (f : c ⟶ c') =>
      category_theory.limits.cone_morphism.mk (category_theory.limits.cone_morphism.hom f)

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_inverse_obj_π_app {X : Top} {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v}
    (U : ι → topological_space.opens ↥X)
    (c : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U))
    (x : category_theory.pairwise ιᵒᵖ) :
    category_theory.nat_trans.app (category_theory.limits.cone.π (cone_equiv_inverse_obj F U c)) x =
        opposite.op_induction
          (fun (x : category_theory.pairwise ι) =>
            category_theory.pairwise.cases_on x
              (fun (i : ι) =>
                category_theory.nat_trans.app (category_theory.limits.cone.π c)
                    category_theory.limits.walking_parallel_pair.zero ≫
                  category_theory.limits.pi.π
                    (fun (i : ι) => category_theory.functor.obj F (opposite.op (U i))) i)
              fun (i j : ι) =>
                category_theory.nat_trans.app (category_theory.limits.cone.π c)
                    category_theory.limits.walking_parallel_pair.one ≫
                  category_theory.limits.pi.π
                    (fun (p : ι × ι) =>
                      category_theory.functor.obj F (opposite.op (U (prod.fst p) ⊓ U (prod.snd p))))
                    (i, j))
          x :=
  Eq.refl
    (category_theory.nat_trans.app (category_theory.limits.cone.π (cone_equiv_inverse_obj F U c)) x)

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_inverse_map_hom {X : Top} {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v}
    (U : ι → topological_space.opens ↥X)
    (c : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U))
    (c' : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U))
    (f : c ⟶ c') :
    category_theory.limits.cone_morphism.hom
          (category_theory.functor.map (cone_equiv_inverse F U) f) =
        category_theory.limits.cone_morphism.hom f :=
  Eq.refl
    (category_theory.limits.cone_morphism.hom
      (category_theory.functor.map (cone_equiv_inverse F U) f))

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
def cone_equiv_unit_iso_app {X : Top} {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v}
    (U : ι → topological_space.opens ↥X)
    (c :
      category_theory.limits.cone
        (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) :
    category_theory.functor.obj 𝟭 c ≅
        category_theory.functor.obj (cone_equiv_functor F U ⋙ cone_equiv_inverse F U) c :=
  category_theory.iso.mk (category_theory.limits.cone_morphism.mk 𝟙)
    (category_theory.limits.cone_morphism.mk 𝟙)

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_unit_iso_hom_app_hom {X : Top} {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v}
    (U : ι → topological_space.opens ↥X) :
    ∀
        (X_1 :
          category_theory.limits.cone
            (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)),
        category_theory.limits.cone_morphism.hom
            (category_theory.nat_trans.app (category_theory.iso.hom (cone_equiv_unit_iso F U))
              X_1) =
          𝟙 :=
  fun
    (X_1 :
    category_theory.limits.cone
      (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) =>
    Eq.refl 𝟙

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_counit_iso_hom_app_hom {X : Top} {C : Type u}
    [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X)
    {ι : Type v} (U : ι → topological_space.opens ↥X) :
    ∀ (X_1 : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U)),
        category_theory.limits.cone_morphism.hom
            (category_theory.nat_trans.app (category_theory.iso.hom (cone_equiv_counit_iso F U))
              X_1) =
          𝟙 :=
  fun (X_1 : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U)) =>
    Eq.refl 𝟙

/--
Cones over `diagram U ⋙ F` are the same as a cones over the usual sheaf condition equalizer diagram.
-/
@[simp] theorem cone_equiv_functor_2 {X : Top} {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v}
    (U : ι → topological_space.opens ↥X) :
    category_theory.equivalence.functor (cone_equiv F U) = cone_equiv_functor F U :=
  Eq.refl (category_theory.equivalence.functor (cone_equiv F U))

/--
If `sheaf_condition_equalizer_products.fork` is an equalizer,
then `F.map_cone (cone U)` is a limit cone.
-/
def is_limit_map_cone_of_is_limit_sheaf_condition_fork {X : Top} {C : Type u}
    [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X)
    {ι : Type v} (U : ι → topological_space.opens ↥X)
    (P : category_theory.limits.is_limit (sheaf_condition_equalizer_products.fork F U)) :
    category_theory.limits.is_limit
        (category_theory.functor.map_cone F
          (category_theory.limits.cocone.op (category_theory.pairwise.cocone U))) :=
  category_theory.limits.is_limit.of_iso_limit
    (coe_fn
      (equiv.symm
        (category_theory.limits.is_limit.of_cone_equiv
          (category_theory.equivalence.symm (cone_equiv F U))))
      P)
    (category_theory.iso.mk (category_theory.limits.cone_morphism.mk 𝟙)
      (category_theory.limits.cone_morphism.mk 𝟙))

/--
If `F.map_cone (cone U)` is a limit cone,
then `sheaf_condition_equalizer_products.fork` is an equalizer.
-/
def is_limit_sheaf_condition_fork_of_is_limit_map_cone {X : Top} {C : Type u}
    [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X)
    {ι : Type v} (U : ι → topological_space.opens ↥X)
    (Q :
      category_theory.limits.is_limit
        (category_theory.functor.map_cone F
          (category_theory.limits.cocone.op (category_theory.pairwise.cocone U)))) :
    category_theory.limits.is_limit (sheaf_condition_equalizer_products.fork F U) :=
  category_theory.limits.is_limit.of_iso_limit
    (coe_fn (equiv.symm (category_theory.limits.is_limit.of_cone_equiv (cone_equiv F U))) Q)
    (category_theory.iso.mk (category_theory.limits.cone_morphism.mk 𝟙)
      (category_theory.limits.cone_morphism.mk 𝟙))

end sheaf_condition_pairwise_intersections

/--
The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of a limit diagram over `U i` and `U i ⊓ U j`.
-/
def sheaf_condition_equiv_sheaf_condition_pairwise_intersections {X : Top} {C : Type u}
    [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) :
    sheaf_condition F ≃ sheaf_condition_pairwise_intersections F :=
  equiv.Pi_congr_right
    fun (i : Type v) =>
      equiv.Pi_congr_right
        fun (U : i → topological_space.opens ↥X) =>
          equiv_of_subsingleton_of_subsingleton
            (sheaf_condition_pairwise_intersections.is_limit_map_cone_of_is_limit_sheaf_condition_fork
              F U)
            (sheaf_condition_pairwise_intersections.is_limit_sheaf_condition_fork_of_is_limit_map_cone
              F U)

/--
The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of the presheaf preserving the limit of the diagram
consisting of the `U i` and `U i ⊓ U j`.
-/
def sheaf_condition_equiv_sheaf_condition_preserves_limit_pairwise_intersections {X : Top}
    {C : Type u} [category_theory.category C] [category_theory.limits.has_products C]
    (F : presheaf C X) :
    sheaf_condition F ≃ sheaf_condition_preserves_limit_pairwise_intersections F :=
  sorry

end Mathlib


import Mathlib.Algebra.Field.Basic
import UnitConjecture.TorsionFree
import UnitConjecture.GroupRing

/-!

## Giles Gardam's result

The proof of the theorem `𝔽₂[P]` has non-trivial units. Together with the main result of `TorsionFree` -- that `P` is torsion-free,
this completes the formal proof of Gardam's theorem that Kaplansky's Unit Conjecture is false.
-/

section Preliminaries

/-! ### Preliminaries -/

/-- The definition of an element of a free module being trivial but not zero, i.e., of the form `k•x` for `x : X` and `k ≠ 0`. -/
def trivialNonZeroElem {R X : Type _} [Ring R] [DecidableEq X] (a : FreeModule R X) : Prop :=
  ∃! x : X, FreeModule.coordinates x a ≠ 0

/-- The statement of Kaplansky's Unit Conjecture:
The only units in a group ring, when the group is torsion-free and the ring is a field, are the trivial units. -/
def UnitConjecture : Prop :=
  ∀ {F : Type _} [Field F] [DecidableEq F]
  {G : Type _} [Group G] [DecidableEq G] [TorsionFree G],
    ∀ u : (F[G])ˣ, trivialNonZeroElem (u : F[G])

/-- The finite field on two elements. -/
abbrev 𝔽₂ := Fin 2

instance : Field 𝔽₂ where
  inv := id
  exists_pair_ne := ⟨0, 1, by decide⟩
  mul_inv_cancel := fun
        | 0, h => by contradiction
        | 1, _ => rfl
  inv_zero := rfl
  div_eq_mul_inv := by decide

instance ringElem : Coe P (𝔽₂[P]) where
    coe g := ⟦[(1, g)]⟧

end Preliminaries

section Constants

namespace P

/-!
The main constants of the group `P`.
-/

abbrev x : P := (K.x, Q.e)
abbrev y : P := (K.y, Q.e)
abbrev z : P := (K.z, Q.e)
abbrev a : P := ((0, 0, 0), Q.a)
abbrev b : P := ((0, 0, 0), Q.b)

end P

namespace Gardam

open P

/-! The components of the non-trivial unit `α`. -/
def p : 𝔽₂[P] := (1 : 𝔽₂[P]) +  x +  y +  x*y +  z⁻¹ + x*z⁻¹ + y*z⁻¹ + x*y*z⁻¹
def q : 𝔽₂[P] := (x⁻¹*y⁻¹ : 𝔽₂[P]) + x + y⁻¹*z + z
def r : 𝔽₂[P] := (1 : 𝔽₂[P]) + x + y⁻¹*z + x*y*z
def s : 𝔽₂[P] := (1 : 𝔽₂[P]) + x*z⁻¹ + x⁻¹*z⁻¹ + y*z⁻¹ + y⁻¹*z⁻¹

/-- The non-trivial unit `α`. -/
def α : 𝔽₂[P] := p  +  q * a  +  r * b  +  s * a * b

/-! The components of the inverse `α'` of the non-trivial unit `α`. -/
def p' : 𝔽₂[P] := x⁻¹ * (a⁻¹  * p * a)
def q' : 𝔽₂[P] := -(x⁻¹ * q)
def r' : 𝔽₂[P] := -(y⁻¹ * r)
def s' : 𝔽₂[P] := z⁻¹ * (a⁻¹ * s * a)

/-- The inverse `α'` of the non-trivial unit `α`. -/
def α' : 𝔽₂[P] := p'  +  q' * a  +  r' * b  +  s' * a * b

end Gardam

end Constants

section Verification

/-!
### Verification

The main verification of Giles Gardam's result.
-/

namespace Gardam

open P

/-- A proof that the unit is non-trivial. -/
theorem α_nonTrivial : ¬ (trivialNonZeroElem α) := by
    intro ⟨g, _, (eqg : ∀ y, α.coordinates y ≠ 0 → y = g)⟩
    have : z⁻¹ = g := by
      apply eqg; native_decide
    have : x * y = g := by
      apply eqg; native_decide
    have : z⁻¹ = x * y := by
      refine' Eq.trans _ (Eq.symm _) <;> assumption
    simp at this

/-! The fact that the counter-example `α` is in fact a unit of the group ring `𝔽₂[P]` is verified by
  computing the product of `α` with its inverse `α'` and checking that the result is `(1 : 𝔽₂[P])`.

  The computational aspects of the group ring implementation and the Metabelian construction are used here. -/

/-- A proof of the existence of a non-trivial unit in `𝔽₂[P]`. -/
def Counterexample : {u : (𝔽₂[P])ˣ // ¬(trivialNonZeroElem u.val)} :=
  ⟨⟨α, α', by native_decide, by native_decide⟩, α_nonTrivial⟩

/-- Giles Gardam's result - Kaplansky's Unit Conjecture is false. -/
theorem GardamTheorem : ¬ UnitConjecture :=
   fun conjecture => Counterexample.prop <|
    conjecture (F := 𝔽₂) (G := P) Counterexample.val

end Gardam

end Verification

/-!
We check that our definition of "trivial but not zero" is correct by showing it equivalent to a more direct definition.
-/

theorem trivialNonZeroElem_trivial_nonzeroAux {R G : Type _} [Ring R] [Group G] [DecidableEq G] (p : FormalSum R G) :
    trivialNonZeroElem  ⟦p⟧  ↔  ∃ a: R, ∃ g : G, p ≈ [(a, g)] ∧ (a ≠ 0) := by
  apply Iff.intro
  · rw [trivialNonZeroElem]
    intro ⟨x, hyp⟩
    let ⟨hyp₁, hyp₂⟩ := hyp
    use FreeModule.coordinates x ⟦p⟧
    use x
    apply And.intro
    · funext x₁
      simp only [FormalSum.coords, monomCoeff, FreeModule.coordinates, Quotient.lift_mk, add_zero]
      by_cases x = x₁
      · simp [h]
      · let hyp₃ := hyp₂ x₁
        simp only [h, FreeModule.coordinates, Quot.lift_mk, ne_eq] at hyp₃
        let neqLem : ((x == x₁) = false) :=
          by apply beq_false_of_ne; assumption
        simp only [neqLem]
        by_cases FormalSum.coords p x₁ = 0
        · assumption
        · simp only [Quotient.lift_mk, h, not_false_iff, forall_true_left] at hyp₃
          have := Eq.symm hyp₃
          contradiction
    · assumption
  · intro ⟨a, g, hyp⟩
    simp only [trivialNonZeroElem, ne_eq]
    use g
    apply And.intro
    · intro h
      simp only [FreeModule.coordinates, Quotient.lift_mk] at h
      have : p.coords = FormalSum.coords [(a, g)] := hyp.left
      rw [this] at h
      simp only [FormalSum.coords, monomCoeff, beq_self_eq_true, add_zero] at h
      have := hyp.right
      contradiction
    · intro x h
      simp only [FreeModule.coordinates, Quotient.lift_mk] at h
      have : p.coords = FormalSum.coords [(a, g)] := hyp.left
      rw [this] at h
      simp only [FormalSum.coords, monomCoeff, add_zero] at h
      by_cases c:x = g
      · assumption
      · have neq : (g == x) = false := by aesop
        simp only [neq, not_true] at h

/-- Our definition of tiviality of `p : R[G]` coincides with the direct definition `p = a ⬝ g` with `a ≠ 0` -/
theorem trivialNonZeroElem_trivial_nonzero {R G : Type _} [Ring R] [Group G] [DecidableEq G]: ∀  (p : FreeModule R G),
    trivialNonZeroElem  p  ↔  ∃ a: R, ∃ g : G, p = (a * g) ∧ (a ≠ 0) := by
  rw [groupRingMul]
  apply Quotient.ind
  simp only [trivialNonZeroElem_trivial_nonzeroAux, ne_eq, exists_and_right, Quotient.eq, forall_const]


mutual

  inductive Arg (α : Type u) where
    | val  (a : α)
    | expr (e : Expr α)

  inductive Expr (α : Type u) where
    | app (f : String) (a : List (Arg α))

end

theorem aux_1 [SizeOf α] (a : List (Arg α)) : Arg._sizeOf_3 a = sizeOf a := by
  induction a with
  | nil => rfl
  | cons h t ih =>
    show 1 + Arg._sizeOf_1 h + Arg._sizeOf_3 t = sizeOf (h :: t)
    rw ih
    rfl


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Adam Topaz
-/
import category_theory.limits.shapes.terminal
import category_theory.punit
import category_theory.structured_arrow

/-!

# Kan extensions

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

This file defines the right and left Kan extensions of a functor.
They exist under the assumption that the target category has enough limits
resp. colimits.

The main definitions are `Ran ι` and `Lan ι`, where `ι : S ⥤ L` is a functor.
Namely, `Ran ι` is the right Kan extension, while `Lan ι` is the left Kan extension,
both as functors `(S ⥤ D) ⥤ (L ⥤ D)`.

To access the right resp. left adjunction associated to these, use `Ran.adjunction`
resp. `Lan.adjunction`.

# Projects

A lot of boilerplate could be generalized by defining and working with pseudofunctors.

-/

noncomputable theory

namespace category_theory

open limits

universes v v₁ v₂ v₃ u₁ u₂ u₃

variables {S : Type u₁} {L : Type u₂} {D : Type u₃}
variables [category.{v₁} S] [category.{v₂} L] [category.{v₃} D]
variables (ι : S ⥤ L)

namespace Ran

local attribute [simp] structured_arrow.proj

/-- The diagram indexed by `Ran.index ι x` used to define `Ran`. -/
abbreviation diagram (F : S ⥤ D) (x : L) : structured_arrow x ι ⥤ D :=
  structured_arrow.proj x ι ⋙ F

variable {ι}

/-- A cone over `Ran.diagram ι F x` used to define `Ran`. -/
@[simp]
def cone {F : S ⥤ D} {G : L ⥤ D} (x : L) (f : ι ⋙ G ⟶ F) :
  cone (diagram ι F x) :=
{ X := G.obj x,
  π :=
  { app := λ i, G.map i.hom ≫ f.app i.right,
    naturality' := begin
      rintro ⟨⟨il⟩, ir, i⟩ ⟨⟨jl⟩, jr, j⟩ ⟨⟨⟨fl⟩⟩, fr, ff⟩,
      dsimp at *,
      simp only [category.id_comp, category.assoc] at *,
      rw [ff],
      have := f.naturality,
      tidy,
    end } }

variable (ι)

/-- An auxiliary definition used to define `Ran`. -/
@[simps]
def loc (F : S ⥤ D) [∀ x, has_limit (diagram ι F x)] : L ⥤ D :=
{ obj := λ x, limit (diagram ι F x),
  map := λ x y f, limit.pre (diagram _ _ _) (structured_arrow.map f : structured_arrow _ ι ⥤ _),
  map_id' := begin
    intro l,
    ext j,
    simp only [category.id_comp, limit.pre_π],
    congr' 1,
    simp,
  end,
  map_comp' := begin
    intros x y z f g,
    ext j,
    erw [limit.pre_pre, limit.pre_π, limit.pre_π],
    congr' 1,
    tidy,
  end }

/-- An auxiliary definition used to define `Ran` and `Ran.adjunction`. -/
@[simps]
def equiv (F : S ⥤ D) [∀ x, has_limit (diagram ι F x)] (G : L ⥤ D) :
  (G ⟶ loc ι F) ≃ (((whiskering_left _ _ _).obj ι).obj G ⟶ F) :=
{ to_fun := λ f,
  { app := λ x, f.app _ ≫ limit.π (diagram ι F (ι.obj x)) (structured_arrow.mk (𝟙 _)),
  naturality' := begin
    intros x y ff,
    dsimp only [whiskering_left],
    simp only [functor.comp_map, nat_trans.naturality_assoc, loc_map, category.assoc],
    congr' 1,
    erw limit.pre_π,
    change _ = _ ≫ (diagram ι F (ι.obj x)).map (structured_arrow.hom_mk _ _),
    rw limit.w,
    tidy,
  end },
  inv_fun := λ f,
  { app := λ x, limit.lift (diagram ι F x) (cone _ f),
    naturality' := begin
      intros x y ff,
      ext j,
      erw [limit.lift_pre, limit.lift_π, category.assoc, limit.lift_π (cone _ f) j],
      tidy,
    end },
  left_inv := begin
    intro x,
    ext k j,
    dsimp only [cone],
    rw limit.lift_π,
    simp only [nat_trans.naturality_assoc, loc_map],
    erw limit.pre_π,
    congr,
    rcases j with ⟨⟨⟩, _, _⟩,
    tidy,
  end,
  right_inv := by tidy }

end Ran

/-- The right Kan extension of a functor. -/
@[simps]
def Ran [∀ X, has_limits_of_shape (structured_arrow X ι) D] : (S ⥤ D) ⥤ L ⥤ D :=
adjunction.right_adjoint_of_equiv (λ F G, (Ran.equiv ι G F).symm) (by tidy)

namespace Ran

variable (D)

/-- The adjunction associated to `Ran`. -/
def adjunction [∀ X, has_limits_of_shape (structured_arrow X ι) D] :
  (whiskering_left _ _ D).obj ι ⊣ Ran ι :=
adjunction.adjunction_of_equiv_right _ _

lemma reflective [full ι] [faithful ι] [∀ X, has_limits_of_shape (structured_arrow X ι) D] :
  is_iso (adjunction D ι).counit :=
begin
  apply nat_iso.is_iso_of_is_iso_app _,
  intros F,
  apply nat_iso.is_iso_of_is_iso_app _,
  intros X,
  dsimp [adjunction],
  simp only [category.id_comp],
  exact is_iso.of_iso ((limit.is_limit _).cone_point_unique_up_to_iso
    (limit_of_diagram_initial structured_arrow.mk_id_initial _)),
end

end Ran

namespace Lan

local attribute [simp] costructured_arrow.proj

/-- The diagram indexed by `Ran.index ι x` used to define `Ran`. -/
abbreviation diagram (F : S ⥤ D) (x : L) : costructured_arrow ι x ⥤ D :=
  costructured_arrow.proj ι x ⋙ F
variable {ι}

/-- A cocone over `Lan.diagram ι F x` used to define `Lan`. -/
@[simp]
def cocone {F : S ⥤ D} {G : L ⥤ D} (x : L) (f : F ⟶ ι ⋙ G) :
  cocone (diagram ι F x) :=
{ X := G.obj x,
  ι :=
  { app := λ i, f.app i.left ≫ G.map i.hom,
    naturality' := begin
      rintro ⟨ir, ⟨il⟩, i⟩ ⟨jl, ⟨jr⟩, j⟩ ⟨fl, ⟨⟨fl⟩⟩, ff⟩,
      dsimp at *,
      simp only [functor.comp_map, category.comp_id, nat_trans.naturality_assoc],
      rw [← G.map_comp, ff],
      tidy,
    end } }

variable (ι)

/-- An auxiliary definition used to define `Lan`. -/
@[simps]
def loc (F : S ⥤ D) [I : ∀ x, has_colimit (diagram ι F x)] : L ⥤ D :=
{ obj := λ x, colimit (diagram ι F x),
  map := λ x y f,
    colimit.pre (diagram _ _ _) (costructured_arrow.map f : costructured_arrow ι _ ⥤ _),
  map_id' := begin
    intro l,
    ext j,
    erw [colimit.ι_pre, category.comp_id],
    congr' 1,
    simp,
  end,
  map_comp' := begin
    intros x y z f g,
    ext j,
    let ff : costructured_arrow ι _ ⥤ _ := costructured_arrow.map f,
    let gg : costructured_arrow ι _ ⥤ _ := costructured_arrow.map g,
    let dd := diagram ι F z,
    -- I don't know why lean can't deduce the following three instances...
    haveI : has_colimit (ff ⋙ gg ⋙ dd) := I _,
    haveI : has_colimit ((ff ⋙ gg) ⋙ dd) := I _,
    haveI : has_colimit (gg ⋙ dd) :=  I _,
    change _ = colimit.ι ((ff ⋙ gg) ⋙ dd) j ≫ _ ≫ _,
    erw [colimit.pre_pre dd gg ff, colimit.ι_pre, colimit.ι_pre],
    congr' 1,
    simp,
  end }

/-- An auxiliary definition used to define `Lan` and `Lan.adjunction`. -/
@[simps]
def equiv (F : S ⥤ D) [I : ∀ x, has_colimit (diagram ι F x)] (G : L ⥤ D) :
  (loc ι F ⟶ G) ≃ (F ⟶ ((whiskering_left _ _ _).obj ι).obj G) :=
{ to_fun := λ f,
  { app := λ x,
      by apply colimit.ι (diagram ι F (ι.obj x)) (costructured_arrow.mk (𝟙 _)) ≫ f.app _, -- sigh
  naturality' := begin
    intros x y ff,
    dsimp only [whiskering_left],
    simp only [functor.comp_map, category.assoc],
    rw [← f.naturality (ι.map ff), ← category.assoc, ← category.assoc],
    let fff : costructured_arrow ι _ ⥤ _ := costructured_arrow.map (ι.map ff),
    -- same issue :-(
    haveI : has_colimit (fff ⋙ diagram ι F (ι.obj y)) := I _,
    erw colimit.ι_pre (diagram ι F (ι.obj y)) fff (costructured_arrow.mk (𝟙 _)),
    let xx : costructured_arrow ι (ι.obj y) := costructured_arrow.mk (ι.map ff),
    let yy : costructured_arrow ι (ι.obj y) := costructured_arrow.mk (𝟙 _),
    let fff : xx ⟶ yy := costructured_arrow.hom_mk ff
      (by {simp only [costructured_arrow.mk_hom_eq_self], erw category.comp_id}),
    erw colimit.w (diagram ι F (ι.obj y)) fff,
    congr,
    simp,
  end },
  inv_fun := λ f,
  { app := λ x, colimit.desc (diagram ι F x) (cocone _ f),
    naturality' := begin
      intros x y ff,
      ext j,
      erw [colimit.pre_desc, ← category.assoc, colimit.ι_desc, colimit.ι_desc],
      tidy,
    end },
  left_inv := begin
    intro x,
    ext k j,
    rw colimit.ι_desc,
    dsimp only [cocone],
    rw [category.assoc, ← x.naturality j.hom, ← category.assoc],
    congr' 1,
    change colimit.ι _ _ ≫ colimit.pre (diagram ι F k) (costructured_arrow.map _) = _,
    rw colimit.ι_pre,
    congr,
    rcases j with ⟨_, ⟨⟩, _⟩,
    tidy,
  end,
  right_inv := by tidy }

end Lan

/-- The left Kan extension of a functor. -/
@[simps]
def Lan [∀ X, has_colimits_of_shape (costructured_arrow ι X) D] : (S ⥤ D) ⥤ L ⥤ D :=
adjunction.left_adjoint_of_equiv (λ F G, Lan.equiv ι F G) (by tidy)

namespace Lan

variable (D)

/-- The adjunction associated to `Lan`. -/
def adjunction [∀ X, has_colimits_of_shape (costructured_arrow ι X) D] :
  Lan ι ⊣ (whiskering_left _ _ D).obj ι :=
adjunction.adjunction_of_equiv_left _ _

lemma coreflective [full ι] [faithful ι] [∀ X, has_colimits_of_shape (costructured_arrow ι X) D] :
  is_iso (adjunction D ι).unit :=
begin
  apply nat_iso.is_iso_of_is_iso_app _,
  intros F,
  apply nat_iso.is_iso_of_is_iso_app _,
  intros X,
  dsimp [adjunction],
  simp only [category.comp_id],
  exact is_iso.of_iso ((colimit.is_colimit _).cocone_point_unique_up_to_iso
    (colimit_of_diagram_terminal costructured_arrow.mk_id_terminal _)).symm,
end

end Lan

end category_theory


import .atom
import ...common.lnq ...common.ldq ...common.predicates

variables {α β : Type}

namespace lia

lemma down_closed_fnormal : @down_closed (lia.atom) (fnormal int)
| ⊤' _ hd _ := by cases hd
| ⊥' _ hd _ := by cases hd
| (A' a) _ hd _ := by cases hd
| (p ∧' q) r hd hn :=
  by {unfold fnormal at hn, cases hn, cases hd; assumption}
| (p ∨' q) r hd hn :=
  by {unfold fnormal at hn, cases hn, cases hd; assumption}
| (¬' p) r hd hn := by {cases hd, apply hn}
| (∃' p) r hd hn := by {cases hd, apply hn}

lemma prop_up_closed_fnormal : @prop_up_closed (lia.atom) (fnormal int)
| ⊤' := trivial
| ⊥' := trivial
| (A' a) := trivial
| (p ∧' q) := begin intros hp hq, apply and.intro hp hq end
| (p ∨' q) := begin intros hp hq, apply and.intro hp hq end
| (¬' p) := id
| (∃' p) := trivial

lemma fnormal_and_o : ∀ (p q : fm atom), fnormal int p → fnormal int q → fnormal int (and_o p q)
 := pred_and_o (fnormal int) prop_up_closed_fnormal

lemma fnormal_or_o : ∀ (p q : fm atom), fnormal int p → fnormal int q → fnormal int (or_o p q)
 := pred_or_o (fnormal int) prop_up_closed_fnormal

lemma fnormal_list_disj : ∀ (ps : list (fm atom)), (∀ p ∈ ps, fnormal int p) → fnormal int (list_disj ps) :=
pred_list_disj _ prop_up_closed_fnormal

lemma fnormal_disj : ∀ (bs : list β) (f : β → fm atom), (∀ b ∈ bs, fnormal int (f b)) → fnormal int (disj bs f) :=
pred_disj _ prop_up_closed_fnormal

meta def nnf_closed_fnormal_aux :=
`[unfold nnf, unfold fnormal,
  unfold fnormal at hn, cases hn with hnp hnq,
  cases (nnf_closed_fnormal_core hnp) with hnp1 hnp2,
  cases (nnf_closed_fnormal_core hnq) with hnq1 hnq2,
  apply and.intro; apply and.intro; assumption]

lemma nnf_closed_fnormal_core : ∀ {p : fm lia.atom},
  fnormal int p → fnormal int (nnf int p) ∧ fnormal int (nnf int (¬' p))
| ⊤' hn := and.intro trivial trivial
| ⊥' hn := and.intro trivial trivial
| (A' a) hn :=
  begin
    unfold nnf, apply and.intro,
    apply hn, rewrite fnormal_iff_fnormal_alt,
    apply atom_type.neg_prsv_normal, apply hn
  end
| (p ∧' q) hn := by nnf_closed_fnormal_aux
| (p ∨' q) hn := by nnf_closed_fnormal_aux
| (¬' p) hn :=
  begin
    apply and.symm, unfold fnormal at hn,
    unfold nnf, apply nnf_closed_fnormal_core hn
  end
| (∃' p) hn :=
  begin unfold nnf, apply and.intro; trivial end

lemma nnf_closed_fnormal : preserves (@nnf lia.atom int _) (fnormal int) :=
λ p hn, (nnf_closed_fnormal_core hn)^.elim_left

lemma atoms_and_o_subset {p q : fm lia.atom} :
  atoms (and_o p q) ⊆ atoms p ∪ atoms q :=
begin
  apply cases_and_o' (λ p' q' r, atoms r ⊆ atoms p' ∪ atoms q') p q;
  intros a ha,
  apply list.mem_union_right, apply ha,
  apply list.mem_union_left, apply ha,
  apply list.mem_union_left, apply ha,
  apply list.mem_union_right, apply ha,
  apply ha
end

lemma lnq_closed_fnormal (f : fm atom → fm atom)
 (hc : preserves f (fnormal ℤ)) : preserves (lift_nnf_qe ℤ f) (fnormal ℤ)
| ⊤' hn := trivial
| ⊥' hn := trivial
| (A' a) hn := by {unfold lift_nnf_qe, apply hn}
| (p ∧' q) hn :=
  begin
    unfold fnormal at hn , cases hn with hnp hnq,
    unfold lift_nnf_qe, apply cases_and_o, trivial,
    apply lnq_closed_fnormal, apply hnp,
    apply lnq_closed_fnormal, apply hnq,
    apply and.intro; apply lnq_closed_fnormal; assumption,
  end
| (p ∨' q) hn :=
  begin
    unfold fnormal at hn , cases hn with hnp hnq,
    unfold lift_nnf_qe, apply cases_or_o, trivial,
    apply lnq_closed_fnormal, apply hnp,
    apply lnq_closed_fnormal, apply hnq,
    apply and.intro; apply lnq_closed_fnormal; assumption,
  end
| (¬' p) hn :=
  begin
    unfold fnormal at hn, unfold lift_nnf_qe, apply cases_not_o,
    trivial, trivial, apply lnq_closed_fnormal, apply hn
  end
| (∃' p) hn :=
  begin
    unfold lift_nnf_qe, apply hc,
    apply nnf_closed_fnormal,
    apply lnq_closed_fnormal, apply hn
  end

theorem lnq_prsv
  (qe : fm lia.atom → fm lia.atom)
  (hqe : preserves qe (fnormal int))
  (hqf : qfree_res_of_nqfree_arg qe)
  (hi : ∀ p, nqfree p → fnormal int p → ∀ (bs : list int), I (qe p) bs ↔ ∃ b, (I p (b::bs))) :
∀ p, fnormal int p → ∀ (bs : list int), I (lift_nnf_qe int qe p) bs ↔ I p bs :=
@lnq_prsv_gen lia.atom int lia.atom_type
  qe hqf (fnormal int) down_closed_fnormal hqe
  nnf_closed_fnormal lnq_closed_fnormal hi

theorem ldq_prsv
  (qe : list lia.atom → fm lia.atom)
  (hqf : ∀ as, (∀ a ∈ as, dep0 a) → qfree (qe as))
  (hn : ∀ as, (∀ a ∈ as, dep0 a) → (∀ a ∈ as, normal a) → fnormal int (qe as))
  (he : ∀ as, (∀ a ∈ as, dep0 a) → (∀ a ∈ as, normal a) → qe_prsv int qe as) :
  ∀ p, fnormal int p → ∀ (bs : list int), I (lift_dnf_qe int qe p) bs ↔ I p bs :=
@ldq_prsv_gen lia.atom int lia.atom_type _ hqf hn he

end lia


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

! This file was ported from Lean 3 source module order.category.Preord
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Category.Cat
import Mathbin.CategoryTheory.Category.Preorder
import Mathbin.CategoryTheory.ConcreteCategory.BundledHom
import Mathbin.Order.Hom.Basic

/-!
# Category of preorders

This defines `Preord`, the category of preorders with monotone maps.
-/

universe u

open CategoryTheory

/-- The category of preorders. -/
def Preord :=
  Bundled Preorder
#align Preord Preord

namespace Preord

instance : BundledHom @OrderHom where
  toFun := @OrderHom.toFun
  id := @OrderHom.id
  comp := @OrderHom.comp
  hom_ext := @OrderHom.ext

deriving instance LargeCategory, ConcreteCategory for Preord

instance : CoeSort Preord (Type _) :=
  Bundled.hasCoeToSort

/-- Construct a bundled Preord from the underlying type and typeclass. -/
def of (α : Type _) [Preorder α] : Preord :=
  Bundled.of α
#align Preord.of Preord.of

@[simp]
theorem coe_of (α : Type _) [Preorder α] : ↥(of α) = α :=
  rfl
#align Preord.coe_of Preord.coe_of

instance : Inhabited Preord :=
  ⟨of PUnit⟩

instance (α : Preord) : Preorder α :=
  α.str

/-- Constructs an equivalence between preorders from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : Preord.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := e
  inv := e.symm
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply x
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply x
#align Preord.iso.mk Preord.Iso.mk

/-- `order_dual` as a functor. -/
@[simps]
def dual : Preord ⥤ Preord where
  obj X := of Xᵒᵈ
  map X Y := OrderHom.dual
#align Preord.dual Preord.dual

/-- The equivalence between `Preord` and itself induced by `order_dual` both ways. -/
@[simps Functor inverse]
def dualEquiv : Preord ≌ Preord :=
  Equivalence.mk dual dual
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
#align Preord.dual_equiv Preord.dualEquiv

end Preord

/-- The embedding of `Preord` into `Cat`.
-/
@[simps]
def preordToCat : Preord.{u} ⥤ Cat where
  obj X := Cat.of X.1
  map X Y f := f.Monotone.Functor
  map_id' X := by apply CategoryTheory.Functor.ext; tidy
  map_comp' X Y Z f g := by apply CategoryTheory.Functor.ext; tidy
#align Preord_to_Cat preordToCat

instance : Faithful preordToCat.{u}
    where map_injective' X Y f g h := by ext x; exact functor.congr_obj h x

instance : Full preordToCat.{u}
    where
  preimage X Y f := ⟨f.obj, f.Monotone⟩
  witness' X Y f := by apply CategoryTheory.Functor.ext; tidy


import tactic.basic
import tactic.linarith
import utils

inductive Untyped
| utrue
| ufalse
| uzero
| usucc : Untyped → Untyped
| uite : Untyped → Untyped → Untyped → Untyped
| upred : Untyped → Untyped
| uiszero : Untyped → Untyped

open Untyped

@[simp]
def consts : Untyped → list Untyped
| utrue := [utrue]
| ufalse := [ufalse]
| uzero := [uzero]
| (usucc n) := consts n
| (uite c t e) := (consts c) ++ ((consts t) ++ (consts e))
| (upred p) := consts p
| (uiszero v) := consts v

@[simp]
def size : Untyped → ℕ
| utrue := 1
| ufalse := 1
| uzero := 1
| (usucc n) := size n + 1
| (uite c t e) := ((size c + size t) + size e) + 1
| (upred p) := size p + 1
| (uiszero v) := size v + 1

@[simp]
def depth : Untyped → ℕ
| utrue := 1
| ufalse := 1
| uzero := 1
| (usucc n) := depth n + 1
| (uite c t e) := max (depth c) (max (depth t) (depth e)) + 1
| (upred p) := depth p + 1
| (uiszero v) := depth v + 1

theorem consts_finite :
  ∀u, ∃n, (consts u).length = n
  := begin
  intro u,
  induction u with n n_ih a b c a_ih b_ih c_ih,
  {
    existsi 1,
    simp,
  },
  {
    existsi 1,
    simp,
  },
  {
    existsi 1,
    simp,
  },
  {
    existsi (consts n).length,
    simp,
  },
  {
    exact exists_eq',
  },
  {
    exact u_ih,
  },
  {
    existsi (consts u_a).length,
    simp,
  }
end

theorem consts_le_size:
    ∀t, (consts t).length ≤ size t
  := begin
  intro t,
  induction t,
  any_goals { simp },
  {
    exact le_add_right t_ih
  },
  {
    apply nat.le_succ_of_le,
    simp,
    apply smaller_than3 t_ih_a t_ih_a_1 t_ih_a_2,
  },
  {
    exact le_add_right t_ih,
  },
  {
    exact le_add_right t_ih,
  }
end

theorem untyped_depth_induction
  (p : Untyped → Prop)
  (h1 : ∀s r, depth r < depth s → p r → p s)
  : ∀s2, (p s2) := begin
  intro s2,
  specialize h1 s2,
  apply h1,
  sorry,
  sorry,
  sorry,
  -- induction s2,
end


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import tactic.interactive
import data.rbtree.init

universe u

meta def tactic.interactive.blast_disjs : tactic unit :=
`[cases_type* or]

namespace rbnode
variables {α : Type u}

open color nat

inductive is_node_of : rbnode α → rbnode α → α → rbnode α → Prop
| of_red   (l v r) : is_node_of (red_node l v r)    l v r
| of_black (l v r) : is_node_of (black_node l v r)  l v r

def lift (lt : α → α → Prop) : option α → option α → Prop
| (some a) (some b) := lt a b
| _         _       := true

inductive is_searchable (lt : α → α → Prop) : rbnode α → option α → option α → Prop
| leaf_s  {lo hi} (hlt : lift lt lo hi) : is_searchable leaf lo hi
| red_s   {l r v lo hi} (hs₁ : is_searchable l lo (some v)) (hs₂ : is_searchable r (some v) hi) :
  is_searchable (red_node l v r) lo hi
| black_s {l r v lo hi} (hs₁ : is_searchable l lo (some v)) (hs₂ : is_searchable r (some v) hi) :
  is_searchable (black_node l v r) lo hi

meta def is_searchable_tactic : tactic unit :=
`[
   constructor_matching*
     [is_searchable _ leaf _ _,
      is_searchable _ (red_node _ _ _) _ _,
      is_searchable _ (black_node _ _ _) _ _];
   cases_matching*
     [is_searchable _ leaf _ _,
      is_searchable _ (red_node _ _ _) _ _,
      is_searchable _ (black_node _ _ _) _ _];
   try { assumption }
]

open rbnode (mem)
open is_searchable

section is_searchable_lemmas
variable {lt : α → α → Prop}

lemma lo_lt_hi {t : rbnode α} {lt} [is_trans α lt] :
  ∀ {lo hi}, is_searchable lt t lo hi → lift lt lo hi :=
begin
  induction t; intros lo hi hs,
  case leaf { cases hs, assumption },
  all_goals
  { cases hs,
    have h₁ := t_ih_lchild hs_hs₁,
    have h₂ := t_ih_rchild hs_hs₂,
    cases lo; cases hi; simp [lift] at *,
    apply trans_of lt h₁ h₂, }
end

lemma is_searchable_of_is_searchable_of_incomp [is_strict_weak_order α lt] {t} :
  ∀ {lo hi hi'} (hc : ¬ lt hi' hi ∧ ¬ lt hi hi') (hs : is_searchable lt t lo (some hi)),
    is_searchable lt t lo (some hi') :=
begin
  classical,
  induction t; intros; is_searchable_tactic,
  { cases lo; simp [lift, *] at *, apply lt_of_lt_of_incomp, assumption, exact ⟨hc.2, hc.1⟩ },
  all_goals { apply t_ih_rchild hc hs_hs₂ }
end

lemma is_searchable_of_incomp_of_is_searchable [is_strict_weak_order α lt] {t} :
  ∀ {lo lo' hi} (hc : ¬ lt lo' lo ∧ ¬ lt lo lo') (hs : is_searchable lt t (some lo) hi),
    is_searchable lt t (some lo') hi :=
begin
  classical,
  induction t; intros; is_searchable_tactic,
  { cases hi; simp [lift, *] at *, apply lt_of_incomp_of_lt, assumption, assumption },
  all_goals { apply t_ih_lchild hc hs_hs₁ }
end

lemma is_searchable_some_low_of_is_searchable_of_lt {t} [is_trans α lt] :
  ∀ {lo hi lo'} (hlt : lt lo' lo) (hs : is_searchable lt t (some lo) hi),
    is_searchable lt t (some lo') hi :=
begin
  induction t; intros; is_searchable_tactic,
  { cases hi; simp [lift, *] at *, apply trans_of lt hlt, assumption },
  all_goals { apply t_ih_lchild hlt hs_hs₁ }
end

lemma is_searchable_none_low_of_is_searchable_some_low {t} :
  ∀ {y hi} (hlt : is_searchable lt t (some y) hi), is_searchable lt t none hi :=
begin
  induction t; intros; is_searchable_tactic,
  { simp [lift] },
  all_goals { apply t_ih_lchild hlt_hs₁ }
end

lemma is_searchable_some_high_of_is_searchable_of_lt {t} [is_trans α lt] :
  ∀ {lo hi hi'} (hlt : lt hi hi') (hs : is_searchable lt t lo (some hi)),
    is_searchable lt t lo (some hi') :=
begin
  induction t; intros; is_searchable_tactic,
  { cases lo; simp [lift, *] at *, apply trans_of lt, assumption, assumption},
  all_goals { apply t_ih_rchild hlt hs_hs₂ }
end

lemma is_searchable_none_high_of_is_searchable_some_high {t} :
  ∀ {lo y} (hlt : is_searchable lt t lo (some y)), is_searchable lt t lo none :=
begin
  induction t; intros; is_searchable_tactic,
  { cases lo; simp [lift] },
  all_goals { apply t_ih_rchild hlt_hs₂ }
end

lemma range [is_strict_weak_order α lt] {t : rbnode α} {x} :
  ∀ {lo hi}, is_searchable lt t lo hi → mem lt x t → lift lt lo (some x) ∧ lift lt (some x) hi :=
begin
  classical,
  induction t,
  case leaf { simp [mem] },
  all_goals { -- red_node and black_node are identical
    intros lo hi h₁ h₂, cases h₁,
    simp only [mem] at h₂,
    have val_hi : lift lt (some t_val) hi, { apply lo_lt_hi, assumption },
    have lo_val : lift lt lo (some t_val), { apply lo_lt_hi, assumption },
    blast_disjs,

    { have h₃ : lift lt lo (some x) ∧ lift lt (some x) (some t_val),
      { apply t_ih_lchild, assumption, assumption },
      cases h₃ with lo_x x_val,
      split,
      show lift lt lo (some x), { assumption },
      show lift lt (some x ) hi,
      { cases hi with hi; simp [lift] at *,
        apply trans_of lt x_val val_hi } },

    { cases h₂,
      cases lo with lo; cases hi with hi; simp [lift] at *,
      { apply lt_of_incomp_of_lt _ val_hi, simp [*] },
      { apply lt_of_lt_of_incomp lo_val, simp [*] },
      split,
      { apply lt_of_lt_of_incomp lo_val, simp [*] },
      { apply lt_of_incomp_of_lt _ val_hi, simp [*] } },

    { have h₃ : lift lt (some t_val) (some x) ∧ lift lt (some x) hi,
      { apply t_ih_rchild, assumption, assumption },
      cases h₃ with val_x x_hi,
      cases lo with lo; cases hi with hi; simp [lift] at *,
      { assumption },
      { apply trans_of lt lo_val val_x },
      split,
      { apply trans_of lt lo_val val_x, },
      { assumption } } }
end

lemma lt_of_mem_left [is_strict_weak_order α lt] {y : α} {t l r : rbnode α} :
  ∀ {lo hi}, is_searchable lt t lo hi → is_node_of t l y r → ∀ {x}, mem lt x l → lt x y :=
begin
 intros _ _ hs hn x hm, cases hn; cases hs,
 all_goals { exact (range hs_hs₁ hm).2 }
end

lemma lt_of_mem_right [is_strict_weak_order α lt] {y : α} {t l r : rbnode α} :
  ∀ {lo hi}, is_searchable lt t lo hi → is_node_of t l y r → ∀ {z}, mem lt z r → lt y z :=
begin
 intros _ _ hs hn z hm, cases hn; cases hs,
 all_goals { exact (range hs_hs₂ hm).1 }
end

end is_searchable_lemmas

inductive is_red_black : rbnode α → color → nat → Prop
| leaf_rb  : is_red_black leaf black 0
| red_rb   {v l r n} (rb_l : is_red_black l black n) (rb_r : is_red_black r black n) :
  is_red_black (red_node l v r) red n
| black_rb {v l r n c₁ c₂} (rb_l : is_red_black l c₁ n) (rb_r : is_red_black r c₂ n) :
  is_red_black (black_node l v r) black (succ n)

open is_red_black

lemma depth_min : ∀ {c n} {t : rbnode α}, is_red_black t c n → n ≤ depth min t :=
begin
  intros c n' t h,
  induction h,
  case leaf_rb {apply le_refl},
  case red_rb { simp [depth],
    have : min (depth min h_l) (depth min h_r) ≥ h_n,
    { apply le_min; assumption },
    apply le_succ_of_le, assumption },
  case black_rb { simp [depth],
    apply succ_le_succ,
    apply le_min; assumption }
end

private def upper : color → nat → nat
| red   n := 2*n + 1
| black n := 2*n

private lemma upper_le : ∀ c n, upper c n ≤ 2 * n + 1
| red n   := by apply le_refl
| black n := by apply le_succ

lemma depth_max' : ∀ {c n} {t : rbnode α}, is_red_black t c n → depth max t ≤ upper c n :=
begin
  intros c n' t h,
  induction h,
  case leaf_rb { simp [max, depth, upper, nat.mul_zero] },
  case red_rb
  { suffices : succ (max (depth max h_l) (depth max h_r)) ≤ 2 * h_n + 1,
    { simp [depth, upper, *] at * },
    apply succ_le_succ,
    apply max_le; assumption },
  case black_rb
  { have : depth max h_l ≤ 2*h_n + 1, from le_trans h_ih_rb_l (upper_le _ _),
    have : depth max h_r ≤ 2*h_n + 1, from le_trans h_ih_rb_r (upper_le _ _),
    suffices new : max (depth max h_l) (depth max h_r) + 1 ≤ 2 * h_n + 2*1,
    { simp [depth, upper, succ_eq_add_one, nat.left_distrib, *] at * },
    apply succ_le_succ, apply max_le; assumption }
end

lemma depth_max {c n} {t : rbnode α} (h : is_red_black t c n) : depth max t ≤ 2 * n + 1:=
le_trans (depth_max' h) (upper_le _ _)

lemma balanced {c n} {t : rbnode α} (h : is_red_black t c n) : depth max t ≤ 2 * depth min t + 1 :=
begin
  have : 2 * depth min t + 1 ≥ 2 * n + 1,
  { apply succ_le_succ, apply nat.mul_le_mul_left, apply depth_min h },
  apply le_trans, apply depth_max h, apply this
end

end rbnode


/-
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, Mario Carneiro

Theory of topological monoids, groups and rings.

TODO: generalize `topological_monoid` and `topological_add_monoid` to semigroups, or add a type class
`topological_operator α (*)`.
-/

import algebra.big_operators data.set.intervals order.liminf_limsup
import analysis.topology.topological_space analysis.topology.continuity analysis.topology.uniform_space

open classical set lattice filter topological_space
local attribute [instance] classical.prop_decidable

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

lemma dense_or_discrete [linear_order α] {a₁ a₂ : α} (h : a₁ < a₂) :
  (∃a, a₁ < a ∧ a < a₂) ∨ ((∀a>a₁, a ≥ a₂) ∧ (∀a<a₂, a ≤ a₁)) :=
classical.or_iff_not_imp_left.2 $ assume h,
  ⟨assume a ha₁, le_of_not_gt $ assume ha₂, h ⟨a, ha₁, ha₂⟩,
    assume a ha₂, le_of_not_gt $ assume ha₁, h ⟨a, ha₁, ha₂⟩⟩

section topological_monoid

/-- A topological monoid is a monoid in which the multiplication is continuous as a function
`α × α → α`. -/
class topological_monoid (α : Type u) [topological_space α] [monoid α] : Prop :=
(continuous_mul : continuous (λp:α×α, p.1 * p.2))

section
variables [topological_space α] [monoid α] [topological_monoid α]

lemma continuous_mul' : continuous (λp:α×α, p.1 * p.2) :=
topological_monoid.continuous_mul α

lemma continuous_mul [topological_space β] {f : β → α} {g : β → α}
  (hf : continuous f) (hg : continuous g) :
  continuous (λx, f x * g x) :=
(hf.prod_mk hg).comp continuous_mul'

lemma tendsto_mul' {a b : α} : tendsto (λp:α×α, p.fst * p.snd) (nhds (a, b)) (nhds (a * b)) :=
continuous_iff_tendsto.mp (topological_monoid.continuous_mul α) (a, b)

lemma tendsto_mul {f : β → α} {g : β → α} {x : filter β} {a b : α}
  (hf : tendsto f x (nhds a)) (hg : tendsto g x (nhds b)) :
  tendsto (λx, f x * g x) x (nhds (a * b)) :=
(hf.prod_mk hg).comp (by rw [←nhds_prod_eq]; exact tendsto_mul')

lemma tendsto_list_prod {f : γ → β → α} {x : filter β} {a : γ → α} :
  ∀l:list γ, (∀c∈l, tendsto (f c) x (nhds (a c))) →
    tendsto (λb, (l.map (λc, f c b)).prod) x (nhds ((l.map a).prod))
| []       _ := by simp [tendsto_const_nhds]
| (f :: l) h :=
  begin
    simp,
    exact tendsto_mul
      (h f (list.mem_cons_self _ _))
      (tendsto_list_prod l (assume c hc, h c (list.mem_cons_of_mem _ hc)))
  end

lemma continuous_list_prod [topological_space β] {f : γ → β → α} (l : list γ)
  (h : ∀c∈l, continuous (f c)) :
  continuous (λa, (l.map (λc, f c a)).prod) :=
continuous_iff_tendsto.2 $ assume x, tendsto_list_prod l $ assume c hc,
  continuous_iff_tendsto.1 (h c hc) x

end

section
variables [topological_space α] [comm_monoid α] [topological_monoid α]

lemma tendsto_multiset_prod {f : γ → β → α} {x : filter β} {a : γ → α} (s : multiset γ) :
  (∀c∈s, tendsto (f c) x (nhds (a c))) →
    tendsto (λb, (s.map (λc, f c b)).prod) x (nhds ((s.map a).prod)) :=
by { rcases s with ⟨l⟩, simp, exact tendsto_list_prod l }

lemma tendsto_finset_prod {f : γ → β → α} {x : filter β} {a : γ → α} (s : finset γ) :
  (∀c∈s, tendsto (f c) x (nhds (a c))) → tendsto (λb, s.prod (λc, f c b)) x (nhds (s.prod a)) :=
tendsto_multiset_prod _

lemma continuous_multiset_prod [topological_space β] {f : γ → β → α} (s : multiset γ) :
  (∀c∈s, continuous (f c)) → continuous (λa, (s.map (λc, f c a)).prod) :=
by { rcases s with ⟨l⟩, simp, exact continuous_list_prod l }

lemma continuous_finset_prod [topological_space β] {f : γ → β → α} (s : finset γ) :
  (∀c∈s, continuous (f c)) → continuous (λa, s.prod (λc, f c a)) :=
continuous_multiset_prod _

end

end topological_monoid

section topological_add_monoid

/-- A topological (additive) monoid is a monoid in which the addition is
  continuous as a function `α × α → α`. -/
class topological_add_monoid (α : Type u) [topological_space α] [add_monoid α] : Prop :=
(continuous_add : continuous (λp:α×α, p.1 + p.2))

section
variables [topological_space α] [add_monoid α] [topological_add_monoid α]

lemma continuous_add' : continuous (λp:α×α, p.1 + p.2) :=
topological_add_monoid.continuous_add α

lemma continuous_add [topological_space β] {f : β → α} {g : β → α}
  (hf : continuous f) (hg : continuous g) : continuous (λx, f x + g x) :=
(hf.prod_mk hg).comp continuous_add'

lemma tendsto_add' {a b : α} : tendsto (λp:α×α, p.fst + p.snd) (nhds (a, b)) (nhds (a + b)) :=
continuous_iff_tendsto.mp (topological_add_monoid.continuous_add α) (a, b)

lemma tendsto_add {f : β → α} {g : β → α} {x : filter β} {a b : α}
  (hf : tendsto f x (nhds a)) (hg : tendsto g x (nhds b)) :
  tendsto (λx, f x + g x) x (nhds (a + b)) :=
(hf.prod_mk hg).comp (by rw [←nhds_prod_eq]; exact tendsto_add')

lemma tendsto_list_sum {f : γ → β → α} {x : filter β} {a : γ → α} :
  ∀l:list γ, (∀c∈l, tendsto (f c) x (nhds (a c))) →
    tendsto (λb, (l.map (λc, f c b)).sum) x (nhds ((l.map a).sum))
| []       _ := by simp [tendsto_const_nhds]
| (f :: l) h :=
  begin
    simp,
    exact tendsto_add
      (h f (list.mem_cons_self _ _))
      (tendsto_list_sum l (assume c hc, h c (list.mem_cons_of_mem _ hc)))
  end

lemma continuous_list_sum [topological_space β] {f : γ → β → α} (l : list γ)
  (h : ∀c∈l, continuous (f c)) : continuous (λa, (l.map (λc, f c a)).sum) :=
continuous_iff_tendsto.2 $ assume x, tendsto_list_sum l $ assume c hc,
  continuous_iff_tendsto.1 (h c hc) x

end

section
variables [topological_space α] [add_comm_monoid α] [topological_add_monoid α]

lemma tendsto_multiset_sum {f : γ → β → α} {x : filter β} {a : γ → α} :
  ∀ (s : multiset γ), (∀c∈s, tendsto (f c) x (nhds (a c))) →
    tendsto (λb, (s.map (λc, f c b)).sum) x (nhds ((s.map a).sum)) :=
by rintros ⟨l⟩; simp; exact tendsto_list_sum l

lemma tendsto_finset_sum {f : γ → β → α} {x : filter β} {a : γ → α} (s : finset γ) :
  (∀c∈s, tendsto (f c) x (nhds (a c))) → tendsto (λb, s.sum (λc, f c b)) x (nhds (s.sum a)) :=
tendsto_multiset_sum _

lemma continuous_multiset_sum [topological_space β] {f : γ → β → α} :
  ∀(s : multiset γ), (∀c∈s, continuous (f c)) → continuous (λa, (s.map (λc, f c a)).sum) :=
by rintros ⟨l⟩; simp; exact continuous_list_sum l

lemma continuous_finset_sum [topological_space β] {f : γ → β → α} (s : finset γ) :
  (∀c∈s, continuous (f c)) → continuous (λa, s.sum (λc, f c a)) :=
continuous_multiset_sum _

end
end topological_add_monoid

section topological_add_group
/-- A topological (additive) group is a group in which the addition and
  negation operations are continuous. -/
class topological_add_group (α : Type u) [topological_space α] [add_group α]
  extends topological_add_monoid α : Prop :=
(continuous_neg : continuous (λa:α, -a))

variables [topological_space α] [add_group α]

lemma continuous_neg' [topological_add_group α] : continuous (λx:α, - x) :=
topological_add_group.continuous_neg α

lemma continuous_neg [topological_add_group α] [topological_space β] {f : β → α}
  (hf : continuous f) : continuous (λx, - f x) :=
hf.comp continuous_neg'

lemma tendsto_neg [topological_add_group α] {f : β → α} {x : filter β} {a : α}
  (hf : tendsto f x (nhds a)) : tendsto (λx, - f x) x (nhds (- a)) :=
hf.comp (continuous_iff_tendsto.mp (topological_add_group.continuous_neg α) a)

lemma continuous_sub [topological_add_group α] [topological_space β] {f : β → α} {g : β → α}
  (hf : continuous f) (hg : continuous g) : continuous (λx, f x - g x) :=
by simp; exact continuous_add hf (continuous_neg hg)

lemma continuous_sub' [topological_add_group α] : continuous (λp:α×α, p.1 - p.2) :=
continuous_sub continuous_fst continuous_snd

lemma tendsto_sub [topological_add_group α] {f : β → α} {g : β → α} {x : filter β} {a b : α}
  (hf : tendsto f x (nhds a)) (hg : tendsto g x (nhds b)) : tendsto (λx, f x - g x) x (nhds (a - b)) :=
by simp; exact tendsto_add hf (tendsto_neg hg)

end topological_add_group

section uniform_add_group
/-- A uniform (additive) group is a group in which the addition and negation are
  uniformly continuous. -/
class uniform_add_group (α : Type u) [uniform_space α] [add_group α] : Prop :=
(uniform_continuous_sub : uniform_continuous (λp:α×α, p.1 - p.2))

theorem uniform_add_group.mk' {α} [uniform_space α] [add_group α]
  (h₁ : uniform_continuous (λp:α×α, p.1 + p.2))
  (h₂ : uniform_continuous (λp:α, -p)) : uniform_add_group α :=
⟨(uniform_continuous_fst.prod_mk (uniform_continuous_snd.comp h₂)).comp h₁⟩

variables [uniform_space α] [add_group α]

lemma uniform_continuous_sub' [uniform_add_group α] : uniform_continuous (λp:α×α, p.1 - p.2) :=
uniform_add_group.uniform_continuous_sub α

lemma uniform_continuous_sub [uniform_add_group α] [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x - g x) :=
(hf.prod_mk hg).comp uniform_continuous_sub'

lemma uniform_continuous_neg [uniform_add_group α] [uniform_space β] {f : β → α}
  (hf : uniform_continuous f) : uniform_continuous (λx, - f x) :=
have uniform_continuous (λx, 0 - f x),
  from uniform_continuous_sub uniform_continuous_const hf,
by simp * at *

lemma uniform_continuous_neg' [uniform_add_group α] : uniform_continuous (λx:α, - x) :=
uniform_continuous_neg uniform_continuous_id

lemma uniform_continuous_add [uniform_add_group α] [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x + g x) :=
have uniform_continuous (λx, f x - - g x),
  from uniform_continuous_sub hf $ uniform_continuous_neg hg,
by simp * at *

lemma uniform_continuous_add' [uniform_add_group α] : uniform_continuous (λp:α×α, p.1 + p.2) :=
uniform_continuous_add uniform_continuous_fst uniform_continuous_snd

instance uniform_add_group.to_topological_add_group [uniform_add_group α] : topological_add_group α :=
{ continuous_add := uniform_continuous_add'.continuous,
  continuous_neg := uniform_continuous_neg'.continuous }

end uniform_add_group

/-- A topological semiring is a semiring where addition and multiplication are continuous. -/
class topological_semiring (α : Type u) [topological_space α] [semiring α]
  extends topological_add_monoid α, topological_monoid α : Prop

/-- A topological ring is a ring where the ring operations are continuous. -/
class topological_ring (α : Type u) [topological_space α] [ring α]
  extends topological_add_monoid α, topological_monoid α : Prop :=
(continuous_neg : continuous (λa:α, -a))

instance topological_ring.to_topological_semiring
  [topological_space α] [ring α] [t : topological_ring α] : topological_semiring α := {..t}

instance topological_ring.to_topological_add_group
  [topological_space α] [ring α] [t : topological_ring α] : topological_add_group α := {..t}

/-- (Partially) ordered topology
Also called: partially ordered spaces (pospaces).

Usually ordered topology is used for a topology on linear ordered spaces, where the open intervals
are open sets. This is a generalization as for each linear order where open interals are open sets,
the order relation is closed. -/
class ordered_topology (α : Type*) [t : topological_space α] [partial_order α] : Prop :=
(is_closed_le' : is_closed (λp:α×α, p.1 ≤ p.2))

section ordered_topology

section partial_order
variables [topological_space α] [partial_order α] [t : ordered_topology α]
include t

lemma is_closed_le [topological_space β] {f g : β → α} (hf : continuous f) (hg : continuous g) :
  is_closed {b | f b ≤ g b} :=
continuous_iff_is_closed.mp (hf.prod_mk hg) _ t.is_closed_le'

lemma is_closed_le' (a : α) : is_closed {b | b ≤ a} :=
is_closed_le continuous_id continuous_const

lemma is_closed_ge' (a : α) : is_closed {b | a ≤ b} :=
is_closed_le continuous_const continuous_id

lemma is_closed_Icc {a b : α} : is_closed (Icc a b) :=
is_closed_inter (is_closed_ge' a) (is_closed_le' b)

lemma le_of_tendsto {f g : β → α} {b : filter β} {a₁ a₂ : α} (hb : b ≠ ⊥)
  (hf : tendsto f b (nhds a₁)) (hg : tendsto g b (nhds a₂)) (h : {b | f b ≤ g b} ∈ b.sets) :
  a₁ ≤ a₂ :=
have tendsto (λb, (f b, g b)) b (nhds (a₁, a₂)),
  by rw [nhds_prod_eq]; exact hf.prod_mk hg,
show (a₁, a₂) ∈ {p:α×α | p.1 ≤ p.2},
  from mem_of_closed_of_tendsto hb this t.is_closed_le' h

private lemma is_closed_eq : is_closed {p : α × α | p.1 = p.2} :=
by simp [le_antisymm_iff];
   exact is_closed_inter t.is_closed_le' (is_closed_le continuous_snd continuous_fst)

instance ordered_topology.to_t2_space : t2_space α :=
{ t2 :=
  have is_open {p : α × α | p.1 ≠ p.2}, from is_closed_eq,
  assume a b h,
  let ⟨u, v, hu, hv, ha, hb, h⟩ := is_open_prod_iff.mp this a b h in
  ⟨u, v, hu, hv, ha, hb,
    set.eq_empty_iff_forall_not_mem.2 $ assume a ⟨h₁, h₂⟩,
    have a ≠ a, from @h (a, a) ⟨h₁, h₂⟩,
    this rfl⟩ }

@[simp] lemma closure_le_eq [topological_space β] {f g : β → α} (hf : continuous f) (hg : continuous g) :
  closure {b | f b ≤ g b} = {b | f b ≤ g b} :=
closure_eq_iff_is_closed.mpr $ is_closed_le hf hg
end partial_order

section linear_order
variables [topological_space α] [linear_order α] [t : ordered_topology α]
include t

lemma is_open_lt [topological_space β] {f g : β → α} (hf : continuous f) (hg : continuous g) :
  is_open {b | f b < g b} :=
by simp [lt_iff_not_ge, -not_le]; exact is_closed_le hg hf

lemma is_open_Ioo {a b : α} : is_open (Ioo a b) :=
is_open_and (is_open_lt continuous_const continuous_id) (is_open_lt continuous_id continuous_const)

lemma is_open_Iio {a : α} : is_open (Iio a) :=
is_open_lt continuous_id continuous_const

end linear_order

section decidable_linear_order
variables [topological_space α] [decidable_linear_order α] [t : ordered_topology α]
  [topological_space β] {f g : β → α}
include t

section
variables (hf : continuous f) (hg : continuous g)
include hf hg

lemma frontier_le_subset_eq : frontier {b | f b ≤ g b} ⊆ {b | f b = g b} :=
assume b ⟨hb₁, hb₂⟩,
le_antisymm
  (by simpa [closure_le_eq hf hg] using hb₁)
  (not_lt.1 $ assume hb : f b < g b,
    have {b | f b < g b} ⊆ interior {b | f b ≤ g b},
      from (subset_interior_iff_subset_of_open $ is_open_lt hf hg).mpr $ assume x, le_of_lt,
    have b ∈ interior {b | f b ≤ g b}, from this hb,
    by exact hb₂ this)

lemma frontier_lt_subset_eq : frontier {b | f b < g b} ⊆ {b | f b = g b} :=
by rw ← frontier_compl;
   convert frontier_le_subset_eq hg hf; simp [ext_iff, eq_comm]

lemma continuous_max : continuous (λb, max (f b) (g b)) :=
have ∀b∈frontier {b | f b ≤ g b}, g b = f b, from assume b hb, (frontier_le_subset_eq hf hg hb).symm,
continuous_if this hg hf

lemma continuous_min : continuous (λb, min (f b) (g b)) :=
have ∀b∈frontier {b | f b ≤ g b}, f b = g b, from assume b hb, frontier_le_subset_eq hf hg hb,
continuous_if this hf hg

end

lemma tendsto_max {b : filter β} {a₁ a₂ : α} (hf : tendsto f b (nhds a₁)) (hg : tendsto g b (nhds a₂)) :
  tendsto (λb, max (f b) (g b)) b (nhds (max a₁ a₂)) :=
show tendsto ((λp:α×α, max p.1 p.2) ∘ (λb, (f b, g b))) b (nhds (max a₁ a₂)),
  from (hf.prod_mk hg).comp
    begin
      rw [←nhds_prod_eq],
      from continuous_iff_tendsto.mp (continuous_max continuous_fst continuous_snd) _
    end

lemma tendsto_min {b : filter β} {a₁ a₂ : α} (hf : tendsto f b (nhds a₁)) (hg : tendsto g b (nhds a₂)) :
  tendsto (λb, min (f b) (g b)) b (nhds (min a₁ a₂)) :=
show tendsto ((λp:α×α, min p.1 p.2) ∘ (λb, (f b, g b))) b (nhds (min a₁ a₂)),
  from (hf.prod_mk hg).comp
    begin
      rw [←nhds_prod_eq],
      from continuous_iff_tendsto.mp (continuous_min continuous_fst continuous_snd) _
    end

end decidable_linear_order

end ordered_topology

/-- Topologies generated by the open intervals.

  This is restricted to linear orders. Only then it is guaranteed that they are also a ordered
  topology. -/
class orderable_topology (α : Type*) [t : topological_space α] [partial_order α] : Prop :=
(topology_eq_generate_intervals :
  t = generate_from {s | ∃a, s = {b : α | a < b} ∨ s = {b : α | b < a}})

section orderable_topology

section partial_order
variables [topological_space α] [partial_order α] [t : orderable_topology α]
include t

lemma is_open_iff_generate_intervals {s : set α} :
  is_open s ↔ generate_open {s | ∃a, s = {b : α | a < b} ∨ s = {b : α | b < a}} s :=
by rw [t.topology_eq_generate_intervals]; refl

lemma is_open_lt' (a : α) : is_open {b:α | a < b} :=
by rw [@is_open_iff_generate_intervals α _ _ t]; exact generate_open.basic _ ⟨a, or.inl rfl⟩

lemma is_open_gt' (a : α) : is_open {b:α | b < a} :=
by rw [@is_open_iff_generate_intervals α _ _ t]; exact generate_open.basic _ ⟨a, or.inr rfl⟩

lemma lt_mem_nhds {a b : α} (h : a < b) : {b | a < b} ∈ (nhds b).sets :=
mem_nhds_sets (is_open_lt' _) h

lemma le_mem_nhds {a b : α} (h : a < b) : {b | a ≤ b} ∈ (nhds b).sets :=
(nhds b).sets_of_superset (lt_mem_nhds h) $ assume b hb, le_of_lt hb

lemma gt_mem_nhds {a b : α} (h : a < b) : {a | a < b} ∈ (nhds a).sets :=
mem_nhds_sets (is_open_gt' _) h

lemma ge_mem_nhds {a b : α} (h : a < b) : {a | a ≤ b} ∈ (nhds a).sets :=
(nhds a).sets_of_superset (gt_mem_nhds h) $ assume b hb, le_of_lt hb

lemma nhds_eq_orderable {a : α} :
  nhds a = (⨅b<a, principal {c | b < c}) ⊓ (⨅b>a, principal {c | c < b}) :=
by rw [t.topology_eq_generate_intervals, nhds_generate_from];
from le_antisymm
  (le_inf
    (le_infi $ assume b, le_infi $ assume hb,
      infi_le_of_le {c : α | b < c} $ infi_le _ ⟨hb, b, or.inl rfl⟩)
    (le_infi $ assume b, le_infi $ assume hb,
      infi_le_of_le {c : α | c < b} $ infi_le _ ⟨hb, b, or.inr rfl⟩))
  (le_infi $ assume s, le_infi $ assume ⟨ha, b, hs⟩,
    match s, ha, hs with
    | _, h, (or.inl rfl) := inf_le_left_of_le $ infi_le_of_le b $ infi_le _ h
    | _, h, (or.inr rfl) := inf_le_right_of_le $ infi_le_of_le b $ infi_le _ h
    end)

lemma tendsto_orderable {f : β → α} {a : α} {x : filter β} :
  tendsto f x (nhds a) ↔ (∀a'<a, {b | a' < f b} ∈ x.sets) ∧ (∀a'>a, {b | a' > f b} ∈ x.sets) :=
by simp [@nhds_eq_orderable α _ _, tendsto_inf, tendsto_infi, tendsto_principal]

/-- Also known as squeeze or sandwich theorem. -/
lemma tendsto_of_tendsto_of_tendsto_of_le_of_le {f g h : β → α} {b : filter β} {a : α}
  (hg : tendsto g b (nhds a)) (hh : tendsto h b (nhds a))
  (hgf : {b | g b ≤ f b} ∈ b.sets) (hfh : {b | f b ≤ h b} ∈ b.sets) :
  tendsto f b (nhds a) :=
tendsto_orderable.2
  ⟨assume a' h',
    have {b : β | a' < g b} ∈ b.sets, from (tendsto_orderable.1 hg).left a' h',
    by filter_upwards [this, hgf] assume a, lt_of_lt_of_le,
    assume a' h',
    have {b : β | h b < a'} ∈ b.sets, from (tendsto_orderable.1 hh).right a' h',
    by filter_upwards [this, hfh] assume a h₁ h₂, lt_of_le_of_lt h₂ h₁⟩

lemma nhds_orderable_unbounded {a : α} (hu : ∃u, a < u) (hl : ∃l, l < a) :
  nhds a = (⨅l (h₂ : l < a) u (h₂ : a < u), principal {x | l < x ∧ x < u }) :=
let ⟨u, hu⟩ := hu, ⟨l, hl⟩ := hl in
calc nhds a = (⨅b<a, principal {c | b < c}) ⊓ (⨅b>a, principal {c | c < b}) : nhds_eq_orderable
  ... = (⨅b<a, principal {c | b < c} ⊓ (⨅b>a, principal {c | c < b})) :
    binfi_inf hl
  ... = (⨅l<a, (⨅u>a, principal {c | c < u} ⊓ principal {c | l < c})) :
    begin
      congr, funext x,
      congr, funext hx,
      rw [inf_comm],
      apply binfi_inf hu
    end
  ... = _ : by simp [inter_comm]; refl

lemma tendsto_orderable_unbounded {f : β → α} {a : α} {x : filter β}
  (hu : ∃u, a < u) (hl : ∃l, l < a) (h : ∀l u, l < a → a < u → {b | l < f b ∧ f b < u } ∈ x.sets) :
  tendsto f x (nhds a) :=
by rw [nhds_orderable_unbounded hu hl];
from (tendsto_infi.2 $ assume l, tendsto_infi.2 $ assume hl,
  tendsto_infi.2 $ assume u, tendsto_infi.2 $ assume hu, tendsto_principal.2 $ h l u hl hu)

end partial_order

theorem induced_orderable_topology' {α : Type u} {β : Type v}
  [partial_order α] [ta : topological_space β] [partial_order β] [orderable_topology β]
  (f : α → β) (hf : ∀ {x y}, f x < f y ↔ x < y)
  (H₁ : ∀ {a x}, x < f a → ∃ b < a, x ≤ f b)
  (H₂ : ∀ {a x}, f a < x → ∃ b > a, f b ≤ x) :
  @orderable_topology _ (induced f ta) _ :=
begin
  letI := induced f ta,
  refine ⟨eq_of_nhds_eq_nhds (λ a, _)⟩,
  rw [nhds_induced_eq_comap, nhds_generate_from, @nhds_eq_orderable β _ _], apply le_antisymm,
  { rw [← map_le_iff_le_comap],
    refine le_inf _ _; refine le_infi (λ x, le_infi $ λ h, le_principal_iff.2 _); simp,
    { rcases H₁ h with ⟨b, ab, xb⟩,
      refine mem_infi_sets _ (mem_infi_sets ⟨ab, b, or.inl rfl⟩ (mem_principal_sets.2 _)),
      exact λ c hc, lt_of_le_of_lt xb (hf.2 hc) },
    { rcases H₂ h with ⟨b, ab, xb⟩,
      refine mem_infi_sets _ (mem_infi_sets ⟨ab, b, or.inr rfl⟩ (mem_principal_sets.2 _)),
      exact λ c hc, lt_of_lt_of_le (hf.2 hc) xb } },
  refine le_infi (λ s, le_infi $ λ hs, le_principal_iff.2 _),
  rcases hs with ⟨ab, b, rfl|rfl⟩,
  { exact mem_comap_sets.2 ⟨{x | f b < x},
      mem_inf_sets_of_left $ mem_infi_sets _ $ mem_infi_sets (hf.2 ab) $ mem_principal_self _,
      λ x, hf.1⟩ },
  { exact mem_comap_sets.2 ⟨{x | x < f b},
      mem_inf_sets_of_right $ mem_infi_sets _ $ mem_infi_sets (hf.2 ab) $ mem_principal_self _,
      λ x, hf.1⟩ }
end

theorem induced_orderable_topology {α : Type u} {β : Type v}
  [partial_order α] [ta : topological_space β] [partial_order β] [orderable_topology β]
  (f : α → β) (hf : ∀ {x y}, f x < f y ↔ x < y)
  (H : ∀ {x y}, x < y → ∃ a, x < f a ∧ f a < y) :
  @orderable_topology _ (induced f ta) _ :=
induced_orderable_topology' f @hf
  (λ a x xa, let ⟨b, xb, ba⟩ := H xa in ⟨b, hf.1 ba, le_of_lt xb⟩)
  (λ a x ax, let ⟨b, ab, bx⟩ := H ax in ⟨b, hf.1 ab, le_of_lt bx⟩)

lemma nhds_top_orderable [topological_space α] [order_top α] [orderable_topology α] :
  nhds (⊤:α) = (⨅l (h₂ : l < ⊤), principal {x | l < x}) :=
by rw [@nhds_eq_orderable α _ _]; simp [(>)]

lemma nhds_bot_orderable [topological_space α] [order_bot α] [orderable_topology α] :
  nhds (⊥:α) = (⨅l (h₂ : ⊥ < l), principal {x | x < l}) :=
by rw [@nhds_eq_orderable α _ _]; simp

section linear_order

variables [topological_space α] [linear_order α] [t : orderable_topology α]
include t

lemma mem_nhds_orderable_dest {a : α} {s : set α} (hs : s ∈ (nhds a).sets) :
  ((∃u, u>a) → ∃u, a < u ∧ ∀b, a ≤ b → b < u → b ∈ s) ∧
  ((∃l, l<a) → ∃l, l < a ∧ ∀b, l < b → b ≤ a → b ∈ s) :=
let ⟨t₁, ht₁, t₂, ht₂, hts⟩ :=
  mem_inf_sets.mp $ by rw [@nhds_eq_orderable α _ _ _] at hs; exact hs in
have ht₁ : ((∃l, l<a) → ∃l, l < a ∧ ∀b, l < b → b ∈ t₁) ∧ (∀b, a ≤ b → b ∈ t₁),
  from infi_sets_induct ht₁
    (by simp {contextual := tt})
    (assume a' s₁ s₂ hs₁ ⟨hs₂, hs₃⟩,
      begin
        by_cases a' < a,
        { simp [h] at hs₁,
          letI := classical.DLO α,
          exact ⟨assume hx, let ⟨u, hu₁, hu₂⟩ := hs₂ hx in
            ⟨max u a', max_lt hu₁ h, assume b hb,
              ⟨hs₁ $ lt_of_le_of_lt (le_max_right _ _) hb,
                hu₂ _ $ lt_of_le_of_lt (le_max_left _ _) hb⟩⟩,
            assume b hb, ⟨hs₁ $ lt_of_lt_of_le h hb, hs₃ _ hb⟩⟩ },
        { simp [h] at hs₁, simp [hs₁],
          exact ⟨by simpa using hs₂, hs₃⟩ }
      end)
    (assume s₁ s₂ h ih, and.intro
      (assume hx, let ⟨u, hu₁, hu₂⟩ := ih.left hx in ⟨u, hu₁, assume b hb, h $ hu₂ _ hb⟩)
      (assume b hb, h $ ih.right _ hb)),
have ht₂ : ((∃u, u>a) → ∃u, a < u ∧ ∀b, b < u → b ∈ t₂) ∧ (∀b, b ≤ a → b ∈ t₂),
  from infi_sets_induct ht₂
    (by simp {contextual := tt})
    (assume a' s₁ s₂ hs₁ ⟨hs₂, hs₃⟩,
      begin
        by_cases a' > a,
        { simp [h] at hs₁,
          letI := classical.DLO α,
          exact ⟨assume hx, let ⟨u, hu₁, hu₂⟩ := hs₂ hx in
            ⟨min u a', lt_min hu₁ h, assume b hb,
              ⟨hs₁ $ lt_of_lt_of_le hb (min_le_right _ _),
                hu₂ _ $ lt_of_lt_of_le hb (min_le_left _ _)⟩⟩,
            assume b hb, ⟨hs₁ $ lt_of_le_of_lt hb h, hs₃ _ hb⟩⟩ },
        { simp [h] at hs₁, simp [hs₁],
          exact ⟨by simpa using hs₂, hs₃⟩ }
      end)
    (assume s₁ s₂ h ih, and.intro
      (assume hx, let ⟨u, hu₁, hu₂⟩ := ih.left hx in ⟨u, hu₁, assume b hb, h $ hu₂ _ hb⟩)
      (assume b hb, h $ ih.right _ hb)),
and.intro
  (assume hx, let ⟨u, hu, h⟩ := ht₂.left hx in ⟨u, hu, assume b hb hbu, hts ⟨ht₁.right b hb, h _ hbu⟩⟩)
  (assume hx, let ⟨l, hl, h⟩ := ht₁.left hx in ⟨l, hl, assume b hbl hb, hts ⟨h _ hbl, ht₂.right b hb⟩⟩)

lemma mem_nhds_unbounded {a : α} {s : set α} (hu : ∃u, a < u) (hl : ∃l, l < a) :
  s ∈ (nhds a).sets ↔ (∃l u, l < a ∧ a < u ∧ ∀b, l < b → b < u → b ∈ s) :=
let ⟨l, hl'⟩ := hl, ⟨u, hu'⟩ := hu in
have nhds a = (⨅p : {l // l < a} × {u // a < u}, principal {x | p.1.val < x ∧ x < p.2.val }),
  by simp [nhds_orderable_unbounded hu hl, infi_subtype, infi_prod],
iff.intro
  (assume hs, by rw [this] at hs; from infi_sets_induct hs
    ⟨l, u, hl', hu', by simp⟩
    begin
      intro p, rcases p with ⟨⟨l, hl⟩, ⟨u, hu⟩⟩,
      simp [set.subset_def],
      intros s₁ s₂ hs₁ l' hl' u' hu' hs₂,
      letI := classical.DLO α,
      refine ⟨max l l', _, min u u', _⟩;
      simp [*, lt_min_iff, max_lt_iff] {contextual := tt}
    end
    (assume s₁ s₂ h ⟨l, u, h₁, h₂, h₃⟩, ⟨l, u, h₁, h₂, assume b hu hl, h $ h₃ _ hu hl⟩))
  (assume ⟨l, u, hl, hu, h⟩,
    by rw [this]; exact mem_infi_sets ⟨⟨l, hl⟩, ⟨u, hu⟩⟩ (assume b ⟨h₁, h₂⟩, h b h₁ h₂))

lemma order_separated {a₁ a₂ : α} (h : a₁ < a₂) :
  ∃u v : set α, is_open u ∧ is_open v ∧ a₁ ∈ u ∧ a₂ ∈ v ∧ (∀b₁∈u, ∀b₂∈v, b₁ < b₂) :=
match dense_or_discrete h with
| or.inl ⟨a, ha₁, ha₂⟩ := ⟨{a' | a' < a}, {a' | a < a'}, is_open_gt' a, is_open_lt' a, ha₁, ha₂,
    assume b₁ h₁ b₂ h₂, lt_trans h₁ h₂⟩
| or.inr ⟨h₁, h₂⟩ := ⟨{a | a < a₂}, {a | a₁ < a}, is_open_gt' a₂, is_open_lt' a₁, h, h,
    assume b₁ hb₁ b₂ hb₂,
    calc b₁ ≤ a₁ : h₂ _ hb₁
      ... < a₂ : h
      ... ≤ b₂ : h₁ _ hb₂⟩
end

instance orderable_topology.to_ordered_topology : ordered_topology α :=
{ is_closed_le' :=
    is_open_prod_iff.mpr $ assume a₁ a₂ (h : ¬ a₁ ≤ a₂),
      have h : a₂ < a₁, from lt_of_not_ge h,
      let ⟨u, v, hu, hv, ha₁, ha₂, h⟩ := order_separated h in
      ⟨v, u, hv, hu, ha₂, ha₁, assume ⟨b₁, b₂⟩ ⟨h₁, h₂⟩, not_le_of_gt $ h b₂ h₂ b₁ h₁⟩ }

instance orderable_topology.t2_space : t2_space α := by apply_instance

instance orderable_topology.regular_space : regular_space α :=
{ regular := assume s a hs ha,
    have -s ∈ (nhds a).sets, from mem_nhds_sets hs ha,
    let ⟨h₁, h₂⟩ := mem_nhds_orderable_dest this in
    have ∃t:set α, is_open t ∧ (∀l∈ s, l < a → l ∈ t) ∧ nhds a ⊓ principal t = ⊥,
      from by_cases
        (assume h : ∃l, l < a,
          let ⟨l, hl, h⟩ := h₂ h in
          match dense_or_discrete hl with
          | or.inl ⟨b, hb₁, hb₂⟩ := ⟨{a | a < b}, is_open_gt' _,
              assume c hcs hca, show c < b,
                from lt_of_not_ge $ assume hbc, h c (lt_of_lt_of_le hb₁ hbc) (le_of_lt hca) hcs,
              inf_principal_eq_bot $ (nhds a).sets_of_superset (mem_nhds_sets (is_open_lt' _) hb₂) $
                assume x (hx : b < x), show ¬ x < b, from not_lt.2 $ le_of_lt hx⟩
          | or.inr ⟨h₁, h₂⟩ := ⟨{a' | a' < a}, is_open_gt' _, assume b hbs hba, hba,
              inf_principal_eq_bot $ (nhds a).sets_of_superset (mem_nhds_sets (is_open_lt' _) hl) $
                assume x (hx : l < x), show ¬ x < a, from not_lt.2 $ h₁ _ hx⟩
          end)
        (assume : ¬ ∃l, l < a, ⟨∅, is_open_empty, assume l _ hl, (this ⟨l, hl⟩).elim,
          by rw [principal_empty, inf_bot_eq]⟩),
    let ⟨t₁, ht₁o, ht₁s, ht₁a⟩ := this in
    have ∃t:set α, is_open t ∧ (∀u∈ s, u>a → u ∈ t) ∧ nhds a ⊓ principal t = ⊥,
      from by_cases
        (assume h : ∃u, u > a,
          let ⟨u, hu, h⟩ := h₁ h in
          match dense_or_discrete hu with
          | or.inl ⟨b, hb₁, hb₂⟩ := ⟨{a | b < a}, is_open_lt' _,
              assume c hcs hca, show c > b,
                from lt_of_not_ge $ assume hbc, h c (le_of_lt hca) (lt_of_le_of_lt hbc hb₂) hcs,
              inf_principal_eq_bot $ (nhds a).sets_of_superset (mem_nhds_sets (is_open_gt' _) hb₁) $
                assume x (hx : b > x), show ¬ x > b, from not_lt.2 $ le_of_lt hx⟩
          | or.inr ⟨h₁, h₂⟩ := ⟨{a' | a' > a}, is_open_lt' _, assume b hbs hba, hba,
              inf_principal_eq_bot $ (nhds a).sets_of_superset (mem_nhds_sets (is_open_gt' _) hu) $
                assume x (hx : u > x), show ¬ x > a, from not_lt.2 $ h₂ _ hx⟩
          end)
        (assume : ¬ ∃u, u > a, ⟨∅, is_open_empty, assume l _ hl, (this ⟨l, hl⟩).elim,
          by rw [principal_empty, inf_bot_eq]⟩),
    let ⟨t₂, ht₂o, ht₂s, ht₂a⟩ := this in
    ⟨t₁ ∪ t₂, is_open_union ht₁o ht₂o,
      assume x hx,
      have x ≠ a, from assume eq, ha $ eq ▸ hx,
      (ne_iff_lt_or_gt.mp this).imp (ht₁s _ hx) (ht₂s _ hx),
      by rw [←sup_principal, inf_sup_left, ht₁a, ht₂a, bot_sup_eq]⟩,
  ..orderable_topology.t2_space }

end linear_order

lemma preimage_neg [add_group α] : preimage (has_neg.neg : α → α) = image (has_neg.neg : α → α) :=
(image_eq_preimage_of_inverse neg_neg neg_neg).symm

lemma filter.map_neg [add_group α] : map (has_neg.neg : α → α) = comap (has_neg.neg : α → α) :=
funext $ assume f, map_eq_comap_of_inverse (funext neg_neg) (funext neg_neg)

section topological_add_group

variables [topological_space α] [ordered_comm_group α] [orderable_topology α] [topological_add_group α]

lemma neg_preimage_closure {s : set α} : (λr:α, -r) ⁻¹' closure s = closure ((λr:α, -r) '' s) :=
have (λr:α, -r) ∘ (λr:α, -r) = id, from funext neg_neg,
by rw [preimage_neg]; exact
  (subset.antisymm (image_closure_subset_closure_image continuous_neg') $
    calc closure ((λ (r : α), -r) '' s) = (λr, -r) '' ((λr, -r) '' closure ((λ (r : α), -r) '' s)) :
        by rw [←image_comp, this, image_id]
      ... ⊆ (λr, -r) '' closure ((λr, -r) '' ((λ (r : α), -r) '' s)) :
        mono_image $ image_closure_subset_closure_image continuous_neg'
      ... = _ : by rw [←image_comp, this, image_id])

end topological_add_group

section order_topology

variables [topological_space α] [topological_space β]
  [decidable_linear_order α] [decidable_linear_order β] [orderable_topology α] [orderable_topology β]

lemma nhds_principal_ne_bot_of_is_lub {a : α} {s : set α} (ha : is_lub s a) (hs : s ≠ ∅) :
  nhds a ⊓ principal s ≠ ⊥ :=
let ⟨a', ha'⟩ := exists_mem_of_ne_empty hs in
forall_sets_neq_empty_iff_neq_bot.mp $ assume t ht,
  let ⟨t₁, ht₁, t₂, ht₂, ht⟩ := mem_inf_sets.mp ht in
  let ⟨hu, hl⟩ := mem_nhds_orderable_dest ht₁ in
  by_cases
    (assume h : a = a',
      have a ∈ t₁, from mem_of_nhds ht₁,
      have a ∈ t₂, from ht₂ $ by rwa [h],
      ne_empty_iff_exists_mem.mpr ⟨a, ht ⟨‹a ∈ t₁›, ‹a ∈ t₂›⟩⟩)
    (assume : a ≠ a',
      have a' < a, from lt_of_le_of_ne (ha.left _ ‹a' ∈ s›) this.symm,
      let ⟨l, hl, hlt₁⟩ := hl ⟨a', this⟩ in
      have ∃a'∈s, l < a',
        from classical.by_contradiction $ assume : ¬ ∃a'∈s, l < a',
          have ∀a'∈s, a' ≤ l, from assume a ha, not_lt.1 $ assume ha', this ⟨a, ha, ha'⟩,
          have ¬ l < a, from not_lt.2 $ ha.right _ this,
          this ‹l < a›,
      let ⟨a', ha', ha'l⟩ := this in
      have a' ∈ t₁, from hlt₁ _ ‹l < a'›  $ ha.left _ ha',
      ne_empty_iff_exists_mem.mpr ⟨a', ht ⟨‹a' ∈ t₁›, ht₂ ‹a' ∈ s›⟩⟩)

lemma nhds_principal_ne_bot_of_is_glb {a : α} {s : set α} (ha : is_glb s a) (hs : s ≠ ∅) :
  nhds a ⊓ principal s ≠ ⊥ :=
let ⟨a', ha'⟩ := exists_mem_of_ne_empty hs in
forall_sets_neq_empty_iff_neq_bot.mp $ assume t ht,
  let ⟨t₁, ht₁, t₂, ht₂, ht⟩ := mem_inf_sets.mp ht in
  let ⟨hu, hl⟩ := mem_nhds_orderable_dest ht₁ in
  by_cases
    (assume h : a = a',
      have a ∈ t₁, from mem_of_nhds ht₁,
      have a ∈ t₂, from ht₂ $ by rwa [h],
      ne_empty_iff_exists_mem.mpr ⟨a, ht ⟨‹a ∈ t₁›, ‹a ∈ t₂›⟩⟩)
    (assume : a ≠ a',
      have a < a', from lt_of_le_of_ne (ha.left _ ‹a' ∈ s›) this,
      let ⟨u, hu, hut₁⟩ := hu ⟨a', this⟩ in
      have ∃a'∈s, a' < u,
        from classical.by_contradiction $ assume : ¬ ∃a'∈s, a' < u,
          have ∀a'∈s, u ≤ a', from assume a ha, not_lt.1 $ assume ha', this ⟨a, ha, ha'⟩,
          have ¬ a < u, from not_lt.2 $ ha.right _ this,
          this ‹a < u›,
      let ⟨a', ha', ha'l⟩ := this in
      have a' ∈ t₁, from hut₁ _ (ha.left _ ha') ‹a' < u›,
      ne_empty_iff_exists_mem.mpr ⟨a', ht ⟨‹a' ∈ t₁›, ht₂ ‹a' ∈ s›⟩⟩)

lemma is_lub_of_mem_nhds {s : set α} {a : α} {f : filter α}
  (hsa : a ∈ upper_bounds s) (hsf : s ∈ f.sets) (hfa : f ⊓ nhds a ≠ ⊥) : is_lub s a :=
⟨hsa, assume b hb,
  not_lt.1 $ assume hba,
  have s ∩ {a | b < a} ∈ (f ⊓ nhds a).sets,
    from inter_mem_inf_sets hsf (mem_nhds_sets (is_open_lt' _) hba),
  let ⟨x, ⟨hxs, hxb⟩⟩ := inhabited_of_mem_sets hfa this in
  have b < b, from lt_of_lt_of_le hxb $ hb _ hxs,
  lt_irrefl b this⟩

lemma is_glb_of_mem_nhds {s : set α} {a : α} {f : filter α}
  (hsa : a ∈ lower_bounds s) (hsf : s ∈ f.sets) (hfa : f ⊓ nhds a ≠ ⊥) : is_glb s a :=
⟨hsa, assume b hb,
  not_lt.1 $ assume hba,
  have s ∩ {a | a < b} ∈ (f ⊓ nhds a).sets,
    from inter_mem_inf_sets hsf (mem_nhds_sets (is_open_gt' _) hba),
  let ⟨x, ⟨hxs, hxb⟩⟩ := inhabited_of_mem_sets hfa this in
  have b < b, from lt_of_le_of_lt (hb _ hxs) hxb,
  lt_irrefl b this⟩

lemma is_lub_of_is_lub_of_tendsto {f : α → β} {s : set α} {a : α} {b : β}
  (hf : ∀x∈s, ∀y∈s, x ≤ y → f x ≤ f y) (ha : is_lub s a) (hs : s ≠ ∅)
  (hb : tendsto f (nhds a ⊓ principal s) (nhds b)) : is_lub (f '' s) b :=
have hnbot : (nhds a ⊓ principal s) ≠ ⊥, from nhds_principal_ne_bot_of_is_lub ha hs,
have ∀a'∈s, ¬ b < f a',
  from assume a' ha' h,
  have {x | x < f a'} ∈ (nhds b).sets, from mem_nhds_sets (is_open_gt' _) h,
  let ⟨t₁, ht₁, t₂, ht₂, hs⟩ := mem_inf_sets.mp (hb this) in
  by_cases
    (assume h : a = a',
      have a ∈ t₁ ∩ t₂, from ⟨mem_of_nhds ht₁, ht₂ $ by rwa [h]⟩,
      have f a < f a', from hs this,
      lt_irrefl (f a') $ by rwa [h] at this)
    (assume h : a ≠ a',
      have a' < a, from lt_of_le_of_ne (ha.left _ ha') h.symm,
      have {x | a' < x} ∈ (nhds a).sets, from mem_nhds_sets (is_open_lt' _) this,
      have {x | a' < x} ∩ t₁ ∈ (nhds a).sets, from inter_mem_sets this ht₁,
      have ({x | a' < x} ∩ t₁) ∩ s ∈ (nhds a ⊓ principal s).sets,
        from inter_mem_inf_sets this (subset.refl s),
      let ⟨x, ⟨hx₁, hx₂⟩, hx₃⟩ := inhabited_of_mem_sets hnbot this in
      have hxa' : f x < f a', from hs ⟨hx₂, ht₂ hx₃⟩,
      have ha'x : f a' ≤ f x, from hf _ ha' _ hx₃ $ le_of_lt hx₁,
      lt_irrefl _ (lt_of_le_of_lt ha'x hxa')),
and.intro
  (assume b' ⟨a', ha', h_eq⟩, h_eq ▸ not_lt.1 $ this _ ha')
  (assume b' hb', le_of_tendsto hnbot hb tendsto_const_nhds $
      mem_inf_sets_of_right $ assume x hx, hb' _ $ mem_image_of_mem _ hx)

lemma is_glb_of_is_glb_of_tendsto {f : α → β} {s : set α} {a : α} {b : β}
  (hf : ∀x∈s, ∀y∈s, x ≤ y → f x ≤ f y) (ha : is_glb s a) (hs : s ≠ ∅)
  (hb : tendsto f (nhds a ⊓ principal s) (nhds b)) : is_glb (f '' s) b :=
have hnbot : (nhds a ⊓ principal s) ≠ ⊥, from nhds_principal_ne_bot_of_is_glb ha hs,
have ∀a'∈s, ¬ b > f a',
  from assume a' ha' h,
  have {x | x > f a'} ∈ (nhds b).sets, from mem_nhds_sets (is_open_lt' _) h,
  let ⟨t₁, ht₁, t₂, ht₂, hs⟩ := mem_inf_sets.mp (hb this) in
  by_cases
    (assume h : a = a',
      have a ∈ t₁ ∩ t₂, from ⟨mem_of_nhds ht₁, ht₂ $ by rwa [h]⟩,
      have f a > f a', from hs this,
      lt_irrefl (f a') $ by rwa [h] at this)
    (assume h : a ≠ a',
      have a' > a, from lt_of_le_of_ne (ha.left _ ha') h,
      have {x | a' > x} ∈ (nhds a).sets, from mem_nhds_sets (is_open_gt' _) this,
      have {x | a' > x} ∩ t₁ ∈ (nhds a).sets, from inter_mem_sets this ht₁,
      have ({x | a' > x} ∩ t₁) ∩ s ∈ (nhds a ⊓ principal s).sets,
        from inter_mem_inf_sets this (subset.refl s),
      let ⟨x, ⟨hx₁, hx₂⟩, hx₃⟩ := inhabited_of_mem_sets hnbot this in
      have hxa' : f x > f a', from hs ⟨hx₂, ht₂ hx₃⟩,
      have ha'x : f a' ≥ f x, from hf _ hx₃ _ ha' $ le_of_lt hx₁,
      lt_irrefl _ (lt_of_lt_of_le hxa' ha'x)),
and.intro
  (assume b' ⟨a', ha', h_eq⟩, h_eq ▸ not_lt.1 $ this _ ha')
  (assume b' hb', le_of_tendsto hnbot tendsto_const_nhds hb $
      mem_inf_sets_of_right $ assume x hx, hb' _ $ mem_image_of_mem _ hx)

lemma is_glb_of_is_lub_of_tendsto {f : α → β} {s : set α} {a : α} {b : β}
  (hf : ∀x∈s, ∀y∈s, x ≤ y → f y ≤ f x) (ha : is_lub s a) (hs : s ≠ ∅)
  (hb : tendsto f (nhds a ⊓ principal s) (nhds b)) : is_glb (f '' s) b :=
have hnbot : (nhds a ⊓ principal s) ≠ ⊥, from nhds_principal_ne_bot_of_is_lub ha hs,
have ∀a'∈s, ¬ b > f a',
  from assume a' ha' h,
  have {x | x > f a'} ∈ (nhds b).sets, from mem_nhds_sets (is_open_lt' _) h,
  let ⟨t₁, ht₁, t₂, ht₂, hs⟩ := mem_inf_sets.mp (hb this) in
  by_cases
    (assume h : a = a',
      have a ∈ t₁ ∩ t₂, from ⟨mem_of_nhds ht₁, ht₂ $ by rwa [h]⟩,
      have f a > f a', from hs this,
      lt_irrefl (f a') $ by rwa [h] at this)
    (assume h : a ≠ a',
      have a' < a, from lt_of_le_of_ne (ha.left _ ha') h.symm,
      have {x | a' < x} ∈ (nhds a).sets, from mem_nhds_sets (is_open_lt' _) this,
      have {x | a' < x} ∩ t₁ ∈ (nhds a).sets, from inter_mem_sets this ht₁,
      have ({x | a' < x} ∩ t₁) ∩ s ∈ (nhds a ⊓ principal s).sets,
        from inter_mem_inf_sets this (subset.refl s),
      let ⟨x, ⟨hx₁, hx₂⟩, hx₃⟩ := inhabited_of_mem_sets hnbot this in
      have hxa' : f x > f a', from hs ⟨hx₂, ht₂ hx₃⟩,
      have ha'x : f a' ≥ f x, from hf _ ha' _ hx₃ $ le_of_lt hx₁,
      lt_irrefl _ (lt_of_lt_of_le hxa' ha'x)),
and.intro
  (assume b' ⟨a', ha', h_eq⟩, h_eq ▸ not_lt.1 $ this _ ha')
  (assume b' hb', le_of_tendsto hnbot tendsto_const_nhds hb $
      mem_inf_sets_of_right $ assume x hx, hb' _ $ mem_image_of_mem _ hx)

end order_topology

section liminf_limsup

section ordered_topology
variables [semilattice_sup α] [topological_space α] [orderable_topology α]

lemma is_bounded_le_nhds (a : α) : (nhds a).is_bounded (≤) :=
match forall_le_or_exists_lt_sup a with
| or.inl h := ⟨a, univ_mem_sets' h⟩
| or.inr ⟨b, hb⟩ := ⟨b, ge_mem_nhds hb⟩
end

lemma is_bounded_under_le_of_tendsto {f : filter β} {u : β → α} {a : α}
  (h : tendsto u f (nhds a)) : f.is_bounded_under (≤) u :=
is_bounded_of_le h (is_bounded_le_nhds a)

lemma is_cobounded_ge_nhds (a : α) : (nhds a).is_cobounded (≥) :=
is_cobounded_of_is_bounded nhds_neq_bot (is_bounded_le_nhds a)

lemma is_cobounded_under_ge_of_tendsto {f : filter β} {u : β → α} {a : α}
  (hf : f ≠ ⊥) (h : tendsto u f (nhds a)) : f.is_cobounded_under (≥) u :=
is_cobounded_of_is_bounded (map_ne_bot hf) (is_bounded_under_le_of_tendsto h)

end ordered_topology

section ordered_topology
variables [semilattice_inf α] [topological_space α] [orderable_topology α]

lemma is_bounded_ge_nhds (a : α) : (nhds a).is_bounded (≥) :=
match forall_le_or_exists_lt_inf a with
| or.inl h := ⟨a, univ_mem_sets' h⟩
| or.inr ⟨b, hb⟩ := ⟨b, le_mem_nhds hb⟩
end

lemma is_bounded_under_ge_of_tendsto {f : filter β} {u : β → α} {a : α}
  (h : tendsto u f (nhds a)) : f.is_bounded_under (≥) u :=
is_bounded_of_le h (is_bounded_ge_nhds a)

lemma is_cobounded_le_nhds (a : α) : (nhds a).is_cobounded (≤) :=
is_cobounded_of_is_bounded nhds_neq_bot (is_bounded_ge_nhds a)

lemma is_cobounded_under_le_of_tendsto {f : filter β} {u : β → α} {a : α}
  (hf : f ≠ ⊥) (h : tendsto u f (nhds a)) : f.is_cobounded_under (≤) u :=
is_cobounded_of_is_bounded (map_ne_bot hf) (is_bounded_under_ge_of_tendsto h)

end ordered_topology

section conditionally_complete_linear_order
variables [conditionally_complete_linear_order α] [topological_space α] [orderable_topology α]

theorem lt_mem_sets_of_Limsup_lt {f : filter α} {b} (h : f.is_bounded (≤)) (l : f.Limsup < b) :
  {a | a < b} ∈ f.sets :=
let ⟨c, (h : {a : α | a ≤ c} ∈ f.sets), hcb⟩ :=
  exists_lt_of_cInf_lt (ne_empty_iff_exists_mem.2 h) l in
mem_sets_of_superset h $ assume a hac, lt_of_le_of_lt hac hcb

theorem gt_mem_sets_of_Liminf_gt {f : filter α} {b} (h : f.is_bounded (≥)) (l : f.Liminf > b) :
  {a | a > b} ∈ f.sets :=
let ⟨c, (h : {a : α | c ≤ a} ∈ f.sets), hbc⟩ :=
  exists_lt_of_lt_cSup (ne_empty_iff_exists_mem.2 h) l in
mem_sets_of_superset h $ assume a hca, lt_of_lt_of_le hbc hca

/-- If the liminf and the limsup of a filter coincide, then this filter converges to
their common value, at least if the filter is eventually bounded above and below. -/
theorem le_nhds_of_Limsup_eq_Liminf {f : filter α} {a : α}
  (hl : f.is_bounded (≤)) (hg : f.is_bounded (≥)) (hs : f.Limsup = a) (hi : f.Liminf = a) :
  f ≤ nhds a :=
tendsto_orderable.2 $ and.intro
  (assume b hb, gt_mem_sets_of_Liminf_gt hg $ hi.symm ▸ hb)
  (assume b hb, lt_mem_sets_of_Limsup_lt hl $ hs.symm ▸ hb)

theorem Limsup_nhds (a : α) : Limsup (nhds a) = a :=
cInf_intro (ne_empty_iff_exists_mem.2 $ is_bounded_le_nhds a)
  (assume a' (h : {n : α | n ≤ a'} ∈ (nhds a).sets), show a ≤ a', from @mem_of_nhds α _ a _ h)
  (assume b (hba : a < b), show ∃c (h : {n : α | n ≤ c} ∈ (nhds a).sets), c < b, from
    match dense_or_discrete hba with
    | or.inl ⟨c, hac, hcb⟩ := ⟨c, ge_mem_nhds hac, hcb⟩
    | or.inr ⟨_, h⟩        := ⟨a, (nhds a).sets_of_superset (gt_mem_nhds hba) h, hba⟩
    end)

theorem Liminf_nhds (a : α) : Liminf (nhds a) = a :=
cSup_intro (ne_empty_iff_exists_mem.2 $ is_bounded_ge_nhds a)
  (assume a' (h : {n : α | a' ≤ n} ∈ (nhds a).sets), show a' ≤ a, from mem_of_nhds h)
  (assume b (hba : b < a), show ∃c (h : {n : α | c ≤ n} ∈ (nhds a).sets), b < c, from
    match dense_or_discrete hba with
    | or.inl ⟨c, hbc, hca⟩ := ⟨c, le_mem_nhds hca, hbc⟩
    | or.inr ⟨h, _⟩        := ⟨a, (nhds a).sets_of_superset (lt_mem_nhds hba) h, hba⟩
    end)

/-- If a filter is converging, its limsup coincides with its limit. -/
theorem Liminf_eq_of_le_nhds {f : filter α} {a : α} (hf : f ≠ ⊥) (h : f ≤ nhds a) : f.Liminf = a :=
have hb_ge : is_bounded (≥) f, from is_bounded_of_le h (is_bounded_ge_nhds a),
have hb_le : is_bounded (≤) f, from is_bounded_of_le h (is_bounded_le_nhds a),
le_antisymm
  (calc f.Liminf ≤ f.Limsup : Liminf_le_Limsup hf hb_le hb_ge
    ... ≤ (nhds a).Limsup :
      Limsup_le_Limsup_of_le h (is_cobounded_of_is_bounded hf hb_ge) (is_bounded_le_nhds a)
    ... = a : Limsup_nhds a)
  (calc a = (nhds a).Liminf : (Liminf_nhds a).symm
    ... ≤ f.Liminf :
      Liminf_le_Liminf_of_le h (is_bounded_ge_nhds a) (is_cobounded_of_is_bounded hf hb_le))

/-- If a filter is converging, its liminf coincides with its limit. -/
theorem Limsup_eq_of_le_nhds {f : filter α} {a : α} (hf : f ≠ ⊥) (h : f ≤ nhds a) : f.Limsup = a :=
have hb_ge : is_bounded (≥) f, from is_bounded_of_le h (is_bounded_ge_nhds a),
le_antisymm
  (calc f.Limsup ≤ (nhds a).Limsup :
    Limsup_le_Limsup_of_le h (is_cobounded_of_is_bounded hf hb_ge) (is_bounded_le_nhds a)
    ... = a : Limsup_nhds a)
  (calc a = f.Liminf : (Liminf_eq_of_le_nhds hf h).symm
    ... ≤ f.Limsup : Liminf_le_Limsup hf (is_bounded_of_le h (is_bounded_le_nhds a)) hb_ge)

end conditionally_complete_linear_order

end liminf_limsup

end orderable_topology

lemma orderable_topology_of_nhds_abs
  {α : Type*} [decidable_linear_ordered_comm_group α] [topological_space α]
  (h_nhds : ∀a:α, nhds a = (⨅r>0, principal {b | abs (a - b) < r})) : orderable_topology α :=
orderable_topology.mk $ eq_of_nhds_eq_nhds $ assume a:α, le_antisymm_iff.mpr
begin
  simp [infi_and, topological_space.nhds_generate_from,
        h_nhds, le_infi_iff, -le_principal_iff, and_comm],
  refine ⟨λ s ha b hs, _, λ r hr, _⟩,
  { rcases hs with rfl | rfl,
    { refine infi_le_of_le (a - b)
        (infi_le_of_le (lt_sub_left_of_add_lt $ by simpa using ha) $
          principal_mono.mpr $ assume c (hc : abs (a - c) < a - b), _),
      have : a - c < a - b := lt_of_le_of_lt (le_abs_self _) hc,
      exact lt_of_neg_lt_neg (lt_of_add_lt_add_left this) },
    { refine infi_le_of_le (b - a)
        (infi_le_of_le (lt_sub_left_of_add_lt $ by simpa using ha) $
          principal_mono.mpr $ assume c (hc : abs (a - c) < b - a), _),
      have : abs (c - a) < b - a, {rw abs_sub; simpa using hc},
      have : c - a < b - a := lt_of_le_of_lt (le_abs_self _) this,
      exact lt_of_add_lt_add_right this } },
  { have h : {b | abs (a + -b) < r} = {b | a - r < b} ∩ {b | b < a + r},
      from set.ext (assume b,
        by simp [abs_lt, -sub_eq_add_neg, (sub_eq_add_neg _ _).symm,
          sub_lt, lt_sub_iff_add_lt, and_comm, sub_lt_iff_lt_add']),
    rw [h, ← inf_principal],
    apply le_inf _ _,
    { exact infi_le_of_le {b : α | a - r < b} (infi_le_of_le (sub_lt_self a hr) $
        infi_le_of_le (a - r) $ infi_le _ (or.inl rfl)) },
    { exact infi_le_of_le {b : α | b < a + r} (infi_le_of_le (lt_add_of_pos_right _ hr) $
        infi_le_of_le (a + r) $ infi_le _ (or.inr rfl)) } }
end


import Lean

open Lean Meta in
def printMutualBlock (declName : Name) : MetaM Unit := do
  IO.println (← getConstInfo declName).all

mutual
  def even : Nat → Bool
    | 0 => true
    | x+1 => !odd x
  def odd : Nat → Bool
    | 0 => false
    | x+1 => !even x
end

#eval printMutualBlock ``even
#eval printMutualBlock ``odd

namespace Ex1
mutual
  partial def f (x : Nat) : Nat :=
    if x < 10 then g x + 1 else 0
  partial def g (x : Nat) : Nat :=
    f (x * 3 / 2)
  partial def h (x : Nat) : Nat :=
    f x
end

#eval printMutualBlock ``f
#eval printMutualBlock ``g
-- Recall that Lean breaks a mutual block into strongly connected components
#eval printMutualBlock ``h

end Ex1

namespace Ex2
mutual
  unsafe def f (x : Nat) : Nat :=
    if x < 10 then g x + 1 else 0
  unsafe def g (x : Nat) : Nat :=
    f (x * 3 / 2)
  unsafe def h (x : Nat) : Nat :=
    f x
end

#eval printMutualBlock ``f
#eval printMutualBlock ``g
-- Recall that Lean breaks a mutual block into strongly connected components
#eval printMutualBlock ``h
end Ex2

inductive Foo where
  | text : String → Foo
  | element : List Foo → Foo

namespace Foo

mutual
  @[simp] def textLengthList : List Foo → Nat
    | [] => 0
    | f::fs => textLength f + textLengthList fs

  @[simp] def textLength : Foo → Nat
    | text s => s.length
    | element children => textLengthList children
end

def concat (f₁ f₂ : Foo) : Foo :=
  Foo.element [f₁, f₂]

theorem textLength_concat (f₁ f₂ : Foo) : textLength (concat f₁ f₂) = textLength f₁ + textLength f₂ := by
  simp [concat]

mutual
  @[simp] def flatList : List Foo → List String
    | [] => []
    | f :: fs => flat f ++ flatList fs

  @[simp] def flat : Foo → List String
    | text s => [s]
    | element children => flatList children
end

def listStringLen (xs : List String) : Nat :=
  xs.foldl (init := 0) fun sum s => sum + s.length

attribute [simp] List.foldl

theorem foldl_init (s : Nat) (xs : List String) :  (xs.foldl (init := s) fun sum s => sum + s.length) = s + (xs.foldl (init := 0) fun sum s => sum + s.length) := by
  induction xs generalizing s with
  | nil => simp
  | cons x xs ih => simp_arith [ih x.length, ih (s + x.length)]

theorem listStringLen_append (xs ys : List String) : listStringLen (xs ++ ys) = listStringLen xs + listStringLen ys := by
  simp [listStringLen]
  induction xs with
  | nil => simp
  | cons x xs ih => simp_arith [foldl_init x.length, ih]

mutual
  theorem listStringLen_flat (f : Foo) : listStringLen (flat f) = textLength f := by
    match f with
    | text s => simp [listStringLen]
    | element cs => simp [listStringLen_flatList cs]

  theorem listStringLen_flatList (cs : List Foo) : listStringLen (flatList cs) = textLengthList cs := by
    match cs with
    | [] => simp
    | f :: fs => simp [listStringLen_append, listStringLen_flatList fs, listStringLen_flat f]
end

#eval printMutualBlock ``listStringLen_flat

end Foo