/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.rbtree.find
universes u v

local attribute [simp] rbnode.lift

namespace rbnode
variables {α : Type u}

open color

@[simp] lemma balance1_eq₁ (l : rbnode α) (x r₁ y r₂ v t) :
  balance1 (red_node l x r₁) y r₂ v t = red_node (black_node l x r₁) y (black_node r₂ v t) :=
begin cases r₂; refl end

@[simp] lemma balance1_eq₂ (l₁ : rbnode α) (y l₂ x r v t) : get_color l₁ ≠ red →
  balance1 l₁ y (red_node l₂ x r)  v t = red_node (black_node l₁ y l₂) x (black_node r v t) :=
begin cases l₁; simp [get_color, balance1, false_implies_iff] end

@[simp] lemma balance1_eq₃ (l : rbnode α) (y r v t) : get_color l ≠ red → get_color r ≠ red →
  balance1 l y r v t = black_node (red_node l y r) v t :=
begin cases l; cases r; simp [get_color, balance1, false_implies_iff] end

@[simp] lemma balance2_eq₁ (l : rbnode α) (x₁ r₁ y r₂ v t) :
  balance2 (red_node l x₁ r₁) y r₂ v t = red_node (black_node t v l) x₁ (black_node r₁ y r₂) :=
by cases r₂; refl

@[simp] lemma balance2_eq₂ (l₁ : rbnode α) (y l₂ x₂ r₂ v t) : get_color l₁ ≠ red →
  balance2 l₁ y (red_node l₂ x₂ r₂) v t = red_node (black_node t v l₁) y (black_node l₂ x₂ r₂) :=
begin cases l₁; simp [get_color, balance2, false_implies_iff] end

@[simp] lemma balance2_eq₃ (l : rbnode α) (y r v t) : get_color l ≠ red → get_color r ≠ red →
  balance2 l  y r  v t = black_node t v (red_node l y r) :=
begin cases l; cases r; simp [get_color, balance2, false_implies_iff] end

/- We can use the same induction principle for balance1 and balance2 -/
lemma balance.cases {p : rbnode α → α → rbnode α → Prop}
  (l y r)
  (red_left : ∀ l x r₁ y r₂, p (red_node l x r₁) y r₂)
  (red_right : ∀ l₁ y l₂ x r, get_color l₁ ≠ red → p l₁ y (red_node l₂ x r))
  (other : ∀ l y r, get_color l ≠ red → get_color r ≠ red → p l y r)
  : p l y r :=
begin
  cases l; cases r,
  any_goals { apply red_left },
  any_goals { apply red_right; simp [get_color]; contradiction; done },
  any_goals { apply other; simp [get_color]; contradiction; done },
end

lemma balance1_ne_leaf (l : rbnode α) (x r v t) : balance1 l x r v t ≠ leaf :=
by apply balance.cases l x r; intros; simp [*]; contradiction

lemma balance1_node_ne_leaf {s : rbnode α} (a : α) (t : rbnode α) :
  s ≠ leaf → balance1_node s a t ≠ leaf :=
begin
  intro h, cases s,
  { contradiction },
  all_goals { simp [balance1_node], apply balance1_ne_leaf }
end

lemma balance2_ne_leaf (l : rbnode α) (x r v t) : balance2 l x r v t ≠ leaf :=
by apply balance.cases l x r; intros; simp [*]; contradiction

lemma balance2_node_ne_leaf {s : rbnode α} (a : α) (t : rbnode α) : s ≠ leaf →
  balance2_node s a t ≠ leaf :=
begin
  intro h, cases s,
  { contradiction },
  all_goals { simp [balance2_node], apply balance2_ne_leaf }
end

variables (lt : α → α → Prop)

@[elab_as_eliminator]
lemma ins.induction [decidable_rel lt] {p : rbnode α → Prop}
  (t x)
  (is_leaf : p leaf)
  (is_red_lt : ∀ a y b (hc : cmp_using lt x y = ordering.lt) (ih : p a), p (red_node a y b))
  (is_red_eq : ∀ a y b (hc : cmp_using lt x y = ordering.eq), p (red_node a y b))
  (is_red_gt : ∀ a y b (hc : cmp_using lt x y = ordering.gt) (ih : p b), p (red_node a y b))
  (is_black_lt_red : ∀ a y b (hc : cmp_using lt x y = ordering.lt) (hr : get_color a = red)
    (ih : p a), p (black_node a y b))
  (is_black_lt_not_red : ∀ a y b (hc : cmp_using lt x y = ordering.lt) (hnr : get_color a ≠ red)
    (ih : p a), p (black_node a y b))
  (is_black_eq : ∀ a y b (hc : cmp_using lt x y = ordering.eq), p (black_node a y b))
  (is_black_gt_red : ∀ a y b (hc : cmp_using lt x y = ordering.gt) (hr : get_color b = red)
    (ih : p b), p (black_node a y b))
  (is_black_gt_not_red : ∀ a y b (hc : cmp_using lt x y = ordering.gt) (hnr : get_color b ≠ red)
    (ih : p b), p (black_node a y b))
  : p t :=
begin
  induction t,
  case leaf { apply is_leaf },
  case red_node : a y b
   { cases h : cmp_using lt x y,
     case ordering.lt { apply is_red_lt; assumption },
     case ordering.eq { apply is_red_eq; assumption },
     case ordering.gt { apply is_red_gt; assumption }, },
  case black_node : a y b
  { cases h : cmp_using lt x y,
    case ordering.lt
    { by_cases get_color a = red,
      { apply is_black_lt_red; assumption },
      { apply is_black_lt_not_red; assumption }, },
    case ordering.eq { apply is_black_eq; assumption },
    case ordering.gt
    { by_cases get_color b = red,
      { apply is_black_gt_red; assumption },
      { apply is_black_gt_not_red; assumption }, } }
end

lemma is_searchable_balance1 {l y r v t lo hi} : is_searchable lt l lo (some y) →
  is_searchable lt r (some y) (some v) → is_searchable lt t (some v) hi →
    is_searchable lt (balance1 l y r v t) lo hi :=
by apply balance.cases l y r; intros; simp [*]; is_searchable_tactic

lemma is_searchable_balance1_node {t} [is_trans α lt] :
  ∀ {y s lo hi}, is_searchable lt t lo (some y) → is_searchable lt s (some y) hi →
    is_searchable lt (balance1_node t y s) lo hi :=
begin
  cases t; simp!; intros; is_searchable_tactic,
  { cases lo,
    { apply is_searchable_none_low_of_is_searchable_some_low, assumption },
    { simp at *, apply is_searchable_some_low_of_is_searchable_of_lt; assumption } },
  all_goals { apply is_searchable_balance1; assumption }
end

lemma is_searchable_balance2 {l y r v t lo hi} :
  is_searchable lt t lo (some v) → is_searchable lt l (some v) (some y) →
    is_searchable lt r (some y) hi → is_searchable lt (balance2 l y r v t) lo hi :=
by apply balance.cases l y r; intros; simp [*]; is_searchable_tactic

lemma is_searchable_balance2_node {t} [is_trans α lt] :
  ∀ {y s lo hi}, is_searchable lt s lo (some y) → is_searchable lt t (some y) hi →
    is_searchable lt (balance2_node t y s) lo hi :=
