Require Import Common.exceptionMonad.
Require Import Common.AstCommon.
Require Import Coq.Unicode.Utf8.

CoInductive liftLe {S D: Type} (R: S -> D -> Prop): option S -> option D -> Prop :=
(* defining this using pattern matching confuses the strict positivity checker.
  Can this part be defined outside generically, using induction? *)
| liftSome: forall s d, R s d -> liftLe R (Some s) (Some d)
| liftNone: forall d, liftLe R None d.

Hint Constructors liftLe : certiclasses.

(** is this defined in the Coq standard library of ExtLib? *)
Definition Rimpl {S D: Type} (R1 R2: S -> D -> Prop) :=
  forall s d, R1 s d -> R2 s d.

Definition liftLeR {S D: Type} (R: S -> D -> Prop) (os: option S) (od: option D) : Prop :=
  match os with
  | None => True
  | Some s =>
    match od with
    | Some d => R s d
    | None => False
    end
  end.

Lemma  liftLeTrans {S I D: Type} (Rsi : S -> I -> Prop) (Rid : I -> D -> Prop) (Rsd : S -> D -> Prop) :
   (forall s i d, Rsi s i -> Rid i d -> Rsd s d)
   -> forall s i d, liftLe Rsi s i -> liftLe Rid i d -> liftLe Rsd s d.
Proof.
  intros Ht ? ? ? Hsi Hid.
  inversion Hsi; subst; eauto with certiclasses.
  inversion Hid. subst; constructor.
  eauto.
Qed.

Require Import SquiggleEq.LibTactics.
(** Could have used RImpl for the conclusion as well, Coq's hint search is not so good
 at unfolding definitions. *)
Lemma  liftLeRimpl {S D: Type} (R1 R2: S -> D -> Prop) os od:
  Rimpl R1 R2 -> liftLe R1 os od -> liftLe R2 os od.
Proof.
  intros Hr Hl.
  inverts Hl; constructor.
  apply Hr. assumption.
Defined.

Hint Resolve liftLeRimpl : certiclasses.

(* This operations picks out the "good" terms in the language.
 All bets are off about the terms that are not good *)
Class GoodTerm (Term: Type) := goodTerm : Term  -> Prop.

Generalizable Variables Src Dst Inter Term Value SrcValue DstValue InterValue.

(** A [Term] can contain an environment embedded in it. *)
Class BigStepOpSem (Term Value:Type) := bigStepEval: Term -> Value -> Prop.

Require Import String.

(* one can use ⇓ to refer to the big step eval relation *)
Notation "s ⇓ t" := (bigStepEval s t) (at level 70).

Definition sameValues {Term:Type}
  `{BigStepOpSem Term} (a b : Term)
:= forall (v: Value), a ⇓ v <-> b ⇓ v.

Inductive bigStepResult (Term Value:Type) :=
| Result : Value -> bigStepResult Term Value
| OutOfTime : Term -> bigStepResult Term Value
| Error : string -> option Term -> bigStepResult Term Value.

Class BigStepOpSemExec (Term Value:Type)
  := bigStepEvaln: nat -> Term -> bigStepResult Term Value.

Arguments Result {Term} {Value} v.
Arguments OutOfTime {Term} {Value} e.
Arguments Error {Term} {Value} s.

Require Import ExtLib.Structures.Monads.

(** for an example usage of this monad, see eval_n in LambdaBoxLocal/LambdaBoxLocal_5_to_L5.v *)
Global Instance Monad_bigStepResult (Term :Type): Monad (bigStepResult Term) :=
{ ret := @Result Term
; bind := fun _ _ r f => match r with
                             | Result v => f v
                             | OutOfTime t => OutOfTime t
                             | Error s ot => Error s ot
                           end
}.

Definition mapBigStepRes {T1 V1 T2 V2 : Type}
           (ft : T1 -> T2)
           (fv : V1 -> V2)
           (tr : bigStepResult T1 V1) : bigStepResult T2 V2 :=
  match tr with
  | Result v => Result (fv v)
  | OutOfTime t => OutOfTime (ft t)
  | Error s t => Error s (option_map ft t)
  end.

Definition injectOption {Term V:Type} (oa : option V) : bigStepResult Term V :=
  match oa with
  | Some v => Result v
  | None => Error "None" None
  end.

Class BigStepOpSemExecCorrect {Term Value:Type}
      {bs: BigStepOpSem Term Value} (bse: BigStepOpSemExec Term Value) :=
  { (** weaken = to a custom equality, which can be instantiated, e.g. by alpha equality? *)
    bseSound: forall n e v, bigStepEvaln n e = Result v -> e ⇓ v;
    bseComplete: forall e v, e ⇓ v -> exists n, bigStepEvaln n e = Result v
  }.

Instance liftBigStepException `{BigStepOpSem Term Value}
  : BigStepOpSem (exception Term) (exception Value) :=
