(* NEXT: ===> ElemIncl                                                          *)

Require Import Le.
Require Import Plus.

Require Import Logic.Nat.Max.
Require Import Logic.Nat.Weaken.

Require Import Logic.Set.Set.
Require Import Logic.Set.Core.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Order.
Require Import Logic.Set.ToList.

(* We have already established that our inclusion relation <= is reflexive.     *)
(* In this module, we tackle a far more difficult property, namely proving that *)
(* <=  is a transitive relation. Obviously our definition would be useless if   *)
(* this property did not hold, so it is very important that we establish it. We *)
(* start with the inclusion statements which are relative to a natural number.  *)

Open Scope nat_scope.
Lemma incl_n_trans : forall (x y z:set) (n:nat),
    order x + order y + order z <= n ->
    incl_n n x y -> incl_n n y z -> incl_n n x z.
Proof.
    intros x y z n. revert x y z. induction n as [|n IH].
    - intros. apply I.
    - intros xs ys zs H1 H2 H3. destruct xs as [|x xs].
        + apply I.
        + simpl in H2. destruct H2 as [H2 [y [H4 [H5 H6]]]].
          simpl in H1. apply le_S_n in H1. simpl. split.
            { apply IH with ys.
                { apply weaken3_l with (max (order x) (order xs)).
                    { assumption. }
                    { apply m_le_max. }}
                { assumption. }
                { apply incl_le_m_n with (S n).
                    { apply weaken_l with (max (order x) (order xs) + order ys).
                        { assumption. }
                        { apply le_plus_r. }}
                    { apply le_S, le_n. }
                    { assumption. }}}
            { apply incl_n_incl in H3.
                { rewrite toListIncl in H3.
                  assert (y :: zs) as H7. { apply H3. assumption. }
                  rewrite toListElem in H7.
                  destruct H7 as [z [H7 [H8 H9]]].
                  exists z. split.
                    { assumption. }
                    { split.
                        { apply (incl_incl_n y z n) in H8.
                            { apply IH with y.
                                { apply weaken_r with (order zs).
                                    { apply weaken3_m with (order ys).
                                        { apply weaken3_l
                                          with (max (order x) (order xs)).
                                            { assumption. }
                                            { apply n_le_max. }}
                                        { apply orderToList. assumption. }}
                                    { apply orderToList. assumption. }}
                                { assumption. }
                                { assumption. }}
                            { apply le_trans with
                              (max (order x) (order xs) + order ys + order zs).
                                { rewrite <- plus_assoc.
                                  apply le_trans with (order ys + order zs).
                                    { apply le_trans with (order ys + order z).
                                        { apply plus_le_compat_r.
                                          apply orderToList. assumption. }
                                        { apply plus_le_compat_l.
                                          apply orderToList. assumption. }}
                                    { apply le_plus_r. }}
                                { assumption. }}}
                        { apply (incl_incl_n z y n) in H9.
                            { apply IH with y.
                                { remember (order z + order y) as e eqn:E.
                                  rewrite plus_comm. rewrite plus_comm in E.
                                  rewrite E. rewrite plus_assoc.
                                  apply weaken_r with (order zs).
                                    { apply weaken3_m with (order ys).
                                        { apply weaken3_l
                                          with (max (order x) (order xs)).
                                            { assumption. }
                                            { apply n_le_max. }}
                                        { apply orderToList. assumption. }}
                                    { apply orderToList. assumption. }}
                                { assumption. }
                                { assumption. }}
                            { rewrite plus_comm.
                              apply le_trans with
                              (max (order x) (order xs) + order ys + order zs).
                                { rewrite <- plus_assoc.
                                  apply le_trans with (order ys + order zs).
                                    { apply le_trans with (order ys + order z).
                                        { apply plus_le_compat_r.
                                          apply orderToList. assumption. }
                                        { apply plus_le_compat_l.
                                          apply orderToList. assumption. }}
                                    { apply le_plus_r. }}
                                { assumption. }}}}}
                { apply le_S. apply le_trans
                  with (max (order x) (order xs) + order ys + order zs).
                      { rewrite <- plus_assoc. apply le_plus_r. }
                      { assumption. }}}
Qed.

(* We can now extend the previous results to inclusion statements proper.       *)
Open Scope Set_Incl_scope.
Theorem inclTrans : forall (x y z:set),
    x <= y -> y <= z -> x <= z.
Proof.
    intros x y z H1 H2.
    remember (order x + order y + order z) as n eqn:E.
    apply incl_n_incl with n.
    - rewrite <- plus_assoc in E. rewrite E.
      apply plus_le_compat_l. apply le_plus_r.
    - apply incl_n_trans with y.
        + rewrite E. apply le_n.
        + apply incl_incl_n.
            { rewrite E. apply le_plus_l. }
            { assumption. }
        + apply incl_incl_n.
            { rewrite <- plus_assoc in E. rewrite E.
              apply le_plus_r. }
            { assumption. }
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import Reals.
Require Import Lra.
Require Import Tactiques.
Require Import Rbase_operations.
Require Import Rbase_inegalites.

Lemma penible : forall r r1 : R, r < r1 /\ - r1 < r -> - r1 < r < r1.
Proof.
intros.
split; elim H; intros; auto.
Qed.
Hint Resolve penible: real.

Lemma Rlt_2_Ropp : forall r r1 r2 : R, - r2 < - r < - r1 -> r1 < r < r2.
Proof.
intros.
elim H; intros.
split; apply Ropp_lt_cancel; auto.
Qed.
Hint Resolve Rlt_2_Ropp: real.

Lemma Rlt_2_Ropp_r : forall r r1 r2 : R, r2 < r < r1 -> - r1 < - r < - r2.
Proof.
intros.
elim H; intros.
split; apply Ropp_lt_contravar; auto.
Qed.
Hint Resolve Rlt_2_Ropp_r: real.

Lemma Rlt_2_le_lt_and :
 forall r r1 r2 r3 r4 : R, r1 < r < r2 -> r3 <= r1 /\ r2 < r4 -> r3 < r < r4.
Proof.
intros.
elim H; intros.
elim H0; intros.
split.
apply Rle_lt_trans with r1; auto.
apply Rlt_trans with r2; auto.
Qed.
Hint Resolve Rlt_2_le_lt_and: real.

Lemma Rlt_2_le_lt :
 forall r r1 r2 r3 r4 : R, r1 < r < r2 -> r3 <= r1 -> r2 < r4 -> r3 < r < r4.
Proof.
intros.
generalize (Rlt_2_le_lt_and r r1 r2 r3 r4); tauto.
Qed.
Hint Resolve Rlt_2_le_lt: real.

Lemma Rlt_le_2_gauss :
 forall r r1 : R,
 r1 - 1 * / 2 < r <= r1 + 1 * / 2 ->
 r - 1 <= r1 - 1 * / 2 /\ r1 + 1 * / 2 < r + 1.
Proof.
intros.
split.
apply Rle_sub_compatibility.
rewrite Rplus_comm; rewrite Rsub_sym; rewrite <- Rplus_assoc.
replace (1 + - (1 * / 2)) with (1 * / 2);
 [ idtac | field; apply Rgt_not_eq; lra ].
elim H; intros.
rewrite Rplus_comm; auto.

apply Rlt_add_compatibility2.
rewrite Rplus_comm; rewrite Rsub_sym; rewrite <- Rplus_assoc.
replace (-(1) + 1 * / 2) with (- (1 * / 2)) by
 ( field; apply Rgt_not_eq; lra).
rewrite <- Rsub_sym.
elim H; intros; assumption.
Qed.
Hint Resolve Rlt_le_2_gauss: real.

Lemma Rlt_2_Rmult_Rinv :
 forall r r1 r2 r3 : R, 0 < r -> r1 < r2 * r < r3 -> r1 * / r < r2 < r3 * / r.
Proof.
intros.
elim H0; intros; clear H0; split.
apply mega_nul; auto; rewrite Rmult_comm; auto.
apply Rmult_lt_reg_l with r; auto.
rewrite Rmult_comm; apply Rgt_lt; rewrite Rmult_comm;
 rewrite Rmult_assoc.
rewrite <- Rinv_l_sym;
 [ rewrite RIneq.Rmult_1_r; apply Rlt_gt; auto
 | apply Rgt_not_eq; apply Rlt_gt; auto ].
Qed.
Hint Resolve Rlt_2_Rmult_Rinv: real.

Lemma Rlt_2_monotony :
 forall r1 r2 r3 r4 r5 r6 : R,
 r1 < r2 < r3 -> r4 < r5 < r6 -> r1 + r4 < r2 + r5 < r3 + r6.
Proof.
intros.
elim H; intros; clear H.
elim H0; intros; clear H0.
split; auto with real.
Qed.
Hint Resolve Rlt_2_monotony: real.

Lemma Rlt_2_monotony_rev :
 forall r r1 r2 r3 : R, 0 < r -> r1 * r < r2 * r < r3 * r -> r1 < r2 < r3.
Proof.
intros.
elim H0; intros; clear H0.
split.
apply Rmult_lt_reg_l with r; auto.
rewrite Rmult_comm; apply Rgt_lt; rewrite Rmult_comm; apply Rlt_gt;
 auto.
apply Rmult_lt_reg_l with r; auto.
rewrite Rmult_comm; apply Rgt_lt; rewrite Rmult_comm; apply Rlt_gt;
 auto.
Qed.
Hint Resolve Rlt_2_monotony_rev: real.

Lemma Rabsolu_def3 : forall r r1 : R, Rabs r < r1 -> - r1 < r < r1.
Proof.
intros.
apply penible.
generalize H; apply Rabs_def2.
Qed.
Hint Resolve Rabsolu_def3: real.

Lemma Rle_lt_2_lt :
 forall r1 r2 r3 r4 r5 : R,
 r1 < r2 <= r3 -> r4 < r1 -> r3 < r5 -> r4 < r2 < r5.
Proof.
intros.
split.
apply Rlt_trans with r1; auto.
elim H; intros; auto.
apply Rle_lt_trans with r3; auto.
elim H; intros; auto.
Qed.
Hint Resolve Rle_lt_2_lt: real.

