Require Import VST.floyd.proofauto.
Require Export malloc_lemmas. (*Exports the model (constants like WA , plus lemmas)*)

(*Require Import malloc. needed for function and type names but not for compspecs
Update: Some UPenn grad students proposed to abstract over function identifiers -
doing so in our setup makes ASIs source-program-independent!*)

Global Open Scope funspec_scope.

Record MallocTokenAPD := {
  malloc_token': share -> Z -> val -> mpred;
  malloc_token'_valid_pointer: forall sh sz p,
      malloc_token' sh sz p |-- valid_pointer p;
  malloc_token'_local_facts:  forall sh sz p,
      malloc_token' sh sz p |-- !! malloc_compatible sz p;
}.

Record MallocFreeAPD := {
  MF_Tok :> MallocTokenAPD;
  mem_mgr: globals -> mpred;
}.

Definition malloc_token {cs:compspecs} M (sh: share) (t: type) (p: val): mpred :=
   !! field_compatible t [] p &&
   malloc_token' M sh (sizeof t) p.

Lemma malloc_token_valid_pointer: forall {cs: compspecs} M sh t p,
      malloc_token M sh t p |-- valid_pointer p.
Proof. intros. unfold malloc_token.
 apply andp_left2. apply malloc_token'_valid_pointer.
Qed.

#[export] Hint Resolve malloc_token'_valid_pointer : valid_pointer.
#[export] Hint Resolve malloc_token_valid_pointer : valid_pointer.

Lemma malloc_token_local_facts:  forall {cs: compspecs} M sh t p,
      malloc_token M sh t p |-- !! (field_compatible t [] p /\ malloc_compatible (sizeof t) p).
Proof. intros.
 unfold malloc_token.
 normalize. rewrite prop_and.
 apply andp_right. apply prop_right; auto.
 apply malloc_token'_local_facts.
Qed.

#[export] Hint Resolve malloc_token'_local_facts : saturate_local.
#[export] Hint Resolve malloc_token_local_facts : saturate_local.

Section Malloc_ASI.
Variable M: MallocFreeAPD.
Variable mallocID:ident.
Variable freeID:ident.

Definition malloc_spec' :=
   DECLARE (*_malloc*)mallocID
   WITH n:Z, gv:globals
   PRE [ size_t ]
       PROP (0 <= n <= Ptrofs.max_unsigned - (WA+WORD))
       PARAMS ((Vptrofs (Ptrofs.repr n))) GLOBALS (gv)
       SEP ( mem_mgr M gv )
   POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( mem_mgr M gv;
             if eq_dec p nullval then emp
             else (malloc_token' M Ews n p * memory_block Ews n p)).

Definition free_spec' :=
 DECLARE (*_free*)freeID
   WITH n:Z, p:val, gv: globals
   PRE [ tptr tvoid ]
       PROP ()
       PARAMS (p) GLOBALS (gv)
       SEP (mem_mgr M gv;
            if eq_dec p nullval then emp
            else (malloc_token' M Ews n p * memory_block Ews n p))
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr M gv).

Definition Malloc_ASI:funspecs := [malloc_spec'; free_spec'].
End Malloc_ASI.

Record MallocFree_R_APD := {
  MF_Tok_R :> MallocTokenAPD;
  mem_mgr_R: resvec -> globals -> mpred; (*changed order of arguments*)
}.
(*
Definition malloc_token_R {cs:compspecs} M (sh: share) (t: type) (p: val): mpred :=
   !! field_compatible t [] p &&
   malloc_token_R' M sh (sizeof t) p.

Lemma malloc_token_R_valid_pointer: forall {cs: compspecs} M sh t p,
      malloc_token_R M sh t p |-- valid_pointer p.
Proof. intros. unfold malloc_token.
 apply andp_left2. apply malloc_token_R'_valid_pointer.
Qed.

#[export] Hint Resolve malloc_token_R'_valid_pointer : valid_pointer.
#[export] Hint Resolve malloc_token_R_valid_pointer : valid_pointer.

Lemma malloc_token_R_local_facts:  forall {cs: compspecs} M sh t p,
      malloc_token_R M sh t p |-- !! (field_compatible t [] p /\ malloc_compatible (sizeof t) p).
Proof. intros.
 unfold malloc_token_R.
 normalize. rewrite prop_and.
 apply andp_right. apply prop_right; auto.
 apply malloc_token_R'_local_facts.
Qed.

#[export] Hint Resolve malloc_token_R'_local_facts : saturate_local.
#[export] Hint Resolve malloc_token_R_local_facts : saturate_local.
*)
Require Import VST.floyd.VSU.

Section Malloc_R_ASI.
Variable M: MallocFree_R_APD.
Variable prefillID:ident.
Variable tryprefillID:ident.
Variable mallocID:ident.
Variable freeID:ident.

Definition pre_fill_spec' :=
 DECLARE (*_pre_fill*) prefillID
   WITH n:Z, p:val, gv:globals, rvec:resvec
   PRE [ tuint, tptr tvoid ]
       PROP (0 <= n <= maxSmallChunk /\ malloc_compatible BIGBLOCK p)
       PARAMS ((Vptrofs (Ptrofs.repr n)); p) GLOBALS (gv)
       SEP (mem_mgr_R M rvec gv; memory_block Tsh BIGBLOCK p)
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr_R M (add_resvec rvec (size2binZ n)
                                     (chunks_from_block (size2binZ n))) gv).

Definition try_pre_fill_spec' :=
 DECLARE (*_try_pre_fill*) tryprefillID
   WITH n:Z, req:Z, rvec:resvec, gv:globals
   PRE [ tuint, tint ]
       PROP (0 <= n <= maxSmallChunk /\ 0 <= req <= Int.max_signed)
       PARAMS ((Vint (Int.repr n)); (Vint (Int.repr req))) GLOBALS (gv)
       SEP (mem_mgr_R M rvec gv)
   POST [ tint ] EX result: Z,
     PROP ()
     LOCAL (temp ret_temp (Vint (Int.repr result)))
     SEP (mem_mgr_R M (add_resvec rvec (size2binZ n) result) gv).

Definition malloc_spec_R' :=
   DECLARE (*_malloc*)mallocID
   WITH n:Z, gv:globals, rvec:resvec
   PRE [ size_t ]
       PROP (0 <= n <= Ptrofs.max_unsigned - (WA+WORD))
       PARAMS ((* _nbytes *) (Vptrofs (Ptrofs.repr n))) GLOBALS (gv)
       SEP ( mem_mgr_R M rvec gv)
   POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( if guaranteed rvec n
             then mem_mgr_R M (add_resvec rvec (size2binZ n) (-1)) gv *
                  malloc_token' M Ews n p * memory_block Ews n p
             else if eq_dec p nullval
                  then mem_mgr_R M rvec gv
                  else (if n <=? maxSmallChunk
                        then (EX rvec':_, !!(eq_except rvec' rvec (size2binZ n))
                                            && (mem_mgr_R M rvec' gv))
                        else mem_mgr_R M rvec gv) *
                       malloc_token' M Ews n p * memory_block Ews n p).

Definition free_spec_R' :=
 DECLARE (*_free*)freeID
   WITH n:Z, p:val, gv:globals, rvec:resvec
   PRE [ tptr tvoid ]
       PROP ()
       PARAMS (p) GLOBALS (gv)
       SEP (mem_mgr_R M rvec gv;
            if eq_dec p nullval then emp
            else (malloc_token' M Ews n p * memory_block Ews n p))
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (if eq_dec p nullval
            then mem_mgr_R M rvec gv
            else if n <=? maxSmallChunk
                 then mem_mgr_R M (add_resvec rvec (size2binZ n) 1) gv
                 else mem_mgr_R M rvec gv).

Definition Malloc_R_ASI:funspecs := [pre_fill_spec'; try_pre_fill_spec'; malloc_spec_R'; free_spec_R'].

Definition ForgetR:MallocFreeAPD :=
  Build_MallocFreeAPD (MF_Tok_R M) (fun gv => EX R, mem_mgr_R M R gv).

Lemma malloc_spec_R_sub i: funspec_sub (snd malloc_spec_R') (snd (malloc_spec' ForgetR i)).
Proof.
do_funspec_sub. destruct w as [n gv]. clear H.
unfold mem_mgr.
Intros rvec.
Exists (n, gv, rvec) emp. (* empty frame *)
simpl; entailer!.
intros tau ? ?.
set (p:=eval_id ret_temp tau).
Exists p; entailer!.
destruct (guaranteed rvec n) eqn:guar.
- (* guaranteed *)
  if_tac; auto.
  Exists (add_resvec rvec (size2binZ n) (-1)); entailer!.
  rewrite H4; entailer!.
  Exists (add_resvec rvec (size2binZ n) (-1)); entailer!.
- (* not guaranteed *)
  bdestruct (n <=? maxSmallChunk).
  + if_tac; auto. Exists rvec; entailer!. Intros rvec'; Exists rvec'; entailer!.
  + if_tac; auto; Exists rvec; entailer!.
Qed.

Lemma free_spec_R_sub i: funspec_sub (snd free_spec_R') (snd (free_spec' ForgetR i)).
Proof.
do_funspec_sub.
destruct w as [[n p] gv]. clear H.
unfold mem_mgr.
Intros rvec. Exists (n,p,gv,rvec) emp.
simpl; entailer!.
intros tau ?.
if_tac.
Exists rvec; entailer!.
bdestruct (n <=? maxSmallChunk).
- (* small *)
  Exists (add_resvec rvec (size2binZ n) 1); entailer!.
- (* large *)
  Exists rvec; entailer!.
Qed.

Variable distinctIDs: list_norepet [prefillID; tryprefillID; mallocID; freeID].

Lemma MallocASI_sqsub_MallocR_ASI:
      funspecs_sqsub Malloc_R_ASI (Malloc_ASI ForgetR mallocID freeID).
Proof. red; intros. simpl in H.
  if_tac in H. inv H.
  { eexists; split. simpl. rewrite 2 if_false. rewrite if_true by trivial.  reflexivity.
    intros N; subst. inv distinctIDs. inv H2. apply H3. left; trivial.
    intros N; subst. inv distinctIDs. apply H1. right; left; trivial.
    apply (malloc_spec_R_sub mallocID).  }
  if_tac in H. inv H.
  { eexists; split. simpl. rewrite 3 if_false. rewrite if_true by trivial.  reflexivity.
    intros N; subst. apply H0; trivial.
    intros N; subst. inv distinctIDs. inv H3. apply H4. right; left; trivial.
    intros N; subst. inv distinctIDs. inv H3. apply H2. do 2 right; left; trivial.
    apply (free_spec_R_sub freeID). }
  congruence.
(*
  repeat (if_tac in H. [ inv H; eexists; split; [ reflexivity |] |]).
  repeat (if_tac in H; [ inv H; eexists; split; [ reflexivity |] |])
  apply malloc_spec_R_sub. apply free_spec_R_sub. congruence.*)
Qed.

End Malloc_R_ASI.


Set Implicit Arguments.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Platform.Cito.Inv.
  Module Import InvMake := Make E.
  Import Semantics.
  Import SemanticsMake.
  Require Import Platform.Cito.WordMap.
  Require Import Coq.FSets.FMapFacts.
  Module Properties := Properties WordMap.
  Module Facts := Facts WordMap.

  Require Import Platform.Cito.RepInv.

  Module Make(R : RepInv E).
    Module Import Inner := InvMake.Make(R).

    Require Import Platform.Cito.LayoutHintsUtil.
    Require Import Platform.Cito.SemanticsFacts5.

    Lemma is_heap_Equal : forall h h',
      WordMap.Equal h h'
      -> is_heap h ===> is_heap h'.
      intros; apply starL_permute; unfold heap_elements; intuition.
      apply NoDupA_NoDup; apply WordMap.elements_3w.
      apply NoDupA_NoDup; apply WordMap.elements_3w.

      apply In_InA' in H0.
      apply InA_In.
      apply Properties.F.elements_mapsto_iff in H0.
      apply Properties.F.elements_mapsto_iff.
      eapply Properties.F.Equal_mapsto_iff; eauto.
      apply Properties.F.Equal_sym; auto.

      apply In_InA' in H0.
      apply InA_In.
      apply Properties.F.elements_mapsto_iff in H0.
      apply Properties.F.elements_mapsto_iff.
      eapply Properties.F.Equal_mapsto_iff; eauto.
    Qed.

  End Make.

End Make.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require Import oeuf.ListLemmas.

Inductive expr :=
| Arg
| Self
| Var (i : nat)
| Deref (e : expr) (off : nat)
.

Inductive stmt :=
| Skip
| Seq (s1 : stmt) (s2 : stmt)
| Call (dst : nat) (f : expr) (a : expr)
| MkConstr (dst : nat) (tag : nat) (args : list expr)
| Switch (dst : nat) (cases : list stmt)
| MkClose (dst : nat) (f : function_name) (free : list expr)
| OpaqueOp (dst : nat) (op : opaque_oper_name) (args : list expr)
| Assign (dst : nat) (e : expr)
.

Definition env := list (stmt * expr).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    locals : list (nat * value)
}.

Definition set f l v :=
    Frame (arg f) (self f) ((l, v) :: locals f).

Definition local f l := lookup (locals f) l.

Inductive cont :=
| Kseq (code : stmt) (k : cont)
| Kswitch (k : cont)
| Kreturn (ret : expr) (k : cont)
| Kcall (dst : nat) (f : frame) (k : cont)
| Kstop.

Inductive state :=
| Run (s : stmt) (f : frame) (k : cont)
| Return (v : value) (k : cont).

Inductive eval : frame -> expr -> value -> Prop :=
| EArg : forall f,
        eval f Arg (arg f)
| ESelf : forall f,
        eval f Self (self f)

| EVar : forall f i v,
        local f i = Some v ->
        eval f (Var i) v

| EDerefConstr : forall f e off tag args v,
        eval f e (Constr tag args) ->
        nth_error args off = Some v ->
        eval f (Deref e off) v
| EDerefClose : forall f e off fname free v,
        eval f e (Close fname free) ->
        nth_error free off = Some v ->
        eval f (Deref e off) v
.

Inductive sstep (E : env) : state -> state -> Prop :=
| SSeq : forall s1 s2 f k,
        sstep E (Run (Seq s1 s2) f k)
                (Run s1 f (Kseq s2 k))

| SConstrDone : forall dst tag args f k vs,
        Forall2 (eval f) args vs ->
        sstep E (Run (MkConstr dst tag args) f k)
                (Run Skip (set f dst (Constr tag vs)) k)
| SCloseDone : forall dst fname free f k vs,
        Forall2 (eval f) free vs ->
        sstep E (Run (MkClose dst fname free) f k)
                (Run Skip (set f dst (Close fname vs)) k)
| SOpaqueOpDone : forall dst op args f k vs v,
        Forall2 (eval f) args vs ->
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run (OpaqueOp dst op args) f k)
                (Run Skip (set f dst v) k)

| SMakeCall : forall dst fe ae f k  fname free arg body ret,
        eval f fe (Close fname free) ->
        eval f ae arg ->
        nth_error E fname = Some (body, ret) ->
        sstep E (Run (Call dst fe ae) f k)
                (Run body (Frame arg (Close fname free) [])
                    (Kreturn ret (Kcall dst f k)))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall dst cases f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run (Switch dst cases) f k)
                (Run case f (Kswitch k))

| SAssign : forall dst src f k v,
        eval f src v ->
        sstep E (Run (Assign dst src) f k)
                (Run Skip (set f dst v) k)

| SContSeq : forall f s k,
        sstep E (Run Skip f (Kseq s k))
                (Run s f k)
| SContSwitch : forall f k,
        sstep E (Run Skip f (Kswitch k))
                (Run Skip f k)
| SContReturn : forall f ret k v,
        eval f ret v ->
        sstep E (Run Skip f (Kreturn ret k))
                (Return v k)
| SContCall : forall v dst f k,
        sstep E (Return v (Kcall dst f k))
                (Run Skip (set f dst v) k)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body ret,
        nth_error (fst prog) fname = Some (body, ret) ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 (Kreturn ret Kstop)).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Return v Kstop) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
