import condensed.ab
import rescale.pseudo_normed_group
import hacks_and_tricks.asyncI
import for_mathlib.Profinite.extend
import facts.nnreal

.

noncomputable theory

universe u

open_locale nnreal
open category_theory

namespace comphaus_filtered_pseudo_normed_group

def of_rescale_one_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom (rescale 1 M) M :=
{ continuous' := λ c, comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * 1⁻¹) c,
  .. rescale.of_rescale_one_strict_pseudo_normed_group_hom M
}

def to_rescale_one_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom M (rescale 1 M) :=
{ continuous' := λ c, begin
    haveI : fact (c ≤ c * 1⁻¹) := ⟨le_of_eq (by rw [inv_one, mul_one])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le c (c * 1⁻¹),
  end,
  .. rescale.to_rescale_one_strict_pseudo_normed_group_hom M
}

def of_rescale_eq_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M]
  (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] (hrr' : r = r') :
strict_comphaus_filtered_pseudo_normed_group_hom (rescale r M) (rescale r' M) :=
{ continuous' := λ c, begin
  haveI : fact (c * r⁻¹ ≤ c * r'⁻¹) := ⟨le_of_eq (by rw hrr')⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * r⁻¹) (c * r'⁻¹),
  end,
  .. rescale.of_rescale_eq_strict_pseudo_normed_group_hom  r r' M hrr',
}

def of_rescale_rescale_strict (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')]
  (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom
    (rescale r (rescale r' M)) (rescale (r' * r) M) :=
{
  continuous' := λ c,
  begin
    haveI : fact (c * r⁻¹ * r'⁻¹ ≤ c * (r' * r)⁻¹) :=
      ⟨le_of_eq (by rw [nnreal.mul_inv, mul_assoc])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * r⁻¹ * r'⁻¹) _,
  end,
  ..rescale.of_rescale_rescale_strict_pseudo_normed_group_hom r r' M
}

def to_rescale_rescale_strict (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')]
  (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom
    (rescale (r' * r) M) (rescale r (rescale r' M)) :=
{
  continuous' := λ c,
  begin
    haveI : fact (c * (r' * r)⁻¹ ≤ c * r⁻¹ * r'⁻¹) :=
      ⟨le_of_eq (by rw [nnreal.mul_inv, mul_assoc])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * (r' * r)⁻¹) _,
  end,
  ..rescale.to_rescale_rescale_strict_pseudo_normed_group_hom r r' M
}

end comphaus_filtered_pseudo_normed_group

namespace CompHausFiltPseuNormGrp

@[simps]
def rescale (r : ℝ≥0) : CompHausFiltPseuNormGrp ⥤ CompHausFiltPseuNormGrp :=
{ obj := λ M, of (rescale r M),
  map := λ M₁ M₂ f, rescale.map_comphaus_filtered_pseudo_normed_group_hom r f,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }
.

def rescale_iso_component (r : ℝ≥0) [fact (0 < r)] (M : CompHausFiltPseuNormGrp) :
  (rescale r).obj M ≅ M :=
{ hom :=
  comphaus_filtered_pseudo_normed_group_hom.mk' (add_monoid_hom.id _)
  begin
    refine ⟨r⁻¹, λ c, ⟨_, _⟩⟩,
    { intros x hx,
      refine pseudo_normed_group.filtration_mono _ hx,
      rw mul_comm },
    { convert @comphaus_filtered_pseudo_normed_group.continuous_cast_le M _ _ _ _ using 1,
      rw mul_comm, apply_instance }
  end,
  inv :=
  comphaus_filtered_pseudo_normed_group_hom.mk' (add_monoid_hom.id _)
  begin
    have hr : r ≠ 0 := ne_of_gt (fact.out _),
    refine ⟨r, λ c, ⟨_, _⟩⟩,
    { intros x hx,
      dsimp, erw rescale.mem_filtration,
      refine pseudo_normed_group.filtration_mono _ hx,
      rw [mul_comm, inv_mul_cancel_left₀ hr], },
    { convert @comphaus_filtered_pseudo_normed_group.continuous_cast_le M _ _ _ _ using 1,
      rw [mul_comm, inv_mul_cancel_left₀ hr], apply_instance }
  end,
  hom_inv_id' := by { intros, ext, refl },
  inv_hom_id' := by { intros, ext, refl } }

def rescale_iso (r : ℝ≥0) [fact (0 < r)] : rescale r ≅ 𝟭 _ :=
nat_iso.of_components (rescale_iso_component r) $ λ _ _ _, rfl

-- instance (X : Profinite) (c : ℝ≥0) [fact (0 < c)] :
--   limits.preserves_limits (rescale c) :=
-- limits.preserves_limits_of_nat_iso (rescale_iso c).symm

instance rescale_preserves_limits_of_shape_discrete_quotient
  (X : Profinite.{u}) (c : ℝ≥0) [fact (0 < c)] :
  limits.preserves_limits_of_shape.{u u u u u+1 u+1} (discrete_quotient.{u} ↥X) (rescale.{u u} c) :=
limits.preserves_limits_of_shape_of_nat_iso (rescale_iso c).symm

def rescale₁ (r : ℝ≥0) [fact (0 < r)] (M : CompHausFiltPseuNormGrp)
  (exh : ∀ m : M, ∃ c, m ∈ pseudo_normed_group.filtration M c) :
  CompHausFiltPseuNormGrp₁ :=
{ M := _root_.rescale r M,
  exhaustive' := λ m, begin
    obtain ⟨c, hc⟩ := exh (rescale.of.symm m),
    simp only [rescale.mem_filtration],
    refine ⟨c * r, pseudo_normed_group.filtration_mono _ hc⟩,
    rw mul_inv_cancel_right₀, exact ne_of_gt (fact.out _),
  end }

end CompHausFiltPseuNormGrp

namespace CompHausFiltPseuNormGrp₁

@[simps]
def rescale (r : ℝ≥0) [fact (0 < r)] : CompHausFiltPseuNormGrp₁ ⥤ CompHausFiltPseuNormGrp₁ :=
{ obj := λ M,
  { M := rescale r M,
    exhaustive' := λ m, begin
      obtain ⟨c, hc⟩ := M.exhaustive (rescale.of.symm m),
      simp only [rescale.mem_filtration],
      refine ⟨c * r, pseudo_normed_group.filtration_mono _ hc⟩,
      rw mul_inv_cancel_right₀, exact ne_of_gt (fact.out _),
    end },
  map := λ M₁ M₂ f, rescale.map_strict_comphaus_filtered_pseudo_normed_group_hom r f,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }
.

instance rescale.equivalence (r : ℝ≥0) [fact (0 < r)] :
  is_equivalence (rescale r) :=
by haveI : fact (0 < r⁻¹) := ⟨nnreal.inv_pos.2 (fact.elim infer_instance)⟩;
   haveI : fact (0 < r * r⁻¹) := ⟨mul_pos (fact.elim infer_instance) (fact.elim infer_instance)⟩;
exactI
is_equivalence.mk (@rescale r⁻¹ ⟨nnreal.inv_pos.2 (fact.elim infer_instance)⟩)
{ hom :=
  { app := λ M,
    -- M ⟶ rescale 1 M ⟶ rescale (r * r⁻¹) M ⟶ rescale r⁻¹ (rescale r M)
    ((comphaus_filtered_pseudo_normed_group.to_rescale_rescale_strict r⁻¹ r M).comp
    ((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M 1 (r * r⁻¹)
      (eq.symm (mul_inv_cancel (ne_of_gt (fact.elim infer_instance))))))).comp
    (comphaus_filtered_pseudo_normed_group.to_rescale_one_strict M),
    naturality' := λ M N f, rfl,
  },
  inv :=
  { app := λ M,
    -- rescale r⁻¹ (rescale r M) ⟶ rescale (r * r⁻¹) M ⟶ rescale 1 M ⟶ M
    (comphaus_filtered_pseudo_normed_group.of_rescale_one_strict M).comp
    (((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M (r * r⁻¹) 1
      ((mul_inv_cancel (ne_of_gt (fact.elim infer_instance)))))).comp
      (comphaus_filtered_pseudo_normed_group.of_rescale_rescale_strict r⁻¹ r M)),
    naturality' := λ M N f, rfl },
  hom_inv_id' := rfl,
  inv_hom_id' := rfl }
  { hom :=
    { app := λ M,
    -- rescale r (rescale r⁻¹ M) ⟶ rescale (r⁻¹ * r) M ⟶ rescale 1 M ⟶ M
    (comphaus_filtered_pseudo_normed_group.of_rescale_one_strict M).comp
    (((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M (r⁻¹ * r) 1
      ((inv_mul_cancel (ne_of_gt (fact.elim infer_instance)))))).comp
      (comphaus_filtered_pseudo_normed_group.of_rescale_rescale_strict r r⁻¹ M)),
      naturality' := λ M N f, rfl },
    inv :=
    { app := λ M,
    -- M ⟶ rescale 1 M ⟶ rescale (r⁻¹ * r) M ⟶ rescale r (rescale r⁻¹ M)
    ((comphaus_filtered_pseudo_normed_group.to_rescale_rescale_strict r r⁻¹ M).comp
    ((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M 1 (r⁻¹ * r)
      (eq.symm (inv_mul_cancel (ne_of_gt (fact.elim infer_instance))))))).comp
    (comphaus_filtered_pseudo_normed_group.to_rescale_one_strict M),
      naturality' := λ M N f, rfl },
    hom_inv_id' := rfl,
    inv_hom_id' := rfl }

instance rescale_preserves_limits_of_shape_discrete_quotient
  (X : Profinite.{u}) (c : ℝ≥0) [fact (0 < c)] :
  limits.preserves_limits_of_shape.{u u u u u+1 u+1} (discrete_quotient.{u} ↥X) (rescale.{u u} c) :=
begin
  let foo := (category_theory.adjunction.is_equivalence_preserves_limits
    (rescale c)).preserves_limits_of_shape,
  exact foo, -- not 100% sure why I need to define foo first
end

@[simps]
def rescale_enlarging_iso (r : ℝ≥0) [fact (0 < r)] :
  rescale r ⋙ CHFPNG₁_to_CHFPNGₑₗ ≅ CHFPNG₁_to_CHFPNGₑₗ :=
begin
  refine _ ≪≫ (iso_whisker_left _ (CompHausFiltPseuNormGrp.rescale_iso r))
    ≪≫ functor.right_unitor _,
  exact nat_iso.of_components (λ M, iso.refl _) (λ _ _ _, rfl),
end

@[simps]
def rescale_to_Condensed_iso (r : ℝ≥0) [fact (0 < r)] :
  rescale r ⋙ to_Condensed ≅
  CHFPNG₁_to_CHFPNGₑₗ ⋙ CompHausFiltPseuNormGrp.rescale r ⋙ CompHausFiltPseuNormGrp.to_Condensed :=
nat_iso.of_components (λ M, iso.refl _) $ λ _ _ _, rfl

-- @[simps]
-- def strict_unscale (r : ℝ≥0) [fact (1 ≤ r)] :
--   rescale r ⟶ 𝟭 _ :=
-- { app := λ M, comphaus_filtered_pseudo_normed_group.strict_unscale M r,
--   naturality' := by { intros, ext, refl, } }

-- def Condensed_unscale (r : ℝ≥0) [fact (1 ≤ r)] :
--   rescale r ⋙ to_Condensed ⟶ to_Condensed :=
-- whisker_right (strict_unscale r) to_Condensed ≫ (functor.left_unitor _).hom

-- instance is_iso_strict_unscale (r : ℝ≥0) [fact (1 ≤ r)] (M) :
--   is_iso ((Condensed_unscale r).app M) :=
-- begin
--   admit
-- end

end CompHausFiltPseuNormGrp₁

namespace comphaus_filtered_pseudo_normed_group_hom

def strictify (M₁ M₂ : Type*)
  [comphaus_filtered_pseudo_normed_group M₁] [comphaus_filtered_pseudo_normed_group M₂]
  (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂)
  (r : ℝ≥0) [fact (0 < r)]
  (hf : f.bound_by r) :
  strict_comphaus_filtered_pseudo_normed_group_hom (rescale r M₁) M₂ :=
strict_comphaus_filtered_pseudo_normed_group_hom.mk' (f.to_add_monoid_hom)
begin
  intro c,
  refine ⟨λ x hx, pseudo_normed_group.filtration_mono _ (hf hx), f.continuous _ (λ _, rfl)⟩,
  have hr : r ≠ 0 := ne_of_gt (fact.out _),
  rw [mul_left_comm, mul_inv_cancel hr, mul_one],
end

end comphaus_filtered_pseudo_normed_group_hom

open CompHausFiltPseuNormGrp₁

def strictify_nat_trans {C : Type*} [category C] {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  F ⋙ CompHausFiltPseuNormGrp₁.rescale.{u u} c ⟶ G :=
{ app := λ X, comphaus_filtered_pseudo_normed_group_hom.strictify _ _ (α.app X) c (h X),
  naturality' := λ X Y f, begin
    ext x, have := α.naturality f, apply_fun (λ φ, φ.to_fun x) at this, exact this
  end }

lemma strictify_nat_trans_enlarging {C : Type*} [category C]
  {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  whisker_right (strictify_nat_trans α c h) CHFPNG₁_to_CHFPNGₑₗ =
  (functor.associator _ _ _).hom ≫ whisker_left F (rescale_enlarging_iso c).hom ≫ α :=
begin
  ext, refl,
end

@[simp]
lemma strictify_nat_trans_enlarging' {C : Type*} [category C]
  {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  whisker_left F (rescale_enlarging_iso.{u u} c).inv ≫ (functor.associator _ _ _).inv ≫
  whisker_right (strictify_nat_trans α c h) CHFPNG₁_to_CHFPNGₑₗ = α :=
begin
  ext, refl,
end

-- move me
instance preadditive_CompHausFiltPseuNormGrp : preadditive CompHausFiltPseuNormGrp.{u} :=
{ hom_group := λ M N, by apply_instance,
  add_comp' := by { intros X Y Z f₁ f₂ g, ext, exact g.map_add _ _ },
  comp_add' := by { intros, ext, refl } }

section

variables {F G H : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
variables (α β : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
variables (c cα cβ cαβ : ℝ≥0) [fact (0 < c)] [fact (0 < cα)] [fact (0 < cβ)] [fact (0 < cαβ)]

def nonstrict_extend (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (c : ℝ≥0) [fact (0 < c)] (h : ∀ X, (α.app X).bound_by c) :
  Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend.{u} G ⋙ CHFPNG₁_to_CHFPNGₑₗ :=
whisker_left (Profinite.extend F) (rescale_enlarging_iso.{u u} c).inv ≫
whisker_right ((Profinite.extend_commutes _ _).hom ≫
  Profinite.extend_nat_trans.{u} (strictify_nat_trans α c h)) CHFPNG₁_to_CHFPNGₑₗ

-- move me
attribute [reassoc] whisker_left_comp whisker_right_comp

lemma nonstrict_extend_whisker_left (h : ∀ X, (α.app X).bound_by c) :
  whisker_left Fintype.to_Profinite (nonstrict_extend.{u} α c h) =
  (functor.associator _ _ _).inv ≫
  whisker_right (Profinite.extend_extends.{u} F).hom CHFPNG₁_to_CHFPNGₑₗ.{u} ≫ α ≫
  whisker_right (Profinite.extend_extends.{u} G).inv CHFPNG₁_to_CHFPNGₑₗ.{u} ≫
  (functor.associator _ _ _).hom :=
begin
  rw [nonstrict_extend, whisker_right_comp, whisker_left_comp, whisker_left_comp,
    ← whisker_right_left, ← whisker_right_left, Profinite.extend_nat_trans_whisker_left,
    whisker_right_comp, whisker_right_comp, strictify_nat_trans_enlarging,
    ← category_theory.whisker_right_comp_assoc, Profinite.extend_commutes_comp_extend_extends],
  refl,
end
.

lemma nonstrict_extend_bound_by (h : ∀ X, (α.app X).bound_by c) (X : Profinite.{u}) :
  ((nonstrict_extend α c h).app X).bound_by c :=
begin
  conv begin congr, skip, rw ← one_mul c, end, -- can't get nth_rewrite to work
  refine comphaus_filtered_pseudo_normed_group_hom.bound_by.comp (λ r m hm, _) _,
  { rw mul_comm,
    rwa (show r = r * c * c⁻¹, begin
      rw [mul_assoc, mul_inv_cancel (ne_of_gt (fact.elim infer_instance)), mul_one];
      apply_instance,
    end) at hm },
  { rw [← one_mul (1 : ℝ≥0), whisker_right_comp],
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one },
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one } },
end

lemma nonstrict_extend_ext'
  (α β : Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (c : ℝ≥0) [fact (0 < c)] (hα : ∀ X, (α.app X).bound_by c) (hβ : ∀ X, (β.app X).bound_by c)
  (h : whisker_left Fintype.to_Profinite α = whisker_left Fintype.to_Profinite β) :
  α = β :=
begin
  suffices : strictify_nat_trans α c hα = strictify_nat_trans β c hβ,
  { rw [← strictify_nat_trans_enlarging' α c hα, ← strictify_nat_trans_enlarging' β c hβ, this] },
  rw ← cancel_epi (Profinite.extend_commutes F (CompHausFiltPseuNormGrp₁.rescale.{u u} c)).inv,
  apply Profinite.extend_nat_trans_ext,
  simp only [whisker_left_comp, cancel_epi],
  refine ((whiskering_right _ _ _).obj CHFPNG₁_to_CHFPNGₑₗ.{u}).map_injective _,
  simp only [whiskering_right_obj_map, whisker_right_left,
    strictify_nat_trans_enlarging, whisker_left_comp, h],
end

-- move me
instance fact_max_pos : fact (0 < max cα cβ) := ⟨lt_max_iff.mpr (or.inl $ fact.out _)⟩

lemma nonstrict_extend_mono (c₁ c₂ : ℝ≥0) [fact (0 < c₁)] [fact (0 < c₂)]
  (h₁ : ∀ X, (α.app X).bound_by c₁) (h₂ : ∀ X, (α.app X).bound_by c₂) :
  nonstrict_extend α c₁ h₁ = nonstrict_extend α c₂ h₂ :=
begin
  refine nonstrict_extend_ext' _ _ (max c₁ c₂) _ _ _,
  { intro X, refine (nonstrict_extend_bound_by _ _ _ _).mono _ (le_max_left _ _), },
  { intro X, refine (nonstrict_extend_bound_by _ _ _ _).mono _ (le_max_right _ _), },
  { simp only [nonstrict_extend_whisker_left], }
end

lemma nonstrict_extend_ext
  (α β : Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (cα : ℝ≥0) [fact (0 < cα)] (cβ : ℝ≥0) [fact (0 < cβ)]
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (h : whisker_left Fintype.to_Profinite α = whisker_left Fintype.to_Profinite β) :
  α = β :=
begin
  refine nonstrict_extend_ext' _ _ (max cα cβ) _ _ h,
  { intro X, refine (hα X).mono _ (le_max_left _ _), },
  { intro X, refine (hβ X).mono _ (le_max_right _ _), },
end

-- move me
instance fact_add_pos (c₁ c₂ : ℝ≥0) [h₁ : fact (0 < c₁)] [h₂ : fact (0 < c₂)] :
  fact (0 < c₁ + c₂) :=
⟨add_pos h₁.1 h₂.1⟩

lemma nonstrict_extend_map_add (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α + β).app X).bound_by cαβ) :
  nonstrict_extend (α + β) cαβ hαβ = nonstrict_extend α cα hα + nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα + cβ) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_add],
    exact (nonstrict_extend_bound_by _ _ _ X).add (nonstrict_extend_bound_by _ _ _ X), },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_add],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.add_comp, preadditive.comp_add,
      nat_trans.app_add, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_map_neg
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((-α).app X).bound_by cβ) :
  nonstrict_extend (-α) cβ hβ = -nonstrict_extend α cα hα :=
begin
  refine nonstrict_extend_ext _ _ cβ cα _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X, apply (nonstrict_extend_bound_by _ _ _ _).neg, },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_neg],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.neg_comp, preadditive.comp_neg,
      nat_trans.app_neg, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_map_sub (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α - β).app X).bound_by cαβ) :
  nonstrict_extend (α - β) cαβ hαβ = nonstrict_extend α cα hα - nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα + cβ) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_sub],
    exact (nonstrict_extend_bound_by _ _ _ X).sub (nonstrict_extend_bound_by _ _ _ X), },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_sub],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.sub_comp, preadditive.comp_sub,
      nat_trans.app_sub, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], },
end

lemma nonstrict_extend_map_nsmul (n : ℕ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((n • α).app X).bound_by cβ) :
  nonstrict_extend (n • α) cβ hβ = n • nonstrict_extend α cα hα :=
begin
  refine nonstrict_extend_ext _ _ cβ (1 + n * cα) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_nsmul],
    exact ((nonstrict_extend_bound_by _ _ _ _).nsmul _).mono _ le_add_self, },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_nsmul],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.nsmul_comp, preadditive.comp_nsmul,
      nat_trans.app_nsmul, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_comp
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (β : G ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ H ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α ≫ β).app X).bound_by cαβ) :
  nonstrict_extend (α ≫ β) cαβ hαβ = nonstrict_extend α cα hα ≫ nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα * cβ) (nonstrict_extend_bound_by _ _ _) _ _,
  { intro X,
    rw mul_comm,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { exact nonstrict_extend_bound_by α cα hα X },
    { exact nonstrict_extend_bound_by β cβ hβ X } },
  { simp only [nonstrict_extend_whisker_left, whisker_left_comp, category.assoc,
      ← iso_whisker_right_hom, ← iso_whisker_right_inv,
      iso.hom_inv_id_assoc, iso.inv_hom_id_assoc], }