Lemma Rlt_2_monotony_contra :
 forall r r1 r2 r3 : R, r < 0 -> r * r3 < r * r2 < r * r1 -> r1 < r2 < r3.
Proof.
intros.
elim H0; intros.
split.
apply Rmult_lt_reg_l with (- r); auto with real.
do 2 rewrite Ropp_mult_distr_l_reverse; apply Ropp_lt_contravar; auto.
apply Rmult_lt_reg_l with (- r); auto with real.
do 2 rewrite Ropp_mult_distr_l_reverse; apply Ropp_lt_contravar; auto.
Qed.
Hint Resolve Rlt_2_monotony_contra: real.

Lemma Rle_2_Rlt_2 :
 forall r r1 r2 r3 r4 : R, r2 < r < r3 -> r1 <= r2 -> r3 <= r4 -> r1 < r < r4.
Proof.
intros.
elim H; intros; split.
apply Rle_lt_trans with r2; auto.
apply Rlt_le_trans with r3; auto.
Qed.
Hint Resolve Rle_2_Rlt_2: real.

Lemma Rle_mult_lt :
 forall r1 r2 r3 r4 r5 r6 : R,
 r1 < r2 < r5 ->
 r3 < r4 < r6 ->
 0 < r2 -> 0 <= r3 -> 0 <= r4 -> 0 < r5 -> r1 * r3 < r2 * r4 < r5 * r6.
Proof.
intros.
elim H; intros; clear H.
elim H0; intros; clear H0.
split; apply Rmult_le; auto with real.
Qed.
Hint Resolve Rle_mult_lt : real.

Lemma Rlt_2_trans :
 forall r1 r2 r3 r4 r5 : R,
 r1 < r2 < r3 -> r4 < r1 -> r3 < r5 -> r4 < r2 < r5.
Proof.
intros.
split.
apply Rlt_trans with r1; auto.
elim H; intros; auto.
apply Rlt_trans with r3; auto.
elim H; intros; auto.
Qed.
Hint Resolve Rlt_2_trans: real.

Lemma Rlt_2_minus_r :
 forall r r1 r2 r3 : R, r1 - r < r2 - r < r3 - r -> r1 < r2 < r3.
Proof.
intros.
elim H; intros.
split; apply Rplus_lt_reg_r with (- r); repeat rewrite <- Rsub_sym; auto.
Qed.
Hint Resolve Rlt_2_minus_r: real.

Lemma Rlt_2_Rinv :
 forall r1 r2 r3 : R,
 r1 > 0 -> r2 > 0 -> r3 > 0 -> r3 < r2 < r1 -> 1 * / r1 < 1 * / r2 < 1 * / r3.
Proof.
intros.
split; repeat rewrite Rmult_1l; apply Rinv_lt_contravar;
 [ apply Rmult_lt_0_compat; auto
 | elim H2; auto
 | apply Rmult_lt_0_compat; auto
 | elim H2; auto ].
Qed.
Hint Resolve Rlt_2_Rinv: real.

Lemma Rlt_2_to_Rlt : forall r1 r2 r3 : R, r1 < r2 < r3 -> r2 < r3.
Proof.
intros.
elim H; auto.
Qed.
Hint Resolve Rlt_2_to_Rlt: real.

Lemma Rlt_2_sqrt :
 forall r1 r2 r3 : R,
 0 <= r1 -> 0 <= r2 -> 0 <= r3 -> r1 < r2 < r3 -> sqrt r1 < sqrt r2 < sqrt r3.
Proof.
intros.
intuition; apply sqrt_lt_1; auto.
Qed.
Hint Resolve Rlt_2_sqrt: real.


Require Import Basics Types WildCat Truncations.Core Truncations.SeparatedTrunc
  Pointed.Core Pointed.pEquiv Pointed.Loops Pointed.pModality.

Local Open Scope pointed_scope.

(** * Truncations of pointed types *)

Definition pTr (n : trunc_index) (A : pType) : pType
  := [Tr n A, _].

(** We specialize [pto] and [pequiv_pto] from pModalities.v to truncations. *)

Definition ptr {n : trunc_index} {A : pType} : A ->* pTr n A
  := pto (Tr n) _.

Definition pequiv_ptr {n : trunc_index} {A : pType} `{IsTrunc n A}
  : A <~>* pTr n A := @pequiv_pto (Tr n) A _.

(** We could specialize [pO_rec] to give the following result, but since maps induced by truncation-recursion compute on elements of the form [tr _], we can give a better proof of pointedness than the one coming from [pO_rec]. *)
Definition pTr_rec n {X Y : pType} `{IsTrunc n Y} (f : X ->* Y)
  : pTr n X ->* Y
  := Build_pMap (pTr n X) Y (Trunc_rec f) (point_eq f).

(** Note that we get an equality of pointed functions here, without Funext, while [pO_rec_beta] only gives a pointed homotopy. This is because [pTr_rec] computes on elements of the form [tr _]. *)
Definition pTr_rec_beta_path n {X Y : pType} `{IsTrunc n Y} (f : X ->* Y)
  : pTr_rec n f o* ptr = f.
Proof.
  unfold pTr_rec, "o*"; cbn.
  (* Since [f] is definitionally equal to [Build_pMap _ _ f (point_eq f)], this works: *)
  apply (ap (Build_pMap _ _ f)).
  apply concat_1p.
Defined.

(** The version with a pointed homotopy. *)
Definition pTr_rec_beta n {X Y : pType} `{IsTrunc n Y} (f : X ->* Y)
  : pTr_rec n f o* ptr ==* f
  := phomotopy_path (pTr_rec_beta_path n f).

(** A pointed version of the induction principle. *)
Definition pTr_ind n {X : pType} {Y : pFam (pTr n X)} `{forall x, IsTrunc n (Y x)}
  (f : pForall X (Build_pFam (Y o tr) (dpoint Y)))
  : pForall (pTr n X) Y
  := Build_pForall (pTr n X) Y (Trunc_ind Y f) (dpoint_eq f).

Definition equiv_ptr_rec `{Funext} {n} {X Y : pType} `{IsTrunc n Y}
  : (pTr n X ->* Y) <~> (X ->* Y).
Proof.
  srapply equiv_adjointify.
  { intro f.
    exact (f o* ptr). }
  1: srapply pTr_rec.
  1: nrapply pTr_rec_beta_path.
  intro f.
  apply path_pforall.
  srapply Build_pHomotopy.
  1: by rapply Trunc_ind.
  cbn.
  symmetry; apply concat_pp_V.
Defined.

(** ** Functoriality of [pTr] *)

Global Instance is0functor_ptr n : Is0Functor (pTr n).
Proof.
  apply Build_Is0Functor.
  intros X Y f.
  exact (pTr_rec _ (ptr o* f)).
Defined.

Global Instance is1functor_ptr n : Is1Functor (pTr n).
Proof.
  apply Build_Is1Functor.
  - intros X Y f g p.
    srapply pTr_ind; cbn.
    snrapply Build_pForall.
    + cbn. exact (fun x => ap tr (p x)).
    + pointed_reduce.
      exact (concat_p1 _ @ concat_p1 _ @ ap _ (concat_p1 _))^.
  - intros X.
    srapply Build_pHomotopy.
    1: apply Trunc_rec_tr.
    cbn. reflexivity.
  - intros X Y Z f g.
    srapply Build_pHomotopy.
    1: by rapply Trunc_ind.
    by pointed_reduce.
Defined.

(** Naturality of [ptr].  Note that we get a equality of pointed functions, not just a pointed homotopy. *)
Definition ptr_natural_path (n : trunc_index) {X Y : pType} (f : X ->* Y)
  : fmap (pTr n) f o* ptr = ptr o* f
  := pTr_rec_beta_path n (ptr o* f).

(** The version with a pointed homotopy. *)
Definition ptr_natural (n : trunc_index) {X Y : pType} (f : X ->* Y)
  : fmap (pTr n) f o* ptr ==* ptr o* f
  := phomotopy_path (ptr_natural_path n f).

Definition ptr_functor_pconst {X Y : pType} n
  : fmap (pTr n) (@pconst X Y) ==* pconst.
Proof.
  srapply Build_pHomotopy.
  1: by rapply Trunc_ind.
  reflexivity.
Defined.

Definition ptr_pequiv {X Y : pType} (n : trunc_index) (f : X <~>* Y)
  : pTr n X <~>* pTr n Y
  := emap (pTr n) f.

Definition ptr_loops `{Univalence} (n : trunc_index) (A : pType)
  : pTr n (loops A) <~>* loops (pTr n.+1 A).
Proof.
  srapply Build_pEquiv'.
  1: apply equiv_path_Tr.
  reflexivity.
Defined.

Definition ptr_iterated_loops `{Univalence} (n : trunc_index)
  (k : nat) (A : pType)
  : pTr n (iterated_loops k A) <~>* iterated_loops k (pTr (trunc_index_inc' n k) A).
Proof.
  revert A n.
  induction k.
  { intros A n; cbn.
    reflexivity. }
  intros A n.
  cbn; etransitivity.
  1: apply ptr_loops.
  rapply (emap loops).
  apply IHk.
Defined.

Definition ptr_loops_eq `{Univalence} (n : trunc_index) (A : pType)
  : pTr n (loops A) = loops (pTr n.+1 A) :> pType
  := path_ptype (ptr_loops n A).

Definition pequiv_ptr_functor {X Y : pType} n
  : X <~>* Y -> pTr n X <~>* pTr n Y.
Proof.
  intro e.
  srapply Build_pEquiv.
  1: rapply (fmap (pTr _) e).
  exact _.
Defined.

(* This lemma generalizes a goal that appears in [ptr_loops_commutes], allowing us to prove it by path induction. *)
Definition path_Tr_commutes (n : trunc_index) (A : Type) (a0 a1 : A)
  : (@path_Tr n A a0 a1) o tr == ap tr.
Proof.
  intro p; induction p.
  reflexivity.
Defined.