begin
  induction t; simp!; intros; is_searchable_tactic,
  { cases hi,
    { apply is_searchable_none_high_of_is_searchable_some_high, assumption },
    { simp at *, apply is_searchable_some_high_of_is_searchable_of_lt, assumption' } },
  all_goals { apply is_searchable_balance2, assumption' }
end

lemma is_searchable_ins [decidable_rel lt] {t x} [is_strict_weak_order α lt] :
  ∀ {lo hi} (h : is_searchable lt t lo hi), lift lt lo (some x) → lift lt (some x) hi →
    is_searchable lt (ins lt t x) lo hi :=
begin
  apply ins.induction lt t x; intros; simp! [*] at * {eta := ff};
    is_searchable_tactic,
  { apply ih h_hs₁, assumption, simp [*] },
  { apply is_searchable_of_is_searchable_of_incomp hc, assumption },
  { apply is_searchable_of_incomp_of_is_searchable hc, assumption },
  { apply ih h_hs₂, cases hi; simp [*], assumption },
  { apply is_searchable_balance1_node, apply ih h_hs₁, assumption, simp [*],
    assumption },
  { apply ih h_hs₁, assumption, simp [*] },
  { apply is_searchable_of_is_searchable_of_incomp hc, assumption },
  { apply is_searchable_of_incomp_of_is_searchable hc, assumption },
  { apply is_searchable_balance2_node, assumption, apply ih h_hs₂, simp [*],
    assumption },
  { apply ih h_hs₂, assumption, simp [*] }
end

lemma is_searchable_mk_insert_result {c t} : is_searchable lt t none none →
  is_searchable lt (mk_insert_result c t) none none :=
begin
  classical,
  cases c; cases t; simp [mk_insert_result],
  { intro h, is_searchable_tactic }
end

lemma is_searchable_insert [decidable_rel lt] {t x} [is_strict_weak_order α lt] :
  is_searchable lt t none none → is_searchable lt (insert lt t x) none none :=
begin
  intro h, simp [insert], apply is_searchable_mk_insert_result, apply is_searchable_ins;
    { assumption <|> simp }
end

end rbnode

namespace rbnode
section membership_lemmas
parameters {α : Type u} (lt : α → α → Prop)

local attribute [simp] mem balance1_node balance2_node

local infix (name := mem) ` ∈ ` := mem lt

lemma mem_balance1_node_of_mem_left {x s} (v) (t : rbnode α) : x ∈ s → x ∈ balance1_node s v t :=
begin
  cases s; simp [false_implies_iff],
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp at *; blast_disjs;
    simp [*] }
end

lemma mem_balance2_node_of_mem_left {x s} (v) (t : rbnode α) : x ∈ s → x ∈ balance2_node s v t :=
begin
  cases s; simp [false_implies_iff],
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp at *; blast_disjs;
    simp [*] }
end

lemma mem_balance1_node_of_mem_right {x t} (v) (s : rbnode α) : x ∈ t → x ∈ balance1_node s v t :=
begin
  intros, cases s; simp [*],
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] }
end

lemma mem_balance2_node_of_mem_right {x t} (v) (s : rbnode α) : x ∈ t → x ∈ balance2_node s v t :=
begin
  intros, cases s; simp [*],
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] }
end

lemma mem_balance1_node_of_incomp {x v} (s t) : (¬ lt x v ∧ ¬ lt v x) → s ≠ leaf →
  x ∈ balance1_node s v t :=
begin
  intros, cases s; simp,
  { contradiction },
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] }
end

lemma mem_balance2_node_of_incomp {x v} (s t) : (¬ lt v x ∧ ¬ lt x v) → s ≠ leaf →
  x ∈ balance2_node s v t :=
begin
  intros, cases s; simp,
  { contradiction },
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] }
end

lemma ins_ne_leaf [decidable_rel lt] (t : rbnode α) (x : α) : t.ins lt x ≠ leaf :=
begin
  apply ins.induction lt t x,
  any_goals { intros, simp [ins, *] },
  { intros, apply balance1_node_ne_leaf, assumption },
  { intros, apply balance2_node_ne_leaf, assumption },
end

lemma insert_ne_leaf [decidable_rel lt] (t : rbnode α) (x : α) : insert lt t x ≠ leaf :=
begin
  simp [insert],
  cases he : ins lt t x; cases get_color t; simp [mk_insert_result],
  { have := ins_ne_leaf lt t x, contradiction },
  { exact absurd he (ins_ne_leaf _ _ _) }
end

lemma mem_ins_of_incomp [decidable_rel lt] (t : rbnode α) {x y : α} :
  ∀ h : ¬ lt x y ∧ ¬ lt y x, x ∈ t.ins lt y :=
begin
  apply ins.induction lt t y; intros; simp [ins, *],
  { have := ih h, apply mem_balance1_node_of_mem_left, assumption },
  { have := ih h, apply mem_balance2_node_of_mem_left, assumption }
end

lemma mem_ins_of_mem [decidable_rel lt] [is_strict_weak_order α lt] {t : rbnode α} (z : α) :
  ∀ {x} (h : x ∈ t), x ∈ t.ins lt z :=
begin
  apply ins.induction lt t z; intros; simp [ins, *] at *; try { contradiction };
    blast_disjs,
  any_goals { intros, simp [h], done },
  any_goals { intros, simp [ih h], done },
  { have := incomp_trans_of lt h ⟨hc.2, hc.1⟩, simp [this] },
  { apply mem_balance1_node_of_mem_left, apply ih h },
  { apply mem_balance1_node_of_incomp, cases h, all_goals { simp [*, ins_ne_leaf lt a z] } },
  { apply mem_balance1_node_of_mem_right, assumption },
  { have := incomp_trans_of lt hc ⟨h.2, h.1⟩, simp [this] },
  { apply mem_balance2_node_of_mem_right, assumption },
  { have := ins_ne_leaf lt a z, apply mem_balance2_node_of_incomp, cases h, simp [*],
      apply ins_ne_leaf },
  { apply mem_balance2_node_of_mem_left, apply ih h },
end

lemma mem_mk_insert_result {a t} (c) : mem lt a t → mem lt a (mk_insert_result c t) :=
by intros; cases c; cases t; simp [mk_insert_result, mem, *] at *

lemma mem_of_mem_mk_insert_result {a t c} : mem lt a (mk_insert_result c t) → mem lt a t :=
by cases t; cases c; simp [mk_insert_result, mem]; intros; assumption

lemma mem_insert_of_incomp [decidable_rel lt] (t : rbnode α) {x y : α} :
  ∀ h : ¬ lt x y ∧ ¬ lt y x, x ∈ t.insert lt y :=
by intros; unfold insert; apply mem_mk_insert_result; apply mem_ins_of_incomp; assumption

lemma mem_insert_of_mem [decidable_rel lt] [is_strict_weak_order α lt] {t x} (z) :
  x ∈ t → x ∈ t.insert lt z :=
by intros; apply mem_mk_insert_result; apply mem_ins_of_mem; assumption

lemma of_mem_balance1_node {x s v t} :
  x ∈ balance1_node s v t → x ∈ s ∨ (¬ lt x v ∧ ¬ lt v x) ∨ x ∈ t :=
begin
  cases s; simp,
  { intros, simp [*] },
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] at *; blast_disjs;
    simp [*] }
end

lemma of_mem_balance2_node {x s v t} :
  x ∈ balance2_node s v t → x ∈ s ∨ (¬ lt x v ∧ ¬ lt v x) ∨ x ∈ t :=
begin
  cases s; simp,
  { intros, simp [*] },
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] at *; blast_disjs;
    simp [*] }
