/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.stream.defs
import tactic.ext
import logic.function.basic

/-!
# Streams a.k.a. infinite lists a.k.a. infinite sequences

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

This file used to be in the core library. It was moved to `mathlib` and renamed to `init` to avoid
name clashes.  -/

open nat function option

universes u v w

namespace stream
variables {α : Type u} {β : Type v} {δ : Type w}

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

protected theorem eta (s : stream α) : head s :: tail s = s :=
funext (λ i, begin cases i; refl end)

@[simp] theorem nth_zero_cons (a : α) (s : stream α) : nth (a :: s) 0 = a := rfl

theorem head_cons (a : α) (s : stream α) : head (a :: s) = a := rfl

theorem tail_cons (a : α) (s : stream α) : tail (a :: s) = s := rfl

theorem tail_drop (n : nat) (s : stream α) : tail (drop n s) = drop n (tail s) :=
funext (λ i, begin unfold tail drop, simp [nth, nat.add_comm, nat.add_left_comm] end)

theorem nth_drop (n m : nat) (s : stream α) : nth (drop m s) n = nth s (n + m) := rfl

theorem tail_eq_drop (s : stream α) : tail s = drop 1 s := rfl

theorem drop_drop (n m : nat) (s : stream α) : drop n (drop m s) = drop (n+m) s :=
funext (λ i, begin unfold drop, rw nat.add_assoc end)

theorem nth_succ (n : nat) (s : stream α) : nth s (succ n) = nth (tail s) n := rfl

@[simp] lemma nth_succ_cons (n : nat) (s : stream α) (x : α) : nth (x :: s) n.succ = nth s n := rfl

theorem drop_succ (n : nat) (s : stream α) : drop (succ n) s = drop n (tail s) := rfl

@[simp] lemma head_drop {α} (a : stream α) (n : ℕ) : (a.drop n).head = a.nth n :=
by simp only [drop, head, nat.zero_add, stream.nth]

@[ext] protected theorem ext {s₁ s₂ : stream α} : (∀ n, nth s₁ n = nth s₂ n) → s₁ = s₂ :=
assume h, funext h

lemma cons_injective2 : function.injective2 (cons : α → stream α → stream α) :=
λ x y s t h, ⟨by rw [←nth_zero_cons x s, h, nth_zero_cons],
  stream.ext (λ n, by rw [←nth_succ_cons n _ x, h, nth_succ_cons])⟩

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

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

theorem all_def (p : α → Prop) (s : stream α) : all p s = ∀ n, p (nth s n) := rfl

theorem any_def (p : α → Prop) (s : stream α) : any p s = ∃ n, p (nth s n) := rfl

theorem mem_cons (a : α) (s : stream α) : a ∈ (a::s) :=
exists.intro 0 rfl

theorem mem_cons_of_mem {a : α} {s : stream α} (b : α) : a ∈ s → a ∈ b :: s :=
assume ⟨n, h⟩,
exists.intro (succ n) (by rw [nth_succ, tail_cons, h])

theorem eq_or_mem_of_mem_cons {a b : α} {s : stream α} : a ∈ b::s → a = b ∨ a ∈ s :=
assume ⟨n, h⟩,
begin
  cases n with n',
  { left, exact h },
  { right, rw [nth_succ, tail_cons] at h, exact ⟨n', h⟩ }
end

theorem mem_of_nth_eq {n : nat} {s : stream α} {a : α} : a = nth s n → a ∈ s :=
assume h, exists.intro n h

section map
variable (f : α → β)

theorem drop_map (n : nat) (s : stream α) : drop n (map f s) = map f (drop n s) :=
stream.ext (λ i, rfl)

theorem nth_map (n : nat) (s : stream α) : nth (map f s) n = f (nth s n) := rfl

theorem tail_map (s : stream α) : tail (map f s) = map f (tail s) :=
begin rw tail_eq_drop, refl end

theorem head_map (s : stream α) : head (map f s) = f (head s) := rfl

theorem map_eq (s : stream α) : map f s = f (head s) :: map f (tail s) :=
by rw [← stream.eta (map f s), tail_map, head_map]

theorem map_cons (a : α) (s : stream α) : map f (a :: s) = f a :: map f s :=
begin rw [← stream.eta (map f (a :: s)), map_eq], refl end

theorem map_id (s : stream α) : map id s = s := rfl

theorem map_map (g : β → δ) (f : α → β) (s : stream α) : map g (map f s) = map (g ∘ f) s := rfl

theorem map_tail (s : stream α) : map f (tail s) = tail (map f s) := rfl

theorem mem_map {a : α} {s : stream α} : a ∈ s → f a ∈ map f s :=
assume ⟨n, h⟩,
exists.intro n (by rw [nth_map, h])

theorem exists_of_mem_map {f} {b : β} {s : stream α} : b ∈ map f s → ∃ a, a ∈ s ∧ f a = b :=
assume ⟨n, h⟩, ⟨nth s n, ⟨n, rfl⟩, h.symm⟩
end map

section zip
variable (f : α → β → δ)

theorem drop_zip (n : nat) (s₁ : stream α) (s₂ : stream β) :
  drop n (zip f s₁ s₂) = zip f (drop n s₁) (drop n s₂) :=
stream.ext (λ i, rfl)

theorem nth_zip (n : nat) (s₁ : stream α) (s₂ : stream β) :
  nth (zip f s₁ s₂) n = f (nth s₁ n) (nth s₂ n) := rfl

theorem head_zip (s₁ : stream α) (s₂ : stream β) : head (zip f s₁ s₂) = f (head s₁) (head s₂) := rfl

theorem tail_zip (s₁ : stream α) (s₂ : stream β) :
  tail (zip f s₁ s₂) = zip f (tail s₁) (tail s₂) := rfl

theorem zip_eq (s₁ : stream α) (s₂ : stream β) :
  zip f s₁ s₂ = f (head s₁) (head s₂) :: zip f (tail s₁) (tail s₂) :=
begin rw [← stream.eta (zip f s₁ s₂)], refl end

@[simp] lemma nth_enum (s : stream α) (n : ℕ) : nth (enum s) n = (n, s.nth n) := rfl

lemma enum_eq_zip (s : stream α) : enum s = zip prod.mk nats s := rfl

end zip

theorem mem_const (a : α) : a ∈ const a :=
exists.intro 0 rfl

theorem const_eq (a : α) : const a = a :: const a :=
begin
  apply stream.ext, intro n,
  cases n; refl
end

theorem tail_const (a : α) : tail (const a) = const a :=
suffices tail (a :: const a) = const a, by rwa [← const_eq] at this, rfl

theorem map_const (f : α → β) (a : α) : map f (const a) = const (f a) := rfl

theorem nth_const (n : nat) (a : α) : nth (const a) n = a := rfl

theorem drop_const (n : nat) (a : α) : drop n (const a) = const a :=
stream.ext (λ i, rfl)

theorem head_iterate (f : α → α) (a : α) : head (iterate f a) = a := rfl

theorem tail_iterate (f : α → α) (a : α) : tail (iterate f a) = iterate f (f a) :=
begin
  funext n,
  induction n with n' ih,
  { refl },
  { unfold tail iterate,
    unfold tail iterate at ih,
    rw add_one at ih, dsimp at ih,
    rw add_one, dsimp, rw ih }
end

theorem iterate_eq (f : α → α) (a : α) : iterate f a = a :: iterate f (f a) :=
begin
  rw [← stream.eta (iterate f a)],
  rw tail_iterate, refl
end

theorem nth_zero_iterate (f : α → α) (a : α) : nth (iterate f a) 0 = a := rfl

theorem nth_succ_iterate (n : nat) (f : α → α) (a : α) :
  nth (iterate f a) (succ n) = nth (iterate f (f a)) n :=
by rw [nth_succ, tail_iterate]

section bisim
  variable (R : stream α → stream α → Prop)
  local infix ` ~ `:50 := R

  def is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → head s₁ = head s₂ ∧ tail s₁ ~ tail s₂

  theorem nth_of_bisim (bisim : is_bisimulation R) :
    ∀ {s₁ s₂} n, s₁ ~ s₂ → nth s₁ n = nth s₂ n ∧ drop (n+1) s₁ ~ drop (n+1) s₂
  | s₁ s₂ 0     h := bisim h
  | s₁ s₂ (n+1) h :=
    match bisim h with
    | ⟨h₁, trel⟩ := nth_of_bisim n trel
    end

  -- If two streams are bisimilar, then they are equal
  theorem eq_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂}, s₁ ~ s₂ → s₁ = s₂ :=
  λ s₁ s₂ r, stream.ext (λ n, and.elim_left (nth_of_bisim R bisim n r))
end bisim

theorem bisim_simple (s₁ s₂ : stream α) :
  head s₁ = head s₂ → s₁ = tail s₁ → s₂ = tail s₂ → s₁ = s₂ :=
assume hh ht₁ ht₂, eq_of_bisim
  (λ s₁ s₂, head s₁ = head s₂ ∧ s₁ = tail s₁ ∧ s₂ = tail s₂)
  (λ s₁ s₂ ⟨h₁, h₂, h₃⟩,
    begin
      constructor, exact h₁, rw [← h₂, ← h₃], repeat { constructor }; assumption
    end)
  (and.intro hh (and.intro ht₁ ht₂))

theorem coinduction {s₁ s₂ : stream α} :
  head s₁ = head s₂ → (∀ (β : Type u) (fr : stream α → β), fr s₁ = fr s₂ →
    fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ :=
assume hh ht,
  eq_of_bisim
    (λ s₁ s₂, head s₁ = head s₂ ∧ ∀ (β : Type u) (fr : stream α → β), fr s₁ = fr s₂ →
      fr (tail s₁) = fr (tail s₂))
    (λ s₁ s₂ h,
      have h₁ : head s₁ = head s₂,               from and.elim_left h,
      have h₂ : head (tail s₁) = head (tail s₂), from and.elim_right h α (@head α) h₁,
      have h₃ : ∀ (β : Type u) (fr : stream α → β),
        fr (tail s₁) = fr (tail s₂) → fr (tail (tail s₁)) = fr (tail (tail s₂)),
      from λ β fr, and.elim_right h β (λ s, fr (tail s)),
      and.intro h₁ (and.intro h₂ h₃))
    (and.intro hh ht)

theorem iterate_id (a : α) : iterate id a = const a :=
coinduction
  rfl
  (λ β fr ch, begin rw [tail_iterate, tail_const], exact ch end)

local attribute [reducible] stream
theorem map_iterate (f : α → α) (a : α) : iterate f (f a) = map f (iterate f a) :=
begin
  funext n,
  induction n with n' ih,
  { refl },
  { unfold map iterate nth, dsimp,
    unfold map iterate nth at ih, dsimp at ih,
    rw ih }
end

section corec
theorem corec_def (f : α → β) (g : α → α) (a : α) : corec f g a = map f (iterate g a) := rfl

theorem corec_eq (f : α → β) (g : α → α) (a : α) : corec f g a = f a :: corec f g (g a) :=
begin rw [corec_def, map_eq, head_iterate, tail_iterate], refl end

theorem corec_id_id_eq_const (a : α) : corec id id a = const a :=
by rw [corec_def, map_id, iterate_id]

theorem corec_id_f_eq_iterate (f : α → α) (a : α) : corec id f a = iterate f a := rfl
end corec

section corec'

theorem corec'_eq (f : α → β × α) (a : α) : corec' f a = (f a).1 :: corec' f (f a).2 :=
corec_eq _ _ _

end corec'

theorem unfolds_eq (g : α → β) (f : α → α) (a : α) : unfolds g f a = g a :: unfolds g f (f a) :=
begin unfold unfolds, rw [corec_eq] end

theorem nth_unfolds_head_tail : ∀ (n : nat) (s : stream α), nth (unfolds head tail s) n = nth s n :=
begin
  intro n, induction n with n' ih,
  { intro s, refl },
  { intro s, rw [nth_succ, nth_succ, unfolds_eq, tail_cons, ih] }
end

theorem unfolds_head_eq : ∀ (s : stream α), unfolds head tail s = s :=
λ s, stream.ext (λ n, nth_unfolds_head_tail n s)

theorem interleave_eq (s₁ s₂ : stream α) : s₁ ⋈ s₂ = head s₁ :: head s₂ :: (tail s₁ ⋈ tail s₂) :=
begin
  unfold interleave corec_on, rw corec_eq, dsimp, rw corec_eq, refl
end

theorem tail_interleave (s₁ s₂ : stream α) : tail (s₁ ⋈ s₂) = s₂ ⋈ (tail s₁) :=
begin unfold interleave corec_on, rw corec_eq, refl end

theorem interleave_tail_tail (s₁ s₂ : stream α) : tail s₁ ⋈ tail s₂ = tail (tail (s₁ ⋈ s₂)) :=
begin rw [interleave_eq s₁ s₂], refl end

theorem nth_interleave_left : ∀ (n : nat) (s₁ s₂ : stream α), nth (s₁ ⋈ s₂) (2 * n) = nth s₁ n
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (s₁ ⋈ s₂) (succ (succ (2*n))) = nth s₁ (succ n),
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons, nth_interleave_left],
    refl
  end

theorem nth_interleave_right : ∀ (n : nat) (s₁ s₂ : stream α), nth (s₁ ⋈ s₂) (2*n+1) = nth s₂ n
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (s₁ ⋈ s₂) (succ (succ (2*n+1))) = nth s₂ (succ n),
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons, nth_interleave_right],
    refl
  end

