(**

Direct implementation of indexed products together with:

- The general product functor ([product_functor])
- Definition of a product structure on a functor category by taking pointwise products in the target
  category (adapted from the binary version) ([Products_functor_precat])
- Products from limits ([Products_from_Lims])

Written by: Anders Mörtberg 2016

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.ProductCategory.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.

Local Open Scope cat.

(** * Definition of indexed products of objects in a precategory *)
Section product_def.

Context (I : UU) (C : category).

Definition isProduct (c : ∏ (i : I), C) (p : C)
  (pi : ∏ i, p --> c i) :=
  ∏ (a : C) (f : ∏ i, a --> c i),
    ∃! (fap : a --> p), ∏ i, fap · pi i = f i.

Definition Product (ci : ∏ i, C) :=
  ∑ pp1p2 : (∑ p : C, ∏ i, p --> ci i),
    isProduct ci (pr1 pp1p2) (pr2 pp1p2).

Definition Products := ∏ (ci : ∏ i, C), Product ci.
Definition hasProducts := ∏ (ci : ∏ i, C), ∥ Product ci ∥.

Definition ProductObject {c : ∏ i, C} (P : Product c) : C := pr1 (pr1 P).

Coercion ProductObject : Product >-> ob.

Definition ProductPr {c : ∏ i, C} (P : Product c) : ∏ i, P --> c i :=
  pr2 (pr1 P).

Definition isProduct_Product {c : ∏ i, C} (P : Product c) :
   isProduct c P (ProductPr P).
 Proof.
  exact (pr2 P).
Defined.

Definition ProductArrow {c : ∏ i, C} (P : Product c) {a : C} (f : ∏ i, a --> c i)
  : a --> P.
Proof.
  apply (pr1 (pr1 (isProduct_Product P _ f))).
Defined.

Lemma ProductPrCommutes (c : ∏ i, C) (P : Product c) :
     ∏ (a : C) (f : ∏ i, a --> c i) i, ProductArrow P f · ProductPr P i = f i.
Proof.
  intros a f i.
  apply (pr2 (pr1 (isProduct_Product P _ f)) i).
Qed.

Lemma ProductPr_idtoiso {i1 i2 : I} (a : I -> C) (P : Product a)
      (e : i1 = i2) :
  ProductPr P i1 · idtoiso (maponpaths a e) = ProductPr P i2.
Proof.
  induction e.
  apply id_right.
Qed.

Lemma ProductArrowUnique (c : ∏ i, C) (P : Product c) (x : C)
    (f : ∏ i, x --> c i) (k : x --> P)
    (Hk : ∏ i, k · ProductPr P i = f i) : k = ProductArrow P f.
Proof.
  set (H' := pr2 (isProduct_Product P _ f) (k,,Hk)).
  apply (base_paths _ _ H').
Qed.

Definition make_Product (a : ∏ i, C) :
  ∏ (c : C) (f : ∏ i, C⟦c,a i⟧), isProduct _ _ f -> Product a.
Proof.
  intros c f X.
  exact (tpair _ (c,,f) X).
Defined.

Definition make_isProduct (hsC : has_homsets C) (a : I -> C) (p : C)
  (pa : ∏ i, C⟦p,a i⟧) : (∏ (c : C) (f : ∏ i, C⟦c,a i⟧),
                                  ∃! k : C⟦c,p⟧, ∏ i, k · pa i = f i) ->
                              isProduct a p pa.
Proof.
intros H c cc; apply H.
Defined.

Lemma ProductArrowEta (c : ∏ i, C) (P : Product c) (x : C)
    (f : x --> P) :
    f = ProductArrow P (λ i, f · ProductPr P i).
Proof.
  now apply ProductArrowUnique.
Qed.

Proposition ProductArrow_eq
            {d : I → C}
            (w : C)
            (x : Product d)
            (f g : w --> x)
            (p : ∏ (i : I), f · ProductPr x i = g · ProductPr x i)
  : f = g.
Proof.
  refine (ProductArrowEta _ _ _ _ @ _ @ !(ProductArrowEta _ _ _ _)).
  apply maponpaths.
  use funextsec.
  exact p.
Qed.

Definition ProductOfArrows {c : ∏ i, C} (Pc : Product c) {a : ∏ i, C}
    (Pa : Product a) (f : ∏ i, a i --> c i) :
      Pa --> Pc :=
    ProductArrow Pc (λ i, ProductPr Pa i · f i).

Lemma ProductOfArrowsPr {c : ∏ i, C} (Pc : Product c) {a : ∏ i, C}
    (Pa : Product a) (f : ∏ i, a i --> c i) :
    ∏ i, ProductOfArrows Pc Pa f · ProductPr Pc i = ProductPr Pa i · f i.
Proof.
  unfold ProductOfArrows; intro i.
  now rewrite (ProductPrCommutes _ _ _ _ i).
Qed.

Lemma postcompWithProductArrow {c : ∏ i, C} (Pc : Product c) {a : ∏ i, C}
    (Pa : Product a) (f : ∏ i, a i --> c i)
    {x : C} (k : ∏ i, x --> a i) :
        ProductArrow Pa k · ProductOfArrows Pc Pa f =
        ProductArrow Pc (λ i, k i · f i).
Proof.
apply ProductArrowUnique; intro i.
now rewrite <- assoc, ProductOfArrowsPr, assoc, ProductPrCommutes.
Qed.

Lemma precompWithProductArrow {c : ∏ i, C} (Pc : Product c)
  {a : C} (f : ∏ i, a --> c i) {x : C} (k : x --> a)  :
       k · ProductArrow Pc f = ProductArrow Pc (λ i, k · f i).
Proof.
apply ProductArrowUnique; intro i.
now rewrite <- assoc, ProductPrCommutes.
Qed.

End product_def.

Section Products.

Context (I : UU) (C : category) (CC : Products I C).

Definition ProductOfArrows_comp (a b c : ∏ (i : I), C)
  (f : ∏ i, a i --> b i) (g : ∏ i, b i --> c i)
  : ProductOfArrows _ _ _ _ f · ProductOfArrows _ _ _ (CC _) g
    = ProductOfArrows _ _ (CC _) (CC _) (λ i, f i · g i).
Proof.
apply ProductArrowUnique; intro i.
rewrite <- assoc, ProductOfArrowsPr.
now rewrite assoc, ProductOfArrowsPr, assoc.
Qed.

End Products.

Section Product_unique.

Context (I : UU) (C : category) (CC : Products I C) (a : ∏ (i : I), C).

Lemma Product_endo_is_identity (P : Product _ _ a)
  (k : P --> P)
  (H1 : ∏ i, k · ProductPr _ _ P i = ProductPr _ _ P i)
  : identity _ = k.
Proof.
  apply pathsinv0.
  eapply pathscomp0.
  apply ProductArrowEta.
  apply pathsinv0.
  apply ProductArrowUnique; intro i; apply pathsinv0.
  now rewrite id_left, H1.
Qed.

End Product_unique.

(** * The product functor: C^I -> C *)
Section product_functor.

Context (I : UU) {C : category} (PC : Products I C).

Definition product_functor_data :
  functor_data (power_category I C) C.
Proof.
use tpair.
- intros p.
  apply (ProductObject _ _ (PC p)).
- intros p q f.
  exact (ProductOfArrows _ _ _ _ f).
Defined.

Definition product_functor : functor (power_category I C) C.
Proof.
apply (tpair _ product_functor_data).
abstract (split;
  [ now intro x; simpl; apply pathsinv0, Product_endo_is_identity;
        intro i; rewrite ProductOfArrowsPr, id_right
  | now intros x y z f g; simpl; rewrite ProductOfArrows_comp]).
Defined.

End product_functor.

(* The product of a family of functors *)
Definition product_of_functors_alt
  (I : UU) {C D : category} (HD : Products I D)
  (F : ∏ (i : I), functor C D) : functor C D :=
   functor_composite (delta_functor I C)
     (functor_composite (family_functor _ F) (product_functor _ HD)).

(** * Products lift to functor categories *)
Section def_functor_pointwise_prod.

Context(I : UU) (C D : category) (HD : Products I D).

Section product_of_functors.

Context (F : I -> functor C D).

Definition product_of_functors_ob (c : C) : D :=
  HD (λ i, F i c).

Definition product_of_functors_mor (c c' : C) (f : c --> c') :
  product_of_functors_ob c --> product_of_functors_ob c' :=
    ProductOfArrows _ _ _ _ (λ i, # (F i) f).

Definition product_of_functors_data : functor_data C D.
Proof.
  exists product_of_functors_ob.
  exact product_of_functors_mor.
Defined.

Lemma is_functor_product_of_functors_data : is_functor product_of_functors_data.
Proof.
split; simpl; intros.
- unfold functor_idax; intros; simpl in *.
    apply pathsinv0.
    apply Product_endo_is_identity; intro i.
    unfold product_of_functors_mor.
    eapply pathscomp0; [apply (ProductOfArrowsPr _ _ (HD (λ i, (F i) a)))|].
    now simpl; rewrite functor_id, id_right.
- unfold functor_compax; simpl; unfold product_of_functors_mor.
  intros; simpl in *.
  apply pathsinv0.
  eapply pathscomp0.
  apply ProductOfArrows_comp.
  apply maponpaths, funextsec; intro i.
  now rewrite functor_comp.
Qed.

Definition product_of_functors : functor C D :=
  tpair _ _ is_functor_product_of_functors_data.

Lemma product_of_functors_alt_eq_product_of_functors :
  product_of_functors_alt _ HD F = product_of_functors.
Proof.
now apply (functor_eq _ _ D).
Qed.

Definition product_nat_trans_pr_data i (c : C) :
  D ⟦ product_of_functors c, (F i) c ⟧ :=
  ProductPr _ _ (HD (λ j, (F j) c)) i.

Lemma is_nat_trans_product_nat_trans_pr_data i :
  is_nat_trans _ _ (product_nat_trans_pr_data i).
Proof.
intros c c' f.
apply (ProductOfArrowsPr I _ (HD (λ i, F i c')) (HD (λ i, F i c))).
Qed.

Definition product_nat_trans_pr i : nat_trans product_of_functors (F i) :=
  tpair _ _ (is_nat_trans_product_nat_trans_pr_data i).

Section vertex.

(** The product morphism of a diagram with vertex [A] *)

Context (A : functor C D) (f : ∏ i, nat_trans A (F i)).

Definition product_nat_trans_data c :
  A c --> product_of_functors c:=
    ProductArrow _ _ _ (λ i, f i c).

Lemma is_nat_trans_product_nat_trans_data :
  is_nat_trans _ _ product_nat_trans_data.
Proof.
intros a b k; simpl.
eapply pathscomp0; [apply precompWithProductArrow|].
apply pathsinv0.
eapply pathscomp0; [apply postcompWithProductArrow|].
apply maponpaths, funextsec; intro i.
now rewrite (nat_trans_ax (f i)).
Qed.

Definition product_nat_trans : nat_trans A product_of_functors
  := tpair _ _ is_nat_trans_product_nat_trans_data.

End vertex.

Definition functor_precat_product_cone
  : Product I [C, D] F.
Proof.
use make_Product.
- apply product_of_functors.
- apply product_nat_trans_pr.
- use make_isProduct.
  + apply functor_category_has_homsets.
  + intros A f.
    use tpair.
    * apply (tpair _ (product_nat_trans A f)).
      abstract (intro i; apply (nat_trans_eq D); intro c;
                apply (ProductPrCommutes I D _ (HD (λ j, (F j) c)))).
    * abstract (
        intro t; apply subtypePath; simpl;
          [intro; apply impred; intro; apply (isaset_nat_trans D)|];
        apply (nat_trans_eq D); intro c;
        apply ProductArrowUnique; intro i;
        apply (nat_trans_eq_pointwise (pr2 t i))).
Defined.

End product_of_functors.

Definition Products_functor_precat : Products I [C, D].
Proof.
intros F; apply functor_precat_product_cone.
Defined.

End def_functor_pointwise_prod.

(** * Products from limits *)
Section products_from_limits.

Context (I : UU) (C : category).

Definition I_graph : graph := (I,,λ _ _,empty).

Definition products_diagram (F : I → C) : diagram I_graph C.
Proof.
exists F.
abstract (intros u v e; induction e).
Defined.

Definition productscone c (F : I → C) (H : ∏ i, c --> F i) :
  cone (products_diagram F) c.
Proof.
use tpair.
+ intro v; apply H.
+ abstract (intros u v e; induction e).
Defined.

Lemma Products_from_Lims : Lims_of_shape I_graph C -> Products I C.
Proof.
intros H F.
set (HF := H (products_diagram F)).
use make_Product.
+ apply (lim HF).
+ intros i; apply (limOut HF).
+ apply (make_isProduct _ _ C); intros c Fic.
  use unique_exists.
  - apply limArrow.
    use make_cone.
    * simpl; intro i; apply Fic.
    * abstract (simpl; intros u v e; induction e).
  - abstract (simpl; intro i; apply (limArrowCommutes HF)).
  - abstract (intros y; apply impred; intro i; apply C).
  - abstract (intros f Hf; apply limArrowUnique; simpl in *; intros i; apply Hf).
Defined.

End products_from_limits.

(**
 Products are closed under iso
 *)
Definition isProduct_z_iso
           {C : category}
           {J : UU}
           (D : J → C)
           {x y : C}
           (h : z_iso x y)
           (px : ∏ (j : J), x --> D j)
           (py : ∏ (j : J), y --> D j)
           (Hx : isProduct J _ D x px)
           (q : ∏ (j : J), py j = inv_from_z_iso h · px j)
  : isProduct J _ D y py.
Proof.
  use make_isProduct.
  {
    apply homset_property.
  }
  intros z f.
  use iscontraprop1.
  - abstract
      (use invproofirrelevance ;
       intros φ₁ φ₂ ;
       use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ;
       use (cancel_z_iso _ _ (z_iso_inv h)) ;
       use (ProductArrow_eq _ _ _ (make_Product _ _ _ _ _ Hx)) ; cbn ;
       intro j ;
       rewrite !assoc' ;
       rewrite <- q ;
       exact (pr2 φ₁ j @ !(pr2 φ₂ j))).
  - refine (ProductArrow _ _ (make_Product _ _ _ _ _ Hx) f · h ,, _).
    abstract
      (intro j ;
       rewrite !assoc' ;
       rewrite q ;
       rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)) ;
       rewrite z_iso_inv_after_z_iso ;
       rewrite id_left ;
       apply ProductPrCommutes).
Defined.

(**
 Products are unique
 *)
Definition eq_Product
           {C : category}
           {J : UU}
           {D : J → C}
           (prod₁ prod₂ : Product J C D)
           (q : ProductObject _ _ prod₁ = ProductObject _ _ prod₂)
           (e : ∏ (j : J),
                ProductPr _ _ prod₁ j
                =
                idtoiso q · ProductPr _ _ prod₂ j)
  : prod₁ = prod₂.
Proof.
  use subtypePath.
  {
    intro.
    repeat (use impred ; intro).
    use isapropiscontr.
  }
  use total2_paths_f.
  - exact q.
  - rewrite transportf_sec_constant.
    use funextsec.
    intro j.
    rewrite <- !idtoiso_precompose.
    rewrite !idtoiso_inv.
    use z_iso_inv_on_right.
    exact (e j).
Qed.

Definition z_iso_between_Product
           {C : category}
           {J : UU}
           {D : J → C}
           (prod₁ prod₂ : Product J C D)
  : z_iso prod₁ prod₂.
Proof.
  use make_z_iso.
  - exact (ProductArrow _ _  prod₂ (ProductPr _ _ prod₁)).
  - exact (ProductArrow _ _  prod₁ (ProductPr _ _ prod₂)).
  - split.
    + abstract
        (use ProductArrow_eq ;
         intro j ;
         rewrite !assoc' ;
         rewrite !ProductPrCommutes ;
         rewrite id_left ;
         apply idpath).
    + abstract
        (use ProductArrow_eq ;
         intro j ;
         rewrite !assoc' ;
         rewrite !ProductPrCommutes ;
         rewrite id_left ;
         apply idpath).
Defined.

Definition isaprop_Product
           {C : category}
           (HC : is_univalent C)
           (J : UU)
           (D : J → C)
  : isaprop (Product J C D).
Proof.
  use invproofirrelevance.
  intros p₁ p₂.
  use eq_Product.
  - refine (isotoid _ HC _).
    apply z_iso_between_Product.
  - rewrite idtoiso_isotoid ; cbn.
    intro j.
    rewrite ProductPrCommutes.
    apply idpath.
Qed.

Definition isProduct_eq_arrow
           {C : category}
           {J : UU}
           {D : J → C}
           {ys : C}
           {π π' : ∏ (j : J), ys --> D j}
           (q : ∏ (j : J), π j = π' j)
           (H : isProduct J C D ys π)
  : isProduct J C D ys π'.
Proof.
  intros w f.
  use iscontraprop1.
  - abstract
      (use invproofirrelevance ;
       intros φ₁ φ₂ ;
       use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ;
       use (ProductArrow_eq _ _ _ (make_Product _ _ _ _ _ H)) ;
       intro j ; cbn ;
       rewrite !q ;
       exact (pr2 φ₁ j @ !(pr2 φ₂ j))).
  - simple refine (_ ,, _).
    + exact (ProductArrow _ _ (make_Product _ _ _ _ _ H) f).
    + abstract
        (cbn ;
         intro j ;
         rewrite <- q ;
         apply (ProductPrCommutes _ _ _ (make_Product _ _ _ _ _ H))).
Defined.


Require Import Coq.PArith.BinPos.
Require Import Coq.Lists.List. Import ListNotations.

Module natmap. Section __.
  Context {V: Type}.

  (* TODO if there are trailing None's map extensionality doesn't hold, can we fix that? *)
  Definition natmap := list (option V).

  Definition head(m: natmap): option V :=
    match m with
    | nil => None
    | o :: _ => o
    end.

  Definition tail: natmap -> natmap := @List.tail (option V).

  Fixpoint skip(n: nat)(m: natmap): natmap :=
    match n with
    | O => m
    | S n' => tail (skip n' m)
    end.

  Definition get(m: natmap)(n: nat): option V := head (skip n m).

  (* m2 overrides m1. Simplifies best if m2 is concrete *)
  Fixpoint merge(m1 m2: natmap): natmap :=
    match m2 with
    | nil => m1
    | cons h t => cons (match h with
                        | Some v => Some v
                        | None => head m1
                        end)
                       (merge (tail m1) t)
    end.

  Fixpoint singleton(k: nat)(v: V): natmap :=
    match k with
    | O => Some v :: nil
    | S n => None :: singleton n v
    end.

  Definition put(m: natmap)(k: nat)(v: V): natmap := merge m (singleton k v).

  Definition putmany: natmap -> list (nat * V) -> natmap :=
    List.fold_right (fun '(k, v) res => put res k v).

End __. End natmap.
Arguments natmap.natmap: clear implicits.
Notation natmap := natmap.natmap.

Definition forcetype(o: option Type): Type :=
  match o with
  | Some T => T
  | None => unit
  end.

Inductive hnatmap: natmap Type -> Type :=
| HNil: hnatmap nil
| HCons{OV: option Type}{T: natmap Type}(v: forcetype OV)(t: hnatmap T): hnatmap (cons OV T).

Module hnatmap.

  Definition head{T: natmap Type}(m: hnatmap T): forcetype (natmap.head T) :=
    match m with
    | HNil => tt
    | HCons v _ => v
    end.

  Definition tail{T: natmap Type}(m: hnatmap T): hnatmap (tail T) :=
    match m with
    | HNil => HNil
    | HCons _ t => t
    end.

  Fixpoint skip(n: nat){T: natmap Type}(m: hnatmap T): hnatmap (natmap.skip n T) :=
    match n with
    | 0 => m
    | S n' => tail (skip n' m)
    end.

  Definition get{T: natmap Type}(m: hnatmap T)(n: nat): forcetype (natmap.get T n) := head (skip n m).

  (* m2 overrides m1 *)
  Fixpoint merge{T1 T2: natmap Type}(m1: hnatmap T1)(m2: hnatmap T2): hnatmap (natmap.merge T1 T2).
    refine (match m2 with
            | HNil => m1
            | @HCons OV T2Tail v t => @HCons (match OV with
                                              | Some V => Some V
                                              | None => natmap.head T1
                                              end)
                                             (natmap.merge (natmap.tail T1) T2Tail)
                                             _
                                             (merge _ _ (tail m1) t)
            end).
    destruct OV as [V|].
    - exact v.
    - exact (head m1).
  Defined.

  Fixpoint singleton{V: Type}(k: nat)(v: V){struct k}: hnatmap (natmap.singleton k V) :=
    match k with
    | 0 => @HCons (Some V) [] v HNil
    | S n => @HCons None (natmap.singleton n V) tt (singleton n v)
    end.

  Definition put{T: natmap Type}(m: hnatmap T)(k: nat){V: Type}(v: V): hnatmap (natmap.put T k V) :=
    merge m (singleton k v).

End hnatmap.

Module HnatmapNotations.
  Declare Scope hnatmap_scope.
  Notation "m [ k := v ]" := (hnatmap.put m k v)
    (at level 8, left associativity, format "m [ k  :=  v ]") : hnatmap_scope.
  Notation "m [ k ]" := (hnatmap.get m k)
    (at level 8, left associativity, format "m [ k ]") : hnatmap_scope.
  (* this notation overrides the notation for applying a function m to the singleton list containing k,
     but that's so rare that it's fine *)
End HnatmapNotations.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Inductive TwoDObj : Type := TwoDX | TwoDY.

Inductive TwoDHom : TwoDObj -> TwoDObj -> Type :=
  | TwoDIdX : TwoDHom TwoDX TwoDX
  | TwoDIdY : TwoDHom TwoDY TwoDY.

Definition TwoDHom_inv_t : forall x y, TwoDHom x y -> Prop.
Proof.
  intros [] [] f.
  exact (f = TwoDIdX).
  exact False.          (* Unused, any Prop is ok here *)
  exact False.          (* Unused, any Prop is ok here *)
  exact (f = TwoDIdY).
Defined.

Corollary TwoDHom_inv x y f : TwoDHom_inv_t x y f.
Proof. destruct f; reflexivity. Qed.

Lemma TwoDHom_X_Y_absurd : TwoDHom TwoDX TwoDY -> False.
Proof. inversion 1. Qed.

Hint Extern 4 => contradiction TwoDHom_X_Y_absurd : two_laws.

Lemma TwoDHom_Y_X_absurd : TwoDHom TwoDY TwoDX -> False.
Proof. inversion 1. Qed.

Hint Extern 4 => contradiction TwoDHom_Y_X_absurd : two_laws.

(* The discrete category 2 has two objects and their identity morphisms. *)

Program Definition Two_Discrete : Category := {|
  obj     := TwoDObj;
  hom     := TwoDHom;
  homset  := Morphism_equality;
  id      := fun x => match x with
    | TwoDX => TwoDIdX
    | TwoDY => TwoDIdY
    end;
  compose := fun x y z (f : TwoDHom y z) (g : TwoDHom x y) =>
    match x, y, z with
    | TwoDX, TwoDX, TwoDX => TwoDIdX
    | TwoDY, TwoDY, TwoDY => TwoDIdY
    | _,    _,    _    => _
    end
|}.
Next Obligation. destruct x, y, z; intuition. Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y; auto with two_laws;
  symmetry; exact (TwoDHom_inv _ _ f).
Qed.
Next Obligation.
  destruct x, y; auto with two_laws;
  symmetry; exact (TwoDHom_inv _ _ f).
Qed.
Next Obligation.
  destruct x, y, z, w; auto with two_laws; intuition.
Qed.
Next Obligation.
  destruct x, y, z, w; auto with two_laws; intuition.
Qed.


Require Import EqStuff.

(* Semantic type-level contexts, as left nested sigmas *)

(* Strongly typed de Bruijn indexes:
 * Allow you to project from an environment, n steps from the near end.
 *)
Inductive AtTCtx : forall D,nat->(D->Type)->Type :=
	topTCtx D (T:D->Type) : AtTCtx (sigT T) O (fun d=>T (projT1 d)) |
	popTCtx D n T T' : AtTCtx D n T->AtTCtx (sigT T') (S n) (fun d=>T (projT1 d)).
Implicit Arguments topTCtx [D].
Implicit Arguments popTCtx [D n T].

(* Project from an environment *)
Fixpoint tctxProj D n T (f:AtTCtx D n T) : forall d,T d := match f with
	topTCtx _ _ => @projT2 _ _ |
	popTCtx _ _ _ _ f => fun d=>tctxProj _ _ _ f (projT1 d)
end.
Implicit Arguments tctxProj [D n T].

(* Semantic contexts (in a type-level context) *)

Inductive AtCtx D : forall G:D->Type,nat->(forall d,G d->Type)->Type :=
	topCtx G (T:forall d,G d->Type) : AtCtx D (fun d=>sigT (T d)) O (fun d g=>T d (projT1 g)) |
	popCtx G n T T' : AtCtx D G n T->AtCtx D (fun d=>sigT (T' d)) (S n) (fun d g=>T d (projT1 g)).
Implicit Arguments AtCtx [D].
Implicit Arguments topCtx [D G].
Implicit Arguments popCtx [D G n T].

Fixpoint ctxProj D (G:D->Type) n T (a:AtCtx G n T) d : forall g,T d g := match a with
	topCtx _ _ => @projT2 _ _ |
	popCtx _ _ _ _ a => fun g=>ctxProj _ _ _ _ a _ (projT1 g)
end.
Implicit Arguments ctxProj [D G n T].

(* Weaken for a new type-level context entry *)
Fixpoint ctxBumpD D G n T (F:D->Type) (a:AtCtx G n T) :
AtCtx (fun d:sigT F=>G (projT1 d)) n (fun d=>T (projT1 d)) := match a with
	topCtx _ _ => topCtx _ |
	popCtx _ _ _ _ a => popCtx _ (ctxBumpD _ _ _ _ _ a)
end.
Implicit Arguments ctxBumpD [D G n T].

Lemma ctxProj_BumpD D (G:D->Type) n T (a:AtCtx G n T) F : ctxProj (ctxBumpD F a) = (fun d=>ctxProj a (projT1 d)).
	induction a.

	reflexivity.

	simpl.
	rewrite IHa.
	reflexivity.
Qed.

(* Context zipping stuff, which helps with structural operations. *)

(* Relational zipper for judgements
 * G/C are the original context/conclusion.
 * GL is the left part remaining zipped.
 * The nat is how many context entries have been unzipped.
 * The last index is a right nested pi--a "right context"--where stuff has been unzipped.
 * Ignoring the nat index, this can be thought of as a preorder on judgements.
 *)
Inductive ZipCtx D G C : nat->forall GL:D->Type,(forall d,GL d->Type)->Type :=
	zipCtxO : ZipCtx D G C O G C |
	zipCtxS n GL T GR :
		ZipCtx D G C n (fun d=>sigT (T d)) GR->
		ZipCtx D G C (S n) GL (fun d g=>forall x,GR d (existT _ g x)).
Implicit Arguments zipCtxS [D G C n GL T GR].

Definition zipCtxOInv D G C GL GR (z:ZipCtx D G C O GL GR) (P:forall n GL GR,ZipCtx D G C n GL GR->Type)
	(zcO:P O G C (zipCtxO D G C))
: P _ _ _ z := match z in ZipCtx _ _ _ zro _ _ return (O = zro)->P _ _ _ z with
	zipCtxO => fun _=>zcO |
	zipCtxS _ _ _ _ _ => fun e=>match O_S _ e with end
end (eq_refl _).
Implicit Arguments zipCtxOInv [D G C GL GR].

Definition zipCtxSInv D G C n GL GR (z:ZipCtx D G C (S n) GL GR) : forall (P:forall n GR,ZipCtx D G C n GL GR->Type)
	(zcS:forall T GR (z:ZipCtx D G C n (fun d=>sigT (T d)) GR),
		P _ (fun d g=>forall x,GR d (existT _ g x)) (zipCtxS z))
,P _ _ z.
	simpl.
	refine (match z as z in ZipCtx _ _ _ Sn _ _ return (Sn = S n)->forall P,_->P _ _ z with
		zipCtxO => fun e=>match O_S _ e with end |
		zipCtxS _ _ _ _ z0 => fun e _ zcS=>_
	end (eq_refl _)).
	exact (match eq_sym (Sinj e) return _ with eq_refl => zcS _ _ end z0).
Defined.
Implicit Arguments zipCtxSInv [D G C n GL GR].

Definition zipCtxInd D G C (P:forall n GL GR,ZipCtx D G C n GL GR->Type)
	(zcO:P _ _ _ (zipCtxO D G C))
	(zcS:forall n,(forall GL GR (z:ZipCtx D G C n GL GR),P n GL GR z)->
		forall GL (T:forall d,GL d->Type) GR (z:ZipCtx D G C n (fun d=>sigT (T d)) GR),P _ _ _ (zipCtxS z))
: forall n GL GR (z:ZipCtx D G C n GL GR),P _ _ _ z.
	refine (fix zipCtxInd n := match n with
		O => fun _ _ z=>_ |
		S _ => fun GL GR z=>_
	end).

	exact (zipCtxOInv z _ zcO).

	exact (zipCtxSInv z (fun n GR z=>P n GL GR z) (zcS _ (zipCtxInd _) _)).
Defined.
Implicit Arguments zipCtxInd [D G C n GL GR].

Definition zipCtxSL D G T C n GL GR (z:ZipCtx D G (fun d g=>forall x,C d (existT _ g x)) n GL GR) :
ZipCtx D (fun d=>sigT (T d)) C (S n) GL GR.
	induction z as [| ? ? ? T'] using zipCtxInd.

	apply zipCtxS.
	apply zipCtxO.

	apply zipCtxS.
	apply X with (1 := z).
Defined.
Implicit Arguments zipCtxSL [D G T C n GL GR].

Lemma zipCtxSLInv D G C (P:forall G,(forall d,G d->Type)->Type) n : forall GL GR (z:ZipCtx D G C (S n) GL GR)
	(zcSL:forall G T C (z:ZipCtx D G (fun d g=>forall x,C d (existT _ g x)) n GL GR),
		P (fun d=>sigT (T d)) C),
P G C.
	induction n;intros ? ? ?;
	apply (zipCtxSInv z (fun _ _ _=>_));clear GR z;intros.

	assert (P (fun d=>sigT (T d)) GR->P G C).
		apply (zipCtxOInv z (fun _ GL GR _=>P GL GR->_)).
		exact (fun p=>p).
	apply X.
	clear X.
	apply zcSL.
	apply zipCtxO.

	apply IHn with (1 := z).
	clear G C IHn z.
	intros ? T' ? ?.
	apply zcSL.
	exact (zipCtxS z).
Qed.

Lemma zipCtxTrans D L1 R1 n L2 R2 L3 R3 : ZipCtx D L1 R1 n L2 R2->forall m,ZipCtx D L2 R2 m L3 R3->
ZipCtx D L1 R1 (n + m) L3 R3.
	intro.
	induction X;intros.

	exact X.

	simpl.
	rewrite plus_n_Sm.
	apply IHX.
	apply zipCtxSL with (1 := X0).
Qed.

(* Left/right context relations stating that a left/right context can be/has been unzipped n times *)

Inductive IsLCtx D : nat->(D->Type)->Type :=
	lCtxO G : IsLCtx D O G |
	lCtxS n G (T:forall d,G d->Type) : IsLCtx D n G->IsLCtx D (S n) (fun d=>sigT (T d)).

Inductive IsRCtx D (GL:D->Type) : nat->(forall d,GL d->Type)->Type :=
	rCtxO C : IsRCtx D GL O C |
	rCtxS n T GR : IsRCtx D (fun d=>sigT (T d)) n GR->IsRCtx D GL (S n) (fun d g=>forall x,GR d (existT _ g x)).

Lemma lCtxSInv D n G P : IsLCtx D (S n) G->(forall G (T:forall d,G d->Type),IsLCtx D n G->P (fun d=>sigT (T d)))->P G.
	intros.
	inversion_clear X.
	apply X0 with (1 := X1).
Qed.

Lemma rCtxSInv D GL n GR P : IsRCtx D GL (S n) GR->
	(forall T GR,IsRCtx D (fun d=>sigT (T d)) n GR->
	P (fun d g=>forall x,GR d (existT _ g x)))->
P GR.
	intros.
	inversion_clear X.
	apply X0 with (1 := X1).
Qed.

Lemma lCtxZipper D n GL GR : forall G C,ZipCtx D G C n GL GR->IsLCtx D n G.
	induction n;intros.

	apply lCtxO.

	apply zipCtxSLInv with (P := fun _ _=>_) (1 := X).
	clear G C X.
	intros.
	apply lCtxS.
	apply IHn with (1 := z).
Qed.

Lemma rCtxZipper D G C n GL GR : ZipCtx D G C n GL GR->IsRCtx D GL n GR.
	intro.
	induction X.

	apply rCtxO.

	apply rCtxS with (1 := IHX).
Qed.

Lemma unzipLCtx D n C : forall G,IsLCtx D n G->forall F,(forall GL GR,ZipCtx D G F n GL GR->C)->C.
	induction n.

	intros.
	apply (X0 G F).
	apply zipCtxO.

	intros ? ?.
	apply lCtxSInv with (1 := X).
	clear G X.
	intros.
	apply (IHn _ X (fun d g=>forall x,F d (existT _ g x))).
	intros.
	apply (X0 GL GR).
	exact (zipCtxSL X1).
Qed.

Lemma zipRCtx D n GL GR C : IsRCtx D GL n GR->(forall G F,ZipCtx D G F n GL GR->C)->C.
	intro.
	induction X as [? F |];intro.

	apply (X GL F).
	apply zipCtxO.

	apply IHX.
	intros.
	apply (X0 G F).
	exact (zipCtxS X1).
Qed.

(* Map with precompose *)

Inductive ZipCtxComp D G C n GL GR : Type := mkZipCtxComp G' (f':forall d,G' d->G d)
	(z':ZipCtx D G' (fun d g=>C d (f' d g)) n GL GR).
Implicit Arguments mkZipCtxComp [D G C n GL GR].

Definition zc_G' D G C n GL GR (zc:ZipCtxComp D G C n GL GR) := match zc with mkZipCtxComp G' _ _ => G' end.
Implicit Arguments zc_G' [D G C n GL GR].

Definition zc_f' D G C n GL GR (zc:ZipCtxComp D G C n GL GR) : forall d,zc_G' zc d->G d := match zc with mkZipCtxComp _ f' _ => f' end.
Implicit Arguments zc_f' [D G C n GL GR].

Definition zipCtxComp D G C n GL GR (z:ZipCtx D G C n GL GR) : forall GL' f,
ZipCtxComp D G C n GL' (fun d g=>GR d (f d g)).
	induction z using zipCtxInd;intros.

	apply (mkZipCtxComp GL' f).
	apply zipCtxO.

	exact (match X _ _ z _ (fun d (g:sigT (fun g=>T d (f d g)))=>existT _ (f d (projT1 g)) (projT2 g)) with
		mkZipCtxComp G' f' z' => mkZipCtxComp G' f' (zipCtxS z') end).
Defined.
Implicit Arguments zipCtxComp [D G C n GL GR].

Definition zipCtxSComp D G C n GL (T:forall d,GL d->Type) GR GL' f
	(zc:ZipCtxComp D G C n
		(fun d=>sigT (fun g=>T d (f d g)))
		(fun d g=>GR d (existT _ (f d (projT1 g)) (projT2 g))))
: ZipCtxComp D G C (S n) GL' (fun d g=>forall x:T d (f d g),GR d (existT _ (f d g) x)) := match zc with
	mkZipCtxComp G' f' z' => mkZipCtxComp G' f' (zipCtxS z')
end.
Implicit Arguments zipCtxSComp [D G C n GL T GR GL' f].

Definition zipCtxSComp' D G C n GL (T:forall d,GL d->Type) GR (z:ZipCtx D G C n (fun d=>sigT (T d)) GR) GL' f :
ZipCtxComp D G C (S n) GL' (fun d g=>forall x:T d (f d g),GR d (existT _ (f d g) x)).
	pose (T' d g := T d (f d g)).
	pose (f' d (g:sigT (T' d)) := existT _ (f d (projT1 g)) (projT2 g)).
	exact (zipCtxSComp (zipCtxComp z (fun d=>sigT (T' d)) f')).
Defined.
Implicit Arguments zipCtxSComp' [D G C n GL T GR].

Lemma zipCtxCompSEq D G C n GL (T:forall d,GL d->Type) GR (z:ZipCtx D G C n (fun d=>sigT (T d)) GR) GL' f :
zipCtxComp (zipCtxS z) GL' f = zipCtxSComp' z GL' f.
	reflexivity.
Qed.

Definition zipCtxSLComp D G T C n GL GR GL' (f:forall d,GL' d->GL d)
	(zc:ZipCtxComp D G (fun d g=>forall x:T d g,C d (existT _ g x)) n GL' (fun d g=>GR d (f d g)))
: ZipCtxComp D (fun d=>sigT (T d)) C (S n) GL' (fun d g=>GR d (f d g)).
	refine (match zc with mkZipCtxComp G' f' z' => _ end).
	pose (T' d g := T d (f' d g)).
	pose (f'' d (g:sigT (T' d)) := existT _ (f' d (projT1 g)) (projT2 g)).
	pose (C' d g := C d (f'' d g)).
	change (ZipCtx D G' (fun d g=>forall x:T' d g,C' d (existT _ g x)) n GL' (fun d g=>GR d (f d g))) in z'.
	exact (mkZipCtxComp (fun d=>sigT (T' d)) f'' (zipCtxSL z')).
Defined.
Implicit Arguments zipCtxSLComp [D G T C n GL GL' f].

Definition zipCtxSLComp' D G T C n GL GR (z:ZipCtx D G (fun d g=>forall x:T d g,C d (existT _ g x)) n GL GR)
GL' (f:forall d,GL' d->GL d) := zipCtxSLComp _ (zipCtxComp z GL' f).
Implicit Arguments zipCtxSLComp' [D G T C n GL GR].

Lemma zipCtxSLCompRewr D G T C n GL GR GL' (f:forall d,GL' d->GL d)
	(zc:ZipCtxComp D G (fun d g=>forall x:T d g,C d (existT _ g x)) n GL' (fun d g=>GR d (f d g)))
	(P:forall G',(forall d,G' d->sigT (T d))->Type)
: P (zc_G' (zipCtxSLComp GR zc)) (zc_f' (zipCtxSLComp GR zc))->
P (fun d=>sigT (fun g=>T d (zc_f' zc d g))) (fun d g=>existT _ (zc_f' zc d (projT1 g)) (projT2 g)).
	destruct zc.
	exact (fun p=>p).
Qed.
Implicit Arguments zipCtxSLCompRewr [D G T C n GL GR GL' f].

Lemma zipCtxSSLCompEq D G T C n GL T' GR GL' (f:forall d,GL' d->GL d)
	(zc:ZipCtxComp D G (fun d g=>forall x:T d g,C d (existT _ g x)) n
		(fun d=>sigT (fun g=>T' d (f d g)))
		(fun d g=>GR d (existT _ (f d (projT1 g)) (projT2 g))))
: zipCtxSComp (zipCtxSLComp GR zc) = zipCtxSLComp (fun d g=>forall x,GR d (existT _ g x)) (zipCtxSComp zc).
	simpl in zc.
	destruct zc.
	reflexivity.
Qed.

Lemma zipCtxCompSLEq D G T C n GL GR (z:ZipCtx D G (fun d g=>forall x:T d g,C d (existT _ g x)) n GL GR) :
forall GL' f,zipCtxComp (zipCtxSL z) GL' f = zipCtxSLComp' z GL' f.
	induction z as [| ? ? ? T'] using zipCtxInd;intros.

	reflexivity.

	simpl zipCtxSL.
	rewrite zipCtxCompSEq.
	unfold zipCtxSComp'.
	rewrite H.
	unfold zipCtxSLComp'.
	rewrite zipCtxCompSEq.
	rewrite zipCtxSSLCompEq.
	reflexivity.
Qed.

(* Context extension *)

Inductive ExtCtx D GL : nat->(D->Type)->Type :=
	extCtxO : ExtCtx D GL O GL |
	extCtxS n G : ExtCtx D GL n G->forall T:forall d,G d->Type,ExtCtx D GL (S n) (fun d=>sigT (T d)).
Implicit Arguments extCtxS [D GL n G].

Definition extCtxOInv D GL G (xg:ExtCtx D GL O G) (P:forall n G,ExtCtx D GL n G->Type)
	(xgO:P O GL (extCtxO D GL))
: P _ _ xg := match xg in ExtCtx _ _ zro _ return (O = zro)->P _ _ xg with
	extCtxO => fun _=>xgO |
	extCtxS _ _ _ _ => fun e=>match O_S _ e with end
end (eq_refl _).
Implicit Arguments extCtxOInv [D GL G].

Definition extCtxSInv D GL n G (xg:ExtCtx D GL (S n) G) : forall (P:forall n G,ExtCtx D GL n G->Type)
	(xgS:forall G (xg:ExtCtx D GL n G) T,P _ _ (extCtxS xg T))
,P _ _ xg.
	refine (match xg as xg in ExtCtx _ _ Sn _ return (Sn = S n)->forall P,_->P _ _ xg with
		extCtxO => fun e=>match O_S _ e with end |
		extCtxS _ _ xg0 _ => fun e _ xgS=>_
	end (eq_refl _)).
	exact (match eq_sym (Sinj e) return _ with eq_refl => xgS _ end xg0 _).
Defined.
Implicit Arguments extCtxSInv [D GL n G].

Definition extCtxInd D GL (P:forall n G,ExtCtx D GL n G->Type)
	(xgO:P _ _ (extCtxO D GL))
	(xgS:forall n,(forall G (xg:ExtCtx D GL n G),P _ _ xg)->
		forall G (xg:ExtCtx D GL n G) T,P _ _ (extCtxS xg T))
: forall n G (xg:ExtCtx D GL n G),P _ _ xg.
	refine (fix extCtxInd n := match n with
		O => fun _ xg=>_ |
		S _ => fun G xg=>_
	end).

	exact (extCtxOInv xg _ xgO).

	exact (extCtxSInv xg _ (xgS _ (extCtxInd _))).
Defined.
Implicit Arguments extCtxInd [D GL n G].

Inductive ExtCtxComp D GL n G : Type := mkExtCtxComp G' (f':forall d,G' d->G d) (xg':ExtCtx D GL n G').
Implicit Arguments mkExtCtxComp [D GL n G].

Definition xc_G' D GL n G (xc:ExtCtxComp D GL n G) := match xc with mkExtCtxComp G' _ _ => G' end.
Implicit Arguments xc_G' [D GL n G].

Definition xc_f' D GL n G (xc:ExtCtxComp D GL n G) : forall d,xc_G' xc d->G d := match xc with mkExtCtxComp _ f' _ => f' end.
Implicit Arguments xc_f' [D GL n G].

Definition extCtxComp D GL n G (xg:ExtCtx D GL n G) GL' (f:forall d,GL' d->GL d) : ExtCtxComp D GL' n G.
	revert n G xg.
	refine (fix extCtxComp n G xg := match xg in ExtCtx _ _ n G return ExtCtxComp D GL' n G with
		extCtxO => _ |
		extCtxS _ _ xg0 _ => _
	end).

	apply (mkExtCtxComp GL' f).
	apply extCtxO.

	exact (match extCtxComp _ _ xg0 with mkExtCtxComp G' f' xg' => mkExtCtxComp _
		(fun d (g:sigT (fun g=>T d (f' d g)))=>existT _ (f' d (projT1 g)) (projT2 g)) (extCtxS xg' _)
	end).
Defined.
Implicit Arguments extCtxComp [D GL n G].

Definition extCtxSComp D GL n G (xc:ExtCtxComp D GL n G) T :
ExtCtxComp D GL (S n) (fun d=>sigT (T d)) := match xc with mkExtCtxComp _ f xg =>
	mkExtCtxComp _ (fun d (g:sigT (fun g=>T d (f d g)))=>existT _ (f d (projT1 g)) (projT2 g)) (extCtxS xg _)
end.
Implicit Arguments extCtxSComp [D GL n G].

Definition extCtxSComp' D GL n G (xg:ExtCtx D GL n G) GL' f T : ExtCtxComp D GL' (S n) (fun d=>sigT (T d))
:= extCtxSComp (extCtxComp xg GL' f) T.
Implicit Arguments extCtxSComp' [D GL n G].

Lemma extCtxCompSEq D GL n G (xg:ExtCtx D GL n G) T GL' f : extCtxComp (extCtxS xg T) GL' f = extCtxSComp' xg GL' f T.
	reflexivity.
Qed.
Implicit Arguments extCtxCompSEq [D GL n G T GL' f].

Lemma extCtxSCompRewr D GL n G (xc:ExtCtxComp D GL n G) T (P:forall G',(forall d,G' d->sigT (T d))->Type)
: P (xc_G' (extCtxSComp xc T)) (xc_f' (extCtxSComp xc T))->
P _ (fun d (g:sigT (fun g=>T d (xc_f' xc d g)))=>existT _ (xc_f' xc d (projT1 g)) (projT2 g)).
	destruct xc.
	exact (fun p=>p).
Qed.
Implicit Arguments extCtxSCompRewr [D GL n G].


From Coq Require Import List Streams Compare_dec Lia.
Import ListNotations.

From CasperCBC Require Import Lib.ListExtras Preamble.

(** * Stream utility definitions and lemmas *)

Lemma recons
  {A : Type}
  (s : Stream A)
  : Cons (hd s) (tl s) = s.
Proof.
  case s.  reflexivity.
Qed.

Lemma map_Cons
  {A B : Type}
  (f : A -> B)
  (x : A)
  (s : Stream A)
  : map f (Cons x s) = Cons (f x) (map f s).
Proof.
  intros.
  rewrite <- (recons (map f (Cons x s))). reflexivity.
Qed.

Definition stream_app
  {A : Type}
  (prefix : list A)
  (suffix : Stream A)
  : Stream A
  :=
  fold_right (@Cons A) suffix prefix.

Definition stream_app_cons {A}
  (a : A)
  (l : Stream A)
  : stream_app [a] l = Cons a l
  := eq_refl.

Lemma stream_app_assoc
  {A : Type}
  (l m : list A)
  (n : Stream A)
  : stream_app l (stream_app m n) = stream_app (l ++ m) n.
Proof.
  induction l; try reflexivity.
  simpl. apply f_equal. assumption.
Qed.

Lemma stream_app_f_equal
  {A : Type}
  (l1 l2 : list A)
  (s1 s2 : Stream A)
  (Hl : l1 = l2)
  (Hs : EqSt s1 s2)
  : EqSt (stream_app l1 s1) (stream_app l2 s2).
Proof.
  subst. induction l2; try assumption.
  simpl. constructor; try reflexivity. assumption.
Qed.

Lemma stream_app_inj_l
  {A : Type}
  (l1 l2 : list A)
  (s : Stream A)
  (Heq : stream_app l1 s = stream_app l2 s)
  (Heq_len : length l1 = length l2)
  : l1 = l2.
Proof.
  generalize dependent l2.
  induction l1; intros; destruct l2; try reflexivity; try inversion Heq_len.
  inversion Heq.
  f_equal.
  specialize (IHl1 l2 H2 H0).
  assumption.
Qed.

Fixpoint stream_prefix
  {A : Type}
  (l : Stream A)
  (n : nat)
  : list A
  := match n,l with
  | 0,_ => []
  | S n, Cons a l => a :: stream_prefix l n
  end.

Lemma stream_prefix_nth
  {A : Type}
  (s : Stream A)
  (n : nat)
  (i : nat)
  (Hi : i < n)
  : nth_error (stream_prefix s n) i = Some (Str_nth i s).
Proof.
  generalize dependent n. generalize dependent s.
  induction i; intros [a s] [|n] Hi; try reflexivity.
  - inversion Hi.
  - inversion Hi.
  - simpl.
    assert (Hi': i < n) by lia.
    specialize (IHi s n Hi').
    rewrite IHi.
    reflexivity.
Qed.

Lemma stream_prefix_EqSt
  {A : Type}
  (s1 s2 : Stream A)
  (Heq : EqSt s1 s2)
  : forall n : nat, stream_prefix s1 n = stream_prefix s2 n .
Proof.
  intro n.
  generalize dependent s2. generalize dependent s1.
  induction n; try reflexivity; intros (a1, s1) (a2,s2) Heq.
  inversion Heq. simpl in H; subst.
  simpl.
  f_equal.
  apply IHn.
  assumption.
Qed.

Lemma EqSt_stream_prefix
  {A : Type}
  (s1 s2 : Stream A)
  (Hpref : forall n : nat, stream_prefix s1 n = stream_prefix s2 n)
  : EqSt s1 s2.
Proof.
  apply ntheq_eqst.
  intro n.
  assert (Hlt : n < S n) by constructor.
  assert (HSome : Some (Str_nth n s1) = Some (Str_nth n s2)).
  {
    rewrite <- (stream_prefix_nth  s1 (S n) n Hlt).
    rewrite <- (stream_prefix_nth  s2 (S n) n Hlt).
    specialize (Hpref (S n)).
    rewrite Hpref.
    reflexivity.
  }
  inversion HSome. reflexivity.
Qed.

Lemma stream_prefix_in
  {A : Type}
  (l : Stream A)
  (n : nat)
  (a : A)
  (Hin : In a (stream_prefix l n))
  : exists k : nat, k < n /\ Str_nth k l = a.
Proof.
  generalize dependent a. generalize dependent l.
  induction n.
  - simpl. intros. contradiction.
  - intros (b, l) a; simpl; intro Hin.
    destruct Hin as [Heq | Hin]; subst.
    + exists 0. split; try reflexivity.
      lia.
    + specialize (IHn l a Hin).
      destruct IHn as [k [Hlt Heq]].
      exists (S k).
      split; try assumption.
      lia.
Qed.

Lemma stream_prefix_app_l
  {A : Type}
  (l : list A)
  (s : Stream A)
  (n : nat)
  (Hle : n <= length l)
  : stream_prefix (stream_app l s) n = list_prefix l n.
Proof.
  generalize dependent n.
  induction l; intros [|n] Hle; try reflexivity.
  - inversion Hle.
  - simpl in Hle.
    simpl. f_equal.
    apply IHl.
    lia.
Qed.

Lemma stream_prefix_app_r
  {A : Type}
  (l : list A)
  (s : Stream A)
  (n : nat)
  (Hge : n >= length l)
  : stream_prefix (stream_app l s) n = l ++ stream_prefix s (n - length l).
Proof.
  generalize dependent l.
  generalize dependent s.
  induction n.
  - intros. simpl.
    destruct l as [|a l]; try reflexivity.
    simpl in Hge. inversion Hge.
  - intros s [| a l] Hge; try reflexivity.
    simpl. f_equal.
    apply IHn.
    simpl in Hge.
    lia.
Qed.

Lemma stream_prefix_map
  {A B : Type}
  (f : A -> B)
  (l : Stream A)
  (n : nat)
  : List.map f (stream_prefix l n) = stream_prefix (Streams.map f l) n.
Proof.
  generalize dependent l. induction n; intros [a l]; try reflexivity.
  simpl.
  f_equal.
  apply IHn.
Qed.

Lemma stream_prefix_length
  {A : Type}
  (l : Stream A)
  (n : nat)
  : length (stream_prefix l n) = n.
Proof.
  generalize dependent l. induction n; intros [a l]; try reflexivity.
  simpl in *. f_equal.
  apply IHn.
Qed.

Definition stream_suffix
  {A : Type}
  (l : Stream A)
  (n : nat)
  : Stream A
  := Str_nth_tl n l.

Lemma stream_suffix_S
  {A : Type}
  (l : Stream A)
  (n : nat)
  : stream_suffix l n = Cons (Str_nth n l) (stream_suffix l (S n)).
Proof.
  generalize dependent l. induction n; intros.
  - destruct l; reflexivity.
  - specialize (IHn (tl l)); simpl in IHn.
    simpl. assumption.
Qed.

Lemma stream_suffix_nth
  {A : Type}
  (s : Stream A)
  (n : nat)
  (i : nat)
  : Str_nth i (stream_suffix s n) = Str_nth (i + n) s.
Proof.
  apply Str_nth_plus.
Qed.

Lemma stream_prefix_suffix
  {A : Type}
  (l : Stream A)
  (n : nat)
  : stream_app (stream_prefix l n) (stream_suffix l n) = l.
Proof.
  generalize dependent l. unfold stream_suffix.
  induction n; try reflexivity; intros [a l]; simpl.
  f_equal. apply IHn.
Qed.

Lemma stream_prefix_prefix
  {A : Type}
  (l : Stream A)
  (n1 n2 : nat)
  (Hn: n1 <= n2)
  : list_prefix (stream_prefix l n2) n1 = stream_prefix l n1.
Proof.
  generalize dependent n2.
  generalize dependent l.
  induction n1; intros [a l]; intros [|n2] Hn; try reflexivity.
  - inversion Hn.
  - simpl. f_equal. apply IHn1. lia.
Qed.

Definition stream_segment
  {A : Type}
  (l : Stream A)
  (n1 n2 : nat)
  : list A
  := list_suffix (stream_prefix l n2) n1.

Lemma stream_segment_nth
  {A : Type}
  (l : Stream A)
  (n1 n2 : nat)
  (Hn : n1 <= n2)
  (i : nat)
  (Hi1 : n1 <= i)
  (Hi2 : i < n2)
  : nth_error (stream_segment l n1 n2) (i - n1) = Some (Str_nth i l).
Proof.
  unfold stream_segment.
  rewrite list_suffix_nth; try assumption.
  apply stream_prefix_nth.
  assumption.
Qed.

Definition stream_segment_alt
  {A : Type}
  (l : Stream A)
  (n1 n2 : nat)
  : list A
  := stream_prefix (stream_suffix l n1) (n2 - n1).

Lemma stream_segment_alt_iff
  {A : Type}
  (l : Stream A)
  (n1 n2 : nat)
  : stream_segment l n1 n2 = stream_segment_alt l n1 n2.
Proof.
  apply nth_error_eq.
  intro k.
  unfold stream_segment_alt. unfold stream_segment.
  destruct (le_lt_dec (n2 - n1) k).
  - specialize (nth_error_None (list_suffix (stream_prefix l n2) n1) k); intros [_ H].
    specialize (nth_error_None (stream_prefix (stream_suffix l n1) (n2 - n1)) k); intros [_ H_alt].
    rewrite H, H_alt; try reflexivity.
    + rewrite stream_prefix_length; assumption.
    + rewrite list_suffix_length. rewrite stream_prefix_length. assumption.
  - rewrite stream_prefix_nth; try assumption.
    rewrite stream_suffix_nth.
    assert (Hle : n1 <= n1 + k) by lia.
    specialize (list_suffix_nth (stream_prefix l n2) n1 (n1 + k) Hle)
    ; intro Heq.
    clear Hle.
    assert (Hs: n1 + k - n1 = k) by lia.
    rewrite Hs in Heq.
    rewrite Heq.
    rewrite stream_prefix_nth.
    + rewrite Plus.plus_comm; reflexivity.
    + lia.
Qed.

Lemma stream_prefix_segment
  {A : Type}
  (l : Stream A)
  (n1 n2 : nat)
  (Hn : n1 <= n2)
  : stream_prefix l n1 ++ stream_segment l n1 n2 = stream_prefix l n2.
Proof.
  unfold stream_segment.
  rewrite <- (list_prefix_suffix (stream_prefix l n2) n1) at 2.
  f_equal.
  symmetry.
  apply stream_prefix_prefix.
  assumption.
Qed.

Lemma stream_prefix_segment_suffix
  {A : Type}
  (l : Stream A)
  (n1 n2 : nat)
  (Hn : n1 <= n2)
  : stream_app
      ((stream_prefix l n1)
        ++
       (stream_segment l n1 n2)
      )
      (stream_suffix l n2)
  = l.
Proof.
  rewrite <- (stream_prefix_suffix l n2) at 4.
  f_equal.
  apply stream_prefix_segment.
  assumption.
Qed.

Lemma stream_segment_app
  {A : Type}
  (l : Stream A)
  (n1 n2 n3 : nat)
  (H12 : n1 <= n2)
  (H23 : n2 <= n3)
  : stream_segment l n1 n2 ++ stream_segment l n2 n3 = stream_segment l n1 n3.
Proof.
  assert (Hle : n1 <= n3) by lia.
  specialize (stream_prefix_segment_suffix l n1 n3 Hle); intro Hl1.
  specialize (stream_prefix_segment_suffix l n2 n3 H23); intro Hl2.
  rewrite <- Hl2 in Hl1 at 4. clear Hl2.
  apply stream_app_inj_l in Hl1.
  - specialize (list_prefix_suffix (stream_prefix l n2) n1); intro Hl2.
    specialize (stream_prefix_prefix l n1 n2 H12); intro Hl3.
    rewrite Hl3 in Hl2.
    rewrite <- Hl2 in Hl1.
    rewrite <- app_assoc in Hl1.
    apply app_inv_head in Hl1.
    symmetry.
    assumption.
  - repeat rewrite app_length.
    unfold stream_segment.
    repeat rewrite list_suffix_length.
    repeat rewrite stream_prefix_length.
    lia.
Qed.

Definition monotone_nat_stream_prop
  (s : Stream nat)
  := forall n1 n2 : nat, n1 < n2 -> Str_nth n1 s < Str_nth n2 s.

Definition monotone_nat_stream :=
  {s : Stream nat | monotone_nat_stream_prop s}.

Lemma monotone_nat_stream_tl
  (s : Stream nat)
  (Hs : monotone_nat_stream_prop s)
  : monotone_nat_stream_prop (tl s).
Proof.
  intros n1 n2 Hlt.
  specialize (Hs (S n1) (S n2)).
  apply Hs.
  lia.
Qed.

Definition nat_sequence_suffix
  (s : Stream nat)
  :=
  Streams.map (fun i => i - (S (hd s))) (tl s).

Lemma monotone_nat_prop_suffix
  (ss : monotone_nat_stream)
  : monotone_nat_stream_prop (nat_sequence_suffix (proj1_sig ss)).
Proof.
  destruct ss as [s Hs].
  intros n1 n2 Hlt.
  unfold nat_sequence_suffix.
  destruct s as (a, s).
  simpl.
  repeat rewrite Str_nth_map.
  assert (Hlt1 : 0 < S n1) by lia.
  pose proof (Hs 0 (S n1) Hlt1) as Ha1.
  unfold Str_nth in Ha1.
  simpl in Ha1.
  assert (Hlt2 : 0 < S n2) by lia.
  pose proof (Hs 0 (S n2) Hlt2) as Ha2.
  unfold Str_nth in Ha2.
  simpl in Ha2.
  assert (HltS : S n1 < S n2) by lia.
  specialize (Hs (S n1) (S n2) HltS).
  unfold Str_nth in Hs.
  simpl in Hs.
  unfold Str_nth.
  lia.
Qed.

Definition monotone_nat_stream_suffix
  (ss : monotone_nat_stream)
  : monotone_nat_stream
  :=
  exist
    monotone_nat_stream_prop
    (nat_sequence_suffix (proj1_sig ss))
    (monotone_nat_prop_suffix ss).

Definition filtering_subsequence
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ss : monotone_nat_stream)
  (ns := proj1_sig ss)
  := forall n : nat, P (Str_nth n s) <-> exists k : nat, Str_nth k ns = n.

Lemma filtering_subsequence_witness
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ss : monotone_nat_stream)
  (Hfs : filtering_subsequence P s ss)
  (ns := proj1_sig ss)
  (k : nat)
  : P (Str_nth (Str_nth k ns) s).
Proof.
  specialize (Hfs (Str_nth k ns)).
  apply Hfs. exists k. reflexivity.
Qed.

Lemma filtering_subsequence_suffix
  {A : Type}
  (P : A -> Prop)
  (ss : Stream A)
  (kss : monotone_nat_stream)
  (ks := proj1_sig kss)
  (Hfs : filtering_subsequence P ss kss)
  (kss' := monotone_nat_stream_suffix kss)
  : filtering_subsequence
    P (stream_suffix ss (S (hd ks))) kss' .
Proof.
  intro n. simpl.
  rewrite stream_suffix_nth.
  specialize (Hfs (S (n + hd ks))).
  split; intro H.
  - apply proj1 in Hfs. specialize (Hfs H).
    destruct Hfs as [k0 Heq].
    unfold ks in *; clear ks.
    destruct kss as [(k, ks) Hseq]; simpl in *.
    destruct k0.
    + elim (Plus.succ_plus_discr k n).
      assumption.
    + exists k0. unfold nat_sequence_suffix.
      rewrite Str_nth_map .
      simpl.
      unfold Str_nth in Heq; simpl in Heq.
      assert (Hlt0 : 0 < (S k0)) by lia.
      clear kss'.
      specialize (Hseq 0 (S k0) Hlt0).
      unfold Str_nth in Hseq; simpl in Hseq.
      unfold Str_nth.
      lia.
  - apply proj2 in Hfs. apply Hfs. clear Hfs.
    destruct H as [k Heq].
    exists (S k).
    unfold nat_sequence_suffix in Heq.
    rewrite Str_nth_map in Heq.
    unfold ks in *; clear ks.
    destruct kss as [(k0, ks) Hseq]; simpl in *.
    assert (Hlt : 0 < (S k)) by lia.
    clear kss'.
    specialize (Hseq 0 (S k) Hlt).
    unfold Str_nth in *; simpl in *.
    lia.
Qed.

Definition stream_subsequence
  {A : Type}
  (s : Stream A)
  (ss : monotone_nat_stream)
  (ns := proj1_sig ss)
  : Stream A
  := Streams.map (fun k => Str_nth k s) ns.

Lemma stream_subsequence_suffix
  {A : Type}
  (ss : Stream A)
  (kss : monotone_nat_stream)
  (k := (hd (proj1_sig kss)))
  (n := Str_nth k ss)
  (ss' := stream_suffix ss (S k))
  (kss' := monotone_nat_stream_suffix kss)
  : EqSt
    (stream_subsequence ss kss)
    (Cons n (stream_subsequence ss' kss')).
Proof.
  apply ntheq_eqst.
  intros [|n']; try reflexivity.
  unfold stream_subsequence at 1.
  rewrite Str_nth_map.
  unfold Str_nth at 3.
  simpl.
  assert
    (Heq :
      hd (Str_nth_tl n' (stream_subsequence ss' kss'))
      =
      Str_nth n' (stream_subsequence ss' kss')
    ) by reflexivity.
  rewrite Heq.
  unfold stream_subsequence.
  rewrite Str_nth_map.
  unfold ss'.
  rewrite stream_suffix_nth.
  destruct kss as [ks Hks]; simpl.
  unfold nat_sequence_suffix.
  rewrite Str_nth_map.
  unfold k in *. clear k. simpl.
  unfold n in *; clear n.
  simpl in ss'.
  clear Heq kss'.
  assert (Hlt : 0 < S n') by lia.
  specialize (Hks 0 (S n') Hlt).
  replace (Str_nth n' (tl ks) - S (hd ks) + S (hd ks)) with (Str_nth (S n') ks)
  ; try reflexivity.
  unfold Str_nth in Hks; simpl in Hks.
  unfold Str_nth; simpl.
  lia.
Qed.

Lemma all_ForAll_hd
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (Hall : forall n : nat, P (Str_nth n s))
  : ForAll (fun str => P (hd str)) s.
Proof.
  apply ForAll_coind with (fun s : Stream A => forall n : nat, P (Str_nth n s))
  ; intros.
  - specialize (H 0). assumption.
  - specialize (H (S n)).
    assumption.
  - apply Hall.
Qed.

Lemma stream_filter_Forall
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ss : monotone_nat_stream)
  (s' := stream_subsequence s ss)
  (Hfs : filtering_subsequence P s ss)
  : ForAll (fun str => P (hd str)) s'.
Proof.
  apply all_ForAll_hd.
  intro n.
  unfold s'.
  unfold stream_subsequence.
  rewrite Str_nth_map.
  apply filtering_subsequence_witness. assumption.
Qed.

CoFixpoint stream_annotate
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (Hs : ForAll (fun str => P (hd str)) s)
  : Stream (sig P) :=
  match Hs with
  | HereAndFurther _ H Hs'
    => Cons (exist _ (hd s) H) (stream_annotate P (tl s) Hs')
  end.

Lemma stream_prefix_Forall
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (Hs : ForAll (fun str => P (hd str)) s)
  : forall n : nat, Forall P (stream_prefix s n).
Proof.
  intros n. generalize dependent s.
  induction n; intros.
  - constructor.
  - destruct s as (a,s).
    simpl.
    inversion Hs.
    constructor; try assumption.
    apply IHn.
    assumption.
Qed.

Lemma stream_prefix_Forall_rev
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (Hpref: forall n : nat, Forall P (stream_prefix s n))
  : ForAll (fun str => P (hd str)) s.
Proof.
  generalize dependent s.
  cofix H.
  intros (a, s) Hpref.
  constructor.
  - specialize (Hpref 1).
    inversion Hpref.
    assumption.
  - apply H.
    intro n.
    specialize (Hpref (S n)).
    inversion Hpref.
    assumption.
Qed.

Lemma stream_prefix_annotate
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (Hs : ForAll (fun str => P (hd str)) s)
  (n : nat)
  : exists Hs', stream_prefix (stream_annotate P s Hs) n
  = list_annotate P (stream_prefix s n) Hs'.
Proof.
  generalize dependent s.
  induction n.
  - intros. simpl. exists (Forall_nil P). reflexivity.
  - intros (a, s) (H, H0).
    specialize (IHn s H0).
    destruct IHn as [Hs' Heq].
    simpl.
    rewrite Heq.
    exists (@Forall_cons A P _ _ H Hs').
    simpl.
    f_equal.
Qed.

Lemma stream_annotate_proj
  {A : Type}
  (P : A -> Prop)
  : forall
    (s : Stream A)
    (Hs : ForAll (fun str => P (hd str)) s)
    , EqSt s (map (@proj1_sig _ _) (stream_annotate P s Hs)).
Proof.
  cofix cf.
  intros (x, s) Hs.
  constructor.
  - simpl.
    destruct Hs.
    trivial.
  - destruct Hs.
    simpl.
    apply cf.
Qed.

Lemma stream_prefix_succ
  {A : Type}
  (s : Stream A)
  (n : nat)
  : stream_prefix s (S n) = stream_prefix s n ++ [Str_nth n s].
Proof.
  specialize (stream_prefix_suffix s n).
  rewrite stream_suffix_S.
  rewrite <- stream_app_cons.
  rewrite stream_app_assoc.
  intros Hn.
  specialize (stream_prefix_suffix s (S n)); intros Hsn.
  rewrite <- Hsn in Hn at 4; clear Hsn.
  specialize
    (stream_app_inj_l
      (stream_prefix s n ++ [Str_nth n s])
      (stream_prefix s (S n))
      (stream_suffix s (S n))
      Hn
    ); intros Hinj.
    symmetry.
    apply Hinj.
    rewrite app_length.
    repeat (rewrite stream_prefix_length).
    rewrite Plus.plus_comm.
    reflexivity.
Qed.

Lemma stream_filter_prefix_0
  `{forall (a : A), Decision (P a)}
  (ss : Stream A)
  (ks : monotone_nat_stream)
  (Hfs : filtering_subsequence P ss ks)
  (kn := Str_nth 0 (proj1_sig ks))
  (ss_to_kn := stream_prefix ss (S kn))
  : stream_prefix (stream_subsequence ss ks) (S 0)
    = filter (fun a => bool_decide (P a)) ss_to_kn.
Proof.
  generalize dependent ks.
  intros [(k, ks) Hseq]; intros.
  simpl in kn. simpl. unfold Str_nth in kn; simpl in kn. unfold kn in *.
  clear kn.
  unfold filtering_subsequence in Hfs. simpl in Hfs.
  unfold ss_to_kn.
  rewrite stream_prefix_succ.
  rewrite filter_app.
  simpl.
  rewrite <- decide_bool_decide.
  assert (P (Str_nth k ss)).
  { destruct (decide (P (Str_nth k ss))).
    assumption.
    specialize (Hfs k).
    apply Hfs.
    exists 0.
    reflexivity.
  }
  destruct (decide (P (Str_nth k ss))); [|tauto].
  replace (filter _ (stream_prefix ss k)) with (@nil A)
  ; try reflexivity.
  symmetry.
  apply filter_nil.
  rewrite Forall_forall.
  intros a Hin.
  rewrite bool_decide_decide.
  destruct (decide (P a)); [|reflexivity].
  exfalso.
  apply stream_prefix_in in Hin.
  destruct Hin as [k0 [Hlt Heq]]; subst.
  specialize (Hfs k0).
  apply Hfs in p0.
  destruct p0 as [i Heqki].
  specialize (Hseq 0 i).
  specialize (Lt.lt_irrefl k0); intro Hk0; elim Hk0.
  destruct i; subst; try assumption.
  apply Lt.lt_trans with k; try assumption.
  apply Hseq.
  auto with arith.
Qed.

Lemma stream_filter_prefix
  `{forall (a : A), Decision (P a)}
  (ss : Stream A)
  (ks : monotone_nat_stream)
  (Hfs : filtering_subsequence P ss ks)
  (n : nat)
  (kn := Str_nth n (proj1_sig ks))
  (ss_to_kn := stream_prefix ss (S kn))
  : stream_prefix (stream_subsequence ss ks) (S n)
    = filter (fun a => bool_decide (P a)) ss_to_kn.
Proof.
  generalize dependent ks. generalize dependent ss.
  induction n; try apply stream_filter_prefix_0.
  intros ss kss Hfs; intros.
  specialize (stream_filter_prefix_0 ss kss Hfs); intro H0.
  remember (Str_nth 0 (proj1_sig kss)) as k0.
  specialize (filtering_subsequence_suffix P ss kss Hfs); intros Hfs'.
  remember (monotone_nat_stream_suffix kss) as kss'.
  specialize (stream_subsequence_suffix ss kss); intros Hsss; simpl in Hsss.
  specialize (stream_prefix_EqSt _ _ Hsss); intro Hpref.
  destruct kss as [(k, ks) Hseq].
  simpl in Hfs'.
  remember (stream_suffix (tl ss) k) as ss'.
  specialize (IHn ss' kss' Hfs').
  assert
    (IHn':
      stream_prefix (stream_subsequence ss' kss') (S n)
      = filter (fun a => bool_decide (P a)) (stream_prefix ss' (S (Str_nth n (proj1_sig kss'))))
    ) by assumption.
  clear IHn.
  subst; simpl in Hpref. specialize (Hpref (S (S n))).
  inversion Hpref.
  remember (stream_prefix (stream_suffix (tl ss) k)) as sp.
  simpl in IHn'.
  rewrite <- H3 in IHn'.
  rewrite <- H2 in IHn'.
  simpl.
  rewrite IHn'.
  unfold ss_to_kn.
  unfold nat_sequence_suffix.
  rewrite Str_nth_map.
  remember (S kn) as skn.
  simpl.
  subst.
  specialize (stream_segment_alt_iff ss (S k) (S (Str_nth n ks)));
  unfold stream_segment; unfold stream_segment_alt; intro Heq.
  remember (S (Str_nth n ks)) as x; simpl in Heq; subst.
  assert  (Heq' : S (Str_nth n ks) - S k = (S (Str_nth n ks - S k))).
  { assert (Hle : 0 < S n) by lia.
    clear Hfs kn ss_to_kn H0 Hfs' Hsss Hpref.
    specialize (Hseq 0 (S n) Hle).
    unfold Str_nth in Hseq. simpl in Hseq.
    unfold Str_nth. simpl.
    lia.
  }
  rewrite Heq' in Heq.
  rewrite <- Heq.
  specialize (list_prefix_suffix (stream_prefix ss (S kn)) (S k)); intro Hps.
  rewrite <- Hps.
  rewrite filter_app.
  rewrite stream_prefix_prefix.
  + assert (H0' : filter (fun a => bool_decide (P a)) (stream_prefix ss (S k)) = [Str_nth k ss])
    by (symmetry; apply H0).
    rewrite H0'.
    remember (stream_prefix ss) as spss.
    simpl.
    f_equal.
  + clear -Hseq. unfold kn. simpl. clear kn.
    assert (Hlt : 0 < S n) by lia.
    apply Hseq in Hlt.
    unfold Str_nth in *; simpl in *.
    lia.
Qed.

Lemma stream_prefix_nth_last
  {A : Type}
  (l : Stream A)
  (n : nat)
  (_last : A)
  : last (stream_prefix l (S n)) _last = Str_nth n l.
Proof.
  specialize (nth_error_last (stream_prefix l (S n)) n); intro Hlast.
  specialize (stream_prefix_length l (S n)); intro Hpref_len.
  symmetry in Hpref_len.
  specialize (Hlast Hpref_len _last).
  specialize (stream_prefix_nth l (S n) n); intro Hnth.
  assert (Hlt : n < S n) by constructor.
  specialize (Hnth Hlt).
  rewrite Hnth in Hlast.
  simpl.
  inversion Hlast.
  reflexivity.
Qed.

Lemma stream_segment_singleton
  {A : Type}
  (l : Stream A)
  (n : nat)
  : stream_segment l n (S n) = [Str_nth n l].
Proof.
  remember (Str_nth n l) as a.
  unfold stream_segment.
  assert (Hlt : n < length (stream_prefix l (S n)))
    by (rewrite stream_prefix_length; constructor).
  specialize (list_suffix_last (stream_prefix l (S n)) n Hlt a); intro Hlast1.
  specialize (stream_prefix_nth_last l n a); intro Hlast2.
  rewrite Hlast2 in Hlast1.
  specialize (list_suffix_length (stream_prefix l (S n)) n).
  rewrite stream_prefix_length; try assumption.
  intro Hlength.
  rewrite <- Minus.minus_Sn_m in Hlength by lia.
  rewrite <- Minus.minus_diag_reverse in Hlength.
  remember (list_suffix (stream_prefix l (S n)) n) as x.
  rewrite <- Heqa in Hlast1.
  clear -Hlength Hlast1.
  destruct x; inversion Hlength.
  destruct x; inversion H0.
  simpl in Hlast1; subst; reflexivity.
Qed.

Lemma str_map_tl
  {A B : Type}
  (f : A -> B)
  (s : Stream A)
  : EqSt (tl (map f s)) (map f (tl s)).
Proof.
  generalize dependent s.
  cofix IH.
  intros (a, s).
  constructor; try reflexivity.
  simpl.
  apply IH.
Qed.

Lemma str_map_cons
  {A B : Type}
  (f : A -> B)
  (s : Stream A)
  : EqSt (map f s) (Cons (f (hd s)) (map f (tl s))).
Proof.
  destruct s as  (a,s).
  constructor; try reflexivity.
  simpl.
  apply EqSt_reflex.
Qed.