Definition prog_type : Type := env * list metadata.

Inductive initial_state (prog : prog_type) : state -> Prop :=.

Inductive final_state (prog : prog_type) : state -> Prop :=
| FinalState : forall v, final_state prog (Return v Kstop).

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env
                 (sstep)
                 (initial_state prog)
                 (final_state prog)
                 (initial_env prog).

*)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition stmt_rect_mut
        (P : stmt -> Type)
        (Pl : list stmt -> Type)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pl cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (i : stmt) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        match i as i_ return P i_ with
        | Skip => HSkip
        | Seq s1 s2 => HSeq s1 s2 (go s1) (go s2)
        | Call dst f a => HCall dst f a
        | MkConstr dst tag args => HConstr dst tag args
        | Switch dst cases => HSwitch dst cases (go_list cases)
        | MkClose dst fname free => HClose dst fname free
        | OpaqueOp dst op args => HOpaqueOp dst op args
        | Assign dst src => HAssign dst src
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition stmt_ind' (P : stmt -> Prop)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Forall P cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (i : stmt) : P i :=
    ltac:(refine (@stmt_rect_mut P (Forall P)
        HSkip HSeq HCall HConstr HSwitch HClose HOpaqueOp HAssign _ _ i); eauto).

Definition all_dests :=
    let fix go s :=
        let fix go_list ps :=
            match ps with
            | [] => []
            | s :: ps => go s ++ go_list ps
            end in
        match s with
        | Skip => []
        | Seq s1 s2 => go s1 ++ go s2
        | Call dst _ _ => [dst]
        | MkConstr dst _ _ => [dst]
        | Switch _ cases => go_list cases
        | MkClose dst _ _ => [dst]
        | OpaqueOp dst _ _ => [dst]
        | Assign dst _ => [dst]
        end in go.

Definition all_dests_list :=
    let go := all_dests in
    let fix go_list ps :=
        match ps with
        | [] => []
        | s :: ps => go s ++ go_list ps
        end in go_list.

Ltac refold_all_dests :=
    fold all_dests_list in *.

Definition cont_all_dests :=
    let go := all_dests in
    let fix go_cont k :=
        match k with
        | Kseq s k => go s ++ go_cont k
        | Kswitch k => go_cont k
        | Kreturn _ k => go_cont k
        | Kcall dst _ k => []
        | Kstop => []
        end in go_cont.

Definition dests_ok :=
    let fix go s :=
        let fix go_list ps :=
            match ps with
            | [] => True
            | s :: ps => go s /\ go_list ps
            end in
        match s with
        | Seq s1 s2 => go s1 /\ go s2 /\ disjoint (all_dests s1) (all_dests s2)
        | Switch _ cases => go_list cases
        | _ => True
        end in go.

Definition dests_ok_list :=
    let go := dests_ok in
    let fix go_list ps :=
        match ps with
        | [] => True
        | s :: ps => go s /\ go_list ps
        end in go_list.

Ltac refold_dests_ok :=
    fold dests_ok_list in *.

Definition check_dests_ok s : { dests_ok s } + { ~ dests_ok s }.
induction s using stmt_rect_mut with
    (Pl := fun cases =>
        { dests_ok_list cases } + { ~ dests_ok_list cases });
try solve [left; constructor].

- (* Seq *)
  destruct IHs1; [ | right; intro; simpl in *; intuition ].
  destruct IHs2; [ | right; intro; simpl in *; intuition ].
  destruct (disjoint_dec eq_nat_dec (all_dests s1) (all_dests s2));
    [ | right; intro; simpl in *; intuition ].
  left. simpl. auto.

- (* Switch *)
  destruct IHs; [ | right; assumption ].
  left. assumption.

- (* cons *)
  destruct IHs; [ | right; inversion 1; eauto ].
  destruct IHs0; [ | right; inversion 1; eauto ].
  left. constructor; eauto.
Defined.

Definition cont_dests_ok :=
    let go := dests_ok in
    let fix go_cont k :=
        match k with
        | Kseq s k => go s /\ go_cont k /\
                disjoint (all_dests s) (cont_all_dests k)
        | Kswitch k => go_cont k
        | Kreturn _ k => go_cont k
        | Kcall _ _ k => go_cont k
        | Kstop => True
        end in go_cont.

Definition state_dests_ok :=
    let go := dests_ok in
    let go_cont := cont_dests_ok in
    let go_state s :=
        match s with
        | Run s _ k => go s /\ go_cont k /\
                disjoint (all_dests s) (cont_all_dests k)
        | Return _ k => go_cont k
        end in go_state.

Lemma step_dests_ok : forall E s s',
    Forall (fun f => dests_ok (fst f)) E ->
    state_dests_ok s ->
    sstep E s s' ->
    state_dests_ok s'.
intros0 Henv II Hstep; invc Hstep;
simpl in *; refold_all_dests; refold_dests_ok.

- repeat break_and. on _, invc_using disjoint_app_inv_l.
  intuition. eauto using disjoint_app_r.

- intuition.
- intuition.
- intuition.
- fwd eapply Forall_nth_error; eauto. simpl in *. intuition.

- break_and.
  on (arg _ = _), fun H => clear H.
  generalize dependent cases. make_first cases. induction cases; intros; simpl in *.
  + destruct tag; discriminate.
  + destruct tag; simpl in *.
    * inject_some. on _, invc_using disjoint_app_inv_l. intuition.
    * on _, invc_using disjoint_app_inv_l. break_and. eapply IHcases; eauto.

- intuition.
- intuition.
- intuition.
- intuition.
- intuition.
Qed.

Lemma all_dests_list_disjoint : forall xs cases n case,
    disjoint xs (all_dests_list cases) ->
    nth_error cases n = Some case ->
    disjoint xs (all_dests case).
induction cases; intros0 Hdj Hnth; simpl in *.
- destruct n; discriminate.
- on _, invc_using disjoint_app_inv_r.
  destruct n; simpl in *.
  + inject_some. auto.
  + eapply IHcases; eauto.
Qed.


(* Semantics and Properties of the monads *)
Require Import Events.
Require Import customSmallstep.
Require Import Integers.

Require Import common.
Require Import monad.
Require Import monad_impl.
Require Import ASMinterpreter.
Require Import jit.

(** * Loop Semantics (deprecated)  *)
(* building the semantics of a monad designed to be looped *)
Inductive loop_step {mstate prog_state:Type} (prog:prog_state -> free (prog_state * trace)) (i:monad_impl mstate) :
  unit -> (prog_state * mstate) -> trace -> (prog_state * mstate) -> Prop :=
| loop:
    forall ps1 ps2 t ms1 ms2
      (EXEC_STEP: (exec (prog ps1)) i ms1 = SOK (ps2, t) ms2),
      loop_step prog i tt (ps1, ms1) t (ps2, ms2).

(* Extending the notion of initial state, from a prog_state definition, to a full state (with monad state) *)
Inductive extend_init {mstate prog_state:Type} (init:prog_state -> Prop) (i:monad_impl mstate) :
  (prog_state * mstate) -> Prop :=
| init_extend:
    forall ps
      (INIT: init ps),
      extend_init init i (ps, init_state i).

(* extending to any monad state *)
Inductive extend_final {mstate prog_state:Type} (final:prog_state -> int -> Prop) (i:monad_impl mstate):
  (prog_state * mstate) -> int -> Prop :=
| final_extend:
    forall ps val ms
      (FINAL: final ps val),
      extend_final final i (ps, ms) val.

(* Loop Semantics given an implem *)
(* prog has the type that the jit_step would be typed with *)
Definition loop_sem {mstate prog_state:Type} (prog:prog_state -> free (prog_state * trace)) (i:monad_impl mstate) (init:prog_state -> Prop) (final:prog_state -> int -> Prop): semantics :=
  Semantics_gen (loop_step prog i) (extend_init init i) (extend_final final i) tt.

(* Forward sim proof *)
Inductive f_match {istate jstate prog_state:Type} (i:monad_impl istate) (j:monad_impl jstate) (R:refines i j): unit -> (prog_state * istate) -> (prog_state * jstate) -> Prop :=
| f_m : forall ps mi mj
          (MATCH: (match_states i j R) mi mj),
    f_match i j R tt (ps, mi) (ps, mj).

Inductive order : unit -> unit -> Prop := .
Lemma wfounded:
  well_founded order.
Proof.
  unfold well_founded. intros. destruct a. constructor. intros. inversion H.
Qed.