λ (s : exception Term) (sv : exception Value),
match (s, sv) with
| (Ret s, Ret sv) => s ⇓ sv
| (_,_) => False
end.

Definition liftExc {T:Type} (R: T->T->Prop) (oa1 oa2 : exception T) :=
  match oa1, oa2 with
  | Ret a1, Ret a2 => R a1 a2
  | _,_ => False
  end.

(* Optimization flags *)
Inductive Opt : Type := | Flag : nat -> Opt.

Class CerticoqTranslation (Src Dst : Type) : Type
  := translate : Opt -> Src -> exception Dst.

Class CerticoqTotalTranslation (Src Dst : Type) : Type
  := translateT : Opt -> Src -> Dst.

Arguments translate  Src Dst {CerticoqTranslation} s.
Arguments translateT  Src Dst {CerticoqTotalTranslation} s.

Instance liftTotal `{CerticoqTotalTranslation Src Dst} : CerticoqTranslation Src Dst :=
  fun opt (x:Src) => Ret (translateT Src Dst opt x).

Definition goodPreserving `{CerticoqTranslation Src Dst}
    `{GoodTerm Src} `{GoodTerm Dst} : Prop :=
  ∀ (s: Src) (o: Opt),
    goodTerm s
    -> match translate Src Dst o s with
      | Ret t => goodTerm t
      | Exc _ => False
      end.

Arguments goodPreserving Src Dst {H} {H0} {H1}.

Definition bigStepPreserving `{CerticoqTranslation Src Dst}
  `{CerticoqTranslation SrcValue DstValue}
   `{BigStepOpSem Src SrcValue} `{BigStepOpSem Dst DstValue} `{GoodTerm Src}
  :=
    ∀ (s:Src) (sv: SrcValue) (o:Opt),
      goodTerm s
      -> s ⇓ sv
      -> (translate Src Dst o s) ⇓ (translate SrcValue DstValue o sv).

Arguments bigStepPreserving Src Dst {H} {SrcValue} {DstValue} {H0} {H1} {H2} {H3}.

Require Import Common.exceptionMonad.

Global Instance composeTranslation `{CerticoqTranslation Src Inter}
  `{CerticoqTranslation Inter Dst} :
  `{CerticoqTranslation Src Dst} :=
  λ o s, bind (translate Src Inter o s) (translate Inter Dst o).

Lemma composePreservesGood (Src Inter Dst: Type)
  {goodi: GoodTerm Inter}
  {goods: GoodTerm Src}
  {goodt: GoodTerm Dst}
  {t1 : CerticoqTranslation Src Inter}
  {t2 : CerticoqTranslation Inter Dst} :
goodPreserving Src Inter
-> goodPreserving Inter Dst
-> goodPreserving Src Dst.
Proof.
  intros Hsi Hit s o Hs.
  unfold goodPreserving, composeTranslation, bind in *.
  unfold translate in *.
  eapply Hsi with (o := o) in Hs.
  destruct (t1 o s); [contradiction|].
  eapply Hit. assumption.
Qed.

Section obsPreserving.
Context (Src Dst: Type) {SrcValue DstValue: Type}
          (VR: SrcValue -> DstValue -> Prop).
Notation "s ⊑ t" := (VR s t) (at level 65).

(* Similar to what Zoe suggested on Wed, Aug 17, 2016 at 8:57 AM *)
Definition obsPreserving
  `{CerticoqTranslation Src Dst}
   `{BigStepOpSem Src SrcValue} `{BigStepOpSem Dst DstValue} `{GoodTerm Src}
  :=
   ∀ (o : Opt) (s:Src) (sv: SrcValue),
     goodTerm s
     -> (s ⇓ sv)
     -> ∃ (dv: DstValue), (translate Src Dst o s) ⇓ (Ret dv) ∧ sv ⊑ dv.
End obsPreserving.

(*
Notation "s =⊏  t" := (obsLe StrongObservation s t) (at level 65).
*)

