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

import tactic

open set

variable {α : Type*}
variables (s t u : set α)

example : s ∩ (s ∪ t) = s :=
begin
  apply subset.antisymm,
  { rintros x ⟨xs,_⟩,
    exact xs },
  { rintros x xs,
    split,
    { exact xs },
    { apply mem_union_left,
      exact xs }},
end

-- Prueba
-- ======

/-
α : Type u_1,
s t : set α
⊢ s ∩ (s ∪ t) = s
  >> apply subset.antisymm,
| ⊢ s ∩ (s ∪ t) ⊆ s
|   >> { rintros x ⟨xs,_⟩,
| x : α,
| xs : x ∈ s,
| a_right : x ∈ s ∪ t
| ⊢ x ∈ s
|   >>   exact xs },
⊢ s ⊆ s ∩ (s ∪ t)
  >> { rintros x xs
x : α,
xs : x ∈ s
⊢ x ∈ s ∩ (s ∪ t),
  >>   split,
| ⊢ x ∈ s
|   >>   { exact xs },
⊢ x ∈ s ∪ t
  >>   { apply mem_union_left,
⊢ x ∈ s
  >>     exact xs }},
no goals
-/

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

example : s ∪ (s ∩ t) = s :=
begin
  apply subset.antisymm,
  { rintros x (xs | ⟨xs,xt⟩),
    { exact xs },
    { exact xs }},
  { rintros x xs,
    left,
    exact xs },
end

-- Prueba
-- ======

/-
α : Type u_1,
s t : set α
⊢ s ∪ s ∩ t = s
  >> apply subset.antisymm,
| ⊢ s ∪ s ∩ t ⊆ s
|   >> { rintros x (xs | ⟨xs,xt⟩),
| | x : α,
| | xs : x ∈ s
| | ⊢ x ∈ s
| |  >>   { exact xs },
| x : α,
| xs : x ∈ s,
| xt : x ∈ t
| ⊢ x ∈ s
|   >>   { exact xs }},
⊢ s ⊆ s ∪ s ∩ t
  >> { rintros x xs,
x : α,
xs : x ∈ s
⊢ x ∈ s ∪ s ∩ t
  >>   left,
⊢ x ∈ s
  >>   exact xs },
no goals
-/

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    (s \ t) ∪ t = s ∪ t
-- ----------------------------------------------------------------------

example : (s \ t) ∪ t = s ∪ t :=
begin
  ext x,
  split,
  { rintros (⟨xs, xnt⟩ | xt),
    { left,
      exact xs },
    { right,
    exact xt }},
  rintros (xs | xt),
  { classical,
    by_cases xt : x ∈ t,
    { right,
      exact xt },
    { left,
      exact ⟨xs, xt⟩ }},
  { right,
    exact xt },

end

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    (s \ t) ∪ (t \ s) = (s ∪ t) \ (s ∩ t)
-- ----------------------------------------------------------------------

example : (s \ t) ∪ (t \ s) = (s ∪ t) \ (s ∩ t) :=
begin
  apply  subset.antisymm,
  { rintros x (⟨xs,xnt⟩ | ⟨xt,xns⟩),
    { split,
      { exact mem_union_left t xs },
      { intro h,
        apply xnt,
        exact mem_of_mem_inter_right h }},
    { split,
      { exact mem_union_right s xt },
      { intro h,
        apply xns,
        exact mem_of_mem_inter_left h }}},
  { rintros x ⟨xs | xt,xnst⟩,
    { left,
      split,
      { exact xs },
      { intro h,
        apply xnst,
        exact mem_sep xs h }},
    { right,
      split,
      { exact xt },
      { intro h,
        apply xnst,
        exact mem_sep h xt }}},
end

-- Prueba
-- ======

/-
α : Type u_1,
s t : set α
⊢ s \ t ∪ t \ s = (s ∪ t) \ (s ∩ t)
  apply  subset.antisymm,
| ⊢ s \ t ∪ t \ s ⊆ (s ∪ t) \ (s ∩ t)
|   { rintros x (⟨xs,xnt⟩ | ⟨xt,xns⟩),
| | x : α,
| | xs : x ∈ s,
| | xnt : x ∉ t
| | ⊢ x ∈ (s ∪ t) \ (s ∩ t)
| |     { split,
| | | ⊢ x ∈ s ∪ t
| | |       { exact mem_union_left t xs },
| | ⊢ (λ (a : α), a ∉ s ∩ t) x
| |       { intro h,
| | h : x ∈ s ∩ t
| | ⊢ false
| |         apply xnt,
| | ⊢ x ∈ t
| |         exact mem_of_mem_inter_right h }},
| x : α,
| xt : x ∈ t,
| xns : x ∉ s
| ⊢ x ∈ (s ∪ t) \ (s ∩ t)
|     { split,
| | ⊢ x ∈ s ∪ t
| |       { exact mem_union_right s xt },
| ⊢ (λ (a : α), a ∉ s ∩ t) x
|       { intro h,
| h : x ∈ s ∩ t
| ⊢ false
|         apply xns,
| ⊢ x ∈ s
|         exact mem_of_mem_inter_left h }}},
⊢ (s ∪ t) \ (s ∩ t) ⊆ s \ t ∪ t \ s
  { rintros x ⟨xs | xt,xnst⟩,
| x : α,
| xnst : x ∉ s ∩ t,
| xs : x ∈ s
| ⊢ x ∈ s \ t ∪ t \ s
|     { left,
| ⊢ x ∈ s \ t
|       split,
| ⊢ x ∈ s
| |       { exact xs },
| ⊢ (λ (a : α), a ∉ t) x
|       { intro h,
| h : x ∈ t
| ⊢ false
|         apply xnst,
| ⊢ x ∈ s ∩ t
|         exact mem_sep xs h }},
⊢ x ∈ s \ t ∪ t \ s
    { right,
⊢ x ∈ t \ s
      split,
| ⊢ x ∈ t
|       { exact xt },
⊢ (λ (a : α), a ∉ s) x
      { intro h,
h : x ∈ s
⊢ false
        apply xnst,
⊢ x ∈ s ∩ t
        exact mem_sep h xt }}},
no goals
-/

-- #lint


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import data.polynomial.derivative

/-!
# Theory of univariate polynomials

The main def is `binom_expansion`.
-/

noncomputable theory

namespace polynomial
universes u v w x y z
variables {R : Type u} {S : Type v} {T : Type w} {ι : Type x} {k : Type y} {A : Type z}
  {a b : R} {m n : ℕ}

section identities

/- @TODO: pow_add_expansion and pow_sub_pow_factor are not specific to polynomials.
  These belong somewhere else. But not in group_power because they depend on tactic.ring_exp

Maybe use data.nat.choose to prove it.
 -/

