From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX Protocols.
From DiSeL Require Import Worlds NetworkSem Rely.
From Coq Require FunctionalExtensionality.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module ProtocolWithInvariant.
Section ProtocolWithInvariant.

Variable p : protocol.

(* Decompose the initial protocol *)
Notation l := (plab p).
Notation coh := (coh p).

(* User-provided (supposedly inductive) invariant *)
Variable I : dstatelet -> pred nid -> Prop.
(* "Initial" state *)
Variable d0 : dstatelet.

Definition W := mkWorld p.

Notation toSt d := (l \\-> d).

(* TODO: prove relation between stability and reachability *)

(* New coherence predicate: includes only reachable states *)
Definition cohI :=
  [Pred d | coh d /\ I d (nodes p d)].

(* The usual coherence properties all hold *)
Lemma cohIVd d : cohI d -> valid (dstate d).
Proof. by case=>/cohVl. Qed.

Lemma cohIVs d : cohI d -> valid (dsoup d).
Proof. by case=>/cohVs. Qed.

Lemma cohIDom d : cohI d -> dom (dstate d) =i nodes p d.
Proof. by case=>/cohDom. Qed.

(* Define it as a coherence *)
Definition CohI := CohPred (CohPredMixin cohIVd cohIVs cohIDom).

(* Some helper lemmas *)
Lemma st_helper d : (getStatelet (toSt d) l) = d.
Proof. by rewrite /getStatelet findPt. Qed.

Lemma cohSt d : coh d -> Coh W (toSt d).
Proof.
move=>C; split.
- by apply/andP; rewrite valid_unit; split=>//; apply: validPt.
- by apply: validPt.
- by move=>z lc ls st; rewrite dom0.
- by move=>z; rewrite !domPt inE.
move=>k; case B: (k \in dom (toSt d)); last first.
- rewrite /getProtocol /getStatelet.
  case: (dom_find k (toSt d))=>[->|v /find_some]; last by rewrite B.
  rewrite domPt inE/= in B.
  by case: (dom_find k (toSt p))=>[->|? /find_some]//; rewrite domPt inE/= B.
rewrite domPt inE/= in B; move/eqP: B=>B; subst k.
by rewrite /getProtocol /getStatelet !findPt.
Qed.

Section SendInvWrapper.

Variable st : send_trans coh.

Definition send_safeI this to d m :=
  send_safe st this to d m /\ I d (nodes p d).

Lemma s_safe_cohI this to d m : send_safeI this to d m -> CohI d.
Proof. by case=>/s_safe_coh=>[H1]H2. Qed.

Lemma s_safe_inI this to d m : send_safeI this to d m ->
                               this \in nodes p d /\ to \in nodes p d.
Proof. by case=>/s_safe_in. Qed.

Definition send_stepI: send_step_t (send_safeI) :=
  fun this to d msg S => (@send_step _ _ st this to d msg (proj1 S)).

Lemma s_safe_defI this to d msg :
  send_safeI this to d msg <->
  exists b pf, @send_stepI this to d msg pf = Some b.
Proof.
move: (s_safe_def st this to d msg)=>H; split.
- move=>S; case: (S)=>/H[b][pf]E H1; exists b.
  exists (conj pf H1).
  by rewrite /send_stepI (pf_irr (proj1 (conj pf H1)) pf).
by case=>b[pf]E.
Qed.

(* Inducitve step - prove that the invariant indeed holds *)
Definition S_inv := forall this to d msg (S : send_safe st this to d msg) b,
    I d (nodes p d) -> Some b = send_step S ->
    let: f' := upd this b (dstate d) in
    let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg) this to true)).1 in
    let: d' := DStatelet f' s' in
    (forall z, z == this = false -> getLocal z d' = getLocal z d) ->
    I d' (nodes p d').

Hypothesis HIstep : S_inv.

Lemma s_step_cohI : s_step_coh_t CohI (t_snd st) send_stepI.
Proof.
have E1: (getProtocol W l) = p by rewrite /getProtocol/W/=findPt.
move/s_step_coh: (st)=>H.
move=>this to d msg [S]H1 b.
rewrite /send_stepI (pf_irr (proj1 (conj S H1)) S)=>E.
split=>//= ; first by apply: (H this to d msg S b E).
apply: (HIstep H1 E _)=>//.
by move=>z N; rewrite /getLocal/= findU N.
Qed.

(* Assemble a new send-transition for the rich coherence *)
Definition snd_transI := SendTrans s_safe_cohI s_safe_inI s_safe_defI s_step_cohI.

End SendInvWrapper.

Section ReceiveInvWrapper.

Variable rt : receive_trans coh.

Definition receive_stepI: receive_step_t CohI :=
  fun this from m d C pf => receive_step rt from m (proj1 C) pf.

Definition R_inv := forall d from this i (C : coh d) m
                           (pf: this \in nodes p d),
    I d (nodes p d) ->
    find i (dsoup d) = Some (Msg m from this true) ->
    this \in dom (dstate d) ->
    msg_wf rt C this from m -> tag m = t_rcv rt ->
    let: loc' := receive_step rt from m C pf in
    let: s'' := consume_msg (dsoup d) i in
    let: f' := upd this loc' (dstate d) in
    let: d' := (DStatelet f' s'') in
    (forall z, z == this = false -> getLocal z d' = getLocal z d) ->
    I d' (nodes p d').

Hypothesis HIstep : R_inv.

Notation msg_wfI := (fun d (C : CohI d) => msg_wf rt (proj1 C)).

Lemma r_step_cohI :
  r_step_coh_t msg_wfI (t_rcv rt) receive_stepI.
Proof.
have E1: (getProtocol W l) = p by rewrite /getProtocol/W/=findPt.
move=>d from this i C F m D N Wf T.
rewrite /receive_stepI/=.
set d' := {| dstate := upd this (receive_step rt from m (proj1 C) F) (dstate d);
             dsoup := consume_msg (dsoup d) i |}.
split; first by apply: (r_step_coh F D N Wf T).
- apply: (HIstep (proj2 C) N D Wf T)=>//z N'.
  by rewrite /getLocal findU N'.
Qed.

Definition rcv_transI := @ReceiveTrans _ CohI _ msg_wfI _ r_step_cohI.

End ReceiveInvWrapper.

(* The client has to provide instances of the following
   two structures along with the proofs of Hs and Hr. *)

Structure SendInv := SI {
  st : send_trans coh;
  st_inv : S_inv st;
}.

Structure ReceiveInv := RI {
  rt : receive_trans coh;
  rt_inv : R_inv rt;
}.

Structure InductiveInv := II {
  sts : seq SendInv;
  rts : seq ReceiveInv;
  _ : map st sts = snd_trans p;
  _ : map rt rts = rcv_trans p
}.

(* Obtain new send/receive transitions *)
Definition stsI sts := map (fun stt =>
                          @snd_transI (st stt) (@st_inv stt)) sts.
Definition rtsI rts := map (fun rtt =>
                          @rcv_transI (rt rtt) (@rt_inv rtt)) rts.

Import FunctionalExtensionality.

Variable ii : InductiveInv.

Lemma us : uniq (map (@t_snd _ _) (stsI (sts ii))).
Proof.
case: ii=>sts rts Hs Hr; rewrite /stsI -seq.map_comp/=.
suff E: (t_snd (coh:=CohI) \o
               (fun stt : SendInv => snd_transI (st_inv (s:=stt))))
        = fun stt => t_snd (st stt).
by rewrite E seq.map_comp; rewrite Hs; apply: snd_uniq.
(* TODO: can we do without this? *)
by apply: functional_extensionality=>z.
Qed.

Lemma ur : uniq (map (@t_rcv _ _) (rtsI (rts ii))).
Proof.
case: ii=>sts rts Hs Hr; rewrite /stsI -seq.map_comp/=.
suff E: (t_rcv (coh:=CohI) \o
               (fun rtt : ReceiveInv => rcv_transI (rt_inv (r:=rtt))))
        = fun rtt => t_rcv (rt rtt).
by rewrite E seq.map_comp; rewrite Hr; apply: rcv_uniq.
(* TODO: can we do without this? *)
by apply: functional_extensionality=>z.
Qed.

Definition ProtocolWithIndInv := @Protocol _ l _ _ _ us ur.

Lemma stIn (s : SendInv) :
  s \In (sts ii) ->
  (snd_transI (@st_inv s)) \In (snd_trans ProtocolWithIndInv).
Proof. by move=>H; rewrite /stsI/=; apply/Mem_map. Qed.

Lemma rtIn (r : ReceiveInv) :
  r \In (rts ii) ->
  (rcv_transI (@rt_inv r)) \In (rcv_trans ProtocolWithIndInv).
Proof. by move=>H; rewrite /rtsI/=; apply/Mem_map. Qed.

Lemma getInvSendTrans st z to msg s1 h :
  st \In (snd_trans ProtocolWithIndInv) ->
  forall (S : send_safe st z to (getStatelet s1 (plab p)) msg),
  Some h = send_step S ->
  exists st', [/\ st' \In get_st (mkWorld p) (plab p),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld p) (plab p) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab p)) msg),
       Some h = send_step S'].
Proof.
simpl; case: ii=>sts rts HS HR/=; rewrite /stsI.
case/Mem_map_inv; case=>st' stI/= [->]H1; case=>S Is E.
rewrite /get_st/InMem!prEq; exists st'. split=>//.
- by rewrite -HS/=; apply: (Mem_map ProtocolWithInvariant.st H1).
rewrite/send_step/=/Transitions.send_step/=/send_stepI in E.
- move=>??? F.
  apply sym_eq in F.
  move: F.
  by move/find_some; rewrite dom0.
by exists (proj1 (conj S Is)).
Qed.

End ProtocolWithInvariant.

Section InductiveInvConj.

Variable p : protocol.

Definition s_inv_conj (I1 I2 : dstatelet -> pred nid -> Prop)
           (st : send_trans (coh p)) :=
  S_inv (fun d n => I1 d n /\ I2 d n) st.

Lemma s_inv_conjC I1 I2 st :
  s_inv_conj I1 I2 st <-> s_inv_conj I2 I1 st.
Proof.
by split; move=>H this to d msg S b /and_comm G E N; apply/and_comm; apply: H.
Qed.

Lemma s_inv_conjA I1 I2 I3 st :
  s_inv_conj I1 (fun d n => I2 d n /\ I3 d n) st <->
  s_inv_conj (fun d n => I1 d n /\ I2 d n) I3 st.
Proof.
by split=>H this to d msg S b /and_assoc G E N; apply/and_assoc; apply: H.
Qed.

Definition r_inv_conj (I1 I2 : dstatelet -> pred nid -> Prop)
           (rt : receive_trans (coh p)) :=
  R_inv (fun d n => I1 d n /\ I2 d n) rt.

Lemma r_inv_conjC I1 I2 rt :
  r_inv_conj I1 I2 rt <-> r_inv_conj I2 I1 rt.
Proof.
by split=>H d from this i C m pf/and_comm G E D W T N; apply/and_comm; apply: H.
Qed.

Lemma r_inv_conjA I1 I2 I3 rt :
  r_inv_conj I1 (fun d n => I2 d n /\ I3 d n) rt <->
  r_inv_conj (fun d n => I1 d n /\ I2 d n) I3 rt.
Proof.
by split=>H d from this i C m pf/and_assoc G E D W T N; apply/and_assoc; apply: H.
Qed.

