/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.lazy_list.basic
import data.tree
import data.int.basic
import control.bifunctor
import tactic.linarith
import testing.slim_check.gen

/-!
# `sampleable` Class

This class permits the creation samples of a given type
controlling the size of those values using the `gen` monad`. It also
helps minimize examples by creating smaller versions of given values.

When testing a proposition like `∀ n : ℕ, prime n → n ≤ 100`,
`slim_check` requires that `ℕ` have an instance of `sampleable` and for
`prime n` to be decidable.  `slim_check` will then use the instance of
`sampleable` to generate small examples of ℕ and progressively increase
in size. For each example `n`, `prime n` is tested. If it is false,
the example will be rejected (not a test success nor a failure) and
`slim_check` will move on to other examples. If `prime n` is true, `n
≤ 100` will be tested. If it is false, `n` is a counter-example of `∀
n : ℕ, prime n → n ≤ 100` and the test fails. If `n ≤ 100` is true,
the test passes and `slim_check` moves on to trying more examples.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `sampleable` class
  * `sampleable_functor` and `sampleable_bifunctor` class
  * `sampleable_ext` class

### `sampleable`

`sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.

### `sampleable_ext`

`sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type.

### `sampleable_functor` and `sampleable_bifunctor`

`sampleable_functor F` and `sampleable_bifunctor F` makes it possible
to create samples of and shrink `F α` given a sampling function and a
shrinking function for arbitrary `α`.

This allows us to separate the logic for generating the shape of a
collection from the logic for generating its contents. Specifically,
the contents could be generated using either `sampleable` or
`sampleable_ext` instance and the `sampleable_(bi)functor` does not
need to use that information

## Shrinking

Shrinking happens when `slim_check` find a counter-example to a
property.  It is likely that the example will be more complicated than
necessary so `slim_check` proceeds to shrink it as much as
possible. Although equally valid, a smaller counter-example is easier
for a user to understand and use.

The `sampleable` class, beside having the `sample` function, has a
`shrink` function so that we can use specialized knowledge while
shrinking a value. It is not responsible for the whole shrinking process
however. It only has to take one step in the shrinking process.
`slim_check` will repeatedly call `shrink` until no more steps can
be taken. Because `shrink` guarantees that the size of the candidates
it produces is strictly smaller than the argument, we know that
`slim_check` is guaranteed to terminate.

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/
universes u v w

namespace slim_check

variables (α : Type u)

local infix ` ≺ `:50 := has_well_founded.r

/-- `sizeof_lt x y` compares the sizes of `x` and `y`. -/
def sizeof_lt {α} [has_sizeof α] (x y : α) := sizeof x < sizeof y

/-- `shrink_fn α` is the type of functions that shrink an
argument of type `α` -/
@[reducible]
def shrink_fn (α : Type*) [has_sizeof α] := Π x : α, lazy_list { y : α // sizeof_lt y x }

/-- `sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.  -/
class sampleable :=
[wf : has_sizeof α]
(sample [] : gen α)
(shrink : Π x : α, lazy_list { y : α // @sizeof _ wf y < @sizeof _ wf x } := λ _, lazy_list.nil)

attribute [instance, priority 100] has_well_founded_of_has_sizeof default_has_sizeof
attribute [instance, priority 200] sampleable.wf

/-- `sampleable_functor F` makes it possible to create samples of and
shrink `F α` given a sampling function and a shrinking function for
arbitrary `α` -/
class sampleable_functor (F : Type u → Type v) [functor F] :=
[wf : Π α [has_sizeof α], has_sizeof (F α)]
(sample [] : ∀ {α}, gen α → gen (F α))
(shrink : ∀ α [has_sizeof α], shrink_fn α → shrink_fn (F α))
(p_repr : ∀ α, has_repr α → has_repr (F α))

/-- `sampleable_bifunctor F` makes it possible to create samples of
and shrink `F α β` given a sampling function and a shrinking function
for arbitrary `α` and `β` -/
class sampleable_bifunctor (F : Type u → Type v → Type w) [bifunctor F] :=
[wf : Π α β [has_sizeof α] [has_sizeof β], has_sizeof (F α β)]
(sample [] : ∀ {α β}, gen α → gen β → gen (F α β))
(shrink : ∀ α β [has_sizeof α] [has_sizeof β], shrink_fn α → shrink_fn β → shrink_fn (F α β))
(p_repr : ∀ α β, has_repr α → has_repr β → has_repr (F α β))

export sampleable (sample shrink)

/-- This function helps infer the proxy representation and
interpretation in `sampleable_ext` instances. -/
meta def sampleable.mk_trivial_interp : tactic unit :=
tactic.refine ``(id)

/-- `sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. -/
class sampleable_ext (α : Sort u) :=
(proxy_repr : Type v)
[wf : has_sizeof proxy_repr]
(interp [] : proxy_repr → α . sampleable.mk_trivial_interp)
[p_repr : has_repr proxy_repr]
(sample [] : gen proxy_repr)
(shrink : shrink_fn proxy_repr)

attribute [instance, priority 100] sampleable_ext.p_repr sampleable_ext.wf

open nat lazy_list

section prio

open sampleable_ext

set_option default_priority 50

instance sampleable_ext.of_sampleable {α} [sampleable α] [has_repr α] : sampleable_ext α :=
{ proxy_repr := α,
  sample := sampleable.sample α,
  shrink := shrink }

instance sampleable.functor {α} {F} [functor F] [sampleable_functor F] [sampleable α] :
  sampleable (F α) :=
{ wf := _,
  sample := sampleable_functor.sample F (sampleable.sample α),
  shrink := sampleable_functor.shrink α sampleable.shrink }

instance sampleable.bifunctor {α β} {F} [bifunctor F] [sampleable_bifunctor F] [sampleable α]
  [sampleable β] : sampleable (F α β) :=
{ wf := _,
  sample := sampleable_bifunctor.sample F (sampleable.sample α) (sampleable.sample β),
  shrink := sampleable_bifunctor.shrink α β sampleable.shrink sampleable.shrink }

set_option default_priority 100

instance sampleable_ext.functor {α} {F} [functor F] [sampleable_functor F] [sampleable_ext α] :
  sampleable_ext (F α) :=
{ wf := _,
  proxy_repr := F (proxy_repr α),
  interp := functor.map (interp _),
  sample := sampleable_functor.sample F (sampleable_ext.sample α),
  shrink := sampleable_functor.shrink _ sampleable_ext.shrink,
  p_repr := sampleable_functor.p_repr _ sampleable_ext.p_repr
  }

instance sampleable_ext.bifunctor {α β} {F} [bifunctor F] [sampleable_bifunctor F]
  [sampleable_ext α] [sampleable_ext β] : sampleable_ext (F α β) :=
{ wf := _,
  proxy_repr := F (proxy_repr α) (proxy_repr β),
  interp := bifunctor.bimap (interp _) (interp _),
  sample := sampleable_bifunctor.sample F (sampleable_ext.sample α) (sampleable_ext.sample β),
  shrink := sampleable_bifunctor.shrink _ _ sampleable_ext.shrink sampleable_ext.shrink,
  p_repr := sampleable_bifunctor.p_repr _ _ sampleable_ext.p_repr sampleable_ext.p_repr
  }

end prio

/-- `nat.shrink' k n` creates a list of smaller natural numbers by
successively dividing `n` by 2 and subtracting the difference from
`k`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink' (k : ℕ) : Π n : ℕ, n ≤ k →
  list { m : ℕ // has_well_founded.r m k } → list { m : ℕ // has_well_founded.r m k }
| n hn ls :=
if h : n ≤ 1
  then ls.reverse
  else
    have h₂ : 0 < n, by linarith,
    have 1 * n / 2 < n,
      from nat.div_lt_of_lt_mul (nat.mul_lt_mul_of_pos_right (by norm_num) h₂),
    have n / 2 < n, by simpa,
    let m := n / 2 in
    have h₀ : m ≤ k, from le_trans (le_of_lt this) hn,
    have h₃ : 0 < m,
      by simp only [m, lt_iff_add_one_le, zero_add]; rw [le_div_iff_mul_le]; linarith,
    have h₁ : k - m < k,
      from nat.sub_lt (lt_of_lt_of_le h₂ hn) h₃,
    nat.shrink' m h₀ (⟨k - m, h₁⟩ :: ls)

/-- `nat.shrink n` creates a list of smaller natural numbers by
successively dividing by 2 and subtracting the difference from
`n`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink (n : ℕ) : list { m : ℕ // has_well_founded.r m n } :=
if h : n > 0 then
  have ∀ k, 1 < k → n / k < n, from
    λ k hk,
     nat.div_lt_of_lt_mul
       (suffices 1 * n < k * n, by simpa,
        nat.mul_lt_mul_of_pos_right hk h),
  ⟨n/11, this _ (by norm_num)⟩ :: ⟨n/3, this _ (by norm_num)⟩ :: nat.shrink' n n (le_refl _) []
else
  []

open gen

/--
Transport a `sampleable` instance from a type `α` to a type `β` using
functions between the two, going in both directions.

Function `g` is used to define the well-founded order that
`shrink` is expected to follow.
-/
def sampleable.lift (α : Type u) {β : Type u} [sampleable α] (f : α → β) (g : β → α)
  (h : ∀ (a : α), sizeof (g (f a)) ≤ sizeof a) : sampleable β :=
{ wf := ⟨ sizeof ∘ g ⟩,
  sample := f <$> sample α,
  shrink := λ x,
    have ∀ a,  sizeof a < sizeof (g x) → sizeof (g (f a)) < sizeof (g x),
      by introv h'; solve_by_elim [lt_of_le_of_lt],
    subtype.map f this <$> shrink (g x) }

instance nat.sampleable : sampleable ℕ :=
{ sample := sized $ λ sz, freq [(1, coe <$> choose_any (fin $ succ (sz^3))),
                                (3, coe <$> choose_any (fin $ succ sz))] dec_trivial,
  shrink :=  λ x, lazy_list.of_list $ nat.shrink x }

/-- `iterate_shrink p x` takes a decidable predicate `p` and a
value `x` of some sampleable type and recursively shrinks `x`.
It first calls `shrink x` to get a list of candidate sample,
finds the first that satisfies `p` and recursively tries
to shrink that one. -/
def iterate_shrink {α} [has_to_string α] [sampleable α]
  (p : α → Prop) [decidable_pred p] :
  α → option α :=
well_founded.fix has_well_founded.wf $ λ x f_rec,
  do trace sformat!"{x} : {(shrink x).to_list}" $ pure (),
     y ← (shrink x).find (λ a, p a),
     f_rec y y.property <|> some y.val .

instance fin.sampleable {n} [fact $ 0 < n] : sampleable (fin n) :=
sampleable.lift ℕ fin.of_nat' subtype.val $
λ i, (mod_le _ _ : i % n ≤ i)

@[priority 100]
instance fin.sampleable' {n} : sampleable (fin (succ n)) :=
sampleable.lift ℕ fin.of_nat subtype.val $
λ i, (mod_le _ _ : i % succ n ≤ i)

instance pnat.sampleable : sampleable ℕ+ :=
sampleable.lift ℕ nat.succ_pnat pnat.nat_pred $ λ a,
by unfold_wf; simp only [pnat.nat_pred, succ_pnat, pnat.mk_coe, nat.sub_zero, succ_sub_succ_eq_sub]

/-- Redefine `sizeof` for `int` to make it easier to use with `nat` -/
def int.has_sizeof : has_sizeof ℤ := ⟨ int.nat_abs ⟩

local attribute [instance, priority 2000] int.has_sizeof

instance int.sampleable : sampleable ℤ :=
{ wf := _,
  sample := sized $ λ sz,
          freq [(1, subtype.val <$> choose (-(sz^3 + 1) : ℤ) (sz^3 + 1) (neg_le_self dec_trivial)),
                (3, subtype.val <$> choose (-(sz + 1)) (sz + 1) (neg_le_self dec_trivial))]
               dec_trivial,
  shrink :=
    λ x, lazy_list.of_list $ (nat.shrink $ int.nat_abs x).bind $
    λ ⟨y,h⟩, [⟨y, h⟩, ⟨-y, by dsimp [sizeof,has_sizeof.sizeof]; rw int.nat_abs_neg; exact h ⟩] }

instance bool.sampleable : sampleable bool :=
{ wf := ⟨ λ b, if b then 1 else 0 ⟩,
  sample := do { x ← choose_any bool,
                 return x },
  shrink := λ b, if h : b then lazy_list.singleton ⟨ff, by cases h; unfold_wf⟩
                          else lazy_list.nil }

/--
Provided two shrinking functions `prod.shrink` shrinks a pair `(x, y)` by
first shrinking `x` and pairing the results with `y` and then shrinking
`y` and pairing the results with `x`.

All pairs either contain `x` untouched or `y` untouched. We rely on
shrinking being repeated for `x` to get maximally shrunken and then
for `y` to get shrunken too.
-/
def prod.shrink {α β} [has_sizeof α] [has_sizeof β]
  (shr_a : shrink_fn α) (shr_b : shrink_fn β) : shrink_fn (α × β)
| ⟨x₀,x₁⟩ :=
  let xs₀ : lazy_list { y : α × β // sizeof_lt y (x₀,x₁) } :=
          (shr_a x₀).map $ subtype.map (λ a, (a, x₁))
                           (λ x h, by dsimp [sizeof_lt]; unfold_wf; apply h),
      xs₁ : lazy_list { y : α × β // sizeof_lt y (x₀,x₁) } :=
          (shr_b x₁).map $ subtype.map (λ a, (x₀, a))
                           (λ x h, by dsimp [sizeof_lt]; unfold_wf; apply h) in
  xs₀.append xs₁

instance prod.sampleable : sampleable_bifunctor.{u v} prod :=
{ wf := _,
  sample := λ α β sama samb, do
              { ⟨x⟩ ← (uliftable.up $ sama : gen (ulift.{max u v} α)),
                ⟨y⟩ ← (uliftable.up $ samb : gen (ulift.{max u v} β)),
                pure (x,y) },
  shrink := @prod.shrink,
  p_repr := @prod.has_repr }

instance sigma.sampleable {α β} [sampleable α] [sampleable β] : sampleable (Σ _ : α, β) :=
sampleable.lift (α × β) (λ ⟨x,y⟩, ⟨x,y⟩) (λ ⟨x,y⟩, ⟨x,y⟩) $ λ ⟨x,y⟩, le_refl _

/-- shrinking function for sum types -/
def sum.shrink {α β} [has_sizeof α] [has_sizeof β] (shrink_α : shrink_fn α)
  (shrink_β : shrink_fn β) : shrink_fn (α ⊕ β)
| (sum.inr x) := (shrink_β x).map $ subtype.map sum.inr $ λ a,
  by dsimp [sizeof_lt]; unfold_wf; solve_by_elim
| (sum.inl x) := (shrink_α x).map $ subtype.map sum.inl $ λ a,
  by dsimp [sizeof_lt]; unfold_wf; solve_by_elim

instance sum.sampleable : sampleable_bifunctor.{u v} sum :=
{ wf := _,
  sample := λ (α : Type u) (β : Type v) sam_α sam_β,
            (@uliftable.up_map gen.{u} gen.{max u v} _ _ _ _ (@sum.inl α β) sam_α <|>
             @uliftable.up_map gen.{v} gen.{max v u} _ _ _ _ (@sum.inr α β) sam_β),
  shrink := λ α β Iα Iβ shr_α shr_β, @sum.shrink _ _ Iα Iβ shr_α shr_β,
  p_repr := @sum.has_repr }

instance rat.sampleable : sampleable ℚ :=
sampleable.lift (ℤ × ℕ+) (λ x, prod.cases_on x rat.mk_pnat) (λ r, (r.num, ⟨r.denom, r.pos⟩)) $
begin
  intro i,
  rcases i with ⟨x,⟨y,hy⟩⟩; unfold_wf;
  dsimp [rat.mk_pnat],
  mono*,
  { rw [← int.coe_nat_le, ← int.abs_eq_nat_abs, ← int.abs_eq_nat_abs],
    apply int.abs_div_le_abs },
  { change _ - 1 ≤ y-1,
    apply nat.sub_le_sub_right,
    apply nat.div_le_of_le_mul,
    suffices : 1 * y ≤ x.nat_abs.gcd y * y, { simpa },
    apply nat.mul_le_mul_right,
    apply gcd_pos_of_pos_right _ hy }
end

/-- `sampleable_char` can be specialized into customized `sampleable char` instances.

The resulting instance has `1 / length` chances of making an unrestricted choice of characters
and it otherwise chooses a character from `characters` with uniform probabilities.  -/
def sampleable_char (length : nat) (characters : string) : sampleable char :=
{ sample := do { x ← choose_nat 0 length dec_trivial,
                 if x.val = 0 then do
                   n ← sample ℕ,
                   pure $ char.of_nat n
                 else do
                   i ← choose_nat 0 (characters.length - 1) dec_trivial,
                   pure (characters.mk_iterator.nextn i).curr },
  shrink := λ _, lazy_list.nil }

instance char.sampleable : sampleable char :=
sampleable_char 3 " 0123abcABC:,;`\\/"

variables {α}

section list_shrink

variables [has_sizeof α] (shr : Π x : α, lazy_list { y : α // sizeof_lt y x })

lemma list.sizeof_cons_lt_right (a b : α) {xs : list α} (h : sizeof a < sizeof b) :
  sizeof (a :: xs) < sizeof (b :: xs) :=
by unfold_wf; assumption

lemma list.sizeof_cons_lt_left (x : α) {xs xs' : list α} (h : sizeof xs < sizeof xs') :
  sizeof (x :: xs) < sizeof (x :: xs') :=
by unfold_wf; assumption

lemma list.sizeof_append_lt_left {xs ys ys' : list α} (h : sizeof ys < sizeof ys') :
  sizeof (xs ++ ys) < sizeof (xs ++ ys') :=
begin
  induction xs,
  { apply h },
  { unfold_wf,
    simp only [list.sizeof, add_lt_add_iff_left],
    exact xs_ih }
end

lemma list.one_le_sizeof (xs : list α) : 1 ≤ sizeof xs :=
by cases xs; unfold_wf; [refl, linarith]

/--
`list.shrink_removes` shrinks a list by removing chunks of size `k` in
the middle of the list.
-/
def list.shrink_removes (k : ℕ) (hk : 0 < k) : Π (xs : list α) n,
  n = xs.length → lazy_list { ys : list α // sizeof_lt ys xs }
| xs n hn :=
  if hkn : k > n then lazy_list.nil
  else
  if hkn' : k = n then
    have 1 < xs.sizeof,
      by { subst_vars, cases xs, { contradiction },
           unfold_wf, apply lt_of_lt_of_le,
           show 1 < 1 + has_sizeof.sizeof xs_hd + 1, { linarith },
           { mono, apply list.one_le_sizeof, } },
    lazy_list.singleton ⟨[], this ⟩
  else
    have h₂ : k < xs.length, from hn ▸ lt_of_le_of_ne (le_of_not_gt hkn) hkn',
    match list.split_at k xs, rfl : Π ys, ys = list.split_at k xs → _ with
    |  ⟨xs₁,xs₂⟩, h :=
      have h₄ : xs₁ = xs.take k,
        by simp only [list.split_at_eq_take_drop, prod.mk.inj_iff] at h; tauto,
      have h₃ : xs₂ = xs.drop k,
        by simp only [list.split_at_eq_take_drop, prod.mk.inj_iff] at h; tauto,
      have sizeof xs₂ < sizeof xs,
        by rw h₃; solve_by_elim [list.sizeof_drop_lt_sizeof_of_lt_length],
      have h₁ : n - k = xs₂.length,
        by simp only [h₃, ←hn, list.length_drop],
      have h₅ : ∀ (a : list α), sizeof_lt a xs₂ → sizeof_lt (xs₁ ++ a) xs,
        by intros a h; rw [← list.take_append_drop k xs, ← h₃, ← h₄];
          solve_by_elim [list.sizeof_append_lt_left],
      lazy_list.cons ⟨xs₂, this⟩ $ subtype.map ((++) xs₁) h₅ <$> list.shrink_removes xs₂ (n - k) h₁
    end

/--
`list.shrink_one xs` shrinks list `xs` by shrinking only one item in
the list.
-/
def list.shrink_one : shrink_fn (list α)
| [] := lazy_list.nil
| (x :: xs) :=
  lazy_list.append
    (subtype.map (λ x', x' :: xs) (λ a,  list.sizeof_cons_lt_right _ _) <$> shr x)
    (subtype.map ((::) x) (λ _, list.sizeof_cons_lt_left _) <$> list.shrink_one xs)

/-- `list.shrink_with shrink_f xs` shrinks `xs` by first
considering `xs` with chunks removed in the middle (starting with
chunks of size `xs.length` and halving down to `1`) and then
shrinks only one element of the list.

This strategy is taken directly from Haskell's QuickCheck -/
def list.shrink_with (xs : list α) :
  lazy_list { ys : list α // sizeof_lt ys xs } :=
let n := xs.length in
lazy_list.append
  ((lazy_list.cons n $ (shrink n).reverse.map subtype.val).bind (λ k,
    if hk : 0 < k
    then list.shrink_removes k hk xs n rfl
    else lazy_list.nil ))
  (list.shrink_one shr _)

end list_shrink

instance list.sampleable : sampleable_functor list.{u} :=
{ wf := _,
  sample := λ α sam_α, list_of sam_α,
  shrink := λ α Iα shr_α, @list.shrink_with _ Iα shr_α,
  p_repr := @list.has_repr }

instance prop.sampleable_ext : sampleable_ext Prop :=
{ proxy_repr := bool,
  interp := coe,
  sample := choose_any bool,
  shrink := λ _, lazy_list.nil }

/-- `no_shrink` is a type annotation to signal that
a certain type is not to be shrunk. It can be useful in
combination with other types: e.g. `xs : list (no_shrink ℤ)`
will result in the list being cut down but individual
integers being kept as is. -/
def no_shrink (α : Type*) := α

instance no_shrink.inhabited {α} [inhabited α] : inhabited (no_shrink α) :=
⟨ (default α : α) ⟩

/-- Introduction of the `no_shrink` type. -/
def no_shrink.mk {α} (x : α) : no_shrink α := x

/-- Selector of the `no_shrink` type. -/
def no_shrink.get {α} (x : no_shrink α) : α := x

instance no_shrink.sampleable {α} [sampleable α] : sampleable (no_shrink α) :=
{ sample := no_shrink.mk <$> sample α }

instance string.sampleable : sampleable string :=
{ sample := do { x ← list_of (sample char), pure x.as_string },
  .. sampleable.lift (list char) list.as_string string.to_list $ λ _, le_refl _ }

/-- implementation of `sampleable (tree α)` -/
def tree.sample (sample : gen α) : ℕ → gen (tree α) | n :=
if h : n > 0
then have n / 2 < n, from div_lt_self h (by norm_num),
     tree.node <$> sample <*> tree.sample (n / 2) <*> tree.sample (n / 2)
else pure tree.nil

/-- `rec_shrink x f_rec` takes the recursive call `f_rec` introduced
by `well_founded.fix` and turns it into a shrinking function whose
result is adequate to use in a recursive call. -/
def rec_shrink {α : Type*} [has_sizeof α] (t : α)
  (sh : Π x : α, sizeof_lt x t → lazy_list { y : α // sizeof_lt y x }) :
  shrink_fn { t' : α // sizeof_lt t' t }
| ⟨t',ht'⟩ := (λ t'' : { y : α // sizeof_lt y t' },
    ⟨⟨t''.val, lt_trans t''.property ht'⟩, t''.property⟩ ) <$> sh t' ht'

lemma tree.one_le_sizeof {α} [has_sizeof α] (t : tree α) : 1 ≤ sizeof t :=
by cases t; unfold_wf; linarith

instance : functor tree :=
{ map := @tree.map }

/--
Recursion principle for shrinking tree-like structures.
-/
def rec_shrink_with [has_sizeof α]
  (shrink_a : Π x : α, shrink_fn { y : α // sizeof_lt y x } →
    list (lazy_list { y : α // sizeof_lt y x })) :
  shrink_fn α :=
well_founded.fix (sizeof_measure_wf _) $ λ t f_rec,
lazy_list.join
    (lazy_list.of_list $
      shrink_a t $ λ ⟨t', h⟩, rec_shrink _ f_rec _)

lemma rec_shrink_with_eq [has_sizeof α]
  (shrink_a : Π x : α, shrink_fn { y : α // sizeof_lt y x } →
    list (lazy_list { y : α // sizeof_lt y x }))
  (x : α) :
  rec_shrink_with shrink_a x =
  lazy_list.join
    (lazy_list.of_list $ shrink_a x $ λ t', rec_shrink _ (λ x h', rec_shrink_with shrink_a x) _) :=
begin
  conv_lhs { rw [rec_shrink_with, well_founded.fix_eq], },
  congr, ext ⟨y, h⟩, refl
end

/-- `tree.shrink_with shrink_f t` shrinks `xs` by using the empty tree,
each subtrees, and by shrinking the subtree to recombine them.

This strategy is taken directly from Haskell's QuickCheck -/
def tree.shrink_with [has_sizeof α] (shrink_a : shrink_fn α) : shrink_fn (tree α) :=
rec_shrink_with $ λ t,
match t with
| tree.nil := λ f_rec, []
| (tree.node x t₀ t₁) :=
λ f_rec,
  have h₂ : sizeof_lt tree.nil (tree.node x t₀ t₁),
    by clear _match; have := tree.one_le_sizeof t₀;
       dsimp [sizeof_lt, sizeof, has_sizeof.sizeof] at *;
       unfold_wf; linarith,
  have h₀ : sizeof_lt t₀ (tree.node x t₀ t₁),
    by dsimp [sizeof_lt]; unfold_wf; linarith,
  have h₁ : sizeof_lt t₁ (tree.node x t₀ t₁),
    by dsimp [sizeof_lt]; unfold_wf; linarith,
  [lazy_list.of_list [⟨tree.nil, h₂⟩, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩],
   (prod.shrink shrink_a (prod.shrink f_rec f_rec) (x, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩)).map
    $ λ ⟨⟨y,⟨t'₀, _⟩,⟨t'₁, _⟩⟩,hy⟩, ⟨tree.node y t'₀ t'₁,
      by revert hy; dsimp [sizeof_lt]; unfold_wf; intro; linarith⟩]
end

instance sampleable_tree : sampleable_functor tree :=
{ wf := _,
  sample := λ α sam_α, sized $ tree.sample sam_α,
  shrink := λ α Iα shr_α, @tree.shrink_with _ Iα shr_α,
  p_repr := @tree.has_repr }

/-- Type tag that signals to `slim_check` to use small values for a given type. -/
def small (α : Type*) := α

/-- Add the `small` type tag -/
def small.mk {α} (x : α) : small α := x

/-- Type tag that signals to `slim_check` to use large values for a given type. -/
def large (α : Type*) := α

/-- Add the `large` type tag -/
def large.mk {α} (x : α) : large α := x

instance small.functor : functor small := id.monad.to_functor
instance large.functor : functor large := id.monad.to_functor
instance small.inhabited [inhabited α] : inhabited (small α) := ⟨ (default α : α) ⟩
instance large.inhabited [inhabited α] : inhabited (large α) := ⟨ (default α : α) ⟩

instance small.sampleable_functor : sampleable_functor small :=
{ wf := _,
  sample := λ α samp, gen.resize (λ n, n / 5 + 5) samp,
  shrink := λ α _, id,
  p_repr := λ α, id }

instance large.sampleable_functor : sampleable_functor large :=
{ wf := _,
  sample := λ α samp, gen.resize (λ n, n * 5) samp,
  shrink := λ α _, id,
  p_repr := λ α, id }

instance ulift.sampleable_functor : sampleable_functor ulift.{u v} :=
{ wf := λ α h, ⟨ λ ⟨x⟩, @sizeof α h x ⟩,
  sample := λ α samp, uliftable.up_map ulift.up $ samp,
  shrink := λ α _ shr ⟨x⟩, (shr x).map (subtype.map ulift.up (λ a h, h)),
  p_repr := λ α h, ⟨ @repr α h ∘ ulift.down ⟩ }

/-!
## Subtype instances

The following instances are meant to improve the testing of properties of the form
`∀ i j, i ≤ j, ...`

The naive way to test them is to choose two numbers `i` and `j` and check that
the proper ordering is satisfied. Instead, the following instances make it
so that `j` will be chosen with considerations to the required ordering
constraints. The benefit is that we will not have to discard any choice
of `j`.
 -/

/-! ### Subtypes of `ℕ` -/

instance nat_le.sampleable {y} : slim_check.sampleable { x : ℕ // x ≤ y } :=
{ sample :=
         do { ⟨x,h⟩ ← slim_check.gen.choose_nat 0 y dec_trivial,
              pure ⟨x, h.2⟩},
  shrink := λ ⟨x, h⟩, (λ a : subtype _, subtype.rec_on a $
    λ x' h', ⟨⟨x', le_trans (le_of_lt h') h⟩, h'⟩) <$> shrink x }

instance nat_ge.sampleable {x} : slim_check.sampleable { y : ℕ // x ≤ y } :=
{ sample :=
         do { (y : ℕ) ← slim_check.sampleable.sample ℕ,
              pure ⟨x+y, by norm_num⟩ },
  shrink := λ ⟨y, h⟩, (λ a : { y' // sizeof y' < sizeof (y - x) },
    subtype.rec_on a $ λ δ h', ⟨⟨x + δ, nat.le_add_right _ _⟩, nat.add_lt_of_lt_sub_left h'⟩) <$>
      shrink (y - x) }

/- there is no `nat_lt.sampleable` instance because if `y = 0`, there is no valid choice
to satisfy `x < y` -/

instance nat_gt.sampleable {x} : slim_check.sampleable { y : ℕ // x < y } :=
{ sample :=
         do { (y : ℕ) ← slim_check.sampleable.sample ℕ,
              pure ⟨x+y+1, by linarith⟩ },
  shrink := λ x, shrink _ }

/-! ### Subtypes of any `linear_ordered_add_comm_group` -/

instance le.sampleable {y : α} [sampleable α] [linear_ordered_add_comm_group α] :
  slim_check.sampleable { x : α // x ≤ y } :=
{ sample :=
         do { x ← sample α,
              pure ⟨y - abs x, sub_le_self _ (abs_nonneg _) ⟩ },
  shrink := λ _, lazy_list.nil }

instance ge.sampleable {x : α}  [sampleable α] [linear_ordered_add_comm_group α] :
  slim_check.sampleable { y : α // x ≤ y } :=
{ sample :=
         do { y ← sample α,
              pure ⟨x + abs y, by norm_num [abs_nonneg]⟩ },
  shrink := λ _, lazy_list.nil }

/-!
### Subtypes of `ℤ`

Specializations of `le.sampleable` and `ge.sampleable` for `ℤ` to help instance search.
-/

instance int_le.sampleable {y : ℤ} : slim_check.sampleable { x : ℤ // x ≤ y } :=
sampleable.lift ℕ (λ n, ⟨y - n, int.sub_left_le_of_le_add $ by simp⟩) (λ ⟨i, h⟩, (y - i).nat_abs)
  (λ n, by unfold_wf; simp [int_le.sampleable._match_1]; ring)

instance int_ge.sampleable {x : ℤ} : slim_check.sampleable { y : ℤ // x ≤ y } :=
sampleable.lift ℕ (λ n, ⟨x + n, by simp⟩) (λ ⟨i, h⟩, (i - x).nat_abs)
  (λ n, by unfold_wf; simp [int_ge.sampleable._match_1]; ring)

instance int_lt.sampleable {y} : slim_check.sampleable { x : ℤ // x < y } :=
sampleable.lift ℕ (λ n, ⟨y - (n+1), int.sub_left_lt_of_lt_add $
    by linarith [int.coe_nat_nonneg n]⟩)
  (λ ⟨i, h⟩, (y - i - 1).nat_abs)
  (λ n, by unfold_wf; simp [int_lt.sampleable._match_1]; ring)

instance int_gt.sampleable {x} : slim_check.sampleable { y : ℤ // x < y } :=
sampleable.lift ℕ (λ n, ⟨x + (n+1), by linarith⟩) (λ ⟨i, h⟩, (i - x - 1).nat_abs)
  (λ n, by unfold_wf; simp [int_gt.sampleable._match_1]; ring)

/-! ### Subtypes of any `list` -/

instance perm.slim_check {xs : list α} : slim_check.sampleable { ys : list α // list.perm xs ys } :=
{ sample := permutation_of xs,
  shrink := λ _, lazy_list.nil }

instance perm'.slim_check {xs : list α} :
  slim_check.sampleable { ys : list α // list.perm ys xs } :=
{ sample := subtype.map id (@list.perm.symm α _) <$> permutation_of xs,
  shrink := λ _, lazy_list.nil }

setup_tactic_parser
open tactic

/--
Print (at most) 10 samples of a given type to stdout for debugging.
-/
def print_samples {t : Type u} [has_repr t] (g : gen t) : io unit := do
xs ← io.run_rand $ uliftable.down $
  do { xs ← (list.range 10).mmap $ g.run ∘ ulift.up,
       pure ⟨xs.map repr⟩ },
xs.mmap' io.put_str_ln

/-- Create a `gen α` expression from the argument of `#sample` -/
meta def mk_generator (e : expr) : tactic (expr × expr) := do
t ← infer_type e,
match t with
| `(gen %%t) := do
  repr_inst ← mk_app ``has_repr [t] >>= mk_instance,
  pure (repr_inst, e)
| _ := do
  samp_inst ← to_expr ``(sampleable_ext %%e) >>= mk_instance,
  repr_inst ← mk_mapp ``sampleable_ext.p_repr [e, samp_inst],
  gen ← mk_mapp ``sampleable_ext.sample [none, samp_inst],
  pure (repr_inst, gen)
end

/--
`#sample my_type`, where `my_type` has an instance of `sampleable`, prints ten random
values of type `my_type` of using an increasing size parameter.

```lean
#sample nat
-- prints
-- 0
-- 0
-- 2
-- 24
-- 64
-- 76
-- 5
-- 132
-- 8
-- 449
-- or some other sequence of numbers

#sample list int
-- prints
-- []
-- [1, 1]
-- [-7, 9, -6]
-- [36]
-- [-500, 105, 260]
-- [-290]
-- [17, 156]
-- [-2364, -7599, 661, -2411, -3576, 5517, -3823, -968]
-- [-643]
-- [11892, 16329, -15095, -15461]
-- or whatever
```
-/
@[user_command]
meta def sample_cmd (_ : parse $ tk "#sample") : lean.parser unit :=
do e ← texpr,
   of_tactic $ do
     e ← i_to_expr e,
     (repr_inst, gen) ← mk_generator e,
     print_samples ← mk_mapp ``print_samples [none, repr_inst, gen],
     sample ← eval_expr (io unit) print_samples,
     unsafe_run_io sample

end slim_check


/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import analysis.specific_limits

/-!
# Hofer's lemma

This is an elementary lemma about complete metric spaces. It is motivated by an
application to the bubbling-off analysis for holomorphic curves in symplectic topology.
We are *very* far away from having these applications, but the proof here is a nice
example of a proof needing to construct a sequence by induction in the middle of the proof.

## References:

* H. Hofer and C. Viterbo, *The Weinstein conjecture in the presence of holomorphic spheres*
-/

open_locale classical topological_space big_operators
open filter finset

local notation `d` := dist

lemma hofer {X: Type*} [metric_space X] [complete_space X]
  (x : X) (ε : ℝ) (ε_pos : 0 < ε)
  {ϕ : X → ℝ} (cont : continuous ϕ) (nonneg : ∀ y, 0 ≤ ϕ y) :
  ∃ (ε' > 0) (x' : X), ε' ≤ ε ∧
                       d x' x ≤ 2*ε ∧
                       ε * ϕ(x) ≤ ε' * ϕ x' ∧
                       ∀ y, d x' y ≤ ε' → ϕ y ≤ 2*ϕ x' :=
begin
  by_contradiction H,
  have reformulation : ∀ x' (k : ℕ), ε * ϕ x ≤ ε / 2 ^ k * ϕ x' ↔ 2^k * ϕ x ≤ ϕ x',
  { intros x' k,
    rw [div_mul_eq_mul_div, le_div_iff, mul_assoc, mul_le_mul_left ε_pos, mul_comm],
    exact pow_pos (by norm_num) k, },
  -- Now let's specialize to `ε/2^k`
  replace H : ∀ k : ℕ, ∀ x', d x' x ≤ 2 * ε ∧ 2^k * ϕ x ≤ ϕ x' →
    ∃ y, d x' y ≤ ε/2^k ∧ 2 * ϕ x' < ϕ y,
  { intros k x',
    push_neg at H,
    simpa [reformulation] using
      H (ε/2^k) (by simp [ε_pos, zero_lt_two]) x' (by simp [ε_pos, zero_lt_two, one_le_two]) },
  clear reformulation,
  haveI : nonempty X := ⟨x⟩,
  choose! F hF using H,  -- Use the axiom of choice
  -- Now define u by induction starting at x, with u_{n+1} = F(n, u_n)
  let u : ℕ → X := λ n, nat.rec_on n x F,
  have hu0 : u 0 = x := rfl,
  -- The properties of F translate to properties of u
  have hu :
    ∀ n,
      d (u n) x ≤ 2 * ε ∧ 2^n * ϕ x ≤ ϕ (u n) →
      d (u n) (u $ n + 1) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u $ n + 1),
  { intro n,
    exact hF n (u n) },
  clear hF,
  -- Key properties of u, to be proven by induction
  have key : ∀ n, d (u n) (u (n + 1)) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u (n + 1)),
  { intro n,
    induction n using nat.case_strong_induction_on with n IH,
    { specialize hu 0,
      simpa [hu0, mul_nonneg_iff, zero_le_one, ε_pos.le, le_refl] using hu },
    have A : d (u (n+1)) x ≤ 2 * ε,
    { rw [dist_comm],
      let r := range (n+1), -- range (n+1) = {0, ..., n}
      calc
      d (u 0) (u (n + 1))
          ≤ ∑ i in r, d (u i) (u $ i+1) : dist_le_range_sum_dist u (n + 1)
      ... ≤ ∑ i in r, ε/2^i             : sum_le_sum (λ i i_in, (IH i $ nat.lt_succ_iff.mp $
                                                                  finset.mem_range.mp i_in).1)
      ... = ∑ i in r, (1/2)^i*ε         : by { congr' with i, field_simp }
      ... = (∑ i in r, (1/2)^i)*ε       : finset.sum_mul.symm
      ... ≤ 2*ε                         : mul_le_mul_of_nonneg_right (sum_geometric_two_le _)
                                            (le_of_lt ε_pos), },
    have B : 2^(n+1) * ϕ x ≤ ϕ (u (n + 1)),
    { refine @geom_le (ϕ ∘ u) _ zero_le_two (n + 1) (λ m hm, _),
      exact (IH _ $ nat.lt_add_one_iff.1 hm).2.le },
    exact hu (n+1) ⟨A, B⟩, },
  cases forall_and_distrib.mp key with key₁ key₂,
  clear hu key,
  -- Hence u is Cauchy
  have cauchy_u : cauchy_seq u,
  { refine cauchy_seq_of_le_geometric _ ε one_half_lt_one (λ n, _),
    simpa only [one_div, inv_pow₀] using key₁ n },
  -- So u converges to some y
  obtain ⟨y, limy⟩ : ∃ y, tendsto u at_top (𝓝 y),
    from complete_space.complete cauchy_u,
  -- And ϕ ∘ u goes to +∞
  have lim_top : tendsto (ϕ ∘ u) at_top at_top,
  { let v := λ n, (ϕ ∘ u) (n+1),
    suffices : tendsto v at_top at_top,
      by rwa tendsto_add_at_top_iff_nat at this,
    have hv₀ : 0 < v 0,
    { have : 0 ≤ ϕ (u 0) := nonneg x,
      calc 0 ≤ 2 * ϕ (u 0) : by linarith
      ... < ϕ (u (0 + 1)) : key₂ 0 },
    apply tendsto_at_top_of_geom_le hv₀ one_lt_two,
    exact λ n, (key₂ (n+1)).le },
  -- But ϕ ∘ u also needs to go to ϕ(y)
  have lim : tendsto (ϕ ∘ u) at_top (𝓝 (ϕ y)),
    from tendsto.comp cont.continuous_at limy,
  -- So we have our contradiction!
  exact not_tendsto_at_top_of_tendsto_nhds lim lim_top,
end


import order.filter.at_top_bot
import o_minimal.o_minimal

-- More facts about tame sets.

open o_minimal

variables {R : Type*} [DUNLO R]

lemma ball_or {α : Type*} (p q r : α → Prop) :
  (∀ a, (p a ∨ q a) → r a) ↔ (∀ a, p a → r a) ∧ (∀ a, q a → r a) :=
⟨λ H, ⟨λ a h, H a (or.inl h), λ a h, H a (or.inr h)⟩,
 λ H a o, o.cases_on (H.1 a) (H.2 a)⟩

lemma exists_tInf {s : set R} (ts : tame s) (ne : s.nonempty) (bdd : bdd_below s) :
  ∃ m, is_glb s m :=
begin
  revert ne bdd,
  refine tame.induction _ _ ts; clear ts s,
  { rintro ⟨_, ⟨⟩⟩ },
  { rintros s i hi IH - bdd,    -- `ne` can never be useful at this point.
    have bdd' : bdd_below s := bdd.mono (by simp),
    induction hi with r a b a b hab; clear i,
    -- We used `induction` because `cases` does too much unfolding.
    -- Unfortunately `induction` does not generate `case` tags.
    -- In two cases, the new set is obviously not bounded below;
    -- dispose of those first.
    -- TODO: Make these two cases lemmas (for `order.bounds`).
    swap 2,                     -- Iii
    { exfalso,
      rcases bdd with ⟨z, hz⟩,
      obtain ⟨y, hy : y < z⟩ := no_bot z,
      exact not_le_of_lt hy (hz (by simp)) },
    swap 3,                     -- Iio
    { exfalso,
      rcases bdd with ⟨z, hz⟩,
      obtain ⟨c, hc : c < b⟩ := no_bot b,
      obtain ⟨y, hy : y < min c z⟩ := no_bot (min c z),
      refine not_le_of_lt (lt_of_lt_of_le hy (min_le_right _ _)) (hz (or.inl _)),
      calc y < min c z : hy
       ...   ≤ c       : min_le_left _ _
       ...   < b       : hc },
    -- In the remaining goals we'll do case analysis on whether
    -- `s` is empty (and thus can be ignored) or nonempty (and thus we can use IH).
    all_goals {
      clear bdd,
      rcases set.eq_empty_or_nonempty s with rfl|ne';
      [ { clear IH bdd', simp only [set.union_empty] },
        { specialize IH ne' bdd', clear ne' bdd', cases IH with l IH }] },
    { exact ⟨_, is_glb_singleton⟩ },
    { exact ⟨_, is_glb.union is_glb_singleton IH⟩ },
    { exact ⟨_, is_glb_Ioi⟩ },
    { exact ⟨_, is_glb.union is_glb_Ioi IH⟩ },
    { exact ⟨_, is_glb_Ioo hab⟩ },
    { exact ⟨_, is_glb.union (is_glb_Ioo hab) IH⟩ } }
end

-- TODO: Make this not a copy&paste of above.
lemma exists_tSup {s : set R} (ts : tame s) (ne : s.nonempty) (bdd : bdd_above s) :
  ∃ m, is_lub s m :=
begin
  revert ne bdd,
  refine tame.induction _ _ ts; clear ts s,
  { rintro ⟨_, ⟨⟩⟩ },
  { rintros s i hi IH - bdd,    -- `ne` can never be useful at this point.
    have bdd' : bdd_above s := bdd.mono (by simp),
    induction hi with r a b a b hab; clear i,
    -- We used `induction` because `cases` does too much unfolding.
    -- Unfortunately `induction` does not generate `case` tags.
    -- In two cases, the new set is obviously not bounded above;
    -- dispose of those first.
    -- TODO: Make these two cases lemmas (for `order.bounds`).
    swap 2,                     -- Iii
    { exfalso,
      rcases bdd with ⟨z, hz⟩,
      obtain ⟨y, hy : y > z⟩ := no_top z,
      exact not_le_of_lt hy (hz (by simp)) },
    swap 2,                     -- Ioi
    { exfalso,
      rcases bdd with ⟨z, hz⟩,
      obtain ⟨c, hc : c > a⟩ := no_top a,
      obtain ⟨y, hy : y > max c z⟩ := no_top (max c z),
      refine not_le_of_lt (lt_of_le_of_lt (le_max_right _ _) hy) (hz (or.inl _)),
      calc y > max c z : hy
       ...   ≥ c       : le_max_left _ _
       ...   > a       : hc },
    -- In the remaining goals we'll do case analysis on whether
    -- `s` is empty (and thus can be ignored) or nonempty (and thus we can use IH).
    all_goals {
      clear bdd,
      rcases set.eq_empty_or_nonempty s with rfl|ne';
      [ { clear IH bdd', simp only [set.union_empty] },
        { specialize IH ne' bdd', clear ne' bdd', cases IH with l IH }] },
    { exact ⟨_, is_lub_singleton⟩ },
    { exact ⟨_, is_lub.union is_lub_singleton IH⟩ },
    { exact ⟨_, is_lub_Iio⟩ },
    { exact ⟨_, is_lub.union is_lub_Iio IH⟩ },
    { exact ⟨_, is_lub_Ioo hab⟩ },
    { exact ⟨_, is_lub.union (is_lub_Ioo hab) IH⟩ } }
end

/-- X ↦ inf X as a partial function. Defined when X is tame, nonempty and bounded below. -/
noncomputable def tInf : set R →. R :=
λ X, { dom := tame X ∧ X.nonempty ∧ bdd_below X, get := λ h, classical.some (exists_tInf h.1 h.2.1 h.2.2) }

/-- X ↦ inf X as a partial function. Defined when X is tame, nonempty and bounded above. -/
noncomputable def tSup : set R →. R :=
λ X, { dom := tame X ∧ X.nonempty ∧ bdd_above X, get := λ h, classical.some (exists_tSup h.1 h.2.1 h.2.2) }


/- Copyright (c) 2022 Sina Hazratpour. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
----------------
# Basics of Categories
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

/-
-- "_Category theory takes a bird’s eye view of mathematics. From high in the sky, details become invisible, but we can spot patterns that were impossible to de- tect from ground level._"

-- From "Basic Category Theory" by Tom Leinster
-- -/

-- import tactic.basic
import ..prooflab
import lectures.lec15_integers
import tactic.basic

open PROOFS
open PROOFS.STR

/-
We already have so far seen many interesting __objects__ in this course:

- Types (introduced in lecture 1)
- Pointed Types (introduced in lecture 11)
- Propositions (introduced in lecture 1 and 6) and Predicates/Relations (introduced in lecture 7)
- Graphs (introduced in hackathon)
- Quasigroups (introduced HW 8)
- Semigroups
- Monoids (natural numbers, endofunctions, endomorphism of monoids)
- Commutative monoids (a monoid where multiplication/addition operation is commutative, e.g. fake natural numbers `mat`, ℕ, ℤ, ℤ[i],  )
- Groups (introduced as an extension of the strucute of monoids (monoids with inverses), e.g. integers and gaussian integers ℤ[i], group of auto-functions (functions `X → X` which are equivalences.))
- Commutative rings (two operations (+, *), e.g. integers and gaussian integers)
-/

/-
In each case, we have seen how to __relate__ objects of the same kind by an appropriate notion of __map__ (also called  __morphism__) between them:

- Function between types (`f : X → Y`, e.g. `bool_of_nat` relates `nat` to `bool`, `nat_of_bool`, many coercion functions, for instance from integers to Gaussian integers. )
- Pointed functions (i.e. functions which preserved the points of pointed type domain) (`f : (X, x : X) → (Y, y : Y)` where `f x = y`)
- Derivations of propositions (`P → Q` if we can derived `Q`from `P`)
- Graph homomorphism between graphs (they preserve adjacency relation)
- Monoid homomorphism between monoids (they preserve multiplication/addition operation)
- Group homomorphism between groups (they preserve multiplication/addition operation)
- Ring homomorphism between commutative rings (they preserve multiplication and addition operations)
-/

/-
Furthermore, we can __compose__ such maps. For instance in the Graph hackathon we composed homomorphisms of graphs and in HW10 you defined the composition of monoid morphisms.

Recall HW10.Q1
@[simp]
def mult_monoid.morphism.comp (g : M →ₘ* N) (f : L →ₘ* M)  : L →ₘ* N :=
{ to_fun := g ∘ f,
  resp_one := sorry,
  resp_mul := sorry, }

And in all of the above cases we established an __identity__ function or homomorphism for each object `X` which is netural with respect to composition.
-/

/-
This common pattern can be generalized to the abstract notion of category_str. A __category_str__ consitsts of

1. a collection of __objects__,
2.  a collection of __morphisms__, (maps between objects)
3. a composition operation whereby we can compose simpler morphisms and build complex morphisms,
4. an operation which provides identiry morphism for each object in the category_str.

And these data satisfy the axioms of __associativity__ and (left/right) __unitality__.
-/

/-
Many of the categories one meets in practice have as objects types with some structure attached to them and as have as morphisms functions or homomorphisms (i.e. structure-preserving functions) between them. This is a good model to keep in mind at the outset.

Therefore, a category_str may be viewed as consisting of objects bearing a certain kind of structure together with morphisms/mappings between such objects preserving that structure.

For instance, in the rest of the course we shall construct the following categories:

-- __Graph__ : the category_str of graphs and graph homomorphisms (the objects of this category_str are __simple graphs__, and morphisms are __graph homomorphisms__)
-- __Mon__ : the category_str of monoids and monoid homomorphisms (the objects of this category_str are monoids, and morphisms are monoid homomorphisms)
-- __Group__ : the category_str of groups and groups homomorphisms
-/

/-
However, there are categories which are not the categories of structures. We construct a category_str whose objects are natural numbers `1,2,3, ...` and whose morphisms are matrices.
-/

/- ## Some Philosophical Remarks
1. A category is a __system__ which has objects and relations between these objects. The objects do not live in isolation: morphisms bind them together.
2. What is more important is the relations (i.e. morphisms): In fact, two objects are the same if they have the same relations to all other objects. This is known as the __Yoneda Lemma__ which we shall discuss in the last lecture.  Therefore, an object in a category is fully determined by its relations to other objects. Note that this is a not necessarily true for other systems of objects and relations. Is it true for instance than an animal is fully determined by the total sum of its relation to all other animals (including oneself, c.f. being vs becoming).
-/

/-
A preliminary ad-hoc structure on the way to defining the category structure, containing only the data of hom-types, the operations of identity and composition.
Later, we extend the structure of precategory_str to category_str.
-/

--library_note "category_str_theory universes"

/-
In the mathematical language Lean, types are organized into a hierarchy of universe levels, with each level representing a different __universe__ of types that are considered to be of a certain size or complexity. This hierarchy allows for a more structured and well-defined approach to working with types, while __avoiding the inconsistencies and paradoxes that can arise from allowing for the existence of a type of all types__.

It is possible to define a type in Lean that represents the collection of all types, but this is done in a more carefully __controlled__ manner than simply allowing for the existence of a type of all types. Universe levels are consistency control parameters.
-/
universes v u -- this handles the distinction between small and large categories -- universe variables are inserted in the order that they were declared.

class precategory_str (obj : Type u) : Type (max u (v+1))  :=
(hom : obj → obj → Type v) -- for any two objects `X : obj` and `Y : obj` we have the type `hom X Y` of morphisms between `X` and `Y`
(id       : Π X : obj, hom X X) -- specifies identity morphism for all types
(comp     : Π {X Y Z : obj}, (hom X Y) → (hom Y Z) → (hom X Z) )
-- ( id       : Π X : obj, hom X X )
-- ( comp     : Π {X Y Z : obj}, (hom Y Z) → (hom X Y) → (hom X Z) )

#check precategory_str
--#print precategory_str

/-! #### notation remarks
There is a special notation for the morphisms in a category_str: if `X Y : C`, we write

-  `X ⟶ Y` for the type `hom X Y`  of morphisms from `X` to `Y`.  Note: X ⟶ Y is entirely different than the type X → Y of functions from `X` to `Y`.
  (To enter the special arrow `⟶`, type `\h` or `\hom`, or hover over the symbol to see the hint.)

- `𝟙 X` is a the identity morphisms on `X` (i.e., a term of type `X ⟶ X`).  (To enter the special arrow `𝟙`, type `\b1` or hover over the symbol to see the hint.)

- If `f : X ⟶ Y` and `g : Y ⟶ Z`, then we write `g ⊚ f` for the composition, a morphism `X ⟶ Z`. -- this is composition in every category_str, not necessarily in the category_str of types
-/

infixr ` ⟶ `:10 := precategory_str.hom -- type as \h
notation `𝟙` := precategory_str.id -- type as \b1
-- infixr ` ⊚ `:80 := precategory_str.comp-- type as \oo

local notation f ` ⊚ `:80 g:80 := precategory_str.comp g f    -- type as \oo

section
variables {𝓒 : Type} [precategory_str 𝓒]
variables W X Y Z : 𝓒 -- terms of type C can be regarded as objects of precategory_str 𝓒
#check X ⟶ Y
variables f₀ f₁ : X ⟶ Y
variables g₀ g₁ : Y ⟶ Z
#check 𝟙 X
--#check f₀ ⊚ g₀ -- this does not type check because the composition goes the other way round.
#check g₀ ⊚ f₀
--#check f₀ ⊚ g₁
#check g₁ ⊚ f₀

end

/-
- Now, we add the axioms of __unitality__ and __associativity__ to extend the structure of a precategory_str to a category_str.
- The typeclass `category_str C` describes morphisms associated to objects of type `C`.
-/

class category_str (obj : Type u) extends precategory_str.{v} obj : Type (max u (v+1)) :=
(id_comp' : ∀ {X Y : obj} (f : hom X Y), f ⊚ (𝟙 X)  = f . obviously) -- naming based diagrammatic order of composition
(comp_id' : ∀ {X Y : obj} (f : hom X Y), (𝟙 Y) ⊚ f = f . obviously)
(comp_assoc'   : ∀ {W X Y Z : obj} (f : hom W X) (g : hom X Y) (h : hom Y Z),
  (h ⊚ g) ⊚ f = h ⊚ (g ⊚ f) . obviously)

#check category_str.id_comp'

set_option trace.simp_lemmas true

instance : category_str ℕ :=
{ hom := λ x, λ y, plift (x ≤ y),
  id := λ x, ⟨ le_refl x ⟩,
  comp := λ x y z, λ f, λ g, ⟨le_trans f.down g.down ⟩,
  id_comp' := by {intros X Y f, simp},
  comp_id' := by {intros X Y f, simp},
  comp_assoc' := by {intros W X Y Z f g h, simp}, }

/-
`restate_axiom` is a command that creates a lemma from a structure field discarding any auto_param wrappers from the type.
It removes a backtick from the name, if it finds one, and otherwise adds "_lemma".
-/

restate_axiom category_str.id_comp'
restate_axiom category_str.comp_id'
restate_axiom category_str.comp_assoc'

/-
`restate_axiom` automates writing lemmas by hand. If we did not use `restate_axiom` then we had to prove a lemma like in below:

@[simp]
lemma id_comp {C : Type} [category_str C] {X Y : C} :
  ∀  f : X ⟶ Y ,  (𝟙 X) ⊚ f = f  :=
begin
  intro f,
  rw [category_str.id_comp' f],
end

At any rate, we now have three lemmas which we can use for rewrite/substitution.
-/

#check category_str.id_comp -- this is a lemma made directly from the field ategory_str.id_comp' in the definition of category.
#check category_str.comp_id
#check category_str.comp_assoc

/-
We add the attributes `simp` so that the tactic `simp` works when using these lemmas to simplify the state of our proofs.
-/
attribute [simp] category_str.id_comp category_str.comp_id category_str.comp_assoc
attribute [trans] precategory_str.comp

initialize_simps_projections category_str (to_precategory_str_hom → hom,
  to_precategory_str_comp → comp, to_precategory_str_id → id, -to_precategory_str)

/--
A `large_category_str` has objects in one universe level higher than the universe level of
the morphisms. It is useful for examples such as the category_str of types, or the category_str
of groups, etc.
-/
abbreviation large_category_str (C : Type (u+1)) : Type (u+1) := category_str.{u} C
/--
A `small_category_str` has objects and morphisms in the same universe level.
-/
abbreviation small_category_str (C : Type u) : Type (u+1) := category_str.{u} C

namespace category_str

/-! ## Category of Types
There is a large category of types where the objects are types and the morphisms are functions between types. -/
instance cat_of_types : category_str Type* :=
{
  hom := λ X, λ Y, X → Y,
  id := λ X, id,
  comp := λ X Y Z, λ f, λ g, g ∘ f,
  id_comp' := by {intros X Y, intro f, refl},
  comp_id' := by {intros X Y, intro f, refl},
  comp_assoc' := by {
                      intros W X Y Z,
                      intros f g h,
                      refl,
                      --funext,
                      --dsimp,
                      --refl,}
                    }
}

#check category_str.cat_of_types.id_comp'

--#reduce category_str.cat_of_types.id_comp'

#reduce category_str.cat_of_types.id_comp' (λ x, (x + 1))

section

variables (𝓒 : Type u) [category_str.{v} 𝓒] (X Y : 𝓒) (f : X ⟶ Y) -- let 𝓒 be a category and `f : X ⟶ Y` a morphism in it .

#reduce category_str.id_comp' f

end --section

/- Note that by the tactic `.obviously` we actually do not need to provide the proofs of three least fields `comp_id'` and  `comp_assoc'` and `comp_assoc'` since all of them follows simply from `refl`. -/

#check (𝟙 ℕ) ⊚ (𝟙 ℕ)

example  :
  bool_of_nat ⊚ (𝟙 ℕ) = bool_of_nat :=
begin
  simp,
end

/-! ## Category of Pointed Types
See lecture 11 for definitions of `→•` and pointed_type.id, or simply command+click below.
-/

instance : large_category_str pointed_type :=
{
  hom := λ X, λ Y, X →• Y, -- really X is (A, a)
  id := λ X, pointed_type.id, -- id: (A,a) ⟶ (A,a)
  comp := λ X Y Z, λ f, λ g, g ∘• f,
}

/-! ##  The Category of a Preorder
Every preorder can be seen as a small category where the objects are the elements/terms of the (underlying type) of the preorder and between two objects `x` and `y` there is a (unique) morphism iff `x ≤ y`. To do this we need some tools to see a proposition as the type of its proofs.
-/

/- We use `plift` to lift a proposition to the type of its proofs -/
#check plift (0 = 0) -- this a type whose terms are proofs of `0 = 0`.

#check ( ⟨ (rfl : 0 = 0) ⟩ : plift (0 = 0) ) -- Since `rfl` is a proof of `0 = 0` we can lift it up to a term `⟨ (rfl : 0 = 0) ⟩` of type `plift (0 = 0)`.

-- For a proposition `P`, the terms of type `plift`

/- We use `ulift` to lift a proposition to the type of its proofs -/
#check ulift -- lifting types from one universe to a higher universe
#check plift -- lifting propositions to types

instance small_cat_of_preorder (X : Type) [preorder X] : small_category_str X :=
{
  hom := λ x, λ y, (plift (x ≤ y) : Type),
  id := λ x, ⟨ le_refl x ⟩,
  comp := λ x y z, λ f, λ g, ⟨le_trans f.down g.down ⟩,
}

def two_to_three :  1 ⟶ 2 :=
⟨one_le_two⟩

#check two_to_three

#reduce category_str.comp_id' two_to_three

#check category_str.small_cat_of_preorder

instance foo : small_category_str ℕ :=
category_str.small_cat_of_preorder ℕ

#check category_str.foo.hom 2 3

#reduce category_str.foo.hom 2 3

section lifting_categories

variables (𝓒 : Type u)[category_str.{v} 𝓒]

universe u'
-- we can lift 𝓒 from universe `u` to a higher universe `u'`.
instance ulift_cat : category_str.{v} (ulift.{u'} 𝓒) :=
{ hom  := λ X Y, (X.down ⟶ Y.down),
  id   := λ X, 𝟙 X.down,
  comp := λ _ _ _ f g, g ⊚ f }

-- We verify that this previous instance can lift small categories to large categories.
example (𝓢 : Type u) [small_category_str 𝓢] : large_category_str (ulift.{u+1} 𝓢) :=
by apply_instance

end lifting_categories

/-
+ There are many more categories which we shall introduce in the three remaining lectures: the category of graphs, the category of monoids, the category of groups, the category of rings, the category of vector spaces, and finally the category of categories!

+ There are statements which are true in all these categories by virtue of  being a category. This is like saying for instance a city has a town-hall by virtue of being a city (that is, we don't know in which country that city is located, what is the population of that city, etc. we just know it is a city.)

+ It is interesting to see which statements are true in an arbitrary category. If we construct something or prove a statement in an arbitrary category,then these constructions and statements and will be valid in every particular category, such as the category of types, groups, etc.

+ In below, we shall introduce new definitions and prove statements which are valid in an arbitrary category.
-/

variables {𝓒 : Type u} [category_str 𝓒] {W X Y Z : 𝓒} {A : Type}

/-! # Delooping of a monoid
Given a monoid `M` (i.e. a type equipped with a monoid structure), we construct a category which has only one object and `M` many morphisms. The composition of morphisms in this category is given by the monoid multiplication.
-/

instance delooping (M : Type u)[mult_monoid_str M] : small_category_str.{u} (punit : Type u) :=
{
  hom := λ _, λ _, M,
  id := 1,
  comp := λ _ _ _, (*),
  id_comp' := by {intros _ _ _, simp [mult_mon_one_mul], },
  comp_id' := by {intros _ _ _, simp [mult_mon_mul_one],},
  comp_assoc' := by {intros _ _ _ _ _ _ _,simp,},
}

#check category_str.delooping
#check category_str.comp

-- A shorter proof
-- instance delooping (M : Type)[mult_monoid_str M] : small_category_str unit :=
-- {
--   hom := λ _, λ _, M,
--   id := 1,
--   comp := λ _ _ _, (*),
--   id_comp' := by {simp},
--   comp_id' := by {simp},
--   comp_assoc' := by {intros _ _ _ ,simp},
-- }

-- Even shorter using tactic `.obviously`

instance delooping_alt (M : Type)[mult_monoid_str M] : small_category_str unit :=
{
  hom := λ _, λ _, M,
  id := 1,
  comp := λ _ _ _, (*),
}

/-
Conversely, in every category every object has, by virtue of being an object of a category, a monoid structure.
-/

/- The type of __endomorphisms__ of an object X in category 𝓒 -/

def End (X : 𝓒) := X ⟶ X

#check @End

#check mult_monoid_str

/- The __endomorphisms monoid__ of an object in a category-/
def monoid_of_object {𝓒 : Type}[small_category_str 𝓒] (X : 𝓒) : mult_monoid_str (X ⟶ X) :=
sorry

/-! ## Challenge:
The endomorphisms monoid of the only object in `single_obj α` is equivalent to the original
     monoid α. -/
-- def to_End {M : Type} [mult_monoid_str M] : M ≃* End (_) :=
-- sorry

lemma eq_comp {f g : X ⟶ Y} (e : f = g) (h : Y ⟶ Z) :
  h ⊚ f = h ⊚ g :=
begin
-- we want to prove  `h ⊚ f = h ⊚ g`
  rw e, -- we sub `f` for `g`
end

lemma comp_eq (f : X ⟶ Y) {g h : Y ⟶ Z} (e : g = h) :
  g ⊚ f = h ⊚ f :=
begin
  rw e,
end

example (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z) :
(h  ⊚  (𝟙 Y ⊚ g)) ⊚  f = h ⊚ (g ⊚ f) :=
begin
  simp,
end

structure equiv (X Y : 𝓒) :=
(to_mor    : X ⟶ Y)
(inv_mor   : Y ⟶ X)
(left_inv  : to_mor ⊚  inv_mor = (𝟙 Y) )
(right_inv : inv_mor ⊚ to_mor = (𝟙 X)  )

local notation ` ≅ `:85 := equiv

/-
A morphism `f` is an __isomorphism__ if it has both a left inverse and a right inverse.
-/

def is_iso (f : X ⟶ Y) :=
∃ (g h : Y ⟶ X), (g ⊚ f = 𝟙 X) ∧ (f ⊚ h = 𝟙 Y)

/- ## Challenge:
Show that an instance of equivalence `f : X ≃ Y` gives rise to a pair of isomorphisms, i.e. both `f.to_mor` and `f.inv_mor` are isomorphisms.

Conversely, we can prove that every isomorphism gives rise to an equivalence.
-/

/--
A morphism `f` is a __monomorphism__ if it can be cancelled when __postcomposed__:
`g ≫ f = h ≫ f` implies `g = h`.
-/
@[simp]
def is_mono (f : X ⟶ Y) :=
∀ (W : 𝓒) (x₁ x₂ : W ⟶ X), (f ⊚ x₁ = f ⊚ x₂) →  (x₁ = x₂)

@[simp]
lemma cancel_mono {f : X ⟶ Y} (mf : is_mono f) {x₁ x₂ : W ⟶ X} :
  (f ⊚ x₁  = f ⊚ x₂) ↔ x₁ = x₂ :=
begin
  split,
  {
    intro h,
    apply mf,
    exact h,
  },
  {
    apply congr_arg,
  },
end

/-
Dually, a morphism `f` is an __epimorphism__ if it can be cancelled when __precomposed__:
`g ⊚ f = h ⊚ f` implies `g = h`.
-/

def is_epi (f : X ⟶ Y) :=
∀ {Z : 𝓒} (g h : Y ⟶ Z), (g ⊚ f = h ⊚ f) → g = h

/- ## Challenge
Show that every isomorphism is a monomorphism.
-/

/-! ## Opposite Category
If `𝓒` is a category, then `𝓒ᵒᵖ` is the __opposite category__, with objects the same but all arrows reversed. `𝓒ᵒᵖ` is the mirror image of `𝓒`. If `X ⟶ Y ⟶ Z` are morphisms in `𝓒ᵒᵖ` then `Z ⟶ Y ⟶ X`  are maps in `𝓒`.

In below we give `𝓒ᵒᵖ` the structure of a category. See `opposite_cat`.
-/

def opposite (𝓒 : Type u) : Type u := 𝓒

notation X `ᵒᵖ`:std.prec.max_plus := opposite X

/- The canonical map `𝓒 → 𝓒ᵒᵖ`.
We need to write `op X` to explicitly move `X` to the opposite category-/
@[pp_nodot]
def op : 𝓒 → 𝓒ᵒᵖ := id

/- The canonical map `𝓒ᵒᵖ → 𝓒`. -/
@[pp_nodot]
def unop : 𝓒ᵒᵖ → 𝓒 := id

section test
variable XX : 𝓒
#check op XX
#check unop (op XX)

example  :
  unop (op XX) = XX := rfl

end  test

@[simp]
lemma op_unop (X : 𝓒ᵒᵖ) : op (unop X) = X := rfl

@[simp]
lemma unop_op (x : 𝓒) : unop (op X) = X := rfl

/- The type-level equivalence between a type and its opposite. -/
def equiv_to_opposite :  𝓒 ≅ 𝓒ᵒᵖ :=
{
  to_fun := op,
  inv_fun := unop,
  left_inv := by {ext, refl, },
  right_inv := by {ext, refl, },
}

instance opposite_cat {𝓒 : Type u} [category_str.{v} 𝓒] : category_str.{v} 𝓒ᵒᵖ :=
{
  hom := λ X, λ Y, (unop Y ⟶ unop X), -- informally, hom_{𝓒ᵒᵖ} X Y = hom_{𝓒} Y X
  id := λ X, 𝟙 (unop X),
  comp := λ X Y Z, λ f g, f ⊚ g,
  id_comp' := by {intros X Y f, simp,},
  comp_id' := by {intros X Y f, simp,},
  comp_assoc' := by {intros W X Y Z f g h, rw [comp_assoc'],}
}

/-
The opposite of an arrow in `𝓒`.
-/
def hom.op  {X Y : 𝓒} (f : X ⟶ Y) :
op Y ⟶ op X := f

/-
Given an arrow in `𝓒ᵒᵖ`, we can take the "unopposite" back in `𝓒`.
-/
def hom.unop {X Y : 𝓒ᵒᵖ} (f : X ⟶ Y) :
unop Y ⟶ unop X := f

@[simp]
lemma op_comp {X Y Z : 𝓒} {f : X ⟶ Y} {g : Y ⟶ Z} :
  hom.op (g ⊚ f) = hom.op f ⊚ hom.op g :=
begin
  refl,
end

@[simp]
lemma unop_comp {X Y Z : 𝓒ᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  hom.unop (g ⊚ f) = hom.unop f ⊚ hom.unop g :=
begin
  refl,
end

@[simp]
lemma op_id {X : 𝓒} : hom.op (𝟙 X) = 𝟙 (op X) :=
begin
  refl,
end

@[simp]
lemma unop_id {X : 𝓒ᵒᵖ} : hom.unop (𝟙 X) = 𝟙 (unop X) :=
begin
  refl,
end

end category_str


import Std.Tactic.GuardExpr
import Std.Tactic.Congr

section congr

example (c : Prop → Prop → Prop → Prop) (x x' y z z' : Prop)
    (h₀ : x ↔ x') (h₁ : z ↔ z') : c x y z ↔ c x' y z' := by
  apply Iff.of_eq -- FIXME: not needed in lean 3
  congr
  · guard_target =ₐ x = x'
    apply_ext_lemma
    assumption
  · guard_target =ₐ z = z'
    ext
    assumption

example {α β γ δ} {F : ∀ {α β}, (α → β) → γ → δ} {f g : α → β} {s : γ}
    (h : ∀ x : α, f x = g x) : F f s = F g s := by
  congr with x
  -- apply_assumption -- FIXME
  apply h

attribute [ext] Subtype.eq

example {α β : Type _} {f : _ → β} {x y : { x : { x : α // x = x } // x = x }}
    (h : x.1 = y.1) : f x = f y := by
  congr with x : 1
  exact h

example {α β : Type _} {F : _ → β} {f g : { f : α → β // f = f }}
    (h : ∀ x : α, (f : α → β) x = (g : α → β) x) : F f = F g := by
  rcongr x
  revert x
  guard_target = type_of% h
  exact h

private opaque List.sum : List Nat → Nat

example {ls : List Nat} :
    (ls.map fun x => (ls.map fun y => 1 + y).sum + 1) =
    (ls.map fun x => (ls.map fun y => Nat.succ y).sum + 1) := by
  rcongr (_x y)
  guard_target =ₐ 1 + y = y.succ
  rw [Nat.add_comm]

example {ls : List Nat} {f g : Nat → Nat} {h : ∀ x, f x = g x} : (ls.map fun x => f x + 3) = ls.map fun x => g x + 3 := by
  rcongr x
  exact h x

-- succeed when either `ext` or `congr` can close the goal
example : () = () := by rcongr

example : 0 = 0 := by rcongr

example {α} (a : α) : a = a := by congr

-- FIXME(?): congr doesn't fail
-- example {α} (a b : α) (h : False) : a = b := by
--   fail_if_success congr
--   cases h

end congr


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston, Bryan Gin-ge Chen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.galois_connection
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Equivalence relations

This file defines the complete lattice of equivalence relations on a type, results about the
inductively defined equivalence closure of a binary relation, and the analogues of some isomorphism
theorems for quotients of arbitrary types.

## Implementation notes

The function `rel` and lemmas ending in ' make it easier to talk about different
equivalence relations on the same type.

The complete lattice instance for equivalence relations could have been defined by lifting
the Galois insertion of equivalence relations on α into binary relations on α, and then using
`complete_lattice.copy` to define a complete lattice instance with more appropriate
definitional equalities (a similar example is `filter.complete_lattice` in
`order/filter/basic.lean`). This does not save space, however, and is less clear.

Partitions are not defined as a separate structure here; users are encouraged to
reason about them using the existing `setoid` and its infrastructure.

## Tags

setoid, equivalence, iseqv, relation, equivalence relation
-/

/-- A version of `setoid.r` that takes the equivalence relation as an explicit argument. -/
def setoid.rel {α : Type u_1} (r : setoid α) : α → α → Prop := setoid.r

/-- A version of `quotient.eq'` compatible with `setoid.rel`, to make rewriting possible. -/
theorem quotient.eq_rel {α : Type u_1} {r : setoid α} {x : α} {y : α} :
    quotient.mk x = quotient.mk y ↔ setoid.rel r x y :=
  quotient.eq'

namespace setoid

theorem ext' {α : Type u_1} {r : setoid α} {s : setoid α} (H : ∀ (a b : α), rel r a b ↔ rel s a b) :
    r = s :=
  ext H

theorem ext_iff {α : Type u_1} {r : setoid α} {s : setoid α} :
    r = s ↔ ∀ (a b : α), rel r a b ↔ rel s a b :=
  { mp := fun (h : r = s) (a b : α) => h ▸ iff.rfl, mpr := ext' }

/-- Two equivalence relations are equal iff their underlying binary operations are equal. -/
theorem eq_iff_rel_eq {α : Type u_1} {r₁ : setoid α} {r₂ : setoid α} : r₁ = r₂ ↔ rel r₁ = rel r₂ :=
  { mp := fun (h : r₁ = r₂) => h ▸ rfl,
    mpr := fun (h : rel r₁ = rel r₂) => ext' fun (x y : α) => h ▸ iff.rfl }

/-- Defining `≤` for equivalence relations. -/
protected instance has_le {α : Type u_1} : HasLessEq (setoid α) :=
  { LessEq := fun (r s : setoid α) => ∀ {x y : α}, rel r x y → rel s x y }

theorem le_def {α : Type u_1} {r : setoid α} {s : setoid α} :
    r ≤ s ↔ ∀ {x y : α}, rel r x y → rel s x y :=
  iff.rfl

theorem refl' {α : Type u_1} (r : setoid α) (x : α) : rel r x x := and.left iseqv x

theorem symm' {α : Type u_1} (r : setoid α) {x : α} {y : α} : rel r x y → rel r y x :=
  fun (h : rel r _x✝ _x) => and.left (and.right iseqv) _x✝ _x h

theorem trans' {α : Type u_1} (r : setoid α) {x : α} {y : α} {z : α} :
    rel r x y → rel r y z → rel r x z :=
  fun (hx : rel r _x✝¹ _x✝) => and.right (and.right iseqv) _x✝¹ _x✝ _x hx

/-- The kernel of a function is an equivalence relation. -/
def ker {α : Type u_1} {β : Type u_2} (f : α → β) : setoid α :=
  mk (fun (x y : α) => f x = f y) sorry

/-- The kernel of the quotient map induced by an equivalence relation r equals r. -/
@[simp] theorem ker_mk_eq {α : Type u_1} (r : setoid α) : ker quotient.mk = r :=
  ext' fun (x y : α) => quotient.eq

theorem ker_def {α : Type u_1} {β : Type u_2} {f : α → β} {x : α} {y : α} :
    rel (ker f) x y ↔ f x = f y :=
  iff.rfl

/-- Given types `α`, `β`, the product of two equivalence relations `r` on `α` and `s` on `β`:
    `(x₁, x₂), (y₁, y₂) ∈ α × β` are related by `r.prod s` iff `x₁` is related to `y₁`
    by `r` and `x₂` is related to `y₂` by `s`. -/
protected def prod {α : Type u_1} {β : Type u_2} (r : setoid α) (s : setoid β) : setoid (α × β) :=
  mk (fun (x y : α × β) => rel r (prod.fst x) (prod.fst y) ∧ rel s (prod.snd x) (prod.snd y)) sorry

/-- The infimum of two equivalence relations. -/
protected instance has_inf {α : Type u_1} : has_inf (setoid α) :=
  has_inf.mk fun (r s : setoid α) => mk (fun (x y : α) => rel r x y ∧ rel s x y) sorry

/-- The infimum of 2 equivalence relations r and s is the same relation as the infimum
    of the underlying binary operations. -/
theorem inf_def {α : Type u_1} {r : setoid α} {s : setoid α} : rel (r ⊓ s) = rel r ⊓ rel s := rfl

theorem inf_iff_and {α : Type u_1} {r : setoid α} {s : setoid α} {x : α} {y : α} :
    rel (r ⊓ s) x y ↔ rel r x y ∧ rel s x y :=
  iff.rfl

/-- The infimum of a set of equivalence relations. -/
protected instance has_Inf {α : Type u_1} : has_Inf (setoid α) :=
  has_Inf.mk
    fun (S : set (setoid α)) => mk (fun (x y : α) => ∀ (r : setoid α), r ∈ S → rel r x y) sorry

/-- The underlying binary operation of the infimum of a set of equivalence relations
    is the infimum of the set's image under the map to the underlying binary operation. -/
theorem Inf_def {α : Type u_1} {s : set (setoid α)} : rel (Inf s) = Inf (rel '' s) := sorry

protected instance partial_order {α : Type u_1} : partial_order (setoid α) :=
  partial_order.mk LessEq (fun (r s : setoid α) => r ≤ s ∧ ¬s ≤ r) sorry sorry sorry

/-- The complete lattice of equivalence relations on a type, with bottom element `=`
    and top element the trivial equivalence relation. -/
protected instance complete_lattice {α : Type u_1} : complete_lattice (setoid α) :=
  complete_lattice.mk complete_lattice.sup complete_lattice.le complete_lattice.lt sorry sorry sorry
    sorry sorry sorry has_inf.inf sorry sorry sorry (mk (fun (_x _x : α) => True) sorry) sorry
    (mk Eq sorry) sorry complete_lattice.Sup complete_lattice.Inf sorry sorry sorry sorry

/-- The inductively defined equivalence closure of a binary relation r is the infimum
    of the set of all equivalence relations containing r. -/
theorem eqv_gen_eq {α : Type u_1} (r : α → α → Prop) :
    eqv_gen.setoid r = Inf (set_of fun (s : setoid α) => ∀ {x y : α}, r x y → rel s x y) :=
  sorry

/-- The supremum of two equivalence relations r and s is the equivalence closure of the binary
    relation `x is related to y by r or s`. -/
theorem sup_eq_eqv_gen {α : Type u_1} (r : setoid α) (s : setoid α) :
    r ⊔ s = eqv_gen.setoid fun (x y : α) => rel r x y ∨ rel s x y :=
  sorry

/-- The supremum of 2 equivalence relations r and s is the equivalence closure of the
    supremum of the underlying binary operations. -/
theorem sup_def {α : Type u_1} {r : setoid α} {s : setoid α} :
    r ⊔ s = eqv_gen.setoid (rel r ⊔ rel s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (r ⊔ s = eqv_gen.setoid (rel r ⊔ rel s))) (sup_eq_eqv_gen r s)))
    (Eq.refl (eqv_gen.setoid fun (x y : α) => rel r x y ∨ rel s x y))

/-- The supremum of a set S of equivalence relations is the equivalence closure of the binary
    relation `there exists r ∈ S relating x and y`. -/
theorem Sup_eq_eqv_gen {α : Type u_1} (S : set (setoid α)) :
    Sup S = eqv_gen.setoid fun (x y : α) => ∃ (r : setoid α), r ∈ S ∧ rel r x y :=
  sorry

/-- The supremum of a set of equivalence relations is the equivalence closure of the
    supremum of the set's image under the map to the underlying binary operation. -/
theorem Sup_def {α : Type u_1} {s : set (setoid α)} : Sup s = eqv_gen.setoid (Sup (rel '' s)) :=
  sorry

/-- The equivalence closure of an equivalence relation r is r. -/
@[simp] theorem eqv_gen_of_setoid {α : Type u_1} (r : setoid α) : eqv_gen.setoid r = r :=
  le_antisymm
    (eq.mpr (id (Eq._oldrec (Eq.refl (eqv_gen.setoid r ≤ r)) (eqv_gen_eq r)))
      (Inf_le fun (_x _x_1 : α) => id))
    eqv_gen.rel

/-- Equivalence closure is idempotent. -/
@[simp] theorem eqv_gen_idem {α : Type u_1} (r : α → α → Prop) :
    eqv_gen.setoid (rel (eqv_gen.setoid r)) = eqv_gen.setoid r :=
  eqv_gen_of_setoid (eqv_gen.setoid r)

/-- The equivalence closure of a binary relation r is contained in any equivalence
    relation containing r. -/
theorem eqv_gen_le {α : Type u_1} {r : α → α → Prop} {s : setoid α}
    (h : ∀ (x y : α), r x y → rel s x y) : eqv_gen.setoid r ≤ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (eqv_gen.setoid r ≤ s)) (eqv_gen_eq r))) (Inf_le h)

/-- Equivalence closure of binary relations is monotonic. -/
theorem eqv_gen_mono {α : Type u_1} {r : α → α → Prop} {s : α → α → Prop}
    (h : ∀ (x y : α), r x y → s x y) : eqv_gen.setoid r ≤ eqv_gen.setoid s :=
  eqv_gen_le fun (_x _x_1 : α) (hr : r _x _x_1) => eqv_gen.rel _x _x_1 (h _x _x_1 hr)

/-- There is a Galois insertion of equivalence relations on α into binary relations
    on α, with equivalence closure the lower adjoint. -/
def gi {α : Type u_1} : galois_insertion eqv_gen.setoid rel :=
  galois_insertion.mk (fun (r : α → α → Prop) (h : rel (eqv_gen.setoid r) ≤ r) => eqv_gen.setoid r)
    sorry sorry sorry

/-- A function from α to β is injective iff its kernel is the bottom element of the complete lattice
    of equivalence relations on α. -/
theorem injective_iff_ker_bot {α : Type u_1} {β : Type u_2} (f : α → β) :
    function.injective f ↔ ker f = ⊥ :=
  iff.symm eq_bot_iff

/-- The elements related to x ∈ α by the kernel of f are those in the preimage of f(x) under f. -/
theorem ker_iff_mem_preimage {α : Type u_1} {β : Type u_2} {f : α → β} {x : α} {y : α} :
    rel (ker f) x y ↔ x ∈ f ⁻¹' singleton (f y) :=
  iff.rfl

/-- Equivalence between functions `α → β` such that `r x y → f x = f y` and functions
`quotient r → β`. -/
def lift_equiv {α : Type u_1} {β : Type u_2} (r : setoid α) :
    (Subtype fun (f : α → β) => r ≤ ker f) ≃ (quotient r → β) :=
  equiv.mk (fun (f : Subtype fun (f : α → β) => r ≤ ker f) => quotient.lift ↑f sorry)
    (fun (f : quotient r → β) => { val := f ∘ quotient.mk, property := sorry }) sorry sorry

/-- The uniqueness part of the universal property for quotients of an arbitrary type. -/
theorem lift_unique {α : Type u_1} {β : Type u_2} {r : setoid α} {f : α → β} (H : r ≤ ker f)
    (g : quotient r → β) (Hg : f = g ∘ quotient.mk) : quotient.lift f H = g :=
  sorry

/-- Given a map f from α to β, the natural map from the quotient of α by the kernel of f is
    injective. -/
theorem ker_lift_injective {α : Type u_1} {β : Type u_2} (f : α → β) :
    function.injective (quotient.lift f fun (_x _x_1 : α) (h : _x ≈ _x_1) => h) :=
  sorry

/-- Given a map f from α to β, the kernel of f is the unique equivalence relation on α whose
    induced map from the quotient of α to β is injective. -/
theorem ker_eq_lift_of_injective {α : Type u_1} {β : Type u_2} {r : setoid α} (f : α → β)
    (H : ∀ (x y : α), rel r x y → f x = f y) (h : function.injective (quotient.lift f H)) :
    ker f = r :=
  sorry

/-- The first isomorphism theorem for sets: the quotient of α by the kernel of a function f
    bijects with f's image. -/
def quotient_ker_equiv_range {α : Type u_1} {β : Type u_2} (f : α → β) :
    quotient (ker f) ≃ ↥(set.range f) :=
  equiv.of_bijective
    (quotient.lift (fun (x : α) => { val := f x, property := set.mem_range_self x }) sorry) sorry

/-- The quotient of α by the kernel of a surjective function f bijects with f's codomain. -/
def quotient_ker_equiv_of_surjective {α : Type u_1} {β : Type u_2} (f : α → β)
    (hf : function.surjective f) : quotient (ker f) ≃ β :=
  equiv.trans (quotient_ker_equiv_range f) (equiv.subtype_univ_equiv hf)

/-- Given a function `f : α → β` and equivalence relation `r` on `α`, the equivalence
    closure of the relation on `f`'s image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are
    related to the elements of `f⁻¹(y)` by `r`.' -/
def map {α : Type u_1} {β : Type u_2} (r : setoid α) (f : α → β) : setoid β :=
  eqv_gen.setoid fun (x y : β) => ∃ (a : α), ∃ (b : α), f a = x ∧ f b = y ∧ rel r a b

/-- Given a surjective function f whose kernel is contained in an equivalence relation r, the
    equivalence relation on f's codomain defined by x ≈ y ↔ the elements of f⁻¹(x) are related to
    the elements of f⁻¹(y) by r. -/
def map_of_surjective {α : Type u_1} {β : Type u_2} (r : setoid α) (f : α → β) (h : ker f ≤ r)
    (hf : function.surjective f) : setoid β :=
  mk (fun (x y : β) => ∃ (a : α), ∃ (b : α), f a = x ∧ f b = y ∧ rel r a b) sorry

/-- A special case of the equivalence closure of an equivalence relation r equalling r. -/
theorem map_of_surjective_eq_map {α : Type u_1} {β : Type u_2} {r : setoid α} {f : α → β}
    (h : ker f ≤ r) (hf : function.surjective f) : map r f = map_of_surjective r f h hf :=
  sorry

/-- Given a function `f : α → β`, an equivalence relation `r` on `β` induces an equivalence
    relation on `α` defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `r`'. -/
def comap {α : Type u_1} {β : Type u_2} (f : α → β) (r : setoid β) : setoid α :=
  mk (fun (x y : α) => rel r (f x) (f y)) sorry

/-- Given a map `f : N → M` and an equivalence relation `r` on `β`, the equivalence relation
    induced on `α` by `f` equals the kernel of `r`'s quotient map composed with `f`. -/
theorem comap_eq {α : Type u_1} {β : Type u_2} {f : α → β} {r : setoid β} :
    comap f r = ker (quotient.mk ∘ f) :=
  sorry

/-- The second isomorphism theorem for sets. -/
def comap_quotient_equiv {α : Type u_1} {β : Type u_2} (f : α → β) (r : setoid β) :
    quotient (comap f r) ≃ ↥(set.range (quotient.mk ∘ f)) :=
  equiv.trans (quotient.congr_right sorry) (quotient_ker_equiv_range (quotient.mk ∘ f))

/-- The third isomorphism theorem for sets. -/
def quotient_quotient_equiv_quotient {α : Type u_1} (r : setoid α) (s : setoid α) (h : r ≤ s) :
    quotient (ker (quot.map_right h)) ≃ quotient s :=
  equiv.mk
    (fun (x : quotient (ker (quot.map_right h))) =>
      quotient.lift_on' x
        (fun (w : Quot fun (x y : α) => rel r x y) => quotient.lift_on' w quotient.mk sorry) sorry)
    (fun (x : quotient s) => quotient.lift_on' x (fun (w : α) => quotient.mk (quotient.mk w)) sorry)
    sorry sorry

/-- Given an equivalence relation `r` on `α`, the order-preserving bijection between the set of
equivalence relations containing `r` and the equivalence relations on the quotient of `α` by `r`. -/
def correspondence {α : Type u_1} (r : setoid α) :
    (Subtype fun (s : setoid α) => r ≤ s) ≃o setoid (quotient r) :=
  rel_iso.mk
    (equiv.mk
      (fun (s : Subtype fun (s : setoid α) => r ≤ s) =>
        map_of_surjective (subtype.val s) quotient.mk sorry quotient.exists_rep)
      (fun (s : setoid (quotient r)) => { val := comap quotient.mk s, property := sorry }) sorry
      sorry)
    sorry

end Mathlib


example (P Q R S T U: Type)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=
begin
have q : Q := h(p),
have t := j(q),
have u := l(t),
exact u,
end


import category_theory.equivalence

open category_theory

variables {C : Type*} [category C]
variables {D : Type*} [category D]

lemma equiv_reflects_mono {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : mono (e.functor.map f)) : mono f :=
begin
  split,
  intros Z g h w,
  apply e.functor.map_injective,
  -- That looks pretty good, we're in a position where we can apply `hef`.
  -- The relevant lemma is `cancel_mono`, which says
  --   `g ≫ f = h ≫ f ↔ g = h ` whenever `f` is a mono
  -- This is an iff, so we can either using `rw ←cancel_mono ...` or `apply (cancel_mono ...).1`.
  sorry,
end


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.over
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.limits.creates
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.monad.algebra
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Algebras for the coproduct monad

The functor `Y ↦ X ⨿ Y` forms a monad, whose category of monads is equivalent to the under category
of `X`. Similarly, `Y ↦ X ⨯ Y` forms a comonad, whose category of comonads is equivalent to the
over category of `X`.

## TODO

Show that `over.forget X : over X ⥤ C` is a comonadic left adjoint and `under.forget : under X ⥤ C`
is a monadic right adjoint.
-/

namespace category_theory

/-- `X ⨯ -` has a comonad structure. This is sometimes called the writer comonad. -/
protected instance obj.comonad {C : Type u} [category C] (X : C) [limits.has_binary_products C] : comonad (functor.obj limits.prod.functor X) :=
  comonad.mk (nat_trans.mk fun (Y : C) => limits.prod.snd)
    (nat_trans.mk fun (Y : C) => limits.prod.lift limits.prod.fst 𝟙)

/--
The forward direction of the equivalence from coalgebras for the product comonad to the over
category.
-/
def coalgebra_to_over {C : Type u} [category C] (X : C) [limits.has_binary_products C] : comonad.coalgebra (functor.obj limits.prod.functor X) ⥤ over X :=
  functor.mk
    (fun (A : comonad.coalgebra (functor.obj limits.prod.functor X)) => over.mk (comonad.coalgebra.a A ≫ limits.prod.fst))
    fun (A₁ A₂ : comonad.coalgebra (functor.obj limits.prod.functor X)) (f : A₁ ⟶ A₂) =>
      over.hom_mk (comonad.coalgebra.hom.f f)

/--
The backward direction of the equivalence from coalgebras for the product comonad to the over
category.
-/
@[simp] theorem over_to_coalgebra_map_f {C : Type u} [category C] (X : C) [limits.has_binary_products C] (f₁ : over X) (f₂ : over X) (g : f₁ ⟶ f₂) : comonad.coalgebra.hom.f (functor.map (over_to_coalgebra X) g) = comma_morphism.left g :=
  Eq.refl (comonad.coalgebra.hom.f (functor.map (over_to_coalgebra X) g))

/-- The equivalence from coalgebras for the product comonad to the over category. -/
def coalgebra_equiv_over {C : Type u} [category C] (X : C) [limits.has_binary_products C] : comonad.coalgebra (functor.obj limits.prod.functor X) ≌ over X :=
  equivalence.mk' (coalgebra_to_over X) (over_to_coalgebra X)
    (nat_iso.of_components
      (fun (A : comonad.coalgebra (functor.obj limits.prod.functor X)) =>
        comonad.coalgebra.iso_mk (iso.refl (comonad.coalgebra.A (functor.obj 𝟭 A))) sorry)
      sorry)
    (nat_iso.of_components
      (fun (f : over X) =>
        over.iso_mk (iso.refl (comma.left (functor.obj (over_to_coalgebra X ⋙ coalgebra_to_over X) f))))
      sorry)

/-- `X ⨿ -` has a monad structure. This is sometimes called the either monad. -/
@[simp] theorem obj.monad_μ_app {C : Type u} [category C] (X : C) [limits.has_binary_coproducts C] (Y : C) : nat_trans.app μ_ Y = limits.coprod.desc limits.coprod.inl 𝟙 :=
  Eq.refl (nat_trans.app μ_ Y)

/--
The forward direction of the equivalence from algebras for the coproduct monad to the under
category.
-/
def algebra_to_under {C : Type u} [category C] (X : C) [limits.has_binary_coproducts C] : monad.algebra (functor.obj limits.coprod.functor X) ⥤ under X :=
  functor.mk
    (fun (A : monad.algebra (functor.obj limits.coprod.functor X)) => under.mk (limits.coprod.inl ≫ monad.algebra.a A))
    fun (A₁ A₂ : monad.algebra (functor.obj limits.coprod.functor X)) (f : A₁ ⟶ A₂) =>
      under.hom_mk (monad.algebra.hom.f f)

/--
The backward direction of the equivalence from algebras for the coproduct monad to the under
category.
-/
@[simp] theorem under_to_algebra_obj_A {C : Type u} [category C] (X : C) [limits.has_binary_coproducts C] (f : under X) : monad.algebra.A (functor.obj (under_to_algebra X) f) = comma.right f :=
  Eq.refl (monad.algebra.A (functor.obj (under_to_algebra X) f))

/--
The equivalence from algebras for the coproduct monad to the under category.
-/
@[simp] theorem algebra_equiv_under_unit_iso {C : Type u} [category C] (X : C) [limits.has_binary_coproducts C] : equivalence.unit_iso (algebra_equiv_under X) =
  nat_iso.of_components
    (fun (A : monad.algebra (functor.obj limits.coprod.functor X)) =>
      monad.algebra.iso_mk (iso.refl (monad.algebra.A (functor.obj 𝟭 A))) (algebra_equiv_under._proof_1 X A))
    (algebra_equiv_under._proof_2 X) :=
  Eq.refl (equivalence.unit_iso (algebra_equiv_under X))


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import linear_algebra.finite_dimensional
import geometry.manifold.smooth_manifold_with_corners
import analysis.inner_product_space.pi_L2

/-!
# Constructing examples of manifolds over ℝ

We introduce the necessary bits to be able to define manifolds modelled over `ℝ^n`, boundaryless
or with boundary or with corners. As a concrete example, we construct explicitly the manifold with
boundary structure on the real interval `[x, y]`.

More specifically, we introduce
* `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n)` for the model space
  used to define `n`-dimensional real manifolds with boundary
* `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_quadrant n)` for the model space used
  to define `n`-dimensional real manifolds with corners

## Notations

In the locale `manifold`, we introduce the notations
* `𝓡 n` for the identity model with corners on `euclidean_space ℝ (fin n)`
* `𝓡∂ n` for `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n)`.

For instance, if a manifold `M` is boundaryless, smooth and modelled on `euclidean_space ℝ (fin m)`,
and `N` is smooth with boundary modelled on `euclidean_half_space n`, and `f : M → N` is a smooth
map, then the derivative of `f` can be written simply as `mfderiv (𝓡 m) (𝓡∂ n) f` (as to why the
model with corners can not be implicit, see the discussion in `smooth_manifold_with_corners.lean`).

## Implementation notes

The manifold structure on the interval `[x, y] = Icc x y` requires the assumption `x < y` as a
typeclass. We provide it as `[fact (x < y)]`.
-/

noncomputable theory
open set function
open_locale manifold

/--
The half-space in `ℝ^n`, used to model manifolds with boundary. We only define it when
`1 ≤ n`, as the definition only makes sense in this case.
-/
def euclidean_half_space (n : ℕ) [has_zero (fin n)] : Type :=
{x : euclidean_space ℝ (fin n) // 0 ≤ x 0}

/--
The quadrant in `ℝ^n`, used to model manifolds with corners, made of all vectors with nonnegative
coordinates.
-/
def euclidean_quadrant (n : ℕ) : Type := {x : euclidean_space ℝ (fin n) // ∀i:fin n, 0 ≤ x i}

section
/- Register class instances for euclidean half-space and quadrant, that can not be noticed
without the following reducibility attribute (which is only set in this section). -/
local attribute [reducible] euclidean_half_space euclidean_quadrant
variable {n : ℕ}

instance [has_zero (fin n)] : topological_space (euclidean_half_space n) := by apply_instance
instance : topological_space (euclidean_quadrant n) := by apply_instance
instance [has_zero (fin n)] : inhabited (euclidean_half_space n) := ⟨⟨0, le_rfl⟩⟩
instance : inhabited (euclidean_quadrant n) := ⟨⟨0, λ i, le_rfl⟩⟩

lemma range_half_space (n : ℕ) [has_zero (fin n)] :
  range (λx : euclidean_half_space n, x.val) = {y | 0 ≤ y 0} :=
by simp

lemma range_quadrant (n : ℕ) :
  range (λx : euclidean_quadrant n, x.val) = {y | ∀i:fin n, 0 ≤ y i} :=
by simp

end

/--
Definition of the model with corners `(euclidean_space ℝ (fin n), euclidean_half_space n)`, used as
a model for manifolds with boundary. In the locale `manifold`, use the shortcut `𝓡∂ n`.
-/
def model_with_corners_euclidean_half_space (n : ℕ) [has_zero (fin n)] :
  model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n) :=
{ to_fun      := subtype.val,
  inv_fun     := λx, ⟨update x 0 (max (x 0) 0), by simp [le_refl]⟩,
  source      := univ,
  target      := {x | 0 ≤ x 0},
  map_source' := λx hx, x.property,
  map_target' := λx hx, mem_univ _,
  left_inv'   := λ ⟨xval, xprop⟩ hx, begin
    rw [subtype.mk_eq_mk, update_eq_iff],
    exact ⟨max_eq_left xprop, λ i _, rfl⟩
  end,
  right_inv'  := λx hx, update_eq_iff.2 ⟨max_eq_left hx, λ i _, rfl⟩,
  source_eq    := rfl,
  unique_diff' :=
    have this : unique_diff_on ℝ _ :=
      unique_diff_on.pi (fin n) (λ _, ℝ) _ _ (λ i ∈ ({0} : set (fin n)), unique_diff_on_Ici 0),
    by simpa only [singleton_pi] using this,
  continuous_to_fun  := continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ $ continuous_id.update 0 $
    (continuous_apply 0).max continuous_const }

/--
Definition of the model with corners `(euclidean_space ℝ (fin n), euclidean_quadrant n)`, used as a
model for manifolds with corners -/
def model_with_corners_euclidean_quadrant (n : ℕ) :
  model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_quadrant n) :=
{ to_fun      := subtype.val,
  inv_fun     := λx, ⟨λi, max (x i) 0, λi, by simp only [le_refl, or_true, le_max_iff]⟩,
  source      := univ,
  target      := {x | ∀ i, 0 ≤ x i},
  map_source' := λx hx, by simpa only [subtype.range_val] using x.property,
  map_target' := λx hx, mem_univ _,
  left_inv'   := λ ⟨xval, xprop⟩ hx, by { ext i, simp only [subtype.coe_mk, xprop i, max_eq_left] },
  right_inv' := λ x hx, by { ext1 i, simp only [hx i, max_eq_left] },
  source_eq    := rfl,
  unique_diff' :=
    have this : unique_diff_on ℝ _ :=
      unique_diff_on.univ_pi (fin n) (λ _, ℝ) _ (λ i, unique_diff_on_Ici 0),
    by simpa only [pi_univ_Ici] using this,
  continuous_to_fun  := continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ $ continuous_pi $ λ i,
    (continuous_id.max continuous_const).comp (continuous_apply i) }

localized "notation `𝓡 `n :=
  (model_with_corners_self ℝ (euclidean_space ℝ (fin n)) :
    model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_space ℝ (fin n)))" in manifold
localized "notation `𝓡∂ `n :=
  (model_with_corners_euclidean_half_space n :
    model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n))" in manifold

/--
The left chart for the topological space `[x, y]`, defined on `[x,y)` and sending `x` to `0` in
`euclidean_half_space 1`.
-/
def Icc_left_chart (x y : ℝ) [fact (x < y)] :
  local_homeomorph (Icc x y) (euclidean_half_space 1) :=
{ source      := {z : Icc x y | z.val < y},
  target      := {z : euclidean_half_space 1 | z.val 0 < y - x},
  to_fun      := λ(z : Icc x y), ⟨λi, z.val - x, sub_nonneg.mpr z.property.1⟩,
  inv_fun     := λz, ⟨min (z.val 0 + x) y, by simp [le_refl, z.prop, le_of_lt (fact.out (x < y))]⟩,
  map_source' := by simp only [imp_self, sub_lt_sub_iff_right, mem_set_of_eq, forall_true_iff],
  map_target' :=
    by { simp only [min_lt_iff, mem_set_of_eq], assume z hz, left,
         dsimp [-subtype.val_eq_coe] at hz, linarith },
  left_inv'   := begin
    rintros ⟨z, hz⟩ h'z,
    simp only [mem_set_of_eq, mem_Icc] at hz h'z,
    simp only [hz, min_eq_left, sub_add_cancel]
  end,
  right_inv'  := begin
    rintros ⟨z, hz⟩ h'z,
    rw subtype.mk_eq_mk,
    funext,
    dsimp at hz h'z,
    have A : x + z 0 ≤ y, by linarith,
    rw subsingleton.elim i 0,
    simp only [A, add_comm, add_sub_cancel', min_eq_left],
  end,
  open_source := begin
    have : is_open {z : ℝ | z < y} := is_open_Iio,
    exact this.preimage continuous_subtype_val
  end,
  open_target := begin
    have : is_open {z : ℝ | z < y - x} := is_open_Iio,
    have : is_open {z : euclidean_space ℝ (fin 1) | z 0 < y - x} :=
      this.preimage (@continuous_apply (fin 1) (λ _, ℝ) _ 0),
    exact this.preimage continuous_subtype_val
  end,
  continuous_to_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have : continuous (λ (z : ℝ) (i : fin 1), z - x) :=
      continuous.sub (continuous_pi $ λi, continuous_id) continuous_const,
    exact this.comp continuous_subtype_val,
  end,
  continuous_inv_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have A : continuous (λ z : ℝ, min (z + x) y) :=
      (continuous_id.add continuous_const).min continuous_const,
    have B : continuous (λz : euclidean_space ℝ (fin 1), z 0) := continuous_apply 0,
    exact (A.comp B).comp continuous_subtype_val
  end }

/--
The right chart for the topological space `[x, y]`, defined on `(x,y]` and sending `y` to `0` in
`euclidean_half_space 1`.
-/
def Icc_right_chart (x y : ℝ) [fact (x < y)] :
  local_homeomorph (Icc x y) (euclidean_half_space 1) :=
{ source      := {z : Icc x y | x < z.val},
  target      := {z : euclidean_half_space 1 | z.val 0 < y - x},
  to_fun      := λ(z : Icc x y), ⟨λi, y - z.val, sub_nonneg.mpr z.property.2⟩,
  inv_fun     := λz,
    ⟨max (y - z.val 0) x, by simp [le_refl, z.prop, le_of_lt (fact.out (x < y)), sub_eq_add_neg]⟩,
  map_source' := by simp only [imp_self, mem_set_of_eq, sub_lt_sub_iff_left, forall_true_iff],
  map_target' :=
    by { simp only [lt_max_iff, mem_set_of_eq], assume z hz, left,
         dsimp [-subtype.val_eq_coe] at hz, linarith },
  left_inv'   := begin
    rintros ⟨z, hz⟩ h'z,
    simp only [mem_set_of_eq, mem_Icc] at hz h'z,
    simp only [hz, sub_eq_add_neg, max_eq_left, add_add_neg_cancel'_right, neg_add_rev, neg_neg]
  end,
  right_inv'  := begin
    rintros ⟨z, hz⟩ h'z,
    rw subtype.mk_eq_mk,
    funext,
    dsimp at hz h'z,
    have A : x ≤ y - z 0, by linarith,
    rw subsingleton.elim i 0,
    simp only [A, sub_sub_cancel, max_eq_left],
  end,
  open_source := begin
    have : is_open {z : ℝ | x < z} := is_open_Ioi,
    exact this.preimage continuous_subtype_val
  end,
  open_target := begin
    have : is_open {z : ℝ | z < y - x} := is_open_Iio,
    have : is_open {z : euclidean_space ℝ (fin 1) | z 0 < y - x} :=
      this.preimage (@continuous_apply (fin 1) (λ _, ℝ) _ 0),
    exact this.preimage continuous_subtype_val
  end,
  continuous_to_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have : continuous (λ (z : ℝ) (i : fin 1), y - z) :=
      continuous_const.sub (continuous_pi (λi, continuous_id)),
    exact this.comp continuous_subtype_val,
  end,
  continuous_inv_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have A : continuous (λ z : ℝ, max (y - z) x) :=
      (continuous_const.sub continuous_id).max continuous_const,
    have B : continuous (λz : euclidean_space ℝ (fin 1), z 0) := continuous_apply 0,
    exact (A.comp B).comp continuous_subtype_val
  end }

/--
Charted space structure on `[x, y]`, using only two charts taking values in
`euclidean_half_space 1`.
-/
instance Icc_manifold (x y : ℝ) [fact (x < y)] : charted_space (euclidean_half_space 1) (Icc x y) :=
{ atlas := {Icc_left_chart x y, Icc_right_chart x y},
  chart_at := λz, if z.val < y then Icc_left_chart x y else Icc_right_chart x y,
  mem_chart_source := λz, begin
    by_cases h' : z.val < y,
    { simp only [h', if_true],
      exact h' },
    { simp only [h', if_false],
      apply lt_of_lt_of_le (fact.out (x < y)),
      simpa only [not_lt] using h'}
  end,
  chart_mem_atlas := λ z, by by_cases h' : (z : ℝ) < y; simp [h'] }

/--
The manifold structure on `[x, y]` is smooth.
-/
instance Icc_smooth_manifold (x y : ℝ) [fact (x < y)] :
  smooth_manifold_with_corners (𝓡∂ 1) (Icc x y) :=
begin
  have M : times_cont_diff_on ℝ ∞ (λz : euclidean_space ℝ (fin 1), - z + (λi, y - x)) univ,
  { rw times_cont_diff_on_univ,
    exact times_cont_diff_id.neg.add times_cont_diff_const },
  apply smooth_manifold_with_corners_of_times_cont_diff_on,
  assume e e' he he',
  simp only [atlas, mem_singleton_iff, mem_insert_iff] at he he',
  /- We need to check that any composition of two charts gives a `C^∞` function. Each chart can be
  either the left chart or the right chart, leaving 4 possibilities that we handle successively.
  -/
  rcases he with rfl | rfl; rcases he' with rfl | rfl,
  { -- `e = left chart`, `e' = left chart`
    exact (mem_groupoid_of_pregroupoid.mpr (symm_trans_mem_times_cont_diff_groupoid _ _ _)).1 },
  { -- `e = left chart`, `e' = right chart`
    apply M.congr_mono _ (subset_univ _),
    rintro _ ⟨⟨hz₁, hz₂⟩, ⟨⟨z, hz₀⟩, rfl⟩⟩,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart,
      update_same, max_eq_left, hz₀, lt_sub_iff_add_lt] with mfld_simps at hz₁ hz₂,
    rw [min_eq_left hz₁.le, lt_add_iff_pos_left] at hz₂,
    ext i,
    rw subsingleton.elim i 0,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart, *,
      pi_Lp.add_apply, pi_Lp.neg_apply, max_eq_left, min_eq_left hz₁.le, update_same]
      with mfld_simps,
    abel },
  { -- `e = right chart`, `e' = left chart`
    apply M.congr_mono _ (subset_univ _),
    rintro _ ⟨⟨hz₁, hz₂⟩, ⟨z, hz₀⟩, rfl⟩,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart, max_lt_iff,
      update_same, max_eq_left hz₀] with mfld_simps at hz₁ hz₂,
    rw lt_sub at hz₁,
    ext i,
    rw subsingleton.elim i 0,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart,
      pi_Lp.add_apply, pi_Lp.neg_apply, update_same, max_eq_left, hz₀, hz₁.le] with mfld_simps,
    abel },
  { -- `e = right chart`, `e' = right chart`
    exact (mem_groupoid_of_pregroupoid.mpr (symm_trans_mem_times_cont_diff_groupoid _ _ _)).1 }
end

/-! Register the manifold structure on `Icc 0 1`, and also its zero and one. -/
section

lemma fact_zero_lt_one : fact ((0 : ℝ) < 1) := ⟨zero_lt_one⟩

local attribute [instance] fact_zero_lt_one

instance : charted_space (euclidean_half_space 1) (Icc (0 : ℝ) 1) := by apply_instance
instance : smooth_manifold_with_corners (𝓡∂ 1) (Icc (0 : ℝ) 1) := by apply_instance

end


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import linear_algebra.isomorphisms
import algebra.category.Module.kernels
import algebra.category.Module.limits
import category_theory.abelian.exact

/-!
# The category of left R-modules is abelian.

Additionally, two linear maps are exact in the categorical sense iff `range f = ker g`.
-/

open category_theory
open category_theory.limits

noncomputable theory

universes v u

namespace Module
variables {R : Type u} [ring R] {M N : Module.{v} R} (f : M ⟶ N)

/-- In the category of modules, every monomorphism is normal. -/
def normal_mono (hf : mono f) : normal_mono f :=
{ Z := of R (N ⧸ f.range),
  g := f.range.mkq,
  w := linear_map.range_mkq_comp _,
  is_limit :=
    is_kernel.iso_kernel _ _ (kernel_is_limit _)
      /- The following [invalid Lean code](https://github.com/leanprover-community/lean/issues/341)
        might help you understand what's going on here:
        ```
        calc
        M   ≃ₗ[R] f.ker.quotient  : (submodule.quot_equiv_of_eq_bot _ (ker_eq_bot_of_mono _)).symm
        ... ≃ₗ[R] f.range         : linear_map.quot_ker_equiv_range f
        ... ≃ₗ[R] r.range.mkq.ker : linear_equiv.of_eq _ _ (submodule.ker_mkq _).symm
        ```
      -/
      (linear_equiv.to_Module_iso'
        ((submodule.quot_equiv_of_eq_bot _ (ker_eq_bot_of_mono _)).symm ≪≫ₗ
          ((linear_map.quot_ker_equiv_range f) ≪≫ₗ
            (linear_equiv.of_eq _ _ (submodule.ker_mkq _).symm)))) $
      by { ext, refl } }

/-- In the category of modules, every epimorphism is normal. -/
def normal_epi (hf : epi f) : normal_epi f :=
{ W := of R f.ker,
  g := f.ker.subtype,
  w := linear_map.comp_ker_subtype _,
  is_colimit :=
    is_cokernel.cokernel_iso _ _ (cokernel_is_colimit _)
      (linear_equiv.to_Module_iso'
      /- The following invalid Lean code might help you understand what's going on here:
        ```
        calc f.ker.subtype.range.quotient
            ≃ₗ[R] f.ker.quotient : submodule.quot_equiv_of_eq _ _ (submodule.range_subtype _)
        ... ≃ₗ[R] f.range        : linear_map.quot_ker_equiv_range f
        ... ≃ₗ[R] N              : linear_equiv.of_top _ (range_eq_top_of_epi _)
        ```
      -/
        (((submodule.quot_equiv_of_eq _ _ (submodule.range_subtype _)) ≪≫ₗ
          (linear_map.quot_ker_equiv_range f)) ≪≫ₗ
          (linear_equiv.of_top _ (range_eq_top_of_epi _)))) $
      by { ext, refl } }

/-- The category of R-modules is abelian. -/
instance : abelian (Module R) :=
{ has_finite_products := ⟨by apply_instance⟩,
  has_kernels := by apply_instance,
  has_cokernels := has_cokernels_Module,
  normal_mono := λ X Y, normal_mono,
  normal_epi := λ X Y, normal_epi }

variables {O : Module.{v} R} (g : N ⟶ O)

open linear_map
local attribute [instance] preadditive.has_equalizers_of_has_kernels

theorem exact_iff : exact f g ↔ f.range = g.ker :=
begin
  rw abelian.exact_iff' f g (kernel_is_limit _) (cokernel_is_colimit _),
  exact ⟨λ h, le_antisymm (range_le_ker_iff.2 h.1) (ker_le_range_iff.2 h.2),
    λ h, ⟨range_le_ker_iff.1 $ le_of_eq h, ker_le_range_iff.1 $ le_of_eq h.symm⟩⟩
end

end Module