Lemma forward_prim:
  forall (A istate jstate R:Type) (i:monad_impl istate) (j:monad_impl jstate) a mi mi' mj
    (Ref: refines i j)
    (p: primitive R)
    (MATCH: match_states i j Ref mi mj)
    (EXEC: exec_prim p i mi = SOK a mi'),
  exists mj', exec_prim p j mj = SOK a mj' /\
         (match_states i j Ref) mi' mj'.
Proof.
  intros A istate jstate R i j a mi mi' mj Ref p MATCH EXEC.
  destruct p; inv EXEC.
  - rename H0 into Hsave. destruct a. (* save *)
    eapply (match_save i j Ref) in Hsave; eauto.
  - rename H0 into Hload. destruct a.       (* load *)
    eapply (match_load i j Ref) in Hload; eauto.
  - rename H0 into Hpusharg. destruct a. (* pusharg *)
    eapply (match_memset i j Ref) in Hpusharg; eauto.
  - rename H0 into Hpoparg. destruct a. (* poparg *)
    eapply (match_memget i j Ref) in Hpoparg; eauto.
  - rename H0 into Hclosesf. destruct a. (* closesf *)
    eapply (match_closesf i j Ref) in Hclosesf; eauto.
  - rename H0 into Hopensf. (* opensf *)
    eapply (match_opensf i j Ref) in Hopensf; eauto.
  - rename H0 into Hpushirsf. destruct a. (* pushirsf *)
    eapply (match_pushirsf i j Ref) in Hpushirsf; eauto.
  - rename H0 into Hinstall_code. destruct a. (* install_code *)
    eapply (match_install_code i j Ref) in Hinstall_code; eauto.
  - rename H0 into Hload_code. destruct a. (* load_call_code *)
    eapply (match_load_code i j Ref) in Hload_code; eauto.
  - rename H0 into Hcheck_compiled.  (* check_compiled *)
    eapply (match_check_compiled i j Ref) in Hcheck_compiled; eauto.
Qed.

Lemma forward_diagram:
  forall {A istate jstate:Type} (i:monad_impl istate) (j:monad_impl jstate) a mi mi' mj
    (R: refines i j)
    (m: free A)
    (MATCH: (match_states i j R) mi mj)
    (EXEC: exec m i mi = SOK a mi'),
  exists mj', exec m j mj = SOK a mj' /\
         (match_states i j R) mi' mj'.
Proof.
  intros A istate jstate i j a mi mi' mj R m MATCH EXEC.
  generalize dependent mi. generalize dependent mi'. generalize dependent mj. generalize dependent a.
  induction m; intros; inversion EXEC; simpl; subst.
  - exists mj. split; auto.          (* ret *)
  - rename H1 into EXEC_CONT. repeat sdo_ok. simpl in EXEC.
    unfold sbind in EXEC. rewrite HDO in EXEC. rewrite EXEC_CONT in EXEC. inv EXEC.
    eapply forward_prim in HDO; eauto. destruct HDO as [j0 [EXEC_PRIM MATCH']].
    specialize (H r a j0 mi' i0 MATCH' EXEC_CONT).
    destruct H as [mj' [EXEC_CONT' MATCH'']].
    exists mj'. unfold sbind. rewrite EXEC_PRIM. split; auto.
Qed.

Theorem loop_refinement:
  forall (prog_state istate jstate:Type) (prog:prog_state -> free (prog_state * trace))  init final
    (i:monad_impl istate) (j:monad_impl jstate)
    (R: refines i j),
    forward_simulation
      (loop_sem prog i init final)
      (loop_sem prog j init final).
Proof.
  intros prog_state istate jstate prog init final i j R.
  eapply Forward_simulation.
  - apply wfounded.
  - intros s1 H. exists tt. simpl in H. inversion H.
    exists (ps, init_state j). split; simpl.
    + constructor. auto.
    + eapply (f_m i j R). apply (match_init i j R).
  - intros tt s1 s2 r H H0. simpl in s1, s2. destruct s1 as [ps1 mi1]. destruct s2 as [ps mi2].
    inversion H. subst. simpl. constructor. inversion H0. auto.
  - intros s1 t s1' H i0 s2 H0. simpl in s1, s1'. destruct s1 as [ps1 mi1]. destruct s1' as [ps1' mi1'].
    inversion H0. subst. exists tt. inversion H. subst.
    eapply forward_diagram in EXEC_STEP; eauto.
    destruct EXEC_STEP as [mj' [EXEC' MATCH']].
    exists (ps1', mj'). split; auto.
    + left. apply plus_one. constructor. auto.
    + constructor. auto.
Qed.

(** * Giving Semantics the Non-Atomic step of a NASM  *)
Record na_spec {state I R:Type}: Type :=
  mk_spec {
      load_: state -> free I;
      step_: I -> free (trace * itret R I);
      ret_ : state -> R -> free state
    }.
(* I defines the type of intermediate states *)
(* R represents the return value type of the internal iteration *)

(** * Unfolded Semantics  *)
Inductive unf_state {S I:Type} :=
| EXT: S -> unf_state       (* when we're executing the main program *)
| INT: S -> I -> unf_state.       (* when we're executing the non-atomic loop. we remember the calling S state *)

Inductive unf_step {state mstate I R:Type} (prog: @nasm_prog state) (impl:monad_impl mstate) (spec: @na_spec state I R):
  unit -> (@unf_state state I * mstate) -> trace -> (@unf_state state I * mstate) -> Prop :=
| ext_step:
    forall (s1 s2:state) t ms1 ms2 symbmon
      (ATOMIC: prog s1 = Ato symbmon)
      (EXEC_STEP: exec symbmon impl ms1 = SOK (t, s2) ms2),
      unf_step prog impl spec tt (EXT s1, ms1) t (EXT s2, ms2)
| loop_start:
    forall s1 ms1 start ms2
      (RUN: prog s1 = LoadAndRun)
      (LOAD: exec (load_ spec s1) impl ms1 = SOK start ms2),
      unf_step prog impl spec tt (EXT s1, ms1) E0 (INT s1 start, ms2)
| int_step:
    forall i1 t i2 ms1 ms2 call_state
      (EXEC_STEP: exec (step_ spec i1) impl ms1 = SOK (t, Halt i2) ms2),
      unf_step prog impl spec tt (INT call_state i1, ms1) t (INT call_state i2, ms2)
| loop_end:
    forall i1 t r s2 ms1 ms2 ms3 call_state
      (EXEC_END: exec (step_ spec i1) impl ms1 = SOK (t, Done r) ms2)
      (EXEC_RET: exec (ret_ spec call_state r) impl ms2 = SOK (s2) ms3),
      unf_step prog impl spec tt (INT call_state i1, ms1) t (EXT s2, ms3).

(* Liftinf initial and final from state to unf_state *)
Inductive init_unf_state {state mstate I:Type} (init:state -> Prop) (impl:monad_impl mstate) : (@unf_state state I  * mstate) -> Prop :=
| init_unf: forall s
              (INIT: init s),
    init_unf_state init impl (EXT s, init_state impl).

Inductive final_unf_state {state mstate I:Type} (final:state -> int -> Prop) (impl:monad_impl mstate) : (@unf_state state I * mstate) -> int -> Prop :=
| final_unf: forall s ms r
               (FINAL: final s r),
    final_unf_state final impl (EXT s, ms) r.

Definition unf_sem {state mstate I R:Type} (prog: @nasm_prog state) (impl:monad_impl mstate) (spec: @na_spec state I R) (init:state->Prop) (final:state->int->Prop): semantics :=
  Semantics_gen (unf_step prog impl spec) (init_unf_state init impl) (final_unf_state final impl) tt.

(** * Refinement Simulation  *)
(* Forward sim proof *)

Theorem refinement:
  forall (state istate jstate I R:Type) (prog: @nasm_prog state) init final
    (i: monad_impl istate) (j:monad_impl jstate) (spec: @na_spec state I R)
    (Ref: refines i j),
    forward_simulation
      (unf_sem prog i spec init final)
      (unf_sem prog j spec init final).
Proof.
  intros state istate jstate I R prog init final i j spec Ref.
  eapply Forward_simulation.
  - apply wfounded.
  - intros s1 H. exists tt. simpl in H. inversion H.
    exists (EXT s, init_state j). split; simpl.
    + constructor. auto.
    + eapply (f_m i j Ref). apply (match_init i j Ref).
  - intros tt s1 s2 r H H0. simpl in s1, s2. destruct s1 as [ps1 mi1]. destruct s2 as [ps mi2].
    inversion H. subst. simpl. inversion H0. subst. constructor. auto.
  - intros s1 t s1' STEP i0 s2 MATCH. simpl in s1, s1'. destruct s1 as [ps1 mi1]. destruct s1' as [ps1' mi1'].
    inversion MATCH. subst. exists tt. inversion STEP; subst.
    + eapply forward_diagram in EXEC_STEP; eauto.
      destruct EXEC_STEP as [mj' [EXEC' MATCH']].
      exists (EXT s2, mj'). split; auto.
      * left. apply plus_one. eapply ext_step; eauto.
      * constructor. auto.
    + eapply forward_diagram in LOAD; eauto.
      destruct LOAD as [mj' [EXEC' MATCH']].
      exists (INT s1 start, mj'). split; auto.
      * left. apply plus_one. eapply loop_start; eauto.
      * constructor. auto.
    + eapply forward_diagram in EXEC_STEP; eauto.
      destruct EXEC_STEP as [mj' [EXEC' MATCH']].
      exists (INT call_state i2, mj'). split; auto.
      * left. apply plus_one. eapply int_step; eauto.
      * constructor. auto.
    + eapply forward_diagram in EXEC_END; eauto.
      destruct EXEC_END as [mj' [EXEC' MATCH']].
      eapply forward_diagram in EXEC_RET; eauto.
      destruct EXEC_RET as [mj'' [EXEC'' MARCH'']].
      exists (EXT s2, mj''). split; auto.
      * left. apply plus_one. eapply loop_end; eauto.
      * constructor. auto.
Qed.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(* A portion of this file was developed by Le Xuan Bach *)

Require Import msl.base.
Require Import msl.sepalg.
Require Import msl.functors.
Require Import msl.sepalg_functors.

Definition midObj {A} {JA: Join A} (a : A) : Prop := ~identity a /\ ~ full a.

Definition ijoinable A {JA: Join A} : Type := {sh : A & midObj sh}.

Definition ijoin {A} {JA: Join A} (j1 j2 j3 : ijoinable A) : Prop :=
  match (j1, j2, j3) with
  (existT t1 _, existT t2 _, existT t3 _) => join t1 t2 t3
  end.

Lemma ijoin_eq {A} {JA: Join A}{PA: Perm_alg A} : forall j1 j2 j3 j3',
  ijoin j1 j2 j3 ->
  ijoin j1 j2 j3' ->
  j3 = j3'.
Proof.
  intros.
  icase j1; icase j2; icase j3; icase j3'.
  unfold ijoin in *.
  apply existT_ext.
  eapply join_eq; eauto.
Qed.

Lemma ijoin_com {A} {JA: Join A}{PA: Perm_alg A} : forall j1 j2 j3,
  ijoin j1 j2 j3 -> ijoin j2 j1 j3.
Proof with auto.
  intros.
  icase j1; icase j2; icase j3.
  red in H; red.
  apply join_comm...
Qed.

Lemma ijoin_assoc {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A} : forall a b c d e,
  ijoin a b d ->
  ijoin d c e ->
  {f : ijoinable A | ijoin b c f /\ ijoin a f e}.
Proof with auto.
  intros.
  icase a; icase b; icase c; icase d; icase e.
  unfold ijoin in *.
  destruct (join_assoc H H0) as [f [? ?]].
  assert ((~identity f) /\ (~full f)).
    unfold midObj in *.
    split.
    intro.
    generalize (split_identity _ _ H1 H3); intro.
    tauto.
    intro.
    spec H3 x. spec H3. exists x3...
    spec H3 f x3 H2. subst x3.
    apply unit_identity in H2.
    tauto.
  exists (existT midObj f H3).
  split...
Qed.

Lemma ijoin_canc {A}  {JA: Join A}{SA: Sep_alg A}{CA: Canc_alg A}: forall a a' b c,
  ijoin a b c ->
  ijoin a' b c ->
  a = a'.
Proof with auto.
  intros.
  icase a; icase a'; icase b; icase c.
  unfold ijoin in *.
  apply existT_ext.
  eapply join_canc; eauto.
Qed.

Lemma ijoin_identity1 {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall a b,
  ijoin a b b ->
  False.
Proof with auto.
  intros.
  icase a; icase b.
  destruct m. apply n.
  apply (unit_identity x0).
  apply H.
Qed.

Lemma ijoin_identity2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA: Disj_alg A}: forall a b,
  ijoin a a b ->
  False.
Proof with auto.
  intros.
  icase a. icase b.
  destruct m; destruct m0.
  assert (x=x0). apply join_self. apply H. subst x0.
  assert (join x x x) by (apply H).
  apply unit_identity in H0.
  contradiction.
Qed.

Section CombineJoin.

Variable A : Type.
Variable JA: Join A.
Variable pa_A : Perm_alg A.
Variable sa_A : Sep_alg A.
Variable ca_A : Canc_alg A.

(* We either need an explicit top witness or some kind of axiom of choice
    (if not here, then in sa_fun or somesuch).  It is a little ugly this way but
    I don't see any other way around. Aquinas *)
Variable A_top : A.
Variable A_top_full : full A_top.

Variable T1 : Type.
Variable T2 : Type.
Variable J1: Join T1.
Variable pa_T1: Perm_alg T1.
Variable sa_T1: Sep_alg T1.

Variable combjoin : T1 -> T1 -> T2 -> Prop.

Variable combjoin_eq : forall v1 v1' v2 v2',
  combjoin v1 v1' v2 ->
  combjoin v1 v1' v2' ->
  v2 = v2'.

Variable combjoin_assoc : forall v1 v2 v3 v4 v5,
   join v1 v2 v3 ->
   combjoin v3 v4 v5 ->
   {v' : T1 & join v2 v4 v' /\ combjoin v1 v' v5}.

Variable combjoin_com : forall v1 v2 v3,
   combjoin v1 v2 v3 ->
   combjoin v2 v1 v3.

Variable combjoin_canc : forall v1 v1' v2 v3,
    combjoin v1 v2 v3 ->
    combjoin v1' v2 v3 ->
    v1 = v1'.

(* We would really prefer this to be:
       exists top, join (projT1 j1) (projT1 j2) top /\ full top
   but, again, we run into Type/Prop problems and wind up needing
   some form of the axiom of choice somewhere or other. *)
Definition covers (j1 j2 : ijoinable A) : Prop :=
  join (projT1 j1) (projT1 j2) A_top.

Inductive combiner : Type :=
  | CEmpty
  | CPart : forall (sh : ijoinable A) (v : T1), combiner
  | CFull : forall (v : T2), combiner.

Instance Join_combiner : Join combiner :=
  fun c1 c2 c3 =>
  match (c1,c2,c3) with
  | (CEmpty, CEmpty, CEmpty) => True
  | (CEmpty, CPart a v, CPart a' v') => a = a' /\ v = v'
  | (CPart a v, CEmpty, CPart a' v')  => a = a' /\ v = v'
  | (CEmpty, CFull v, CFull v') => v = v'
  | (CFull v, CEmpty, CFull v') => v = v'
  | (CPart a v, CPart a' v', CPart a'' v'') => ijoin a a' a'' /\ join v v' v''
  | (CPart a v, CPart a' v', CFull v'') => combjoin v v' v'' /\ covers a a'
  | _ => False
 end.

Lemma combineJ_eq: forall x y z z' : combiner,
  join x y z -> join x y z' -> z = z'.
Proof with auto.
  intros.
  icase x;icase y;icase z;icase z';try inversion H;try inversion H0;try congruence.

  f_equal.
  eapply ijoin_eq; eauto.
  eapply join_eq; eauto.

  elimtype False; clear - pa_A sa_A H1 H4 A_top_full.
  destruct sh; destruct sh0; destruct sh1.
  red in H1; red in H4; simpl in H4.
  generalize (join_eq H1 H4); intro; subst x1.
  unfold midObj in *.
  tauto.

  elimtype False; clear - pa_A sa_A H2 H3 A_top_full.
  destruct sh;destruct sh0;destruct sh1.
  red in H3; red in H2; simpl in H2.
  generalize (join_eq H2 H3);intro;subst x1.
  unfold midObj in *.
  tauto.

  rewrite (combjoin_eq _ _ _ _ H1 H3)...
Qed.

Lemma combineJ_assoc: forall a b c d e : combiner,
  join a b d -> join d c e ->
                    {f : combiner & join b c f /\ join a f e}.
Proof with auto.
   intros. red in H, H0. unfold join.
   icase a;icase b;icase c;icase d;icase e;inv H;inv H0.

   exists CEmpty;split;red...
   exists (CPart sh0 v0);split;red...
   exists (CFull v0);split;red...
   exists (CPart sh1 v1);split;red...
   exists (CPart sh2 v2);split;red...
   exists (CFull v2);split;red...
   exists (CFull v1);split;red...
   exists CEmpty;split;red...
   exists (CPart sh0 v0);split;red...
   exists (CPart sh0 v0);split;red...
   exists (CPart sh0 v0);split;red...
   exists (CPart sh0 v0);split;red...
   3: exists (CEmpty);split;red...

   destruct (ijoin_assoc _ _ _ _ _ H1 H) as [sh' [? ?]].
   destruct (join_assoc H2 H3) as [fv [? ?]].
   exists (CPart sh' fv); split; red...

   icase sh; icase sh0; icase sh1; icase sh2.
   red in H1, H3. simpl in H1, H3.
   destruct (join_assoc H1 H3) as [sh' [? ?]].
   assert ((~identity sh') /\ (~full sh')).
     split; intro.
     generalize (split_identity _ _ H0 H5); intro.
     unfold midObj in *.
     tauto.
     spec H5 x.
     spec H5. exists A_top...
     spec H5 sh' A_top H4.
     subst sh'.
     apply unit_identity in H4.
     unfold midObj in *.
     tauto.
  destruct (combjoin_assoc _ _ _ _ _ H2 H) as [v' [? ?]].
  exists (CPart (existT _ sh' H5) v').
  split; split...
Qed.

Lemma combineJ_com: forall a b c : combiner,
    join a b c -> join b a c.
Proof with auto.
  intros. unfold join in H|-*.
  icase a; icase b.
  icase c; red in H; red; destruct H;
  split...
  apply ijoin_com...
  apply join_comm...
Qed.

Lemma combineJ_canc {C1: Canc_alg T1}: forall a1 a2 b c : combiner,
       join a1 b c -> join a2 b c -> a1=a2.
Proof with auto.
   intros. unfold join in H,H0.
   icase c;icase b;icase a1;icase a2;inv H;inv H0;auto.

   destruct (ijoin_identity1 _ _ H).
   destruct (ijoin_identity1 _ _ H1).

   generalize (ijoin_canc _ _ _ _ H1 H).
   generalize (join_canc H2 H3); intros.
   subst sh2 v2...

   generalize (join_canc H2 H3).
   generalize (combjoin_canc _ _ _ _ H1 H); intros.
   f_equal...
   icase sh0; icase sh1.
   apply existT_ext...
Qed.

Lemma combineJ_ex_identities: forall a , {e : combiner &  join e a a}.
Proof with auto.
   intros.
   icase a;
   exists CEmpty;
   constructor...
Qed.

Lemma combineJ_self {DA: Disj_alg A}:
        forall a b : combiner, join a a b -> a = b.
Proof.
  intros.
  icase a;icase b; inv H.
  destruct (ijoin_identity2 _ _ H0).
  elimtype False. clear - DA H1 A_top_full.
  icase sh. red in H1. simpl in H1.
  generalize (join_self H1); intro.
  subst x.
  unfold midObj in *.
  tauto.
Qed.

Instance Perm_combiner : Perm_alg combiner.
Proof. constructor.
  apply combineJ_eq.
  apply combineJ_assoc.
  apply combineJ_com.
   (* positivity *)
  intros.
  hnf in H, H0.
  destruct a, a'; try contradiction; destruct b,b'; try contradiction; auto;
  try solve [destruct H; destruct H0; congruence].
  destruct H; destruct H0.
  f_equal.
  destruct sh as [sh i]; destruct sh0 as [sh0 i0];
  destruct sh1 as [sh1 i1]; destruct sh2 as [sh2 i2].
  apply existT_ext. unfold ijoin in H,H0.
  eapply join_positivity; eauto.
  eapply join_positivity; eauto.
Qed.

Instance Sep_combiner: Sep_alg combiner.
Proof.
  apply mkSep with (fun _ => CEmpty).
  intros. hnf.  destruct t; auto.
  auto.
Defined.

Instance Sing_combiner: Sing_alg combiner.
Proof.
  apply (mkSing CEmpty).
  auto.
Defined.

Instance Canc_combiner {C1: Canc_alg T1}: Canc_alg combiner.
Proof.
 repeat intro. eapply combineJ_canc; eauto.
Qed.

Instance Disj_combiner {D1: Disj_alg A}: Disj_alg combiner.
Proof.
 repeat intro. eapply combineJ_self; eauto.
Qed.

(* Usefull facts about combiners *)

Lemma identity_combiner {C1: Canc_alg T1}: forall d : combiner,
  identity d ->
  d = CEmpty.
Proof.
  intros.
  rewrite identity_unit_equiv in H.
  icase d.
  destruct H.
  destruct (ijoin_identity1 _ _ H).
Qed.

Lemma combiner_identity {C1: Canc_alg T1}:
  identity CEmpty.
Proof.
  intros.
  rewrite identity_unit_equiv.
  compute.
  trivial.
Qed.

Lemma combiner_full {C1: Canc_alg T1}: forall t2,
  full (CFull t2).
Proof.
  unfold full.  intros.
  destruct H as [sigma'' ?].
  icase sigma'.
  apply combiner_identity.
Qed.

(* This one is only true under various restrictions. *)
(*
Lemma full_combiner: forall (d : combiner),
  (* we require that As have complements *)
  (forall a : ijoinable, exists a' : ijoinable, join (projT1 a) (projT1 a') A_top) ->
  (* we require that T2 be nonempty *)
  forall (at2 : T2),
  full d ->
  {t2 : T2 | d = DFull t2}.
Proof.
  intros.
  icase d.
  3: exists v; trivial.
  spec H0 (DFull at2) (DFull at2).
  spec H0.
  apply identity_unit.
  apply combiner_identity.
  exists (DFull at2).
  compute. trivial.
  apply identity_combiner in H0.
  inversion H0.

  elimtype False.
  spec H sh.
  destruct H as [sh' ?].
  destruct (join_ex_identities v) as [v0 [? ?]].
  spec H0 ( sh' v0) (DFull .

  ad mit.
  exists v. trivial.
Qed.
*)

End CombineJoin.

Implicit Arguments combiner.
Implicit Arguments Join_combiner.
Implicit Arguments CEmpty.
Implicit Arguments CPart.
Implicit Arguments CFull.
Implicit Arguments identity_combiner.
Implicit Arguments combiner_identity.
Implicit Arguments combiner_full.

Section ParameterizedCombiner.

  Existing Instance Join_combiner.

  Variable S : Type.
  Variable JS : Join S.
  Variable pa_S : Perm_alg S.
  Variable sa_S : Sep_alg S.
  Variable ca_S : Canc_alg S.

  Variable T1 : Type -> Type.
  Variable J1: forall A, Join (T1 A).
  Variable Perm1: forall A, Perm_alg (T1 A).
  Variable Sep1: forall A, Sep_alg (T1 A).
  Variable f_T1 : functor T1.
  Variable T2 : Type -> Type.
  Variable f_T2 : functor T2.

  Definition fcombiner (A : Type) : Type :=
    @combiner S JS (T1 A) (T2 A).

  Definition fcombiner_fmap (A B : Type) (f : A -> B)
    (fa : fcombiner A) : fcombiner B :=
      match fa with
        | CEmpty => CEmpty _ _ _
        | CPart sh rs => CPart _ sh (fmap f rs)
        | CFull trs => CFull _ _ (fmap f trs)
      end.
  Implicit Arguments fcombiner_fmap [A B].

  Lemma ff_combiner : functorFacts fcombiner fcombiner_fmap.
  Proof with auto.
    constructor; intros;
    extensionality pd; unfold fcombiner_fmap.
    icase pd; rewrite fmap_id...
    icase pd; rewrite <- fmap_comp...
  Qed.

  Instance f_combiner : functor fcombiner := Functor ff_combiner.

  Variable top_S : S.
  Variable topS_full : full top_S.
  Variable combjoin : forall A, (T1 A) -> (T1 A) -> (T2 A) -> Prop.
  Variable combjoin_eq : forall A v1 v1' v2 v2',
    combjoin A v1 v1' v2 ->
    combjoin A v1 v1' v2' ->
    v2 = v2'.
  Variable combjoin_assoc : forall A (v1 v2 v3 v4: T1 A) (v5: T2 A),
    join v1 v2 v3 ->
    combjoin A v3 v4 v5 ->
    {v' : (T1 A) & join v2 v4 v' /\ combjoin A v1 v' v5}.
  Variable combjoin_com : forall A v1 v2 v3,
    combjoin A v1 v2 v3 ->
    combjoin A v2 v1 v3.
  Variable combjoin_canc : forall A v1 v1' v2 v3,
    combjoin A v1 v2 v3 ->
    combjoin A v1' v2 v3 ->
    v1 = v1'.
  Variable saf_T1 : pafunctor f_T1.

  Instance Join_fcombiner (A: Type) : Join (fcombiner A) :=
    Join_combiner top_S (J1 A) (combjoin A).

  Instance Perm_fcombiner (A: Type): Perm_alg (fcombiner A).
  Proof. apply Perm_combiner; auto.
     apply combjoin_eq. apply combjoin_assoc.
  Defined.

  Instance Sep_fcombiner (A: Type): Sep_alg (fcombiner A).
  Proof. apply Sep_combiner; auto.
  Defined.

  Instance Canc_fcombiner (A: Type) (CA: Canc_alg (T1 A)): Canc_alg (fcombiner A).
  Proof.  apply Canc_combiner; auto. apply combjoin_canc.
  Qed.

  Definition combjoin_hom (A : Type) (B : Type)
    (f : T1 A -> T1 B) (g : T2 A -> T2 B) : Prop :=
      forall x y z,
        combjoin A x y z ->
        combjoin B (f x) (f y) (g z).
  Implicit Arguments combjoin_hom [A B].

  Variable fmaps_combjoin_hom: forall A B (f : A -> B),
    combjoin_hom (fmap f) (fmap f).

  Lemma fmap_fcombiner_hom: forall A B (f : A -> B),
    join_hom (JA := Join_fcombiner A) (JB := Join_fcombiner B) (fmap f).
  Proof with auto.
    repeat intro. hnf in H|-*.
    icase x; icase y; icase z.
    destruct H.
    split; congruence.
    simpl in H. subst v0. simpl...
    destruct H.
    split; congruence.
    destruct H.
    split...
    apply paf_join_hom...
    destruct H.
    split...
    apply fmaps_combjoin_hom...
    simpl in H. subst v0. simpl...
  Qed.

  Definition combjoin_unmap_left (A B : Type)
    (f : T1 A -> T1 B) (g : T2 A -> T2 B) : Type :=
      forall (x' : T1 B) (y :T1 A) (z : T2 A),
        combjoin B x' (f y) (g z) ->
        {x : T1 A &  {y0 : T1 A | combjoin A x y0 z /\ f x = x' /\ f y0 = f y}}.
  Implicit Arguments combjoin_unmap_left [A B].

  Variable combjoin_preserves_unmap_left : forall A B (f : A -> B),
    combjoin_unmap_left (fmap f) (fmap f).

  Definition combjoin_unmap_right (A B : Type)
    (f : T1 A -> T1 B) (g : T2 A -> T2 B) : Type :=
      forall (x y :T1 A) (z' : T2 B),
        combjoin B (f x) (f y) z' ->
        {y0 : T1 A &  {z : T2 A | combjoin A x y0 z /\ f y0 = f y /\ g z = z'}}.
  Implicit Arguments combjoin_unmap_right [A B].

  Variable combjoin_preserves_unmap_right : forall A B (f : A -> B),
    combjoin_unmap_right (fmap f) (fmap f).

  Lemma fmap_fcombiner_preserves_unmap_left: forall A B (f : A -> B),
    unmap_left (Join_fcombiner A) (Join_fcombiner B) (fmap f).
  Proof with auto.
    repeat intro. simpl in H|-*. unfold join in H|-*. simpl in H|-*.
    icase x'; icase y; icase z.
    exists (CEmpty _ _ _). exists (CEmpty _ _ _). firstorder.
    exists (CEmpty _ _ _). exists (CPart _ sh0 v0).
    destruct H. simpl.
    repeat split; congruence.
    exists (CEmpty _ _ _). exists (CFull _ _ v0).
    simpl in H. simpl.
    repeat split; congruence.
    exists (CPart _ sh v0). exists (CEmpty _ _ _).
    destruct H. simpl.
    repeat split; congruence.
    destruct H.
    generalize (paf_preserves_unmap_left f v v0 v1 H0); intro X.
    destruct X as [x [y0 [? [? ?]]]].
    exists (CPart _ sh x). exists (CPart _ sh0 y0).
    split. split...
    simpl. split; congruence.
    (* combjoin case *)
    destruct H.
    spec combjoin_preserves_unmap_left A B f v v0 v1 H.
    destruct combjoin_preserves_unmap_left as [x [y0 [? [? ?]]]].
    exists (CPart _ sh x). exists (CPart _ sh0 y0).
    split. split...
    simpl. split; congruence.
    (* end combjoin case *)
    exists (CFull _ _ v0). exists (CEmpty _ _ _).
    simpl in H. simpl.
    repeat split; congruence.
  Qed.

  Lemma fmap_fcombiner_preserves_unmap_right: forall A B (f : A -> B),
    unmap_right (Join_fcombiner A) (Join_fcombiner B) (fmap f).
  Proof with auto.
    repeat intro. simpl in H|-*. unfold join in H|-*. simpl in H|-*.
    icase x; icase y; icase z'.
    exists (CEmpty _ _ _). exists (CEmpty _ _ _). firstorder.
    exists (CPart _ sh v). exists (CPart _ sh v).
    destruct H. simpl.
    repeat split; congruence.
    exists (CFull _ _ v). exists (CFull _ _ v).
    simpl in H. simpl.
    repeat split; congruence.
    exists (CEmpty _ _ _). exists (CPart _ sh v).
    destruct H. simpl.
    repeat split; congruence.
    destruct H.
    generalize (paf_preserves_unmap_right f v v0 v1 H0); intro X.
    destruct X as [y0 [z [? [? ?]]]].
    exists (CPart _ sh0 y0). exists (CPart _ sh1 z).
    split. split...
    simpl. split; congruence.
    (* combjoin case *)
    destruct H.
    spec combjoin_preserves_unmap_right A B f v v0 v1 H.
    destruct combjoin_preserves_unmap_right as [y0 [z [? [? ?]]]].
    exists (CPart _ sh0 y0). exists (CFull _ _ z).
    split. split...
    simpl. split; congruence.
    (* end combjoin case *)
    exists (CEmpty _ _ _). exists (CFull _ _ v).
    simpl in H. simpl.
    repeat split; congruence.
  Qed.

 Instance paf_combiner: @pafunctor _ f_combiner Join_fcombiner.
 Proof.
    constructor.
    apply fmap_fcombiner_hom.
    apply fmap_fcombiner_preserves_unmap_left.
    apply fmap_fcombiner_preserves_unmap_right.
 Qed.

End ParameterizedCombiner.

Implicit Arguments fcombiner.
Implicit Arguments combjoin_hom [T1 T2 A B].
Implicit Arguments combjoin_unmap_left [A B T1 T2].
Implicit Arguments combjoin_unmap_right [A B T1 T2].
Implicit Arguments f_combiner [S JS T1 T2].
Implicit Arguments paf_combiner.


Load "phase23".

(** some tactics *)

(*******************************************)
(** ** Phase-II : Voting Phase *)

(**
- (V) -> C : sign( sk (A) , commit(v, r))

 *)
(** frame 6***)
  (** * Frame [phi6] *)

Definition shuftrm (x1:message) :=  (shuf (dec (pi1 (pi1 x1)) (sk 5)) (dec (pi1 (pi2 x1)) (sk 5))).

Definition phi77t n1 n2 := (phi66t n1 n2) ++ [msg  (shuf (unblind (commit (v (nonce 0)) (rr (nonce 7))) (pi1 (k (nonce 3))) (rr (nonce 8)) (pi1 (x2t 0)))
                                                         (unblind (b 1 19) (pk 3) (r 20) (pi2 (x4ttt 0 1)))) ].

Definition x87t n1 n2 := (f (conv_mylist_listm (phi77t n1 n2))).

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

Definition phi74tf3t n1 n2 := (phi64tftt n1 n2) ++ [msg (shuftrm (x74tftt n1 n2)) ].
Definition x84tf3t n1 n2 := (f (conv_mylist_listm (phi74tf3t n1 n2))).
(*
Definition phi3ttft n1  := (phi2tt n1) ++ [msg  ((bsign (sk 3)  (pi1 (pi2 (pi1  (x3tt n1 ))))),  (bsign (sk 3)  (pi1 (pi2 (pi2  (x3tt n1 ))))))].
Definition x4ttft n1 := (f (conv_mylist_listm (phi3ttft n1))).
*)
Definition phi7tf6t n1 n2 := (phi6tf5t n1 n2) ++ [msg (shuftrm (x7tf5t n1 n2) ) ].
Definition x8tf6t n1 n2 := (f (conv_mylist_listm (phi7tf6t n1 n2))).

Definition phi7tf3tf3t n1 n2 := (phi6tf3tftt n1 n2) ++ [msg (shuftrm (x7tf3tftt n1 n2)) ].
Definition x8tf3tf3t n1 n2 := (f (conv_mylist_listm (phi7tf3tf3t n1 n2))).
(**********************************************************************************)

Definition phi7tftf5t n1 n2 := (phi6tftf4t n1 n2) ++ [msg (shuftrm (x7tftf4t n1 n2) ) ].
Definition x8tftf5t n1 n2 := (f (conv_mylist_listm (phi7tftf5t n1 n2))).

Definition phi7tftfttf3t n1 n2 := (phi6tftfttftt n1 n2) ++ [msg (shuftrm (x7tftfttftt n1 n2) ) ].
Definition x8tftfttf3t n1 n2 := (f (conv_mylist_listm (phi7tftfttf3t n1 n2))).
(*
Definition phi3tftfft n1 n2 := (phi2tft n1 n2) ++ [msg  ((bsign (sk 3)  (pi1 (pi2 (pi1 (x3tft n1 n2))))),  (bsign (sk 3)  (pi1 (pi2 (pi2 (x3tft n1 n2))))))].

Definition x4tftfft n1 n2 := (f (conv_mylist_listm (phi3tftfft n1 n2))).
 *)
(*
Definition phi3tfftt n1  := (phi2tfft n1) ++ [msg ok].
Definition x4tfftt n1  := (f (conv_mylist_listm (phi3tfftt n1))).

Definition phi3tfftft n1 n2 := (phi2tfft n1) ++ [msg ((pk 2), ( (e (b n2 21) 22),  (sign (sk 2) (e (b n2 21) 22))))].
Definition x4tfftft n1 n2 := (f (conv_mylist_listm (phi3tfftft n1 n2))). *)
Definition phi7f7t n1 n2 := (phi6f6t n1 n2) ++ [msg (shuftrm (x7f6t n1 n2) ) ].
Definition x8f7t n1 n2 := (f (conv_mylist_listm (phi7f7t n1 n2))).

Definition phi7f4tf3t n1 n2 := (phi6f4tftt n1 n2) ++ [msg (shuftrm (x7f4tftt n1 n2) ) ].
Definition x8f4tf3t n1 n2 := (f (conv_mylist_listm (phi7f4tf3t n1 n2))).
(*Definition phi3fttft  n2 := (phi2ftt n2) ++ [msg  ((bsign (sk 3)  (pi1 (pi2 (pi1 (x3ftt n2 ))))),  (bsign (sk 3)  (pi1 (pi2 (pi2 (x3ftt n2 ))))))].

Definition x4fttft n2 := (f (conv_mylist_listm (phi3fttft n2))). *)

Definition phi7ftf6t n1 n2:= (phi6ftf5t n1 n2) ++ [msg (shuftrm (x7ftf5t n1 n2) ) ].
Definition x8ftf6t n1 n2 := (f (conv_mylist_listm (phi7ftf6t n1 n2))).
Definition phi7ftf3tf3t n1 n2:= (phi6ftf3tftt n1 n2) ++ [msg (shuftrm (x7ftf3tftt n1 n2) ) ] .
Definition x8ftf3tf3t n1 n2 := (f (conv_mylist_listm (phi7ftf3tf3t n1 n2))).
(**********************************************************************)
Definition phi7ftftf5t n1 n2:= (phi6ftftf4t n1 n2) ++ [msg (shuftrm (x7ftftf4t n1 n2) ) ] .
Definition x8ftftf5t n1 n2 := (f (conv_mylist_listm (phi7ftftf5t n1 n2))).

Definition phi7ftftf2tf3t n1 n2:= (phi6ftftf2tftt n1 n2) ++ [msg (shuftrm (x7ftftf2tftt n1 n2) ) ].
Definition x8ftftf2tf3t n1 n2 := (f (conv_mylist_listm (phi7ftftf2tf3t n1 n2))).

(** mixnetops *)

Definition revtrm1   n r2 := ((enc (r n) (pk 5) (r r2)), (sign (sk 1)  (THREE, (enc (r n) (pk 5) (r r2))))).
Definition revtrm2   n r2 := ((enc (r n) (pk 5) (r r2)), (sign (sk 2)  (THREE, (enc (r n) (pk 5) (r r2))))).

 Definition rev x1 n1 r1 n2 r2 := (ifm (eqm (to x1) (V 1)) (revtrm1 n1 r1) (ifm (eqm (to x1) (V 2)) (revtrm2 n2 r2)  O)).

Definition mixnet' x1 x2 n1 r1 n2 r2 :=  (ifm (mchecks (x1)) (rev x2 n1 r1 n2 r2)  O).

Definition mnetop' n x1 x2 x3 n1 r1 n2 r2 := (ifm (eqm (to x1) (V n)) (mixnet' x2 x3 n1 r1 n2 r2) O).
 (*
Definition voter1 x1 n1 n2 r1 x2 r2 := (ifm (eqm (to x1) (V 1)) (vtrm (sk 1) n1 n2 r1 (pi1 (x2)) r2) O).
Definition voter2 x1 n1 n2 r1 x2 r2 := (ifm (eqm (to x1) (V 2)) (vtrm (sk 2) n1 n2 r1 (pi2 (x2)) r2) O).
(** vote 2 *)
  *)

Definition q111r1 n1 n2 := (ifm (eqm (to (x54t n1 n2)) (V 1)) (mnetop' 2 (x65t n1 n2) (x76t n1 n2) (x87t n1 n2) 7 51 19 52)
                                  (ifm (eqm (to (x54t n1 n2)) (V 2)) (mnetop' 1 (x64tft n1 n2) (x74tftt n1 n2) (x84tf3t n1 n2) 7 53 19 54) O)).

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

Definition q121r1 n1 n2 := (ifm (eqm (to (x5tf3t n1 n2)) (V 1)) (mnetop' 2 (x6tf4t n1 n2) (x7tf5t n1 n2) (x8tf6t n1 n2) 7 55 11 56)
                                  (ifm (eqm (to (x5tf3t n1 n2)) (V 2)) (mnetop' 1 (x6tf3tft n1 n2) (x7tf3tftt n1 n2) (x8tf3tf3t n1 n2) 7 57 11 58)  O)).

Definition q122r1 n1 n2 := (ifm (eqm (to (x5tftft n1 n2)) (V 1)) (mnetop' 2 (x6tftf3t n1 n2) (x7tftf4t n1 n2)  (x8tftf5t n1 n2) 7 59 11 60)
                                  (ifm (eqm (to (x5tftft n1 n2)) (V 2)) (mnetop' 1 (x6tftfttft n1 n2) (x7tftfttftt n1 n2) (x8tftfttf3t n1 n2) 7 61 11 62)  O)).

Definition q211r1 n1 n2 := (ifm (eqm (to (x5f4t n1 n2)) (V 1))   (mnetop' 2 (x6f5t n1 n2) (x7f6t n1 n2) (x8f7t n1 n2) 23 63 9 64)
                                  (ifm (eqm (to (x5f4t n1 n2)) (V 2)) (mnetop' 1 (x6f4tft n1 n2) (x7f4tftt n1 n2) (x8f4tf3t n1 n2) 23 65 9 66) O)).

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

Definition q221r1 n1 n2:=  (ifm (eqm (to (x5ftf3t n1 n2)) (V 1)) (mnetop' 2 (x6ftf4t n1 n2) (x7ftf5t n1 n2) (x8ftf6t n1 n2) 13 66 9 68)
                                  (ifm (eqm (to (x5ftf3t n1 n2)) (V 2)) (mnetop' 1 (x6ftf3tft n1 n2) (x7ftf3tftt n1 n2) (x8ftf3tf3t n1 n2) 13 69 9 70) O)).

Definition q222r1 n1 n2 :=  (ifm (eqm (to (x5ftftf2t n1 n2)) (V 1)) (mnetop' 2 (x6ftftf3t n1 n2) (x7ftftf4t n1 n2) (x8ftftf5t n1 n2) 13 71 9 72)
                                  (ifm (eqm (to (x5ftftf2t n1 n2)) (V 2)) (mnetop' 1 (x6ftftf2tft n1 n2) (x7ftftf2tftt n1 n2) (x8ftftf2tf3t n1 n2) 13 73 9 74) O)).

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

Definition q111s n1 n2 := (ifm  (eqm (to (x4ttt n1 n2)) (V 2))& (bacc (pk 3) (b n2 19) (r 20) (pi2 (x4ttt n1 n2))) (q111r1 n1 n2)
                                     O).

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

Definition q121s n1 n2 := (ifm (eqm (to (x4tftt n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x4tftt n1 n2))) (q121r1 n1 n2)
                         O).

Definition q122s n1 n2 := (ifm (eqm (to (x4tftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x4tftft n1 n2))) (q122r1 n1 n2)
                         O).

Definition q211s n1 n2 :=  (ifm (eqm (to (x4fttt n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 23) (r 24) (pi1 (x4fttt n1 n2))) (q211r1 n1 n2)
                          O).

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

Definition q221s n1 n2:=   (ifm (eqm (to (x4ftftt n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x4ftftt n1 n2))) (q221r1 n1 n2)
                           O).
Definition q222s n1 n2 :=  (ifm (eqm (to (x4ftftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x4ftftft n1 n2))) (q222r1 n1 n2) O).

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

Definition q11_r1 n1 n2 :=  (ifm  (eqm (to (x3tt n1 )) (V 2)) (q111s n1 n2)
                                      O).

Definition q12_r1 n1 n2 := (ifm (eqm (to (x3tft n1 n2)) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi2 (x3tft n1 n2))) (q121s n1 n2)
                                    (ifm (eqm (to (x3tft n1 n2)) (V 2))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x3tft n1 n2))) (q122s n1 n2)
                                                 O)).

Definition q21_r1 n1 n2 := (ifm  (eqm (to (x3ftt n2)) (V 1))  (q211s n1 n2)
                                   O).

Definition q22_r1 n1 n2  := (ifm (eqm (to (x3ftft n1 n2)) (V 1))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x3ftft n1 n2))) (q221s n1 n2)
                                    (ifm (eqm (to (x3ftft n1 n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x3ftft n1 n2))) (q222s n1 n2)
                                                   O)).

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

Definition q1_r1 n1 n2 := (ifm (eqm (to (x2t n1 )) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x2t n1 )))  (q11_r1 n1 n2)
			           (ifm (eqm (to (x2t n1 )) (V 2))  (q12_r1 n1 n2)
                                                  O)).

Definition q2_r1 n1 n2 :=  (ifm (eqm (to (x2ft n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x2ft n2)))  (q21_r1 n1 n2)
			           (ifm (eqm (to (x2ft n2)) (V 1))  (q22_r1 n1 n2)
                                                   O)).

Definition t7 n1 n2 :=  (ifm (eqm (to x1) (V 1)) (q1_r1 n1 n2)
		    	           (ifm (eqm (to x1) (V 2))  (q2_r1 n1 n2)
                                                   O )).

Definition phi8 n1 n2 := (phi7 n1 n2) ++ [msg (t7 n1 n2)] .


(* 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                                                     *)

(****************************************************************************)
(*                          Signes Project                                  *)
(*                            2002-2003                                     *)
(*                           Houda ANOUN                                    *)
(*                          Pierre Casteran                                 *)
(*                           LaBRI/INRIA                                    *)
(****************************************************************************)

(* Introduction to filters Cf Kurtonina's PhD Thesis
These filters will be used to give another proof of completeness *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Form.

Section CompletenessFilters.
Variable Atoms : Set.
Section CompletenessDefs.
Variable X : arrow_extension.
Section Filter_Def.

Definition getSet (A : Type) (P : A -> Prop) (x : sigT P) :=
  match x with
  | existT s P => s
  end.

Definition weakFilter (S : Form Atoms -> Prop) : Prop :=
  forall A B : Form Atoms, S A /\ weak (arrow X A B) -> S B.

(* for additive connectives
Definition filter: ((Form Atoms)->Prop)->Prop:=
[S:(Form Atoms)->Prop] (weakFilter S) /\
                       (A,B:(Form Atoms)) (S (Inter A B))<->
                                           (S A) /\ (S B) .

Definition primeFilter: ((Form Atoms)->Prop)->Prop:=
[S:(Form Atoms)->Prop] (filter S)/\
                         (A, B: (Form Atoms)) (S (Uni A B)) <->
                                              (S A)/\(S B) .

*)

Definition compSet (S1 S2 : Form Atoms -> Prop) (F : Form Atoms) : Prop :=
  exists x1 : Form Atoms,
    (exists x2 : Form Atoms, S1 x1 /\ S2 x2 /\ weak (arrow X (Dot x1 x2) F)).

Definition formDerivation (A1 A2 : Form Atoms) : Prop := weak (arrow X A1 A2).

Definition isIncluded (E1 E2 : Form Atoms -> Prop) :=
  forall F : Form Atoms, E1 F -> E2 F.

Lemma formDerivWFilter : forall A : Form Atoms, weakFilter (formDerivation A).
Proof.
 intro A.
 unfold weakFilter in |- *.
 unfold formDerivation in |- *.
 intros A0 B H.
 elim H.
 clear H; intros H H0.
 eapply weak_comp; eauto.
Qed.

Lemma weakFilterComp :
 forall SF1 SF2 : Form Atoms -> Prop, weakFilter (compSet SF1 SF2).
Proof.
 intros SF1 SF2.
 unfold weakFilter in |- *.
 unfold compSet in |- *.
 intros A B H.
 elim H; clear H; intros H H0.
 elim H; clear H; intros x1 H.
 elim H; clear H; intros x2 H.
 split with x1.
 split with x2.
 split.
 tauto.
 split.
 tauto.
 apply weak_comp with A.
 tauto.
 auto.
Qed.

End Filter_Def.

Section semanticDefs.
(* the same as in the file Semantics.v *)
Variables (W : Type) (R : W -> W -> W -> Prop) (v_at : Atoms -> W -> Prop).

(* extension of some valuation on atoms to all formulae *)

Fixpoint val (F : Form Atoms) : W -> Prop :=
  match F with
  | At a => v_at a
  | Dot A B =>
      fun x => ex (fun y => ex (fun z => R x y z /\ val A y /\ val B z))
  | Slash C B => fun y => forall x z : W, R x y z -> val B z -> val C x
  | Backslash A C => fun z => forall x y : W, R x y z -> val A y -> val C x
  end.

End semanticDefs.
Section model_types.

 (* Kinds of models are caracterized wrt the ternary relation R *)

 Definition model_type := forall W : Type, (W -> W -> W -> Prop) -> Prop.

 Definition model_inter (P1 P2 : model_type) (W : Type)
   (R : W -> W -> W -> Prop) := P1 W R /\ P2 W R.
 Variable P : model_type.

  Definition sem_implies : Form Atoms -> Form Atoms -> Prop :=
    fun A B : Form _ =>
    forall (W : Type) (R : W -> W -> W -> Prop) (v_at : Atoms -> W -> Prop),
    P R -> forall w : W, val R v_at A w -> val R v_at B w.

 (* associativity and commutativity *)

 Definition ASS : model_type :=
   fun (W : Type) (R : W -> W -> W -> Prop) =>
   (forall x y z t u : W,
    R t x y -> R u t z -> exists v : W, R v y z /\ R u x v) /\
   (forall x y z v u : W,
    R v y z -> R u x v -> exists t : W, R t x y /\ R u t z).

 Definition COM : model_type :=
   fun (W : Type) (R : W -> W -> W -> Prop) =>
   forall x y z : W, R x y z -> R x z y.

(* canonical model *)
(* WK is the set of all weak filters *)

Definition WK := sigT weakFilter.

Definition RK (E1 E2 E3 : WK) :=
  isIncluded (compSet (getSet E2) (getSet E3)) (getSet E1).

Definition VatK (p : Atoms) (A : WK) := getSet A (At p).
End model_types.

Definition model_OK (P : model_type) := P _ RK.

 Definition complete (P : model_type) :=
   forall A B : Form Atoms, sem_implies P A B -> weak (arrow X A B).

Lemma getSetWeakFilter :
 forall (A : WK) (F1 F2 : Form Atoms),
 getSet A F1 -> weak (arrow X F1 F2) -> getSet A F2.
Proof.
 intro A.
 elim A.
 intros x p F1 F2 H H0.
 simpl in |- *.
 simpl in H.
 unfold weakFilter in p.
 eapply p; split; eauto.
Qed.

Lemma truthLemmaFilters :
 forall (F : Form Atoms) (A : WK), val RK VatK F A <-> getSet A F.
 intro F.
 elim F.
 simpl in |- *.
 unfold VatK in |- *.
 tauto.
 intros f H f0 H0 A.
 split.
 intro H1.
 cut (compSet (getSet A) (formDerivation f0) f).
 intro H2.
 unfold compSet in H2.
 elim H2; clear H2; intros x1 H2.
 elim H2; clear H2; intros x2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intros H3 H4.
 unfold formDerivation in H3.
 apply getSetWeakFilter with x1.
 assumption.
 apply weak_beta.
 apply weak_comp with (Dot x1 x2).
 apply weak_Dot_mono_right; assumption.
 assumption.
 cut (weakFilter (compSet (getSet A) (formDerivation f0))).
 intro H2.
 elim (H (existT weakFilter (compSet (getSet A) (formDerivation f0)) H2)).
 intros.
 apply H3.
 generalize H1.
 simpl in |- *.
 clear H1; intro H1.
 cut (weakFilter (formDerivation f0)).
 intro H5.
 apply H1 with (existT weakFilter (formDerivation f0) H5).
 unfold RK in |- *.
 simpl in |- *.
 unfold isIncluded in |- *.
 auto.
 elim (H0 (existT weakFilter (formDerivation f0) H5)).
 intros H6 H7.
 apply H7.
 simpl in |- *.
 unfold formDerivation in |- *.
 apply weak_one.
 apply formDerivWFilter.
 apply weakFilterComp.
 intro H1.
 simpl in |- *.
 unfold RK in |- *.
 unfold isIncluded in |- *.
 intros x z H2 H3.
 elim (H x); intros H4 H5.
 apply H5.
 apply (H2 f).
 unfold compSet in |- *.
 split with (Slash f f0).
 split with f0.
 split.
 auto.
 split.
 elim (H0 z); intros H6 H7.
 apply H6; assumption.
 apply weak_beta'.
 apply weak_one.
(* case where F=(Dot f f0) *)
 intros f H f0 H0.
 split.
 simpl in |- *.
 intro H1.
 elim H1.
 clear H1; intros x H1.
 elim H1; clear H1; intros z H1.
 elim H1; unfold RK in |- *; clear H1; intros H1 H2.
 elim H2; clear H2; intros H2 H3.
 unfold isIncluded in H1.
 apply H1.
 unfold compSet in |- *.
 split with f.
 split with f0.
 split.
 elim (H x); intros H4 H5.
 apply H4; exact H2.
 split.
 elim (H0 z).
 intros H4 H5.
 apply H4.
 assumption.
 apply weak_one.
 intro H1.
 simpl in |- *.
 assert (H2 : forall A : Form Atoms, weakFilter (formDerivation A)).
 exact formDerivWFilter.
 split with (existT weakFilter (formDerivation f) (H2 f)).
 split with (existT weakFilter (formDerivation f0) (H2 f0)).
 unfold RK in |- *.
 split.
 unfold isIncluded in |- *.
 simpl in |- *.
 unfold compSet in |- *.
 intros F0 H3.
 elim H3; clear H3; intros x1 H3.
 elim H3; clear H3; intros x2 H3.
 apply getSetWeakFilter with (Dot x1 x2).
 apply getSetWeakFilter with (Dot f f0).
 assumption.
 apply weak_Dot_mono; tauto.
 tauto.
 split.
 elim (H (existT weakFilter (formDerivation f) (H2 f))).
 intros H3 H4.
 apply H4.
 simpl in |- *.
 unfold formDerivation in |- *.
 apply weak_one.
 elim (H0 (existT weakFilter (formDerivation f0) (H2 f0))).
 intros H3 H4.
 apply H4.
 simpl in |- *.
 unfold formDerivation in |- *; apply weak_one.
(* Case where F=(Backslash f f0) *)
 intros f H0 f0 H.
 split.
 intro H1.
 assert (L : compSet (formDerivation f) (getSet A) f0).
 simpl in H1.
 assert (H2 : weakFilter (compSet (formDerivation f) (getSet A))).
 apply weakFilterComp.
 elim (H (existT weakFilter (compSet (formDerivation f) (getSet A)) H2)).
 intros H4 H5.
 apply H4.
 assert (H6 : forall A : Form Atoms, weakFilter (formDerivation A)).
 exact formDerivWFilter.
 apply H1 with (existT weakFilter (formDerivation f) (H6 f)).
 unfold RK in |- *.
 unfold isIncluded in |- *.
 simpl in |- *.
 auto.
 elim (H0 (existT weakFilter (formDerivation f) (H6 f))).
 intros H7 H8.
 apply H8.
 simpl in |- *.
 unfold formDerivation in |- *.
 apply weak_one.
 unfold compSet in L.
 elim L; clear L; intros x2 L.
 elim L; clear L; intros x3 L.
 apply getSetWeakFilter with x3.
 tauto.
 apply weak_gamma.
 apply weak_comp with (Dot x2 x3).
 apply weak_Dot_mono_left.
 unfold formDerivation in L.
 tauto.
 tauto.
 intro H1.
 simpl in |- *.
 intros x y H2 H3.
 elim (H x).
 intros H4 H5.
 apply H5.
 unfold RK in H2.
 unfold isIncluded in H2.
 apply H2.
 unfold compSet in |- *.
 split with f.
 split with (Backslash f f0).
 split.
 elim (H0 y).
 intros H6 H7.
 apply H6.
 exact H3.
 split.
 exact H1.
 apply weak_gamma'.
 apply weak_one.
Qed.

 Lemma completenessProof : forall P : model_type, model_OK P -> complete P.

Proof.
 unfold model_OK, complete, sem_implies in |- *.
 intros P H A B HO.
 unfold formDerivation in |- *.
 cut (formDerivation A B).
 unfold formDerivation in |- *.
 auto.
 assert (H1 : weakFilter (formDerivation A)).
 apply formDerivWFilter.
 set (w := existT weakFilter (formDerivation A) H1).
 cut (getSet w B).
 simpl in |- *.
 auto.
 elim (truthLemmaFilters B w).
 intros H2 H3.
 apply H2.
 apply HO.
 auto.
 elim (truthLemmaFilters A w).
 intros H4 H5.
 apply H5.
 simpl in |- *.
 unfold formDerivation in |- *; apply weak_one.
Qed.

End CompletenessDefs.

Lemma NL_OK : model_OK NL (fun _ _ => True).
Proof.
 unfold model_OK in |- *.
 auto.
Qed.

Lemma NL_complete : complete NL (fun _ _ => True).
Proof.
 apply completenessProof.
 apply NL_OK.
Qed.

Lemma NLP_OK : forall X : arrow_extension, extends NLP X -> model_OK X COM.
Proof.
 intros X H.
 unfold model_OK in |- *.
 unfold COM in |- *.
 unfold RK in |- *.
 unfold isIncluded in |- *.
 intros x y z H0 F H1.
 apply H0.
 unfold compSet in |- *.
 unfold compSet in H1.
 elim H1; clear H1; intros x1 H1.
 elim H1; clear H1; intros x2 H1.
 split with x2.
 split with x1.
 split.
 tauto.
 split.
 tauto.
 apply weak_comp with (Dot x1 x2).
 apply weak_arrow_plus.
 unfold extends in H.
 apply H.
 split.
 tauto.
Qed.

Lemma NLP_complete : complete NLP COM.
Proof.
 apply completenessProof.
 apply NLP_OK.
 apply no_extend.
Qed.

Lemma LcompSet :
 forall (F : Form Atoms) (X : arrow_extension) (x y z : WK X),
 extends L X ->
 compSet X (getSet x) (compSet X (getSet y) (getSet z)) F ->
 compSet X (compSet X (getSet x) (getSet y)) (getSet z) F.
Proof.
 intros F X x y z H H0.
 unfold compSet in |- *.
 unfold compSet in H0.
 elim H0; clear H0; intros x1 H0.
 elim H0; clear H0; intros x2 H0.
 elim H0; clear H0; intros H0 H1.
 elim H1; clear H1; intros H1 H2.
 elim H1; clear H1; intros x3 H1.
 elim H1; clear H1; intros x4 H1.
 split with (Dot x1 x3).
 split with x4.
 split.
 split with x1.
 split with x3.
 split.
 auto.
 split.
 tauto.
 apply weak_one.
 split.
 tauto.
 apply weak_comp with (Dot x1 (Dot x3 x4)).
 apply weak_arrow_plus.
 unfold extends in H.
 apply H.
 constructor 2.
 apply weak_comp with (Dot x1 x2).
 apply weak_Dot_mono_right.
 tauto.
 assumption.
Qed.

Lemma LcompSet' :
 forall (F : Form Atoms) (X : arrow_extension) (x y z : WK X),
 extends L X ->
 compSet X (compSet X (getSet x) (getSet y)) (getSet z) F ->
 compSet X (getSet x) (compSet X (getSet y) (getSet z)) F.

Proof.
 intros F X x y z H H0.
 unfold compSet in |- *.
 unfold compSet in H0.
 elim H0; clear H0; intros x1 H0.
 elim H0; clear H0; intros x2 H0.
 elim H0; clear H0; intros H0 H1.
 elim H0; clear H0; intros x3 H0.
 elim H0; clear H0; intros x4 H0.
 split with x3.
 split with (Dot x4 x2).
 split.
 tauto.
 split.
 split with x4.
 split with x2.
 split.
 tauto.
 split.
 tauto.
 apply weak_one.
 apply weak_comp with (Dot (Dot x3 x4) x2).
 apply weak_arrow_plus.
 unfold extends in H.
 apply H.
 constructor 1.
 apply weak_comp with (Dot x1 x2).
 apply weak_Dot_mono_left.
 tauto.
 tauto.
Qed.

Lemma compSetMono :
 forall (X : arrow_extension) (s1 s2 s3 s4 : Form Atoms -> Prop)
   (F : Form Atoms),
 isIncluded s1 s2 ->
 isIncluded s3 s4 -> compSet X s1 s3 F -> compSet X s2 s4 F.
Proof.
 intros X s1 s2 s3 s4 F.
 unfold isIncluded in |- *.
 unfold compSet in |- *.
 intros H H0 H1.
 elim H1; clear H1; intros x1 H1.
 elim H1; clear H1; intros x2 H1.
 split with x1.
 split with x2.
 split.
 apply H; tauto.
 split.
 apply H0; tauto.
 tauto.
Qed.

Lemma L_OK : forall X : arrow_extension, extends L X -> model_OK X ASS.

 intros X H.
 unfold model_OK, ASS, RK in |- *.
 split.
 intros x y z t u H0 H1.
 assert (L : weakFilter X (compSet X (getSet y) (getSet z))).
 apply weakFilterComp.
 split with (existT (weakFilter X) (compSet X (getSet y) (getSet z)) L).
 split.
 simpl in |- *; auto.
 simpl in |- *.
 unfold isIncluded in |- *; auto.
 unfold isIncluded in |- *; intros F H2.
 apply H1.
 apply compSetMono with (compSet X (getSet x) (getSet y)) (getSet z).
 auto.
 unfold isIncluded in |- *; auto.
 apply LcompSet; auto.
 intros x y z v u H0 H1.
 assert (L : weakFilter X (compSet X (getSet x) (getSet y))).
 apply weakFilterComp.
 split with (existT (weakFilter X) (compSet X (getSet x) (getSet y)) L).
 split.
 simpl in |- *.
 unfold isIncluded in |- *; auto.
 simpl in |- *.
 unfold isIncluded in |- *.
 intros F H2.
 apply H1.
 apply compSetMono with (getSet x) (compSet X (getSet y) (getSet z)).
 unfold isIncluded in |- *; auto.
 exact H0.
 apply LcompSet'; auto.
Qed.

Lemma L_complete : complete L ASS.
Proof.
 apply completenessProof.
 apply L_OK.
 apply no_extend.
Qed.

End CompletenessFilters.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef1.Spec.
Require Import TableDataOpsRef1.Layer.
Require Import TableDataOpsRef2.Code.table_unmap2.

Require Import TableDataOpsRef2.LowSpecs.table_unmap2.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _table_unmap ↦ gensem table_unmap_spec
      ⊕ _table_unmap1 ↦ gensem table_unmap1_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_table_unmap: block.
    Hypothesis h_table_unmap_s : Genv.find_symbol ge _table_unmap = Some b_table_unmap.
    Hypothesis h_table_unmap_p : Genv.find_funct_ptr ge b_table_unmap
                                 = Some (External (EF_external _table_unmap
                                                  (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                        (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap_spec.

    Variable b_table_unmap1: block.
    Hypothesis h_table_unmap1_s : Genv.find_symbol ge _table_unmap1 = Some b_table_unmap1.
    Hypothesis h_table_unmap1_p : Genv.find_funct_ptr ge b_table_unmap1
                                  = Some (External (EF_external _table_unmap1
                                                   (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                         (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap1_spec.

    Lemma table_unmap2_body_correct:
      forall m d d' env le g_rd_base g_rd_offset map_addr level res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (Hspec: table_unmap2_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned map_addr)) (VZ64 (Int64.unsigned level)) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) table_unmap2_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec table_unmap2_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

  Velisarios 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.

  Velisarios 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 Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFTwell_formed_log.
Require Export PBFTordering.
Require Export PBFTprops3.
Require Export PBFTwf.
Require Export PBFTgarbage_collect.
Require Export PBFTpreserves_has_new_view.
Require Export PBFT_A_1_2_7.

Section PBFT_A_1_2_1.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Lemma own_prepare_is_already_logged_with_different_digest_clear_log_checkpoint_false_implies :
    forall (n s : SeqNum) i v d L,
      n < s
      -> own_prepare_is_already_logged_with_different_digest i s v d (clear_log_checkpoint L n) = None
      -> own_prepare_is_already_logged_with_different_digest i s v d L = None.
  Proof.
    induction L; introv h own; simpl in *; smash_pbft.
    repeat (autodimp IHL hyp).
    allrw SeqNumLe_true.
    dands; auto.
    unfold own_prepare_is_already_in_entry_with_different_digest in *; smash_pbft.
    destruct a, log_entry_request_data; simpl in *; ginv; omega.
  Qed.
  Hint Resolve own_prepare_is_already_logged_with_different_digest_clear_log_checkpoint_false_implies : pbft.

  Lemma update_state_new_view_preserves_own_prepare_is_already_logged_with_different_digest_false_forward :
    forall i (s : SeqNum) v d s1 nv s2 msgs,
      correct_new_view nv = true
      -> update_state_new_view i s1 nv = (s2, msgs)
      -> low_water_mark s2 < s
      -> own_prepare_is_already_logged_with_different_digest i s v d (log s2) = None
      -> own_prepare_is_already_logged_with_different_digest i s v d (log s1) = None.
  Proof.
    introv cor upd h prep.

    unfold update_state_new_view in upd; smash_pbft.
    unfold log_checkpoint_cert_from_new_view in *; smash_pbft.

    - unfold update_log_checkpoint_stable, low_water_mark in *; simpl in *.
      apply own_prepare_is_already_logged_with_different_digest_clear_log_checkpoint_false_implies in prep; eauto 3 with pbft;[].

      rename_hyp_with view_change_cert2max_seq_vc mseq.
      applydup view_change_cert2_max_seq_vc_some_in in mseq.
      apply sn_of_view_change_cert2max_seq_vc in mseq; subst.

      rename_hyp_with extract_seq_and_digest_from_checkpoint_certificate ext.
      eapply extract_seq_and_digest_from_checkpoint_certificate_implies_eq_view_change2seq in ext; eauto 3 with pbft;[].
      subst; auto.

    - rename_hyp_with view_change_cert2max_seq_vc mseq.
      applydup view_change_cert2_max_seq_vc_some_in in mseq.
      apply sn_of_view_change_cert2max_seq_vc in mseq; subst.

      rename_hyp_with extract_seq_and_digest_from_checkpoint_certificate ext.
      apply extract_seq_and_digest_from_checkpoint_certificate_none_implies in ext.
      rewrite ext in *.
      simpl in *; ginv.

    - unfold update_log_checkpoint_stable, low_water_mark in *; simpl in *.
      apply own_prepare_is_already_logged_with_different_digest_clear_log_checkpoint_false_implies in prep; eauto 3 with pbft;[].

      rename_hyp_with view_change_cert2max_seq_vc mseq.
      applydup view_change_cert2_max_seq_vc_some_in in mseq.
      apply sn_of_view_change_cert2max_seq_vc in mseq; subst.

      rename_hyp_with extract_seq_and_digest_from_checkpoint_certificate ext.
      eapply extract_seq_and_digest_from_checkpoint_certificate_implies_eq_view_change2seq in ext; eauto 3 with pbft;[].
      subst; auto.

    - rename_hyp_with view_change_cert2max_seq_vc mseq.
      applydup view_change_cert2_max_seq_vc_some_in in mseq.
      apply sn_of_view_change_cert2max_seq_vc in mseq; subst.

      rename_hyp_with extract_seq_and_digest_from_checkpoint_certificate ext.
      apply extract_seq_and_digest_from_checkpoint_certificate_none_implies in ext.
      rewrite ext in *.
      simpl in *; ginv.

      apply correct_new_view_implies_correct_view_change in mseq0; auto.
      unfold correct_view_change, correct_view_change_cert in *; smash_pbft.
      rewrite ext in *; simpl in *; omega.
  Qed.
  Hint Resolve update_state_new_view_preserves_own_prepare_is_already_logged_with_different_digest_false_forward : pbft.

  (* Invariant A.1.2 (1) in PBFT PhD p.145 *)
  Lemma PBFT_A_1_2_1 :
    forall (eo      : EventOrdering)
           (e       : Event)
           (i       : Rep)
           (n       : SeqNum)
           (v       : View)
           (a1 a2   : Tokens)
           (d1 d2   : PBFTdigest)
           (state   : PBFTstate),
      state_sm_on_event (PBFTreplicaSM i) e = Some state
      -> prepare_in_log (mk_prepare v n d1 i a1) (log state) = true
      -> prepare_in_log (mk_prepare v n d2 i a2) (log state) = true
      -> d1 = d2.
  Proof.
    intros eo e.
    induction e as [? ind] using predHappenedBeforeInd_local_pred;[].
    introv eqst prep1 prep2.

    dup eqst as eqst_At_e.
    rewrite state_sm_on_event_unroll2 in eqst.

    match goal with
    | [ H : context[map_option _ ?s] |- _ ] =>
      remember s as sop; symmetry in Heqsop; destruct sop; simpl in *;[|ginv];op_st_some m eqtrig
    end.

    unfold PBFTreplica_update in eqst.

    destruct m;
      simpl in *; ginv; subst; tcsp;
        try smash_handlers; try (smash_pbft_ind ind).

    { (* pre-prepare *)

      match goal with
      | [ H : check_send_replies _ _ _ _ _ _ = _ |- _ ] =>
        dup H as check1; dup H as check2
      end.

      eapply check_send_replies_preserves_prepare_in_log in check1;[|exact prep1].
      eapply check_send_replies_preserves_prepare_in_log in check2;[|exact prep2].
      simpl in *.

      match goal with
      | [ H : add_new_pre_prepare_and_prepare2log _ _ _ _ _ _ = _ |- _ ] =>
        dup H as add1; dup H as add2
      end.

      eapply add_new_pre_prepare_and_prepare2log_preserves_prepare_in_log in add1;[| |exact check1];
        autorewrite with pbft in *; auto;[].
      eapply add_new_pre_prepare_and_prepare2log_preserves_prepare_in_log in add2;[| |exact check2];
        autorewrite with pbft in *; auto;[].

      repndors; repnd; try (smash_pbft_ind ind).

      - match goal with
        | [ H : own_prepare_is_already_logged_with_different_digest _ _ _ _ _ = _ |- _ ] =>
          eapply own_prepare_is_already_logged_with_different_digest_false_and_prepare_in_log_implies_same_digest in H;
            [|destruct p0, b; simpl in *;
              unfold pre_prepare2prepare, mk_prepare in *; ginv]
        end.

        match goal with
        | [ H : mk_prepare _ _ _ _ _ = _ |- _ ] =>
          applydup mk_prepare_eq_pre_prepare2prepare_implies_eq in H
        end.
        repnd; subst; auto.

      - match goal with
        | [ H : own_prepare_is_already_logged_with_different_digest _ _ _ _ _ = _ |- _ ] =>
          eapply own_prepare_is_already_logged_with_different_digest_false_and_prepare_in_log_implies_same_digest in H;
            [|destruct p0, b; simpl in *;
              unfold pre_prepare2prepare, mk_prepare in *; ginv]
        end.

        match goal with
        | [ H : mk_prepare _ _ _ _ _ = _ |- _ ] =>
          applydup mk_prepare_eq_pre_prepare2prepare_implies_eq in H
        end.
        repnd; subst; auto.

      - repeat
          match goal with
          | [ H : mk_prepare _ _ _ _ _ = _ |- _ ] =>
            apply mk_prepare_eq_pre_prepare2prepare_implies_eq in H
          end.
        repnd; subst; auto.
    }

    { (* prepare *)

      match goal with
      | [ H : check_send_replies _ _ _ _ _ _ = _ |- _ ] =>
        dup H as check1; dup H as check2
      end.

      eapply check_send_replies_preserves_prepare_in_log in check1;[|exact prep1].
      eapply check_send_replies_preserves_prepare_in_log in check2;[|exact prep2].
      simpl in *.

      match goal with
      | [ H : add_new_prepare2log _ _ _ _ = _ |- _ ] =>
        dup H as add1; dup H as add2
      end.

      eapply add_new_prepare2log_preserves_prepare_in_log in add1;[|exact check1];
        autorewrite with pbft in *; auto;[].
      eapply add_new_prepare2log_preserves_prepare_in_log in add2;[|exact check2];
        autorewrite with pbft in *; auto;[].

      repndors; repnd;
        try (complete (subst; simpl in *; tcsp));
        try (smash_pbft_ind ind).
    }

    { (* commit *)

      match goal with
      | [ H : check_send_replies _ _ _ _ _ _ = _ |- _ ] =>
        dup H as check1; dup H as check2
      end.

      eapply check_send_replies_preserves_prepare_in_log in check1;[|exact prep1].
      eapply check_send_replies_preserves_prepare_in_log in check2;[|exact prep2].
      simpl in *.

      match goal with
      | [ H : add_new_commit2log _ _ = _ |- _ ] =>
        dup H as add1; dup H as add2
      end.

      eapply add_new_commit2log_preserves_prepare_in_log in add1.
      rewrite check1 in add1; symmetry in add1.
      eapply add_new_commit2log_preserves_prepare_in_log in add2.
      rewrite check2 in add2; symmetry in add2.

      try (smash_pbft_ind ind).
    }

    {
      (* check-bcast-new-view*)

      rename_hyp_with update_state_new_view upd.

      applydup update_state_new_view_preserves_wf in upd; simpl; eauto 4 with pbft;[].

      eapply update_state_new_view_preserves_prepare_in_log in prep1;[| |eauto];simpl in *;eauto 4 with pbft;[].
      eapply update_state_new_view_preserves_prepare_in_log in prep2;[| |eauto];simpl in *;eauto 4 with pbft;[].
      rewrite log_pre_prepares_preserves_prepare_in_log in prep1.
      rewrite log_pre_prepares_preserves_prepare_in_log in prep2.
      try (smash_pbft_ind ind).
    }

    { (* new-view *)

      rename_hyp_with update_state_new_view upd.
      rename_hyp_with add_prepares_to_log_from_new_view_pre_prepares add.

      applydup add_prepares_to_log_from_new_view_pre_prepares_preserves_wf in add;
        simpl; autorewrite with pbft; eauto 3 with pbft;[].
      applydup update_state_new_view_preserves_wf in upd; simpl; eauto 3 with pbft;[].

      eapply update_state_new_view_preserves_prepare_in_log2 in prep1;
        [| | |eauto];simpl;auto.
      eapply update_state_new_view_preserves_prepare_in_log2 in prep2;
        [| | |eauto];simpl;auto.
      simpl in *.
      autorewrite with pbft in *.
      exrepnd.

      eapply add_prepares_to_log_from_new_view_pre_prepares_preserves_prepare_in_log in prep5;[|eauto];[].
      eapply add_prepares_to_log_from_new_view_pre_prepares_preserves_prepare_in_log in prep3;[|eauto];[].

      hide_hyp prep4.
      hide_hyp prep0.
      simpl in *.
      autorewrite with pbft in *.

      repndors; exrepnd; autorewrite with pbft in *; try (smash_pbft_ind ind);[| |].

      - eapply PBFT_A_1_2_7_before in prep3;[|eauto];auto.
        exrepnd.
        eapply pre_prepare_in_log_implies_has_new_view_before in prep3;[|eauto];auto.
        simpl in *.
        apply pre_prepare_in_map_correct_new_view_implies2 in prep6;auto;[].
        simpl in *.
        rewrite prep6 in *.
        destruct pp, b; simpl in *.
        unfold mk_prepare, pre_prepare2prepare in *; ginv; simpl in *; pbft_simplifier.

      - eapply PBFT_A_1_2_7_before in prep5;[|eauto];auto.
        exrepnd.
        eapply pre_prepare_in_log_implies_has_new_view_before in prep5;[|eauto];auto.
        simpl in *.
        apply pre_prepare_in_map_correct_new_view_implies2 in prep6;auto;[].
        simpl in *.
        rewrite prep6 in *.
        destruct pp, b; simpl in *.
        unfold mk_prepare, pre_prepare2prepare in *; ginv; simpl in *; pbft_simplifier.

      - rename_hyp_with correct_new_view cor.
        applydup correct_new_view_implies_norepeatsb in cor as norep.

        match goal with
        | [ H1 : mk_prepare _ _ _ _ _ = _, H2 : mk_prepare _ _ _ _ _ = _ |- _ ] =>
          applydup mk_prepare_eq_pre_prepare2prepare_implies_eq_seq in H1 as eqsn1;
            applydup mk_prepare_eq_pre_prepare2prepare_implies_eq_seq in H2 as eqsn2;
            rewrite <- eqsn1 in eqsn2; clear eqsn1
        end.

        eapply norepeatsb_and_in_map_digest_same_seq_implies_eq in norep;
          [|exact prep6|exact prep9|]; auto;[].
        repnd; subst.

        repeat
          match goal with
          | [ H : mk_prepare _ _ _ _ _ = _ |- _ ] =>
            apply mk_prepare_eq_pre_prepare2prepare_implies_eq in H
          end.
        repnd; subst; auto.
    }
  Qed.
  Hint Resolve PBFT_A_1_2_1 : pbft.

  (* Uses if_prepare_in_log_digest_unique *)
  Lemma PBFT_A_1_2_1_direct_pred :
    forall (eo : EventOrdering)
           (e1 e2   : Event)
           (i       : Rep)
           (n       : SeqNum)
           (v       : View)
           (a1 a2   : Tokens)  (* these two should be different!!! *)
           (d1 d2   : PBFTdigest)
           (state1 state2 : PBFTstate),
      e1 ⊂ e2
      -> state_sm_on_event (PBFTreplicaSM i) e1 = Some state1
      -> state_sm_on_event (PBFTreplicaSM i) e2 = Some state2
      -> prepare_in_log (mk_prepare v n d1 i a1) (log state1) = true
      -> prepare_in_log (mk_prepare v n d2 i a2) (log state2) = true
      -> d1 = d2.
  Proof.
    introv ltev eqst1 eqst2 pl1 pl2.

    dup eqst2 as eqst2_At_e.
    hide_hyp eqst2_At_e.

    rewrite state_sm_on_event_unroll2 in eqst2.

    match goal with
    | [ H : context[map_option _ ?s] |- _ ] =>
      remember s as sop; symmetry in Heqsop; destruct sop; simpl in *;[|ginv];op_st_some m eqtrig
    end.

    rewrite state_sm_before_event_as_state_sm_on_event_pred in Heqsop; eauto 2 with eo.
    apply pred_implies_local_pred in ltev.
    subst.
    rewrite eqst1 in Heqsop; ginv.

    unfold PBFTreplica_update in eqst2.

    destruct m;
      simpl in *; ginv; subst; tcsp;
        try (smash_handlers); try (smash_pbft_ind ind); eauto 2 with pbft.

    (* 6 goals left *)

    { (* pre-prepare *)

      match goal with
      | [ H : check_send_replies _ _ _ _ _ _ = _ |- _ ] =>
        dup H as check;
          eapply check_send_replies_preserves_prepare_in_log in check;[|eauto];
            simpl in *
      end.

      match goal with
      | [ H : add_new_pre_prepare_and_prepare2log _ _ _ _ _ _ = _ |- _ ] =>
        dup H as add;
          eapply add_new_pre_prepare_and_prepare2log_preserves_prepare_in_log in add;
          [| |eauto]; autorewrite with pbft in *; auto
      end.

      repndors; repnd; auto; eauto 3 with pbft;[].

      match goal with
      | [ H : own_prepare_is_already_logged_with_different_digest _ _ _ _ _ = _ |- _ ] =>
        rename H into own;
          eapply own_prepare_is_already_logged_with_different_digest_false_and_prepare_in_log_implies_same_digest in own;
          [|destruct p0, b; simpl in *; unfold pre_prepare2prepare, mk_prepare in *; ginv]
      end.

      match goal with
      | [ H : mk_prepare _ _ _ _ _ = _ |- _ ] =>
        applydup mk_prepare_eq_pre_prepare2prepare_implies_eq in H
      end.
      repnd; subst; auto.
    }

    { (* prepare *)

      match goal with
      | [ H : check_send_replies _ _ _ _ _ _ = _ |- _ ] =>
        dup H as check;
          eapply check_send_replies_preserves_prepare_in_log in check;[|eauto];
            simpl in *
      end.

      match goal with
      | [ H : add_new_prepare2log _ _ _ _ = _ |- _ ] =>
        dup H as add;
          eapply add_new_prepare2log_preserves_prepare_in_log in add;[|exact check];
            autorewrite with pbft in *; auto;[]
      end.

      repndors; repnd; auto; subst; simpl in *; tcsp; eauto 3 with pbft.
    }

    { (* commit *)

      match goal with
      | [ H : check_send_replies _ _ _ _ _ _ = _ |- _ ] =>
        dup H as check;
          eapply check_send_replies_preserves_prepare_in_log in check;[|eauto];
            simpl in *
      end.

      match goal with
      | [ H : add_new_commit2log _ _ = _ |- _ ] =>
        dup H as add;
          eapply add_new_commit2log_preserves_prepare_in_log in add;
          rewrite check in add; symmetry in add
      end.

      eauto 3 with pbft.
    }

    {
      (* check-ready *)

      apply check_one_stable_preserves_prepare_in_log in pl2; smash_pbft.
    }

    {
      (* check-bcast-new-view*)

      rename_hyp_with update_state_new_view upd.

      applydup update_state_new_view_preserves_wf in upd; simpl; eauto 4 with pbft;[].

      eapply update_state_new_view_preserves_prepare_in_log in pl2;[| |eauto];simpl in *;eauto 4 with pbft;[].
      rewrite log_pre_prepares_preserves_prepare_in_log in pl2.
      eauto 3 with pbft.
    }

    {
      (* new-view *)

      rename_hyp_with update_state_new_view upd.
      rename_hyp_with add_prepares_to_log_from_new_view_pre_prepares add.

      applydup add_prepares_to_log_from_new_view_pre_prepares_preserves_wf in add;
        simpl; autorewrite with pbft; eauto 3 with pbft;[].
      applydup update_state_new_view_preserves_wf in upd; simpl; eauto 3 with pbft;[].

      eapply update_state_new_view_preserves_prepare_in_log2 in pl2;
        [| | |eauto];simpl in *; auto;[].
      exrepnd.
      hide_hyp pl0.

      eapply add_prepares_to_log_from_new_view_pre_prepares_preserves_prepare_in_log2
        in pl3;[|eauto];[].
      simpl in *; autorewrite with pbft in *.

      repndors; exrepnd; eauto 3 with pbft; try (smash_pbft_ind ind);[].

      eapply PBFT_A_1_2_7 in pl1;[|eauto];auto; autorewrite with eo; auto;[].
      exrepnd.
      eapply pre_prepare_in_log_implies_has_new_view in pl1;[|eauto];auto; autorewrite with eo; auto;[].
      simpl in *.
      apply pre_prepare_in_map_correct_new_view_implies2 in pl4;auto;[].
      simpl in *.
      rewrite pl4 in *.
      destruct pp, b; simpl in *.
      unfold mk_prepare, pre_prepare2prepare in *; ginv; simpl in *; pbft_simplifier.
    }
  Qed.
  Hint Resolve PBFT_A_1_2_1_direct_pred : pbft.

End PBFT_A_1_2_1.

Hint Resolve update_state_new_view_preserves_wf : pbft.
Hint Resolve own_prepare_is_already_logged_with_different_digest_clear_log_checkpoint_false_implies : pbft.
Hint Resolve update_state_new_view_preserves_own_prepare_is_already_logged_with_different_digest_false_forward : pbft.
Hint Resolve PBFT_A_1_2_1 : pbft.
Hint Resolve PBFT_A_1_2_1_direct_pred : pbft.