(* [ptr_loops] commutes with the two [ptr] maps. *)
Definition ptr_loops_commutes `{Univalence} (n : trunc_index) (A : pType)
  : (ptr_loops n A) o* ptr ==* fmap loops ptr.
Proof.
  srapply Build_pHomotopy.
  - intro p.
    simpl.
    refine (_ @ _).
    + apply path_Tr_commutes.
    + symmetry; refine (_ @ _).
      * apply concat_1p.
      * apply concat_p1.
  - simpl.
    reflexivity.
Defined.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type :=   Zero : natural | Succ : natural -> natural .

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint fac (fac_arg0 : natural) : natural
           := match fac_arg0 with
              | Zero => Succ Zero
              | Succ n => mult (fac n) n
              end.

Fixpoint qfac (qfac_arg0 : natural) (qfac_arg1 : natural) : natural
           := match qfac_arg0, qfac_arg1 with
              | Zero, n => n
              | Succ n, m => qfac n (mult m n)
              end.
Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   -
   rewrite plus_zero. reflexivity.
   - simpl. lfind. Admitted.


Require Import prosa.classic.util.all prosa.classic.model.arrival.basic.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

(* In this file we provide extra definitions for job arrival sequences with jitter. *)
Module ArrivalSequenceWithJitter.

  Export ArrivalSequence.

  (* First, we identify the actual arrival time of a job. *)
  Section ActualArrival.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_jitter: Job -> time.

    (* Let j be any job. *)
    Variable j: Job.

    (* We define the actual arrival of job j as the time when the jitter ends. *)
    Definition actual_arrival := job_arrival j + job_jitter j.

    (* Next, we state whether the actual arrival of job j occurs in some interval [0, t], ... *)
    Definition jitter_has_passed (t: time) := actual_arrival <= t.

    (* ...along with the variants for interval [0, t), ... *)
    Definition actual_arrival_before (t: time) := actual_arrival < t.

    (* ...and interval [t1, t2). *)
    Definition actual_arrival_between (t1 t2: time) :=
      t1 <= actual_arrival < t2.

  End ActualArrival.

  (* In this section, we show how to compute the list of arriving jobs. *)
  Section ArrivingJobs.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_jitter: Job -> time.
    Variable arr_seq: arrival_sequence Job.

    (* For simplicity, let's define some local names. *)
    Let actual_job_arrival := actual_arrival job_arrival job_jitter.
    Let actual_job_arrival_between := actual_arrival_between job_arrival job_jitter.
    Let actual_job_arrival_before := actual_arrival_before job_arrival job_jitter.
    Let arrivals_before := jobs_arrived_before arr_seq.

    (* First, we define the actual job arrivals in the interval [t1, t2). *)
    Definition actual_arrivals_between (t1 t2: time) :=
      [seq j <- arrivals_before t2 | t1 <= actual_job_arrival j < t2].

    (* Similarly, we define the actual job arrivals up to time t... *)
    Definition actual_arrivals_up_to (t: time) := actual_arrivals_between 0 t.+1.

    (* ...and the actual job arrivals strictly before time t. *)
    Definition actual_arrivals_before (t: time) := actual_arrivals_between 0 t.

    (* In this section, we prove some lemmas about the arrival sequence prefixes. *)
    Section Lemmas.

      (* Assume that job arrival times are consistent. *)
      Hypothesis H_arrival_times_are_consistent:
        arrival_times_are_consistent job_arrival arr_seq.

      (* We begin with basic lemmas for manipulating the sequences. *)
      Section Basic.

        (* First, we show that the set of arriving jobs can be split
           into disjoint intervals. *)
        Lemma actual_arrivals_between_mem_cat:
          forall j t1 t t2,
            t1 <= t ->
            t <= t2 ->
            j \in actual_arrivals_between t1 t2 =
            (j \in actual_arrivals_between t1 t ++ actual_arrivals_between t t2).
        Proof.
          unfold actual_arrivals_between; intros j t1 t t2 GE LE.
          apply/idP/idP.
          {
            intros IN.
            rewrite mem_filter in IN; move: IN => /andP [/andP [GE1 LT2] IN].
            rewrite mem_cat; apply/orP.
            rewrite 2!mem_filter.
            case (ltnP (actual_job_arrival j) t) => [BEFORE | AFTER]; last by right; rewrite LT2.
            left; rewrite GE1 /=.
            have INarr: arrives_in arr_seq j by apply in_arrivals_implies_arrived in IN.
            apply arrived_between_implies_in_arrivals with (job_arrival0 := job_arrival);
              try (by done).
            by apply: (leq_ltn_trans _ BEFORE); apply leq_addr.
          }
          {
            rewrite mem_cat; move => /orP [LEFT | RIGHT].
            {
              rewrite mem_filter in LEFT; move: LEFT => /andP [ /andP [GE0 LT0] IN0].
              rewrite mem_filter GE0 /=.
              apply/andP; split; first by apply: (leq_trans _ LE).
              have INarr: arrives_in arr_seq j by apply in_arrivals_implies_arrived in IN0.
              apply arrived_between_implies_in_arrivals with (job_arrival0 := job_arrival);
                try (by done).
              rewrite /arrived_between /=.
              by apply: (leq_trans _ LE); apply: (leq_ltn_trans _ LT0); apply leq_addr.
            }
            {
              rewrite mem_filter in RIGHT; move: RIGHT => /andP [/andP [GE0 LT0] IN0].
              rewrite mem_filter LT0 /= andbT.
              apply/andP; split; first by apply: (leq_trans GE).
              have INarr: arrives_in arr_seq j by apply in_arrivals_implies_arrived in IN0.
              apply arrived_between_implies_in_arrivals with (job_arrival0 := job_arrival);
                try (by done).
              by apply: (leq_ltn_trans _ LT0); apply leq_addr.
            }
          }
        Qed.

        Lemma actual_arrivals_between_sub:
          forall j t1 t1' t2 t2',
            t1' <= t1 ->
            t2 <= t2' ->
            j \in actual_arrivals_between t1 t2 ->
            j \in actual_arrivals_between t1' t2'.
        Proof.
          intros j t1 t1' t2 t2' GE1 LE2 IN.
          rewrite mem_filter in IN; move: IN => /andP [/andP [GE LE] IN].
          move: (leq_total t1 t2) => /orP [BEFORE | AFTER]; last first.
          {
            suff BUG: t2 < t2 by rewrite ltnn in BUG.
            by apply: (leq_ltn_trans AFTER); apply: (leq_ltn_trans GE).
          }
          rewrite -> actual_arrivals_between_mem_cat with (t := t1);
            [| by done | by apply: (leq_trans BEFORE)].
          rewrite mem_cat; apply/orP; right.
          rewrite -> actual_arrivals_between_mem_cat with (t := t2);
            [| by done | by done].
          rewrite mem_cat; apply/orP; left.
          by rewrite mem_filter; repeat (apply/andP; split).
        Qed.

      End Basic.

      (* Next, we relate the arrival prefixes with job arrival times. *)
      Section ArrivalTimes.

        (* First, we prove that if a job belongs to the prefix (actual_arrivals_before t),
         then it arrives in the arrival sequence. *)
        Lemma in_actual_arrivals_between_implies_arrived:
          forall j t1 t2,
            j \in actual_arrivals_between t1 t2 ->
            arrives_in arr_seq j.
        Proof.
          rename H_arrival_times_are_consistent into CONS.
          intros j t1 t2 IN.
          rewrite mem_filter in IN; move: IN => /andP [_ IN].
          apply mem_bigcat_nat_exists in IN.
          by move: IN => [t0 /= [IN _]]; exists t0.
        Qed.

        Lemma in_actual_arrivals_before_implies_arrived:
          forall j t,
            j \in actual_arrivals_before t ->
            arrives_in arr_seq j.
        Proof.
          rename H_arrival_times_are_consistent into CONS.
          intros j t IN.
          rewrite mem_filter in IN; move: IN => /andP [_ IN].
          apply mem_bigcat_nat_exists in IN.
          by move: IN => [t0 /= [IN _]]; exists t0.
        Qed.

        (* Next, we prove that if a job belongs to the prefix (actual_arrivals_before t),
         then its actual job arrival occured before t. *)
        Lemma in_actual_arrivals_implies_arrived_before:
          forall j t,
            j \in actual_arrivals_before t ->
            actual_job_arrival_before j t.
        Proof.
          intros j t IN.
          by rewrite mem_filter /= in IN; move: IN => /andP [LTt _].
        Qed.

        (* We also prove that if a job belongs to the prefix (actual_arrivals_between t1 t2),
           then its actual job arrival occured between t1 and t2. *)
        Lemma in_actual_arrivals_implies_arrived_between:
          forall j t1 t2,
            j \in actual_arrivals_between t1 t2 ->
            actual_job_arrival_between j t1 t2.
        Proof.
          intros j t1 t2 IN.
          by rewrite mem_filter /= in IN; move: IN => /andP [LTt _].
        Qed.

        (* Similarly, we prove that if a job from the arrival sequence has actual arrival
         before time t, then it belongs to the sequence (actual_arrivals_before t). *)
        Lemma arrived_between_implies_in_actual_arrivals:
          forall j t1 t2,
            arrives_in arr_seq j ->
            actual_job_arrival_between j t1 t2 ->
            j \in actual_arrivals_between t1 t2.
        Proof.
          intros j t1 t2 IN BEFORE.
          rewrite mem_filter; apply/andP; split; first by done.
          eapply arrived_between_implies_in_arrivals; [by eauto | by done |].
          rewrite /arrived_between /=.
          move: BEFORE => /andP [_ LE].
          by apply: (leq_ltn_trans _ LE); apply leq_addr.
        Qed.

        (* Next, we prove that if the arrival sequence doesn't contain duplicate jobs,
         the same applies for any of its prefixes. *)
        Lemma actual_arrivals_uniq :
          arrival_sequence_is_a_set arr_seq ->
          forall t1 t2, uniq (actual_arrivals_between t1 t2).
        Proof.
          intros SET t1 t2.
          by eapply filter_uniq, arrivals_uniq, SET; eauto 1.
        Qed.

      End ArrivalTimes.

    End Lemmas.

  End ArrivingJobs.

End ArrivalSequenceWithJitter.


Require Import ILogic ILInsts SepAlgMap Maps Rel SepAlg BILogic BILInsts.
Require Import MapInterface MapFacts.
Require Import UUSepAlg SepAlgInsts.

Local Existing Instance ILFun_Ops.
Local Existing Instance ILFun_ILogic.

Definition myLogic := nat -> bool -> Prop.

Instance myLogicOps : ILogicOps myLogic := _.
Instance myLogicIL : ILogic myLogic := _.

Lemma test1 : forall P Q R, P //\\ Q //\\ R |-- Q //\\ R //\\ P.
Proof.
  intros.
  repeat apply landR.
  + apply landL2. apply landL1. reflexivity.
  + apply landL2. apply landL2. reflexivity.
  + apply landL1. reflexivity.
Qed.

(* You can make this connectives in the logic transparent by using this command. It is generally recommended
   that you do this as little as possible. You will in effect be reasoning in the model of the logic and not
   in the logic itself. Still, it is often necessary when proving the soundness of Hoare triples for instance.
*)
Transparent ILFun_Ops.

Lemma test2 : forall P Q R, P //\\ Q //\\ R |-- Q //\\ R //\\ P.
Proof.
  intros.
  intros n b H; simpl in *.
  intuition.
Qed.

(* Here the connectives are made opaque again. *)
Opaque ILFun_Ops.

(* Separation logic *)

Definition heap := Map [nat, nat].

Definition heap_unit : heap := @map_unit _ _ _ nat.

Local Existing Instance MapSepAlgOps.
Local Existing Instance MapSepAlg.
Local Existing Instance MapEquiv.
Local Existing Instance EquivPreorder.
Local Existing Instance UUMapSepAlg.
Local Existing Instance SepAlgOps_prod.
Local Existing Instance SepAlg_prod.
Local Existing Instance UUSepAlg_prod.

Instance RelHeap : Rel heap := _.
Instance HeapSepAlgOps : SepAlgOps heap := _.
Instance SepAlgHeap : SepAlg heap := _.
Instance UUSepAlgHeap : UUSepAlg heap := _.
Instance PreorderHeap : PreOrder (@rel heap RelHeap) := _.

Local Existing Instance ILPre_Ops.

Definition mySepLogic := ILPreFrm (@rel heap RelHeap) Prop.

Local Existing Instance ILPre_Ops.
Local Existing Instance SABIOps.
Local Existing Instance SABILogic.

Instance mySepLogicOps : BILOperators mySepLogic := _.
Instance mySepLogicBI : BILogic mySepLogic := _.

Lemma test3 : forall P Q R : mySepLogic, P ** Q |-- Q ** P.
Proof.
   intros.
   rewrite sepSPC1.
   apply bilsep.
   + reflexivity.
Qed.


Require Import List.

Require Import Logic.Class.Ord.

Require Import Logic.List.In.
Require Import Logic.List.Nub.
Require Import Logic.List.Sort.
Require Import Logic.List.Equiv.

(* Nubing a sorted list yields a sorted list.                                   *)
Lemma nubSorted : forall (a:Type) (o:Ord a) (xs:list a),
    Sorted xs -> Sorted (nub xs).
Proof.
    intros a o xs H. induction H as [|x|x y xs H1 H2 IH].
    - constructor.
    - constructor.
    - simpl. destruct (eqDec x y) as [H3|H3].
        + subst. exact IH.
        + destruct (in_dec eqDec y xs) as [H4|H4].
            { exact IH. }
            { simpl in IH. destruct (in_dec eqDec x xs) as [H5|H5].
                { apply sortedCons.
                    { intros z H6. apply leqTrans with x.
                        { apply sortedConsInLeq with xs.
                            { assumption. }
                            { rewrite nubInIff. exact H6. }} (* assumption fails *)
                        { assumption. }}
                    { assumption. }}
                { apply sortedCons.
                    { intros z [H6|H6].
                        { subst. assumption. }
                        { apply leqTrans with x.
                            { apply sortedConsInLeq with xs.
                                { assumption. }
                                { rewrite nubInIff. exact H6. }}
                            { assumption. }}}
                    { assumption. }}}
Qed.

(* Inserting a new element into a nubed list yields a nubed list.               *)
Lemma insertNubed : forall (a:Type) (o:Ord a) (x:a) (xs:list a),
    ~ x :: xs -> Nubed xs -> Nubed (insert x xs).
Proof.
    intros a o x xs H1 H. revert H1. revert x.
    induction H as [|x xs H1 H2 IH]; intros y H; simpl.
    - constructor.
        + assumption.
        + constructor.
    - destruct (leqDec y x) as [H3|H3].
        + constructor.
            { intros H4. destruct (insertEquivCons a o y xs) as [H5 H6].
              apply (H5 x) in H4. destruct H4 as [H4|H4].
                { subst. apply H. left. reflexivity. }
                { apply H1.  assumption. }}
            { apply IH. intros H4. apply H. right. assumption. }
        + constructor.
            { assumption. }
            { constructor; assumption. }
Qed.

(* Sorting a nubed list yields a nubed list.                                    *)
Lemma sortNubed : forall (a:Type) (o:Ord a) (xs:list a),
    Nubed xs -> Nubed (sort xs).
Proof.
    intros a o xs H. induction H as [|x xs H1 H2 IH]; simpl.
    - constructor.
    - apply insertNubed.
        + rewrite <- sortInIff. assumption.
        + assumption.
Qed.

(* Two sorted lists which are equivalent have identical heads.                  *)
Lemma sameHead : forall (a:Type) (o:Ord a) (x y:a) (xs ys:list a),
    cons x xs ==  cons y ys ->
    Sorted (cons x xs) ->
    Sorted (cons y ys) ->
    x = y.
Proof.
    intros a o x y xs ys [H1 H2] H3 H4. destruct (eqDec x y) as [H5|H5].
    - assumption.
    - apply leqAsym.
        + apply sortedConsInLeq with ys.
            { assumption. }
            { assert (In x (cons y ys)) as H6.
                { apply H1. left. reflexivity. }
              destruct H6 as [H6|H6].
                { exfalso. apply H5. symmetry. assumption. }
                { assumption. }}
        + apply sortedConsInLeq with xs.
            { assumption. }
            { assert (In y (cons x xs)) as H6.
                { apply H2. left. reflexivity. }
              destruct H6 as [H6|H6].
                  { exfalso.  apply H5. assumption. }
                  { assumption. }}
Qed.

(* Two sorted and nubed lists which are equivalent are identical.               *)
Lemma nubedSortedEquivSame : forall (a:Type) (o:Ord a) (xs ys:list a),
    Nubed xs  ->
    Nubed ys  ->
    Sorted xs ->
    Sorted ys ->
    xs == ys  ->
    xs = ys.
Proof.
    intros a o xs ys H. revert ys. induction H as [|x xs H1 H2 IH];
    intros ys H3 H4 H5 H6.
    - symmetry. apply equivSym in H6. apply equivNil. assumption.
    - destruct ys as [|y ys].
        + apply equivNil. assumption.
        + assert (xs = ys) as H7.
            { apply IH.
                { apply (nubedConsNubedTail a _ y). assumption. }
                { apply sortedConsSortedTail with x. assumption. }
                { apply sortedConsSortedTail with y. assumption. }
                { split; intros u H8.
                    { assert (In u (cons y ys)) as H9.
                        { apply H6. right.  assumption. }
                      destruct H9 as [H9|H9].
                        { subst. exfalso. apply H1.
                            assert (x = u) as H10.
                                { apply (sameHead a o _ _ xs ys); assumption. }
                          subst. assumption. }
                        { assumption. }}
                    { assert (In u (cons x xs)) as H11.
                        { destruct H6 as [H6 H12]. apply H12. right. assumption. }
                      destruct H11 as [H11|H11].
                        { assert (x = y).
                            { apply (sameHead a o _ _ xs ys); assumption. }
                          subst. exfalso. apply (nubedConsNotIn a _ y ys) in H3.
                          apply H3. assumption. }
                        { assumption. }}}}
          assert (x = y) as H8. { apply (sameHead a o _ _ xs ys); assumption. }
          subst. reflexivity.
Qed.

(* Nubing and sorting commute with each other.                                  *)
Lemma nubSortCommute : forall (a:Type) (o:Ord a) (xs:list a),
    nub (sort xs) = sort (nub xs).
Proof.
    intros a o xs. apply (nubedSortedEquivSame a _).
    - apply nubNubed.
    - apply sortNubed. apply nubNubed.
    - apply nubSorted. apply sortSorted.
    - apply sortSorted.
    - apply equivTrans with xs.
        + apply equivTrans with (sort xs).
            { apply nubEquiv.  }
            { apply sortEquiv. }
        + apply equivTrans with (nub xs).
            { apply equivSym. apply nubEquiv.  }
            { apply equivSym. apply sortEquiv. }
Qed.

(* Normalizing a list: simply sorting and nubing.                               *)
Definition normal (a:Type) (o:Ord a) (xs:list a) : list a := sort (nub xs).

Arguments normal {a} {o}.

(* Predicate expressing the fact that a list is in normal form:                 *)
(* A list is in normal form when it has been nubed and sorted.                  *)
Definition Normal (a:Type) (o:Ord a) (xs:list a) : Prop := Nubed xs /\ Sorted xs.

Arguments Normal {a} {o}.

(* A list is equivalent to its normal form                                      *)
Lemma normalEquiv : forall (a:Type) (o:Ord a) (xs:list a), normal xs == xs.
Proof.
    intros a o xs. unfold normal. apply equivTrans with (nub xs).
    - apply sortEquiv.
    - apply nubEquiv.
Qed.

(* The normal form is in normal form.                                           *)
Lemma normalNormal : forall (a:Type) (o:Ord a) (xs:list a), Normal (normal xs).
Proof.
    intros a o xs. unfold normal. split.
    - apply sortNubed. apply nubNubed.
    - apply sortSorted.
Qed.

(* Two equivalent lists in normal form are equal.                               *)
Lemma normalEquivSame : forall (a:Type) (o:Ord a) (xs ys:list a),
    Normal xs -> Normal ys -> xs == ys -> xs = ys.
Proof.
    intros a o xs ys [H1 H2] [H3 H4] H5.
    apply (nubedSortedEquivSame a _); assumption.
Qed.

(* The predicate Normal has the right semantics in relation to normal.          *)
(* A list is in normal form if and only if it is equal to its normal form.      *)
Lemma normalCheck : forall (a:Type) (o:Ord a) (xs:list a),
    Normal xs <-> normal xs = xs.
Proof.
    intros a o xs. split; intro H.
    - apply (normalEquivSame a _).
        + apply normalNormal.
        + assumption.
        + apply normalEquiv.
    - rewrite <- H. apply normalNormal.
Qed.

(* Equivalence between lists is equivalent to equality of their normal forms.   *)
Lemma normalCharac : forall (a:Type) (o:Ord a) (xs ys:list a),
    xs == ys <-> normal xs = normal ys.
Proof.
    intros a o xs ys. split; intros H.
    - apply (normalEquivSame a _).
        + apply normalNormal.
        + apply normalNormal.
        + apply equivTrans with xs.
            { apply normalEquiv. }
            { apply equivTrans with ys.
                { assumption. }
                { apply equivSym, normalEquiv. }}
    - apply equivTrans with (normal xs).
        + apply equivSym, normalEquiv.
        + rewrite H. apply normalEquiv.
Qed.


(* DM : Equivalence des sémantiques petits et grands pas*)

(* Ce DM est la suite du TP4; la première partie du fichier correspond simplement au corrigé du TP4.
Les définitions pour les sémantiques opérationnelles petit et grand pas sont données, ainsi que les preuves
de l'implication grand pas -> petit pas.
Le but du DM est de montrer l'autre sens de l'implication: grand pas -> petit pas. Puis de
montrer le déterminisme de la sémantique à grand pas. *)

(* PREMIÈRE PARTIE : rappel des définitions pour la sémantique de IMP,
  preuves des lemmes prouvant l'implication execute => ss *)
(* IL N'Y A RIEN À COMPLÉTER DANS CETTE PARTIE *)

Require Import List.

(* Les valeurs calculées seront des entiers. *)
Definition value := nat.
(* Les addresses seront implémentées par des entiers. *)
Definition addr := nat.
(* La mémoire sera représentée par une liste de couples adresse/valeur *)
Definition env := list (addr * value).

(* Le prédicat (get l a x) signifie que (a,x) ∈ l.
   Il est axiomatisé par les règles suivantes :
                                    get l a x
  ────────────────── head  a≠b ──────────────────── tail
  get ((a,x)::l) a x            get ((b,y)::l) a x

*)
Inductive get : env -> addr -> value -> Prop :=
| get_head : forall a x l, get ((a,x)::l) a x
| get_tail : forall a x b y l, get l a x->~a=b->get ((b,y)::l) a x.

(* Le prédicat (update l a y l') signifie que l' est obtenu en
   remplaçant la première occurence de (a,_) dans l par (a,y). *)
(*
                                                       update l a x l'
  ──────────────────────────────── head  a≠b ────────────────────────────────── tail
  update ((a,x)::l) a y ((a,y)::l)            update ((b,y)::l) a x ((b,y)::l')

*)
Inductive update : env -> addr -> value -> env -> Prop :=
|update_head : forall a x l y, update ((a,x)::l) a y ((a,y)::l)
|update_tail : forall a x l' b y l, update l a x l' -> ~a=b -> update ((b,y)::l) a x ((b,y)::l').

(* Les termes arithmétiques du langage sont donnés par
   la grammaire suivante *)
Inductive aexpr : Type :=
   | zero : aexpr
   | var : addr -> aexpr
   | succ : aexpr -> aexpr
   | pred : aexpr -> aexpr.

(* On a aussi des expressions booleens*)
Inductive bexpr : Type :=
   | blt : aexpr -> aexpr -> bexpr
   | bneq : aexpr -> aexpr -> bexpr.

(* Les programmes sont donnés par : *)
Inductive prg : Type :=
   | skip : prg
   | seq : prg -> prg -> prg
   | ass : addr -> aexpr -> prg
   | ifte : bexpr -> prg -> prg -> prg
   | while : bexpr -> prg -> prg.

Notation "# x" := (var x) (at level 0).
Notation "x << y" := (blt x y) (at level 70).
Notation "x <<>> y" := (bneq x y) (at level 70).
Notation "A ; B" := (seq A B) (at level 100, right associativity).
Notation "A <- B" := (ass A B) (at level 80, right associativity).

(* Sémantique grand pas pour les expressions arithmetiques:
                         get ρ x n              <ρ|t> ⇓ n
  ──────────── zero    ───────────── var   ────────────────── succ
  <ρ|zero> ⇓ 0         <ρ|var x> ⇓ n       <ρ|succ t> ⇓ (S n)

        <ρ|t> ⇓ (S n)              <ρ|t> ⇓ 0
       ────────────── pred_S    ────────────── pred_0
       <ρ|pred t> ⇓ n           <ρ|pred t> ⇓ 0

 *)

Inductive aeval : env -> aexpr -> value -> Prop :=
|aeval_zero : forall l, aeval l zero 0
|aeval_var : forall l x n, get l x n->aeval l #x n
|aeval_succ : forall l t n, aeval l t n->aeval l (succ t) (S n)
|aeval_pred_S : forall l t n, aeval l t (S n)->aeval l (pred t) n
|aeval_pred_0 : forall l t, aeval l t 0-> aeval l (pred t) 0.
(*Sémantique grand pas pour les expressions booleenes.*)
(*
   <ρ|x> ⇓ n   <ρ|y> ⇓ m   n < m
  ───────────────────────────────
         <ρ|x<<y> ⇓ true

   <ρ|x> ⇓ n   <ρ|y> ⇓ m   m <= n
  ───────────────────────────────
         <ρ|x<<y> ⇓ false
*)

Inductive beval : env -> bexpr -> bool -> Prop :=
|beval_true : forall rho x n m y, aeval rho x n-> aeval rho y m-> n<m -> beval rho (x<<y) true
|beval_false : forall rho x n y m, aeval rho x n->aeval rho y m->m<=n->beval rho (x<<y) false
|beval_true_neq : forall rho x n y m, aeval rho x n->aeval rho y m->n<>m->beval rho (x<<>>y) true
|beval_false_neq : forall rho x n y m, aeval rho x n->aeval rho y m->n=m->beval rho (x<<>>y) false.

(* Sémantique grand pas pour les programmes. *)
Inductive execute : env -> prg -> env -> Prop :=
|execute_skip : forall sigma, execute sigma skip sigma
|execute_seq : forall o o' o'' c1 c2, execute o c1 o'->execute o' c2 o''->execute o (c1;c2) o''
|execute_ifte_t : forall c1 c2 o o' b, beval o b true->execute o c1 o'->execute o (ifte b c1 c2) o'
|execute_ifte_f : forall c1 c2 o o' b, beval o b false->execute o c2 o'->execute o (ifte b c1 c2) o'
|execute_while_false : forall b c o, beval o b false->execute o (while b c) o
|execute_while_true : forall b o o' c o'', beval o b true->execute o c o'->execute o' (while b c) o''->execute o (while b c) o''
|execute_assign : forall o o' x a n, aeval o a n->update o x n o'->execute o (x<-a) o'.

Check sym_eq.
Check plus_n_Sm.

(* On maintenant s'intéresser à une sémantique à petits pas
   en montrer son équivalence avec la sémantique à grands pas
   donnée par execute *)
Reserved Notation "A => B" (at level 80).

Definition state := (prg * env)%type.
Notation "[ π | p ]" := (π,p).

Inductive ss : state -> state -> Prop :=
  | ss_ass : forall s s' i a x, aeval s a x -> update s i x s' -> [i <- a | s] => [skip | s']
  | ss_seq_skip : forall s c, [skip ; c | s] => [ c | s ]
  | ss_seq_seq : forall s s' c c' d, [c | s] => [c'|s'] -> [c ; d|s] => [ c' ; d | s']
  | ss_ifte_true : forall s b c d, beval s b true -> [ ifte b c d | s ] => [ c | s ]
  | ss_ifte_false : forall s b c d, beval s b false -> [ ifte b c d | s ] => [ d | s ]
  | ss_while : forall s b c, [ while b c | s ] => [ ifte b (c ; while b c) skip | s ]
where "A => B" := (ss A B).

(* L'évaluation d'un programme correspond à la clôture
   réflexive transitive de la sémantique à petit-pas.
   La définir inductivement permet de raisonner
   dessus plus facilement.
*)

Section Star.
Variable A : Type.
Variable R : A -> A -> Prop.

Inductive star : A -> A -> Prop :=
  | star_refl : forall a, star a a
  | star_R : forall a b c, R a b -> star b c -> star a c.

Lemma star_trans : forall a b c, star a b -> star b c -> star a c.
intros.
Proof.
induction H.
apply H0.
apply star_R with b.
apply H.
apply IHstar.
apply H0.
Qed.

End Star.

Notation "A =>* B" := (star _ ss A B) (at level 20).

(* On va maintenant montrer l'équivalence entre les deux sémantiques. *)

(* On commence par grands pas -> petits pas. *)
(* Le séquencement ';' est géré de manière différente
   par les deux sémantiques : *)
Check execute_seq.
Check ss_seq_skip.
Check ss_seq_seq.

(* On va montrer que =>* peut traiter ';' de manière similaire
   à ss_seq_seq :
     pour tous p q r e1 e2,
   [p | e1] =>* [q | e2] -> [p ; r | e1] =>* [q ; r | e2]
*)

(* La tactique [induction H] est insuffisante
   pour certains prédicats inductifs dépendants.
   Commencez par décommenter les lignes suivantes
   et essayer de continuer la preuve ...
*)
(*
Goal forall p q r e1 e2,
  [p | e1] =>* [q | e2] -> [p ; r | e1] =>* [q ; r | e2].
intros. induction H.
...
*)
(* Cette difficulté se résoud en renforcant le principe d'induction.
   On utilise pour cela la tactique [assert P].
*)

(* Astuce : la tactique [injection H] permet d'utiliser l'injectivité
     des constructeurs (en particulier du constructeur de paires)
*)

Lemma seq_trans : forall p q r e1 e2,
  [p | e1] =>* [q | e2] -> [p ; r | e1] =>* [q ; r | e2].
assert (H : forall s1 s2, s1 =>* s2 -> forall p q r e1 e2,
  s1 = [ p | e1 ] -> s2 = [ q | e2 ] -> [ p ; r | e1 ] =>* [ q ; r | e2 ]).
Proof.
intros s1 s2 H.
induction H.
- intros.
  rewrite H in H0.
  injection H0.
  intros.
  rewrite H1.
  rewrite H2.
  apply star_refl.
- intros.
  inversion H.
  + rewrite H1 in H5.
    injection H5.
    intros.
    rewrite <-H8.
    rewrite <-H7.
    apply star_R with [skip;r|s'].
    apply ss_seq_seq.
    apply ss_ass with x.
    apply H3.
    apply H4.
    apply IHstar.
    symmetry in H6.
    apply H6.
    apply H2.
  + rewrite H1 in H3.
    injection H3.
    intros.
    symmetry in H6.
    rewrite H6.
    symmetry in H5.
    rewrite H5.
    symmetry in H4.
    apply star_R with [c0;r|s].
    apply ss_seq_seq.
    apply ss_seq_skip.
    apply IHstar.
    apply H4.
    apply H2.
  + rewrite H1 in H4.
    injection H4.
    intros.
    symmetry in H7.
    rewrite H7.
    symmetry in H6.
    rewrite H6.
    apply star_R with [(c';d);r|s'].
    apply ss_seq_seq.
    apply ss_seq_seq.
    apply H3.
    apply IHstar.
    symmetry.
    apply H5.
    apply H2.
  + rewrite H1 in H4.
    injection H4.
    intros.
    symmetry in H7.
    rewrite H7.
    apply star_R with [c0;r|s].
    symmetry in H6.
    rewrite H6.
    apply ss_seq_seq.
    apply ss_ifte_true.
    apply H3.
    apply IHstar.
    symmetry.
    apply H5.
    apply H2.
  + rewrite H1 in H4.
    injection H4.
    intros.
    symmetry in H7.
    rewrite H7.
    symmetry in H6.
    rewrite H6.
    apply star_R with [d;r|s].
    apply ss_seq_seq.
    apply ss_ifte_false.
    apply H3.
    apply IHstar.
    symmetry; apply H5.
    apply H2.
  + rewrite H1 in H3.
    injection H3; intros.
    subst.
    apply star_R with [ifte b0 (c0; while b0 c0) skip ; r|e1]; try trivial.
    apply ss_seq_seq.
    apply ss_while.
    apply IHstar.
    reflexivity.
    reflexivity.
- intros.
  apply H with [p|e1] [q|e2].
  apply H0.
  repeat reflexivity.
  reflexivity.
Qed.

Lemma skip_exe_neutre : forall p e1 e2, execute e1 p e2 <-> execute e1 (p;skip) e2.
Proof.
intros.
split.
intros.
apply execute_seq with e2.
apply H.
apply execute_skip.
intros.
inversion H.
inversion H5.
symmetry in H8; rewrite H8.
apply H3.
Qed.

(* Vous pouvez maintenant montrer que *)
Lemma execute_sse : forall p e1 e2,
  execute e1 p e2 -> [p | e1] =>* [skip | e2].
Proof.
intros.
induction H.
apply star_refl.
apply star_trans with [skip;c2|o'].
apply seq_trans.
apply IHexecute1.
apply star_R with [c2|o'].
apply ss_seq_skip.
apply IHexecute2.
apply star_R with [c1|o].
apply ss_ifte_true.
apply H.
apply IHexecute.
apply star_R with [c2|o].
apply ss_ifte_false.
apply H.
apply IHexecute.
apply star_R with [ifte b (c; while b c) skip|o].
apply ss_while.
apply star_R with [skip|o].
apply ss_ifte_false.
apply H.
apply star_refl.
apply star_R with [ifte b (c; while b c) skip|o].
apply ss_while.
apply star_R with [c;while b c|o].
apply ss_ifte_true.
apply H.
apply star_trans with [skip;while b c|o'].
apply seq_trans.
apply IHexecute1.
apply star_R with [while b c|o'].
apply ss_seq_skip.
apply IHexecute2.
apply star_R with [skip|o'].
apply ss_ass with n.
apply H.
apply H0.
apply star_refl.
Qed.

(* DEUXIÈME PARTIE : preuve de l'implication ss => execute *)
(* TOUTES LES PREUVES DANS CETTE PARTIE DOIVENT ÊTRE COMPLÉTÉES.
  N'HÉSITEZ PAS À SUIVRE LES INDICATIONS DONNÉES, ET ÉVENTUELLEMENT
  À FAIRE LA PREUVE SUR PAPIER POUR NE PAS PERDRE LE FIL *)

(* L'objetif est de montrer le lemme ss_execute, qui dit que si
  [p | e1] =>* [skip | e2], alors execute e1 p e2 *)
(* Pour gérer l'induction sur la longueur de la réduction =>*,
  on commence par prouver le lemme ss_execute_aux, qui traite le cas d'une
  seule réduction => :
  si [p1 | e1] => [p2 | e2], alors pour tout e3,
  execute e2 p2 e3 implique execute e2 p1 e3 *)

(* Prouvons tout d'abord les quatre lemmes suivants afin de se faciliter
  la tâche lors de la preuve de ss_execute_aux *)

(* La preuve semble ici très simple : execute e2 skip e3
  ne peut provenir que de la règle execute_skip, et on doit
  alors avoir e2 = e3. *)
(* La tactique inversion, appliquée sur l'hypothèse
  execute e2 skip e3, est en fait une version améliorée du destruct.
  Elle génère un cas pour chaque constructeur (règle) de execute,
  conserve les égalités pour les arguments de execute, puis élimine
  si possible les cas menant à une contradiction *)
(* Ici, inversion va générer un cas pour chaque règle de execute,
  mais seule la règle execute_skip est conservée car les autres
  mènent à une contradiction.*)

(* N'oubliez pas d'aider Coq lorsque sa tactique apply H ne permet
  pas de deviner tous les arguments de H :
- apply H with t : lorsque H n'a qu'un seul argument non inféré
  par apply : on lui dit alors de prendre le terme t.
- apply H with (x1 := t1) (x2 := t2) ... (xn := tn), lorsque H
  possède n arguments x1 x2 ... xn (les désigner par le nom qu'ils portent
  dans le "forall ..." du type de H) qu'apply n'a pas pu inférer.
*)

Lemma ss_execute_aux_ass : forall e1 e2 e3 i a x,
  aeval e1 a x -> update e1 i x e2 ->
  execute e2 skip e3 -> execute e1 (i <- a) e3.
Proof.
  intros.
  inversion H1.
  apply execute_assign with x.
  apply H.
  symmetry in H4.
  rewrite H4.
  apply H0.
Qed.

(* rien à signaler *)
Lemma ss_execute_aux_seq_skip : forall e1 e2 c,
  execute e1 c e2 -> execute e1 (skip; c) e2.
Proof.
  intros.
  apply execute_seq with e1.
  apply execute_skip.
  apply H.
Qed.

(* Là encore, inversion permettra de déduire toutes les informations
  utiles de execute e2 (c'; d) e2. *)
Lemma ss_execute_aux_seq_seq : forall e1 e2 e3 c c' d,
  (forall e, execute e2 c' e -> execute e1 c e) ->
  execute e2 (c'; d) e3 -> execute e1 (c; d) e3.
Proof.
  intros.
  inversion H0.
  apply execute_seq with o'.
  apply H.
  apply H4.
  apply H6.
Qed.

(* Le cas du while est un tout petit peu plus délicat que les autres,
  car la sémantique ss n'utilise qu'un constructeur pour while, tandis que
  execute en a deux0 *)
(* une bonne utilisation de inversion doit ici générer deux cas, reflétant
  deux constructeurs de execute, l'un dans le cas où b est vrai, l'autre
  lorsqu'il est faux. *)
Lemma ss_execute_aux_while : forall e1 e2 b c,
  execute e1 (ifte b (c; while b c) skip) e2 -> execute e1 (while b c) e2.
Proof.
  intros.
  inversion H.
  inversion H6.
  Print execute.
  apply execute_while_true with o'0.
  apply H5.
  apply H10.
  apply H12.
  inversion H6.
  rewrite<- H9.
  apply execute_while_false.
  apply H5.
Qed.

(* On peut maintenant passer à la preuve de ss_execute_aux. *)
(* Vous pouvez essayer de continuer la preuve commençant
  directement par une induction : *)
(*
Lemma ss_execute_aux : forall p1 p2 e1 e2,
  [p1 | e1] => [p2 | e2] ->
  forall e3, execute e2 p2 e3 -> execute e1 p1 e3.
Proof.
intros until 1. induction H.
intros.
*)
(* On remarque que induction semble perdre des informations
  très utiles en cours de route : des corrélations entre certains
  termes disparaissent lorsque les termes sont remplacés par des
  variables génériques sans corrélations particulières. *)
(* Afin de conserver ces corrélations (comme inversion le fait là où
  destruct perd ces informations), on propose de réécrire le lemme
  à prouver à l'aide d'une formulation H qui introduit explicitement
  les égalités que l'on souhaite conserver lors du passage à l'induction. *)

Lemma ss_execute_aux : forall p1 p2 e1 e2,
  [p1 | e1] => [p2 | e2] ->
  forall e3, execute e2 p2 e3 -> execute e1 p1 e3.
Proof.

assert (H: forall s1 s2, s1=>s2 -> forall p1 p2 e1 e2, s1=[p1|e1] ->
s2=[p2|e2]-> forall e3, execute e2 p2 e3 ->execute e1 p1 e3).

+
  intros until 1.
  induction H.
  *
    intros.
    inversion H1.
    inversion H2.
    apply ss_execute_aux_ass with (x:=x) (e2:=s').
    rewrite<- H6.
    apply H.
    rewrite<- H6.
    apply H0.
    rewrite H7,H8.
    apply H3.
  *
    intros.
    inversion H.
    inversion H0.
    apply ss_execute_aux_seq_skip.
    rewrite <-H4,H6.
    apply H1.
  *
    intros.
    inversion H0.
    inversion H1.
    apply ss_execute_aux_seq_seq with (e2:=e2) (c':=c').
    apply IHss.
    rewrite H5.
    reflexivity.
    rewrite H7.
    reflexivity.
    rewrite H6.
    apply H2.
  *
    intros.
    inversion H0.
    inversion H1.
    apply execute_ifte_t.
    rewrite<- H5.
    apply H.
    rewrite<- H5.
    rewrite H7.
    apply H2.
  *
    intros.
    inversion H0.
    inversion H1.
    apply execute_ifte_f.
    rewrite<- H5.
    apply H.
    rewrite<- H5.
    rewrite H7.
    apply H2.
  *
    intros.
    inversion H.
    inversion H0.
    apply ss_execute_aux_while.
    rewrite H4 in H6.
    rewrite H6,H5.
    apply H1.

+
  intros.
  apply H with (s1:=[p1|e1])(s2:=[p2|e2])(p2:=p2)(e2:=e2).
  apply H0.
  reflexivity.
  reflexivity.
  apply H1.
Qed.

(* On termine enfin la preuve que ss implique execute *)
(* Pour rappel, la clôture réflexive transitive de =>, notée =>*,
  a été définie plus haut, dans la section Star de la partie 1. *)
(* Attention à l'utilisation brutale de l'induction, qui risque de faire
  disparaître des corrélations essentielles ! *)
(* Pour cela, on pourra généraliser l'énoncé avec un assert H qui introduit
  explicitement les égalités à conserver. N'hésitez pas à vous inspirer de
  ce qui a été fait pour ss_execute_aux. *)

Lemma sse_execute : forall p e1 e2,
  [ p | e1 ] =>*  [ skip | e2 ] -> execute e1 p e2.
Proof.
  assert (H:forall s1 s2:state,
             s1=>* s2 ->
             forall p e1 e2,
               s1 = [p|e1] -> s2 = [skip|e2] -> execute e1 p e2).
  +
  intros until 1.
  induction H.
    *
      intros.
      rewrite H in H0.
      inversion H0.
      apply execute_skip.
    *
      intros.
      destruct b.
      apply ss_execute_aux with (p2:=p0)(e2:=e).
      rewrite<- H1.
      apply H.
      apply IHstar.
      reflexivity.
      apply H2.
  +
    intros.
    apply H with (s1:=[p|e1])(s2:=[skip|e2]).
    apply H0.
    reflexivity.
    reflexivity.
Qed.

(* TROISIÈME PARTIE : déterminisme de la sémantique de IMP *)
(* TOUTES LES PREUVES DANS CETTE PARTIE DOIVENT ÊTRE COMPLÉTÉES.
  N'HÉSITEZ PAS À SUIVRE LES INDICATIONS DONNÉES, ET ÉVENTUELLEMENT
  À FAIRE LA PREUVE SUR PAPIER POUR NE PAS PERDRE LE FIL *)

(* Dans cette partie à nouveau, inversion joue un rôle clé pour
  extraire toutes les informations d'un type inductif dépendant *)
(* Astuce : si les hypothèses contiennent H1 : a = b et H2 : a <> b,
  alors le but doit pouvoir se prouver automatiquement puisqu'on a
  une contradiction. Pour cela, étant donné que (H2 H1) a le type False,
  on pourra simplement invoquer destruct (H2 H1). *)
(* Si on a une contradiction du type H : 0 = S n, ou toute autre égalité
  où les constructeurs ne peuvent pas correspondre, on pourra conclure
  avec discriminate H *)
(* La tactique replace t with u remplace dans le but courant le terme t
  par le terme u. L'égalité t = u sera alors prouvée dans un but ultérieur.
  replace t with u in H permet de faire la même chose dans l'hypothèse H *)

Lemma get_det : forall s a v1, get s a v1 -> forall v2, get s a v2 -> v2 = v1.
Proof.
  intros.
  induction H.
  inversion H0.
  reflexivity.
  destruct H6.
  reflexivity.
  apply IHget.
  inversion H0.
  symmetry in H2.
  destruct (H1 H2).
  apply H7.
Qed.

Lemma update_det : forall s a v s1, update s a v s1 -> forall s2, update s a v s2 -> s2 = s1.
Proof.
  intros until 1.
  induction H.
  intros.
  inversion H.
  reflexivity.
  destruct H7.
  reflexivity.

  intros.
  inversion H1.
  symmetry in H2.
  destruct (H0 H2).
  assert (HH:l'0 = l').
  apply IHupdate.
  apply H8.
  rewrite HH.
  reflexivity.
Qed.

Lemma succ_inj : forall m n, S m = S n -> m = n.
Proof.
intros.
inversion H.
reflexivity.
Qed.

Lemma aeval_det : forall a s n1, aeval s a n1 -> forall n2, aeval s a n2 -> n2 = n1.
Proof.
  intros until 1.
  induction H.
  intros.
  inversion H.
  reflexivity.

  intros.
  inversion H0.
  subst.
  apply get_det with (s:=l)(a:=x).
  assumption.
  assumption.

  intros.
  inversion H0.
  subst.
  assert(n0=n).
  apply IHaeval.
  assumption.
  rewrite H1.
  reflexivity.

  intros.
  inversion H0.
  subst.
  assert(S n2 = S n).
  apply IHaeval.
  assumption.
  inversion H1.
  reflexivity.

  subst.
  apply IHaeval in H3.
  inversion H3.

  intros.
  inversion H0.
  subst.
  apply IHaeval in H3.
  inversion H3.

  reflexivity.

Qed.

Require Le.
Lemma beval_det : forall a s b1, beval s a b1 -> forall b2, beval s a b2 -> b2 = b1.
Proof.
  intros a s.
  induction a.
  intros.
  inversion H.
  inversion H0.
  reflexivity.
  subst.
  assert(HH:n0=n).
  apply aeval_det with (a:=a)(s:=s).
  apply H3.
  apply H10.

  assert(HHH:m=m0).
  apply aeval_det with(a:=a0)(s:=s).
  apply H12.
  apply H5.
  rewrite<- HHH,HH in H14.
  apply Lt.le_not_lt in H14.
  destruct (H14 H7).

  inversion H0.
  subst.
  assert(HH:n0=n).
  apply aeval_det with (a:=a)(s:=s).
  apply H3.
  apply H10.

  assert(HHH:m=m0).
  apply aeval_det with(a:=a0)(s:=s).
  apply H12.
  apply H5.
  rewrite<- HHH,HH in H14.
  apply Lt.le_not_lt in H7.
  destruct(H7 H14).

  reflexivity.

  intros.
  inversion H.
  inversion H0.
  reflexivity.
  assert(HH:n0=n).
  apply aeval_det with(a:=a)(s:=s).
  apply H3.
  apply H10.
  assert(HHH:m0=m).
  apply aeval_det with (a:=a0)(s:=s).
  apply H5.
  apply H12.
  rewrite HH,HHH in H14.
  destruct (H7 H14).
  inversion H0.
  assert(HH:n0=n).
  apply aeval_det with(a:=a)(s:=s).
  apply H3.
  apply H10.
  assert(HHH:m0=m).
  apply aeval_det with (a:=a0)(s:=s).
  apply H5.
  apply H12.
  rewrite HH,HHH in H14.
  destruct (H14 H7).

  reflexivity.

Qed.

Lemma bvnc : forall s a, beval s a true -> beval s a false -> False.
Proof.
  intros.
  assert(true=false).
  apply beval_det with (s:=s)(a:=a).
  assumption.
  assumption.
  inversion H1.
Qed.

Lemma bs_det : forall s p s1, execute s p s1 -> forall s2, execute s p s2 -> s2 = s1.
Proof.
  intros until 1.
  induction H.
  intros.
  inversion H.
  reflexivity.
  intros.
  inversion H1.
  subst.
  assert (o'0=o').
  apply IHexecute1.
  apply H5.
  apply IHexecute2.
  rewrite <-H2.
  assumption.

  intros.
  inversion H1.
  subst.
  apply IHexecute.
  assumption.

  assert(False).
  apply bvnc with (s:=o)(a:=b).
  assumption.
  assumption.
  contradiction.

  intros.
  inversion H1.
  subst.
  assert(False).
  apply bvnc with (s:=o) (a:=b).
  assumption.
  assumption.
  contradiction.

  subst.
  apply IHexecute.
  assumption.

  intros.
  inversion H0.
  subst.
  reflexivity.
  subst.
  assert(False).
  apply bvnc with (s:=o) (a:=b).
  assumption.
  assumption.
  contradiction.

  intros.
  inversion H2.
  subst.
  assert(False).
  apply bvnc with (s:=s2) (a:=b).
  assumption.
  assumption.
  contradiction.
  subst.
  assert(o'0 = o').
  apply IHexecute1.
  assumption.
  apply IHexecute2.
  rewrite <-H3.
  assumption.

  intros.
  inversion H1.
  subst.

  assert(n=n0).
  apply aeval_det with (a:=a)(s:=o).
  assumption.
  assumption.
  apply update_det with (s:=o) (a:=x) (v:=n).
  assumption.
  rewrite H2.
  assumption.
Qed.


(** * Vectors as iterated products. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)

Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Foundations.NaturalNumbers.

Local Open Scope nat.
Local Open Scope stn.

(** ** Lemmata about standard finite sets. *)

Definition stn_extens {n} (i j : ⟦ n ⟧) (p : stntonat _ i = stntonat _ j)
  : i = j
  := subtypePath' p (propproperty (j < n)).

Definition fromstn0 (i : ⟦ 0 ⟧) {A : UU} : A
  := fromempty (negnatlthn0 (pr1 i) (pr2 i)).

(** ** Vectors. *)

Definition vec (A : UU) (n : nat) : UU.
Proof.
induction n as [|n IHn].
- apply unit.
- apply (A × IHn).
Defined.

(** *** Constructors. *)

Definition vnil {A: UU}: vec A 0 := tt.

Definition vcons {A: UU} {n} (x : A) (v : vec A n) : vec A (S n)
  := x,, v.

(** *** Notations. *)

Declare Scope vec_scope.

Delimit Scope vec_scope with vec.

Bind Scope vec_scope with vec.

Local Open Scope vec_scope.

Notation "[()]" := vnil (at level 0, format "[()]"): vec_scope.

Infix ":::" := vcons (at level 60, right associativity) : vec_scope.

Notation "[( x ; .. ; y )]" := (vcons x .. (vcons y [()]) ..): vec_scope.

Section vecs.

Context {A : UU}.

Definition drop {n} (f : ⟦ S n ⟧ → A) (i : ⟦ n ⟧) : A :=
  f (dni_firstelement i).

Definition make_vec {n} (f : ⟦ n ⟧ → A) : vec A n.
Proof.
  induction n as [|m h].
  - exact [()].
  - exact ((f firstelement) ::: (h (drop f))).
Defined.

(** *** Projections. *)

Definition hd {n} (v : vec A (S n)) : A := pr1 v.

Definition tl {n} (v : vec A (S n)) : vec A n := pr2 v.

Definition el {n} (v : vec A n) : ⟦ n ⟧ → A.
Proof.
  induction n as [|m f].
  - apply (λ i, fromstn0 i).
  - intro i.
    induction i as (j,jlt).
    induction j as [|k _].
    + exact (hd v).
    + exact (f (tl v) (k,, jlt)).
Defined.

(** *** Some identities for computing [el]. *)

Lemma el_make_vec {n} (f : ⟦ n ⟧ → A) : el (make_vec f) ~ f .
Proof.
  intro i.
  induction n as [|m meq].
  - exact (fromstn0 i).
  - induction i as (j,jlt).
    induction j as [|k _].
    + cbn.
      apply maponpaths.
      apply stn_extens.
      apply idpath.
    + etrans.
      { apply meq. }
      unfold drop.
      apply maponpaths.
      apply idpath.
Defined.

Lemma el_make_vec_fun {n} (f : ⟦ n ⟧ → A) : el (make_vec f) = f.
Proof.
  apply funextfun.
  apply el_make_vec.
Defined.

Lemma el_vcons_tl {n} (v : vec A n) (x : A) (i : ⟦ n ⟧) :
  el (x ::: v) (dni_firstelement i) = el v i.
Proof.
  induction n as [|m meq].
  - apply fromstn0. exact i.
  - cbn. apply maponpaths.
    apply proofirrelevance;
    exact (propproperty (pr1 i < S m)).
Defined.

Lemma el_vcons_hd {n} (v : vec A n) (x : A) :
  el (x ::: v) (firstelement) = x.
Proof.
  reflexivity.
Defined.

Lemma drop_el {n} (v : vec A (S n)) (i: ⟦ n ⟧ ) : drop (el v) i = el (tl v) i.
Proof.
  induction v as (x, u).
  change (drop (el (x ::: u)) i = el u i).
  apply el_vcons_tl.
Defined.

Lemma el_tl {n} (v : vec A (S n)) (i : ⟦ n ⟧)
  : el (tl v) i = drop (el v) i.
Proof.
  rewrite drop_el.
  reflexivity.
Defined.

(** *** Extensionality. *)

Definition vec0_eq (u v : vec A 0) : u = v
  := proofirrelevancecontr iscontrunit u v.

Definition vecS_eq {n} {u v : vec A (S n)}
           (p : hd u = hd v) (q : tl u = tl v)
  : u = v
  := dirprod_paths p q.

Lemma vec_extens {n} {u v : vec A n}
  : (∏ i : ⟦ n ⟧, el u i = el v i) → u = v.
Proof.
  intros H.
  induction n as [|m meq].
  - apply vec0_eq.
  - apply vecS_eq.
    + exact (H firstelement).
    + apply meq.
      intros.
      do 2 rewrite el_tl.
      apply H.
Defined.

Lemma make_vec_el {n} (v : vec A n) : make_vec (el v) = v.
Proof.
  apply vec_extens.
  intros i.
  rewrite el_make_vec.
  reflexivity.
Defined.

(** *** Weak equivalence with functions. *)

Definition isweqvecfun {n} : isweq (el:vec A n → ⟦ n ⟧ → A)
  := isweq_iso el make_vec make_vec_el el_make_vec_fun.

Definition weqvecfun n : vec A n ≃ (⟦ n ⟧ -> A)
  := make_weq el isweqvecfun.

Lemma isofhlevelvec {n} (is1 : isofhlevel n A) k
  : isofhlevel n (vec A k).
Proof.
  induction k as [|k IH].
  - apply isofhlevelcontr, iscontrunit.
  - apply isofhleveldirprod.
    + apply is1.
    + apply IH.
Defined.

(** *** Induction. *)

Lemma vec_ind (P : ∏ n, vec A n → UU) :
  P 0 [()]
  → (∏ x n (v : vec A n), P n v → P (S n) (x ::: v))
  → (∏ n (v : vec A n), P n v).
Proof.
  intros Hnil Hcons.
  induction n as [|m H]; intros.
  - apply (transportb (P 0) (vec0_eq v [()]) Hnil).
  - apply Hcons, H.
Defined.

End vecs.

(** *** Map, fold and append. *)

Definition vec_map {A B : UU} (f : A → B) {n} (v : vec A n) : vec B n.
Proof.
  induction n as [|m h].
  - exact vnil.
  - eapply vcons.
    + exact (f (hd v)).
    + exact (h (tl v)).
Defined.

Lemma hd_vec_map {A B : UU} (f : A → B) {n} (v : vec A (S n))
  : hd (vec_map f v) = f (hd v).
Proof.
  reflexivity.
Defined.

Lemma tl_vec_map {A B : UU} (f : A → B) {n} (v : vec A (S n))
  : tl (vec_map f v) = vec_map f (tl v).
Proof.
  reflexivity.
Defined.

Lemma el_vec_map {A B : UU} (f : A → B) {n} (v : vec A n) (i : ⟦ n ⟧)
  : el (vec_map f v) i = f (el v i).
Proof.
  induction n as [|m H].
  - exact (fromstn0 i).
  - induction i as (j, jlt).
    induction j as [|k _].
    + apply hd_vec_map.
    + change (el (tl (vec_map f v)) (make_stn _ k jlt) =
              f (el (tl v) (make_stn _ k jlt))).
      etrans.
      { apply el_tl. }
      etrans.
      { apply H. }
      apply maponpaths.
      apply maponpaths.
      reflexivity.
Defined.

Lemma vec_map_as_make_vec {A B: UU} (f: A → B) {n} (v: vec A n)
  : vec_map f v = make_vec (λ i, f (el v i)).
Proof.
  apply vec_extens.
  intro i.
  rewrite el_vec_map.
  rewrite el_make_vec.
  apply idpath.
Defined.

Definition vec_foldr {A B : UU} (f : A -> B -> B) (b : B) {n}
  : vec A n -> B
  := vec_ind (λ (n : nat) (_ : vec A n), B) b
                (λ (a : A) (m : nat) (_ : vec A m) (acc : B), f a acc)
                n.

Definition vec_foldr1 {A : UU} (f : A -> A -> A) {n} : vec A (S n) → A
  := nat_rect (λ n : nat, vec A (S n) → A)
              hd
              (λ (m : nat) (h : vec A (S m) → A),
               uncurry (λ (x : A) (u : vec A (S m)), f x (h u)))
              n.

Definition vec_append {A : UU} {m} (u : vec A m) {n} (v : vec A n)
  : vec A (m + n)
  := vec_ind (λ (p : nat) (_ : vec A p), vec A (p + n))
                v
                (λ (x : A) (p : nat) (_ : vec A p) (w : vec A (p + n)),
                 x ::: w)
                m u.

(** *** Fusion laws. *)

Lemma vec_map_id {A : UU} {n} (v: vec A n)
  : vec_map (idfun A) v = v.
Proof.
  revert n v.
  refine (vec_ind _ _ _).
  - apply idpath.
  - intros x n xs HPxs.
    simpl.
    apply maponpaths.
    apply HPxs.
Defined.

Lemma vec_map_comp {A B C: UU} (f: A → B) (g: B → C) {n: nat} (v: vec A n) :
  vec_map (funcomp f g) v = (funcomp (vec_map f) (vec_map g)) v.
Proof.
  revert n v.
  refine (vec_ind _ _ _).
  - apply idpath.
  - intros x n xs HPxs.
    apply vecS_eq.
    + reflexivity.
    + apply HPxs.
Defined.

Lemma vec_map_make_vec {A B: UU} {n: nat} (g: ⟦ n ⟧ → A) (f: A → B)
  : vec_map f (make_vec g) = make_vec (f ∘ g).
Proof.
  apply vec_extens.
  intro i.
  rewrite el_vec_map.
  rewrite el_make_vec.
  rewrite el_make_vec.
  apply idpath.
Defined.

Lemma vec_append_lid {A : UU} (u : vec A 0) {n}
  : vec_append u = idfun (vec A n).
Proof.
  induction u.
  reflexivity.
Defined.

(** *** Other operations on vecs. *)

Definition vec_fill {A: UU} (a: A): ∏ n: nat, vec A n
  := nat_rect (λ n: nat, vec A n) [()] (λ (n: nat) (v: vec A n), a ::: v).

Lemma vec_map_const {A: UU} {n: nat} {v: vec A n} {B: UU} (b: B) : vec_map (λ _, b) v = vec_fill b n.
Proof.
  revert n v.
  apply vec_ind.
  - apply idpath.
  - intros x n xs HPind.
    change (b ::: vec_map (λ _: A, b) xs = b ::: vec_fill b n).
    apply maponpaths.
    exact HPind.
Defined.

Definition vec_zip {A B: UU} {n: nat} (v1: vec A n) (v2: vec B n): vec (A × B) n.
Proof.
  induction n.
  - exact [()].
  - induction v1 as [x1 xs1].
    induction v2 as [x2 xs2].
    exact ((x1 ,, x2) ::: IHn xs1 xs2).
Defined.