(*
Arguments CerticoqTranslationCorrect2 NonTrivObservation
  Src {SrcValue} {H} {H0} {H1} {H2} {H3} Dst {DstValue} {H4} {H5} {H6} {H7} {H8} {H9}.
Arguments CerticoqLanguage2 Term Value {H} {H0} {H1} {H2}.
Arguments obsPreserving Src Dst {H} {SrcValue} {H0} {DstValue} {H1} {H2} {H3} {H4} {H5} {H6}.
*)

Definition normalizes `{BigStepOpSem Term Value} (s:Term): Prop :=
  ∃ (sv : Value) , s ⇓ sv.

(* Todo : generalize over Coq.Init.Logic.eq. *)
Definition deterministicBigStep `{BigStepOpSem Term Value} :=
∀ (s :Term) (v1 v2 : Value), s ⇓ v1 -> s ⇓ v2 -> v1 = v2.

Arguments deterministicBigStep Term {Value} {H}.

Definition totalTranslation `{CerticoqTranslation Src Dst} : Prop :=
  ∀ (o:Opt) (s:Src),
    match translate Src Dst o s with
    | Ret _ => True
    | Exc _ => False
    end.

Lemma deterministicBigStepLiftExc `{BigStepOpSem Term Value}:
  deterministicBigStep Term
  -> deterministicBigStep (exception Term).
Proof.
  intros Hd ? ? ? He1 He2.
  destruct s, v1, v2; compute in He1; compute in He2; try contradiction.
  f_equal.
  unfold deterministicBigStep in Hd.
  eapply Hd; eauto.
Qed.

(* ( * ) in Randy's email dated Tue, May 31, 2016 at 10:35 PM EST
*)

Definition bigStepReflecting `{CerticoqTranslation Src Dst}
  `{CerticoqTranslation SrcValue DstValue}
   `{BigStepOpSem Src SrcValue} `{BigStepOpSem Dst DstValue}
   (o:Opt) (s:Src) : Prop :=
  ∀ (dv: DstValue),
    (translate Src Dst o s) ⇓ (Ret dv)
    -> ∃ (sv:SrcValue), s ⇓ sv ∧ Ret dv = translate SrcValue DstValue o sv.

Section obsPreserving2.
Context (Src Dst : Type) {SrcValue DstValue : Type} (VR : SrcValue -> DstValue -> Prop).
Notation "s ⊑ t" := (VR s t) (at level 65).

(* Similar to the new +, except this one does not enforce preservation of non-termination *)
Definition obsReflecting `{CerticoqTranslation Src Dst}
   `{BigStepOpSem Src SrcValue} `{BigStepOpSem Dst DstValue}
   (o:Opt) (s:Src) : Prop :=
 ∀ (dv: DstValue),
   (translate Src Dst o s) ⇓ (Ret dv)
   -> ∃ (sv:SrcValue), s ⇓ sv ∧ sv ⊑ dv .

End obsPreserving2.

Arguments bigStepReflecting Src Dst {H} {SrcValue} {DstValue} {H0} {H1} {H2} o s.

Lemma bigStepPreservingReflecting
  `{CerticoqTranslation Src Dst}
  `{CerticoqTranslation SrcValue DstValue}
  `{GoodTerm Src}
  `{GoodTerm Dst}
  `{BigStepOpSem Src SrcValue}
  `{BigStepOpSem Dst DstValue}
  {_:bigStepPreserving Src Dst} :
  (deterministicBigStep Dst)
  -> ∀ (o:Opt) (s:Src),
    goodTerm s
    -> normalizes s
    -> bigStepReflecting Src Dst o s.
Proof.
  intros Hd o s Hp Hn ? Ht.
  destruct Hn as [d  Hn].
  exists d. split;[assumption|].
  apply deterministicBigStepLiftExc in Hd.
  eauto.
(* info eauto :
eapply Hd.
 exact Ht.
 apply preservesEval0.
  exact Hp.
  exact Hn.
*)
Qed.

Lemma obsPreservingReflecting
  `{CerticoqTranslation Src Dst}
  `{GoodTerm Src}
  `{GoodTerm Dst}
  `{BigStepOpSem Src SrcValue}
  `{BigStepOpSem Dst DstValue}
  (RV : SrcValue → DstValue → Prop)
  {Ho:obsPreserving Src Dst RV} : (* * *)
  (deterministicBigStep Dst)
  -> ∀ (o:Opt) (s:Src),
    goodTerm s
    -> normalizes s
    -> obsReflecting Src Dst RV o s. (* + *)