theorem mem_interleave_left {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₁ → a ∈ s₁ ⋈ s₂ :=
assume ⟨n, h⟩,
exists.intro (2*n) (by rw [h, nth_interleave_left])

theorem mem_interleave_right {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₂ → a ∈ s₁ ⋈ s₂ :=
assume ⟨n, h⟩,
exists.intro (2*n+1) (by rw [h, nth_interleave_right])

theorem odd_eq (s : stream α) : odd s = even (tail s) := rfl

theorem head_even (s : stream α) : head (even s) = head s := rfl

theorem tail_even (s : stream α) : tail (even s) = even (tail (tail s)) :=
begin unfold even, rw corec_eq, refl end

theorem even_cons_cons (a₁ a₂ : α) (s : stream α) : even (a₁ :: a₂ :: s) = a₁ :: even s :=
begin unfold even, rw corec_eq, refl end

theorem even_tail (s : stream α) : even (tail s) = odd s := rfl

theorem even_interleave (s₁ s₂ : stream α) : even (s₁ ⋈ s₂) = s₁ :=
eq_of_bisim
  (λ s₁' s₁, ∃ s₂, s₁' = even (s₁ ⋈ s₂))
  (λ s₁' s₁ ⟨s₂, h₁⟩,
    begin
      rw h₁,
      constructor,
       {refl},
       {exact ⟨tail s₂, by rw [interleave_eq, even_cons_cons, tail_cons]⟩}
    end)
  (exists.intro s₂ rfl)

theorem interleave_even_odd (s₁ : stream α) : even s₁ ⋈ odd s₁ = s₁ :=
eq_of_bisim
  (λ s' s, s' = even s ⋈ odd s)
  (λ s' s (h : s' = even s ⋈ odd s),
    begin
      rw h, constructor,
       {refl},
       {simp [odd_eq, odd_eq, tail_interleave, tail_even]}
    end)
  rfl

theorem nth_even : ∀ (n : nat) (s : stream α), nth (even s) n = nth s (2*n)
| 0        s := rfl
| (succ n) s :=
  begin
    change nth (even s) (succ n) = nth s (succ (succ (2 * n))),
    rw [nth_succ, nth_succ, tail_even, nth_even], refl
  end

theorem nth_odd : ∀ (n : nat) (s : stream α), nth (odd s) n = nth s (2 * n + 1) :=
λ n s, begin rw [odd_eq, nth_even], refl end

theorem mem_of_mem_even (a : α) (s : stream α) : a ∈ even s → a ∈ s :=
assume ⟨n, h⟩,
exists.intro (2*n) (by rw [h, nth_even])

theorem mem_of_mem_odd (a : α) (s : stream α) : a ∈ odd s → a ∈ s :=
assume ⟨n, h⟩,
exists.intro (2*n+1) (by rw [h, nth_odd])

theorem nil_append_stream (s : stream α) : append_stream [] s = s := rfl

theorem cons_append_stream (a : α) (l : list α) (s : stream α) :
  append_stream (a::l) s = a :: append_stream l s := rfl

theorem append_append_stream :
  ∀ (l₁ l₂ : list α) (s : stream α), (l₁ ++ l₂) ++ₛ s = l₁ ++ₛ (l₂ ++ₛ s)
| []               l₂ s := rfl
| (list.cons a l₁) l₂ s := by rw [list.cons_append, cons_append_stream, cons_append_stream,
                                  append_append_stream]

theorem map_append_stream (f : α → β) :
  ∀ (l : list α) (s : stream α), map f (l ++ₛ s) = list.map f l ++ₛ map f s
| []              s := rfl
| (list.cons a l) s := by rw [cons_append_stream, list.map_cons, map_cons, cons_append_stream,
                              map_append_stream]

theorem drop_append_stream : ∀ (l : list α) (s : stream α), drop l.length (l ++ₛ s) = s
| []              s := by refl
| (list.cons a l) s := by rw [list.length_cons, add_one, drop_succ, cons_append_stream, tail_cons,
                              drop_append_stream]

theorem append_stream_head_tail (s : stream α) : [head s] ++ₛ tail s = s :=
by rw [cons_append_stream, nil_append_stream, stream.eta]

theorem mem_append_stream_right : ∀ {a : α} (l : list α) {s : stream α}, a ∈ s → a ∈ l ++ₛ s
| a []              s h := h
| a (list.cons b l) s h :=
  have ih : a ∈ l ++ₛ s, from mem_append_stream_right l h,
  mem_cons_of_mem _ ih

theorem mem_append_stream_left : ∀ {a : α} {l : list α} (s : stream α), a ∈ l → a ∈ l ++ₛ s
| a []     s h := absurd h (list.not_mem_nil _)
| a (list.cons b l) s h :=
  or.elim (list.eq_or_mem_of_mem_cons h)
    (λ (aeqb : a = b), exists.intro 0 aeqb)
    (λ (ainl : a ∈ l), mem_cons_of_mem b (mem_append_stream_left s ainl))

@[simp] theorem take_zero (s : stream α) : take 0 s = [] := rfl

@[simp] theorem take_succ (n : nat) (s : stream α) :
  take (succ n) s = head s :: take n (tail s) := rfl

@[simp] theorem length_take (n : ℕ) (s : stream α) : (take n s).length = n :=
by induction n generalizing s; simp *

theorem nth_take_succ : ∀ (n : nat) (s : stream α), list.nth (take (succ n) s) n = some (nth s n)
| 0     s := rfl
| (n+1) s := begin rw [take_succ, add_one, list.nth, nth_take_succ], refl end

theorem append_take_drop :
  ∀ (n : nat) (s : stream α), append_stream (take n s) (drop n s) = s :=
begin
  intro n,
  induction n with n' ih,
  { intro s, refl },
  { intro s, rw [take_succ, drop_succ, cons_append_stream, ih (tail s), stream.eta] }
end

-- Take theorem reduces a proof of equality of infinite streams to an
-- induction over all their finite approximations.
theorem take_theorem (s₁ s₂ : stream α) : (∀ (n : nat), take n s₁ = take n s₂) → s₁ = s₂ :=
begin
  intro h, apply stream.ext, intro n,
  induction n with n ih,
  { have aux := h 1, simp [take] at aux, exact aux },
  { have h₁ : some (nth s₁ (succ n)) = some (nth s₂ (succ n)),
    { rw [← nth_take_succ, ← nth_take_succ, h (succ (succ n))] },
    injection h₁ }
end

protected lemma cycle_g_cons (a : α) (a₁ : α) (l₁ : list α) (a₀ : α) (l₀ : list α) :
              stream.cycle_g (a, a₁::l₁, a₀, l₀) = (a₁, l₁, a₀, l₀) := rfl

theorem cycle_eq : ∀ (l : list α) (h : l ≠ []), cycle l h = l ++ₛ cycle l h
| []              h := absurd rfl h
| (list.cons a l) h :=
  have gen : ∀ l' a', corec stream.cycle_f stream.cycle_g (a', l', a, l) =
    (a' :: l') ++ₛ corec stream.cycle_f stream.cycle_g (a, l, a, l),
    begin
      intro l',
      induction l' with a₁ l₁ ih,
        {intros, rw [corec_eq], refl},
        {intros, rw [corec_eq, stream.cycle_g_cons, ih a₁], refl}
    end,
  gen l a

theorem mem_cycle {a : α} {l : list α} : ∀ (h : l ≠ []), a ∈ l → a ∈ cycle l h :=
assume h ainl, begin rw [cycle_eq], exact mem_append_stream_left _ ainl end

theorem cycle_singleton (a : α) (h : [a] ≠ []) : cycle [a] h = const a :=
coinduction
  rfl
  (λ β fr ch, by rwa [cycle_eq, const_eq])

theorem tails_eq (s : stream α) : tails s = tail s :: tails (tail s) :=
by unfold tails; rw [corec_eq]; refl

theorem nth_tails : ∀ (n : nat) (s : stream α), nth (tails s) n = drop n (tail s) :=
begin
  intro n, induction n with n' ih,
  { intros, refl },
  { intro s, rw [nth_succ, drop_succ, tails_eq, tail_cons, ih] }
end

theorem tails_eq_iterate (s : stream α) : tails s = iterate tail (tail s) := rfl

theorem inits_core_eq (l : list α) (s : stream α) :
  inits_core l s = l :: inits_core (l ++ [head s]) (tail s) :=
begin unfold inits_core corec_on, rw [corec_eq], refl end

theorem tail_inits (s : stream α) :
  tail (inits s) = inits_core [head s, head (tail s)] (tail (tail s)) :=
begin unfold inits, rw inits_core_eq, refl end

theorem inits_tail (s : stream α) :
  inits (tail s) = inits_core [head (tail s)] (tail (tail s)) := rfl

theorem nth_inits : ∀ (n : nat) (s : stream α), nth (inits s) n = take (succ n) s  :=
begin
  intro n, induction n with n' ih,
  { intros, refl },
  { intros, rw [nth_succ, take_succ, ← ih, tail_inits, inits_tail, cons_nth_inits_core] }
end

theorem inits_eq (s : stream α) : inits s = [head s] :: map (list.cons (head s)) (inits (tail s)) :=
begin
  apply stream.ext, intro n,
  cases n,
  { refl },
  { rw [nth_inits, nth_succ, tail_cons, nth_map, nth_inits], refl }
end

theorem zip_inits_tails (s : stream α) : zip append_stream (inits s) (tails s) = const s :=
begin
  apply stream.ext, intro n,
  rw [nth_zip, nth_inits, nth_tails, nth_const, take_succ,
      cons_append_stream, append_take_drop, stream.eta]
end

theorem identity (s : stream α) : pure id ⊛ s = s := rfl
theorem composition (g : stream (β → δ)) (f : stream (α → β)) (s : stream α) :
  pure comp ⊛ g ⊛ f ⊛ s = g ⊛ (f ⊛ s) := rfl
theorem homomorphism (f : α → β) (a : α) : pure f ⊛ pure a = pure (f a) := rfl
theorem interchange (fs : stream (α → β)) (a : α) :
  fs ⊛ pure a = pure (λ f : α → β, f a) ⊛ fs := rfl
theorem map_eq_apply (f : α → β) (s : stream α) : map f s = pure f ⊛ s := rfl

theorem nth_nats (n : nat) : nth nats n = n := rfl

theorem nats_eq : nats = 0 :: map succ nats :=
begin
  apply stream.ext, intro n,
  cases n, refl, rw [nth_succ], refl
end

end stream


-- $ cd divseq2
-- $ code .

import «Divseq2»

open Nat

namespace divseq2
  theorem h₀₃ (m : Nat) : 18 * (2 * m) + 13 = succ (succ (succ (succ ((succ ((succ (m * 3 * 2)) * 2)) * 3)))) := by linarith
  theorem h₀₄ (m : Nat) : 9 * (4 * m + 1) + 16 = succ (succ (succ (succ ((succ ((succ ((succ (m * 3)) * 2)) * 2)) * 3)))) := by linarith
  --theorem h₀₅1 (m : Nat) : 36 * m + 37 = succ (succ (succ (succ ((succ ((succ ((succ (succ (m * 3))) * 2)) * 2)) * 3)))) := by linarith
  axiom   h₀₅ (m : Nat) : (9 * (8 * m + 7) + 11) / 2 = succ (succ (succ (succ ((succ ((succ ((succ (succ (m * 3))) * 2)) * 2)) * 3))))
  axiom   h₀₆ (l : Nat) : (16 * l + 3) + (16 * l + 3 - 3) / 8 + 1 = succ (succ (succ (succ (l * 3 * 2 * 3))))
  axiom   h₀₇ (l : Nat) : 8 * l + 4 + (8 * l + 4 - 4) / 4 * 5 + 6 = succ (succ (succ (succ (((succ (l * 3)) * 2) * 3))))
  axiom   h₀₈ (l : Nat) : 4 * (4 * l + 3) + (4 * l + 3 - 3) / 2 + 4 = succ (succ (succ (succ (((succ (succ (l * 3))) * 2) * 3))))
  theorem h₁₂ (l : Nat) : 9 * (2 * l) + 6 = succ (succ (succ ((succ (l * 3 * 2)) * 3))) := by linarith
  axiom   h₁₃ (l : Nat) : (9 * (4 * l + 1) + 15) / 2 = succ (succ (succ ((succ ((succ (l * 3)) * 2)) * 3)))
  axiom   h₁₄ (l : Nat) : (9 * (8 * l + 7) + 9) / 4 = succ (succ (succ ((succ ((succ (succ (l * 3))) * 2)) * 3)))
  -- 十分条件
  theorem singleToExts (n : Nat) (p : SingleLimited n) : ExtsLimited n := match p with
    | SingleLimited.is02 _ p2 => match p2 with
      | ExtsLimited.is _ _ p3 _ _ _ _ _ _ _ _ _ _ _ => p3
    | SingleLimited.is03 m p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ p3 _ _ _ _ _ _ _ _ => have p4 := Eq.subst (h₀₃ m) p3; p4
    | SingleLimited.is04 m p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ _ _ _ _ p3 _ _ _ => have p4 := Eq.subst (h₀₄ m) p3; p4
    | SingleLimited.is05 m p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ _ _ _ _ _ p3 _ _ => have p4 := Eq.subst (h₀₅ m) p3; p4
    | SingleLimited.is06 l p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ _ p3 _ _ _ _ _ _ => have p4 := Eq.subst (h₀₆ l) p3; p4
    | SingleLimited.is07 l p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ _ _ p3 _ _ _ _ _ => have p4 := Eq.subst (h₀₇ l) p3; p4
    | SingleLimited.is08 l p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ _ _ _ p3 _ _ _ _ => have p4 := Eq.subst (h₀₈ l) p3; p4
    | SingleLimited.is09 _ p2 => match p2 with
      | ExtsLimited.is _ _ _ p3 _ _ _ _ _ _ _ _ _ _ => p3
    | SingleLimited.is11 _ p2 => match p2 with
      | ExtsLimited.is _ _ _ _ p3 _ _ _ _ _ _ _ _ _ => p3
    | SingleLimited.is12 l p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ p3 _ _ _ _ _ _ _ => have p4 := Eq.subst (h₁₂ l) p3; p4
    | SingleLimited.is13 l p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ _ _ _ _ _ _ p3 _ => have p4 := Eq.subst (h₁₃ l) p3; p4
    | SingleLimited.is14 l p2 => match p2 with
      | ExtsLimited.is _ _ _ _ _ _ _ _ _ _ _ _ _ p3 => have p4 := Eq.subst (h₁₄ l) p3; p4

  theorem m₀₂₁ (l : Nat) : l < succ (succ (succ (succ (succ (l * 2 * 2) * 3)))) := by linarith
  theorem m₀₃₁ (m : Nat) : 2 * m < succ (succ (succ (succ (succ (succ (m * 3 * 2) * 2) * 3)))) := by linarith
  theorem m₀₄₁ (m : Nat) : 4 * m + 1 < succ (succ (succ (succ (succ (succ (succ (m * 3) * 2) * 2) * 3)))) := by linarith
  theorem m₀₅₁ (m : Nat) : 8 * m + 7 < succ (succ (succ (succ (succ (succ (succ (succ (m * 3)) * 2) * 2) * 3)))) := by linarith
  theorem m₀₆₁ (l : Nat) : 16 * l + 3 < succ (succ (succ (succ (l * 3 * 2 * 3)))) := by linarith
  theorem m₀₇₁ (l : Nat) : 8 * l + 4 < succ (succ (succ (succ (succ (l * 3) * 2 * 3)))) := by linarith
  theorem m₀₈₁ (l : Nat) : 4 * l + 3 < succ (succ (succ (succ (succ (succ (l * 3)) * 2 * 3)))) := by linarith
  theorem m₀₉₁ (j : Nat) : j < succ (succ (j * 3)) := by linarith
  theorem m₁₁₁ (k : Nat) : k < succ (succ (succ (k * 2 * 3))) := by linarith
  theorem m₁₂₁ (l : Nat) : 2 * l < succ (succ (succ (succ (l * 3 * 2) * 3))) := by linarith
  theorem m₁₃₁ (l : Nat) : 4 * l + 1 < succ (succ (succ (succ (succ (l * 3) * 2) * 3))) := by linarith
  theorem m₁₄₁ (l : Nat) : 8 * l + 7 < succ (succ (succ (succ (succ (succ (l * 3)) * 2) * 3))) := by linarith
  def makeLimitedDivSeq (x : Nat) (rs : ∀ x₁, x₁ < x → SingleLimited x₁) : SingleLimited x := match x with
    | 0             => is10 -- 6*<0>+3 = 3
    | 1             => is01 -- 6*<1>+3 = 9
    | succ (succ x) => by have rs := rs; cases (mod3 x) with
      -- 6 mod 9
      | threeZero j =>
          have sin := rs j (m₀₉₁ j); have ext := singleToExts j sin;
          exact SingleLimited.is09 j ext;
      -- 3 mod 9
      | threeOne j  => cases (parity j) with
        | even k =>
            have sin := rs k (m₁₁₁ k); have ext := singleToExts k sin;
            exact SingleLimited.is11 k ext;
        | odd k  => cases (mod3 k) with
          | threeZero l =>
              have sin := rs (2 * l) (m₁₂₁ l); have ext := singleToExts (2 * l) sin;
              exact SingleLimited.is12 l ext;
          | threeOne l  =>
              have sin := rs (4 * l + 1) (m₁₃₁ l); have ext := singleToExts (4 * l + 1) sin;
              exact SingleLimited.is13 l ext;
          | threeTwo l  =>
              have sin := rs (8 * l + 7) (m₁₄₁ l); have ext := singleToExts (8 * l + 7) sin;
              exact SingleLimited.is14 l ext;
      -- 0 mod 9
      | threeTwo j  => cases (parity j) with
        | even k => cases (mod3 k) with
          | threeZero l =>
              have sin := rs (16 * l + 3) (m₀₆₁ l); have ext := singleToExts (16 * l + 3) sin;
              exact SingleLimited.is06 l ext;
          | threeOne l  =>
              have sin := rs (8 * l + 4) (m₀₇₁ l); have ext := singleToExts (8 * l + 4) sin;
              exact SingleLimited.is07 l ext;
          | threeTwo l  =>
              have sin := rs (4 * l + 3) (m₀₈₁ l); have ext := singleToExts (4 * l + 3) sin;
              exact SingleLimited.is08 l ext;
        | odd k  => cases (parity k) with
          | even l =>
              have sin := rs l (m₀₂₁ l); have ext := singleToExts l sin;
              exact SingleLimited.is02 l ext;
          | odd l  => cases (mod3 l) with
            | threeZero m =>
                have sin := rs (2 * m) (m₀₃₁ m); have ext := singleToExts (2 * m) sin;
                exact SingleLimited.is03 m ext;
            | threeOne m  =>
                have sin := rs (4 * m + 1) (m₀₄₁ m); have ext := singleToExts (4 * m + 1) sin;
                exact SingleLimited.is04 m ext;
            | threeTwo m  =>
                have sin := rs (8 * m + 7) (m₀₅₁ m); have ext := singleToExts (8 * m + 7) sin;
                exact SingleLimited.is05 m ext;
  -- 最終的な定理
  def LimitedDivSeq (n : Nat) : SingleLimited n := WellFounded.fix' (measure id).wf makeLimitedDivSeq n
end divseq2

def main : IO Unit :=
  IO.println s!"Hello,"


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.zsqrtd.basic
import Mathlib.data.complex.basic
import Mathlib.ring_theory.principal_ideal_domain
import Mathlib.number_theory.quadratic_reciprocity
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Gaussian integers

The Gaussian integers are complex integer, complex numbers whose real and imaginary parts are both
integers.

## Main definitions

The Euclidean domain structure on `ℤ[i]` is defined in this file.

The homomorphism `to_complex` into the complex numbers is also defined in this file.

## Main statements

`prime_iff_mod_four_eq_three_of_nat_prime`
A prime natural number is prime in `ℤ[i]` if and only if it is `3` mod `4`

## Notations

This file uses the local notation `ℤ[i]` for `gaussian_int`

## Implementation notes

Gaussian integers are implemented using the more general definition `zsqrtd`, the type of integers
adjoined a square root of `d`, in this case `-1`. The definition is reducible, so that properties
and definitions about `zsqrtd` can easily be used.
-/

def gaussian_int := ℤ√(-1)

namespace gaussian_int

protected instance has_repr : has_repr gaussian_int :=
  has_repr.mk
    fun (x : gaussian_int) =>
      string.str string.empty
                (char.of_nat
                  (bit0
                    (bit0
                      (bit0
                        (bit1
                          (bit0 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit0 (bit0 1)))))))))))))) ++
              repr (zsqrtd.re x) ++
            string.str (string.str string.empty (char.of_nat (bit0 (bit0 (bit1 (bit1 (bit0 1)))))))
              (char.of_nat (bit0 (bit0 (bit0 (bit0 (bit0 1)))))) ++
          repr (zsqrtd.im x) ++
        string.str string.empty
          (char.of_nat
            (bit1
              (bit0
                (bit0 (bit1 (bit0 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit0 (bit0 1))))))))))))))