end

lemma equiv_or_mem_of_mem_ins [decidable_rel lt] {t : rbnode α} {x z} :
  ∀ (h : x ∈ t.ins lt z), x ≈[lt] z ∨ x ∈ t :=
begin
  apply ins.induction lt t z; intros; simp [ins, strict_weak_order.equiv, *] at *;
    blast_disjs,
  any_goals { intros, simp [h] },
  any_goals { intros, have ih := ih h, cases ih; simp [*], done },
  { have h' := of_mem_balance1_node lt h, blast_disjs,
    have := ih h', blast_disjs,
    all_goals { simp [h, *] } },
  { have h' := of_mem_balance2_node lt h, blast_disjs,
    have := ih h', blast_disjs,
    all_goals { simp [h, *] }},
end

lemma equiv_or_mem_of_mem_insert [decidable_rel lt] {t : rbnode α} {x z} :
  ∀ (h : x ∈ t.insert lt z), x ≈[lt] z ∨ x ∈ t :=
begin
  simp [insert], intros, apply equiv_or_mem_of_mem_ins, exact mem_of_mem_mk_insert_result lt h
end

local attribute [simp] mem_exact

lemma mem_exact_balance1_node_of_mem_exact {x s} (v) (t : rbnode α) :
  mem_exact x s → mem_exact x (balance1_node s v t) :=
begin
  cases s; simp [false_implies_iff],
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] at *; blast_disjs;
    simp [*] }
end

lemma mem_exact_balance2_node_of_mem_exact {x s} (v) (t : rbnode α) :
  mem_exact x s → mem_exact x (balance2_node s v t) :=
begin
  cases s; simp [false_implies_iff],
  all_goals { apply balance.cases s_lchild s_val s_rchild; intros; simp [*] at *; blast_disjs;
    simp [*] }
end

lemma find_balance1_node [decidable_rel lt] [is_strict_weak_order α lt] {x y z t s} :
  ∀ {lo hi}, is_searchable lt t lo (some z) → is_searchable lt s (some z) hi →
    find lt t y = some x → y ≈[lt] x → find lt (balance1_node t z s) y = some x :=
begin
  intros _ _ hs₁ hs₂ heq heqv,
  have hs := is_searchable_balance1_node lt hs₁ hs₂,
  have := eq.trans (find_eq_find_of_eqv hs₁ heqv.symm) heq,
  have := iff.mpr (find_correct_exact hs₁) this,
  have := mem_exact_balance1_node_of_mem_exact z s this,
  have := iff.mp (find_correct_exact hs) this,
  exact eq.trans (find_eq_find_of_eqv hs heqv) this
end

lemma find_balance2_node [decidable_rel lt] [is_strict_weak_order α lt] {x y z s t}
  [is_trans α lt] :
  ∀ {lo hi}, is_searchable lt s lo (some z) → is_searchable lt t (some z) hi →
    find lt t y = some x → y ≈[lt] x → find lt (balance2_node t z s) y = some x :=
begin
  intros _ _ hs₁ hs₂ heq heqv,
  have hs := is_searchable_balance2_node lt hs₁ hs₂,
  have := eq.trans (find_eq_find_of_eqv hs₂ heqv.symm) heq,
  have := iff.mpr (find_correct_exact hs₂) this,
  have := mem_exact_balance2_node_of_mem_exact z s this,
  have := iff.mp (find_correct_exact hs) this,
  exact eq.trans (find_eq_find_of_eqv hs heqv) this
end

/- Auxiliary lemma -/

lemma ite_eq_of_not_lt [decidable_rel lt] [is_strict_order α lt] {a b} {β : Type v}
  (t s : β) (h : lt b a) :
  (if lt a b then t else s) = s :=
begin have := not_lt_of_lt h, simp [*] end

local attribute [simp] ite_eq_of_not_lt

private meta def simp_fi : tactic unit :=
`[simp [find, ins, *, cmp_using]]

lemma find_ins_of_eqv [decidable_rel lt] [is_strict_weak_order α lt] {x y : α} {t : rbnode α}
  (he : x ≈[lt] y) :
  ∀ {lo hi} (hs : is_searchable lt t lo hi) (hlt₁ : lift lt lo (some x))
    (hlt₂ : lift lt (some x) hi), find lt (ins lt t x) y = some x :=
begin
  simp [strict_weak_order.equiv] at he,
  apply ins.induction lt t x; intros,
  { simp_fi },
  all_goals { simp at hc, cases hs },
  { have := lt_of_incomp_of_lt he.swap hc,
    have := ih hs_hs₁ hlt₁ hc,
    simp_fi },
  { simp_fi },
  { have := lt_of_lt_of_incomp hc he,
    have := ih hs_hs₂ hc hlt₂,
    simp_fi },
  { simp_fi,
    have := is_searchable_ins lt hs_hs₁ hlt₁ hc,
    apply find_balance1_node lt this hs_hs₂ (ih hs_hs₁ hlt₁ hc) he.symm },
  { have := lt_of_incomp_of_lt he.swap hc,
    have := ih hs_hs₁ hlt₁ hc,
    simp_fi },
  { simp_fi },
  { simp_fi,
    have := is_searchable_ins lt hs_hs₂ hc hlt₂,
    apply find_balance2_node lt hs_hs₁ this (ih hs_hs₂ hc hlt₂) he.symm },
  { have := lt_of_lt_of_incomp hc he,
    have := ih hs_hs₂ hc hlt₂,
    simp_fi }
end

lemma find_mk_insert_result [decidable_rel lt] (c : color) (t : rbnode α) (x : α) :
  find lt (mk_insert_result c t) x = find lt t x :=
begin
  cases t; cases c; simp [mk_insert_result],
  { simp [find], cases cmp_using lt x t_val; simp [find] }
end

lemma find_insert_of_eqv [decidable_rel lt] [is_strict_weak_order α lt] {x y : α}
  {t : rbnode α} (he : x ≈[lt] y) :
  is_searchable lt t none none → find lt (insert lt t x) y = some x :=
begin
  intro hs,
  simp [insert, find_mk_insert_result],
  apply find_ins_of_eqv lt he hs; simp
end

lemma weak_trichotomous (x y) {p : Prop} (is_lt : ∀ h : lt x y, p)
  (is_eqv : ∀ h : ¬ lt x y ∧ ¬ lt y x, p) (is_gt : ∀ h : lt y x, p) : p :=
begin
  by_cases lt x y,
  { apply is_lt, assumption },
  by_cases lt y x,
  { apply is_gt, assumption },
  { apply is_eqv, constructor; assumption }
end

section find_ins_of_not_eqv

section simp_aux_lemmas

lemma find_black_eq_find_red [decidable_rel lt] {l y r x} :
  find lt (black_node l y r) x = find lt (red_node l y r) x :=
begin simp [find], all_goals { cases cmp_using lt x y; simp [find] } end

lemma find_red_of_lt [decidable_rel lt] {l y r x} (h : lt x y) :
  find lt (red_node l y r) x = find lt l x :=
by simp [find, cmp_using, *]

lemma find_red_of_gt [decidable_rel lt] [is_strict_order α lt] {l y r x} (h : lt y x) :
  find lt (red_node l y r) x = find lt r x :=
begin have := not_lt_of_lt h, simp [find, cmp_using, *]  end

lemma find_red_of_incomp [decidable_rel lt] {l y r x} (h : ¬ lt x y ∧ ¬ lt y x) :
  find lt (red_node l y r) x = some y :=
by simp [find, cmp_using, *]

end simp_aux_lemmas

local attribute [simp]
  find_black_eq_find_red find_red_of_lt find_red_of_lt find_red_of_gt
  find_red_of_incomp

variables [is_strict_weak_order α lt] [decidable_rel lt]

lemma find_balance1_lt {l r t v x y lo hi}
                       (h : lt x y)
                       (hl : is_searchable lt l lo (some v))
                       (hr : is_searchable lt r (some v) (some y))
                       (ht : is_searchable lt t (some y) hi)
                       : find lt (balance1 l v r y t) x = find lt (red_node l v r) x :=
begin
  revert hl hr ht, apply balance.cases l v r; intros; simp [*]; is_searchable_tactic,
  { apply weak_trichotomous lt y_1 x; intros; simp [*] },
  { apply weak_trichotomous lt x_1 x; intro h',
    { have := trans_of lt (lo_lt_hi hr_hs₁) h', simp [*] },
    { have : lt y_1 x := lt_of_lt_of_incomp (lo_lt_hi hr_hs₁) h', simp [*] },
    { apply weak_trichotomous lt y_1 x; intros; simp [*] } }
end

meta def ins_ne_leaf_tac := `[apply ins_ne_leaf]