Proof.
  intros Hd o s Hp Hn ? Ht.
  destruct Hn as [sv  Hn].
  pose proof Hn as Hnb.
  eapply Ho in Hn;[| assumption].
  destruct Hn as [dvv Hn].
  destruct Hn as [Hnt  Hnr].
  apply deterministicBigStepLiftExc in Hd.
  specialize (Hd _ _ _ Hnt Ht).
  inversion Hd. subst. clear Hd.
  exists sv. split; assumption.
Qed.

Require Import SquiggleEq.UsefulTypes.
From MetaCoq Require Import Template.Ast.

Global Instance EqDecInd : Deq inductive.
eapply @deqAsSumbool.
unfold DeqSumbool. intros.
unfold DecidableSumbool.
repeat decide equality.
Defined.

Lemma goodPreservingId {Src:Type} {Hg: GoodTerm Src}:
  @goodPreserving Src Src (fun o x => Ret x) _ _.
Proof using.
  intros ? ? ?.
  simpl. assumption.
Qed.

Class IsValue (T:Type) := isValue: T -> Prop.

Definition IsValueSound {T V:Type} {bgs: BigStepOpSem T V} {isv: IsValue V} :=
  forall v, isValue v -> exists t, t ⇓ v.

Definition IsValueComplete {T V:Type} {bgs: BigStepOpSem T V} {isv: IsValue V} :=
  forall t v, t ⇓ v -> isValue v.


Require Import List Mem BaseTypes.
Import ListNotations.

Set Implicit Arguments.