protected instance comm_ring : comm_ring gaussian_int := zsqrtd.comm_ring

/-- The embedding of the Gaussian integers into the complex numbers, as a ring homomorphism. -/
def to_complex : gaussian_int →+* ℂ := coe_fn zsqrtd.lift { val := complex.I, property := sorry }

protected instance complex.has_coe : has_coe gaussian_int ℂ := has_coe.mk ⇑to_complex

theorem to_complex_def (x : gaussian_int) : ↑x = ↑(zsqrtd.re x) + ↑(zsqrtd.im x) * complex.I := rfl

theorem to_complex_def' (x : ℤ) (y : ℤ) : ↑(zsqrtd.mk x y) = ↑x + ↑y * complex.I := sorry

theorem to_complex_def₂ (x : gaussian_int) : ↑x = complex.mk ↑(zsqrtd.re x) ↑(zsqrtd.im x) := sorry

@[simp] theorem to_real_re (x : gaussian_int) : ↑(zsqrtd.re x) = complex.re ↑x := sorry

@[simp] theorem to_real_im (x : gaussian_int) : ↑(zsqrtd.im x) = complex.im ↑x := sorry

@[simp] theorem to_complex_re (x : ℤ) (y : ℤ) : complex.re ↑(zsqrtd.mk x y) = ↑x := sorry

@[simp] theorem to_complex_im (x : ℤ) (y : ℤ) : complex.im ↑(zsqrtd.mk x y) = ↑y := sorry

@[simp] theorem to_complex_add (x : gaussian_int) (y : gaussian_int) : ↑(x + y) = ↑x + ↑y :=
  ring_hom.map_add to_complex x y

@[simp] theorem to_complex_mul (x : gaussian_int) (y : gaussian_int) : ↑(x * y) = ↑x * ↑y :=
  ring_hom.map_mul to_complex x y

@[simp] theorem to_complex_one : ↑1 = 1 := ring_hom.map_one to_complex

@[simp] theorem to_complex_zero : ↑0 = 0 := ring_hom.map_zero to_complex

@[simp] theorem to_complex_neg (x : gaussian_int) : ↑(-x) = -↑x := ring_hom.map_neg to_complex x

@[simp] theorem to_complex_sub (x : gaussian_int) (y : gaussian_int) : ↑(x - y) = ↑x - ↑y :=
  ring_hom.map_sub to_complex x y

@[simp] theorem to_complex_inj {x : gaussian_int} {y : gaussian_int} : ↑x = ↑y ↔ x = y := sorry

@[simp] theorem to_complex_eq_zero {x : gaussian_int} : ↑x = 0 ↔ x = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑x = 0 ↔ x = 0)) (Eq.symm to_complex_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑x = ↑0 ↔ x = 0)) (propext to_complex_inj)))
      (iff.refl (x = 0)))

@[simp] theorem nat_cast_real_norm (x : gaussian_int) :
    ↑(zsqrtd.norm x) = coe_fn complex.norm_sq ↑x :=
  sorry

@[simp] theorem nat_cast_complex_norm (x : gaussian_int) :
    ↑(zsqrtd.norm x) = ↑(coe_fn complex.norm_sq ↑x) :=
  sorry