(* Definition ii_conj (I1 I2 : dstatelet -> pred nid -> Prop) *)
(*            (ii1 : InductiveInv p I1) *)
(*            (ii2 : InductiveInv p I2) : *)
(*   InductiveInv p (fun d n => I1 d n /\ I2 d n). *)
(* Proof. *)
(* case: ii1 ii2=>sts1 rts1 Es1 Er1 [sts2] rts2 Es2 Er2. *)
(* Qed. *)

End InductiveInvConj.

End ProtocolWithInvariant.

Module PWIExports.
Section PWIExports.

Import ProtocolWithInvariant.

Definition st_helper := st_helper.
Definition cohSt := cohSt.

Definition S_inv := ProtocolWithInvariant.S_inv.
Definition R_inv := ProtocolWithInvariant.R_inv.

Definition SendInv := SendInv.
Definition SI := SI.
Definition ReceiveInv := ReceiveInv.
Definition RI := RI.

Definition InductiveInv := InductiveInv.

Lemma with_inv_coh pr I (ii : InductiveInv pr I) s:
  s \In Coh (mkWorld (ProtocolWithIndInv ii)) ->
  s \In Coh (mkWorld pr).
Proof.
case=>G1 G2 Gh G3 G4; split=>//.
- by apply/andP; rewrite valid_unit; split=>//; rewrite !validPt in G1 *.
- by move=>???? ;rewrite dom0.
- by move=>z; move: (G3 z); rewrite !domPt !inE.
move=>l; move: (G4 l).
case X: (l == plab pr); first by move/eqP:X=>X; subst l; rewrite !prEq; case.
rewrite /getProtocol/mkWorld/=.
suff [X1 X2]: l \notin dom (plab pr \\-> ProtocolWithIndInv ii) /\
              l \notin dom (plab pr \\-> pr).
- by case: dom_find X1 X2=>//=->_; case: dom_find=>//=->.
rewrite !domPt !inE/=; suff: plab pr != l by [].
by apply/negbT; apply/negP=>/eqP Z; subst l; rewrite eqxx in X.
Qed.

Lemma with_inv_nodes pr I (ii : InductiveInv pr I) l :
  nodes (getProtocol (mkWorld (ProtocolWithIndInv ii)) l) =
  nodes (getProtocol (mkWorld pr) l).
Proof.
rewrite /getProtocol/mkWorld/=.
case X: (l == plab pr);
  first by move/eqP:X=>X; subst l; rewrite !findPt.
rewrite /getProtocol/mkWorld/=.
suff [X1 X2]: l \notin dom (plab pr \\-> ProtocolWithIndInv ii) /\
              l \notin dom (plab pr \\-> pr).
by case: dom_find X1 X2=>//=->_; case: dom_find=>//=->.
rewrite !domPt !inE/=; suff: plab pr != l by [].
by apply/negbT; apply/negP=>/eqP Z; subst l; rewrite eqxx in X.
Qed.

Lemma with_inv_labE pr I (ii : InductiveInv pr I):
  plab (ProtocolWithIndInv ii) = plab pr.
Proof. by []. Qed.

Lemma with_inv_step pr I (ii : InductiveInv pr I) z s1 s2:
  s1 \In Coh (mkWorld (ProtocolWithIndInv ii)) ->
  network_step (mkWorld pr) z s1 s2 ->
  network_step (mkWorld (ProtocolWithIndInv ii)) z s1 s2.
Proof.
move=>C'; move: (with_inv_coh C')=>C.
case; first by case=>_<-; apply: Idle.

(*** Send-transition of the host protocol ***)
move=>l st Hs to msg h H1 H2 _ S A E ->/=.
have Y : l = plab pr
  by rewrite -(cohD C) domPt inE/= in H2; move/eqP:H2.
subst l; move: st Hs H1 S E A; rewrite /get_st/InMem!prEq/==>st Hs H1 S E A.
suff X: exists st',
    [/\ st' \In get_st (mkWorld (ProtocolWithIndInv ii)) (plab pr),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld (ProtocolWithIndInv ii)) (plab pr) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab pr)) msg),
                Some h = send_step S'].
case:X=>st'[Hs']Et A'[S']E'; rewrite -Et.
move: (with_inv_nodes ii (plab pr)); rewrite !prEq=>P.
by rewrite -P in H1; apply: (SendMsg (to:=to)(this:=z)(b:=h)(msg:=msg) Hs').

(* Finding the corresponding send-transition of rich protocol *)
rewrite -(with_inv_labE ii)/get_st/InMem!prEq.
case: ii (@stIn _ _ ii) C' =>sts rts HS HR/= Hi C'.
rewrite -HS in Hs; move/Mem_map_inv: Hs=>[[st' stI]]/=[Es]Si; subst st'.
have G: I (getStatelet s1 (plab pr)) (nodes pr (getStatelet s1 (plab pr))).
+ by case: C'=>_ _ _ _/(_ (plab pr)); rewrite prEq; case.
move:(Hi _ Si)=>/={Hi Si}Hi; exists (@snd_transI pr I st stI); split=>//=.
rewrite /send_safeI /send_stepI/=.
by exists (conj S G); rewrite (pf_irr (proj1 (conj S G)) S).

(*** Receive-transition of the host protocol ***)
move=>l rt  Hr i from H1 H2 C1 msg E[F]Hw/=.
have Y : l = plab pr by rewrite -(cohD C) domPt inE/= in H2; move/eqP:H2.
subst l; move: rt Hr H1 E (coh_s _ C1) Hw.
rewrite /get_rt/InMem/=!prEq=>rt Hr H1 E C1' Hw .
have Hi: (coh (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr)))
           (getStatelet s1 (plab pr)) by case:C'=>_ _ _/(_ (plab pr)).
have Hz : z \in nodes
          (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr))
          (getStatelet s1 (plab pr)) by rewrite (with_inv_nodes ii (plab pr)) prEq.
suff X: exists rt',
     [/\ rt' \In get_rt (mkWorld (ProtocolWithIndInv ii)) (plab pr),
      tag msg = t_rcv rt', msg_wf rt' Hi z from msg &
      receive_step rt from msg C1' H1 = receive_step rt' from msg Hi Hz].
case:X=>rt'[Hr']E' Hw' Gr G.
have pf: (z \in nodes (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr))
                  (getStatelet s1 (plab pr))) by rewrite prEq.