end

lemma nonstrict_extend_id
  (hα : ∀ X, (nat_trans.app (𝟙 (F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u})) X).bound_by cα) :
  nonstrict_extend (𝟙 _) cα hα = 𝟙 _ :=
begin
  refine nonstrict_extend_ext _ _ cα 1 (nonstrict_extend_bound_by _ _ _) _ _,
  { intro X, exact comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ _ _ },
  { simp only [nonstrict_extend_whisker_left, whisker_left_comp, category.assoc,
      ← iso_whisker_right_hom, ← iso_whisker_right_inv, category.id_comp,
      iso.hom_inv_id_assoc, iso.inv_hom_id_assoc, whisker_left_id'],
    refl, }
end

lemma nonstrict_extend_whisker_right_enlarging (α : F ⟶ G) :
  nonstrict_extend (whisker_right α CHFPNG₁_to_CHFPNGₑₗ) 1
    (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one) =
  whisker_right (Profinite.extend_nat_trans α) _ :=
begin
  refine nonstrict_extend_ext _ _ 1 1 (nonstrict_extend_bound_by _ _ _)
    (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one) _,
  rw [nonstrict_extend_whisker_left, ← whisker_right_left, Profinite.extend_nat_trans_whisker_left],
  refl
end

end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.concrete_category.basic
import category_theory.functor.reflects_isomorphisms

/-!
A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
whose forgetful functors both reflect isomorphisms, itself reflects isomorphisms.
-/

universes u

namespace category_theory

instance : reflects_isomorphisms (forget (Type u)) :=
{ reflects := λ X Y f i, i }

variables (C : Type (u+1)) [category C] [concrete_category.{u} C]
variables (D : Type (u+1)) [category D] [concrete_category.{u} D]

/--
A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
where `forget C` reflects isomorphisms, itself reflects isomorphisms.
-/
-- This should not be an instance, as it causes a typeclass loop
-- with `category_theory.has_forget_to_Type`
lemma reflects_isomorphisms_forget₂ [has_forget₂ C D] [reflects_isomorphisms (forget C)] :
  reflects_isomorphisms (forget₂ C D) :=
{ reflects := λ X Y f i,
  begin
    resetI,
    haveI i' : is_iso ((forget D).map ((forget₂ C D).map f)) := functor.map_is_iso (forget D) _,
    haveI : is_iso ((forget C).map f) :=
    begin
      have := has_forget₂.forget_comp,
      dsimp at this,
      rw ←this,
      exact i',
    end,
    apply is_iso_of_reflects_iso f (forget C),
  end }

end category_theory


/- -----------------------------------------------------------------------
Dependent products in LeanCat.
----------------------------------------------------------------------- -/

import ..c1_basic
import ..c2_limits
import ..c3_wtypes

import .s1_basic

namespace qp

open stdaux

universe variables ℓ ℓobjx ℓhomx

/- -----------------------------------------------------------------------
The dependent product functor.
----------------------------------------------------------------------- -/

/-! #brief The dependent product functor on objects.
-/
definition LeanCat.DepProdFun.obj {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    (S : OverObj LeanCat.{ℓ} B)
    : OverObj LeanCat.{ℓ} A
:= { obj := @coproduct LeanCat A
              (λ a, @product LeanCat {b : B // disp b = a}
                      (λ b, { x : S^.obj // S^.hom x = b^.val})
                      (LeanCat.HasProduct.{ℓ ℓ} _))
              (LeanCat.HasCoProduct.{ℓ ℓ} _)
   , hom := sigma.fst
   }

-- /-! #brief Function induced toward the dependent product of a monic.
-- -/
-- definition LeanCat.DepProdFun.obj.monic_to {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     [disp_Monic : @Monic LeanCat.{ℓ} B A disp]
--     (S : OverObj LeanCat.{ℓ} B)
--     (s : S^.obj)
--     : (LeanCat.DepProdFun.obj disp S)^.obj
-- := { fst := disp (S^.hom s)
--    , snd := λ b
--             , { val := s
--               , property := eq.symm (LeanCat.Monic.inj disp_Monic b^.property)
--               }
--    }

-- /-! #brief Function induced from the dependent product of a (strong) epic.
-- -/
-- definition LeanCat.DepProdFun.obj.epic_from.upon {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     (undisp : LeanCat.{ℓ}^.hom A B)
--     {ωdisp_undisp : LeanCat.{ℓ}^.circ disp undisp = LeanCat.{ℓ}^.id A}
--     (S : OverObj LeanCat.{ℓ} B)
--     (af : (LeanCat.DepProdFun.obj disp S)^.obj)
--     : {b // disp b = af^.fst}
-- := { val := undisp af^.fst
--    , property := congr_fun ωdisp_undisp af^.fst
--    }

-- /-! #brief Function induced from the dependent product of a (strong) epic.
-- -/
-- definition LeanCat.DepProdFun.obj.epic_from {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     (undisp : LeanCat.{ℓ}^.hom A B)
--     (ωdisp_undisp : LeanCat.{ℓ}^.circ disp undisp = LeanCat.{ℓ}^.id A)
--     (S : OverObj LeanCat.{ℓ} B)
--     (af : (LeanCat.DepProdFun.obj disp S)^.obj)
--     : S^.obj
-- := (af^.snd (@LeanCat.DepProdFun.obj.epic_from.upon B A disp undisp ωdisp_undisp S af))^.val

-- /-! #brief The dependent product functor is trivial on isos.
-- -/
-- definition LeanCat.DepProdFun.obj.Iso {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     [disp_Monic : @Monic LeanCat.{ℓ} B A disp]
--     (undisp : LeanCat.{ℓ}^.hom A B)
--     (ωdisp_undisp : LeanCat.{ℓ}^.circ disp undisp = LeanCat.{ℓ}^.id A)
--     (S : OverObj LeanCat.{ℓ} B)
--     : @Iso LeanCat.{ℓ} _ _
--         (LeanCat.DepProdFun.obj.monic_to disp S)
--         (LeanCat.DepProdFun.obj.epic_from disp undisp ωdisp_undisp S)
-- := { id₁ := rfl
--    , id₂ := begin
--               apply funext,
--               intro a,
--               cases a with a f,
--               unfold LeanCat SortCat,
--               dsimp,
--               unfold LeanCat.DepProdFun.obj.monic_to,
--               unfold LeanCat.DepProdFun.obj.epic_from,
--               exact sorry
--             end
--    }

/-! #brief The dependent product functor on functions.
-/
definition LeanCat.DepProdFun.hom {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    {S₀ S₁ : OverObj LeanCat.{ℓ} B}
    (f : OverHom LeanCat.{ℓ} B S₀ S₁)
    : OverHom LeanCat.{ℓ} A
       (@LeanCat.DepProdFun.obj B A disp S₀)
       (@LeanCat.DepProdFun.obj B A disp S₁)
:= let a : (LeanCat.DepProdFun.obj disp S₀)^.obj → A
        := λ σ
           , σ^.fst
in let s₁ : ∀ (σ : (LeanCat.DepProdFun.obj disp S₀)^.obj)
              (b : {b // disp b = a σ})
            , S₁^.obj
         := λ σ b
            , f^.hom (σ^.snd b)^.val
in let ωs₁ : ∀ (σ : (LeanCat.DepProdFun.obj disp S₀)^.obj)
               (b : {b // disp b = a σ})
             , S₁^.hom (s₁ σ b) = b^.val
          := λ σ b
             , begin
                 apply eq.trans (congr_fun (eq.symm f^.triangle) (σ^.snd b)),
                 apply (σ^.snd b)^.property
               end
in { hom
      := λ σ, { fst := a σ
              , snd := λ b, { val := s₁ σ b, property := ωs₁ σ b }
              }
   , triangle := rfl
   }

/-! #brief The dependent product functor preserves identity functions.
-/
definition LeanCat.DepProdFun.hom_id {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    (S : OverObj LeanCat.{ℓ} B)
    : LeanCat.DepProdFun.hom disp (OverHom.id LeanCat.{ℓ} B S)
       = OverHom.id LeanCat.{ℓ} A (LeanCat.DepProdFun.obj disp S)
:= begin
     apply OverHom.eq,
     apply funext, intro σ,
     cases σ with a f,
     apply congr_arg (sigma.mk a),
     apply funext, intro b,
     apply subtype.eq,
     trivial
   end

/-! #brief The dependent product functor distributes over composition.
-/
definition LeanCat.DepProdFun.hom_comp {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    (S₁ S₂ S₃ : OverObj LeanCat.{ℓ} B)
    (g : OverHom LeanCat.{ℓ} B S₂ S₃)
    (f : OverHom LeanCat.{ℓ} B S₁ S₂)
    : LeanCat.DepProdFun.hom disp (OverHom.comp LeanCat.{ℓ} B _ _ _ g f)
       = OverHom.comp LeanCat.{ℓ} A _ _ _ (LeanCat.DepProdFun.hom disp g) (LeanCat.DepProdFun.hom disp f)
:= begin
     apply OverHom.eq,
     apply funext, intro σ,
     cases σ with a h,
     apply congr_arg (sigma.mk a),
     apply funext, intro b,
     apply subtype.eq,
     trivial
   end

/-! #brief The dependent product functor.
-/
definition LeanCat.DepProdFun {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    : Fun (OverCat LeanCat.{ℓ} B) (OverCat LeanCat.{ℓ} A)
:= { obj := LeanCat.DepProdFun.obj disp
   , hom := @LeanCat.DepProdFun.hom B A disp
   , hom_id := LeanCat.DepProdFun.hom_id disp
   , hom_circ := LeanCat.DepProdFun.hom_comp disp
   }

-- /- -----------------------------------------------------------------------
-- The dependent product functor is right adjoint to base change.
-- ----------------------------------------------------------------------- -/

/-! #brief Component of the counit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.counit_com
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (X : OverObj LeanCat.{ℓ} x)
    : OverHom LeanCat.{ℓ} x
        (BaseChangeFun.obj f (LeanCat.DepProdFun.obj f X))
        X
:= { hom := λ Z
            , let pb₀ := pullback.π LeanCat.{ℓ} (f ↗→ (LeanCat.DepProdFun.obj f X)^.hom ↗→↗) (@fin_of 1 0) Z
           in let pb₁ := (pullback.π LeanCat.{ℓ} (f ↗→ (LeanCat.DepProdFun.obj f X)^.hom ↗→↗) (@fin_of 0 1) Z)^.snd
              in (pb₁ { val := pb₀, property := sorry })^.val
   , triangle := sorry
   }

/-! #brief Counit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.counit
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    : NatTrans (@BaseChangeFun LeanCat.{ℓ} x y f (HasAllPullbacks.HasPullbacksAlong LeanCat _) □□ LeanCat.DepProdFun f)
               (Fun.id (OverCat LeanCat.{ℓ} x))
:= { com := LeanCat.BaseChange_DepProd.Adj.counit_com f
   , natural := sorry
   }

/-! #brief Cone used to define the component of the unit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.unit_com.cone
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (Y : OverObj LeanCat.{ℓ} y)
    (Yy : OverObj.dom Y)
    (Xx : {b // f b = Y^.hom Yy})
    : PullbackCone LeanCat.{ℓ} (f ↗→ Y^.hom ↗→↗)
:= @PullbackCone.mk LeanCat.{ℓ} _ _
    (f ↗→ Y^.hom ↗→↗) {b // f b = Y^.hom Yy}
    (λ Xx, f Xx^.val) (subtype.val ↗← (λ Xx, Yy) ↗←↗)
    begin
      apply dlist.eq,
      { trivial },
      apply dlist.eq,
      { apply funext, intro Xx, cases Xx with Xx ωXx,
        exact sorry
      }
      , trivial
    end

/-! #brief Component of the unit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.unit_com
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (Y : OverObj LeanCat.{ℓ} y)
    : OverHom LeanCat.{ℓ} y
        Y
        (LeanCat.DepProdFun.obj f (BaseChangeFun.obj f Y))
:= { hom := λ Yy, { fst := Y^.hom Yy
                  , snd := λ Xx
                           , { val := pullback.univ LeanCat.{ℓ}
                                       (f ↗→ Y^.hom ↗→↗)
                                       (LeanCat.BaseChange_DepProd.Adj.unit_com.cone f Y Yy Xx) Xx
                             , property := sorry
                             }
                  }
   , triangle := sorry
   }

/-! #brief Unit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.unit
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    : NatTrans (Fun.id (OverCat LeanCat.{ℓ} y))
               (LeanCat.DepProdFun f □□ @BaseChangeFun LeanCat.{ℓ} x y f (HasAllPullbacks.HasPullbacksAlong _ _))
:= { com := LeanCat.BaseChange_DepProd.Adj.unit_com f
   , natural := sorry
   }

/-! #brief Left-identity of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
theorem LeanCat.BaseChange_DepProd.Adj.id_left
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (Y : OverObj LeanCat.{ℓ} y)
    : OverHom.comp LeanCat x _ _ _
        (LeanCat.BaseChange_DepProd.Adj.counit_com f (BaseChangeFun.obj f Y))
        (BaseChangeFun.hom f _ _ (LeanCat.BaseChange_DepProd.Adj.unit_com f Y))
       = OverHom.id LeanCat x (BaseChangeFun.obj f Y)
:= sorry

/-! #brief Right-identity of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
theorem LeanCat.BaseChange_DepProd.Adj.id_right
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (X : OverObj LeanCat.{ℓ} x)
    : OverHom.comp LeanCat y _ _ _
        (LeanCat.DepProdFun.hom f (LeanCat.BaseChange_DepProd.Adj.counit_com f X))
        (LeanCat.BaseChange_DepProd.Adj.unit_com f (LeanCat.DepProdFun.obj f X))
       = OverHom.id LeanCat y (LeanCat.DepProdFun.obj f X)
:= sorry

/-! #brief BaseChangeFun and LeanCat.DepProdFun are adjoint.
-/
definition LeanCat.BaseChange_DepProd.Adj
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    : Adj (LeanCat.BaseChangeFun f)
          (LeanCat.DepProdFun f)
:= { counit := LeanCat.BaseChange_DepProd.Adj.counit f
   , unit := LeanCat.BaseChange_DepProd.Adj.unit f
   , id_left := LeanCat.BaseChange_DepProd.Adj.id_left f
   , id_right := LeanCat.BaseChange_DepProd.Adj.id_right f
   }

/-! #brief LeanCat has dependent product.
-/
instance LeanCat.HasDepProd {X Y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom X Y)
    : HasDepProd LeanCat.{ℓ} f
:= { depprod := LeanCat.DepProdFun f
   , adj := LeanCat.BaseChange_DepProd.Adj f
   }

/-! #brief LeanCat has all dependent products.
-/
instance LeanCat.HasAllDepProd
    : HasAllDepProd LeanCat.{ℓ}
:= { has_depprod := λ x y f, LeanCat.HasDepProd f
   }

/- -----------------------------------------------------------------------
Existence of W-types in LeanCat.
----------------------------------------------------------------------- -/

definition LeanCat.DepProdFun.PresCoLimit.hom
    (P : PolyEndoFun LeanCat.{ℓ})
    (ωP : ∀ (a : P^.codom), FinType { b : P^.dom // P^.hom b = a })
    (L : Fun NatCat (OverCat LeanCat P^.dom))
     : OverHom LeanCat P^.codom
        ((LeanCat.DepProdFun P^.hom)^.obj (colimit L))
        (colimit (LeanCat.DepProdFun P^.hom □□ L))
:= sorry

definition LeanCat.DepProdFun.PresCoLimit
    (P : PolyEndoFun LeanCat.{ℓ})
    (ωP : ∀ (a : P^.codom), FinType { b : P^.dom // P^.hom b = a })
    (L : Fun NatCat (OverCat LeanCat P^.dom))
    : PresCoLimit L (LeanCat.DepProdFun P^.hom)
:= PresCoLimit.show
    (λ L_HasCoLimit C hom ωhom
     , let ccone : CoCone (LeanCat.DepProdFun P^.hom □□ L)
                := CoCone.mk C hom @ωhom
       in (OverCat LeanCat P^.codom)^.circ
           ((OverCat LeanCat P^.codom)^.circ
              (@colimit.univ _ _ _ (LeanCat.Over.HasCoLimit _ _) ccone)
              (LeanCat.DepProdFun.PresCoLimit.hom P ωP L))
           ((LeanCat.DepProdFun P^.hom)^.hom (colimit.iso L_HasCoLimit (LeanCat.Over.HasCoLimit P^.dom L))))
    sorry
    sorry

definition LeanCat.HasWType
    (P : PolyEndoFun LeanCat.{ℓ})
    (ωP : ∀ (a : P^.codom), FinType { b : P^.dom // P^.hom b = a })
    : HasWType LeanCat P
:= HasWType.Adamek LeanCat P
    { pres_colimit := LeanCat.DepProdFun.PresCoLimit P ωP }

end qp


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin, Bhavik Mehta
-/
import category_theory.isomorphism
import category_theory.functor.category
import category_theory.eq_to_hom

/-!
# Comma categories

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

A comma category is a construction in category theory, which builds a category out of two functors
with a common codomain. Specifically, for functors `L : A ⥤ T` and `R : B ⥤ T`, an object in
`comma L R` is a morphism `hom : L.obj left ⟶ R.obj right` for some objects `left : A` and
`right : B`, and a morphism in `comma L R` between `hom : L.obj left ⟶ R.obj right` and
`hom' : L.obj left' ⟶ R.obj right'` is a commutative square

```
L.obj left   ⟶   L.obj left'
      |               |
  hom |               | hom'
      ↓               ↓
R.obj right  ⟶   R.obj right',
```

where the top and bottom morphism come from morphisms `left ⟶ left'` and `right ⟶ right'`,
respectively.

## Main definitions

* `comma L R`: the comma category of the functors `L` and `R`.
* `over X`: the over category of the object `X` (developed in `over.lean`).
* `under X`: the under category of the object `X` (also developed in `over.lean`).
* `arrow T`: the arrow category of the category `T` (developed in `arrow.lean`).

## References

* <https://ncatlab.org/nlab/show/comma+category>

## Tags

comma, slice, coslice, over, under, arrow
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ v₅ u₁ u₂ u₃ u₄ u₅
variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]
variables {T : Type u₃} [category.{v₃} T]

/-- The objects of the comma category are triples of an object `left : A`, an object
   `right : B` and a morphism `hom : L.obj left ⟶ R.obj right`.  -/
structure comma (L : A ⥤ T) (R : B ⥤ T) : Type (max u₁ u₂ v₃) :=
(left : A)
(right : B)
(hom : L.obj left ⟶ R.obj right)

-- Satisfying the inhabited linter
instance comma.inhabited [inhabited T] : inhabited (comma (𝟭 T) (𝟭 T)) :=
{ default :=
  { left := default,
    right := default,
    hom := 𝟙 default } }

variables {L : A ⥤ T} {R : B ⥤ T}

/-- A morphism between two objects in the comma category is a commutative square connecting the
    morphisms coming from the two objects using morphisms in the image of the functors `L` and `R`.
-/
@[ext] structure comma_morphism (X Y : comma L R) :=
(left : X.left ⟶ Y.left)
(right : X.right ⟶ Y.right)
(w' : L.map left ≫ Y.hom = X.hom ≫ R.map right . obviously)

-- Satisfying the inhabited linter
instance comma_morphism.inhabited [inhabited (comma L R)] :
  inhabited (comma_morphism (default : comma L R) default) :=
⟨⟨𝟙 _, 𝟙 _⟩⟩

restate_axiom comma_morphism.w'
attribute [simp, reassoc] comma_morphism.w

instance comma_category : category (comma L R) :=
{ hom := comma_morphism,
  id := λ X,
  { left := 𝟙 X.left,
    right := 𝟙 X.right },
  comp := λ X Y Z f g,
  { left := f.left ≫ g.left,
    right := f.right ≫ g.right } }

namespace comma

section
variables {X Y Z : comma L R} {f : X ⟶ Y} {g : Y ⟶ Z}

@[simp] lemma id_left  : ((𝟙 X) : comma_morphism X X).left = 𝟙 X.left := rfl
@[simp] lemma id_right : ((𝟙 X) : comma_morphism X X).right = 𝟙 X.right := rfl
@[simp] lemma comp_left  : (f ≫ g).left  = f.left ≫ g.left   := rfl
@[simp] lemma comp_right : (f ≫ g).right = f.right ≫ g.right := rfl

end

variables (L) (R)

/-- The functor sending an object `X` in the comma category to `X.left`. -/
@[simps]
def fst : comma L R ⥤ A :=
{ obj := λ X, X.left,
  map := λ _ _ f, f.left }

/-- The functor sending an object `X` in the comma category to `X.right`. -/
@[simps]
def snd : comma L R ⥤ B :=
{ obj := λ X, X.right,
  map := λ _ _ f, f.right }

/-- We can interpret the commutative square constituting a morphism in the comma category as a
    natural transformation between the functors `fst ⋙ L` and `snd ⋙ R` from the comma category
    to `T`, where the components are given by the morphism that constitutes an object of the comma
    category. -/
@[simps]
def nat_trans : fst L R ⋙ L ⟶ snd L R ⋙ R :=
{ app := λ X, X.hom }

@[simp] lemma eq_to_hom_left (X Y : comma L R) (H : X = Y) :
  comma_morphism.left (eq_to_hom H) = eq_to_hom (by { cases H, refl }) := by { cases H, refl }

@[simp] lemma eq_to_hom_right (X Y : comma L R) (H : X = Y) :
  comma_morphism.right (eq_to_hom H) = eq_to_hom (by { cases H, refl }) := by { cases H, refl }

section
variables {L₁ L₂ L₃ : A ⥤ T} {R₁ R₂ R₃ : B ⥤ T}

/--
Construct an isomorphism in the comma category given isomorphisms of the objects whose forward
directions give a commutative square.
-/
@[simps]
def iso_mk {X Y : comma L₁ R₁} (l : X.left ≅ Y.left) (r : X.right ≅ Y.right)
  (h : L₁.map l.hom ≫ Y.hom = X.hom ≫ R₁.map r.hom) : X ≅ Y :=
{ hom := { left := l.hom, right := r.hom },
  inv :=
  { left := l.inv,
    right := r.inv,
    w' := begin
      rw [←L₁.map_iso_inv l, iso.inv_comp_eq, L₁.map_iso_hom, reassoc_of h, ← R₁.map_comp],
      simp
    end, } }

/-- A natural transformation `L₁ ⟶ L₂` induces a functor `comma L₂ R ⥤ comma L₁ R`. -/
@[simps]
def map_left (l : L₁ ⟶ L₂) : comma L₂ R ⥤ comma L₁ R :=
{ obj := λ X,
  { left  := X.left,
    right := X.right,
    hom   := l.app X.left ≫ X.hom },
  map := λ X Y f,
  { left  := f.left,
    right := f.right } }

/-- The functor `comma L R ⥤ comma L R` induced by the identity natural transformation on `L` is
    naturally isomorphic to the identity functor. -/
@[simps]
def map_left_id : map_left R (𝟙 L) ≅ 𝟭 _ :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- The functor `comma L₁ R ⥤ comma L₃ R` induced by the composition of two natural transformations
    `l : L₁ ⟶ L₂` and `l' : L₂ ⟶ L₃` is naturally isomorphic to the composition of the two functors
    induced by these natural transformations. -/
@[simps]
def map_left_comp (l : L₁ ⟶ L₂) (l' : L₂ ⟶ L₃) :
  (map_left R (l ≫ l')) ≅ (map_left R l') ⋙ (map_left R l) :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- A natural transformation `R₁ ⟶ R₂` induces a functor `comma L R₁ ⥤ comma L R₂`. -/
@[simps]
def map_right (r : R₁ ⟶ R₂) : comma L R₁ ⥤ comma L R₂ :=
{ obj := λ X,
  { left  := X.left,
    right := X.right,
    hom   := X.hom ≫ r.app X.right },
  map := λ X Y f,
  { left  := f.left,
    right := f.right } }

/-- The functor `comma L R ⥤ comma L R` induced by the identity natural transformation on `R` is
    naturally isomorphic to the identity functor. -/
@[simps]
def map_right_id : map_right L (𝟙 R) ≅ 𝟭 _ :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- The functor `comma L R₁ ⥤ comma L R₃` induced by the composition of the natural transformations
    `r : R₁ ⟶ R₂` and `r' : R₂ ⟶ R₃` is naturally isomorphic to the composition of the functors
    induced by these natural transformations. -/
@[simps]
def map_right_comp (r : R₁ ⟶ R₂) (r' : R₂ ⟶ R₃) :
  (map_right L (r ≫ r')) ≅ (map_right L r) ⋙ (map_right L r') :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

end

section
variables {C : Type u₄} [category.{v₄} C] {D : Type u₅} [category.{v₅} D]

/-- The functor `(F ⋙ L, R) ⥤ (L, R)` -/
@[simps] def pre_left (F: C ⥤ A) (L : A ⥤ T) (R : B ⥤ T) : comma (F ⋙ L) R ⥤ comma L R :=
{ obj := λ X, { left := F.obj X.left, right := X.right, hom := X.hom },
  map := λ X Y f, { left := F.map f.left, right := f.right, w' := by simpa using f.w } }

/-- The functor `(F ⋙ L, R) ⥤ (L, R)` -/
@[simps] def pre_right (L : A ⥤ T) (F: C ⥤ B) (R : B ⥤ T) : comma L (F ⋙ R) ⥤ comma L R :=
{ obj := λ X, { left := X.left, right := F.obj X.right, hom := X.hom },
  map := λ X Y f, { left := f.left, right := F.map f.right, w' := by simp } }

/-- The functor `(L, R) ⥤ (L ⋙ F, R ⋙ F)` -/
@[simps] def post (L : A ⥤ T) (R : B ⥤ T) (F: T ⥤ C) : comma L R ⥤ comma (L ⋙ F) (R ⋙ F) :=
{ obj := λ X, { left := X.left, right := X.right, hom := F.map X.hom },
  map := λ X Y f, { left := f.left, right := f.right, w' :=
    by { simp only [functor.comp_map, ←F.map_comp, f.w] } } }

end
end comma

end category_theory


import data.matrix.block

namespace matrix
open_locale matrix
variables {l m α R : Type*}
variables [decidable_eq l] [decidable_eq m]

section has_zero
variables [has_zero α]

lemma to_block_diagonal_self (d : m → α) (p : m → Prop) :
  matrix.to_block (diagonal d) p p = diagonal (λ i : subtype p, d ↑i) :=
begin
  ext i j,
  by_cases i = j,
  { simp [h] },
  { simp [has_one.one, h, λ h', h $ subtype.ext h'], }
end

lemma to_block_diagonal_disjoint (d : m → α) {p q : m → Prop} (hpq : disjoint p q) :
  matrix.to_block (diagonal d) p q = 0 :=
begin
  ext ⟨i, hi⟩ ⟨j, hj⟩,
  have : i ≠ j, from λ heq, hpq i ⟨hi, heq.symm ▸ hj⟩,
  simp [diagonal_apply_ne d this]
end

end has_zero

section has_zero_has_one
variables [has_zero α] [has_one α]

lemma to_block_one_self (p : m → Prop) : matrix.to_block (1 : matrix m m α) p p = 1 :=
to_block_diagonal_self _ p

lemma to_block_one_disjoint {p q : m → Prop} (hpq : disjoint p q) :
  matrix.to_block (1 : matrix m m α) p q = 0 :=
to_block_diagonal_disjoint _ hpq

end has_zero_has_one

section
variables [comm_ring R]

lemma to_block_mul_eq_mul {m n k : Type*} [fintype n] (p : m → Prop) (q : k → Prop)
  (A : matrix m n R) (B : matrix n k R) :
  (A ⬝ B).to_block p q = A.to_block p ⊤ ⬝ B.to_block ⊤ q :=
begin
  ext i k,
  simp only [to_block_apply, mul_apply],
  rw finset.sum_subtype,
  simp [has_top.top, complete_lattice.top, bounded_order.top],
end

lemma to_block_mul_eq_add
  {m n k : Type*} [fintype n] (p : m → Prop) (q : n → Prop) [decidable_pred q] (r : k → Prop)
  (A : matrix m n R) (B : matrix n k R) :
  (A ⬝ B).to_block p r =
    A.to_block p q ⬝ B.to_block q r + A.to_block p (λ i, ¬ q i) ⬝ B.to_block (λ i, ¬ q i) r :=
begin
  classical,
  ext i k,
  simp only [to_block_apply, mul_apply, pi.add_apply],
  convert (fintype.sum_subtype_add_sum_subtype q (λ x, A ↑i x * B x ↑k)).symm
end

end

end matrix


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.group.ext
import category_theory.simple
import category_theory.linear.basic
import category_theory.endomorphism
import algebra.algebra.spectrum

/-!
# Schur's lemma
We first prove the part of Schur's Lemma that holds in any preadditive category with kernels,
that any nonzero morphism between simple objects
is an isomorphism.

Second, we prove Schur's lemma for `𝕜`-linear categories with finite dimensional hom spaces,
over an algebraically closed field `𝕜`:
the hom space `X ⟶ Y` between simple objects `X` and `Y` is at most one dimensional,
and is 1-dimensional iff `X` and `Y` are isomorphic.
-/

namespace category_theory

open category_theory.limits

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

-- See also `epi_of_nonzero_to_simple`, which does not require `preadditive C`.
lemma mono_of_nonzero_from_simple [has_kernels C] {X Y : C} [simple X] {f : X ⟶ Y} (w : f ≠ 0) :
  mono f :=
preadditive.mono_of_kernel_zero (kernel_zero_of_nonzero_from_simple w)

/--
The part of **Schur's lemma** that holds in any preadditive category with kernels:
that a nonzero morphism between simple objects is an isomorphism.
-/
lemma is_iso_of_hom_simple [has_kernels C] {X Y : C} [simple X] [simple Y] {f : X ⟶ Y} (w : f ≠ 0) :
  is_iso f :=
begin
  haveI := mono_of_nonzero_from_simple w,
  exact is_iso_of_mono_of_nonzero w
end

/--
As a corollary of Schur's lemma for preadditive categories,
any morphism between simple objects is (exclusively) either an isomorphism or zero.
-/
lemma is_iso_iff_nonzero [has_kernels C] {X Y : C} [simple X] [simple Y] (f : X ⟶ Y) :
  is_iso f ↔ f ≠ 0 :=
⟨λ I,
  begin
    introI h,
    apply id_nonzero X,
    simp only [←is_iso.hom_inv_id f, h, zero_comp],
  end,
  λ w, is_iso_of_hom_simple w⟩

/--
In any preadditive category with kernels,
the endomorphisms of a simple object form a division ring.
-/
noncomputable
instance [has_kernels C] {X : C} [simple X] : division_ring (End X) :=
by classical; exact
{ inv := λ f, if h : f = 0 then 0 else by { haveI := is_iso_of_hom_simple h, exact inv f, },
  exists_pair_ne := ⟨𝟙 X, 0, id_nonzero _⟩,
  inv_zero := dif_pos rfl,
  mul_inv_cancel := λ f h, begin
    haveI := is_iso_of_hom_simple h,
    convert is_iso.inv_hom_id f,
    exact dif_neg h,
  end,
  ..(infer_instance : ring (End X)) }

open finite_dimensional

section
variables (𝕜 : Type*) [division_ring 𝕜]

/--
Part of **Schur's lemma** for `𝕜`-linear categories:
the hom space between two non-isomorphic simple objects is 0-dimensional.
-/
lemma finrank_hom_simple_simple_eq_zero_of_not_iso
  [has_kernels C] [linear 𝕜 C] {X Y : C} [simple X] [simple Y]
  (h : (X ≅ Y) → false):
  finrank 𝕜 (X ⟶ Y) = 0 :=
begin
  haveI := subsingleton_of_forall_eq (0 : X ⟶ Y) (λ f, begin
    have p := not_congr (is_iso_iff_nonzero f),
    simp only [not_not, ne.def] at p,
    refine p.mp (λ _, by exactI h (as_iso f)),
  end),
  exact finrank_zero_of_subsingleton,
end

end

variables (𝕜 : Type*) [field 𝕜]
variables [is_alg_closed 𝕜] [linear 𝕜 C]

-- In the proof below we have some difficulty using `I : finite_dimensional 𝕜 (X ⟶ X)`
-- where we need a `finite_dimensional 𝕜 (End X)`.
-- These are definitionally equal, but without eta reduction Lean can't see this.
-- To get around this, we use `convert I`,
-- then check the various instances agree field-by-field,

/--
An auxiliary lemma for Schur's lemma.

If `X ⟶ X` is finite dimensional, and every nonzero endomorphism is invertible,
then `X ⟶ X` is 1-dimensional.
-/
-- We prove this with the explicit `is_iso_iff_nonzero` assumption,
-- rather than just `[simple X]`, as this form is useful for
-- Müger's formulation of semisimplicity.
lemma finrank_endomorphism_eq_one
  {X : C} (is_iso_iff_nonzero : ∀ f : X ⟶ X, is_iso f ↔ f ≠ 0)
  [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
begin
  have id_nonzero := (is_iso_iff_nonzero (𝟙 X)).mp (by apply_instance),
  apply finrank_eq_one (𝟙 X),
  { exact id_nonzero, },
  { intro f,
    haveI : nontrivial (End X) := nontrivial_of_ne _ _ id_nonzero,
    obtain ⟨c, nu⟩ := @spectrum.nonempty_of_is_alg_closed_of_finite_dimensional 𝕜 (End X) _ _ _ _ _
      (by { convert I, ext, refl, ext, refl, }) (End.of f),
    use c,
    rw [spectrum.mem_iff, is_unit.sub_iff, is_unit_iff_is_iso, is_iso_iff_nonzero, ne.def,
      not_not, sub_eq_zero, algebra.algebra_map_eq_smul_one] at nu,
    exact nu.symm, },
end

variables [has_kernels C]

/--
**Schur's lemma** for endomorphisms in `𝕜`-linear categories.
-/
lemma finrank_endomorphism_simple_eq_one
  (X : C) [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
finrank_endomorphism_eq_one 𝕜 is_iso_iff_nonzero

lemma endomorphism_simple_eq_smul_id
  {X : C} [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] (f : X ⟶ X) :
  ∃ c : 𝕜, c • 𝟙 X = f :=
(finrank_eq_one_iff_of_nonzero' (𝟙 X) (id_nonzero X)).mp (finrank_endomorphism_simple_eq_one 𝕜 X) f

/--
Endomorphisms of a simple object form a field if they are finite dimensional.
This can't be an instance as `𝕜` would be undetermined.
-/
noncomputable
def field_End_of_finite_dimensional (X : C) [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] :
  field (End X) :=
by classical; exact
{ mul_comm := λ f g, begin
    obtain ⟨c, rfl⟩ := endomorphism_simple_eq_smul_id 𝕜 f,
    obtain ⟨d, rfl⟩ := endomorphism_simple_eq_smul_id 𝕜 g,
    simp [←mul_smul, mul_comm c d],
  end,
  ..(infer_instance : division_ring (End X)) }

/--
**Schur's lemma** for `𝕜`-linear categories:
if hom spaces are finite dimensional, then the hom space between simples is at most 1-dimensional.

See `finrank_hom_simple_simple_eq_one_iff` and `finrank_hom_simple_simple_eq_zero_iff` below
for the refinements when we know whether or not the simples are isomorphic.
-/
-- There is a symmetric argument that uses `[finite_dimensional 𝕜 (Y ⟶ Y)]` instead,
-- but we don't bother proving that here.
lemma finrank_hom_simple_simple_le_one
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) ≤ 1 :=
begin
  cases subsingleton_or_nontrivial (X ⟶ Y) with h,
  { resetI,
    rw finrank_zero_of_subsingleton,
    exact zero_le_one },
  { obtain ⟨f, nz⟩ := (nontrivial_iff_exists_ne 0).mp h,
    haveI fi := (is_iso_iff_nonzero f).mpr nz,
    apply finrank_le_one f,
    intro g,
    obtain ⟨c, w⟩ := endomorphism_simple_eq_smul_id 𝕜 (g ≫ inv f),
    exact ⟨c, by simpa using w =≫ f⟩, },
end

lemma finrank_hom_simple_simple_eq_one_iff
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = 1 ↔ nonempty (X ≅ Y) :=
begin
  fsplit,
  { intro h,
    rw finrank_eq_one_iff' at h,
    obtain ⟨f, nz, -⟩ := h,
    rw ←is_iso_iff_nonzero at nz,
    exactI ⟨as_iso f⟩, },
  { rintro ⟨f⟩,
    have le_one := finrank_hom_simple_simple_le_one 𝕜 X Y,
    have zero_lt : 0 < finrank 𝕜 (X ⟶ Y) :=
      finrank_pos_iff_exists_ne_zero.mpr ⟨f.hom, (is_iso_iff_nonzero f.hom).mp infer_instance⟩,
    linarith, }
end

lemma finrank_hom_simple_simple_eq_zero_iff
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = 0 ↔ is_empty (X ≅ Y) :=
begin
  rw [← not_nonempty_iff, ← not_congr (finrank_hom_simple_simple_eq_one_iff 𝕜 X Y)],
  refine ⟨λ h, by { rw h, simp, }, λ h, _⟩,
  have := finrank_hom_simple_simple_le_one 𝕜 X Y,
  interval_cases finrank 𝕜 (X ⟶ Y) with h',
  { exact h', },
  { exact false.elim (h h'), },
end

open_locale classical

lemma finrank_hom_simple_simple
  (X Y : C) [∀ X Y : C, finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = if nonempty (X ≅ Y) then 1 else 0 :=
begin
  split_ifs,
  exact (finrank_hom_simple_simple_eq_one_iff 𝕜 X Y).2 h,
  exact (finrank_hom_simple_simple_eq_zero_iff 𝕜 X Y).2 (not_nonempty_iff.mp h),
end

end category_theory


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

open encodable part

universes u v

section

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

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

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

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

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

prefix `↑ᵣ`:max := coe_ropt

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

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

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

prefix `↑ₒ`:max := coe_opt

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

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

prefix `↑ʳ`:max := coe_opt_ropt

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

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

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

prefix `↑ᵒ`:max := coe_ropt_opt

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

end

namespace nat

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

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

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

end nat

namespace list
variables {α : Type*}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

infix ` ⊂ᵢ `:50 := is_initial

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

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

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

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

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

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

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

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

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

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

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

#check list.rec_on

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

section
open primrec

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

end

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

infix ` ∥ ` :50 := incomparable

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end list

namespace option
variables {α : Type u}

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

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

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

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

end option

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

namespace omega_ordering

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end omega_ordering
namespace fin

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

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

end fin

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

namespace finitary
variables {α : Type*}
open vector

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

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

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

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

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

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

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

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

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

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

end finitary

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

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

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

namespace part

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

infix ` ≼ `:50 := part.le_nat

end part

namespace pfun

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

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

end pfun


import data.nat.digits

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