Section Disk.
  (* maybe rename better *)
  Definition set V := (V * list V)%type.

  Definition set_dec {V} (value_dec : forall (v v': V),{v=v'}+{v<>v'}): forall s s': set V, {s=s'}+{s<>s'}.
    decide equality.
    decide equality.
  Defined.

  Definition disk V := @mem addr addr_dec V.

  Definition read {V} (d: disk (set V)) (a: addr) :=
    match d a with
    | None => None
    | Some vs => Some (fst vs)
    end.

  Definition write {V} (d: disk (set V)) (a: addr) (v: V) : disk (set V) :=
    match d a with
    | None => d
    | Some vs => upd d a (v, fst vs::snd vs)
    end.

  Fixpoint write_all {V} (d: disk (set V)) (la: list addr) (lv: list V) : disk (set V) :=
    match la, lv with
    | a::la', v::lv' =>
      match d a with
      | None => d
      | Some vs => write_all (upd d a (v, fst vs::snd vs)) la' lv'
      end
    | _, _ => d
    end.

  Fixpoint write_all_to_set {V} (vl: list V) (vsl: list (set V)) :=
    match vl, vsl with
    | v::vl', vs::vsl' =>
      (v, fst vs::snd vs)::write_all_to_set vl' vsl'
    | _, _ =>
      nil
    end.

End Disk.


(* -*- mode: coq; mode: visual-line -*- *)

Require Import HoTT.Basics HoTT.Types.

(** * Metatheory *)

(** This directory contains files that prove important metatheoretic results about HoTT, but that are not important for internal development of mathematics in HoTT.  Thus, no files in this directory should ever need to be imported by files outside of this directory. *)

(** Many of these results are about ways to prove univalence and function extensionality (which in the main library we simply assert as axioms, though we track their usage with dummy typeclasses).  For convenience, here we define the types of these two statements. *)

Definition Funext_type@{i j max} :=
  forall (A : Type@{i}) (P : A -> Type@{j}) f g,
    IsEquiv (@apD10@{i j max} A P f g).

(** Univalence is a property of a single universe; its statement lives in a higher universe *)
Definition Univalence_type@{i iplusone} : Type@{iplusone} :=
  forall (A B : Type@{i}), IsEquiv (equiv_path@{i iplusone} A B).


Set Implicit Arguments.
Unset Strict Implicit.

Require Import QArith.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import GRing.Theory Num.Theory Num.Def.

Require Import games.

Local Open Scope nat_scope.
Local Open Scope ring_scope.

Module Christodoulou.

  (* ########################################################### *)
  (** * Helper lemmas *)

  Lemma subrr' (rty : realFieldType) (a : rty) :
    - a + a = 0.
  Proof.
    rewrite addrC. apply: subrr.
  Qed.

  Lemma sub_add_0 (rty : realFieldType) (a b : rty) :
    a - b + b = a.
  Proof.
    rewrite -addrA subrr' addrC add0r => //.
  Qed.

  Lemma leq_case (a b : nat) :
    is_true (leq a (S b)) ->
    a = S b \/ is_true (leq a b).
  Proof.
    move => H. rewrite leq_eqVlt in H.
    move: H. move => /orP H.
    destruct H.
    left. move: H. move => /eqP H. apply H.
    right. apply H.
  Qed.

  (* ########################################################### *)
  (** * Subresult proof.

    yz <= y^2 + (1/3)z^2 *)

  (* Multiply both sides by 3 *)
  Lemma s1 (y z : nat) :
    3%:Q * y%:Q * z%:Q <= 3%:Q * y%:Q ^+ 2 + z%:Q ^+ 2 ->
    y%:Q * z%:Q <= (3%:Q / 3%:Q) * y%:Q ^+ 2 + (1%:Q / 3%:Q) * z%:Q ^+ 2.
  Proof.
    move => H0. apply ler_mull2 with (z := 3%:Q); auto.
    rewrite mulrA [3%:~R * (_ + _)] mulrDr mulrA.
    have H1: ((3%:Q / 3%:Q) = 1%:Q) by apply: divff.
    rewrite H1 mulr1 mulrA mulrA mulrA.
    have H2: (3%:Q * (1%:Q / 3%:Q) = 1%:Q) by [].
    rewrite H2 mul1r.
    have H3: (y%:Q ^+ 2 = y%:Q * y%:Q) by [].
    have H4: (z%:Q ^+ 2 = z%:Q * z%:Q) by [].
    rewrite H3 H4 mulrA in H0. apply H0.
  Qed.

  (* Subtract 3*y^2 from both sides *)
  Lemma s2 (y z : nat) :
    (3%:Q * y%:Q * z%:Q - 3%:Q * y%:Q ^+ 2 <= z%:Q ^+ 2) ->
    (3%:Q * y%:Q * z%:Q <= 3%:Q * y%:Q ^+ 2 + z%:Q ^+ 2).
  Proof.
    move => H.
    have H0: (3%:Q * y%:Q * z%:Q - 3%:Q * y%:Q ^+ 2 +
              3%:Q * y%:Q ^+ 2 <= z%:Q ^+ 2 + 3%:Q * y%:Q ^+ 2).
    { apply ler_add. apply H. auto. }
    rewrite sub_add_0 addrC in H0. apply H0.
  Qed.

  (* Distrbute 3*y *)
  Lemma s3 (y z : nat) :
    3%:Q * y%:Q * z%:Q - 3%:Q * y%:Q ^+ 2 =
    3%:Q * y%:Q * (z%:Q - y%:Q).
  Proof. rewrite [_ * (_ - y%:Q)] mulrBr mulrA => //. Qed.

  (* Divide both sides by 3 *)
  Lemma s4 (y z : nat) :
    y%:Q * (z%:Q - y%:Q) <= (z%:Q / 2%:Q) ^+ 2 ->
    3%:Q * y%:Q * (z%:Q - y%:Q) <= 3%:Q * (z%:Q / 2%:Q) ^+ 2.
  Proof.
    move => H.
    have H0: (3%:Q * y%:Q * (z%:Q - y%:Q) = 3%:Q * (y%:Q * (z%:Q - y%:Q))).
    { rewrite mulrA => //. }
    rewrite H0.
    apply ler_mull => //.
  Qed.

  Lemma s5 (y z : nat) :
    z%:Q = y%:Q + (z%:Q - y%:Q).
  Proof. rewrite addrC sub_add_0 => //. Qed.

  (* Divide both sides by 3 then apply AGM inequality *)
  Lemma s6 (y z : nat) :
    3%:Q * y%:Q * (z%:Q - y%:Q) <= 3%:Q * (z%:Q / 2%:Q) ^+ 2.
  Proof.
    apply: s4.
    have H: (z%:Q = y%:~R + (z%:~R - y%:~R)) by apply: s5.
    rewrite {2} H.
    apply: lerif_AGM2.
  Qed.

  Lemma s7 (z : nat) :
    (z%:Q / 2%:Q) * (z%:Q / 2%:Q) = (z%:Q * z%:Q) / 4%:Q.
  Proof.
    have H0: (4%:Q = 2%:Q * 2%:Q) by [].
    rewrite H0 mulrA [z%:~R * z%:~R / _] mulrC.
    rewrite -mulrA -mulrA [2%:~R^-1 * _] mulrC mulrC.
    rewrite [z%:~R / 2%:~R] mulrC mulrA mulrA [2%:~R^-1 / 2%:~R] mulrC.
    rewrite -invrM; auto.
    rewrite mulrC [z%:~R / (2%:~R * 2%:~R) * z%:~R] mulrC mulrA => //.
  Qed.

  Lemma s8 (z : nat) :
    3%:Q * (z%:Q / 2%:Q) * (z%:Q / 2%:Q) =
    z%:Q * z%:Q * (3%:Q / 4%:Q).
  Proof.
    rewrite -[3%:Q * _ * _] mulrA s7 mulrA mulrC.
    rewrite [4%:~R^-1 * _] mulrA mulrC mulrC => //.
  Qed.

  (* 1 <= y -> 0 < y *)
  Lemma s9 (rty : numDomainType) (z : nat) :
    leq (S O) z ->
    0 < (z%:R^-1 : rty).
  Proof.
    rewrite -(ler_nat rty) => H.
    rewrite invr_gt0.
    have H2: (0 : rty) < 1%:R by [].
      by apply: (ltr_le_trans H2 H).
  Qed.

  (* 1 <= z -> z != 0 *)
  Lemma s10 (rty : numDomainType) (z : nat) :
    leq (S O) z ->
    (z%:R : rty) != (0%:R : rty).
  Proof.
    move => H. rewrite -(ler_nat rty) in H.
    rewrite lt0r_neq0 => //.
    have H0: ((0 : rty) < (1%:R : rty)) by [].
      by apply: (ltr_le_trans H0 H).
  Qed.

  Lemma s11 (y z : nat) :
    3%:Q * (z%:Q / 2%:Q) ^+ 2 <= z%:Q ^+ 2.
  Proof.
    case H0: z.
    - (* z = 0 *)
      rewrite mul0r.
      have H1: (0%:Q ^+ 2 = 0%:Q * 0%:Q) by [].
        by rewrite !H1 mul0r mulrC mul0r.
    - (* z > 0 *)
      have H1: ((z%:Q / 2%:Q) ^+ 2 = (z%:Q / 2%:Q) * (z%:Q / 2%:Q)) by [].
      rewrite H0 in H1.
      rewrite H1 mulrA s8.
      have H2: (z%:Q ^+ 2 = z%:Q * z%:Q) by [].
      rewrite H0 in H2. rewrite H2.
      apply ler_mull2 with (z := z%:Q^-1). apply s9 => //; last by rewrite H0.
      rewrite -H0 [z%:Q^-1 * _] mulrA [z%:~R^-1 * _] mulrA [z%:~R^-1 * z%:~R] mulVf.
      rewrite mul1r.
      apply ler_mull2 with (z := z%:Q^-1). apply s9 => //.
        by rewrite H0.
        rewrite [z%:~R^-1 * _] mulrA [z%:~R^-1 * z%:~R] mulVf.
        rewrite  mul1r => //.
        apply s10 => //. by rewrite H0.
        apply s10 => //. by rewrite H0.
  Qed.

  (* this implies the main result when y >= 2 *)
  Lemma subresult (y z : nat) :
      y%:Q * z%:Q <=
      (3%:Q / 3%:Q) * y%:Q ^+ 2 + (1%:Q / 3%:Q) * z%:Q ^+ 2.
  Proof.
    apply: s1. apply: s2. rewrite s3.
    have H1: (3%:Q * y%:Q * (z%:Q - y%:Q) <= 3%:Q * (z%:Q / 2%:Q) ^+ 2)
      by apply: s6.
    have H2: (3%:Q * (z%:Q / 2%:Q) ^+ 2 <= z%:Q ^+ 2) by apply: s11.
    apply: ler_trans. apply H1. apply H2.
  Qed.

  (* ########################################################### *)
  (** * Subresult implies main result proof *)

  (* 2 <= y -> 0 < y *)
  Lemma sr3 (y : nat) :
    leq 2 y ->
    0 < y%:Q.
  Proof.
    move => H0.
    rewrite -(ltr1n rat_numDomainType) in H0.
    have H1: (0%:Q < 1%:Q) by [].
    apply: ltr_trans. apply H1. apply H0.
  Qed.

  (* 2 <= y -> 2/3 <= y *)
  Lemma sr4 (y : nat) :
    leq 2 y ->
    3%:Q / 2%:Q <= y%:Q.
  Proof.
    move => H0.
    rewrite -(ler_nat rat_numDomainType) in H0.
    have H1: (3%:Q / 2%:Q <= 2%:Q) by [].
    apply: ler_trans. apply: H1. apply: H0.
  Qed.

  (* 2 <= y -> y <= (2/3)*y^2 *)
  Lemma sr5 (y : nat) :
    leq 2 y ->
    y%:Q <= 2%:Q / 3%:Q * y%:Q ^+ 2.
  Proof.
    move => H.
    rewrite mulrC.
    have H0: (y%:Q ^+ 2 = y%:Q * y%:Q) by [].
    rewrite H0 mulrA.
    have H1: (y%:Q = y%:Q * 1%:Q). rewrite mulrC mul1r => //.
    rewrite {1} H1.
    have H2: (y%:Q * y%:Q * (2%:Q / 3%:Q) = y%:Q * (y%:Q * (2%:Q / 3%:Q)))
      by rewrite -mulrA.
    rewrite -mulrA  H2.
    apply ler_mull with (x := 1%:Q) (y := y%:Q * (2%:Q / 3%:Q)) (z := y%:Q).
    rewrite le0r. apply /orP. right. apply sr3 => //.
    apply ler_mull2 with (z := 3%:Q / 2%:Q) => //.
    rewrite mulrC mul1r.
    have H3: (y%:Q * (2%:Q / 3%:Q) = 2%:Q / 3%:Q * y%:Q) by rewrite mulrC.
    rewrite H3 mulrA.
    have H4: (2%:Q / 3%:Q = (3%:Q / 2%:Q)^-1) by [].
    have H5: (3%:Q / 2%:Q * (2%:Q / 3%:Q) = 1) by rewrite mulrC H4 mulVr.
    rewrite H5 mul1r.
    apply sr4 => //.
  Qed.

  (* Combine terms *)
  Lemma sr6 (y : nat) (a : rat) :
    3%:Q / 3%:Q * y%:Q ^+ 2 + a + 2%:Q / 3%:Q * y%:Q ^+ 2 =
    5%:Q / 3%:Q * y%:Q ^+ 2 + a.
  Proof.
    rewrite addrC addrA -mulrDl.
    have H: (2%:Q / 3%:Q + 3%:Q / 3%:Q = 5%:Q / 3%:Q) by [].
    rewrite H => //.
  Qed.

  (* When 2 <= y, subresult -> main result *)
  Lemma subresult_implies_result (y z: nat) :
      leq 2 y ->
      y%:Q * z%:Q <= (3%:Q / 3%:Q) * y%:Q ^+ 2 + (1%:Q / 3%:Q) * z%:Q ^+ 2 ->
      y%:Q * (z%:Q + 1) <= (5%:Q / 3%:Q) * y%:Q ^+ 2 + (1%:Q / 3%:Q) * z%:Q ^+ 2.
  Proof.
    move => H0 H1.
    have H2: (y%:Q * z%:Q + y%:Q <=
              3%:Q / 3%:Q * y%:Q ^+ 2 +
              1%:Q / 3%:Q * z%:Q ^+ 2 + (2%:Q / 3%:Q) * y%:Q ^+ 2).
    {  apply ler_add. apply H1. apply: sr5 => //. }
    rewrite sr6 in H2.
    rewrite mulrDr mulr1. apply: H2.
  Qed.

  (* 3 <= z -> z <= (1/3)*z^2 *)
  Lemma r1_1 (z : nat) :
    leq 3 z ->
    z%:Q <= 1%:Q / 3%:Q * z%:Q ^+ 2.
  Proof.
    move => H.
    rewrite mulrC.
    have H0: (z%:Q ^+ 2 = z%:Q * z%:Q) by [].
    rewrite H0 mulrA.
    have H1: (z%:Q = z%:Q * 1%:Q). rewrite mulrC mul1r => //.
    rewrite {1} H1.
    have H2: (z%:Q * z%:Q * (1%:Q / 3%:Q) = z%:Q * (z%:Q * (1%:Q / 3%:Q)))
      by rewrite -mulrA.
    rewrite -mulrA  H2.
    apply ler_mull with (x := 1%:Q) (y := z%:Q * (1%:Q / 3%:Q)) (z := z%:Q).
    rewrite le0r. apply /orP. right. apply sr3 => //.
    have H3: (ltn (S O) 2) by [].
    apply: ltn_trans. apply H3. apply H.
    apply ler_mull2 with (z := 3%:Q / 1%:Q).
    rewrite mulrC mul1r => //.
    have H3: (z%:Q * (1%:Q / 3%:Q) = 1%:Q / 3%:Q * z%:Q) by rewrite mulrC.
    rewrite H3 mulrA.
    have H4: (1%:Q / 3%:Q = (3%:Q / 1%:Q)^-1) by [].
    have H5: (3%:Q / 1%:Q * (1%:Q / 3%:Q) = 1) by rewrite mulrC H4 mulVr.
    rewrite H5 mul1r mulrC mul1r.
    have H6: (3%:Q / 1%:Q = 3%:Q) by []. rewrite H6.
    rewrite ler_nat. apply H.
  Qed.

  (* This is the main result when y = 1 *)
  Lemma r1 (z : nat) :
      z%:Q + 1 <= 5%:Q / 3%:Q + 1%:Q / 3%:Q * z%:Q ^+ 2.
  Proof.
    have H0: (z%:Q <= 2%:Q / 3%:Q +  1%:Q / 3%:Q * z%:Q ^+ 2).
    { case H: (leq 3 z).
      apply elimT with (P := (le 3 z)%N) in H.
      rewrite addrC.
      have H0: (z%:Q = z%:Q + 0%:Q) by rewrite addrC add0r => //.
      rewrite {1} H0. apply ler_add; auto.
      apply r1_1. move: H. move => /leP => //.
      apply /leP.
      apply negbT in H.  rewrite -ltnNge in H.
      apply leq_case in H. destruct H.
      have H1: (z = 2) by case: H. rewrite H1 => //.
      apply leq_case in H. destruct H.
      have H1: (z = S O) by case: H. rewrite H1 => //.
      apply leq_case in H. destruct H.
      have H1: (z = O) by case: H. rewrite H1 => //.
      rewrite ltn0 in H. congruence. }
    have H1: (5%:Q / 3%:Q = 2%:Q / 3%:Q + 1%:Q) by [].
    rewrite H1 -addrA [1%:~R + _] addrC addrA.
    apply ler_add; by [].
  Qed.

  (* ########################################################### *)
  (** * Main result *)

  Lemma result (y z : nat) :
      y%:Q * (z%:Q + 1) <=
      (5%:Q / 3%:Q) * y%:Q ^+ 2 + (1%:Q / 3%:Q) * z%:Q ^+ 2.
  Proof.
    case H: (leq 2 y).
    - (* y > 1 *)
      apply: subresult_implies_result => //.
      apply: subresult.
      (* other cases *)
      apply negbT in H. rewrite -leqNgt in H.
      apply leq_case in H. destruct H.
      + (* y = 1 *)
        rewrite H. rewrite mul1r. apply: r1.
      + (* y = 0*)
        rewrite leqn0 in H. move: H. move => /eqP H.
        rewrite H mul0r mulrC mul0r add0r.
        apply: mulr_ge0 => //. apply: sqr_ge0.
  Qed.

End Christodoulou.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_low_rfn_top_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 Ts, T2 = (t_rfn_top Ts) ->
                           subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import ZArith.
Require Import QArith.
Definition t : Type := Q * (option unit) * nat.

Definition tt : t := ((1, Some tt), O).


(* Movie Night

Four boys are at home to watch some movies. Figure out which is the favorite kind of movie of each one.

1. Joshua is in one of the ends.
2. The boy wearing the Black shirt is somewhere to the left of the youngest boy.
3. Joshua likes Horror movies.
4. The 14 years old boy is at third position.
5. The boy wearing the Red shirt is somewhere between the 13 years old boy and the one who likes Action movies, in that order.
6. Daniel likes Thriller movies.
7. The boy who is going to eat Cookies is in one of the ends.
8. The boy wearing the Black shirt is exactly to the left of the one who likes Thriller movies.
9. The boy who is going to eat Crackers is exactly to the right of the boy who likes Comedy movies.
10. The boy wearing the Red shirt is somewhere between the boy who is going to eat Popcorn and Nicholas, in that order.
11. In one of the ends is the boy who likes Thriller movies.
12. Nicholas is somewhere between Joshua and Daniel, in that order.
13. At first position is the boy wearing the Green shirt

Source: https://www.brainzilla.com/logic/zebra/movies-night/ *)

Inductive Name: Type :=
  | Joshua
  | Ryan
  | Nicholas
  | Daniel.

Inductive Shirt: Type :=
  | green
  | red
  | black
  | blue.

Inductive Movie: Type :=
  | horror
  | comedy
  | action
  | thriller.

Inductive Snack: Type :=
  | popcorn
  | chips
  | crackers
  | cookies.


(**

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.