From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype fintype choice ssrfun seq path.

From mathcomp.ssreflect
Require Import tuple.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.

From Probchain Require Import InvMisc.

Set Implicit Arguments.

Definition ntuple_cons (A : Type) (n : nat) (a : A) (list : n.-tuple A) : (n.+1).-tuple A.
Proof.
    case list=> tval /eqP H0.
    split with (tval := (a :: tval)).
    by rewrite  -H0.
Defined.

Definition ntuple_head (A : Type) (n' : nat) (list : (n'.+1).-tuple A) : A .
Proof.
    apply (thead list).
Defined.

Definition ntuple_tail (A : Type) (n' : nat) (list : (n'.+1).-tuple A) : n'.-tuple A.
Proof.
    move: (tuple_eta list) => H.
    split with (tval := behead list).
    apply behead_tupleP.
Defined.

Lemma size_ncons_nil (A : Type) (a : A) (n : nat): (size (ncons n a [::])) == n.
Proof.
    rewrite size_ncons => //=.
    by rewrite addn0.
Defined.

Fixpoint set_tnth (A : Type) (m : nat) (list : m.-tuple A) (a : A) (n : nat) : m.-tuple A.
Proof.
    induction  m  as [|m'] eqn: Hm.
    induction n as [|n''] eqn: Hn.
        (* 0, 0 *)
        exact list.
        (* 0, n.+1 *)
        exact list.
    case n eqn: Hn.
        (* m.+1, 0 *)
        exact [tuple of a :: (ntuple_tail list)].
        (* m'.+1, n'.+1 *)
        exact [tuple of ntuple_head list ::  set_tnth A m' (ntuple_tail list) a n0].
Defined.
Lemma ltn_Snn a b : a.+1 < b.+1 -> a < b.
Proof.
  by rewrite -{1}(addn1 a) -{1}(addn1 b) ltn_add2r.
Qed.

Lemma tnth_cons A n (ls : n.-tuple A) x i :  forall (prf : i.+1 < n.+1) (prf': i < n),  tnth [tuple of x :: ls] (Ordinal prf) = tnth ls (Ordinal prf').
Proof.
  move: ls => [ls Hls].
  move=> prf prf' //=.
  by rewrite (@tnth_nth _ _ x _) (@tnth_nth _ _ x _) //=.
Qed.

Lemma tnth_set_nth_eq  A (n : nat) (ls: n.-tuple A) x (addr addr' : 'I_n) : (nat_of_ord addr) == (nat_of_ord addr') -> tnth (set_tnth ls x addr') addr = x.
Proof.
  move: addr addr' => [addr' Haddr'] [addr Haddr] //= /eqP Heq.
  move: ls => [ls ].
  move: addr addr' Heq n Haddr Haddr'.
  elim: ls => //= .
    by move=> addr addr' Heq [//=|n] Haddr Haddr' => /eqP //=.
  move=> y ys Hys addr addr' Heq [//=|n] Haddr Haddr' Hlen. move: (Hlen) => Hlen' //=.
  case Haddreqn: (addr) => [ | addr_].
      move: Haddr'.
      by rewrite Heq Haddreqn //=.
  rewrite/ntuple_head/ntuple_tail //=.
  move: (behead_tupleP _) => //=; move: Haddr'.
  rewrite Heq Haddreqn /thead //= => Haddr' Hbhd.
  rewrite tnth_cons //= Hys //=.
Qed.

Lemma tnth_set_nth_neq  A (n : nat) (ls: n.-tuple A) x (addr addr' : 'I_n) : (nat_of_ord addr) != (nat_of_ord addr') -> tnth (set_tnth ls x addr') addr = tnth ls addr.
Proof.
  move: ls addr addr' => [ls Hls] [addr Haddr] [addr' Haddr'] //=.
  move: n Hls addr addr'  Haddr Haddr'.
  elim: ls => //=.
    move=> n Hls. move:  Hls (Hls) => /eqP Hls Hls'.
    move=> addr addr' Haddr; move: Haddr (Haddr).
    by rewrite -{1}Hls.
  move=> y ys IHs //= [//=|n] Hls addr addr' .
  case Haddreqn: addr => [ | addr_].
     move=> Haddr //=.
     by case addr' => //=.
  case addr' => //= addr'_ Haddr'_.
    by rewrite tnth_cons //= (@tnth_nth _ _  x _) (@tnth_nth _ _  x _) => //=.
  rewrite !tnth_cons /ntuple_tail => //=.
  move: (behead_tupleP _ ) => //= Hbhd Hltnaddr_ Hneq.
  rewrite IHs => //=.
  by rewrite (@tnth_nth _ _  x _) (@tnth_nth _ _  x _) => //=.
Qed.

Section fixlist.
    Variable A : eqType.
Definition fixlist n := n.-tuple (option A).

    Definition fixlist_empty n : fixlist n :=
        @Tuple n
            (option A)
            (ncons n None [::])
            (size_ncons_nil   None n).

    Definition fixlist_of n (a : A) : fixlist n:=
        @Tuple n
            (option A)
            (ncons n (Some a) [::])
            (size_ncons_nil (Some a) n).

    (* I wanted to write this, but it wouldn't type check*)
    (* Fixpoint fixlist_insert (m : nat) (list : fixlist m.+1) (a : A) : fixlist m.+1 :=
        match tnth list (inord m) return fixlist m.+1  with
            | None => [tuple of (Some value) :: [tuple of behead list]]
            | Some value => match m return fixlist m.+1 with
                                | 0 => list
                                | m'.+1 =>  [tuple of (Some value) :: fixlist_insert m' [tuple of behead list] a ]
                                end
            end. *)

    Definition fixlist_insert {m : nat} (list : fixlist m)  :=
      nat_rect (fun m0 : nat => fixlist m0 -> A -> fixlist m0) (fun (list0 : fixlist 0) (_ : A) => list0)
       (fun (m0 : nat) (fixlist_insert : fixlist m0 -> A -> fixlist m0) (list0 : fixlist m0.+1) (a0 : A) =>
        let o := thead list0 in
        let H : thead list0 = o := erefl o in
        match o as o0 return (thead list0 = o0 -> fixlist m0.+1) with
        | Some s =>
            fun _ : thead list0 = Some s => [tuple of Some s :: [tuple of fixlist_insert (ntuple_tail list0) a0]]
        | None => fun _ : thead list0 = None => [tuple of Some a0 :: [tuple of behead list0]]
        end H) m list.

    Definition fixlist_unwrap (m : nat) (list : fixlist m) : seq A :=
        flatten (map (fun o_value => match o_value with
                            | Some value => [:: value]
                            | None => [::]
                            end) list).

    (* Lemma fixlist_insert (m : nat) (list : fixlist m) (a : A) : fixlist m. *)
    (*     move: a. *)
    (*     move: list. *)
    (*     elim m. *)
    (*     move=> list a. *)
    (*         exact list. (* can not insert anything into an empty list*) *)
    (*     move=> m0 fixlist_insert list a. *)
    (*     case (thead list) eqn:H; last first. *)
    (*         exact [tuple of (Some a) :: [tuple of behead list]]. *)
    (*         exact [tuple of (Some s) :: [tuple of fixlist_insert (ntuple_tail list) a]]. *)
    (* Defined. *)

(*
    Lemma fixlist_remove_h (m m' : nat) : (m'.+1 = m) -> fixlist m.+1 -> fixlist m'.+2.
    Proof.
        move=> H list.
        rewrite -H in list.
        exact list.
    Qed.
 *)
    (* Fixpoint fixlist_remove (m : nat) (list : fixlist m.+1) (n : nat) : fixlist m.+1 :=
        match m as m', n return _ = m -> fixlist _ with
            | m'.+1, n'.+1 => fun epf => [tuple of ntuple_head list ::  @fixlist_remove m' (ntuple_tail list) n']
            | 0, n'.+1 => fun epf => [ tuple of [:: ntuple_head list]]
            | m'.+1, 0 => fun epf => match (tnth list (inord m'))  with
                            | None =>  list
                            | Some v => [tuple of None :: (ntuple_tail list)]
                          end
            | 0, 0 => fun epf =>  [tuple of [:: None] ]
           end (erefl _)
           .
    *)

    (* remove will remove the nth index of the list *)
    Fixpoint fixlist_remove (m : nat) (list : fixlist m) (n : nat) : fixlist m.
        move: list.
        induction  m  as [|m'] eqn: Hm.
        induction n as [|n''] eqn: Hn.
            (* 0, 0 *)
            move=> _.
            exact [tuple of [::]].
            (* 0, n.+1 *)
            move=> list.
            exact list.
        case n eqn: Hn.
            (*m'.+1, 0 *)
            move=> list.
            exact [tuple of None :: (ntuple_tail list)].
        (* m'.+1, n0.+1 *)
        move=> list.
            exact [tuple of ntuple_head list ::  @fixlist_remove m' (ntuple_tail list) n0].
    Defined.

    (* rem will remove all instances of a in the list*)
    Lemma fixlist_rem (m : nat) (list: fixlist m) (a : A) : fixlist m.
        induction m.
            (* if m is 0, return empty list *)
            exact list.
        (* assume we have a rem function for lists of length m*)
        (* consider a list of length m.+1 *)
        case (ntuple_head list) eqn: H.
            (* if it's head is not none, *)
            case (s == a) eqn: H'.
                (* if the value of the head is equal to the value being removed*)
                (* return a list with None in the place of the first value, and all subsequent ones removed*)
                exact [tuple of None :: IHm (ntuple_tail list)].
            (* if the value of the head is not equal, just keep the head, remve from the tail*)
            exact [tuple of (Some s) :: IHm (ntuple_tail list)].
        (* if the value of the head is none, just remove from the tail*)
        exact [tuple of None :: IHm (ntuple_tail list)].
    Defined.

    (* Fixpoint fixlist_set_nth (m : nat) (list : fixlist  m.+1) (a : A) (n : nat) : fixlist m.+1 :=
         match m, n with
            | m'.+1, n'.+1 => [tuple of ntuple_head list ::  @fixlist_remove m' (ntuple_tail list) n']
            | 0, n'.+1 => [tuple of [:: ntuple_head list]]
            | m'.+1, 0 => [tuple of (Some a) :: (ntuple_tail list)]
            | 0, 0 =>  [tuple of [:: Some a] ]
       end. *)

    Definition fixlist_set_nth (m : nat) (list : fixlist  m) (a : A) (n : nat) : fixlist m := set_tnth list (Some a) n .

    (* Definition fixlist_nth (m : nat) (default : A) (list : fixlist m) (n : nat) : A :=
        if n < m then
            match m with
                | 0 => default
                | m'.+1 => tnth list (Ordinal (m'.+1))
                end
        else default. *)

    Definition fixlist_nth (m : nat) (default : A) (list : fixlist m)  (n : nat) : A.
    Proof.
        case (n < m) eqn: H; last first.
            exact default.

        apply ltn_addr with (p := 1) in H .
        case m eqn: H1.
            exact default.
        move: (ltn0Sn n0)=> H''.
        move: (Ordinal H'')=> ind.
        case (tnth list ind) eqn: isSome.
            exact s.
            exact default.
    Defined.

    Definition fixlist_get_nth (m : nat)  (list : fixlist m)  (n : nat) : option A .
    Proof.
        case (n < m) eqn: H; last first.
            exact None.
        move: (Ordinal H)=> ind.
        case (tnth list ind) eqn: isSome.
          exact (Some s).
          exact None.
   Defined.

    (* Fixpoint fixlist_length' (m : nat) (list : fixlist  m.+1) : nat :=
        match m with
            | 0 => match ntuple_head list with
                | Some _ => 1
                | None   => 0
                end
            | m'.+1 => match ntuple_head list with
                | Some _ => 1 + fixlist_length' (ntuple_tail list)
                | None   =>  fixlist_length' (ntuple_tail list)
                end
            end. *)

    Definition fixlist_length (m : nat) (list : fixlist  m) : nat :=
      length (fixlist_unwrap list).
    Definition fixlist_is_empty (m : nat) (list: fixlist m) : bool :=
      (fixlist_unwrap list) == [::].

    Definition fixlist_is_full (m : nat) (list : fixlist m) : bool :=
      fixlist_length list == m .

    (* a fixed list is top heavy if all the empty spaces are at the tail of the list*)
    Definition fixlist_is_top_heavy (m : nat) (list : fixlist m) : bool :=
      nat_rect (fun m0 : nat => fixlist m0 -> bool) xpredT
       (fun (m0 : nat) (fixlist_is_top_heavy : fixlist m0 -> bool) (list0 : fixlist m0.+1) =>
          let o := thead list0 in
          let H : thead list0 = o := erefl o in
          match o as o0 return (thead list0 = o0 -> bool) with
          | Some s => fun _ : thead list0 = Some s => fixlist_is_top_heavy [tuple of behead list0]
          | None => fun _ : thead list0 = None => fixlist_is_empty [tuple of behead list0]
          end H) m list
      .

    (* Proof. *)
    (*   move: list. *)
    (*   elim m. *)
    (*     move=> list. *)
    (*     exact true. *)
    (*   move=> m0 fixlist_is_top_heavy list. *)
    (*   case (thead list) eqn: H; last first. *)
    (*   exact (fixlist_is_empty [tuple of behead list]). *)
    (*   exact (fixlist_is_top_heavy [tuple of behead list]). *)
    (* Defined. *)

    (* Fixpoint fixlist_filter (m : nat) (P : pred A) (list : fixlist m) : fixlist m :=
        match m with
            | 0 => list
            | m'.+1 => match ntuple_head list with
                | Some a => if P a then [tuple of (Some a) :: fixlist_filter (ntuple_tail list)]
                                    else [tuple of fixlist_filter (ntuple_tail list)]
                | None => [tuple of fixlist_filter (ntuple_tail list)]
                end
            end. *)
    Fixpoint fixlist_filter (m : nat) (P : pred A) (list : fixlist m) : fixlist m.
        case m eqn: H.
            exact list.
        case (ntuple_head list).
            move=> a.
            case (P a) eqn: H'.
                exact [tuple of (Some a) :: fixlist_filter n P (ntuple_tail list)].
            exact [tuple of None :: fixlist_filter n P (ntuple_tail list)].
        exact [tuple of None :: fixlist_filter n P (ntuple_tail list)].
    Defined.

    (* Fixpoint fixlist_contains (m : nat) (a : A) (list : fixlist m) : bool :=
        match m with
            | 0 => false
            end
            | m'.+1 => match ntuple_head list with
                | Some a' => if a' == a then true else fixlist_contains (ntuple_tail list)
                | None => fixlist_contains (ntuple_tail list)
                end
            end. *)

    Definition fixlist_contains (m : nat) (a : A) (list : fixlist m) : bool :=
      has (fun x => x == a) (fixlist_unwrap list).

    Fixpoint fixlist_index_of' (m : nat) (n: nat) (a : A) (list : fixlist m) : option nat.
        case m eqn: H.
            exact None.
        case (ntuple_head list).
            move=> a'.
            case (a' == a) eqn: H'.
                exact (Some n).
                exact (fixlist_index_of' n0 n.+1 a (ntuple_tail list)).
            exact (fixlist_index_of' n0 n.+1 a (ntuple_tail list)).
    Defined.

    Definition fixlist_index_of (m : nat) (a : A) (list : fixlist m) : option nat :=
        fixlist_index_of' 0 a list.

    (* uses a fixlist like a fixed length queue, inserting at the start and removing from the end*)
    Fixpoint fixlist_enqueue (m : nat) (a : option A) (list: fixlist m) : (fixlist m * option A).
     (* :=
        match m with
            | 0     => list  (* simply drop the a *)
            | m'.+1 => [tuple of a :: fixlist_shiftl' (ntuple_head list) (ntuple_tail list)]
            end. *)
        case m eqn: H.
            exact (list, a).
        case (@fixlist_enqueue _ (ntuple_head list) (ntuple_tail list)) => shifted_tail output.
        exact ([tuple of a :: shifted_tail], output).
    Defined.

    Definition option_rcons B (ls : seq.seq B) (a : option B) :=
      if a is Some v
      then rcons ls v
      else ls.

    Definition option_cons B  (a : option B) (ls : seq.seq B) :=
      if a is Some v
      then cons v ls
      else ls.

    Definition fixlist_shiftl (m : nat) (list: fixlist m) : fixlist m :=
        let: (result, output) := fixlist_enqueue None list in
        result.

    Lemma eqn_incr a b : a == b -> a.+1 == b.+1.
    Proof. by move=>/eqP/(f_equal S)/eqP. Qed.

    Lemma size_incr (X : Type) (m : nat) (ls : seq X) (o: X) : (size ls == m) -> (size (o::ls) == m.+1).
    Proof. by []. Qed.

    Lemma fixlist_coerce_some (m : nat) (ls : seq (option A)) (o: (A)) (pf: size ls == m) (pf': size ((Some o) :: ls) == m.+1) :
      (fixlist_unwrap (Tuple pf')) = o :: (fixlist_unwrap (Tuple pf)).
      Proof.
        move: pf pf'.
        by elim ls => //.
      Qed.

    Lemma fixlist_coerce_none (m : nat) (ls : seq (option A)) (pf: size ls == m) (pf': size (None :: ls) == m.+1) :
      (fixlist_unwrap (Tuple pf')) = (fixlist_unwrap (Tuple pf)).
      Proof.
        move: pf pf'.
        by elim ls => //.
      Qed.

     Lemma fixlist_insert_coerce_none (m : nat) (ls : seq (option A)) (o: (A)) (pf: size ls == m) (pf': size (None :: ls) == m.+1) :
      (fixlist_unwrap (fixlist_insert (Tuple pf') o) = o :: (fixlist_unwrap (Tuple pf))).
      Proof.
        move: ls pf pf' .
        by elim m => //=.
      Qed.

      Lemma ntuple_tail_coerce (m : nat) (T: Type) (y  x: T) xs : forall (pf' : (size [:: y, x & xs] == m.+2)) (pf: size [:: x & xs] == m.+1),
        (ntuple_tail (Tuple (n:=m.+2) (tval:=[:: y, x & xs]) pf')) = (Tuple (n:=m.+1) (tval:=[:: x & xs]) pf).
      Proof.
        move: x y m.
        case: xs => [x y |x0 xs x y].
        move=> m Hpf' Hpf.
        move: (Hpf') (Hpf).
        move/eqP:Hpf => Hpf.
        move=> pf' pf.
        rewrite /ntuple_tail //=.
        generalize (behead_tupleP (Tuple (n:=m.+2) (tval:=[:: y; x]) pf')) as H_tail.
        have Hobv: (behead (Tuple (n:=m.+2) (tval:=[:: y; x]) pf')) = ([:: x] ). by [].
        have Hobv': m.+2.-1 = m.+1. by [].
        move=> H_tail.
        dependent rewrite Hobv in H_tail.
        dependent rewrite Hobv' in H_tail.
        by rewrite (proof_irrelevance _  H_tail pf).

        move=> m pf' pf .
        rewrite /ntuple_tail //=.
        generalize (behead_tupleP (Tuple (n:=m.+2) (tval:=[:: y, x, x0 & xs]) pf')) as H_tail.
        move=> H_tail.
        have Hobv: (behead (Tuple (n:=m.+2) (tval:=[:: y, x, x0 & xs]) pf')) = [:: x, x0 & xs]. by [].
        have Hobv': m.+2.-1 = m.+1. by [].

        dependent rewrite Hobv in H_tail.
        dependent rewrite Hobv' in H_tail.
        by rewrite (proof_irrelevance _  H_tail pf).

      Qed.

      Lemma fixlist_insert_size_idem  (m : nat) (ls : fixlist m) (a : A) : size (fixlist_insert ls a) = size ls.
      Proof.
        destruct ls as [ls Hls].
        move: ls Hls .
        elim: m=> //= m Ihm xs Hxs.
        case: (thead _) => [s//=|//=]; last first.
        move: Hxs.
        by case xs => //=.
        move: Hxs.
        case: xs => //= x xs Hxs'.
        move: (Hxs').
        move/eqP: Hxs'=>Hxs'.
        case:Hxs'=>/eqP Hxs.
        move: (Ihm xs Hxs) => IHm.
        move=> Hxs'//=.
        case x => //=; last first.
        rewrite /ntuple_tail//=.
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=None :: xs) Hxs')) as H_tail.
        move=> H_tail.
        have Hobv: (behead (Tuple (n:=m.+1) (tval:=None :: xs) Hxs')) = xs. by [].
        have Hobv': m.+1.-1 = m. by[].
        dependent rewrite Hobv in H_tail.
        dependent rewrite Hobv' in H_tail.
        rewrite -IHm.
        by rewrite (proof_irrelevance _  H_tail Hxs).
        move=> s'.
        rewrite /ntuple_tail//=.
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=Some s' :: xs) Hxs')) as H_tail.
        move=> H_tail.
        have Hobv: (behead (Tuple (n:=m.+1) (tval:=Some s' :: xs) Hxs')) = xs. by[].
        have Hobv': m.+1.-1 = m. by[].
        dependent rewrite Hobv in H_tail.
        dependent rewrite Hobv' in H_tail.
        rewrite -IHm.
        by rewrite (proof_irrelevance _  H_tail Hxs).
  Qed.

      Lemma tval_injectivitiy (T:Type) n (t: n.-tuple T) (pf: size t == n) : Tuple (n:=n) (tval:=tval t) pf =  t.
      Proof.
        destruct t as [t t_pf].
        move=>//=.
          by rewrite (proof_irrelevance _ pf t_pf).
      Qed.

     Lemma fixlist_insert_coerce_some (m : nat) (ls : seq (option A)) (s o: A) (pf: size ls == m) (pf': size (Some s :: ls) == m.+1) :
      (fixlist_unwrap (fixlist_insert (Tuple pf') o) = s :: fixlist_unwrap (fixlist_insert (Tuple pf) o)).
      Proof.
        rewrite fixlist_coerce_some.
        by rewrite fixlist_insert_size_idem .
        rewrite /ntuple_tail//= .
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=Some s :: ls) pf')) as H_tail.
        move=> H_tail.
        have Hobv: (behead (Tuple (n:=m.+1) (tval:=Some s :: ls) pf')) = ls. by [].
        have Hobv': m.+1.-1 = m. by [].
        dependent rewrite Hobv in H_tail.
        dependent rewrite Hobv' in H_tail.
        clear Hobv.
        clear Hobv'.
        move=>Hpf.
        suff: (Tuple (n:=m) (tval:=fixlist_insert (Tuple (n:=m) (tval:=ls) H_tail) o) Hpf) = (fixlist_insert (Tuple (n:=m) (tval:=ls) pf) o).
        by move=> ->.
        rewrite (proof_irrelevance _ pf H_tail).
        by rewrite tval_injectivitiy.
    Qed.

      Lemma fixlist_contains_obv a m' xs Hxs : fixlist_contains a (fixlist_insert (Tuple (n:=m') (tval:=xs) Hxs) a) =
  has (eq_op^~ a) (fixlist_unwrap (fixlist_insert (Tuple (n:=m') (tval:=xs) Hxs) a)).
        Proof.
          apply/eqP=>//=.
        Qed.

    Lemma fixlist_has_eq (m : nat) (list: fixlist m) (a : A) (P: pred A) :
       (has P (fixlist_unwrap (fixlist_insert list a))) = has P (fixlist_unwrap list) || [ && P a, fixlist_contains a (fixlist_insert list a) & ~~ has P (fixlist_unwrap list)].
      Proof.
        destruct list as [xs Hxs].
        move: m Hxs .
        elim: xs => //=.
        move=> m xs.
        case H: (P a).
        move: (xs).
        by move/eqP: xs => <- //=.
        move=> //=.
        by induction m=>//=.

        move=> x xs IHx m.
        case m.
        by move=> Hxs; move/eqP:(Hxs)=>Hwrong; inversion Hwrong.
        case x =>[s m'|]; last first.
        move=> m' Hxs.
        rewrite  (@fixlist_insert_coerce_none ) //=.
        rewrite fixlist_coerce_none.
        move: (Hxs).
        move/eqP: Hxs => Hxs.
        case: Hxs => /eqP Hxs Hxs'.
        case (has P (fixlist_unwrap (Tuple (n:=m') (tval:=xs) Hxs'))) => //=.
        by apply orbT.
        rewrite Bool.orb_false_r.
        case (P a) => //=.
        rewrite /fixlist_contains//=.
        have :a == a. by[].
        by move=> ->.

        move=> Hxs'.
        rewrite  (@fixlist_insert_coerce_some m' xs s a) .
        rewrite fixlist_coerce_some /fixlist_contains.
        rewrite fixlist_insert_coerce_some //=.
        case Hps: (P s) => //=.
        move: (Hxs').
        move/eqP: Hxs' => Hxs'.
        case: Hxs' => /eqP Hxs'.
        move=> Hxs.
        rewrite IHx.
        case (has P (fixlist_unwrap (Tuple (n:=m') (tval:=xs) Hxs))) => //=.
        case Hpa: (P a) => //=.
        case Heq: (s == a) => //= .
        move/eqP: Heq => Heq.
        rewrite -Heq in Hpa.
        rewrite Hpa in Hps.
        by inversion Hps.
  Qed.

      Lemma fixlist_length_coerce (m : nat) (ls : fixlist m) ( x : A) pf :
              fixlist_length [tuple of Some x :: (Tuple (n:=m) (tval:=ls) pf)] = (fixlist_length (Tuple pf)).+1.
        Proof.
          destruct ls as [ls Hls].
          move: ls Hls pf.
          by elim: m=> //= m IHx [//|o_x] xs .
        Qed.

      Lemma fixlist_insert_length_incr (m : nat) (ls : fixlist m) (a : A) :
        fixlist_length ls < m ->
        fixlist_length (fixlist_insert ls a) = (fixlist_length ls).+1.
      Proof.
        destruct ls as [ls Hls].
        move: ls Hls .
        elim: m=> //= m Ihm xs .
        case: xs => //= o_x xs IHxs.
        move: (IHxs); move/eqP: IHxs =>  IHxs; case: IHxs => /eqP IHxs IHxs'.

        case: o_x => //=.
        move=> x.

        have: fixlist_length (Tuple (n:=m.+1) (tval:=Some x :: xs) IHxs') < m.+1 -> fixlist_length (Tuple IHxs) < m.
        by rewrite /fixlist_length//=.
        move=> H /H Hlen.

        move: (Ihm xs IHxs Hlen) => IHn.
        clear Ihm.
        rewrite /ntuple_tail .
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) IHxs')) => //= Ht'.
        rewrite (proof_irrelevance _ Ht' IHxs) => //=.
        rewrite fixlist_length_coerce => //=.
        rewrite tval_injectivitiy.
        rewrite IHn.
        by rewrite /fixlist_length => //=.
      Qed.

      Lemma fixlist_is_empty_top_heavy (m : nat) (ls : fixlist m) :
        fixlist_is_empty ls -> fixlist_is_top_heavy ls.
      Proof.
        case: ls => ls Hls.
        move: m Hls.
        elim ls => //=.
        by move=>m ls_H; move: (ls_H); move/eqP: ls_H => <-.
        move=> o_x xs IHm [//|m'] Hls .
        by case o_x => //=.
      Qed.

      Lemma fixlist_empty_is_empty (m : nat) : fixlist_is_empty (fixlist_empty m).
      Proof.
        by elim m=> //=.
      Qed.

      Lemma fixlist_empty_is_top_heavy (m : nat) : fixlist_is_top_heavy (fixlist_empty m).
      Proof.
        by apply fixlist_is_empty_top_heavy; exact (fixlist_empty_is_empty m).
      Qed.

      Lemma fixlist_top_heavy_coerce_some (m : nat) (xs : seq (option A)) (x a: A) (pf: size xs == m) (pf': size (Some x :: xs) == m.+1) :
        fixlist_is_top_heavy (fixlist_insert (Tuple pf') a) = fixlist_is_top_heavy (fixlist_insert (Tuple pf) a).
        Proof.

        move:  m pf' pf.
        elim: xs => [m pf pf' |o_x xs IHx m pf pf'].
          move=> //=.
          move: (pf'); move/eqP: pf' => Hpf.
          move: pf.
          by rewrite -Hpf .
          move: pf pf'.
        case o_x => [//= x'|].
        move=> pf pf'.
        rewrite /ntuple_tail.
        generalize  (behead_tupleP (Tuple (n:=m.+1) (tval:=[:: Some x, Some x' & xs]) pf)) => Ht'.
        have Hht'rew: size (behead (Tuple (n:=m.+1) (tval:=[:: Some x, Some x' & xs]) pf)) == m.+1.-1 = (size (o_x :: xs) == m). by [].
        dependent rewrite Hht'rew in Ht' => //=.
        rewrite/tuple.
        rewrite /behead_tuple.
        generalize  (behead_tupleP
          (Tuple (n:=m.+1) (tval:=Some x :: fixlist_insert (Tuple (n:=m) (tval:=Some x' :: xs) Ht') a)
             (let
              '@Tuple _ _ _ tP as t :=
               cons_tuple (Some x)
                 (Tuple (n:=m) (tval:=fixlist_insert (Tuple (n:=m) (tval:=Some x' :: xs) Ht') a)
                    (let
                     '@Tuple _ _ _ tP as t := fixlist_insert (Tuple (n:=m) (tval:=Some x' :: xs) Ht') a
                      return (size t == m) in tP)) return (size t == m.+1) in tP))) => //= Ht.
           have: (Tuple (n:=m) (tval:=fixlist_insert (Tuple (n:=m) (tval:=Some x' :: xs) Ht') a) Ht) = (fixlist_insert (Tuple (n:=m) (tval:=Some x' :: xs) pf') a).

           rewrite tval_injectivitiy.
           by rewrite (proof_irrelevance _ Ht' pf').
          by move=> ->.

          move=> pf pf'//=.
        rewrite /ntuple_tail.
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=[:: Some x, None & xs]) pf)) => Ht'.
        have Hht'rew: size (behead (Tuple (n:=m.+1) (tval:=[:: Some x, None & xs]) pf)) == m.+1.-1 = (size (None :: xs) == m). by [].
        dependent rewrite Hht'rew in Ht' => //=.

        rewrite/tuple.
        rewrite /behead_tuple.

        generalize  (behead_tupleP
          (Tuple (n:=m.+1) (tval:=Some x :: fixlist_insert (Tuple (n:=m) (tval:=None :: xs) Ht') a)
             (let
              '@Tuple _ _ _ tP as t :=
               cons_tuple (Some x)
                 (Tuple (n:=m) (tval:=fixlist_insert (Tuple (n:=m) (tval:=None :: xs) Ht') a)
                    (let
                     '@Tuple _ _ _ tP as t := fixlist_insert (Tuple (n:=m) (tval:=None :: xs) Ht') a
                      return (size t == m) in tP)) return (size t == m.+1) in tP))) => //= Ht.
       have: (Tuple (n:=m) (tval:=fixlist_insert (Tuple (n:=m) (tval:=None :: xs) Ht') a) Ht) = (fixlist_insert (Tuple (n:=m) (tval:=None :: xs) pf') a).
           rewrite tval_injectivitiy.
           by rewrite (proof_irrelevance _ Ht' pf').
          by move=> ->.
      Qed.

    Lemma fixlist_insert_preserves_top_heavy (m : nat) (ls : fixlist m) (a : A) :
        fixlist_is_top_heavy ls -> fixlist_is_top_heavy (fixlist_insert ls a).
      Proof.
        case: ls => ls Hls.
        move: ls Hls a.
        elim: m .
        move=> ls Hls' a.
        move: (Hls'); move/eqP: Hls'=>/size0nil Hls'.
        by rewrite Hls'.
        move=> m IHn [//|x] xs Hxs a.
        have Hxseq: size (x :: xs) == m.+1 = (size xs == m). by [].
        dependent rewrite Hxseq in Hxs.
        case x; last first.
        move => //=.
          move=>/fixlist_is_empty_top_heavy.
          rewrite /tuple.
          rewrite /behead_tuple.
          generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=None :: xs) Hxs)) as H_tail => //= H_tail.
          generalize (behead_tupleP
            (Tuple (n:=m.+1) (tval:=Some a :: xs)
              (valP (sT:=tuple_subType m (option A)) (Tuple (n:=m) (tval:=xs) H_tail)))) as H_tail' => //= H_tail'.
          by rewrite (proof_irrelevance _ H_tail H_tail').

        move: (IHn xs Hxs a) => IHn'.
        move=> x'.
        have Heq: fixlist_is_top_heavy (Tuple (n:=m.+1) (tval:=Some x' :: xs) Hxs) = fixlist_is_top_heavy (Tuple (n:=m) (tval:=xs) Hxs).
          move=> //=.
          rewrite/tuple.
          rewrite /behead_tuple.
          generalize ((behead_tupleP (Tuple (n:=m.+1) (tval:=Some x' :: xs) Hxs))) => //= Ht.
          by rewrite (proof_irrelevance _ Ht Hxs).

          move=> Hbase.
          rewrite (@fixlist_top_heavy_coerce_some m xs x' a Hxs).
          apply IHn.
          by rewrite -Heq.
    Qed.

    Lemma fixlist_insert_rewrite (m : nat) (ls : fixlist m) (a : A) :
        fixlist_is_top_heavy ls -> fixlist_length ls < m -> fixlist_unwrap (fixlist_insert ls a) = rcons (fixlist_unwrap ls)  a.
      Proof.
        case: ls => ls Hls.
        move: ls Hls.
        elim: m => //= m IHn ls .
        case ls => //= x xs Hls.
        case: x => //=; last first.
          rewrite/tuple.
          rewrite /behead_tuple.
          generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=None :: xs) Hls)) => //= Ht.
          rewrite /fixlist_is_empty =>/eqP His_empty.
          rewrite fixlist_coerce_none.
          rewrite His_empty //=.
          move=> H //=.
          rewrite fixlist_coerce_some.
          by rewrite His_empty.
        move=> x.
        rewrite /tuple.
        rewrite /behead_tuple.
        generalize  (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls)) => //= Ht.
        move=> His_top_heavy.
        move=> Hvlen.
        move: (Hvlen).
        move: Hvlen.
        rewrite {1}/fixlist_length.
        rewrite {1}/fixlist_unwrap //=.
        rewrite -{1}(addn1 m).
        rewrite -{1}(addn1 (length _)).
        rewrite ltn_add2r => Hlen Hvlen.
        have Hlenfxlen:  length (flatten [seq match o_value with
                              | Some value => [:: value]
                              | None => [::]
                              end | o_value <- xs]) = (fixlist_length (Tuple Ht)). by [].
       rewrite  Hlenfxlen in Hlen.

        rewrite /ntuple_tail.
        rewrite fixlist_coerce_some . by rewrite fixlist_insert_size_idem.
        move: (IHn xs Ht His_top_heavy Hlen) => IHn'.
        clear His_top_heavy.
        clear Hlenfxlen.
        clear Hlen.
        have: (forall pf, fixlist_unwrap (fixlist_insert (Tuple (n:=m) (tval:=xs) pf) a) =
         rcons (fixlist_unwrap (Tuple (n:=m) (tval:=xs) pf)) a).
        move=> pf.
        move: IHn'.
        by rewrite (proof_irrelevance _ pf Ht).
        clear IHn'.
        move=> IHn'.
        clear Hvlen.
        clear Ht.
        clear ls.
        clear IHn.

        have Hrew:
             (size
                (fixlist_insert
                    (Tuple (n:=m) (tval:=behead (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls))
                           (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls))) a) == m) =
             (size xs == m) .
          generalize  (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls)) => //=.
          move=> Ht''.
          by rewrite fixlist_insert_size_idem //=.
          move=> Ht.
       suff: (Tuple (n:=m)
          (tval:=fixlist_insert
                   (Tuple (n:=m) (tval:=behead (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls))
                      (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls))) a) Ht) = (fixlist_insert (Tuple (n:=m) (tval:=xs) Hls) a).
       move=> ->.
       by rewrite IHn'.

        rewrite tval_injectivitiy.
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls)) => //= Ht'.
        by rewrite (proof_irrelevance _ Ht' Hls).
  Qed.

  Lemma fixlist_insert_contains (m : nat) (ls : fixlist m) (a : A) :
        fixlist_is_top_heavy ls -> fixlist_length ls < m -> fixlist_contains a (fixlist_insert ls a) .
  Proof.
        case: ls => ls Hls.
        move: ls Hls.
        elim: m => //= m IHn ls .
        case ls => //= o_x xs Hls.
        case: o_x => //=; last first.
          rewrite/tuple.
          rewrite /behead_tuple.
          generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=None :: xs) Hls)) => //= Ht.
          rewrite /fixlist_is_empty =>/eqP His_empty.
          move=> Hlen.
          rewrite /fixlist_contains.
          rewrite fixlist_coerce_some => //=.
          have: (a == a). by [].
          by move=> ->.

        move=> x.
        move: (Hls).
        move/eqP: Hls => Hls.
        case: Hls => /eqP Hls Hls'.
        move: (IHn xs Hls) => IHn'.
        clear IHn.
        rewrite /tuple.
        rewrite /behead_tuple.
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls')) => //= Hls''.
        rewrite (proof_irrelevance _ Hls'' Hls).
        move=> /IHn' IHn.
        clear IHn'.
        rewrite /fixlist_length => //=.
        rewrite -{1}(addn1  (length _)).
        rewrite -{1}(addn1  m).
        rewrite ltn_add2r => Hvlen.
        have Hlenfxlen:  length (flatten [seq match o_value with
                              | Some value => [:: value]
                              | None => [::]
                              end | o_value <- xs]) = (fixlist_length (Tuple Hls)). by [].

        rewrite Hlenfxlen in Hvlen.
        apply IHn in Hvlen.
        clear IHn.
        clear Hlenfxlen.
        clear Hls''.
        have Hls'_rem : (size xs).+1 == m.+1 = (size xs == m). by[].
        dependent rewrite Hls'_rem in Hls'.
        rewrite (proof_irrelevance _ Hls' Hls).
        clear Hls'.

        rewrite /fixlist_contains.
        rewrite fixlist_coerce_some. by rewrite fixlist_insert_size_idem .
        move=> Hsz //=.
        case (x == a) => //=.
        rewrite /ntuple_tail//=.
        rewrite tval_injectivitiy.
        generalize (behead_tupleP (Tuple (n:=m.+1) (tval:=Some x :: xs) Hls)) => //= Ht'.
        rewrite -/fixlist_contains.
        move: Hvlen.
        rewrite /fixlist_contains.
        by rewrite (proof_irrelevance _ Hls Ht').
        Qed.

    Lemma fixlist_length_unwrap_ident : forall (m : nat) (ls : fixlist m), length (fixlist_unwrap ls) = fixlist_length ls.
    Proof.
      move => m.
      elim: m => //=.
    Qed.

    Lemma fixlist_empty_find_index' (n acc: nat) k (ls : fixlist n) :
      fixlist_is_empty ls  ->
      fixlist_index_of' acc k ls = None.
    Proof.
      move:   ls acc k => [].
      elim: n=> //=  n IHs.
      move=> [//=| x xs].
      rewrite/fixlist_is_empty/fixlist_unwrap/ntuple_head/thead /ntuple_tail => prf acc k.
      rewrite (tnth_nth x) //=.
      move: (behead_tupleP _) => //=.
      move: prf.
      case: x => //= _ prf Hempty.
      apply IHs.
      by rewrite /fixlist_is_empty/fixlist_unwrap.
    Qed.

    Lemma fixlist_empty_find_index (n acc: nat) k (ls : fixlist n) :
      fixlist_is_empty ls  ->
      fixlist_index_of k ls = None.
    Proof.
      rewrite /fixlist_index_of => Hisempty.
      by rewrite fixlist_empty_find_index' => //=.
    Qed.

    Lemma fixlist_index_pred (n acc ind : nat) (ls : fixlist n) k :
        acc > 0 ->
        fixlist_index_of' acc k ls = Some ind ->
        fixlist_index_of' acc.-1 k ls = Some ind.-1.
      move: ls acc k => [ ] .
      elim: n .
           by move=> [ ] //=.
      move=> n IHn [ //= | x xs] .
      move=>  Hls acc k ; move: (Hls); move: Hls => //= /eqP [] /eqP Heqn Hls.
      rewrite/ntuple_head/thead //= (tnth_nth x) //=.
      case: x => //= [x | ].
        move: (erefl _).
        case: (_  == _) => //=.
          by move=> _ _ [] ->.
        move=> _.
        rewrite/ntuple_tail//=.
        move: (behead_tupleP _) => //= Htemp Hacc; rewrite (proof_irrelevance _ Htemp Heqn); clear Htemp.
        have HSacc : 0 < acc.+1. by [].
        move=>/(IHn xs Heqn acc.+1 k HSacc) .
        by rewrite prednK //=.

      rewrite/ntuple_tail//=.
      move: (behead_tupleP _) => //= Htemp Hacc; rewrite (proof_irrelevance _ Htemp Heqn); clear Htemp.
      have HSacc : 0 < acc.+1. by [].
      move=>/(IHn xs Heqn acc.+1 k HSacc) .
      by rewrite prednK //=.
   Qed.

    Lemma fixlist_index_of_lt (n ind : nat) (ls: fixlist  n ) k :  fixlist_is_top_heavy ls ->
                                    fixlist_index_of k ls = Some ind -> ind < fixlist_length ls.
    Proof.
      move: ls k ind => [ ] .
      elim: n .
           by move=> [ ] //=.
      move=> n IHn [ //= | x xs] .
      move=>  Hls k ind; move: (Hls); move: Hls => /eqP [] /eqP Heqn Hls Hith Hfind .
      move: IHn (Hith) (Hfind) .
      rewrite /fixlist_index_of //= /ntuple_head/thead/tnth//= /ntuple_tail => IHn.
      move: (erefl _).
      move: (behead_tupleP _) => //=.
      move=> Htemp; rewrite (proof_irrelevance _ Htemp Heqn); clear Htemp.
      move: Hls Hith Hfind .
      case: x => [ x| ] Hith' Hfind'; last first.
        by move=>  Hempty; rewrite fixlist_empty_find_index' //=.
      move=> Hfindt; move: (Hfindt).
      rewrite/tuple; rewrite/behead_tuple; move: (behead_tupleP _) => //= Htemp;
      rewrite (proof_irrelevance _ Htemp Heqn); clear Htemp.
      move=>   Hith .
      move: (erefl _) Hith; case Heqk: (_ == _) =>  _; last first.
        move=> Hflind _ Hith /(fixlist_index_pred ) Hind.
        have Hosn: (0 < 1). by [].
        apply Hind in Hosn. clear Hind; move: Hosn => //= Hind.
        move: (IHn xs Heqn k ind.-1 Hith Hind).
        rewrite /fixlist_length/fixlist_unwrap //= -subn1.
        case: (length _) => [|len].
          by rewrite ltn0.
          by rewrite !ltnS leq_subLR addnC addn1.
     by move=> Hlen _ Hith [] <-; rewrite /fixlist_length/fixlist_unwrap//=.
  Qed.

  Lemma fixlist_index_set_is_top_heavy n (fls: fixlist n) k ind: fixlist_is_top_heavy fls ->
                                    fixlist_index_of k fls = Some ind ->
                          fixlist_is_top_heavy (fixlist_set_nth fls k ind ).
  Proof.
      move: fls k ind => [ ] .
      elim: n .
        by move=> [ ] //=.
      move=> n IHn [ //= | x xs] Heqn k ind Hith_base Hind_of .
      move: (Hith_base) (Hind_of); move: IHn.
      rewrite /fixlist_set_nth//=/thead (tnth_nth x) //= => IHn.
      move: (erefl _) => //=.
      move: (erefl _) => //=.
      move: Heqn Hith_base Hind_of .
      case: x => [x | ] Heqn Hith_base Hind_of //=; last first.
        move=> prf _ Hisempty.
        by rewrite fixlist_empty_find_index //=.
      move: Heqn Hith_base Hind_of .
      case: ind => [ | ind]  Heqn Hith_base Hind_of Hlen //=.
        move=>    _ Hith Hind.
        move: Hith.
        rewrite /tuple/behead_tuple/ntuple_tail;
        move:  (behead_tupleP _) => //= prf' ;
        move: (behead_tupleP _) => //= prf''.
        by rewrite (proof_irrelevance _ prf' prf'').
      move=> _ .
      rewrite /tuple/ntuple_tail//=.
      move: (behead_tupleP _) => //= Heqn'.
      move: (behead_tupleP _) => //= Hsz.
      have: ((Tuple (n:=n) (tval:=set_tnth (Tuple (n:=n) (tval:=xs) Heqn') (Some k) ind) Hsz) =
        set_tnth (Tuple (n:=n) (tval:=xs) Heqn') (Some k) ind).
        move: Hsz.
        by case: (set_tnth _) => //= ls prf0 prf1; rewrite (proof_irrelevance _ prf0 prf1) //=.
      move=> -> Hith .

      move: IHn Hind_of; rewrite /fixlist_index_of => IHn Hind_of //=.
      move: (erefl _); case Hxkeqn: (_ == _) => _ //=.
      move=> /fixlist_index_pred Hsn.
      have Hfindof: (0 < 1). by []. apply Hsn in Hfindof; clear Hsn; move: Hfindof => //=.
      rewrite /ntuple_tail; move: (behead_tupleP _) => //= Htemp.
      rewrite (proof_irrelevance _ Htemp Heqn); clear Htemp => Hindof.
      apply IHn => //=.
      by rewrite (proof_irrelevance _ Heqn' Heqn).

    Qed.

  Lemma option_rcons_coerce B (xs : seq.seq B) x y : option_rcons (x :: xs) y = x :: (option_rcons xs y).
  Proof.
    by case: y =>//=.
  Qed.
  Lemma fixlist_unwrap_eq (m : nat)  (xs ys : fixlist m) :
      tval xs = tval ys ->
      fixlist_unwrap xs = fixlist_unwrap ys.
  Proof.
    move: xs ys => [xs Hxs] [ys Hys]; move: xs ys Hxs Hys.
    elim: m => //= [ [ |  //= ] [ | //= ] Hxs Hys _ | m IHm [ //= | x xs] [ //= | y ys] Hxs Hys ].
    by rewrite (proof_irrelevance _ Hxs Hys).
    by move=> Heq; move: Hxs Hys; rewrite Heq => Hxs Hys; rewrite (proof_irrelevance _ Hxs Hys).
  Qed.

  Lemma option_cons_ident B (ls : seq.seq B) : ls = option_cons None ls.
  Proof.
      by [].
  Qed.

  Lemma option_rcons_ident B (ls : seq.seq B) : ls = option_rcons ls None .
  Proof.
      by [].
  Qed.

  Lemma fixlist_length_bounds (m : nat) (ls : fixlist m) : fixlist_length ls  < m.+1.
  Proof.
    move: ls => []; elim: m => [ | m IHm ] [//= | ] x xs Hxs.
    by move: Hxs => //=.
    case: x Hxs => [ x | ] Hxs.
      move: Hxs (Hxs) => /eqP  Heqxs Hxs.
      move: Heqxs => //= []/eqP Heqxs.
      rewrite /fixlist_length fixlist_coerce_some//= -(addn1 (fixlist_length _)) -(addn1 m.+1).
      by rewrite ltn_add2r; apply IHm.
    rewrite /fixlist_length fixlist_coerce_none -(addn1 m.+1); apply ltn_addr.
    by apply IHm.
  Qed.

  Lemma fixlist_enqueue_unwrap' (m : nat) (a : option A) (list : fixlist m) :
    m > 0 ->
    let: (list', result) := fixlist_enqueue (a) list  in
        option_rcons (fixlist_unwrap list') result = option_cons a (fixlist_unwrap list).
  Proof.
    case Henq: (fixlist_enqueue (a) list) => [[n_ls Hn_ls] result].
    move: list a n_ls Hn_ls result  Henq => [].
    elim: m => //= m IHm  [//= | x xs] Hxs a [//=| y ys] Hys result .
    rewrite /ntuple_head/thead (tnth_nth x) //=.
    case Henq_eq : (fixlist_enqueue _ ) => [[xs' Hxs''] x'] [Hay Hxs' Hx'].
    move: Henq_eq.
    rewrite /ntuple_tail; move: (behead_tupleP _) => //= Hlenq.
    move: Hys.
    rewrite -Hx' -Hay -Hxs' => Hys Henq .
    rewrite ltnS leq_eqVlt => /orP [/eqP Hmeq0 | Hmlt ].
    move: (Hlenq); rewrite -{1}Hmeq0 => /eqP/size0nil Hnil.
    move: Hxs Hlenq Henq ; rewrite Hnil //= => Hxs Hleqn .
    move:  Hleqn (Hleqn) IHm xs Hnil xs' Hxs'' Hxs' Hys Hmeq0 Hxs => /eqP <- //=.
    move=>  Hleqn IHm xs Hnil [ | x0 xs0] .
      move=> Hxs'' _ Hys _ Hxs [] -> //=.
      have Hprf: (size [:: Some a] == 1). by[].
      rewrite /fixlist_unwrap/option_rcons/option_cons//=.
      by case: x' Hx' => //=; case: a Hay Hprf => //=.
    by move=> Hxs'' Hys0 Hys _ Hxs [] //=.

    move: Hys (Hys) => /eqP [] /eqP Hlx' Hys.
    case: a Hay Hys => [a Hay Hys | Hay Hys] .
      rewrite fixlist_coerce_some.
      rewrite option_rcons_coerce.
      rewrite (@IHm xs _ x xs') //=; last first.
        by rewrite Henq (proof_irrelevance _ Hxs'' Hlx').

      case: x Hxs Henq => [ x | ] Hxs Henq.
        by rewrite fixlist_coerce_some //=.
      by rewrite fixlist_coerce_none //=.
    rewrite fixlist_coerce_none.
    case: x Hxs Henq => [ x | ] Hxs Henq; last first.
    rewrite fixlist_coerce_none.
    rewrite -(IHm _ _ _ xs' _ x') //=.
    by rewrite Henq (proof_irrelevance _ Hxs'' Hlx').
    rewrite fixlist_coerce_some /option_cons.
    by rewrite (IHm xs _ (Some x)) => //=; rewrite Henq (proof_irrelevance _ Hxs'' Hlx').
  Qed.

  Lemma fixlist_enqueue_unwrap (m : nat) (a result: option A) (list : fixlist m) list' :
    m > 0 ->
      (list', result) = fixlist_enqueue (a) list ->
        option_rcons (fixlist_unwrap list') result = option_cons a (fixlist_unwrap list).
  Proof.
    move=>/fixlist_enqueue_unwrap' H Heqn.
    move: (H a list).
    by rewrite -Heqn => //=.
  Qed.

  Lemma fixlist_enqueue_unwrap_some (m : nat) (a : A) (list list': fixlist m) result :
    m > 0 ->
      (list', result) = fixlist_enqueue (Some a) list  ->
        option_rcons (fixlist_unwrap list') result = a :: (fixlist_unwrap list).
  Proof.
    move=> Hlvd Henq.
    by rewrite (@fixlist_enqueue_unwrap _ (Some a) _ list) => //=.
  Qed.

  Lemma fixlist_enqueue_preserves_full (m : nat) (a : A) (list list': fixlist m) :
    m > 0 ->
    fixlist_is_full list ->
    fst (fixlist_enqueue (Some a) list) = list' ->
    fixlist_is_full list'.
  Proof.
    move: list list' => [xs Hxs] [ys Hys]; move: a xs ys Hxs Hys.
    elim: m => //= m IHm a [ //= | x xs] [ //= | y ys] Hxs Hys.
      rewrite ltnS leq_eqVlt => /orP [].
      move=>/eqP Hm0.
      rewrite /fixlist_is_full //=.
      move: Hxs Hys; rewrite -Hm0 => Hxs Hys; rewrite /fixlist_length //=.
      case: x Hxs => //= [x | ] Hxs.
          move=>/eqP [] => His_empty.
          rewrite/tuple //=/ntuple_tail; move: (behead_tupleP _) => //= Hln; move: Hln (Hln).
          move=>/eqP/size0nil-> //= Hlen.
          move: (valP _) => //= Hlen'.
          by move=> []  => <- Heqn; move: Hys; rewrite -Heqn => //=.
      rewrite fixlist_coerce_none //= => H1.
      move=> [Hay Hxn].
      move: Hys; rewrite -Hay -Hxn => Hys //=.
      move: H1; rewrite /fixlist_unwrap //=.
      by move: Hxs => /eqP [] /size0nil -> //=.
    move=> Hmltn; rewrite /fixlist_is_full/fixlist_length.
    case: x Hxs => [x|] Hxs.
      move: Hxs (Hxs) => /eqP [] /eqP Hx'eqn Hxs.
      rewrite fixlist_coerce_some //= => /eqP [] /eqP Hlen.
      rewrite /ntuple_head/thead (tnth_nth (some x)) //=.
      rewrite /ntuple_tail//=; move: (behead_tupleP _) => //= Hxs_sz.
      case Henq: (fixlist_enqueue _) => [[result Hresult] output] => [[ Hay Hres]].
      move: Hys; rewrite -Hay => Hys; move: Hys (Hys) => /eqP [] /eqP Hybeq Hys; rewrite fixlist_coerce_some //=.
      apply/eqP/f_equal/eqP.
      apply IHm with (xs:= xs) (Hxs:= Hxs_sz) (a:=x) => //=.
      rewrite Henq //=; clear Henq.
      move: Hresult; rewrite Hres => Hresult.
      by rewrite (proof_irrelevance _ Hresult Hybeq).
    move: Hxs (Hxs) => /eqP [] /eqP Hxs_len Hxs.
    rewrite fixlist_coerce_none => Hxslen.
    move: (fixlist_length_bounds (Tuple (n:=m) (tval:=xs) Hxs_len)) .
    rewrite ltn_neqAle => /andP [/negP Hlt Hlen].
    by move: (Hlt Hxslen).
  Qed.

  Lemma tnth_tuple_cons B m n (x : B) xs : forall prf0 prf1 prf2 prf3,
    tnth (Tuple (n:=m.+1) (tval:=x :: xs) prf0) (Ordinal (n:=m.+1) (m:=n.+1) prf1) =
    tnth (Tuple (n:=m) (tval:=xs) prf2) (Ordinal (n:=m) (m:=n) prf3).
  Proof.
    move: n; elim: m => [//=|] m IHm n.
    move=> Hprf0 Hprf1 Hprf2 Hprf3.
    rewrite (tnth_nth x) //=.
    rewrite (tnth_nth x) //=.
  Qed.

  Lemma fixlist_get_nth_coerce m (xs : fixlist m) x n : forall Hxxs Hxs,
    fixlist_get_nth (Tuple (n:=m.+1) (tval:=x :: xs) Hxxs) n.+1 =
    fixlist_get_nth (Tuple (n:=m) (tval:=xs) Hxs) n.
  Proof.
    move=> Hxxs Hxs.
    rewrite /fixlist_get_nth//=.
    move:  {1}(erefl (_ < _)).
    case Hnlm: {2 3}(n.+1 < m.+1); move: Hnlm;
    rewrite -{1}(addn1 m) -{1}(addn1 n) {1}ltn_add2r => Hlmn;
    move: (erefl ( _ < _)); rewrite {2 3}Hlmn => Htmp //=.
    move: xs x Hxxs Hxs => [xs Hxxslen] x Hxxs //= Hxs.
    rewrite (proof_irrelevance _ Hxs Hxxslen); clear Hxs.
    rewrite (proof_irrelevance _ Htmp Hlmn); clear Htmp => Hprf.
    move: {1}(erefl _); case Htnth_eq: (tnth _) => [v] _.
      move: Htnth_eq => //= <-.
      rewrite (@tnth_tuple_cons _ _ _ _ _ Hxxs Hprf  Hxxslen Hlmn) //=.
      by move: (erefl _); case Htnth_eq: (tnth _).
    move: Htnth_eq => {1}<- .
    rewrite (@tnth_tuple_cons _ _ _ _ _ Hxxs Hprf  Hxxslen Hlmn) //=.
    by move: (erefl _); case Htnth_eq: (tnth _).
  Qed.

  Lemma fixlist_get_nth_full_succeed m (ls:fixlist m) n :
    n < m ->
    fixlist_is_full ls ->
    exists a, (fixlist_get_nth ls n) = Some a.
  Proof.
    move: ls n => []; elim: m =>  [//= | ] m IHm [//= | x xs] Hxs n .
    move: x xs Hxs.
    elim: n =>  [//= | n IHn ] x xs Hxs.
      case: x Hxs => [x | ] Hxs.
        by move=> Hlen; exists x; rewrite /fixlist_get_nth //=.
      rewrite /fixlist_is_full//= /fixlist_length fixlist_coerce_none=> _ Hxslen.
      move: (fixlist_length_bounds (Tuple (n:=m) (tval:=xs) Hxs)) .
      rewrite ltn_neqAle => /andP [/negP Hlt Hlen].
      by move: (Hlt Hxslen).
    move: Hxs (Hxs) => /eqP [] /eqP Hxs' Hxs.
    case: xs Hxs Hxs' => [ //=  | x0 xs] Hxs Hxs'.
      case: n IHn => //= n IHn.
      by move: IHn; move/eqP: (Hxs) => {1}<-; rewrite ltnn.
      by move/eqP: (Hxs) => {1}<- //=.
    move/eqP: (Hxs) =>  [] Hxlen.
    have Hxlen': (size (x0 :: xs) == m). by [].
    rewrite -{1}(addn1 n) -{1}(addn1 m) ltn_add2r => Hnltm Hfful.
    move: (IHm (x0 :: xs) Hxlen' n Hnltm) => [].
    move: (fixlist_length_bounds (Tuple Hxlen')).
    move: Hfful; rewrite /fixlist_is_full/fixlist_length//=.
    by case x=> //=; rewrite fixlist_coerce_none => /eqP ->; rewrite ltnn.
    move=> x' Hgnth; exists x'.
    by rewrite (@fixlist_get_nth_coerce m (Tuple Hxs') x n) => //=.
  Qed.

  Lemma fixlist_get_nth_base m (ls : fixlist m) a :
    m > 0 ->
    fixlist_get_nth (fixlist_enqueue (Some a) ls).1 0 = Some a.
  Proof.
    move: ls a => []; elim: m => [//=| ] m IHm [//= | x xs] Hxxs a.
    rewrite ltnS leq_eqVlt => /orP [/eqP Hm0 | H0ltm].
      by move: Hxxs; rewrite -Hm0 => //= .
    rewrite /fixlist_enqueue/ntuple_tail/ntuple_head/thead//=.
    rewrite -/fixlist_enqueue (tnth_nth x) //=.
    move: (behead_tupleP _) => //= Hlen.
    rewrite /fixlist_get_nth //=.
    move: (erefl (tnth  _ _)) => //=.
    by case: (fixlist_enqueue _) => //=.
  Qed.

  Lemma fixlist_get_nth_increment m (ls : fixlist m) n x :
    n.+1 < m ->
    fixlist_get_nth ls n = fixlist_get_nth (fixlist_enqueue x ls).1 n.+1.
  Proof.
    move: ls x n => []; elim: m => [//= | ] m IHm [//= | y ys] Hys x n Hltn.
    move: Hltn (Hltn); rewrite -{1}(addn1 n) -{1}(addn1 m) ltn_add2r => Hltnm Hltn.
    case: n Hltnm Hltn => [ | n ]//= Hltnm Htln .
      rewrite /ntuple_head/ntuple_tail/thead//= (tnth_nth y) //=.
      move: (behead_tupleP _) => //= Hlen.
      case Henq: (fixlist_enqueue _) => //= [[ls Hls] l].
      rewrite fixlist_get_nth_coerce//=.
      rewrite {2}/fixlist_get_nth //=.
      move: (erefl _).
      rewrite {2 3}Hltnm => //= Htmp.
      rewrite (proof_irrelevance _ Htmp Hltnm); clear Htmp.
      case: ls Hls Henq => [ | k ks].
        by move=> //= Hls; move: Hls (Hls) => /eqP Hm0;  move: Hltnm (Hltnm); rewrite -{1}Hm0.
      move=> Hls Henq.
      rewrite (tnth_nth k) => //=.
      have: (match k as o return (k = o -> option A) with
                | Some s => fun _ : k = Some s => Some s
                | None => fun _ : k = None => None
              end (erefl k)) = k. by case k => //=.
      move=> ->.
      have Hsm: (0 < m.+1). by[].
      rewrite /fixlist_get_nth//=; move:(erefl _) => Hprf.
      rewrite (tnth_nth y) //=.
      have: (match y as o return (y = o -> option A) with
              | Some s => fun _ : y = Some s => Some s
              | None => fun _ : y = None => None
            end (erefl y)) = y. by case y => //=.
      move=> ->.
      move: Henq; rewrite /fixlist_enqueue.
      rewrite /ntuple_head/thead /ntuple_tail//=.
      case: m Hlen Hls Hsm Hprf Hltnm Htln IHm Hys => //=.
      move=> m Hlen Hls Hsm Hprf Hltnm Htln IHm Hys .
      rewrite -/fixlist_enqueue.
      by case: (fixlist_enqueue _) => //= ls0 ls1 [].
    have Hyspred: size ys == m. by move: Hys => //=.
    rewrite (@fixlist_get_nth_coerce m (Tuple Hyspred)) //=.
    rewrite (IHm _ _ y) => //=.
    rewrite /ntuple_head/thead/ntuple_tail //= (tnth_nth y) //=.
    move: (behead_tupleP _) => //= Htmp; rewrite (proof_irrelevance _ Htmp Hyspred).
    case: (fixlist_enqueue _) => //= [[ls Hls]].
    by rewrite fixlist_get_nth_coerce //=.
  Qed.

  Lemma fixlist_get_nth_final m (ls : fixlist m)  x :
    0 < m ->
    fixlist_get_nth ls (m.-1) = (fixlist_enqueue x ls).2.
  Proof.
    move: ls x => []; elim: m => [//=  | m IHm [//=| y ys] ] Hprf x .
    rewrite ltnS leq_eqVlt => /orP [/eqP Hme0 | Hmlt].
      move: Hprf; rewrite -Hme0 => //= Hprf.
      move: Hprf (Hprf) => /eqP [] /size0nil Hy0 Hprf.
      rewrite /fixlist_get_nth/ntuple_head//=/thead !(tnth_nth y) //=.
      by move: (erefl _); case: y => //=.
    case: m Hmlt Hprf IHm => [//= | m ] Hmlt Hprf IHm.
    move: Hprf.
    have: (m.+2.-1 = m.+1.-1.+1). by [].
    move=> -> Hprf.
    have Hys: size ys == m.+1. by move: Hprf => //=.
    move: (@fixlist_get_nth_coerce m.+1 (Tuple Hys) y m.+1.-1) => //= ->.
    have: m = m.+1.-1. by [].
    move=> {3}->.
    rewrite (IHm _ _ x) => //=.
    rewrite /ntuple_head/ntuple_tail/thead //= .
    move: (behead_tupleP _) => //=  Hsize.
    move: (behead_tupleP _) => //= Hsize'.
    move: (behead_tupleP _) => //= Hsize''.
    rewrite (@tnth_nth m.+2 _ y) //=.
    case: ys Hprf Hys Hsize Hsize' Hsize'' => //= y' ys.
    move=> Hprf Hys Hsize Hsize' Hsize'' .
    rewrite (proof_irrelevance _ Hsize' Hys); clear Hsize'.
    rewrite (proof_irrelevance _ Hsize'' Hsize); clear Hsize''.
    by case: (fixlist_enqueue _ ) => //=.
  Qed.

  (* A couple of nicer forms of the lemmas for use in the main proof *)

  Lemma fixlist_get_nthP_base (P : option A -> Prop) m (ls ls' : fixlist m)  a :
    m > 0 ->
    ls' = (fixlist_enqueue (Some a) ls).1 ->
    P (Some a) ->
    P (fixlist_get_nth ls' 0).
  Proof.
    move=> Hmvld -> Hbase .
    by rewrite fixlist_get_nth_base //=.
  Qed.

  Lemma fixlist_get_nthP_increment (P : option A -> Prop) m (ls ls' : fixlist m) n k x :
    n.+1 < m ->
    k = n.+1 ->
    ls' = (fixlist_enqueue x ls).1 ->
    P (fixlist_get_nth ls n) ->
    P (fixlist_get_nth ls' k).
  Proof.
    by move=> Hnvld -> -> Hbase; rewrite -fixlist_get_nth_increment.
  Qed.

  Lemma fixlist_get_nthP_final (P : option A -> Prop) m (ls : fixlist m) n x a :
    0 < m ->
    n = m.-1 ->
    a = (fixlist_enqueue x ls).2 ->
    P (fixlist_get_nth ls n) ->
    P (a).
  Proof.
    by move=> Hnvld -> -> Hbase; rewrite -fixlist_get_nth_final.

  Qed.

  Lemma fixlist_get_nth_empty m  n  :
    fixlist_get_nth (fixlist_empty m) n = None.
  Proof.
    rewrite /fixlist_empty.
    rewrite /fixlist_get_nth//=.
    case: {2 3}(n < m) (erefl _) => //= Hltn.
    case Htnth: (tnth _) (erefl _)=> [res]//=.
    elim: n Hltn Htnth => //= [ | n ].
      by case: m => //=.

    case: m => //= m  IHn Hltn.
    rewrite !(tnth_nth None) //=.
    have Hobv (a b : nat) : nth None (ncons a None [::]) b =  None.
      elim: a b => [//= | //= a IHa b].
        by case => //=.
      by case: b => //=.
    by rewrite Hobv.
  Qed.

End fixlist.

Notation "[ ls <- x ]" := (@fixlist_insert _ _ ls x).
Notation "[ x -> ls ]" := (@fixlist_enqueue _ _ x ls).
Notation "[length  ls ]" := (@fixlist_length _ _ ls).
Notation "[unwrap  ls ]" := (@fixlist_unwrap _ _ ls).
Notation "[unwrap  ls <- x ]" := (@fixlist_unwrap _ _ (@fixlist_insert _ _ ls x)).
Notation "[unwrap  x -> ls ]" := (@fixlist_unwrap _ _ (@fixlist_enqueue _ _ x ls)).
Notation " ls <::< x " := (rcons ls x) (at level 50).


Require Import init.

Require Export analysis_norm.

(* begin hide *)
Section NormMetric.

Context {U V} `{
    Metric U,

    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    @PlusComm V VP,
    @PlusAssoc V VP,
    @PlusLid V VP VZ,
    @PlusLinv V VP VZ VN,

    SM : ScalarMult real V,
    @ScalarId real V real_one SM,
    @ScalarRdist real V real_plus VP SM,

    VA : AbsoluteValue V,
    @AbsDefinite V VA VZ,
    @AbsNeg V VA VN,
    @AbsTriangle V VA VP,
    @AbsPositive V VA
}.

Existing Instance abs_metric.
(* end hide *)
Theorem continuous_plus : ∀ (f g : U → V) x,
    continuous_at f x → continuous_at g x → continuous_at (λ a, f a + g a) x.
Proof.
    intros f g x f_cont g_cont.
    rewrite metric_continuous_seq in *.
    intros a ax.
    specialize (f_cont a ax).
    specialize (g_cont a ax).
    apply seq_lim_plus.
    -   exact f_cont.
    -   exact g_cont.
Qed.

Theorem continuous_bilinear : ∀ m x (f g : U → V),
    bilinear m → cauchy_schwarz m →
    continuous_at f x → continuous_at g x →
    continuous_at (λ a, m (f a) (g a)) x.
Proof.
    intros m x f g m_bil m_cs f_cont g_cont.
    rewrite metric_continuous_seq in *.
    intros a ax.
    specialize (f_cont a ax).
    specialize (g_cont a ax).
    apply seq_lim_bilinear; assumption.
Qed.
(* begin hide *)
End NormMetric.
(* end hide *)


Require Coq.Structures.Orders.
Require Coq.Classes.RelationClasses.
Require Coq.Arith.Compare_dec.
Require Coq.Arith.PeanoNat.

(** * Protocol Version *)

(** A _protocol version_ encodes the version number of a _semantically-versioned_
    protocol, consisting of a _major_ and _minor_ version. The _minor_ version
    is incremented on compatible changes, and the _major_ version is
    incremented on incompatible changes. *)

Record t := {
  major : nat;
  minor : nat
}.

(** A protocol version _x_ is defined to be _compatible_ with a protocol
    version _y_ if the major versions are equal. The basic assumption is that
    any peer that supports major version _M_ of a protocol _P_ can speak to any
    other peer that supports major version _M_ of _P_, regardless of the minor
    version supported by either peer. *)

Definition isCompatibleWith (x y : t) : Prop :=
  (major x) = (major y).

(** The _isCompatibleWith_ relation is reflexive. *)

Theorem isCompatibleWith_reflexive : forall x, isCompatibleWith x x.
Proof. intro x. apply eq_refl. Qed.

(** The _isCompatibleWith_ relation is symmetric. *)

Theorem isCompatibleWith_symmetric : forall x y,
  isCompatibleWith x y -> isCompatibleWith y x.
Proof.
  intros x y Hxy.
  apply eq_sym.
  exact Hxy.
Qed.

(** The _isCompatibleWith_ relation is transitive. *)

Theorem isCompatibleWith_transitive : forall x y z,
  isCompatibleWith x y -> isCompatibleWith y z -> isCompatibleWith x z.
Proof.
  unfold isCompatibleWith.
  intros x y z Hxy Hyz.
  rewrite Hxy.
  exact Hyz.
Qed.

(** The _isCompatibleWith_ relation is therefore an equivalence relation. *)

#[local]
Instance isCompatibleWith_Eq : RelationClasses.Equivalence isCompatibleWith.
Proof.
  constructor.
  exact isCompatibleWith_reflexive.
  exact isCompatibleWith_symmetric.
  exact isCompatibleWith_transitive.
Qed.

(** Protocol versions are ordered. *)

Module Ord : Orders.UsualOrderedType
  with Definition t := t.

  Definition t := t.
  Definition eq (x y : t) := x = y.

  Definition eq_refl  := @Logic.eq_refl t.
  Definition eq_sym   := @Logic.eq_sym t.
  Definition eq_trans := @Logic.eq_trans t.

  (** For a protocol version _x_ to be _less than_ a protocol version _y_,
      either the major version of _x_ is less than the major version of _y_,
      or the major versions of _x_ and _y_ are equal and the minor version of
      _x_ is less than the minor version of _y_. *)

  Definition lt (x y : t) : Prop :=
    major x < major y \/ (major x = major y /\ minor x < minor y).

  #[local]
  Instance lt_is_irreflexive : RelationClasses.Irreflexive lt.
  Proof.
    hnf; intro x; hnf.
    unfold lt.
    intro Hc.
    destruct Hc as [HcL|[HcR0 HcR1]].
    - pose proof (PeanoNat.Nat.lt_irrefl (major x)); contradiction.
    - pose proof (PeanoNat.Nat.lt_irrefl (minor x)); contradiction.
  Qed.

  #[local]
  Instance lt_is_transitive : RelationClasses.Transitive lt.
  Proof.
    hnf; intro x; hnf.
    unfold lt.
    intros y z [HxyL|[HxyR0 HxyR1]] [HyzL|[HyzR0 HyzR1]].
    - left; apply (PeanoNat.Nat.lt_trans _ _ _ HxyL HyzL).
    - rewrite HyzR0 in *; left; auto.
    - rewrite HxyR0 in *; left; auto.
    - right.
      constructor.
      * rewrite HxyR0 in *; exact HyzR0.
      * apply (PeanoNat.Nat.lt_trans _ _ _ HxyR1 HyzR1).
  Qed.

  #[local]
  Instance lt_strorder : RelationClasses.StrictOrder lt := { }.

  #[local]
  Instance eq_equiv : RelationClasses.Equivalence eq := { }.

  Theorem lt_compat : Morphisms.Proper (Morphisms.respectful Logic.eq (Morphisms.respectful Logic.eq iff)) lt.
  Proof.
    unfold Morphisms.Proper.
    unfold Morphisms.respectful.
    intros x y Heq0 x0 y0 Heq1.
    rewrite Heq0.
    rewrite Heq1.
    constructor; tauto.
  Qed.

  Definition compare (x y : t) : comparison :=
    match Nat.compare (major x) (major y) with
    | Eq => Nat.compare (minor x) (minor y)
    | Lt => Lt
    | Gt => Gt
    end.

  Definition compare_spec : forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y).
  Proof.
    intros x y.
    destruct (compare x y) eqn:Hcomp. {
      apply CompEq.
      unfold compare in Hcomp.
      destruct (Nat.compare (major x) (major y)) eqn:Hmajxy. {
        pose proof (Compare_dec.nat_compare_eq _ _ Hmajxy) as H0.
        pose proof (Compare_dec.nat_compare_eq _ _ Hcomp) as H1.
        destruct x as [xM xm].
        destruct y as [yM ym].
        auto.
      } {
        contradict Hcomp; discriminate.
      } {
        contradict Hcomp; discriminate.
      }
    } {
      apply CompLt.
      unfold compare in Hcomp.
      destruct (Nat.compare (major x) (major y)) eqn:Hmajxy. {
        pose proof (Compare_dec.nat_compare_eq _ _ Hmajxy) as H0.
        rewrite <- Compare_dec.nat_compare_lt in Hcomp.
        right; constructor; auto.
      } {
        rewrite <- Compare_dec.nat_compare_lt in Hmajxy.
        left; auto.
      } {
        contradict Hcomp; discriminate.
      }
    } {
      apply CompGt.
      unfold compare in Hcomp.
      destruct (Nat.compare (major x) (major y)) eqn:Hmajxy. {
        pose proof (Compare_dec.nat_compare_eq _ _ Hmajxy) as H0.
        pose proof (Compare_dec.nat_compare_Gt_gt _ _ Hcomp) as H1.
        unfold gt in H1.
        right; constructor.
        symmetry; auto.
        auto.
      } {
        contradict Hcomp; discriminate.
      } {
        pose proof (Compare_dec.nat_compare_Gt_gt _ _ Hmajxy) as H0.
        unfold gt in H0.
        left; auto.
      }
    }
  Qed.

  (** Protocol versions have decidable equality. *)

  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
  Proof.
    destruct x as [xM xm].
    destruct y as [yM ym].
    destruct (PeanoNat.Nat.eq_dec xM yM) as [HML|HMR]. {
      destruct (PeanoNat.Nat.eq_dec xm ym) as [HmL|HmR]. {
        subst xM.
        subst xm.
        left; reflexivity.
      } {
        right. intro Hc. assert (xm = ym) as H0 by congruence. contradiction.
      }
    } {
      right. intro Hc. assert (xM = yM) as H0 by congruence. contradiction.
    }
  Qed.

End Ord.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.arrival_sequence prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.uni.jitter.schedule
               prosa.classic.model.schedule.uni.jitter.platform.
Require Import prosa.classic.model.schedule.uni.transformation.construction.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop seq path.

Module ConcreteScheduler.

  Import Job ArrivalSequence UniprocessorScheduleWithJitter Platform Priority
         ScheduleConstruction.

  (* In this section, we implement a jitter-aware priority-based uniprocessor scheduler *)
  Section Implementation.

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

    (* Let arr_seq be any job arrival sequence. *)
    Variable arr_seq: arrival_sequence Job.

    (* Also, assume that a JLDP policy is given. *)
    Variable higher_eq_priority: JLDP_policy Job.

    (* Next, we show how to recursively construct the schedule. *)
    Section ScheduleConstruction.

      (* For any time t, suppose that we have generated the schedule prefix in the
         interval [0, t). Then, we must define what should be scheduled at time t. *)
      Variable sched_prefix: schedule Job.
      Variable t: time.

      (* For simplicity, let's use some local names. *)
      Let is_pending := pending job_arrival job_cost job_jitter sched_prefix.

      (* Consider the list of pending jobs with actual arrivals up to t. *)
      Definition pending_jobs :=
        [seq j <- actual_arrivals_up_to job_arrival job_jitter arr_seq t | is_pending j t].

      (* To make the scheduling decision, we just pick one of the highest-priority jobs
         that are pending (if it exists). *)
      Definition highest_priority_job :=
        seq_min (higher_eq_priority t) pending_jobs.

    End ScheduleConstruction.

    (* Starting from the empty schedule, the final schedule is obtained by iteratively
       picking the highest-priority job. *)
    Let empty_schedule : schedule Job := fun t => None.
    Definition scheduler :=
      build_schedule_from_prefixes highest_priority_job empty_schedule.

    (* Then, by showing that the construction function depends only on the prefix, ... *)
    Lemma scheduler_depends_only_on_prefix:
      forall sched1 sched2 t,
        (forall t0, t0 < t -> sched1 t0 = sched2 t0) ->
        highest_priority_job sched1 t = highest_priority_job sched2 t.
    Proof.
      intros sched1 sched2 t ALL.
      rewrite /highest_priority_job.
      suff SAME: pending_jobs sched1 t = pending_jobs sched2 t by rewrite SAME.
      apply eq_in_filter.
      intros j IN; rewrite mem_filter in IN.
      move: IN => /andP [ARR IN].
      rewrite ltnS /= in ARR.
      rewrite /pending /jitter_has_passed ARR 2!andTb; f_equal.
      rewrite /completed_by; f_equal.
      apply eq_big_nat; move => i /= LTi.
      by rewrite /service_at /scheduled_at ALL.
    Qed.

    (* ...we infer that the generated schedule is indeed based on the construction function. *)
    Corollary scheduler_uses_construction_function:
      forall t, scheduler t = highest_priority_job scheduler t.
    Proof.
      by ins; apply prefix_dependent_schedule_construction,
                    scheduler_depends_only_on_prefix.
    Qed.

  End Implementation.

  (* In this section, we prove the properties of the scheduler that are used
     as hypotheses in the analyses. *)
  Section Proofs.

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

    (* Assume any job arrival sequence with consistent, duplicate-free arrivals. *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_no_duplicate_arrivals: arrival_sequence_is_a_set arr_seq.

    (* Consider any JLDP policy that is reflexive, transitive and total. *)
    Variable higher_eq_priority: JLDP_policy Job.
    Hypothesis H_priority_is_reflexive: JLDP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: JLDP_is_transitive higher_eq_priority.
    Hypothesis H_priority_is_total: JLDP_is_total arr_seq higher_eq_priority.

    (* Let sched denote our concrete scheduler implementation. *)
    Let sched := scheduler job_arrival job_cost job_jitter arr_seq higher_eq_priority.

    (* To conclude, we prove the important properties of the scheduler implementation. *)

    (* First, we show that scheduled jobs come from the arrival sequence. *)
      Lemma scheduler_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched arr_seq.
      Proof.
        move => j t /eqP SCHED.
        rewrite /sched scheduler_uses_construction_function // /highest_priority_job in SCHED.
        apply seq_min_in_seq in SCHED.
        rewrite mem_filter in SCHED.
        move: SCHED => /andP [_ ARR].
        rewrite /actual_arrivals_up_to in ARR.
        by apply in_actual_arrivals_between_implies_arrived in ARR.
      Qed.

    (* Next, we show that jobs do not execute before they arrive...*)
    Theorem scheduler_jobs_execute_after_jitter:
      jobs_execute_after_jitter job_arrival job_jitter sched.
    Proof.
      move => j t /eqP SCHED.
      rewrite /sched scheduler_uses_construction_function // /highest_priority_job in SCHED.
      apply seq_min_in_seq in SCHED.
      rewrite mem_filter in SCHED.
      by move: SCHED => /andP [/andP [ARR _] _].
    Qed.

    (* ... nor after completion. *)
    Theorem scheduler_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.
    Proof.
      intros j t.
      induction t;
        first by rewrite /service /service_during big_geq //.
      rewrite /service /service_during big_nat_recr //=.
      rewrite leq_eqVlt in IHt; move: IHt => /orP [/eqP EQ | LT]; last first.
      {
        apply: leq_trans LT; rewrite -addn1.
          by apply leq_add; last by apply leq_b1.
      }
      rewrite -[job_cost _]addn0; apply leq_add; first by rewrite -EQ.
      rewrite leqn0 eqb0 /scheduled_at.
      rewrite /sched scheduler_uses_construction_function /highest_priority_job.
      apply/eqP; intro HP.
      apply seq_min_in_seq in HP.
      by rewrite mem_filter /pending /completed_by -EQ leqnn andbF /= in HP.
    Qed.

    (* In addition, the scheduler is work conserving... *)
    Theorem scheduler_work_conserving:
      work_conserving job_arrival job_cost job_jitter arr_seq sched.
    Proof.
      intros j t IN BACK.
      move: BACK => /andP [/andP [ARR NOTCOMP] NOTSCHED].
      rewrite /scheduled_at /sched scheduler_uses_construction_function /= in NOTSCHED.
      rewrite /scheduled_at /sched scheduler_uses_construction_function /=.
      case HP: (highest_priority_job _ _ _ _ _ ) => [j_hp|]; first by exists j_hp.
      set hp := highest_priority_job _ _ _ _ _ _ _ in NOTSCHED HP.
      suff BUG: hp != None by rewrite HP in BUG.
      apply seq_min_exists with (x := j).
      rewrite mem_filter /pending ARR NOTCOMP /=.
      by eapply arrived_between_implies_in_actual_arrivals, ARR.
    Qed.

    (* ... and respects the JLDP policy. *)
    Theorem scheduler_respects_policy :
      respects_JLDP_policy job_arrival job_cost job_jitter arr_seq sched higher_eq_priority.
    Proof.
      rename H_priority_is_transitive into TRANS, H_priority_is_total into TOTAL.
      move => j1 j2 t ARR1 BACK /eqP SCHED.
      move: BACK => /andP [/andP [ARR NOTCOMP] NOTSCHED].
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in NOTSCHED.
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in SCHED.
      rewrite /highest_priority_job in SCHED NOTSCHED.
      set jobs := pending_jobs _ _ _ _ _ _ in SCHED NOTSCHED.
      have IN: j1 \in jobs.
      {
        rewrite mem_filter /pending ARR NOTCOMP /=.
        by eapply arrived_between_implies_in_actual_arrivals, ARR.
      }
      apply seq_min_computes_min with (y := j1) in SCHED; try (by done).
      intros x y; rewrite /jobs mem_filter [y \in _]mem_filter.
      move => /andP [_ INx] /andP [_ INy].
      rewrite /actual_arrivals_up_to in INx INy.
      by apply TOTAL; eapply in_actual_arrivals_between_implies_arrived; eauto 2.
    Qed.

  End Proofs.

End ConcreteScheduler.


Require Export ListSets.

Section NFA.

Context {State Symbol : Type}.
Definition Word := ListSet Symbol.

Hypothesis State_eq_dec : forall (x1 x2:State), { x1 = x2 } + { x1 <> x2 }.
Hypothesis Symbol_eq_dec : forall (x1 x2:Symbol), { x1 = x2 } + { x1 <> x2 }.

Inductive NFA_comp :=
  | state (q:State)
  | symbol (a:Symbol)
  | start (q:State)
  | accept (q:State)
  | transition (q1:State) (a:Symbol) (q2:State).

Definition NFA := ListSet NFA_comp.

Fixpoint states (g:NFA) :=
  match g with
  | state q::g => q::states g
  | start q::g => q::states g
  | accept q::g => q::states g
  | transition q1 a q2::g => q1::q2::states g
  | _::g => states g
  | nil => nil
  end.

Fixpoint alphabet (g:NFA) :=
  match g with
  | symbol a::g => a::alphabet g
  | transition q1 a q2::g => a::alphabet g
  | _::g => alphabet g
  | nil => nil
  end.

Fixpoint start_states (g:NFA) :=
  match g with
  | start q::g => q::start_states g
  | _::g => start_states g
  | nil => nil
  end.

Fixpoint accept_states (g:NFA) :=
  match g with
  | accept q::g => q::accept_states g
  | _::g => accept_states g
  | nil => nil
  end.

(* Transition function *)
Fixpoint transitionf (g:NFA) s a :=
  match g with
  | transition q1 b q2::g =>
    (if In_dec State_eq_dec q1 s then
      (if Symbol_eq_dec b a then [q2] else nil)
    else nil) ++ transitionf g s a
  | _::g => transitionf g s a
  | nil => nil
  end.

(* Extended transition function *)
Fixpoint ext_transitionf (g:NFA) s w :=
  match w with
  | a::w => ext_transitionf g (transitionf g s a) w
  | nil => s
  end.

(* In states decomposition *)
Lemma in_states q g :
  In q (states g) <->
  In (state q) g \/
  In (start q) g \/
  In (accept q) g \/
  (exists a q', In (transition q a q') g) \/
  (exists a q', In (transition q' a q) g).
Proof.
  induction g as [|c g IH]. {
    split; intro.
    contradiction.
    destruct H.
    2: destruct H.
    3: destruct H.
    4: destruct H.
    4,5: destruct H as [a [q' H]].
    1-5: contradiction.
  }
  destruct c; simpl.
  2: {
    split; intro H.
    - apply IH in H.
      destruct H.
      2: destruct H.
      3: destruct H.
      1-3: intuition.
      destruct H as [[b [q' H]]|[b [q' H]]].
      right; right; right; left; exists b, q'; intuition.
      repeat right; exists b, q'; intuition.
    - apply IH.
      destruct H as [[H|H]|H]; try discriminate.
      intuition.
      destruct H as [[H|H]|H]; try discriminate.
      intuition.
      destruct H as [[H|H]|H]; try discriminate.
      intuition.
      destruct H as [[b [q' [H|H]]]|H]; try discriminate.
      right; right; right; left; exists b, q'; intuition.
      destruct H as [b [q' [H|H]]]; try discriminate.
      repeat right; exists b, q'; intuition.
  }
  - split; intro H.
    + destruct H.
      subst; intuition.
      apply IH in H.
      destruct H.
      2: destruct H.
      3: destruct H.
      1-3: intuition.
      destruct H as [[b [q' H]]|[b [q' H]]].
      right; right; right; left; exists b, q'; intuition.
      right; right; right; right; exists b, q'; intuition.
    + destruct H.
      destruct H.
      injection H; intros; subst; intuition.
      right; apply IH; intuition.
      destruct H.
      destruct H; try discriminate.
      right; apply IH; intuition.
      destruct H.
      destruct H; try discriminate.
      right; apply IH; intuition.
      destruct H as [[b [q' [H|H]]]|[b [q' [H|H]]]]; try discriminate.
      1,2: right; apply IH.
      right; right; right; left; exists b, q'; intuition.
      repeat right; exists b, q'; intuition.
  - split; intro H.
    + destruct H.
      subst; intuition.
      apply IH in H.
      destruct H.
      2: destruct H.
      3: destruct H.
      1-3: intuition.
      destruct H as [[a [q' H]]|[a [q' H]]].
      right; right; right; left; exists a, q'; intuition.
      right; right; right; right; exists a, q'; intuition.
    + destruct H.
      destruct H; try discriminate.
      right; apply IH; intuition.
      destruct H.
      destruct H.
      injection H; intros; subst; intuition.
      right; apply IH; intuition.
      destruct H.
      destruct H; try discriminate.
      right; apply IH; intuition.
      destruct H as [[a [q' [H|H]]]|[a [q' [H|H]]]]; try discriminate.
      1,2: right; apply IH.
      right; right; right; left; exists a, q'; intuition.
      repeat right; exists a, q'; intuition.
  - split; intro H.
    + destruct H.
      subst; intuition.
      apply IH in H.
      destruct H.
      2: destruct H.
      3: destruct H.
      1-3: intuition.
      destruct H as [[a [q' H]]|[a [q' H]]].
      right; right; right; left; exists a, q'; intuition.
      right; right; right; right; exists a, q'; intuition.
    + destruct H.
      destruct H; try discriminate.
      right; apply IH; intuition.
      destruct H.
      destruct H; try discriminate.
      right; apply IH; intuition.
      destruct H.
      destruct H.
      injection H; intros; subst; intuition.
      right; apply IH; intuition.
      destruct H as [[a [q' [H|H]]]|[a [q' [H|H]]]]; try discriminate.
      1,2: right; apply IH.
      right; right; right; left; exists a, q'; intuition.
      repeat right; exists a, q'; intuition.
  - split; intro H.
    + destruct H.
      subst; right; right; right; left; exists a, q2; intuition.
      destruct H.
      subst; repeat right; exists a, q1; intuition.
      apply IH in H.
      destruct H.
      2: destruct H.
      3: destruct H.
      1-3: intuition.
      destruct H as [[b [q' H]]|[b [q' H]]].
      right; right; right; left; exists b, q'; intuition.
      right; right; right; right; exists b, q'; intuition.
    + destruct H.
      destruct H; try discriminate.
      repeat right; apply IH; intuition.
      destruct H.
      destruct H; try discriminate.
      repeat right; apply IH; intuition.
      destruct H.
      destruct H; try discriminate.
      repeat right; apply IH; intuition.
      destruct H as [[b [q' [H|H]]]|[b [q' [H|H]]]].
      injection H; intros; subst; intuition.
      2: injection H; intros; subst; intuition.
      1,2: repeat right; apply IH.
      right; right; right; left; exists b, q'; intuition.
      repeat right; exists b, q'; intuition.
Qed.

(* In start_states decomposition *)
Lemma in_start_states q g :
  In q (start_states g) <-> In (start q) g.
Proof.
  induction g as [|c g IH].
  intuition.
  simpl; destruct c.
  3: {
    split; intro H.
    destruct H; subst; intuition.
    destruct H.
    injection H; intros; subst.
    1,2: intuition.
  }
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
  (* same code from above: *)
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
  (* same code from above: *)
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
  (* same code from above: *)
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
Qed.

(* In accept_states decomposition *)
Lemma in_accept_states q g :
  In q (accept_states g) <-> In (accept q) g.
Proof.
  (* same proof from in_start_states: *)
  induction g as [|c g IH].
  intuition.
  simpl; destruct c.
  4: {
    split; intro H.
    destruct H; subst; intuition.
    destruct H.
    injection H; intros; subst.
    1,2: intuition.
  }
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
  (* same code from above: *)
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
  (* same code from above: *)
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
  (* same code from above: *)
  - split; intro H.
    right.
    2: destruct H; try discriminate.
    1,2: intuition.
Qed.

(* A state in the concatenation of two NFAs is in at least one of them *)
Lemma in_states_app g1 g2 q :
  In q (states (g1 ++ g2)) <->
  In q (states g1) \/ In q (states g2).
Proof.
  induction g1 as [|c g1 IH].
  simpl; intuition.
  destruct c; simpl.
  2: trivial.
  - split; intro H.
    destruct H; subst; intuition.
    apply or_assoc in H; destruct H; subst; intuition.
  (* same code from above: *)
  - split; intro H.
    destruct H; subst; intuition.
    apply or_assoc in H; destruct H; subst; intuition.
  (* same code from above: *)
  - split; intro H.
    destruct H; subst; intuition.
    apply or_assoc in H; destruct H; subst; intuition.
  - split; intro H.
    destruct H.
    2: destruct H.
    1-3: subst; intuition.
    apply or_assoc in H; destruct H.
    2: apply or_assoc in H; destruct H.
    1,2: subst; intuition.
    intuition.
Qed.

(* An accept state in the concatenation of two NFAs is in at least one of them *)
Lemma in_accept_states_app g1 g2 q :
  In q (accept_states (g1 ++ g2)) <->
  In q (accept_states g1) \/ In q (accept_states g2).
Proof.
  induction g1 as [|c g1 IH].
  simpl; intuition.
  destruct c; simpl.
  1-3,5: trivial.
  split; intro H.
  destruct H; subst; intuition.
  apply or_assoc in H; destruct H; subst; intuition.
Qed.

(* A start state is a state *)
Lemma start_state g q :
  In q (start_states g) -> In q (states g).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1,2,4,5: apply IH in H; try right; intuition.
  destruct H.
  - subst.
    simpl; intuition.
  - right; intuition.
Qed.

(* The start states of the concatenation of two NFAs is the their start states concatenated *)
Lemma start_states_app g1 g2 :
  start_states (g1 ++ g2) = start_states g1 ++ start_states g2.
Proof.
  induction g1 as [|c g1 IH].
  intuition.
  simpl; destruct c;
  simpl; rewrite IH; intuition.
Qed.

(* Transition function decomposition *)
Lemma transition_transitionf g q1 a q2 :
  In (transition q1 a q2) g <-> In q2 (transitionf g [q1] a).
Proof.
  induction g as [|c g IH].
  intuition.
  destruct c; simpl.
  1-4: split; intro H; try destruct H as [H|H]; try discriminate; intuition.
  destruct (State_eq_dec q1 q0) as [H|H].
  - subst; destruct (Symbol_eq_dec a0 a) as [H|H].
    + subst; split; intro H.
      * destruct H.
        inversion H; subst.
        1,2: intuition.
      * destruct H; subst; intuition.
    + split; intro H0.
      * destruct H0.
        inversion H0; subst.
        1,2: intuition.
      * intuition.
  - split; intro H0.
    + destruct H0.
      inversion H0; subst.
      1,2: intuition.
    + intuition.
Qed.

(*
  The transition function applied to two sets concatenated returns a state returned
  by the transition function applied to one of the sets
*)
Lemma in_transitionf_app g q s1 s2 a :
  In q (transitionf g (s1 ++ s2) a) -> In q (transitionf g s1 a) \/ In q (transitionf g s2 a).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1-4: apply IH in H; destruct H; intuition.
  simpl; simpl in H;
  destruct (in_dec State_eq_dec q1 (s1 ++ s2)) as [H0|H0]; destruct (Symbol_eq_dec a0 a) as [H1|H1];
  subst.
  apply in_app_or in H; destruct H. {
    apply in_singleton in H; subst.
    apply in_app_or in H0; destruct H0.
    - destruct (in_dec State_eq_dec q1 s1).
      intuition.
      contradiction.
    - destruct (in_dec State_eq_dec q1 s2).
      intuition.
      contradiction.
  }
  1-4: apply IH in H; destruct H.
  1,3,5,7: left; apply in_or_app; intuition.
  1-4: right; apply in_or_app; intuition.
Qed.

(*
  The transition function applied to a set returns a state returned
  by the transition function applied to a single state in the set
*)
Lemma transitionf_singleton g s q2 a :
  In q2 (transitionf g s a) -> exists q1,
  In q1 s /\ In q2 (transitionf g [q1] a).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1-4: apply IH in H; destruct H as [q1 H]; exists q1; intuition.
  simpl in H; destruct (in_dec State_eq_dec q1 s).
  destruct (Symbol_eq_dec a0 a).
  destruct H.
  2-4: apply IH in H; destruct H as [q3 H]; exists q3; split; simpl; try (apply in_or_app); intuition.
  subst.
  exists q1; split.
  2: simpl; destruct (State_eq_dec q1 q1).
  2: destruct (Symbol_eq_dec a a).
  1-4: intuition.
Qed.

(* The reciprocal *)
Lemma transitionf_generalize g s q1 q2 a :
  In q1 s -> In q2 (transitionf g [q1] a) ->
  In q2 (transitionf g s a).
Proof.
  intros H H0.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1-4: intuition.
  simpl; simpl in H0.
  destruct (State_eq_dec q1 q0).
  destruct (Symbol_eq_dec a0 a).
  destruct H0.
  2-4: apply in_or_app; intuition.
  subst.
  destruct (in_dec State_eq_dec q0 s).
  intuition.
  contradiction.
Qed.

(*
  Given two equivalent states, the transition function applied to them
  returns equivalent sets
*)
Lemma transitionf_equiv g s1 s2 a :
  equiv_sets State s1 s2 ->
  equiv_sets State (transitionf g s1 a) (transitionf g s2 a).
Proof.
  intro H; induction g as [|c g IH].
  apply equiv_sets_self.
  destruct c.
  1-4: intuition.
  simpl.
  destruct (in_dec State_eq_dec q1 s1) as [H0|H0];
  destruct (in_dec State_eq_dec q1 s2) as [H1|H1].
  4: intuition.
  2: apply H in H0.
  3: apply H in H1.
  2,3: contradiction.
  destruct (Symbol_eq_dec a0 a) as [H2|H2].
  2: intuition.
  simpl; split; intros q [H3|H3]; subst.
  1,3: intuition.
  1,2: right; apply IH; intuition.
Qed.

(* A set cannot be nil if the transition function applied to it returns something *)
Lemma ext_transitionf_not_nil g s w q :
  In q (ext_transitionf g s w) ->
  exists q', In q' s.
Proof.
  revert s.
  induction w as [|a w IH];
  intros s H.
  exists q; intuition.
  simpl in H; apply IH in H.
  destruct H as [q0 H].
  clear IH.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  5: simpl in H; apply in_app_or in H; destruct H.
  1-4,6: intuition.
  destruct (in_dec State_eq_dec q1 s).
  destruct (Symbol_eq_dec a0 a).
  2,3: contradiction.
  exists q1; intuition.
Qed.

(* Rewrite rule on the extended transition function for concatenation of words *)
Lemma ext_transitionf_app g s w1 w2 :
  ext_transitionf g s (w1 ++ w2) = ext_transitionf g (ext_transitionf g s w1) w2.
Proof.
  revert s;
  induction w1 as [|a1 w1 IH];
  intro s.
  intuition.
  apply IH.
Qed.

(*
  The extended transition function applied to two sets concatenated returns a state returned
  by the transition function applied to one of the sets
*)
Lemma in_ext_transitionf_app g q s1 s2 w :
  In q (ext_transitionf g (s1 ++ s2) w) <-> In q (ext_transitionf g s1 w) \/ In q (ext_transitionf g s2 w).
Proof.
  generalize dependent q;
  induction w as [|a w IH] using rev_ind;
  intro q.
  simpl; split; intro H.
  apply in_app_or.
  2: apply in_or_app.
  1,2: intuition.
  split; intro H.
  - repeat rewrite ext_transitionf_app; rewrite ext_transitionf_app in H; simpl; simpl in H.
    apply transitionf_singleton in H.
    destruct H as [q1 [H H0]].
    apply IH in H.
    destruct H.
    left.
    2: right.
    1,2: apply transitionf_generalize with q1; intuition.
  - rewrite ext_transitionf_app; repeat rewrite ext_transitionf_app in H; simpl; simpl in H.
    destruct H.
    + apply transitionf_singleton in H.
      destruct H as [q1 [H H0]].
      assert (In q1 (ext_transitionf g s1 w) \/ In q1 (ext_transitionf g s2 w)).
      2: apply IH in H1.
      2: apply transitionf_generalize with q1.
      1-3: intuition.
    (* same code from above: *)
    + apply transitionf_singleton in H.
      destruct H as [q1 [H H0]].
      assert (In q1 (ext_transitionf g s1 w) \/ In q1 (ext_transitionf g s2 w)).
      2: apply IH in H1.
      2: apply transitionf_generalize with q1.
      1-3: intuition.
Qed.

(*
  The extended transition function applied to a single state can be generalized
  for a set of states
*)
Lemma ext_transitionf_generalize g s q1 q2 w :
  In q1 s -> In q2 (ext_transitionf g [q1] w) ->
  In q2 (ext_transitionf g s w).
Proof.
  intros H H0.
  apply in_split in H.
  destruct H as [s1 [s2 H]]; subst.
  apply in_ext_transitionf_app; right.
  replace (q1 :: s2) with ([q1] ++ s2).
  apply in_ext_transitionf_app.
  1,2: intuition.
Qed.

(* The reciprocal *)
Lemma ext_transitionf_singleton g s q2 w :
  In q2 (ext_transitionf g s w) -> exists q1,
  In q1 s /\ In q2 (ext_transitionf g [q1] w).
Proof.
  generalize dependent s;
  induction w as [|a w IH];
  intros s H; simpl in H.
  exists q2; simpl; intuition.
  apply IH in H; destruct H as [q1 [H H0]]; clear IH.
  assert (exists q0, In q0 s /\ In q1 (transitionf g [q0] a)). {
    apply transitionf_singleton; intuition.
  }
  destruct H1 as [q0 [H1 H2]].
  exists q0; split.
  intuition.
  simpl; apply ext_transitionf_generalize with q1; intuition.
Qed.

(* Transition decomposition into states and alphabet *)
Lemma transition_states_alphabet g q1 a q2 :
  In (transition q1 a q2) g ->
  In q1 (states g) /\ In a (alphabet g) /\ In q2 (states g).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1-4: destruct H; try discriminate; apply IH in H; repeat split; try right; intuition.
  destruct H.
  - injection H; intros; subst; repeat split.
    1,2: left.
    3: right; left.
    1-3: intuition.
  - apply IH in H; repeat split; try right; intuition.
Qed.

(* The transition function returns states *)
Lemma transitionf_all_states g s a q :
  In q (transitionf g s a) ->
  In q (states g).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1-4: try right; intuition.
  simpl in H.
  apply in_app_or in H; destruct H.
  destruct (in_dec State_eq_dec q1 s).
  destruct (Symbol_eq_dec a0 a).
  2,3: contradiction.
  apply in_singleton in H.
  subst; right; left.
  2: right; right.
  1,2: intuition.
Qed.

(* The extended transition function returns states *)
Lemma ext_transitionf_all_states g s w q :
  subset State s (states g) ->
  In q (ext_transitionf g s w) ->
  In q (states g).
Proof.
  revert s; induction w as [|a w IH]; intros s H0 H1.
  apply H0; intuition.
  simpl in H1.
  apply IH with (transitionf g s a).
  2: intuition.
  clear IH H1 w.
  induction s as [|q1 s IH]; intros q2 H. {
    clear H0; induction g as [|c g IH].
    contradiction.
    destruct c;
    try right; try right; intuition.
  }
  replace (q1::s) with ([q1] ++ s) in H.
  apply in_transitionf_app in H.
  destruct H; apply transitionf_all_states in H.
  1-3: intuition.
Qed.

Lemma ext_transitionf_singleton_all_states g q1 w q2 :
  In q1 (states g) -> In q2 (ext_transitionf g [q1] w) ->
  In q2 (states g).
Proof.
  intros H H0; apply (ext_transitionf_all_states g [q1] w q2).
  intros q [H1|H1].
  1,3: subst; intuition.
  contradiction.
Qed.

Definition has_state (s1 s2:ListSet State) := has_el State s1 s2.

Definition has_accept_state (g:NFA) s := has_state s (accept_states g).

(* hast_accept_state decider *)
Lemma has_accept_state_dec (g:NFA) :
  forall s, {has_accept_state g s} + {~ has_accept_state g s}.
Proof.
  intro s; induction s as [|q s IH].
  right; intros [q [H _]]; contradiction.
  destruct IH as [H|H].
  left; destruct H as [qf H]; exists qf; intuition.
  destruct (in_dec State_eq_dec q (accept_states g)) as [H0|H0].
  left; exists q; intuition.
  right; intros [qf [[H1|H1] H2]].
  subst; contradiction.
  apply H; exists qf; intuition.
Qed.

(* Equivalent states *)
Definition equiv_states (g:NFA) (q1 q2:State) :=
  forall w, has_accept_state g (ext_transitionf g [q1] w) <-> has_accept_state g (ext_transitionf g [q2] w).

(* Word acceptance *)
Definition nfa_accepts (g:NFA) w :=
  has_accept_state g (ext_transitionf g (start_states g) w).

Definition reachable_state (g:NFA) q :=
  exists w, In q (ext_transitionf g (start_states g) w).

Inductive path (g:NFA) : State -> State -> Word -> Prop :=
  | path_nil q : path g q q nil
  | path_trans q1 q2 q3 a w : In (transition q1 a q2) g -> path g q2 q3 w ->
    path g q1 q3 (a::w).

(* Every transition is a path *)
Lemma path_ext_transitionf g q1 q2 w :
  path g q1 q2 w <-> In q2 (ext_transitionf g [q1] w).
Proof.
  split; intro H.
  - induction H; simpl.
    intuition.
    apply transition_transitionf in H.
    apply ext_transitionf_generalize with (s:=transitionf g [q1] a) in IHpath.
    1,2: intuition.
  - generalize dependent q1; induction w as [|a w IH]; intros q1 H.
    destruct H.
    subst; constructor.
    contradiction.
    simpl in H; apply ext_transitionf_singleton in H; destruct H as [q3 [H H0]].
    apply IH in H0.
    apply transition_transitionf in H.
    apply path_trans with q3; intuition.
Qed.

(* A inverted transitive property *)
Lemma path_trans_inv1 g q1 q2 q3 w a :
  path g q1 q2 w -> In (transition q2 a q3) g ->
  path g q1 q3 (w ++ [a]).
Proof.
  intros H H0.
  induction H.
  apply path_trans with (q2:=q3).
  2: constructor.
  2: simpl; apply path_trans with q2.
  1-3: intuition.
Qed.

(* The reciprocal *)
Lemma path_trans_inv2 g q1 q3 w a :
  path g q1 q3 (w ++ [a]) -> exists q2,
  path g q1 q2 w /\ In (transition q2 a q3) g.
Proof.
  intro H.
  generalize dependent q1;
  induction w as [|b w IH];
  intros q1 H.
  inversion H; subst.
  inversion H5; subst.
  exists q1; split.
  constructor.
  intuition.
  simpl in H; inversion H; subst.
  apply IH in H5; destruct H5 as [q4 [H5 H6]].
  exists q4; split.
  apply path_trans with q2.
  1-3: intuition.
Qed.

End NFA.


Require Export XR_Rinv_neq_0_compat.

Local Open Scope R_scope.

Lemma Rinv_involutive : forall r, r <> R0 -> / / r = r.
Proof.
  intros x hneq.
  apply Rmult_eq_reg_l with (/x).
  {
    rewrite Rinv_r.
    {
      rewrite Rinv_l.
      { reflexivity. }
      { exact hneq. }
    }
    {
      apply Rinv_neq_0_compat.
      exact hneq.
    }
  }
  {
    apply Rinv_neq_0_compat.
    exact hneq.
  }
Qed.


(* An adaption of the tests from [Examples.v]
   for SMTCoq 1.3 and native Coq (trunk version October 2016)

  This illustrates that SMTCoq can also solve such goals
  (but in a less interactive way).
*)

Require Import SMTCoq.SMTCoq.

Lemma ex_intro (x: Z) (f: Z -> Z):
implb (x <=? 1)
(implb ((f x) <? (f 1))
       (x <? 1)).
Proof.
  verit.
Qed.

(* In a first step, no uninterpreted type !
   No division !
*)
Lemma simpler_bigex0 (f:Z -> Z) (g:Z -> Z) (v1 v2 v3 v4: Z):
implb  (6*v1 - v2 - 10*v3 + 7*(f(g v1) + 1) <=? -1)
(implb (3*(f(g v1) - 2*v3) + 4 >=? v2 - 4*v1)
(implb (8*v1 - 3*v2 - 4*v3 - f(g v1) <=? 2)
(implb (11*v1 - 4*v2 >? 3)
(implb (v3 >? -1)
(implb (v4 >=? 0)
(implb (negb (Zeq_bool (g((11 - v2 + 13*v4))) (g(13 * (v3+v4)))))
       (3 + 4*v2 + 5*v3 + f(g v1) >? 11*v1))))))).
Proof.
  verit.
Qed.

(* Failure on Division
 => the veriT solver finds that the formula is satisfiable !
This is because operator "/" is passed as a non-interpreted term
to veriT by SMTCoq !
*)
Lemma simpler_bigex1 (f:Z -> Z) (g:Z -> Z) (v1 v2 v3 v4: Z):
implb  (6*v1 - v2 - 10*v3 + 7*(f(g v1) + 1) <=? -1)
(implb (3*(f(g v1) - 2*v3) + 4 >=? v2 - 4*v1)
(implb (8*v1 - 3*v2 - 4*v3 - f(g v1) <=? 2)
(implb (11*v1 - 4*v2 >? 3)
(implb (v3 >? -1)
(implb (v4 >=? 0)
(implb (negb (Zeq_bool (g((11 - v2 + 13*v4) / (v3+v4))) (g(13))))
       (3 + 4*v2 + 5*v3 + f(g v1) >? 11*v1))))))).
Proof.
  try verit.
  idtac.
Abort.

(* We introduced an uninterpreted type: it must have a decidable equality !
*)
Lemma simpler_bigex (A:Type) (f:A -> Z) (g:Z -> A) (eqA: A -> A -> bool) (P: A -> bool) (v1 v2 v3 v4: Z):
(forall x y, eqA x y = true <-> x=y) ->
implb  (6*v1 - v2 - 10*v3 + 7*(f(g v1) + 1) <=? -1)
(implb (3*(f(g v1) - 2*v3) + 4 >=? v2 - 4*v1)
(implb (8*v1 - 3*v2 - 4*v3 - f(g v1) <=? 2)
(implb (11*v1 - 4*v2 >? 3)
(implb (v3 >? -1)
(implb (v4 >=? 0)
(implb (Bool.eqb (negb (P (g((11 - v2 + 13*v4))))) (P (g(13 * (v3+v4)))))
       (3 + 4*v2 + 5*v3 + f(g v1) >? 11*v1))))))).
Proof.
  verit.
  (* additionnal OP: provide a decidable equality on A *)
  apply (existT _ eqA).
  intros x y; generalize (H x y); clear H; intro H.
  destruct (eqA x y).
  - apply Bool.ReflectT; rewrite <- H; auto.
  - apply Bool.ReflectF; rewrite <- H; auto.
Qed.

(* NO SUPPORT FOR Q or Qc in SMTCoq ! *)

Require Import QArith.
Require Import Qcanon.

Goal forall (x: Z), (Zeq_bool x 1) = Zeq_bool (x+1) (1+1).
Proof.
  verit.
Qed.

Goal forall (x: Q), (Qeq_bool x 1) = Qeq_bool (x+1) (1+1).
Proof.
  try verit.
  idtac.
Abort.

Goal forall (x: Qc), (Qc_eq_bool x 1) = Qc_eq_bool (x+1) (1+1).
Proof.
  try verit.
  idtac.
Abort.


Inductive tm : Type :=
  | zro : tm
  | scc : tm -> tm
  | pls : tm -> tm -> tm
  | nul : tm
  | cns : tm -> tm -> tm
  | len : tm -> tm
  | idx : tm -> tm -> tm
  | stn : tm -> tm.

Inductive nvalue : tm -> Prop :=
  | nv_zro : nvalue zro
  | nv_scc : forall v1, nvalue v1 -> nvalue (scc v1).

Inductive lvalue : tm -> Prop :=
  | lv_nul : lvalue nul
  | lv_cns : forall v1 v2,
      nvalue v1 -> lvalue v2 -> lvalue (cns v1 v2).

Definition value (t : tm) := nvalue t \/ lvalue t.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_Scc : forall t1 t1',
      t1 --> t1' ->
      scc t1 --> scc t1'
  | ST_PlsZro : forall v1,
      nvalue v1 ->
      pls zro v1 --> v1
  | ST_PlsScc : forall v1 v2,
      nvalue v1 ->
      nvalue v2 ->
      pls (scc v1) v2 --> scc (pls v1 v2)
  | ST_Pls2 : forall v1 t2 t2',
      nvalue v1 ->
      t2 --> t2' ->
      pls v1 t2 --> pls v1 t2'
  | ST_Pls1 : forall t1 t1' t2,
      t1 --> t1' ->
      pls t1 t2 --> pls t1' t2
  | ST_Cns2 : forall v1 t2 t2',
      nvalue v1 ->
      t2 --> t2' ->
      cns v1 t2 --> cns v1 t2'
  | ST_Cns1 : forall t1 t1' t2,
      t1 --> t1' ->
      cns t1 t2 --> cns t1' t2
  | ST_LenNul :
      len nul --> zro
  | ST_LenCns : forall v1 v2,
      nvalue v1 ->
      lvalue v2 ->
      len (cns v1 v2) --> scc (len v2)
  | ST_Len : forall t1 t1',
      t1 --> t1' ->
      len t1 --> len t1'
  | ST_IdxZro : forall v1 v2,
      nvalue v1 ->
      lvalue v2 ->
      idx zro (cns v1 v2) --> v1
  | ST_IdxScc : forall v1 v2 v3,
      nvalue v1 ->
      nvalue v2 ->
      lvalue v3 ->
      idx (scc v1) (cns v2 v3) --> idx v1 v3
  | ST_Idx2 : forall v1 t2 t2',
      nvalue v1 ->
      t2 --> t2' ->
      idx v1 t2 --> idx v1 t2'
  | ST_Idx1 : forall t1 t1' t2,
      t1 --> t1' ->
      idx t1 t2 --> idx t1' t2
  | ST_StnNval : forall v1,
      nvalue v1 ->
      stn v1 --> cns v1 nul
  | ST_Stn : forall t1 t1',
      t1 --> t1' ->
      stn t1 --> stn t1'

where "t1 '-->' t2" := (step t1 t2).

Definition relation (X : Type) := X -> X -> Prop.

Definition deterministic {X : Type} (R : relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive ty : Type :=
  | Nat : ty
  | List : ty.

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_Zro :
      |- zro \in Nat
  | T_Scc : forall t1,
      |- t1 \in Nat ->
      |- scc t1 \in Nat
  | T_Pls : forall t1 t2,
      |- t1 \in Nat ->
      |- t2 \in Nat ->
      |- pls t1 t2 \in Nat
  | T_Nul :
      |- nul \in List
  | T_Cns : forall t1 t2,
      |- t1 \in Nat ->
      |- t2 \in List ->
      |- cns t1 t2 \in List
  | T_Len : forall t1,
      |- t1 \in List ->
      |- len t1 \in Nat
  | T_Idx : forall t1 t2,
      |- t1 \in Nat ->
      |- t2 \in List ->
      |- idx t1 t2 \in Nat
  | T_Stn : forall t1,
      |- t1 \in Nat ->
      |- stn t1 \in List

where "'|-' t '\in' T" := (has_type t T).

Definition progress := forall t T,
  |- t \in T ->
  value t \/ exists t', t --> t'.

Definition preservation := forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Definition normal_form {X : Type} (R : relation X) (t : X) : Prop :=
  ~ exists t', R t t'.

Notation step_normal_form := (normal_form step).

Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ ~ value t.

Definition soundness := forall t t' T,
  |- t \in T ->
  t -->* t' ->
  ~ stuck t'.

Variant Learnt {P:Prop} :=
  | AlreadyLearnt (H:P).

Local Ltac learn_fact H :=
    let P := type of H in
    lazymatch goal with
    (* matching the type of H with the Learnt hypotheses means the
    learning fails even when the proposition is known by a different
    but unifiable type term *)
    | [ Hlearnt: @Learnt P |- _ ] =>
      fail 0 "already knew" P "through" Hlearnt
    | _ => pose proof H; pose proof (AlreadyLearnt H)
    end.

Tactic Notation "learn" constr(H) := learn_fact H.

Theorem step_deterministic : deterministic step.
Proof.
  hnf.
  intros x.
  induction x; intros;
  inversion H; inversion H0; subst; clear H H0; try easy.
  all: repeat multimatch goal with
       | [H1:  ?x --> ?a, H2: ?x --> ?b |- _] => learn (IHx a b H1 H2); subst
       | H: _ _ = _ _ |- _ => (try injection H; intros; subst)
       | H: ?a = ?a |- _ => clear H
       | H: nvalue zro |- _ => clear H
       | H: lvalue nil |- _ => clear H
       | _ => try easy
  end.
  destruct y1; try easy.
  inversion H9; try easy; subst.

  intro.

Theorem progress_dec : progress \/ ~ progress.
Proof.
  admit.
Admitted.

Theorem preservation_dec : preservation \/ ~ preservation.
Proof.
  admit.
Admitted.

Corollary soundness_dec : soundness \/ ~ soundness.
Proof.
  admit.
Admitted.