import tactic

def F : Type → Type → Type :=
λ X Y, (Y → X × X) → X → Y

def map1 {X Y : Type} (Z : Type) (f : X → Y) : F Y Z → F X Z :=
λ g h x, g (λ z, (h z).map f f) (f x)

def map1_id {X : Type} (Y : Type) : map1 Y (id : X → X) = id :=
by delta id; simp [map1]

def map1_comp {W X Y : Type} (Z : Type) (f : W → X) (g : X → Y) :
  map1 Z (g ∘ f) = map1 Z f ∘ map1 Z g := rfl

def map2 (X : Type) {Y Z : Type} (f : Y → Z) : F X Y → F X Z :=
λ g h, (∘) f (g (h ∘ f))

def map2_id (X : Type) {Y : Type} : map2 X (id : Y → Y) = id :=
by funext; simp [map2]

def map2_comp (W : Type) {X Y Z : Type} (f : X → Y) (g : Y → Z) :
  map2 X (g ∘ f) = map2 X g ∘ map2 X f := rfl

section

variables {X Y : Type} (R : X → Y → Prop)

open function sum

inductive rel : X ⊕ Y → X ⊕ Y → Prop
| lr : ∀ {x y}, R x y → rel (inl x) (inr y)
| rl : ∀ {x y}, R x y → rel (inr y) (inl x)
| refl : ∀ a, rel a a
| transl : ∀ {x₁ x₂ y}, R x₁ y → R x₂ y → rel (inl x₁) (inl x₂)
| transr : ∀ {x y₁ y₂}, R x y₁ → R x y₂ → rel (inr y₁) (inr y₂)

lemma rel.symm : ∀ {a b : X ⊕ Y}, rel R a b → rel R b a
| _ _ (rel.lr h)         := rel.rl h
| _ _ (rel.rl h)         := rel.lr h
| _ _ (rel.refl _)       := rel.refl _
| _ _ (rel.transl h₁ h₂) := rel.transl h₂ h₁
| _ _ (rel.transr h₁ h₂) := rel.transr h₂ h₁

lemma rel.trans
  (hR : ∀ {x₁ x₂ y₁ y₂}, R x₁ y₁ → R x₂ y₁ → R x₂ y₂ → R x₁ y₂) :
  ∀ {a b c : X ⊕ Y}, rel R a b → rel R b c → rel R a c
| _ _ _ (rel.refl _)       h                  := h
| _ _ _ (rel.lr h₁)        (rel.rl h₂)        := rel.transl h₁ h₂
| _ _ _ (rel.rl h₁)        (rel.lr h₂)        := rel.transr h₁ h₂
| _ _ _ (rel.lr h₁)        (rel.transr h₂ h₃) := rel.lr (hR h₁ h₂ h₃)
| _ _ _ (rel.rl h₁)        (rel.transl h₂ h₃) := rel.rl (hR h₃ h₂ h₁)
| _ _ _ (rel.transl h₁ h₂) (rel.lr h₃)        := rel.lr (hR h₁ h₂ h₃)
| _ _ _ (rel.transr h₁ h₂) (rel.rl h₃)        := rel.rl (hR h₃ h₂ h₁)
| _ _ _ (rel.transr h₁ h₂) (rel.transr h₃ h₄) := rel.transr h₁ (hR h₂ h₃ h₄)
| _ _ _ (rel.transl h₁ h₂) (rel.transl h₃ h₄) := rel.transl h₁ (hR h₄ h₃ h₂)
-- Cases below shouldn't be necessary
| _ _ _ (rel.lr h)         (rel.refl _)       := rel.lr h
| _ _ _ (rel.rl h)         (rel.refl _)       := rel.rl h
| _ _ _ (rel.transl h₁ h₂) (rel.refl _)       := rel.transl h₁ h₂
| _ _ _ (rel.transr h₁ h₂) (rel.refl _)       := rel.transr h₁ h₂

lemma R_of_rel {x : X} {y : Y} : rel R (inl x) (inr y) → R x y
| (rel.lr h) := h

def rel_setoid (hR : ∀ x₁ x₂ y₁ y₂, R x₁ y₁ → R x₂ y₁ → R x₂ y₂ → R x₁ y₂) :
  setoid (X ⊕ Y) :=
{ r := rel R,
  iseqv := ⟨rel.refl, @rel.symm _ _ _, @rel.trans _ _ _ hR⟩ }

def square {A B : Type} (R : A → B → Prop) : Prop :=
∀ x₁ x₂ y₁ y₂, R x₁ y₁ → R x₂ y₁ → R x₂ y₂ → R x₁ y₂

inductive square_closure {A B : Type} (R : A → B → Prop) : A → B → Prop
| of_rel {a b} : R a b → square_closure a b
| closure {a₁ a₂ b₁ b₂} : square_closure a₁ b₁ → square_closure a₁ b₂ →
  square_closure a₂ b₁ → square_closure a₂ b₂

example {X Y : Type} {R : X → Y → Prop} :
  (∀ x₁ x₂ y₁ y₂, R x₁ y₁ → R x₂ y₁ → R x₂ y₂ → R x₁ y₂) ↔
  ∃ (Z : Type) (f₁ : X → Z) (f₂ : Y → Z), (∀ x y, R x y ↔ f₁ x = f₂ y) :=
