import tactic.induction
import data.stream.init
import .A_lists

set_option pp.generalized_field_notation false

/-
# 3. Streams
We'll prove CPS equivalences for a variety of non-CPS and CPS functions over CPS
streams (i.e., streams that are themselves implemented as a CPS type).

We require that all stream functions be *maximally lazy*; that is, that they
perform no computation until it is necessary to produce a requested value.
-/

/- ## 3.1. The `stream_cps` Type
Due to the nature of streams (and Lean's current lack of support for coinductive
types over non-Prop universes), we can do something a little different here:
rather than re-write our *functions* to be in CPS, we can rewrite our *type* to
be a CPS type. In this section, the functions are actually in direct style;
we'll deal with the CPS-on-CPS case in §3.2. For the meantime, we're interested
in proving that a CPS *representation* of our data is equivalent to a non-CPS
representation. Even this was deceptively tricky to get right!
-/

-- ### 3.1.1. Basic Stream Operations
-- We begin by defining a type of CPS streams and a few basic operations
-- thereupon
def stream_cps (α : Type _) {β : Type _} := ℕ → (α → β) → β

def stream_cps.expose {α β : Type _} (s : stream_cps α) (k : α → β) : β := s 0 k

def stream_cps.const {α β : Type _} (x : α) : stream_cps α :=
  (λ (n : ℕ) (k' : α → β), k' x)

def stream_cps.cons {α β : Type _} (x : α) (s : stream_cps α) : stream_cps α :=
  (λ (n : ℕ) (k' : α → β),
    match n with
    | 0 := k' x
    | nat.succ n := s n k'
    end)

def stream_cps.drop {α β : Type _} (n : ℕ) (s : stream_cps α) : stream_cps α :=
  λ (n' : ℕ) (k' : α → β), s (n' + n) k'

-- ### 3.1.2. Basic Stream Equivalences
-- We define a notion of equivalence between a CPS stream and a regular stream
-- (since we don't have formal coinduction in Lean)
def stream_equiv {α β : Type _} (s_cps : stream_cps α) (s : stream α) :=
  ∀(n : ℕ) (k : α → β), k (s n) = s_cps n k

-- Now, we use that equivalence to prove various equivalences between the
-- primitive CPS and non-CPS functions:
lemma const_cps_equiv_const {β : Type _} :
  @stream_equiv ℕ β (stream_cps.const 2) (stream.const 2) :=
λ _ _, rfl

lemma cons_cps_equiv_cons {α β : Type _} :
  ∀ (s_cps : @stream_cps α β) (s : stream α) (x : α),
  stream_equiv s_cps s ↔
    stream_equiv (stream_cps.cons x s_cps) (stream.cons x s) :=
begin
  intros s_cps s x,
  apply iff.intro,
  {
    intros h_equiv n k,
    rw [stream_cps.cons, stream.cons],
    dsimp only,
    cases' n,
    { refl, },
    {
      rw [stream_cps.cons._match_1, stream.cons._match_1],
      exact h_equiv n k,
    }
  },
  {
    intros h_equiv n k,
    rw [stream_cps.cons, stream.cons] at h_equiv,
    have h_e_inst := h_equiv (nat.succ n) k,
    dsimp only at h_e_inst,
    rw [stream.cons._match_1, stream_cps.cons._match_1] at h_e_inst,
    exact h_e_inst,
  }
end

lemma drop_cps_equiv_drop {α β : Type _} :
  ∀ (s_cps : @stream_cps α β) (s : stream α) (n : ℕ),
    stream_equiv s_cps s →
      stream_equiv (stream_cps.drop n s_cps) (stream.drop n s) :=
begin
  intros s_cps s n,
  {
    intros h_equiv n' k',
    rw [stream_cps.drop, stream.drop],
    dsimp only,
    exact h_equiv (n' + n) k',
  }
end

-- Note that the `drop` lemma, unlike `cons_cps_equiv_cons`, isn't biconditional
-- We provide the following counterexample (let "C<...>" denote a CPS stream and
-- ≡ the CPS/non-CPS stream equivalence relation):
-- C<4, 3, 3, ...> ≢ <2, 3, 3, ...> even though
-- (drop_cps 1 C<4, 3, 3, ...>) ≡ <3, 3, ...> = (drop 1 <2, 3, 3, ...>)
lemma drop_equiv_not_bicond :
  ¬(∀ (α β : Type _) (s_cps : @stream_cps α β) (s : stream α) (n : ℕ),
    stream_equiv (stream_cps.drop n s_cps) (stream.drop n s)
      → stream_equiv s_cps s) :=
begin
  intro h,
  let s_cps := @stream_cps.cons (ulift ℕ) (ulift ℕ)
                                (ulift.up 4) (stream_cps.const (ulift.up 3)),
  let s := stream.cons (ulift.up 2) (stream.const (ulift.up 3)),

  have h_drop_equiv :
    stream_equiv (stream_cps.drop 1 s_cps) (stream.drop 1 s) := λ_ _, rfl,

  have h_not_equiv : ¬(stream_equiv s_cps s) :=
  begin
    intro h_s_cps_equiv_s,
    dsimp only [s, s_cps] at h_s_cps_equiv_s,  -- expands s and s_cps defns
    -- for the continuation, instead of just `id`, we have to do some universe
    -- trickery since we can't assume that `u₁ = u₂`
    have h_equiv_at_0 := h_s_cps_equiv_s 0 (ulift.up ∘ ulift.down),
    rw [stream.const, stream.cons, stream_cps.const, stream_cps.cons]
      at h_equiv_at_0,
    dsimp only at h_equiv_at_0,
    rw [stream.cons._match_1, stream_cps.cons._match_1, function.comp] at h_equiv_at_0,
    dsimp only at h_equiv_at_0,
    -- Because where's the fun in using the simplifier?
    exact (@ulift.no_confusion ℕ false {down := 2} {down := 4} h_equiv_at_0)
            (λh2eq4, (@nat.no_confusion false 2 4 h2eq4)
              (λh', (@nat.no_confusion false 1 3 h')
                (λh'', nat.no_confusion h'')))
  end,
  have h_for_contra := h (ulift ℕ) (ulift ℕ) s_cps s,
  exact absurd (h_for_contra 1 h_drop_equiv) h_not_equiv,
end

-- ## 3.2. CPS Functions on CPS Streams
-- Shortly, we will be composing functions, which, of course, we want to be
-- doing in CPS. Therefore, we now turn our attention to handling CPS functions
-- which abstract over a data structure which is itself a CPS function.

-- ### 3.2.1. A(nother) Notion of Equivalence
-- We'll first need a way of saying that a CPS function over CPS streams is
-- equivalent to a non-CPS function over non-CPS streams. A naïve way of doing
-- this would be to simply pass `id` as the continuation and use `stream_equiv`,
-- but this isn't nearly general enough if we want to reuse lemmas in the future
-- (as we will do shortly). Therefore, we resort to this rather messy, but very
-- useful, notion of "double-CPS stream function" equivalence.
def stream_cps_fn_equiv {α β γ : Sort _}
                        (f_res : stream α)
                        (f_res_cps : (@stream_cps α β → γ) → γ) :=
∀ (k : @stream_cps α β → γ)
    (k' : stream α → γ)
    (hks : ∀(s : stream_cps α) (s' : stream α),
        stream_equiv s s' → k s = k' s'),
      (f_res_cps k) = k' f_res

-- ### 3.2.2. `map`
-- A simple, maximally-lazy stream map
-- Because we'll be using this in the next section, it is implemented as a full
-- CPS function, which makes for a tricky lemma statement
def stream_cps.map {α β γ δ : Type _} (f : α → (β → γ) → γ)
                                    (s : stream_cps α)
                                    (k : stream_cps β → δ) : δ :=
k (λ(n : ℕ) (k' : β → γ), s n (λel, f el k'))

lemma map_cps_equiv_map {α β γ δ : Type _} (f : α → β) :
  ∀(s : stream α) (s_cps : @stream_cps α γ) (hequiv : stream_equiv s_cps s),
    stream_cps_fn_equiv (stream.map f s)
                        (@stream_cps.map α β γ δ (λ(x : α) (k'' : β → γ),
                                                    k'' (f x)) s_cps) :=
begin
  intros s s_cps hequiv k k' hks,
  rw stream_cps.map,
  rw hks,
  intros n_se k_se,
  rw stream.map,
  dsimp only,
  rw stream.nth,
  -- rw conveniently decides to do β-reduction for us...for once
  rw ←hequiv n_se (λ (el : α), k_se (f el)),
end

-- ## 3.2.3. The Corecursor Term (and Friends)
-- Since Lean doesn't support corecursion natively, we don't get a corecursor
-- term for free; instead, we must declare it ourselves. To do so, we'll need to
-- implement two helper functions: a CPS version of the natural number recursor
-- (so that `corec` can be fully-CPS) and an iterator function that will "seed"
-- our stream with input values to the generator function, over which we will
-- then `map` the generator. This approach mirrors that taken by the mathlib
-- implementation of direct-style streams

-- We first implement a new natural-number rec_on that's in CPS
-- (I'm drawing the line at "type-level CPS" -- we'll leave the `motive`
-- as-is...)
def nat.rec_on_cps : Π {α : Sort _} {motive : ℕ → Sort _} (n : ℕ),
  motive 0 →
  (Π (n : ℕ), motive n → (motive n.succ → α) → α) →
  (motive n → α) → α
| α motive 0 val0 fn_succ k := k val0
| α motive (nat.succ n) val0 fn_succ k :=
    nat.rec_on_cps n val0 fn_succ (λv_prev, fn_succ n v_prev k)

/-
This iterator function turned out to be pretty involved. To see what's going on,
here are implementations using the regular nat recursor (or an analogue) in SML
(which I find a bit easier to parse in this instance) and Lean.

SML:
```
type ('a, 'b) stream_cps = int -> ('a -> 'b) -> 'b

fun stream_cps_iterate (f : 'a -> ('a -> 'b) -> 'b)
                       (a : 'a)
                       (outer_k : ('a, 'b) stream_cps -> 'c) = outer_k
(fn (n : int) => fn (k : 'a -> 'b) => let
  val rec res = (fn 0 => (fn (k' : 'a -> 'b) => k' a)
                  | n' => (fn (k' : 'a -> 'b) =>
                            res (n - 1) (fn (prev : 'a) => f prev k')))
in
  res n k
end)
```

Lean:
```
def stream_cps.iterate {α β γ : Type _} (f : α → (α → β) → β)
                                        (a : α)
                                        (outer_k : @stream_cps α β → γ) : γ :=
outer_k (λ(n : ℕ) (k : α → β),
@nat.rec_on (λ_, (α → β) → β)
            n
            (λ (k' : α → β), k' a)
            (λ (_ : ℕ) (r : (α → β) → β) (k' : α → β),
              r (λ(prev : α), f prev k'))
            k)
```

For wrapping your head around the full-CPS version, it's helpful to consider
that `motive n = ((α → β) → β)`, so `fn_succ` has type `(((α → β) → β) → γ) → γ`
-/
def stream_cps.iterate {α β γ : Type _} (f : α → (α → β) → β)
                                        (a : α)
                                        (outer_k : @stream_cps α β → γ) : γ :=
outer_k (λ(n : ℕ) (k : α → β),
  @nat.rec_on_cps _ (λ_, (α → β) → β)
              n
              (λ (k' : α → β), k' a)
              (λ (_ : ℕ) (r : (α → β) → β) (k' : ((α → β) → β) → β),
                k' (λ(inner_k : α → β), r (λ(prev : α), f prev inner_k)))
              (λnth_el_accessor, nth_el_accessor k)
                 -- the motive type takes a continuation; we ultimately need to
                 -- produce a β, so we use k to pass the value from the nat
                 -- recursion to the stream caller
)

-- This is the analogue of the corecursor term `stream.corec`. As mentioned,
-- this implementation mirrors the library's dual-argument approach, which
-- makes the proofs to come (a little) less painful
def stream_cps.corec {α β γ δ : Type _} (f : α → (β → γ) → γ)
                                      (g : α → (α → γ) → γ) :
                                      α → (stream_cps β → δ) → δ :=
λ (a : α) (k : stream_cps β → δ),
  k (λ(n : ℕ) (k : β → γ),
    stream_cps.iterate g a (λs_seeds,
      stream_cps.map f s_seeds (λs, s n k)))

-- We now prove that all of these functions behave equivalently to their non-CPS
-- non-CPS-stream analogues
lemma nat_rec_on_cps_equiv_nat_rec_on {α β : Sort _} :
  ∀ {mot : ℕ → Sort _}
    (n : ℕ)
    (el0 : mot 0)
    (f_succ : Π(n' : ℕ), mot n' → mot (nat.succ n'))
    (k : mot n → α),
  k (@nat.rec_on mot n el0 f_succ)
    = nat.rec_on_cps n el0 (λn' x k', k' (f_succ n' x)) k
:=
begin
  intros mot n el0 f_succ k,
  induction' n,
  { refl, },
  {
    rw nat.rec_on_cps,
    dsimp only,  -- unfold nat.rec_on definition
    rw ←(ih el0 (λ (n' : ℕ) (x : mot n'), f_succ n' x)
                (λ (v_prev : mot n), k (f_succ n v_prev))),
  }
end

lemma iterate_cps_equiv_iterate {α β γ : Type _} :
  ∀ (f : α → α)
    (a : α),
    stream_cps_fn_equiv (stream.iterate f a)
                        (@stream_cps.iterate α β γ (λ(x : α) (k'' : α → β),
                                                      k'' (f x)) a) :=
begin
  intros f a k k' hks,
  rw stream_cps.iterate,
  rw hks,
  intros n k,
  dsimp only,
  rw ←(@nat_rec_on_cps_equiv_nat_rec_on β α),
  rw stream.iterate,
  dsimp only,
  -- It feels like this induction shouldn't be necessary since
  -- n_r_o_c_e_n_r_o handles the induction for us.
  induction' n,
  { refl },
  { rw ←(ih f a k k' hks) },
end

lemma corec_cps_equiv_corec {α β γ δ : Type _} :
  ∀ (f : α → β) (g : α → α) (a : α),
    stream_cps_fn_equiv (stream.corec f g a)
                        (@stream_cps.corec α β γ δ (λx k, k (f x))
                                                   (λx k, k (g x)) a) :=
begin
  intros f g a k k' hks,
  rw stream_cps.corec,
  dsimp only,
  rw hks,
  intros n_se k_se,
  rw stream.corec,
  dsimp only,
  let k_cand := λ (s : stream α), k_se ((stream.map f s) n_se),
  rw (iterate_cps_equiv_iterate g a _ k_cand),  -- _ = the CPS continuation
  {
    -- Proving that k_cand is an appropriate analogue of the CPS continuation
    intros s_candpf s'_candpf hequiv_candpf,
    dsimp only [k_cand],
    resetI,
    apply (map_cps_equiv_map f s'_candpf s_candpf _ _ -- _ = CPS continuation
            (λ(s : stream β), k_se (s n_se))),
    {
      -- Proving that the candidate continuation matches the CPS one for map
      intros s_map s'_map hequiv_map,
      dsimp only,
      apply eq.symm (hequiv_map n_se k_se),
    },
    exact hequiv_candpf,
  }
end

-- ### 3.2.4. The Big Finale: `cycle`
-- Using our fancy new iterator and corecursor, we implement `cycle` analogously
-- to the built-in library (but in CPS, of course!) and then prove its
-- equivalence to the library implementation over regular streams
def stream_cps.cycle_f {α β : Type _} : α × list α × α × list α → (α → β) → β
| (v, _, _, _) k := k v

def stream_cps.cycle_g {α β : Type _} :
  α × list α × α × list α → (α × list α × α × list α → β) → β
| (v₁, [], v₀, l₀) k := k (v₀, l₀, v₀, l₀)
| (v₁, list.cons v₂ l₂, v₀, l₀) k := k (v₂, l₂, v₀, l₀)

def stream_cps.cycle {α β γ : Type _} :
  Π (l : list α), l ≠ [] → (@stream_cps α γ → β) → β
| []              h := absurd rfl h
| (list.cons a l) h := stream_cps.corec stream_cps.cycle_f
                                        stream_cps.cycle_g
                                        (a, l, a, l)

-- Just to "prove" it all works:
#eval @nat.rec_on (λ_, list ℕ)
                  20
                  []
                  (λn r, stream_cps.cycle [1, 9, 5, 1, 88]
                                          (by apply list.no_confusion)
                                          (λs, s n (λel, r ++ [el])))

-- And now to **prove** it all works...
-- I finally have to break my "no-axioms" rule...to take advantage of the other
-- lemmas, we have to use `funext` to substitute lambdas. This proof is doable
-- without `funext`, of course, but it would end up duplicating a lot of the
-- previous lemmas (which we wouldn't be able to apply)
lemma cycle_cps_equiv_cycle {α β γ : Type _} :
  ∀ (l : list α) (hl : l ≠ []) (k : @stream_cps α β → γ) (k' : stream α → γ)
    (hks : ∀(s : stream_cps α) (s' : stream α),
        stream_equiv s s' → k s = k' s'),
    stream_cps.cycle l hl k = k' (stream.cycle l hl) :=
begin
  intros l hl k k' hks,
  cases' l,
  { apply absurd rfl hl, },
  {
    rw stream_cps.cycle,
    have hf : ∀{α β : Type _},
      (λ (x : α × list α × α × list α) (k : α → β), k (stream.cycle_f x))
      = stream_cps.cycle_f :=
    begin
      intros α β,
      apply funext,
      intro x,
      apply funext,
      intro k,
      -- To make rw work, we have to expand out the tuple fully
      cases' x,
      cases' snd,
      cases' snd,
      rw [stream_cps.cycle_f, stream.cycle_f],
    end,
    have hg: ∀{α β : Type _}, (λ (x : α × list α × α × list α)
                                 (k : α × list α × α × list α → β),
                                   k (stream.cycle_g x)) = stream_cps.cycle_g :=
    begin
      intros α β,
      apply funext,
      intro x,
      apply funext,
      intro k,
      cases' x,
      cases' snd,
      cases' snd,
      cases' fst_1,
      { refl, },
      { rw [stream_cps.cycle_g, stream.cycle_g], },
    end,
    rw [←hf, ←hg],
    rw (corec_cps_equiv_corec stream.cycle_f stream.cycle_g (hd, l, hd, l) k k'
          hks),
    rw stream.cycle,
  }
end

/-
## 3.3. CPS Functions on Non-CPS Streams
For completeness, we can also consider a more traditional case: our functions
are in CPS, and we leave our streams in direct style.

Unfortunately, this turned out to be relatively uninteresting -- since streams
aren't inductively defined, the CPS functions essentially amount to applying a
continuation to a re-implementation of a library function. Just to illustrate
this point, I've included `boring_map_cps` below, but the reader can imagine
analogous cases for most other stream functions:
-/

def boring_map_cps {α β γ : Type _} (f : α → β)
                                    (s : stream α)
                                    (k : stream β → γ) :=
  k (λn, f (s n))

lemma boring_map_cps_equiv_map {α β γ : Type _} :
  ∀ (f : α → β) (s : stream α) (k : stream β → γ),
  k (stream.map f s) = boring_map_cps f s k := λ_ _ _, rfl


import ring_theory.tensor_product
import algebra.algebra.bilinear

open_locale tensor_product

universes ur uc

noncomputable theory

section missing_tensor_stuff

variables
{R : Type*} [comm_semiring R]
{A : Type*} [ring A] [algebra R A]
{M₁ : Type*} [add_comm_monoid M₁] [module R M₁]
{N₁ : Type*} [add_comm_monoid N₁] [module R N₁]
{M₂ : Type*} [add_comm_monoid M₂] [module R M₂]
{N₂ : Type*} [add_comm_monoid N₂] [module R N₂]
{M₃ : Type*} [add_comm_monoid M₃] [module R M₃]
{N₃ : Type*} [add_comm_monoid N₃] [module R N₃]

namespace tensor_product

lemma map_assoc (f₁ : M₁ →ₗ[R] N₁) (f₂ : M₂ →ₗ[R] N₂) (f₃ : M₃ →ₗ[R] N₃) :
  (↑(tensor_product.assoc R N₁ N₂ N₃)) ∘ₗ (tensor_product.map (tensor_product.map f₁ f₂) f₃)
  = (tensor_product.map (f₁ : M₁ →ₗ[R] N₁) (tensor_product.map f₂ f₃)) ∘ₗ
  ↑(tensor_product.assoc R M₁ M₂ M₃) :=
begin
  apply tensor_product.ext',
  intros xy z,
  apply tensor_product.induction_on xy,
  { simp only [zero_tmul, map_zero] },
  { intros x y,
    simp only [linear_map.coe_comp, linear_equiv.coe_coe, function.comp_app, map_tmul,
       assoc_tmul] },
  { simp only [tensor_product.add_tmul, linear_map.coe_comp, linear_equiv.coe_coe,
      function.comp_app, map_tmul, map_add],
    intros x y hx hy,
    rw [← hx,← hy] },
end

lemma lid_comm_ltensor (f₁ : M₁ →ₗ[R] N₁) : ↑(tensor_product.lid R N₁) ∘ₗ
  (tensor_product.map (linear_map.id : R →ₗ[R] R) f₁) =  f₁ ∘ₗ ↑(tensor_product.lid R M₁) :=
by apply tensor_product.ext'; simp [linear_map.comp_apply]

lemma rid_comm_rtensor (f₁ : M₁ →ₗ[R] N₁) : ↑(tensor_product.rid R N₁) ∘ₗ
  (tensor_product.map f₁ (linear_map.id : R →ₗ[R] R)) =  f₁ ∘ₗ ↑(tensor_product.rid R M₁) :=
by apply tensor_product.ext'; simp [linear_map.comp_apply]

end tensor_product

namespace algebra

/-
  translating algebra defns to statements about linear maps between
  vector spaces.
-/

lemma lmul'_assoc : (lmul' R : A ⊗ A →ₗ[R] A) ∘ₗ (_root_.tensor_product.map (lmul' R)
  (linear_map.id : A →ₗ[R] A)) = (lmul' R : A ⊗ A →ₗ[R] A) ∘ₗ
  (_root_.tensor_product.map linear_map.id (lmul' R)) ∘ₗ ↑(_root_.tensor_product.assoc R A A A) :=
begin
  apply tensor_product.ext',
  intros xy z,
  apply tensor_product.induction_on xy,
  { simp only [tensor_product.zero_tmul, map_zero] },
  { intros x y,
    simp only[ mul_assoc, linear_map.coe_comp, function.comp_app,_root_.tensor_product.map_tmul,
      lmul'_apply, linear_map.id_coe, id.def, linear_equiv.coe_coe,
      _root_.tensor_product.assoc_tmul, eq_self_iff_true] },
  { simp only [tensor_product.add_tmul, linear_map.coe_comp, function.comp_app,
      tensor_product.map_tmul, linear_map.id_coe, id.def, lmul'_apply, linear_equiv.coe_coe, map_add],
    intros x y hx hy,
    rw [←hx, ←hy] }
end

lemma algebra_map_id_left : (lmul' R : A ⊗ A →ₗ[R] A) ∘ₗ
  (_root_.tensor_product.map (algebra.linear_map R A) linear_map.id) =
  ↑(_root_.tensor_product.lid R A) :=
by apply tensor_product.ext'; simp[algebra.smul_def]

lemma algebra_map_id_right : (lmul' R : A ⊗ A →ₗ[R] A) ∘ₗ
  (_root_.tensor_product.map linear_map.id (algebra.linear_map R A) ) =
  ↑(_root_.tensor_product.rid R A) :=
by apply tensor_product.ext'; simp[← algebra.commutes, algebra.smul_def]

end algebra

end missing_tensor_stuff

class coalgebra (R : Type ur) [comm_semiring R] (C : Type uc) [add_comm_monoid C] [module R C] :=
(counit : C →ₗ[R] R)
(comul  : C →ₗ[R] (C ⊗[R] C))
(counit_left : ↑(tensor_product.lid R C) ∘ₗ (tensor_product.map counit linear_map.id) ∘ₗ comul =
  (linear_map.id : C →ₗ[R] C))
(counit_right : ↑(tensor_product.rid R C) ∘ₗ (tensor_product.map linear_map.id counit) ∘ₗ comul =
  (linear_map.id : C →ₗ[R] C))
(coassoc : ↑(tensor_product.assoc R C C C) ∘ₗ (tensor_product.map comul linear_map.id) ∘ₗ comul =
    (tensor_product.map linear_map.id  comul) ∘ₗ comul)

namespace coalgebra

variables
(R : Type*) [comm_semiring R]
(C : Type*) [add_comm_monoid C] [module R C] [coalgebra R C]
(A : Type*) [ring A] [algebra R A]

@[derive [add_comm_group, module R]]
def conv_alg := C →ₗ[R] A

variables {R} {C} {A}

lemma coassoc' : (tensor_product.map comul linear_map.id) ∘ₗ (comul : C →ₗ[R] C ⊗ C) =
  ↑(tensor_product.assoc R C C C).symm ∘ₗ (tensor_product.map linear_map.id comul)
  ∘ₗ (comul : C →ₗ[R] C ⊗ C) :=
begin
  rw [←linear_equiv.to_linear_map_eq_coe ,linear_equiv.eq_to_linear_map_symm_comp],
  exact coassoc,
end

def grouplike_elm (c : C) : Prop := comul c = c ⊗ₜ[R] c

namespace conv_alg

instance : has_mul (conv_alg R C A) :=
 ⟨λ f g, (algebra.lmul' R) ∘ₗ (tensor_product.map f g) ∘ₗ comul⟩

@[simp]
lemma mul_def (f g : conv_alg R C A) :
  f * g = (algebra.lmul' R) ∘ₗ (tensor_product.map f g) ∘ₗ comul := rfl

instance : has_one (conv_alg R C A) := ⟨(algebra.linear_map R A) ∘ₗ counit⟩

@[simp]
lemma one_def : (1 : conv_alg R C A) = (algebra.linear_map R A) ∘ₗ counit := rfl

instance : add_monoid_hom_class (conv_alg R C A) C A := linear_map.add_monoid_hom_class

lemma left_distrib (f g h : conv_alg R C A) : f * (g + h) = f * g + f * h :=
by simp [mul_def,tensor_product.map_add_right, linear_map.add_comp, linear_map.comp_add]

lemma right_distrib (f g h : conv_alg R C A) : (f + g) * h = f * h + g * h :=
by simp [mul_def,tensor_product.map_add_left, linear_map.add_comp, linear_map.comp_add]

lemma one_mul (f : conv_alg R C A) : 1 * f = f :=
begin
  simp only [one_def, mul_def],
  conv_lhs
    begin
      rw [← linear_map.id_comp f,tensor_product.map_comp, ← linear_map.comp_id f,
        ← linear_map.id_comp counit,tensor_product.map_comp],
    end,
  have hassoc : (algebra.lmul' R).comp
      (((tensor_product.map (algebra.linear_map R A) linear_map.id).comp
      ((tensor_product.map linear_map.id f).comp (tensor_product.map counit linear_map.id))).comp
      (comul : C →ₗ[R] C ⊗ C)) = ((algebra.lmul' R : A ⊗ A →ₗ[R] A) ∘ₗ
      (tensor_product.map (algebra.linear_map R A) linear_map.id)) ∘ₗ
      (tensor_product.map linear_map.id f) ∘ₗ
      ((tensor_product.map counit linear_map.id) ∘ₗ (comul : C →ₗ[R] C ⊗ C)),
    { simp only [linear_map.comp_assoc] },
  rw [hassoc, algebra.algebra_map_id_left, ←linear_map.comp_assoc,tensor_product.lid_comm_ltensor,
    linear_map.comp_assoc,counit_left],
  simp
end

lemma mul_one (f : conv_alg R C A) : f * 1 = f :=
begin
  simp only [one_def, mul_def],
  conv_lhs
    begin
      rw [← linear_map.id_comp f,tensor_product.map_comp, ← linear_map.comp_id f,
        ← linear_map.id_comp counit,tensor_product.map_comp],
    end,
  have hassoc : (algebra.lmul' R).comp
      (((tensor_product.map linear_map.id (algebra.linear_map R A) ).comp
      ((tensor_product.map f linear_map.id).comp (tensor_product.map linear_map.id counit))).comp
      (comul : C →ₗ[R] C ⊗ C)) = ((algebra.lmul' R : A ⊗ A →ₗ[R] A) ∘ₗ
      (tensor_product.map  linear_map.id (algebra.linear_map R A) )) ∘ₗ
      (tensor_product.map f linear_map.id) ∘ₗ
      ((tensor_product.map linear_map.id counit) ∘ₗ (comul : C →ₗ[R] C ⊗ C)),
    { simp only [linear_map.comp_assoc] },
  rw [hassoc, algebra.algebra_map_id_right, ←linear_map.comp_assoc,tensor_product.rid_comm_rtensor,
    linear_map.comp_assoc,counit_right],
  simp
end

lemma mul_assoc (f g h : conv_alg R C A) : f * g * h = f * (g * h) :=
begin
  simp only [mul_def],
  conv_rhs
    begin
      congr, skip,
      rw [← linear_map.comp_id f, ← linear_map.comp_assoc,tensor_product.map_comp,
        linear_map.comp_assoc, ← coassoc, ← linear_map.id_comp f, tensor_product.map_comp,
        linear_map.comp_assoc],
      congr, skip,
      rw [← linear_map.comp_assoc,← tensor_product.map_assoc],
    end,
  conv_rhs
    begin
      simp only [← linear_map.comp_assoc],
      congr, congr, congr,
      rw  [linear_map.comp_assoc, ← algebra.lmul'_assoc],
    end,
  simp[← tensor_product.map_comp, linear_map.comp_assoc],
end

instance : ring (conv_alg R C A) := {
  mul_assoc := mul_assoc,
  left_distrib := left_distrib,
  right_distrib := right_distrib,
  one_mul := one_mul,
  mul_one := mul_one,
  .. conv_alg.has_one,
  .. conv_alg.has_mul,
  .. (infer_instance : add_comm_group (conv_alg R C A))
}

instance : algebra R (conv_alg R C A) :=
begin
  apply algebra.of_module,
  { simp only [tensor_product.map_smul_left, linear_map.comp_smul, linear_map.smul_comp, mul_def,
     eq_self_iff_true, forall_const] },
  { simp only [tensor_product.map_smul_right, linear_map.comp_smul, linear_map.smul_comp, mul_def,
    eq_self_iff_true, forall_const] }
end

end conv_alg

end coalgebra

structure coalg_hom (R : Type*) [comm_semiring R] (C₁ : Type*) [add_comm_monoid C₁] [module R C₁]
  [coalgebra R C₁] (C₂ : Type*) [add_comm_monoid C₂] [module R C₂] [coalgebra R C₂] :=
(to_map : C₁ →ₗ[R] C₂)
(map_counit' : (coalgebra.counit ∘ₗ to_map : C₁ → R) = coalgebra.counit)
(map_comul' : coalgebra.comul ∘ₗ to_map  = (tensor_product.map to_map to_map) ∘ₗ coalgebra.comul)

infixr ` →ᶜ `:25 := coalg_hom _
notation A ` →ᶜ[`:25 R `] ` B := coalg_hom R A B

namespace coalg_hom

end coalg_hom

class bialgebra (R : Type*) [comm_semiring R] (B : Type*) [ring B] [algebra R B] extends
  coalgebra R B :=
(counit_one : counit 1 = 1)
(counit_mul : ∀ x y : B, counit (x * y) = (counit x) * (counit y))
(comul_one : comul 1 = 1)
(comul_mul : ∀ x y : B,  comul (x * y) = (comul x) * (comul y))

class hopf_algebra (R : Type*) [comm_semiring R](H : Type*) [ring H] [algebra R H] extends
  bialgebra R H :=
(id_unit : is_unit (linear_map.id : coalgebra.conv_alg R H H))

namespace hopf_algebra

end hopf_algebra


import data.list.basic

/- Prelude -/

attribute [simp] nat.succ_le_succ nat.zero_le
attribute [reducible] id

lemma {u v} if_distrib {c : Prop} {h : decidable c} {α : Sort u} {t e : α}
  {β : Sort v} (f : α → β) : f (ite c t e) = ite c (f t) (f e) :=
match h with
| (is_true  hc)  := rfl
| (is_false hnc) := rfl
end

lemma nat.succ_lt_succ_iff (n m : ℕ) : n.succ < m.succ ↔ n < m :=
⟨nat.lt_of_succ_lt_succ, nat.succ_lt_succ⟩

theorem nat.sub_lt_sub_right : Π {n m k : ℕ} (h₁ : n < m) (h₂ : k ≤ n), n - k < m - k
| n     m     0     h₁ h₂ := h₁
| (n+1) (m+1) (k+1) h₁ h₂ := by simp; apply nat.sub_lt_sub_right (nat.lt_of_succ_lt_succ h₁) (nat.le_of_succ_le_succ h₂)

theorem nat.le_sub_one_of_lt {a b : ℕ} (h : a < b) : a ≤ b - 1 :=
begin
  cases b,
  { simp [nat.not_lt_zero] at h; contradiction },
  { simp [nat.le_of_succ_le_succ h] }
end

namespace list
universe u
variables {α β : Type u}
@[simp]
lemma nth_map (xs : list α) (f : α → β) (i : ℕ) : (xs.map f).nth i = f <$> xs.nth i :=
begin
  induction xs generalizing i,
  { refl },
  { cases i, { refl },
    apply ih_1 }
end

@[simp]
lemma nth_drop (xs : list α) (i k : ℕ) : (xs.drop k).nth i = xs.nth (i + k) :=
begin
  induction xs generalizing k i,
  { cases k; refl },
  { cases k, { refl },
    simp [nat.add_succ],
    apply ih_1 }
end

lemma nth_take (xs : list α) (i k : ℕ) : (xs.take k).nth i = if i < k then xs.nth i else none :=
begin
  induction xs generalizing k i,
  { simp [list.nth] },
  { cases k, { refl },
    cases i, { refl },
    simp [list.take, ih_1, nat.succ_lt_succ_iff],
    apply if_congr; refl }
end

lemma nth_append (xs ys : list α) (i : ℕ) : (xs ++ ys).nth i =
  if i < length xs then xs.nth i else ys.nth (i - length xs) :=
begin
  induction xs generalizing i,
  case list.nil { refl },
  case list.cons x xs { cases i with i,
    { refl },
    { simp [ih_1, nat.one_add, nat.succ_lt_succ_iff],
      apply if_congr; refl }
  }
end
end list

namespace system_f_sub

/- Recursive types in F<: -/

inductive type
| var (idx : ℕ)
| top
| «fun» (domain body : type)
| abs (bound body : type)
| mu (rec : type)

open type

infixr ` →ₛ `:55 := type.fun
notation `∀0<: ` t `, ` s := abs t s

/- Parallel substitution -/

def rename := ℕ → ℕ
def rename.up (ξ : rename) : rename
| 0     := 0
| (k+1) := ξ k + 1

@[simp]
def type.rename : rename → type → type
| ξ (var x)    := var (ξ x)
| ξ top        := top
| ξ (a →ₛ b)   := a.rename ξ →ₛ b.rename ξ
| ξ (∀0<:a, b) := ∀0<:a.rename ξ, b.rename ξ.up
| ξ (mu a)     := mu (a.rename ξ.up)

def subst := ℕ → type
def subst.up (σ : subst) : subst
| 0     := var 0
| (k+1) := (σ k).rename (+1)

@[simp]
def type.subst : subst → type → type
| σ (var x)    := σ x
| σ top        := top
| σ (a →ₛ b)   := a.subst σ →ₛ b.subst σ
| σ (∀0<:a, b) := ∀0<:a.subst σ, b.subst σ.up
| σ (mu a)     := mu (a.subst σ.up)

def subst.comp (σ' σ : subst) : subst := type.subst σ' ∘ σ

infix ` ∘ₛ `:90 := subst.comp

def lift_idx (k : ℕ) (d := 0) : rename :=
λ i, if i ≥ d then i + k else i

def type.lift (a : type) (k : ℕ) (d := 0) : type :=
a.rename (lift_idx k d)

def instantiate_idx (r : type) (d := 0) : subst :=
λ i, if d < i then var (i-1) else if i = d then r.lift d else var i

def type.instantiate (a b : type) (d := 0) : type :=
a.subst (instantiate_idx b d)

def type.expand (a : type) : type :=
a.instantiate (mu a)

def type.free_range : type → ℕ
| (var d)     := d + 1
| top         := 0
| (a →ₛ b)    := max a.free_range b.free_range
| (∀0<: a, b) := max a.free_range (b.free_range - 1)
| (mu a)      := a.free_range - 1

def type.closed (t : type) := t.free_range = 0

/- The subtyping relation -/

@[reducible] def env := list type

def env.lift : env → ℕ → opt_param ℕ 0 → env
| [] k d := []
| (a::e) k d := a.lift k (d + e.length) :: env.lift e k d

inductive sub : env → type → type → Prop
  notation e ` ⊢ `:40 a ` <: `:40 b:40 := sub e a b
| var_refl (e x) : e ⊢ var x <: var x
| env {e x a b} : list.nth e x = some a → e ⊢ a.lift (x+1) <: b → e ⊢ var x <: b
| top (e a) : e ⊢ a <: top
| «fun» {e a a' b b'} : e ⊢ a' <: a → e ⊢ b <: b' → e ⊢ a →ₛ b <: a' →ₛ b'
| abs {e a a' b b'} : e ⊢ a' <: a → a'::e ⊢ b <: b' → e ⊢ ∀0<:a, b <: ∀0<:a', b'
-- violates the positivity restriction
--| mu {e a a'} : (∀ b b', e ⊢ b <: b' → e ⊢ type.instantiate a b <: type.instantiate a' b') → e ⊢ mu a <: mu a'
| mu_refl (e a) : e ⊢ mu a <: mu a
| expₗ {e a a'} : e ⊢ type.expand a <: a' → e ⊢ mu a <: a'
| expᵣ {e a a'} : e ⊢ a <: type.expand a' → e ⊢ a <: mu a'

notation e ` ⊢ `:40 a:41 ` <: `:40 b:40 := sub e a b
notation a ` <: `:40 b:40 := sub [] a b

lemma sub.refl : Π e a, e ⊢ a <: a
| e (var x)    := sub.var_refl e x
| e top        := sub.top e top
| e (a →ₛ b)   := sub.fun (sub.refl e a) (sub.refl e b)
| e (∀0<:a, b) := sub.abs (sub.refl e a) (sub.refl _ b)
| e (mu a)     := sub.mu_refl e a

/- A macro for translating Lean types into F<: types -/

section
open lean
open lean.parser
open interactive
open interactive.types

open expr (app pi const lam)

reserve notation `⟦ₛ`:1000
def mu_helper := 0
notation `μ ` binder `, ` a:scoped := mu_helper a
def ctx_helper := 0
notation `bctx ` binder <: a:50 `⊢` b:scoped := ctx_helper a b

private meta def parse_type : ℕ → ℕ → pexpr → parser pexpr
| d d' (expr.var n) := let n := n - d' in pure ``(var %%(reflect n))
| d d' (const n ls) := pure $ const n ls
| d d' (app (const ``mu_helper _) (lam _ _ _ a)) := do a ← parse_type (d+1) d' a, pure ``(mu %%a)
| d d' (expr.local_const n m bi t) := pure $ ``(type.lift  %%(expr.local_const n m bi t) %%(reflect d))
-- ``(∀ x <: %%a, %%b)
| d d' (pi _ _ _ (pi _ _ (app (app (app (const `system_f_sub.sub []) _) (expr.var 0)) a) b)) :=
do a ← parse_type (d+1) (d'+1) a, b ← parse_type (d+1) (d'+1) b, pure ``(∀0<:%%a, %%b)
| d d' (expr.pi _ _ dom b) :=
if (@unchecked_cast _ expr b).has_var_idx 0 then
     do b ← parse_type (d+1) d' b, pure ``(∀0<:top, %%b)
   else
     do dom ← parse_type d d' dom, b ← parse_type d (d'+1) b, pure ``(%%dom →ₛ %%b)
| d d' e := match e.get_structure_instance_info with
  | some info :=
    do fields ← (info.field_names.zip info.field_values).mmap (λ ⟨n, v⟩,
      do v ← parse_type d d' v,
         pure ``(⟨%%(const (`system_f_sub.labels ++ n) [] : pexpr), %%v⟩)),
    pure (app (const `system_f_sub.record []) (fields.foldr (λ e f, ``(%%e::%%f)) ``([])))
  | _ := tactic.fail format!"unsupported sub-expression {e.to_raw_fmt}"
  end

private meta def parse_ctx : list pexpr → pexpr → parser pexpr
| ctx (app (app (const ``ctx_helper _) a) (lam _ _ _ b)) :=
do a ← parse_type ctx.length 0 a,
   let ctx := a::ctx,
   parse_ctx ctx b
| ctx (app (app (app (const ``sub _) _) a) b) :=
do a ← parse_type ctx.length 0 a,
   b ← parse_type ctx.length 0 b,
   pure ``(sub %%(ctx.foldl (λ ctx a, ``(%%a :: %%ctx)) ``([])) %%a %%b)
| _ e := parse_type 0 0 e

private meta def erase_all_annotations : expr → expr :=
λ e, expr.replace e (λ e _, match e.is_annotation with
| some (_, e') := some (erase_all_annotations e')
| _ := none
end)

@[user_notation]
meta def interpret_notation (_ : parse $ tk "⟦ₛ") (e : parse $ parser.pexpr <* tk "⟧") : parser pexpr :=
let e := erase_all_annotations (unchecked_cast e) in
parse_ctx [] (unchecked_cast e)
end

/- Basic types -/

-- def Bool := ∀0<:top, var 0 →ₛ var 0 →ₛ var 0
def Bool := ⟦ₛ ∀ a, a → a → a ⟧
def True := ⟦ₛ ∀ a, a → top → a ⟧
def False := ⟦ₛ ∀ a, top → a → a ⟧
def None := ⟦ₛ ∀ a, top → top → a ⟧

example : None <: True := by repeat {constructor}
example : None <: False := by repeat {constructor}
example : True <: Bool := by repeat {constructor}
example : False <: Bool := by repeat {constructor}

def prod (a b : type) := ⟦ₛ ∀ r, (a → b → r) → r ⟧
infix ` ×ₛ `:45 := prod

def tuple : list type → type
| []      := top
| (a::as) := a ×ₛ tuple as

structure field :=
(idx : ℕ)
(type : type)

def record_list (fields : list field) : list type :=
let max_idx := (fields.map field.idx).foldr max 0 in
(list.range (max_idx+1)).map (λ i, (field.type <$> fields.find (λ f, f.idx = i)).get_or_else top)

def record (fields : list field) : type :=
tuple (record_list fields ++ [top])

/- Finally, some proofs -/

lemma rename_up_id : rename.up id = id :=
begin
  apply funext, intro i,
  cases i; simp [rename.up]
end

lemma rename_up_comp_rename_up (ξ ξ' : rename) : ξ'.up ∘ ξ.up = rename.up (ξ' ∘ ξ) :=
begin
  apply funext, intro i,
  cases i; simp [function.comp, rename.up]
end

@[simp]
lemma rename_rename (a : type) (ξ ξ') : (a.rename ξ).rename ξ' = a.rename (ξ' ∘ ξ) :=
by induction a generalizing ξ ξ'; simp [*,rename_up_comp_rename_up]

lemma subst_up_comp_rename_up (ξ : rename) (σ : subst) : σ.up ∘ ξ.up = subst.up (σ ∘ ξ) :=
begin
  apply funext, intro i,
  cases i; simp [function.comp, rename.up, subst.up]
end

@[simp]
lemma rename_subst (a : type) (ξ σ) : (a.rename ξ).subst σ = a.subst (σ ∘ ξ) :=
by induction a generalizing ξ σ; simp [*,subst_up_comp_rename_up]

lemma rename_up_comp_subst_up (ξ : rename) (σ : subst) : type.rename ξ.up ∘ σ.up = subst.up (type.rename ξ ∘ σ) :=
begin
  apply funext, intro i,
  cases i with i; simp [function.comp, rename.up, subst.up]
end

@[simp]
lemma subst_rename (a : type) (ξ σ) : (a.subst σ).rename ξ = a.subst (type.rename ξ ∘ σ) :=
by induction a generalizing ξ σ; simp [*,rename_up_comp_subst_up]

lemma subst_up_comp_subst_up (σ σ' : subst) : σ'.up ∘ₛ σ.up = (σ' ∘ₛ σ).up :=
begin
  apply funext, intro i,
  cases i with i; simp [subst.comp, function.comp, subst.up]
end

@[simp]
lemma subst_subst (a : type) (σ σ') : (a.subst σ).subst σ' = a.subst (σ' ∘ₛ σ) :=
begin
  induction a generalizing σ σ'; simp [*,subst_up_comp_subst_up],
  case var { simp [subst.comp, function.comp] }
end

lemma lift_lift {k k' d d'} (a : type) : d ≤ d' → d' ≤ k + d → (a.lift k d).lift k' d' = a.lift (k + k') d :=
begin
  intros, simp [type.lift,rename_rename,function.comp],
  congr, apply funext, intro i,
  by_cases i ≥ d,
  { simp [ge, h, type.lift, lift_idx, le_trans ‹d' ≤ k + d› (add_le_add_left h _)] },
  { have : ¬d' ≤ i, from λ hcontr, h (le_trans ‹d ≤ d'› hcontr),
    simp [ge, h, type.lift, lift_idx, this] }
end

@[simp]
lemma lift_lift' (k k') (a : type) : (a.lift k).lift k' = a.lift (k + k') :=
lift_lift _ dec_trivial dec_trivial

lemma lift_lift2 (k k' d d') (a : type) : k + d ≤ d' → (a.lift k d).lift k' d' = (a.lift k' (d' - k)).lift k d :=
begin
  intros, simp [type.lift,rename_rename,function.comp],
  congr, apply funext, intro i,
  have : k ≤ d', from le_trans (nat.le_add_right _ _) ‹k + d ≤ d'›,
  by_cases i ≥ d,
  { by_cases d' ≤ k + i with h',
    { have : d' - k ≤ k + i - k, from nat.sub_le_sub_right h' k,
      simp [nat.add_sub_cancel_left] at this,
      simp [ge, h, type.lift, lift_idx, h', this, le_add_of_nonneg_of_le (nat.zero_le _) h] },
    { have : ¬ d' - k ≤ i, begin
        assume hcontr, apply h',
        have : d' - k + k ≤ i + k, from nat.add_le_add_right hcontr k,
        simp [nat.sub_add_cancel ‹k ≤ d'›] at this,
        simp [this],
      end,
      simp [ge, h, type.lift, lift_idx, h', this] }
  },
  { simp [ge, lift_idx, h],
    have : ¬d' - k ≤ i, begin
      have : k + i < k + d, from add_lt_add_left (lt_of_not_ge h) _,
      have : i + k < k + d, by simp [this],
      have : d' > i + k, from lt_of_lt_of_le this ‹k + d ≤ d'›,
      have : d' - k > i + k - k, from nat.sub_lt_sub_right this (nat.le_add_left _ _),
      simp only [nat.add_sub_cancel] at this,
      exact not_le_of_gt this,
    end,
    have : d ≤ d', from le_trans (nat.le_add_left _ _) ‹k + d ≤ d'›,
    have : ¬d' ≤ i, from not_le_of_gt (lt_of_lt_of_le (lt_of_not_ge h) this),
    simp [*, h, type.lift, this] }
end

lemma nat.succ_le_iff_lt (n m : ℕ) : n.succ ≤ m ↔ n < m := ⟨nat.succ_le_of_lt, nat.lt_of_succ_le⟩

@[simp]
lemma expand_lift (k d) (a : type) : (a.lift k (d+1)).expand = a.expand.lift k d :=
begin
  intros, simp [type.expand,type.instantiate,type.lift,instantiate_idx,rename_rename,function.comp],
  congr, apply funext, intro i,
  simp [nat.not_lt_zero,ge,lift_idx,nat.succ_le_iff_lt],
  by_cases d < i,
  { have : 0 < i, from lt_of_le_of_lt (nat.zero_le _) ‹d < i›,
    have : 0 < k + i, from lt_of_lt_of_le this (nat.le_add_left _ _),
    simp [*, le_of_lt h, nat.add_sub_assoc, nat.succ_le_iff_lt, nat.le_sub_one_of_lt] },
  { simp [*],
    cases i with i,
    { simp [rename_up_comp_rename_up, nat.not_lt_zero],
      congr, apply funext, intro j,
      cases j, --by_cases d ≤ j,
      { simp [rename.up,*] },
      { simp [rename.up,*, function.comp, if_distrib nat.succ, nat.add_one, nat.add_succ,
          nat.lt_succ_iff_le, rename_up_id],
        apply if_congr; simp }
    },
    { have : ¬ d ≤ i, from h ∘ nat.lt_succ_of_le,
      simp [nat.zero_lt_succ,*] }
  }
end

@[simp]
lemma env.length_lift (e : env) (k d) : (e.lift k d).length = e.length :=
by induction e; simp [env.lift, *]

@[simp]
lemma option_has_map_map_none {α β : Type} (f : α → β) : f <$> none = none := rfl

@[simp]
lemma option_has_map_map_some {α β : Type} (f : α → β) (x : α) : f <$> some x = f x := rfl

@[simp]
lemma env.nth_lift {e : env} (k d i) : (e.lift k d).nth i = (λ a : type, a.lift k (d + (e.length - 1 - i))) <$> e.nth i :=
begin
  induction e generalizing i,
  { simp [env.lift] },
  { simp [list.nth],
    cases i with i,
    { simp [env.lift, list.nth, nat.add_sub_cancel_left], refl },
    { simp [env.lift, ih_1, nat.add_sub_cancel_left, nat.sub_sub] }
  }
end

@[simp]
lemma lift_zero (a : type) : a.lift 0 = a :=
by induction a; simp [*, type.lift, lift_idx, rename_up_id] at *

@[simp]
lemma up_lift_idx (k d) : (lift_idx k d).up = lift_idx k (d+1) :=
begin
  apply funext, intro i,
  simp [lift_idx],
  cases i,
  { have : d + 1 > 0, from nat.zero_lt_succ _,
    simp [rename.up, ge, not_le_of_gt this] },
  { simp [rename.up, ge, nat.succ_le_succ_iff],
    rw if_distrib (has_add.add 1),
    simp [nat.add_one],
    apply if_congr; refl }
end

@[simp]
lemma up_instantiate_idx (a d) : (instantiate_idx a d).up = instantiate_idx a (d+1) :=
begin
  apply funext, intro i,
  simp [instantiate_idx],
  cases i with i,
  { have : d + 1 > 0, from nat.zero_lt_succ _,
    simp [subst.up, not_lt_of_ge (nat.zero_le _), ne_of_lt this] },
  { simp [subst.up, ge, nat.succ_lt_succ_iff, nat.add_one],
    by_cases d < i,
    { have : 0 < i, from lt_of_le_of_lt (nat.zero_le _) h,
      simp [*, (nat.succ_sub this).symm] },
    { simp *,
      by_cases i = d,
      { simp [*,type.lift,lift_idx,function.comp,nat.zero_le,ge,nat.add_succ] },
      { have : i.succ ≠ d.succ, from h ∘ nat.succ.inj,
        simp [*] }
    }
  }
end

section
variables (k d : ℕ)
@[simp] def type.lift_idx (x : ℕ) : (var x).lift k d = var (lift_idx k d x) := rfl
@[simp] def type.lift_top : top.lift k d = top := rfl
@[simp] def type.lift_app (a b) : (a →ₛ b).lift k d = a.lift k d →ₛ b.lift k d := rfl
@[simp] def type.lift_abs (a b) : (∀0<:a, b).lift k d = ∀0<:a.lift k d, b.lift k (d+1) := by simp [type.lift]
@[simp] def type.lift_mu (a) : (mu a).lift k d = mu (a.lift k (d+1)) := by simp [type.lift]

variables (r : type)
@[simp] def type.instantiate_var (x : ℕ) : (var x).instantiate r d = if d < x then var (x-1) else if x = d then r.lift d else var x := rfl
@[simp] def type.instantiate_top : top.instantiate r d = top := rfl
@[simp] def type.instantiate_app (a b) : (a →ₛ b).instantiate r d = a.instantiate r d →ₛ b.instantiate r d := rfl
@[simp] def type.instantiate_abs (a b) : (∀0<: a, b).instantiate r d = ∀0<:a.instantiate r d, b.instantiate r (d+1) := by simp [type.instantiate]
@[simp] def type.instantiate_mu (a) : (mu a).instantiate r d = mu (a.instantiate r (d+1)) := by simp [type.instantiate]
end

lemma sub_insert {e₁ e₂ : env} {a b c} : e₁ ++ e₂ ⊢ a <: b → e₁.lift 1 ++ c::e₂ ⊢ a.lift 1 e₁.length <: b.lift 1 e₁.length :=
begin
  generalize he' : e₁ ++ e₂ = e',
  intro h, induction h generalizing c e₁,
  all_goals { simp [lift_idx, -add_comm], try {constructor; done} },
  case sub.env e' x a b h₁ h₂ ih {
    subst e',
    by_cases x ≥ e₁.length,
    { simp [if_pos h], apply sub.env,
      { have : ¬ (x + 1 < e₁.length), from
          λ hcontr, not_lt_of_ge h (nat.lt_of_succ_lt hcontr),
        simp [list.nth_append, this, nat.sub_add_comm h, -add_comm, list.nth],
        simp [list.nth_append, if_neg (not_lt_of_ge h)] at h₁,
        apply h₁ },
      { have ih := ih rfl,
        rw lift_lift _ (nat.zero_le _) (nat.le_succ_of_le h) at ih,
        apply ih }
    },
    { simp [if_neg h], apply sub.env,
      { simp [list.nth_append, lt_of_not_ge h] at ⊢ h₁,
        -- HACK
        show _ = some (a.lift 1 (e₁.length - 1 - x)),
        simp [h₁], refl },
      { have ih := ih rfl,
        rw lift_lift2 at ih,
        { rw [nat.sub_sub, nat.one_add], apply ih },
        { apply nat.succ_le_of_lt (lt_of_not_ge h) }
      }
    }
  },
  case sub.abs {
    have ih_2 := @ih_2 c (a'::e₁),
    apply sub.abs; simp [*, env.lift] at *
  },
  case sub.fun {
    apply sub.fun (ih_1 he') (ih_2 he')
  },
  case sub.expₗ {
    apply sub.expₗ,
    simp only [expand_lift],
    apply ih_1 he'
  },
  case sub.expᵣ {
    apply sub.expᵣ,
    simp only [expand_lift],
    apply ih_1 he'
  }
end

lemma prod.sub {e : env} {a a' b b'} :
  e ⊢ a <: a' →
  e ⊢ b <: b' →
  e ⊢ a ×ₛ b <: a' ×ₛ b' :=
begin
  intros,
  repeat {any_goals {constructor}},
  apply @sub_insert []; assumption,
  apply @sub_insert []; assumption
end

lemma {u} list.elem_zip_cons_of_elem_zip {α β : Type u} {a : α} {b : β} {p as bs} : p ∈ list.zip as bs → p ∈ list.zip (a::as) (b::bs) :=
or.inr

lemma list.sub {e : env} {as as'} : list.length as = list.length as' → (∀ p ∈ as.zip as', e ⊢ prod.fst p <: p.2) → e ⊢ tuple as <: tuple as' :=
begin
  intros hlen helem, induction as generalizing as',
  { cases as', {constructor}, {contradiction} },
  { cases as', {contradiction},
    simp [tuple],
    apply prod.sub,
    { apply helem (a, a_2), simp [list.zip, list.zip_with] },
    { simp [list.length] at hlen, apply ih_1 (eq_of_add_eq_add_left hlen),
      intros p hp, apply helem p (list.elem_zip_cons_of_elem_zip hp), }
  }
end

@[simp]
lemma lift_tuple (as k d) : (tuple as).lift k d = tuple (as.map (λ a, a.lift k d)) :=
begin
  induction as generalizing d,
  { refl },
  { simp [tuple, prod, lift_idx, lift_lift2, *, ge, not_le_of_gt (nat.zero_lt_succ _)] }
end

@[simp]
lemma instantiate_idx_lift_idx (i b d) : instantiate_idx b (d + 1) (lift_idx 1 0 i) = type.rename (lift_idx 1) (instantiate_idx b d i) :=
begin
  simp [instantiate_idx, lift_idx, ge, nat.zero_le, nat.add_one, nat.succ_lt_succ_iff],
  by_cases d < i,
  { have : 0 < i, from lt_of_le_of_lt (nat.zero_le _) ‹d < i›,
    simp [*, has_sub.sub, nat.sub, nat.succ_pred_eq_of_pos this] },
  { simp [*],
    by_cases i = d,
    { simp [*, type.lift, lift_idx, function.comp, ge, nat.zero_le, nat.add_succ] },
    { simp [*, show i.succ ≠ d.succ, from h ∘ nat.succ.inj] }
  }
end

@[simp]
lemma instantiate_tuple (as b d) : (tuple as).instantiate b d = tuple (as.map (λ a, a.instantiate b d)) :=
begin
  generalize h : as.length = l,
  induction l generalizing as b d,
  { simp [list.eq_nil_of_length_eq_zero h], refl },
  { cases as,
    { contradiction },
    { rw list.length at h, injection h with h,
      simp [tuple, prod, nat.not_lt_zero],
      rw ih_1 _ b (d+1),
      { have : 0 ≠ d + 1, by intro hcontr; injection hcontr,
        simp [*, type.instantiate, type.lift, function.comp, list.length_map] },
      { simp [*, list.length_map] }
    }
  }
end

lemma instantiate_record (b fs) : (record fs).instantiate b = record (fs.map (λ ⟨i, a⟩, ⟨i, a.instantiate b⟩)) :=
begin
  simp [record, record_list],
  congr,
  { apply funext, intro i,
    induction fs,
    { refl },
    { simp [list.find], cases a,
      simp,
      by_cases idx = i,
      { simp [function.comp, h, option.get_or_else, has_map.map, option.map, option.bind] },
      { simp [function.comp, h], apply ih_1 },
    }
  },
  { apply funext, intro a, cases a with idx ty,
    simp }
end

lemma record.sub {e} {fs fs' : list field} :
  (record_list fs).length ≥ (record_list fs').length →
  (∀ p : _ × _, p ∈ (record_list fs).zip (record_list fs') → e ⊢ p.1 <: p.2) →
  e ⊢ record fs <: record fs' :=
begin
  simp [record],
  generalize : record_list fs = rfs,
  induction record_list fs' generalizing rfs,
  all_goals { intros hlen helem },
  case list.nil {
    cases rfs,
    { apply sub.refl },
    { simp [tuple], apply prod.sub; apply sub.top }
  },
  case list.cons {
    cases rfs,
    { cases hlen },
    { simp [tuple], apply prod.sub,
      { apply helem, simp [list.zip, list.zip_with] },
      { apply ih_1,
        { simp at hlen, apply le_of_add_le_add_left hlen },
        { intros a b hab, apply helem a b (list.elem_zip_cons_of_elem_zip hab) }
      }
    }
  }
end

lemma lift_free_range {t : type} (k m) : t.free_range ≤ m → t.lift k m = t :=
begin
  induction t generalizing m,
  all_goals { simp [type.free_range] },
  { intro h,  simp [lift_idx, ge, not_le_of_gt (nat.lt_of_succ_le h)] },
  { intro h,
    have := ih_1 m (le_trans (le_max_left _ _) h),
    rw [this],
    have := ih_2 m (le_trans (le_max_right _ _) h),
    rw [this] },
  { intro h,
    have := ih_1 m (le_trans (le_max_left _ _) h),
    rw [this],
    have : body.lift k (m+1) = body, {
      apply ih_2 (m+1),
      have : body.free_range - 1 ≤ m, from le_trans (le_max_right _ _) h,
      show body.free_range ≤ m + 1, from nat.le_succ_of_pred_le this,
    },
    rw [this] },
  { intro h,
    have := ih_1 (m+1) (nat.le_succ_of_pred_le h),
    rw [this] }
end

lemma lift_closed {t : type} (k) : t.closed → (t.lift k) = t :=
begin
  intro h, apply lift_free_range,
  simp [type.closed] at h, simp [h]
end

lemma left_le_of_max_le {a b c : ℕ} : max a b ≤ c → a ≤ c :=
begin
  intro h,
  by_cases a ≤ b with ab,
  { simp [max, ab] at h, apply le_trans ab h },
  { simp [max, ab] at h, apply h }
end

lemma right_le_of_max_le {a b c : ℕ} : max a b ≤ c → b ≤ c :=
begin
  intro h,
  by_cases a ≤ b with ab,
  { simp [max, ab] at h, apply h },
  { simp [max, ab] at h, apply le_trans (le_of_not_le ab) h }
end

lemma instantiate_free_range {t t' : type} {d} : t.free_range ≤ d → t.instantiate t' d = t :=
begin
  induction t generalizing d,
  all_goals { simp [type.free_range] },
  { intro h,
    have : idx < d, from nat.lt_of_succ_le h,
    simp [lift_idx, instantiate_idx, ne_of_lt this, not_lt_of_gt this] },
  { intro h, rw[ih_1 (le_trans (left_le_of_max_le h) (le_refl _)),
                ih_2 (le_trans (right_le_of_max_le h) (le_refl _))] },
  { intro h, rw[ih_1 (le_trans (left_le_of_max_le h) (le_refl _)),
                ih_2 (le_trans (nat.le_succ_of_pred_le (right_le_of_max_le h)) (le_refl _))] },
  { intro h, rw[ih_1 (le_trans (nat.le_succ_of_pred_le h) (le_refl _))] },
end

@[simp]
lemma instantiate_closed {t t' : type} : t.closed → t.instantiate t' = t :=
begin
  intro h, apply instantiate_free_range,
  simp [type.closed] at h, simp [h]
end

/- A tactic for reducing record relations to field-wise relations -/

section
private meta def go :=
`[simp [record_list, list.range, list.range_core, list.find,
        option.get_or_else, list.zip, list.zip_with, max_eq_left, max_eq_right]
       at h {fail_if_unchanged:=ff},
  do {
    h ← tactic.get_local `h >>= tactic.infer_type,
    match h with
    | `(_ ∨ _) := `[
        cases h with h h,
        tactic.swap,
        go]
    | _ := tactic.skip
    end
  }]

meta def record.fieldwise_eq : tactic unit :=
`[apply record.sub,
  { exact dec_trivial },
  intros p h,
  cases p with a b,
  go,
  all_goals { simp [h] }]

run_cmd add_interactive [``record.fieldwise_eq]
end

section

attribute [reducible] lift_t coe_to_lift coe_t coe_option

@[simp] def labels.a := 0
@[simp] def labels.b := 1
@[simp] def labels.c := 2

def foo := ⟦ₛ { a := Bool, b := top } ⟧
def bar := ⟦ₛ { a := Bool, b := Bool, c := Bool } ⟧

example : bar <: foo :=
record.sub dec_trivial (λ ⟨a, b⟩ h, begin
  conv at h {
    change (a, b) = (Bool, Bool) ∨ _,
    simp,
  },
  cases h with h h; simp [h],
  { apply sub.refl },
  { apply sub.top },
end)

def A := ⟦ₛ { a := Bool } ⟧
def B := ⟦ₛ ∀ α <: A, μ β, { a := Bool, b := Bool → α → β } ⟧
def C := ⟦ₛ ∀ α <: A, { a := Bool, b := Bool → α → A } ⟧

@[simp] lemma A.is_closed : A.closed :=
show A.free_range = 0, from rfl

example : B <: C :=
begin
  suffices : ⟦ₛ bctx α <: A ⊢
    (μ β, { a := Bool, b := Bool → α → β }) <:
          { a := Bool, b := Bool → α → A } ⟧,
    from sub.abs (sub.refl _ _) this,
  suffices : ⟦ₛ bctx α <: A ⊢
    { a := Bool, b := Bool → α → μ β, { a := Bool, b := Bool → α → β } } <:
    { a := Bool, b := Bool → α → A } ⟧,
    from sub.expₗ this,
  record.fieldwise_eq,
  show ⟦ₛ bctx α <: A ⊢
    (Bool → α → μ β, { a := Bool, b := Bool → α → β }) <:
    (Bool → α → A) ⟧,
  { suffices : ⟦ₛ bctx α <: A ⊢ (μ β, { a := Bool, b := Bool → α → β }) <: A ⟧,
      by simp at this; simp [sub.fun, sub.refl, this],
    suffices : ⟦ₛ bctx α <: A ⊢ { a := Bool, b := Bool → α → (μ β, { a := Bool, b := Bool → α → β }) } <: A ⟧,
      from sub.expₗ this,
    simp [lift_closed],
    record.fieldwise_eq,
    show [A] ⊢ Bool <: Bool, from sub.refl _ _
  },
  show [A] ⊢ Bool <: Bool, from sub.refl _ _
end
end

end system_f_sub

/- Unused experiments -/

section
open lean
open lean.parser
open interactive
open interactive.types
open tactic

@[user_command]
meta def extend_inductive_cmd (dmi : decl_meta_info) (_ : parse $ tk "extend_inductive") : parser unit :=
do base ← ident,
   base ← resolve_constant base,
   env ← get_env,
   guard (env.is_inductive base) <|> fail "expected inductive type",
   tk "with",
   decl ← inductive_decl.parse dmi,
   [idecl] ← pure decl.decls | fail "mutual inductives not supported",
   let new := idecl.sig.app_fn.local_uniq_name,
   let ls : list name := [], -- TODO
   let p := env.inductive_num_params base,
   ty ← declaration.type <$> env.get base,
   is ← (env.constructors_of base).mmap (λ ctor,
     do ty ← declaration.type <$> env.get ctor,
     let ty := ty.replace (λ e _, match e with
     | expr.const n ls := if n = base then some (expr.const new ls) else none
     | _ := none
     end) in
     pure (new ++ ctor.components.ilast, ty)),
   let is := is ++ idecl.intros.map (λ e, (e.local_uniq_name, e.local_type)),
   set_env $ env.add_namespace new,
   add_inductive new ls p ty is

meta def dunfold_productive (cfg : delta_config := {}) : conv unit :=
let unfold (u : unit) (e : expr) : tactic (unit × expr × bool) := do
  (expr.const f_name _) ← return e.get_app_fn,
  es ← get_eqn_lemmas_for ff f_name,
  guard $ es.length > 1,
  sl ← es.mfoldl simp_lemmas.add_simp simp_lemmas.mk,
  new_e ← sl.drewrite e,
  return (u, new_e, tt)
in do e ← target,
      (c, new_e) ← dsimplify_core () (λ c e, failed) unfold e {max_steps := cfg.max_steps, canonize_instances := cfg.visit_instances},
      change new_e

meta def delta_target (cs : list name) (cfg : delta_config := {}) : tactic unit :=
do t ← target, delta cs t cfg >>= unsafe_change

run_cmd add_interactive [`dunfold_productive] `conv.interactive
end


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Bhavik Mehta
-/

import category_theory.adjunction.reflective
import topology.category.Top
import topology.stone_cech
import category_theory.monad.limits
import topology.urysohns_lemma

/-!
# The category of Compact Hausdorff Spaces

We construct the category of compact Hausdorff spaces.
The type of compact Hausdorff spaces is denoted `CompHaus`, and it is endowed with a category
instance making it a full subcategory of `Top`.
The fully faithful functor `CompHaus ⥤ Top` is denoted `CompHaus_to_Top`.

**Note:** The file `topology/category/Compactum.lean` provides the equivalence between `Compactum`,
which is defined as the category of algebras for the ultrafilter monad, and `CompHaus`.
`Compactum_to_CompHaus` is the functor from `Compactum` to `CompHaus` which is proven to be an
equivalence of categories in `Compactum_to_CompHaus.is_equivalence`.
See `topology/category/Compactum.lean` for a more detailed discussion where these definitions are
introduced.

-/

universes v u

open category_theory

/-- The type of Compact Hausdorff topological spaces. -/
structure CompHaus :=
(to_Top : Top)
[is_compact : compact_space to_Top]
[is_hausdorff : t2_space to_Top]

namespace CompHaus

instance : inhabited CompHaus := ⟨{to_Top := { α := pempty }}⟩

instance : has_coe_to_sort CompHaus Type* := ⟨λ X, X.to_Top⟩
instance {X : CompHaus} : compact_space X := X.is_compact
instance {X : CompHaus} : t2_space X := X.is_hausdorff

instance category : category CompHaus := induced_category.category to_Top

instance concrete_category : concrete_category CompHaus :=
induced_category.concrete_category _

@[simp]
lemma coe_to_Top {X : CompHaus} : (X.to_Top : Type*) = X :=
rfl

variables (X : Type*) [topological_space X] [compact_space X] [t2_space X]

/-- A constructor for objects of the category `CompHaus`,
taking a type, and bundling the compact Hausdorff topology
found by typeclass inference. -/
def of : CompHaus :=
{ to_Top := Top.of X,
  is_compact := ‹_›,
  is_hausdorff := ‹_› }

@[simp] lemma coe_of : (CompHaus.of X : Type _) = X := rfl

/-- Any continuous function on compact Hausdorff spaces is a closed map. -/
lemma is_closed_map {X Y : CompHaus.{u}} (f : X ⟶ Y) : is_closed_map f :=
λ C hC, (hC.is_compact.image f.continuous).is_closed

/-- Any continuous bijection of compact Hausdorff spaces is an isomorphism. -/
lemma is_iso_of_bijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : function.bijective f) :
  is_iso f :=
begin
  let E := equiv.of_bijective _ bij,
  have hE : continuous E.symm,
  { rw continuous_iff_is_closed,
    intros S hS,
    rw ← E.image_eq_preimage,
    exact is_closed_map f S hS },
  refine ⟨⟨⟨E.symm, hE⟩, _, _⟩⟩,
  { ext x,
    apply E.symm_apply_apply },
  { ext x,
    apply E.apply_symm_apply }
end

/-- Any continuous bijection of compact Hausdorff spaces induces an isomorphism. -/
noncomputable
def iso_of_bijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : function.bijective f) : X ≅ Y :=
by letI := is_iso_of_bijective _ bij; exact as_iso f

end CompHaus

/-- The fully faithful embedding of `CompHaus` in `Top`. -/
@[simps {rhs_md := semireducible}, derive [full, faithful]]
def CompHaus_to_Top : CompHaus.{u} ⥤ Top.{u} := induced_functor _

instance CompHaus.forget_reflects_isomorphisms : reflects_isomorphisms (forget CompHaus.{u}) :=
⟨by introsI A B f hf; exact CompHaus.is_iso_of_bijective _ ((is_iso_iff_bijective f).mp hf)⟩

/--
(Implementation) The object part of the compactification functor from topological spaces to
compact Hausdorff spaces.
-/
@[simps]
def StoneCech_obj (X : Top) : CompHaus := CompHaus.of (stone_cech X)

/--
(Implementation) The bijection of homsets to establish the reflective adjunction of compact
Hausdorff spaces in topological spaces.
-/
noncomputable def stone_cech_equivalence (X : Top.{u}) (Y : CompHaus.{u}) :
  (StoneCech_obj X ⟶ Y) ≃ (X ⟶ CompHaus_to_Top.obj Y) :=
{ to_fun := λ f,
  { to_fun := f ∘ stone_cech_unit,
    continuous_to_fun := f.2.comp (@continuous_stone_cech_unit X _) },
  inv_fun := λ f,
  { to_fun := stone_cech_extend f.2,
    continuous_to_fun := continuous_stone_cech_extend f.2 },
  left_inv :=
  begin
    rintro ⟨f : stone_cech X ⟶ Y, hf : continuous f⟩,
    ext (x : stone_cech X),
    refine congr_fun _ x,
    apply continuous.ext_on dense_range_stone_cech_unit (continuous_stone_cech_extend _) hf,
    rintro _ ⟨y, rfl⟩,
    apply congr_fun (stone_cech_extend_extends (hf.comp _)) y,
  end,
  right_inv :=
  begin
    rintro ⟨f : (X : Type*) ⟶ Y, hf : continuous f⟩,
    ext,
    exact congr_fun (stone_cech_extend_extends hf) _,
  end }

/--
The Stone-Cech compactification functor from topological spaces to compact Hausdorff spaces,
left adjoint to the inclusion functor.
-/
noncomputable def Top_to_CompHaus : Top.{u} ⥤ CompHaus.{u} :=
adjunction.left_adjoint_of_equiv stone_cech_equivalence.{u} (λ _ _ _ _ _, rfl)

lemma Top_to_CompHaus_obj (X : Top) : ↥(Top_to_CompHaus.obj X) = stone_cech X :=
rfl

/--
The category of compact Hausdorff spaces is reflective in the category of topological spaces.
-/
noncomputable instance CompHaus_to_Top.reflective : reflective CompHaus_to_Top :=
{ to_is_right_adjoint := ⟨Top_to_CompHaus, adjunction.adjunction_of_equiv_left _ _⟩ }

noncomputable instance CompHaus_to_Top.creates_limits : creates_limits CompHaus_to_Top :=
monadic_creates_limits _

instance CompHaus.has_limits : limits.has_limits CompHaus :=
has_limits_of_has_limits_creates_limits CompHaus_to_Top

instance CompHaus.has_colimits : limits.has_colimits CompHaus :=
has_colimits_of_reflective CompHaus_to_Top

namespace CompHaus

/-- An explicit limit cone for a functor `F : J ⥤ CompHaus`, defined in terms of
`Top.limit_cone`. -/
def limit_cone {J : Type v} [small_category J] (F : J ⥤ CompHaus.{max v u}) :
  limits.cone F :=
{ X :=
  { to_Top := (Top.limit_cone (F ⋙ CompHaus_to_Top)).X,
    is_compact := begin
      show compact_space ↥{u : Π j, (F.obj j) | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j},
      rw ← is_compact_iff_compact_space,
      apply is_closed.is_compact,
      have : {u : Π j, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j} =
        ⋂ (i j : J) (f : i ⟶ j), {u | F.map f (u i) = u j},
      { ext1, simp only [set.mem_Inter, set.mem_set_of_eq], },
      rw this,
      apply is_closed_Inter, intros i,
      apply is_closed_Inter, intros j,
      apply is_closed_Inter, intros f,
      apply is_closed_eq,
      { exact (continuous_map.continuous (F.map f)).comp (continuous_apply i), },
      { exact continuous_apply j, }
    end,
    is_hausdorff :=
      show t2_space ↥{u : Π j, (F.obj j) | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j},
      from infer_instance },
  π :=
  { app := λ j, (Top.limit_cone (F ⋙ CompHaus_to_Top)).π.app j,
    naturality' := by { intros _ _ _, ext ⟨x, hx⟩,
      simp only [comp_apply, functor.const.obj_map, id_apply], exact (hx f).symm, } } }

/-- The limit cone `CompHaus.limit_cone F` is indeed a limit cone. -/
def limit_cone_is_limit {J : Type v} [small_category J] (F : J ⥤ CompHaus.{max v u}) :
  limits.is_limit (limit_cone F) :=
{ lift := λ S,
    (Top.limit_cone_is_limit (F ⋙ CompHaus_to_Top)).lift (CompHaus_to_Top.map_cone S),
  uniq' := λ S m h, (Top.limit_cone_is_limit _).uniq (CompHaus_to_Top.map_cone S) _ h }

lemma epi_iff_surjective {X Y : CompHaus.{u}} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  split,
  { contrapose!,
    rintros ⟨y, hy⟩ hf,
    let C := set.range f,
    have hC : is_closed C := (is_compact_range f.continuous).is_closed,
    let D := {y},
    have hD : is_closed D := is_closed_singleton,
    have hCD : disjoint C D,
    { rw set.disjoint_singleton_right, rintro ⟨y', hy'⟩, exact hy y' hy' },
    haveI : normal_space ↥(Y.to_Top) := normal_of_compact_t2,
    obtain ⟨φ, hφ0, hφ1, hφ01⟩ := exists_continuous_zero_one_of_closed hC hD hCD,
    haveI : compact_space (ulift.{u} $ set.Icc (0:ℝ) 1) := homeomorph.ulift.symm.compact_space,
    haveI : t2_space (ulift.{u} $ set.Icc (0:ℝ) 1) := homeomorph.ulift.symm.t2_space,
    let Z := of (ulift.{u} $ set.Icc (0:ℝ) 1),
    let g : Y ⟶ Z := ⟨λ y', ⟨⟨φ y', hφ01 y'⟩⟩,
      continuous_ulift_up.comp (continuous_subtype_mk (λ y', hφ01 y') φ.continuous)⟩,
    let h : Y ⟶ Z := ⟨λ _, ⟨⟨0, set.left_mem_Icc.mpr zero_le_one⟩⟩, continuous_const⟩,
    have H : h = g,
    { rw ← cancel_epi f,
      ext x, dsimp,
      simp only [comp_apply, continuous_map.coe_mk, subtype.coe_mk, hφ0 (set.mem_range_self x),
        pi.zero_apply], },
    apply_fun (λ e, (e y).down) at H,
    dsimp at H,
    simp only [subtype.mk_eq_mk, hφ1 (set.mem_singleton y), pi.one_apply] at H,
    exact zero_ne_one H, },
  { rw ← category_theory.epi_iff_surjective,
    apply faithful_reflects_epi (forget CompHaus) },
end

lemma mono_iff_injective {X Y : CompHaus.{u}} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  split,
  { introsI hf x₁ x₂ h,
    let g₁ : of punit ⟶ X := ⟨λ _, x₁, continuous_of_discrete_topology⟩,
    let g₂ : of punit ⟶ X := ⟨λ _, x₂, continuous_of_discrete_topology⟩,
    have : g₁ ≫ f = g₂ ≫ f, by { ext, exact h },
    rw cancel_mono at this,
    apply_fun (λ e, e punit.star) at this,
    exact this },
  { rw ← category_theory.mono_iff_injective,
    apply faithful_reflects_mono (forget CompHaus) }
end

end CompHaus


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .magma

namespace algebra

signature unital (α : Type*) :=
(op : α → α → α)
(id : α)

namespace unital_sig
variables {α : Type*} (s : unital_sig α)

@[signature_instance]
definition to_magma : magma_sig α :=
{ op := s.op
}

end unital_sig

variables {α : Type*} (s : unital_sig α)
local infix ∙ := s.op
local notation `e` := s.id

@[theory]
class unital : Prop := intro ::
(left_identity : identity.op_left_identity s.op s.id)
(right_identity : identity.op_right_identity s.op s.id)

namespace unital
variable [i : unital s]
include i

instance to_magma : magma s.to_magma := magma.infer _

end unital

@[theory]
class cancel_unital : Prop := intro ::
(left_cancellative : identity.op_left_cancellative s.op)
(right_cancellative : identity.op_right_cancellative s.op)
(left_identity : identity.op_left_identity s.op s.id)
(right_identity : identity.op_right_identity s.op s.id)

namespace cancel_unital
variable [i : cancel_unital s]
include i

instance to_cancel_magma : cancel_magma s.to_magma := cancel_magma.infer _

end cancel_unital

@[theory]
class comm_unital : Prop := intro ::
(commutative : identity.op_commutative s.op)
(right_identity : identity.op_right_identity s.op s.id)

namespace comm_unital
variable [i : comm_unital s]
include i

@[identity_instance]
theorem left_identity : identity.op_left_identity s.op s.id :=
λ x, show e ∙ x = x, from calc _
= x ∙ e : by rw op_commutative s.op ...
= x : by rw op_right_identity s.op

instance to_unital : unital s := unital.infer _

instance to_comm_magma : comm_magma s.to_magma := comm_magma.infer _

end comm_unital

@[theory]
class cancel_comm_unital : Prop := intro ::
(commutative : identity.op_commutative s.op)
(right_identity : identity.op_right_identity s.op s.id)
(right_cancellative : identity.op_right_cancellative s.op)

namespace cancel_comm_unital
variables [i : cancel_comm_unital s]
include i

instance to_comm_unital : comm_unital s := comm_unital.infer _

instance to_cancel_comm_magma : cancel_comm_magma s.to_magma := cancel_comm_magma.infer _

instance to_cancel_unital : cancel_unital s := cancel_unital.infer _

end cancel_comm_unital

end algebra


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Bhavik Mehta
-/
import category_theory.structured_arrow
import category_theory.punit
import category_theory.functor.reflects_isomorphisms
import category_theory.epi_mono

/-!
# Over and under categories

Over (and under) categories are special cases of comma categories.
* If `L` is the identity functor and `R` is a constant functor, then `comma L R` is the "slice" or
  "over" category over the object `R` maps to.
* Conversely, if `L` is a constant functor and `R` is the identity functor, then `comma L R` is the
  "coslice" or "under" category under the object `L` maps to.

## Tags

comma, slice, coslice, over, under
-/

namespace category_theory

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].
variables {T : Type u₁} [category.{v₁} T]

/--
The over category has as objects arrows in `T` with codomain `X` and as morphisms commutative
triangles.

See https://stacks.math.columbia.edu/tag/001G.
-/
@[derive category]
def over (X : T) := costructured_arrow (𝟭 T) X

-- Satisfying the inhabited linter
instance over.inhabited [inhabited T] : inhabited (over (default : T)) :=
{ default :=
  { left := default,
    hom := 𝟙 _ } }

namespace over

variables {X : T}

@[ext] lemma over_morphism.ext {X : T} {U V : over X} {f g : U ⟶ V}
  (h : f.left = g.left) : f = g :=
by tidy

@[simp] lemma over_right (U : over X) : U.right = punit.star := by tidy

@[simp] lemma id_left (U : over X) : comma_morphism.left (𝟙 U) = 𝟙 U.left := rfl
@[simp] lemma comp_left (a b c : over X) (f : a ⟶ b) (g : b ⟶ c) :
  (f ≫ g).left = f.left ≫ g.left := rfl

@[simp, reassoc] lemma w {A B : over X} (f : A ⟶ B) : f.left ≫ B.hom = A.hom :=
by have := f.w; tidy

/-- To give an object in the over category, it suffices to give a morphism with codomain `X`. -/
@[simps]
def mk {X Y : T} (f : Y ⟶ X) : over X :=
costructured_arrow.mk f

/-- We can set up a coercion from arrows with codomain `X` to `over X`. This most likely should not
    be a global instance, but it is sometimes useful. -/
def coe_from_hom {X Y : T} : has_coe (Y ⟶ X) (over X) :=
{ coe := mk }

section
local attribute [instance] coe_from_hom

@[simp] lemma coe_hom {X Y : T} (f : Y ⟶ X) : (f : over X).hom = f := rfl
end

/-- To give a morphism in the over category, it suffices to give an arrow fitting in a commutative
    triangle. -/
@[simps]
def hom_mk {U V : over X} (f : U.left ⟶ V.left) (w : f ≫ V.hom = U.hom . obviously) :
  U ⟶ V :=
costructured_arrow.hom_mk f w

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
@[simps]
def iso_mk {f g : over X} (hl : f.left ≅ g.left) (hw : hl.hom ≫ g.hom = f.hom . obviously) :
  f ≅ g :=
costructured_arrow.iso_mk hl hw

section
variable (X)
/--
The forgetful functor mapping an arrow to its domain.

See https://stacks.math.columbia.edu/tag/001G.
-/
def forget : over X ⥤ T := comma.fst _ _

end

@[simp] lemma forget_obj {U : over X} : (forget X).obj U = U.left := rfl
@[simp] lemma forget_map {U V : over X} {f : U ⟶ V} : (forget X).map f = f.left := rfl

/-- The natural cocone over the forgetful functor `over X ⥤ T` with cocone point `X`. -/
@[simps] def forget_cocone (X : T) : limits.cocone (forget X) :=
{ X := X, ι := { app := comma.hom } }

/--
A morphism `f : X ⟶ Y` induces a functor `over X ⥤ over Y` in the obvious way.

See https://stacks.math.columbia.edu/tag/001G.
-/
def map {Y : T} (f : X ⟶ Y) : over X ⥤ over Y := comma.map_right _ $ discrete.nat_trans (λ _, f)

section
variables {Y : T} {f : X ⟶ Y} {U V : over X} {g : U ⟶ V}
@[simp] lemma map_obj_left : ((map f).obj U).left = U.left := rfl
@[simp] lemma map_obj_hom  : ((map f).obj U).hom  = U.hom ≫ f := rfl
@[simp] lemma map_map_left : ((map f).map g).left = g.left := rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id : map (𝟙 Y) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {Y Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map f ⋙ map g :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

end

instance forget_reflects_iso : reflects_isomorphisms (forget X) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨over.hom_mk (inv ((forget X).map f))
      ((as_iso ((forget X).map f)).inv_comp_eq.2 (over.w f).symm),
    by tidy⟩⟩ }

instance forget_faithful : faithful (forget X) := {}.

/--
If `k.left` is an epimorphism, then `k` is an epimorphism. In other words, `over.forget X` reflects
epimorphisms.
The converse does not hold without additional assumptions on the underlying category.
-/
-- TODO: Show the converse holds if `T` has binary products or pushouts.
lemma epi_of_epi_left {f g : over X} (k : f ⟶ g) [hk : epi k.left] : epi k :=
faithful_reflects_epi (forget X) hk

/--
If `k.left` is a monomorphism, then `k` is a monomorphism. In other words, `over.forget X` reflects
monomorphisms.
The converse of `category_theory.over.mono_left_of_mono`.

This lemma is not an instance, to avoid loops in type class inference.
-/
lemma mono_of_mono_left {f g : over X} (k : f ⟶ g) [hk : mono k.left] : mono k :=
faithful_reflects_mono (forget X) hk

/--
If `k` is a monomorphism, then `k.left` is a monomorphism. In other words, `over.forget X` preserves
monomorphisms.
The converse of `category_theory.over.mono_of_mono_left`.
-/
instance mono_left_of_mono {f g : over X} (k : f ⟶ g) [mono k] : mono k.left :=
begin
  refine ⟨λ (Y : T) l m a, _⟩,
  let l' : mk (m ≫ f.hom) ⟶ f := hom_mk l (by { dsimp, rw [←over.w k, reassoc_of a] }),
  suffices : l' = hom_mk m,
  { apply congr_arg comma_morphism.left this },
  rw ← cancel_mono k,
  ext,
  apply a,
end

section iterated_slice
variables (f : over X)

/-- Given f : Y ⟶ X, this is the obvious functor from (T/X)/f to T/Y -/
@[simps]
def iterated_slice_forward : over f ⥤ over f.left :=
{ obj := λ α, over.mk α.hom.left,
  map := λ α β κ, over.hom_mk κ.left.left (by { rw auto_param_eq, rw ← over.w κ, refl }) }

/-- Given f : Y ⟶ X, this is the obvious functor from T/Y to (T/X)/f -/
@[simps]
def iterated_slice_backward : over f.left ⥤ over f :=
{ obj := λ g, mk (hom_mk g.hom : mk (g.hom ≫ f.hom) ⟶ f),
  map := λ g h α, hom_mk (hom_mk α.left (w_assoc α f.hom)) (over_morphism.ext (w α)) }

/-- Given f : Y ⟶ X, we have an equivalence between (T/X)/f and T/Y -/
@[simps]
def iterated_slice_equiv : over f ≌ over f.left :=
{ functor := iterated_slice_forward f,
  inverse := iterated_slice_backward f,
  unit_iso :=
    nat_iso.of_components
    (λ g, over.iso_mk (over.iso_mk (iso.refl _) (by tidy)) (by tidy))
    (λ X Y g, by { ext, dsimp, simp }),
  counit_iso :=
    nat_iso.of_components
    (λ g, over.iso_mk (iso.refl _) (by tidy))
    (λ X Y g, by { ext, dsimp, simp }) }

lemma iterated_slice_forward_forget :
  iterated_slice_forward f ⋙ forget f.left = forget f ⋙ forget X :=
rfl

lemma iterated_slice_backward_forget_forget :
  iterated_slice_backward f ⋙ forget f ⋙ forget X = forget f.left :=
rfl

end iterated_slice

section
variables {D : Type u₂} [category.{v₂} D]

/-- A functor `F : T ⥤ D` induces a functor `over X ⥤ over (F.obj X)` in the obvious way. -/
@[simps]
def post (F : T ⥤ D) : over X ⥤ over (F.obj X) :=
{ obj := λ Y, mk $ F.map Y.hom,
  map := λ Y₁ Y₂ f,
  { left := F.map f.left,
    w' := by tidy; erw [← F.map_comp, w] } }

end

end over

/-- The under category has as objects arrows with domain `X` and as morphisms commutative
    triangles. -/
@[derive category]
def under (X : T) := structured_arrow X (𝟭 T)

-- Satisfying the inhabited linter
instance under.inhabited [inhabited T] : inhabited (under (default : T)) :=
{ default :=
  { right := default,
    hom := 𝟙 _ } }

namespace under

variables {X : T}

@[ext] lemma under_morphism.ext {X : T} {U V : under X} {f g : U ⟶ V}
  (h : f.right = g.right) : f = g :=
by tidy

@[simp] lemma under_left (U : under X) : U.left = punit.star := by tidy

@[simp] lemma id_right (U : under X) : comma_morphism.right (𝟙 U) = 𝟙 U.right := rfl
@[simp] lemma comp_right (a b c : under X) (f : a ⟶ b) (g : b ⟶ c) :
  (f ≫ g).right = f.right ≫ g.right := rfl

@[simp, reassoc] lemma w {A B : under X} (f : A ⟶ B) : A.hom ≫ f.right = B.hom :=
by have := f.w; tidy

/-- To give an object in the under category, it suffices to give an arrow with domain `X`. -/
@[simps]
def mk {X Y : T} (f : X ⟶ Y) : under X :=
structured_arrow.mk f

/-- To give a morphism in the under category, it suffices to give a morphism fitting in a
    commutative triangle. -/
@[simps]
def hom_mk {U V : under X} (f : U.right ⟶ V.right) (w : U.hom ≫ f = V.hom . obviously) :
  U ⟶ V :=
structured_arrow.hom_mk f w

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
def iso_mk {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) : f ≅ g :=
structured_arrow.iso_mk hr hw

@[simp]
lemma iso_mk_hom_right {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) :
  (iso_mk hr hw).hom.right = hr.hom := rfl

@[simp]
lemma iso_mk_inv_right {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) :
  (iso_mk hr hw).inv.right = hr.inv := rfl

section
variables (X)
/-- The forgetful functor mapping an arrow to its domain. -/
def forget : under X ⥤ T := comma.snd _ _

end

@[simp] lemma forget_obj {U : under X} : (forget X).obj U = U.right := rfl
@[simp] lemma forget_map {U V : under X} {f : U ⟶ V} : (forget X).map f = f.right := rfl

/-- The natural cone over the forgetful functor `under X ⥤ T` with cone point `X`. -/
@[simps] def forget_cone (X : T) : limits.cone (forget X) :=
{ X := X, π := { app := comma.hom } }

/-- A morphism `X ⟶ Y` induces a functor `under Y ⥤ under X` in the obvious way. -/
def map {Y : T} (f : X ⟶ Y) : under Y ⥤ under X := comma.map_left _ $ discrete.nat_trans (λ _, f)

section
variables {Y : T} {f : X ⟶ Y} {U V : under Y} {g : U ⟶ V}
@[simp] lemma map_obj_right : ((map f).obj U).right = U.right := rfl
@[simp] lemma map_obj_hom   : ((map f).obj U).hom   = f ≫ U.hom := rfl
@[simp] lemma map_map_right : ((map f).map g).right = g.right := rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id : map (𝟙 Y) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {Y Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map g ⋙ map f :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

end

instance forget_reflects_iso : reflects_isomorphisms (forget X) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨under.hom_mk (inv ((under.forget X).map f)) ((is_iso.comp_inv_eq _).2 (under.w f).symm),
    by tidy⟩⟩ }

instance forget_faithful : faithful (forget X) := {}.

section
variables {D : Type u₂} [category.{v₂} D]

/-- A functor `F : T ⥤ D` induces a functor `under X ⥤ under (F.obj X)` in the obvious way. -/
@[simps]
def post {X : T} (F : T ⥤ D) : under X ⥤ under (F.obj X) :=
{ obj := λ Y, mk $ F.map Y.hom,
  map := λ Y₁ Y₂ f,
  { right := F.map f.right,
    w' := by tidy; erw [← F.map_comp, w] } }

end

end under

end category_theory