def pow_add_expansion {R : Type*} [comm_semiring R] (x y : R) : ∀ (n : ℕ),
  {k // (x + y)^n = x^n + n*x^(n-1)*y + k * y^2}
| 0 := ⟨0, by simp⟩
| 1 := ⟨0, by simp⟩
| (n+2) :=
  begin
    cases pow_add_expansion (n+1) with z hz,
    existsi x*z + (n+1)*x^n+z*y,
    calc (x + y) ^ (n + 2) = (x + y) * (x + y) ^ (n + 1) : by ring_exp
    ... = (x + y) * (x ^ (n + 1) + ↑(n + 1) * x ^ (n + 1 - 1) * y + z * y ^ 2) : by rw hz
    ... = x ^ (n + 2) + ↑(n + 2) * x ^ (n + 1) * y + (x*z + (n+1)*x^n+z*y) * y ^ 2 :
      by { push_cast, ring_exp! }
  end

variables [comm_ring R]

private def poly_binom_aux1 (x y : R) (e : ℕ) (a : R) :
  {k : R // a * (x + y)^e = a * (x^e + e*x^(e-1)*y + k*y^2)} :=
begin
  existsi (pow_add_expansion x y e).val,
  congr,
  apply (pow_add_expansion _ _ _).property
end

private lemma poly_binom_aux2 (f : polynomial R) (x y : R) :
  f.eval (x + y) = f.sum (λ e a, a * (x^e + e*x^(e-1)*y + (poly_binom_aux1 x y e a).val*y^2)) :=
begin
  unfold eval eval₂, congr' with n z,
  apply (poly_binom_aux1 x y _ _).property
end

private lemma poly_binom_aux3 (f : polynomial R) (x y : R) : f.eval (x + y) =
  f.sum (λ e a, a * x^e) +
  f.sum (λ e a, (a * e * x^(e-1)) * y) +
  f.sum (λ e a, (a *(poly_binom_aux1 x y e a).val)*y^2) :=
by rw poly_binom_aux2; simp [left_distrib, finsupp.sum_add, mul_assoc]

def binom_expansion (f : polynomial R) (x y : R) :
  {k : R // f.eval (x + y) = f.eval x + (f.derivative.eval x) * y + k * y^2} :=
begin
  existsi f.sum (λ e a, a *((poly_binom_aux1 x y e a).val)),
  rw poly_binom_aux3,
  congr,
  { rw [←eval_eq_sum], },
  { rw derivative_eval, symmetry,
    apply finsupp.sum_mul },
  { symmetry, apply finsupp.sum_mul }
end

def pow_sub_pow_factor (x y : R) : Π (i : ℕ), {z : R // x^i - y^i = z * (x - y)}
| 0 := ⟨0, by simp⟩
| 1 := ⟨1, by simp⟩
| (k+2) :=
  begin
    cases @pow_sub_pow_factor (k+1) with z hz,
    existsi z*x + y^(k+1),
    calc x ^ (k + 2) - y ^ (k + 2)
        = x * (x ^ (k + 1) - y ^ (k + 1)) + (x * y ^ (k + 1) - y ^ (k + 2)) : by ring_exp
    ... = x * (z * (x - y)) + (x * y ^ (k + 1) - y ^ (k + 2)) : by rw hz
    ... = (z * x + y ^ (k + 1)) * (x - y) : by ring_exp
  end

def eval_sub_factor (f : polynomial R) (x y : R) :
  {z : R // f.eval x - f.eval y = z * (x - y)} :=
begin
  refine ⟨f.sum (λ i r, r * (pow_sub_pow_factor x y i).val), _⟩,
  delta eval eval₂,
  rw ← finsupp.sum_sub,
  rw finsupp.sum_mul,
  delta finsupp.sum,
  congr' with i r, dsimp,
  rw [mul_assoc, ←(pow_sub_pow_factor x y _).prop, mul_sub],
end

end identities

end polynomial


import tactic

/-!

# Equivalence relations are the same as partitions

In this file we prove that there's a bijection between
the equivalence relations on a type, and the partitions of a type.

## Overview

Say `α` is a type, and `R : α → α → Prop` is a binary relation on `α`.
The following things are already in Lean:

`reflexive R := ∀ (x : α), R x x`
`symmetric R := ∀ ⦃x y : α⦄, R x y → R y x`
`transitive R := ∀ ⦃x y z : α⦄, R x y → R y z → R x z`

`equivalence R := reflexive R ∧ symmetric R ∧ transitive R`

In the file below, we will define partitions of `α` and "build some
interface" (i.e. prove some propositions). We will define
equivalence classes and do the same thing.
Finally, we will prove that there's a bijection between
equivalence relations on `α` and partitions of `α`.

-/

/-
# Partitions

## Definition of a partition

Let `α` be a type. A *partition* on `α` is defined to be
the following data:

1) A set C of subsets of α, called "blocks".
2) A hypothesis (i.e. a proof!) that all the blocks are non-empty.
3) A hypothesis that every term of type α is in one of the blocks.
4) A hypothesis that two blocks with non-empty intersection are equal.
-/

@[ext] structure partition (α : Type) :=
(C : set (set α))
(Hnonempty : ∀ X ∈ C, (X : set α).nonempty)
(Hcover : ∀ a, ∃ X ∈ C, a ∈ X)
(Hdisjoint : ∀ X Y ∈ C, (X ∩ Y : set α).nonempty → X = Y)

/-

## Basic interface for partitions

Here's the way notation works. If `α` is a type (i.e. a set)
then a term `P` of type `partition α` is a partition of `α`,
that is, a set of disjoint nonempty subsets of `α` whose union is `α`.

The collection of sets underlying `P` is `P.C`, the proof that
they're all nonempty is `P.Hnonempty` and so on.

-/

namespace partition

variables {α : Type} {P : partition α } {X Y : set α}

theorem eq_of_mem (hX : X ∈ P.C) (hY : Y ∈ P.C) {a : α} (haX : a ∈ X) (haY : a ∈ Y) : X = Y := by
begin

  --apply P.Hdisjoint _ _ hX hY ⟨a, haX, haY⟩,

  /-
  This may be a good time to explain all the underscores, brackets and commas
  You can think of P.Hdisjoint as a function that takes some arguments and returns a proof
  that two distinct elements of a partition are distjoint.
  Here we need to provide two sets, a proof they belong to P.C, and a proof their intersection is nonempty
  `_` asks Lean to infer the appropriate value. Here it's very simple.
  It guesses that the two sets are X,Y
  Together with hX hY we prove the part - X Y ∈ C
  `⟨stuff⟩` is a bit more complicated (i.e. I don't know enough type theory to really understand it)
  In essence it uses the terms you provide to construct a term of another type. You don't need to specify the type
  Lean infers it on its own. Now it gets wild
  Lean can in fact construct a proof of `(X ∩ Y : set α).nonempty` using these terms
  'How the hell?' you may ask. This comes down to how `nonempty` is defined in Lean.
  It's not immediately visible in the statement of the goal
  So how to come up with this thing?
  Use `library_search`. It will come up with all sorts of slick one-liners that utilise the power of Lean's type system
  Or if you want to understand every step, do this :
  -/
  apply P.Hdisjoint X Y hX hY,
  --now we may prove the non empty-interseciton 'manually'
  refine set.nonempty_def.mpr _,
  --bingo! We rewrote the goal using the definition of a non-empty set
  -- We can now complete with `use ⟨a, haX, haY⟩`,
  --Or if you REALLY want to understand everything under the hood, do this step by step
  use a,
  use ⟨haX, haY⟩,
  --The last step uses terms of the two types `a ∈ X, a ∈ Y` to construct a term of type `a ∈ X ∩ Y`
  --If it's still not clear how this works, try writing `rw set.inter_def` after `use a` instead
end

--Let's return to doing honest work instead of proving the same thing in 10 ways

/-- If a is in two blocks X and Y, and if b is in X,
  then b is in Y (as X=Y) -/
theorem mem_of_mem (hX : X ∈ P.C) (hY : Y ∈ P.C) {a b : α}
  (haX : a ∈ X) (haY : a ∈ Y) (hbX : b ∈ X) : b ∈ Y :=
begin
  -- you might want to start with `have hXY : X = Y`
  -- and prove it from the previous lemma
  sorry,
end

/-- Every term of type `α` is in one of the blocks for a partition `P`. -/
theorem mem_block (a : α) : ∃ X : set α, X ∈ P.C ∧ a ∈ X :=
begin
  -- an interesting way to start is
  -- `obtain ⟨X, hX, haX⟩ := P.Hcover a,`

  sorry,
end

end partition

/-
# Equivalence classes
-/

section equivalence_classes

/-
## Definition of equivalence classes
-/

-- Notation and variables for the equivalence class section:

-- let α be a type, and let R be a binary relation on R.
variables {α : Type} (R : α → α → Prop)

-- Note for me to make sure everyone understands why R is a binary relation

/-- The equivalence class of `a` is the set of `b` related to `a`. -/
def cl (a : α) :=
{b : α | R b a}

/-

## Basic lemmas about equivalence classes

-/
/-- Useful for rewriting -- `b` is in the equivalence class of `a` iff
`b` is related to `a`. True by definition. -/

--Can you see why this is useful?
theorem mem_cl_iff {a b : α} : b ∈ cl R a ↔ R b a :=
begin
  -- true by definition
  refl
end

-- Assume now that R is an equivalence relation.
variables {R} (hR : equivalence R)
include hR

/-- x is in cl(x) -/
lemma mem_cl_self (a : α) :
  a ∈ cl R a :=
begin
  -- Note that `hR : equivalence R` is a package of three things.
  -- You can extract the things with
  -- `rcases hR with ⟨hrefl, hsymm, htrans⟩,` or
  -- `obtain ⟨hrefl, hsymm, htrans⟩ := hR,`
  sorry,

end

--We're slowly entering the territory of theorems that take more than one sentence to prove in normal math.
--Apart from consulting `suggest` and `library_search` it's good to think
-- about how you would prove this with pen and paper and try to translate it
lemma cl_sub_cl_of_mem_cl {a b : α} :
  a ∈ cl R b →
  cl R a ⊆ cl R b :=
begin
  -- remember `set.subset_def` says `X ⊆ Y ↔ ∀ a, a ∈ X → a ∈ Y
  sorry,

end

lemma cl_eq_cl_of_mem_cl {a b : α} :
  a ∈ cl R b →
  cl R a = cl R b :=
begin
  -- remember `set.subset.antisymm` says `X ⊆ Y → Y ⊆ X → X = Y`
  sorry,
end

end equivalence_classes
/-
# The theorem

Let `α` be a type (i.e. a collection of stuff).

There is a bijection between equivalence relations on `α` and
partitions of `α`.

We prove this by writing down constructions in each direction
and proving that the constructions are two-sided inverses of one another.
-/

open partition

example (α : Type) : {R : α → α → Prop // equivalence R} ≃ partition α :=
-- We define constructions (functions!) in both directions and prove that
-- one is a two-sided inverse of the other
{ -- Here is the first construction, from equivalence
  -- relations to partitions.
  -- Let R be an equivalence relation.
  to_fun := λ R, {
    -- Let C be the set of equivalence classes for R.
    C := { B : set α | ∃ x : α, B = cl R.1 x},
    -- I claim that C is a partition. We need to check the three
    -- hypotheses for a partition (`Hnonempty`, `Hcover` and `Hdisjoint`),
    -- so we need to supply three proofs.
    Hnonempty := begin
      sorry,
    end,

    Hcover := begin
      cases R with R hR,
      -- The equivalence classes cover α
      show ∀ (a : α), ∃ (X : set α) (H : ∃ (b : α), X = cl R b), a ∈ X,
      sorry,
    end,
    Hdisjoint := begin
      cases R with R hR,
      -- If two equivalence classes overlap, they are equal.
      show ∀ (X Y : set α), (∃ (a : α), X = cl R a) →
        (∃ (b : α), Y = cl _ b) → (X ∩ Y).nonempty → X = Y,
      sorry,
    end },
  -- Conversely, say P is an partition.
  inv_fun := λ P,
    -- Let's define a binary relation `R` thus:
    --  `R a b` iff *every* block containing `a` also contains `b`.
    -- Because only one block contains a, this will work,
    -- and it turns out to be a nice way of thinking about it.
    ⟨λ a b, ∀ X ∈ P.C, a ∈ X → b ∈ X, begin
      -- I claim this is an equivalence relation.
    split,
    { -- It's reflexive
      show ∀ (a : α)
        (X : set α), X ∈ P.C → a ∈ X → a ∈ X,
      sorry,
    },
    split,
    { -- it's symmetric
      show ∀ (a b : α),
        (∀ (X : set α), X ∈ P.C → a ∈ X → b ∈ X) →
         ∀ (X : set α), X ∈ P.C → b ∈ X → a ∈ X,
      sorry,
    },
    { -- it's transitive
      unfold transitive,
      show ∀ (a b c : α),
        (∀ (X : set α), X ∈ P.C → a ∈ X → b ∈ X) →
        (∀ (X : set α), X ∈ P.C → b ∈ X → c ∈ X) →
         ∀ (X : set α), X ∈ P.C → a ∈ X → c ∈ X,
      sorry,
    }
  end⟩,
  -- If you start with the equivalence relation, and then make the partition
  -- and a new equivalence relation, you get back to where you started.
  left_inv := begin
    rintro ⟨R, hR⟩,
    -- Tidying up the mess...
    suffices : (λ (a b : α), ∀ (c : α), a ∈ cl R c → b ∈ cl R c) = R,
      simpa,
    -- ... you have to prove two binary relations are equal.
    ext a b,
    -- so you have to prove an if and only if.
    show (∀ (c : α), a ∈ cl R c → b ∈ cl R c) ↔ R a b,
    sorry,
  end,
  -- Similarly, if you start with the partition, and then make the
  -- equivalence relation, and then construct the corresponding partition
  -- into equivalence classes, you have the same partition you started with.
  right_inv := begin
    -- Let P be a partition
    intro P,
    -- It suffices to prove that a subset X is in the original partition
    -- if and only if it's in the one made from the equivalence relation.
    ext X,
    show (∃ (a : α), X = cl _ a) ↔ X ∈ P.C,
    dsimp only,
    sorry,
  end }


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

! This file was ported from Lean 3 source module topology.sheaves.sheaf_of_functions
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.PresheafOfFunctions
import Mathbin.Topology.Sheaves.SheafCondition.UniqueGluing

/-!
# Sheaf conditions for presheaves of (continuous) functions.

We show that
* `Top.presheaf.to_Type_is_sheaf`: not-necessarily-continuous functions into a type form a sheaf
* `Top.presheaf.to_Types_is_sheaf`: in fact, these may be dependent functions into a type family

For
* `Top.sheaf_to_Top`: continuous functions into a topological space form a sheaf
please see `topology/sheaves/local_predicate.lean`, where we set up a general framework
for constructing sub(pre)sheaves of the sheaf of dependent functions.

## Future work
Obviously there's more to do:
* sections of a fiber bundle
* various classes of smooth and structure preserving functions
* functions into spaces with algebraic structure, which the sections inherit
-/

open CategoryTheory

open CategoryTheory.Limits

open TopologicalSpace

open TopologicalSpace.Opens

universe u

noncomputable section

variable (X : TopCat.{u})

open TopCat

namespace TopCat.Presheaf

/-- We show that the presheaf of functions to a type `T`
(no continuity assumptions, just plain functions)
form a sheaf.

In fact, the proof is identical when we do this for dependent functions to a type family `T`,
so we do the more general case.
-/
theorem to_Types_isSheaf (T : X → Type u) : (presheafToTypes X T).IsSheaf :=
  isSheaf_of_isSheafUniqueGluing_types _ fun ι U sf hsf =>
    -- We use the sheaf condition in terms of unique gluing
  -- U is a family of open sets, indexed by `ι` and `sf` is a compatible family of sections.
  -- In the informal comments below, I'll just write `U` to represent the union.
  by
    -- Our first goal is to define a function "lifted" to all of `U`.
    -- We do this one point at a time. Using the axiom of choice, we can pick for each
    -- `x : supr U` an index `i : ι` such that `x` lies in `U i`
    choose index index_spec using fun x : supᵢ U => opens.mem_supr.mp x.2
    -- Using this data, we can glue our functions together to a single section
    let s : ∀ x : supᵢ U, T x := fun x => sf (index x) ⟨x.1, index_spec x⟩
    refine' ⟨s, _, _⟩
    · intro i
      ext x
      -- Now we need to verify that this lifted function restricts correctly to each set `U i`.
      -- Of course, the difficulty is that at any given point `x ∈ U i`,
      -- we may have used the axiom of choice to pick a different `j` with `x ∈ U j`
      -- when defining the function.
      -- Thus we'll need to use the fact that the restrictions are compatible.
      convert congr_fun (hsf (index ⟨x, _⟩) i) ⟨x, ⟨index_spec ⟨x.1, _⟩, x.2⟩⟩
      ext
      rfl
    · -- Now we just need to check that the lift we picked was the only possible one.
      -- So we suppose we had some other gluing `t` of our sections
      intro t ht
      -- and observe that we need to check that it agrees with our choice
      -- for each `f : s .X` and each `x ∈ supr U`.
      ext x
      convert congr_fun (ht (index x)) ⟨x.1, index_spec x⟩
      ext
      rfl
#align Top.presheaf.to_Types_is_sheaf TopCat.Presheaf.to_Types_isSheaf

-- We verify that the non-dependent version is an immediate consequence:
/-- The presheaf of not-necessarily-continuous functions to
a target type `T` satsifies the sheaf condition.
-/
theorem to_Type_isSheaf (T : Type u) : (presheafToType X T).IsSheaf :=
  to_Types_isSheaf X fun _ => T
#align Top.presheaf.to_Type_is_sheaf TopCat.Presheaf.to_Type_isSheaf

end TopCat.Presheaf

namespace TopCat

/-- The sheaf of not-necessarily-continuous functions on `X` with values in type family
`T : X → Type u`.
-/
def sheafToTypes (T : X → Type u) : Sheaf (Type u) X :=
  ⟨presheafToTypes X T, Presheaf.to_Types_isSheaf _ _⟩
#align Top.sheaf_to_Types TopCat.sheafToTypes

/-- The sheaf of not-necessarily-continuous functions on `X` with values in a type `T`.
-/
def sheafToType (T : Type u) : Sheaf (Type u) X :=
  ⟨presheafToType X T, Presheaf.to_Type_isSheaf _ _⟩
#align Top.sheaf_to_Type TopCat.sheafToType

end TopCat


import orbit.basic

namespace mygroup

open classical function set mygroup.subgroup mygroup.group
variables {G : Type} [group G]

-- The normalizer of a subset of G is a subgroup of G
def normalizer_of_set (A : set G) : subgroup G :=
{ carrier := { g : G | ∀ n, n ∈ A ↔ g * n * g⁻¹ ∈ A },
  one_mem' := by intro a; rw [group.one_mul, group.one_inv, group.mul_one],
  mul_mem' := λ _ _ hx hy _, by rw [hy, hx]; simp [group.mul_assoc],
  inv_mem' := λ x hx a, by rw hx (x⁻¹ * a * x⁻¹⁻¹); simp [group.mul_assoc] }

lemma mem_normalizer_of_set_iff [group G] {H : subgroup G} (x : G):
  x ∈ normalizer_of_set H.carrier ↔ ∀ k : G, k ∈ H ↔ x * k * x⁻¹ ∈ H := by refl

def normalizer (H : subgroup G) := stabilizer (conjugation_action) H

lemma mem_normalizer_def  {H : subgroup G} (x : G) :
  x ∈ normalizer H ↔ {k : G | ∃ (h : G) (H : h ∈ H), k = x * h * x⁻¹} = H :=
subgroup.ext'_iff.symm

lemma mem_normalizer_iff {H : subgroup G} (x : G):
  x ∈ normalizer H ↔ ∀ k : G, k ∈ H ↔ x * k * x⁻¹ ∈ H :=
begin
  rw mem_normalizer_def, split,
  { intros hx s,
    rw ext_iff at hx, specialize hx (x * s *x⁻¹) ,
    dsimp at hx, rw mem_coe' at hx, rw ← hx,
    split,
    { rintro hs, use [s, hs] },
    { rintro ⟨h, hh, hsx⟩, convert hh,
      exact group.mul_left_cancel x _ _ (mul_right_cancel x⁻¹ _ _ hsx) } },
  { intro hx, ext y, split,
    { rintro ⟨s, hs, rfl⟩, exact ( hx s ).1 hs},
    { intro hy, refine ⟨x⁻¹ * y * x, _, _⟩,
        { change y ∈ H at hy,
          convert (hx (x⁻¹ * y * x)).2 _,
          convert hy,
          simp [group.mul_assoc] },
        { simp [group.mul_assoc] } } }
end

lemma normalizer_eq_normalizer_of_set (H : subgroup G) :
  (normalizer H  : set G) = { g : G | ∀ n, n ∈ H ↔ g * n * g⁻¹ ∈ H } :=
by { ext, rw [subgroup.mem_coe', mem_normalizer_iff], refl }

lemma normalizer_of_set_eq_normalizer (H : subgroup G) :
  normalizer_of_set H.carrier = normalizer H :=
begin
  apply subgroup.ext'_iff.1,
  change (normalizer_of_set H.carrier).carrier = normalizer H,
  rw normalizer_eq_normalizer_of_set, refl,
end

lemma le_normalizer (H : subgroup G) : H ≤ normalizer H :=
begin
  intros g hg,
  apply (mem_normalizer_iff _).2,
  intro k,
  split,
    intro hk,
    apply H.mul_mem (H.mul_mem hg hk) (H.inv_mem hg),
  intro hk,
  suffices : g⁻¹ * (g * k * g⁻¹) * g ∈ H,
    convert this; simp [group.mul_assoc],
  apply H.mul_mem (H.mul_mem (H.inv_mem hg) hk) hg
end

end mygroup


/-
Copyright (c) 2022 Peter Nelson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Peter Nelson.
-/
import tactic
import .easy_lemmas
import order.minimal
import order.upper_lower
import order.modular_lattice
import .weak_compl
import order.atoms

/-!
# supermatroids

In this file we define a `supermatroid`, namely a nonempty `antichain` in a `lattice`
that satisfies certain incrementation axioms; its members are 'independent'.

## Main content

- `indep`, `dep`, `coindep`, `basis`, `circuit`, `cocircuit`, `spanning` : predicates of the form
  `α → Prop` for various supermatroid properties. Defining these as predicates rather than set
  enables dot notation, but sometimes we treat them as sets.

- the `order_dual` of a supermatroid `M` : If `M` is a matroid on a modular lattice, then `M` is
  also a matroid relative to the dual order.

## References

-/

universes u v

open set

variables {α : Type u}

section prelim

variables [preorder α] {s : set α}

def middle (s : set α) : Prop :=
  ∀ x y, x ≤ y → (s ∩ (Ici x)).nonempty → (s ∩ Iic y).nonempty → (s ∩ Icc x y).nonempty

def max_lower (s : set α) : Prop :=
  ∀ x y, ((lower_closure s) ∩ (Icc x y)).nonempty
    → (maximals (≤) ((lower_closure s) ∩ (Icc x y))).nonempty

def min_upper (s : set α) : Prop :=
  ∀ x y, ((upper_closure s) ∩ (Icc x y)).nonempty
    → (minimals (≤) ((upper_closure s) ∩ (Icc x y))).nonempty

lemma max_lower_dual (hs : min_upper s) : @max_lower αᵒᵈ _ s := λ x y, by {erw [dual_Icc], apply hs}

lemma min_upper_dual (hs : max_lower s) : @min_upper αᵒᵈ _ s := λ x y, by {erw [dual_Icc], apply hs}

lemma middle_dual (hs : middle s) : @middle αᵒᵈ _ s :=
λ x y h, by {erw [dual_Ici, dual_Iic, dual_Icc], exact flip (hs y x h)}

/-- A `supermatroid` is a nonempty antichain of `bases` in a lattice such that
  - for all `x ≤ y` such that `x` is below a basis and `y` is above a basis, the closed interval
    `[x,y]` contains a basis
  - For all `x,y` such that the interval `[x,y]` contains an element below a basis, this interval
    contains a maximal element that is below a basis.
-/
@[ext] structure supermatroid (α : Type u) [preorder α] :=
(basis                 : α → Prop)
(exists_basis          : ∃ b, basis b)
(basis_antichain       : is_antichain (≤) basis)
(basis_has_middle      : middle basis)
(basis_has_max_lower   : max_lower basis)

end prelim

namespace supermatroid

variables {i j b b' b'' x y c d r s t : α}

section partial_order

variables [partial_order α] {M : supermatroid α}

/-- An element below a basis is independent-/
def indep (M : supermatroid α) (x : α) := ∃ b, M.basis b ∧ x ≤ b

/-- An element above a basis is spanning-/
def spanning (M : supermatroid α) (x : α) :=  ∃ b, M.basis b ∧ b ≤ x

/-- An element that is not independent is depedent-/
@[reducible] def dep (M : supermatroid α) (x : α) := ¬ M.indep x

/-- A basis of `x` is a maximal element subject to being independent and below `x`-/
def basis_of (M : supermatroid α) (i x : α) :=
  M.indep i ∧ i ≤ x ∧ ∀ j, M.indep j → j ≤ x → i ≤ j → i = j

lemma basis_middle (hxy : x ≤ y) (hb : M.basis b) (hb' : M.basis b') (hxb : x ≤ b) (hb'y : b' ≤ y):
  ∃ b₀, M.basis b₀ ∧ x ≤ b₀ ∧ b₀ ≤ y :=
M.basis_has_middle _ _ hxy ⟨b,hb,hxb⟩ ⟨b',hb',hb'y⟩

@[simp] lemma mem_lower_set_basis_iff_indep : M.indep i ↔ i ∈ lower_closure M.basis :=
⟨λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩, λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩⟩

lemma indep.indep_of_le (hi : M.indep i) (hji : j ≤ i) : M.indep j :=
exists.elim hi (λ b hb, ⟨b, ⟨hb.1, hji.trans hb.2⟩⟩)

lemma bot_indep [order_bot α] (M : supermatroid α): M.indep ⊥ :=
exists.elim M.exists_basis (λ b h, ⟨b, h, bot_le⟩)

lemma indep.not_dep (hi : M.indep i) : ¬ M.dep i := by rwa [not_not]

lemma dep.not_indep (hx : M.dep x) : ¬ M.indep x := hx

lemma not_dep_iff_indep : ¬ M.dep i ↔ M.indep i  := by rw [not_not]

lemma indep_or_dep (i : α) : M.indep i ∨ M.dep i := em _

lemma not_indep_iff_dep : ¬ M.indep i ↔ M.dep i := iff.rfl

lemma dep.dep_of_lt (hx : M.dep x) (hxy : x ≤ y) : M.dep y :=
not_indep_iff_dep.mp (λ h, (hx.not_indep (h.indep_of_le hxy)).elim)

lemma indep.basis_of (hi : M.indep i) (hix : i ≤ x) (h : ∀ j, M.indep j → j ≤ x → i ≤ j → i = j) :
  M.basis_of i x :=
⟨hi,  hix, h⟩

lemma basis.indep (h : M.basis b) : M.indep b := ⟨b, h, rfl.le⟩

lemma exists_indep (M : supermatroid α) : ∃ i, M.indep i :=
exists.elim M.exists_basis (λ b hb, ⟨b, hb.indep⟩)

lemma basis.indep_of_le (hb : M.basis b) (hi : i ≤ b) : M.indep i := ⟨b,hb,hi⟩

lemma basis.eq_of_le_indep (h : M.basis b) (hbi : b ≤ i) (hi : M.indep i) : b = i :=
begin
  by_contradiction h_ne,
  obtain ⟨b',h₁,h₂⟩ := hi,
  exact M.basis_antichain h h₁ (λ hbb', h_ne (le_antisymm hbi (hbb'.symm ▸ h₂))) (hbi.trans h₂),
end

lemma basis.not_indep_of_lt (hb : M.basis b) (hbx : b < x) : ¬ M.indep x :=
λ hx,hbx.ne (hb.eq_of_le_indep hbx.le hx)

lemma basis.eq_of_basis_le (hb : M.basis b) (hx : M.basis x) (hxb : x ≤ b) : x = b :=
hx.eq_of_le_indep hxb hb.indep

lemma basis_iff_maximal_indep : M.basis b ↔ (maximals (≤) M.indep) b :=
⟨λ hb, ⟨hb.indep,λ i hi hbi, hb.eq_of_le_indep hbi hi⟩,
  by {rintro ⟨⟨b',hb',hbb'⟩, hb''⟩, rwa hb'' hb'.indep hbb'}⟩

lemma basis_of.indep (h : M.basis_of b x) : M.indep b := h.1

lemma basis_of.le (h : M.basis_of b x) : b ≤ x := h.2.1

lemma basis_of.not_indep_of_lt (h : M.basis_of b x) (hby : b < y) (hyx : y ≤ x) : ¬ M.indep y :=
begin
  rintros ⟨b',hb',hyb'⟩,
  obtain ⟨i,hix,hi⟩ := h,
  exact hby.ne (hi y (hb'.indep_of_le hyb') hyx hby.le),
end

lemma basis_of.eq_of_le_indep (h : M.basis_of b x) (hby : b ≤ y) (hYx : y ≤ x) (hy : M.indep y):
  b = y :=
by_contra (λ h', h.not_indep_of_lt (lt_of_le_of_ne hby h') hYx hy)

lemma basis_of.indep_of_le (hb : M.basis_of b x) (hib : i ≤ b)  : M.indep i :=
(hb.indep).indep_of_le hib

lemma basis.basis_of_top [order_top α] (hb : M.basis b) : M.basis_of b ⊤ :=
hb.indep.basis_of le_top (λ j hj hbj h, hb.eq_of_le_indep h hj)

lemma basis.lt_not_basis (hb : M.basis b) (hbx : b < x) : ¬ M.basis x :=
λ hx, (hb.not_indep_of_lt hbx hx.indep)

lemma basis.not_basis_of_lt (hb : M.basis b) (hxb : x < b) : ¬ M.basis x :=
λ h, (h.lt_not_basis hxb) hb

lemma indep.basis (hi : M.indep i) (hmax : ∀ j, M.indep j → i ≤ j → i = j) : M.basis i :=
by {obtain ⟨b,hb, hbi⟩ := hi, have := (hmax b hb.indep hbi), rwa ← this at hb}

lemma indep.increment (hi : M.indep i) (hi_nb : ¬M.basis i) (his : i ≤ s) (hs : M.spanning s):
  ∃ j, i < j ∧ j ≤ s ∧ M.indep j :=
begin
  obtain ⟨⟨bi, hbi, hibi⟩,⟨bs,hbs,hsbs⟩⟩ := ⟨hi,hs⟩,
  obtain ⟨b, hb, hib, hbs⟩ := basis_middle his hbi hbs hibi hsbs,
  exact ⟨b, hib.lt_of_ne' (λ h, hi_nb (h ▸ hb)),hbs,hb.indep⟩,
end

lemma basis_of.basis (hb : M.basis_of b x) (hx : M.spanning x) : M.basis b :=
begin
  by_contradiction h,
  obtain ⟨j,hbj,hjx,hj⟩ := hb.indep.increment h hb.le hx,
  exact hb.not_indep_of_lt hbj hjx hj,
end

lemma exists_basis_of [order_bot α] (M : supermatroid α) (x : α) : ∃ i, M.basis_of i x :=
begin
  obtain ⟨b,hb⟩ := M.exists_basis,
  obtain ⟨i,⟨⟨b,hb,hib⟩,-,hix⟩,hi'⟩ := M.basis_has_max_lower ⊥ x ⟨⊥,⟨b,hb,bot_le⟩,rfl.le, bot_le⟩,
  exact ⟨i,⟨b,hb,hib⟩,hix, λ j hj hjx hij, hi'
    ⟨(mem_lower_set_basis_iff_indep.mp hj),⟨bot_le, hjx⟩⟩ hij⟩,
end

lemma bases_inj {M₁ M₂ : supermatroid α} (hb : M₁.basis = M₂.basis)  : M₁ = M₂ := by {ext, rw hb}

lemma indep_inj {M₁ M₂ : supermatroid α} (hb : M₁.indep = M₂.indep)  : M₁ = M₂ :=
by {ext, simp_rw [basis_iff_maximal_indep, hb]}

lemma basis_of_indep_spanning (hi : M.indep x) (hs : M.spanning x) : M.basis x :=
begin
  obtain ⟨⟨bi,hbi,hxbi⟩,⟨bs,hbs,hbsx⟩⟩ := ⟨hi,hs⟩,
  refine by_contra (λ h, (M.basis_antichain hbs hbi (λ h', h _) (hbsx.trans hxbi)).elim),
  subst h', rwa (hxbi.antisymm hbsx),
end

end partial_order

section lattice

variables [lattice α] {M : supermatroid α}

lemma indep.inf_left_indep (hi : M.indep i) (x : α) : M.indep (x ⊓ i) :=
hi.indep_of_le inf_le_right

lemma indep.inf_right_indep (hi : M.indep i) (x : α) : M.indep (i ⊓ x) :=
hi.indep_of_le inf_le_left

lemma basis.inf_left_indep (hb : M.basis b) (x : α) : M.indep (x ⊓ b) :=
hb.indep.indep_of_le inf_le_right

lemma basis.inf_right_indep (hb : M.basis b) (x : α) : M.indep (b ⊓ x) :=
hb.indep.indep_of_le inf_le_left

/-- An alternative version of `exists_basis_of` that assumes `lattice` rather than `order_bot` -/
lemma exists_basis_of' (M : supermatroid α) (x : α) : ∃ i, M.basis_of i x :=
begin
  obtain ⟨b,hb⟩ := M.exists_basis,
  obtain ⟨i,⟨⟨b,hb,hib⟩,h',hix⟩,hi'⟩ :=
    M.basis_has_max_lower (x ⊓ b) x ⟨x ⊓ b, ⟨b,hb,inf_le_right⟩, rfl.le,inf_le_left⟩,
  exact ⟨i,⟨b,hb,hib⟩,hix, λ j hj hjx hij,
    hi' ⟨(mem_lower_set_basis_iff_indep.mp hj), h'.trans hij,hjx⟩ hij⟩,
end

lemma indep.increment_sup (hi : M.indep i) (hi_nb : ¬M.basis i) (hb : M.basis b) :
  ∃ i', i < i' ∧ i' ≤ i ⊔ b ∧ M.indep i' :=
begin
  obtain ⟨b₁, hb₁, hib₁⟩ := hi,
  obtain ⟨b₂, hb₂, hib₂, hb₂i⟩ := basis_middle (le_sup_left : i ≤ i ⊔ b) hb₁ hb hib₁ le_sup_right,
  exact ⟨b₂, lt_of_le_of_ne' hib₂ (λ h, hi_nb (h ▸ hb₂)), hb₂i, hb₂.indep⟩,
end

lemma basis.max_inf (hb : M.basis b) (x : α):
  ∃ b', M.basis b' ∧ b ⊓ x ≤ b' ∧ ∀ b'', M.basis b'' → b' ⊓ x ≤ b'' → b' ⊓ x = b'' ⊓ x :=
begin
  obtain ⟨i,⟨⟨b₁,hb₁,hib₁⟩,hbi,hix⟩,hmax⟩ := M.basis_has_max_lower _ x
    ⟨b ⊓ x, ⟨⟨b,hb,inf_le_left⟩,⟨rfl.le,inf_le_right⟩⟩⟩,

  refine ⟨b₁,hb₁,hbi.trans hib₁, λ b₂ hb₂ hb₁b₂, inf_eq_inf_of_le_of_le hb₁b₂ _⟩,
  have hib₂ := (le_inf hib₁ hix).trans hb₁b₂,
  rwa ←hmax ⟨⟨b₂,hb₂,(inf_le_left : b₂ ⊓ x ≤ b₂)⟩,
    ⟨le_inf (hbi.trans hib₂) inf_le_right ,inf_le_right⟩⟩ (le_inf hib₂ hix),
end

lemma indep.le_basis_of (hi : M.indep i) (hix : i ≤ x) :
  ∃ j, i ≤ j ∧ M.basis_of j x :=
begin
  obtain ⟨b,hb,hbi⟩ := hi,
  obtain ⟨b',⟨hb',hb'x,hb'_max⟩⟩ := hb.max_inf x,
  refine ⟨b' ⊓ x, le_inf ((le_inf hbi hix).trans hb'x) hix, hb'.inf_right_indep _,inf_le_right, _⟩,
  rintros j ⟨b'',hb'',hjb''⟩ hjx hb'j,
  have h₀ := (le_inf hjb'' hjx),
  rw [←(hb'_max _ hb'' (hb'j.trans hjb''))] at h₀,
  exact le_antisymm hb'j h₀,
end

lemma indep.le_basis_sup (hi : M.indep i) (hb : M.basis b) :
   ∃ b', M.basis b' ∧ i ≤ b' ∧ b' ≤ i ⊔ b :=
begin
  obtain ⟨b',hib', hb'⟩ := hi.le_basis_of (@le_sup_left _ _ i b),
  exact ⟨b',hb'.basis ⟨b,hb,le_sup_right⟩, hib', hb'.le⟩,
end

lemma indep.lt_basis_sup (hi : M.indep i) (hi_nb : ¬ M.basis i) (hb : M.basis b) :
  ∃ b', M.basis b' ∧ i < b' ∧ b' ≤ i ⊔ b :=
begin
  obtain ⟨b',hb',h₁,h₂⟩ := hi.le_basis_sup hb,
  exact ⟨b', hb', lt_of_le_of_ne h₁ (λ h, (hi_nb (h.symm ▸ hb')).elim), h₂⟩,
end

lemma basis.inf_basis_of (hb : M.basis b) (x : α) :
  ∃ b', b' ≤ x ⊔ b ∧ M.basis b' ∧ (M.basis_of (b' ⊓ x) x) :=
begin
  obtain ⟨i,hi⟩ := M.exists_basis_of' x,
  obtain ⟨b',⟨hb',bib',hb'i⟩⟩ := hi.indep.le_basis_sup hb,
  refine ⟨b', hb'i.trans (sup_le_sup_right hi.le _) ,hb',
    (hb'.inf_right_indep _).basis_of inf_le_right (λ j hj hjx hb'j, hb'j.antisymm (le_inf _ hjx))⟩,
  rwa ←hi.eq_of_le_indep (le_trans (le_inf bib' hi.le) hb'j) hjx hj,
end

lemma basis.lt_basis_sup (hb : M.basis b) (hib : i < b) (hb' : M.basis b'):
  ∃ b₀, M.basis b₀ ∧ i < b₀ ∧ b₀ ≤ i ⊔ b' :=
(hb.indep_of_le hib.le).lt_basis_sup (hb.not_basis_of_lt hib) hb'

end lattice

section dual

variables [lattice α] [is_modular_lattice α]

lemma basis_has_min_upper (M : supermatroid α) : min_upper M.basis :=
begin
  rintros x y ⟨s,⟨b,hb,hbs⟩,hxs,hsy⟩,
  obtain ⟨b₁,hb₁b,hb₁,hb₁x⟩ := hb.inf_basis_of x,
  refine ⟨x ⊔ b₁,⟨⟨b₁,hb₁,le_sup_right⟩,le_sup_left,sup_le (hxs.trans hsy)
    (hb₁b.trans ((sup_le hxs hbs).trans hsy))⟩, _⟩,

  rintros t ⟨⟨b₂,hb₂,hb₂t⟩,hxt,hty⟩ htx,
  refine le_antisymm (sup_le hxt _) htx,
  by_contradiction hb₁t,
  set j := b₁ ⊓ (x ⊔ b₂) with hj,

  have hj_lt : j < b₁ := inf_le_left.lt_of_ne
    (λ h_eq, hb₁t (by {rw ← h_eq, exact inf_le_right.trans (sup_le hxt hb₂t)})),

  obtain ⟨b₃, hb₃, hjb₃, hb₃j⟩ := hb₁.lt_basis_sup hj_lt hb₂,

  have h1 := @inf_lt_inf_of_lt_of_sup_le_sup _ _ _ _ _ x hjb₃ (sup_le _ le_sup_right),
  swap,
  { rw [hj, inf_comm, inf_sup_assoc_of_le b₁ le_sup_right, le_inf_iff] at hb₃j,
    rw [hj, inf_comm, inf_sup_assoc_of_le b₁ le_sup_left, le_inf_iff],
    refine ⟨hb₃j.1, hb₃j.2.trans (sup_le le_sup_left (hb₂t.trans _))⟩,
    rwa sup_comm},
  refine (hb₁x.not_indep_of_lt (lt_of_le_of_lt (le_inf _ inf_le_right) h1)
    inf_le_right (hb₃.inf_right_indep x)),
  rw [hj, inf_comm, @inf_comm _ _ _ (x ⊔ b₂)],
  exact le_inf (inf_le_left.trans le_sup_left) inf_le_right,
end

/-- The matroid on the dual lattice with the same set of bases as `M`-/
def order_dual (M:  supermatroid α) : supermatroid αᵒᵈ :=
{ basis := M.basis,
  exists_basis := M.exists_basis,
  basis_antichain := M.basis_antichain.to_dual,
  basis_has_middle := middle_dual M.basis_has_middle,
  basis_has_max_lower := max_lower_dual M.basis_has_min_upper}

postfix `ᵈ`:(max + 1) := order_dual

open has_involution

def dual [has_involution α] (M : supermatroid α) : supermatroid α :=
{ basis := invo ⁻¹' M.basis,
  exists_basis := exists.elim M.exists_basis
    (λ b hb, ⟨bⁱ, by rwa [mem_preimage_invo', invo_invo]⟩),
  basis_antichain := M.basis_antichain.preimage_invo,
  basis_has_middle :=
  begin
    intros x y hxy,

    simp only [←image_invo_eq_preimage_invo, image_inter_nonempty_iff, preimage_Ici,
      preimage_Iic, preimage_Icc],
    exact flip (M.basis_has_middle yⁱ xⁱ (invo_le_iff.mpr hxy)),
  end,
  basis_has_max_lower :=
  begin
    intros x y h,
    simp only [←image_invo_eq_preimage_invo, lower_closure_image_invo,image_inter_nonempty_iff,
      preimage_Icc] at h,

    obtain ⟨a,⟨h₁,h₂⟩,h₃⟩ := M.basis_has_min_upper yᵒ xᵒ h,
    rw [lower_closure_preimage_invo],
    refine ⟨aᵒ, ⟨by rwa [mem_preimage, invo_invo],by rwa [←mem_image_invo, image_Icc]⟩,_⟩,
    rintros p ⟨hp1,hp2⟩ hap,
    rw [←invo_invo p, ←mem_image_invo, image_Icc] at hp2,
    rw [(h₃ ⟨hp1,hp2⟩ (invo_le_comm.mp hap)), invo_invo],
  end,

}

end dual

section spanning

variables [lattice α] [is_modular_lattice α] {M : supermatroid α}

/-- A super of `x` is a minimal element subject to being spanning and above `x`-/
def super_of (M : supermatroid α) (s x : α) := @basis_of αᵒᵈ _ Mᵈ s x

@[simp] lemma mem_upper_set_basis_iff_spanning : M.spanning s ↔ s ∈ upper_closure M.basis :=
⟨λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩, λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩⟩

lemma super_of_iff :
  M.super_of s x ↔ M.spanning s ∧ x ≤ s ∧ ∀ s', M.spanning s' → x ≤ s' → s' ≤ s → s = s' := iff.rfl

lemma spanning.super_of (hs : M.spanning s) (hxs : x ≤ s)
  (h : ∀ t, M.spanning t → x ≤ t → t ≤ s → s = t) : M.super_of s x :=
⟨hs, hxs, h⟩

lemma spanning.spanning_of_le (hs : M.spanning s) (hst : s ≤ t) : M.spanning t :=
exists.elim hs (λ b hb, ⟨b, hb.1, hb.2.trans hst⟩)

lemma basis.spanning (h : M.basis b) : M.spanning b := ⟨b, h, rfl.le⟩

lemma basis.spanning_of_le (h : M.basis b) (hbs : b ≤ s) : M.spanning s :=
  h.spanning.spanning_of_le hbs

lemma basis_iff_minimal_spanning : M.basis b ↔ (minimals (≤) M.spanning) b :=
@basis_iff_maximal_indep _ _ _ Mᵈ

lemma super_of.spanning (h : M.super_of s x) : M.spanning s := h.1

lemma super_of.le (h : M.super_of s x) : x ≤ s := h.2.1

lemma super_of.eq_of_spanning_le (hs : M.super_of s x) (hxt : x ≤ t) (hts : t ≤ s)
  (ht : M.spanning t) : t = s :=
(hs.2.2 _ ht hxt hts).symm

lemma super_of.not_spanning_of_lt (hs : M.super_of s x) (hts : t < s) (hxt : x ≤ t):
  ¬ M.spanning t :=
λ h, hts.ne (hs.eq_of_spanning_le hxt hts.le h)

lemma top_spanning [order_top α] (M : supermatroid α) : M.spanning ⊤ :=
exists.elim (M.exists_basis) (λ b hb, ⟨b,hb,le_top⟩)

lemma exists_super_of [order_top α] (M : supermatroid α) (x : α) : ∃ s, M.super_of s x :=
@exists_basis_of αᵒᵈ _ _ Mᵈ x

lemma spanning.decrement (hs : M.spanning s) (hs_nb : ¬M.basis s) (his : i ≤ s) (hi : M.indep i):
  ∃ t, t < s ∧ i ≤ t ∧ M.spanning t :=
@indep.increment αᵒᵈ s i _ Mᵈ hs hs_nb his hi

lemma spanning.sup_left_spanning (hs : M.spanning s) (x : α) : M.spanning (x ⊔ s) :=
  hs.spanning_of_le le_sup_right

lemma spanning.sup_right_spanning (hs : M.spanning s) (x : α) : M.spanning (s ⊔ x) :=
  hs.spanning_of_le le_sup_left

lemma basis.sup_left_spanning (h : M.basis b) (x : α) : M.spanning (x ⊔ b) :=
  h.spanning.sup_left_spanning _

lemma basis.sup_right_spanning (h : M.basis b) (x : α) : M.spanning (b ⊔ x) :=
  h.spanning.sup_right_spanning _

lemma spanning.decrement_inf (hs : M.spanning s) (hs_nb : ¬M.basis s) (hb : M.basis b) :
  ∃ t, t < s ∧ s ⊓ b ≤ t ∧ M.spanning t :=
@indep.increment_sup αᵒᵈ _ _ _ Mᵈ hs hs_nb hb

lemma super_of.basis (hs : M.super_of s x) (hx : M.indep x) : M.basis s :=
@basis_of.basis αᵒᵈ _ _ _ Mᵈ hs hx

lemma basis.min_sup (hb : M.basis b) (x : α) :
  ∃ b', M.basis b' ∧ b' ≤ b ⊔ x ∧ ∀ b'', M.basis b'' → b'' ≤ b' ⊔ x → b' ⊔ x = b'' ⊔ x :=
@basis.max_inf αᵒᵈ _ _ Mᵈ hb x

lemma spanning.super_of_le (hs : M.spanning s) (hxs : x ≤ s) :
  ∃ t, t ≤ s ∧ M.super_of t x :=
@indep.le_basis_of αᵒᵈ _ _ _ Mᵈ hs hxs

lemma spanning.basis_inf_le (hs : M.spanning s) (hb : M.basis b) :
  ∃ b', M.basis b' ∧ b' ≤ s ∧ s ⊓ b ≤ b' :=
@indep.le_basis_sup αᵒᵈ _ _ _ Mᵈ hs hb

lemma spanning.basis_inf_lt (hs : M.spanning s) (hs_nb : ¬ M.basis s) (hb : M.basis b) :
  ∃ b', M.basis b' ∧ b' < s ∧ s ⊓ b ≤ b' :=
@indep.lt_basis_sup αᵒᵈ _ _ _ Mᵈ hs hs_nb hb

lemma basis.basis_inf_lt (hb : M.basis b) (hbs : b < s) (hb' : M.basis b'):
  ∃ b₀, M.basis b₀ ∧ b₀ < s ∧ s ⊓ b' ≤ b₀ :=
(hb.spanning_of_le hbs.le).basis_inf_lt (hb.lt_not_basis hbs) hb'

lemma basis.sup_super_of (hb : M.basis b) (x : α) :
  ∃ b', x ⊓ b ≤ b' ∧ M.basis b' ∧ M.super_of (b' ⊔ x) x  :=
@basis.inf_basis_of αᵒᵈ _ _ Mᵈ hb x

end spanning

end supermatroid


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad

! This file was ported from Lean 3 source module data.int.bitwise
! leanprover-community/mathlib commit 0743cc5d9d86bcd1bba10f480e948a257d65056f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Int.Basic
import Mathlib.Data.Nat.Pow
import Mathlib.Data.Nat.Size
import Mathlib.Init.Data.Int.Bitwise
import Mathlib.Tactic.Coe

/-!
# Bitwise operations on integers

## Recursors
* `Int.bitCasesOn`: Parity disjunction. Something is true/defined on `ℤ` if it's true/defined for
  even and for odd values.
-/

namespace Int

/-! ### bitwise ops -/

@[simp]
theorem bodd_zero : bodd 0 = false :=
  rfl
#align int.bodd_zero Int.bodd_zero

@[simp]
theorem bodd_one : bodd 1 = true :=
  rfl
#align int.bodd_one Int.bodd_one

theorem bodd_two : bodd 2 = false :=
  rfl
#align int.bodd_two Int.bodd_two

@[simp, norm_cast]
theorem bodd_coe (n : ℕ) : Int.bodd n = Nat.bodd n :=
  rfl
#align int.bodd_coe Int.bodd_coe

@[simp]
theorem bodd_subNatNat (m n : ℕ) : bodd (subNatNat m n) = xor m.bodd n.bodd := by
  apply subNatNat_elim m n fun m n i => bodd i = xor m.bodd n.bodd <;>
  intros i j <;>
  simp only [Int.bodd, Int.bodd_coe, Nat.bodd_add] <;>
  cases Nat.bodd i <;> simp
#align int.bodd_sub_nat_nat Int.bodd_subNatNat

@[simp]
theorem bodd_negOfNat (n : ℕ) : bodd (negOfNat n) = n.bodd := by
  cases n <;> simp
  rfl
#align int.bodd_neg_of_nat Int.bodd_negOfNat

@[simp]
theorem bodd_neg (n : ℤ) : bodd (-n) = bodd n := by
  cases n with
  | ofNat =>
    rw [←negOfNat_eq, bodd_negOfNat]
    simp
  | negSucc n =>
    rw [neg_negSucc, bodd_coe, Nat.bodd_succ]
    change (!Nat.bodd n) = !(bodd n)
    rw [bodd_coe]
-- Porting note: Heavily refactored proof, used to work all with `simp`:
-- `cases n <;> simp [Neg.neg, Int.coe_nat_eq, Int.neg, bodd, -of_nat_eq_coe]`
#align int.bodd_neg Int.bodd_neg

@[simp]
theorem bodd_add (m n : ℤ) : bodd (m + n) = xor (bodd m) (bodd n) := by
  cases' m with m m <;>
  cases' n with n n <;>
  simp only [ofNat_eq_coe, ofNat_add_negSucc, negSucc_add_ofNat,
             negSucc_add_negSucc, bodd_subNatNat] <;>
  simp only [negSucc_coe, bodd_neg, bodd_coe, ←Nat.bodd_add, Bool.xor_comm, ←Nat.cast_add]
  rw [←Nat.succ_add, add_assoc]
-- Porting note: Heavily refactored proof, used to work all with `simp`:
-- `by cases m with m m; cases n with n n; unfold has_add.add;`
-- `simp [int.add, -of_nat_eq_coe, bool.bxor_comm]`
#align int.bodd_add Int.bodd_add

@[simp]
theorem bodd_mul (m n : ℤ) : bodd (m * n) = (bodd m && bodd n) := by
  cases' m with m m <;> cases' n with n n <;>
  simp only [ofNat_eq_coe, ofNat_mul_negSucc, negSucc_mul_ofNat, ofNat_mul_ofNat,
             negSucc_mul_negSucc] <;>
  simp only [negSucc_coe, bodd_neg, bodd_coe, ←Nat.bodd_mul]
-- Porting note: Heavily refactored proof, used to be:
-- `by cases m with m m; cases n with n n;`
-- `simp [← int.mul_def, int.mul, -of_nat_eq_coe, bool.bxor_comm]`
#align int.bodd_mul Int.bodd_mul

theorem bodd_add_div2 : ∀ n, cond (bodd n) 1 0 + 2 * div2 n = n
  | (n : ℕ) => by
    rw [show (cond (bodd n) 1 0 : ℤ) = (cond (bodd n) 1 0 : ℕ) by cases bodd n <;> rfl]
    exact congr_arg ofNat n.bodd_add_div2
  | -[n+1] => by
    refine' Eq.trans _ (congr_arg negSucc n.bodd_add_div2)
    dsimp [bodd]; cases Nat.bodd n <;> dsimp [cond, not, div2, Int.mul]
    · change -[2 * Nat.div2 n+1] = _
      rw [zero_add]
    · rw [zero_add, add_comm]
      rfl
#align int.bodd_add_div2 Int.bodd_add_div2

theorem div2_val : ∀ n, div2 n = n / 2
  | (n : ℕ) => congr_arg ofNat n.div2_val
  | -[n+1] => congr_arg negSucc n.div2_val
#align int.div2_val Int.div2_val

section deprecated

set_option linter.deprecated false

@[deprecated]
theorem bit0_val (n : ℤ) : bit0 n = 2 * n :=
  (two_mul _).symm
#align int.bit0_val Int.bit0_val

@[deprecated]
theorem bit1_val (n : ℤ) : bit1 n = 2 * n + 1 :=
  congr_arg (· + (1 : ℤ)) (bit0_val _)
#align int.bit1_val Int.bit1_val

theorem bit_val (b n) : bit b n = 2 * n + cond b 1 0 := by
  cases b
  apply (bit0_val n).trans (add_zero _).symm
  apply bit1_val
#align int.bit_val Int.bit_val

theorem bit_decomp (n : ℤ) : bit (bodd n) (div2 n) = n :=
  (bit_val _ _).trans <| (add_comm _ _).trans <| bodd_add_div2 _
#align int.bit_decomp Int.bit_decomp

/-- Defines a function from `ℤ` conditionally, if it is defined for odd and even integers separately
  using `bit`. -/
def bitCasesOn.{u} {C : ℤ → Sort u} (n) (h : ∀ b n, C (bit b n)) : C n := by
  rw [← bit_decomp n]
  apply h
#align int.bit_cases_on Int.bitCasesOn

@[simp]
theorem bit_zero : bit false 0 = 0 :=
  rfl
#align int.bit_zero Int.bit_zero

@[simp]
theorem bit_coe_nat (b) (n : ℕ) : bit b n = Nat.bit b n := by
  rw [bit_val, Nat.bit_val]
  cases b <;> rfl
#align int.bit_coe_nat Int.bit_coe_nat

@[simp]
theorem bit_negSucc (b) (n : ℕ) : bit b -[n+1] = -[Nat.bit (not b) n+1] := by
  rw [bit_val, Nat.bit_val]
  cases b <;> rfl
#align int.bit_neg_succ Int.bit_negSucc

@[simp]
theorem bodd_bit (b n) : bodd (bit b n) = b := by
  rw [bit_val]
  cases b <;> cases bodd n <;> simp
#align int.bodd_bit Int.bodd_bit

@[simp, deprecated]
theorem bodd_bit0 (n : ℤ) : bodd (bit0 n) = false :=
  bodd_bit false n
#align int.bodd_bit0 Int.bodd_bit0

@[simp, deprecated]
theorem bodd_bit1 (n : ℤ) : bodd (bit1 n) = true :=
  bodd_bit true n
#align int.bodd_bit1 Int.bodd_bit1

@[deprecated]
theorem bit0_ne_bit1 (m n : ℤ) : bit0 m ≠ bit1 n :=
  mt (congr_arg bodd) <| by simp
#align int.bit0_ne_bit1 Int.bit0_ne_bit1

@[deprecated]
theorem bit1_ne_bit0 (m n : ℤ) : bit1 m ≠ bit0 n :=
  (bit0_ne_bit1 _ _).symm
#align int.bit1_ne_bit0 Int.bit1_ne_bit0

@[deprecated]
theorem bit1_ne_zero (m : ℤ) : bit1 m ≠ 0 := by simpa only [bit0_zero] using bit1_ne_bit0 m 0
#align int.bit1_ne_zero Int.bit1_ne_zero

end deprecated

@[simp]
theorem testBit_zero (b) : ∀ n, testBit (bit b n) 0 = b
  | (n : ℕ) => by rw [bit_coe_nat]; apply Nat.testBit_zero
  | -[n+1] => by
    rw [bit_negSucc]; dsimp [testBit]; rw [Nat.testBit_zero]; clear testBit_zero;
        cases b <;>
      rfl
#align int.test_bit_zero Int.testBit_zero

@[simp]
theorem testBit_succ (m b) : ∀ n, testBit (bit b n) (Nat.succ m) = testBit n m
  | (n : ℕ) => by rw [bit_coe_nat]; apply Nat.testBit_succ
  | -[n+1] => by
    dsimp [testBit]
    simp only [bit_negSucc]
    cases b <;> simp [Nat.testBit_succ]
#align int.test_bit_succ Int.testBit_succ

-- Porting note: TODO
-- /- ./././Mathport/Syntax/Translate/Expr.lean:333:4: warning: unsupported (TODO): `[tacs] -/
-- private unsafe def bitwise_tac : tactic Unit :=
--   sorry
-- #align int.bitwise_tac int.bitwise_tac

--Porting note : Was `bitwise_tac` in mathlib
theorem bitwise_or : bitwise or = lor := by
  funext m n
  cases' m with m m <;> cases' n with n n <;> try {rfl}
    <;> simp only [bitwise, natBitwise, Bool.not_false, Bool.or_true, cond_true, lor, Nat.ldiff',
      negSucc.injEq, Bool.true_or, Nat.land']
  . rw [Nat.bitwise'_swap, Function.swap]
    congr
    funext x y
    cases x <;> cases y <;> rfl
    rfl
  . congr
    funext x y
    cases x <;> cases y <;> rfl
  . congr
    funext x y
    cases x <;> cases y <;> rfl
#align int.bitwise_or Int.bitwise_or

--Porting note : Was `bitwise_tac` in mathlib
theorem bitwise_and : bitwise and = land := by
  funext m n
  cases' m with m m <;> cases' n with n n <;> try {rfl}
    <;> simp only [bitwise, natBitwise, Bool.not_false, Bool.or_true,
      cond_false, cond_true, lor, Nat.ldiff', Bool.and_true, negSucc.injEq,
      Bool.and_false, Nat.land']
  . rw [Nat.bitwise'_swap, Function.swap]
    congr
    funext x y
    cases x <;> cases y <;> rfl
    rfl
  . congr
    funext x y
    cases x <;> cases y <;> rfl
#align int.bitwise_and Int.bitwise_and

--Porting note : Was `bitwise_tac` in mathlib
theorem bitwise_diff : (bitwise fun a b => a && not b) = ldiff' := by
  funext m n
  cases' m with m m <;> cases' n with n n <;> try {rfl}
    <;> simp only [bitwise, natBitwise, Bool.not_false, Bool.or_true,
      cond_false, cond_true, lor, Nat.ldiff', Bool.and_true, negSucc.injEq,
      Bool.and_false, Nat.land', Bool.not_true, ldiff', Nat.lor']
  . congr
    funext x y
    cases x <;> cases y <;> rfl
  . congr
    funext x y
    cases x <;> cases y <;> rfl
  . rw [Nat.bitwise'_swap, Function.swap]
    congr
    funext x y
    cases x <;> cases y <;> rfl
    rfl
#align int.bitwise_diff Int.bitwise_diff

--Porting note : Was `bitwise_tac` in mathlib
theorem bitwise_xor : bitwise xor = lxor' := by
  funext m n
  cases' m with m m <;> cases' n with n n <;> try {rfl}
    <;> simp only [bitwise, natBitwise, Bool.not_false, Bool.or_true,
      cond_false, cond_true, lor, Nat.ldiff', Bool.and_true, negSucc.injEq, Bool.false_xor,
      Bool.true_xor, Bool.and_false, Nat.land', Bool.not_true, ldiff', Nat.lor', lxor', Nat.lxor']
  . congr
    funext x y
    cases x <;> cases y <;> rfl
  . congr
    funext x y
    cases x <;> cases y <;> rfl
  . congr
    funext x y
    cases x <;> cases y <;> rfl
#align int.bitwise_xor Int.bitwise_xor

@[simp]
theorem bitwise_bit (f : Bool → Bool → Bool) (a m b n) :
    bitwise f (bit a m) (bit b n) = bit (f a b) (bitwise f m n) := by
  cases' m with m m <;> cases' n with n n <;>
  simp only [bitwise, ofNat_eq_coe, bit_coe_nat, natBitwise, Bool.not_false, Bool.not_eq_false',
    bit_negSucc]
  . by_cases h : f false false <;> simp [h]
  . by_cases h : f false true <;> simp [h]
  . by_cases h : f true false <;> simp [h]
  . by_cases h : f true true <;> simp [h]
#align int.bitwise_bit Int.bitwise_bit

@[simp]

@[simp]
theorem land_bit (a m b n) : land (bit a m) (bit b n) = bit (a && b) (land m n) := by
  rw [← bitwise_and, bitwise_bit]
#align int.land_bit Int.land_bit

@[simp]
theorem ldiff_bit (a m b n) : ldiff' (bit a m) (bit b n) = bit (a && not b) (ldiff' m n) := by
  rw [← bitwise_diff, bitwise_bit]
#align int.ldiff_bit Int.ldiff_bit

@[simp]
theorem lxor_bit (a m b n) : lxor' (bit a m) (bit b n) = bit (xor a b) (lxor' m n) := by
  rw [← bitwise_xor, bitwise_bit]
#align int.lxor_bit Int.lxor_bit

@[simp]
theorem lnot_bit (b) : ∀ n, lnot (bit b n) = bit (not b) (lnot n)
  | (n : ℕ) => by simp [lnot]
  | -[n+1] => by simp [lnot]
#align int.lnot_bit Int.lnot_bit

@[simp]
theorem testBit_bitwise (f : Bool → Bool → Bool) (m n k) :
    testBit (bitwise f m n) k = f (testBit m k) (testBit n k) := by
  cases m <;> cases n <;> simp only [testBit, bitwise, natBitwise]
  . by_cases h : f false false <;> simp [h]
  . by_cases h : f false true <;> simp [h]
  . by_cases h : f true false <;> simp [h]
  . by_cases h : f true true <;> simp [h]
#align int.test_bit_bitwise Int.testBit_bitwise

@[simp]
theorem testBit_lor (m n k) : testBit (lor m n) k = (testBit m k || testBit n k) := by
  rw [← bitwise_or, testBit_bitwise]
#align int.test_bit_lor Int.testBit_lor

@[simp]
theorem testBit_land (m n k) : testBit (land m n) k = (testBit m k && testBit n k) := by
  rw [← bitwise_and, testBit_bitwise]
#align int.test_bit_land Int.testBit_land

@[simp]
theorem testBit_ldiff (m n k) : testBit (ldiff' m n) k = (testBit m k && not (testBit n k)) := by
  rw [← bitwise_diff, testBit_bitwise]
#align int.test_bit_ldiff Int.testBit_ldiff

@[simp]
theorem testBit_lxor (m n k) : testBit (lxor' m n) k = xor (testBit m k) (testBit n k) := by
  rw [← bitwise_xor, testBit_bitwise]
#align int.test_bit_lxor Int.testBit_lxor

@[simp]
theorem testBit_lnot : ∀ n k, testBit (lnot n) k = not (testBit n k)
  | (n : ℕ), k => by simp [lnot, testBit]
  | -[n+1], k => by simp [lnot, testBit]
#align int.test_bit_lnot Int.testBit_lnot

@[simp]
theorem shiftl_neg (m n : ℤ) : shiftl m (-n) = shiftr m n :=
  rfl
#align int.shiftl_neg Int.shiftl_neg

@[simp]
theorem shiftr_neg (m n : ℤ) : shiftr m (-n) = shiftl m n := by rw [← shiftl_neg, neg_neg]
#align int.shiftr_neg Int.shiftr_neg

-- Porting note: what's the correct new name?
@[simp]
theorem shiftl_coe_nat (m n : ℕ) : shiftl m n = Nat.shiftl m n :=
  rfl
#align int.shiftl_coe_nat Int.shiftl_coe_nat

-- Porting note: what's the correct new name?
@[simp]
theorem shiftr_coe_nat (m n : ℕ) : shiftr m n = Nat.shiftr m n := by cases n <;> rfl
#align int.shiftr_coe_nat Int.shiftr_coe_nat

@[simp]
theorem shiftl_negSucc (m n : ℕ) : shiftl -[m+1] n = -[Nat.shiftl' true m n+1] :=
  rfl
#align int.shiftl_neg_succ Int.shiftl_negSucc

@[simp]
theorem shiftr_negSucc (m n : ℕ) : shiftr -[m+1] n = -[Nat.shiftr m n+1] := by cases n <;> rfl
#align int.shiftr_neg_succ Int.shiftr_negSucc

theorem shiftr_add : ∀ (m : ℤ) (n k : ℕ), shiftr m (n + k) = shiftr (shiftr m n) k
  | (m : ℕ), n, k => by
    rw [shiftr_coe_nat, shiftr_coe_nat, ← Int.ofNat_add, shiftr_coe_nat, Nat.shiftr_add]
  | -[m+1], n, k => by
    rw [shiftr_negSucc, shiftr_negSucc, ← Int.ofNat_add, shiftr_negSucc, Nat.shiftr_add]
#align int.shiftr_add Int.shiftr_add

/-! ### bitwise ops -/

attribute [local simp] Int.zero_div

theorem shiftl_add : ∀ (m : ℤ) (n : ℕ) (k : ℤ), shiftl m (n + k) = shiftl (shiftl m n) k
  | (m : ℕ), n, (k : ℕ) => congr_arg ofNat (Nat.shiftl_add _ _ _)
  | -[m+1], n, (k : ℕ) => congr_arg negSucc (Nat.shiftl'_add _ _ _ _)
  | (m : ℕ), n, -[k+1] =>
    subNatNat_elim n k.succ (fun n k i => shiftl (↑m) i = Nat.shiftr (Nat.shiftl m n) k)
      (fun (i n : ℕ) =>
        by dsimp; rw [← Nat.shiftl_sub, add_tsub_cancel_left]; apply Nat.le_add_right)
      fun i n =>
        by dsimp; rw [add_assoc, Nat.shiftr_add, ← Nat.shiftl_sub, tsub_self] <;> rfl
  | -[m+1], n, -[k+1] =>
    subNatNat_elim n k.succ
      (fun n k i => shiftl -[m+1] i = -[Nat.shiftr (Nat.shiftl' true m n) k+1])
      (fun i n =>
        congr_arg negSucc <| by
          rw [← Nat.shiftl'_sub, add_tsub_cancel_left]; apply Nat.le_add_right)
      fun i n =>
      congr_arg negSucc <| by rw [add_assoc, Nat.shiftr_add, ← Nat.shiftl'_sub, tsub_self] <;> rfl
#align int.shiftl_add Int.shiftl_add

theorem shiftl_sub (m : ℤ) (n : ℕ) (k : ℤ) : shiftl m (n - k) = shiftr (shiftl m n) k :=
  shiftl_add _ _ _
#align int.shiftl_sub Int.shiftl_sub

theorem shiftl_eq_mul_pow : ∀ (m : ℤ) (n : ℕ), shiftl m n = m * ↑(2 ^ n)
  | (m : ℕ), _ => congr_arg ((↑) : ℕ → ℤ) (Nat.shiftl_eq_mul_pow _ _)
  | -[_+1], _ => @congr_arg ℕ ℤ _ _ (fun i => -i) (Nat.shiftl'_tt_eq_mul_pow _ _)
#align int.shiftl_eq_mul_pow Int.shiftl_eq_mul_pow

theorem shiftr_eq_div_pow : ∀ (m : ℤ) (n : ℕ), shiftr m n = m / ↑(2 ^ n)
  | (m : ℕ), n => by rw [shiftr_coe_nat, Nat.shiftr_eq_div_pow _ _]; simp
  | -[m+1], n => by
    rw [shiftr_negSucc, negSucc_ediv, Nat.shiftr_eq_div_pow]; rfl
    exact ofNat_lt_ofNat_of_lt (pow_pos (by decide) _)
#align int.shiftr_eq_div_pow Int.shiftr_eq_div_pow

theorem one_shiftl (n : ℕ) : shiftl 1 n = (2 ^ n : ℕ) :=
  congr_arg ((↑) : ℕ → ℤ) (Nat.one_shiftl _)
#align int.one_shiftl Int.one_shiftl

@[simp]
theorem zero_shiftl : ∀ n : ℤ, shiftl 0 n = 0
  | (n : ℕ) => congr_arg ((↑) : ℕ → ℤ) (Nat.zero_shiftl _)
  | -[_+1] => congr_arg ((↑) : ℕ → ℤ) (Nat.zero_shiftr _)
#align int.zero_shiftl Int.zero_shiftl

@[simp]
theorem zero_shiftr (n) : shiftr 0 n = 0 :=
  zero_shiftl _
#align int.zero_shiftr Int.zero_shiftr

end Int


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

/-! # Stone-Čech compactification

Construction of the Stone-Čech compactification using ultrafilters.

Parts of the formalization are based on "Ultrafilters and Topology"
by Marius Stekelenburg, particularly section 5.
-/

noncomputable theory

open filter set
open_locale topological_space

universes u v

section ultrafilter
/- The set of ultrafilters on α carries a natural topology which makes
  it the Stone-Čech compactification of α (viewed as a discrete space). -/

/-- Basis for the topology on `ultrafilter α`. -/
def ultrafilter_basis (α : Type u) : set (set (ultrafilter α)) :=
range $ λ s : set α, {u | s ∈ u}

variables {α : Type u}

instance : topological_space (ultrafilter α) :=
topological_space.generate_from (ultrafilter_basis α)

lemma ultrafilter_basis_is_basis :
  topological_space.is_topological_basis (ultrafilter_basis α) :=
⟨begin
   rintros _ ⟨a, rfl⟩ _ ⟨b, rfl⟩ u ⟨ua, ub⟩,
   refine ⟨_, ⟨a ∩ b, rfl⟩, inter_mem ua ub, assume v hv, ⟨_, _⟩⟩;
     apply mem_of_superset hv; simp [inter_subset_right a b]
 end,
 eq_univ_of_univ_subset $ subset_sUnion_of_mem $
   ⟨univ, eq_univ_of_forall (λ u, univ_mem)⟩,
 rfl⟩

/-- The basic open sets for the topology on ultrafilters are open. -/
lemma ultrafilter_is_open_basic (s : set α) :
  is_open {u : ultrafilter α | s ∈ u} :=
ultrafilter_basis_is_basis.is_open ⟨s, rfl⟩

/-- The basic open sets for the topology on ultrafilters are also closed. -/
lemma ultrafilter_is_closed_basic (s : set α) :
  is_closed {u : ultrafilter α | s ∈ u} :=
begin
  rw ← is_open_compl_iff,
  convert ultrafilter_is_open_basic sᶜ,
  ext u,
  exact ultrafilter.compl_mem_iff_not_mem.symm
end

/-- Every ultrafilter `u` on `ultrafilter α` converges to a unique
  point of `ultrafilter α`, namely `mjoin u`. -/
lemma ultrafilter_converges_iff {u : ultrafilter (ultrafilter α)} {x : ultrafilter α} :
  ↑u ≤ 𝓝 x ↔ x = mjoin u :=
begin
  rw [eq_comm, ← ultrafilter.coe_le_coe],
  change ↑u ≤ 𝓝 x ↔ ∀ s ∈ x, {v : ultrafilter α | s ∈ v} ∈ u,
  simp only [topological_space.nhds_generate_from, le_infi_iff, ultrafilter_basis,
    le_principal_iff, mem_set_of_eq],
  split,
  { intros h a ha, exact h _ ⟨ha, a, rfl⟩ },
  { rintros h a ⟨xi, a, rfl⟩, exact h _ xi }
end

instance ultrafilter_compact : compact_space (ultrafilter α) :=
⟨is_compact_iff_ultrafilter_le_nhds.mpr $ assume f _,
   ⟨mjoin f, trivial, ultrafilter_converges_iff.mpr rfl⟩⟩

instance ultrafilter.t2_space : t2_space (ultrafilter α) :=
t2_iff_ultrafilter.mpr $ assume x y f fx fy,
  have hx : x = mjoin f, from ultrafilter_converges_iff.mp fx,
  have hy : y = mjoin f, from ultrafilter_converges_iff.mp fy,
  hx.trans hy.symm

instance : totally_disconnected_space (ultrafilter α) :=
begin
  rw totally_disconnected_space_iff_connected_component_singleton,
  intro A,
  simp only [set.eq_singleton_iff_unique_mem, mem_connected_component, true_and],
  intros B hB,
  rw ← ultrafilter.coe_le_coe,
  intros s hs,
  rw [connected_component_eq_Inter_clopen, set.mem_Inter] at hB,
  let Z := { F : ultrafilter α | s ∈ F },
  have hZ : is_clopen Z := ⟨ultrafilter_is_open_basic s, ultrafilter_is_closed_basic s⟩,
  exact hB ⟨Z, hZ, hs⟩,
end

lemma ultrafilter_comap_pure_nhds (b : ultrafilter α) : comap pure (𝓝 b) ≤ b :=
begin
  rw topological_space.nhds_generate_from,
  simp only [comap_infi, comap_principal],
  intros s hs,
  rw ←le_principal_iff,
  refine infi_le_of_le {u | s ∈ u} _,
  refine infi_le_of_le ⟨hs, ⟨s, rfl⟩⟩ _,
  exact principal_mono.2 (λ a, id)
end

section embedding

lemma ultrafilter_pure_injective : function.injective (pure : α → ultrafilter α) :=
begin
  intros x y h,
  have : {x} ∈ (pure x : ultrafilter α) := singleton_mem_pure,
  rw h at this,
  exact (mem_singleton_iff.mp (mem_pure.mp this)).symm
end

open topological_space

/-- The range of `pure : α → ultrafilter α` is dense in `ultrafilter α`. -/
lemma dense_range_pure : dense_range (pure : α → ultrafilter α) :=
λ x, mem_closure_iff_ultrafilter.mpr
       ⟨x.map pure, range_mem_map, ultrafilter_converges_iff.mpr (bind_pure x).symm⟩

/-- The map `pure : α → ultra_filter α` induces on `α` the discrete topology. -/
lemma induced_topology_pure :
  topological_space.induced (pure : α → ultrafilter α) ultrafilter.topological_space = ⊥ :=
begin
  apply eq_bot_of_singletons_open,
  intros x,
  use [{u : ultrafilter α | {x} ∈ u}, ultrafilter_is_open_basic _],
  simp,
end

/-- `pure : α → ultrafilter α` defines a dense inducing of `α` in `ultrafilter α`. -/
lemma dense_inducing_pure : @dense_inducing _ _ ⊥ _ (pure : α → ultrafilter α) :=
by letI : topological_space α := ⊥; exact ⟨⟨induced_topology_pure.symm⟩, dense_range_pure⟩

-- The following refined version will never be used

/-- `pure : α → ultrafilter α` defines a dense embedding of `α` in `ultrafilter α`. -/
lemma dense_embedding_pure : @dense_embedding _ _ ⊥ _ (pure : α → ultrafilter α) :=
by letI : topological_space α := ⊥ ;
exact { inj := ultrafilter_pure_injective, ..dense_inducing_pure }
end embedding

section extension
/- Goal: Any function `α → γ` to a compact Hausdorff space `γ` has a
  unique extension to a continuous function `ultrafilter α → γ`. We
  already know it must be unique because `α → ultrafilter α` is a
  dense embedding and `γ` is Hausdorff. For existence, we will invoke
  `dense_embedding.continuous_extend`. -/

variables {γ : Type*} [topological_space γ]

/-- The extension of a function `α → γ` to a function `ultrafilter α → γ`.
  When `γ` is a compact Hausdorff space it will be continuous. -/
def ultrafilter.extend (f : α → γ) : ultrafilter α → γ :=
by letI : topological_space α := ⊥; exact dense_inducing_pure.extend f

variables [t2_space γ]

lemma ultrafilter_extend_extends (f : α → γ) : ultrafilter.extend f ∘ pure = f :=
begin
  letI : topological_space α := ⊥,
  haveI : discrete_topology α := ⟨rfl⟩,
  exact funext (dense_inducing_pure.extend_eq continuous_of_discrete_topology)
end

variables  [compact_space γ]

lemma continuous_ultrafilter_extend (f : α → γ) : continuous (ultrafilter.extend f) :=
have ∀ (b : ultrafilter α), ∃ c, tendsto f (comap pure (𝓝 b)) (𝓝 c) := assume b,
  -- b.map f is an ultrafilter on γ, which is compact, so it converges to some c in γ.
  let ⟨c, _, h⟩ := compact_univ.ultrafilter_le_nhds (b.map f)
    (by rw [le_principal_iff]; exact univ_mem) in
  ⟨c, le_trans (map_mono (ultrafilter_comap_pure_nhds _)) h⟩,
begin
  letI : topological_space α := ⊥,
  haveI : normal_space γ := normal_of_compact_t2,
  exact dense_inducing_pure.continuous_extend this
end

/-- The value of `ultrafilter.extend f` on an ultrafilter `b` is the
  unique limit of the ultrafilter `b.map f` in `γ`. -/
lemma ultrafilter_extend_eq_iff {f : α → γ} {b : ultrafilter α} {c : γ} :
  ultrafilter.extend f b = c ↔ ↑(b.map f) ≤ 𝓝 c :=
⟨assume h, begin
   -- Write b as an ultrafilter limit of pure ultrafilters, and use
   -- the facts that ultrafilter.extend is a continuous extension of f.
   let b' : ultrafilter (ultrafilter α) := b.map pure,
   have t : ↑b' ≤ 𝓝 b,
     from ultrafilter_converges_iff.mpr (bind_pure _).symm,
   rw ←h,
   have := (continuous_ultrafilter_extend f).tendsto b,
   refine le_trans _ (le_trans (map_mono t) this),
   change _ ≤ map (ultrafilter.extend f ∘ pure) ↑b,
   rw ultrafilter_extend_extends,
   exact le_refl _
 end,
 assume h, by letI : topological_space α := ⊥; exact
   dense_inducing_pure.extend_eq_of_tendsto (le_trans (map_mono (ultrafilter_comap_pure_nhds _)) h)⟩

end extension

end ultrafilter

section stone_cech
/- Now, we start with a (not necessarily discrete) topological space α
  and we want to construct its Stone-Čech compactification. We can
  build it as a quotient of `ultrafilter α` by the relation which
  identifies two points if the extension of every continuous function
  α → γ to a compact Hausdorff space sends the two points to the same
  point of γ. -/

variables (α : Type u) [topological_space α]

instance stone_cech_setoid : setoid (ultrafilter α) :=
{ r := λ x y, ∀ (γ : Type u) [topological_space γ], by exactI
    ∀ [t2_space γ] [compact_space γ] (f : α → γ) (hf : continuous f),
    ultrafilter.extend f x = ultrafilter.extend f y,
  iseqv :=
    ⟨assume x γ tγ h₁ h₂ f hf, rfl,
     assume x y xy γ tγ h₁ h₂ f hf, by exactI (xy γ f hf).symm,
     assume x y z xy yz γ tγ h₁ h₂ f hf, by exactI (xy γ f hf).trans (yz γ f hf)⟩ }

/-- The Stone-Čech compactification of a topological space. -/
def stone_cech : Type u := quotient (stone_cech_setoid α)

variables {α}
instance : topological_space (stone_cech α) := by unfold stone_cech; apply_instance
instance [inhabited α] : inhabited (stone_cech α) := by unfold stone_cech; apply_instance

/-- The natural map from α to its Stone-Čech compactification. -/
def stone_cech_unit (x : α) : stone_cech α := ⟦pure x⟧

/-- The image of stone_cech_unit is dense. (But stone_cech_unit need
  not be an embedding, for example if α is not Hausdorff.) -/
lemma dense_range_stone_cech_unit : dense_range (stone_cech_unit : α → stone_cech α) :=
dense_range_pure.quotient

section extension

variables {γ : Type u} [topological_space γ] [t2_space γ] [compact_space γ]
variables {f : α → γ} (hf : continuous f)

local attribute [elab_with_expected_type] quotient.lift

/-- The extension of a continuous function from α to a compact
  Hausdorff space γ to the Stone-Čech compactification of α. -/
def stone_cech_extend : stone_cech α → γ :=
quotient.lift (ultrafilter.extend f) (λ x y xy, xy γ f hf)

lemma stone_cech_extend_extends : stone_cech_extend hf ∘ stone_cech_unit = f :=
ultrafilter_extend_extends f

lemma continuous_stone_cech_extend : continuous (stone_cech_extend hf) :=
continuous_quot_lift _ (continuous_ultrafilter_extend f)

end extension

lemma convergent_eqv_pure {u : ultrafilter α} {x : α} (ux : ↑u ≤ 𝓝 x) : u ≈ pure x :=
assume γ tγ h₁ h₂ f hf, begin
  resetI,
  transitivity f x, swap, symmetry,
  all_goals { refine ultrafilter_extend_eq_iff.mpr (le_trans (map_mono _) (hf.tendsto _)) },
  { apply pure_le_nhds }, { exact ux }
end

lemma continuous_stone_cech_unit : continuous (stone_cech_unit : α → stone_cech α) :=
continuous_iff_ultrafilter.mpr $ λ x g gx,
  have ↑(g.map pure) ≤ 𝓝 g,
    by rw ultrafilter_converges_iff; exact (bind_pure _).symm,
  have (g.map stone_cech_unit : filter (stone_cech α)) ≤ 𝓝 ⟦g⟧, from
    continuous_at_iff_ultrafilter.mp (continuous_quotient_mk.tendsto g) _ this,
  by rwa (show ⟦g⟧ = ⟦pure x⟧, from quotient.sound $ convergent_eqv_pure gx) at this

instance stone_cech.t2_space : t2_space (stone_cech α) :=
begin
  rw t2_iff_ultrafilter,
  rintros ⟨x⟩ ⟨y⟩ g gx gy,
  apply quotient.sound,
  intros γ tγ h₁ h₂ f hf,
  resetI,
  let ff := stone_cech_extend hf,
  change ff ⟦x⟧ = ff ⟦y⟧,
  have lim := λ (z : ultrafilter α) (gz : (g : filter (stone_cech α)) ≤ 𝓝 ⟦z⟧),
    ((continuous_stone_cech_extend hf).tendsto _).mono_left gz,
  exact tendsto_nhds_unique (lim x gx) (lim y gy)
end

instance stone_cech.compact_space : compact_space (stone_cech α) :=
quotient.compact_space

end stone_cech