Require Import Coq.Program.Syntax.
Require Export ZArith.
Require Import Coq.Program.Basics.
Require Import SetoidTactics.
Require Import SetoidClass.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.

Require Import HDI.Util.
Require Import HDI.CoInduction.
Require Import HDI.Syntax.
Require Import HDI.Heap.
Require Import HDI.OpSem.
Require Import HDI.Bisimulation.
Require Import HDI.SafetyI.
Require Export HDI.Predicates.

Local Open Scope Z.
Local Open Scope stmt.

  Definition in_inv (I: predicate heap->stmt->Prop) x s :=
    exists y s', x |-- y /\ bisimilar s s' /\ I y s'.

  Definition incl_inv (I1 I2: predicate heap->stmt->Prop) :=
    forall x s, I1 x s -> I2 x s.

  Definition inv_union (I1 I2: predicate heap -> stmt -> Prop) : predicate heap -> stmt -> Prop :=
    fun x s => I1 x s \/ I2 x s.

  Lemma incl_inv_in: forall I1 I2 x s,
    incl_inv I1 I2 ->
    in_inv I1 x s ->
    in_inv I2 x s.
  Proof. firstorder. Qed.
  Global Hint Resolve incl_inv_in : safe.

  Lemma in_inv_eq: forall (I: predicate heap->stmt->Prop) x s,
    I x s ->
    in_inv I x s.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_eq : safe.

  Lemma incl_inv_refl: forall I,
    incl_inv I I.
  Proof. firstorder. Qed.
  Global Hint Immediate incl_inv_refl : safe.

  Lemma in_inv_entails: forall (I: predicate heap->stmt->Prop) x y s,
    in_inv I y s ->
    x |-- y ->
    in_inv I x s.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_entails : safe.

  Lemma in_inv_bisim: forall (I: predicate heap->stmt->Prop) x s1 s2,
    in_inv I x s2 ->
    bisimilar s1 s2 ->
    in_inv I x s1.
  Proof.
    unfold in_inv; intuition auto.
    setoid_rewrite H0.
    auto.
  Qed.
  Global Hint Resolve in_inv_bisim : safe.

  Lemma incl_inv_union1: forall I1 I2,
    incl_inv I1 (inv_union I1 I2).
  Proof. firstorder. Qed.

  Lemma incl_inv_union2: forall I1 I2,
    incl_inv I2 (inv_union I1 I2).
  Proof. firstorder. Qed.
  Hint Resolve incl_inv_union1 incl_inv_union2 : safe.

  Lemma in_inv_forall: forall B (b:B) I x s,
    in_inv I (x b) s ->
    in_inv I (All_ b:B, x b) s.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_forall : safe.

  Lemma in_inv_exists: forall I h x s,
    in_inv I x s ->
    h |= x ->
    exists y s', h|=y /\ bisimilar s s' /\ I y s'.
  Proof. firstorder. Qed.
  Global Hint Resolve in_inv_exists : safe.

  Add Parametric Morphism : in_inv
    with signature eq ==> equiv ==> bisimilar ==> iff
    as in_inv_m.
  Proof.
    split; intros; [ symmetry in H0 | symmetry in H];
      (eapply in_inv_entails;
        [ eapply in_inv_bisim | rewrite <-H; reflexivity ];
        eauto).
  Qed.

  Add Parametric Morphism : in_inv
    with signature incl_inv ++> entails --> eq ==> impl
    as in_inv_d.
  Proof. firstorder. Qed.

  Add Parametric Morphism : inv_union
    with signature incl_inv ++> incl_inv ++> incl_inv
    as inv_union_d.
  Proof. firstorder. Qed.

  Global Instance incl_inv_preorder : PreOrder incl_inv.
  Proof. firstorder. Qed.

  Lemma in_inv_union: forall I1 I2 x s,
    in_inv (inv_union I1 I2) x s ->
    in_inv I1 x s \/ in_inv I2 x s.
  Proof. firstorder. Qed.

  Lemma or_dup: forall P,
    (P \/ P) <-> P.
  Proof. intuition idtac. Qed.

  Lemma incl_inv_union_dup: forall I,
    incl_inv (inv_union I I) I.
  Proof. firstorder. Qed.

  Definition hoare_double (I: predicate heap->stmt->Prop) (x: predicate heap) (s: stmt) :=
    forall h, h |= x ->
      safeI (fun h s => exists y s', h |= y /\ bisimilar s s' /\ I y s') h s.

  Definition hoare_double_gen (I1 I2: predicate heap->stmt->Prop) :=
    forall (x: predicate heap) (s: stmt),
      I1 x s ->
      hoare_double I2 x s.

  Definition hoare_double' (I: predicate heap->stmt->Prop) (x: predicate heap) (s: stmt) :=
    in_inv I x s \/ hoare_double I x s.

  Notation "I ||- {{ x }} s" :=
    (hoare_double I x%pred s%stmt)
    (no associativity, at level 65, s at level 42).

  Notation "I ||= {{ x }} s" :=
    (hoare_double' I x%pred s%stmt)
    (no associativity, at level 65, s at level 42).

  Lemma hd_bisim: forall I x s1 s2,
    bisimilar s1 s2 ->
    I ||- {{x}}  s1 ->
    I ||- {{x}}  s2.
  Proof.
    unfold hoare_double, incl_inv.
    intuition auto.
    eapply safeI_bisim; eauto.
    simpl_relation.
    setoid_rewrite H3 at 1.
    reflexivity.
  Qed.

  Lemma hd'_bisim: forall I x s1 s2,
    bisimilar s1 s2 ->
    I ||= {{x}}  s1 ->
    I ||= {{x}}  s2.
  Proof.
    unfold hoare_double'.
    intuition eauto using hd_bisim.
    left; rewrite <-H; auto.
  Qed.

  Lemma hd_weaken: forall I1 I2 x y s,
    I1 ||- {{y}}  s ->
    x |-- y ->
    incl_inv I1 I2 ->
    I2 ||- {{x}}  s.
  Proof.
    unfold hoare_double, incl_inv.
    intuition auto.
    eapply safeI_weaken; intros; eauto.
    destruct H3 as [z[s1[?[??]]]]; eauto 8.
  Qed.

  Lemma hd_weaken': forall I x y s,
    I ||- {{y}}  s ->
    x |-- y ->
    I ||- {{x}}  s.
  Proof.
    intros; eapply hd_weaken; eauto; reflexivity.
  Qed.

  Lemma hd'_weaken: forall I1 I2 x y s,
    I1 ||= {{y}}  s ->
    x |-- y ->
    incl_inv I1 I2 ->
    I2 ||= {{x}}  s.
  Proof.
    unfold hoare_double'.
    intuition eauto using hd_weaken.
    left; firstorder.
  Qed.

  Lemma hd'_weaken': forall I x y s,
    I ||= {{y}}  s ->
    x |-- y ->
    I ||= {{x}}  s.
  Proof.
    intros; eapply hd'_weaken; eauto; reflexivity.
  Qed.

  Add Parametric Morphism : hoare_double
    with signature eq ==> equiv ==> bisimilar ==> iff
    as hoare_double_m.
  Proof.
    split; intros;
      eapply hd_bisim, hd_weaken;
      eauto;
      try solve
      [ apply equiv_sub_entails; eauto with pred
      | reflexivity
      | symmetry; assumption
      ].
  Qed.

  Add Parametric Morphism : hoare_double'
    with signature eq ==> equiv ==> bisimilar ==> iff
    as hoare_double'_m.
  Proof.
    split; intros;
      eapply hd'_bisim, hd'_weaken;
      eauto;
      try solve
      [ apply equiv_sub_entails; eauto with pred
      | reflexivity
      | symmetry; assumption
      ].
  Qed.

  Add Parametric Morphism : hoare_double
    with signature incl_inv ++> entails --> eq ==> impl
    as hoare_double_d.
  Proof.
    unfold impl; eauto using hd_weaken.
  Qed.

  Add Parametric Morphism : hoare_double'
    with signature incl_inv ++> entails --> eq ==> impl
    as hoare_double'_d.
  Proof.
    unfold impl; eauto using hd'_weaken.
  Qed.

  Lemma hd_exists: forall A I x s,
    (forall a:A, I ||-{{x a}}  s) ->
    I ||-{{Ex_ a:A, x a}}  s.
  Proof. firstorder. Qed.
  Global Hint Resolve hd_exists : safe.

  Lemma hd_forall: forall A (a:A) I x s,
    I ||-{{x a}}  s ->
    I ||-{{All_ a:A, x a}}  s.
  Proof. firstorder. Qed.
  Global Hint Resolve hd_forall : safe.

  Lemma hd'_inv: forall I x s,
    in_inv I x s ->
    I ||= {{x}}  s.
  Proof. left; auto. Qed.
  Global Hint Resolve hd'_inv : safe.

  Lemma hd'_safe: forall I x s,
    I ||- {{x}}  s ->
    I ||= {{x}}  s.
  Proof. right; auto. Qed.
  Global Hint Resolve hd'_safe : safe.

  Lemma hd'_forall: forall A (a:A) I x s,
    I ||={{x a}}  s ->
    I ||={{All_ a:A, x a}}  s.
  Proof. firstorder. Qed.
  Global Hint Resolve hd'_forall : safe.

  Lemma hd_coind: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall x s,
      I' x s ->
      inv_union I I' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||- {{x}}  s.
  Proof.
    intros ? ? ? ? Hsafe_ Hin.
    assert (Hsafe: forall x s, in_inv I' x s -> inv_union I I' ||- {{x}}  s).
    { intros.
      destruct H as [y[s1[Hy[Hbisim ?]]]].
      rewrite Hy, Hbisim; eauto.
    }
    clear Hsafe_.
    unfold hoare_double.
    intros h Hx.
    cut (in_inv I' x s
        \/ safeI (fun h' s' => exists y s'', h'|=y /\ bisimilar s' s'' /\ (inv_union I I') y s'') h s);
      [ | solve[auto with safe] ].
    clear Hin.
    revert h x s Hx.
    cofix; intros.
    destruct H as [Hin|Hsafe2].
    * specialize (Hsafe x s Hin h Hx).
    inversion Hsafe; subst; clear Hsafe.
    - constructor.
    - constructor.
    destruct H as [h'[s'[Hstep Hsafe']]].
    specialize (hd_coind h' (just h')).
    exists h' s'; split; auto.
    destruct Hsafe' as [ [z[s0[Hz[Hbisim [Hin'|Hin']]]]] | Hsafe'];
      eauto 7;
      solve [right; eapply hd_coind; eauto 7 with safe pred].
    * inversion Hsafe2; subst; clear Hsafe2.
    - constructor.
    - constructor.
    destruct H as [h'[s'[Hstep Hsafe']]].
    specialize (hd_coind h' (just h')).
    exists h' s'; split; auto.
    destruct Hsafe' as [ [z[s0[Hz[Hbisim [Hin'|Hin']]]]] | Hsafe'];
      eauto 7;
      solve [right; eapply hd_coind; eauto 7 with safe pred].
  Qed.

  Lemma hd'_coind: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall x s,
      I' x s ->
      inv_union I I' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||= {{x}}  s.
  Proof.
    eauto using hd_coind with safe.
  Qed.

  Lemma hd_coindI: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall I'' x s,
      I' x s ->
      incl_inv I I'' ->
      incl_inv I' I'' ->
      I'' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||- {{x}}  s.
  Proof.
    eauto using hd_coind with safe.
  Qed.

  Lemma hd'_coindI: forall (I I': predicate heap -> stmt -> Prop) x s,
    (forall I'' x s,
      I' x s ->
      incl_inv I I'' ->
      incl_inv I' I'' ->
      I'' ||- {{x}}  s) ->
    in_inv I' x s ->
    I ||= {{x}}  s.
  Proof.
    eauto using hd_coind with safe.
  Qed.

  Lemma in_inv_hoare_double: forall I x s,
    in_inv (hoare_double I) x s <-> hoare_double I x s.
  Proof.
    split; [ intros [y[s'[H1[H2 ?]]]] | intros ].
    rewrite H1, H2; assumption.
    exists x s; split; try split; try reflexivity; auto.
  Qed.

  Lemma in_inv_hoare_double': forall I x s,
    in_inv (hoare_double' I) x s <-> hoare_double' I x s.
  Proof.
    split; [ intros [y[s'[H1[H2 ?]]]] | intros ].
    rewrite H1, H2; assumption.
    exists x s; split; try split; try reflexivity; auto.
  Qed.

  Lemma hoare_double_coind_principle: forall (I1 I2: predicate heap -> stmt -> Prop) x s,
    I2 x s ->
    hoare_double_gen I2 (inv_union I1 I2) ->
    hoare_double I1 x s.
  Proof.
    intros I1 I2 x s HI2 Hsafe.
    eapply hd_coindI;
      [ clear x s HI2; intros I'' x s HI2 Hincl1 Hincl2
      | apply in_inv_eq; eauto ].
    apply Hsafe in HI2; clear Hsafe.
    hnf; intros.
    eapply safeI_weaken; eauto.
    simpl; intros.
    destruct H0 as [y[s'[Hy[Hbisim Hsafe']]]].
    destruct Hsafe' as [Hsafe'|Hsafe'];
      eauto 7 with safe.
  Qed.

  Lemma hoare_double_gen_hd_intro: forall (I1 I2: predicate heap -> stmt -> Prop),
    (forall I3: _ -> _ -> Prop,
      (forall x s,
        I1 x s ->
        hoare_double' I3 x s) ->
      incl_inv I2 I3 ->
      hoare_double_gen I1 I3) ->
    hoare_double_gen I1 (inv_union I2 I1).
  Proof.
    unfold hoare_double_gen; intuition auto.
    eapply H; intros; eauto;
    intuition eauto with safe.
  Qed.

  Lemma hoare_double_coind: forall (I1 I2: predicate heap -> stmt -> Prop),
    (forall I3: _ -> _ -> Prop,
      (forall x s, I2 x s -> hoare_double' I3 x s) ->
(*      (forall x s, I1 x s -> hoare_double' I3 x s) ->*)
      incl_inv I1 I3 ->
      hoare_double_gen I2 I3) ->
    forall x s,
    I2 x s ->
    hoare_double I1 x s.
  Proof.
    intros.
    apply (hoare_double_coind_principle I1 I2 x s); auto.
    apply hoare_double_gen_hd_intro.
    intros; eauto.
  Qed.

  Global Instance coind_hoare_double {I} `{co_rel:CoRelation _}  {x s}
    : CoIndRelation (hoare_double I x s) | 100 :=
    {| coind_rel:= coind_co_rel (x,s) |}.

  Global Program Instance hoare_double_cind (I1 I2: predicate heap -> stmt -> Prop) x s
    : CoIndPrinciple I2 (hoare_double I1 x s) :=
    {| coind_principle := fun H1 H2 =>
        hoare_double_coind I1 I2 H2 x s H1
    |}.

  Ltac hd_coind_ :=
    let G:= thegoal in
    (* rephrase in a friendler way: provide helper lemmas to solve gen relations *)
    coind_ ltac:(fun names =>
      (**)
      try match thegoal with
      | hoare_double_gen ?I1 ?I2 =>
        try intro_relation_with_names names
      | _ =>
        try intro_relation_with_names names
      end).

  Tactic Notation "hd_coind" :=
    hd_coind_.

  Lemma ret_ok: forall I v F,
    I ||-{{F}}  ret v.
  Proof.
    unfold hoare_double; intros.
    eauto with safe.
  Qed.

  Lemma ret_bind_ok: forall I v F k,
    I ||={{F}}  k v ->
    I ||-{{F}}  x <- ret v; k x.
  Proof.
    unfold hoare_double; intros.
    destruct H; eauto with safe.
  Qed.

  Hint Resolve ret_ok ret_bind_ok : safe.

  Lemma read_ok: forall I a v F k,
    I ||= {{a |-> v && F}}  k v ->
    I ||- {{a |-> v && F}}  x <- read a; k x.
  Proof.
    unfold hoare_double; intros.
    destruct H; eauto with safe pred.
  Qed.

  Lemma read_str0_0_ok: forall I a v F k,
    I ||= {{a |->0 v && F}}  k (match v with String c _ => Z_of_ascii c | _ => 0 end) ->
    I ||- {{a |->0 v && F}}  x <- read a; k x.
  Proof.
    unfold getd; intros.
    destruct v; simpl in *.
    * rewrite str0_empty in *.
    apply read_ok; auto.
    * rewrite str0_cons in *.
    rewrite <-inter_assoc in H |- *.
    apply read_ok; auto.
  Qed.

  Lemma write_ok: forall I a v v0 F k,
    pred_free F a ->
    I ||= {{a |-> v && F}}  k 1 ->
    I ||- {{a |-> v0 && F}}  write a v >>= k.
  Proof.
    unfold hoare_double; intros.
    eapply safeI_write; eauto with safe pred.
    destruct H0; eauto with safe pred.
    - eapply safeI_bind_ret'; eauto with safe pred.
    apply in_inv_exists with (x:=(a|->v && F)%pred); auto.
    firstorder.
    - eapply safeI_bind_ret; eauto with safe pred.
    firstorder.
  Qed.

  Ltac step :=
    match goal with
    | |- _ ||= {{_}} _ => apply hd'_safe; step
    | |- ?I ||- {{?x}} ?s =>
      match s with
      | ret _ => apply ret_ok
      | bind (ret _) _ => apply ret_bind_ok
      | _ <- act (read ?a); _ =>
        match x with
        | appcontext[pts a ?v'] =>
          eapply hd_weaken'; [apply read_ok with (v:=v') | try reflexivity]
        | appcontext[str0 a ?v'] =>
          eapply hd_weaken'; [apply read_str0_0_ok with (v:=v') | try reflexivity]
        | _ =>
          eapply hd_weaken'; [apply read_ok | try reflexivity]
        end
      | _ <- act (write _); _ => eapply hd_weaken'; [apply write_ok | try reflexivity]
      | bind (bind _ _) _ => rewrite !bisim_bind_assoc; step
      end
    end.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export per_props_equality.
Require Export cequiv_tacs.

Lemma mkc_subtype_rel_eq {o} :
  forall (a b : @CTerm o),
    mkc_subtype_rel a b = mkc_member mkc_id (mkc_fun a b).
Proof.
  introv; destruct_cterms; apply cterm_eq; simpl; auto.
Qed.

Definition subtype_rel {o} lib (A B : @CTerm o) :=
  forall a a', equality lib a a' A -> equality lib a a' B.

Lemma equality_in_subtype_rel {p} :
  forall lib (t u A B : @CTerm p),
    equality lib t u (mkc_subtype_rel A B)
    <=>
    ((t ===>(lib) mkc_axiom)
     # (u ===>(lib) mkc_axiom)
     # type lib A
     # (inhabited_type lib A -> type lib B)
     # subtype_rel lib A B).
Proof.
  introv.
  rw @mkc_subtype_rel_eq.
  rw @equality_in_member.
  rw @equality_in_fun.
  split; intro k; repnd; dands; auto.

  - introv e.
    apply k in e.
    pose proof (cequivc_apply_id lib a) as e1.
    pose proof (cequivc_apply_id lib a') as e2.
    apply (equality_trans _ _ (mkc_apply mkc_id a)).
    + apply equality_sym; apply equality_respects_cequivc; auto.
      apply equality_refl in e; auto.
    + apply (equality_trans _ _ (mkc_apply mkc_id a')); auto.
      apply equality_respects_cequivc; auto.
      apply equality_sym in e; apply equality_refl in e; auto.

  - introv e.
    apply k in e.
    pose proof (cequivc_apply_id lib a) as e1.
    pose proof (cequivc_apply_id lib a') as e2.
    rwg e1.
    rwg e2; auto.
Qed.

Lemma inhabited_subtype_rel {p} :
  forall lib (A B : @CTerm p),
    inhabited_type lib (mkc_subtype_rel A B)
    <=>
    (type lib A
     # (inhabited_type lib A -> type lib B)
     # subtype_rel lib A B).
Proof.
  introv; split; intro k.
  - unfold inhabited_type in k; exrepnd.
    rw @equality_in_subtype_rel in k0; repnd; dands; auto.
  - repnd.
    unfold inhabited_type.
    exists (@mkc_axiom p).
    apply equality_in_subtype_rel.
    dands; spcast; auto; apply computes_to_valc_refl; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(* Time-stamp: "2018-02-09 17:01:29 pierre" *)
(****************************************************************)
(*                        escalation.v                          *)
(*                                                              *)
(**          © Pierre Lescanne  (December 2015)                 *)
(*                                                              *)
(*              LIP (ENS-Lyon, CNRS, INRIA)                     *)
(*                                                              *)
(*                                                              *)
(*  Developed in  V8.4pl4                January -- April 2016  *)
(****************************************************************)
Section Escalation.

Require Import games_Choice_Dependent yinYang dollar.

Arguments Divergent  [Agent Utility Choice] s.

(* preference on Utility *)
Require Import Relations.

Lemma AlwaysGoodAndDivergentInYinYang :
  exists (s:StratProf yinYang.AliceBob  YinYang yinYang.Choice),
    AlwaysGood yinYang.AliceBob YinYang yinYang.Choice eq s /\
    Divergent s.
Proof.
  exists yinYangAcBc.
  split.
  apply AlwaysGoodYyAcBc.
  apply DivergenceYyAcBc.
Qed.

Lemma AlwaysGoodAndDivergentInDollar :
  exists (s:StratProf dollar.AliceBob nat dollar.Choice),
    AlwaysGood dollar.AliceBob nat dollar.Choice ge s /\
    Divergent s.
Proof.
  exists (dollarAcBc 0).
  split.
  apply AlwaysGoodDolAcBc.
  apply DivergenceDolAcBc.
Qed.

End Escalation.


Require Import
        Bedrock.Word
        Coq.NArith.NArith
        Coq.Arith.Arith
        Coq.Numbers.Natural.Peano.NPeano
        Coq.Logic.Eqdep_dec
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.BinLib.Core
        compcert.lib.Integers.

Import Byte.

Record ByteString :=
  { padding : nat;
    front : word padding;
    paddingOK : (padding < 8)%nat;
    numBytes : nat;
    byteString : Vector.t byte numBytes (* The bytestring. *)
  }.

Definition length_ByteString (bs : ByteString) := numBytes bs.

Definition wordToByte (w : word 8) : byte :=
  repr (BinInt.Z.of_N (wordToN w)).

Definition byteToWord (i : byte) : word 8 :=
  match intval i with
  | 0%Z => wzero 8
  | Zpos p => posToWord 8 p
  | _ => wzero 8
  end.

Definition ByteString_enqueue
         (b : bool)
         (bs : ByteString)
  : ByteString.
  refine (if (eq_nat_dec (padding bs) 7) then
            {| front := WO;
               byteString := Vector.append (byteString bs)
                                           (Vector.cons _ (wordToByte (WS b _)) _ (@Vector.nil _)) |}
  else
    {| front := WS b (front bs);
       padding := S (padding bs);
       byteString := byteString bs |}).
  abstract omega.
  abstract (pose proof (front bs) as w; generalize dependent (padding bs);
            intros ?? w; subst; exact w).
  abstract (pose proof (paddingOK bs); omega).
Defined.

Fixpoint word_dequeue {sz}
           (w : word (S sz))
  : bool * word sz :=
  match sz return word (S sz) -> bool * word sz with
  | 0 => fun w => (whd w, WO)
  | S sz' =>
    fun w => let (b, w') := word_dequeue (wtl w) in
             (b, WS (whd w) w')
  end w.

Fixpoint CharList_dequeue
         {numBytes}
         (l : Vector.t byte (S numBytes))
  : bool * (Vector.t byte numBytes) * word 7 :=
  let (b, w') := word_dequeue (byteToWord (Vector.hd l)) in
  match numBytes return
        Vector.t byte (S numBytes) -> _ with
  | S numBytes' =>
    fun l =>
      match CharList_dequeue (Vector.tl l) with
      | (b', l'', tail) =>
        (b, Vector.cons _ (wordToByte (WS b' w')) _ l'', tail)
      end
  | 0 => fun _ => (b, Vector.nil _, w')
  end l.

Definition ByteString_dequeue
         (bs : ByteString)
  : option (bool * ByteString).
  refine (match padding bs as n return
                word n
                -> (n < 8)%nat
                -> _ with
          | 0 =>
            match numBytes bs as nb return
                  Vector.t byte nb
                  -> _ with
            | S n' =>
              fun l _ _ =>
                match CharList_dequeue l with
                | (b', l'', tail) =>
                  Some (b', {| front := tail;
                               byteString := l'' |})
                end
            | _ => fun _ _ _ => None
            end (byteString bs)
          | S n =>
            fun front' lt_n =>
              match numBytes bs as nb return
                    Vector.t byte nb
                    -> _ with
              | S n' =>
                fun l =>
                  match CharList_dequeue l with
                  | (b', l'', tail) =>
                    let (b, w') := word_dequeue front' in
                    Some (b', {| front := w';
                                 byteString := Vector.append l''
                                                             (Vector.cons _ (wordToByte (WS b tail)) _ (@Vector.nil _))
                              |})
                  end
              | _ => fun _ =>
                       let (b, w') := word_dequeue front' in
                       Some (b, {| front := w';
                                   byteString := Vector.nil _ |})
              end (byteString bs)
          end (front bs) (paddingOK bs)).
  abstract omega.
  abstract omega.
  abstract omega.
Defined.

Fixpoint ByteString_enqueue_word
           {n}
           (w : word n)
           (bs : ByteString) :=
  match n return word n -> ByteString with
  | 0 => fun _ => bs
  | S n' => fun w =>
              (ByteString_enqueue (whd w) (ByteString_enqueue_word (wtl w) bs))
  end w.

Definition ByteString_enqueue_char (bs : ByteString) (b : byte)
  := ByteString_enqueue_word (byteToWord b) bs.

Definition ByteString_enqueue_ByteString
           (bs bs' : ByteString)
  : ByteString :=
  let bs'' := Vector.fold_left ByteString_enqueue_char bs (byteString bs') in
  ByteString_enqueue_word (front bs') bs''.

Definition ByteString_id : ByteString.
  refine {| front := WO; byteString := Vector.nil _ |}.
  abstract omega.
Defined.

Definition CharStringToByteString
           (bs : ByteString)
  : Core.ByteString :=
  {| Core.padding := padding bs;
     Core.front := front bs;
     Core.paddingOK := paddingOK bs;
     Core.byteString := map byteToWord (Vector.to_list (byteString bs))
  |}.

Definition ByteStringToCharString
           (bs : Core.ByteString)
  : ByteString :=
  {| padding := Core.padding bs;
     front := Core.front bs;
     paddingOK := Core.paddingOK bs;
     byteString := Vector.map wordToByte (Vector.of_list (Core.byteString bs))
  |}.

Lemma byteToWord_wordToByte_eq :
  forall w, byteToWord (wordToByte w) = w.
Proof.
  Local Transparent Byte.repr.
  intros; shatter_word w.
  destruct x; destruct x0; destruct x1; destruct x2; destruct x3; destruct x4; destruct x5; destruct x6;
    reflexivity.
  Local Opaque Byte.repr.
Qed.

Lemma wordToByte_byteToWord_eq :
  forall b, wordToByte (byteToWord b) = b.
Proof.
  Local Transparent Byte.repr.
  destruct b.
  destruct intval0; simpl; intros; intuition eauto.
  - compute; apply Byte.mkint_eq; reflexivity.
  - repeat first [compute in intrange0; destruct intrange0; congruence
                 | destruct p as [p | p | ]; simpl
                 | compute; apply Byte.mkint_eq; reflexivity].
  - compute in intrange0; destruct p; destruct intrange0; congruence.
    Local Opaque Byte.repr.
Qed.

Lemma Vector_to_list_map {A B}
: forall n (v : Vector.t A n) (f : A -> B),
    Vector.to_list (Vector.map f v) = map f (Vector.to_list v).
Proof.
  induction v; simpl; intros; eauto.
  unfold Vector.to_list in *.
  rewrite IHv; reflexivity.
Qed.

Lemma Vector_to_list_of_list_eq {A}
  : forall (v : list A),
    Vector.to_list (Vector.of_list v) = v.
Proof.
  induction v; simpl.
  reflexivity.
  replace (a :: v) with (a :: Vector.to_list (Vector.of_list v)).
  reflexivity.
  rewrite IHv; reflexivity.
Qed.

Lemma CharStringToByteString_ByteStringToCharString_eq :
  forall bs, CharStringToByteString (ByteStringToCharString bs) = bs.
Proof.
  unfold CharStringToByteString, ByteStringToCharString; destruct bs; simpl;
    f_equal.
  rewrite Vector_to_list_map, Vector_to_list_of_list_eq.
  clear; induction byteString0; simpl; eauto.
  rewrite byteToWord_wordToByte_eq.
  rewrite IHbyteString0; reflexivity.
Qed.

Lemma ByteString_f_equal
  : forall bs bs'
           (p_eq : padding bs' = padding bs)
           (numBytes_eq : numBytes bs' = numBytes bs),
    front bs = eq_rect (padding bs') (fun t : nat => word t) (front bs') (padding bs) p_eq
    -> byteString bs = eq_rect (numBytes bs') _ (byteString bs') (numBytes bs) numBytes_eq
    -> bs = bs'.
Proof.
  destruct bs; destruct bs'; simpl; intros.
  subst.
  f_equal.
  apply le_uniqueness_proof.
Qed.

Lemma length_Vector_to_list {A B}
  : forall (f : A -> B) n (v : Vector.t A n),
    n = length (map f (Vector.to_list v)).
Proof.
  induction v; simpl; eauto.
Qed.

Lemma eq_rect_Vector_cons {A}
  : forall n m a v H H',
    eq_rect (S n) (Vector.t A) (VectorDef.cons A a n v) (S m) H =
    Vector.cons _ a _ (eq_rect n (Vector.t A) v _ H').
Proof.
  intros.
  destruct H'; simpl; symmetry;
    apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma ByteStringToCharString_CharStringToByteString_eq :
  forall bs, ByteStringToCharString (CharStringToByteString bs) = bs.
Proof.
  unfold CharStringToByteString, ByteStringToCharString; destruct bs; simpl;
    eapply ByteString_f_equal; simpl.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  instantiate (1 := length_Vector_to_list byteToWord _ byteString0).
  clear; induction byteString0; simpl.
  - apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  - unfold Vector.to_list in *; rewrite IHbyteString0; clear.
    erewrite eq_rect_Vector_cons; f_equal.
    apply wordToByte_byteToWord_eq.
    Grab Existential Variables.
    reflexivity.
Qed.

Lemma ByteString_enqueue_ByteString_ByteStringToCharString
  : forall bs bs',
    ByteString_enqueue_ByteString (ByteStringToCharString bs)
                                  (ByteStringToCharString bs')
    = ByteStringToCharString (Core.ByteString_enqueue_ByteString bs bs').
Proof.
Admitted.

Lemma length_ByteString_ByteStringToCharString_eq
  : forall bs,
    length_ByteString (ByteStringToCharString bs) =
    Core.length_ByteString bs.
Proof.
Admitted.

Lemma CharStringToByteString_ByteString_id_eq
  : CharStringToByteString ByteString_id = Core.ByteString_id.
Proof.
Admitted.

Instance ByteStringQueueTransformer : Transformer ByteString.
Proof.
  refine {| transform := ByteString_enqueue_ByteString;
            bin_measure := length_ByteString;
            transform_id := ByteString_id |}.
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b),
                      <- (ByteStringToCharString_CharStringToByteString_eq b'),
                      ByteString_enqueue_ByteString_ByteStringToCharString,
                      !length_ByteString_ByteStringToCharString_eq,
                      ByteString_enqueue_ByteString_measure;
              reflexivity).
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq ByteString_id),
                      <- (ByteStringToCharString_CharStringToByteString_eq l),
                      ByteString_enqueue_ByteString_ByteStringToCharString,
                      CharStringToByteString_ByteString_id_eq,
                      ByteString_enqueue_ByteString_id_left; reflexivity).
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq ByteString_id),
                      <- (ByteStringToCharString_CharStringToByteString_eq l),
                      ByteString_enqueue_ByteString_ByteStringToCharString,
                      CharStringToByteString_ByteString_id_eq,
                      ByteString_enqueue_ByteString_id_right; reflexivity).
  - abstract (intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq l),
                     <- (ByteStringToCharString_CharStringToByteString_eq m),
                     <- (ByteStringToCharString_CharStringToByteString_eq n),
                     !ByteString_enqueue_ByteString_ByteStringToCharString,
                     ByteString_enqueue_ByteString_assoc; reflexivity).
Defined.

Lemma ByteString_enqueue_ByteStringToCharString_eq
  : forall (b : bool) (b' : Core.ByteString),
    ByteString_enqueue b (ByteStringToCharString b') =
    ByteStringToCharString (Core.ByteString_enqueue b b').
Proof.
Admitted.

Lemma ByteString_enqueue_ByteStringToCharString_eq'
  : forall (b : bool) (b' : ByteString),
    Core.ByteString_enqueue b (CharStringToByteString b') =
    CharStringToByteString (ByteString_enqueue b b').
Proof.
Admitted.

Lemma ByteString_dequeue_ByteStringToCharString_eq
  : forall (b' : Core.ByteString),
    ByteString_dequeue (ByteStringToCharString b') =
    Ifopt (Core.ByteString_dequeue b')
    as bbs
         Then Some (fst bbs, ByteStringToCharString (snd bbs))
         Else None.
Proof.
Admitted.

Lemma ByteString_dequeue_ByteStringToCharString_eq'
  : forall (b' : ByteString),
    Core.ByteString_dequeue (CharStringToByteString b') =
    Ifopt (ByteString_dequeue b')
    as bbs
         Then Some (fst bbs, CharStringToByteString (snd bbs))
         Else None.
Proof.
Admitted.

Instance ByteString_QueueTransformerOpt
  : QueueTransformerOpt ByteStringQueueTransformer bool.
Proof.
refine {| B_measure f := 1;
          enqueue_opt := ByteString_enqueue;
          dequeue_opt := ByteString_dequeue |}.
  - abstract eauto.
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b'),
                             ByteString_enqueue_ByteStringToCharString_eq,
                             !length_ByteString_ByteStringToCharString_eq,
                             length_ByteString_enqueue';
              reflexivity).
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b) in *;
              rewrite ByteString_dequeue_ByteStringToCharString_eq in H;
              destruct (Core.ByteString_dequeue (CharStringToByteString b)) eqn : ?; simpl in *;
              try discriminate; injections;
              destruct p; apply ByteString_measure_dequeue_Some in Heqo;
              simpl in Heqo;
              rewrite length_ByteString_ByteStringToCharString_eq; simpl in *;
              rewrite <- Heqo;
              rewrite <- length_Vector_to_list, <- length_ByteString_ByteStringToCharString_eq,
              ByteStringToCharString_CharStringToByteString_eq; reflexivity).
  - simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b),
                   <- (ByteStringToCharString_CharStringToByteString_eq b') in *;
    rewrite <- (ByteStringToCharString_CharStringToByteString_eq b'').
    rewrite ByteString_dequeue_ByteStringToCharString_eq in H;
    destruct (Core.ByteString_dequeue (CharStringToByteString b)) eqn : ?; simpl in *;
      try discriminate; destruct p; simpl in *.
    injection H; intros; subst.
    apply ByteString_dequeue_transform_opt with (b'' := CharStringToByteString b'') in Heqo;
          simpl in *.
    admit.
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b'),
                             <- (ByteStringToCharString_CharStringToByteString_eq b''),
                             !ByteString_enqueue_ByteString_ByteStringToCharString,
                             ByteString_enqueue_ByteStringToCharString_eq,
                             ByteString_enqueue_ByteString_enqueue_ByteString,
                             !ByteStringToCharString_CharStringToByteString_eq,
                             ByteString_enqueue_ByteStringToCharString_eq',
                             <- ByteString_enqueue_ByteString_ByteStringToCharString,
                             !ByteStringToCharString_CharStringToByteString_eq;
              reflexivity).
  - abstract (simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq ByteString_id),
                             ByteString_enqueue_ByteStringToCharString_eq,
                             ByteString_dequeue_ByteStringToCharString_eq;
              replace (CharStringToByteString ByteString_id)
              with Core.ByteString_id;
              [rewrite ByteString_dequeue_head_opt; reflexivity
              | unfold ByteString_id, Core.ByteString_id, CharStringToByteString; simpl;
                f_equal;
                apply le_uniqueness_proof]).
  - abstract reflexivity.
  - intros ? ? ? ?.
    simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq b),
                   <- (ByteStringToCharString_CharStringToByteString_eq b'),
                   !ByteString_dequeue_ByteStringToCharString_eq in *.
    destruct (Core.ByteString_dequeue (CharStringToByteString b)) eqn : ?;
      simpl in *; try discriminate.
    destruct (Core.ByteString_dequeue (CharStringToByteString b')) eqn : ?;
      simpl in *; try discriminate.
    destruct p; destruct p0.
    simpl in *; rewrite <- H in H0.
    rewrite (ByteString_dequeue_opt_inj (CharStringToByteString b) (CharStringToByteString b') Heqo).
    reflexivity.
    rewrite Heqo0; repeat f_equal.
    injection H0; eauto.
    assert (ByteStringToCharString b3 = ByteStringToCharString b1) by congruence.
    rewrite <- (CharStringToByteString_ByteStringToCharString_eq b3),
    <-  (CharStringToByteString_ByteStringToCharString_eq b1), H1.
    reflexivity.
Defined.

Definition build_aligned_ByteString
           {numBytes}
           (v : Vector.t byte numBytes)
  : ByteString.
  refine {| front := WO;
            byteString := v |}.
  abstract omega.
Defined.

Definition byteToInt32 (b : byte) : int.
  refine {| intval := Byte.intval b |}.
  pose proof (Byte.intrange b).
  abstract (intuition auto; etransitivity; [apply H1 | reflexivity]).
Defined.

Lemma DecodeBindOpt_assoc:
  forall (A B C D : Type)
         (a_opt : option (A * B))
         (f : A -> B -> option (C * B))
         (g : C -> B -> option (D * B)),
    (`(c, b) <- (`(a, b) <- a_opt; f a b); g c b) =
    (`(a, b) <- a_opt;
      `(c, b) <- f a b;
      g c b).
Proof.
  destruct a_opt as [ [? ?] | ]; simpl; intros.
  - destruct (f a b) as [ [? ?] | ]; reflexivity.
  - reflexivity.
Qed.

Lemma DecodeBindOpt_under_bind:
  forall (A B C : Type) (a_opt : option (A * B)) (f f' : A -> B -> option (C * B)),
  (forall (a : A) (b : B), f a b = f' a b) -> (`(a, b) <- a_opt;
                                                 f a b ) = (`(a, b) <- a_opt;
                                                              f' a b).
Proof.
  destruct a_opt as [ [? ?] | ]; simpl; intros; eauto.
Qed.

Lemma byteString_f_equal
  : forall bs bs'
           (padding_eq : padding bs' = padding bs)
           (numBytes_eq : numBytes bs' = numBytes bs),
    front bs = (@eq_rect nat (padding bs') (fun t => word t) (front bs') _ padding_eq)
    -> byteString bs = @eq_rect nat (numBytes bs') (Vector.t byte) (byteString bs') _ numBytes_eq
    -> bs = bs'.
Proof.
  destruct bs; destruct bs'; simpl; intros.
  subst.
  f_equal.
  apply Core.le_uniqueness_proof.
Qed.

Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Lemma vector_append_assoc {A} {n}
  : forall (v : Vector.t A n) {n'} (v' : Vector.t A n')
           {n''} (v'' : Vector.t A n''),
    append (append v v') v'' = cast (append v (append v' v'')) (Core.plus_assoc' n n' n'').
Proof.
  induction v; simpl.
  - induction v'; simpl.
    + induction v''; simpl.
      reflexivity.
      rewrite <- IHv''; eauto.
    + intros; rewrite <- IHv'.
      reflexivity.
  - intros; rewrite IHv; repeat f_equal.
    eapply Eqdep_dec.eq_proofs_unicity; intros;
      omega.
Qed.

Lemma build_aligned_ByteString_append
      {numBytes'}
  : forall (v' : Vector.t byte numBytes') {numBytes} (v : Vector.t byte numBytes),
    build_aligned_ByteString (Vector.append v v') = ByteString_enqueue_ByteString (build_aligned_ByteString v) (build_aligned_ByteString v').
Proof.
  simpl; intros; rewrite <- (ByteStringToCharString_CharStringToByteString_eq (build_aligned_ByteString v)),
                 <- (ByteStringToCharString_CharStringToByteString_eq (build_aligned_ByteString v')),
                 ByteString_enqueue_ByteString_ByteStringToCharString.
  unfold build_aligned_ByteString; simpl.
  unfold CharStringToByteString; simpl.
  erewrite <- massage_queue_into_ByteString.
  unfold ByteStringToCharString; simpl.
  assert (Datatypes.length
            (List.map byteToWord (to_list v) ++ List.map byteToWord (to_list v'))
          = numBytes0 + numBytes').
  rewrite app_length, <- !length_Vector_to_list; reflexivity.
  eapply byteString_f_equal with (numBytes_eq := H); simpl.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  induction v; simpl in *.
  induction v'.
  - apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
  - simpl in H; injection H; intros.
    simpl; rewrite eq_rect_Vector_cons with (H' := H0); simpl.
    f_equal.
    rewrite wordToByte_byteToWord_eq; eauto.
    eapply IHv'.
  -  simpl in H; injection H; intros.
     simpl; rewrite eq_rect_Vector_cons with (H' := H0); simpl.
     f_equal.
     rewrite wordToByte_byteToWord_eq; eauto.
     eapply IHv.
     Grab Existential Variables.
     reflexivity.
     omega.
Qed.

Lemma build_aligned_ByteString_cons
      {numBytes}
  : forall (v : Vector.t byte (S numBytes)),
    (build_aligned_ByteString v) = ByteString_enqueue_ByteString (build_aligned_ByteString (Vector.cons _ (Vector.hd v) _ (Vector.nil _))) (build_aligned_ByteString (Vector.tl v)).
Proof.
  intros; rewrite <- (build_aligned_ByteString_append (Vector.tl v)
                                                      (Vector.cons _ (Vector.hd v) _ (Vector.nil _))).
  pattern numBytes, v; apply VectorDef.caseS; simpl; intros; reflexivity.
Qed.

Require Import Fiat.BinEncoders.Env.Lib2.WordOpt.

Lemma aligned_decode_char_eq
      {numBytes}
  : forall (v : Vector.t byte (S numBytes)),
    WordOpt.decode_word' (transformerUnit := ByteString_QueueTransformerOpt) 8 (build_aligned_ByteString v)
    = Some (byteToWord (Vector.hd v), build_aligned_ByteString (Vector.tl v)).
Proof.
  simpl; intros.
  etransitivity.
  apply DecodeBindOpt_under_bind; intros; set_evars; rewrite !DecodeBindOpt_assoc.
  repeat (unfold H; apply DecodeBindOpt_under_bind; intros; set_evars; rewrite !DecodeBindOpt_assoc).
  unfold H5; higher_order_reflexivity.
  simpl.
  pattern numBytes, v; eapply Vector.caseS; intros; simpl; clear v numBytes.
  replace (build_aligned_ByteString t) with (ByteString_enqueue_ByteString ByteString_id (build_aligned_ByteString t)).
  rewrite <- (wordToByte_byteToWord_eq h).
  generalize (byteToWord h); intro; rewrite byteToWord_wordToByte_eq.
  shatter_word w.
  pose proof (@dequeue_transform_opt _ _ _ ByteString_QueueTransformerOpt).
  rewrite build_aligned_ByteString_cons; simpl.
  simpl in H7.
  erewrite H7 with (t := x6)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 (WS x3 (WS x4 (WS x5 WO))))));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x5)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 (WS x3 (WS x4 WO)))));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x4)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 (WS x3 WO))));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x3)
                     (b' := {| front := WS x (WS x0 (WS x1 (WS x2 WO)));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x2)
                     (b' := {| front := WS x (WS x0 (WS x1 WO));
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x1)
                     (b' := {| front := WS x (WS x0 WO);
                               byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x0)
                     (b' := {| front := WS x WO;
                            byteString := Vector.nil _ |}); simpl.
  erewrite H7 with (t := x)
                     (b' := {| front := WO;
                            byteString := Vector.nil _ |}); simpl.
  reflexivity.
  unfold dequeue_opt.
  simpl.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  compute; repeat f_equal; apply Core.le_uniqueness_proof.
  unfold build_aligned_ByteString.
  unfold ByteString_dequeue; simpl.
  rewrite byteToWord_wordToByte_eq; simpl.
  repeat f_equal; apply Core.le_uniqueness_proof.
  apply (@transform_id_left _ ByteStringQueueTransformer).
Qed.

Fixpoint Vector_split {A} (n m : nat) (v : Vector.t A (n + m)) :
  Vector.t A n * Vector.t A m :=
  match n return Vector.t A (n + m)
                 -> Vector.t A n * Vector.t A m with
  | 0 => fun v => (Vector.nil _, v)
  | S n' => fun v => let (v', v'') := Vector_split n' m (Vector.tl v) in
                     (Vector.cons _ (Vector.hd v) _ v', v'')
  end v.

Fixpoint VectorByteToWord {numBytes} (v : t byte numBytes) : word (8 * numBytes) :=
  match numBytes return
        t byte numBytes
        -> word (8 * numBytes) with
  | 0 => fun _ => WO
  | S numBytes' => fun v => eq_rect _ word (Core.append_word (VectorByteToWord (Vector.tl v)) (byteToWord (Vector.hd v)))
                                    (8 * S numBytes')  (sym_eq (NPeano.Nat.mul_succ_r _ _))
  end v.

Lemma SW_word_eq_rect_eq
  : forall (m n: nat)
           (b : bool)
           (a : word m) H H',
    SW_word b (eq_rect m word a n H) =
    eq_rect (S m) word (SW_word b a) (S n) H'.
Proof.
  destruct H; simpl; intros.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma Some_eq_rect_eq
  : forall n m w H b,
    eq_rect n (fun n : nat => option (word n * ByteString)) (Some  (w, b)) m H
    = Some (eq_rect n word w _ H, b).
Proof.
  destruct H; simpl; reflexivity.
Qed.

Lemma None_eq_rect_eq
  : forall n m H,
    eq_rect n (fun n : nat => option (word n * ByteString)) (None) m H
    = None.
Proof.
  destruct H; simpl; reflexivity.
Qed.

Require Import Fiat.Common.Equality.

Lemma WS_eq_rect_eq
  : forall n m b (w : word n) H H',
    WS b (eq_rect n word w m H)
    = eq_rect (S n) word (WS b w) (S m) H'.
Proof.
  destruct H; simpl; intros.
  apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma eq_rect_decode_word
  : forall n m H b,
    eq_rect n (fun n0 : nat => option (word n0 * ByteString)) (decode_word' n b) m H =
    decode_word' m b.
Proof.
  induction n; simpl; intros; subst; simpl.
  - reflexivity.
  - reflexivity.
Qed.

Lemma decode_word_plus : forall n m (v : ByteString),
    WordOpt.decode_word' (n + m) v =
    (`(w, v') <- WordOpt.decode_word' (m + n) v;
      Some (eq_rect _ word w _ (Plus.plus_comm _ _), v')).
Proof.
  induction n; simpl; intros.
  - revert v; induction m; simpl; intros.
    + repeat f_equal; apply Eqdep_dec.eq_rect_eq_dec; intros; eauto using Peano_dec.eq_nat_dec.
    + destruct (ByteString_dequeue v) as [ [? ?] | ]; simpl; eauto.
      rewrite IHm, !DecodeBindOpt_assoc; apply DecodeBindOpt_under_bind; intros.
      simpl; eauto.
      repeat f_equal; clear.
      eapply SW_word_eq_rect_eq.
  - etransitivity.
    apply DecodeBindOpt_under_bind; intros.
    set_evars; rewrite IHn, !DecodeBindOpt_assoc.
    unfold H; reflexivity.
    simpl; replace (WordOpt.decode_word' (m + S n) v) with
      (`(w', v') <- WordOpt.decode_word' (S (m + n)) v; Some (eq_rect _ word w' _ (plus_n_Sm _ _), v')).
    + simpl; repeat (rewrite !DecodeBindOpt_assoc; apply DecodeBindOpt_under_bind; intros).
      simpl; repeat f_equal;  erewrite SW_word_eq_rect_eq; rewrite <- transport_pp; f_equal.
    + simpl; rewrite !DecodeBindOpt_assoc.
      etransitivity.
      apply DecodeBindOpt_under_bind; intros.
      set_evars; rewrite !DecodeBindOpt_assoc; simpl.
      unfold H; reflexivity.
      simpl.
      pose proof (IHn (S m) v); simpl in H.
      rewrite !DecodeBindOpt_assoc in H; simpl.
      destruct (ByteString_dequeue v) as [ [? ?] | ]; simpl in *.
      setoid_rewrite DecodeBindOpt_assoc in H; simpl.
      destruct (decode_word' (m + n) b0) as [ [? ?] | ]; simpl in *.
      assert (n + S m = m + S n) by omega.
      assert (eq_rect _ (fun n => option (word n * ByteString)) (decode_word' (n + S m) v) (m + S n) H0
              = eq_rect _ (fun n => option (word n * ByteString))
                        (Some (eq_rect (S (m + n)) word (SW_word b w) (n + S m) (PeanoNat.Nat.add_comm (S m) n), b1))
                        (m + S n) H0)
             by (intros; rewrite H; reflexivity).
      rewrite Some_eq_rect_eq in H1.
      rewrite <- transport_pp in H1.
      erewrite Eqdep_dec.eq_proofs_unicity with (p1 := (plus_n_Sm m n));
        intros; try omega.
      rewrite <- H1.
      rewrite eq_rect_decode_word; reflexivity.
      assert (n + S m = m + S n) by omega.
      rewrite <- eq_rect_decode_word with (H := H0), H; simpl.
      destruct H0; reflexivity.
      assert (n + S m = m + S n) by omega.
      rewrite <- eq_rect_decode_word with (H := H0), H; simpl.
      destruct H0; reflexivity.
Qed.

Lemma aligned_decode_char_eq'
          {numBytes numBytes'}
  : forall (v : Vector.t byte (S numBytes' + numBytes)),
    WordOpt.decode_word' (transformerUnit := ByteString_QueueTransformerOpt) (8 * (S numBytes')) (build_aligned_ByteString v)
    = let (v', v'') := Vector_split (S numBytes') numBytes v in
      Some (VectorByteToWord v', build_aligned_ByteString v'').
Proof.
  induction numBytes'.
  - intros; rewrite aligned_decode_char_eq.
    unfold Vector_split; simpl.
    repeat f_equal; generalize (byteToWord (Vector.hd v)); intro; shatter_word w.
    fold Nat.add.
    apply Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
  - revert IHnumBytes'; generalize (S numBytes'); intros.
    match goal with
      |- ?k = _ =>
      replace k
      with (`(w, v') <-  Some (byteToWord (Vector.hd v), build_aligned_ByteString (Vector.tl v));
            `(w', v'') <- WordOpt.decode_word' (8 * n) v';
            Some (eq_rect _ word (Core.append_word w' w) _ (sym_eq (NPeano.Nat.mul_succ_r _ _)), v''))
    end.
    simpl.
    rewrite IHnumBytes'; simpl.
    destruct (Vector_split n numBytes (Vector.tl v)); simpl; repeat f_equal; clear.
    unfold DecodeBindOpt at 1; unfold If_Opt_Then_Else.
    assert (8 + 8 * n = 8 * S n) by omega.
    rewrite <- eq_rect_decode_word with (H := H).
    assert (8 * n + 8 = 8 + 8 * n) by omega.
    match goal with
      |- context [decode_word' ?m (build_aligned_ByteString ?b) ] =>
      replace (decode_word' m (build_aligned_ByteString b))
      with (`(w, v') <- Some (byteToWord (hd b), build_aligned_ByteString (tl b));
            `(w', v'') <- decode_word' (8 * n) v';
            Some (eq_rect _ word (append_word w' w) _ H0, v''))
    end.
    unfold DecodeBindOpt at 2; unfold If_Opt_Then_Else.
    destruct (decode_word' (8 * n) (build_aligned_ByteString (tl v))) as [ [? ?] | ]; try reflexivity.
    unfold DecodeBindOpt; unfold If_Opt_Then_Else.
    rewrite Some_eq_rect_eq.
    rewrite <- transport_pp.
    repeat f_equal.
    apply Eqdep_dec.eq_proofs_unicity; try intros; omega.
    simpl; symmetry; apply None_eq_rect_eq.
    rewrite <- aligned_decode_char_eq.
    simpl.
    repeat (rewrite !DecodeBindOpt_assoc; simpl; apply DecodeBindOpt_under_bind; intros).
    clear.
    repeat f_equal.
    simpl in H0.
    revert a7 H0; generalize (n + (n + (n + (n + (n + (n + (n + (n + 0)))))))); clear; intros n0 w.
    induction w; simpl; intros.
    symmetry.
    apply Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
    erewrite <- IHw; clear.
    erewrite WS_eq_rect_eq; reflexivity.
    Grab Existential Variables.
    omega.
Qed.

Definition LetIn {A B} (a : A) (k : A -> B) : B := let a' := a in k a'.

Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
                           (at level 81, right associativity,
                            format "'[v' x  <-  y ; '/' z ']'") : comp_scope.

Notation "'Let' a ':=' b 'in' k" := (LetIn b (fun a => k))
                                    (at level 81, right associativity,
                                     format "'[v' 'Let'  a  ':=' b  'in' '/' k ']'").

Lemma VectorByteToWord_cons :
  forall n v h H,
    VectorByteToWord (Vector.cons byte h n v)
    = eq_rect _ _ (Core.append_word (VectorByteToWord v) (byteToWord h)) _ H.
Proof.
  induction v; simpl; intros.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
  repeat f_equal; apply Eqdep_dec.eq_proofs_unicity; intros; omega.
Qed.

Lemma Vector_nth_tl {A} : forall n (v : Vector.t A (S n)) p,
    Vector.nth v (Fin.FS p) = Vector.nth (Vector.tl v) p.
Proof.
  intros ? ?; pattern n, v; apply Vector.rectS; simpl; intros.
  inversion p.
  reflexivity.
Qed.

Lemma Vector_nth_hd {A} : forall n (v : Vector.t A (S n)),
    Vector.nth v Fin.F1 = Vector.hd v.
Proof.
  intros ? ?; pattern n, v; apply Vector.rectS; simpl; reflexivity.
Qed.

Fixpoint decode_list'
         {A : Type}
         {cache : Cache}
         (n : nat)
         (A_decode: nat -> CacheDecode -> (A * CacheDecode))
         (cd : CacheDecode) {struct n}
  : (list A * CacheDecode) :=
  match n return (nat -> CacheDecode -> (A * CacheDecode))
                 -> _
  with
  | 0 => fun _ => ([ ], cd)
  | S n' => fun A_decode' => Let a := A_decode' 0 cd in
        Let a' := decode_list' n' (fun p => A_decode' (S p)) (snd a) in
                                            (fst a :: (fst a'), snd a')
  end A_decode.

(* Variable magic : forall (n : nat), Fin.t (4 * n).

Lemma decode_list_decode_list'_eq
  : forall n m (b : Vector.t byte ((4 * n) + m)) cd,
    decode_list (decode_int Int.wordsize) n (build_aligned_ByteString b) cd
    = Some (fst (decode_list' n (fun p cd =>
                                   (ofbytes (Vector.nth b (Fin.L m (magic p)))
                                            (Vector.nth b (Fin.FS (Fin.L m (magic _ p))))
                                            (Vector.nth b p)
                                            (Vector.nth b p), cd)) cd),
            (build_aligned_ByteString b),
            snd (decode_list' n (fun p cd =>
                                   (ofbytes (Vector.nth b p)
                                            (Vector.nth b p)
                                            (Vector.nth b p)
                                            (Vector.nth b p), cd)) cd)).
Admitted. *)


(************************************************************************)
(* Copyright (c) 2017-2018, Ajay Kumar Eeralla <ae266@mail.missouri.edu>*)
(************************************************************************)

Require Export cpdtTactics.

(** This library defines equational theory and axioms. The axioms are written for [message] and [Bool] types. *)

(** * Equational theory for DH Protocol *)
Open Scope msg_scope.
Section eqtheory.
Axiom proj1: forall (m1 m2 : message),  (pi1 (m1, m2)) # m1.
Axiom proj2: forall (m1 m2 : message), (pi2 (m1, m2)) # m2.
Axiom len: forall (m:message), | |m| | # |m|.
Axiom eqmeql: forall (m: message), m #? m ## TRue.
End eqtheory.

(** * Core Axioms *)
Section core_axioms.

   Section funapp.
Axiom FUNCApp_att4: forall (p1 p2 p3 p4 : nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ bol (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos  p2 ml1)) (ostomsg (getelt_at_pos  p3 ml1)) (ostomsg (getelt_at_pos  p4 ml1)))] ++ ml1 )
 ~ ([ bol (f (ostomsg (getelt_at_pos  p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos  p3 ml2)) (ostomsg (getelt_at_pos p4 ml2)))] ++ ml2).

Axiom FUNCApp_mconst: forall  {n} (m:message) (ml1 ml2 : mylist n), (const_msg m = true) -> (ml1 ~ ml2)  -> ([msg m] ++ ml1) ~ ([msg m] ++ ml2).

Axiom FUNCApp_bconst: forall  {n} (b:Bool) (ml1 ml2 : mylist n), (const_bol b = true)-> (ml1 ~ ml2) -> ([bol b] ++ ml1) ~ ([bol b] ++ ml2).

Axiom FUNCApp_f1: forall (p:nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2) -> ([msg (f (ostomsg (getelt_at_pos p ml1)))] ++ ml1) ~
                                                                              ([msg (f (ostomsg (getelt_at_pos p ml2)))] ++ ml2).

Axiom FUNCApp_f2b: forall (p1 p2 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2) -> ([bol (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)))] ++ ml1) ~
                                                                                ([bol (f (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)))] ++ ml2).

Axiom FUNCApp_f2m: forall (p1 p2 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ msg  (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)))] ++ ml1) ~
                                                                                ([ msg (f (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)))] ++ ml2).

Axiom FUNCApp_f3b: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ bol  (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)))] ++ ml1) ~
                                                                                ([ bol  (f (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)))] ++ ml2).

Axiom FUNCApp_f3bm: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ msg  (f (ostobol (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)))] ++ ml1) ~
                                                                                ([ msg  (f (ostobol (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)))] ++ ml2).

Axiom FUNCApp_f3m: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ msg  (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)))] ++ ml1) ~
                                                                                ([ msg  (f (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)))] ++ ml2).

Axiom FUNCApp_f4b: forall (p1 p2 p3 p4 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ bol  (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)) (ostomsg (getelt_at_pos p4 ml1)))] ++ ml1) ~ ( [ bol  (f (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)) (ostomsg (getelt_at_pos p4 ml2)))] ++ ml2).

Axiom FUNCApp_f4m: forall (p1 p2 p3 p4 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ msg  (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)) (ostomsg (getelt_at_pos p4 ml1)))] ++ ml1) ~ ([msg (f (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)) (ostomsg (getelt_at_pos p4 ml2)))] ++ ml2).

Axiom FUNCApp_f4mb: forall (p1 p2 p3 p4 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ bol (f (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)) (ostomsg (getelt_at_pos p4 ml1)))] ++ ml1) ~ ([bol (f (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)) (ostomsg (getelt_at_pos p4 ml2)))] ++ ml2).

Axiom FUNCApp_g2: forall (p1 p2 :nat) {n} (ml1 ml2 : mylist n) {f}, (ml1 ~ ml2 ) -> ([ bol  (f (ostobol (getelt_at_pos p1 ml1)) (ostobol (getelt_at_pos p2 ml1)))] ++ ml1) ~
                                                                                ([ bol  (f (ostobol (getelt_at_pos p1 ml2)) (ostobol (getelt_at_pos p2 ml2)))] ++ ml2).

Axiom FUNCApp_g3: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n){f}, (ml1 ~ ml2 ) -> ([ bol  (f (ostobol (getelt_at_pos p1 ml1)) (ostobol (getelt_at_pos p2 ml1)) (ostobol (getelt_at_pos p3 ml1)))] ++ ml1) ~
                                                                                ([ bol  (f (ostobol (getelt_at_pos p1 ml2)) (ostobol (getelt_at_pos p2 ml2)) (ostobol (getelt_at_pos p3 ml2)))] ++ ml2).
Axiom FUNCApp_sublist:  forall (m n:nat) {n1} (ml1 ml2:mylist n1){f}, (ml1 ~ ml2) -> ([msg (f  (sublist m n (toListm ml1)))]++ ml1) ~ ([msg (f (sublist m n (toListm ml2)))]++ ml2).

(**************************************************************************************************)

Axiom FUNCApp_const: forall (n m :nat) (ml1 ml2: mylist n) (a: mylist m), (ml1 ~ ml2) -> ((const  a ml1 )++ ml1) ~ ((const a ml2)++ ml2).

Axiom FUNCApp_appelt:  forall (n p :nat) (ml1 ml2: mylist n), (ml1 ~ ml2) -> ([getelt_at_pos  p ml1]  ++ ml1) ~ ([getelt_at_pos  p ml2]++ ml2).

Axiom FUNCApp_eqm: forall (p1 p2:nat) {n} (ml1 ml2: mylist n), (ml1 ~ ml2) -> (([ bol (eqm_at_pos  p1 p2 ml1) ])++ ml1) ~ (([ bol (eqm_at_pos  p1 p2 ml2)])++ ml2).
Axiom FUNCApp_eqb: forall ( p1 p2:nat) {n} (ml1 ml2: mylist n), (ml1 ~ ml2) ->  ( [ bol (eqb_at_pos  p1 p2 ml1)])  ~ ( [ bol (eqb_at_pos  p1 p2 ml2)])  .

Axiom FUNCApp_negpos: forall (p :nat) {n} (ml1 ml2: mylist n), (ml1 ~ ml2) -> ((neg_at_pos p ml1)++ ml1) ~ ((neg_at_pos p ml2)++ ml2).

Axiom FUNCApp_ifmnespair : forall ( p1 p2 p3 p4 : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2) -> ([msg (ifm_nespair  p1 p2 p3 p4 ml1)]++ ml1) ~([msg (ifm_nespair  p1 p2 p3 p4 ml2)]++ ml2).

Axiom FUNCApp_ifmpair: forall ( p1 p2 p3 p4  : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2) -> ([msg (ifm_pair  p1 p2 p3 p4 ml1)]++ ml1) ~ ([ msg (ifm_pair p1 p2 p3 p4 ml2)]++ ml2).
(*
Axiom FUNCApp_expatpos: forall (p1 p2 p3 : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2) -> ( [msg (exp_at_pos  p1 p2 p3  ml1)]++ ml1) ~ ( [msg (exp_at_pos  p1 p2 p3  ml2)]) .

Axiom FUNCApp_att : forall {n} (ml1 ml2: mylist n) (l1 l2 :list message ), (ml1 ~ ml2) -> ([msg (f l1)] ++ ml1++ ml1) ~ ([msg (f l2)] ++ ml2++ ml2).

Axiom FUNCApp_reveal:  forall ( p:nat) {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg (reveal_at_pos p ml1)] ++ml1   ++ ml1) ~ ([msg (reveal_at_pos p ml2)] ++ml2 ++ ml2).
*)
Axiom FUNCApp_to:  forall (p:nat) {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg (to_at_pos p ml1)] ++ ml1)  ~ ([msg (to_at_pos p ml2)] ++ ml2).
(*
Axiom FUNCApp_act:  forall (p:nat) {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg (act_at_pos p ml1)] ++ ml1)  ~ ([msg (act_at_pos p ml2)] ++ ml2++ ml2).

Axiom FUNCApp_new : forall {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg new ] ++ ml1++ ml1) ~ ([msg new ] ++ ml2++ ml2).
*)
Axiom FUNCApp_O : forall {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ( [msg O]++ ml1) ~ ([msg O]++ ml2).
(*
Axiom FUNCApp_acc : forall {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ( [msg acc]++ ml1) ~ ([msg acc]++ ml2).

Axiom FUNCApp_session : forall ( m: nat ) {n} (ml1 ml2 : mylist m) , (ml1 ~ ml2) -> ([msg (i n) ] ++ ml1++ ml1) ~ ([msg (i n) ] ++ ml2++ ml2).
*)
Axiom FUNCApp_andB : forall (p1 p2 :nat) {m} (ml1 ml2 : mylist m), (ml1 ~ ml2) -> ([bol (andB_at_pos p1 p2 ml1)]++ ml1) ~  ([bol (andB_at_pos p1 p2 ml2)]++ ml2).

Axiom FUNCApp_notB : forall (p :nat) {m} (ml1 ml2:mylist m), (ml1 ~ ml2) -> ([bol (notB_at_pos  p ml1)]++ ml1) ~ ([bol (notB_at_pos p ml2)]++ ml2).
(*
Axiom FUNCApp_m : forall (p :nat) {m} (ml1 ml2:mylist m), (ml1 ~ ml2) -> ( [ msg (m_at_pos  p ml1)] ++ ml1++ ml1) ~  (  [msg (m_at_pos  p ml2) ] ++ ml2++ ml2).

Axiom FUNCApp_elt :   forall (p   :nat) {m} (ml1 ml2:mylist m), (ml1~ml2) ->  ([getelt_at_pos  p ml1 ] ++ ml1) ~ ([  getelt_at_pos p ml2]++ ml2).
*)
Axiom FUNCApp_pair: forall (p1 p2 :nat) {m} (ml1 ml2 : mylist m), (ml1 ~ ml2) -> ([msg ( ostomsg (getelt_at_pos p1 ml1) , ostomsg ( getelt_at_pos p2 ml1 )) ]++ ml1) ~ ([ msg ( ostomsg (getelt_at_pos p1 ml2) , ostomsg ( getelt_at_pos p2 ml2 ))] ++ ml2).

Axiom FUNCApp_pi1: forall (p :nat)  {m} (ml1 ml2 : mylist m), (ml1 ~ ml2) -> ( [ msg (pi1 (ostomsg (getelt_at_pos p ml1)))] ++ ml1) ~  ( [ msg (pi1 (ostomsg (getelt_at_pos p ml2)))] ++ ml2).

Axiom FUNCApp_pi2: forall (p :nat)  {m} (ml1 ml2 : mylist m), (ml1 ~ ml2) -> ( [ msg (pi2 (ostomsg (getelt_at_pos p ml1)))] ++ ml1 ) ~  ( [ msg (pi2 (ostomsg (getelt_at_pos p ml2)))] ++ ml2).
(** TODO: XXX a version of FuncApp is presented below*)
Axiom funcApp_latest: forall p {m} (l1 l2: mylist m) n t,
    (length (mVarMsg t) <=? 1)%nat = true ->
    mVarMsg t = (cons n nil) ->
    l1 ~ l2 ->
    (l1 ++ [msg (submsg_msg n (ostomsg (getelt_at_pos p l1)) t)]) ~
                     (l2 ++ [msg (submsg_msg n (ostomsg (getelt_at_pos p l2)) t)]).

End funapp.

(** [RESTR] *)
Section restr.
(** Indistinguishability is closed under projections *)
Axiom RESTR_proj : forall ( p :nat) {m} (ml1 ml2 :mylist m), ml1 ~ ml2 -> (proj_at_pos p ml1) ~ (proj_at_pos p ml2).

Axiom RESTR_dropls: forall {n} (ml1 ml2: mylist n), ml1 ~ ml2 -> (droplastsec ml1) ~ (droplastsec ml2).

Axiom RESTR_dropone: forall {n} (ml1 ml2: mylist n), ml1 ~ ml2 -> (dropone ml1) ~ (dropone ml2).

(** Indistinguishability is closed under permutations *)

Axiom RESTR_swap : forall (p1 p2 : nat) {n} (ml1 ml2 : mylist n), ml1~ ml2 -> (swap_mylist p1 p2 ml1) ~ (swap_mylist p1 p2 ml2).

Axiom RESTR_swapls: forall {n1 n2} (ml1 ml2 : mylist n1) (ml3 ml4 :mylist n2) , (ml1 ++ ml3) ~ (ml2 ++ ml4) -> (ml3 ++ ml1) ~ (ml4 ++ ml2).

End restr.

(** Axioms for indistinguishability *)

Axiom REFL: forall {n} (x : mylist n), x ~ x.
Axiom SYM: forall {n} (x y : mylist n), x ~ y -> y ~ x.
Axiom TRANS: forall {n} (x y z : mylist n), x ~ y /\ y ~ z -> x ~ z.
Axiom RESTR: forall {n m} (x y : mylist n) (p: mylist n -> mylist m), x ~ y -> (p x) ~ (p y).
Axiom FUNCAPP: forall {n m} (x y : mylist n) (f: mylist n -> mylist m), x ~ y -> (x ++ (f x)) ~ (y ++ (f y)).
Axiom IFDIST: not([bol TRue] ~ [bol FAlse]).

(** Axioms for equality *)
Axiom EQCONG_M: forall (x y : message) {f}, x # y -> (f x) # (f y).
Axiom EQCONG_B: forall (x y : Bool) {f}, x ## y -> (f x) ## (f y).

(** Axioms for [if_then_else] symbol. *)

(** [IFSAME] *)

Axiom IFSAME_M: forall (b:Bool) (x : message), (If b then x else x) # x.

Axiom IFSAME_B: forall (b:Bool) (b1 : Bool),  (IF b then b1 else b1) ## b1.

(** [IFEVAL] *)

Axiom IFEVAL_B : forall (b1 b2 : Bool)(n:nat), (IF (Bvar n) then b1 else b2) ## (IF (Bvar n) then ([n := TRue] b1) else ([n := FAlse] b2)).

Axiom IFEVAL_M : forall (t1 t2 : message) (n:nat), (If (Bvar n) then t1 else t2) # (If (Bvar n) then ((n := TRue) t1) else ((n := FAlse) t2)).

Axiom IFEVAL_B' : forall (b b1 b2 : Bool), (IF b then b1 else b2) ## (IF b then (subbol_bol' b TRue b1) else (subbol_bol' b FAlse b2)).

Axiom IFEVAL_M' : forall (b:Bool)(t1 t2 : message), (If b then t1 else t2) #(If b then (subbol_msg' b TRue t1) else (subbol_msg' b FAlse t2)).

(** [IFTRue] *)

Axiom IFTRUE_M : forall (x y : message),  (If TRue then x else y) # x .

Axiom IFTRUE_B : forall (b1 b2 : Bool), (IF TRue then b1 else b2) ## b1.

(** [IFFAlse] *)

Axiom IFFALSE_M: forall (x y : message), (If FAlse then x else y) # y.

Axiom IFFALSE_B: forall (b1 b2 : Bool), (IF FAlse then b1 else b2) ## b2.

(** [IFBRANCH *)

Axiom  IFBRANCH_M1: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x x' y y':message), (ml1 ++ [ bol b , msg x] ) ~  ( ml2 ++ [ bol b', msg x'])  ->  (ml1 ++ [bol b , msg y ] ) ~( ml2 ++ [bol b' , msg y']) -> (ml1 ++  [ msg (If b then x else y)])~ ( ml2 ++ [ msg (If b' then x' else y')]).

Axiom IFBRANCH_M2: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' y1 y1' y2 y2' :message), (ml1 ++ [ bol b , msg x1, msg x2] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2'])  ->  (ml1 ++ [bol b, msg y1, msg y2 ] ) ~( ml2 ++ [bol b', msg y1', msg y2'])
                                                                                -> (ml1 ++  [ msg (If b then x1 else y1) , msg (If b then x2 else y2) ])~ ( ml2 ++ [ msg (If b' then x1' else y1') , msg (If b' then x2' else y2')]).

(** [Fresh] *)

Definition r (n:nat) := (re (nonce n)).
Notation " '[[' x ']]'" := (cons x nil): msg_scope.

Axiom FRESHIND : forall (n n1 n2:nat) (v w: mylist n),   (v ~ w) ->   ((closMylist (v++w)) = true) /\ ( (Fresh [[n1]] (v++w)) = true) /\ ( (Fresh [[n2]] (v++w)) = true) -> ((msg  (nonce n1)) +++ v) ~ (( msg  (nonce n2)) +++w ).

Axiom FRESHNEQ: forall (n : nat) (m : message), ((closMsg m) = true)/\ ( (Fresh [[n]] [msg m]) = true) ->[bol (eqm (nonce n) m)]~ [bol FAlse].

Axiom FRESHIND_rs: forall (n n1 n2:nat) (v w: mylist n),  (v ~ w) -> ((closMylist (v++w)) = true) /\ ( (Fresh [[n1]]  (v++w)) = true) /\ ( (Fresh [[n2]] (v++w)) = true)   -> ((msg (r n1) ) +++ v) ~ (( msg (r n2)) +++w ).

Section ifbranch.
(** [IFBRANCH] *)
(*
Axiom IFBRANCH_M: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x x' y y':message), (ml1 ++ [ bol b ; msg x] ) ~  ( ml2 ++ [ bol b'; msg x'])  ->  (ml1 ++ [bol b ; msg y ] ) ~( ml2 ++ [bol b' ; msg y'])
-> (ml1 ++ [bol b ;msg (ifm b x y)])~ ( ml2 ++ [bol b' ; msg (ifm b' x' y')]).

Axiom IFBRANCH_B: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(b1 b1' b2 b2':Bool), (ml1 ++ [bol b ;bol b1]) ~ ( ml2 ++ [bol b' ; bol b1'])  ->  (ml1 ++ [ bol b; bol b2]) ~( ml2 ++ [bol b'; bol b2'])
-> (ml1 ++ [ bol b ;bol (ifb b b1 b2)])~ (  ml2 ++ [bol b' ; bol (ifb b' b1' b2')] ).
 *)

Axiom IFBRANCH_M3: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' y1 y1' y2 y2' y3 y3' :message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3 ] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3'])                                                                                -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) ])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3')]).

Axiom IFBRANCH_M4: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' x4 x4' y1 y1' y2 y2' y3 y3' y4 y4' :message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3, msg x4] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3', msg x4'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3, msg y4 ] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3', msg y4'])  -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) , msg (ifm_then_else_ b x4 y4) ])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3') ,  msg (ifm_then_else_ b' x4' y4')]).

Axiom IFBRANCH_M5: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' x4 x4' x5 x5' y1 y1' y2 y2' y3 y3' y4 y4' y5 y5' :message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3, msg x4 , msg x5] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3', msg x4', msg x5'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3, msg y4, msg y5 ] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3', msg y4', msg y5'])  -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) , msg (ifm_then_else_ b x4 y4), msg (ifm_then_else_ b x5 y5) ])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3') ,  msg (ifm_then_else_ b' x4' y4'), msg (ifm_then_else_ b' x5' y5')]).

Axiom IFBRANCH_M6: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' x4 x4' x5 x5' x6 x6' y1 y1' y2 y2' y3 y3' y4 y4' y5 y5' y6 y6':message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3, msg x4 , msg x5, msg x6] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3', msg x4', msg x5' , msg x6'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3, msg y4, msg y5, msg y6] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3', msg y4', msg y5', msg y6'])  -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) , msg (ifm_then_else_ b x4 y4), msg (ifm_then_else_ b x5 y5), msg (ifm_then_else_ b x6 y6)])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3') ,  msg (ifm_then_else_ b' x4' y4'), msg (ifm_then_else_ b' x5' y5'), msg (ifm_then_else_ b' x6' y6')]).

Axiom IFBRANCH_M7: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' x4 x4' x5 x5' x6 x6' x7 x7' y1 y1' y2 y2' y3 y3' y4 y4' y5 y5' y6 y6' y7 y7' :message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3, msg x4 , msg x5, msg x6 , msg x7] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3', msg x4', msg x5' , msg x6' , msg x7'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3, msg y4, msg y5, msg y6 , msg y7 ] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3', msg y4', msg y5', msg y6' , msg y7'])  -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) , msg (ifm_then_else_ b x4 y4), msg (ifm_then_else_ b x5 y5), msg (ifm_then_else_ b x6 y6), msg (ifm_then_else_ b x7 y7) ])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3') ,  msg (ifm_then_else_ b' x4' y4'), msg (ifm_then_else_ b' x5' y5'), msg (ifm_then_else_ b' x6' y6'), msg (ifm_then_else_ b' x7' y7')]).

Axiom IFBRANCH_M8: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' x4 x4' x5 x5' x6 x6' x7 x7' x8 x8' y1 y1' y2 y2' y3 y3' y4 y4' y5 y5' y6 y6' y7 y7' y8 y8' :message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3, msg x4 , msg x5, msg x6 , msg x7, msg x8] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3', msg x4', msg x5' , msg x6' , msg x7', msg x8'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3, msg y4, msg y5, msg y6 , msg y7, msg y8 ] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3', msg y4', msg y5', msg y6' , msg y7', msg y8'])  -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) , msg (ifm_then_else_ b x4 y4), msg (ifm_then_else_ b x5 y5), msg (ifm_then_else_ b x6 y6), msg (ifm_then_else_ b x7 y7), msg (ifm_then_else_ b x8 y8) ])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3') ,  msg (ifm_then_else_ b' x4' y4'), msg (ifm_then_else_ b' x5' y5'), msg (ifm_then_else_ b' x6' y6'), msg (ifm_then_else_ b' x7' y7'), msg (ifm_then_else_ b' x8' y8')]).

Axiom IFBRANCH_M9: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' x4 x4' x5 x5' x6 x6' x7 x7' x8 x8' x9 x9' y1 y1' y2 y2' y3 y3' y4 y4' y5 y5' y6 y6' y7 y7' y8 y8' y9 y9' :message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3, msg x4 , msg x5, msg x6 , msg x7, msg x8, msg x9] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3', msg x4', msg x5' , msg x6' , msg x7', msg x8', msg x9'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3, msg y4, msg y5, msg y6 , msg y7, msg y8, msg y9 ] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3', msg y4', msg y5', msg y6' , msg y7', msg y8', msg y9'])  -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) , msg (ifm_then_else_ b x4 y4), msg (ifm_then_else_ b x5 y5), msg (ifm_then_else_ b x6 y6), msg (ifm_then_else_ b x7 y7), msg (ifm_then_else_ b x8 y8), msg (ifm_then_else_ b x9 y9) ])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3') ,  msg (ifm_then_else_ b' x4' y4'), msg (ifm_then_else_ b' x5' y5'), msg (ifm_then_else_ b' x6' y6'), msg (ifm_then_else_ b' x7' y7'), msg (ifm_then_else_ b' x8' y8'), msg (ifm_then_else_ b' x9' y9')]).

Axiom IFBRANCH_M10: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x1 x1' x2 x2' x3 x3' x4 x4' x5 x5' x6 x6' x7 x7' x8 x8' x9 x9' x10 x10' y1 y1' y2 y2' y3 y3' y4 y4' y5 y5' y6 y6' y7 y7' y8 y8' y9 y9' y10 y10' :message), (ml1 ++ [ bol b , msg x1, msg x2 , msg x3, msg x4 , msg x5, msg x6 , msg x7, msg x8, msg x9, msg x10] ) ~  ( ml2 ++ [ bol b', msg x1' , msg x2' , msg x3', msg x4', msg x5' , msg x6' , msg x7', msg x8', msg x9', msg x10'])  ->  (ml1 ++ [bol b , msg y1 , msg y2 , msg y3, msg y4, msg y5, msg y6 , msg y7, msg y8, msg y9, msg y10 ] ) ~( ml2 ++ [bol b' , msg y1', msg y2' , msg y3', msg y4', msg y5', msg y6' , msg y7', msg y8', msg y9', msg y10'])  -> (ml1 ++  [ msg (ifm_then_else_ b x1 y1) , msg (ifm_then_else_ b x2 y2) , msg (ifm_then_else_ b x3 y3) , msg (ifm_then_else_ b x4 y4), msg (ifm_then_else_ b x5 y5), msg (ifm_then_else_ b x6 y6), msg (ifm_then_else_ b x7 y7), msg (ifm_then_else_ b x8 y8), msg (ifm_then_else_ b x9 y9), msg (ifm_then_else_ b x10 y10) ])~ ( ml2 ++ [ msg (ifm_then_else_ b' x1' y1') , msg (ifm_then_else_ b' x2' y2') , msg (ifm_then_else_ b' x3' y3') ,  msg (ifm_then_else_ b' x4' y4'), msg (ifm_then_else_ b' x5' y5'), msg (ifm_then_else_ b' x6' y6'), msg (ifm_then_else_ b' x7' y7'), msg (ifm_then_else_ b' x8' y8'), msg (ifm_then_else_ b' x9' y9'), msg (ifm_then_else_ b' x10' y10')]).

End ifbranch.
End core_axioms.

(** * Auxilary Axioms *)
Section aux_thms.

(** Equality ([Bool] or [message]) is closed under substitution. *)

Theorem Forall_ELM_EVAL_M: forall (x:Bool) (n:nat) (t1 t2 :message), ( t1 # t2 ) ->  ((( n:=x )t1) # ((n:=x)t2)).
Proof. intros; rewriteHyp;try reflexivity. Qed.

  Theorem Forall_ELM_EVAL_B: forall (b:Bool) (n:nat) (b1 b2 :Bool), (  b1 ## b2 ) ->  ( ([n:=b] b1) ## ([n:=b] b2)).
Proof. intros; rewriteHyp;try reflexivity. Qed.
Theorem Forall_ELM_EVAL_M1: forall (x:message) (n:nat) (t1 t2 :message), (t1 # t2 ) ->  ({{n:=x}} t1 # {{n:=x}}t2).
  Proof. intros; rewriteHyp;try reflexivity. Qed.
Theorem Forall_ELM_EVAL_B1: forall (b:message) (n:nat) (b1 b2 :Bool), ( b1 ## b2 ) ->  ( [[n:=b]] b1 ## [[n:=b]] b2).
Proof. intros; rewriteHyp;try reflexivity. Qed.
Theorem Forall_ELM_EVAL_M2: forall (x:Bool) (n:nat) (t1 t2 :message), (t1 # t2)  ->  ( (( n:=x )t1) # ((n:=x)t2 )).
  Proof. intros; rewriteHyp;try reflexivity. Qed.
Theorem Forall_ELM_EVAL_B2: forall (b:Bool) (n:nat) (b1 b2 :Bool), (b1 ## b2)  ->   ( [n:=b] b1 ## [n:=b] b2).
Proof. intros; rewriteHyp;try reflexivity. Qed.
Theorem Forall_ELM_EVAL_M3: forall (x:message) (n:nat) (t1 t2 :message),  ( t1 # t2)  ->  ( {{n:=x}} t1  # {{n:=x}}t2).
  Proof. intros; rewriteHyp;try reflexivity. Qed.
  Theorem Forall_ELM_EVAL_B3: forall (b:message) (n:nat) (b1 b2 :Bool), ( b1 ## b2) ->   ( [[n:=b]] b1 ## [[n:=b]] b2).
    Proof. intros; rewriteHyp;try reflexivity. Qed.
End aux_thms.

(*
(***substitutions under attacker functions**********)
Axiom sub_msg_f : forall ( n :nat) (s:message) {m} (l: ilist message m), {{ n := s }} (f l) # (f (submsg_mlist n s l)).
Axiom sub_bol_f : forall ( n :nat) (b: Bool) {m} (l: ilist message m), ( n := b ) (f l) # (f (subbol_mlist n b l)).
 *)

(** There always exists a natural number which doesn't occur in lists of terms. *)

Fixpoint occurNlist (n:nat) (nl: Nlist):bool :=
  match nl with
  | nil => false
  | h :: t => beq_nat n h || occurNlist n t
  end.

Axiom existsnMylist: forall (m :nat) (nl : Nlist)(bl:mylist m), exists n , (occurNlist n nl = false) /\ (occur_name_mylist n bl = false).
Axiom existsnBlist : forall (m:nat) (nl : Nlist)(bl:Blist ), exists n , (occurNlist n nl = false) /\ (occurBlist n bl = false).
Axiom existsnMlist: forall (m :nat) (nl : Nlist)(ml:Mlist), exists n , (occurNlist n nl = false) /\ (occurMlist n ml = false).
(*
Axiom subconct: forall (n1 n2 n:nat) (ml1 : mylist n1)(ml2 : mylist n2)(b:Bool), ((subbol_mylist n b (ml1 ++ ml2)) =(subbol_mylist n b ml1 ++ subbol_mylist n b ml2)).
Axiom subinmsg : forall (n : nat)(b:Bool) (t1:message), ( (subbol_os n b (msg t1) ) = (msg ((n := b) t1))).
Axiom subinbol : forall (n : nat)(b:Bool) (t1:Bool), ( (subbol_os n b (bol t1) ) = (bol ([n := b] t1))).
*)

(** Substitution inside substitution. *)

Axiom notocc_bolmm: forall (n1 n2 : nat) (b: Bool) (m1 m2 : message), (occur_name_msg n1 m2) = false -> ( n1 :=  b) ({{ n2:= m1}}  m2) = ({{ n2 := (( n1 := b) m1) }} m2).
(*Axiom occ_bolmm: forall (n1 n2 : nat) (b: Bool) (m1 m2 : message), (notoccur_name_msg n1 m2) = false -> ( n1 :=  b)  ((submsg_msg n2 m1)  m2) = (submsg_msg n2 (( n1 := b) m1)) (( n1 := b)m2) .*)

Axiom notocc_bolbb : forall  (n1 n2 :nat) (b b1 b2:Bool), (occur_name_bol n1 b2) = false -> ([ n1 :=  b]  [ n2 := b1]  b2)  =    ( [ n2 := ([n1:=b] b1)]  b2) .
(*Axiom occ_bolbb : forall  (n1 n2 :nat) (b b1 b2:Bool), (notoccur_bol n1 b2) = false -> ([ n1 :=  b]  [ n2 := b1]  b2)  =    ( [ n2 := ([n1:=b] b1)]  ([n1:=b] b2)) .*)

Axiom notocc_bolmb : forall (n1 n2 :nat) (b  b1:Bool) (m:message),(occur_name_bol n1 b1) = false -> ([ n1 :=  b]  [[ n2 := m]]  b1)  =    ( [[ n2 := ((n1 := b) m)]]  b1).
(*Axiom occ_bolmb : forall (n1 n2 :nat) (b  b1:Bool) (m:message),(notoccur_bol n1 b1) = false -> ([ n1 :=  b]  [[ n2 := m]]  b1)  =    ( [[ n2 := ((n1 := b) m)]]  ([ n1 :=  b] b1)).*)

Axiom notocc_bolbm : forall (n1 n2 :nat) (b  b1:Bool) (m:message),(occur_name_msg n1 m) = false -> ( ( n1 :=  b)  (( n2 := b1) m)  =    ( ( n2 := ([n1 := b] b1))  m)).
(*Axiom occ_bolbm : forall (n1 n2 :nat) (b  b1:Bool) (m:message),(notoccur_msg n1 m) = false -> ( ( n1 :=  b)  (( n2 := b1) m)  =    ( ( n2 := ([n1 := b] b1))  (n1 := b)m)).*)

Axiom single_var_sub: forall n t t1 n1 s, beq_nat n1 n = false ->
                                          mVarMsg t1 = (cons n nil) ->
                                          occur_name_msg n1 t = false ->
                                               {{ n1 := s }} ({{ n := t}} t1) # ({{ n := t}} t1).
(********************************************************************************)
Axiom notoccn_Bool: forall (n:nat)(b t:Bool), ((occur_name_bol n t) = true )-> ([n := b]t =  t).
Axiom notoccn_msg: forall (n:nat)(b:Bool)(t:message), ((occur_name_msg n t) = true) -> ((n:= b)t) = t.
(***********************************************************************************)

(** Trivially sound axioms. *)

Axiom invarsub_Bmsg : forall(n:nat)(t:message), ((n:= (Bvar n))t = t).
Axiom invarsub_BBool: forall(n:nat)(b:Bool), ([n:=(Bvar n)] b) = b.
Axiom invarsub_mBool : forall(n:nat)(b: Bool), ([[n:= (Mvar n)]] b) = b.
Axiom invarsub_mmsg : forall(n:nat)(t: message),{{n:= (Mvar n)}} t = t.

(*
(**Axiom RESTR_Perm: forall(n1 n2 n3 n4 n5:nat) (nl1 ml1 : mylist n1)(nl2 ml2 : mylist n2)(nl3 ml3 : mylist n3)(ml4 nl4 : mylist n4) (ml5 nl5 : mylist n5), (nl1++nl2++nl3++nl4++nl5)~(ml1++ml2++ml3++ml4++ml5)  -> (nl1 ++nl4++nl2++nl5++nl3)~ (ml1 ++ml4++ml2++ml5++ml3).**)

(*********************Axiliary axioms****************************)

(*Axiom simpinsub_B : forall (n n1 n2 n3 n4 n5 n6 :nat)(t1 t2 : Bool), (ifb (Bvar n) [n5 := ifb TRue (Bvar n1) (Bvar n2)](t1)
   [n6 := ifb FAlse (Bvar n3) (Bvar n4)](t2))## (ifb (Bvar n) [n5 := Bvar n1](t1) [n6 := Bvar n4](t2)).**)
*)

(*
Section dh_axioms.
 *)
(** [DDH] assumption:
[[
    Fresh [n,n1,n2,n3]-> [G(n), g(n),g(n)^(r (n1)),g(n)^(r (n2)), g(n)^(r (n1))(r (n2))] ~[G(n), g(n),g(n)^(r (n1)),g(n)^(r (n2)), g(n)^(r (n3))]
]]

*)
     (*
Axiom DDH : forall (n n1 n2 n3: nat),  (Fresh [ n , n1 ,  n2  , n3 ] []) = true->
                                       [ msg (G n) , msg (g n) , msg (exp (G n) (g n) (r  n1)) , msg (exp (G n) (g n) (r  n2)) , msg (exp (G n) (exp (G n) (g n) (r  n1)) (r  n2))] ~ [msg (G n) , msg (g n) , msg (exp (G n) (g n) (r  n1)) , msg (exp (G n) (g n) (r n2)) , msg (exp (G n) (g n) (r n3))] .

End dh_axioms.
*)
Section ds_axioms.
(** * Digital Signatures*)
(** Correctness *)

Axiom correctness :  forall (n:nat) (t t' :message), (ver (vk n)  t (sign (ssk n) t t')) ## TRue.

(** Existential unforgeability under adaptively chosen message attacks (UF-CMA secure) *)

  Fixpoint unforgb  (j:nat) (n:nat)  (ml: list message) (t u :message) : Bool :=
    match j, ml with
      |  0 , _ => FAlse
      |  S _, nil => FAlse
      | S j',  h :: tl => match h with
                             | (sign (pi2 (ks (nonce n))) t1 t2) =>   IF (eqm t t1) then (ver (vk n) t1 u) else (unforgb j' n tl t u)
                             | _ => FAlse
                           end
    end.

  Axiom UFCMA : forall (n :nat)(t u: message), (closMylist [msg t, msg u] = true) /\ (insec_n_mylis n [msg t, msg u] = false) ->
                                               let j := length(list_skn_in_sign n ((subtrmls_msg t) ++ (subtrmls_msg u))) in
                                               let ml := distsigntrms n ((subtrmls_msg t) ++ ( subtrmls_msg u)) in
                                               (ver (vk n) t u) ## (unforgb j n ml t u).

End ds_axioms.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rbasic_fun.
Require Reals.R_sqrt.
Require Reals.Rtrigo_def.
Require Reals.Rtrigo1.
Require Reals.Ratan.
Require BuiltIn.
Require real.Real.
Require real.RealInfix.
Require real.Abs.
Require real.FromInt.
Require int.Int.
Require real.Square.
Require real.Trigonometry.
Require floating_point.Rounding.
Require floating_point.SingleFormat.
Require floating_point.Single.

(* Why3 assumption *)
Definition unit := unit.

Require Import Interval_tactic.

(* Why3 goal *)
Theorem WP_parameter_my_cosine : forall (x:floating_point.SingleFormat.single),
  ((Reals.Rbasic_fun.Rabs (floating_point.Single.value x)) <= (1 / 32)%R)%R ->
  ((Reals.Rbasic_fun.Rabs ((1%R - (((floating_point.Single.value x) * (floating_point.Single.value x))%R * (05 / 10)%R)%R)%R - (Reals.Rtrigo_def.cos (floating_point.Single.value x)))%R) <= (1 / 16777216)%R)%R.
(* Why3 intros x h1. *)
(* YOU MAY EDIT THE PROOF BELOW *)
intros x H.
interval with (i_bisect_diff (Single.value x)).
Qed.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                     SF-Calculus                                    *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

(** The operators S and F are enough, but more may be added in future. *)

Inductive operator := | Sop | Fop .

(** The terms of SF-calculus are either variables (given as de Bruijn indices), operators or applications.
Terms are called combinations if they do not use any variables. *)

Inductive SF:  Set :=
  | Ref : nat -> SF
  | Op  : operator -> SF
  | App : SF -> SF -> SF
.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj11eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus Zero (plus lv0 lv1))).
Admitted.
QuickChick conj11eqsynthconj1.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj12synthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus Zero (plus lv0 lv1)) (plus lv0 lv1)).
Admitted.
QuickChick conj12synthconj1.