theorem norm_nonneg (x : gaussian_int) : 0 ≤ zsqrtd.norm x :=
  zsqrtd.norm_nonneg
    (eq.mpr (id (eq_true_intro (neg_nonpos_of_nonneg (norm_num.nonneg_pos 1 zero_lt_one'))))
      trivial)
    x

@[simp] theorem norm_eq_zero {x : gaussian_int} : zsqrtd.norm x = 0 ↔ x = 0 := sorry

theorem norm_pos {x : gaussian_int} : 0 < zsqrtd.norm x ↔ x ≠ 0 := sorry

@[simp] theorem coe_nat_abs_norm (x : gaussian_int) :
    ↑(int.nat_abs (zsqrtd.norm x)) = zsqrtd.norm x :=
  int.nat_abs_of_nonneg (norm_nonneg x)

@[simp] theorem nat_cast_nat_abs_norm {α : Type u_1} [ring α] (x : gaussian_int) :
    ↑(int.nat_abs (zsqrtd.norm x)) = ↑(zsqrtd.norm x) :=
  sorry

theorem nat_abs_norm_eq (x : gaussian_int) :
    int.nat_abs (zsqrtd.norm x) =
        int.nat_abs (zsqrtd.re x) * int.nat_abs (zsqrtd.re x) +
          int.nat_abs (zsqrtd.im x) * int.nat_abs (zsqrtd.im x) :=
  sorry

protected def div (x : gaussian_int) (y : gaussian_int) : gaussian_int :=
  let n : ℚ := rat.of_int (zsqrtd.norm y)⁻¹;
  let c : ℤ√(-1) := zsqrtd.conj y;
  zsqrtd.mk (round (rat.of_int (zsqrtd.re (x * c)) * n))
    (round (rat.of_int (zsqrtd.im (x * c)) * n))

protected instance has_div : Div gaussian_int := { div := gaussian_int.div }

theorem div_def (x : gaussian_int) (y : gaussian_int) :
    x / y =
        zsqrtd.mk (round (↑(zsqrtd.re (x * zsqrtd.conj y)) / ↑(zsqrtd.norm y)))
          (round (↑(zsqrtd.im (x * zsqrtd.conj y)) / ↑(zsqrtd.norm y))) :=
  sorry

theorem to_complex_div_re (x : gaussian_int) (y : gaussian_int) :
    complex.re ↑(x / y) = ↑(round (complex.re (↑x / ↑y))) :=
  sorry

theorem to_complex_div_im (x : gaussian_int) (y : gaussian_int) :
    complex.im ↑(x / y) = ↑(round (complex.im (↑x / ↑y))) :=
  sorry

theorem norm_sq_le_norm_sq_of_re_le_of_im_le {x : ℂ} {y : ℂ}
    (hre : abs (complex.re x) ≤ abs (complex.re y))
    (him : abs (complex.im x) ≤ abs (complex.im y)) :
    coe_fn complex.norm_sq x ≤ coe_fn complex.norm_sq y :=
  sorry

theorem norm_sq_div_sub_div_lt_one (x : gaussian_int) (y : gaussian_int) :
    coe_fn complex.norm_sq (↑x / ↑y - ↑(x / y)) < 1 :=
  sorry

protected def mod (x : gaussian_int) (y : gaussian_int) : gaussian_int := x - y * (x / y)

protected instance has_mod : Mod gaussian_int := { mod := gaussian_int.mod }

theorem mod_def (x : gaussian_int) (y : gaussian_int) : x % y = x - y * (x / y) := rfl

theorem norm_mod_lt (x : gaussian_int) {y : gaussian_int} (hy : y ≠ 0) :
    zsqrtd.norm (x % y) < zsqrtd.norm y :=
  sorry

theorem nat_abs_norm_mod_lt (x : gaussian_int) {y : gaussian_int} (hy : y ≠ 0) :
    int.nat_abs (zsqrtd.norm (x % y)) < int.nat_abs (zsqrtd.norm y) :=
  sorry

theorem norm_le_norm_mul_left (x : gaussian_int) {y : gaussian_int} (hy : y ≠ 0) :
    int.nat_abs (zsqrtd.norm x) ≤ int.nat_abs (zsqrtd.norm (x * y)) :=
  sorry

protected instance nontrivial : nontrivial gaussian_int :=
  nontrivial.mk (Exists.intro 0 (Exists.intro 1 (of_as_true trivial)))

protected instance euclidean_domain : euclidean_domain gaussian_int :=
  euclidean_domain.mk comm_ring.add comm_ring.add_assoc comm_ring.zero comm_ring.zero_add
    comm_ring.add_zero comm_ring.neg comm_ring.sub comm_ring.add_left_neg comm_ring.add_comm
    comm_ring.mul comm_ring.mul_assoc comm_ring.one comm_ring.one_mul comm_ring.mul_one
    comm_ring.left_distrib comm_ring.right_distrib comm_ring.mul_comm nontrivial.exists_pair_ne
    Div.div sorry Mod.mod sorry (measure (int.nat_abs ∘ zsqrtd.norm)) sorry nat_abs_norm_mod_lt
    sorry

theorem mod_four_eq_three_of_nat_prime_of_prime (p : ℕ) [hp : fact (nat.prime p)] (hpi : prime ↑p) :
    p % bit0 (bit0 1) = bit1 1 :=
  sorry

theorem sum_two_squares_of_nat_prime_of_not_irreducible (p : ℕ) [hp : fact (nat.prime p)]
    (hpi : ¬irreducible ↑p) : ∃ (a : ℕ), ∃ (b : ℕ), a ^ bit0 1 + b ^ bit0 1 = p :=
  sorry

theorem prime_of_nat_prime_of_mod_four_eq_three (p : ℕ) [hp : fact (nat.prime p)]
    (hp3 : p % bit0 (bit0 1) = bit1 1) : prime ↑p :=
  sorry

/-- A prime natural number is prime in `ℤ[i]` if and only if it is `3` mod `4` -/
theorem prime_iff_mod_four_eq_three_of_nat_prime (p : ℕ) [hp : fact (nat.prime p)] :
    prime ↑p ↔ p % bit0 (bit0 1) = bit1 1 :=
  { mp := mod_four_eq_three_of_nat_prime_of_prime p,
    mpr := prime_of_nat_prime_of_mod_four_eq_three p }

end Mathlib


/- 2018-10-12T21:52:34 Locally nameless formulas, built off Floris' preterms
---Jesse

I wanted to avoid the headache over shifts (at the cost of needing to define a well-formedness predicate on terms); my implementation of locally nameless formulas is based off Chargueraud's paper (thanks for the pointer Jeremy!).

TODO:
 - finish writing the coercion for variable lists
 - finish writing the substitution functions
 - add a well-formedness predicate
-/

structure Language :=
(relations : Π n : nat, Type) (functions : Π  n : nat, Type)
section
parameter L : Language

/- preterm n is a partially applied term. if applied to n terms, it becomes a term -/
inductive preterm  : ℕ → Type
| bvar : ℕ → preterm 0
| fvar : string → preterm 0
| func : ∀ {n : nat}, L.functions n → preterm n
| apply : ∀ {n : nat}, preterm (n + 1) → preterm 0 → preterm n

open preterm
def term := preterm 0

-- /- raise_depth_term _ t n m raises variables in t which are at least m by n -/
-- def raise_depth_term : ∀ {l}, preterm l → ℕ → ℕ → preterm l
-- | _ (var L k) n m := if m ≤ k then var (k+m) else var k
-- | _ (func f) n m := func f
-- | _ (apply t1 t2) n m := apply (raise_depth_term t1 n m) (raise_depth_term t2 n m)

-- /- substitute_term t s n substitutes s for (var n) and reduces the level of all variables above n by 1 -/
-- def substitute_term : ∀ {l}, preterm l → term → ℕ → preterm l
-- | _ (var L k) s n := if k < n then var k else if k > n then var (k-1) else s
-- | _ (func f) s n := func f
-- | _ (apply t1 t2) s n := apply (substitute_term t1 s n) (substitute_term t2 s n)

/-- Given a preterm, return a list of free variables which occur in it--/
def free_vars_preterm : Π n : ℕ, preterm n → list string
| _ (bvar L k) := []
| _ (fvar L s) := [s]
| _ (@func L _ f) := []
| _ (@apply L n t1 t2) := (free_vars_preterm (n+1) t1 ∪ free_vars_preterm 0 t2)

def free_vars_term : term → list string := free_vars_preterm 0

lemma free_var_preterm_coercionl (n : ℕ) (t1 : preterm (n+1)) (t2 : term) : {x : string // x ∈ (free_vars_preterm (n+1) t1)} → {x : string // x ∈ (free_vars_preterm n (apply t1 t2))} := sorry

def substitute_preterm : Π n : ℕ, Π (t : preterm n), term → {x : string // x ∈ (free_vars_preterm n t)} → preterm n
| _ (bvar L k) t x := (bvar k)
| _ (fvar L s) t x := sorry
| _ (@func L _ f) t x := (func f)
| _ (@apply L n t1 t2) t x := sorry
end

section

parameter L : Language
/- preformula n is a partially applied formula. if applied to n terms, it becomes a formula -/
inductive preformula : ℕ → Type
| true : preformula 0
| false : preformula 0
| equal : (term L)  → (term L) → preformula 0
| rel : ∀ {n : nat}, L.relations n → preformula n
| apprel : ∀ {n : nat}, preformula (n + 1) → (term L) → preformula n
| imp : preformula 0 → preformula 0 → preformula 0
| all : preformula 0 → preformula 0
open preformula
def formula := preformula 0

def free_vars_preformula : Π n : ℕ, preformula n → list string
| _ (true L) := []
| _ (false L) := []
| _ (equal t1 t2) := free_vars_term L t1 ∪ free_vars_term L t2
| _ (@rel L n R) := []
| _ (@apprel L n ψ t) := free_vars_preformula _ ψ ∪ free_vars_term L t
| _ (imp ϕ ψ) := free_vars_preformula _ ϕ ∪ free_vars_preformula _ ψ
| _ (all ψ) := free_vars_preformula _ ψ

def free_vars_formula : formula → list string := free_vars_preformula 0

-- def raise_depth_formula : ∀ {l}, preformula l → ℕ → ℕ → preformula l
-- | _ (true L) n m := true
-- | _ (false L) n m := false
-- | _ (equal t1 t2) n m := equal (raise_depth_term t1 n m) (raise_depth_term t2 n m)
-- | _ (rel R) n m := rel R
-- | _ (apprel f t) n m := apprel (raise_depth_formula f n m) (raise_depth_term t n m)
-- | _ (imp f1 f2) n m := imp (raise_depth_formula f1 n m) (raise_depth_formula f2 n m)
-- | _ (all f) n m := all (raise_depth_formula f n (m+1))

def substitute_formula : ∀ {l}, preformula l → (term L) → ℕ → preformula l
| _ (true L) s n := true
| _ (false L) s n := false
| _ (equal t1 t2) s n := equal (substitute_term L t1 s n) (substitute_term L t2 s n)
| _ (rel R) s n := rel R
| _ (apprel f t) s n := apprel (substitute_formula f s n) (substitute_term t s n)
| _ (imp f1 f2) s n := imp (substitute_formula f1 s n) (substitute_formula f2 s n)
| _ (all f) s n := all (substitute_formula f s (n+1))

def substitute_preformula : Π n : ℕ, Π (ψ : preformula n), term → {x : string // x ∈ (free_vars_preformula _ ψ)} → preformula n
| _ (true L) t x := true
| _ (false L) t x := false
| _ (equal t1 t2) := equal (substitute_preformula _ _ _ _ t1) (substitute_preformula _ _ _ _ t2)
end


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison
-/
import tactic.reassoc_axiom
import tactic.monotonicity
import category_theory.category.basic

/-!
# Functors

Defines a functor between categories, extending a `prefunctor` between quivers.

Introduces notation `C ⥤ D` for the type of all functors from `C` to `D`.
(Unfortunately the `⇒` arrow (`\functor`) is taken by core,
but in mathlib4 we should switch to this.)
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v v₁ v₂ v₃ u u₁ u₂ u₃

section

set_option old_structure_cmd true

/--
`functor C D` represents a functor between categories `C` and `D`.

To apply a functor `F` to an object use `F.obj X`, and to a morphism use `F.map f`.

The axiom `map_id` expresses preservation of identities, and
`map_comp` expresses functoriality.

See https://stacks.math.columbia.edu/tag/001B.
-/
structure functor (C : Type u₁) [category.{v₁} C] (D : Type u₂) [category.{v₂} D]
  extends prefunctor C D : Type (max v₁ v₂ u₁ u₂) :=
(map_id'   : ∀ (X : C), map (𝟙 X) = 𝟙 (obj X) . obviously)
(map_comp' : ∀ {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z), map (f ≫ g) = (map f) ≫ (map g) . obviously)

/-- The prefunctor between the underlying quivers. -/
add_decl_doc functor.to_prefunctor

end

-- A functor is basically a function, so give ⥤ a similar precedence to → (25).
-- For example, `C × D ⥤ E` should parse as `(C × D) ⥤ E` not `C × (D ⥤ E)`.
infixr ` ⥤ `:26 := functor       -- type as \func --

restate_axiom functor.map_id'
attribute [simp] functor.map_id
restate_axiom functor.map_comp'
attribute [reassoc, simp] functor.map_comp

namespace functor

section
variables (C : Type u₁) [category.{v₁} C]

/-- `𝟭 C` is the identity functor on a category `C`. -/
protected def id : C ⥤ C :=
{ obj := λ X, X,
  map := λ _ _ f, f }

notation `𝟭` := functor.id -- Type this as `\sb1`

instance : inhabited (C ⥤ C) := ⟨functor.id C⟩

variable {C}

@[simp] lemma id_obj (X : C) : (𝟭 C).obj X = X := rfl
@[simp] lemma id_map {X Y : C} (f : X ⟶ Y) : (𝟭 C).map f = f := rfl
end

section
variables {C : Type u₁} [category.{v₁} C]
          {D : Type u₂} [category.{v₂} D]
          {E : Type u₃} [category.{v₃} E]

/--
`F ⋙ G` is the composition of a functor `F` and a functor `G` (`F` first, then `G`).
-/
def comp (F : C ⥤ D) (G : D ⥤ E) : C ⥤ E :=
{ obj := λ X, G.obj (F.obj X),
  map := λ _ _ f, G.map (F.map f) }

infixr ` ⋙ `:80 := comp

@[simp] lemma comp_obj (F : C ⥤ D) (G : D ⥤ E) (X : C) : (F ⋙ G).obj X = G.obj (F.obj X) := rfl
@[simp] lemma comp_map (F : C ⥤ D) (G : D ⥤ E) {X Y : C} (f : X ⟶ Y) :
  (F ⋙ G).map f = G.map (F.map f) := rfl

-- These are not simp lemmas because rewriting along equalities between functors
-- is not necessarily a good idea.
-- Natural isomorphisms are also provided in `whiskering.lean`.
protected lemma comp_id (F : C ⥤ D) : F ⋙ (𝟭 D) = F := by cases F; refl
protected lemma id_comp (F : C ⥤ D) : (𝟭 C) ⋙ F = F := by cases F; refl

@[simp] lemma map_dite (F : C ⥤ D) {X Y : C} {P : Prop} [decidable P]
  (f : P → (X ⟶ Y)) (g : ¬P → (X ⟶ Y)) :
  F.map (if h : P then f h else g h) = if h : P then F.map (f h) else F.map (g h) :=
by { split_ifs; refl, }

end

end functor

end category_theory


import .ops
open subtype nnf tmodel list

section
variables (φ ψ : nnf) (Γ₁ Γ₂ Δ Λ: list nnf) {st : Type}
variables (k : S4 st) (s : st)
open list

theorem sat_subset (h₁ : Γ₁ ⊆ Γ₂) (h₂ : sat k s Γ₂) : sat k s Γ₁ :=
λ x hx, h₂ _ (h₁ hx)

theorem sat_sublist (h₁ : Γ₁ <+ Γ₂) (h₂ :sat k s Γ₂) : sat k s Γ₁ :=
sat_subset _ _ _ _ (sublist.subset h₁) h₂

theorem sat_append (h₁ : sat k s Γ₁) (h₂ : sat k s Γ₂) : sat k s (Γ₁ ++ Γ₂) :=
begin
  intros φ h, rw mem_append at h, cases h,
  apply h₁ _ h, apply h₂ _ h
end

theorem unsat_contra  {Δ n} : var n ∈ Δ →  neg n ∈ Δ →  unsatisfiable Δ:=
begin
  intros h₁ h₂, intros v hsat, intros s hsat,
  have := hsat _ h₁, have := hsat _ h₂, simpa
end

theorem unsat_contra_seqt {Δ : sseqt} {n} : var n ∈ Δ.m →  neg n ∈ Δ.m →  unsatisfiable (Δ.m ++ Δ.b):=
begin
  intros h₁ h₂, intros st m, intros s hsat,
  have := unsat_contra h₁ h₂,
  have := this _ m s,
  apply this,
  apply sat_subset _ _ _ _ _ hsat,
  simp
end

theorem sat_of_and : force k s (and φ ψ) ↔ (force k s φ) ∧ (force k s ψ) :=
by split; {intro, simpa}

theorem sat_of_sat_erase (h₁ : sat k s $ Δ.erase φ) (h₂ : force k s φ) : sat k s Δ :=
begin
  intro ψ, intro h,
  by_cases (ψ = φ),
  {rw h, assumption},
  {have : ψ ∈ Δ.erase φ,
   rw mem_erase_of_ne, assumption, exact h,
   apply h₁, assumption}
end

theorem unsat_and_of_unsat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : unsatisfiable $ φ :: ψ :: Δ.erase (and φ ψ)) :
        unsatisfiable Δ :=
begin
  intro st, intros, intro h,
  apply h₂, swap 3, exact k, swap, exact s,
  intro e, intro he,
  cases he,
  {rw he, have := h _ h₁, rw sat_of_and at this, exact this.1},
  {cases he,
    {rw he, have := h _ h₁, rw sat_of_and at this, exact this.2},
    {have := h _ h₁, apply h, apply mem_of_mem_erase he} }
end

theorem unsat_and_of_unsat_split_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : unsatisfiable $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ)) :
        unsatisfiable (Δ++Γ) :=
begin
  intro st, intros, intro h,
  apply h₂, swap 3, exact k, swap, exact s,
  intro e, intro he,
  cases he,
  {rw he, have := h _ (mem_append_left _ h₁), rw sat_of_and at this, exact this.1},
  {cases he,
    {rw he, have := h _ (mem_append_left _ h₁), rw sat_of_and at this, exact this.2},
    {have := h _ (mem_append_left _ h₁), apply h, apply mem_of_mem_erase, rw erase_append_left, exact he, exact h₁} }
end

theorem sat_and_of_sat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s $ φ :: ψ :: Δ.erase (and φ ψ)) :
        sat k s Δ :=
begin
  intro e, intro he,
  by_cases (e = and φ ψ),
  { rw h, dsimp, split, repeat {apply h₂, simp} },
  { have : e ∈ Δ.erase (and φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply h₂, simp [this] }
end

theorem sat_and_of_sat_split_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ)) :
        sat k s (Δ++Γ) :=
begin
  intro e, intro he,
  by_cases (e = and φ ψ),
  { rw h, dsimp, split, repeat {apply h₂, simp} },
  { have : e ∈ Δ.erase (and φ ψ) ++ Γ,
      { rw ←erase_append_left, rw mem_erase_of_ne, repeat {assumption} },
    apply h₂, simp [this] }
end

theorem sat_split_of_sat_and_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s (Δ++Γ)) :
        sat k s $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ) :=
begin
  intros e he, rw mem_append at he, cases he,
  have : force k s (and φ ψ), {apply h₂, simp [h₁]}, rw sat_of_and at this,
  {cases he,
  {rw he, exact this.left},
  {cases he, rw he, exact this.right, apply h₂, rw mem_append, left, apply mem_of_mem_erase he}
  },
  {apply h₂, rw mem_append, right, exact he}
end

theorem unsat_or_of_unsat_split_seqt {Γ}
        (h : or φ ψ ∈ Δ)
        (h₁ : unsatisfiable $ (φ :: Δ.erase (nnf.or φ ψ)++Γ))
        (h₂ : unsatisfiable $ (ψ :: Δ.erase (nnf.or φ ψ)++Γ)) :
        unsatisfiable $ (Δ++Γ) :=
begin
  intro, intros, intro hsat,
  have := hsat _ (mem_append_left _ h),
  dsimp at this,
  cases this,
  {apply h₁, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat,
apply mem_of_mem_erase, rw erase_append_left, exact he, exact h},
  {apply h₂, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat, apply mem_of_mem_erase, rw erase_append_left, exact he, exact h}
end

theorem sat_or_of_sat_split_left
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ φ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, dsimp, left, apply hl, simp},
  {have : e ∈ Δ.erase (or φ ψ),
     { rw mem_erase_of_ne, repeat { assumption } },
   apply hl, simp [this]}
end

theorem sat_or_of_sat_split_right
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ ψ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, dsimp, right, apply hl, simp},
  { have : e ∈ Δ.erase (or φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply hl, simp [this] }
end

/- S4-specific lemmas -/

theorem force_of_force_box (h : force k s $ box φ) : force k s φ
:= by apply h; apply k.refl

theorem force_box_box_of_force_box : force k s (box φ) → force k s (box (box φ)) :=
by intros h s₁ rs₁ s₂ rs₂; apply h; apply k.trans rs₁ rs₂

theorem unsat_of_unsat_box_new
        (h₁ : box φ ∈ Δ)
        (h₂ : unsatisfiable $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ) :
        unsatisfiable (Δ ++ Λ) :=
begin
  intros st k s h,
  apply h₂, swap 3, exact k, swap, exact s,
  intros e he,
  rw [mem_append] at he,
  cases he,
  {cases he,
    {rw he, apply force_of_force_box, apply h (box φ), simp [h₁]},
    {apply h, rw mem_append, left, apply mem_of_mem_erase he }},
  {cases he,
    {rw ←he at h₁, apply h, rw mem_append, left, exact h₁},
    {apply h, rw mem_append, right, assumption}}
end

theorem sat_copy_of_sat_box_new
        (h₁ : box φ ∈ Δ)
        (h₂ : sat k s $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ) :
        sat k s (Δ ++ Λ) :=
begin
  intros ψ hφ,
  rw mem_append at hφ,
  cases hφ,
  {by_cases heq : ψ = box φ,
    {rw heq, apply h₂ (box φ), simp},
    {have := mem_erase_of_ne heq, rw ←this at hφ, apply h₂, simp, right, left, exact hφ}},
  {apply h₂, simp, repeat {right}, exact hφ}
end

theorem unsat_of_unsat_box_dup
        (h₁ : box φ ∈ Δ)
        (h₃ : unsatisfiable $ (φ :: Δ.erase (box φ)) ++ Λ) :
        unsatisfiable (Δ ++ Λ) :=
begin
  intros st k s h,
  apply h₃, swap 3, exact k, swap, exact s,
  intros e he,
  cases he,
  {rw he, apply force_of_force_box, apply h (box φ), simp [h₁]},
  {have := mem_append.1 he, cases this,
   {apply h, apply mem_append_left, apply mem_of_mem_erase this},
   {apply h, apply mem_append_right, exact this}}
end

end

def unmodal_seqt (Γ : sseqt) : list sseqt :=
@list.pmap _ _ (λ φ, φ ∉ Γ.h ∧ dia φ ∈ Γ.m)
(λ d h,
({s := some {d := d, b := Γ.b},
a := {d := d, b := Γ.b} :: Γ.a,
h := d :: Γ.h,
m := d :: Γ.b,
ndh := begin rw list.nodup_cons, split, exact h.1, exact Γ.ndh end,
sph := begin apply list.cons_subperm_of_mem, apply Γ.ndh, exact h.1, apply mem_closure_dia, apply Γ.sbm, exact h.2,  exact Γ.sph end,
sbm := begin rw list.cons_subset, split, apply mem_closure_dia, apply Γ.sbm, exact h.2, apply list.subperm.subset, exact Γ.spb end,
ha  := begin intros φ h, cases h with l r, rw l, simp, right, apply Γ.ha, exact r end,
ps₁ := begin simp [dsig] end,
ps₂ := begin simp [bsig] end,
.. Γ} : sseqt))
(filter_undia Γ.h Γ.m)
(begin
intros φ hmem,split,
{apply mem_filter_dia_right, exact hmem},
{apply mem_filter_dia_right_aux, exact hmem}
end)

def unmodal_seqt_size (Γ : sseqt) : ∀ (i : sseqt),  i ∈ unmodal_seqt Γ → (prod.measure_lex' sseqt_size i Γ) :=
list.pmapp _ _
begin
intros φ h hmem,
right, left,
apply length_sub_lt_of_nodup_subperm,
{apply Γ.sph},
{apply mem_closure_dia, apply Γ.sbm, exact h.2},
{exact h.1},
{exact Γ.ndh}
end
_

def sat_unmodal_of_sat {Γ : sseqt} : ∀ (i : sseqt),  i ∈ unmodal_seqt Γ →
(∀ {st : Type} (k : S4 st) s,
sat k s (Γ.m ++ Γ.b) → ∃ s', sat k s' (i.m ++ i.b)) :=
list.pmapp _ _
begin
intros φ hninh hmem st k s h,
have hd : force k s (dia φ),
  { apply h, rw mem_append, left, exact hninh.2 },
have hb : ∀ φ ∈ Γ.b, force k s (box φ),
  { intros γ hγ,
    have := box_only_ex Γ.hb hγ, cases this with w hw,
    rw hw, apply force_box_box_of_force_box,
    have := h _ (mem_append_right _ hγ), rw hw at this, exact this},
rcases hd with ⟨w, hrw, hfw⟩,
split, swap, exact w,
intros ψ hψ, simp at hψ, cases hψ,
{rw hψ, exact hfw},
{apply hb, exact hψ, exact hrw}
end
_

def unsat_of_unsat_unmodal {Γ : sseqt} (i : sseqt) : i ∈ unmodal_seqt Γ ∧ unsatisfiable (i.m ++ i.b) → unsatisfiable (Γ.m ++ Γ.b) :=
begin
  intro hex, intros st k s h,
  have := sat_unmodal_of_sat i hex.1 k s h,
  cases this with w hw,
  have := hex.2,
  exact this _ _ _ hw
end

def unmodal_mem_box (Γ : sseqt) : ∀ (i : sseqt),  i ∈ unmodal_seqt Γ → (∀ φ, box φ ∈ Γ.b → box φ ∈ i.m) :=
list.pmapp _ _ begin intros φ h hmem ψ hψ, right, exact hψ end _

def mem_unmodal_seqt (Γ : sseqt) (φ) (h : φ ∉ Γ.h ∧ dia φ ∈ Γ.m) : ∃ (i : sseqt), i ∈ unmodal_seqt Γ ∧ φ ∈ i.m :=
begin
split, swap,
{exact
({s := some {d := φ, b := Γ.b},
a := {d := φ, b := Γ.b} :: Γ.a,
h := φ :: Γ.h,
m := φ :: Γ.b,
ndh := begin rw list.nodup_cons, split, exact h.1, exact Γ.ndh end,
sph := begin apply list.cons_subperm_of_mem, apply Γ.ndh, exact h.1, apply mem_closure_dia, apply Γ.sbm, exact h.2,  exact Γ.sph end,
sbm := begin rw list.cons_subset, split, apply mem_closure_dia, apply Γ.sbm, exact h.2, apply list.subperm.subset, exact Γ.spb end,
ha  := begin intros φ h, cases h with l r, rw l, simp, right, apply Γ.ha, exact r end,
ps₁ := begin intro, simp [dsig] end,
ps₂ := begin intro, simp [bsig] end,
.. Γ} : sseqt)},
{ dsimp [unmodal_seqt], split,
  {let mf := (λ (d : nnf) (h : d ∉ Γ.h ∧ dia d ∈ Γ.m),
      ({s := some {d := d, b := Γ.b},
       a := {d := d, b := Γ.b} :: Γ.a,
       h := d :: Γ.h,
       m := d :: Γ.b,
       ndh := begin rw list.nodup_cons, split, exact h.1, exact Γ.ndh end,
       sph := begin apply list.cons_subperm_of_mem, apply Γ.ndh, exact h.1, apply mem_closure_dia, apply Γ.sbm, exact h.2,  exact Γ.sph end,
       sbm := begin rw list.cons_subset, split, apply mem_closure_dia, apply Γ.sbm, exact h.2, apply list.subperm.subset, exact Γ.spb end,
       ha  := begin intros φ h, cases h with l r, rw l, simp, right, apply Γ.ha, exact r end,
       ps₁ := begin simp [dsig] end,
       ps₂ := begin simp [bsig] end,
       .. Γ} :sseqt)),
  have hmem := mem_filter_undia_left _ _ _ h.2 h.1,
  have hf : ∀ (y : nnf), y ∈ filter_undia (Γ.h) (Γ.m) → y ∉ Γ.h ∧ dia y ∈ Γ.m,
    {intros h hy, split, {apply mem_filter_dia_right, exact hy}, {apply mem_filter_dia_right_aux, exact hy}},
  exact mem_pmap_of_mem mf hmem hf},
{ simp } }
end

theorem unmodal_sig (Γ : sseqt) : ∀ (i : sseqt),  i ∈ unmodal_seqt Γ → (∀ a, a ∈ i.a → some a = i.s ∨ a ∈ Γ.a) :=
list.pmapp _ _
begin
intros φ h hmem a ha, simp at ha,
cases ha,
{left, simp, exact ha},
{right, exact ha}
end
_

theorem unsat_of_closed_and {Γ Δ} (i : and_instance Γ Δ) (h : unsatisfiable Δ) : unsatisfiable Γ :=
by cases i; { apply unsat_and_of_unsat_split, repeat {assumption} }

theorem unsat_of_closed_and_seqt {Γ Δ} (i : and_instance_seqt Γ Δ) (h : unsatisfiable (Δ.m++Δ.b)) : unsatisfiable (Γ.m++Γ.b) :=
by cases i; {apply unsat_and_of_unsat_split_seqt, repeat {assumption} }

theorem unsat_of_closed_or_seqt {Γ₁ Γ₂ Δ : sseqt} (i : or_instance_seqt Δ Γ₁ Γ₂)
(h₁ : unsatisfiable (Γ₁.m++Γ₁.b))
(h₂ : unsatisfiable (Γ₂.m++Γ₂.b)) :
unsatisfiable (Δ.m++Δ.b) :=
by cases i; {apply unsat_or_of_unsat_split_seqt, repeat { assumption }}

theorem unsat_of_closed_box_new {Γ Δ} (i : box_new_instance_seqt Γ Δ) (h : unsatisfiable $ (Δ.m++Δ.b)) : unsatisfiable (Γ.m++Γ.b) :=
by cases i; { apply unsat_of_unsat_box_new, repeat { assumption } }

theorem unsat_of_closed_box_dup {Γ Δ} (i : box_dup_instance_seqt Γ Δ) (h : unsatisfiable $ (Δ.m++Δ.b)) : unsatisfiable (Γ.m++Γ.b) :=
by cases i; { apply unsat_of_unsat_box_dup, repeat { assumption } }


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Markus Himmel, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.wide_pullbacks
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.PostPort

universes v u_1 u u₂

namespace Mathlib

/-!
# Pullbacks

We define a category `walking_cospan` (resp. `walking_span`), which is the index category
for the given data for a pullback (resp. pushout) diagram. Convenience methods `cospan f g`
and `span f g` construct functors from the walking (co)span, hitting the given morphisms.

We define `pullback f g` and `pushout f g` as limits and colimits of such functors.

## References
* [Stacks: Fibre products](https://stacks.math.columbia.edu/tag/001U)
* [Stacks: Pushouts](https://stacks.math.columbia.edu/tag/0025)
-/

namespace category_theory.limits

/--
The type of objects for the diagram indexing a pullback, defined as a special case of
`wide_pullback_shape`.
-/
def walking_cospan := wide_pullback_shape walking_pair

/-- The left point of the walking cospan. -/
/-- The right point of the walking cospan. -/
def walking_cospan.left : walking_cospan := some walking_pair.left

/-- The central point of the walking cospan. -/
def walking_cospan.right : walking_cospan := some walking_pair.right

def walking_cospan.one : walking_cospan := none

/--
The type of objects for the diagram indexing a pushout, defined as a special case of
`wide_pushout_shape`.
-/
def walking_span := wide_pushout_shape walking_pair

/-- The left point of the walking span. -/
/-- The right point of the walking span. -/
def walking_span.left : walking_span := some walking_pair.left

/-- The central point of the walking span. -/
def walking_span.right : walking_span := some walking_pair.right

def walking_span.zero : walking_span := none

namespace walking_cospan

/-- The type of arrows for the diagram indexing a pullback. -/
def hom : walking_cospan → walking_cospan → Type v := wide_pullback_shape.hom

/-- The left arrow of the walking cospan. -/
/-- The right arrow of the walking cospan. -/
def hom.inl : left ⟶ one := wide_pullback_shape.hom.term walking_pair.left

/-- The identity arrows of the walking cospan. -/
def hom.inr : right ⟶ one := wide_pullback_shape.hom.term walking_pair.right

def hom.id (X : walking_cospan) : X ⟶ X := wide_pullback_shape.hom.id X

protected instance category_theory.has_hom.hom.subsingleton (X : walking_cospan)
    (Y : walking_cospan) : subsingleton (X ⟶ Y) :=
  subsingleton.intro
    fun (a b : X ⟶ Y) => eq.mpr (id (propext (eq_iff_true_of_subsingleton a b))) trivial

end walking_cospan

namespace walking_span

/-- The type of arrows for the diagram indexing a pushout. -/
def hom : walking_span → walking_span → Type v := wide_pushout_shape.hom

/-- The left arrow of the walking span. -/
/-- The right arrow of the walking span. -/
def hom.fst : zero ⟶ left := wide_pushout_shape.hom.init walking_pair.left

/-- The identity arrows of the walking span. -/
def hom.snd : zero ⟶ right := wide_pushout_shape.hom.init walking_pair.right

def hom.id (X : walking_span) : X ⟶ X := wide_pushout_shape.hom.id X

protected instance category_theory.has_hom.hom.subsingleton (X : walking_span) (Y : walking_span) :
    subsingleton (X ⟶ Y) :=
  subsingleton.intro
    fun (a b : X ⟶ Y) => eq.mpr (id (propext (eq_iff_true_of_subsingleton a b))) trivial

end walking_span

/-- `cospan f g` is the functor from the walking cospan hitting `f` and `g`. -/
def cospan {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    walking_cospan ⥤ C :=
  wide_pullback_shape.wide_cospan Z (fun (j : walking_pair) => walking_pair.cases_on j X Y)
    fun (j : walking_pair) => walking_pair.cases_on j f g

/-- `span f g` is the functor from the walking span hitting `f` and `g`. -/
def span {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :
    walking_span ⥤ C :=
  wide_pushout_shape.wide_span X (fun (j : walking_pair) => walking_pair.cases_on j Y Z)
    fun (j : walking_pair) => walking_pair.cases_on j f g

@[simp] theorem cospan_left {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z)
    (g : Y ⟶ Z) : functor.obj (cospan f g) walking_cospan.left = X :=
  rfl

@[simp] theorem span_left {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    (g : X ⟶ Z) : functor.obj (span f g) walking_span.left = Y :=
  rfl

@[simp] theorem cospan_right {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z)
    (g : Y ⟶ Z) : functor.obj (cospan f g) walking_cospan.right = Y :=
  rfl

@[simp] theorem span_right {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    (g : X ⟶ Z) : functor.obj (span f g) walking_span.right = Z :=
  rfl

@[simp] theorem cospan_one {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z)
    (g : Y ⟶ Z) : functor.obj (cospan f g) walking_cospan.one = Z :=
  rfl

@[simp] theorem span_zero {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    (g : X ⟶ Z) : functor.obj (span f g) walking_span.zero = X :=
  rfl

@[simp] theorem cospan_map_inl {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z)
    (g : Y ⟶ Z) : functor.map (cospan f g) walking_cospan.hom.inl = f :=
  rfl

@[simp] theorem span_map_fst {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    (g : X ⟶ Z) : functor.map (span f g) walking_span.hom.fst = f :=
  rfl

@[simp] theorem cospan_map_inr {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z)
    (g : Y ⟶ Z) : functor.map (cospan f g) walking_cospan.hom.inr = g :=
  rfl

@[simp] theorem span_map_snd {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    (g : X ⟶ Z) : functor.map (span f g) walking_span.hom.snd = g :=
  rfl

theorem cospan_map_id {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)
    (w : walking_cospan) : functor.map (cospan f g) (walking_cospan.hom.id w) = 𝟙 :=
  rfl

theorem span_map_id {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : X ⟶ Z)
    (w : walking_span) : functor.map (span f g) (walking_span.hom.id w) = 𝟙 :=
  rfl

/-- Every diagram indexing an pullback is naturally isomorphic (actually, equal) to a `cospan` -/
def diagram_iso_cospan {C : Type u} [category C] (F : walking_cospan ⥤ C) :
    F ≅ cospan (functor.map F walking_cospan.hom.inl) (functor.map F walking_cospan.hom.inr) :=
  nat_iso.of_components (fun (j : walking_cospan) => eq_to_iso sorry) sorry

/-- Every diagram indexing a pushout is naturally isomorphic (actually, equal) to a `span` -/
def diagram_iso_span {C : Type u} [category C] (F : walking_span ⥤ C) :
    F ≅ span (functor.map F walking_span.hom.fst) (functor.map F walking_span.hom.snd) :=
  nat_iso.of_components (fun (j : walking_span) => eq_to_iso sorry) sorry

/-- A pullback cone is just a cone on the cospan formed by two morphisms `f : X ⟶ Z` and
    `g : Y ⟶ Z`.-/
def pullback_cone {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :=
  cone (cospan f g)

namespace pullback_cone

/-- The first projection of a pullback cone. -/
def fst {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    (t : pullback_cone f g) : cone.X t ⟶ X :=
  nat_trans.app (cone.π t) walking_cospan.left

/-- The second projection of a pullback cone. -/
def snd {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    (t : pullback_cone f g) : cone.X t ⟶ Y :=
  nat_trans.app (cone.π t) walking_cospan.right

/-- This is a slightly more convenient method to verify that a pullback cone is a limit cone. It
    only asks for a proof of facts that carry any mathematical content -/
def is_limit_aux {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    (t : pullback_cone f g) (lift : (s : cone (cospan f g)) → cone.X s ⟶ cone.X t)
    (fac_left : ∀ (s : pullback_cone f g), lift s ≫ fst t = fst s)
    (fac_right : ∀ (s : pullback_cone f g), lift s ≫ snd t = snd s)
    (uniq :
      ∀ (s : pullback_cone f g) (m : cone.X s ⟶ cone.X t),
        (∀ (j : walking_cospan), m ≫ nat_trans.app (cone.π t) j = nat_trans.app (cone.π s) j) →
          m = lift s) :
    is_limit t :=
  is_limit.mk lift

/-- This is another convenient method to verify that a pullback cone is a limit cone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def is_limit_aux' {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    (t : pullback_cone f g)
    (create :
      (s : pullback_cone f g) →
        Subtype
          fun (l : cone.X s ⟶ cone.X t) =>
            l ≫ fst t = fst s ∧
              l ≫ snd t = snd s ∧
                ∀ {m : cone.X s ⟶ cone.X t}, m ≫ fst t = fst s → m ≫ snd t = snd s → m = l) :
    is_limit t :=
  is_limit_aux t (fun (s : cone (cospan f g)) => subtype.val (create s)) sorry sorry sorry

/-- A pullback cone on `f` and `g` is determined by morphisms `fst : W ⟶ X` and `snd : W ⟶ Y`
    such that `fst ≫ f = snd ≫ g`. -/
@[simp] theorem mk_π_app {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) (j : walking_cospan) :
    nat_trans.app (cone.π (mk fst snd eq)) j =
        option.cases_on j (fst ≫ f) fun (j' : walking_pair) => walking_pair.cases_on j' fst snd :=
  Eq.refl (nat_trans.app (cone.π (mk fst snd eq)) j)

@[simp] theorem mk_π_app_left {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z}
    {g : Y ⟶ Z} {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
    nat_trans.app (cone.π (mk fst snd eq)) walking_cospan.left = fst :=
  rfl

@[simp] theorem mk_π_app_right {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z}
    {g : Y ⟶ Z} {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
    nat_trans.app (cone.π (mk fst snd eq)) walking_cospan.right = snd :=
  rfl

@[simp] theorem mk_π_app_one {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z}
    {g : Y ⟶ Z} {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
    nat_trans.app (cone.π (mk fst snd eq)) walking_cospan.one = fst ≫ f :=
  rfl

@[simp] theorem mk_fst {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) : fst (mk fst snd eq) = fst :=
  rfl

@[simp] theorem mk_snd {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) : snd (mk fst snd eq) = snd :=
  rfl

theorem condition_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    (t : pullback_cone f g) {X' : C} (f' : Z ⟶ X') : fst t ≫ f ≫ f' = snd t ≫ g ≫ f' :=
  sorry

/-- To check whether a morphism is equalized by the maps of a pullback cone, it suffices to check
  it for `fst t` and `snd t` -/
theorem equalizer_ext {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    (t : pullback_cone f g) {W : C} {k : W ⟶ cone.X t} {l : W ⟶ cone.X t}
    (h₀ : k ≫ fst t = l ≫ fst t) (h₁ : k ≫ snd t = l ≫ snd t) (j : walking_cospan) :
    k ≫ nat_trans.app (cone.π t) j = l ≫ nat_trans.app (cone.π t) j :=
  sorry

theorem is_limit.hom_ext {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    {t : pullback_cone f g} (ht : is_limit t) {W : C} {k : W ⟶ cone.X t} {l : W ⟶ cone.X t}
    (h₀ : k ≫ fst t = l ≫ fst t) (h₁ : k ≫ snd t = l ≫ snd t) : k = l :=
  is_limit.hom_ext ht (equalizer_ext t h₀ h₁)

/-- If `t` is a limit pullback cone over `f` and `g` and `h : W ⟶ X` and `k : W ⟶ Y` are such that
    `h ≫ f = k ≫ g`, then we have `l : W ⟶ t.X` satisfying `l ≫ fst t = h` and `l ≫ snd t = k`.
    -/
def is_limit.lift' {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    {t : pullback_cone f g} (ht : is_limit t) {W : C} (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) :
    Subtype fun (l : W ⟶ cone.X t) => l ≫ fst t = h ∧ l ≫ snd t = k :=
  { val := is_limit.lift ht (mk h k w), property := sorry }

/--
This is a more convenient formulation to show that a `pullback_cone` constructed using
`pullback_cone.mk` is a limit cone.
-/
def is_limit.mk {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} {W : C}
    {fst : W ⟶ X} {snd : W ⟶ Y} (eq : fst ≫ f = snd ≫ g)
    (lift : (s : pullback_cone f g) → cone.X s ⟶ W)
    (fac_left : ∀ (s : pullback_cone f g), lift s ≫ fst = fst s)
    (fac_right : ∀ (s : pullback_cone f g), lift s ≫ snd = snd s)
    (uniq :
      ∀ (s : pullback_cone f g) (m : cone.X s ⟶ W),
        m ≫ fst = fst s → m ≫ snd = snd s → m = lift s) :
    is_limit (mk fst snd eq) :=
  is_limit_aux (mk fst snd eq) lift fac_left fac_right sorry

/-- The flip of a pullback square is a pullback square. -/
def flip_is_limit {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} {W : C}
    {h : W ⟶ X} {k : W ⟶ Y} {comm : h ≫ f = k ≫ g} (t : is_limit (mk k h flip_is_limit._proof_1)) :
    is_limit (mk h k comm) :=
  is_limit_aux' (mk h k comm)
    fun (s : pullback_cone f g) =>
      { val := subtype.val (is_limit.lift' t (snd s) (fst s) sorry), property := sorry }

/--
The pullback cone `(𝟙 X, 𝟙 X)` for the pair `(f, f)` is a limit if `f` is a mono. The converse is
shown in `mono_of_pullback_is_id`.
-/
def is_limit_mk_id_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    is_limit (mk 𝟙 𝟙 (is_limit_mk_id_id._proof_1 f)) :=
  is_limit.mk sorry (fun (s : pullback_cone f f) => fst s) sorry sorry sorry

/--
`f` is a mono if the pullback cone `(𝟙 X, 𝟙 X)` is a limit for the pair `(f, f)`. The converse is
given in `pullback_cone.is_id_of_mono`.
-/
theorem mono_of_is_limit_mk_id_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    (t : is_limit (mk 𝟙 𝟙 rfl)) : mono f :=
  sorry

end pullback_cone

/-- A pushout cocone is just a cocone on the span formed by two morphisms `f : X ⟶ Y` and
    `g : X ⟶ Z`.-/
def pushout_cocone {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :=
  cocone (span f g)

namespace pushout_cocone

/-- The first inclusion of a pushout cocone. -/
def inl {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    (t : pushout_cocone f g) : Y ⟶ cocone.X t :=
  nat_trans.app (cocone.ι t) walking_span.left

/-- The second inclusion of a pushout cocone. -/
def inr {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    (t : pushout_cocone f g) : Z ⟶ cocone.X t :=
  nat_trans.app (cocone.ι t) walking_span.right

/-- This is a slightly more convenient method to verify that a pushout cocone is a colimit cocone.
    It only asks for a proof of facts that carry any mathematical content -/
def is_colimit_aux {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    (t : pushout_cocone f g) (desc : (s : pushout_cocone f g) → cocone.X t ⟶ cocone.X s)
    (fac_left : ∀ (s : pushout_cocone f g), inl t ≫ desc s = inl s)
    (fac_right : ∀ (s : pushout_cocone f g), inr t ≫ desc s = inr s)
    (uniq :
      ∀ (s : pushout_cocone f g) (m : cocone.X t ⟶ cocone.X s),
        (∀ (j : walking_span), nat_trans.app (cocone.ι t) j ≫ m = nat_trans.app (cocone.ι s) j) →
          m = desc s) :
    is_colimit t :=
  is_colimit.mk desc

/-- This is another convenient method to verify that a pushout cocone is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def is_colimit_aux' {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    (t : pushout_cocone f g)
    (create :
      (s : pushout_cocone f g) →
        Subtype
          fun (l : cocone.X t ⟶ cocone.X s) =>
            inl t ≫ l = inl s ∧
              inr t ≫ l = inr s ∧
                ∀ {m : cocone.X t ⟶ cocone.X s}, inl t ≫ m = inl s → inr t ≫ m = inr s → m = l) :
    is_colimit t :=
  is_colimit_aux t (fun (s : pushout_cocone f g) => subtype.val (create s)) sorry sorry sorry

/-- A pushout cocone on `f` and `g` is determined by morphisms `inl : Y ⟶ W` and `inr : Z ⟶ W` such
    that `f ≫ inl = g ↠ inr`. -/
def mk {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z} {W : C}
    (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) : pushout_cocone f g :=
  cocone.mk W
    (nat_trans.mk
      fun (j : walking_span) =>
        option.cases_on j (f ≫ inl) fun (j' : walking_pair) => walking_pair.cases_on j' inl inr)

@[simp] theorem mk_ι_app_left {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y}
    {g : X ⟶ Z} {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
    nat_trans.app (cocone.ι (mk inl inr eq)) walking_span.left = inl :=
  rfl

@[simp] theorem mk_ι_app_right {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y}
    {g : X ⟶ Z} {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
    nat_trans.app (cocone.ι (mk inl inr eq)) walking_span.right = inr :=
  rfl

@[simp] theorem mk_ι_app_zero {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y}
    {g : X ⟶ Z} {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
    nat_trans.app (cocone.ι (mk inl inr eq)) walking_span.zero = f ≫ inl :=
  rfl

@[simp] theorem mk_inl {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) : inl (mk inl inr eq) = inl :=
  rfl

@[simp] theorem mk_inr {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) : inr (mk inl inr eq) = inr :=
  rfl

theorem condition_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    (t : pushout_cocone f g) {X' : C} (f' : cocone.X t ⟶ X') : f ≫ inl t ≫ f' = g ≫ inr t ≫ f' :=
  sorry

/-- To check whether a morphism is coequalized by the maps of a pushout cocone, it suffices to check
  it for `inl t` and `inr t` -/
theorem coequalizer_ext {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    (t : pushout_cocone f g) {W : C} {k : cocone.X t ⟶ W} {l : cocone.X t ⟶ W}
    (h₀ : inl t ≫ k = inl t ≫ l) (h₁ : inr t ≫ k = inr t ≫ l) (j : walking_span) :
    nat_trans.app (cocone.ι t) j ≫ k = nat_trans.app (cocone.ι t) j ≫ l :=
  sorry

theorem is_colimit.hom_ext {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    {t : pushout_cocone f g} (ht : is_colimit t) {W : C} {k : cocone.X t ⟶ W} {l : cocone.X t ⟶ W}
    (h₀ : inl t ≫ k = inl t ≫ l) (h₁ : inr t ≫ k = inr t ≫ l) : k = l :=
  is_colimit.hom_ext ht (coequalizer_ext t h₀ h₁)

/-- If `t` is a colimit pushout cocone over `f` and `g` and `h : Y ⟶ W` and `k : Z ⟶ W` are
    morphisms satisfying `f ≫ h = g ≫ k`, then we have a factorization `l : t.X ⟶ W` such that
    `inl t ≫ l = h` and `inr t ≫ l = k`. -/
def is_colimit.desc' {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    {t : pushout_cocone f g} (ht : is_colimit t) {W : C} (h : Y ⟶ W) (k : Z ⟶ W)
    (w : f ≫ h = g ≫ k) : Subtype fun (l : cocone.X t ⟶ W) => inl t ≫ l = h ∧ inr t ≫ l = k :=
  { val := is_colimit.desc ht (mk h k w), property := sorry }

/--
This is a more convenient formulation to show that a `pushout_cocone` constructed using
`pushout_cocone.mk` is a colimit cocone.
-/
def is_colimit.mk {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z} {W : C}
    {inl : Y ⟶ W} {inr : Z ⟶ W} (eq : f ≫ inl = g ≫ inr)
    (desc : (s : pushout_cocone f g) → W ⟶ cocone.X s)
    (fac_left : ∀ (s : pushout_cocone f g), inl ≫ desc s = inl s)
    (fac_right : ∀ (s : pushout_cocone f g), inr ≫ desc s = inr s)
    (uniq :
      ∀ (s : pushout_cocone f g) (m : W ⟶ cocone.X s),
        inl ≫ m = inl s → inr ≫ m = inr s → m = desc s) :
    is_colimit (mk inl inr eq) :=
  is_colimit_aux (mk inl inr eq) desc fac_left fac_right sorry

/-- The flip of a pushout square is a pushout square. -/
def flip_is_colimit {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    {W : C} {h : Y ⟶ W} {k : Z ⟶ W} {comm : f ≫ h = g ≫ k}
    (t : is_colimit (mk k h flip_is_colimit._proof_1)) : is_colimit (mk h k comm) :=
  is_colimit_aux' (mk h k comm)
    fun (s : pushout_cocone f g) =>
      { val := subtype.val (is_colimit.desc' t (inr s) (inl s) sorry), property := sorry }

end pushout_cocone

/-- This is a helper construction that can be useful when verifying that a category has all
    pullbacks. Given `F : walking_cospan ⥤ C`, which is really the same as
    `cospan (F.map inl) (F.map inr)`, and a pullback cone on `F.map inl` and `F.map inr`, we
    get a cone on `F`.

    If you're thinking about using this, have a look at `has_pullbacks_of_has_limit_cospan`,
    which you may find to be an easier way of achieving your goal. -/
@[simp] theorem cone.of_pullback_cone_π {C : Type u} [category C] {F : walking_cospan ⥤ C}
    (t :
      pullback_cone (functor.map F walking_cospan.hom.inl) (functor.map F walking_cospan.hom.inr)) :
    cone.π (cone.of_pullback_cone t) = cone.π t ≫ iso.inv (diagram_iso_cospan F) :=
  Eq.refl (cone.π (cone.of_pullback_cone t))

/-- This is a helper construction that can be useful when verifying that a category has all
    pushout. Given `F : walking_span ⥤ C`, which is really the same as
    `span (F.map fst) (F.mal snd)`, and a pushout cocone on `F.map fst` and `F.map snd`,
    we get a cocone on `F`.

    If you're thinking about using this, have a look at `has_pushouts_of_has_colimit_span`, which
    you may find to be an easiery way of achieving your goal.  -/
@[simp] theorem cocone.of_pushout_cocone_X {C : Type u} [category C] {F : walking_span ⥤ C}
    (t : pushout_cocone (functor.map F walking_span.hom.fst) (functor.map F walking_span.hom.snd)) :
    cocone.X (cocone.of_pushout_cocone t) = cocone.X t :=
  Eq.refl (cocone.X (cocone.of_pushout_cocone t))

/-- Given `F : walking_cospan ⥤ C`, which is really the same as `cospan (F.map inl) (F.map inr)`,
    and a cone on `F`, we get a pullback cone on `F.map inl` and `F.map inr`. -/
@[simp] theorem pullback_cone.of_cone_X {C : Type u} [category C] {F : walking_cospan ⥤ C}
    (t : cone F) : cone.X (pullback_cone.of_cone t) = cone.X t :=
  Eq.refl (cone.X (pullback_cone.of_cone t))

/-- Given `F : walking_span ⥤ C`, which is really the same as `span (F.map fst) (F.map snd)`,
    and a cocone on `F`, we get a pushout cocone on `F.map fst` and `F.map snd`. -/
def pushout_cocone.of_cocone {C : Type u} [category C] {F : walking_span ⥤ C} (t : cocone F) :
    pushout_cocone (functor.map F walking_span.hom.fst) (functor.map F walking_span.hom.snd) :=
  cocone.mk (cocone.X t) (iso.inv (diagram_iso_span F) ≫ cocone.ι t)

/--
`has_pullback f g` represents a particular choice of limiting cone
for the pair of morphisms `f : X ⟶ Z` and `g : Y ⟶ Z`.
-/
/--
def has_pullback {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :=
  has_limit (cospan f g)

`has_pushout f g` represents a particular choice of colimiting cocone
for the pair of morphisms `f : X ⟶ Y` and `g : X ⟶ Z`.
-/
def has_pushout {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :=
  has_colimit (span f g)

/-- `pullback f g` computes the pullback of a pair of morphisms with the same target. -/
def pullback {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)
    [has_pullback f g] : C :=
  limit (cospan f g)

/-- `pushout f g` computes the pushout of a pair of morphisms with the same source. -/
def pushout {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : X ⟶ Z)
    [has_pushout f g] : C :=
  colimit (span f g)

/-- The first projection of the pullback of `f` and `g`. -/
def pullback.fst {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    [has_pullback f g] : pullback f g ⟶ X :=
  limit.π (cospan f g) walking_cospan.left

/-- The second projection of the pullback of `f` and `g`. -/
def pullback.snd {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    [has_pullback f g] : pullback f g ⟶ Y :=
  limit.π (cospan f g) walking_cospan.right

/-- The first inclusion into the pushout of `f` and `g`. -/
def pushout.inl {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    [has_pushout f g] : Y ⟶ pushout f g :=
  colimit.ι (span f g) walking_span.left

/-- The second inclusion into the pushout of `f` and `g`. -/
def pushout.inr {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    [has_pushout f g] : Z ⟶ pushout f g :=
  colimit.ι (span f g) walking_span.right

/-- A pair of morphisms `h : W ⟶ X` and `k : W ⟶ Y` satisfying `h ≫ f = k ≫ g` induces a morphism
    `pullback.lift : W ⟶ pullback f g`. -/
def pullback.lift {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    [has_pullback f g] (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) : W ⟶ pullback f g :=
  limit.lift (cospan f g) (pullback_cone.mk h k w)

/-- A pair of morphisms `h : Y ⟶ W` and `k : Z ⟶ W` satisfying `f ≫ h = g ≫ k` induces a morphism
    `pushout.desc : pushout f g ⟶ W`. -/
def pushout.desc {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    [has_pushout f g] (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) : pushout f g ⟶ W :=
  colimit.desc (span f g) (pushout_cocone.mk h k w)

@[simp] theorem pullback.lift_fst_assoc {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C}
    {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g] (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) {X' : C}
    (f' : X ⟶ X') : pullback.lift h k w ≫ pullback.fst ≫ f' = h ≫ f' :=
  sorry

@[simp] theorem pullback.lift_snd_assoc {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C}
    {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g] (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) {X' : C}
    (f' : Y ⟶ X') : pullback.lift h k w ≫ pullback.snd ≫ f' = k ≫ f' :=
  sorry

@[simp] theorem pushout.inl_desc_assoc {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C}
    {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g] (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) {X' : C}
    (f' : W ⟶ X') : pushout.inl ≫ pushout.desc h k w ≫ f' = h ≫ f' :=
  sorry

@[simp] theorem pushout.inr_desc_assoc {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C}
    {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g] (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) {X' : C}
    (f' : W ⟶ X') : pushout.inr ≫ pushout.desc h k w ≫ f' = k ≫ f' :=
  sorry

/-- A pair of morphisms `h : W ⟶ X` and `k : W ⟶ Y` satisfying `h ≫ f = k ≫ g` induces a morphism
    `l : W ⟶ pullback f g` such that `l ≫ pullback.fst = h` and `l ≫ pullback.snd = k`. -/
def pullback.lift' {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    [has_pullback f g] (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) :
    Subtype fun (l : W ⟶ pullback f g) => l ≫ pullback.fst = h ∧ l ≫ pullback.snd = k :=
  { val := pullback.lift h k w, property := sorry }

/-- A pair of morphisms `h : Y ⟶ W` and `k : Z ⟶ W` satisfying `f ≫ h = g ≫ k` induces a morphism
    `l : pushout f g ⟶ W` such that `pushout.inl ≫ l = h` and `pushout.inr ≫ l = k`. -/
def pullback.desc' {C : Type u} [category C] {W : C} {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    [has_pushout f g] (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) :
    Subtype fun (l : pushout f g ⟶ W) => pushout.inl ≫ l = h ∧ pushout.inr ≫ l = k :=
  { val := pushout.desc h k w, property := sorry }

theorem pullback.condition {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    [has_pullback f g] : pullback.fst ≫ f = pullback.snd ≫ g :=
  pullback_cone.condition (limit.cone (cospan f g))

theorem pushout.condition_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y}
    {g : X ⟶ Z} [has_pushout f g] {X' : C} (f' : pushout f g ⟶ X') :
    f ≫ pushout.inl ≫ f' = g ≫ pushout.inr ≫ f' :=
  sorry

/-- Two morphisms into a pullback are equal if their compositions with the pullback morphisms are
    equal -/
theorem pullback.hom_ext {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
    [has_pullback f g] {W : C} {k : W ⟶ pullback f g} {l : W ⟶ pullback f g}
    (h₀ : k ≫ pullback.fst = l ≫ pullback.fst) (h₁ : k ≫ pullback.snd = l ≫ pullback.snd) : k = l :=
  limit.hom_ext (pullback_cone.equalizer_ext (limit.cone (cospan f g)) h₀ h₁)

/-- The pullback cone built from the pullback projections is a pullback. -/
def pullback_is_pullback {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)
    [has_pullback f g] : is_limit (pullback_cone.mk pullback.fst pullback.snd pullback.condition) :=
  pullback_cone.is_limit.mk pullback.condition
    (fun (s : pullback_cone f g) =>
      pullback.lift (pullback_cone.fst s) (pullback_cone.snd s) (pullback_cone.condition s))
    sorry sorry sorry

/-- The pullback of a monomorphism is a monomorphism -/
protected instance pullback.fst_of_mono {C : Type u} [category C] {X : C} {Y : C} {Z : C}
    {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g] [mono g] : mono pullback.fst :=
  sorry

/-- The pullback of a monomorphism is a monomorphism -/
protected instance pullback.snd_of_mono {C : Type u} [category C] {X : C} {Y : C} {Z : C}
    {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g] [mono f] : mono pullback.snd :=
  sorry

/-- Two morphisms out of a pushout are equal if their compositions with the pushout morphisms are
    equal -/
theorem pushout.hom_ext {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
    [has_pushout f g] {W : C} {k : pushout f g ⟶ W} {l : pushout f g ⟶ W}
    (h₀ : pushout.inl ≫ k = pushout.inl ≫ l) (h₁ : pushout.inr ≫ k = pushout.inr ≫ l) : k = l :=
  colimit.hom_ext (pushout_cocone.coequalizer_ext (colimit.cocone (span f g)) h₀ h₁)

/-- The pushout of an epimorphism is an epimorphism -/
protected instance pushout.inl_of_epi {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y}
    {g : X ⟶ Z} [has_pushout f g] [epi g] : epi pushout.inl :=
  epi.mk
    fun (W : C) (u v : pushout f g ⟶ W) (h : pushout.inl ≫ u = pushout.inl ≫ v) =>
      pushout.hom_ext h
        (iff.mp (cancel_epi g)
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : X ⟶ W) (e_1 : a = a_1) (ᾰ ᾰ_1 : X ⟶ W) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (g ≫ pushout.inr ≫ u) (f ≫ pushout.inl ≫ v)
                  (Eq.trans (Eq.symm (pushout.condition_assoc u))
                    ((fun (ᾰ ᾰ_1 : X ⟶ Y) (e_1 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : Y ⟶ W) (e_2 : ᾰ_2 = ᾰ_3) =>
                        congr (congr_arg category_struct.comp e_1) e_2)
                      f f (Eq.refl f) (pushout.inl ≫ u) (pushout.inl ≫ v) h))
                  (g ≫ pushout.inr ≫ v) (f ≫ pushout.inl ≫ v) (Eq.symm (pushout.condition_assoc v)))
                (propext (eq_self_iff_true (f ≫ pushout.inl ≫ v)))))
            trivial))

/-- The pushout of an epimorphism is an epimorphism -/
protected instance pushout.inr_of_epi {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y}
    {g : X ⟶ Z} [has_pushout f g] [epi f] : epi pushout.inr :=
  epi.mk
    fun (W : C) (u v : pushout f g ⟶ W) (h : pushout.inr ≫ u = pushout.inr ≫ v) =>
      pushout.hom_ext
        (iff.mp (cancel_epi f)
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : X ⟶ W) (e_1 : a = a_1) (ᾰ ᾰ_1 : X ⟶ W) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (f ≫ pushout.inl ≫ u) (g ≫ pushout.inr ≫ v)
                  (Eq.trans (pushout.condition_assoc u)
                    ((fun (ᾰ ᾰ_1 : X ⟶ Z) (e_1 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : Z ⟶ W) (e_2 : ᾰ_2 = ᾰ_3) =>
                        congr (congr_arg category_struct.comp e_1) e_2)
                      g g (Eq.refl g) (pushout.inr ≫ u) (pushout.inr ≫ v) h))
                  (f ≫ pushout.inl ≫ v) (g ≫ pushout.inr ≫ v) (pushout.condition_assoc v))
                (propext (eq_self_iff_true (g ≫ pushout.inr ≫ v)))))
            trivial))
        h

/--
The comparison morphism for the pullback of `f,g`.
This is an isomorphism iff `G` preserves the pullback of `f,g`; see
`category_theory/limits/preserves/shapes/pullbacks.lean`
-/
def pullback_comparison {C : Type u} [category C] {X : C} {Y : C} {Z : C} {D : Type u₂} [category D]
    (G : C ⥤ D) (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g]
    [has_pullback (functor.map G f) (functor.map G g)] :
    functor.obj G (pullback f g) ⟶ pullback (functor.map G f) (functor.map G g) :=
  pullback.lift (functor.map G pullback.fst) (functor.map G pullback.snd) sorry

@[simp] theorem pullback_comparison_comp_fst_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C}
    {D : Type u₂} [category D] (G : C ⥤ D) (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g]
    [has_pullback (functor.map G f) (functor.map G g)] {X' : D} (f' : functor.obj G X ⟶ X') :
    pullback_comparison G f g ≫ pullback.fst ≫ f' = functor.map G pullback.fst ≫ f' :=
  sorry

@[simp] theorem pullback_comparison_comp_snd_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C}
    {D : Type u₂} [category D] (G : C ⥤ D) (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g]
    [has_pullback (functor.map G f) (functor.map G g)] {X' : D} (f' : functor.obj G Y ⟶ X') :
    pullback_comparison G f g ≫ pullback.snd ≫ f' = functor.map G pullback.snd ≫ f' :=
  sorry

@[simp] theorem map_lift_pullback_comparison_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C}
    {D : Type u₂} [category D] (G : C ⥤ D) (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g]
    [has_pullback (functor.map G f) (functor.map G g)] {W : C} {h : W ⟶ X} {k : W ⟶ Y}
    (w : h ≫ f = k ≫ g) {X' : D} (f' : pullback (functor.map G f) (functor.map G g) ⟶ X') :
    functor.map G (pullback.lift h k w) ≫ pullback_comparison G f g ≫ f' =
        pullback.lift (functor.map G h) (functor.map G k)
            (eq.mpr
              (id
                ((fun (a a_1 : functor.obj G W ⟶ functor.obj G Z) (e_1 : a = a_1)
                    (ᾰ ᾰ_1 : functor.obj G W ⟶ functor.obj G Z) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (functor.map G h ≫ functor.map G f) (functor.map G (k ≫ g))
                  (Eq.trans (Eq.symm (functor.map_comp G h f))
                    ((fun (c : C ⥤ D) {X Y : C} (ᾰ ᾰ_1 : X ⟶ Y) (e_4 : ᾰ = ᾰ_1) =>
                        congr_arg (functor.map c) e_4)
                      G (h ≫ f) (k ≫ g) w))
                  (functor.map G k ≫ functor.map G g) (functor.map G (k ≫ g))
                  (Eq.symm (functor.map_comp G k g))))
              (Eq.refl (functor.map G (k ≫ g)))) ≫
          f' :=
  sorry

/--
`has_pullbacks` represents a choice of pullback for every pair of morphisms

See https://stacks.math.columbia.edu/tag/001W.
-/
def has_pullbacks (C : Type u) [category C] := has_limits_of_shape walking_cospan C

/-- `has_pushouts` represents a choice of pushout for every pair of morphisms -/
def has_pushouts (C : Type u) [category C] := has_colimits_of_shape walking_span C

/-- If `C` has all limits of diagrams `cospan f g`, then it has all pullbacks -/
theorem has_pullbacks_of_has_limit_cospan (C : Type u) [category C]
    [∀ {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}, has_limit (cospan f g)] : has_pullbacks C :=
  has_limits_of_shape.mk
    fun (F : walking_cospan ⥤ C) => has_limit_of_iso (iso.symm (diagram_iso_cospan F))

/-- If `C` has all colimits of diagrams `span f g`, then it has all pushouts -/
theorem has_pushouts_of_has_colimit_span (C : Type u) [category C]
    [∀ {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z}, has_colimit (span f g)] : has_pushouts C :=
  has_colimits_of_shape.mk fun (F : walking_span ⥤ C) => has_colimit_of_iso (diagram_iso_span F)

end Mathlib


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module order.category.BddLat
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Category.BddOrd
import Mathbin.Order.Category.Lat
import Mathbin.Order.Category.Semilat

/-!
# The category of bounded lattices

This file defines `BddLat`, the category of bounded lattices.

In literature, this is sometimes called `Lat`, the category of lattices, because being a lattice is
understood to entail having a bottom and a top element.
-/

universe u

open CategoryTheory

/-- The category of bounded lattices with bounded lattice morphisms. -/
structure BddLat where
  toLat : Lat
  [isBoundedOrder : BoundedOrder to_Lat]
#align BddLat BddLat

namespace BddLat

instance : CoeSort BddLat (Type _) :=
  ⟨fun X => X.toLat⟩

instance (X : BddLat) : Lattice X :=
  X.toLat.str

attribute [instance] BddLat.isBoundedOrder

/-- Construct a bundled `BddLat` from `lattice` + `bounded_order`. -/
def of (α : Type _) [Lattice α] [BoundedOrder α] : BddLat :=
  ⟨⟨α⟩⟩
#align BddLat.of BddLat.of

@[simp]
theorem coe_of (α : Type _) [Lattice α] [BoundedOrder α] : ↥(of α) = α :=
  rfl
#align BddLat.coe_of BddLat.coe_of

instance : Inhabited BddLat :=
  ⟨of PUnit⟩

instance : LargeCategory.{u} BddLat
    where
  Hom X Y := BoundedLatticeHom X Y
  id X := BoundedLatticeHom.id X
  comp X Y Z f g := g.comp f
  id_comp' X Y := BoundedLatticeHom.comp_id
  comp_id' X Y := BoundedLatticeHom.id_comp
  assoc' W X Y Z _ _ _ := BoundedLatticeHom.comp_assoc _ _ _

instance : ConcreteCategory BddLat
    where
  forget := ⟨coeSort, fun X Y => coeFn, fun X => rfl, fun X Y Z f g => rfl⟩
  forget_faithful := ⟨fun X Y => by convert FunLike.coe_injective⟩

instance hasForgetToBddOrd : HasForget₂ BddLat BddOrd
    where forget₂ :=
    { obj := fun X => BddOrd.of X
      map := fun X Y => BoundedLatticeHom.toBoundedOrderHom }
#align BddLat.has_forget_to_BddOrd BddLat.hasForgetToBddOrd

instance hasForgetToLat : HasForget₂ BddLat Lat
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y => BoundedLatticeHom.toLatticeHom }
#align BddLat.has_forget_to_Lat BddLat.hasForgetToLat

instance hasForgetToSemilatSup : HasForget₂ BddLat SemilatSup
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y => BoundedLatticeHom.toSupBotHom }
#align BddLat.has_forget_to_SemilatSup BddLat.hasForgetToSemilatSup

instance hasForgetToSemilatInf : HasForget₂ BddLat SemilatInf
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y => BoundedLatticeHom.toInfTopHom }
#align BddLat.has_forget_to_SemilatInf BddLat.hasForgetToSemilatInf

@[simp]
theorem coe_forget_to_bddOrd (X : BddLat) : ↥((forget₂ BddLat BddOrd).obj X) = ↥X :=
  rfl
#align BddLat.coe_forget_to_BddOrd BddLat.coe_forget_to_bddOrd

@[simp]
theorem coe_forget_to_lat (X : BddLat) : ↥((forget₂ BddLat Lat).obj X) = ↥X :=
  rfl
#align BddLat.coe_forget_to_Lat BddLat.coe_forget_to_lat

@[simp]
theorem coe_forget_to_semilatSup (X : BddLat) : ↥((forget₂ BddLat SemilatSup).obj X) = ↥X :=
  rfl
#align BddLat.coe_forget_to_SemilatSup BddLat.coe_forget_to_semilatSup

@[simp]
theorem coe_forget_to_semilatInf (X : BddLat) : ↥((forget₂ BddLat SemilatInf).obj X) = ↥X :=
  rfl
#align BddLat.coe_forget_to_SemilatInf BddLat.coe_forget_to_semilatInf

theorem forget_lat_partOrd_eq_forget_bddOrd_partOrd :
    forget₂ BddLat Lat ⋙ forget₂ Lat PartOrd = forget₂ BddLat BddOrd ⋙ forget₂ BddOrd PartOrd :=
  rfl
#align BddLat.forget_Lat_PartOrd_eq_forget_BddOrd_PartOrd BddLat.forget_lat_partOrd_eq_forget_bddOrd_partOrd

theorem forget_semilatSup_partOrd_eq_forget_bddOrd_partOrd :
    forget₂ BddLat SemilatSup ⋙ forget₂ SemilatSup PartOrd =
      forget₂ BddLat BddOrd ⋙ forget₂ BddOrd PartOrd :=
  rfl
#align BddLat.forget_SemilatSup_PartOrd_eq_forget_BddOrd_PartOrd BddLat.forget_semilatSup_partOrd_eq_forget_bddOrd_partOrd

theorem forget_semilatInf_partOrd_eq_forget_bddOrd_partOrd :
    forget₂ BddLat SemilatInf ⋙ forget₂ SemilatInf PartOrd =
      forget₂ BddLat BddOrd ⋙ forget₂ BddOrd PartOrd :=
  rfl
#align BddLat.forget_SemilatInf_PartOrd_eq_forget_BddOrd_PartOrd BddLat.forget_semilatInf_partOrd_eq_forget_bddOrd_partOrd

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

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

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

end BddLat

theorem bddLat_dual_comp_forget_to_bddOrd :
    BddLat.dual ⋙ forget₂ BddLat BddOrd = forget₂ BddLat BddOrd ⋙ BddOrd.dual :=
  rfl
#align BddLat_dual_comp_forget_to_BddOrd bddLat_dual_comp_forget_to_bddOrd

theorem bddLat_dual_comp_forget_to_lat :
    BddLat.dual ⋙ forget₂ BddLat Lat = forget₂ BddLat Lat ⋙ Lat.dual :=
  rfl
#align BddLat_dual_comp_forget_to_Lat bddLat_dual_comp_forget_to_lat

theorem bddLat_dual_comp_forget_to_semilatSup :
    BddLat.dual ⋙ forget₂ BddLat SemilatSup = forget₂ BddLat SemilatInf ⋙ SemilatInf.dual :=
  rfl
#align BddLat_dual_comp_forget_to_SemilatSup bddLat_dual_comp_forget_to_semilatSup

theorem bddLat_dual_comp_forget_to_semilatInf :
    BddLat.dual ⋙ forget₂ BddLat SemilatInf = forget₂ BddLat SemilatSup ⋙ SemilatSup.dual :=
  rfl
#align BddLat_dual_comp_forget_to_SemilatInf bddLat_dual_comp_forget_to_semilatInf