/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.basic
import data.lazy_list
import data.nat.basic
import data.stream.init
import data.seq.computation

namespace stream
universes u v w

/-
coinductive seq (α : Type u) : Type u
| nil : seq α
| cons : α → seq α → seq α
-/

/--
A stream `s : option α` is a sequence if `s.nth n = none` implies `s.nth (n + 1) = none`.
-/
def is_seq {α : Type u} (s : stream (option α)) : Prop :=
∀ {n : ℕ}, s n = none → s (n + 1) = none

/-- `seq α` is the type of possibly infinite lists (referred here as sequences).
  It is encoded as an infinite stream of options such that if `f n = none`, then
  `f m = none` for all `m ≥ n`. -/
def seq (α : Type u) : Type u := {f : stream (option α) // f.is_seq}

/-- `seq1 α` is the type of nonempty sequences. -/
def seq1 (α) := α × seq α

namespace seq
variables {α : Type u} {β : Type v} {γ : Type w}

/-- The empty sequence -/
def nil : seq α := ⟨stream.const none, λ n h, rfl⟩

instance : inhabited (seq α) := ⟨nil⟩

/-- Prepend an element to a sequence -/
def cons (a : α) (s : seq α) : seq α :=
⟨some a :: s.1, begin
  rintros (n | _) h,
  { contradiction },
  { exact s.2 h }
end⟩

@[simp] lemma val_cons (s : seq α) (x : α) : (cons x s).val = some x :: s.val := rfl

/-- Get the nth element of a sequence (if it exists) -/
def nth : seq α → ℕ → option α := subtype.val

@[simp] theorem nth_mk (f hf) : @nth α ⟨f, hf⟩ = f := rfl

@[simp] theorem nth_nil (n : ℕ) : (@nil α).nth n = none := rfl
@[simp] theorem nth_cons_zero (a : α) (s : seq α) : (cons a s).nth 0 = some a := rfl
@[simp] theorem nth_cons_succ (a : α) (s : seq α) (n : ℕ) : (cons a s).nth (n + 1) = s.nth n := rfl

@[ext] protected lemma ext {s t : seq α} (h : ∀ n : ℕ, s.nth n = t.nth n) : s = t :=
subtype.eq $ funext h

lemma cons_injective2 : function.injective2 (cons : α → seq α → seq α) :=
λ x y s t h, ⟨by rw [←option.some_inj, ←nth_cons_zero, h, nth_cons_zero],
  seq.ext $ λ n, by simp_rw [←nth_cons_succ x s n, h, nth_cons_succ]⟩

lemma cons_left_injective (s : seq α) : function.injective (λ x, cons x s) :=
cons_injective2.left _

lemma cons_right_injective (x : α) : function.injective (cons x) :=
cons_injective2.right _

/-- A sequence has terminated at position `n` if the value at position `n` equals `none`. -/
def terminated_at (s : seq α) (n : ℕ) : Prop := s.nth n = none

/-- It is decidable whether a sequence terminates at a given position. -/
instance terminated_at_decidable (s : seq α) (n : ℕ) : decidable (s.terminated_at n) :=
decidable_of_iff' (s.nth n).is_none $ by unfold terminated_at; cases s.nth n; simp

/-- A sequence terminates if there is some position `n` at which it has terminated. -/
def terminates (s : seq α) : Prop := ∃ (n : ℕ), s.terminated_at n

theorem not_terminates_iff {s : seq α} : ¬ s.terminates ↔ ∀ n, (s.nth n).is_some :=
by simp [terminates, terminated_at, ←ne.def, option.ne_none_iff_is_some]

/-- Functorial action of the functor `option (α × _)` -/
@[simp] def omap (f : β → γ) : option (α × β) → option (α × γ)
| none          := none
| (some (a, b)) := some (a, f b)

/-- Get the first element of a sequence -/
def head (s : seq α) : option α := nth s 0

/-- Get the tail of a sequence (or `nil` if the sequence is `nil`) -/
def tail (s : seq α) : seq α := ⟨s.1.tail, λ n, by { cases s with f al, exact al }⟩

/-- member definition for `seq`-/
protected def mem (a : α) (s : seq α) := some a ∈ s.1

instance : has_mem α (seq α) :=
⟨seq.mem⟩

theorem le_stable (s : seq α) {m n} (h : m ≤ n) : s.nth m = none → s.nth n = none :=
by { cases s with f al, induction h with n h IH, exacts [id, λ h2, al (IH h2)] }

/-- If a sequence terminated at position `n`, it also terminated at `m ≥ n `. -/
lemma terminated_stable : ∀ (s : seq α) {m n : ℕ}, m ≤ n → s.terminated_at m →
  s.terminated_at n :=
le_stable

/--
If `s.nth n = some aₙ` for some value `aₙ`, then there is also some value `aₘ` such
that `s.nth = some aₘ` for `m ≤ n`.
-/
lemma ge_stable (s : seq α) {aₙ : α} {n m : ℕ} (m_le_n : m ≤ n)
(s_nth_eq_some : s.nth n = some aₙ) :
  ∃ (aₘ : α), s.nth m = some aₘ :=
have s.nth n ≠ none, by simp [s_nth_eq_some],
have s.nth m ≠ none, from mt (s.le_stable m_le_n) this,
option.ne_none_iff_exists'.mp this

theorem not_mem_nil (a : α) : a ∉ @nil α :=
λ ⟨n, (h : some a = none)⟩, by injection h

theorem mem_cons (a : α) : ∀ (s : seq α), a ∈ cons a s
| ⟨f, al⟩ := stream.mem_cons (some a) _

theorem mem_cons_of_mem (y : α) {a : α} : ∀ {s : seq α}, a ∈ s → a ∈ cons y s
| ⟨f, al⟩ := stream.mem_cons_of_mem (some y)

theorem eq_or_mem_of_mem_cons {a b : α} : ∀ {s : seq α}, a ∈ cons b s → a = b ∨ a ∈ s
| ⟨f, al⟩ h := (stream.eq_or_mem_of_mem_cons h).imp_left (λ h, by injection h)

@[simp] theorem mem_cons_iff {a b : α} {s : seq α} : a ∈ cons b s ↔ a = b ∨ a ∈ s :=
⟨eq_or_mem_of_mem_cons, by rintro (rfl|m); [apply mem_cons, exact mem_cons_of_mem _ m]⟩

/-- Destructor for a sequence, resulting in either `none` (for `nil`) or
  `some (a, s)` (for `cons a s`). -/
def destruct (s : seq α) : option (seq1 α) :=
(λ a', (a', s.tail)) <$> nth s 0

theorem destruct_eq_nil {s : seq α} : destruct s = none → s = nil :=
begin
  dsimp [destruct],
  induction f0 : nth s 0; intro h,
  { apply subtype.eq,
    funext n,
    induction n with n IH, exacts [f0, s.2 IH] },
  { contradiction }
end

theorem destruct_eq_cons {s : seq α} {a s'} : destruct s = some (a, s') → s = cons a s' :=
begin
  dsimp [destruct],
  induction f0 : nth s 0 with a'; intro h,
  { contradiction },
  { cases s with f al,
    injections with _ h1 h2,
    rw ←h2, apply subtype.eq, dsimp [tail, cons],
    rw h1 at f0, rw ←f0,
    exact (stream.eta f).symm }
end

@[simp] theorem destruct_nil : destruct (nil : seq α) = none := rfl

@[simp] theorem destruct_cons (a : α) : ∀ s, destruct (cons a s) = some (a, s)
| ⟨f, al⟩ := begin
  unfold cons destruct functor.map,
  apply congr_arg (λ s, some (a, s)),
  apply subtype.eq, dsimp [tail], rw [stream.tail_cons]
end

theorem head_eq_destruct (s : seq α) : head s = prod.fst <$> destruct s :=
by unfold destruct head; cases nth s 0; refl

@[simp] theorem head_nil : head (nil : seq α) = none := rfl

@[simp] theorem head_cons (a : α) (s) : head (cons a s) = some a :=
by rw [head_eq_destruct, destruct_cons]; refl

@[simp]

@[simp] theorem tail_cons (a : α) (s) : tail (cons a s) = s :=
by cases s with f al; apply subtype.eq; dsimp [tail, cons]; rw [stream.tail_cons]

@[simp] theorem nth_tail (s : seq α) (n) : nth (tail s) n = nth s (n + 1) := rfl

