import tactic data.pfun computability.primrec data.list.basic

open encodable part

universes u v

section

@[simp, reducible] def prod.unpaired {α β γ} (f : α → β → γ) : α × β → γ := λ p, f p.1 p.2

@[simp, reducible] def prod.unpaired3 {α β γ δ} (f : α → β → γ → δ) : α × β × γ → δ := λ p, f p.1 p.2.1 p.2.2

@[simp, reducible] def prod.unpaired4 {α β γ δ ε} (f : α → β → γ → δ → ε) : α × β × γ × δ → ε :=
λ p, f p.1 p.2.1 p.2.2.1 p.2.2.2

@[simp, reducible] def prod.unpaired5 {α β γ δ ε ζ} (f : α → β → γ → δ → ζ → ε) : α × β × γ × δ × ζ → ε :=
λ p, f p.1 p.2.1 p.2.2.1 p.2.2.2.1  p.2.2.2.2

def coe_ropt {α σ} (f : α → σ) : α →. σ := λ x, part.some (f x)

prefix `↑ᵣ`:max := coe_ropt

@[simp] theorem coe_ropt_app {α σ} (f : α → σ) (a : α) : ↑ᵣf a = some (f a) := rfl

@[simp] theorem coe_ropt_dom {α σ} (f : α → σ) : (↑ᵣf).dom = set.univ := rfl

def coe_opt {α σ} (f : α → σ) : α → option σ := λ x, option.some (f x)

prefix `↑ₒ`:max := coe_opt

@[simp] theorem coe_opt_app {α σ} (f : α → σ) (a : α) : ↑ₒf a = some (f a) := rfl

def coe_opt_ropt {α σ} (f : α → option σ) : α →. σ := λ x, part.of_option (f x)

prefix `↑ʳ`:max := coe_opt_ropt

lemma coe_opt_ropt_eq {α σ} (f : α → option σ) : ↑ʳ f = (λ x, ↑(f x)) := rfl

@[simp] theorem coe_opt_ropt_app {α σ} (f : α → option σ) (a : α) : ↑ʳf a = f a := rfl

def coe_ropt_opt {α σ} (f : α →. σ) [D : decidable_pred f.dom] : α → option σ := λ x,
@part.to_option _ (f x) (D x)

prefix `↑ᵒ`:max := coe_ropt_opt

@[simp] theorem coe_ropt_opt_app {α σ} (f : α →. σ) [D : decidable_pred f.dom] (a : α) :
  ↑ᵒf a = @part.to_option _ (f a) (D a) := rfl

end

namespace nat