move: (@ReceiveMsg _ z s1 s2 (plab pr) rt' Hr' i from pf)=>/=.
rewrite -(cohD C) /= domPt inE eqxx/=; move/(_ is_true_true C' msg E')=>X.
subst s2; apply X; split=>//; clear X.
- by rewrite (pf_irr (coh_s (plab pr) C') Hi).
congr (upd _ _); congr {| dstate := _ ; dsoup := _ |}; congr (upd _ _).
rewrite Gr; clear E E' Hw Hw' Hr Hr' Gr rt F H2 H1 C1 C.
rewrite (pf_irr pf Hz).
by rewrite (pf_irr Hi (coh_s (plab pr) C')).

(* Finding the corresponding receive-transition of rich protocol *)
rewrite /get_rt/InMem/=; move: C1' H1 Hi Hz Hw; rewrite !prEq=>C1' H1 Hi Hz Hw.
case: ii (@rtIn _ _ ii) C' Hi Hz=>/=sts rts HS HR/= Hi C'.
rewrite -HR in Hr; move/Mem_map_inv: Hr=>[[rt' rtI]]/=[Er]Ri; subst rt'.
case=>C1'' Inv Hz. exists (@rcv_transI pr I rt rtI); split=>//.
- by move: (@Hi _ Ri).
rewrite /receive_step/=/receive_stepI/=/receive_step/=.
- by rewrite -(pf_irr C1' (proj1 (conj C1'' Inv))).
by rewrite ?(pf_irr C1' (proj1 (conj C1'' Inv)))
           ?(pf_irr H1 Hz).
Qed.

Lemma with_inv_step' pr I (ii : InductiveInv pr I) z s1 s2:
  network_step (mkWorld (ProtocolWithIndInv ii)) z s1 s2 ->
  network_step (mkWorld pr) z s1 s2.
Proof.
case.
- by case=>C'<-; apply: Idle; split=>//; apply: with_inv_coh C'.
(* Emulating send-transition *)
move=>l st Hs to msg h H1 H2 C' S A E->{s2}.
have Y : l = plab pr
  by rewrite -(cohD C') domPt inE/= in H2; move/eqP:H2.
subst l; move: st Hs H1 S E A; rewrite /get_st/InMem!prEq/==>st Hs H1 S E A.
suff X: exists st',
    [/\ st' \In get_st (mkWorld pr) (plab pr),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld (ProtocolWithIndInv ii)) (plab pr) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab pr)) msg),
                Some h = send_step S'].
case:X=>st'[Hs']Et A'[S']E'; rewrite -Et.
apply: (SendMsg (to:=to)(this:=z)(b:=h)(msg:=msg) Hs')=>//;
  [by rewrite prEq| by apply: (with_inv_coh C')].
by apply: (getInvSendTrans (ii := ii)).

(* Emulating a receive-transition *)
move=>l rt  Hr i from H1 H2 C1 msg E[F]Hw/=.
have Y : l = plab pr by rewrite -(cohD C1) domPt inE/= in H2; move/eqP:H2.
subst l; move: rt Hr H1 E (coh_s _ C1) Hw.
rewrite /get_rt/InMem/=!prEq=>rt Hr H1 E C1' Hw.
have Hi: (coh (getProtocol (mkWorld pr) (plab pr)))
           (getStatelet s1 (plab pr)) by case:(C1'); rewrite prEq.
have Hz : z \in nodes (getProtocol (mkWorld pr) (plab pr))
                      (getStatelet s1 (plab pr))
  by rewrite -(with_inv_nodes ii (plab pr)) prEq.
suff X: exists rt',
     [/\ rt' \In get_rt (mkWorld pr) (plab pr),
      tag msg = t_rcv rt', msg_wf rt' Hi z from msg &
      receive_step rt from msg C1' H1 = receive_step rt' from msg Hi Hz].
case:X=>rt'[Hr']E' Hw' Gr G.
have pf: (z \in nodes (getProtocol (mkWorld pr) (plab pr))
                  (getStatelet s1 (plab pr))) by rewrite prEq.
move: (@ReceiveMsg _ z s1 s2 (plab pr) rt' Hr' i from pf)=>/=.
rewrite -(cohD C1) domPt inE eqxx/=.
move/(_ is_true_true (with_inv_coh C1) msg E')=>X.
subst s2; apply X; split=>//; clear X.
- by rewrite (pf_irr (coh_s (plab pr) (with_inv_coh C1)) Hi).
congr (upd _ _); congr {| dstate := _ ; dsoup := _ |}; congr (upd _ _).
rewrite Gr; clear E E' Hw Hw' Hr Hr' Gr rt F H2 H1.
rewrite (pf_irr pf Hz).
by rewrite (pf_irr Hi (coh_s (plab pr) (with_inv_coh C1))).
(* Identifying the appropriate receive transition *)
case: ii C1 H2 rt Hr E H1 C1' Hw=>sts rts HS HR/=C1 H2 rt Hr E H1 C1' Hw.
move: Hr; rewrite /rtsI.
case/Mem_map_inv; case=>rt' rtI/= [Z] H1'; subst rt.
rewrite /get_rt/InMem; move: C1' H1 Hi Hz Hw; rewrite !prEq=>C1' H1 Hi Hz Hw.
exists rt'; split=>//; last first.
- rewrite {1}/receive_step /rcv_transI /receive_stepI/=.
  rewrite (pf_irr H1 Hz).
  by rewrite (pf_irr (proj1 C1') Hi).
- by rewrite -(pf_irr (proj1 C1') Hi).
by rewrite -HR; apply: (Mem_map (@ProtocolWithInvariant.rt pr I) H1').
Qed.

Lemma with_inv_rely' pr I (ii : InductiveInv pr I) z s1 s2:
  network_rely (mkWorld (ProtocolWithIndInv ii)) z s1 s2 ->
  network_rely (mkWorld pr) z s1 s2.
Proof.
case=>n; elim: n s1=>[|n Hi] s1; first by move=>[<-]/with_inv_coh=>C; exists 0.
case=>z'[s3][N]H/Hi; move/with_inv_step':H=>S; case=>n' R.
by exists n'.+1, z', s3.
Qed.

(* The following definition requires the proofs, for each transitions
   of p that it satisfies the corresponding two-state invariants with
   respect to the supposedly inductive I. *)

Definition ProtocolWithIndInv := ProtocolWithIndInv.

End PWIExports.
End PWIExports.

Export PWIExports.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model AllFences *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition mfence : relation events := (*failed: try fencerel MFENCE with 0*) 0.
Definition lfence : relation events := (*failed: try fencerel LFENCE with 0*) 0.
Definition sfence : relation events := (*failed: try fencerel SFENCE with 0*) 0.
Definition dmb_st : relation events := (*failed: try fencerel DMB.ST with 0*) 0.
Definition dsb_st : relation events := (*failed: try fencerel DSB.ST with 0*) 0.
Definition dmb : relation events := (*failed: try fencerel DMB with 0*) 0.
Definition dsb : relation events := (*failed: try fencerel DSB with 0*) 0.
Definition isb : relation events := (*failed: try fencerel ISB with 0*) 0.
Definition ctrlisb : relation events := (*failed: try ctrlcfence ISB with 0*) 0.
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition lwsync : relation events := (*failed: try fencerel LWSYNC with 0*) 0.
Definition eieio : relation events := (*failed: try fencerel EIEIO with 0*) 0.
Definition isync : relation events := (*failed: try fencerel ISYNC with 0*) 0.
Definition ctrlisync : relation events := (*failed: try ctrlcfence ISYNC with 0*) 0.
Definition DMB_ISH := (*failed: try DMB.ISH with emptyset_0*) emptyset_0.
Definition DMB_ISHLD := (*failed: try DMB.ISHLD with emptyset_0*) emptyset_0.
Definition DMB_ISHST := (*failed: try DMB.ISHST with emptyset_0*) emptyset_0.
Definition DSB_ISH := (*failed: try DSB.ISH with emptyset_0*) emptyset_0.
Definition DSB_ISHLD := (*failed: try DSB.ISHLD with emptyset_0*) emptyset_0.
Definition DSB_ISHST := (*failed: try DSB.ISHST with emptyset_0*) emptyset_0.
Definition DMB_SY := (*failed: try DMB.SY with emptyset_0*) emptyset_0.
Definition DMB_ST := (*failed: try DMB.ST with emptyset_0*) emptyset_0.
Definition DMB_LD := (*failed: try DMB.LD with emptyset_0*) emptyset_0.
Definition DSB_SY := (*failed: try DSB.SY with emptyset_0*) emptyset_0.
Definition DSB_ST := (*failed: try DSB.ST with emptyset_0*) emptyset_0.
Definition DSB_LD := (*failed: try DSB.LD with emptyset_0*) emptyset_0.
Definition DMB_OSH := (*failed: try DMB.OSH with emptyset_0*) emptyset_0.
Definition DSB_OSH := (*failed: try DSB.OSH with emptyset_0*) emptyset_0.
Definition DMB_OSHLD := (*failed: try DMB.OSHLD with emptyset_0*) emptyset_0.
Definition DSB_OSHLD := (*successful: try DSB.OSH with emptyset_0*) DSB_OSH.
Definition DMB_OSHST := (*failed: try DMB.OSHST with emptyset_0*) emptyset_0.
Definition DSB_OSHST := (*failed: try DSB.OSHST with emptyset_0*) emptyset_0.
Definition ISB := (*failed: try ISB with emptyset_0*) emptyset_0.
Definition A := (*failed: try A with emptyset_0*) emptyset_0.
Definition L := (*failed: try L with emptyset_0*) emptyset_0.
Definition Q := (*failed: try Q with emptyset_0*) emptyset_0.
Definition NoRet := (*failed: try NoRet with emptyset_0*) emptyset_0.
Definition dmb_ish := fencerel DMB_ISH.
Definition dmb_ishld := fencerel DMB_ISHLD.
Definition dmb_ishst := fencerel DMB_ISHST.
Definition dmb_fullsy := fencerel DMB_SY.
Definition dmb_fullst := fencerel DMB_ST.
Definition dmb_fullld := fencerel DMB_LD.
Definition dmb_sy := dmb_fullsy ⊔ dmb_ish.
Definition dmb_st_0 := dmb_fullst ⊔ dmb_ishst.
Definition dmb_ld := dmb_fullld ⊔ dmb_ishld.
Definition dsb_sy := fencerel DSB_SY.
Definition dsb_st_0 := fencerel DSB_ST.
Definition dsb_ld := fencerel DSB_LD.
Definition isb_0 := fencerel ISB.
Definition ctrlisb_0 := (*successful: try ctrlcfence ISB with 0*) ctrlcfence ISB.
Definition ctrlcfence_0 := ctrlisb_0 ⊔ ctrlisync.
Definition witness_conditions := True.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW mfence lfence sfence dmb_st dsb_st dmb dsb isb ctrlisb sync lwsync eieio isync ctrlisync DMB_ISH DMB_ISHLD DMB_ISHST DSB_ISH DSB_ISHLD DSB_ISHST DMB_SY DMB_ST DMB_LD DSB_SY DSB_ST DSB_LD DMB_OSH DSB_OSH DMB_OSHLD DSB_OSHLD DMB_OSHST DSB_OSHST ISB A L Q NoRet dmb_ish dmb_ishld dmb_ishst dmb_fullsy dmb_fullst dmb_fullld dmb_sy dmb_st_0 dmb_ld dsb_sy dsb_st_0 dsb_ld isb_0 ctrlisb_0 ctrlcfence_0 witness_conditions model_conditions : cat.

Definition valid (c : candidate) := True.

(* End of translation of model AllFences *)


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj27eqsynthconj2 : forall  (lv0 : natural), (@eq natural (lv0) (mult lv0 (Succ Zero))).
Admitted.
QuickChick conj27eqsynthconj2.


Require Import ExtLib.Structures.Monad.

Set Universe Polymorphism.
Set Printing Universes.

Class MonadState@{s d c} (T : Type@{s}) (m : Type@{d} -> Type@{c}) : Type :=
{ get : m T
; put : T -> m unit
}.

Arguments get {_ m MS} : rename.
Arguments put {_ m MS} _ : rename.

Section monadic.
  Polymorphic Universes s d c.
  Context {m : Type@{d} -> Type@{c}}.
  Context {M : Monad@{d c} m}.
  Context {T : Type@{s}}.
  Context {MS : MonadState@{s d c} T m}.

  Definition modify (f : T -> T) : m T :=
    bind get (fun x => bind (put (f x)) (fun _ => ret x)).

  Definition gets {U} (f : T -> U) : m U :=
    bind get (fun x => ret (f x)).

End monadic.

Section SubState.
  Polymorphic Universes s d c.
  Context {m : Type@{d} -> Type@{c}}.
  Context {M : Monad@{d c} m}.
  Context {T S : Type@{s}}.
  Context {MS : MonadState@{s d c} T m}.

  Definition StateProd (f : T -> S) (g : S -> T -> T)
    : MonadState S m :=
  {| get := @gets m M T MS S f
   ; put := fun x => bind get (fun s => put (g x s))
   |}.
End SubState.


(**************************************************************************)
(*                                                                        *)
(*     Sniper                                                             *)
(*     Copyright (C) 2021                                                 *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Export SMTCoq.SMTCoq.

From elpi Require Import elpi.

Require Export utilities.
Require Export definitions.
Require Export higher_order.
Require Export anonymous_functions.
Require Export elimination_fixpoints.
Require Export expand.
Require Export elimination_pattern_matching.
Require Export elimination_polymorphism.
Require Export case_analysis.
Require Export case_analysis_existentials.
Require Export interpretation_algebraic_types.
Require Export instantiate.
Require Export indrel.
Require Import ZArith.
Require Import PArith.BinPos.
Require Import SMTCoq.bva.BVList.
Require Import NArith.BinNatDef.

(** Preprocessing for SMTCoq (first-order classical logic with interpreted theories) **)

(* Tuple of symbols we do not want to unfold
in the default tactic *)
Definition prod_of_symb := (impossible_term,
         Zplus,
         Zminus,
         Zmult,
         Z.eqb,
         Zlt_bool,
         Zle_bool,
         Zge_bool,
         Zgt_bool,
         Z.lt,
         Z.le,
         Z.ge,
         Z.gt,
         Pos.lt,
         Pos.le,
         Pos.ge,
         Pos.gt,
         Z.to_nat,
         Pos.mul,
         Pos.add,
         Pos.sub,
         Init.Nat.add,
         Init.Nat.mul,
         Nat.eqb,
         Nat.leb,
         Nat.ltb,
         Init.Peano.lt,
         Init.Peano.ge,
         Init.Peano.gt,
         N.add,
         N.mul,
         N.eqb,
         N.leb,
         N.ltb,
         Init.Peano.lt,
         Init.Peano.ge,
         Init.Peano.gt,
         negb,
         not,
         andb,
         orb,
         implb,
         xorb,
         Bool.eqb,
         iff,
         @BITVECTOR_LIST.bv_eq,
         @BITVECTOR_LIST.bv_and,
         @BITVECTOR_LIST.bv_or,
         @BITVECTOR_LIST.bv_xor,
         @BITVECTOR_LIST.bv_add,
         @BITVECTOR_LIST.bv_mult,
         @BITVECTOR_LIST.bv_ult,
         @BITVECTOR_LIST.bv_slt,
         @BITVECTOR_LIST.bv_concat,
         @BITVECTOR_LIST.bv_shl,
         @BITVECTOR_LIST.bv_shr,
         @FArray.select,
         @FArray.diff,
         is_true,
         @eqb_of_compdec).

Definition prod_types := (Z, bool, True, False, positive, N, and, or, nat, Init.Peano.le).

Ltac def_and_pattern_matching p1 k :=
anonymous_funs ; prenex_higher_order_with_equations ;
let p1' := eval unfold p1 in p1 in
k p1' ltac:(fun H => expand_hyp_cont H ltac:(fun H' =>
eliminate_dependent_pattern_matching H')).

Ltac def_fix_and_pattern_matching p1 k :=
anonymous_funs ; prenex_higher_order_with_equations ;
let p1' := eval unfold p1 in p1 in
k p1' ltac:(fun H => expand_hyp_cont H ltac:(fun H' =>
eliminate_fix_ho H' ltac:(fun H'' =>
try (eliminate_dependent_pattern_matching H'')))).

Ltac def_and_pattern_matching_mono p1 k :=
def_and_pattern_matching p1 k ; inst.

Ltac def_and_pattern_matching_mono_param p1 t k :=
def_and_pattern_matching p1 k ; inst t.

Ltac def_fix_and_pattern_matching_mono_param p1 t k :=
def_fix_and_pattern_matching p1 k ; inst t.

Ltac scope_param p1 p2 t :=
let p2' := eval unfold p2 in p2 in
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2' ; try (def_fix_and_pattern_matching_mono_param p1 t
ltac:(get_definitions_theories_no_generalize)) ;
get_projs_in_variables p2'.

Ltac scope_no_param p1 p2 :=
let p2' := eval unfold p2 in p2 in
intros ;
repeat match goal with
| H : _  |- _ => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2'; try (def_fix_and_pattern_matching p1 ltac:(get_definitions_theories); intros ; inst) ;
get_projs_in_variables p2'.

Ltac snipe_param_no_check p1 p2 t :=
scope_param p1 p2 t ; verit_no_check.

Ltac snipe_no_param_no_check p1 p2 :=
scope_no_param p1 p2 ; verit_no_check.

Ltac snipe_param p1 p2 t :=
scope_param p1 p2 t ; verit.

Ltac snipe_no_param p1 p2 :=
scope_no_param p1 p2 ; verit.

Tactic Notation "elimination_polymorphism" uconstr_list_sep(l, ",") :=
  elpi elimination_polymorphism ltac_term_list:(l) ; clear_prenex_poly_hyps_in_context.

Tactic Notation "scope2_aux" constr(p1) constr(p2) uconstr_list_sep(l, ",") :=
let p2' := eval unfold p2 in p2 in
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2' ; try (def_fix_and_pattern_matching p1 ltac:(get_definitions_theories_no_generalize) ;
elpi elimination_polymorphism ltac_term_list:(l) ; clear_prenex_poly_hyps_in_context) ;
get_projs_in_variables p2'.

Tactic Notation "snipe2" uconstr_list_sep(l, ",") :=
let p2' := eval unfold prod_types in prod_types in
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2' ; try (def_fix_and_pattern_matching prod_of_symb ltac:(get_definitions_theories_no_generalize); intros ;
elpi elimination_polymorphism ltac_term_list:(l) ; clear_prenex_poly_hyps_in_context) ;
get_projs_in_variables p2' ; verit.

Tactic Notation "snipe_no_check" constr(t) := snipe_param_no_check prod_of_symb prod_types t.
Tactic Notation "snipe_no_check" := snipe_no_param_no_check prod_of_symb prod_types.

Tactic Notation "scope" constr(t) := scope_param prod_of_symb prod_types t.
Tactic Notation "scope" := scope_no_param prod_of_symb prod_types.

Tactic Notation "snipe" constr(t) := snipe_param prod_of_symb prod_types t.
Tactic Notation "snipe" := snipe_no_param prod_of_symb prod_types.

Tactic Notation "snipe_no_check_timeout" constr(t) int_or_var(n) := scope_param prod_of_symb prod_types t ; verit_no_check_timeout n.
Tactic Notation "snipe_no_check_timeout" int_or_var(n) := scope_no_param prod_of_symb prod_types ; verit_no_check_timeout n.

Tactic Notation "snipe_timeout" constr(t) int_or_var(n) := scope_param prod_of_symb prod_types t ; verit_timeout n.
Tactic Notation "snipe_timeout" int_or_var(n) := scope_no_param prod_of_symb prod_types ; verit_timeout n.

(** Preprocessing for first-order intuitionistic logic with no interpreted symbols **)

Definition tuple_def := (iff, not).

Ltac scope_param_intuitionistic t :=
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal impossible_term ; try (def_fix_and_pattern_matching_mono_param tuple_def t
ltac:(get_definitions_theories_no_generalize); inv_principle_all; inst) ;
get_projs_in_variables tuple_def.

Ltac scope_no_param_intuitionistic :=
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal impossible_term ; try (def_fix_and_pattern_matching tuple_def
ltac:(get_definitions_theories_no_generalize) ; inv_principle_all ; inst) ;
get_projs_in_variables tuple_def.


(** * Imp: Simple Imperative Programs *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.
From QuickChick Require Import QuickChick.
Import QcNotation QcDefaultNotation.
Require Export ExtLib.Structures.Monads.
Export MonadNotation. Open Scope monad_scope.
Open Scope qc_scope.
Require Import
        Coq.FSets.FMapList
        Coq.Structures.OrderedTypeEx
        Coq.FSets.FMapFacts.

Module Import M := FMapList.Make(String_as_OT).

(* Instantiate a map type using strings as keys *)
Module P := WProperties_fun String_as_OT M.
Module F := P.F.

(* Optionals are moands  *)
Instance option_monad : Monad option :=
  {
  ret X v := @Some X v;
  bind T U mt f :=
    match mt with
    | Some v => f v
    | None => None
  end
  }.

(* some list combinators *)
Fixpoint foldr {X B}
           (f : X -> B -> B) (b : B) (l : list X) : B :=
  match l with
  | [] => b
  | (x::l) => (f x (foldr f b l))
  end.

Definition andmap {X} (p : X -> bool) :=
  foldr (fun x b => (p x) && b) true.

Definition ormap {X} (p : X -> bool) :=
  foldr (fun x b => (p x) || b) false.

Fixpoint zip {X Y} (l1 : list X) (l2 : list Y)
  : list (X * Y) :=
  match l1, l2 with
  | _, [] => []
  | [], _ => []
  | (x::xs), (y::ys) => (x,y) :: (zip xs ys)
end.

Open Scope string_scope.
Instance string_arb : Gen string :=
  {
  arbitrary := ret "random"
  }.
Instance shrink_str : Shrink string :=
  {
  shrink s := []
  }.
Close Scope string_scope.

(* ================================================================= *)
(* Labels, for controlling priviledge *)

Inductive label : Type :=
  | Secret
  | Public.

Derive (Arbitrary, Show) for label.
Instance eq_dec_label (l1 l2 : label) : Dec (l1 = l2).
Proof. dec_eq. Defined.

(* Reflection setup *)
Definition label_eqb l1 l2 :=
  match l1, l2 with
| Secret, Secret => true
| Public, Public => true
| _, _ => false
  end.

Definition label_eqb_eq : forall l1 l2,
    label_eqb l1 l2 = true -> l1 = l2.
Proof.
  intros.
  destruct l1; destruct l2; auto; inversion H.
Qed.

Definition label_eqb_neq : forall l1 l2,
    label_eqb l1 l2 = false -> l1 <> l2.
Proof.
  intros.
  destruct l1; destruct l2; auto; congruence.
Qed.

Definition merge (l1 l2 : label) : label :=
  match l1, l2 with
  | Public, Public => Public
  | _, _ => Secret
  end.

(* Conjecture merge_secret : forall l, merge l Secret = Secret. *)
(* QuickChick merge_secret. *)

Theorem merge_secret : forall l1,
    merge l1 Secret = Secret.
Proof.
  intros. destruct l1; auto.
Qed.

Theorem merge_public : forall l1,
    merge l1 Public = l1.
Proof.
  intros.
  destruct l1; auto.
Qed.

Theorem merge_commutative : forall l1 l2,
    merge l1 l2 = merge l2 l1.
Proof.
  destruct l1; destruct l2; auto.
Qed.

(* This class drives the entire implementation of IFC-Imp *)

Class Distinguishable X :=
  {
  indist : X -> X -> Prop
  }.

Notation "x1 == x2" := (indist x1 x2)
                         (at level 40).

Definition value (X:Type) : Type := (X * label).

Instance value_indist {X} : Distinguishable (value X) :=
  {
  indist x1 x2 :=
    match x1, x2 with
    | (_, Secret), (_, Secret) => True
    | (n1, Public), (n2, Public) => n1 = n2
    | _, _ => False
    end
  }.

Definition nat_value : Type := value nat.

Instance dec_value_indist (v1 v2 : nat_value) :
  Dec (v1 == v2).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct v1. destruct v2.
  destruct l; destruct l0;
    try (right; auto; fail).
  - left. simpl. tauto.
  - destruct (Nat.eqb n n0) eqn:Heq.
    + apply Nat.eqb_eq in Heq.
      subst. left. simpl. auto.
    + apply Nat.eqb_neq in Heq. right. simpl. auto.
Qed.

Definition bool_value : Type := value bool.

Instance bool_value_indist (v1 v2 : bool_value) :
  Dec (v1 == v2).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct v1. destruct v2.
  destruct l; destruct l0;
    try (right; auto; fail).
  - left. simpl. tauto.
  - destruct (Bool.eqb b b0) eqn:Heq.
    + assert (b = b0).
      apply Bool.eqb_eq. unfold Is_true. rewrite Heq. tauto.
      subst. left. simpl. auto.
    + assert (b <> b0).
      apply Bool.eqb_false_iff. assumption.
      right. simpl. assumption.
Qed.

Definition state := M.t nat_value.
Close Scope string_scope.

Instance indist_state : Distinguishable state :=
  {
  indist s1 s2 := forall (x1 : string) (v1 v2: nat_value),
        (MapsTo x1 v1 s1 ->
         (exists (v2' : nat_value),
             MapsTo x1 v2' s2 /\ v1 == v2'))
        /\
        (MapsTo x1 v2 s2 ->
         exists (v1' : nat_value),
           MapsTo x1 v1' s1 /\ v1' == v2)
  }.

Theorem indist_comm : forall (st1 st2 : state),
    st1 == st2 -> st2 == st1.
Proof.
  intros.
  unfold "==". simpl.
  intros.
  split.
  - intros.
    simpl "==" in H. simpl in H.
    destruct H with
        (x1 := x1)
        (v1 := v2)
        (v2 := v1).
    destruct H2 as [v1']. assumption.
    clear H1. clear H.
    destruct H2.
    exists v1'. split.
    + assumption.
    + destruct v1'. destruct v1.
      destruct l; destruct l0;
        try assumption; auto.
  - intros.
    simpl "==" in H.
    destruct H with
        (x1 := x1)
        (v1 := v2)
        (v2 := v1).
    clear H2. clear H.
    destruct H1 as [v2']. assumption.
    destruct H.
    exists v2'. split.
    + assumption.
    + destruct v2'. destruct v2.
      destruct l; destruct l0;
        try assumption; auto.
Qed.

Theorem indist_trans : forall (st1 st2 st3 : state),
    st1 == st2 ->
    st2 == st3 ->
    st1 == st3.
Proof.
  intros.
  simpl "==". intros.
  split.
  - intros.
    simpl "==" in *.
    specialize (H x1 v1 v2).
    destruct H. destruct H as [v2']. assumption.
    destruct H. clear H2.
    specialize (H0 x1 v2' v2).
    destruct H0. destruct H0 as [ v2'0 ]. assumption.
    destruct H0. exists v2'0. split.
    + assumption.
    + destruct v1. destruct v2'0. destruct v2.
      destruct v2'.
      destruct l; destruct l0;
        destruct l1; destruct l2; try assumption;
          try tauto; try (exfalso; assumption);
            subst; auto.
  - intros.
    simpl "==" in *.
    specialize (H0 x1 v1 v2).
    destruct H0. destruct H2 as [v1']. assumption.
    destruct H2.
    specialize (H x1 v1 v1').
    destruct H. destruct H4 as [v2']. assumption.
    destruct H4. exists v2'. split.
    + assumption.
    + destruct v2'. destruct v2. destruct v1'. destruct v1.
      destruct l; destruct l0; destruct l1; destruct l2;
        try tauto;
        try (exfalso; assumption);
        subst; auto.
Qed.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : string)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Instance aexp_dec_eq (a1 a2 : aexp) :
  Dec (a1 = a2).
Proof. dec_eq. Defined.
Derive (Show, Shrink, Arbitrary) for aexp.

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).
Instance bexp_eq_dec (b1 b2 : bexp) :
  Dec (b1 = b2).
Proof. dec_eq. Defined.
Derive (Show, Shrink, Arbitrary) for bexp.

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Declare Custom Entry com.
Declare Scope com_scope.
Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
Notation "( x )" := x (in custom com, x at level 99) : com_scope.
Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
Notation "f x .. y" := (.. (f x) .. y)
                  (in custom com at level 0, only parsing,
                  f constr at level 0, x constr at level 9,
                  y constr at level 9) : com_scope.
Notation "x + y" := (APlus x y) (in custom com at level 50, left associativity).
Notation "x - y" := (AMinus x y) (in custom com at level 50, left associativity).
Notation "x * y" := (AMult x y) (in custom com at level 40, left associativity).
Notation "'true'"  := true (at level 1).
Notation "'true'"  := BTrue (in custom com at level 0).
Notation "'false'"  := false (at level 1).
Notation "'false'"  := BFalse (in custom com at level 0).
Notation "x <= y" := (BLe x y) (in custom com at level 70, no associativity).
Notation "x = y"  := (BEq x y) (in custom com at level 70, no associativity).
Notation "x && y" := (BAnd x y) (in custom com at level 80, left associativity).
Notation "'~' b"  := (BNot b) (in custom com at level 75, right associativity).

Open Scope com_scope.

Definition example_aexp : aexp := <{ 3 + (X * 2) }>.
Definition example_bexp : bexp := <{ true && ~(X <= 4) }>.

Close Scope string_scope.
(* ================================================================= *)
(** ** Evaluation *)

Inductive aevalR : state -> aexp -> nat_value -> Prop :=
  | A_Value : forall state (n : nat),
      aevalR state (ANum n) (n, Public)
  | A_Id : forall state x v,
      MapsTo x v state ->
      aevalR state (AId x) v
  | A_EPlus : forall state a1 a2 n1 n2 l1 l2,
      aevalR state a1 (n1, l1) ->
      aevalR state a2 (n2, l2) ->
      aevalR state <{a1 + a2}> (n1 + n2, merge l1 l2)
  | A_EMinus : forall state a1 a2 n1 n2 l1 l2,
      aevalR state a1 (n1, l1) ->
      aevalR state a2 (n2, l2) ->
      aevalR state <{a1 - a2}> (n1 - n2, merge l1 l2)
  | A_EMult : forall state a1 a2 n1 n2 l1 l2,
      aevalR state a1 (n1, l1) ->
      aevalR state a2 (n2, l2) ->
      aevalR state <{a1 * a2}> (n1 * n2, merge l1 l2).

Fixpoint aeval (fuel : nat) (st : state) (a : aexp) : option nat_value :=
  match fuel with
| 0 => None
| S n' => match a with
       | (ANum n) => Some (n, Public)
       | (AId x) => find x st
       | (APlus a1 a2) =>
         '(n1, l1) <- aeval n' st a1;;
         '(n2, l2) <- aeval n' st a2;;
         ret (n1 + n2, merge l1 l2)
       | (AMinus a1 a2) =>
         '(n1, l1) <- aeval n' st a1;;
         '(n2, l2) <- aeval n' st a2;;
         ret (n1 - n2, merge l1 l2)
       | (AMult a1 a2) =>
         '(n1, l1) <- aeval n' st a1;;
         '(n2, l2) <- aeval n' st a2;;
         ret (n1 * n2, merge l1 l2)
         end
  end.

Theorem aeval_implies_aevalR : forall fuel st a v,
    aeval fuel st a = Some v ->
    aevalR st a v.
Proof.
  intros.
  generalize dependent st.
  generalize dependent fuel.
  generalize dependent v.
  induction a; intros;
    try destruct fuel; try (inversion H).
  - apply A_Value.
  - apply A_Id. apply find_2. assumption.
  - destruct (aeval fuel st a1) eqn:Heq1.
    + destruct n as [n1 l2].
      destruct (aeval fuel st a2) eqn:Heq2.
      * destruct n as [n2 l3].
        injection H1. intros. subst.
        apply A_EPlus.
        -- eapply IHa1. eauto.
        -- eapply IHa2. eauto.
      * congruence.
    + congruence.
  - destruct (aeval fuel st a1) eqn:Heq1.
    + destruct n as [n1 l2].
      destruct (aeval fuel st a2) eqn:Heq2.
      * destruct n as [n2 l3].
        injection H1. intros. subst.
        apply A_EMinus.
        -- eapply IHa1. eauto.
        -- eapply IHa2. eauto.
      * congruence.
    + congruence.
  - destruct (aeval fuel st a1) eqn:Heq1.
    + destruct n as [n1 l2].
      destruct (aeval fuel st a2) eqn:Heq2.
      * destruct n as [n2 l3].
        injection H1. intros. subst.
        apply A_EMult.
        -- eapply IHa1. eauto.
        -- eapply IHa2. eauto.
      * congruence.
    + congruence.
Qed.

Inductive bevalR : state -> bexp -> bool_value -> Prop :=
  | E_True : forall st,
      bevalR st <{true}> (true, Public)
  | E_False : forall st,
      bevalR st <{false}> (false, Public)
  | E_Eq : forall st a1 a2 n1 n2 l1 l2,
      aevalR st a1 (n1, l1) ->
      aevalR st a2 (n2, l2) ->
      bevalR st <{a1 = a2}> (n1 =? n2, merge l1 l2)
  | E_Lt : forall st a1 a2 n1 n2 l1 l2,
      aevalR st a1 (n1, l1) ->
      aevalR st a2 (n2, l2) ->
      bevalR st <{a1 <= a2}> (n1 <=? n2, merge l1 l2)
  | E_not__true : forall st b l1,
      bevalR st b (true, l1) ->
      bevalR st <{~ b}> (false, l1)
  | E_not__false : forall st b l1,
      bevalR st b (false, l1) ->
      bevalR st <{~ b}> (true, l1)
  | E_and : forall st b1 b2 bool1 bool2 l1 l2,
      bevalR st b1 (bool1, l1) ->
      bevalR st b2 (bool2, l2) ->
      bevalR st <{b1 && b2}> (bool1 && bool2, merge l1 l2).

Definition empty_st : state := (M.empty nat_value).

Notation "x '!->' v" := (add x v (M.empty nat_value))
                          (at level 100).
Example aexp0 :
  aevalR (X !-> (5, Public)) <{ X * 2 }> (10, Public).
Proof.
  replace (10, Public) with (5 * 2, merge Public Public).
  apply A_EMult.
  apply A_Id.
  apply find_2. auto.
  apply A_Value.
  auto.
Qed.

Example aexp1 :
    aevalR (X !-> (5, Public)) <{ (3 + (X * 2))}> (13, Public).
Proof.
  replace (13, Public) with (3 + 10, merge Public Public).
  apply A_EPlus.
  apply A_Value.
  replace (10, Public) with (5 * 2, merge Public Public).
  apply A_EMult.
  apply A_Id.
  apply find_2. auto.
  apply A_Value.
  auto.
  auto.
Qed.

Example bexp1 :
  bevalR (X !-> (5, Secret)) <{ true && ~(X <= 4)}>
  (true, Secret).
Proof.
  replace (true, Secret) with
      (true && true, merge Public Secret).
  apply E_and.
  apply E_True.
  apply E_not__false.
  replace (false, Secret) with
      (5 <=? 4, merge Secret Public).
  apply E_Lt.
  apply A_Id. apply find_2. auto.
  apply A_Value.
  auto.
  auto.
Qed.

(* ################################################################# *)
(** * Commands *)

(* ================================================================= *)
(** ** Syntax *)

Inductive com : Type :=
  | CSkip
  | CAss (x : string) (a : aexp) (l : label)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com).
  (* | CWhile (b : bexp) (c : com). *)

Fixpoint com_indist_f c1 c2 :=
  match c1, c2 with
| CSkip, CSkip => True
| CAss x1 a1 Public, CAss x2 a2 Public =>
  x1 = x2 /\ a1 = a2
| CAss x1 a1 Secret, CAss x2 a2 Secret => x1 = x2
| CSeq c1 c2, CSeq c1' c2' =>
  com_indist_f c1 c1' /\ com_indist_f c2 c2'
| CIf b c1 c2, CIf b' c1' c2' =>
  b = b' /\ com_indist_f c1 c1' /\ com_indist_f c2 c2'
| _, _ => False
  end.

Instance com_indist : Distinguishable com :=
  {
  indist := com_indist_f
  }.

Notation "'skip'"  :=
         CSkip (in custom com at level 0) : com_scope.
Notation "x ':=' y ',' l"  :=
         (CAss x y l)
           (in custom com at level 0,
               x constr at level 0,
                y at level 85,
                no associativity) : com_scope.
Notation "x ; y" :=
         (CSeq x y)
           (in custom com at level 90, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
           (in custom com at level 89, x at level 99,
            y at level 99, z at level 99) : com_scope.
(* Notation "'while' x 'do' y 'end'" := *)
(*          (CWhile x y) *)
(*             (in custom com at level 89, x at level 99, y at level 99) : com_scope. *)

Reserved Notation
         "st '=[' c ']=>' st'"
         (at level 40, c custom com at level 99,
          st constr, st' constr at next level).

Definition sec_context : Type := (state * label).

Instance sec_context_indist : Distinguishable sec_context :=
  {
  indist c1 c2 :=
    match c1, c2 with
    | (s1, l1), (s2, l2) => l2 = l1  /\ indist s1 s2
    end
  }.

Definition merge_list (l : list label) : label :=
  foldr (fun l1 l2 => merge l1 l2) Public l.

Definition writing_valid (x : string) (st : state) (l : label)
  : Prop :=
  (exists (n' : nat) (l' : label),
      l = l' /\
      MapsTo x (n', l') st).

Inductive ceval : com -> sec_context -> sec_context -> Prop :=
  | E_Skip : forall ctxt,
      ctxt=[ skip ]=> ctxt
  | E_Ass  : forall (st : M.t nat_value) a n x l l__v l__s,
      aevalR st a (n, l__v) ->
      In x st ->
      writing_valid x st (merge l__v l) ->
      (st,l) =[ x := a , l__s ]=>
      (add x (n, merge_list [l__v;l__s; l]) st, l)
  | E_Seq : forall c1 c2 ctxt ctxt' ctxt'',
      ctxt  =[ c1 ]=> ctxt'  ->
      ctxt' =[ c2 ]=> ctxt'' ->
      ctxt  =[ c1 ; c2 ]=> ctxt''
  | E_IfTrue : forall st st' b l__guard l__begin c1 c2,
      bevalR st b (true, l__guard) ->
      (st, merge l__begin l__guard) =[ c1 ]=>
    (st', l__begin ) ->
      (st,l__begin) =[ if b then c1 else c2 end]=> (st', l__begin)
  | E_IfFalse : forall st st' l__guard l__begin b c1 c2,
      bevalR st b (false, l__guard) ->
      (st, merge l__begin l__guard) =[ c2 ]=>
    (st', merge l__begin l__guard) ->
      (st, l__begin) =[ if b then c1 else c2 end]=> (st', l__begin)
  where "st =[ c ]=> st'" := (ceval c st st').
  (* | E_WhileFalse : forall b st c, *)
  (*     beval st b = false -> *)
  (*     st =[ while b do c end ]=> st *)
  (* | E_WhileTrue : forall st st' st'' b c, *)
  (*     beval st b = true -> *)
  (*     st  =[ c ]=> st' -> *)
  (*     st' =[ while b do c end ]=> st'' -> *)
  (*     st  =[ while b do c end ]=> st'' *)

Definition default_ctxt (xs : list (string * label)) :
  sec_context :=

  let st :=
      foldr (fun '(x, l) st => add x (0, l) st)
            (M.empty nat_value) xs in
  (st, Public).

Definition v_eq (v1 v2 : nat_value) : bool :=
  match v1, v2 with
  | (n1, l1), (n2, l2) => (l1 = l2 ?) && (n1 =? n2)
  end.

Definition build_st (entries : list (string * (nat * label)))
  : M.t nat_value :=
  foldr
    (fun '(key, value) m' => add key value m')
    (empty nat_value)
    entries.

Definition ceval_example1state : sec_context :=
  default_ctxt [(X, Public); (Y, Public); (Z, Public)].

Example ceval_example1:
  ceval_example1state =[
     X := 2, Public;
     if (X <= 1)
       then Y := 3, Public
       else Z := 4, Public
     end
  ]=> (build_st [(Z, (4, Public));(X, (2, Public)); (Y, (0, Public))], Public).
Proof.
  remember (add X (0, Public) (add Y (0, Public) (Z !-> (0, Public)))).
  eapply E_Seq.
  - eapply E_Ass.
    + simpl. rewrite <- Heqt0.
      exact (A_Value t0 2).
    + simpl. apply mem_2. auto.
    + simpl. rewrite <- Heqt0.
      unfold writing_valid.
      Admitted.

Lemma public_indist : forall {X} (n : X),
    (n, Public) == (n, Public).
Proof.
  intros.
  unfold indist. simpl.
  reflexivity.
Qed.

Lemma secret_indist : forall {X} (n1 n2 : X),
    (n1, Secret) == (n2, Secret).
Proof.
  intros.
  unfold indist. simpl. tauto.
Qed.

Lemma diff_dist : forall {X} (n1 n2 : X),
    not ((n1, Secret) == (n2, Public)).
Proof.
  intros. unfold not. intros.
  unfold indist in H. simpl in H.
  auto.
Qed.

Lemma indist_commut :
  forall {X:Type} `{forall (x1 x2 : X), Dec (x1 = x2)}
    (n1 n2 : X) (l1 l2 : label),
    (n1, l1) == (n2, l2) ->
    (n2, l2) == (n1, l1).
Proof.
  intros.
  unfold indist in H. simpl in H0.
  destruct l1; destruct l2.
  - apply secret_indist.
  - apply H0.
  - apply H0.
  - specialize (H n1 n2). destruct H.
    destruct dec.
    + rewrite H0. apply public_indist.
    + congruence.
Qed.

Lemma MapsTo_eq :
  forall (st : state) (x : string) (v1 v2 : nat_value),
    MapsTo x v1 st ->
    MapsTo x v2 st ->
    v1 = v2.
Proof.
  intros.
  apply find_1 in H.
  apply find_1 in H0. rewrite H0 in H. injection H.
  intros. auto.
Qed.

Lemma map_add_eq :
  forall (st : state) (x : string) (v1 v2 : nat_value),
    MapsTo x v1 (add x v2 st) ->
    v1 = v2.
Proof.
  intros.
  assert (MapsTo x v2 (add x v2 st)).
  {
    apply add_1. reflexivity.
  }
  apply MapsTo_eq with (st := add x v2 st) (x := x);
    assumption.
Qed.

Lemma indist_implies_indist :
  forall (st1 st2 : state) (x : string) (v1 v2 : nat_value),
    st1 == st2 ->
    MapsTo x v1 st1 ->
    MapsTo x v2 st2 ->
    v1 == v2.
Proof.
  intros. simpl "==" in H.
  specialize (H x v1 v2).
  destruct H. destruct H as [v2']. assumption.
  destruct H.
  replace v2' with v2 in *.
  - destruct v1. destruct v2.
    destruct l; destruct l0;
      try tauto;
      try (exfalso; assumption);
      subst; auto.
  - apply MapsTo_eq with (st := st2) (x := x);
      assumption.
Qed.

Theorem indist_split : forall {X} (n1 n2 : X) (l1 l2 : label),
    (n1, l1) == (n2, l2) ->
    (l1 = Secret /\ l2 = Secret) \/
    (l1 = Public /\ l2 = Public /\ n1 = n2).
Proof.
  intros.
  destruct l1; destruct l2;
    auto;
    contradict H.
Qed.

Theorem aexp_EENI :
  forall (st1 st2 : state) (a : aexp) (v1 v2 : nat_value),
    st1 == st2 ->
    aevalR st1 a v1 ->
    aevalR st2 a v2 ->
    v1 == v2.
Proof.
  intros.
  generalize dependent v1.
  generalize dependent v2.
  induction a; intros;
    inversion H0; inversion H1; subst;
    try (
       assert ((n1, l1) == (n0, l0)); auto;
    assert ((n2, l2) == (n3, l3)); auto;
    apply indist_split in H2;
    apply indist_split in H3;
    destruct H2; destruct H3;
      destruct H2 as [Hl1 Hl0];
      destruct H3 as [Hl2 Hl3];
      subst; simpl; try tauto;
        destruct Hl0; subst; simpl; try tauto;
          destruct Hl3; subst; simpl; tauto).
  - apply public_indist.
  - eapply indist_implies_indist.
    apply H. apply H4. apply H8.
Qed.

Theorem bexp_EENI :
  forall (st1 st2 : state) (b : bexp) (v1 v2 : bool_value),
    st1 == st2 ->
    bevalR st1 b v1 ->
    bevalR st2 b v2 ->
    v1 == v2.
Proof.
  intros.
  generalize dependent v1.
  generalize dependent v2.
  induction b; intros;
    inversion H0; inversion H1; subst;
      try (apply public_indist).
  -
    assert ((n1, l1) == (n0, l0)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a1); assumption.
    assert ((n2, l2) == (n3, l3)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a2); assumption.
    apply indist_split in H2.
    apply indist_split in H3.
    destruct H2; destruct H3;
      destruct H2; destruct H3; subst; simpl; try tauto;
        destruct H4; subst; simpl; try tauto;
          destruct H6; subst; auto; tauto.
  - assert ((n1, l1) == (n0, l0)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a1); assumption.
    assert ((n2, l2) == (n3, l3)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a2); assumption.
    apply indist_split in H2.
    apply indist_split in H3.
    destruct H2; destruct H3;
      destruct H2; destruct H3; subst; simpl; try tauto;
        destruct H4; subst; simpl; try tauto;
          destruct H6; subst; simpl; tauto.
  - assert ((true, l1) == (true, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2. destruct H3. subst. apply public_indist.
  - assert ((true, l1) == (false, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2 as [_ [_ Contra]]. congruence.
  - assert ((false, l1) == (true, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2 as [_ [_ Contra]]. congruence.
  - assert ((false, l1) == (false, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2 as [H21 [H22 H23]].
      subst. simpl. tauto.
  - assert ((bool1, l1) == (bool0, l0)).
    apply IHb1; assumption.
    assert ((bool2, l2) == (bool3, l3)).
    apply IHb2; assumption.
    apply indist_split in H2.
    apply indist_split in H3.
    destruct H2; destruct H3;
      destruct H2; destruct H3; subst; simpl; try tauto;
        destruct H4; subst; simpl; try tauto.
    destruct H6. subst. simpl. tauto.
Qed.

Theorem secret_doms : forall (ls : list label),
    List.In Secret ls ->
    merge_list ls = Secret.
Proof.
  intros.
  unfold merge_list.
  induction ls as [| l ls' IH].
  - inversion H.
  - destruct l.
    + auto.
    + assert (List.In Secret ls').
      {
        inversion H.
        + congruence.
        + assumption.
      }
      simpl.
      assert
        ((foldr (fun l1 l2 : label => merge l1 l2) Public ls')
         = Secret).
      apply IH. assumption.
      rewrite H1. reflexivity.
Qed.

Theorem map_add_congruence : forall (l1 l2 : label) (n1 n2 : nat)
                               (st : state) (x : string),
    l1 <> l2 ->
    MapsTo x (n1, l1) (add x (n2, l2) st) ->
    False.
Proof.
  intros.
  assert (MapsTo x (n2, l2) (add x (n2, l2) st)).
  {
    apply add_1. auto.
  }
  assert ((n1, l1) = (n2, l2)).
  {
    apply MapsTo_eq with
        (st := (add x (n2, l2) st))
        (x := x); auto.
  }
  injection H2. intros. congruence.
Qed.

(* the no wrote down rule is sound*)
Theorem add_secret :
  forall (x : string) (n : nat) (st : state),
    writing_valid x st Secret ->
    st == (add x (n, Secret) st).
Proof.
  intros.
  unfold writing_valid in H.
  destruct H as [n']. destruct H as [l']. destruct H.
  subst. simpl "==". intros.
  destruct (String.eqb x x1) eqn:Heq.
  - apply String.eqb_eq in Heq.
    split.
    + intros. exists (n, Secret).
      split; subst.
      * apply add_1. auto.
      * destruct v1. destruct l.
        -- tauto.
        -- assert ((n', Secret) = (n0, Public)).
           {
             apply MapsTo_eq with (st := st) (x := x1);
               assumption.
           }
           injection H1. intros. congruence.
    + intros. subst.
      exists (n', Secret). destruct v1. destruct v2.
      split.
      * assumption.
      * destruct l; destruct l0;
          try tauto; try (exfalso; assumption);
            apply map_add_congruence with
                (l1 := Public)
                (l2 := Secret)
                (n1 := n1)
                (n2 := n)
                (st := st)
                (x := x1); auto; discriminate.
  - apply String.eqb_neq in Heq.
    split.
    + intros. exists v1. split.
      * apply add_2; assumption.
      * destruct v1. destruct l; auto.
    + intros. exists v2. split.
      * apply add_3 with (x := x) (e' := (n, Secret)); auto.
      * destruct v2. destruct l; auto.
Qed.

Theorem add_indist :
  forall (x : string) (v1 v2 : nat_value) (st1 st2 : state),
    st1 == st2 ->
    v1 == v2 ->
    (add x v1 st1) == (add x v2 st2).
Proof.
  intros x v1 v2 st1 st2 Hstindist Hvindist.
  simpl "==". intros.
  destruct (String.eqb x x1) eqn:Heqx.
  - apply String.eqb_eq in Heqx.
    split.
    + intros. subst.
      apply MapsTo_eq with (v1 := v1) in H.
      * subst. exists v2. split.
        -- apply add_1. auto.
        -- destruct v0. destruct v2.
           destruct l; destruct l0;
             inversion Hvindist; auto.
      * apply add_1. auto.
    + intros. subst.
      apply MapsTo_eq with (v1 := v2) in H.
      * subst. exists v1. split.
        -- apply add_1. auto.
        -- destruct v1. destruct v3.
           destruct l; destruct l0;
             inversion Hvindist; auto.
      * apply add_1. auto.
  - apply String.eqb_neq in Heqx.
    split.
    + intros.
      apply add_3 with (x := x) (e' := v1) in H.
      simpl "==" in Hstindist.
      specialize (Hstindist x1 v0 v2).
      destruct Hstindist. destruct H0 as [v2']. assumption.
      destruct H0. exists v2'.
      split.
      * apply add_2 with
            (x := x)
            (e' := v2) in H0; assumption.
      * destruct v0. destruct v2'.
        destruct l; destruct l0;
          auto; exfalso; auto.
      * assumption.
    + intros.
      apply add_3 with (x := x) (e' := v2) in H.
      simpl "==" in Hstindist.
      specialize (Hstindist x1 v0 v3).
      destruct Hstindist.
      destruct H1 as [v1']. assumption.
      destruct H1.
      exists v1'. split.
      * apply add_2 with (x := x) (e' := v1) in H1;
          assumption.
      * destruct v1'. destruct v3.
        destruct l; destruct l0;
          auto; exfalso; auto.
      * assumption.
Qed.

Ltac secret_merge :=
  symmetry; apply secret_doms; simpl; auto.

Ltac open_indist H :=
  unfold "==" in H; simpl in H.

Lemma indist_f : forall (c1 c2 : com),
    com_indist_f c1 c2 ->
    c1 == c2.
Proof.
  intros. unfold "==". simpl. assumption.
Qed.

Theorem com_indist_refl : forall (c : com),
    c == c.
Proof.
  intros. induction c;
            unfold "=="; simpl; try tauto.
  - destruct l; auto.
Qed.

Theorem state_indist_refl : forall (st : state),
    st == st.
Proof.
  intros.
  simpl "==".
  intros.
  split; intros.
  - exists v1. split. auto.
    destruct v1. destruct l; auto.
  - exists v2. split. auto.
    destruct v2. destruct l; auto.
Qed.

Lemma ctxt_split : forall (st1 st2 : state) (l1 l2 : label),
    (st1, l1) == (st2, l2) ->
    st1 == st2 /\ l1 = l2.
Proof.
  intros.
  unfold "==" in *. simpl in *.
  destruct H. subst. split; auto.
Qed.

Theorem ctxt_indist_refl : forall (ctxt : sec_context),
    ctxt == ctxt.
Proof.
  intros. unfold "==". simpl.
  destruct ctxt. split.
  - reflexivity.
  - apply state_indist_refl.
Qed.

Lemma indist_neq_secret : forall {X} (x1 x2 : X) (l1 l2 : label),
    x1 <> x2 ->
    (x1, l1) == (x2, l2) ->
    l1 = l2 /\ l1 = Secret.
Proof.
  intros. unfold "==" in *. simpl in *.
  destruct l1; destruct l2;
    auto; exfalso; auto.
Qed.

Lemma indist_samelabel : forall {X} (x1 x2 : X) (l1 l2 : label),
    (x1, l1) == (x2, l2) ->
    l1 = l2.
Proof.
  intros.
  unfold "==" in H. simpl in H.
  destruct l1; destruct l2; subst;
    auto; exfalso; auto.
Qed.

Ltac simpl_indist :=
  unfold "=="; simpl; split; auto.

Theorem label_const : forall c (st st' : state) (l l' : label),
    (st, l) =[ c ]=> (st', l') ->
    l = l'.
Proof.
  intros c.
  induction c; intros.
  - inversion H. auto.
  - inversion H. subst. auto.
  - inversion H. subst.
    rename l' into l''.
    rename st' into st''.
    destruct ctxt' as [ st' l' ].
    assert (l = l').
    {
      apply IHc1 with (st := st) (st' := st').
      assumption.
    }
    subst.
    apply IHc2 with (st := st') (st' := st'').
    assumption.
  - inversion H; subst; auto.
Qed.

Theorem secret_step : forall (c : com) (st st': state),
    (st, Secret) =[ c ]=> (st', Secret) ->
    st == st'.
Proof.
  intros c.
  induction c; intros.
  - inversion H. subst. apply state_indist_refl.
  - inversion H. subst.
    replace (merge_list [l__v; l; Secret]) with Secret in *.
    + apply add_secret.
      replace (merge l__v Secret) with Secret in *.
      assumption.
      destruct l__v; auto.
    + symmetry. apply secret_doms. simpl. auto.
  - rename st' into st''.
    inversion H. subst.
    destruct ctxt' as [ st' l ].
    destruct l.
    + apply indist_trans with (st2 := st').
      * apply IHc1. assumption.
      * apply IHc2. assumption.
    + assert (Secret = Public).
      {
        apply (label_const c1 st st'). assumption.
      }
      congruence.
  - inversion H; subst;
      replace (merge Secret l__guard) with Secret in *;
      auto.
Qed.

Theorem leak_step : forall (c : com) (st st' : state),
    (st, Secret) =[ c ]=> (st', Public) -> False.
Proof.
  intros.
  generalize dependent st.
  generalize dependent st'.
  induction c; intros; inversion H.
  - inversion H. subst. destruct ctxt'.
    destruct l.
    + eapply IHc2. eauto.
    + eapply IHc1. eauto.
Qed.

Lemma indist_diff_label : forall (st1 st2 : state) (n1 n2 : nat)
                            (l1 l2 : label) (x : string),
    st1 == st2 ->
    l1 <> l2 ->
    MapsTo x (n1, l1) st1 ->
    MapsTo x (n2, l2) st2 ->
    False.
Proof.
  intros.
  simpl "==" in H.
  specialize (H x (n1, l1) (n2, l2)). destruct H.
  destruct H as [v2']. assumption.
  destruct H.
  replace v2' with (n2, l2) in *.
  - destruct l1; destruct l2;
      try tauto;
      try (exfalso; assumption).
  - apply MapsTo_eq with (st := st2) (x := x); assumption.
Qed.

Theorem aeval_diverges : forall (a : aexp) (st1 st2 : state)
                           (l1 l2 : label) (n1 n2 : nat),
    st1 == st2 ->
    n1 <> n2 ->
    aevalR st1 a (n1, l1) ->
    aevalR st2 a (n2, l2) ->
    l1 = Secret /\ l2 = Secret.
Proof.
  intros.
  destruct (label_eqb l1 l2) eqn:Heq.
  - apply label_eqb_eq in Heq.
    subst.
    assert ((n1, l2) == (n2, l2)).
    eapply aexp_EENI; eauto.
    simpl "==" in H3. destruct l2.
    + auto.
    + congruence.
  - apply label_eqb_neq in Heq.
    assert ((n1, l1) == (n2, l2)).
    eapply aexp_EENI; eauto.
    simpl "==" in H3.
    destruct l1; destruct l2;
      auto; exfalso; auto.
Qed.

Theorem beval_diverges : forall (b : bexp) (st1 st2 : state)
                           (l1 l2 : label) (b1 b2 : bool),
    st1 == st2 ->
    bevalR st1 b (b1, l1) ->
    bevalR st2 b (b2, l2) ->
    b1 <> b2 ->
    l1 = Secret /\ l2 = Secret.
Proof.
  intros.
  destruct (label_eqb l1 l2) eqn:Heq.
  - apply label_eqb_eq in Heq.
    subst.
    assert ((b1, l2) == (b2, l2)).
    eapply bexp_EENI; eauto.
    simpl "==" in H3. destruct l2.
    + auto.
    + congruence.
  - apply label_eqb_neq in Heq.
    assert ((b1, l1) == (b2, l2)).
    eapply bexp_EENI; eauto.
    simpl "==" in H3.
    destruct l2; destruct l1; auto; exfalso; auto.
Qed.

Ltac brute l1 l2 :=
  destruct l1; destruct l2;
  auto; exfalso; auto.

Theorem com_EENI :
  forall (c1 c2 : com)
    (ctxt1 ctxt2 ctxt1' ctxt2' : sec_context),
    c1 == c2 ->
    ctxt1 == ctxt2 ->
    ctxt1 =[ c1 ]=> ctxt1' ->
    ctxt2 =[ c2 ]=> ctxt2' ->
    ctxt1' == ctxt2'.
Proof.
  intros c1.
  induction c1; intros.
  - inversion H1. subst. unfold "==" in H. simpl in H.
    destruct c2 eqn:Hc2;
      try (exfalso; assumption).
    + subst. inversion H2. subst. assumption.
  - unfold "==" in H. simpl in H.
    destruct c2 eqn:Hc2;
      try (destruct l; exfalso; assumption).
    + subst.
      destruct l; destruct l0;
        try (exfalso; assumption).
      * inversion H1. subst. inversion H2. subst.
        replace (merge_list [l__v; Secret; l]) with Secret in *;
          try secret_merge.
        replace (merge_list [l__v0; Secret; l0]) with Secret in *;
          try secret_merge.
        -- inversion H0. subst.
           unfold "==". simpl. split.
           ++ reflexivity.
           ++ apply add_indist. assumption.
              apply secret_indist.
      * destruct H. subst. inversion H1. inversion H2. subst.
        inversion H0. subst.
        assert (l__v0 = l__v).
        {
          assert ((n, l__v) == (n0, l__v0)).
          apply aexp_EENI with
              (st1 := st)
              (st2 := st0)
              (a := a0); assumption.
          unfold "==" in H. simpl in H.
          destruct l__v; destruct l__v0; auto; exfalso; assumption.
        }
        subst.
        destruct l eqn:Hl.
        -- split. reflexivity.
           apply add_indist.
           assumption.
           destruct l__v; simpl; tauto.
        -- destruct l__v.
           ++ unfold "==". simpl. split. auto.
              apply add_indist. assumption.
              simpl. tauto.
           ++ unfold "==". simpl. split. auto.
              apply add_indist. assumption.
              simpl. assert ((n, Public) == (n0, Public)).
              apply aexp_EENI with
                  (st1 := st)
                  (st2 := st0)
                  (a := a0); assumption.
              unfold "==" in H. simpl in H. subst.
              auto.
  - open_indist H. destruct c2;
                     try (exfalso; assumption).
    + inversion H1. inversion H2. subst.
      assert (ctxt' == ctxt'0) as Hindist1.
      {
        apply IHc1_1 with
            (c2 := c2_1)
            (ctxt1 := ctxt1)
            (ctxt2 := ctxt2); try assumption.
        inversion H. unfold "==". simpl. assumption.
      }
      apply IHc1_2 with
          (c2 := c2_2)
          (ctxt1 := ctxt')
          (ctxt2 := ctxt'0); try assumption.
      inversion H. unfold "==". simpl. assumption.
  - (* Conditionals *)
    destruct c2; try inversion H.
    inversion H. subst.
    clear H5 H6. destruct H4.
    apply indist_f in H3.
    apply indist_f in H4.
    destruct ctxt1 as [ st1 l1 ].
    destruct ctxt2 as [ st2 l2 ].
    destruct ctxt1' as [ st1' l1' ].
    destruct ctxt2' as [ st2' l2' ].
    apply ctxt_split in H0. destruct H0. subst.
    inversion H1; inversion H2;
      destruct l2'; subst.
    + (* both eval to true, secret *)
      replace l__guard0 with l__guard in *.
      * replace (merge Secret l__guard) with Secret in *.
        -- apply IHc1_1 with
               (c2 := c2_1)
               (ctxt1 := (st1, Secret))
               (ctxt2 := (st2, Secret));
             try assumption. simpl_indist.
        -- auto.
      * apply indist_samelabel with
            (x1 := true) (x2 := true).
        apply bexp_EENI with (st1 := st1) (st2 := st2)
                             (b := b0);
          assumption.
    + (* both eval to true, public *)
      replace l__guard0 with l__guard in *.
      * eapply IHc1_1; eauto.
        simpl "==".
        split.
        -- destruct l__guard; auto.
        -- assumption.
      * assert ((true, l__guard) == (true, l__guard0)).
        eapply bexp_EENI; eauto.
        simpl "==" in H5.
        destruct l__guard; destruct l__guard0;
          auto; exfalso; auto.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst. simpl in H13. simpl in H22.
      apply secret_step in H13.
      apply secret_step in H22.
      clear H1. clear H2. clear H7. clear H16. clear H.
      clear H3. clear H4.
      assert (st1 == st2').
      {
        eapply indist_trans.
        apply H0. apply H22.
      }
      apply indist_comm in H13.
      assert (st1' == st2').
      {
        eapply indist_trans.
        apply H13. assumption.
      }
      simpl "==". split. auto. apply H1.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst.
      simpl in H13. simpl in H22.
      exfalso. eapply leak_step. apply H13.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst.
      simpl in H13. simpl in H22.
      clear H1. clear H2. clear H7. clear H16. clear H.
      clear H3. clear H4.
      apply secret_step in H13. apply secret_step in H22.
      assert (st1 == st2').
      {
        eapply indist_trans.
        apply H0. apply H22.
      }
      apply indist_comm in H13.
      assert (st1' == st2').
      {
        eapply indist_trans.
        apply H13. assumption.
      }
      simpl "==". split. auto. apply H1.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst.
      simpl in H13. simpl in H22.
      exfalso. eapply leak_step. apply H22.
    + replace (merge Secret l__guard) with Secret in *.
      replace (merge Secret l__guard0) with Secret in *.
      * eapply IHc1_2; eauto.
        simpl "==". split. auto. assumption.
      * destruct l__guard0; auto.
      * destruct l__guard; auto.
    + replace l__guard0 with l__guard in *.
      destruct l__guard.
      * simpl in H13. simpl in H22.
        apply secret_step in H13. apply secret_step in H22.
        assert (st1 == st2').
        eapply indist_trans.
        apply H0. apply H22.
        apply indist_comm in H13.
        assert (st1' == st2').
        eapply indist_trans.
        apply H13. assumption. simpl. split. auto.
        assumption.
      * simpl in H13. simpl in H22.
        assert ((st1, Public) == (st2, Public)).
        simpl. split. auto. assumption.
        eapply IHc1_2; eauto.
      * assert ((false, l__guard) == (false, l__guard0)).
        eapply bexp_EENI; eauto. simpl in H5.
        brute l__guard l__guard0.
Qed.


(*
  Verificación Formal - Unam 2020-2
  Ciro Iván García López
  Proyecto 1. Session Type Systems Verification
*)
From PROYI Require Import  Defs_Typing.
From PROYI Require Import  Defs_Process.
From PROYI Require Import  Defs_Proposition.
From Coq Require Import Strings.String.
From PROYI Require Import Props_Process.

(*
Lo siguientes lemas son intuitivamente ciertos, sin embargo su prueba
es difícil teniendo en cuenta que necesitan la idea que x aparece en P para que la operación  Close_Rec i x P tenga sentido.
*)
Lemma Close_Rec_Eq_Subst :
forall (P Q : Prepro)(x y : Name)( i: nat),
Process P -> Process Q ->
Close_Rec i x P = Close_Rec i y Q ->
P = {x\y} Q.
Proof.
Admitted.

Lemma Eq_Change_Var_Close :
forall (P : Prepro)(x y : Name),
Close x P = Close y ({y\x}P).
Admitted.

(*
*)
Lemma Char_Red_Arr :
forall (u x: Name)(P Q0 Q1 : Prepro),
( ((u !· Close x P) ↓ Q0) --> Q1 ) ->
(exists (Q2 : Prepro), ( Q1 = ((u !· Close x P) ↓ Q2) /\ Q0 --> Q2 )).
Proof.
  intros.
  inversion H; subst.
  + admit.
  + exists R.
    split; auto.
Admitted.

(*
Los siguientes lemas apoyan la prueba del teorema 2.1, determinan que algunos de los casos no se reducen a algo.
*)
Lemma No_Red_AX1 :
forall (x y : Name)(Q : Prepro),
~([x ←→  y] --> Q ).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX2 :
forall (x y : Name)(P Q : Prepro),
~ ((x !· Close_Rec 0 y P) --> Q).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX4 :
forall (x : Name)(P Q: Prepro),
~( (x · P) --> Q ).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

Check No_Red_AX4.

(*
*)
Lemma No_Red_AX51 :
forall (x y : Name)(P Q R: Prepro),
~( (x « y »· (P ↓ Q)) --> R ).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX52 :
forall (x : Name)(P Q: Prepro),
(P = Q ) -> (Open_Rec 0 x P = Open_Rec 0 x Q).
Proof.
  intros.
  rewrite <- H.
  auto.
Qed.

(*
*)
Lemma No_Red_AX55 :
forall ( x y : Name),
Process_Name x -> Process_Name y -> (Open_Name 0 x (Close_Name 0 y y)) = x.
Proof.
  intros.
  inversion H; inversion H0; subst.
  specialize (string_dec x1 x1) as HX.
  destruct HX.
  + specialize (Str_True x1 x1) as HB.
    simpl.
    rewrite HB; auto.
  + contradiction.
Qed.

(*
*)
Lemma No_Red_AX5 :
forall (x y : Name)(P Q R: Prepro),
Process_Name x -> Process_Name y -> Process P -> Process Q ->
~( (ν Close_Rec 0 y (x « y »· (P ↓ Q))) --> R ).
Proof.
  unfold not.
  intros.
  inversion H3; subst.
  apply (No_Red_AX52 x0 _ _ ) in H4.
  unfold Close in H4.
  rewrite Eq_Subs_Close in H4; auto.
  simpl in H4.
  specialize (Close_Name_Output 0 y x) as HX.
  rewrite No_Red_AX55 in H4; auto.
  rewrite Eq_Subs_Close in H4; auto.
  rewrite Eq_Subs_Close in H4; auto.
  do 3 rewrite Ax_Alpha in H4.
  rewrite H4 in H8.
  destruct HX;
    try rewrite H9 in H8;
    try specialize (Open_PName_Output 0 x0 x) as HX || specialize (Open_BName_Output 0 x0) as HX;
    try rewrite HX in H8;
    try apply No_Red_AX51 in H8; auto.
Qed.

(*
*)
Lemma No_Red_AX6 :
forall (x : Name)(P Q : Prepro),
~( ( x ()· P ) --> Q).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX71 :
forall ( x u : Name)( P Q : Prepro),
~((u « x »· P) --> Q).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
Caso 7 no reduce a nada
*)
Lemma No_Red_AX7 :
forall ( x u : Name)( P Q : Prepro),
Process_Name x -> Process_Name u -> Process P ->
~(ν (Close_Rec 0 x (u « x »· P)) --> Q).
Proof.
  unfold not.
  intros.
  inversion H2; subst.
  apply (No_Red_AX52 x0 _ _ ) in H3.
  rewrite Eq_Subs_Close in H3; auto.
  rewrite Ax_Alpha in H3.
  simpl in H3.
  rewrite No_Red_AX55 in H3; auto.
  rewrite Eq_Subs_Close in H3; auto.
  rewrite Ax_Alpha in H3.
  rewrite H3 in H7.
  specialize (Close_Name_Output 0 x u) as HX.
  destruct HX;
    try rewrite H8 in H7;
    try specialize (Open_PName_Output 0 x0 u) as HX || specialize (Open_BName_Output 0 x0) as HX;
    try rewrite HX in H7;
    try apply No_Red_AX71 in H7;
    auto.
Qed.

(*
El caso 8 no reduce a nada
*)
Lemma No_Red_AX8 :
forall (x : Name)( Q : Prepro),
~ ((x «»·°) --> Q).
Proof.
  unfold not.
  intros.
  induction Q; try inversion H.
Qed.

(*
Construcción de un tipo de Proceso.
*)
Lemma Proc_Valid_V1 :
forall (P Q : Prepro)( u x : Name),
Process_Name u -> Process_Name x -> Process P -> Process Q ->
Process ((u !· Close x P) ↓ Q).
Proof.
  intros.
  constructor; auto.
  specialize ( Close_Is_Body x P) as HB.
  specialize ( HB H0 H1).
  inversion HB.
  constructor; auto.
Qed.

(*
Caracteriza la reducción de un proceso como el de la hipótesis.
*)
Lemma Char_Red_Chanres2 :
forall (P Q : Prepro)(x : Name),
Process P -> (ν (Close x P) --> Q ) ->
exists (Q0 : Prepro), ( Q = (ν (Close x Q0)) /\ P --> Q0).
Proof.
  intros.
  inversion H0; subst.
  exists ({x\x0}Q0).
  split.
  + specialize (Eq_Change_Var_Close Q0 x0 x) as HX.
    rewrite HX.
    auto.
  + specialize (Close_Rec_Eq_Subst P0 P x0 x 0) as HT.
    specialize (HT H2 H H1).
    rewrite Ax_Alpha in HT.
    rewrite Ax_Alpha.
    rewrite <- HT.
    auto.
Qed.

(*
Teorema 2.1 del artículo.
*)
Theorem Soundness :
forall (P : Prepro)(D F G : list Assignment),
  ( D ;;; F !- P ::: G ) -> (forall (Q: Prepro), (P --> Q)
  -> ( D ;;; F !- Q ::: G )).
Proof.
  intros P D F G H.
  induction H; intros.
  + apply No_Red_AX1 in H2. contradiction.
  + apply No_Red_AX1 in H2. contradiction.
  + apply No_Red_AX2 in H4. contradiction.
  + rewrite Ax_Alpha in H6.
    rewrite <- (Ax_Alpha u x Q).
    constructor; auto.
    apply (ProcessReduction_WD P Q); auto.
  + rewrite Ax_Alpha in H6.
    rewrite <- (Ax_Alpha u x Q).
    constructor; auto.
    apply (ProcessReduction_WD P Q); auto.
  + apply No_Red_AX2 in H4. contradiction.
  + apply No_Red_AX4 in H6. contradiction.
  + apply No_Red_AX5 in H10; try contradiction; auto.
  + apply No_Red_AX4 in H6. contradiction.
  + apply No_Red_AX5 in H10; try contradiction; auto.
  + apply No_Red_AX4 in H6. contradiction.
  + apply No_Red_AX5 in H10; try contradiction; auto.
  + apply No_Red_AX6 in H5. contradiction.
  + apply No_Red_AX8 in H1. contradiction.
  + apply No_Red_AX6 in H5. contradiction.
  + apply No_Red_AX8 in H1. contradiction.
  + apply No_Red_AX7 in H6; try contradiction; auto.
  + apply No_Red_AX7 in H6; try contradiction; auto.
  + specialize (Char_Red_Chanres2  ((u !· Close x P) ↓ Q) Q0 u) as HU.
    specialize (Proc_Valid_V1 P Q u x) as HV.
    specialize (HV H3 H2 H4 H5).
    specialize (HU HV H8).
    destruct HU as [Q1 H9].
    destruct H9.
    rewrite H9.
    specialize (Char_Red_Arr u x P Q Q1) as HT.
    specialize (HT H10).
    destruct HT as [Q2 H11].
    destruct H11.
    rewrite H11.
    apply (cutrep D F G x u P Q2 A); auto.
    apply (ProcessReduction_WD Q Q2); auto.
  + specialize (Char_Red_Chanres2  ((u !· Close x P) ↓ Q) Q0 u) as HU.
    specialize (Proc_Valid_V1 P Q u x) as HV.
    specialize (HV H3 H2 H4 H5).
    specialize (HU HV H8).
    destruct HU as [Q1 H9].
    destruct H9.
    rewrite H9.
    specialize (Char_Red_Arr u x P Q Q1) as HT.
    specialize (HT H10).
    destruct HT as [Q2 H11].
    destruct H11.
    rewrite H11.
    apply (cutcon D F G x u P Q2 A); auto.
    apply (ProcessReduction_WD Q Q2); auto.
Qed.