begin
  split,
  { intro hR,
    refine ⟨quotient (rel_setoid R hR),
      quotient.mk' ∘ inl, quotient.mk' ∘ inr, _⟩,
    intros x y,
    simp only [quotient.eq'],
    split,
    { exact rel.lr },
    { exact R_of_rel R } },
  { rintros ⟨Z, f₁, f₂, h⟩,
    simp only [h], cc },
end

example {A A' : Type} {B : A → Type} {B' : A' → Type} (Ra : A → A' → Prop)
  (hRa : square Ra)
  (Rb : Π (a₁ : A) (a₂ : A') (h : Ra a₁ a₂),
    {R : B a₁ → B' a₂ → Prop // square R}) :
  square (λ (f : Π a, B a) (g : Π a, B' a),
    ∀ a a' (h : Ra a a'), (Rb a a' h).1 (f a) (g a')) :=
begin
  intros f₁ f₂ g₁ g₂,
  dsimp,
  intros h₁ h₂ h₃ a a' h,
  exact (Rb a a' h).2 _ _ _ _  (h₁ a a' h) (h₂ a a' h) (h₃ a a' h)
end

example {X₁ X₂ : Type} (R : X₁ → X₂ → Prop) (h : square R)
  (F : Type → Type) :
  square (λ (f : X₁ → X₁) (g : X₂ → X₂), ∀ x₁ x₂, R x₁ x₂ → R (f x₁) (g x₂)) :=
begin
  intros f₁ f₂ g₁ g₂ h₁ h₂ h₃ x₁ x₂ hx,
  exact h _ _ _ _ (h₁ _ _ hx) (h₂ _ _ hx) (h₃ _ _ hx),
end

example {A₁ A₂ : Type} {B₁ : A₁ → Type} {B₂ : A₂ → Type}
  (Ra : Type) (f₁ : A₁ → Ra) (f₂ : A₂ → Ra)
  (Rb : Π {a₁ : A₁} {a₂ : A₂} (h : f₁ a₁ = f₂ a₂), Type)
  (g₁ : Π {a₁ : A₁} {a₂ : A₂} (h : f₁ a₁ = f₂ a₂), B₁ a₁ → Rb h)
  (g₂ : Π {a₁ : A₁} {a₂ : A₂} (h : f₁ a₁ = f₂ a₂), B₂ a₂ → Rb h) :
  Σ' (R : Type) (i₁ : (Π a₁ : A₁, B₁ a₁) → R) (i₂ : (Π a₂ : A₂, B₂ a₂) → R),
    ∀ (p₁ : (Π a₁ : A₁, B₁ a₁)) (p₂ : (Π a₂ : A₂, B₂ a₂)),
      (∀ a₁ a₂ (h : f₁ a₁ = f₂ a₂), g₁ h (p₁ a₁) = g₂ h (p₂ a₂)) ↔
    i₁ p₁ = i₂ p₂ :=
⟨Π (a₁ : A₁) (a₂ : A₂) (h : f₁ a₁ = f₂ a₂), Rb h,
  λ p₁ a₁ a₂ h, g₁ h (p₁ a₁),
  λ p₂ a₁ a₂ h, g₂ h (p₂ a₂),
  by simp [function.funext_iff]⟩

example {F G : Type → Type}
  (n : Π {X Y : Type}, (X → Y) → (F X → G Y))
  (fmap : Π {X Y : Type}, (X → Y) → (F X → F Y))
  (hn : ∀ {X Y Z : Type} (g : Y → Z) (f : X → Y), n (g ∘ f) = n g ∘ fmap f) :
  ∀ {X Y : Type} (f : X → Y), n f = n id ∘ (fmap f) :=
begin
  intros,
  exact hn id f
end

end

def preimage (F₁ F₂ G₁ G₂ : Type → Type)
  (R : Π {A₁ A₂ : Type} (R : A₁ → A₂ → Type), G₁ A₁ → G₂ A₂ → Type)
  ( hom₁ : Π {A : Type}, F₁ A → G₁ A)
  ( hom₂ : Π {A₁ A₂ : Type}, (F₂ A₁ → G₂ A₂) ) :
  Π {A₁ A₂ : Type} (Ra : A₁ → A₂ → Type), F₁ A₁ → F₂ A₂ → Type :=
λ A₁ A₂ Ra a₁ a₂, R Ra (@hom₁ A₁ a₁) _

def preimage (F₁ F₂ G₁ G₂ : Type → Type)
  (R : Π {A₁ A₂ : Type}, (A₁ → A₂ → Type) → G₁ A₁ → G₂ A₂ → Type)
  (hom₁ : Π {A₁ A₂ : Type}, (A₁ → A₂) → (F₁ A₁ → G₁ A₂))
  (hom₂ : Π {A₁ A₂ : Type}, (A₁ → A₂) → (F₂ A₁ → G₂ A₂)) :
  Π {A₁ A₂ : Type}, (A₁ → A₂ → Type) → F₁ A₁ → F₂ A₂ → Type :=
λ A₁ A₂ Ra a₁ a₂, R Ra (hom₁ id a₁) _

def natural (F : Type → Type) (G : Type → Type)
  (mapF : Π {X Y}, (X → Y) → (F X → F Y))
  (mapG : Π {X Y}, (X → Y) → (G X → G Y))
  (n : Π X, F X → G X) :=
  ∀ (X Y) (f : X → Y), n Y ∘ mapF f = mapG f ∘ n X

example (F : Type → Type) (G : Type → Type)
  (mapF : Π {X Y}, (X → Y) → (F X → F Y))
  (mapG : Π {X Y}, (X → Y) → (G X → G Y))
  (hom₁ : Π {A : Type}, F A → G A) :
  Π {A₁ A₂ : Type}, (A₁ → A₂) → (F A₁ → G A₂) :=
  λ A₁ A₂ f a, hom₁ (mapF f a)

def parametric (F : Type → Type) (G : Type → Type)
  (mapF : Π {X Y}, (X → Y → Prop) → (F X → F Y → Prop))
  (mapG : Π {X Y}, (X → Y → Prop) → (G X → G Y → Prop))
  (n : Π X, F X → G X) :=
∀ (X Y) (R : X → Y → Prop) (x : F X) (y : F Y),
  mapF R x y → mapG R (n X x) (n Y y)
  -- ∀ (X Y) (R : X → Y → Prop)
  -- mapF R ≤ (n X, n Y) ⁻¹ mapG R

def cyril_hom (F G : Type → Type) :=
  Π {{X Y}}, (X → Y) → (F X → G Y)

def comp {F G H : Type → Type} : cyril_hom G H → cyril_hom F G → cyril_hom F H :=
λ f g X Y i x, begin
  dsimp [cyril_hom] at *,
  apply f,
  apply i,
  apply g,
  apply id,
  apply x,
end

def comp_assoc (W X Y Z : Type → Type)
  (f : cyril_hom Y Z) (g : cyril_hom X Y) (h : cyril_hom W X) :
  comp f (comp g h) = comp (comp f g) h :=
begin
  funext,
  simp [comp],

end

open function

example {X Y : Type} (f : X → Y) (hf : surjective f) :
  ∃ g : ((X → X) → (Y → Y)), (∀ a b, g a = b ↔ ∀ x y, f x = y → f (a x) = b y) :=
⟨λ a y, f (a (surj_inv hf y)), begin
intros a b,
simp only [function.funext_iff],
split,
rintros h x y rfl,
rw ← h, admit,
intros h y,
exact h (surj_inv hf y) y (surj_inv_eq _ _),

 end⟩


import lib

open encodable denumerable

attribute [simp] set.set_of_app_iff

def Tree' : ℕ → Type
| 0       := bool
| (n + 1) := list (Tree' n)

instance : ∀ {k : ℕ}, has_to_string (Tree' k)
| 0       := ⟨λ b, match b with | tt := "∞" | ff := "0" end⟩
| (k + 1) := @list.has_to_string (Tree' k) (@Tree'.has_to_string k)

def Tree (n : ℕ) := Tree' (n + 1)

instance {k : ℕ} : has_to_string (Tree k) := @Tree'.has_to_string (k + 1)

instance {k} : has_append (Tree k) := ⟨list.append⟩
instance {k} : has_mem (Tree' k) (Tree k) := ⟨list.mem⟩
instance {k} : has_mem (Tree' k) (Tree' (k + 1)) := ⟨list.mem⟩

instance : ∀ {k}, inhabited (Tree' k)
| 0       := ⟨tt⟩
| (k + 1) := ⟨[]⟩

instance {k} : inhabited (Tree k) := Tree'.inhabited

instance : ∀ n, decidable_eq (Tree' n)
| 0       := bool.decidable_eq
| (n + 1) := @list.decidable_eq _ (Tree'.decidable_eq n)

instance : ∀ n, primcodable (Tree' n)
| 0       := primcodable.bool
| (s + 1) := @primcodable.list (Tree' s) (Tree'.primcodable s)

instance (n) : primcodable (Tree n) := Tree'.primcodable (n + 1)

def ancestor {n} (η : Tree n) := {μ : Tree n // μ ⊂ᵢ η}

instance {k} (η : Tree k) : primcodable (ancestor η) :=
primcodable.subtype (list.primrec.is_initial.comp primrec.id (primrec.const η))

instance {n} {η : Tree n} : has_coe (ancestor η) (Tree n) :=
⟨subtype.val⟩

instance {n} {η : Tree n} : linear_order (ancestor η) :=
{ le := λ x y, x.val <:+ y.val,
  lt := λ x y, x.val ⊂ᵢ y.val,
  le_refl := λ μ, by simp,
  le_trans := λ μ₁ μ₂ μ₃, list.is_suffix.trans,
  lt_iff_le_not_le := λ μ₁ μ₂, by {
    simp[list.is_initial_iff_suffix], intros h₁,
    split,
    { contrapose, simp, intros h₂, exact list.suffix_antisymm h₁ h₂ },
    { contrapose, simp, intros eqn, simp[eqn] } },
  le_antisymm := λ μ₁ μ₂ eqn₁ eqn₂, subtype.eq (list.suffix_antisymm eqn₁ eqn₂),
  le_total := λ μ₁ μ₂, by { simp[has_le.le, preorder.le],
    have h₁ := (list.is_initial_iff_suffix.mp μ₁.property).1,
    have h₂ := (list.is_initial_iff_suffix.mp μ₂.property).1,
    exact list.suffix_or_suffix_of_suffix h₁ h₂ },
  decidable_le := λ μ₁ μ₂, list.decidable_suffix μ₁.val μ₂.val }

def ancestor.index {k : ℕ} {η : Tree k} (μ : ancestor η) : ℕ := μ.val.length

def ancestor.at {k : ℕ} (η : Tree k) (i : ℕ) (h : i < η.length) : ancestor η := ⟨η↾*i, list.is_initial_initial η i h⟩

def Tree.ancestors {n} (η : Tree n) : list (ancestor η) :=
(list.range_r η.length).pmap (λ m (h : m < η.length), (⟨η↾*m, list.is_initial_of_lt_length h⟩ : ancestor η))
(λ _, by simp)
-- η.ancestors = [η↾*(η.length - 1) ... η↾*2, η↾*1, η↾*0]

def Tree.ancestors' {n} (η : Tree n) : Tree (n + 1) := η.ancestors.map subtype.val

def Tree.ancestors_or_refl {n} (η : Tree n) : Tree (n + 1) := η :: η.ancestors'

namespace ancestor
variables {k : ℕ}

lemma le_iff {n} {η : Tree n} {μ₁ μ₂ : ancestor η} : μ₁ ≤ μ₂ ↔ μ₁.val <:+ μ₂.val := by refl

lemma lt_iff {n} {η : Tree n} {μ₁ μ₂ : ancestor η} : μ₁ < μ₂ ↔ μ₁.val ⊂ᵢ μ₂.val := by refl

@[simp] def mk' {k} {η μ : Tree k} (h : μ ⊂ᵢ η) : ancestor η := ⟨μ, h⟩

def extend {η₁ η₂ : Tree k} (le : η₁ <:+ η₂) (μ : ancestor η₁) : ancestor η₂ :=
⟨μ, list.is_initial.is_initial_of_suffix μ.property le⟩

@[simp] lemma extend_val {η₁ η₂ : Tree k} (le : η₁ <:+ η₂) (μ : ancestor η₁) :
  (μ.extend le).val = μ := rfl

@[simp] lemma extend_coe {η₁ η₂ : Tree k} (le : η₁ <:+ η₂) (μ : ancestor η₁) :
  (↑(μ.extend le) : Tree k) = ↑μ := rfl

def extend_fn {α} {η₂ : Tree k}
  (f : ancestor η₂ → α) (η₁ : Tree k) (le : η₁ <:+ η₂) : ancestor η₁ → α := λ ν, f (ν.extend le)

@[simp] def extend_fn_val {α} {η₁ η₂ : Tree k}
  (f : ancestor η₂ → α) (le : η₁ <:+ η₂) (ν : ancestor η₁) : extend_fn f η₁ le ν = f (ν.extend le) := rfl

@[simp] lemma extend_id {n} {η : Tree n} {s} : @extend _ η η s = id :=
funext (by simp[extend])

@[simp] lemma ancestors_nil {n} : @Tree.ancestors n [] = [] := rfl

@[simp] lemma ancestors_cons {n} (η : Tree n) (x) :
  Tree.ancestors (x :: η) = ⟨η, by simp⟩ :: η.ancestors.map (extend (by simp)) :=
by { simp[Tree.ancestors, list.map_pmap], apply list.pmap_congr, simp,
     intros m eqn₁ eqn₂, simp [list.initial_cons (le_of_lt eqn₂), extend] }

@[simp] lemma ancestors'_nil {n} : @Tree.ancestors' n [] = [] := rfl

@[simp] lemma ancestors'_cons {n} (η : Tree n) (x) :
  Tree.ancestors' (x :: η) = η :: η.ancestors' :=
by { simp [Tree.ancestors', ancestors_cons, function.comp], unfold_coes }

lemma ancestors'_suffix_of_suffix {n} {μ₁ μ₂ : Tree n} (s : μ₁ <:+ μ₂) :
  μ₁.ancestors' <:+ μ₂.ancestors' :=
begin
  rcases s with ⟨l, rfl⟩,
  induction l with x l IH,
  { refl },
  { simp, exact IH.trans (list.suffix_cons _ _) }
end

lemma ancestors_suffix_of_suffix' {n} {μ₁ μ₂ : Tree n} (s : μ₁ <:+ μ₂) :
  μ₁.ancestors.map (ancestor.extend s) <:+ μ₂.ancestors :=
begin
  rcases s with ⟨l, h⟩,
  induction l with x l IH generalizing μ₁ μ₂,
  { simp at h, rcases h with rfl, simp },
  { simp at h, rcases h with rfl, simp,
    have : μ₁.ancestors.map (λ ν₁, (⟨ν₁.val, _⟩ : ancestor (x :: (l ++ μ₁))))
      <:+ list.map (extend (list.suffix_cons _ _)) (Tree.ancestors (l.append μ₁)),
    { have := list.map_suffix (extend (list.suffix_cons _ _)) (@IH μ₁ (l.append μ₁) rfl),
      simp[function.comp] at this, exact this },
    exact this.trans (list.suffix_cons _ _) }
end

@[simp] lemma ancestors_or_reflngth {n} {μ : Tree n} : μ.ancestors.length = μ.length := by simp[Tree.ancestors]

lemma ancestors_rnth {n} {μ : Tree n} {i : ℕ} (h : i < μ.length)  :
  μ.ancestors.rnth i = some ⟨μ↾*i, list.is_initial_of_lt_length h⟩ :=
begin
  have : μ.ancestors.rnth i = μ.ancestors.nth (list.length μ - 1 - i),
  { have := @list.rnth_eq_nth_of_lt _ μ.ancestors i (by simp[h]), simp at this, exact this },
  rw this, simp[Tree.ancestors, list.nth_pmap],
  refine ⟨i, _, rfl⟩,
  have := @list.rnth_eq_nth_of_lt _ (list.range_r (list.length μ)) i (by simp[h]), simp[h] at this,
  exact eq.symm this
end

lemma ancestors_ordered {n} : ∀ (μ : Tree n), μ.ancestors.ordered (<)
| []       := by simp
| (x :: η) := by simp[list.ordered];
    exact ⟨list.ordered_map (extend (by simp)) (λ x y lt, lt) (ancestors_ordered η), λ η₀ mem, η₀.property⟩

lemma nodup_Tree.ancestors {n} (η : Tree n) : (Tree.ancestors η).nodup :=
list.nodup_pmap
  (λ m₁ eqn₁ m₂ eqn₂ eqn, by { simp at eqn, have : (η↾*m₁).length = m₁, from list.initial_length eqn₁,
       simp [eqn, list.initial_length eqn₂] at this, simp[this] })
  (list.nodup_range_r _)

def ancestor_univ {n} (η : Tree n) : finset (ancestor η) :=
⟨Tree.ancestors η, nodup_Tree.ancestors η⟩

@[simp] lemma ancestors_complete {n} {η : Tree n} (η₀ : ancestor η) : η₀ ∈ η.ancestors :=
list.mem_pmap.2 ⟨η₀.val.length, by { simp[ancestor_univ],
refine ⟨list.is_initial_length η₀.property, _⟩, apply subtype.ext, simp,
exact list.eq_initial_of_is_initial η₀.property }⟩

lemma ancestors'_complete {n} {η : Tree n} (η₀ : Tree n) (lt : η₀ ⊂ᵢ η) : η₀ ∈ η.ancestors' :=
by { simp[Tree.ancestors'], refine ⟨⟨η₀, lt⟩, rfl⟩ }

@[simp] lemma mem_fin_range {n} {η : Tree n} (η₀ : ancestor η) : η₀ ∈ ancestor_univ η :=
ancestors_complete _

instance {n} (η : Tree n) : fintype (ancestor η) :=
⟨ancestor_univ η, mem_fin_range⟩

def ancestor_univ' {n} (η : Tree n) : finset (Tree n) := (ancestor_univ η).image subtype.val

@[simp] lemma ancestor_univ_card {n} (η : Tree n) : (ancestor_univ η).card = η.length :=
by simp[ancestor_univ, Tree.ancestors]

@[simp] lemma ancestor_univ'_card {n} (η : Tree n) : (ancestor_univ' η).card = η.length :=
by { have : (ancestor_univ' η).card = (ancestor_univ η).card,
     { apply finset.card_image_of_injective, intros x y, exact subtype.eq },
     simp[this] }

end ancestor

def out {n} : Π {η : Tree n}, ancestor η → Tree' n
| []       ⟨μ, μ_p⟩ := by exfalso; simp* at*
| (ν :: η) ⟨μ, μ_p⟩ := if h : μ ⊂ᵢ η then out ⟨μ, h⟩ else ν

lemma out_eq_iff {n} : ∀ {η : Tree n} {μ : ancestor η} {ν}, out μ = ν ↔ ν :: μ.val <:+ η
| []       ⟨μ, μ_p⟩ _  := by exfalso; simp* at*
| (ν :: η) ⟨μ, μ_p⟩ ν' :=
    by { simp, have : μ = η ∨ μ ⊂ᵢ η, from list.is_initial_cons_iff.mp μ_p, cases this,
         { rcases this with rfl, simp[out], exact eq_comm },
         { simp[out, this],
           have IH : out ⟨μ, this⟩ = ν' ↔ ν' :: μ <:+ η, from @out_eq_iff η ⟨μ, this⟩ ν', rw IH,
           split,
           { intros h, refine list.suffix_cons_iff.mpr (or.inr h) },
           { intros h, have C := list.suffix_cons_iff.mp h, cases C,
             { exfalso, simp at C, rcases C with ⟨_, rfl⟩, simp at this, exact this },
             { exact C } } } }

lemma out_eq_iff' {n} {η : Tree n} {μ : ancestor η} {ν} : ν = out μ ↔ ν :: μ.val <:+ η :=
by { rw[←out_eq_iff], exact eq_comm }

lemma suffix_out_cons {n} {η : Tree n} (μ : ancestor η) : out μ :: μ.val <:+ η :=
by { have := @out_eq_iff n η μ (out μ), simp* at* }

lemma out_cons'_eq {n} {η : Tree n} (ν) (μ : ancestor η)  :
  @out n (ν :: η) (μ.extend (list.suffix_cons ν η)) = out μ :=
by { simp[out, ancestor.extend], intros h, exfalso, have := h μ.property, exact this }

lemma out_cons'_eq' {n} {η : Tree n} (ν) (μ : ancestor η) {h : μ.val ⊂ᵢ ν :: η} :
  @out n (ν :: η) ⟨μ.val, h⟩ = out μ :=
by { simp[out], intros h, exfalso, have := h μ.property, exact this }

lemma suffix_out_eq {n} : ∀ {η₁ η₂: Tree n} {μ₁ : ancestor η₁} {μ₂ : ancestor η₂}
  (h₁ : μ₁.val = μ₂.val) (h₂ : η₂ <:+ η₁), out μ₁ = out μ₂ :=
begin
  suffices : ∀ (l : list _) {η₁ η₂: Tree n} {μ₁ : ancestor η₁} {μ₂ : ancestor η₂}
    (h₁ : μ₁.val = μ₂.val) (h₂ : l.reverse ++ η₂ = η₁), out μ₁ = out μ₂,
  { intros η₁ η₂ μ₁ μ₂ h₁ h₂, rcases h₂ with ⟨l, h₂⟩,
    exact this l.reverse h₁ (by simp[h₂]) },
  intros l η₁ η₂ μ₁ μ₂ h₁ h₂,
  induction l with ν l IH generalizing η₁ η₂,
  { simp at h₂, rcases h₂ with rfl, congr, exact subtype.eq h₁ },
  { simp at h₂,
    let μ₂' : ancestor (ν :: η₂) := ⟨μ₂.val, μ₂.property.trans (by simp)⟩,
    have h₁' : μ₁.val = μ₂'.val, { simp[μ₂', h₁] },
    have eqn₁ : out μ₁ = out μ₂', from IH h₁' h₂,
    have eqn₂ : out μ₂' = out μ₂, from out_cons'_eq' ν μ₂,
    simp[eqn₁, eqn₂] }
end

lemma suffix_out_eq' {n} {η₁ η₂: Tree n} {μ₁ : ancestor η₁} {μ₂ : ancestor η₂}
  (h₁ : μ₁.val = μ₂.val) (h₂ : η₁ <:+ η₂ ∨ η₂ <:+ η₁) : out μ₁ = out μ₂ :=
by { cases h₂, { exact eq.symm (suffix_out_eq (eq.symm h₁) h₂) }, { exact suffix_out_eq h₁ h₂ } }

@[simp] lemma out_extend_eq {k} {η₁ η₂ : Tree k} {h : η₁ <:+ η₂} {μ₁ : ancestor η₁} :
  out (ancestor.extend h μ₁) = out μ₁ :=
suffix_out_eq (by simp) h

@[simp] lemma out_cons {k} {η : Tree k} {x} (h : η ⊂ᵢ x :: η) : out ⟨η, h⟩ = x := by simp[out_eq_iff]

lemma ancestor_initial_index {k} {η : Tree k} (μ : ancestor η) : η↾*μ.index = μ.val :=
begin
  rcases μ with ⟨l, μ, a, rfl⟩, simp[ancestor.index],
  rw [show μ ++ a :: l = μ ++ [a] ++ l, by simp, list.initial_append]
end

lemma ancestor_initial_index_succ {k} {η : Tree k} (μ : ancestor η) : η↾*(μ.index + 1) = out μ :: μ.val :=
begin
  rcases μ with ⟨l, μ, a, rfl⟩, simp[ancestor.index],
  rw [show list.length l + 1 = (a :: l).length, by simp, list.initial_append],
  simp[out_eq_iff'],
end

structure Path (n : ℕ) :=
(path : ℕ → Tree n)
(mono : ∀ m, path m <:+ path (m + 1))

instance {n : ℕ} : has_coe_to_fun (Path n) (λ _, ℕ → Tree n) := ⟨Path.path⟩

namespace Path

lemma ext {k} {Λ₁ Λ₂ : Path k} (h : ∀ s, Λ₁ s = Λ₂ s) : Λ₁ = Λ₂ :=
by { rcases Λ₁ with ⟨P₁, _⟩, rcases Λ₂ with ⟨P₂, _⟩, simp,
     refine funext h }

@[simp] lemma path_eta {n : ℕ} {p : ℕ → Tree n} {h} : (({path := p, mono := h} : Path n) : ℕ → Tree n) = p := rfl

def trivialPath_aux {i : ℕ} : ℕ → Tree i
| 0       := []
| (n + 1) := (default _) :: trivialPath_aux n

instance (i) : inhabited (Path i) := ⟨⟨trivialPath_aux, by simp[trivialPath_aux]⟩⟩

variables {k : ℕ} (Λ : Path k)

lemma mono' : ∀ {n m : ℕ} (le : n ≤ m), Λ n <:+ Λ m :=
begin
  suffices : ∀ n m, Λ n <:+ Λ (n + m),
  { intros n m eqn, have := this n (m - n), simp[nat.add_sub_of_le eqn] at this,
    exact this },
  intros n m, induction m with m IH,
  { refl },
  { simp[←nat.add_one, ←add_assoc], exact IH.trans (Λ.mono _) }
end

lemma ssubset_of_le {n m : ℕ} {η : Tree k} (ss : η ⊂ᵢ Λ n) (le : n ≤ m) : η ⊂ᵢ Λ m :=
list.is_initial.is_initial_of_suffix ss (Λ.mono' le)

def ssubset (η : Tree k) (Λ : Path k) : Prop := ∃ n, η ⊂ᵢ Λ n
def subset (η : Tree k) (Λ : Path k): Prop := ∃ n, η <:+ Λ n

infix ` ⊂' `:50   := Path.ssubset
infix ` ⊆' `:50   := Path.subset

def infinite (Λ : Path k) : Prop := ∀ n, ∃ m, Λ n ⊂ᵢ Λ (n + m)

noncomputable def infinite.succ {Λ : Path k} (h : Λ.infinite) (n : ℕ) : ℕ := classical.some (h n)

@[simp] lemma infinite.succ_spec {Λ : Path k} (h : Λ.infinite) (n : ℕ) : Λ n ⊂ᵢ Λ (n + h.succ n) :=
classical.some_spec (h n)

noncomputable def infinite.out {Λ : Path k} (h : Λ.infinite) (s : ℕ) : Tree' k := out ⟨Λ s, h.succ_spec s⟩

lemma infinite.out_eq_out {Λ : Path k} (h : Λ.infinite) {s t : ℕ} (lt : Λ s ⊂ᵢ Λ t) : out ⟨Λ s, lt⟩ = h.out s :=
by { have C : s + h.succ s ≤ t ∨ t ≤ s + h.succ s, from le_total (s + infinite.succ h s) t,
     refine suffix_out_eq' rfl (by cases C; simp[Λ.mono' C])}

def thick (Λ : Path k) : Prop := Λ 0 = [] ∧ ∀ n, ∃ ν, Λ (n + 1) = ν :: Λ n

def le (Λ₁ Λ₂ : Path k) : Prop := ∀ n, ∃ m, Λ₁ n <:+ Λ₂ m
infix ` ≤ₚ `:80 := le

def equiv (Λ₁ Λ₂ : Path k) : Prop := Λ₁.le Λ₂ ∧ Λ₂.le Λ₁
infix ` ≃ₚ `:80 := equiv

@[refl] lemma equiv.refl (Λ : Path k) : Λ ≃ₚ Λ :=
⟨λ n, ⟨n, by refl⟩, λ n, ⟨n, by refl⟩⟩

@[symm] lemma equiv.symm {Λ₁ Λ₂ : Path k} : Λ₁ ≃ₚ Λ₂ → Λ₂ ≃ₚ Λ₁ := and.symm

@[trans] lemma equiv.trans {Λ₁ Λ₂ Λ₃ : Path k} (eqn₁ : Λ₁ ≃ₚ Λ₂) (eqn₂ : Λ₂ ≃ₚ Λ₃) : Λ₁ ≃ₚ Λ₃ :=
⟨λ n, by { rcases eqn₁.1 n with ⟨m, le₁⟩, rcases eqn₂.1 m with ⟨l, le₂⟩, refine ⟨l, le₁.trans le₂⟩ },
 λ n, by { rcases eqn₂.2 n with ⟨m, le₁⟩, rcases eqn₁.2 m with ⟨l, le₂⟩, refine ⟨l, le₁.trans le₂⟩ }⟩

lemma le.ssubset_of_ssubset {Λ₁ Λ₂ : Path k} (eqn : Λ₁ ≤ₚ Λ₂) {μ} (lt : μ ⊂' Λ₁) : μ ⊂' Λ₂ :=
by { rcases lt with ⟨n, lt⟩,
     rcases eqn n with ⟨m, eqn⟩, refine ⟨m, _⟩, exact list.is_initial.is_initial_of_suffix lt eqn }

lemma infinite.length {Λ : Path k} (h : Λ.infinite) (n : ℕ) : ∃ m, n < (Λ m).length :=
begin
  induction n with n IH,
  { rcases h 0 with ⟨m, h⟩, simp at h,
    refine ⟨m, _⟩, cases Λ m; simp at*, { contradiction } },
  { rcases IH with ⟨m, IH⟩, rcases h m with ⟨m', h⟩, refine ⟨m + m', _⟩,
    exact gt_of_gt_of_ge (h.lt_length) IH }
end

lemma infinite.lt_length_eq {Λ : Path k} (h : Λ.infinite) (n : ℕ) : ∃ μ, μ ⊂' Λ ∧ μ.length = n :=
by rcases h.length n with ⟨m, lt⟩;
   refine ⟨Λ m↾* n, ⟨_, list.is_initial_initial _ _ lt⟩, list.initial_length lt⟩

lemma thick.infinite {Λ : Path k} (h : Λ.thick) : Λ.infinite :=
λ s, ⟨1, by { rcases h.2 s with ⟨ν, eqn⟩, simp[eqn] }⟩

lemma thick.is_initial_of_lt {Λ : Path k} (h : Λ.thick) {s t : ℕ} (lt : s < t) : Λ s ⊂ᵢ Λ t :=
by { have : Λ s ⊂ᵢ Λ (s + 1), { rcases h.2 s with ⟨ν, eqn⟩, simp[eqn] },
     exact list.is_initial.is_initial_of_suffix this (Λ.mono' (nat.succ_le_iff.mpr lt)) }

lemma thick.length {Λ : Path k} (h : Λ.thick) (s : ℕ) : (Λ s).length = s :=
by { induction s with s IH, { simp[h.1] }, { rcases h.2 s with ⟨ν, eqn⟩, simp[eqn, IH] } }

lemma thick.ssubset {Λ : Path k} (h : Λ.thick) {μ} : μ ⊆' Λ ↔ ∃ s, μ = Λ s :=
⟨λ ss, by { rcases ss with ⟨s, eqn⟩, refine ⟨μ.length, _⟩,
     have : μ.length ≤ s,
     { have := eqn.le_length, simp[h.length] at this, exact this },
     have := list.suffix_of_suffix_length_le eqn (Λ.mono' this) (by simp[h.length]),
     exact list.eq_of_suffix_of_length_eq this (by simp[h.length]) }, λ ⟨s, eqn⟩, ⟨s, by simp[eqn]⟩⟩

lemma thick.eq_length_of_le {Λ : Path k} (h : Λ.thick) (μ : Tree k) (le : μ ⊆' Λ) : (Λ μ.length) = μ :=
by { rcases h.ssubset.mp le with ⟨s, rfl⟩, simp[h.length] }

lemma thick.lt_mono_iff {Λ : Path k} (h : Λ.thick) {s t : ℕ} : Λ s ⊂ᵢ Λ t ↔ s < t :=
by { have : s < t ∨ t ≤ s, from lt_or_ge s t, rcases this with (lt | le),
     { simp[lt], exact thick.is_initial_of_lt h lt },
     { simp[not_lt.mpr le], intros lt, exact list.is_initial_suffix_antisymm lt (Λ.mono' le) } }

lemma thick.le_mono_iff {Λ : Path k} (h : Λ.thick) {n m : ℕ} : Λ n <:+ Λ m ↔ n ≤ m :=
begin
  have C : n < m ∨ n = m ∨ m < n, from trichotomous n m,
  cases C,
  { have := h.is_initial_of_lt C, simp[le_of_lt C], exact list.is_initial.suffix this }, rcases C with (rfl | C),
  { simp },
  { simp[not_le.mpr C], have := h.is_initial_of_lt C, exact list.is_initial_suffix_antisymm this }
end

def thick.out {Λ : Path k} (h : Λ.thick) (s : ℕ) : Tree' k := out ⟨Λ s, h.is_initial_of_lt (lt_add_one s)⟩

lemma thick.succ_eq {Λ : Path k} (h : Λ.thick) (s : ℕ) : Λ (s + 1) = h.out s :: Λ s :=
by { rcases h.2 s with ⟨ν, eqn⟩,
     have : h.out s :: Λ s <:+ Λ (s + 1), from suffix_out_cons ⟨Λ s, h.is_initial_of_lt (lt_add_one s)⟩,
     simp[eqn] at this, simp[this, eqn] }

lemma thick.out_eq_out {Λ : Path k} (h : Λ.thick) {s t : ℕ} (lt : Λ s ⊂ᵢ Λ t) : out ⟨Λ s, lt⟩ = h.out s :=
by { rcases h.2 s with ⟨ν, eqn⟩,
     have eq₁ : out ⟨Λ s, lt⟩ = ν,
     { have le₁ : out ⟨Λ s, lt⟩ :: Λ s <:+ Λ t, from suffix_out_cons ⟨Λ s, lt⟩,
       have le₂ : ν :: Λ s <:+ Λ t, rw ←eqn, from h.le_mono_iff.mpr (nat.succ_le_iff.mpr (h.lt_mono_iff.mp lt)),
       have := list.suffix_or_suffix_of_suffix le₁ le₂, simp at this, cases this; simp[this] },
     have eq₂ : h.out s = ν,
     { simp[h.succ_eq s] at eqn, exact list.head_eq_of_cons_eq eqn },
     simp[eq₁, eq₂] }

lemma thick.infinite_out_eq_out {Λ : Path k} (h : Λ.thick) (inf : Λ.infinite) {s : ℕ} : inf.out s = h.out s :=
by simp[infinite.out, h.out_eq_out]

lemma infinite.thick_exists {Λ : Path k} (h : Λ.infinite) :
  ∃ Λ' : Path k, Λ' ≃ₚ Λ ∧ Λ'.thick :=
begin
  have : ∃ f : ℕ → ℕ, ∀ x, x < list.length (Λ (f x)), from classical.skolem.mp (infinite.length h),
  rcases this with ⟨f, eqn⟩,
  let P : ℕ → Tree k := λ s, Λ (f s)↾*s,
  have P_length : ∀ s, (P s).length = s, from λ s, list.initial_length (eqn s),
  have le : ∀ s, P s <:+ P (s + 1),
  { intros s, simp[P],
    have lmm₁ : P s <:+ Λ (max (f s) (f (s + 1))),
      from (list.suffix_initial (Λ (f s)) s).trans (Λ.mono' (le_max_left _ _)),
    have lmm₂ : P (s + 1) <:+ Λ (max (f s) (f (s + 1))),
      from (list.suffix_initial (Λ (f (s + 1))) (s + 1)).trans (Λ.mono' (le_max_right _ _)),
    refine list.suffix_of_suffix_length_le lmm₁ lmm₂ (by simp[P_length]) },
  let Λ' : Path k := ⟨P, le⟩,
  have equiv : Λ' ≃ₚ Λ,
  { split, { intros s, exact ⟨f s, list.suffix_initial _ _⟩ },
    { intros s, refine ⟨(Λ s).length, _⟩, simp[Λ', P],
      have lmm₁ : Λ s <:+ Λ (max s (f (Λ s).length)), from Λ.mono' (le_max_left _ _),
      have lmm₂ : P (Λ s).length <:+ Λ (max s (f (Λ s).length)),
        from (list.suffix_initial (Λ (f _)) _).trans (Λ.mono' (le_max_right _ _)),
      refine list.suffix_of_suffix_length_le lmm₁ lmm₂ (by simp[P_length]) } },
  have thick : Λ'.thick,
  { split, { simp[Λ', P] },
    intros s,
    rcases (le s).is_initial_of_lt (by simp[P, P_length]) with ⟨l, ν, eqn⟩,
    have : l = [], { have := congr_arg list.length eqn, simp[P_length] at this, exact list.length_eq_zero.mp this },
    rcases this with rfl, simp at eqn,
    refine ⟨ν, eq.symm eqn⟩ },
  exact ⟨Λ', equiv, thick⟩
end

end Path

def eventually_include {k} (μ : Tree k) (η : ℕ → Tree k) : Prop :=
∃ s₀, μ = η s₀ ∧ ∀ s ≥ s₀, μ <:+ η s

notation `lim` binders `, ` μ ` =≤ ` r:(scoped η, eventually_include μ η) := r

def eventually_include_s {k} {μ₀ : Tree k} (μ : ancestor μ₀) (η : ℕ → Tree k) : Prop :=
∃ s₀, ↑μ = η s₀ ∧ ∀ s ≥ s₀, out μ :: μ.val <:+ η (s + 1)

notation `lim` binders `, ` μ ` =< ` r:(scoped η, eventually_include_s μ η) := r

@[simp] def Tree'.is_pi : Π {k} (η : Tree' k), bool
| 0       ff       := ff
| 0       tt       := tt
| (k + 1) (η :: _) := !Tree'.is_pi η
| (k + 1) []       := ff

def Tree'.is_sigma {k} (η : Tree' k) : bool := !η.is_pi

@[simp] def Tree'.is_validated : Π {k} (η : Tree' k), bool
| 0       ff       := ff
| 0       tt       := tt
| (k + 1) (η :: _) := Tree'.is_validated η
| (k + 1) []       := ff

def infinity : Tree' 0 := tt
notation `∞` := infinity

def zero : Tree' 0 := ff
notation `𝟘` := zero

@[simp] lemma is_pi_neg {k} {η : Tree k} : !η.is_pi ↔ η.is_sigma := by simp[Tree'.is_sigma]

lemma neg_is_pi_iff {k} {η : Tree k} : ¬η.is_pi ↔ η.is_sigma :=
by { unfold Tree'.is_sigma, cases Tree'.is_pi η; simp }

@[simp] lemma is_pi_eq_ff {k} {η : Tree' k} : η.is_pi = ff ↔ η.is_sigma :=
by { unfold Tree'.is_sigma, cases Tree'.is_pi η; simp }

@[simp] lemma is_sigma_eq_ff {k} {η : Tree' k} : η.is_sigma = ff ↔ η.is_pi :=
by { unfold Tree'.is_sigma, cases Tree'.is_pi η; simp }

lemma pi_or_sigma {k} (η : Tree' k) : η.is_pi ∨ η.is_sigma :=
by { unfold Tree'.is_sigma, cases η.is_pi; simp }

lemma not_pi_sigma {k} {η : Tree' k} (pi : η.is_pi) (sigma : η.is_sigma) : false :=
by { simp only [Tree'.is_sigma] at sigma, cases η.is_pi, { exact bool.not_ff pi }, { exact bool.not_ff sigma } }

@[simp] lemma pi_cons_iff_sigma {k} (μ : Tree' k) (η : Tree k) : @Tree'.is_pi (k + 1) (μ :: η) = μ.is_sigma :=
by simp[Tree'.is_sigma]

@[simp] lemma sigma_cons_iff_pi {k} (μ : Tree' k) (η : Tree k) : @Tree'.is_sigma (k + 1) (μ :: η) = μ.is_pi :=
by simp[Tree'.is_sigma]

@[simp] lemma is_pi_iff_eq_infinity (μ : Tree' 0) : μ.is_pi ↔ μ = ∞ :=
by simp[infinity]; cases μ; simp

@[simp] lemma is_sigma_iff_eq_zero (μ : Tree' 0) : μ.is_sigma ↔ μ = 𝟘 :=
by simp[zero]; cases μ; simp[Tree'.is_sigma]

lemma Path.thick.out_sigma {k} {Λ : Path k} (h : Λ.thick) {s : ℕ} : (Λ (s + 1)).is_sigma ↔ (h.out s).is_pi :=
by simp [h.succ_eq]

lemma Path.thick.out_pi {k} {Λ : Path k} (h : Λ.thick) {s : ℕ} : (Λ (s + 1)).is_pi ↔ (h.out s).is_sigma :=
by simp [h.succ_eq]

def ancestor.pi_outcome {k} {η : Tree k} (μ : ancestor η) : bool := (out μ).is_sigma

def ancestor.sigma_outcome {k} {η : Tree k} (μ : ancestor η) : bool := (out μ).is_pi

lemma lt_or_le_of_le_of_le {k} {μ₁ μ₂ η : Tree k} (le₁ : μ₁ <:+ η) (le₂ : μ₂ <:+ η) : μ₁ ⊂ᵢ μ₂ ∨ μ₂ <:+ μ₁ :=
begin
  have lt₁ : μ₁ ⊂ᵢ (default _) :: η, from list.is_initial_cons_iff_suffix.mpr le₁,
  have lt₂ : μ₂ ⊂ᵢ (default _) :: η, from list.is_initial_cons_iff_suffix.mpr le₂,
  have : ancestor.mk' lt₁ < ancestor.mk' lt₂ ∨ ancestor.mk' lt₂ ≤ ancestor.mk' lt₁,
  from lt_or_ge (ancestor.mk' lt₁) (ancestor.mk' lt₂), simp[ancestor.lt_iff, ancestor.le_iff] at this, exact this
end

lemma trichotomous_of_le_of_le {k} {μ₁ μ₂ η : Tree k} (le₁ : μ₁ <:+ η) (le₂ : μ₂ <:+ η) : μ₁ ⊂ᵢ μ₂ ∨ μ₁ = μ₂ ∨ μ₂ ⊂ᵢ μ₁ :=
begin
  have := lt_or_le_of_le_of_le le₁ le₂, simp[list.suffix_iff_is_initial] at this,
  rcases this with (h | h | h); simp[h]
end

def Tree'.proper : ∀ {n}, Tree' n → Prop
| 0       _ := true
| 1       _ := true
| (n + 2) η := list.ordered (⊂ᵢ) η ∧
    ∀ {μ : Tree' (n + 1)}, μ ∈ η → Tree'.proper μ

def Path.proper {k} (Λ : Path k) : Prop := ∀ s, (Λ s).proper

@[simp] lemma Path.proper_0 (Λ : Path 0) : Λ.proper := λ s, by simp[Tree'.proper]

namespace Tree'.proper

lemma proper_of_mem {n} {η : Tree n}
  (proper : η.proper) {μ : Tree' n} (mem : μ ∈ η) : μ.proper :=
by cases n; simp[Tree'.proper] at proper; exact proper.2 mem

lemma proper_of_cons {n} {η : Tree n} {μ : Tree' n}
  (proper : @Tree'.proper (n + 1) (μ :: η)) : η.proper :=
by cases n; simp[Tree'.proper] at*; refine ⟨list.ordered_cons proper.1, proper.2.2⟩

@[simp] def nil (k : ℕ) : @Tree'.proper (k + 1) ([] : Tree k) :=
by cases k; simp[Tree'.proper]

def singleton {k : ℕ} (η : Tree' k) (proper : η.proper) : @Tree'.proper (k + 1) [η] :=
by cases k; simp[Tree'.proper, proper]

lemma proper_of_le {k} {η₁ η₂ : Tree k} (le : η₁ <:+ η₂) (proper : η₂.proper) : η₁.proper :=
by { cases k; simp[Tree'.proper],
     refine ⟨list.ordered_suffix le proper.1, λ μ mem, _⟩,
     have : μ ∈ η₂, { rcases le with ⟨_, rfl⟩, exact list.mem_append_right _ mem},
     exact proper.2 this }

lemma le_length_of_proper {k} {ν : Tree k} {μ : Tree (k + 1)} (proper : @Tree'.proper (k + 2) (ν :: μ)) :
  μ.length ≤ ν.length :=
begin
  induction μ with σ μ IH generalizing ν; simp,
  have : @Tree'.proper (k + 2) (σ :: μ), from proper_of_le (by simp) proper,
  have le : μ.length ≤ σ.length, from IH this,
  have lt : σ.length < ν.length, exact list.is_initial_length (proper.1.2 σ (by simp)),
  exact nat.succ_le_iff.mpr (lt_of_le_of_lt le lt)
end

end Tree'.proper

def Tree'.weight_aux : ∀ {k}, Tree' k → ℕ
| 0       ff := 0
| 0       tt := 1
| (k + 1) μ  := list.weight_of (@Tree'.weight_aux k) μ

variables {k : ℕ}

lemma lt_weight_aux_of_lt {μ₁ μ₂ : Tree k} (lt : μ₁ ⊂ᵢ μ₂) : μ₁.weight_aux < μ₂.weight_aux :=
list.lt_weight_of_is_initial lt

lemma lt_weight_aux_of_mem {μ : Tree' k} {η : Tree k} (lt : μ ∈ η) : μ.weight_aux < η.weight_aux :=
list.lt_weight_of_mem lt

lemma weight_aux_injective : ∀ {k}, function.injective (@Tree'.weight_aux k)
| 0       tt tt eqn := by simp[Tree'.weight_aux] at eqn
| 0       tt ff eqn := by simp[Tree'.weight_aux] at eqn; contradiction
| 0       ff tt eqn := by simp[Tree'.weight_aux] at eqn; contradiction
| 0       ff ff eqn := by simp[Tree'.weight_aux] at eqn
| (k + 1) μ₁ μ₂ eqn := list.weight_of_injective (@weight_aux_injective k) eqn

def Tree.weight : Π {k}, Tree k → ℕ
| 0       μ        := μ.weight_aux
| (k + 1) []       := 0
| (k + 1) (ν :: μ) := ν.weight_aux + 1

@[simp] lemma weight_nil : @Tree.weight k [] = 0 := by cases k; simp[Tree.weight, Tree'.weight_aux]

@[simp] lemma weight_cons_pos (μ : Tree' k) (η : Tree k) : 0 < Tree.weight (μ :: η) :=
by {cases k; simp[Tree.weight, Tree'.weight_aux, list.weight_of] }

lemma lt_weight_of_lt : ∀ {k} {μ₁ μ₂ : Tree k} (proper : μ₂.proper), μ₁ ⊂ᵢ μ₂ → μ₁.weight < μ₂.weight
| 0       μ₁         μ₂         _      lt := by {simp[Tree.weight], exact lt_weight_aux_of_lt lt }
| (k + 1) μ          []         _      lt := by { simp at lt, contradiction }
| (k + 1) []         (ν :: μ)   _      lt := by simp[Tree.weight]
| (k + 1) (ν₁ :: μ₁) (ν₂ :: μ₂) proper lt := by {
    simp[Tree.weight],
    have : ν₁ ⊂ᵢ ν₂,
    { have : ν₁ ∈ μ₂, { rcases list.is_initial_cons_iff_suffix.mp lt with ⟨l, rfl⟩, simp },
      exact proper.1.2 ν₁ this },
    exact lt_weight_aux_of_lt this }

lemma le_weight_of_le {k} {μ₁ μ₂ : Tree k} (proper : μ₂.proper) (le : μ₁ <:+ μ₂) : μ₁.weight ≤ μ₂.weight :=
by { rcases list.suffix_iff_is_initial.mp le with (lt | rfl),
     { exact le_of_lt (lt_weight_of_lt proper lt) }, { simp } }

lemma lt_weight_of_mem : ∀ {k} {μ : Tree k} {η : Tree (k + 1)} (proper : η.proper), μ ∈ η → μ.weight < η.weight
| k       μ        []       _      mem := by { simp at mem, contradiction }
| k       []       (ν :: η) _      mem := by { cases k; simp[Tree.weight, Tree'.weight_aux] at mem ⊢ }
| 0       (σ :: μ) (ν :: η) proper mem := by {
    simp[Tree.weight] at mem ⊢, rcases mem with (rfl | mem),
    { simp },
    { rcases proper.1.2 (σ :: μ) mem with ⟨l, a, rfl⟩,
      refine nat.lt.step (lt_weight_aux_of_lt ⟨l, a, rfl⟩) } }
| (k + 1) (σ :: μ) (ν :: η) proper mem := by {
    simp[Tree.weight] at mem ⊢, rcases mem with (rfl | mem),
    { exact lt_weight_aux_of_mem (by simp) },
    { rcases proper.1.2 (σ :: μ) mem with ⟨_, _, rfl⟩, exact lt_weight_aux_of_mem (by simp) } }

lemma lt_weight_cons_of_lt {μ₁ μ₂ : Tree k} {η₁ η₂ : Tree (k + 1)} (lt : μ₁ ⊂ᵢ μ₂) :
  Tree.weight (μ₁ :: η₁) < Tree.weight (μ₂ :: η₂) :=
by { simp[Tree.weight], exact lt_weight_aux_of_lt lt}

lemma lt_weight_aux_length {k} (μ : Tree k) : μ.length ≤ μ.weight_aux :=
by { simp[Tree'.weight_aux], exact list.lt_length_weight }

lemma le_weight_length : ∀ {k} {μ : Tree k} (proper : μ.proper), μ.length ≤ μ.weight
| 0       μ        _      := by simp[Tree.weight, lt_weight_aux_length]
| (k + 1) []       _      := by simp
| (k + 1) (ν :: μ) proper := by { simp[Tree.weight], exact proper.le_length_of_proper.trans (lt_weight_aux_length ν) }

lemma weight_restrict_injective : ∀ {k} {μ μ₁ μ₂ : Tree k} (proper : μ.proper) (le₁ : μ₁ <:+ μ) (le₂ : μ₂ <:+ μ),
  μ₁.weight = μ₂.weight → μ₁ = μ₂
| 0 _ _ _ _ _ _ eqn := by { simp[Tree.weight] at eqn, exact weight_aux_injective eqn }
| (k + 1) μ [] [] _ le₁ le₂ eqn := rfl
| (k + 1) μ [] (ν₂ :: μ₂) _ le₁ le₂ eqn := by { exfalso, simp[Tree.weight] at eqn, exact nat.succ_ne_zero _ (eq.symm eqn) }
| (k + 1) μ (ν₁ :: μ₁) [] _ le₁ le₂ eqn := by { exfalso, simp[Tree.weight] at eqn, contradiction }
| (k + 1) μ (ν₁ :: μ₁) (ν₂ :: μ₂) proper le₁ le₂ eqn :=
    by { have : ν₁ :: μ₁ ⊂ᵢ ν₂ :: μ₂ ∨ ν₁ :: μ₁ = ν₂ :: μ₂ ∨ ν₂ :: μ₂ ⊂ᵢ ν₁ :: μ₁, from trichotomous_of_le_of_le le₁ le₂,
         rcases this with (lt | eq | lt),
         { exfalso,
           have : Tree.weight (ν₁ :: μ₁) < Tree.weight (ν₂ :: μ₂), from lt_weight_of_lt (Tree'.proper.proper_of_le le₂ proper) lt,
           simp[eqn] at this, contradiction },
         { exact eq },
         { exfalso,
           have : Tree.weight (ν₂ :: μ₂) < Tree.weight (ν₁ :: μ₁), from lt_weight_of_lt (Tree'.proper.proper_of_le le₁ proper) lt,
           simp[eqn] at this, contradiction } }


import linear_algebra.linear_map_module data.rat

namespace Q_div_Z

instance Q_div_Z.setoid : setoid ℚ :=
⟨λ x y, ∃ n : ℤ, x-y = n,
 λ x, ⟨0, by simp⟩,
 λ x y ⟨n, h⟩, ⟨-n, by simp [h.symm]⟩,
 λ x y z ⟨m, hm⟩ ⟨n, hn⟩, ⟨m + n, by simp [hm.symm, hn.symm]⟩⟩

end Q_div_Z

def Q_div_Z : Type :=
quotient Q_div_Z.Q_div_Z.setoid

namespace Q_div_Z

instance : add_comm_group Q_div_Z :=
by refine
{ add := quotient.lift₂ (λ x y, ⟦x + y⟧) (λ a₁ a₂ b₁ b₂ h1 h2,
    have h3 : ∃ n : ℤ, a₁ - b₁ = (n:ℚ), from h1,
    have h4 : ∃ n : ℤ, a₂ - b₂ = (n:ℚ), from h2,
    let ⟨m, hm⟩ := h3 in
    let ⟨n, hn⟩ := h4 in
    quotient.sound $ ⟨m + n, by simp [hm.symm, hn.symm]⟩),
  zero := ⟦0⟧,
  neg := quotient.lift (λ x, ⟦-x⟧) (λ a b h,
    have H : ∃ n : ℤ, a - b = (n:ℚ), from h,
    let ⟨n, hn⟩ := H in
    quotient.sound $ ⟨-n, by simp [hn.symm]⟩),
  .. };
{ intros,
  try {apply quotient.induction_on a, intro a},
  try {apply quotient.induction_on b, intro b},
  try {apply quotient.induction_on c, intro c},
  apply quotient.sound, simp }

end Q_div_Z

universes u v

variables (R : Type u) [ring R]

def Hom_R_Q_div_Z : Type u :=
{ f : R → Q_div_Z // ∀ x y, f (x + y) = f x + f y }

instance Hom_R_Q_div_Z.module : module R (Hom_R_Q_div_Z R) :=
{ add := λ ⟨f, hf⟩ ⟨g, hg⟩, ⟨λ x, f x + g x, by simp [hf, hg]⟩,
  zero := ⟨λ x, 0, by simp⟩,
  neg := λ ⟨f, hf⟩, ⟨λ x, - f x, by simp [hf]⟩,
  smul := λ r ⟨f, hf⟩, ⟨λ x, f (x * r), by simp [add_mul, hf]⟩,
  add_assoc := λ ⟨f, hf⟩ ⟨g, hg⟩ ⟨k, hk⟩, subtype.eq $ funext $ λ x, add_assoc _ _ _,
  zero_add := λ ⟨f, hf⟩, subtype.eq $ funext $ λ x, zero_add _,
  add_zero := λ ⟨f, hf⟩, subtype.eq $ funext $ λ x, add_zero _,
  add_left_neg := λ ⟨f, hf⟩, subtype.eq $ funext $ λ x, add_left_neg _,
  add_comm := λ ⟨f, hf⟩ ⟨g, hg⟩, subtype.eq $ funext $ λ x, add_comm _ _,
  add_smul := λ r s ⟨f, hf⟩, subtype.eq $ funext $ λ x,
    show f (x * (r + s)) = f (x * r) + f (x * s), by simp [mul_add, hf],
  smul_add := λ r ⟨f, hf⟩ ⟨g, hf⟩, subtype.eq $ funext $ λ x, rfl,
  mul_smul := λ r s ⟨f, hf⟩, subtype.eq $ funext $ λ x,
    show f (x * (r * s)) = f (x * r * s), by simp [mul_assoc],
  one_smul := λ ⟨f, hf⟩, subtype.eq $ funext $ λ x,
    show f (x * 1) = f x, by simp }

variables (M : Type v) [module R M]

class injective extends module R M :=
(extend_map : ∀ A B [module R A] [module R B] (f : linear_map A B) (H : function.injective f.1) (g : linear_map A M), linear_map B M)
(extend_map_extends : ∀ A B [module R A] [module R B] (f : linear_map A B) (H : function.injective f.1) (g : linear_map A M) (x : A), (extend_map A B f H g).1 (f.1 x) = g.1 x)

def find_injective : Type (max u v) :=
@linear_map R M (Hom_R_Q_div_Z R) _ _ (Hom_R_Q_div_Z.module R) → Hom_R_Q_div_Z R

instance find_injective.module : module R (find_injective R M) :=
by refine
{ add := λ x y f, by letI := Hom_R_Q_div_Z.module R; from x f + y f,
  zero := λ f, by letI := Hom_R_Q_div_Z.module R; from 0,
  neg := λ x f, by letI := Hom_R_Q_div_Z.module R; from -x f,
  smul := λ r x f, by letI := Hom_R_Q_div_Z.module R; from r • x f,
  .. };
{ intros, funext, letI := Hom_R_Q_div_Z.module R, simp,
  try { apply smul_add },
  try { apply add_smul },
  try { apply mul_smul } }

def find_injective.of_module : M → (find_injective R M) :=
λ m f, ⟨λ r, (f.1 m).1 r, (f.1 m).2⟩

theorem find_injective.of_module.is_linear_map : is_linear_map (find_injective.of_module R M) :=
{ add := λ x y, funext $ λ f, by letI := Hom_R_Q_div_Z.module R; simp [find_injective.of_module]; rw f.2.1 x y; refl,
  smul := λ c x, funext $ λ f, by letI := Hom_R_Q_div_Z.module R; simp [find_injective.of_module]; rw f.2.2 c x; refl, }

-- TODO:
-- 1. show that find_injective.of_module is injective
-- 2. show that find_injective is actually injective
-- facepalm


import for_mathlib.category_theory.triangulated.hom_homological
import for_mathlib.algebra.homology.trunc

noncomputable theory

namespace category_theory

open derived_category category limits

variables {C : Type*} [category C] [abelian C]

def Ext (n : ℕ) (X Y : C) :=
((single_functor C 0).obj X ⟶ ((single_functor C 0).obj Y)⟦(n : ℤ)⟧)

def Ext_functor (n : ℕ) : Cᵒᵖ ⥤ C ⥤ AddCommGroup :=
(single_functor C 0).op ⋙ preadditive_coyoneda ⋙
  (whiskering_left _ _ AddCommGroup).obj (single_functor C 0 ⋙ shift_functor _ (n : ℤ))

instance (n : ℕ) (X Y : C) : add_comm_group (Ext n X Y) :=
by { dsimp only [Ext], apply_instance, }

def Ext_map₁ (n : ℕ) {X X' : C} (f : X' ⟶ X) (Y : C) :
  Ext n X Y →+ Ext n X' Y :=
{ to_fun := λ e, ((single_functor C 0).map f) ≫ e,
  map_zero' := by simp,
  map_add' := by simp, }

def Ext_map₂ (n : ℕ) (X : C) {Y Y' : C} (g : Y ⟶ Y') :
  Ext n X Y →+ Ext n X Y' :=
{ to_fun := λ e, e ≫ ((single_functor C 0).map g)⟦(n : ℤ)⟧',
  map_zero' := by simp,
  map_add' := by simp, }

lemma Ext_map₁₂_comm (n : ℕ) {X X' Y Y' : C} (f : X' ⟶ X) (g : Y ⟶ Y') :
  (Ext_map₂ n X' g).comp (Ext_map₁ n f Y) = (Ext_map₁ n f Y').comp (Ext_map₂ n X g) :=
begin
  ext x,
  dsimp [Ext_map₂, Ext_map₁],
  rw assoc,
end

@[simp]
lemma Ext_map₁_id (n : ℕ) (X Y : C) :
  Ext_map₁ n (𝟙 X) Y = add_monoid_hom.id _ :=
begin
  ext x,
  dsimp [Ext_map₁],
  simp only [functor.map_id, id_comp],
end

@[simp]
lemma Ext_map₁_zero (n : ℕ) (X X' Y : C) :
  Ext_map₁ n (0 : X ⟶ X') Y = 0 :=
begin
  ext x,
  dsimp [Ext_map₁],
  simp only [functor.map_zero, zero_comp],
end

@[simp]
lemma Ext_map₁_comp (n : ℕ) {X X' X'' : C} (f : X ⟶ X') (f' : X' ⟶ X'') (Y : C) :
  Ext_map₁ n (f ≫ f') Y = (Ext_map₁ n f Y).comp (Ext_map₁ n f' Y) :=
begin
  ext x,
  dsimp [Ext_map₁],
  simp only [functor.map_comp, assoc],
end

@[simp]
lemma Ext_map₂_id (n : ℕ) (X Y : C) :
  Ext_map₂ n X (𝟙 Y) = add_monoid_hom.id _ :=
begin
  ext x,
  dsimp [Ext_map₂],
  simp only [functor.map_id, comp_id],
end

@[simp]
lemma Ext_map₂_zero (n : ℕ) (X Y Y' : C) :
  Ext_map₂ n X (0 : Y ⟶ Y') = 0 :=
begin
  ext x,
  dsimp [Ext_map₂],
  simp only [functor.map_zero, comp_zero],
end

@[simp]
lemma Ext_map₂_comp (n : ℕ) (X : C) {Y Y' Y'' : C} (g : Y ⟶ Y') (g' : Y' ⟶ Y'') :
  Ext_map₂ n X (g ≫ g') = (Ext_map₂ n X g').comp (Ext_map₂ n X g) :=
begin
  ext x,
  dsimp [Ext_map₂],
  simp only [functor.map_comp, assoc],
end

namespace short_complex

namespace short_exact

variables {S : short_complex C} (ex : S.short_exact)

include ex

def triangle : pretriangulated.triangle (derived_category C) :=
triangle_of_ses
  (short_complex.short_exact.map_of_exact ex
  (homological_complex.single C (complex_shape.up ℤ) 0))

lemma triangle_dist : ex.triangle ∈ dist_triang (derived_category C) :=
triangle_of_ses_dist _

def Ext_δ₂ (X : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  Ext n₀ X S.X₃ →+ Ext n₁ X S.X₁ :=
{ to_fun := λ x, x ≫ ex.triangle.mor₃⟦(n₀ : ℤ)⟧' ≫
    (shift_functor_add' (derived_category C) (1 : ℤ) n₀ n₁
      (by rw [h, nat.cast_add, add_comm, algebra_map.coe_one])).inv.app _,
  map_zero' := by simp,
  map_add' := by simp, }

lemma Ext_comp_δ₂ (X : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  (ex.Ext_δ₂ X n₀ n₁ h).comp (Ext_map₂ n₀ X S.g) = 0 :=
begin
  ext x,
  dsimp [Ext_map₂, Ext_δ₂],
  simp only [assoc],
  erw [← functor.map_comp_assoc, pretriangulated.triangle.comp_zero₂₃ _ ex.triangle_dist,
    functor.map_zero, zero_comp, comp_zero],
end

lemma Ext_δ₂_comp (X : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  (Ext_map₂ n₁ X S.f).comp (ex.Ext_δ₂ X n₀ n₁ h) = 0 :=
begin
  ext x,
  dsimp [Ext_map₂, Ext_δ₂],
  simp only [assoc],
  erw [← nat_trans.naturality, ← functor.map_comp_assoc,
    pretriangulated.triangle.comp_zero₃₁ _ ex.triangle_dist, functor.map_zero,
    zero_comp, comp_zero],
end

lemma Ext_ex₂₂ (X : C) (n : ℕ) :
  (short_complex.mk (AddCommGroup.of_hom (Ext_map₂ n X S.f))
    (AddCommGroup.of_hom (Ext_map₂ n X S.g)) begin
      ext x,
      simp only [comp_apply, AddCommGroup.of_hom_apply, AddCommGroup.zero_apply],
      rw [← add_monoid_hom.comp_apply, ← Ext_map₂_comp, S.zero,
        Ext_map₂_zero, add_monoid_hom.zero_apply],
    end).exact :=
functor.is_homological.ex₂
  (preadditive_coyoneda.obj (opposite.op ((single_functor C 0).obj X))) _ ex.triangle_dist n

lemma Ext_ex₂₂' {X : C} {n : ℕ} (x₂ : Ext n X S.X₂)
  (hx₂ : Ext_map₂ n X S.g x₂ = 0) :
  ∃ (x₁ : Ext n X S.X₁), Ext_map₂ n X S.f x₁ = x₂ :=
begin
  have h := ex.Ext_ex₂₂ X n,
  rw AddCommGroup_exact_iff at h,
  exact h x₂ hx₂,
end

lemma Ext_ex₂₃ (X : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  (short_complex.mk (AddCommGroup.of_hom (Ext_map₂ n₀ X S.g))
    (AddCommGroup.of_hom (ex.Ext_δ₂ X n₀ n₁ h)) begin
      ext x,
      simp only [comp_apply, AddCommGroup.of_hom_apply, AddCommGroup.zero_apply],
      rw [← add_monoid_hom.comp_apply, ex.Ext_comp_δ₂, add_monoid_hom.zero_apply],
    end).exact :=
functor.is_homological.ex₃
  (preadditive_coyoneda.obj (opposite.op ((single_functor C 0).obj X))) _ ex.triangle_dist _ _
  (by simp [h])

lemma Ext_ex₂₃' {X : C} (n₀ n₁ : ℕ) (h : n₁ = n₀+1)
  (x₃ : Ext n₀ X S.X₃)
  (hx₃ : ex.Ext_δ₂ X n₀ n₁ h x₃ = 0) :
  ∃ (x₂ : Ext n₀ X S.X₂), Ext_map₂ n₀ X S.g x₂ = x₃ :=
begin
  have h := ex.Ext_ex₂₃ X n₀ n₁ h,
  rw AddCommGroup_exact_iff at h,
  exact h x₃ hx₃,
end

lemma Ext_ex₂₁ (X : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  (short_complex.mk (AddCommGroup.of_hom (ex.Ext_δ₂ X n₀ n₁ h))
    (AddCommGroup.of_hom (Ext_map₂ n₁ X S.f)) begin
      ext x,
      simp only [comp_apply, AddCommGroup.of_hom_apply, AddCommGroup.zero_apply],
      rw [← add_monoid_hom.comp_apply, ex.Ext_δ₂_comp, add_monoid_hom.zero_apply],
    end).exact :=
functor.is_homological.ex₁
  (preadditive_coyoneda.obj (opposite.op ((single_functor C 0).obj X))) _ ex.triangle_dist _ _ (by simp [h])

lemma Ext_ex₂₁' {X : C} (n₀ n₁ : ℕ) (h : n₁ = n₀+1)
  (x₁ : Ext n₁ X S.X₁)
  (hx₁ : Ext_map₂ n₁ X S.f x₁ = 0) :
  ∃ (x₃ : Ext n₀ X S.X₃), ex.Ext_δ₂ X n₀ n₁ h x₃ = x₁ :=
begin
  have h := ex.Ext_ex₂₁ X n₀ n₁ h,
  rw AddCommGroup_exact_iff at h,
  exact h x₁ hx₁,
end

def Ext_δ₁ (Y : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  Ext n₀ S.X₁ Y →+ Ext n₁ S.X₃ Y :=
{ to_fun := λ x, ((-1 : units ℤ)^n₁) • ex.triangle.mor₃ ≫ x⟦(1 : ℤ)⟧' ≫
    (shift_functor_add' (derived_category C) (n₀ : ℤ) 1 n₁
      (by rw [h, nat.cast_add, algebra_map.coe_one])).inv.app _,
  map_zero' := by simp only [functor.map_zero, zero_comp, comp_zero, smul_zero],
  map_add' := λ a b, by simp only [functor.map_add, preadditive.add_comp,
    preadditive.comp_add, smul_add], }

lemma Ext_δ₁_comp (Y : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  (ex.Ext_δ₁ Y n₀ n₁ h).comp (Ext_map₁ n₀ S.f Y) = 0 :=
begin
  ext x,
  dsimp [Ext_δ₁, Ext_map₁],
  simp only [assoc, functor.map_comp],
  erw [pretriangulated.triangle.comp_zero₃₁_assoc _ ex.triangle_dist, zero_comp, smul_zero],
end

lemma Ext_comp_δ₁ (Y : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  (Ext_map₁ n₁ S.g Y).comp (ex.Ext_δ₁ Y n₀ n₁ h) = 0 :=
begin
  ext x,
  dsimp [Ext_map₁, Ext_δ₁],
  erw [preadditive.comp_zsmul, pretriangulated.triangle.comp_zero₂₃_assoc _ ex.triangle_dist,
    zero_comp, zsmul_zero],
end

lemma Ext_δ₁_δ₂ {S' : short_complex C} (ex' : S'.short_exact) (n₀ n₁ n₂ : ℕ)
  (hn₁ : n₁ = n₀+1) (hn₂ : n₂ = n₁+1) :
  (ex.Ext_δ₁ S'.X₁ n₁ n₂ hn₂).comp (ex'.Ext_δ₂ S.X₁ n₀ n₁ hn₁) =
    -(ex'.Ext_δ₂ S.X₃ n₁ n₂ hn₂).comp (ex.Ext_δ₁ S'.X₃ n₀ n₁ hn₁) :=
begin
  ext x,
  dsimp [Ext_δ₁, Ext_δ₂],
  simp only [hn₂, pow_add, pow_one, mul_neg, mul_one],
  erw preadditive.zsmul_comp,
  rw units.neg_smul,
  simp only [assoc, functor.map_comp],
  erw ← nat_trans.naturality_assoc,
  congr' 5,
  erw ← shift_functor_add₃'_inv_app (1 : ℤ) n₀ 1 n₂ (by linarith) n₁ (by linarith),
  rw ← shift_functor_add₃'_inv_app' (1 : ℤ) n₀ 1,
end

local attribute [instance] has_shift_op_neg_ℤ

lemma triangle_op_dist : ex.triangle.op ∈ dist_triang (derived_category C)ᵒᵖ :=
by simpa only [ ← pretriangulated.mem_dist_triang_iff_op] using ex.triangle_dist

lemma Ext_ex₁₂ (Y : C) (n : ℕ) :
  (short_complex.mk (AddCommGroup.of_hom (Ext_map₁ n S.g Y))
    (AddCommGroup.of_hom (Ext_map₁ n S.f Y)) begin
      ext x,
      simp only [comp_apply, AddCommGroup.of_hom_apply, AddCommGroup.zero_apply],
      rw [← add_monoid_hom.comp_apply, ← Ext_map₁_comp, S.zero, Ext_map₁_zero,
        add_monoid_hom.zero_apply],
    end).exact :=
functor.is_homological.map_distinguished (preadditive_yoneda.obj
  (((single_functor C 0).obj Y)⟦(n : ℤ)⟧)) _ ex.triangle_op_dist

lemma Ext_ex₁₂' {Y : C} {n : ℕ} (x₂ : Ext n S.X₂ Y)
  (hx₂ : Ext_map₁ n S.f Y x₂ = 0) :
  ∃ (x₃ : Ext n S.X₃ Y), Ext_map₁ n S.g Y x₃ = x₂ :=
begin
  have h := ex.Ext_ex₁₂ Y n,
  rw AddCommGroup_exact_iff at h,
  exact h x₂ hx₂,
end

/- This should be done by first developping notions about homological functors
in two variables `C ⥤ D ⥤ A` with `C`, `D` triangulated categories and `A` abelian.

lemma Ext_ex₁₁ (Y : C) (n₀ n₁ : ℕ) (h : n₁ = n₀+1) :
  (short_complex.mk (AddCommGroup.of_hom (Ext_map₁ n₀ S.f Y))
    (AddCommGroup.of_hom (ex.Ext_δ₁ Y n₀ n₁ h)) begin
      ext x,
      simp only [comp_apply, AddCommGroup.of_hom_apply, AddCommGroup.zero_apply],
      rw [← add_monoid_hom.comp_apply, Ext_δ₁_comp, add_monoid_hom.zero_apply],
    end).exact :=
begin
  refine (exact_iff_of_iso _ ).1 (functor.is_homological.map_distinguished
    (preadditive_yoneda.obj (((single_functor C 0).obj Y)⟦(n₀ : ℤ)⟧)) ex.triangle.op.rotate
      (by simpa only [← pretriangulated.rotate_distinguished_triangle] using ex.triangle_op_dist)),
  refine short_complex.mk_iso (iso.refl _) (iso.refl _) _ sorry sorry,
  dsimp [Ext, pretriangulated.triangle.op, short_complex.short_exact.triangle, triangle_of_ses],
  sorry,
end

lemma Ext_ex₁₁' {Y : C} (n₀ n₁ : ℕ) (h : n₁ = n₀+1) (x₁ : Ext n₀ S.X₁ Y)
  (hx₁ : ex.Ext_δ₁ Y n₀ n₁ h x₁ = 0) :
  ∃ (x₃ : Ext n₀ S.X₂ Y), Ext_map₁ n₀ S.f Y x₃ = x₁ :=
begin
  have h := ex.Ext_ex₁₁ Y n₀ n₁ h,
  rw AddCommGroup_exact_iff at h,
  exact h x₁ hx₁,
end-/

end short_exact

end short_complex

end category_theory


import category_theory.limits.shapes

open category_theory category_theory.category category_theory.limits

universes u v
variables {C : Type u} [𝒞 : category.{v} C]
variables {J : Type v} [small_category J]
include 𝒞

@[simp] lemma limit.lift_self_id (F : J ⥤ C) [has_limit F] :
  limit.lift F (limit.cone F) = 𝟙 (limit F) :=
begin
  symmetry, refine is_limit.uniq _ _ _ _,
  intro j, erw [id_comp _ (limit.π F j)], refl,
end


import data.pfun
import logic.relation
import data.fun_like.basic
import computability.turing_machine

open relation (refl_trans_gen)

@[ext]
structure execution (σ : Type*) :=
(next : σ →. option σ)
(start : σ)

namespace execution
variables {σ τ : Type*}

def states (f : execution σ) : set σ :=
{s | refl_trans_gen (λ x y, some y ∈ f.next x) f.start s}

lemma start_mem_states (f : execution σ) : f.start ∈ f.states :=
relation.refl_trans_gen.refl

lemma mem_states_of_fwd {f : execution σ} {x y} (hx : x ∈ f.states) (hxy : some y ∈ f.next x) :
  y ∈ f.states :=
relation.refl_trans_gen.tail hx hxy

lemma fwd_states {f : execution σ} {y} (hy : some y ∈ f.next f.start) :
  f.states = insert f.start (states ⟨f.next, y⟩) :=
begin
  ext, dsimp [states],
  rw relation.refl_trans_gen.cases_head_iff, rw ← part.eq_some_iff at hy,
  simp [hy], tauto,
end

@[elab_as_eliminator]
theorem step_induction {P : σ → Prop} {f : execution σ} {x : σ} (hx : x ∈ f.states) (base : P f.start)
  (step : ∀ ⦃x y⦄, x ∈ f.states → P x → some y ∈ f.next x → P y) : P x :=
by { induction hx with _ _ H h ih, { assumption, }, { refine step H ih h, } }

lemma mem_ran_of_mem_states {f : execution σ} {y : σ} (hy : y ∈ f.states) :
  y = f.start ∨ some y ∈ f.next.ran :=
begin
  apply step_induction hy, { exact or.inl rfl, },
  intros x y hx _,
  simp [pfun.ran], tauto,
end

variables (f : execution σ)

def eval : part σ :=
pfun.fix (λ s, (f.next s).map (λ x, x.elim (sum.inl s) sum.inr)) f.start

theorem eval_from {f : execution σ} {x : σ} (hx : x ∈ f.states) : eval ⟨f.next, x⟩ = f.eval :=
begin
  apply execution.step_induction hx, { refl, },
  intros x y _ h hn,
  rw [eval, pfun.fix_fwd x y] at h, { exact h, },
  simp, use some y, simpa
end

@[elab_as_eliminator] def eval_induction {σ}
  {f : σ →. option σ} {b : σ} {C : σ → Sort*} {a : σ} (h : b ∈ eval ⟨f, a⟩)
  (H : ∀ a, b ∈ eval ⟨f, a⟩ →
    (∀ a', (some a') ∈ f a → C a') → C a) : C a :=
by { dsimp only [eval] at h, exact pfun.fix_induction h (λ _ b ih, H _ b (λ _ ha, ih _ (by { rw ← part.eq_some_iff at ha, simp [ha], }))), }

theorem mem_eval {σ} {f : execution σ} {b} :
  b ∈ f.eval ↔ b ∈ f.states ∧ none ∈ f.next b :=
begin
  split,
  { intro h, cases f with f a, dsimp only at *,
    apply eval_induction h, clear h a, intros a hb ih,
    have : (f a).dom := by simpa using pfun.dom_of_mem_fix hb,
    rw part.dom_iff_mem at this,
    rcases this with ⟨a'|a', ha'⟩, rw ← part.eq_some_iff at ha',
    { rw [eval] at hb, cases (part.mem_unique hb (pfun.fix_stop a _) : b = a),
      { rw part.eq_some_iff at ha', exact ⟨start_mem_states _, ha'⟩, }, { simp [ha'], } },
    specialize ih a' ha',
    refine ⟨_, ih.2⟩, rw @fwd_states _ ⟨f, a⟩ _ ha', simp, right, exact ih.1, },
  { rintro ⟨h₁, h₂⟩,
    rw ← eval_from h₁, dsimp only [eval] at *,
    apply pfun.fix_stop,
    rw ← part.eq_some_iff at h₂, simp [h₂], }
end

end execution

section tr_step
variables {σ τ : Type*}

structure stepwise_tr (f : execution σ) (g : execution τ) :=
(rel : σ → τ → Prop)
(dom_iff : ∀ {x y}, x ∈ f.states → y ∈ g.states → rel x y → ((f.next x).dom ↔ (g.next y).dom))
(some_iff : ∀ {x y x' y'}, x ∈ f.states → y ∈ g.states → rel x y → some x' ∈ f.next x → some y' ∈ g.next y → rel x' y')
(none_iff : ∀ {x y}, x ∈ f.states → y ∈ g.states → rel x y → (none ∈ f.next x ↔ none ∈ g.next y))
(start : rel f.start g.start)

infixr ` ∼ₛ `:25 := stepwise_tr

namespace stepwise_tr
variables {f : execution σ} {g : execution τ} (h : f ∼ₛ g)

@[symm, simps]
def symm : g ∼ₛ f :=
{ rel := λ a b, h.rel b a,
  dom_iff := λ x y hx hy hrel, by rw h.dom_iff hy hx hrel,
  some_iff := λ x y x' y' hx hy hrel h₁ h₂, h.some_iff hy hx hrel h₂ h₁,
  none_iff := λ x y hx hy hrel, by rw h.none_iff hy hx hrel,
  start := h.start }

theorem exists_some_of {x y x'} (hx : x ∈ f.states) (hy : y ∈ g.states) (hrel : h.rel x y)
  (hx' : some x' ∈ f.next x) : ∃ y', some y' ∈ g.next y ∧ h.rel x' y' :=
begin
  obtain ⟨y', hy'⟩ : ∃ y', y' ∈ g.next y,
  { rw [← part.dom_iff_mem, ← h.dom_iff hx hy hrel, part.dom_iff_mem], exact ⟨_, hx'⟩, },
  cases y', { rw ← h.none_iff hx hy hrel at hy', cases part.mem_unique hx' hy', },
  refine ⟨_, hy', _⟩,
  exact h.some_iff hx hy hrel hx' hy',
end

theorem exists_some_iff {x y} (hx : x ∈ f.states) (hy : y ∈ g.states) (hrel : h.rel x y) :
  (∃ x', some x' ∈ f.next x) ↔ (∃ y', some y' ∈ g.next y) :=
by { split, { rintro ⟨x', hx'⟩, rcases h.exists_some_of hx hy hrel hx' with ⟨y', hy', _⟩, exact ⟨y', hy'⟩, },
    { rintro ⟨y', hy'⟩, rcases h.symm.exists_some_of hy hx hrel hy' with ⟨x', hx', _⟩, exact ⟨x', hx'⟩, }, }

@[trans, simps]
def trans {γ : Type*} {f : execution σ} {g : execution τ} {h : execution γ}
  (r₁ : f ∼ₛ g) (r₂ : g ∼ₛ h) : f ∼ₛ h :=
{ rel := λ a b, ∃ c ∈ g.states, r₁.rel a c ∧ r₂.rel c b,
  dom_iff := λ x y hx hy ⟨c, hc, h₁, h₂⟩, by rw [r₁.dom_iff hx hc h₁, r₂.dom_iff hc hy h₂],
  some_iff := λ x y x' y' hx hy ⟨c, hc, hc₁, hc₂⟩ h₁ h₂,
begin
  obtain ⟨c', h₁c', h₂c'⟩ := r₁.exists_some_of hx hc hc₁ h₁,
  refine ⟨_, execution.mem_states_of_fwd hc h₁c', h₂c', _⟩,
  exact r₂.some_iff hc hy hc₂ h₁c' h₂,
end,
  none_iff := λ x y hx hy ⟨c, hc, h₁, h₂⟩, by rw [r₁.none_iff hx hc h₁, r₂.none_iff hc hy h₂],
  start := ⟨g.start, execution.start_mem_states _, r₁.start, r₂.start⟩, }

@[simps]
def extend (r₁ : f ∼ₛ g) (rel₂ : σ → τ → Prop)
  (some_iff : ∀ {x y x' y'}, x ∈ f.states → y ∈ g.states → r₁.rel x y → rel₂ x y → some x' ∈ f.next x → some y' ∈ g.next y → rel₂ x' y')
  (start : rel₂ f.start g.start) : f ∼ₛ g :=
{ rel := λ a b, r₁.rel a b ∧ rel₂ a b,
  dom_iff := λ x y hx hy hrel, by rw r₁.dom_iff hx hy hrel.1,
  some_iff := λ x y x' y' hx hy hrel hx' hy', ⟨r₁.some_iff hx hy hrel.1 hx' hy', some_iff hx hy hrel.1 hrel.2 hx' hy'⟩,
  none_iff := λ x y hx hy hrel, by rw r₁.none_iff hx hy hrel.1,
  start := ⟨r₁.start, start⟩ }

theorem exists_state_of {x} (hx : x ∈ f.states) : ∃ y, y ∈ g.states ∧ h.rel x y :=
begin
  apply execution.step_induction hx; clear hx x,
  { exact ⟨_, g.start_mem_states, h.start⟩, },
  rintros x x' hx ⟨y, h₁y, h₂y⟩ hx',
  obtain ⟨y', hy', H⟩ := h.exists_some_of hx h₁y h₂y hx',
  exact ⟨y', execution.mem_states_of_fwd h₁y hy', H⟩,
end

theorem mem_eval_of {x} (hx : x ∈ f.eval) : ∃ y, y ∈ g.eval ∧ h.rel x y :=
begin
  simp only [execution.mem_eval] at *, cases hx with hx₁ hx₂,
  obtain ⟨y, hy, H⟩ := h.exists_state_of hx₁, refine ⟨y, ⟨hy, _⟩, H⟩,
  rwa ← h.none_iff hx₁ hy H,
end

theorem rel_of_mem_eval {x y} (hx : x ∈ f.eval) (hy : y ∈ g.eval) : h.rel x y :=
begin
  obtain ⟨y, hy', hrel⟩ := h.mem_eval_of hx,
  cases part.mem_unique hy hy',
  exact hrel,
end

theorem eval_dom_iff (h : f ∼ₛ g) : f.eval.dom ↔ g.eval.dom :=
begin
  simp only [part.dom_iff_mem], split,
  { rintro ⟨x, hx⟩, obtain ⟨y, hy, _⟩ := h.mem_eval_of hx, exact ⟨y, hy⟩, },
  { rintro ⟨y, hy⟩, obtain ⟨x, hx, _⟩ := h.symm.mem_eval_of hy, exact ⟨x, hx⟩, },
end

end stepwise_tr

section track_with
variables (f : execution σ) (state : τ → σ →. τ) (s : τ)
def execution.track_with : execution (τ × σ) :=
{ next := λ x, (f.next x.2).bind (λ x', x'.elim (part.some none) (λ x'', (state x.1 x.2).map (λ s', some (s', x'')))),
-- { next := λ x, (state x.1 x.2).bind $ λ s', (f.next x.2).map $ λ x', x'.map (prod.mk s'),
  start := (s, f.start) }

lemma _root_.option.elim_comp {α β} (P : β → Sort*) (x : option α) (y : β) (f : α → β)  :
  P (x.elim y f) = (x.elim (P y) (P ∘ f)) :=
by cases x; simp

@[simp] lemma _root_.option.elim_true {α} (x : option α) (f : α → Prop) :
  x.elim true f ↔ ∀ y, x = some y → f y :=
by cases x; simp

@[simp] lemma _root_.option.eq_none_iff_forall_not_some {α} (x : option α) :
  (∀ y, x ≠ some y) ↔ (x = none) :=
by simp_rw [ne.def, ← not_exists, ← option.is_some_iff_exists, option.not_is_some_iff_eq_none]

@[simp] lemma _root_.option.elim_false {α} (x : option α) (f : α → Prop) :
  x.elim false f ↔ (∃ y, x = some y ∧ f y) :=
by cases x; simp

@[simp] lemma execution.track_with_dom_iff {x : τ × σ} :
  ((f.track_with state s).next x).dom ↔ (f.next x.2).dom ∧ (∀ y, some y ∈ f.next x.2 → (state x.1 x.2).dom) :=
by simp [execution.track_with, option.elim_comp part.dom, function.comp, part.get_eq_iff_mem]

@[simp] lemma execution.track_with_some_def {x y : τ × σ} :
  some y ∈ (f.track_with state s).next x ↔ y.1 ∈ state x.1 x.2 ∧ some y.2 ∈ f.next x.2 :=
begin
  cases x with x₁ x₂, cases y with y₁ y₂,
  simp [execution.track_with, option.elim_comp (has_mem.mem (some (y₁, y₂)))], tidy,
end

@[simp] lemma execution.track_with_none_def {x : τ × σ} :
  none ∈ (f.track_with state s).next x ↔ none ∈ f.next x.2 :=
by simp [execution.track_with, option.elim_comp (has_mem.mem none), imp_false]

@[simp] lemma execution.track_with_start :
  (f.track_with state s).start = (s, f.start) := rfl

@[simps]
def tr_of_track_with (hd : ∀ {x x'} (y), x ∈ f.states → some x' ∈ f.next x → (state y x).dom) :
  f ∼ₛ f.track_with state s :=
{ rel := λ a b, a = b.snd,
  dom_iff := λ x y hx hy, by { rintro rfl, simp, tauto, },
  some_iff := λ x y x' y' _ _,
begin
  rintro rfl,
  intros h, rw ← part.eq_some_iff at h,
  cases y', simp [h], tauto,
end,
  none_iff := λ x y hx _,
begin
  cases y with y₁ y₂,
  rintro rfl,
  simp,
end,
  start := rfl }

@[simp] lemma track_with_eval_dom (hd : ∀ ⦃x x'⦄ (y), x ∈ f.states → some x' ∈ f.next x → (state y x).dom) :
  (f.track_with state s).eval.dom ↔ f.eval.dom :=
(tr_of_track_with f state s hd).eval_dom_iff.symm

lemma track_with_change_start (s' : τ × σ) :
  (execution.mk (f.track_with state s).next s') = (execution.mk f.next s'.2).track_with state s'.1 :=
by { ext : 1, { simp [execution.track_with], }, { simp, } }

section time_with

def execution.time_with (time : σ →. ℕ) : execution (ℕ × σ) :=
f.track_with (λ n s, (time s).map (+n)) 0

@[simp] lemma execution.none_mem_time_with (time : σ →. ℕ) {x : ℕ × σ} :
  none ∈ (f.time_with time).next x ↔ none ∈ f.next x.2 :=
by simp [execution.time_with]

@[simps]
def execution.time_with_tr (time : σ →. ℕ) (hd : ∀ {x x'}, x ∈ f.states → some x' ∈ f.next x → (time x).dom) :
  f ∼ₛ f.time_with time :=
tr_of_track_with f _ _ (λ x y hx, by simpa using hd)

def execution.time (time : σ →. ℕ) : part ℕ :=
(f.time_with time).eval.map prod.fst

@[simp] lemma _root_.pfun.pure_dom_eq {α β} (x : β) :
  (pfun.pure x : α →. β).dom = set.univ := rfl
@[simp] lemma _root_.pfun.pure_dom {α β} (x : β) (y : α) :
  (pfun.pure x y).dom := trivial
@[simp] lemma _root_.pfun.pure_apply {α β} (x : β) (y : α) :
  (pfun.pure x y) = part.some x := rfl

@[simps]
def execution.time_with_bound (J : ℕ) (time : σ →. ℕ) (hd : ∀ ⦃x x'⦄, x ∈ f.states → some x' ∈ f.next x → (time x).dom)
  (hJ : ∀ ⦃x t⦄, x ∈ f.states → t ∈ time x → t ≤ J) :
  f.time_with time ∼ₛ f.time_with (pfun.pure 1) :=
((f.time_with_tr time hd).symm.trans (f.time_with_tr _ (by simp))).extend (λ s₁ s₂, s₁.1 ≤ J * s₂.1)
  (λ x y x' y' hx hy hr₁ hr₂,
begin
  cases x with xt x, cases y with yt y, cases x' with x't x', cases y' with y't y', dsimp only at *,
  simp at hr₁, rcases hr₁ with ⟨hr₁, rfl⟩,
  simp [execution.time_with],
  rintros t ht rfl hx'' rfl hy'',
  specialize hJ hr₁ ht, rw mul_add, mono, simpa using hJ,
end)
  (by simp [execution.time_with])

@[simps]
def stepwise_tr.time_with_pure_tr_aux {f : execution σ} {g : execution τ} (h : f ∼ₛ g) :
  f.time_with (pfun.pure 1) ∼ₛ g.time_with (pfun.pure 1) :=
((f.time_with_tr (pfun.pure 1) (by simp)).symm.trans h).trans (g.time_with_tr (pfun.pure 1) (by simp))

def stepwise_tr.time_with_pure_tr {f : execution σ} {g : execution τ} (h : f ∼ₛ g) :
  f.time_with (pfun.pure 1) ∼ₛ g.time_with (pfun.pure 1) :=
h.time_with_pure_tr_aux.extend (λ n₁ n₂, n₁.1 = n₂.1)
(by { rintros ⟨t₀, x₀⟩ ⟨t₀', y₀⟩ ⟨t₁, x₁⟩ ⟨t₁', y₁⟩, simp [execution.time_with], intros, subst_vars, })
rfl

@[simp] lemma stepwise_tr.time_with_pure_tr_rel {f : execution σ} {g : execution τ} {h : f ∼ₛ g} {s₀ : ℕ × σ} {s₁ : ℕ × τ} :
  h.time_with_pure_tr.rel s₀ s₁ ↔ s₀.1 = s₁.1 ∧ h.rel s₀.2 s₁.2 ∧ s₀.2 ∈ f.states ∧ s₁.2 ∈ g.states :=
by { simp [stepwise_tr.time_with_pure_tr], tidy, }

private lemma stepwise_tr.time_pure_eq_aux {f : execution σ} {g : execution τ} (h : f ∼ₛ g) {T}
  (hT : T ∈ f.time (pfun.pure 1)) : T ∈ g.time (pfun.pure 1) :=
begin
  simp [execution.time] at hT ⊢,
  rcases hT with ⟨x, hx⟩,
  obtain ⟨⟨t', y⟩, h₁, h₂⟩ := h.time_with_pure_tr.mem_eval_of hx,
  use y, simp at h₂, rwa h₂.1,
end

lemma stepwise_tr.time_pure_eq {f : execution σ} {g : execution τ} (h : f ∼ₛ g) :
  f.time (pfun.pure 1) = g.time (pfun.pure 1) :=
by { ext T, split, { exact stepwise_tr.time_pure_eq_aux h, }, { exact stepwise_tr.time_pure_eq_aux h.symm, } }

theorem execution.time_le (J : ℕ) (time : σ →. ℕ) (hd : ∀ ⦃x y⦄, x ∈ f.states → some y ∈ f.next x → (time x).dom)
  (hJ : ∀ ⦃x t⦄, x ∈ f.states → t ∈ time x → t ≤ J) {N} (hN : N ∈ f.time (pfun.pure 1)) :
  ∃ t, t ∈ f.time time ∧ t ≤ J * N :=
begin
  let R := f.time_with_bound J time hd hJ,
  simp [execution.time] at hN ⊢, cases hN with x₂ ht₂,
  have := R.symm.mem_eval_of ht₂, simp at this,
  rcases this with ⟨t, x, ht, _, H⟩,
  exact ⟨t, ⟨x, ht⟩, H⟩,
end

@[simps]
def execution.time_tr_self (time : σ →. ℕ) (t₀ : ℕ) :
  f.time_with time ∼ₛ (f.track_with (λ n s, (time s).map (+n)) t₀) :=
{ rel := λ a b, b.1 = a.1 + t₀ ∧ b.2 = a.2,
  dom_iff := λ x y hx hy, by { cases x, cases y, dsimp only, rintros ⟨rfl, rfl⟩, simp [execution.time_with], },
  some_iff := λ x y x' y' hx hy,
begin
  cases x, cases y, cases x', cases y', dsimp only,
  rintros ⟨rfl, rfl⟩, simp [execution.time_with],
  rintros _ h₀ rfl h₁ _ h₂ rfl h₃,
  cases part.mem_unique h₀ h₂, cases part.mem_unique h₁ h₃, simp [add_assoc],
end,
  none_iff := λ x y hx hy, by { cases x, cases y, dsimp only, rintros ⟨rfl, rfl⟩, simp [execution.time_with], },
  start := by simp [execution.time_with] }

theorem execution.time_fwd (time : σ →. ℕ)  (t₀ : ℕ) :
  (f.track_with (λ n s, (time s).map (+n)) t₀).eval = (f.time_with time).eval.map (prod.map (+t₀) id) :=
begin
  let R := (f.time_tr_self time t₀), apply part.ext',
  { rw R.symm.eval_dom_iff, simp, },
  intros h₁ h₂, rw part.dom_iff_mem at h₁ h₂, rcases h₁ with ⟨⟨t₁, s₁⟩, h₁⟩, rcases h₂ with ⟨⟨t₂, s₂⟩, h₂⟩, rw [part.get_eq_of_mem h₁, part.get_eq_of_mem h₂],
  simp at h₂, rcases h₂ with ⟨t₂, h₂, rfl⟩,
  have := R.rel_of_mem_eval h₂ h₁, simpa,
end

theorem execution.start_time_le_time (time : σ →. ℕ) {t₀ N : ℕ} (hN : ∃ xf : σ, (N, xf) ∈ (f.track_with (λ n s, (time s).map (+n)) t₀).eval) :
  t₀ ≤ N :=
begin
  simp_rw execution.mem_eval at hN, rcases hN with ⟨xf, H, _⟩,
  apply @execution.step_induction _ (λ S : ℕ × σ, t₀ ≤ S.1) _ _ H,
  { simp, }, { rintros ⟨_, _⟩ ⟨_, _⟩ _ h, simp, rintros _ _ rfl _, refine h.trans _, simp, }
end

theorem execution.state_time_le_time (time : σ →. ℕ) {N} (hN : N ∈ f.time time) {s : ℕ × σ} (hs : s ∈ (f.time_with time).states) :
  s.1 ≤ N :=
begin
  simp [execution.time, ← execution.eval_from hs] at hN,
  simp [execution.time_with, track_with_change_start] at hN,
  exact execution.start_time_le_time _ time hN,
end

end time_with

end track_with

end tr_step


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebraic_geometry.presheafed_space
import Mathlib.topology.sheaves.sheaf
import Mathlib.PostPort

universes v u l u_1

namespace Mathlib

/-!
# Sheafed spaces

Introduces the category of topological spaces equipped with a sheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

namespace algebraic_geometry

/-- A `SheafedSpace C` is a topological space equipped with a sheaf of `C`s. -/
structure SheafedSpace (C : Type u) [category_theory.category C]
    [category_theory.limits.has_products C]
    extends PresheafedSpace C where
  sheaf_condition : Top.presheaf.sheaf_condition (PresheafedSpace.presheaf _to_PresheafedSpace)

namespace SheafedSpace

protected instance coe_carrier {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] : has_coe (SheafedSpace C) Top :=
  has_coe.mk fun (X : SheafedSpace C) => PresheafedSpace.carrier (to_PresheafedSpace X)

/-- Extract the `sheaf C (X : Top)` from a `SheafedSpace C`. -/
def sheaf {C : Type u} [category_theory.category C] [category_theory.limits.has_products C]
    (X : SheafedSpace C) : Top.sheaf C ↑X :=
  Top.sheaf.mk (PresheafedSpace.presheaf (to_PresheafedSpace X)) (sheaf_condition X)

@[simp] theorem as_coe {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (X : SheafedSpace C) :
    PresheafedSpace.carrier (to_PresheafedSpace X) = ↑X :=
  rfl

@[simp] theorem mk_coe {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (carrier : Top) (presheaf : Top.presheaf C carrier)
    (h :
      Top.presheaf.sheaf_condition
        (PresheafedSpace.presheaf (PresheafedSpace.mk carrier presheaf))) :
    ↑(mk (PresheafedSpace.mk carrier presheaf) h) = carrier :=
  rfl

protected instance topological_space {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (X : SheafedSpace C) : topological_space ↥X :=
  category_theory.bundled.str (PresheafedSpace.carrier (to_PresheafedSpace X))

/-- The trivial `punit` valued sheaf on any topological space. -/
def punit (X : Top) : SheafedSpace (category_theory.discrete PUnit) :=
  mk
    (PresheafedSpace.mk (PresheafedSpace.carrier (PresheafedSpace.const X PUnit.unit))
      (PresheafedSpace.presheaf (PresheafedSpace.const X PUnit.unit)))
    (Top.presheaf.sheaf_condition_punit
      (PresheafedSpace.presheaf
        (PresheafedSpace.mk (PresheafedSpace.carrier (PresheafedSpace.const X PUnit.unit))
          (PresheafedSpace.presheaf (PresheafedSpace.const X PUnit.unit)))))

protected instance inhabited : Inhabited (SheafedSpace (category_theory.discrete PUnit)) :=
  { default := punit (Top.of pempty) }

protected instance category_theory.category {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] : category_theory.category (SheafedSpace C) :=
  (fun
      (this :
      category_theory.category
        (category_theory.induced_category (PresheafedSpace C) to_PresheafedSpace)) =>
      this)
    (category_theory.induced_category.category to_PresheafedSpace)

/-- Forgetting the sheaf condition is a functor from `SheafedSpace C` to `PresheafedSpace C`. -/
def forget_to_PresheafedSpace {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] : SheafedSpace C ⥤ PresheafedSpace C :=
  category_theory.induced_functor to_PresheafedSpace

@[simp] theorem id_base {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (X : SheafedSpace C) : PresheafedSpace.hom.base 𝟙 = 𝟙 :=
  rfl

theorem id_c {C : Type u} [category_theory.category C] [category_theory.limits.has_products C]
    (X : SheafedSpace C) :
    PresheafedSpace.hom.c 𝟙 =
        category_theory.iso.inv
            (category_theory.functor.left_unitor
              (PresheafedSpace.presheaf (to_PresheafedSpace X))) ≫
          category_theory.whisker_right
            (category_theory.nat_trans.op
              (category_theory.iso.hom
                (topological_space.opens.map_id (PresheafedSpace.carrier (to_PresheafedSpace X)))))
            (PresheafedSpace.presheaf (to_PresheafedSpace X)) :=
  rfl

@[simp] theorem id_c_app {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (X : SheafedSpace C)
    (U : topological_space.opens ↥(PresheafedSpace.carrier (to_PresheafedSpace X))ᵒᵖ) :
    category_theory.nat_trans.app (PresheafedSpace.hom.c 𝟙) U =
        category_theory.eq_to_hom
          (opposite.op_induction
            (fun (U : topological_space.opens ↥(PresheafedSpace.carrier (to_PresheafedSpace X))) =>
              subtype.cases_on U
                fun (U_val : set ↥(PresheafedSpace.carrier (to_PresheafedSpace X)))
                  (U_property : is_open U_val) =>
                  Eq.refl
                    (category_theory.functor.obj (PresheafedSpace.presheaf (to_PresheafedSpace X))
                      (opposite.op { val := U_val, property := U_property })))
            U) :=
  sorry

@[simp] theorem comp_base {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] {X : SheafedSpace C} {Y : SheafedSpace C}
    {Z : SheafedSpace C} (f : X ⟶ Y) (g : Y ⟶ Z) :
    PresheafedSpace.hom.base (f ≫ g) = PresheafedSpace.hom.base f ≫ PresheafedSpace.hom.base g :=
  rfl

@[simp] theorem comp_c_app {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] {X : SheafedSpace C} {Y : SheafedSpace C}
    {Z : SheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z)
    (U : topological_space.opens ↥(PresheafedSpace.carrier (to_PresheafedSpace Z))ᵒᵖ) :
    category_theory.nat_trans.app (PresheafedSpace.hom.c (α ≫ β)) U =
        category_theory.nat_trans.app (PresheafedSpace.hom.c β) U ≫
          category_theory.nat_trans.app (PresheafedSpace.hom.c α)
              (opposite.op
                (category_theory.functor.obj
                  (topological_space.opens.map (PresheafedSpace.hom.base β)) (opposite.unop U))) ≫
            category_theory.nat_trans.app
              (category_theory.iso.inv
                (Top.presheaf.pushforward.comp (PresheafedSpace.presheaf (to_PresheafedSpace X))
                  (PresheafedSpace.hom.base α) (PresheafedSpace.hom.base β)))
              U :=
  rfl

/-- The forgetful functor from `SheafedSpace` to `Top`. -/
def forget (C : Type u) [category_theory.category C] [category_theory.limits.has_products C] :
    SheafedSpace C ⥤ Top :=
  category_theory.functor.mk (fun (X : SheafedSpace C) => ↑X)
    fun (X Y : SheafedSpace C) (f : X ⟶ Y) => PresheafedSpace.hom.base f

/--
The restriction of a sheafed space along an open embedding into the space.
-/
def restrict {C : Type u} [category_theory.category C] [category_theory.limits.has_products C]
    {U : Top} (X : SheafedSpace C) (f : U ⟶ ↑X) (h : open_embedding ⇑f) : SheafedSpace C :=
  sorry

/--
The global sections, notated Gamma.
-/
def Γ {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] :
    SheafedSpace Cᵒᵖ ⥤ C :=
  category_theory.functor.op forget_to_PresheafedSpace ⋙ PresheafedSpace.Γ

theorem Γ_def {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] :
    Γ = category_theory.functor.op forget_to_PresheafedSpace ⋙ PresheafedSpace.Γ :=
  rfl

@[simp] theorem Γ_obj {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] (X : SheafedSpace Cᵒᵖ) :
    category_theory.functor.obj Γ X =
        category_theory.functor.obj
          (PresheafedSpace.presheaf (to_PresheafedSpace (opposite.unop X))) (opposite.op ⊤) :=
  rfl

theorem Γ_obj_op {C : Type u} [category_theory.category C] [category_theory.limits.has_products C]
    (X : SheafedSpace C) :
    category_theory.functor.obj Γ (opposite.op X) =
        category_theory.functor.obj (PresheafedSpace.presheaf (to_PresheafedSpace X))
          (opposite.op ⊤) :=
  rfl

@[simp] theorem Γ_map {C : Type u} [category_theory.category C]
    [category_theory.limits.has_products C] {X : SheafedSpace Cᵒᵖ} {Y : SheafedSpace Cᵒᵖ}
    (f : X ⟶ Y) :
    category_theory.functor.map Γ f =
        category_theory.nat_trans.app (PresheafedSpace.hom.c (category_theory.has_hom.hom.unop f))
            (opposite.op ⊤) ≫
          category_theory.functor.map
            (PresheafedSpace.presheaf (to_PresheafedSpace (opposite.unop Y)))
            (category_theory.has_hom.hom.op
              (topological_space.opens.le_map_top
                (PresheafedSpace.hom.base (category_theory.has_hom.hom.unop f)) ⊤)) :=
  rfl

theorem Γ_map_op {C : Type u} [category_theory.category C] [category_theory.limits.has_products C]
    {X : SheafedSpace C} {Y : SheafedSpace C} (f : X ⟶ Y) :
    category_theory.functor.map Γ (category_theory.has_hom.hom.op f) =
        category_theory.nat_trans.app (PresheafedSpace.hom.c f) (opposite.op ⊤) ≫
          category_theory.functor.map (PresheafedSpace.presheaf (to_PresheafedSpace X))
            (category_theory.has_hom.hom.op
              (topological_space.opens.le_map_top (PresheafedSpace.hom.base f) ⊤)) :=
  rfl

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Scott Morrison
-/
import tactic data.set.lattice data.prod
       tactic.rewrite data.stream.basic

section solve_by_elim
example {a b : Prop} (h₀ : a → b) (h₁ : a) : b :=
begin
  apply_assumption,
  apply_assumption,
end

example {a b : Prop} (h₀ : a → b) (h₁ : a) : b :=
by solve_by_elim

example {α : Type} {a b : α → Prop} (h₀ : ∀ x : α, b x = a x) (y : α) : a y = b y :=
by solve_by_elim

example {α : Type} {p : α → Prop} (h₀ : ∀ x, p x) (y : α) : p y :=
begin
  apply_assumption,
end

open tactic

example : true :=
begin
  (do gs ← get_goals,
     set_goals [],
     success_if_fail `[solve_by_elim],
     set_goals gs),
  trivial
end

end solve_by_elim

section tauto₀
variables p q r : Prop
variables h : p ∧ q ∨ p ∧ r
include h
example : p ∧ p :=
by tauto

end tauto₀

section tauto₁
variables α : Type
variables p q r : α → Prop
variables h : (∃ x, p x ∧ q x) ∨ (∃ x, p x ∧ r x)
include h
example : ∃ x, p x :=
by tauto

end tauto₁

section tauto₂
variables α : Type
variables x : α
variables p q r : α → Prop
variables h₀ : (∀ x, p x → q x → r x) ∨ r x
variables h₁ : p x
variables h₂ : q x

include h₀ h₁ h₂
example : ∃ x, r x :=
by tauto

end tauto₂

section tauto₃

example (p : Prop) : p ∧ true ↔ p := by tauto
example (p : Prop) : p ∨ false ↔ p := by tauto
example (p q r : Prop) [decidable p] [decidable r] : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (r ∨ p ∨ r) := by tauto
example (p q r : Prop) [decidable q] [decidable r] : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (r ∨ p ∨ r) := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : ¬ p) : q := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : p) : ¬ q := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : q) : ¬ p := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : ¬ q) : p := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : ¬ q) (h'' : ¬ p) : false := by tauto
example (p q r : Prop) [decidable q] [decidable p] (h : p ↔ q) (h' : r ↔ q) (h'' : ¬ r) : ¬ p := by tauto
example (p q r : Prop) [decidable q] [decidable p] (h : p ↔ q) (h' : r ↔ q) : p ↔ r :=
by tauto
example (p q r : Prop) [decidable p] [decidable q] [decidable r] (h : ¬ p = q) (h' : r = q) : p ↔ ¬ r := by tauto

section modulo_symmetry
variables {p q r : Prop} {α : Type} {x y : α} [decidable_eq α]
variables [decidable p] [decidable q] [decidable r]
variables (h : x = y)
variables (h'' : (p ∧ q ↔ q ∨ r) ↔ (r ∧ p ↔ r ∨ q))
include h
include h''
example (h' : ¬ y = x) : p ∧ q := by tauto
example (h' : p ∧ ¬ y = x) : p ∧ q := by tauto
example : y = x := by tauto
example (h' : ¬ x = y) : p ∧ q := by tauto
example : x = y := by tauto

end modulo_symmetry

end tauto₃

section wlog

example {x y : ℕ} (a : x = 1) : true :=
begin
  suffices : false, trivial,
  wlog h : x = y,
  { guard_target x = y ∨ y = x,
    admit },
  { guard_hyp h := x = y,
    guard_hyp a := x = 1,
    admit }
end

example {x y : ℕ} : true :=
begin
  suffices : false, trivial,
  wlog h : x ≤ y,
  { guard_hyp h := x ≤ y,
    guard_target false,
    admit }
end

example {x y z : ℕ} : true :=
begin
  suffices : false, trivial,
  wlog : x ≤ y + z using x y,
  { guard_target x ≤ y + z ∨ y ≤ x + z,
    admit },
  { guard_hyp case := x ≤ y + z,
    guard_target false,
    admit },
end

example {x : ℕ} (S₀ S₁ : set ℕ) (P : ℕ → Prop)
  (h : x ∈ S₀ ∪ S₁) : true :=
begin
  suffices : false, trivial,
  wlog h' : x ∈ S₀ using S₀ S₁,
  { guard_target x ∈ S₀ ∨ x ∈ S₁,
    admit },
  { guard_hyp h  := x ∈ S₀ ∪ S₁,
    guard_hyp h' := x ∈ S₀,
    admit }
end

example {n m i : ℕ} {p : ℕ → ℕ → ℕ → Prop} : true :=
begin
  suffices : false, trivial,
  wlog : p n m i using [n m i, n i m, i n m],
  { guard_target p n m i ∨ p n i m ∨ p i n m,
    admit },
  { guard_hyp case := p n m i,
    admit }
end

example {n m i : ℕ} {p : ℕ → Prop} : true :=
begin
  suffices : false, trivial,
  wlog : p n using [n m i, m n i, i n m],
  { guard_target p n ∨ p m ∨ p i,
    admit },
  { guard_hyp case := p n,
    admit }
end

example {n m i : ℕ} {p : ℕ → ℕ → Prop} {q : ℕ → ℕ → ℕ → Prop} : true :=
begin
  suffices : q n m i, trivial,
  have h : p n i ∨ p i m ∨ p m i, from sorry,
  wlog : p n i := h using n m i,
  { guard_hyp h := p n i,
    guard_target q n m i,
    admit },
  { guard_hyp h := p i m,
    guard_hyp this := q i m n,
    guard_target q n m i,
    admit },
  { guard_hyp h := p m i,
    guard_hyp this := q m i n,
    guard_target q n m i,
    admit },
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    cases hyp,
    wlog x_in : x ∈ B using B C,
    { assumption },
    { exact or.inl ⟨hyp_left, x_in⟩ } },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B using B C,
    { assumption },
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    wlog x_in : x ∈ B := hyp.2 using B C,
    { exact or.inl ⟨hyp.1, x_in⟩ } },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B := hyp using B C,
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    cases hyp,
    wlog x_in : x ∈ B := hyp_right using B C,
    { exact or.inl ⟨hyp_left, x_in⟩ }, },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B := hyp using B C,
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

end wlog

example (m n p q : nat) (h : m + n = p) : true :=
begin
  have : m + n = q,
  { generalize_hyp h' : m + n = x at h,
    guard_hyp h' := m + n = x,
    guard_hyp h := x = p,
    guard_target m + n = q,
    admit },
  have : m + n = q,
  { generalize_hyp h' : m + n = x at h ⊢,
    guard_hyp h' := m + n = x,
    guard_hyp h := x = p,
    guard_target x = q,
    admit },
  trivial
end

example (α : Sort*) (L₁ L₂ L₃ : list α)
  (H : L₁ ++ L₂ = L₃) : true :=
begin
  have : L₁ ++ L₂ = L₂,
  { generalize_hyp h : L₁ ++ L₂ = L at H,
    induction L with hd tl ih,
    case list.nil
    { tactic.cleanup,
      change list.nil = L₃ at H,
      admit },
    case list.cons
    { change hd :: tl = L₃ at H,
      admit } },
  trivial
end

section convert
open set

variables {α β : Type}
local attribute [simp]
private lemma singleton_inter_singleton_eq_empty {x y : α} :
  ({x} ∩ {y} = (∅ : set α)) ↔ x ≠ y :=
by simp [singleton_inter_eq_empty]

example {f : β → α} {x y : α} (h : x ≠ y) : f ⁻¹' {x} ∩ f ⁻¹' {y} = ∅ :=
begin
  have : {x} ∩ {y} = (∅ : set α) := by simpa using h,
  convert preimage_empty,
  rw [←preimage_inter,this],
end

end convert

section rcases

universe u
variables {α β γ : Type u}

example (x : α × β × γ) : true :=
begin
  rcases x with ⟨a, b, c⟩,
  { guard_hyp a := α,
    guard_hyp b := β,
    guard_hyp c := γ,
    trivial }
end

example (x : α × β × γ) : true :=
begin
  rcases x with ⟨a, ⟨b, c⟩⟩,
  { guard_hyp a := α,
    guard_hyp b := β,
    guard_hyp c := γ,
    trivial }
end

example (x : (α × β) × γ) : true :=
begin
  rcases x with ⟨⟨a, b⟩, c⟩,
  { guard_hyp a := α,
    guard_hyp b := β,
    guard_hyp c := γ,
    trivial }
end

example (x : inhabited α × option β ⊕ γ) : true :=
begin
  rcases x with ⟨⟨a⟩, _ | b⟩ | c,
  { guard_hyp a := α, trivial },
  { guard_hyp a := α, guard_hyp b := β, trivial },
  { guard_hyp c := γ, trivial }
end

example (x y : ℕ) (h : x = y) : true :=
begin
  rcases x with _|⟨⟩|z,
  { guard_hyp h := nat.zero = y, trivial },
  { guard_hyp h := nat.succ nat.zero = y, trivial },
  { guard_hyp z := ℕ,
    guard_hyp h := z.succ.succ = y, trivial },
end

-- from equiv.sum_empty
example (s : α ⊕ empty) : true :=
begin
  rcases s with _ | ⟨⟨⟩⟩,
  { guard_hyp s := α, trivial }
end

end rcases

section ext

@[extensionality] lemma unit.ext (x y : unit) : x = y :=
begin
  cases x, cases y, refl
end

example : subsingleton unit :=
begin
  split, intros, ext
end

example (x y : ℕ) : true :=
begin
  have : x = y,
  { ext <|> admit },
  have : x = y,
  { ext i <|> admit },
  have : x = y,
  { ext : 1 <|> admit },
  trivial
end

example (X Y : ℕ × ℕ)  (h : X.1 = Y.1) (h : X.2 = Y.2) : X = Y :=
begin
  ext; assumption
end

example (X Y : (ℕ → ℕ) × ℕ)  (h : ∀ i, X.1 i = Y.1 i) (h : X.2 = Y.2) : X = Y :=
begin
  ext x; solve_by_elim,
end

example (X Y : ℕ → ℕ × ℕ)  (h : ∀ i, X i = Y i) : true :=
begin
  have : X = Y,
  { ext i : 1,
    guard_target X i = Y i,
    admit },
  have : X = Y,
  { ext i,
    guard_target (X i).fst = (Y i).fst, admit,
    guard_target (X i).snd = (Y i).snd, admit, },
  have : X = Y,
  { ext : 1,
    guard_target X x = Y x,
    admit },
  trivial,
end

example (s₀ s₁ : set ℕ) (h : s₁ = s₀) : s₀ = s₁ :=
by { ext1, guard_target x ∈ s₀ ↔ x ∈ s₁, simp * }

example (s₀ s₁ : stream ℕ) (h : s₁ = s₀) : s₀ = s₁ :=
by { ext1, guard_target s₀.nth n = s₁.nth n, simp * }

example (s₀ s₁ : ℤ → set (ℕ × ℕ))
        (h : ∀ i a b, (a,b) ∈ s₀ i ↔ (a,b) ∈ s₁ i) : s₀ = s₁ :=
begin
  ext i ⟨a,b⟩,
  apply h
end

def my_foo {α} (x : semigroup α) (y : group α) : true := trivial

example {α : Type} : true :=
begin
  have : true,
  { refine_struct (@my_foo α { .. } { .. } ),
      -- 9 goals
    guard_tags _field mul semigroup, admit,
      -- case semigroup, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc semigroup, admit,
      -- case semigroup, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field mul group, admit,
      -- case group, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc group, admit,
      -- case group, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field one group, admit,
      -- case group, one
      -- α : Type
      -- ⊢ α

    guard_tags _field one_mul group, admit,
      -- case group, one_mul
      -- α : Type
      -- ⊢ ∀ (a : α), 1 * a = a

    guard_tags _field mul_one group, admit,
      -- case group, mul_one
      -- α : Type
      -- ⊢ ∀ (a : α), a * 1 = a

    guard_tags _field inv group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ α → α

    guard_tags _field mul_left_inv group, admit,
      -- case group, mul_left_inv
      -- α : Type
      -- ⊢ ∀ (a : α), a⁻¹ * a = 1
  },
  trivial
end

def my_bar {α} (x : semigroup α) (y : group α) (i j : α) : α := i

example {α : Type} : true :=
begin
  have : monoid α,
  { refine_struct { mul := my_bar { .. } { .. } },
    guard_tags _field mul semigroup, admit,
    guard_tags _field mul_assoc semigroup, admit,
    guard_tags _field mul group, admit,
    guard_tags _field mul_assoc group, admit,
    guard_tags _field one group, admit,
    guard_tags _field one_mul group, admit,
    guard_tags _field mul_one group, admit,
    guard_tags _field inv group, admit,
    guard_tags _field mul_left_inv group, admit,
    guard_tags _field mul_assoc monoid, admit,
    guard_tags _field one monoid, admit,
    guard_tags _field one_mul monoid, admit,
    guard_tags _field mul_one monoid, admit, },
  trivial
end

end ext

section apply_rules

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
add_le_add (add_le_add (add_le_add (add_le_add h1 (mul_le_mul_of_nonneg_right h2 h3)) h1 ) h2) h3

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
by apply_rules [add_le_add, mul_le_mul_of_nonneg_right]

@[user_attribute]
meta def mono_rules : user_attribute :=
{ name := `mono_rules,
  descr := "lemmas usable to prove monotonicity" }
attribute [mono_rules] add_le_add mul_le_mul_of_nonneg_right

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
by apply_rules [mono_rules]

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
by apply_rules mono_rules

end apply_rules

section h_generalize

variables {α β γ φ ψ : Type} (f : α → α → α → φ → γ)
          (x y : α) (a b : β) (z : φ)
          (h₀ : β = α) (h₁ : β = α) (h₂ : φ = β)
          (hx : x == a) (hy : y == b) (hz : z == a)
include f x y z a b hx hy hz

example : f x y x z = f (eq.rec_on h₀ a) (cast h₀ b) (eq.mpr h₁.symm a) (eq.mpr h₂ a) :=
begin
  guard_hyp_nums 16,
  h_generalize hp : a == p with hh,
  guard_hyp_nums 19,
  guard_hyp' hh := β = α,
  guard_target f x y x z = f p (cast h₀ b) p (eq.mpr h₂ a),
  h_generalize hq : _ == q,
  guard_hyp_nums 21,
  guard_target f x y x z = f p q p (eq.mpr h₂ a),
  h_generalize _ : _ == r,
  guard_hyp_nums 23,
  guard_target f x y x z = f p q p r,
  casesm* [_ == _, _ = _], refl
end

end h_generalize

section h_generalize

variables {α β γ φ ψ : Type} (f : list α → list α → γ)
          (x : list α) (a : list β) (z : φ)
          (h₀ : β = α) (h₁ : list β = list α)
          (hx : x == a)
include f x z a hx h₀ h₁

example : true :=
begin
  have : f x x = f (eq.rec_on h₀ a) (cast h₁ a),
  { guard_hyp_nums 11,
    h_generalize : a == p with _,
    guard_hyp_nums 13,
    guard_hyp' h := β = α,
    guard_target f x x = f p (cast h₁ a),
    h_generalize! : a == q ,
    guard_hyp_nums 13,
    guard_target ∀ q, f x x = f p q,
    casesm* [_ == _, _ = _],
    success_if_fail { refl },
    admit },
  trivial
end

end h_generalize

section assoc_rw
open tactic
example : ∀ x y z a b c : ℕ, true :=
begin
 intros,
 have : x + (y + z) = 3 + y, admit,
 have : a + (b + x) + y + (z + b + c) ≤ 0,
 (do this ← get_local `this,
     tgt ← to_expr ```(a + (b + x) + y + (z + b + c)),
     assoc ← mk_mapp ``add_monoid.add_assoc [`(ℕ),none],
     (l,p) ← assoc_rewrite_intl assoc this tgt,
     note `h none p  ),
 erw h,
 guard_target a + b + 3 + y + b + c ≤ 0,
 admit,
 trivial
end

example : ∀ x y z a b c : ℕ, true :=
begin
 intros,
 have : ∀ y, x + (y + z) = 3 + y, admit,
 have : a + (b + x) + y + (z + b + c) ≤ 0,
 (do this ← get_local `this,
     tgt ← to_expr ```(a + (b + x) + y + (z + b + c)),
     assoc_rewrite_target this ),
 guard_target a + b + 3 + y + b + c ≤ 0,
 admit,
 trivial
end

variables x y z a b c : ℕ
variables h₀ : ∀ (y : ℕ), x + (y + z) = 3 + y
variables h₁ : a + (b + x) + y + (z + b + a) ≤ 0
variables h₂ : y + b + c = y + b + a
include h₀ h₁ h₂
example : a + (b + x) + y + (z + b + c) ≤ 0 :=
by { assoc_rw [h₀,h₂] at *,
     guard_hyp _inst := is_associative ℕ has_add.add,
       -- keep a local instance of is_associative to cache
       -- type class queries
     exact h₁ }

end assoc_rw


import data.finset.basic

theorem AIME_2021_3 (S:finset ℕ)(h:∀(n:ℕ), n∈S ↔ (n≤ 1000 ∧ ∃ (a b :ℕ),n=2^a-2^b)): finset.card S=50 :=
begin
  sorry
end


import data.set.basic -- hide
import data.set.finite -- hide
open set -- hide

/- Tactic : use

## Summary
The tactic use specializes the goal with a particular case. For example, if we want to prove the statement "there exists a natural number which is odd", we will need to provide a concrete number like 3.

-/

/- Lemma :
If A and B are subsets of a fixed set, then there exists a subset S such that S ⊆ A ∩ B.
-/
lemma example_on_use (α : Type) (A : set α) (B : set α) : ∃ S : set α, S ⊆ A ∩ B :=
begin
  use ∅,
  intros h h1,
  split,
  repeat
  {
    exfalso,
    exact h1
  }

end


structure A where
  private x : Nat := 10

def g (a : Nat) : A :=
  {}

theorem ex1 (a : Nat) : (g a |>.x) = 10 :=
  rfl

structure B extends A where
  y : Nat

def f (a : Nat) : B :=
  { y := a }

theorem ex2 (a : Nat) : (f a |>.x) = 10 :=
  rfl


/-
Copyright (c) 2023 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

! This file was ported from Lean 3 source module analysis.normed_space.triv_sq_zero_ext
! leanprover-community/mathlib commit b8d2eaa69d69ce8f03179a5cda774fc0cde984e4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.Basic
import Mathbin.Analysis.NormedSpace.Exponential
import Mathbin.Topology.Instances.TrivSqZeroExt

/-!
# Results on `triv_sq_zero_ext R M` related to the norm

For now, this file contains results about `exp` for this type.

## Main results

* `triv_sq_zero_ext.fst_exp`
* `triv_sq_zero_ext.snd_exp`
* `triv_sq_zero_ext.exp_inl`
* `triv_sq_zero_ext.exp_inr`

## TODO
* Actually define a sensible norm on `triv_sq_zero_ext R M`, so that we have access to lemmas
  like `exp_add`.
* Generalize some of these results to non-commutative `R`.

-/

variable (𝕜 : Type _) {R M : Type _}

-- mathport name: exprtsze
local notation "tsze" => TrivSqZeroExt

namespace TrivSqZeroExt

section Topology

variable [TopologicalSpace R] [TopologicalSpace M]

/-- If `exp R x.fst` converges to `e` then `exp R x` converges to `inl e + inr (e • x.snd)`. -/
theorem hasSum_expSeries [Field 𝕜] [CharZero 𝕜] [CommRing R] [AddCommGroup M] [Algebra 𝕜 R]
    [Module R M] [Module Rᵐᵒᵖ M] [IsCentralScalar R M] [Module 𝕜 M] [IsScalarTower 𝕜 R M]
    [TopologicalRing R] [TopologicalAddGroup M] [ContinuousSMul R M] (x : tsze R M) {e : R}
    (h : HasSum (fun n => expSeries 𝕜 R n fun _ => x.fst) e) :
    HasSum (fun n => expSeries 𝕜 (tsze R M) n fun _ => x) (inl e + inr (e • x.snd)) :=
  by
  simp_rw [expSeries_apply_eq] at *
  conv =>
    congr
    ext
    rw [← inl_fst_add_inr_snd_eq (x ^ _), fst_pow, snd_pow, smul_add, ← inr_smul, ← inl_smul,
      nsmul_eq_smul_cast 𝕜 n, smul_smul, inv_mul_eq_div, ← inv_div, ← smul_assoc]
  refine' (has_sum_inl M h).add (has_sum_inr M _)
  apply HasSum.smul_const
  rw [← hasSum_nat_add_iff' 1]; swap; infer_instance
  rw [Finset.range_one, Finset.sum_singleton, Nat.cast_zero, div_zero, inv_zero, zero_smul,
    sub_zero]
  simp_rw [← Nat.succ_eq_add_one, Nat.pred_succ, Nat.factorial_succ, Nat.cast_mul, ←
    Nat.succ_eq_add_one,
    mul_div_cancel_left _ ((@Nat.cast_ne_zero 𝕜 _ _ _).mpr <| Nat.succ_ne_zero _)]
  exact h
#align triv_sq_zero_ext.has_sum_exp_series TrivSqZeroExt.hasSum_expSeries

end Topology

section NormedRing

variable [IsROrC 𝕜] [NormedCommRing R] [AddCommGroup M]

variable [NormedAlgebra 𝕜 R] [Module R M] [Module Rᵐᵒᵖ M] [IsCentralScalar R M]

variable [Module 𝕜 M] [IsScalarTower 𝕜 R M]

variable [TopologicalSpace M] [TopologicalRing R]

variable [TopologicalAddGroup M] [ContinuousSMul R M]

variable [CompleteSpace R] [T2Space R] [T2Space M]

theorem exp_def (x : tsze R M) : exp 𝕜 x = inl (exp 𝕜 x.fst) + inr (exp 𝕜 x.fst • x.snd) :=
  by
  simp_rw [exp, FormalMultilinearSeries.sum]
  refine' (has_sum_exp_series 𝕜 x _).tsum_eq
  exact expSeries_hasSum_exp _
#align triv_sq_zero_ext.exp_def TrivSqZeroExt.exp_def

@[simp]
theorem fst_exp (x : tsze R M) : fst (exp 𝕜 x) = exp 𝕜 x.fst := by
  rw [exp_def, fst_add, fst_inl, fst_inr, add_zero]
#align triv_sq_zero_ext.fst_exp TrivSqZeroExt.fst_exp

@[simp]
theorem snd_exp (x : tsze R M) : snd (exp 𝕜 x) = exp 𝕜 x.fst • x.snd := by
  rw [exp_def, snd_add, snd_inl, snd_inr, zero_add]
#align triv_sq_zero_ext.snd_exp TrivSqZeroExt.snd_exp

@[simp]
theorem exp_inl (x : R) : exp 𝕜 (inl x : tsze R M) = inl (exp 𝕜 x) := by
  rw [exp_def, fst_inl, snd_inl, smul_zero, inr_zero, add_zero]
#align triv_sq_zero_ext.exp_inl TrivSqZeroExt.exp_inl

@[simp]
theorem exp_inr (m : M) : exp 𝕜 (inr m : tsze R M) = 1 + inr m := by
  rw [exp_def, fst_inr, exp_zero, snd_inr, one_smul, inl_one]
#align triv_sq_zero_ext.exp_inr TrivSqZeroExt.exp_inr

/-- Polar form of trivial-square-zero extension. -/
theorem eq_smul_exp_of_invertible (x : tsze R M) [Invertible x.fst] :
    x = x.fst • exp 𝕜 (⅟ x.fst • inr x.snd) := by
  rw [← inr_smul, exp_inr, smul_add, ← inl_one, ← inl_smul, ← inr_smul, smul_eq_mul, mul_one,
    smul_smul, mul_invOf_self, one_smul, inl_fst_add_inr_snd_eq]
#align triv_sq_zero_ext.eq_smul_exp_of_invertible TrivSqZeroExt.eq_smul_exp_of_invertible

end NormedRing

section NormedField

variable [IsROrC 𝕜] [NormedField R] [AddCommGroup M]

variable [NormedAlgebra 𝕜 R] [Module R M] [Module Rᵐᵒᵖ M] [IsCentralScalar R M]

variable [Module 𝕜 M] [IsScalarTower 𝕜 R M]

variable [TopologicalSpace M] [TopologicalRing R]

variable [TopologicalAddGroup M] [ContinuousSMul R M]

variable [CompleteSpace R] [T2Space R] [T2Space M]

/-- More convenient version of `triv_sq_zero_ext.eq_smul_exp_of_invertible` for when `R` is a
field. -/
theorem eq_smul_exp_of_ne_zero (x : tsze R M) (hx : x.fst ≠ 0) :
    x = x.fst • exp 𝕜 (x.fst⁻¹ • inr x.snd) :=
  letI : Invertible x.fst := invertibleOfNonzero hx
  eq_smul_exp_of_invertible _ _
#align triv_sq_zero_ext.eq_smul_exp_of_ne_zero TrivSqZeroExt.eq_smul_exp_of_ne_zero

end NormedField

end TrivSqZeroExt


import Scratch.IntrosRwFind
universe u

variable {M: Type u}[Mul M]

theorem CzSlOly : (∀ a b : M, (a * b) * b = a) → (∀ a b : M, a * (a * b) = b) →
            (m n: M) → m * n = n * m := by
              intros ax1 ax2 m n
              have lem1 : (m * n) * n = m := ax1 m n
              have lem2 : (m * n) * ((m * n) * n) = n := ax2 (m * n) n
              have lem3 : ((m * n) * m) * m = m * n  := ax1 (m * n) m
              have lem4 : (m * n) * ((m * n) * n) = (m * n) * m :=
                  congrArg (fun x => (m * n) * x) lem1
              have lem5 : (m * n) * m = n := by
                    rw [lem4] at lem2
                    assumption
              have lem6 : ((m * n) * m) * m = n * m  :=
                    congrArg (fun x => x * m) lem5
              rw [lem3] at lem6
              assumption

example : (∀ a b : M, (a * b) * b = a) → (∀ a b : M, a * (a * b) = b) →
            (m n : M) →  (m * n) * n = m := by
            introsRwFind 2

set_option maxHeartbeats 1000000

example : (∀ a b : M, (a * b) * b = a) → (m n: M)  → m * n * n = m := by
    introsRwFind 2

example : (∀ a b : M, (a * b) * b = a) → (∀ a b : M, a * (a * b) = b) →
    (m n: M)  → m * n * n = m := by
        goalVariables
        intros ax1 ax2 m n
        goalVariables
        polyFind #⟨ax1, ax2, m, n⟩ 2

example : (∀ a b : M, (a * b) * b = a) → (∀ a b : M, a * (a * b) = b) →
    (m n: M)  → (m * n) * n * n = m * n := by
        intros ax1 ax2 m n
        polyFind #⟨ax1, ax2, m, n, m * n⟩ 2

example : (∀ a b : M, (a * b) * b = a) → (m n: M)  → m * (m * n * n) = m * m := by
    intros ax m n
    polyFind #⟨ax, m, n⟩ 2 save:mnn
    eqDeduc #⟨ax, m, n⟩ 1 eqs:mnn

example : (∀ a b : M, (a * b) * b = a) → (m n: M)  →
            (m * n * n) * (m * n) = m * (m * n) := by
    intro ax m n
    polyFind #⟨ax, m, n⟩ 2 save:mnn
    eqDeduc #⟨ax, m, n⟩ 2 eqs:mnn

def eg : (∀ a b : M, (a * b) * b = a) → (m n: M)  →
            (m * n) * ((m * n) * n) = (m * n) * m := by
    intro ax m n
    polyFind #⟨ax, m, n⟩ 2 save:mmnn
    eqDeduc #⟨ax, m, n⟩ 2 eqs:mmnn save:mmnn2

#print eg
#reduce @eg

#check fun (m: M) => HMul.hMul m

#check @HMul.hMul

def mn := fun m : M => fun n: M => nameapply! HMul.hMul at m with n

#check @mn


variable (R : α → α → Prop)

inductive List.Pairwise : List α → Prop
  | nil : Pairwise []
  | cons : ∀ {a : α} {l : List α}, (∀ {a} (_ : a' ∈ l), R a a') → Pairwise l → Pairwise (a :: l)

theorem and_assoc : (a ∧ b) ∧ c ↔ a ∧ (b ∧ c) :=
  ⟨fun ⟨⟨ha, hb⟩, hc⟩ => ⟨ha, hb, hc⟩, fun ⟨ha, hb, hc⟩ => ⟨⟨ha, hb⟩, hc⟩⟩

theorem and_left_comm : a ∧ (b ∧ c) ↔ b ∧ (a ∧ c) := by
  rw [← and_assoc, ← and_assoc, @And.comm a b]
  exact Iff.rfl

theorem pairwise_append {l₁ l₂ : List α} :
    (l₁ ++ l₂).Pairwise R ↔ l₁.Pairwise R ∧ l₂.Pairwise R ∧ ∀ {a} (_ : a ∈ l₁), ∀ {b} (_ : b ∈ l₂), R a b := by
  induction l₁ <;> simp [*, and_left_comm]
  repeat sorry