/-- Recursion principle for sequences, compare with `list.rec_on`. -/
def rec_on {C : seq α → Sort v} (s : seq α)
  (h1 : C nil) (h2 : ∀ x s, C (cons x s)) : C s := begin
  induction H : destruct s with v v,
  { rw destruct_eq_nil H, apply h1 },
  { cases v with a s', rw destruct_eq_cons H, apply h2 }
end

theorem mem_rec_on {C : seq α → Prop} {a s} (M : a ∈ s)
  (h1 : ∀ b s', (a = b ∨ C s') → C (cons b s')) : C s :=
begin
  cases M with k e, unfold stream.nth at e,
  induction k with k IH generalizing s,
  { have TH : s = cons a (tail s),
    { apply destruct_eq_cons,
      unfold destruct nth functor.map, rw ←e, refl },
    rw TH, apply h1 _ _ (or.inl rfl) },
  revert e, apply s.rec_on _ (λ b s', _); intro e,
  { injection e },
  { have h_eq : (cons b s').val (nat.succ k) = s'.val k, { cases s'; refl },
    rw [h_eq] at e,
    apply h1 _ _ (or.inr (IH e)) }
end

/-- Corecursor over pairs of `option` values-/
def corec.F (f : β → option (α × β)) : option β → option α × option β
| none     := (none, none)
| (some b) := match f b with none := (none, none) | some (a, b') := (some a, some b') end

/-- Corecursor for `seq α` as a coinductive type. Iterates `f` to produce new elements
  of the sequence until `none` is obtained. -/
def corec (f : β → option (α × β)) (b : β) : seq α :=
begin
  refine ⟨stream.corec' (corec.F f) (some b), λ n h, _⟩,
  rw stream.corec'_eq,
  change stream.corec' (corec.F f) (corec.F f (some b)).2 n = none,
  revert h, generalize : some b = o, revert o,
  induction n with n IH; intro o,
  { change (corec.F f o).1 = none → (corec.F f (corec.F f o).2).1 = none,
    cases o with b; intro h, { refl },
    dsimp [corec.F] at h, dsimp [corec.F],
    cases f b with s, { refl },
    { cases s with a b', contradiction } },
  { rw [stream.corec'_eq (corec.F f) (corec.F f o).2,
        stream.corec'_eq (corec.F f) o],
    exact IH (corec.F f o).2 }
end

@[simp] theorem corec_eq (f : β → option (α × β)) (b : β) :
  destruct (corec f b) = omap (corec f) (f b) :=
begin
  dsimp [corec, destruct, nth],
  change stream.corec' (corec.F f) (some b) 0 with (corec.F f (some b)).1,
  dsimp [corec.F],
  induction h : f b with s, { refl },
  cases s with a b', dsimp [corec.F],
  apply congr_arg (λ b', some (a, b')),
  apply subtype.eq,
  dsimp [corec, tail],
  rw [stream.corec'_eq, stream.tail_cons],
  dsimp [corec.F], rw h, refl
end

section bisim
  variable (R : seq α → seq α → Prop)

  local infix (name := R) ` ~ `:50 := R

  /-- Bisimilarity relation over `option` of `seq1 α`-/
  def bisim_o : option (seq1 α) → option (seq1 α) → Prop
  | none          none            := true
  | (some (a, s)) (some (a', s')) := a = a' ∧ R s s'
  | _             _               := false
  attribute [simp] bisim_o

  /-- a relation is bisimiar if it meets the `bisim_o` test-/
  def is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → bisim_o R (destruct s₁) (destruct s₂)

  -- If two streams are bisimilar, then they are equal
  theorem eq_of_bisim (bisim : is_bisimulation R) {s₁ s₂} (r : s₁ ~ s₂) : s₁ = s₂ :=
  begin
    apply subtype.eq,
    apply stream.eq_of_bisim (λ x y, ∃ s s' : seq α, s.1 = x ∧ s'.1 = y ∧ R s s'),
    dsimp [stream.is_bisimulation],
    intros t₁ t₂ e,
    exact match t₁, t₂, e with ._, ._, ⟨s, s', rfl, rfl, r⟩ :=
      suffices head s = head s' ∧ R (tail s) (tail s'), from
      and.imp id (λ r, ⟨tail s, tail s',
        by cases s; refl, by cases s'; refl, r⟩) this,
      begin
        have := bisim r, revert r this,
        apply rec_on s _ _; intros; apply rec_on s' _ _; intros; intros r this,
        { constructor, refl, assumption },
        { rw [destruct_nil, destruct_cons] at this,
          exact false.elim this },
        { rw [destruct_nil, destruct_cons] at this,
          exact false.elim this },
        { rw [destruct_cons, destruct_cons] at this,
          rw [head_cons, head_cons, tail_cons, tail_cons],
          cases this with h1 h2,
          constructor, rw h1, exact h2 }
      end
    end,
    exact ⟨s₁, s₂, rfl, rfl, r⟩
  end
end bisim

theorem coinduction : ∀ {s₁ s₂ : seq α}, head s₁ = head s₂ →
  (∀ (β : Type u) (fr : seq α → β),
    fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂)) → s₁ = s₂
| ⟨f₁, a₁⟩ ⟨f₂, a₂⟩ hh ht :=
  subtype.eq (stream.coinduction hh (λ β fr, ht β (λ s, fr s.1)))

theorem coinduction2 (s) (f g : seq α → seq β)
  (H : ∀ s, bisim_o (λ (s1 s2 : seq β), ∃ (s : seq α), s1 = f s ∧ s2 = g s)
    (destruct (f s)) (destruct (g s)))
  : f s = g s :=
begin
  refine eq_of_bisim (λ s1 s2, ∃ s, s1 = f s ∧ s2 = g s) _ ⟨s, rfl, rfl⟩,
  intros s1 s2 h, rcases h with ⟨s, h1, h2⟩,
  rw [h1, h2], apply H
end

/-- Embed a list as a sequence -/
def of_list (l : list α) : seq α :=
⟨list.nth l, λ n h, begin
  rw list.nth_eq_none_iff at h ⊢,
  exact h.trans (nat.le_succ n)
end⟩

instance coe_list : has_coe (list α) (seq α) := ⟨of_list⟩

@[simp] theorem of_list_nil : of_list [] = (nil : seq α) := rfl
@[simp] theorem of_list_nth (l : list α) (n : ℕ) : (of_list l).nth n = l.nth n := rfl
@[simp] theorem of_list_cons (a : α) (l : list α) : of_list (a :: l) = cons a (of_list l) :=
by ext1 (_|n); refl

/-- Embed an infinite stream as a sequence -/
def of_stream (s : stream α) : seq α :=
⟨s.map some, λ n h, by contradiction⟩

instance coe_stream : has_coe (stream α) (seq α) := ⟨of_stream⟩

/-- Embed a `lazy_list α` as a sequence. Note that even though this
  is non-meta, it will produce infinite sequences if used with
  cyclic `lazy_list`s created by meta constructions. -/
def of_lazy_list : lazy_list α → seq α :=
corec (λ l, match l with
  | lazy_list.nil := none
  | lazy_list.cons a l' := some (a, l' ())
  end)

instance coe_lazy_list : has_coe (lazy_list α) (seq α) := ⟨of_lazy_list⟩

/-- Translate a sequence into a `lazy_list`. Since `lazy_list` and `list`
  are isomorphic as non-meta types, this function is necessarily meta. -/
meta def to_lazy_list : seq α → lazy_list α | s :=
match destruct s with
| none := lazy_list.nil
| some (a, s') := lazy_list.cons a (to_lazy_list s')
end

/-- Translate a sequence to a list. This function will run forever if
  run on an infinite sequence. -/
meta def force_to_list (s : seq α) : list α := (to_lazy_list s).to_list

/-- The sequence of natural numbers some 0, some 1, ... -/
def nats : seq ℕ := stream.nats

@[simp]
lemma nats_nth (n : ℕ) : nats.nth n = some n := rfl

/-- Append two sequences. If `s₁` is infinite, then `s₁ ++ s₂ = s₁`,
  otherwise it puts `s₂` at the location of the `nil` in `s₁`. -/
def append (s₁ s₂ : seq α) : seq α :=
@corec α (seq α × seq α) (λ ⟨s₁, s₂⟩,
  match destruct s₁ with
  | none := omap (λ s₂, (nil, s₂)) (destruct s₂)
  | some (a, s₁') := some (a, s₁', s₂)
  end) (s₁, s₂)

/-- Map a function over a sequence. -/
def map (f : α → β) : seq α → seq β | ⟨s, al⟩ :=
⟨s.map (option.map f),
λ n, begin
  dsimp [stream.map, stream.nth],
  induction e : s n; intro,
  { rw al e, assumption }, { contradiction }
end⟩

/-- Flatten a sequence of sequences. (It is required that the
  sequences be nonempty to ensure productivity; in the case
  of an infinite sequence of `nil`, the first element is never
  generated.) -/
def join : seq (seq1 α) → seq α :=
corec (λ S, match destruct S with
  | none := none
  | some ((a, s), S') := some (a, match destruct s with
    | none := S'
    | some s' := cons s' S'
    end)
  end)

/-- Remove the first `n` elements from the sequence. -/
def drop (s : seq α) : ℕ → seq α
| 0     := s
| (n+1) := tail (drop n)
attribute [simp] drop

/-- Take the first `n` elements of the sequence (producing a list) -/
def take : ℕ → seq α → list α
| 0     s := []
| (n+1) s := match destruct s with
  | none := []
  | some (x, r) := list.cons x (take n r)
  end

/-- Split a sequence at `n`, producing a finite initial segment
  and an infinite tail. -/
def split_at : ℕ → seq α → list α × seq α
| 0     s := ([], s)
| (n+1) s := match destruct s with
  | none := ([], nil)
  | some (x, s') := let (l, r) := split_at n s' in (list.cons x l, r)
  end

section zip_with

/-- Combine two sequences with a function -/
def zip_with (f : α → β → γ) (s₁ : seq α) (s₂ : seq β) : seq γ :=
⟨λ n, option.map₂ f (s₁.nth n) (s₂.nth n), λ n hn,
  option.map₂_eq_none_iff.2 $ (option.map₂_eq_none_iff.1 hn).imp s₁.2 s₂.2⟩

variables {s : seq α} {s' : seq β} {n : ℕ}

@[simp] lemma nth_zip_with (f : α → β → γ) (s s' n) :
  (zip_with f s s').nth n = option.map₂ f (s.nth n) (s'.nth n) :=
rfl

end zip_with

/-- Pair two sequences into a sequence of pairs -/
def zip : seq α → seq β → seq (α × β) := zip_with prod.mk

lemma nth_zip (s : seq α) (t : seq β) (n : ℕ) :
  nth (zip s t) n = option.map₂ prod.mk (nth s n) (nth t n) :=
nth_zip_with _ _ _ _

/-- Separate a sequence of pairs into two sequences -/
def unzip (s : seq (α × β)) : seq α × seq β := (map prod.fst s, map prod.snd s)

/-- Enumerate a sequence by tagging each element with its index. -/
def enum (s : seq α) : seq (ℕ × α) := seq.zip nats s

@[simp] lemma nth_enum (s : seq α) (n : ℕ) : nth (enum s) n = option.map (prod.mk n) (nth s n) :=
nth_zip _ _ _

@[simp] lemma enum_nil : enum (nil : seq α) = nil := rfl

/-- Convert a sequence which is known to terminate into a list -/
def to_list (s : seq α) (h : s.terminates) : list α :=
take (nat.find h) s

/-- Convert a sequence which is known not to terminate into a stream -/
def to_stream (s : seq α) (h : ¬ s.terminates) : stream α :=
λ n, option.get $ not_terminates_iff.1 h n

/-- Convert a sequence into either a list or a stream depending on whether
  it is finite or infinite. (Without decidability of the infiniteness predicate,
  this is not constructively possible.) -/
def to_list_or_stream (s : seq α) [decidable s.terminates] : list α ⊕ stream α :=
if h : s.terminates
then sum.inl (to_list s h)
else sum.inr (to_stream s h)

@[simp] theorem nil_append (s : seq α) : append nil s = s :=
begin
  apply coinduction2, intro s,
  dsimp [append], rw [corec_eq],
  dsimp [append], apply rec_on s _ _,
  { trivial },
  { intros x s,
    rw [destruct_cons], dsimp,
    exact ⟨rfl, s, rfl, rfl⟩ }
end

@[simp] theorem cons_append (a : α) (s t) : append (cons a s) t = cons a (append s t) :=
destruct_eq_cons $ begin
  dsimp [append], rw [corec_eq],
  dsimp [append], rw [destruct_cons],
  dsimp [append], refl
end

@[simp] theorem append_nil (s : seq α) : append s nil = s :=
begin
  apply coinduction2 s, intro s,
  apply rec_on s _ _,
  { trivial },
  { intros x s,
    rw [cons_append, destruct_cons, destruct_cons], dsimp,
    exact ⟨rfl, s, rfl, rfl⟩ }
end

@[simp] theorem append_assoc (s t u : seq α) :
  append (append s t) u = append s (append t u) :=
begin
  apply eq_of_bisim (λ s1 s2, ∃ s t u,
    s1 = append (append s t) u ∧ s2 = append s (append t u)),
  { intros s1 s2 h, exact match s1, s2, h with ._, ._, ⟨s, t, u, rfl, rfl⟩ := begin
      apply rec_on s; simp,
      { apply rec_on t; simp,
        { apply rec_on u; simp,
          { intros x u, refine ⟨nil, nil, u, _, _⟩; simp } },
        { intros x t, refine ⟨nil, t, u, _, _⟩; simp } },
      { intros x s, exact ⟨s, t, u, rfl, rfl⟩ }
    end end },
  { exact ⟨s, t, u, rfl, rfl⟩ }
end

@[simp] theorem map_nil (f : α → β) : map f nil = nil := rfl

@[simp] theorem map_cons (f : α → β) (a) : ∀ s, map f (cons a s) = cons (f a) (map f s)
| ⟨s, al⟩ := by apply subtype.eq; dsimp [cons, map]; rw stream.map_cons; refl

@[simp] theorem map_id : ∀ (s : seq α), map id s = s
| ⟨s, al⟩ := begin
  apply subtype.eq; dsimp [map],
  rw [option.map_id, stream.map_id]; refl
end

@[simp] theorem map_tail (f : α → β) : ∀ s, map f (tail s) = tail (map f s)
| ⟨s, al⟩ := by apply subtype.eq; dsimp [tail, map]; rw stream.map_tail; refl

theorem map_comp (f : α → β) (g : β → γ) : ∀ (s : seq α), map (g ∘ f) s = map g (map f s)
| ⟨s, al⟩ := begin
  apply subtype.eq; dsimp [map],
  rw stream.map_map,
  apply congr_arg (λ f : _ → option γ, stream.map f s),
  ext ⟨⟩; refl
end

@[simp] theorem map_append (f : α → β) (s t) : map f (append s t) = append (map f s) (map f t) :=
begin
  apply eq_of_bisim (λ s1 s2, ∃ s t,
    s1 = map f (append s t) ∧ s2 = append (map f s) (map f t)) _ ⟨s, t, rfl, rfl⟩,
  intros s1 s2 h, exact match s1, s2, h with ._, ._, ⟨s, t, rfl, rfl⟩ := begin
    apply rec_on s; simp,
    { apply rec_on t; simp,
      { intros x t, refine ⟨nil, t, _, _⟩; simp } },
    { intros x s, refine ⟨s, t, rfl, rfl⟩ }
  end end
end

@[simp] theorem map_nth (f : α → β) : ∀ s n, nth (map f s) n = (nth s n).map f
| ⟨s, al⟩ n := rfl

instance : functor seq := {map := @map}

instance : is_lawful_functor seq :=
{ id_map := @map_id, comp_map := @map_comp }

@[simp] theorem join_nil : join nil = (nil : seq α) := destruct_eq_nil rfl

@[simp] theorem join_cons_nil (a : α) (S) :
  join (cons (a, nil) S) = cons a (join S) :=
destruct_eq_cons $ by simp [join]

@[simp] theorem join_cons_cons (a b : α) (s S) :
  join (cons (a, cons b s) S) = cons a (join (cons (b, s) S)) :=
destruct_eq_cons $ by simp [join]

@[simp, priority 990] theorem join_cons (a : α) (s S) :
  join (cons (a, s) S) = cons a (append s (join S)) :=
begin
  apply eq_of_bisim (λ s1 s2, s1 = s2 ∨
    ∃ a s S, s1 = join (cons (a, s) S) ∧
      s2 = cons a (append s (join S))) _ (or.inr ⟨a, s, S, rfl, rfl⟩),
  intros s1 s2 h,
  exact match s1, s2, h with
  | _, _, (or.inl $ eq.refl s) := begin
      apply rec_on s, { trivial },
      { intros x s, rw [destruct_cons], exact ⟨rfl, or.inl rfl⟩ }
    end
  | ._, ._, (or.inr ⟨a, s, S, rfl, rfl⟩) := begin
      apply rec_on s,
      { simp },
      { intros x s, simp, refine or.inr ⟨x, s, S, rfl, rfl⟩ }
    end
  end
end

@[simp] theorem join_append (S T : seq (seq1 α)) :
  join (append S T) = append (join S) (join T) :=
begin
  apply eq_of_bisim (λ s1 s2, ∃ s S T,
    s1 = append s (join (append S T)) ∧
    s2 = append s (append (join S) (join T))),
  { intros s1 s2 h, exact match s1, s2, h with ._, ._, ⟨s, S, T, rfl, rfl⟩ := begin
      apply rec_on s; simp,
      { apply rec_on S; simp,
        { apply rec_on T, { simp },
          { intros s T, cases s with a s; simp,
            refine ⟨s, nil, T, _, _⟩; simp } },
        { intros s S, cases s with a s; simp,
          exact ⟨s, S, T, rfl, rfl⟩ } },
      { intros x s, exact ⟨s, S, T, rfl, rfl⟩ }
    end end },
  { refine ⟨nil, S, T, _, _⟩; simp }
end

@[simp] theorem of_stream_cons (a : α) (s) :
  of_stream (a :: s) = cons a (of_stream s) :=
by apply subtype.eq; simp [of_stream, cons]; rw stream.map_cons

@[simp] theorem of_list_append (l l' : list α) :
  of_list (l ++ l') = append (of_list l) (of_list l') :=
by induction l; simp [*]

@[simp] theorem of_stream_append (l : list α) (s : stream α) :
  of_stream (l ++ₛ s) = append (of_list l) (of_stream s) :=
by induction l; simp [*, stream.nil_append_stream, stream.cons_append_stream]

/-- Convert a sequence into a list, embedded in a computation to allow for
  the possibility of infinite sequences (in which case the computation
  never returns anything). -/
def to_list' {α} (s : seq α) : computation (list α) :=
@computation.corec (list α) (list α × seq α) (λ ⟨l, s⟩,
  match destruct s with
  | none         := sum.inl l.reverse
  | some (a, s') := sum.inr (a::l, s')
  end) ([], s)

theorem dropn_add (s : seq α) (m) : ∀ n, drop s (m + n) = drop (drop s m) n
| 0     := rfl
| (n+1) := congr_arg tail (dropn_add n)

theorem dropn_tail (s : seq α) (n) : drop (tail s) n = drop s (n + 1) :=
by rw add_comm; symmetry; apply dropn_add

@[simp] theorem head_dropn (s : seq α) (n) : head (drop s n) = nth s n :=
begin
  induction n with n IH generalizing s, { refl },
  rw [nat.succ_eq_add_one, ←nth_tail, ←dropn_tail], apply IH
end

theorem mem_map (f : α → β) {a : α} : ∀ {s : seq α}, a ∈ s → f a ∈ map f s
| ⟨g, al⟩ := stream.mem_map (option.map f)

theorem exists_of_mem_map {f} {b : β} : ∀ {s : seq α}, b ∈ map f s → ∃ a, a ∈ s ∧ f a = b
| ⟨g, al⟩ h := let ⟨o, om, oe⟩ := stream.exists_of_mem_map h in
  by cases o with a; injection oe with h'; exact ⟨a, om, h'⟩

theorem of_mem_append {s₁ s₂ : seq α} {a : α} (h : a ∈ append s₁ s₂) : a ∈ s₁ ∨ a ∈ s₂ :=
begin
  have := h, revert this,
  generalize e : append s₁ s₂ = ss, intro h, revert s₁,
  apply mem_rec_on h _,
  intros b s' o s₁,
  apply s₁.rec_on _ (λ c t₁, _); intros m e;
  have := congr_arg destruct e,
  { apply or.inr, simpa using m },
  { cases (show a = c ∨ a ∈ append t₁ s₂, by simpa using m) with e' m,
    { rw e', exact or.inl (mem_cons _ _) },
    { cases (show c = b ∧ append t₁ s₂ = s', by simpa) with i1 i2,
      cases o with e' IH,
      { simp [i1, e'] },
      { exact or.imp_left (mem_cons_of_mem _) (IH m i2) } } }
end

theorem mem_append_left {s₁ s₂ : seq α} {a : α} (h : a ∈ s₁) : a ∈ append s₁ s₂ :=
by apply mem_rec_on h; intros; simp [*]

@[simp] lemma enum_cons (s : seq α) (x : α) :
  enum (cons x s) = cons (0, x) (map (prod.map nat.succ id) (enum s)) :=
begin
  ext ⟨n⟩ : 1,
  { simp, },
  { simp only [nth_enum, nth_cons_succ, map_nth, option.map_map],
    congr }
end

end seq

namespace seq1
variables {α : Type u} {β : Type v} {γ : Type w}
open stream.seq

/-- Convert a `seq1` to a sequence. -/
def to_seq : seq1 α → seq α
| (a, s) := seq.cons a s

instance coe_seq : has_coe (seq1 α) (seq α) := ⟨to_seq⟩

/-- Map a function on a `seq1` -/
def map (f : α → β) : seq1 α → seq1 β
| (a, s) := (f a, seq.map f s)

theorem map_id : ∀ (s : seq1 α), map id s = s | ⟨a, s⟩ := by simp [map]

/-- Flatten a nonempty sequence of nonempty sequences -/
def join : seq1 (seq1 α) → seq1 α
| ((a, s), S) := match destruct s with
  | none := (a, seq.join S)
  | some s' := (a, seq.join (seq.cons s' S))
  end

@[simp] theorem join_nil (a : α) (S) : join ((a, nil), S) = (a, seq.join S) := rfl

@[simp] theorem join_cons (a b : α) (s S) :
  join ((a, seq.cons b s), S) = (a, seq.join (seq.cons (b, s) S)) :=
by dsimp [join]; rw [destruct_cons]; refl

/-- The `return` operator for the `seq1` monad,
  which produces a singleton sequence. -/
def ret (a : α) : seq1 α := (a, nil)

instance [inhabited α] : inhabited (seq1 α) := ⟨ret default⟩

/-- The `bind` operator for the `seq1` monad,
  which maps `f` on each element of `s` and appends the results together.
  (Not all of `s` may be evaluated, because the first few elements of `s`
  may already produce an infinite result.) -/
def bind (s : seq1 α) (f : α → seq1 β) : seq1 β :=
join (map f s)

@[simp] theorem join_map_ret (s : seq α) : seq.join (seq.map ret s) = s :=
by apply coinduction2 s; intro s; apply rec_on s; simp [ret]

@[simp] theorem bind_ret (f : α → β) : ∀ s, bind s (ret ∘ f) = map f s
| ⟨a, s⟩ := begin
  dsimp [bind, map], change (λ x, ret (f x)) with (ret ∘ f),
  rw [map_comp], simp [function.comp, ret]
end

@[simp] theorem ret_bind (a : α) (f : α → seq1 β) : bind (ret a) f = f a :=
begin
  simp [ret, bind, map],
  cases f a with a s,
  apply rec_on s; intros; simp
end

@[simp] theorem map_join' (f : α → β) (S) :
  seq.map f (seq.join S) = seq.join (seq.map (map f) S) :=
begin
  apply seq.eq_of_bisim (λ s1 s2,
    ∃ s S, s1 = seq.append s (seq.map f (seq.join S)) ∧
      s2 = append s (seq.join (seq.map (map f) S))),
  { intros s1 s2 h, exact match s1, s2, h with ._, ._, ⟨s, S, rfl, rfl⟩ := begin
      apply rec_on s; simp,
      { apply rec_on S; simp,
        { intros x S, cases x with a s; simp [map],
          exact ⟨_, _, rfl, rfl⟩ } },
      { intros x s, refine ⟨s, S, rfl, rfl⟩ }
    end end },
  { refine ⟨nil, S, _, _⟩; simp }
end

@[simp] theorem map_join (f : α → β) : ∀ S, map f (join S) = join (map (map f) S)
| ((a, s), S) := by apply rec_on s; intros; simp [map]

@[simp] theorem join_join (SS : seq (seq1 (seq1 α))) :
  seq.join (seq.join SS) = seq.join (seq.map join SS) :=
begin
  apply seq.eq_of_bisim (λ s1 s2,
    ∃ s SS, s1 = seq.append s (seq.join (seq.join SS)) ∧
      s2 = seq.append s (seq.join (seq.map join SS))),
  { intros s1 s2 h, exact match s1, s2, h with ._, ._, ⟨s, SS, rfl, rfl⟩ := begin
      apply rec_on s; simp,
      { apply rec_on SS; simp,
        { intros S SS, cases S with s S; cases s with x s; simp [map],
          apply rec_on s; simp,
          { exact ⟨_, _, rfl, rfl⟩ },
          { intros x s,
            refine ⟨seq.cons x (append s (seq.join S)), SS, _, _⟩; simp } } },
      { intros x s, exact ⟨s, SS, rfl, rfl⟩ }
    end end },
  { refine ⟨nil, SS, _, _⟩; simp }
end

@[simp] theorem bind_assoc (s : seq1 α) (f : α → seq1 β) (g : β → seq1 γ) :
  bind (bind s f) g = bind s (λ (x : α), bind (f x) g) :=
begin
  cases s with a s,
  simp [bind, map],
  rw [←map_comp],
  change (λ x, join (map g (f x))) with (join ∘ ((map g) ∘ f)),
  rw [map_comp _ join],
  generalize : seq.map (map g ∘ f) s = SS,
  rcases map g (f a) with ⟨⟨a, s⟩, S⟩,
  apply rec_on s; intros; apply rec_on S; intros; simp,
  { cases x with x t, apply rec_on t; intros; simp },
  { cases x_1 with y t; simp }
end

instance : monad seq1 :=
{ map  := @map,
  pure := @ret,
  bind := @bind }

instance : is_lawful_monad seq1 :=
{ id_map := @map_id,
  bind_pure_comp_eq_map := @bind_ret,
  pure_bind := @ret_bind,
  bind_assoc := @bind_assoc }

end seq1
end stream


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Yaël Dillies
-/
import topology.sets.closeds
import topology.quasi_separated

/-!
# Compact sets

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

We define a few types of compact sets in a topological space.

## Main Definitions

For a topological space `α`,
* `compacts α`: The type of compact sets.
* `nonempty_compacts α`: The type of non-empty compact sets.
* `positive_compacts α`: The type of compact sets with non-empty interior.
* `compact_opens α`: The type of compact open sets. This is a central object in the study of
  spectral spaces.
-/

open set

variables {α β : Type*} [topological_space α] [topological_space β]

namespace topological_space

/-! ### Compact sets -/

/-- The type of compact sets of a topological space. -/
structure compacts (α : Type*) [topological_space α] :=
(carrier : set α)
(is_compact' : is_compact carrier)

namespace compacts
variables {α}

instance : set_like (compacts α) α :=
{ coe := compacts.carrier,
  coe_injective' := λ s t h, by { cases s, cases t, congr' } }

protected lemma is_compact (s : compacts α) : is_compact (s : set α) := s.is_compact'

instance (K : compacts α) : compact_space K := is_compact_iff_compact_space.1 K.is_compact

instance : can_lift (set α) (compacts α) coe is_compact :=
{ prf := λ K hK, ⟨⟨K, hK⟩, rfl⟩ }

@[ext] protected lemma ext {s t : compacts α} (h : (s : set α) = t) : s = t := set_like.ext' h

@[simp] lemma coe_mk (s : set α) (h) : (mk s h : set α) = s := rfl

@[simp] lemma carrier_eq_coe (s : compacts α) : s.carrier = s := rfl

instance : has_sup (compacts α) := ⟨λ s t, ⟨s ∪ t, s.is_compact.union t.is_compact⟩⟩
instance [t2_space α] : has_inf (compacts α) := ⟨λ s t, ⟨s ∩ t, s.is_compact.inter t.is_compact⟩⟩
instance [compact_space α] : has_top (compacts α) := ⟨⟨univ, is_compact_univ⟩⟩
instance : has_bot (compacts α) := ⟨⟨∅, is_compact_empty⟩⟩

instance : semilattice_sup (compacts α) := set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance [t2_space α] : distrib_lattice (compacts α) :=
set_like.coe_injective.distrib_lattice _ (λ _ _, rfl) (λ _ _, rfl)

instance : order_bot (compacts α) := order_bot.lift (coe : _ → set α) (λ _ _, id) rfl

instance [compact_space α] : bounded_order (compacts α) :=
bounded_order.lift (coe : _ → set α) (λ _ _, id) rfl rfl

/-- The type of compact sets is inhabited, with default element the empty set. -/
instance : inhabited (compacts α) := ⟨⊥⟩

@[simp] lemma coe_sup (s t : compacts α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_inf [t2_space α] (s t : compacts α) : (↑(s ⊓ t) : set α) = s ∩ t := rfl
@[simp] lemma coe_top [compact_space α] : (↑(⊤ : compacts α) : set α) = univ := rfl
@[simp] lemma coe_bot : (↑(⊥ : compacts α) : set α) = ∅ := rfl

@[simp] lemma coe_finset_sup {ι : Type*} {s : finset ι} {f : ι → compacts α} :
  (↑(s.sup f) : set α) = s.sup (λ i, f i) :=
begin
  classical,
  refine finset.induction_on s rfl (λ a s _ h, _),
  simp_rw [finset.sup_insert, coe_sup, sup_eq_union],
  congr',
end

/-- The image of a compact set under a continuous function. -/
protected def map (f : α → β) (hf : continuous f) (K : compacts α) : compacts β :=
⟨f '' K.1, K.2.image hf⟩

@[simp] lemma coe_map {f : α → β} (hf : continuous f) (s : compacts α) :
  (s.map f hf : set β) = f '' s := rfl

/-- A homeomorphism induces an equivalence on compact sets, by taking the image. -/
@[simp] protected def equiv (f : α ≃ₜ β) : compacts α ≃ compacts β :=
{ to_fun := compacts.map f f.continuous,
  inv_fun := compacts.map _ f.symm.continuous,
  left_inv := λ s, by { ext1, simp only [coe_map, ← image_comp, f.symm_comp_self, image_id] },
  right_inv := λ s, by { ext1, simp only [coe_map, ← image_comp, f.self_comp_symm, image_id] } }

/-- The image of a compact set under a homeomorphism can also be expressed as a preimage. -/
lemma equiv_to_fun_val (f : α ≃ₜ β) (K : compacts α) :
  (compacts.equiv f K).1 = f.symm ⁻¹' K.1 :=
congr_fun (image_eq_preimage_of_inverse f.left_inv f.right_inv) K.1

/-- The product of two `compacts`, as a `compacts` in the product space. -/
protected def prod (K : compacts α) (L : compacts β) : compacts (α × β) :=
{ carrier := K ×ˢ L,
  is_compact' := is_compact.prod K.2 L.2 }

@[simp] lemma coe_prod (K : compacts α) (L : compacts β) : (K.prod L : set (α × β)) = K ×ˢ L := rfl

end compacts

/-! ### Nonempty compact sets -/

/-- The type of nonempty compact sets of a topological space. -/
structure nonempty_compacts (α : Type*) [topological_space α] extends compacts α :=
(nonempty' : carrier.nonempty)

namespace nonempty_compacts

instance : set_like (nonempty_compacts α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { obtain ⟨⟨_, _⟩, _⟩ := s, obtain ⟨⟨_, _⟩, _⟩ := t, congr' } }

protected lemma is_compact (s : nonempty_compacts α) : is_compact (s : set α) := s.is_compact'
protected lemma nonempty (s : nonempty_compacts α) : (s : set α).nonempty := s.nonempty'

/-- Reinterpret a nonempty compact as a closed set. -/
def to_closeds [t2_space α] (s : nonempty_compacts α) : closeds α := ⟨s, s.is_compact.is_closed⟩

@[ext] protected lemma ext {s t : nonempty_compacts α} (h : (s : set α) = t) : s = t :=
set_like.ext' h

@[simp] lemma coe_mk (s : compacts α) (h) : (mk s h : set α) = s := rfl

@[simp] lemma carrier_eq_coe (s : nonempty_compacts α) : s.carrier = s := rfl

instance : has_sup (nonempty_compacts α) :=
⟨λ s t, ⟨s.to_compacts ⊔ t.to_compacts, s.nonempty.mono $ subset_union_left _ _⟩⟩
instance [compact_space α] [nonempty α] : has_top (nonempty_compacts α) := ⟨⟨⊤, univ_nonempty⟩⟩

instance : semilattice_sup (nonempty_compacts α) :=
set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance [compact_space α] [nonempty α] : order_top (nonempty_compacts α) :=
order_top.lift (coe : _ → set α) (λ _ _, id) rfl

@[simp] lemma coe_sup (s t : nonempty_compacts α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_top [compact_space α] [nonempty α] :
  (↑(⊤ : nonempty_compacts α) : set α) = univ := rfl

/-- In an inhabited space, the type of nonempty compact subsets is also inhabited, with
default element the singleton set containing the default element. -/
instance [inhabited α] : inhabited (nonempty_compacts α) :=
⟨{ carrier := {default}, is_compact' := is_compact_singleton, nonempty' := singleton_nonempty _ }⟩

instance to_compact_space {s : nonempty_compacts α} : compact_space s :=
is_compact_iff_compact_space.1 s.is_compact

instance to_nonempty {s : nonempty_compacts α} : nonempty s := s.nonempty.to_subtype

/-- The product of two `nonempty_compacts`, as a `nonempty_compacts` in the product space. -/
protected def prod (K : nonempty_compacts α) (L : nonempty_compacts β) :
  nonempty_compacts (α × β) :=
{ nonempty' := K.nonempty.prod L.nonempty,
  .. K.to_compacts.prod L.to_compacts }

@[simp] lemma coe_prod (K : nonempty_compacts α) (L : nonempty_compacts β) :
  (K.prod L : set (α × β)) = K ×ˢ L := rfl

end nonempty_compacts

/-! ### Positive compact sets -/

/-- The type of compact sets with nonempty interior of a topological space.
See also `compacts` and `nonempty_compacts`. -/
structure positive_compacts (α : Type*) [topological_space α] extends compacts α :=
(interior_nonempty' : (interior carrier).nonempty)

namespace positive_compacts

instance : set_like (positive_compacts α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { obtain ⟨⟨_, _⟩, _⟩ := s, obtain ⟨⟨_, _⟩, _⟩ := t, congr' } }

protected lemma is_compact (s : positive_compacts α) : is_compact (s : set α) := s.is_compact'
lemma interior_nonempty (s : positive_compacts α) : (interior (s : set α)).nonempty :=
s.interior_nonempty'

protected lemma nonempty (s : positive_compacts α) : (s : set α).nonempty :=
s.interior_nonempty.mono interior_subset

/-- Reinterpret a positive compact as a nonempty compact. -/
def to_nonempty_compacts (s : positive_compacts α) : nonempty_compacts α :=
⟨s.to_compacts, s.nonempty⟩

@[ext] protected lemma ext {s t : positive_compacts α} (h : (s : set α) = t) : s = t :=
set_like.ext' h

@[simp] lemma coe_mk (s : compacts α) (h) : (mk s h : set α) = s := rfl

@[simp] lemma carrier_eq_coe (s : positive_compacts α) : s.carrier = s := rfl

instance : has_sup (positive_compacts α) :=
⟨λ s t, ⟨s.to_compacts ⊔ t.to_compacts,
  s.interior_nonempty.mono $ interior_mono $ subset_union_left _ _⟩⟩

instance [compact_space α] [nonempty α] : has_top (positive_compacts α) :=
⟨⟨⊤, interior_univ.symm.subst univ_nonempty⟩⟩

instance : semilattice_sup (positive_compacts α) :=
set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance [compact_space α] [nonempty α] : order_top (positive_compacts α) :=
order_top.lift (coe : _ → set α) (λ _ _, id) rfl

@[simp] lemma coe_sup (s t : positive_compacts α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_top [compact_space α] [nonempty α] :
  (↑(⊤ : positive_compacts α) : set α) = univ := rfl

lemma _root_.exists_positive_compacts_subset [locally_compact_space α] {U : set α} (ho : is_open U)
  (hn : U.nonempty) : ∃ K : positive_compacts α, ↑K ⊆ U :=
let ⟨x, hx⟩ := hn, ⟨K, hKc, hxK, hKU⟩ := exists_compact_subset ho hx in ⟨⟨⟨K, hKc⟩, ⟨x, hxK⟩⟩, hKU⟩

instance [compact_space α] [nonempty α] : inhabited (positive_compacts α) := ⟨⊤⟩

/-- In a nonempty locally compact space, there exists a compact set with nonempty interior. -/
instance nonempty' [locally_compact_space α] [nonempty α] : nonempty (positive_compacts α) :=
nonempty_of_exists $ exists_positive_compacts_subset is_open_univ univ_nonempty

/-- The product of two `positive_compacts`, as a `positive_compacts` in the product space. -/
protected def prod (K : positive_compacts α) (L : positive_compacts β) :
  positive_compacts (α × β) :=
{ interior_nonempty' :=
  begin
    simp only [compacts.carrier_eq_coe, compacts.coe_prod, interior_prod_eq],
    exact K.interior_nonempty.prod L.interior_nonempty,
  end,
  .. K.to_compacts.prod L.to_compacts }

@[simp] lemma coe_prod (K : positive_compacts α) (L : positive_compacts β) :
  (K.prod L : set (α × β)) = K ×ˢ L := rfl

end positive_compacts

/-! ### Compact open sets -/

/-- The type of compact open sets of a topological space. This is useful in non Hausdorff contexts,
in particular spectral spaces. -/
structure compact_opens (α : Type*) [topological_space α] extends compacts α :=
(is_open' : is_open carrier)

namespace compact_opens

instance : set_like (compact_opens α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { obtain ⟨⟨_, _⟩, _⟩ := s, obtain ⟨⟨_, _⟩, _⟩ := t, congr' } }

protected lemma is_compact (s : compact_opens α) : is_compact (s : set α) := s.is_compact'
protected lemma is_open (s : compact_opens α) : is_open (s : set α) := s.is_open'

/-- Reinterpret a compact open as an open. -/
@[simps] def to_opens (s : compact_opens α) : opens α := ⟨s, s.is_open⟩

/-- Reinterpret a compact open as a clopen. -/
@[simps] def to_clopens [t2_space α] (s : compact_opens α) : clopens α :=
⟨s, s.is_open, s.is_compact.is_closed⟩

@[ext] protected lemma ext {s t : compact_opens α} (h : (s : set α) = t) : s = t := set_like.ext' h

@[simp] lemma coe_mk (s : compacts α) (h) : (mk s h : set α) = s := rfl

instance : has_sup (compact_opens α) :=
⟨λ s t, ⟨s.to_compacts ⊔ t.to_compacts, s.is_open.union t.is_open⟩⟩

instance [quasi_separated_space α] : has_inf (compact_opens α) :=
⟨λ U V, ⟨⟨(U : set α) ∩ (V : set α),
  quasi_separated_space.inter_is_compact U.1.1 V.1.1 U.2 U.1.2 V.2 V.1.2⟩, U.2.inter V.2⟩⟩
instance [quasi_separated_space α] : semilattice_inf (compact_opens α) :=
set_like.coe_injective.semilattice_inf _ (λ _ _, rfl)

instance [compact_space α] : has_top (compact_opens α) := ⟨⟨⊤, is_open_univ⟩⟩
instance : has_bot (compact_opens α) := ⟨⟨⊥, is_open_empty⟩⟩
instance [t2_space α] : has_sdiff (compact_opens α) :=
⟨λ s t, ⟨⟨s \ t, s.is_compact.diff t.is_open⟩, s.is_open.sdiff t.is_compact.is_closed⟩⟩
instance [t2_space α] [compact_space α] : has_compl (compact_opens α) :=
⟨λ s, ⟨⟨sᶜ, s.is_open.is_closed_compl.is_compact⟩, s.is_compact.is_closed.is_open_compl⟩⟩

instance : semilattice_sup (compact_opens α) :=
set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance : order_bot (compact_opens α) := order_bot.lift (coe : _ → set α) (λ _ _, id) rfl

instance [t2_space α] : generalized_boolean_algebra (compact_opens α) :=
set_like.coe_injective.generalized_boolean_algebra _ (λ _ _, rfl) (λ _ _, rfl) rfl (λ _ _, rfl)

instance [compact_space α] : bounded_order (compact_opens α) :=
bounded_order.lift (coe : _ → set α) (λ _ _, id) rfl rfl

instance [t2_space α] [compact_space α] : boolean_algebra (compact_opens α) :=
set_like.coe_injective.boolean_algebra _ (λ _ _, rfl) (λ _ _, rfl) rfl rfl (λ _, rfl) (λ _ _, rfl)

@[simp] lemma coe_sup (s t : compact_opens α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_inf [t2_space α] (s t : compact_opens α) : (↑(s ⊓ t) : set α) = s ∩ t := rfl
@[simp] lemma coe_top [compact_space α] : (↑(⊤ : compact_opens α) : set α) = univ := rfl
@[simp] lemma coe_bot : (↑(⊥ : compact_opens α) : set α) = ∅ := rfl
@[simp]

instance : inhabited (compact_opens α) := ⟨⊥⟩

/-- The image of a compact open under a continuous open map. -/
@[simps] def map (f : α → β) (hf : continuous f) (hf' : is_open_map f) (s : compact_opens α) :
  compact_opens β :=
⟨s.to_compacts.map f hf, hf' _ s.is_open⟩

@[simp] lemma coe_map {f : α → β} (hf : continuous f) (hf' : is_open_map f) (s : compact_opens α) :
  (s.map f hf hf' : set β) = f '' s := rfl

/-- The product of two `compact_opens`, as a `compact_opens` in the product space. -/
protected def prod (K : compact_opens α) (L : compact_opens β) :
  compact_opens (α × β) :=
{ is_open' := K.is_open.prod L.is_open,
  .. K.to_compacts.prod L.to_compacts }

@[simp] lemma coe_prod (K : compact_opens α) (L : compact_opens β) :
  (K.prod L : set (α × β)) = K ×ˢ L := rfl

end compact_opens
end topological_space


-- Razonamiento con tipos enumerados: Los días de la semana
-- ========================================================

-- ----------------------------------------------------
-- Ejercicio ?. Definir el tipo dia cuyos constructores
-- sean los días de la semana.
-- ---------------------------------------------------------------------

inductive dia : Type
| lunes     : dia
| martes    : dia
| miercoles : dia
| jueves    : dia
| viernes   : dia
| sabado    : dia
| domingo   : dia

-- ----------------------------------------------------
-- Ejercicio ?. Calcular el tipo del constructor lunes.
-- ----------------------------------------------------

-- #check dia.lunes
-- Da: dia

-- ----------------------------------------------------
-- Ejercicio ?. Abrir el espacio de nombre dia.
-- ----------------------------------------------------

namespace dia

-- ----------------------------------------------------
-- Ejercicio ?. Calcular el tipo del constructor lunes.
-- ----------------------------------------------------

-- #check lunes
-- Da: dia

-- ----------------------------------------------------
-- Ejercicio ?. Calcular la lista de las funciones
-- definidas en el espacio de nombres dia.
-- ----------------------------------------------------

-- #print prefix dia
-- Da:
--    dia : Type
--    dia.cases_on : Π {C : dia → Sort l} (n : dia),
--      C lunes → C martes → C miercoles → C jueves → C viernes → C sabado → C domingo → C n
--    dia.domingo : dia
--    dia.domingo.inj : domingo = domingo → true
--    dia.domingo.inj_arrow : domingo = domingo → Π ⦃P : Sort l⦄, (true → P) → P
--    dia.domingo.inj_eq : domingo = domingo = true
--    dia.domingo.sizeof_spec : domingo.sizeof = 1
--    dia.has_sizeof_inst : has_sizeof dia
--    dia.jueves : dia
--    dia.jueves.inj : jueves = jueves → true
--    dia.jueves.inj_arrow : jueves = jueves → Π ⦃P : Sort l⦄, (true → P) → P
--    dia.jueves.inj_eq : jueves = jueves = true
--    dia.jueves.sizeof_spec : jueves.sizeof = 1
--    dia.lunes : dia
--    dia.lunes.inj : lunes = lunes → true
--    dia.lunes.inj_arrow : lunes = lunes → Π ⦃P : Sort l⦄, (true → P) → P
--    dia.lunes.inj_eq : lunes = lunes = true
--    dia.lunes.sizeof_spec : lunes.sizeof = 1
--    dia.martes : dia
--    dia.martes.inj : martes = martes → true
--    dia.martes.inj_arrow : martes = martes → Π ⦃P : Sort l⦄, (true → P) → P
--    dia.martes.inj_eq : martes = martes = true
--    dia.martes.sizeof_spec : martes.sizeof = 1
--    dia.miercoles : dia
--    dia.miercoles.inj : miercoles = miercoles → true
--    dia.miercoles.inj_arrow : miercoles = miercoles → Π ⦃P : Sort l⦄, (true → P) → P
--    dia.miercoles.inj_eq : miercoles = miercoles = true
--    dia.miercoles.sizeof_spec : miercoles.sizeof = 1
--    dia.no_confusion : Π {P : Sort l} {v1 v2 : dia}, v1 = v2 → dia.no_confusion_type P v1 v2
--    dia.no_confusion_type : Sort l → dia → dia → Sort l
--    dia.rec : Π {C : dia → Sort l},
--      C lunes → C martes → C miercoles → C jueves → C viernes → C sabado → C domingo → Π (n : dia), C n
--    dia.rec_on : Π {C : dia → Sort l} (n : dia),
--      C lunes → C martes → C miercoles → C jueves → C viernes → C sabado → C domingo → C n
--    dia.sabado : dia
--    dia.sabado.inj : sabado = sabado → true
--    dia.sabado.inj_arrow : sabado = sabado → Π ⦃P : Sort l⦄, (true → P) → P
--    dia.sabado.inj_eq : sabado = sabado = true
--    dia.sabado.sizeof_spec : sabado.sizeof = 1
--    dia.sizeof : dia → ℕ
--    dia.viernes : dia
--    dia.viernes.inj : viernes = viernes → true
--    dia.viernes.inj_arrow : viernes = viernes → Π ⦃P : Sort l⦄, (true → P) → P
--    dia.viernes.inj_eq : viernes = viernes = true
--    dia.viernes.sizeof_spec : viernes.sizeof = 1

-- ----------------------------------------------------
-- Ejercicio ?. Calcular el tipo de las reglas de
-- eliminación (recursores) del tipo dia: dia.rec,
-- dia.rec_on y dia.cases_on.
-- ----------------------------------------------------

-- Recursor (regla de eliminación):
-- #check @dia.rec
-- Da: Π {C : dia → Sort u_1},
--       C lunes →
--       C martes →
--       C miercoles →
--       C jueves →
--       C viernes →
--       C sabado →
--       C domingo
--       → Π (n : dia), C n
--
-- #check @dia.rec_on
-- Da: Π {C : dia → Sort u_1} (n : dia),
--       C lunes →
--       C martes →
--       C miercoles →
--       C jueves →
--       C viernes →
--       C sabado →
--       C domingo
--
-- #check @dia.cases_on
-- Da: Π {C : dia → Sort u_1} (n : dia),
--       C lunes →
--       C martes →
--       C miercoles →
--       C jueves →
--       C viernes →
--       C sabado →
--       C domingo

-- ----------------------------------------------------
-- Ejercicio ?. Definir la función
--    numero_del_dia : dia → ℕ
-- tal que (numero_del_dia d) es el número del día de
-- la semana de d. Por ejemplo,
--    numero_del_dia martes = 2
-- ----------------------------------------------------

-- 1ª definición
def numero_del_dia (d : dia) : ℕ :=
dia.rec_on d 1 2 3 4 5 6 7

-- 2ª definición
def numero_del_dia_2 (d : dia) : ℕ :=
dia.cases_on d 1 2 3 4 5 6 7

-- 3ª definición
def numero_del_dia_3 : dia → ℕ :=
λ d, dia.rec 1 2 3 4 5 6 7 d

-- ----------------------------------------------------
-- Ejercicio ?. Definir la función
--    siguiente : dia → dia
-- tal que (siguiente d) es el día siguiente a d. Por
-- ejemplo,
--    siguiente (siguiente jueves) = sabado
-- ----------------------------------------------------

-- 1ª definición
def siguiente : dia → dia :=
λ d, dia.cases_on d martes miercoles jueves viernes sabado domingo lunes

-- 2ª definición
def siguiente_2 (d : dia) : dia :=
dia.cases_on d martes miercoles jueves viernes sabado domingo lunes

-- 3ª definición
def siguiente_3 : dia → dia
| lunes     := martes
| martes    := miercoles
| miercoles := jueves
| jueves    := viernes
| viernes   := sabado
| sabado    := domingo
| domingo   := lunes

-- #reduce siguiente (siguiente jueves)
-- Da: sabado

-- ----------------------------------------------------
-- Ejercicio ?. Definir la función
--    anterior : dia → dia
-- tal que (anterior d) es el día anterior a d. Por
-- ejemplo,
--    siguiente (anterior jueves) = jueves
-- ----------------------------------------------------

-- 1ª definición
def anterior : dia → dia :=
λ d, dia.cases_on d domingo lunes martes miercoles jueves viernes sabado

-- 2ª definición
def anterior_2 (d : dia) : dia :=
dia.cases_on d domingo lunes martes miercoles jueves viernes sabado

-- 3ª definición
def anterior_3 : dia → dia
| lunes     := domingo
| martes    := lunes
| miercoles := martes
| jueves    := miercoles
| viernes   := jueves
| sabado    := viernes
| domingo   := sabado

-- #reduce siguiente (anterior jueves)
-- Da: jueves

-- ----------------------------------------------------
-- Ejercicio ?. Demostrar que
--    siguiente (anterior jueves) = jueves
-- ----------------------------------------------------

example : siguiente (anterior jueves) = jueves :=
rfl

-- ----------------------------------------------------
-- Ejercicio ?. Demostrar que, para cualquier día d,
--    siguiente (anterior d) = d
-- ----------------------------------------------------

-- 1ª demostración
example (d: dia) :
  siguiente (anterior d) = d :=
dia.cases_on d
  (show siguiente (anterior lunes)     = lunes,     from rfl)
  (show siguiente (anterior martes)    = martes,    from rfl)
  (show siguiente (anterior miercoles) = miercoles, from rfl)
  (show siguiente (anterior jueves)    = jueves,    from rfl)
  (show siguiente (anterior viernes)   = viernes,   from rfl)
  (show siguiente (anterior sabado)    = sabado,    from rfl)
  (show siguiente (anterior domingo)   = domingo,   from rfl)

-- 2ª demostración
example (d: dia) :
  siguiente (anterior d) = d :=
dia.cases_on d rfl rfl rfl rfl rfl rfl rfl

-- 3ª demostración
example (d: dia) :
  siguiente (anterior d) = d :=
begin
 apply dia.cases_on d,
 refl,
 refl,
 refl,
 refl,
 refl,
 refl,
 refl,
end

-- 4ª demostración
example (d: dia) :
  siguiente (anterior d) = d :=
by apply dia.cases_on d; refl

-- 5ª demostración
example (d: dia) :
  siguiente (anterior d) = d :=
by apply dia.rec_on d; refl

-- 6ª demostración
attribute [simp] siguiente anterior

example (d: dia) :
  siguiente (anterior d) = d :=
by cases d; simp

end dia


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

import .basic
import .homomorphism
import .identity

namespace universal
variables {τ : Type} {σ : Type*} (sig : signature τ σ)

namespace algebra

section pi
variables {sig} {ι : Type*} (alg : ι → algebra sig)

definition pi : algebra sig :=
{ sort := λ t, Π j, (alg j).sort t
, func := λ f xs j, (alg j).func f (λ i, xs i j)
}

@[simp] theorem pi_func (f) (xs) (j) : (pi alg).func f xs j = (alg j).func f (λ i, xs i j) := rfl

definition pi_proj (j) : homomorphism (pi alg) (alg j) :=
{ map := λ _ x, x j
, func := λ _ _, rfl
}

theorem pi_eval {dom} : ∀ {cod} (t : term sig dom cod) (xs) (j),
(pi alg).eval t xs j = (alg j).eval t (λ i, xs i j)
| _ (term.proj _) _ _ := rfl
| _ (term.func f ts) xs j :=
  have (λ i, (pi alg).eval (ts i) xs j) = (λ i, (alg j).eval (ts i) (λ i, xs i j)),
  from funext $ λ i, pi_eval (ts i) xs j,
  calc _
  = (alg j).func f (λ i, (pi alg).eval (ts i) xs j) : rfl ...
  = (alg j).func f (λ i, (alg j).eval (ts i) (λ i, xs i j)) : by rw this ...
  = (alg j).eval (term.func f ts) (λ i, xs i j) : by reflexivity

theorem pi_satisfies (e : identity sig) : (∀ i, (alg i).satisfies e) → (pi alg).satisfies e :=
begin
intros H val,
funext,
rw pi_eval,
rw pi_eval,
apply H,
end

section universal_property
variables {alg} {alg₀ : algebra sig} (h : Π j, homomorphism alg₀ (alg j))

definition pi_hom : homomorphism alg₀ (pi alg) :=
{ map := λ t x j, (h j).map t x
, func := λ _ _, funext $ λ j, by simp [(h j).func]
}

@[simp] theorem pi_hom_proj (j) : (pi_proj alg j).comp (pi_hom h) = h j := homomorphism.ext $ λ _ _, rfl

theorem pi_univ (h₀ : homomorphism alg₀ (pi alg)) :
(∀ j, (pi_proj alg j).comp h₀ = h j) → h₀ = pi_hom h :=
λ H, homomorphism.ext $ λ t x, funext $ λ j,
begin
transitivity ((pi_proj alg j).comp h₀).map t x,
reflexivity,
rw H,
reflexivity,
end

end universal_property

end pi

section prod
variables {sig} (alg₁ : algebra sig) (alg₂ : algebra sig)

definition prod : algebra sig :=
{ sort := λ t, alg₁.sort t × alg₂.sort t
, func := λ f xs, (alg₁.func f (λ i, (xs i).fst), alg₂.func f (λ i, (xs i).snd))
}

@[simp] theorem prod_func (f) (xs) : (prod alg₁ alg₂).func f xs = (alg₁.func f (λ i, (xs i).fst), alg₂.func f (λ i, (xs i).snd)) := rfl

definition prod_fst : homomorphism (prod alg₁ alg₂) alg₁ :=
{ map := λ _, prod.fst
, func := λ _ _, rfl
}

definition prod_snd : homomorphism (prod alg₁ alg₂) alg₂ :=
{ map := λ _, prod.snd
, func := λ _ _, rfl
}

theorem prod_eval {dom} : ∀ {cod} (t : term sig dom cod) (xs),
(prod alg₁ alg₂).eval t xs = (alg₁.eval t (λ i, (xs i).fst), alg₂.eval t (λ i, (xs i).snd))
| _ (term.proj _) _ := prod.eq rfl rfl
| _ (term.func f ts) xs :=
  have (λ i, (prod alg₁ alg₂).eval (ts i) xs) = (λ i,
    (alg₁.eval (ts i) (λ i, (xs i).fst),
      alg₂.eval (ts i) (λ i, (xs i).snd))),
  from funext $ λ i, prod_eval (ts i) xs,
  calc (prod alg₁ alg₂).eval (term.func f ts) xs
  = (prod alg₁ alg₂).func f (λ i, (prod alg₁ alg₂).eval (ts i) xs) : rfl ...
  = (prod alg₁ alg₂).func f (λ i, (alg₁.eval (ts i) (λ i, (xs i).fst), alg₂.eval (ts i) (λ i, (xs i).snd))) : by rw this ...
  = (alg₁.eval (term.func f ts) (λ i, (xs i).fst), alg₂.eval (term.func f ts) (λ i, (xs i).snd)) : by reflexivity

theorem prod_eval_fst {dom} {cod} (t : term sig dom cod) (xs) :
((prod alg₁ alg₂).eval t xs).fst = alg₁.eval t (λ i, (xs i).fst) := by rw prod_eval

theorem prod_eval_snd {dom} {cod} (t : term sig dom cod) (xs) :
((prod alg₁ alg₂).eval t xs).snd = alg₂.eval t (λ i, (xs i).snd) := by rw prod_eval

theorem prod_satisfies (e : identity sig) : alg₁.satisfies e → alg₂.satisfies e → (prod alg₁ alg₂).satisfies e :=
begin
intros H₁ H₂ val,
rw prod_eval,
rw prod_eval,
apply prod.eq,
apply H₁,
apply H₂,
end

section universal_property
variables {alg₁ alg₂} {alg : algebra sig} (h₁ : homomorphism alg alg₁) (h₂ : homomorphism alg alg₂)
include h₁ h₂

definition prod_hom : homomorphism alg (prod alg₁ alg₂) :=
{ map := λ t x, (h₁.map t x, h₂.map t x)
, func := λ f xs, prod.eq (by simp [h₁.func f]) (by simp [h₂.func f])
}

@[simp] theorem prod_hom_fst : (prod_fst alg₁ alg₂).comp (prod_hom h₁ h₂) = h₁ := homomorphism.ext $ λ _ _, rfl

@[simp] theorem prod_hom_snd : (prod_snd alg₁ alg₂).comp (prod_hom h₁ h₂) = h₂ := homomorphism.ext $ λ _ _, rfl

theorem prod_univ (h : homomorphism alg (prod alg₁ alg₂)) :
(prod_fst alg₁ alg₂).comp h = h₁ → (prod_snd alg₁ alg₂).comp h = h₂ → h = prod_hom h₁ h₂ :=
λ H₁ H₂, homomorphism.ext $ λ t x, prod.eq
(begin
transitivity ((prod_fst alg₁ alg₂).comp h).map t x,
reflexivity,
rw H₁,
reflexivity,
end)
(begin
transitivity ((prod_snd alg₁ alg₂).comp h).map t x,
reflexivity,
rw H₂,
reflexivity,
end)

end universal_property

end prod

end algebra

end universal