lemma find_balance1_node_lt {t s x y lo hi} (hlt : lt y x)
                            (ht : is_searchable lt t lo (some x))
                            (hs : is_searchable lt s (some x) hi)
                            (hne : t ≠ leaf . ins_ne_leaf_tac)
                            : find lt (balance1_node t x s) y = find lt t y :=
begin
  cases t; simp [balance1_node],
  { contradiction },
  all_goals { intros, is_searchable_tactic, apply find_balance1_lt, assumption' }
end

lemma find_balance1_gt {l r t v x y lo hi}
                       (h : lt y x)
                       (hl : is_searchable lt l lo (some v))
                       (hr : is_searchable lt r (some v) (some y))
                       (ht : is_searchable lt t (some y) hi)
                       : find lt (balance1 l v r y t) x = find lt t x :=
begin
  revert hl hr ht, apply balance.cases l v r; intros; simp [*]; is_searchable_tactic,
  { have := trans_of lt (lo_lt_hi hr) h, simp [*] },
  { have := trans_of lt (lo_lt_hi hr_hs₂) h, simp [*] }
end

lemma find_balance1_node_gt {t s x y lo hi} (h : lt x y)
                            (ht : is_searchable lt t lo (some x))
                            (hs : is_searchable lt s (some x) hi)
                            (hne : t ≠ leaf . ins_ne_leaf_tac)
                            : find lt (balance1_node t x s) y = find lt s y :=
begin
  cases t; simp [balance1_node],
  all_goals { intros, is_searchable_tactic, apply find_balance1_gt, assumption' }
end

lemma find_balance1_eqv {l r t v x y lo hi}
                        (h : ¬ lt x y ∧ ¬ lt y x)
                        (hl : is_searchable lt l lo (some v))
                        (hr : is_searchable lt r (some v) (some y))
                        (ht : is_searchable lt t (some y) hi)
                        : find lt (balance1 l v r y t) x = some y :=
begin
  revert hl hr ht, apply balance.cases l v r; intros; simp [*]; is_searchable_tactic,
  { have : lt y_1 x := lt_of_lt_of_incomp (lo_lt_hi hr) h.swap,
    simp [*] },
  { have : lt x_1 x := lt_of_lt_of_incomp (lo_lt_hi hr_hs₂) h.swap,
    simp [*] }
end

lemma find_balance1_node_eqv {t s x y lo hi}
                             (h : ¬ lt x y ∧ ¬ lt y x)
                             (ht : is_searchable lt t lo (some y))
                             (hs : is_searchable lt s (some y) hi)
                             (hne : t ≠ leaf . ins_ne_leaf_tac)
                             : find lt (balance1_node t y s) x = some y :=
begin
  cases t; simp [balance1_node],
  { contradiction },
  all_goals { intros, is_searchable_tactic, apply find_balance1_eqv, assumption' }
end

lemma find_balance2_lt {l v r t x y lo hi}
                       (h :  lt x y)
                       (hl : is_searchable lt l (some y) (some v))
                       (hr : is_searchable lt r (some v) hi)
                       (ht : is_searchable lt t lo (some y))
                       : find lt (balance2 l v r y t) x = find lt t x :=
begin
  revert hl hr ht, apply balance.cases l v r; intros; simp [*]; is_searchable_tactic,
  { have := trans h (lo_lt_hi hl_hs₁), simp [*] },
  { have := trans h (lo_lt_hi hl), simp [*] }
end

lemma find_balance2_node_lt {s t x y lo hi}
                            (h : lt x y)
                            (ht : is_searchable lt t (some y) hi)
                            (hs : is_searchable lt s lo (some y))
                            (hne : t ≠ leaf . ins_ne_leaf_tac)
                            : find lt (balance2_node t y s) x = find lt s x :=
begin
  cases t; simp [balance2_node],
  all_goals { intros, is_searchable_tactic, apply find_balance2_lt, assumption' }
end

lemma find_balance2_gt {l v r t x y lo hi}
                       (h :  lt y x)
                       (hl : is_searchable lt l (some y) (some v))
                       (hr : is_searchable lt r (some v) hi)
                       (ht : is_searchable lt t lo (some y))
                       : find lt (balance2 l v r y t) x = find lt (red_node l v r) x :=
begin
  revert hl hr ht, apply balance.cases l v r; intros; simp [*]; is_searchable_tactic,
  { apply weak_trichotomous lt x_1 x; intro h'; simp [*],
    { apply weak_trichotomous lt y_1 x; intros; simp [*] },
    { have : lt x _ := lt_of_incomp_of_lt h'.swap (lo_lt_hi hl_hs₂), simp [*] },
    { have := trans h' (lo_lt_hi hl_hs₂), simp [*] } },
  { apply weak_trichotomous lt y_1 x; intros; simp [*] }
end

lemma find_balance2_node_gt {s t x y lo hi}
                            (h : lt y x)
                            (ht : is_searchable lt t (some y) hi)
                            (hs : is_searchable lt s lo (some y))
                            (hne : t ≠ leaf . ins_ne_leaf_tac)
                            : find lt (balance2_node t y s) x = find lt t x :=
begin
  cases t; simp [balance2_node],
  { contradiction },
  all_goals { intros, is_searchable_tactic, apply find_balance2_gt, assumption' }
end

lemma find_balance2_eqv {l v r t x y lo hi}
                        (h : ¬ lt x y ∧ ¬ lt y x)
                        (hl : is_searchable lt l (some y) (some v))
                        (hr : is_searchable lt r (some v) hi)
                        (ht : is_searchable lt t lo (some y))
                        : find lt (balance2 l v r y t) x = some y :=
begin
  revert hl hr ht, apply balance.cases l v r; intros; simp [*]; is_searchable_tactic,
  { have := lt_of_incomp_of_lt h (lo_lt_hi hl_hs₁), simp [*] },
  { have := lt_of_incomp_of_lt h (lo_lt_hi hl), simp [*] }
end

lemma find_balance2_node_eqv {t s x y lo hi}
                             (h : ¬ lt x y ∧ ¬ lt y x)
                             (ht : is_searchable lt t (some y) hi)
                             (hs : is_searchable lt s lo (some y))
                             (hne : t ≠ leaf . ins_ne_leaf_tac)
                             : find lt (balance2_node t y s) x = some y :=
begin
  cases t; simp [balance2_node],
  { contradiction },
  all_goals { intros, is_searchable_tactic, apply find_balance2_eqv, assumption' }
end

lemma find_ins_of_disj {x y : α} {t : rbnode α} (hn : lt x y ∨ lt y x)
                       : ∀ {lo hi}
                           (hs : is_searchable lt t lo hi)
                           (hlt₁ : lift lt lo (some x))
                           (hlt₂ : lift lt (some x) hi),
                           find lt (ins lt t x) y = find lt t y :=
begin
  apply ins.induction lt t x; intros,
  { cases hn,
    all_goals { simp [find, ins, cmp_using, *] } },
  all_goals { simp at hc, cases hs },
  { have := ih hs_hs₁ hlt₁ hc, simp_fi },
  { cases hn,
    { have := lt_of_incomp_of_lt hc.symm hn,
      simp_fi },
    { have := lt_of_lt_of_incomp hn hc,
      simp_fi } },
  { have := ih hs_hs₂ hc hlt₂,
    simp_fi },
  { have ih := ih hs_hs₁ hlt₁ hc,
    cases hn,
    { cases hc' : cmp_using lt y y_1; simp at hc',
      { have hsi := is_searchable_ins lt hs_hs₁ hlt₁ (trans_of lt hn hc'),
        have := find_balance1_node_lt lt hc' hsi hs_hs₂,
        simp_fi },
      { have hlt := lt_of_lt_of_incomp hn hc',
        have hsi := is_searchable_ins lt hs_hs₁ hlt₁ hlt,
        have := find_balance1_node_eqv lt hc' hsi hs_hs₂,
        simp_fi },
      { have hsi := is_searchable_ins lt hs_hs₁ hlt₁ hc,
        have := find_balance1_node_gt lt hc' hsi hs_hs₂,
        simp [*], simp_fi } },
    { have hlt := trans hn hc,
      have hsi := is_searchable_ins lt hs_hs₁ hlt₁ hc,
      have := find_balance1_node_lt lt hlt hsi hs_hs₂,
      simp_fi } },
  { have := ih hs_hs₁ hlt₁ hc, simp_fi },
  { cases hn,
    { have := lt_of_incomp_of_lt hc.swap hn, simp_fi },
    { have := lt_of_lt_of_incomp hn hc, simp_fi } },
  { have ih := ih hs_hs₂ hc hlt₂,
    cases hn,
    { have hlt := trans hc hn, simp_fi,
      have hsi := is_searchable_ins lt hs_hs₂ hc hlt₂,
      have := find_balance2_node_gt lt hlt hsi hs_hs₁,
      simp_fi },
    { simp_fi,
      cases hc' : cmp_using lt y y_1; simp at hc',
      { have hsi := is_searchable_ins lt hs_hs₂ hc hlt₂,
        have := find_balance2_node_lt lt hc' hsi hs_hs₁,
        simp_fi },
      { have hlt := lt_of_incomp_of_lt hc'.swap hn,
        have hsi := is_searchable_ins lt hs_hs₂ hlt hlt₂,
        have := find_balance2_node_eqv lt hc' hsi hs_hs₁,
        simp_fi },
      { have hsi := is_searchable_ins lt hs_hs₂ hc hlt₂,
        have := find_balance2_node_gt lt hc' hsi hs_hs₁,
        simp_fi } } },
  { have ih := ih hs_hs₂ hc hlt₂,
    simp_fi }
end

end find_ins_of_not_eqv

lemma find_insert_of_disj [decidable_rel lt] [is_strict_weak_order α lt] {x y : α} {t : rbnode α}
  (hd : lt x y ∨ lt y x) : is_searchable lt t none none → find lt (insert lt t x) y = find lt t y :=
begin
  intro hs,
  simp [insert, find_mk_insert_result],
  apply find_ins_of_disj lt hd hs; simp
end

lemma find_insert_of_not_eqv [decidable_rel lt] [is_strict_weak_order α lt] {x y : α} {t : rbnode α}
  (hn : ¬ x ≈[lt] y) : is_searchable lt t none none → find lt (insert lt t x) y = find lt t y :=
begin
  intro hs,
  simp [insert, find_mk_insert_result],
  have he : lt x y ∨ lt y x,
  { simp [strict_weak_order.equiv, decidable.not_and_iff_or_not, decidable.not_not_iff] at hn,
    assumption },
  apply find_ins_of_disj lt he hs; simp
end

end membership_lemmas

section is_red_black
variables {α : Type u}
open nat color

inductive is_bad_red_black : rbnode α → nat → Prop
| bad_red   {c₁ c₂ n l r v} (rb_l : is_red_black l c₁ n) (rb_r : is_red_black r c₂ n) :
  is_bad_red_black (red_node l v r) n

lemma balance1_rb {l r t : rbnode α} {y v : α} {c_l c_r c_t n} : is_red_black l c_l n →
  is_red_black r c_r n → is_red_black t c_t n → ∃ c, is_red_black (balance1 l y r v t) c (succ n) :=
by intros h₁ h₂ _; cases h₁; cases h₂; repeat { assumption <|> constructor }

lemma balance2_rb {l r t : rbnode α} {y v : α} {c_l c_r c_t n} : is_red_black l c_l n →
  is_red_black r c_r n → is_red_black t c_t n → ∃ c, is_red_black (balance2 l y r v t) c (succ n) :=
by intros h₁ h₂ _; cases h₁; cases h₂; repeat { assumption <|> constructor }

lemma balance1_node_rb {t s : rbnode α} {y : α} {c n} : is_bad_red_black t n → is_red_black s c n →
  ∃ c, is_red_black (balance1_node t y s) c (succ n) :=
by intros h _; cases h; simp [balance1_node]; apply balance1_rb; assumption'

lemma balance2_node_rb {t s : rbnode α} {y : α} {c n} : is_bad_red_black t n → is_red_black s c n →
  ∃ c, is_red_black (balance2_node t y s) c (succ n) :=
by intros h _; cases h; simp [balance2_node]; apply balance2_rb; assumption'

def ins_rb_result : rbnode α → color → nat → Prop
| t red   n := is_bad_red_black t n
| t black n := ∃ c, is_red_black t c n

variables {lt : α → α → Prop} [decidable_rel lt]

lemma of_get_color_eq_red {t : rbnode α} {c n} : get_color t = red → is_red_black t c n → c = red :=
begin intros h₁ h₂, cases h₂; simp only [get_color] at h₁; contradiction end

lemma of_get_color_ne_red {t : rbnode α} {c n} : get_color t ≠ red → is_red_black t c n →
  c = black :=
begin intros h₁ h₂, cases h₂; simp only [get_color] at h₁; contradiction end

variable (lt)

def insert_rb_result : rbnode α → color → nat → Prop
| t red n   := is_red_black t black (succ n)
| t black n := ∃ c, is_red_black t c n

lemma insert_rb {t : rbnode α} (x) {c n} (h : is_red_black t c n) :
  insert_rb_result (insert lt t x) c n :=
begin
  simp [insert],
  have hi := ins_rb lt x h,
  generalize he : ins lt t x = r,
  simp [he] at hi,
  cases h; simp [get_color, ins_rb_result, insert_rb_result, mk_insert_result] at *,
  assumption',
  { cases hi, simp [mk_insert_result], constructor; assumption }
end

lemma insert_is_red_black {t : rbnode α} {c n} (x) : is_red_black t c n →
  ∃ c n, is_red_black (insert lt t x) c n :=
begin
  intro h,
  have := insert_rb lt x h,
  cases c; simp [insert_rb_result] at this,
  { constructor, constructor, assumption },
  { cases this, constructor, constructor, assumption }
end

end is_red_black

end rbnode


import Playground.Category.Functor.Universal
import Playground.Category.WithZeroMorphisms

namespace Category.Construction
section
  universe u
  variable {X : Type u}
  namespace Quotient2
  structure Data.{v} (R : Setoid X) where
    object : Type v
    morphism : X → object
    sound : ∀ x y : X, x ≈ y → morphism x = morphism y

  structure Data.Hom {R : Setoid X} (A B : Data R) where
    function : A.object ⟶ B.object
    law : A.morphism ≫ function = B.morphism

  example {R : Setoid X} : Category (Data R) where
    hom := Data.Hom
    comp
    | { function := f₁, law := h₁ }, { function := f₂, law := h₂ } =>
      { function := f₁ ≫ f₂, law := by rw [←assoc, h₁, h₂] }
    id A := { function := 𝟙 _, law := rfl }
    id_comp _ := rfl
    comp_id _ := rfl
    assoc _ _ _ := sorry
  end Quotient2
end
end Category.Construction


-- import for_mathlib.exact_seq3
-- import for_mathlib.salamander
-- .

-- open category_theory category_theory.limits

-- variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]

-- -- Consider the following diagram
-- variables {     Kv₁   Kv₂        : 𝓐}
-- variables {Kh₁  A₁₁   A₁₂  Qh₁   : 𝓐}
-- variables {Kh₂  A₂₁   A₂₂  Qh₂   : 𝓐}
-- variables {     Qv₁   Qv₂        : 𝓐}
-- -- with morphisms
-- variables                         (fKv : Kv₁ ⟶ Kv₂)
-- variables                 {ιv₁ : Kv₁ ⟶ A₁₁} {ιv₂ : Kv₂ ⟶ A₁₂}
-- variables         {ιh₁ : Kh₁ ⟶ A₁₁} {f₁ : A₁₁ ⟶ A₁₂} {πh₁ : A₁₂ ⟶ Qh₁}
-- variables (gKh : Kh₁ ⟶ Kh₂) {g₁ : A₁₁ ⟶ A₂₁} {g₂ : A₁₂ ⟶ A₂₂} (gQh : Qh₁ ⟶ Qh₂)
-- variables         {ιh₂ : Kh₂ ⟶ A₂₁} {f₂ : A₂₁ ⟶ A₂₂} {πh₂ : A₂₂ ⟶ Qh₂}
-- variables                 {πv₁ : A₂₁ ⟶ Qv₁}  {πv₂ : A₂₂ ⟶ Qv₂}
-- variables                         (fQv : Qv₁ ⟶ Qv₂)
-- -- with exact rows and columns
-- variables (H₁ : exact_seq 𝓐 [ιh₁, f₁, πh₁])
-- variables (H₂ : exact_seq 𝓐 [ιh₂, f₂, πh₂])
-- variables (V₁ : exact_seq 𝓐 [ιv₁, g₁, πv₁])
-- variables (V₂ : exact_seq 𝓐 [ιv₂, g₂, πv₂])
-- -- and such that all the extremal maps are appropriately monos or epis
-- variables [mono ιv₁] [mono ιv₂] [mono ιh₁] [mono ιh₂]
-- variables [epi πv₁] [epi πv₂] [epi πh₁] [epi πh₂]
-- -- of course the diagram should commute
-- variables (sqᵤ : fKv ≫ ιv₂ = ιv₁ ≫ f₁)
-- variables (sqₗ : ιh₁ ≫ g₁ = gKh ≫ ιh₂) (sqm : f₁ ≫ g₂ = g₁ ≫ f₂)
-- variables (sqᵣ : πh₁ ≫ gQh = g₂ ≫ πh₂)
-- variables (sqₛ : f₂ ≫ πv₂ = πv₁ ≫ fQv)

-- include H₁ H₂ V₁ V₂ sqᵤ sqₗ sqm sqᵣ sqₛ

-- open_locale zero_object
-- open category_theory.abelian

-- lemma bicartesian.isos_of_isos (hfKv : is_iso fKv) (hfQv : is_iso fQv) :
--   is_iso gKh ∧ is_iso gQh :=
-- begin
--   resetI,
--   have mgKh : mono gKh,
--   { have sq : (0 : 0 ⟶ Kv₁) ≫ ιv₁ = 0 ≫ ιh₁ := (is_zero_zero _).eq_of_src _ _,
--     rw (tfae_mono 0 gKh).out 0 2,
--     apply (LBC.three_x_three_left_col _ H₁.pair H₂.pair V₁.pair V₂.pair
--       sq sqᵤ sqₗ sqm).1,
--     apply exact_zero_left_of_mono, },
--   have egKh : epi gKh,
--   { exact LBC.four_lemma_left_epi V₁ V₂ H₁.pair H₂.pair sqᵤ sqₗ sqm sqₛ, },
--   have mgQh : mono gQh,
--   { exact LBC.four_lemma_right_mono V₁ V₂ (H₁.drop 1).pair (H₂.drop 1).pair sqᵤ sqm sqᵣ sqₛ, },
--   have egQh : epi gQh,
--   { have sq : πh₂ ≫ (0 : _ ⟶ 0) = πv₂ ≫ 0 := (is_zero_zero _).eq_of_tgt _ _,
--     rw (tfae_epi 0 gQh).out 0 2,
--     apply (LBC.three_x_three_right_col
--       (H₁.drop 1).pair (H₂.drop 1).pair _ (V₁.drop 1).pair (V₂.drop 1).pair
--       sqm sqᵣ sqₛ sq).1,
--     rw ← epi_iff_exact_zero_right, apply_instance },
--   exactI ⟨is_iso_of_mono_of_epi _, is_iso_of_mono_of_epi _⟩
-- end

-- lemma bicartesian.isos_iff_isos : (is_iso fKv ∧ is_iso fQv) ↔ (is_iso gKh ∧ is_iso gQh) :=
-- begin
--   split; intro h,
--   { apply bicartesian.isos_of_isos fKv gKh gQh fQv H₁ H₂ V₁ V₂ _ _ _ _ _ h.1 h.2,
--     assumption' },
--   { apply bicartesian.isos_of_isos gKh fKv fQv gQh V₁ V₂ H₁ H₂ _ _ _ _ _ h.1 h.2;
--     symmetry, assumption' }
-- end


def s1 := "Hello, "
def s2 := "Lean!"
def s3 := "Hello, Lean!"

theorem t1 : s1 ++ s2 = s3 := eq.refl "Hello, Lean!"

theorem t2 : 4 * 4 = 16 := eq.refl 16

def square : ℕ → ℕ
| n := n^2

theorem t3 : s1 ++ s2 = s3 ∧ square 5 = 25 :=
and.intro t1 (eq.refl 25)

theorem t4 : (s1 ++ s2 = s3 ∧ square 5 = 25) → (square 5 = 25)  :=
λ h, h.right


import category_theory.base
import category_theory.natural_transformation
import category_theory.functor_category
import category_theory.colimit_lemmas

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f
local notation F ` ∘ᶠ `:80 G:80 := G.comp F

universes v u

-- TODO: Move these elsewhere
notation t ` @> `:90 X:90 := t.app X

namespace homotopy_theory.cylinder

-- An "abstract endpoint" of a "cylinder"; there are two.
inductive endpoint
| zero
| one

instance : has_zero endpoint := ⟨endpoint.zero⟩
instance : has_one endpoint := ⟨endpoint.one⟩

-- A cylinder functor (with contraction). We treat the contraction as
-- part of the basic structure as it is needed to define "homotopy
-- rel".
--
-- The standard example is C = Top, IX = X × [0,1], i ε x = (x, ε),
-- p (x, t) = x.
class has_cylinder (C : Type u) [category.{v} C] :=
(I : C ↝ C)
(i : endpoint → (functor.id C ⟶ I))
(p : I ⟶ functor.id C)
(pi : ∀ ε, p ∘ i ε = nat_trans.id _)

section
parameters {C : Type u} [category.{v} C] [has_cylinder.{v} C]

def I : C ↝ C :=
has_cylinder.I

@[reducible] def i : Π ε, functor.id C ⟶ I :=
has_cylinder.i

@[reducible] def p : I ⟶ functor.id C :=
has_cylinder.p

@[simp] lemma pi_components (ε) {A : C} : p.app A ∘ (i ε).app A = 𝟙 A :=
show (p ∘ (i ε)).app A = 𝟙 A,
by erw has_cylinder.pi; refl

lemma i_nat_assoc (ε) {y z w : C} (g : I.obj z ⟶ w) (h : y ⟶ z) :
  g ∘ i ε @> z ∘ h = g ∘ I &> h ∘ i ε @> y :=
by erw [←assoc, (i ε).naturality]; simp

lemma p_nat_assoc {y z w : C} (g : z ⟶ w) (h : y ⟶ z) :
  g ∘ p @> z ∘ I &> h = g ∘ h ∘ p @> y :=
by erw [←assoc, p.naturality]; simp

end

section boundary
variables {C : Type u} [category.{v} C] [has_coproducts.{v} C]

-- If C admits coproducts, then we can combine the inclusions `i 0`
-- and `i 1` into a single natural transformation `∂I ⟶ I`, where `∂I`
-- is defined by `∂I A = A ⊔ A`. (`∂I` does not depend on `I`.)
def boundary_I : C ↝ C :=
{ obj := λ A, A ⊔ A,
  map := λ A B f, coprod_of_maps f f,
  map_id' := λ A, by apply coprod.uniqueness; simp,
  map_comp' := λ A B C f g, by apply coprod.uniqueness; rw ←assoc; simp }

notation `∂I` := boundary_I

variables [has_cylinder C]

def ii : ∂I ⟶ I :=
show ∂I ⟶ (I : C ↝ C), from
{ app := λ (A : C), coprod.induced (i 0 @> A) (i 1 @> A),
  naturality' := λ A B f,
  begin
    dsimp [boundary_I],
    apply coprod.uniqueness;
      { rw [←assoc, ←assoc], simpa using (i _).naturality f }
  end }

@[simp] lemma iii₀_assoc {A B : C} (f : I.obj A ⟶ B) : f ∘ ii.app A ∘ i₀ = f ∘ (i 0).app A :=
by rw ←assoc; dsimp [ii]; simp

@[simp] lemma iii₁_assoc {A B : C} (f : I.obj A ⟶ B) : f ∘ ii.app A ∘ i₁ = f ∘ (i 1).app A :=
by rw ←assoc; dsimp [ii]; simp

end boundary

def endpoint.v : endpoint → endpoint
| endpoint.zero := endpoint.one
| endpoint.one := endpoint.zero

@[simp] lemma endpoint.vv (ε : endpoint) : ε.v.v = ε := by cases ε; refl

-- "Time-reversal" on a cylinder functor. The standard example is (on
-- Top as above) v (x, t) = (x, 1 - t).
--
-- The condition v² = 1 is not in Williamson; we add it here because
-- it holds in the standard examples and lets us reverse the homotopy
-- extension property. (Actually it would be enough for v to be an
-- isomorphism.)
class has_cylinder_with_involution (C : Type u) [category C]
  extends has_cylinder C :=
(v : I ⟶ I)
(vi : ∀ ε, v ∘ i ε = i ε.v)
(vv : v ∘ v = 𝟙 _)
(pv : p ∘ v = p)

section
parameters {C : Type u} [category.{v} C] [has_cylinder_with_involution C]
local notation `I` := (I : C ↝ C)

@[reducible] def v : I ⟶ I :=
has_cylinder_with_involution.v

@[simp] lemma vi_components {A : C} (ε) : v @> A ∘ i ε @> A = i ε.v @> A :=
show (v ∘ i ε) @> A = (i ε.v) @> A,
by rw has_cylinder_with_involution.vi; refl

@[simp] lemma vv_components {A : C} : v @> A ∘ v @> A = 𝟙 (I.obj A) :=
show (v ∘ v) @> A = _,
by rw has_cylinder_with_involution.vv; refl

end

section interchange
variables (C : Type u) [cat : category.{v} C] [has_cylinder C]
include cat -- This one is still necessary because of some weird interaction
-- between the "local notation `I`" and "variables {C}" below.

local notation `I` := (I : C ↝ C)

-- Interchange of two applications of the cylinder functor. The
-- standard example is (on Top as above) T (x, t, t') = (x, t', t).
class cylinder_has_interchange :=
(T : I ∘ᶠ I ⟶ I ∘ᶠ I)
(Ti : ∀ ε A, T @> _ ∘ i ε @> I.obj A = I &> (i ε @> A))
(TIi : ∀ ε A, T @> _ ∘ I &> (i ε @> A) = i ε @> I.obj A)

variables [cylinder_has_interchange.{v} C]
variables {C}

@[reducible] def T : I ∘ᶠ I ⟶ I ∘ᶠ I :=
cylinder_has_interchange.T

end interchange

end homotopy_theory.cylinder


/- A definition of unordered pairs.

   This follows the same form as "Theorem Proving in Lean" [1]. We define a
   pair where both elements are the same type, an equivalency relationship over
   them. This is used to build a quotient, which represents our actual pair.

   [1]: https://leanprover.github.io/theorem_proving_in_lean/axioms_and_computation.html#quotients-/

import tactic.lint tactic.basic data.quot logic.function data.string.basic

namespace upair
  variable {α : Type*}

  /-- A pair of items, both of the same type. -/
  @[nolint has_inhabited_instance]
  protected structure pair (α : Type*) := (fst snd : α)

  instance pair.has_repr (α : Type*) [has_repr α] : has_repr (upair.pair α)
    := ⟨ λ x, repr x.1 ++ " , " ++ repr x.2 ⟩

  /-- Two pairs are equivalent if they are equal or equal when swapped. -/
  protected def equiv : pair α → pair α → Prop
  | ⟨ a₁, b₁ ⟩ ⟨ a₂, b₂ ⟩ := (a₁ = a₂ ∧ b₁ = b₂) ∨ (a₁ = b₂ ∧ a₂ = b₁)

  private lemma equiv_refl : ∀ (p : pair α), upair.equiv p p
  | ⟨ a, b ⟩ := or.inl ⟨ rfl, rfl ⟩

  private lemma equiv_symm : ∀ (p q : pair α), upair.equiv p q → upair.equiv q p
  | ⟨ a, b ⟩ ⟨ _, _ ⟩ (or.inl ⟨ rfl, rfl ⟩):= or.inl ⟨ rfl, rfl ⟩
  | ⟨ a, b ⟩ ⟨ _, _ ⟩ (or.inr ⟨ rfl, rfl ⟩):= or.inr ⟨ rfl, rfl ⟩

  private lemma equiv_trans : ∀ (p q r : pair α), upair.equiv p q → upair.equiv q r → upair.equiv p r
  | ⟨ a₁, b₁ ⟩ ⟨ a₂, b₂ ⟩ ⟨ a₃, b₃ ⟩ p q := begin
    rcases p with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩ | ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩;
    rcases q with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩ | ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩;
    { from or.inl ⟨ rfl, rfl ⟩ <|> from or.inr ⟨ rfl, rfl ⟩ }
  end

  private lemma is_equiv : equivalence (@upair.equiv α)
    := ⟨ equiv_refl, equiv_symm, equiv_trans ⟩

  instance setoid : setoid (pair α) := setoid.mk upair.equiv is_equiv

  instance decidable_rel [decidable_eq α] : decidable_rel (@upair.equiv α)
  | ⟨ a₁, b₁ ⟩ ⟨ a₂, b₂ ⟩ := by { unfold upair.equiv, apply_instance }
end upair

/-- An unordered pair of items. -/
@[nolint has_inhabited_instance]
def upair (α : Type*) : Type* := quotient (@upair.setoid α)

namespace upair
  variables {α : Type*} {β : Type*}

  /-- Construct a new unordered pair. -/
  protected def mk (a b : α) : upair α := ⟦ ⟨ a, b ⟩ ⟧

  protected lemma mk.comm (a b : α) : upair.mk a b = upair.mk b a
    := quot.sound (or.inr ⟨ rfl, rfl ⟩)

  protected lemma exists_rep (p : upair α) : ∃ (a b : α), upair.mk a b = p
    := let ⟨ ⟨ a, b ⟩, e ⟩ := quot.exists_rep p in ⟨ a, b, e ⟩

  instance [decidable_eq α] : decidable_eq (upair α) := quotient.decidable_eq

  /-- Apply a symmetric function to the contents of this pair. -/
  protected def lift (f : α → α → β)
    : (∀ a b, f a b = f b a) → upair α → β
  | comm p := quot.lift_on p (λ p, f p.fst p.snd) (λ ⟨ a₁, b₁ ⟩ ⟨ a₂, b₂ ⟩ r, begin
    rcases r with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩ | ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
    from rfl, from comm _ _,
  end)

  /-- Apply a symmetric function to the contents of this pair. Just `upair.lift`, but in a more type-inference friendly
      order-/
  protected def lift_on (q : upair α) (f : α → α → β) (h : ∀ a b, f a b = f b a) : β
    := upair.lift f h q

  instance {α : Type*} [has_repr α] : has_repr (upair α) := ⟨ λ x,
    upair.lift_on x (λ x y, min (repr (pair.mk x y)) (repr (pair.mk y x))) (λ x y, min_comm _ _)⟩

  protected lemma lift.inj (f : α → α → β) (h : (∀ a b, f a b = f b a))
      (inj : ∀ ⦃a b a' b'⦄, f a b = f a' b' → pair.mk a b ≈ pair.mk a' b')
    : function.injective (upair.lift f h)
  | p q eql := begin
    rcases quot.exists_rep p with ⟨ ⟨ a₁, b₁ ⟩, e ⟩, subst e,
    rcases quot.exists_rep q with ⟨ ⟨ a₂, b₂ ⟩, e ⟩, subst e,
    from quot.sound (inj eql),
  end

  @[simp]
  protected lemma lift_on_beta (f : α → α → β) (c : ∀ (a b : α), f a b = f b a) {a b : α}
    : upair.lift_on (upair.mk a b) f c = f a b
    := rfl

  /-- A bit like `lift_on`, but polymorphic in the return type. -/
  @[reducible, elab_as_eliminator]
  protected def rec_on {β : upair α → Sort*} (q : upair α) (f : ∀ a b, β (upair.mk a b))
    (c : ∀ (a b : α), f a b == f b a) : β q
  := quotient.hrec_on q (λ ⟨ a, b ⟩, f a b) (λ ⟨ a₁, b₁ ⟩ ⟨ a₂, b₂ ⟩ r, begin
    show f a₁ b₁ == f a₂ b₂,
    rcases r with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩ | ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
    from heq.rfl, from c a₁ b₁,
  end)

  @[simp]
  protected lemma rec_on_beta {β : upair α → Sort*} {a b : α} (f : ∀ a b, β (upair.mk a b))
      (c : ∀ (a b : α), f a b == f b a)
    : @upair.rec_on α β (upair.mk a b) f c = f a b
    := rfl

  protected lemma rec_on.inj {β : upair α → Sort*} {f : ∀ a b, β (upair.mk a b)}
      (c : ∀ (a b : α), f a b == f b a)
      (inj : ∀ ⦃a b a' b'⦄, f a b == f a' b' → pair.mk a b ≈ pair.mk a' b')
  : ∀ p q
  , @upair.rec_on α β p f c == @upair.rec_on α β q f c
  → p = q
  | p q eql := begin
    rcases quot.exists_rep p with ⟨ ⟨ a₁, b₁ ⟩, e ⟩, subst e,
    rcases quot.exists_rep q with ⟨ ⟨ a₂, b₂ ⟩, e ⟩, subst e,
    from quot.sound (inj eql),
  end

  protected lemma eq (a b : α) : upair.mk a b = upair.mk b a
    := quot.sound (or.inr ⟨rfl, rfl⟩)

  /-- Map over the contents of an unordered pair. -/
  protected def map (f : α → β) (p : upair α) : upair β
    := upair.lift_on p (λ x y, upair.mk (f x) (f y)) (λ x y, mk.comm _ _ )

  @[simp]
  protected lemma map_compose {γ : Type*} (f : α → β) (g : β → γ) (p : upair α)
    : upair.map g (upair.map f p) = upair.map (g ∘ f) p
    := quot.rec_on p (λ ⟨ a, b ⟩, quot.sound (or.inl ⟨ rfl, rfl ⟩)) (λ _ _ _, rfl)

  @[simp]
  protected lemma map_identity (p : upair α)
    : upair.map id p = p := begin
      rcases quot.exists_rep p with ⟨ ⟨ a, b ⟩, ⟨ _ ⟩ ⟩,
      from quot.sound (or.inl ⟨ rfl, rfl ⟩)
    end

  protected lemma map_id : upair.map (@id α) = id := funext upair.map_identity

  protected lemma map.inj {f : α → β}
    (inj : function.injective f) :
    ∀ {p q : upair α}, upair.map f p = upair.map f q → p = q
  | p q eq := begin
    suffices : ∀ (a b a' b' : α), upair.mk (f a) (f b) = upair.mk (f a') (f b') → pair.mk a b ≈ pair.mk a' b',
      from lift.inj _ _ this eq,

    assume a₁ b₁ a₂ b₂ eql,
    refine or.imp _ _ (quotient.exact eql); from (λ x, ⟨ inj x.1, inj x.2 ⟩),
  end

  @[simp]
  protected lemma map_beta (f : α → β) (a b : α)
    : upair.map f (upair.mk a b) = upair.mk (f a) (f b)
    := quot.sound (or.inl ⟨ rfl, rfl ⟩)
end upair

#lint-