lemma least_number {p : ℕ → Prop} (ex : ∃ n, p n) : ∃ n, (∀ m, m < n → ¬ p m) ∧ p n :=
by { revert ex, contrapose, simp, intros h, exact nat.strong_rec' h }

lemma least_number' {p : ℕ → Prop} {n} (ex : p n) : ∃ n, (∀ m, m < n → ¬ p m) ∧ p n :=
nat.least_number ⟨n, ex⟩

lemma range_infinity_of_injective {f : ℕ → ℕ} (hf : function.injective f) :
  ∀ n, ∃ m, n < f m := λ n,
begin
  have : set.inj_on f set.univ, { intros x₁ _ x₂ _ eqn, exact hf eqn },
  have : (f '' set.univ).infinite, from (set.infinite_image_iff this).mpr (set.infinite_univ),
  rcases set.infinite.exists_nat_lt this n with ⟨k, ⟨m, _, rfl⟩, lt⟩,
  exact ⟨m, lt⟩
end

end nat

namespace list
variables {α : Type*}

def rnth (l : list α) := l.reverse.nth

def rnth_le (l : list α) (n) (h : n < l.length) : α := l.reverse.nth_le n (by simp; exact h)

def irnth [inhabited α] (l : list α) (n) : α := (l.rnth n).iget

theorem rnth_ext {l₁ l₂ : list α} (h : ∀ n, l₁.rnth n = l₂.rnth n) : l₁ = l₂ :=
list.reverse_inj.mp (list.ext h)

theorem rnth_ext' {l₁ l₂ : list α} (h : ∀ n a, l₁.rnth n = some a ↔ l₂.rnth n = some a) : l₁ = l₂ :=
rnth_ext (λ n, by
  { cases C₁ : l₁.rnth n; cases C₂ : l₂.rnth n,
    { refl },
    { exfalso, simp[(h n _).mpr C₂] at*, exact C₁ },
    { exfalso, simp[(h n _).mp C₁] at*, exact C₂ },
    { simp[(h n _).mp C₁] at*, exact C₂ } })

@[simp]
lemma rnth_nil (n) : (nil : list α).rnth n = none := rfl

@[simp]
lemma rnth_self_length (l : list α) : l.rnth l.length = none :=
by simp[rnth]

@[simp]
lemma rnth_concat_length (n : α) (l : list α) : (n :: l).rnth l.length = some n :=
by { simp[list.rnth],
     have : l.length = l.reverse.length, simp,
     simp only [this, list.nth_concat_length] }

lemma rnth_append {l₀ l₁ : list α} {n : ℕ} (hn : n < l₀.length) :
  (l₁ ++ l₀).rnth n = l₀.rnth n :=
by { simp[list.rnth], exact list.nth_append (by simp; exact hn) }

lemma rnth_cons {l : list α} {n : ℕ} {a} (hn : n < l.length) :
  (a :: l).rnth n = l.rnth n :=
by { simp[list.rnth], exact list.nth_append (by simp; exact hn) }

lemma rnth_le_rnth {l : list α} {n} (h : n < l.length) :
  l.rnth n = some (l.rnth_le n h) :=
by simp[list.rnth, list.rnth_le]; exact nth_le_nth _

lemma irnth_rnth [inhabited α] {l : list α} :
  ∀ {n}, n < l.length → l.rnth n = some (l.irnth n) :=
begin
  induction l with d l IH; simp,
  intros n h, have := eq_or_lt_of_le (nat.lt_succ_iff.mp h),
  cases this; simp[irnth, this],
  simp[rnth_cons this], exact IH this
end

lemma rnth_some_lt {l : list α} {n a} (h : l.rnth n = some a) : n < l.length :=
begin
  simp[list.rnth] at h, rcases list.nth_eq_some.mp h with ⟨h1, _⟩,
  simp at h1, exact h1
end

lemma mem_iff_rnth {a : α} {l : list α} :
a ∈ l ↔ ∃ (n : ℕ), l.rnth n = some a :=
by { have := @mem_iff_nth _ a l.reverse, simp at this, exact this }

lemma rnth_none {l : list α} {n} : l.rnth n = none ↔ l.length ≤ n :=
by simp[list.rnth]

lemma rnth_cons_none {l : list α} {a} {n} : (a :: l).rnth n = none ↔ l.length < n :=
by {simp[list.rnth], exact nat.succ_le_iff }

lemma rnth_cons_some_iff {l : list α} {n : ℕ} {a a' : α} :
  (a :: l).rnth n = a' ↔ (l.rnth n = a' ∧ n < l.length) ∨ (a = a' ∧ n = l.length) :=
begin
  have C : n < l.length ∨ n = l.length ∨ l.length < n, exact trichotomous n (length l),
  cases C,
  { have : ¬n = l.length, { intros h, simp[h] at C, contradiction },
    simp[C, rnth_cons, this] },cases C,
  { rcases C with rfl, unfold_coes, simp },
  { unfold_coes, simp[C, rnth_cons_none.mpr],
    have eqn₁ : ¬ n < l.length, { intros h, exact nat.lt_asymm C h },
    have eqn₂ : ¬ n = l.length, { intros h, simp[h] at C, contradiction },
    simp[eqn₁, eqn₂] }
end

theorem rnth_map {α β} (f : α → β) : ∀ (l : list α) n, (l.map f).rnth n = (l.rnth n).map f :=
by simp [list.rnth, ←list.map_reverse]

lemma rnth_eq_nth_of_lt {l : list α} {n : ℕ} (hn : n < l.length) : l.rnth n = l.nth (l.length - 1 - n) :=
by { simp[list.rnth, rnth_le_rnth hn],
     have eqn :l.length - 1 - n < l.length, { omega },
     have : l.rnth_le n hn = l.nth_le (l.length - 1 - n) eqn,
       from list.nth_le_reverse' l n (by simp[hn]) eqn, simp[this, nth_le_nth eqn] }

lemma rnth_of_rnth_cons {l : list α} {a a' : α} {n} (h : l.rnth n = a') : (a :: l).rnth n = a' :=
by simp[rnth_cons_some_iff]; exact or.inl ⟨h, rnth_some_lt h⟩

theorem nth_find_index {α} {p : α → Prop} [decidable_pred p] {l : list α} :
  ∀ {a}, l.nth (l.find_index p) = some a → p a :=
by { induction l with b l IH; simp[list.find_index],
     by_cases C : p b; simp [C, IH], exact @IH }

theorem nth_find_index_neg {α} {p : α → Prop} [decidable_pred p] {l : list α} :
  ∀ {n} {a}, n < l.find_index p → l.nth n = some a → ¬p a :=
begin
  induction l with b l IH; simp[list.find_index],
  by_cases C : p b; simp [C], intros n a e,
  cases n; simp, { intros e, simp[←e, C] },
  have : n < list.find_index p l, from nat.succ_lt_succ_iff.mp e,
  exact IH this
end

@[simp] def range_r : ℕ → list ℕ
| 0       := []
| (n + 1) := n :: range_r n

lemma range_r_eq_reverse_range (n) : range_r n = (range n).reverse :=
by { induction n with n IH, { simp }, { simp[IH, list.range_succ] } }

@[simp] lemma mem_range_r_iff_mem_reverse_range (n m) : m ∈ range_r n ↔ m ∈ range n :=
by simp[range_r_eq_reverse_range]

theorem nodup_range_r (n : ℕ) : nodup (range_r n) :=
by simp[range_r_eq_reverse_range]; exact nodup_range n

@[simp] lemma length_range_r (n : ℕ) : (list.range_r n).length = n :=
by simp[range_r_eq_reverse_range]

@[simp] lemma range_r_rnth : ∀ {n i} (h : i < n), (range_r n).rnth i = some i
| (n + 1) i h := by { simp,
    have C : i < n ∨ i = n, from lt_or_eq_of_le (nat.lt_succ_iff.mp h),
    cases C,
    { have : (n :: range_r n).rnth i = (range_r n).rnth i, from rnth_cons (by simp[C]),
      simp[this, range_r_rnth C] },
    { simp[C], have := rnth_concat_length n (range_r n), simp at this, exact this } }

def initial {α} (l : list α) (n : ℕ) : list α := l.drop (l.length - n)

infix `↾*`:70 := list.initial

lemma initial_elim {α} {l : list α} {n} (h : l.length ≤ n) : l↾*n = l :=
by { have : l.length - n = 0, omega, simp[list.initial, this] }

@[simp] lemma initial_0 {α} {l : list α} : l↾*0 = [] := by simp[list.initial]

lemma initial_length {α} {l : list α} {n : ℕ} (h : n < l.length) : (l↾*n).length = n :=
by simp [list.initial, h]; omega

@[simp] lemma le_initial_length {α} (l : list α) (n : ℕ) : (l↾*n).length ≤ n :=
by { simp[list.initial], omega }

@[simp] lemma initial_initial {α} (l : list α) (n m : ℕ) :
  (l↾*m)↾*n = l↾*(min m n) :=
begin
  simp[list.initial], congr,
  have C : n ≤ m ∨ m ≤ n, exact le_total n m, cases C; simp[C],
  { have : ∀ k, k - (k - m) - n + (k - m) = k - n,
    { intros k,
      have eqn := le_or_lt m k, cases eqn,
      { omega },
      { have : k - m = 0, from nat.sub_eq_zero_of_le (le_of_lt eqn),
        simp[this] } },
    exact this _ },
  omega
end

@[simp] lemma initial_append {α} (l₁ l₂ : list α) :
  (l₁ ++ l₂)↾*l₂.length = l₂ :=
by simp[list.initial]

lemma initial_rnth_some_iff  {α} {l : list α} {n m : ℕ} {a} :
  (l↾*m).rnth n = some a ↔ l.rnth n = some a ∧ n < m :=
begin
  have eqn : l.length ≤ m ∨ m < l.length, from le_or_lt _ _,
  cases eqn,
  { simp[list.initial_elim eqn], intros h, exact gt_of_ge_of_gt eqn (rnth_some_lt h) },
  split,
  { revert eqn a m n,
    simp [list.initial],
    induction l with d l IH; simp,
    intros n m a eqn_m eqn_a,
     simp[show l.length + 1 - m = l.length - m + 1, by omega] at eqn_a,
    have C := eq_or_lt_of_le (nat.lt_succ_iff.mp eqn_m),
    cases C,
    { simp[←C] at eqn_a, simp[list.rnth_cons (list.rnth_some_lt eqn_a)],
      exact ⟨eqn_a, by simp[C]; exact rnth_some_lt eqn_a⟩ },
    { have : n < l.length, { have := list.rnth_some_lt eqn_a, simp at this, omega},
      simp[list.rnth_cons this], apply IH C eqn_a } },
  { rintros ⟨h, eq⟩,
    have :=list.reverse_take m (le_of_lt eqn),
    simp [list.initial, list.rnth, ←this] at*, simp[list.nth_take eq, h] }
end

lemma initial_rnth_of_lt  {α} {l : list α} {n m : ℕ} (h : n < m) :
  (l↾*m).rnth n = l.rnth n :=
begin
  cases C₂ : l.rnth n,
  { have : ∀ a, ¬((l↾*m).rnth n = some a),
    { intros a, simp[initial_rnth_some_iff], simp[C₂] },
    cases (l↾*m).rnth n with x, { refl }, { exfalso, exact this x rfl } },
  { exact initial_rnth_some_iff.mpr ⟨C₂, h⟩ }
end

lemma initial_rnth_some  {α} {l : list α} {n m : ℕ} {a} :
  (l↾*m).rnth n = some a → l.rnth n = some a :=
begin
  have eqn : l.length ≤ m ∨ m < l.length, from le_or_lt _ _,
  cases eqn,
  { simp[list.initial_elim eqn] },
  revert eqn a m n,
  simp [list.initial],
  induction l with d l IH; simp,
  intros n m a eqn_m eqn_a, simp[show l.length + 1 - m = l.length - m + 1, by omega] at eqn_a,
  have C := eq_or_lt_of_le (nat.lt_succ_iff.mp eqn_m),
  cases C,
  { simp[←C] at eqn_a, simp[list.rnth_cons (list.rnth_some_lt eqn_a)], exact eqn_a },
  { have : n < l.length, { have := list.rnth_some_lt eqn_a, simp at this, omega},
    simp[list.rnth_cons this], apply IH C eqn_a }
end

@[simp] lemma initial_nil {n} : (nil : list α)↾*n = nil := by simp[list.initial]

lemma initial_cons {l : list α} {d n} (h : n ≤ l.length) : (d :: l)↾*n = l↾*n :=
by { simp[list.initial, show l.length + 1 - n = l.length - n + 1, by omega] }

@[simp] lemma initial_cons_self {l : list α} {d} : (d :: l)↾*l.length = l :=
by simp[list.initial]

def get_elem {α} (p : α → Prop) [decidable_pred p] (l : list α) : option α :=
l.nth (l.find_index p)

theorem get_elem_eq_some_iff {α} {p : α → Prop} [decidable_pred p] {l : list α} {x} :
  l.get_elem p = some x ↔ ∃ n, l.nth n = some x ∧ p x ∧ ∀ m z, m < n → l.nth m = some z → ¬p z :=
begin
  simp [list.get_elem],
  induction l with a l IH generalizing x; simp [list.find_index],
  by_cases C : p a; simp [C],
  { split,
    { intros eqn, use 0, simp[←eqn, C] },
    { rintros ⟨n, hyp, px, hyp1⟩,
      cases n; simp at hyp, exact hyp,
      exfalso,
      have := hyp1 0 a, simp at this,
      contradiction } },
  { rw IH, split,
    { rintros ⟨n, eqn_x, px, hyp_n⟩,
      refine ⟨n+1, eqn_x, px, _⟩,
      intros m z eqn_m eqn_z,
      cases m; simp at eqn_z, simp [←eqn_z, C],
      have : m < n, from nat.succ_lt_succ_iff.mp eqn_m,
      exact hyp_n m z this eqn_z },
    { rintros ⟨n, eqn_x, px, hyp_n⟩,
      cases n; simp at eqn_x, simp [eqn_x] at C, contradiction,
      refine ⟨n, eqn_x, px, λ m z eqn_m eqn_z, _⟩,
      have := nat.succ_lt_succ_iff.mpr eqn_m,
      exact hyp_n (m+1) z this (by simp; exact eqn_z) } }
end

theorem get_elem_iff_none {α} {p : α → Prop} [decidable_pred p] {l : list α} :
  l.get_elem p = none ↔ ∀ n x, l.nth n = some x → ¬p x :=
begin
  simp [list.get_elem, list.find_index],
  induction l with a l IH; simp [list.find_index], by_cases C : p a;
  simp[C],
  { refine ⟨0, a, rfl, C⟩ },
  { simp [nat.succ_le_succ_iff, IH], split,
    { intros hyp n, cases n; simp[C], exact hyp n },
    { intros hyp n x eqn_x, exact hyp (n+1) x eqn_x } }
end

def get_elem_r {α} (p : α → Prop) [decidable_pred p] (l : list α) : option α :=
l.reverse.get_elem p

theorem get_elem_r_eq_some_iff {α} {p : α → Prop} [decidable_pred p] {l : list α} {x} :
  l.get_elem_r p = ↑x ↔ ∃ n, l.rnth n = ↑x ∧ p x ∧ ∀ m z, m < n → l.rnth m = ↑z → ¬p z :=
@get_elem_eq_some_iff _ _ _ _ x

theorem get_elem_r_eq_none_iff_rnth {α} {p : α → Prop} [decidable_pred p] {l : list α} :
  l.get_elem_r p = none ↔ ∀ n x, l.rnth n = some x → ¬p x :=
get_elem_iff_none

theorem get_elem_r_eq_none_iff_mem {α} {p : α → Prop} [decidable_pred p] {l : list α} :
  l.get_elem_r p = none ↔ ∀ x, x ∈ l → ¬p x :=
by { simp[list.mem_iff_rnth, get_elem_r_eq_none_iff_rnth], exact forall_swap }

def to_fn {α σ} [decidable_eq α] (c : list (α × σ)) (a : α) : option σ :=
(c.get_elem (λ x : α × σ, x.fst = a)).map prod.snd
-- to_fn c a = ε b. ⟨a, b⟩ ∈ c

def to_set {α} [decidable_eq α] (a : α) (c : list (α × bool)) : bool := c.to_fn a = some tt
-- to_set c a ↔ ⟨a, tt⟩ ∈ c

@[simp] theorem to_fn_iff {α σ} [decidable_eq α] (c : list (α × σ)) {x y} :
  c.to_fn x = some y ↔
  ∃ n, c.nth n = some (x, y) ∧ ∀ m z, m < n → c.nth m ≠ some (x, z) :=
begin
  simp [list.to_fn, list.get_elem_eq_some_iff], split,
  { rintros ⟨a, n, eqn_n, eqn_a, hyp⟩,
    refine ⟨n, (by simp [←eqn_a]; exact eqn_n), λ m z eqn_m eqn_m1, _⟩,
    have := hyp m (x, z) eqn_m eqn_m1, simp at this, contradiction },
  { rintros ⟨n, eqn_n, hyp⟩,
    refine ⟨x, n, eqn_n, rfl, λ m z eqn_m eqn_m1 eqn_x, _⟩,
    have := hyp m z.snd eqn_m, rw ←eqn_x at this, simp at this,
    contradiction }
end

@[simp] theorem to_fn_iff_none {α σ} [decidable_eq α] (c : list (α × σ)) {x} :
  c.to_fn x = none ↔ ∀ n y, c.nth n ≠ some (x, y) :=
begin
  simp [list.to_fn, list.get_elem_iff_none], split,
  { intros hyp n y eqn_xy, have := hyp n (x, y) eqn_xy, simp at this, contradiction },
  { intros hyp n z eqn_z eqn_z1, have := hyp n z.snd, rw ←eqn_z1 at this, simp at this,
    contradiction }
end

@[simp] theorem to_fn_cons {α σ} [decidable_eq α] (x y) (c : list (α × σ)) :
  ((x, y) :: c).to_fn x = some y :=
by simp; refine ⟨0, rfl, λ m z, by simp⟩

@[simp] def of_fn' (f : ℕ → α) : ℕ → list α
| 0     := []
| (n+1) := f n :: of_fn' n

def chr {α} [decidable_eq α] (l : list α) (a : α) : bool := a ∈ l

@[simp] lemma chr_tt_iff {α} [decidable_eq α] (l : list α) (a : α) : l.chr a = tt ↔ a ∈ l := by simp[chr]

@[simp] lemma chr_ff_iff {α} [decidable_eq α] (l : list α) (a : α) : l.chr a = ff ↔ a ∉ l := by simp[chr]

@[simp] lemma chr_app_iff {α} [decidable_eq α] (l : list α) (a : α) : l.chr a ↔ a ∈ l := by simp[chr]

@[simp] lemma append_cons_neq (a : α) (l₁ l₂ : list α) : l₁ ++ a :: l₂ ≠ l₂ := λ h,
begin
  have : (l₁ ++ a :: l₂).length = l₂.length, simp[h],
  simp[nat.add_left_comm l₁.length] at this, exact this
end

@[simp] lemma cons_neq (a : α) (l : list α) : a :: l ≠ l := append_cons_neq a [] l

@[simp] lemma cons_neq' (a : α) (l : list α) : l ≠ a :: l := ne.symm (cons_neq a l)

@[simp] lemma not_suffix_cons (l : list α) (a : α) : ¬ a :: l <:+ l :=
by simp[list.is_suffix, append_cons_neq]

lemma suffix_append_iff_suffix (l l₁ l₂ : list α) : l₁ ++ l <:+ l₂ ++ l ↔ l₁ <:+ l₂ :=
exists_congr $ λ r, by rw [←append_assoc, append_left_inj]

@[simp] lemma suffix_cons_iff_eq (a₁ a₂ : α) (l : list α) : a₁ :: l <:+ a₂ :: l ↔ a₁ = a₂ :=
by { have : a₁ :: l <:+ a₂ :: l ↔ [a₁] <:+ [a₂], from suffix_append_iff_suffix l [a₁] [a₂], rw this,
     split,
     { rintros ⟨⟨hd, tl⟩, h⟩, { simp* at* }, { exfalso, simp at*, exact h } },
     { rintros rfl, refine ⟨[], by simp⟩ } }

lemma suffix_antisymm {l₁ l₂ : list α} (h₁ : l₁ <:+ l₂) (h₂ : l₂ <:+ l₁) : l₁ = l₂ :=
by { rcases h₁ with ⟨l12, h₁⟩, rcases h₂ with ⟨l21, h₂⟩,
     have : (l21 ++ l12) ++ l₁ = [] ++ l₁,
     { rw [←h₁, ←append_assoc] at h₂, simp[h₂] },
     have : l21 ++ l12 = [] := list.append_right_cancel this,
     simp at this,
     simp[this] at h₁, refine h₁ }

def is_initial (l₁ l₂ : list α) : Prop := ∃ l₃ a, l₃ ++ a :: l₁ = l₂

infix ` ⊂ᵢ `:50 := is_initial

@[simp] lemma is_initial_antirefl (l : list α) : ¬ l ⊂ᵢ l := λ h,
by simp[is_initial, *] at*

@[simp] lemma not_is_initial_nil (l : list α) : ¬ l ⊂ᵢ [] := λ h,
by simp[is_initial, *] at*

@[simp] lemma is_initial_nil_cons (l : list α) (a : α) : [] ⊂ᵢ a :: l :=
by { cases C : l.reverse with x l',
     { have := congr_arg list.reverse C, simp at this, exact ⟨[], a, by simp[this]⟩ },
     { have := congr_arg list.reverse C, simp at this, exact ⟨[a] ++ l'.reverse, x, by simp[this]⟩ } }

lemma is_initial.trans {l₁ l₂ l₃ : list α} (h₁ : l₁ ⊂ᵢ l₂) (h₂ : l₂ ⊂ᵢ l₃) : l₁ ⊂ᵢ l₃ :=
by { rcases h₁ with ⟨l12, a12, h₁⟩, rcases h₂ with ⟨l23, a23, h₂⟩,
     refine ⟨l23 ++ [a23] ++ l12, a12, by simp[h₁, h₂]⟩ }

lemma is_suffix.is_initial_of_is_initial {l₁ l₂ l₃ : list α} (h₁ : l₁ <:+ l₂) (h₂ : l₂ ⊂ᵢ l₃) : l₁ ⊂ᵢ l₃ :=
by { rcases h₁ with ⟨l12, h₁⟩,
     cases C : l12.reverse with a' l',
     { simp at C, rcases C with rfl,
       simp at h₁, rcases h₁ with rfl, exact h₂ },
     { have := congr_arg list.reverse C, simp at this, rcases this with rfl,
       rcases h₂ with ⟨l23, a23, h₂⟩, simp at h₁,
       refine ⟨l23 ++ [a23] ++ l'.reverse, a', by simp[h₁, h₂]⟩ } }

lemma is_initial_antisymm {l₁ l₂ : list α} (h₁ : l₁ ⊂ᵢ l₂) (h₂ : l₂ ⊂ᵢ l₁) : false :=
by { rcases h₁ with ⟨l, a, rfl⟩, rcases h₂ with ⟨l', a', eqn⟩,
     have := congr_arg list.length eqn, simp[add_assoc] at this,
     rw (show l₁.length + (1 + 1) = (1+1) + l₁.length, from add_comm _ _) at this,
     simp[←add_assoc] at this, contradiction }

lemma is_initial.is_initial_of_suffix {l₁ l₂ l₃ : list α} (h₁ : l₁ ⊂ᵢ l₂) (h₂ : l₂ <:+ l₃) : l₁ ⊂ᵢ l₃ :=
by { rcases h₁ with ⟨l12, a12, h₁⟩, rcases h₂ with ⟨l23, h₂⟩,
     refine ⟨l23 ++ l12, a12, by simp[h₁, h₂]⟩ }

lemma is_initial.lt_length {l₁ l₂ : list α} (h : l₁ ⊂ᵢ l₂) : l₁.length < l₂.length :=
by { rcases h with ⟨l, x, rfl⟩, simp,
     exact (length l₁).lt_add_left (length l₁ + 1) (length l) (lt_add_one (length l₁))}

@[simp] lemma is_initial_cons (a : α) (l : list α) : l ⊂ᵢ a :: l := ⟨[], a, rfl⟩

lemma is_initial_cons_iff {x : α} {l₁ l₂ : list α} :
  l₁ ⊂ᵢ x :: l₂ ↔ l₁ = l₂ ∨ l₁ ⊂ᵢ l₂ :=
begin
  split,
  { rintro ⟨⟨hd, tl⟩, y, eqn⟩,
    { simp at eqn, refine or.inl eqn.2 },
    { simp at eqn, refine or.inr ⟨_, _, eqn.2⟩ } },
  { rintro (rfl | hl₁),
    { simp },
    { exact hl₁.trans (l₂.is_initial_cons _) } }
end

instance is_initial_decidable [decidable_eq α] : ∀ (l₁ l₂ : list α), decidable (l₁ ⊂ᵢ l₂)
| l₁ []        := is_false (not_is_initial_nil l₁)
| l₁ (a :: l₂) :=
  have IH : decidable (l₁ ⊂ᵢ l₂) := is_initial_decidable l₁ l₂,
  @dite (decidable (l₁ ⊂ᵢ (a :: l₂))) (l₁ ⊂ᵢ l₂) IH
    (λ h, is_true (h.trans (l₂.is_initial_cons _)))
    (λ h, if eqn : l₁ = l₂ then is_true (by simp[eqn])
      else is_false (by { simp[is_initial_cons_iff], exact not_or eqn h }))

#check list.rec_on

def is_initial_fn [decidable_eq α] (l₁ : list α) : list α → bool
| [] := ff
| (x :: l) := is_initial_fn l || (l₁ = l)

section
open primrec

lemma primrec.is_initial [primcodable α] [decidable_eq α] : primrec_rel ((⊂ᵢ) : list α → list α → Prop) :=
begin
  let f : list α → list α → bool := λ l₀ l : list α, list.rec_on l ff (λ hd tl IH, IH || (l₀ = tl)),
  let h : list α × list α → α × list α × bool → bool := λ l p, p.2.2 || to_bool  (l.1 = p.2.1),
  have ph : primrec₂ h,
    from primrec.bor.comp (snd.comp $ snd.comp snd) (primrec.eq.comp (fst.comp fst) (fst.comp $ snd.comp snd)),
  have : primrec₂ f, from (primrec.list_rec primrec.snd (primrec.const ff) ph),
  exact this.of_eq (λ l₀ l, by { induction l with x l IH, { simp[f] }, { simp[f, is_initial_cons_iff],
    by_cases C : l₀ = l; simp[C], { simp[f] at IH, simp[IH] } } })
end

end

lemma is_initial_of_lt_length {l : list α} {n : ℕ} (h : n < l.length) : l↾*n ⊂ᵢ l :=
begin
  simp[initial],
  cases C : (take (l.length - n) l).reverse with a l',
  { exfalso,
    have : l.length ≤ n,
    { have := congr_arg list.length C, simp at this, exact this },
    exact nat.lt_le_antisymm h this },
  { have : take (l.length - n) l = l'.reverse ++ [a],
    { have := congr_arg list.reverse C, simp at this, exact this },
    refine ⟨l'.reverse, a, _⟩,
    have lmm := list.take_append_drop (l.length - n) l, simp [this] at lmm,
    exact lmm }
end

lemma suffix_of_is_initial {l₁ l₂ : list α} (h : l₁ ⊂ᵢ l₂) : l₁ <:+ l₂ :=
by { rcases h with ⟨l₃, a, h⟩, refine ⟨l₃ ++ [a], by simp[h]⟩ }

lemma is_initial.suffix {l₁ l₂ : list α} (h : l₁ ⊂ᵢ l₂) : l₁ <:+ l₂ :=
by { rcases h with ⟨l₃, a, h⟩, refine ⟨l₃ ++ [a], by simp[h]⟩ }

lemma suffix_iff_is_initial {l₁ l₂ : list α} : l₁ <:+ l₂ ↔ l₁ ⊂ᵢ l₂ ∨ l₁ = l₂ :=
⟨begin
    revert l₁ l₂,
    suffices :
      ∀ {l l₁ l₂ : list α}, l.reverse ++ l₁ = l₂ → l₁ ⊂ᵢ l₂ ∨ l₁ = l₂,
    { intros l₁ l₂ h, rcases h with ⟨l, h⟩, exact @this l.reverse l₁ l₂ (by simp[h]) },
    intros l l₁ l₂ h, induction l with a l IH generalizing l₁ l₂,
    { right, simp* at* },
    { left, simp at h, refine ⟨l.reverse, a, h⟩ }
  end, λ h, by { cases h, { exact suffix_of_is_initial h }, { simp[h] } } ⟩

lemma is_initial_iff_suffix {l₁ l₂ : list α} : l₁ ⊂ᵢ l₂ ↔ l₁ <:+ l₂ ∧ l₁ ≠ l₂ :=
by { simp[suffix_iff_is_initial, or_and_distrib_right], intros h₁ h₂, simp[h₂] at*, exact h₁ }

lemma is_initial_suffix_antisymm {l₁ l₂ : list α} (lt : l₁ ⊂ᵢ l₂) (le : l₂ <:+ l₁) : false :=
by {cases suffix_iff_is_initial.mp le, { exact is_initial_antisymm lt h }, { simp[h] at lt, contradiction } }

lemma is_initial_cons_iff_suffix {x : α} {l₁ l₂ : list α} :
  l₁ ⊂ᵢ x :: l₂ ↔ l₁ <:+ l₂ :=
by { simp[is_initial_cons_iff, suffix_iff_is_initial], exact or.comm }

lemma suffix_cons_iff_is_initial {l₁ l₂ : list α} :
  (∃ x : α, x :: l₁ <:+ l₂) ↔ l₁ ⊂ᵢ l₂ :=
⟨λ ⟨x, l, eqn⟩, ⟨l, x, eqn⟩, λ ⟨l, a, eqn⟩, ⟨a, l, eqn⟩⟩

lemma is_initial_of_pos_suffix {l₁ l₂ l : list α}
  (h : l ++ l₁ <:+ l₂) (pos : 0 < l.length) : l₁ ⊂ᵢ l₂ :=
begin
    cases C : l.reverse with a l IH,
    { exfalso, simp at C, rcases C with rfl, simp at pos, contradiction },
    { have := congr_arg list.reverse C, simp at this, rcases this with rfl,
      rcases h with ⟨l', rfl⟩,
      exact ⟨l' ++ l.reverse, a, by simp⟩ }
end

lemma is_suffix.is_initial_of_lt {l₁ l₂ : list α}
  (h : l₁ <:+ l₂) (lt : l₁.length < l₂.length) : l₁ ⊂ᵢ l₂ :=
begin
  rcases h with ⟨l, rfl⟩,
  induction l with a l IH, { exfalso, simp at lt, contradiction },
  { simp[is_initial_cons_iff_suffix] }
end

lemma is_suffix.eq_of_eq {l₁ l₂ : list α}
  (h : l₁ <:+ l₂) (lt : l₁.length = l₂.length) : l₁ = l₂ :=
begin
  exact eq_of_suffix_of_length_eq h lt
end

lemma is_suffix.le_length {l₁ l₂ : list α} (h : l₁ <:+ l₂) : l₁.length ≤ l₂.length :=
by { rcases h with ⟨l, rfl⟩, simp }

lemma rnth_eq_iff_suffix_cons_initial {l : list α} {n : ℕ} {a : α} :
  l.rnth n = a ↔ a :: l↾*n <:+ l :=
begin
  induction l with a' l IH,
  { simp, exact option.not_mem_none a },
  { have C : n < l.length ∨ n = l.length ∨ l.length < n, exact trichotomous _ _,
    cases C,
    { simp[rnth_cons C, initial_cons (le_of_lt C), IH], split,
      { intros h, exact h.trans (list.suffix_cons a' l) },
      { intros h, have := list.suffix_cons_iff.mp h,
        cases this,
        { exfalso,
          have : l↾*n = l, { simp* at * },
          have := congr_arg list.length this, simp[initial_length C] at this,
          simp[this] at C, exact C  },
        { exact this } } },
    cases C,
    { rcases C with rfl, simp, unfold_coes, simp[option.some_inj, @eq_comm _ a a'] },
    { have : (a' :: l).length ≤ n, { simp, exact nat.succ_le_iff.mpr C },
      simp[rnth_none.mpr this, initial_elim this], exact option.not_mem_none a } }
end

lemma is_initial_length {l₁ l₂ : list α} (h : l₁ ⊂ᵢ l₂) : l₁.length < l₂.length :=
by { rcases h with ⟨l, a, h⟩, simp[←h],
     exact (length l₁).lt_add_left (length l₁ + 1) (length l) (lt_add_one (length l₁)) }

lemma eq_initial_of_is_initial {l₁ l₂ : list α} (h : l₁ ⊂ᵢ l₂) : l₂↾*l₁.length = l₁ :=
begin
  simp[initial],
  rcases h with ⟨l, a, h⟩, simp[←h, add_assoc],
  have : l.length + (l₁.length + 1) - l₁.length = l.length + 1,
  { simp[←add_assoc], omega },
  simp[this, list.drop_append]
end

lemma suffix_initial (l : list α) (n : ℕ) : l↾*n <:+ l :=
by { simp[initial], exact drop_suffix (length l - n) l }

lemma is_initial_initial (l : list α) (n : ℕ) (lt : n < l.length): l↾*n ⊂ᵢ l :=
is_suffix.is_initial_of_lt (suffix_initial l n) (by simp[initial_length lt, lt])

lemma map_suffix {α β} {l l' : list α} (f : α → β) (h : l <:+ l') :
  l.map f <:+ l'.map f :=
begin
  rcases h with ⟨l'', h⟩,
  refine ⟨map f l'', _⟩, simp[←h]
end

lemma mem_of_suffix {l₁ l₂ : list α} (h : l₁ <:+ l₂) {a : α} (mem : a ∈ l₁) : a ∈ l₂ :=
by { rcases h with ⟨l, rfl⟩, simp[mem] }

def incomparable (l₁ l₂ : list α) : Prop := ¬l₁ <:+ l₂ ∧ ¬l₂ <:+ l₁

infix ` ∥ ` :50 := incomparable

lemma incomparable_iff_suffix_is_initial {l₁ l₂ : list α} :
  l₁ ∥ l₂ ↔ ¬l₁ ⊂ᵢ l₂ ∧ ¬l₂ <:+ l₁ :=
⟨λ ⟨h₁, h₂⟩, ⟨λ A, h₁ (suffix_of_is_initial A), h₂⟩,
  λ ⟨h₁, h₂⟩, ⟨λ A, by { simp[is_initial_iff_suffix] at h₁, simp[h₁ A, suffix_refl] at h₂, contradiction }, h₂⟩⟩

@[simp] lemma incomparable.antirefl {l : list α} : ¬ l ∥ l :=
by simp[incomparable]

lemma incomparable.symm {l₁ l₂ : list α} :
  l₁ ∥ l₂ → l₂ ∥ l₁ := λ ⟨h₁, h₂⟩, ⟨h₂, h₁⟩

lemma incomparable.symm_iff {l₁ l₂ : list α} :
  l₁ ∥ l₂ ↔ l₂ ∥ l₁ := ⟨incomparable.symm, incomparable.symm⟩

lemma incomparable_iff_is_initial_suffix {l₁ l₂ : list α} :
  l₁ ∥ l₂ ↔ ¬l₁ <:+ l₂ ∧ ¬l₂ ⊂ᵢ l₁ :=
⟨λ h, by simp[incomparable_iff_suffix_is_initial.mp h.symm], λ h,
  incomparable.symm (incomparable_iff_suffix_is_initial.mpr (by simp[h]))⟩

lemma incomparable_trichotomy (l₁ l₂ : list α) : l₁ <:+ l₂ ∨ l₂ ⊂ᵢ l₁ ∨ l₁ ∥ l₂ :=
by { simp[incomparable_iff_is_initial_suffix], by_cases C₁ : l₁ <:+ l₂; simp[C₁], by_cases C₂ : l₂ ⊂ᵢ l₁; simp[C₂] }

lemma incomparable_of_le_of_le {l₁ l₂ k₁ k₂ : list α} (h : l₁ ∥ l₂) (le₁ : l₁ <:+ k₁) (le₂ : l₂ <:+ k₂) :
  k₁ ∥ k₂ :=
begin
  simp[incomparable], rcases h with ⟨i₁, i₂⟩,
  rcases le₁ with ⟨m₁, rfl⟩, rcases le₂ with ⟨m₂, rfl⟩,
  by_contradiction,
  have C : m₁ ++ l₁ <:+ m₂ ++ l₂ ∨ m₂ ++ l₂ <:+ m₁ ++ l₁, from or_iff_not_and_not.mpr h,
  cases C,
  { have : l₁ <:+ l₂ ∨ l₂ <:+ l₁,
      from list.suffix_or_suffix_of_suffix ((list.suffix_append m₁ l₁).trans C) (list.suffix_append m₂ l₂),
    cases this; contradiction },
  { have : l₂ <:+ l₁ ∨ l₁ <:+ l₂,
      from list.suffix_or_suffix_of_suffix ((list.suffix_append m₂ l₂).trans C) (list.suffix_append m₁ l₁),
    cases this; contradiction }
end

lemma incomparable_of_lt {l₁ l₂ : list α} (lt : l₁ ⊂ᵢ l₂) {a : α} (h : a ∉ l₂)  : a :: l₁ ∥ l₂ :=
begin
  simp[incomparable], by_contradiction A,
  have : a :: l₁ <:+ l₂ ∨ l₂ <:+ a :: l₁, from or_iff_not_and_not.mpr A,
  cases this,
  { rcases this with ⟨l, rfl⟩, simp at h, contradiction },
  { rcases list.suffix_cons_iff.mp this with (rfl | hh), {simp at h, contradiction },
    { exact is_initial_suffix_antisymm lt hh } }
end

def ordered (r : α → α → Prop) : list α → Prop
| []       := true
| (a :: l) := ordered l ∧ (∀ a', a' ∈ l → r a' a)

@[simp] lemma ordered_nil {r : α → α → Prop} : [].ordered r :=
by simp[ordered]

@[simp] lemma ordered_singleton {r : α → α → Prop} (a : α) : [a].ordered r :=
by simp[ordered]

lemma ordered_cons {r : α → α → Prop} {l : list α} {a : α} (o : (a :: l).ordered r) : l.ordered r :=
by simp[ordered] at o; exact o.1

lemma ordered_suffix {r : α → α → Prop} {l₁ l₂ : list α} (le : l₁ <:+ l₂) (o : l₂.ordered r) : l₁.ordered r :=
begin
  rcases le with ⟨l, rfl⟩,
  induction l with a l IH,
  { exact o },
  { simp[ordered] at o, exact IH o.1 }
end

lemma ordered_mono {r : α → α → Prop} {l : list α} (o : l.ordered r) :
  ∀ {n m : ℕ} (lt : n < m) {a₁ a₂ : α} (h₁ : l.rnth n = a₁) (h₂ : l.rnth m = a₂), r a₁ a₂ :=
begin
  suffices :
    ∀ n m {a₁ a₂ : α} (h₁ : l.rnth n = a₁) (h₂ : l.rnth (n + 1 + m) = a₂), r a₁ a₂,
    { intros n m lt, have := @this n (m - (n + 1)),
      have le : n + 1 ≤ m, from nat.succ_le_iff.mpr lt,
      simp[nat.add_sub_of_le le] at this, exact @this },
  intros n m a₁ a₂ eqn₁ eqn₂, induction l with a l IH generalizing n m a₁ a₂,
  { simp at eqn₂, exfalso, exact option.not_mem_none a₂ eqn₂ },
  { simp[ordered] at o,
    have lt : n < l.length, { have := rnth_some_lt eqn₂, simp at this,
      simp[nat.succ_add n m, ←nat.add_one] at this, exact buffer.lt_aux_1 this },
    have eqn₁ : l.rnth n = ↑a₁, { simp[lt, rnth_cons] at eqn₁, exact eqn₁ },
    simp[rnth_cons, lt, rnth_cons_some_iff] at eqn₂, cases eqn₂,
    { exact IH o.1 _ _ eqn₁ eqn₂.1 },
    { rcases eqn₂ with ⟨rfl, eqn₂⟩, refine o.2 _ (mem_iff_rnth.mpr ⟨n, eqn₁⟩) } }
end

lemma ordered_isomorphism {r : α → α → Prop} [is_irrefl α r] [is_asymm α r] {l : list α} (o : l.ordered r)
  {n m : ℕ} {a₁ a₂ : α} (h₁ : l.rnth n = a₁) (h₂ : l.rnth m = a₂) : n < m ↔ r a₁ a₂ :=
begin
  have C : n < m ∨ n = m ∨ m < n, from trichotomous n m,
  cases C,
  { simp[C], exact ordered_mono o C h₁ h₂ }, cases C,
  { rcases C with rfl,
    have : a₁ = a₂, { simp[h₁] at h₂, exact option.some_inj.mp h₂ },
    simp[this], exact irrefl a₂ },
  { have : ¬n < m, { intros h, exact nat.lt_asymm C h },
    simp[this],
    intros A,
    have : r a₂ a₁, from ordered_mono o C h₂ h₁, exact asymm A this }
end

lemma ordered_filter {r : α → α → Prop} (p : α → Prop) [decidable_pred p] : ∀ {l : list α}
  (h : l.ordered r), (l.filter p).ordered r
| []       h := by simp
| (a :: l) h := by { simp[filter] at h ⊢,
    by_cases C : p a; simp[C, ordered],
    { exact ⟨ordered_filter h.1, λ a' mem pa', h.2 _ mem⟩ },
    { exact ordered_filter h.1 } }

lemma ordered_map {α β} {r : α → α → Prop} {r' : β → β → Prop} (f : α → β)
  (isom : ∀ x y, r x y → r' (f x) (f y)) : ∀ {l : list α} (o : l.ordered r), (l.map f).ordered r'
| []       o := by simp
| (a :: l) o := by { simp[ordered] at o ⊢, refine ⟨ordered_map o.1, λ a' mem, isom _ _ (o.2 _ mem)⟩ }

def weight_of (wt : α → ℕ) : list α → ℕ
| []       := 0
| (a :: l) := nat.mkpair (wt a) l.weight_of + 1

@[simp] lemma weight_of_nil (wt : α → ℕ) : ([] : list α).weight_of wt = 0 := rfl

lemma lt_weight_of_is_initial {wt : α → ℕ} {l₁ l₂ : list α} (lt : l₁ ⊂ᵢ l₂) : l₁.weight_of wt < l₂.weight_of wt :=
begin
  rcases lt with ⟨l, x, rfl⟩, induction l with y l IH; simp[weight_of],
  { exact nat.lt_succ_iff.mpr (nat.right_le_mkpair (wt x) (weight_of wt l₁)) },
  { exact nat.lt_succ_iff.mpr (le_of_lt (gt_of_ge_of_gt (nat.right_le_mkpair (wt y) (weight_of wt (l ++ x :: l₁))) IH)) }
end

lemma lt_length_weight {wt : α → ℕ} {l : list α} : l.length ≤ l.weight_of wt :=
by { induction l with a l IH; simp[weight_of], refine IH.trans (nat.right_le_mkpair (wt a) (weight_of wt l)) }

lemma lt_weight_of_mem {wt : α → ℕ} {a : α} {l : list α} (lt : a ∈ l) : wt a < l.weight_of wt :=
begin
  induction l with x l IH,
  { simp at lt, contradiction },
  { simp at lt, rcases lt with (rfl | mem); simp[weight_of],
    exact nat.lt_succ_iff.mpr (nat.left_le_mkpair (wt a) (weight_of wt l)),
    refine nat.lt_succ_iff.mpr (le_of_lt (gt_of_ge_of_gt (nat.right_le_mkpair (wt x) (l.weight_of wt)) (IH mem))) }
end

lemma weight_of_injective {wt : α → ℕ} (inj : function.injective wt) : function.injective (list.weight_of wt)
| []         []         eqn := rfl
| []         (a :: l)   eqn := by { exfalso, simp[weight_of] at eqn, exact ne.symm (nat.succ_ne_zero _) eqn }
| (a :: l)   []         eqn := by { exfalso, simp[weight_of] at eqn, exact eqn }
| (a₁ :: l₁) (a₂ :: l₂) eqn := by { simp[weight_of] at eqn,
    have eqn := congr_arg nat.unpair eqn, simp at eqn,
    have eqn₁ : a₁ = a₂, from inj eqn.1,
    have eqn₂ : l₁ = l₂, from weight_of_injective eqn.2,
    simp[eqn₁, eqn₂] }

end list

namespace option
variables {α : Type u}

@[simp] lemma some_ne_none' (x : α) : ¬ (↑x : option α) = none := option.some_ne_none x
@[simp] lemma some_ne_none'' (x : α) : ¬ none = (↑x : option α) := ne.symm (option.some_ne_none x)

@[simp] theorem some_inj' {a b : α} : (↑a : option α) = ↑b ↔ a = b := by unfold_coes; simp
@[simp] theorem some_inj'' {a b : α} : ↑a = some b ↔ a = b := by unfold_coes; simp
@[simp] theorem some_inj''' {a b : α} : some a = ↑b ↔ a = b := by unfold_coes; simp

@[simp] lemma coe_is_some (x : α) : (x : option α).is_some = tt := rfl

@[simp] lemma coe_is_none (x : α) : (x : option α).is_none = ff := rfl

end option

class omega_ordering (α : Type u) :=
(ordering : α → ℕ)
(inj : function.injective ordering)

namespace omega_ordering

def default (α : Type*) [encodable α] : omega_ordering α := ⟨encodable.encode, encode_injective⟩

instance {α : Type u} [omega_ordering α] : linear_order α :=
{ le := λ x y, (omega_ordering.ordering x) ≤ (omega_ordering.ordering y),
  lt := λ x y, (omega_ordering.ordering x) < (omega_ordering.ordering y),
  le_refl := λ x, le_refl (omega_ordering.ordering x),
  le_trans := λ x y z, by { simp, exact le_trans },
  lt_iff_le_not_le := λ x y, by { simp, exact le_of_lt },
  le_antisymm := λ x y h₁ h₂,
    by { have := @le_antisymm ℕ _ _ _ h₁ h₂, exact omega_ordering.inj this },
  le_total := λ x y, @le_total ℕ _ _ _,
  decidable_le := λ x y,
    @has_le.le.decidable ℕ _ (omega_ordering.ordering x) (omega_ordering.ordering y) }

lemma le_iff {α} [omega_ordering α] {a b : α} :
  a ≤ b ↔ (omega_ordering.ordering a) ≤ (omega_ordering.ordering b) := by refl

lemma lt_iff {α} [omega_ordering α] {a b : α} :
  a < b ↔ (omega_ordering.ordering a) < (omega_ordering.ordering b) := by refl

lemma min_iff {α} [omega_ordering α] {a b : α} :
  min a b = if (omega_ordering.ordering a) ≤ (omega_ordering.ordering b) then a else b := rfl

def Min {α : Type u} (o : omega_ordering α) : list α → option α
| []       := none
| (a :: l) := if h : (Min l).is_some then some (min a (option.get h)) else a

lemma min_some_of_pos {α : Type u} (o : omega_ordering α) : ∀ (l : list α) (h : 0 < l.length), (o.Min l).is_some
| []       h := by exfalso; simp at h; contradiction
| (a :: l) h := by { simp[Min],  cases C : o.Min l; simp[C] }

def Min_le {α : Type u} (o : omega_ordering α) (l : list α) (h : 0 < l.length) : α :=
option.get (min_some_of_pos o l h)

lemma Min_le_eq {α : Type u} (o : omega_ordering α) {l₁ l₂ : list α}
  (h₁ : 0 < l₁.length) (h₂ : 0 < l₂.length) :
  l₁ = l₂ → Min_le o l₁ h₁ = Min_le o l₂ h₂ :=
by { rintros rfl; refl }

variables {α : Type u} {o : omega_ordering α}

@[simp] lemma min_none_iff : ∀ l : list α, o.Min l = none ↔ l = []
| []       := by simp[Min]
| (x :: l) := by { simp[Min], cases C : o.Min l; simp[C], }

@[simp] lemma mem_of_Min_iff_le : ∀ {l : list α} {m : α}, o.Min l = some m ↔ m ∈ l ∧ ∀ a ∈ l, m ≤ a
| []       _ := by simp[Min]
| (x :: l) m := by { simp[Min], cases C : o.Min l with m'; simp[C],
    { simp at C, simp[C], refine ⟨λ eqn, by simp[eqn], λ eqn, by simp[eqn]⟩ },
    { have : m' ∈ l ∧ ∀ (a : α), a ∈ l → m' ≤ a, from mem_of_Min_iff_le.mp C, rcases this with ⟨IH₁, IH₂⟩,
      by_cases C₁ : x ≤ m'; simp[min, C₁, min_default],
      { split,
        { rintros rfl, simp, intros a mem, exact le_trans C₁ (IH₂ a mem) },
        { rintros ⟨(h₁ | h₁), h₂, h₃⟩, { simp[h₁] },
          { have : m = m', { exact le_antisymm (h₃ m' IH₁) (IH₂ m h₁) }, rcases this with rfl,
            exact le_antisymm C₁ h₂ } } },
      { split,
        { rintros rfl, exact ⟨or.inr IH₁, le_of_not_ge C₁, IH₂⟩ },
        { rintros ⟨(h₁ | h₁), h₂, h₃⟩, {exfalso, rcases h₁ with rfl, exact C₁ (h₃ m' IH₁) },
          { exact le_antisymm (IH₂ m h₁) (h₃ m' IH₁) } } } } }

lemma Min_le_mem (o : omega_ordering α) (l : list α) {h} : o.Min_le l h ∈ l :=
(mem_of_Min_iff_le.mp (option.mem_def.mp (option.get_mem (min_some_of_pos o l h)))).1

lemma Min_le_minimum (o : omega_ordering α) {l : list α} {h} : ∀ a ∈ l, o.Min_le l h ≤ a :=
(mem_of_Min_iff_le.mp (option.mem_def.mp (option.get_mem (min_some_of_pos o l h)))).2

lemma eq_Min_sequence (o : omega_ordering α) (A : ℕ → list α) (pos : ∀ s, 0 < (A s).length)
  (hA₁ : ∀ s t, s < t → ¬o.Min_le (A s) (pos s) ∈ A t)
  {a : α} (mem : a ∈ A 0) (hA₂ : ∀ s, a ≠ o.Min_le (A s) (pos s) → a ∈ A s → a ∈ A (s + 1)) :
  ∃ s, a = o.Min_le (A s) (pos s) :=
begin
  suffices : ¬∀ s, a ∈ A s,
  { revert this, contrapose, simp, intros h s,
    induction s with s IH, { exact mem },
    { exact hA₂ s (h s) IH } },
  intros mem,
  have lt : ∀ s, o.Min_le (A s) (pos s) < a,
  { intros s, have : o.Min_le (A s) (pos s) ≤ a, from o.Min_le_minimum a (mem s),
    have C : o.Min_le (A s) (pos s) < a ∨ o.Min_le (A s) (pos s) = a, from lt_or_eq_of_le this,
    rcases C with (C | rfl),
    { exact C }, { exfalso, exact (hA₁ s (s + 1) (lt_add_one s)) (mem (s + 1)) } },
  have : function.injective (λ s, ordering (o.Min_le (A s) (pos s))),
  { intros s₁ s₂ eqn, simp at eqn,
    have C : s₁ < s₂ ∨ s₁ = s₂ ∨ s₂ < s₁, exact trichotomous s₁ s₂, cases C,
    { exfalso,
      have : o.Min_le (A s₁) (pos s₁) ∉ A s₂, from hA₁ s₁ s₂ C,
      have : o.Min_le (A s₁) (pos s₁) ∈ A s₂, rw inj eqn, from o.Min_le_mem _,
      contradiction }, cases C,
    { exact C },
    { exfalso,
      have : o.Min_le (A s₂) (pos s₂) ∉ A s₁, from hA₁ s₂ s₁ C,
      have : o.Min_le (A s₂) (pos s₂) ∈ A s₁, rw ← inj eqn, from o.Min_le_mem _,
      contradiction } },
  have : ∃ s, a < o.Min_le (A s) (pos s), from nat.range_infinity_of_injective this (ordering a),
  rcases this with ⟨s, eqn⟩,
  exact nat.lt_asymm (lt s) eqn
end

end omega_ordering
namespace fin

def add' {n} (i : fin n) : fin (n + 1) := ⟨i, nat.lt.step i.property⟩

lemma cases' {n} (i : fin (n + 1)) : (∃ i' : fin n, i = add' i') ∨ i = ⟨n, lt_add_one n⟩ :=
by { have : ↑i < n ∨ ↑i = n, exact nat.lt_succ_iff_lt_or_eq.mp i.property, cases this,
     { left, refine ⟨⟨i, this⟩, fin.eq_of_veq _⟩, simp[add'] },
     { right, apply fin.eq_of_veq, simp[this] } }

end fin

def finitary (α : Type*) (n : ℕ) := fin n → α

namespace finitary
variables {α : Type*}
open vector

def cons {n} (f : finitary α n) (a : α) : finitary α (n + 1) := λ i, if h : ↑i < n then f ⟨i, h⟩ else a

infixr ` ::ᶠ `:60  := finitary.cons

@[simp] lemma cons_app0 {n} (f : finitary α n) (a : α) : (f ::ᶠ a) ⟨n, lt_add_one n⟩ = a := by simp[finitary.cons]

@[simp] lemma cons_app1 {n} (f : finitary α n) (a : α) (i : fin n) : (f ::ᶠ a) i.add' = f i :=
by { simp[finitary.cons, fin.add'], intros h, exfalso, exact nat.lt_le_antisymm i.property h }

def nil : finitary α 0 := λ i, by { exfalso, exact i.val.not_lt_zero i.property }
notation `fin[` l:(foldl `, ` (h t, finitary.cons t h) nil `]`) := l

def tail {n} (f : finitary α (n + 1)) : finitary α n := λ i, f ⟨i, nat.lt.step i.property⟩
def head {n} (f : finitary α (n + 1)) : α := f ⟨n, lt_add_one n⟩

lemma tail_cons_head {n} (f : finitary α (n + 1)) : f.tail ::ᶠ f.head = f :=
funext (λ i, by { simp[cons, tail, head],
  intros h,
  congr, apply fin.eq_of_veq, simp,
  have : ↑i ≤ n, from fin.is_le i,
  exact le_antisymm h this })

@[simp] lemma zero_eq (f : finitary α 0) : f = finitary.nil :=
funext (λ i, by { have := i.property, exfalso, exact i.val.not_lt_zero this })

@[simp] lemma fin1_eq (f : finitary α 1) : fin[f 0] = f :=
funext (λ i, by { rcases i with ⟨i, i_p⟩, cases i; simp[cons], exfalso, simp[←nat.add_one] at*, exact i_p })

@[simp] lemma fin2_eq (f : finitary α 2) : fin[f 0, f 1] = f :=
funext (λ i, by { rcases i with ⟨i, i_p⟩, cases i; simp[cons], cases i, { simp },
  exfalso, simp[←nat.add_one] at i_p, exact i_p })

end finitary

def eq_under {α : Sort*} (n : ℕ) (f g : ℕ → α) : Prop := ∀ x < n, f x = g x

notation f ` =[<` n `]` g := eq_under n f g

def list.of_list {α : Type*} : ∀ l : list α, (fin (l.length) → α)
| []        := finitary.nil
| (a :: as) := as.of_list ::ᶠ a

namespace part

def le_nat (m : part ℕ) (n : ℕ) : Prop := ∃ m' ∈ m, m' ≤ n

infix ` ≼ `:50 := part.le_nat

end part

namespace pfun

def complement {α : Type*} {β : Type*} (p : α →. β) [∀ a, decidable (p a).dom] (a : α) : option β := (p a).to_option

@[simp] lemma complement.app {α : Type*} {β : Type*} (p : α →. β) [∀ a, decidable (p a).dom] (a : α) :
  (p.complement a : part β) = p a := by { simp[complement], exact part.of_to_option _ }

end pfun


import data.nat.digits

example : nat.digits 0 0 = [] := by norm_num
example : nat.digits 1 0 = [] := by norm_num
example : nat.digits 2 0 = [] := by norm_num
example : nat.digits 10 0 = [] := by norm_num
example : nat.digits 0 1 = [1] := by norm_num
example : nat.digits 0 1000 = [1000] := by norm_num
example : nat.digits 1 10 = [1, 1, 1, 1, 1, 1, 1, 1, 1, 1] := by norm_num
example : nat.digits 2 65536 = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1] := by norm_num
example : nat.digits 3 30000000 = [0, 1, 0, 1, 2, 0, 1, 1, 0, 0, 1, 1, 2, 0, 0, 2] := by norm_num
example : nat.digits 10 1234567 = [7, 6, 5, 4, 3, 2, 1] := by norm_num


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.finite

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

open category_theory
open opposite

namespace category_theory.limits

universes v u u₂
variables {C : Type u} [category.{v} C]

variables {J : Type v} [small_category J]

-- We hide the "implementation details" inside a namespace
namespace has_limit_of_has_products_of_has_equalizers

variables {F : J ⥤ C}
          {c₁ : fan F.obj}
          {c₂ : fan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2)}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), s ≫ c₂.π.app f = c₁.π.app f.1.1 ≫ F.map f.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), t ≫ c₂.π.app f = c₁.π.app f.1.2)
          (i : fork s t)

include hs ht
/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
@[simps]
def build_limit : cone F :=
{ X := i.X,
  π :=
  { app := λ j, i.ι ≫ c₁.π.app _,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.id_comp, category.assoc, ← hs ⟨⟨_, _⟩, f⟩, i.condition_assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) :
  is_limit (build_limit s t hs ht i) :=
{ lift := λ q,
  begin
    refine hi.lift (fork.of_ι _ _),
    { refine t₁.lift (fan.mk _ (λ j, _)),
      apply q.π.app j },
    { apply t₂.hom_ext,
      simp [hs, ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.equalizer_ext (t₁.hom_ext (by simpa using w))) }

end has_limit_of_has_products_of_has_equalizers

open has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
lemma has_limit_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : has_limit F :=
has_limit.mk
{ cone := _,
  is_limit :=
    build_is_limit
      (pi.lift (λ f, limit.π _ _ ≫ F.map f.2))
      (pi.lift (λ f, limit.π _ f.1.2))
      (by simp)
      (by simp)
      (limit.is_limit _)
      (limit.is_limit _)
      (limit.is_limit _) }

/--
Any category with products and equalizers has all limits.

See https://stacks.math.columbia.edu/tag/002N.
-/
lemma limits_from_equalizers_and_products
  [has_products C] [has_equalizers C] : has_limits C :=
{ has_limits_of_shape := λ J 𝒥,
  { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F } }

/--
Any category with finite products and equalizers has all finite limits.

See https://stacks.math.columbia.edu/tag/002O.
-/
lemma finite_limits_from_equalizers_and_finite_products
  [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
⟨λ J _ _, { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F }⟩

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

section

variables [has_limits_of_shape (discrete J) C]
          [has_limits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_equalizers C]
variables (G : C ⥤ D)
          [preserves_limits_of_shape walking_parallel_pair G]
          [preserves_limits_of_shape (discrete J) G]
          [preserves_limits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product :
  preserves_limits_of_shape J G :=
{ preserves_limit := λ K,
  begin
    let P := ∏ K.obj,
    let Q := ∏ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.2),
    let s : P ⟶ Q := pi.lift (λ f, limit.π _ _ ≫ K.map f.2),
    let t : P ⟶ Q := pi.lift (λ f, limit.π _ f.1.2),
    let I := equalizer s t,
    let i : I ⟶ P := equalizer.ι s t,
    apply preserves_limit_of_preserves_limit_cone
      (build_is_limit s t (by simp) (by simp)
        (limit.is_limit _)
        (limit.is_limit _)
        (limit.is_limit _)),
    refine is_limit.of_iso_limit (build_is_limit _ _ _ _ _ _ _) _,
    { exact fan.mk _ (λ j, G.map (pi.π _ j)) },
    { exact fan.mk (G.obj Q) (λ f, G.map (pi.π _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { apply fork.of_ι (G.map i) _,
      simp only [← G.map_comp, equalizer.condition] },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_fork_map_of_is_limit,
      apply equalizer_is_equalizer },
    refine cones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products
  [has_equalizers C] [has_finite_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ J [fintype J], preserves_limits_of_shape (discrete J) G] :
  preserves_finite_limits G :=
⟨λ _ _ _, by exactI preserves_limit_of_preserves_equalizers_and_product G⟩

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products
  [has_equalizers C] [has_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ J, preserves_limits_of_shape (discrete J) G] :
preserves_limits G :=
{ preserves_limits_of_shape := λ J 𝒥,
  by exactI preserves_limit_of_preserves_equalizers_and_product G }

/-!
We now dualize the above constructions, resorting to copy-paste.
-/

-- We hide the "implementation details" inside a namespace
namespace has_colimit_of_has_coproducts_of_has_coequalizers

variables {F : J ⥤ C}
          {c₁ : cofan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1)}
          {c₂ : cofan F.obj}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app f ≫ s = F.map f.2 ≫ c₂.ι.app f.1.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app f ≫ t = c₂.ι.app f.1.1)
          (i : cofork s t)

include hs ht
/--
(Implementation) Given the appropriate coproduct and coequalizer cocones,
build the cocone for `F` which is colimiting if the given cocones are also.
-/
@[simps]
def build_colimit : cocone F :=
{ X := i.X,
  ι :=
  { app := λ j, c₂.ι.app _ ≫ i.π,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.comp_id, ←reassoc_of (hs ⟨⟨_, _⟩, f⟩), i.condition, ←category.assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cocone constructed in `build_colimit` is colimiting,
provided the cocones used in its construction are.
-/
def build_is_colimit (t₁ : is_colimit c₁) (t₂ : is_colimit c₂) (hi : is_colimit i) :
  is_colimit (build_colimit s t hs ht i) :=
{ desc := λ q,
  begin
    refine hi.desc (cofork.of_π _ _),
    { refine t₂.desc (cofan.mk _ (λ j, _)),
      apply q.ι.app j },
    { apply t₁.hom_ext,
      simp [reassoc_of hs, reassoc_of ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.coequalizer_ext (t₂.hom_ext (by simpa using w))) }

end has_colimit_of_has_coproducts_of_has_coequalizers

open has_colimit_of_has_coproducts_of_has_coequalizers

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we know a colimit of `F` exists.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
lemma has_colimit_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : has_colimit F :=
has_colimit.mk
{ cocone := _,
  is_colimit :=
    build_is_colimit
      (sigma.desc (λ f, F.map f.2 ≫ colimit.ι (discrete.functor F.obj) f.1.2))
      (sigma.desc (λ f, colimit.ι (discrete.functor F.obj) f.1.1))
      (by simp)
      (by simp)
      (colimit.is_colimit _)
      (colimit.is_colimit _)
      (colimit.is_colimit _) }

/--
Any category with coproducts and coequalizers has all colimits.

See https://stacks.math.columbia.edu/tag/002P.
-/
lemma colimits_from_coequalizers_and_coproducts
  [has_coproducts C] [has_coequalizers C] : has_colimits C :=
{ has_colimits_of_shape := λ J 𝒥,
  { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F } }

/--
Any category with finite coproducts and coequalizers has all finite colimits.

See https://stacks.math.columbia.edu/tag/002Q.
-/
lemma finite_colimits_from_coequalizers_and_finite_coproducts
  [has_finite_coproducts C] [has_coequalizers C] : has_finite_colimits C :=
⟨λ J _ _, { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F }⟩

noncomputable theory

section

variables [has_colimits_of_shape (discrete J) C]
          [has_colimits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_coequalizers C]
variables (G : C ⥤ D)
          [preserves_colimits_of_shape walking_parallel_pair G]
          [preserves_colimits_of_shape (discrete J) G]
          [preserves_colimits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves coequalizers and the appropriate coproducts, it preserves colimits. -/
def preserves_colimit_of_preserves_coequalizers_and_coproduct :
  preserves_colimits_of_shape J G :=
{ preserves_colimit := λ K,
  begin
    let P := ∐ K.obj,
    let Q := ∐ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.1),
    let s : Q ⟶ P := sigma.desc (λ f, K.map f.2 ≫ colimit.ι (discrete.functor K.obj) _),
    let t : Q ⟶ P := sigma.desc (λ f, colimit.ι (discrete.functor K.obj) f.1.1),
    let I := coequalizer s t,
    let i : P ⟶ I := coequalizer.π s t,
    apply preserves_colimit_of_preserves_colimit_cocone
      (build_is_colimit s t (by simp) (by simp)
        (colimit.is_colimit _)
        (colimit.is_colimit _)
        (colimit.is_colimit _)),
    refine is_colimit.of_iso_colimit (build_is_colimit _ _ _ _ _ _ _) _,
    { exact cofan.mk (G.obj Q) (λ j, G.map (sigma.ι _ j)) },
    { exact cofan.mk _ (λ f, G.map (sigma.ι _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { apply cofork.of_π (G.map i) _,
      simp only [← G.map_comp, coequalizer.condition] },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_cofork_map_of_is_colimit,
      apply coequalizer_is_coequalizer },
    refine cocones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves coequalizers and finite coproducts, it preserves finite colimits. -/
def preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts
  [has_coequalizers C] [has_finite_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J [fintype J], preserves_colimits_of_shape (discrete J) G] :
  preserves_finite_colimits G :=
⟨λ _ _ _, by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G⟩

/-- If G preserves coequalizers and coproducts, it preserves all colimits. -/
def preserves_colimits_of_preserves_coequalizers_and_coproducts
  [has_coequalizers C] [has_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J, preserves_colimits_of_shape (discrete J) G] :
preserves_colimits G :=
{ preserves_colimits_of_shape := λ J 𝒥,
  by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G }

end category_theory.limits


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import combinatorics.simplicial_complex.convex_join

open set

variables {E : Type*} [add_comm_group E] [module ℝ E] {x y : E} {A B : set E} {c : set (set E)}

/-- Stone's Separation Theorem -/
lemma subsets_compl_convexes (hA : convex A) (hB : convex B) (hAB : disjoint A B) :
  ∃ C : set E, convex C ∧ convex Cᶜ ∧ A ⊆ C ∧ B ⊆ Cᶜ :=
begin
  sorry
  /-
  let S : set (set E) := {C | convex C ∧ C ⊆ Bᶜ},
  obtain ⟨C, hC, hAC, hCmax⟩ := zorn.zorn_subset_nonempty S (λ c hcS hc ⟨B, hB⟩, ⟨⋃₀c,
    ⟨(zorn.chain.directed_on hc).convex_sUnion (λ A hA, (hcS hA).1), sUnion_subset
    (λ C hC, (hcS hC).2)⟩, λ s, subset_sUnion_of_mem⟩) A ⟨hA, disjoint_iff_subset_compl_right.1 hAB⟩,
  refine ⟨C, hC.1, _, hAC, subset_compl_comm.1 hC.2⟩,
  rw convex_iff_segment_subset,
  rintro x y hx hy z hz hzC,
  suffices h : ∀ c ∈ Cᶜ, ∃ a ∈ C, (segment c a ∩ B).nonempty,
  { obtain ⟨p, hp, u, huC, huB⟩ := h x hx,
    obtain ⟨q, hq, v, hvC, hvB⟩ := h y hy,
    rw disjoint_iff_subset_compl_left at hAB,
    apply hAB,
    sorry
  },
  rintro c hc,
  by_contra,
  push_neg at h,
  suffices h : convex_hull (insert c C) ⊆ Bᶜ,
  { rw ←hCmax _ ⟨convex_convex_hull _, h⟩ (subset.trans (subset_insert _ _)
      (subset_convex_hull _)) at hc,
    exact hc (subset_convex_hull _ (mem_insert _ _)) },
  rw convex_hull_insert ⟨z, hzC⟩,
  refine bUnion_subset _,
  rintro a ha b hb hbB,
  rw convex.convex_hull_eq hC.1 at ha,
  exact h a ha ⟨b, hb, hbB⟩,
  -/
end


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.nat.form
import Mathlib.PostPort

namespace Mathlib

/-
Negation elimination.
-/

namespace omega

namespace nat

/-- push_neg p returns the result of normalizing ¬ p by
    pushing the outermost negation all the way down,
    until it reaches either a negation or an atom -/
@[simp] def push_neg : preform → preform := sorry

theorem push_neg_equiv {p : preform} : preform.equiv (push_neg p) (preform.not p) := sorry

/-- NNF transformation -/
def nnf : preform → preform := sorry

/-- Asserts that the given preform is in NNF -/
def is_nnf : preform → Prop := sorry

theorem is_nnf_push_neg (p : preform) : is_nnf p → is_nnf (push_neg p) := sorry

theorem is_nnf_nnf (p : preform) : is_nnf (nnf p) := sorry

theorem nnf_equiv {p : preform} : preform.equiv (nnf p) p := sorry

@[simp] def neg_elim_core : preform → preform := sorry

theorem neg_free_neg_elim_core (p : preform) : is_nnf p → preform.neg_free (neg_elim_core p) :=
  sorry

theorem le_and_le_iff_eq {α : Type} [partial_order α] {a : α} {b : α} : a ≤ b ∧ b ≤ a ↔ a = b :=
  sorry

theorem implies_neg_elim_core {p : preform} : preform.implies p (neg_elim_core p) := sorry

/-- Eliminate all negations in a preform -/
def neg_elim : preform → preform := neg_elim_core ∘ nnf

theorem neg_free_neg_elim {p : preform} : preform.neg_free (neg_elim p) :=
  neg_free_neg_elim_core (nnf p) (is_nnf_nnf p)

theorem implies_neg_elim {p : preform} : preform.implies p (neg_elim p) :=
  id
    fun (v : ℕ → ℕ) (h1 : preform.holds v p) =>
      implies_neg_elim_core v (iff.elim_right (nnf_equiv v) h1)

end Mathlib


/-
Copyright (c) 2022 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.fintype.basic
import model_theory.substructures

/-!
# Elementary Maps Between First-Order Structures

## Main Definitions
* A `first_order.language.elementary_embedding` is an embedding that commutes with the
  realizations of formulas.
* A `first_order.language.elementary_substructure` is a substructure where the realization of each
  formula agrees with the realization in the larger model.

## Main Results
* The Tarski-Vaught Test for embeddings: `first_order.language.embedding.is_elementary_of_exists`
gives a simple criterion for an embedding to be elementary.
* The Tarski-Vaught Test for substructures: `first_order.language.embedding.is_elementary_of_exists`
gives a simple criterion for a substructure to be elementary.
 -/

open_locale first_order
namespace first_order
namespace language
open Structure

variables (L : language) (M : Type*) (N : Type*) {P : Type*} {Q : Type*}
variables [L.Structure M] [L.Structure N] [L.Structure P] [L.Structure Q]

/-- An elementary embedding of first-order structures is an embedding that commutes with the
  realizations of formulas. -/
structure elementary_embedding :=
(to_fun : M → N)
(map_formula' : ∀{n} (φ : L.formula (fin n)) (x : fin n → M),
  φ.realize (to_fun ∘ x) ↔ φ.realize x . obviously)

localized "notation A ` ↪ₑ[`:25 L `] ` B := first_order.language.elementary_embedding L A B"
  in first_order

variables {L} {M} {N}

namespace elementary_embedding

instance fun_like : fun_like (M ↪ₑ[L] N) M (λ _, N) :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, begin
    cases f,
    cases g,
    simp only,
    ext x,
    exact function.funext_iff.1 h x end }

@[simp] lemma map_formula (f : M ↪ₑ[L] N) {α : Type} [fintype α] (φ : L.formula α) (x : α → M) :
  φ.realize (f ∘ x) ↔ φ.realize x :=
begin
  have g := fintype.equiv_fin α,
  have h := f.map_formula' (φ.relabel g) (x ∘ g.symm),
  rw [formula.realize_relabel, formula.realize_relabel, function.comp.assoc x g.symm g,
    g.symm_comp_self, function.comp.right_id] at h,
  rw [← h, iff_eq_eq],
  congr,
  ext y,
  simp,
end

@[simp] lemma injective (φ : M ↪ₑ[L] N) :
  function.injective φ :=
begin
  intros x y,
  have h := φ.map_formula ((var 0).equal (var 1) : L.formula (fin 2)) (λ i, if i = 0 then x else y),
  rw [formula.realize_equal, formula.realize_equal] at h,
  simp only [nat.one_ne_zero, term.realize, fin.one_eq_zero_iff, if_true, eq_self_iff_true,
    function.comp_app, if_false] at h,
  exact h.1,
end

instance embedding_like : embedding_like (M ↪ₑ[L] N) M N :=
{ injective' := injective }

instance has_coe_to_fun : has_coe_to_fun (M ↪ₑ[L] N) (λ _, M → N) :=
⟨λ f, f.to_fun⟩

@[simp] lemma map_fun (φ : M ↪ₑ[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) :=
begin
  have h := φ.map_formula (formula.graph f) (fin.cons (fun_map f x) x),
  rw [formula.realize_graph, fin.comp_cons, formula.realize_graph] at h,
  rw [eq_comm, h]
end

@[simp] lemma map_rel (φ : M ↪ₑ[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r (φ ∘ x) ↔ rel_map r x :=
begin
  have h := φ.map_formula (r.formula var) x,
  exact h
end

instance strong_hom_class : strong_hom_class L (M ↪ₑ[L] N) M N :=
{ map_fun := map_fun,
  map_rel := map_rel }

@[simp] lemma map_constants (φ : M ↪ₑ[L] N) (c : L.constants) : φ c = c :=
hom_class.map_constants φ c

/-- An elementary embedding is also a first-order embedding. -/
def to_embedding (f : M ↪ₑ[L] N) : M ↪[L] N :=
{ to_fun := f,
  inj' := f.injective, }

/-- An elementary embedding is also a first-order homomorphism. -/
def to_hom (f : M ↪ₑ[L] N) : M →[L] N :=
{ to_fun := f }

@[simp] lemma to_embedding_to_hom (f : M ↪ₑ[L] N) : f.to_embedding.to_hom = f.to_hom := rfl

@[simp]
lemma coe_to_hom {f : M ↪ₑ[L] N} : (f.to_hom : M → N) = (f : M → N) := rfl

@[simp] lemma coe_to_embedding (f : M ↪ₑ[L] N) : (f.to_embedding : M → N) = (f : M → N) := rfl

lemma coe_injective : @function.injective (M ↪ₑ[L] N) (M → N) coe_fn :=
fun_like.coe_injective

@[ext]
lemma ext ⦃f g : M ↪ₑ[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
fun_like.ext f g h

lemma ext_iff {f g : M ↪ₑ[L] N} : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

variables (L) (M)
/-- The identity elementary embedding from a structure to itself -/
@[refl] def refl : M ↪ₑ[L] M :=
{ to_fun := id }

variables {L} {M}

instance : inhabited (M ↪ₑ[L] M) := ⟨refl L M⟩

@[simp] lemma refl_apply (x : M) :
  refl L M x = x := rfl

/-- Composition of elementary embeddings -/
@[trans] def comp (hnp : N ↪ₑ[L] P) (hmn : M ↪ₑ[L] N) : M ↪ₑ[L] P :=
{ to_fun := hnp ∘ hmn }

@[simp] lemma comp_apply (g : N ↪ₑ[L] P) (f : M ↪ₑ[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of elementary embeddings is associative. -/
lemma comp_assoc (f : M ↪ₑ[L] N) (g : N ↪ₑ[L] P) (h : P ↪ₑ[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

end elementary_embedding

namespace embedding

/-- The Tarski-Vaught test for elementarity of an embedding. -/
theorem is_elementary_of_exists (f : M ↪[L] N)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → M) (a : N),
    φ.realize default (fin.snoc (f ∘ x) a : _ → N) →
    ∃ b : M, φ.realize default (fin.snoc (f ∘ x) (f b) : _ → N)) :
  ∀{n} (φ : L.formula (fin n)) (x : fin n → M), φ.realize (f ∘ x) ↔ φ.realize x :=
begin
  suffices h : ∀ (n : ℕ) (φ : L.bounded_formula empty n) (xs : fin n → M),
    φ.realize (f ∘ default) (f ∘ xs) ↔ φ.realize default xs,
  { intros n φ x,
    refine φ.realize_relabel_sum_inr.symm.trans (trans (h n _ _) φ.realize_relabel_sum_inr), },
  refine λ n φ, φ.rec_on _ _ _ _ _,
  { exact λ _ _, iff.rfl },
  { intros,
    simp [bounded_formula.realize, ← sum.comp_elim, embedding.realize_term] },
  { intros,
    simp [bounded_formula.realize, ← sum.comp_elim, embedding.realize_term] },
  { intros _ _ _ ih1 ih2 _,
    simp [ih1, ih2] },
  { intros n φ ih xs,
    simp only [bounded_formula.realize_all],
    refine ⟨λ h a, _, _⟩,
    { rw [← ih, fin.comp_snoc],
      exact h (f a) },
    { contrapose!,
      rintro ⟨a, ha⟩,
      obtain ⟨b, hb⟩ := htv n φ.not xs a _,
      { refine ⟨b, λ h, hb (eq.mp _ ((ih _).2 h))⟩,
        rw [unique.eq_default (f ∘ default), fin.comp_snoc], },
      { rw [bounded_formula.realize_not, ← unique.eq_default (f ∘ default)],
        exact ha } } },
end

/-- Bundles an embedding satisfying the Tarski-Vaught test as an elementary embedding. -/
@[simps] def to_elementary_embedding (f : M ↪[L] N)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → M) (a : N),
    φ.realize default (fin.snoc (f ∘ x) a : _ → N) →
    ∃ b : M, φ.realize default (fin.snoc (f ∘ x) (f b) : _ → N)) :
  M ↪ₑ[L] N :=
⟨f, λ _, f.is_elementary_of_exists htv⟩

end embedding

namespace equiv

/-- A first-order equivalence is also an elementary embedding. -/
def to_elementary_embedding (f : M ≃[L] N) : M ↪ₑ[L] N :=
{ to_fun := f }

@[simp] lemma to_elementary_embedding_to_embedding (f : M ≃[L] N) :
  f.to_elementary_embedding.to_embedding = f.to_embedding := rfl

@[simp] lemma coe_to_elementary_embedding (f : M ≃[L] N) :
  (f.to_elementary_embedding : M → N) = (f : M → N) := rfl

end equiv

@[simp] lemma realize_term_substructure {α : Type*} {S : L.substructure M} (v : α → S)
  (t : L.term α) :
  t.realize (coe ∘ v) = (↑(t.realize v) : M) :=
S.subtype.realize_term t

namespace substructure

@[simp]

@[simp] lemma realize_formula_top {α : Type*} {φ : L.formula α} {v : α → (⊤ : L.substructure M)} :
  φ.realize v ↔ φ.realize ((coe : (⊤ : L.substructure M) → M) ∘ v) :=
begin
  rw ← substructure.top_equiv.realize_formula φ,
  simp,
end

/-- A substructure is elementary when every formula applied to a tuple in the subtructure
  agrees with its value in the overall structure. -/
def is_elementary (S : L.substructure M) : Prop :=
∀{n} (φ : L.formula (fin n)) (x : fin n → S), φ.realize ((coe : _ → M) ∘ x) ↔ φ.realize x

end substructure

variables (L) (M)
/-- An elementary substructure is one in which every formula applied to a tuple in the subtructure
  agrees with its value in the overall structure. -/
structure elementary_substructure :=
(to_substructure : L.substructure M)
(is_elementary' : to_substructure.is_elementary)

variables {L} {M}

namespace elementary_substructure

instance : has_coe (L.elementary_substructure M) (L.substructure M) :=
⟨elementary_substructure.to_substructure⟩

instance : set_like (L.elementary_substructure M) M :=
⟨λ x, x.to_substructure.carrier, λ ⟨⟨s, hs1⟩, hs2⟩ ⟨⟨t, ht1⟩, ht2⟩ h, begin
  congr,
  exact h,
end⟩

@[simp] lemma is_elementary (S : L.elementary_substructure M) :
  (S : L.substructure M).is_elementary := S.is_elementary'

/-- The natural embedding of an `L.substructure` of `M` into `M`. -/
def subtype (S : L.elementary_substructure M) : S ↪ₑ[L] M :=
{ to_fun := coe,
  map_formula' := λ n, S.is_elementary }

@[simp] theorem coe_subtype {S : L.elementary_substructure M} : ⇑S.subtype = coe := rfl

/-- The substructure `M` of the structure `M` is elementary. -/
instance : has_top (L.elementary_substructure M) :=
⟨⟨⊤, λ n φ x, substructure.realize_formula_top.symm⟩⟩

instance : inhabited (L.elementary_substructure M) := ⟨⊤⟩

@[simp] lemma mem_top (x : M) : x ∈ (⊤ : L.elementary_substructure M) := set.mem_univ x

@[simp] lemma coe_top : ((⊤ : L.elementary_substructure M) : set M) = set.univ := rfl

@[simp] lemma realize_sentence (S : L.elementary_substructure M) (φ : L.sentence)  :
  S ⊨ φ ↔ M ⊨ φ :=
begin
  have h := S.is_elementary (φ.relabel (empty.elim : empty → fin 0)) default,
  rw [formula.realize_relabel, formula.realize_relabel] at h,
  exact (congr (congr rfl (congr rfl (unique.eq_default _))) (congr rfl (unique.eq_default _))).mp
    h.symm,
end

@[simp] lemma Theory_model_iff (S : L.elementary_substructure M) (T : L.Theory) :
  S ⊨ T ↔ M ⊨ T :=
by simp only [Theory.model_iff, realize_sentence]

instance Theory_model {T : L.Theory} [h : M ⊨ T] {S : L.elementary_substructure M} : S ⊨ T :=
(Theory_model_iff S T).2 h

instance [h : nonempty M] {S : L.elementary_substructure M} : nonempty S :=
(Theory.model_nonempty_iff L).1 infer_instance

end elementary_substructure

namespace substructure

/-- The Tarski-Vaught test for elementarity of a substructure. -/
theorem is_elementary_of_exists (S : L.substructure M)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → S) (a : M),
    φ.realize default (fin.snoc (coe ∘ x) a : _ → M) →
    ∃ b : S, φ.realize default (fin.snoc (coe ∘ x) b : _ → M)) :
  S.is_elementary :=
λ n, S.subtype.is_elementary_of_exists htv

/-- Bundles a substructure satisfying the Tarski-Vaught test as an elementary substructure. -/
@[simps] def to_elementary_substructure (S : L.substructure M)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → S) (a : M),
    φ.realize default (fin.snoc (coe ∘ x) a : _ → M) →
    ∃ b : S, φ.realize default (fin.snoc (coe ∘ x) b : _ → M)) :
  L.elementary_substructure M :=
⟨S, λ _, S.is_elementary_of_exists htv⟩

end substructure

end language
end first_order