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.


(** * Extensionality of boolean recognizer *)
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.BooleanRecognizer.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.ListMorphisms.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Local Ltac subst_le_proof :=
  idtac;
  match goal with
    | [ H : ?x <= ?y, H' : ?x <= ?y |- _ ]
      => assert (H = H') by apply Le.le_proof_irrelevance; subst
  end.

Section recursive_descent_parser.
  Context {Char} {HSL : StringLikeMin Char} {G : grammar Char}.
  Context {data : @boolean_parser_dataT Char _}
          {rdata : @parser_removal_dataT' _ G _}.

  Create HintDb boolr_ext_db discriminated.
  Hint Unfold Proper respectful respectful_hetero pointwise_relation forall_relation pointwise2_relation sumbool_rect : boolr_ext_db.
  (** Dummy hint for [boolr_ext_db] to work around https://coq.inria.fr/bugs/show_bug.cgi?id=4479 *)
  Hint Rewrite production_tl_correct : boolr_ext_db.

  Local Ltac expand' :=
    idtac;
    (lazymatch goal with
    | [ |- ?R = ?L ]
      => (let rh := head R in
          let lh := head L in
          constr_eq rh lh;
          progress unfold rh)
     end).

  Local Ltac t_ext' :=
    idtac;
    match goal with
      | _ => reflexivity
      | _ => solve [ eauto with nocore ]
      | _ => progress intros
      | _ => progress subst
      | _ => progress subst_le_proof
      | [ |- @list_rect ?A ?P ?Pn ?Pc ?ls = @list_rect ?A ?P ?Pn' ?Pc' ?ls ]
        => apply (@list_rect_ext A P Pn Pn' Pc Pc' ls)
      | [ |- @option_rect ?A ?P ?Ps ?Pn ?x = @option_rect ?A ?P ?Ps' ?Pn' ?x ]
        => apply (@option_rect_ext A P Ps Ps' Pn Pn' x)
      | [ |- @List.fold_left ?A ?B _ _ _ = @List.fold_left ?A ?B _ _ _ ]
        => let lem := constr:(_ : Proper (_ ==> _ ==> _ ==> eq) (@List.fold_left A B)) in
           apply lem
      | [ |- @List.fold_right ?A ?B _ _ _ = @List.fold_right ?A ?B _ _ _ ]
        => let lem := constr:(_ : Proper (_ ==> _ ==> _ ==> eq) (@List.fold_right A B)) in
           apply lem
      | [ |- @List.map ?A ?B _ _ = @List.map ?A ?B _ _ ]
        => let lem := constr:(_ : Proper (_ ==> _ ==> eq) (@List.map A B)) in
           apply lem
      | [ |- andb ?x _ = andb ?x _ ] => apply f_equal
      | [ |- andb _ ?x = andb _ ?x ] => apply f_equal2
      | _ => progress autounfold with boolr_ext_db
      | [ |- appcontext[match ?e with _ => _ end] ] => is_var e; destruct e
      | [ |- appcontext[match ?e with _ => _ end] ] => destruct e eqn:?
      | [ H : _ |- _ ] => rewrite H
      | _ => progress autorewrite with boolr_ext_db
      | _ => progress simpl option_rect
      | [ H : cons _ _ = cons _ _ |- _ ] => inversion H; clear H
    end.

  Local Ltac t_ext tac := repeat (t_ext' || tac).

  Global Instance parse_item'_Proper
  : Proper (eq ==> pointwise_relation _ eq ==> eq ==> eq ==> eq ==> eq) (parse_item').
  Proof. t_ext expand'. Qed.

  Lemma parse_item'_ext
        (str : String)
        (str_matches_nonterminal str_matches_nonterminal' : nonterminal_carrierT -> bool)
        (ext : forall s, str_matches_nonterminal s = str_matches_nonterminal' s)
        (offset : nat)
        (len : nat)
        (it : item Char)
  : parse_item' str str_matches_nonterminal offset len it
    = parse_item' str str_matches_nonterminal' offset len it.
  Proof.
    change ((pointwise_relation _ eq) str_matches_nonterminal str_matches_nonterminal') in ext.
    rewrite ext; reflexivity.
  Qed.

  Hint Rewrite parse_item'_ext : boolr_ext_db.

  Inductive drop_takeT := drop_of (n : nat) | take_of (n : nat).

  Fixpoint drop_takes_offset (ns : list drop_takeT) (offset : nat)
    := match ns with
         | nil => offset
         | cons (drop_of n) ns' => drop_takes_offset ns' offset + n
         | cons (take_of n) ns' => drop_takes_offset ns' offset
       end.

  Fixpoint drop_takes_len (ns : list drop_takeT) (len : nat)
    := match ns with
         | nil => len
         | cons (drop_of n) ns' => drop_takes_len ns' len - n
         | cons (take_of n) ns' => min n (drop_takes_len ns' len)
       end.

  Fixpoint drop_takes_len_pf {len0} (ns : list drop_takeT) (len : nat) (pf : len <= len0) {struct ns}
  : drop_takes_len ns len <= len0.
  Proof.
    refine match ns return drop_takes_len ns len <= len0 with
             | nil => pf
             | cons (drop_of n) ns' => Le.le_trans _ _ _ (Minus.le_minus _ _) (@drop_takes_len_pf len0 ns' _ pf)
             | cons (take_of n) ns' => Le.le_trans _ _ _ (Min.le_min_r _ _) (@drop_takes_len_pf len0 ns' _ pf)
           end.
  Defined.

  Section production_drop_take.
    Context {len0}
            (parse_nonterminal parse_nonterminal'
             : forall (offset : nat) (len : nat),
                 len <= len0
                 -> nonterminal_carrierT
                 -> bool).

    Lemma parse_production'_for_ext_drop_take
          (str : String)
          splits splits'
          (offset : nat)
          (len : nat)
          (Hsplits : forall idx len ns, splits idx str (drop_takes_offset ns offset) (drop_takes_len ns len) = splits' idx str (drop_takes_offset ns offset) (drop_takes_len ns len))
          (ext : forall ns offset len pf nt,
                     @parse_nonterminal (drop_takes_offset ns offset) (drop_takes_len ns len) pf nt
                     = @parse_nonterminal' (drop_takes_offset ns offset) (drop_takes_len ns len) pf nt)
          (ns : list _)
          (pf pf' : drop_takes_len ns len <= len0)
          prod_idx
    : parse_production'_for str parse_nonterminal splits (drop_takes_offset ns offset) pf prod_idx
      = parse_production'_for str parse_nonterminal' splits' (drop_takes_offset ns offset) pf' prod_idx.
    Proof.
      remember (to_production prod_idx) as prod eqn:Heq.
      unfold parse_production'_for.
      revert prod_idx Heq ns offset len splits splits' Hsplits ext pf pf'; induction prod; simpl; intros;
      rewrite <- Heq; simpl;
      subst_le_proof;
      t_ext idtac.
      erewrite parse_item'_ext.
      { apply f_equal.
        specialize (IHprod (production_tl prod_idx)).
        rewrite production_tl_correct in IHprod.
        generalize dependent (to_production prod_idx); intros; subst.
        specialize (fun n ns => IHprod eq_refl (drop_of n :: ns)%list); simpl in IHprod.
        apply IHprod; clear IHprod; auto with nocore. }
      { specialize (fun n ns => ext (take_of n :: ns)%list); simpl in ext.
        auto with nocore. }
    Qed.

    Definition parse_production'_ext_drop_take
               (str : String)
               (offset : nat)
               (len : nat)
               (ext : forall ns offset len pf nt,
                        @parse_nonterminal (drop_takes_offset ns offset) (drop_takes_len ns len) pf nt
                        = @parse_nonterminal' (drop_takes_offset ns offset) (drop_takes_len ns len) pf nt)
               (ns : list _)
               (pf pf' : drop_takes_len ns len <= len0)
               prod_idx
    : parse_production' str parse_nonterminal (drop_takes_offset ns offset) pf prod_idx
      = parse_production' str parse_nonterminal' (drop_takes_offset ns offset) pf prod_idx
      := parse_production'_for_ext_drop_take _ _ _ _ _ (fun _ _ _ => eq_refl) ext _ _ _ _.
  End production_drop_take.

  Section production.
    Context {len0} (str : String)
            (parse_nonterminal parse_nonterminal'
             : forall (offset : nat) (len : nat),
                 len <= len0
                 -> nonterminal_carrierT
                 -> bool)
            (ext : forall offset len pf nt,
                     parse_nonterminal offset len pf nt
                     = parse_nonterminal' offset len pf nt).

    Lemma parse_production'_for_ext
          splits splits'
          (Hsplits : forall idx offset len, splits idx str offset len = splits' idx str offset len)
          (offset : nat)
          (len : nat)
          (pf pf' : len <= len0)
          prod_idx
    : parse_production'_for str parse_nonterminal splits offset pf prod_idx
      = parse_production'_for str parse_nonterminal' splits' offset pf' prod_idx.
    Proof.
      apply parse_production'_for_ext_drop_take with (ns := nil); auto with nocore.
    Qed.

    Definition parse_production'_ext
               (offset : nat)
               (len : nat)
               (pf pf' : len <= len0)
               prod_idx
    : parse_production' str parse_nonterminal offset pf prod_idx
      = parse_production' str parse_nonterminal' offset pf' prod_idx
      := parse_production'_for_ext _ _ (fun _ _ _ => eq_refl) _ _ _ _.
  End production.

  Global Instance parse_production'_for_Proper
  : Proper ((pointwise_relation _ (forall_relation (fun _ => pointwise_relation _ (pointwise_relation _ eq))))
              ==> (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ eq))))
              ==> eq
              ==> forall_relation (fun _ => (fun _ _ => True) ==> eq ==> eq))
           (parse_production'_for str (len0 := len0)).
  Proof.
    repeat intro; subst.
    apply parse_production'_for_ext;
    unfold pointwise_relation in *;
    eauto with nocore.
  Qed.

  Global Instance parse_production'_Proper
    : Proper ((pointwise_relation _ (forall_relation (fun _ => pointwise_relation _ (pointwise_relation _ eq))))
                ==> eq
                ==> forall_relation (fun _ => (fun _ _ => True) ==> eq ==> eq))
             (parse_production' str (len0 := len0)).
  Proof.
    repeat intro; subst.
    apply parse_production'_ext.
    assumption.
  Qed.

  Section productions_drop_take.
    Context {len0} (str : String)
            (parse_nonterminal parse_nonterminal'
             : forall (offset : nat)
                      (len : nat)
                      (pf : len <= len0),
                 nonterminal_carrierT -> bool).

    Lemma parse_productions'_ext_drop_take
          (ext : forall ns offset len pf nt,
                   @parse_nonterminal (drop_takes_offset ns offset) (drop_takes_len ns len) pf nt
                   = @parse_nonterminal' (drop_takes_offset ns offset) (drop_takes_len ns len) pf nt)
          (offset : nat)
          (len : nat)
          ns
          (pf pf' : drop_takes_len ns len <= len0)
          (prods : list production_carrierT)
    : parse_productions' str parse_nonterminal (drop_takes_offset ns offset) pf prods
      = parse_productions' str parse_nonterminal' (drop_takes_offset ns offset) pf' prods.
    Proof.
      t_ext ltac:(erewrite parse_production'_for_ext_drop_take || expand').
    Qed.
  End productions_drop_take.

  Section productions.
    Context {len0} (str : String)
            (parse_nonterminal parse_nonterminal'
             : forall (offset : nat)
                      (len : nat)
                      (pf : len <= len0),
                 nonterminal_carrierT -> bool)
            (ext : forall str len pf nt,
                     parse_nonterminal str len pf nt
                     = parse_nonterminal' str len pf nt).

    Lemma parse_productions'_ext
          (offset : nat)
          (len : nat)
          (pf pf' : len <= len0)
          (prods : list production_carrierT)
    : parse_productions' str parse_nonterminal offset pf prods
      = parse_productions' str parse_nonterminal' offset pf' prods.
    Proof.
      apply parse_productions'_ext_drop_take with (ns := nil); auto with nocore.
    Qed.
  End productions.

  Global Instance parse_productions'_Proper
  : Proper ((pointwise_relation _ (forall_relation (fun _ => pointwise_relation _ (pointwise_relation _ eq))))
              ==> eq
              ==> forall_relation (fun _ => (fun _ _ => True) ==> eq ==> eq))
           (parse_productions' str (len0 := len0)).
  Proof.
    repeat intro; subst.
    apply parse_productions'_ext.
    assumption.
  Qed.

  Section nonterminals.
    Section step_drop_take.
      Context {len0 valid_len} (str : String)
              (parse_nonterminal parse_nonterminal'
               : forall (p : nat * nat),
                   Wf.prod_relation lt lt p (len0, valid_len)
                   -> forall (valid : nonterminals_listT)
                             (offset : nat) (len : nat),
                        len <= fst p -> nonterminal_carrierT -> bool).

      Definition parse_nonterminal_step_ext_drop_take
                 (valid : nonterminals_listT)
                 (ext : forall ns p pf valid offset len pf' nt,
                          @parse_nonterminal p pf valid (drop_takes_offset ns offset) (drop_takes_len ns len) pf' nt
                          = @parse_nonterminal' p pf valid (drop_takes_offset ns offset) (drop_takes_len ns len) pf' nt)
                 (offset : nat)
                 (len : nat)
                 ns
                 (pf pf' : drop_takes_len ns len <= len0)
                 (nt : nonterminal_carrierT)
      : parse_nonterminal_step str parse_nonterminal valid (drop_takes_offset ns offset) pf nt
        = parse_nonterminal_step str parse_nonterminal' valid (drop_takes_offset ns offset) pf' nt.
      Proof.
        t_ext ltac:(erewrite parse_productions'_ext_drop_take || expand').
      Qed.
    End step_drop_take.

    Section step.
      Context {len0 valid_len} (str : String)
              (parse_nonterminal parse_nonterminal'
               : forall (p : nat * nat),
                   Wf.prod_relation lt lt p (len0, valid_len)
                   -> forall (valid : nonterminals_listT)
                             (offset : nat) (len : nat),
                        len <= fst p -> nonterminal_carrierT -> bool)
              (ext : forall p pf valid str len pf' nt,
                       parse_nonterminal p pf valid str len pf' nt
                       = parse_nonterminal' p pf valid str len pf' nt).

      Definition parse_nonterminal_step_ext
                 (valid : nonterminals_listT)
                 (offset : nat)
                 (len : nat)
                 (pf pf' : len <= len0)
                 (nt : nonterminal_carrierT)
      : parse_nonterminal_step str parse_nonterminal valid offset pf nt
        = parse_nonterminal_step str parse_nonterminal' valid offset pf' nt.
      Proof.
        apply parse_nonterminal_step_ext_drop_take with (ns := nil); auto with nocore.
      Qed.
    End step.

    Global Instance parse_nonterminal_step_Proper
    : Proper ((forall_relation (fun _ => pointwise_relation _ (pointwise_relation _ (pointwise_relation _ (forall_relation (fun _ => pointwise_relation _ (pointwise_relation _ eq)))))))
                ==> eq
                ==> eq
                ==> forall_relation (fun _ => (fun _ _ => True) ==> eq ==> eq))
             (parse_nonterminal_step str (len0 := len0) (valid_len := valid_len)).
    Proof.
      repeat intro; subst.
      apply parse_nonterminal_step_ext.
      assumption.
    Qed.
  End nonterminals.
End recursive_descent_parser.


(** * Functional correctness of the compiler *)

(** We finally turn to proving our compiler correct.

SAZ: This needs to be updated.

    We express the result as a (weak) bisimulation between
    the [itree] resulting from the denotation of the source
    _Imp_ statement and the denotation of the compiled _Asm_
    program. This weak bisimulation is a _up-to-tau_ bisimulation.
    More specifically, we relate the itrees after having
    interpreted the events contained in the trees, and run
    the resulting computation from the state monad:
    [ImpState] on the _Imp_ side, [Reg] and [Memory] on the
    _Asm_ side.

    The proof is essentially structured as followed:
    - a simulation relation is defined to relate the _Imp_
    state to the _Asm_ memory during the simulation. This
    relation is strengthened into a second one additionally
    relating the result of the denotation of an expression to
    the _Asm_ set of registers, and used during the simulation
    of expressions.
    - the desired bisimulation is defined to carry out the
    the simulation invariant into a up-to-tau equivalence after
    interpretation of events. Once again a slightly different
    bisimulation is defined when handling expressions.
    - Linking is proved in isolation: the "high level" control
    flow combinators for _Asm_ defined in [Imp2Asm.v] are
    proved correct in the same style as the elementary ones
    from [AsmCombinators.v].
    - Finally, all the pieces are tied together to prove the
    correctness.

    We emphasize the following aspects of the proof:
    - Despite establishing a termination-sensitive correctness
    result over Turing-complete languages, we have not written
    a single [cofix]. All coinductive reasoning is internalized
    into the [itree] library.
    - We have separated the control-flow-related reasoning from
    the functional correctness one. In particular, the low-level
    [asm] combinators are entirely reusable, and the high-level
    ones are only very loosely tied to _Imp_.
    - All reasoning is equational. In particular, reasoning at the
    level of [ktree]s rather than introducing the entry label and
    trying to reason at the level of [itree]s ease sensibly the pain
    by reducing the amount of binders under which we need to work.
    - We transparently make use of the heterogeneous bisimulation provided
    by the [itree] library to relate computations of _Asm_ expressions that
    return a pair of environments (registers and memory) and a [unit] value to
    ones of _Imp_ that return a single environment and an [Imp.value].
 *)

(* begin hide *)
From ITreeTutorial Require Import Imp Asm Utils_tutorial AsmCombinators Imp2Asm Fin KTreeFin.

From Coq Require Import
     Psatz
     Strings.String
     List
     Program.Basics
     Morphisms
     ZArith
     Setoid
     RelationClasses.

From ITree Require Import
     ITree
     ITreeFacts
     Basics.CategorySub
     Basics.HeterogeneousRelations
     Events.StateFacts
     Events.MapDefault.

Import ITreeNotations.

From ExtLib Require Import
     Data.String
     Core.RelDec
     Structures.Monad
     Structures.Maps
     Data.Map.FMapAList.

Import ListNotations.
Open Scope string_scope.

Import CatNotations.
Local Open Scope cat_scope.
Local Open Scope itree_scope.

(* end hide *)

(* ================================================================= *)
(** ** Simulation relations and invariants *)

(** The compiler is proved correct by constructing a (itree) bisimulation
    between the source program and its compilation.  The compiler does two
    things that affect the state:

      - it translates source Imp variables to Asm global variables, which should
        match at each step of computation

      - it introduces temporary local variables that name intermediate values

    As is traditional, we define, to this end, a simulation relation [Renv] and
    invariants that relate the source Imp environment to the target Asm
    environment, following the description above.

    [Renv] relates two [alist var value] environments if they act as
    equivalent maps.  This is used to relate Imp's [ImpState] environment to
    Asm's [Memory].

*)

Section Simulation_Relation.

  (** ** Definition of the simulation relations *)

  (** The simulation relation for evaluation of statements.
      The relation relates two environments of type [alist var value].
      The source and target environments exactly agree on user variables.
   *)
  Definition Renv (g_imp : Imp.env) (g_asm : Asm.memory) : Prop :=
    forall k v, alist_In k g_imp v <-> alist_In k g_asm v.

  Global Instance Renv_refl : Reflexive Renv.
  Proof.
    red. intros. unfold Renv. tauto.
  Qed.

 (** The simulation relation for evaluation of expressions.

     The relation connects

       - the global state at the Imp level

       - the memory and register states at the Asm level

     and, additionally the returned value at the _Imp_ level. The _Asm_ side
     does not carry a [value], but a [unit], since its denotation does not
     return any [value].

     The [sim_rel] relation is parameterized by the state of the local [asm]
     environment before the step, and the name of the variable used to store the
     result.

     It enforces three conditions:
     - [Renv] on the global environments, ensuring that evaluation of expressions does
     not change user variables;

     - Agreement on the computed value, i.e. the returned value [v] is stored at
     the assembly level in the expected temporary;

     - The "stack" of temporaries used to compute intermediate results is left
       untouched.
  *)
  Definition sim_rel l_asm n: (env * value) -> (memory * (registers * unit)) -> Prop :=
    fun '(g_imp', v) '(g_asm', (l_asm', _))  =>
      Renv g_imp' g_asm' /\            (* we don't corrupt any of the imp variables *)
      alist_In n l_asm' v /\           (* we get the right value *)
      (forall m, m < n -> forall v,              (* we don't mess with anything on the "stack" *)
            alist_In m l_asm v <-> alist_In m l_asm' v).

  Lemma sim_rel_find : forall g_asm g_imp l_asm l_asm' n  v,
    sim_rel l_asm n (g_imp, v) (g_asm, (l_asm', tt)) ->
    alist_find n l_asm' = Some v.
  Proof.
    intros.
    destruct H as [_ [IN _]].
    apply IN.
  Qed.

  (** ** Facts on the simulation relations *)

  (** [Renv] entails agreement of lookup of user variables. *)
  Lemma Renv_find:
    forall g_asm g_imp x,
      Renv g_imp g_asm ->
      alist_find x g_imp = alist_find x g_asm.
  Proof.
    intros.
    destruct (alist_find x g_imp) eqn:LUL, (alist_find x g_asm) eqn:LUR; auto.
    - eapply H in LUL.
      rewrite LUL in LUR; auto.
    - eapply H in LUL.
      rewrite LUL in LUR; auto.
    - eapply H in LUR.
      rewrite LUR in LUL; inv LUL.
  Qed.

  (** [sim_rel] can be initialized from [Renv]. *)
  Lemma sim_rel_add: forall g_asm l_asm g_imp n v,
      Renv g_imp g_asm ->
      sim_rel l_asm n  (g_imp, v) (g_asm, (alist_add n v l_asm, tt)).
  Proof.
    intros.
    split; [| split].
    - assumption.
    - apply In_add_eq.
    - intros m LT v'.
      apply In_add_ineq_iff; lia.
  Qed.

  (** [Renv] can be recovered from [sim_rel]. *)
  Lemma sim_rel_Renv: forall l_asm n s1 l v1 s2 v2,
      sim_rel l_asm n (s2,v2) (s1,(l,v1)) -> Renv s2 s1 .
  Proof.
    intros ? ? ? ? ? ? ? H; apply H.
  Qed.

  Lemma sim_rel_find_tmp_n:
    forall l_asm g_asm' n l_asm' g_imp' v,
      sim_rel l_asm n  (g_imp',v) (g_asm', (l_asm', tt)) ->
      alist_In n l_asm' v.
  Proof.
    intros ? ? ? ? ? ? [_ [H _]]; exact H.
  Qed.

  (** [sim_rel] entails agreement of lookups in the "stack" between its argument
      and the current Asm environement *)
  Lemma sim_rel_find_tmp_lt_n:
    forall l_asm g_asm' n m l_asm' g_imp' v,
      m < n ->
      sim_rel l_asm n (g_imp',v) (g_asm', (l_asm', tt)) ->
      alist_find m l_asm = alist_find m l_asm'.
  Proof.
    intros ? ? ? ? ? ? ? ineq [_ [_ H]].
    match goal with
    | |- _ = ?x => destruct x eqn:EQ
    end.
    setoid_rewrite (H _ ineq); auto.
    match goal with
    | |- ?x = _ => destruct x eqn:EQ'
    end; [| reflexivity].
    setoid_rewrite (H _ ineq) in EQ'.
    rewrite EQ' in EQ; easy.
  Qed.

  Lemma sim_rel_find_tmp_n_trans:
    forall l_asm n l_asm' l_asm'' g_asm' g_asm'' g_imp' g_imp'' v v',
      sim_rel l_asm n (g_imp',v) (g_asm', (l_asm', tt))  ->
      sim_rel l_asm' (S n) (g_imp'',v') (g_asm'', (l_asm'', tt))  ->
      alist_In n l_asm'' v.
  Proof.
    intros.
    generalize H; intros LU; apply sim_rel_find_tmp_n in LU.
    unfold alist_In in LU; erewrite sim_rel_find_tmp_lt_n in LU; eauto.
  Qed.

  (** [Renv] is preserved by assignment.
   *)
  Lemma Renv_write_local:
    forall (k : Imp.var) (g_asm g_imp : alist var value) v,
      Renv g_imp g_asm ->
      Renv (alist_add k v g_imp) (alist_add k v g_asm).
  Proof.
    intros k m m' v HRel k' v'.
    unfold alist_add, alist_In; simpl.
    flatten_goal;
      repeat match goal with
             | h: _ = true |- _ => rewrite rel_dec_correct in h
             | h: _ = false |- _ => rewrite <- neg_rel_dec_correct in h
             end; try subst.
    - tauto.
    - setoid_rewrite In_remove_In_ineq_iff; eauto using RelDec_Correct_string.
  Qed.

  (** [sim_rel] can be composed when proving binary arithmetic operators. *)
  Lemma sim_rel_binary_op:
    forall (l_asm l_asm' l_asm'' : registers) (g_asm' g_asm'' : memory) (g_imp' g_imp'' : env)
      (n v v' : nat)
      (Hsim : sim_rel l_asm n (g_imp', v) (g_asm', (l_asm', tt)))
      (Hsim': sim_rel l_asm' (S n) (g_imp'', v') (g_asm'', (l_asm'', tt)))
      (op: nat -> nat -> nat),
      sim_rel l_asm n (g_imp'', op v v') (g_asm'', (alist_add n (op v v') l_asm'', tt)).
  Proof.
    intros.
    split; [| split].
    - eapply sim_rel_Renv; eassumption.
    - apply In_add_eq.
    - intros m LT v''.
      rewrite <- In_add_ineq_iff; [| lia].
      destruct Hsim as [_ [_ Hsim]].
      destruct Hsim' as [_ [_ Hsim']].
      rewrite Hsim; [| auto with arith].
      rewrite Hsim'; [| auto with arith].
      reflexivity.
  Qed.

End Simulation_Relation.

(* ================================================================= *)
(** ** Bisimulation *)

(** We now make precise the bisimulation established to show the correctness of
    the compiler.  Naturally, we cannot establish a _strong bisimulation_
    between the source program and the target program: the [asm] counterpart
    performs "more steps" when evaluating expressions.  The appropriate notion
    is of course the _equivalence up to tau_. However, the [itree] structures
    are also quite different.  [asm] programs manipulate two state
    components. The simulation will establish that the [imp] global state
    corresponds to the [asm] memory, but to be able to  establish this
    correspondence, we also need to interpret the [asm] register effects.  *)

Section Bisimulation.

  (** Definition of our bisimulation relation.

      As previously explained, the bisimulation relates (up-to-tau)
      two [itree]s after having interpreted their events.

      We additionally bake into it a simulation invariant:
      - Events are interpreted from states related by [Renv]
      - Returned values must contain related states, as well as computed datas
        related by another relation [RAB] taken in parameter.
      In our case, we will specialize [RAB] to the total relation since the trees return
      respectively [unit] and the unique top-level label [F0: fin 1].
   *)

  Section RAB.

    Context {A B : Type}.
    Context (RAB : A -> B -> Prop).  (* relation on Imp / Asm values *)

    Definition state_invariant (a : Imp.env * A) (b : Asm.memory * (Asm.registers * B))  :=
      Renv (fst a) (fst b) /\ (RAB (snd a) (snd (snd b))).

    Definition bisimilar {E} (t1 : itree (ImpState +' E) A) (t2 : itree (Reg +' Memory +' E) B)  :=
    forall g_asm g_imp l,
      Renv g_imp g_asm ->
      eutt state_invariant
           (interp_imp t1 g_imp)
           (interp_asm t2 g_asm l).
  End RAB.

  (** [bisimilar] is compatible with [eutt]. *)

  Global Instance eutt_bisimilar  {A B E}  (RAB : A -> B -> Prop):
    Proper (eutt eq ==> eutt eq ==> iff) (@bisimilar A B RAB E).
  Proof.
    repeat intro.
    unfold bisimilar. split.
    - intros.
      rewrite <- H, <- H0. auto.
    - intros.
      rewrite H, H0. auto.
  Qed.

  Lemma bisimilar_bind' {A A' B C E} (RAA' : A -> A' -> Prop) (RBC: B -> C -> Prop):
    forall (t1 : itree (ImpState +' E) A) (t2 : itree (Reg +' Memory +' E) A') ,
      bisimilar RAA' t1 t2 ->
      forall (k1 : A -> itree (ImpState +' E) B) (k2 : A' -> itree (Reg +' Memory +' E) C)
        (H: forall (a:A) (a':A'), RAA' a a' -> bisimilar RBC (k1 a) (k2 a')),
        bisimilar RBC (t1 >>= k1) (t2 >>= k2).
  Proof.
    repeat intro.
    rewrite interp_asm_bind.
    rewrite interp_imp_bind.
    eapply eutt_clo_bind.
    { eapply H; auto. }
    intros.
    destruct u1 as [? ?].
    destruct u2 as [? [? ?]].
    unfold state_invariant in H2.
    simpl in H2. destruct H2. subst.
    eapply H0; eauto.
  Qed.

  Lemma bisimilar_iter {E A A' B B'}
        (R : A -> A' -> Prop)
        (S : B -> B' -> Prop)
        (t1 : A -> itree (_ +' E) (A + B))
        (t2 : A' -> itree (_ +' _ +' E) (A' + B')) :
    (forall l l', R l l' -> bisimilar (sum_rel R S) (t1 l) (t2 l')) ->
    forall x x', R x x' ->
    bisimilar S (iter (C := ktree _) t1 x) (iter (C := ktree _) t2 x').
  Proof.

    unfold bisimilar, interp_asm, interp_imp, interp_map.
    intros. rewrite 2 interp_iter.
    unfold iter, Iter_Kleisli.
    pose proof @interp_state_iter'.
    red in H2. unfold Basics.iter, MonadIter_itree.

    rewrite 2 H2.
    unfold Basics.iter, MonadIter_stateT0, Basics.iter, MonadIter_itree; cbn.
    rewrite H2.
    apply (eutt_iter' (state_invariant R)).
    intros.
    destruct H3; cbn.
    rewrite interp_state_bind, bind_bind.
    setoid_rewrite interp_state_ret.
    setoid_rewrite bind_ret_l. cbn.
    apply (@eutt_clo_bind _ _ _ _ _ _ (state_invariant (sum_rel R S))).
    - auto.
    - intros ? ? [? []]; cbn; apply eqit_Ret; constructor; split; auto.
    - constructor; auto.
  Qed.

  (** [sim_rel] at [n] entails that [GetVar (gen_tmp n)] gets interpreted
      as returning the same value as the _Imp_ related one.
   *)
  Lemma sim_rel_get_tmp0:
    forall {E} n l l' g_asm g_imp v,
      sim_rel l' n (g_imp,v) (g_asm, (l,tt)) ->
      (interp_asm ((trigger (GetReg n)) : itree (Reg +' Memory +' E) value)
                                       g_asm l)
      ≈     (Ret (g_asm, (l, v))).
  Proof.
    intros.
    unfold interp_asm.
    rewrite interp_trigger.
    cbn.
    unfold interp_map.
    unfold h_reg, CategoryOps.cat, Cat_Handler, Handler.cat.
    unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger. cbn.
    unfold lookup_def; cbn.
    unfold embed, Embeddable_itree, Embeddable_forall, embed.
    rewrite interp_trigger.
    rewrite interp_state_trigger_eqit.
    cbn.
    rewrite bind_ret_l, tau_eutt.
    rewrite interp_state_ret.
    unfold lookup_default, lookup, Map_alist.
    erewrite sim_rel_find.
    reflexivity.
    apply H.
  Qed.

End Bisimulation.

(* ================================================================= *)
(** ** Linking *)

(** We first show that our "high level" [asm] combinators are correct.  These
    proofs are mostly independent from the compiler, and therefore fairly
    reusable.  Once again, these notion of correctness are expressed as
    equations commuting the denotation with the combinator.  *)

Section Linking.

  Import KTreeFin.

  Context {E} `{Reg -< E, Memory -< E, Exit -< E}.

  Notation denote_asm := (Asm.denote_asm (E := E)).

  (** [seq_asm] is denoted as the (horizontal) composition of denotations. *)
  Lemma seq_asm_correct {A B C} (ab : asm A B) (bc : asm B C) :
      denote_asm (seq_asm ab bc)
    ⩯ denote_asm ab >>> denote_asm bc.
  Proof.
    unfold seq_asm.
    rewrite loop_asm_correct, relabel_asm_correct, app_asm_correct.
    rewrite fmap_id0, cat_id_r, fmap_swap.
    apply cat_from_loop.
  Qed.

  (** [if_asm] is denoted as the ktree first denoting the branching condition,
      then looking-up the appropriate variable and following with either denotation. *)
  Lemma if_asm_correct {A} (e : list instr) (tp fp : asm 1 A) :
      denote_asm (if_asm e tp fp)
    ⩯ ((fun _ =>
         denote_list e ;;
         v <- trigger (GetReg tmp_if) ;;
         if v : value then denote_asm fp f0 else denote_asm tp f0)).
  Proof.
    unfold if_asm.
    rewrite seq_asm_correct.
    unfold cond_asm.
    rewrite raw_asm_block_correct_lifted.
    rewrite relabel_asm_correct.

    intros ?.
    Local Opaque Asm.denote_asm.

    unfold CategoryOps.cat, Cat_sub, CategoryOps.cat, Cat_Kleisli; simpl.
    rewrite denote_after.
    cbn.
    repeat setoid_rewrite bind_bind.
    apply eqit_bind; try reflexivity. intros _.
    apply eqit_bind; try reflexivity. intros [].

    - rewrite !bind_ret_l.
      setoid_rewrite (app_asm_correct tp fp _).
      setoid_rewrite bind_bind.
      match goal with
      | [ |- _ (?t >>= _) _ ] => let y := eval compute in t in change t with y
      end.
      rewrite bind_ret_l. cbn.
      setoid_rewrite bind_ret_l.
      rewrite bind_bind.
      setoid_rewrite bind_ret_l.
      unfold from_bif, FromBifunctor_ktree_fin; cbn.
      rewrite bind_ret_r'.
      { rewrite (unique_f0 (fi' 0)). reflexivity. }
      { intros.
        Local Opaque split_fin_sum R. cbv. Local Transparent split_fin_sum R.
        rewrite split_fin_sum_R. reflexivity. }

    - rewrite !bind_ret_l.
      setoid_rewrite (app_asm_correct tp fp _).
      repeat setoid_rewrite bind_bind.
      match goal with
      | [ |- _ (?t >>= _) _ ] => let y := eval compute in t in change t with y
      end.
      rewrite bind_ret_l. cbn. rewrite bind_bind.
      setoid_rewrite bind_ret_l.
      unfold from_bif, FromBifunctor_ktree_fin.
      setoid_rewrite bind_ret_l.
      rewrite bind_ret_r'.
      { rewrite (unique_f0 (fi' 0)). reflexivity. }
      { intros. Local Opaque split_fin_sum L. cbv. Local Transparent split_fin_sum R.
        rewrite split_fin_sum_L. reflexivity. }
  Qed.

  (** [while_asm] is denoted as the loop of the body with two entry point, the exit
      of the loop, and the body in which we have the same structure as for the conditional *)
  Notation label_case := (split_fin_sum _ _).

  Lemma while_asm_correct (e : list instr) (p : asm 1 1) :
      denote_asm (while_asm e p)
    ⩯ (loop (C := sub (ktree _) fin) (fun l : fin (1 + 1) =>
         match label_case l with
         | inl _ =>
           denote_list e ;;
           v <- trigger (GetReg tmp_if) ;;
           if (v:value) then Ret (fS f0) else (denote_asm p f0;; Ret f0)
         | inr _ => Ret f0
         end)).
  Proof.
    unfold while_asm.
    rewrite loop_asm_correct.
    apply Proper_loop.
    rewrite relabel_asm_correct.
    rewrite fmap_id0, cat_id_l.
    rewrite app_asm_correct.
    rewrite if_asm_correct.
    intros x.
    cbn.
    unfold to_bif, ToBifunctor_ktree_fin.
    rewrite bind_ret_l.
    destruct (label_case x); cbn.
    - rewrite !bind_bind. setoid_rewrite bind_ret_l.
      eapply eutt_clo_bind; try reflexivity. intros; subst.
      rewrite bind_bind.
      eapply eutt_clo_bind; try reflexivity. intros; subst.
      unfold from_bif, FromBifunctor_ktree_fin; cbn.
      setoid_rewrite bind_ret_l.
      destruct u0.
      + rewrite (pure_asm_correct _ _); cbn.
        rewrite !bind_ret_l.
        apply eqit_Ret.
        apply unique_fin; reflexivity.

      + rewrite (relabel_asm_correct _ _ _ _). cbn.
        rewrite bind_ret_l.
        setoid_rewrite bind_bind.
        eapply eutt_clo_bind; try reflexivity.
        intros ? ? [].
        repeat rewrite bind_ret_l.
        apply eqit_Ret.
        rewrite (unique_f0 u1).
        apply unique_fin; reflexivity.

    - cbn.
      rewrite (pure_asm_correct _ _).
      rewrite bind_bind. cbn.
      unfold from_bif, FromBifunctor_ktree_fin.
      rewrite !bind_ret_l.
      apply eqit_Ret.
      rewrite (unique_f0 f).
      apply unique_fin; reflexivity.
Qed.

End Linking.

(* ================================================================= *)
(** ** Correctness *)

Section Correctness.

  (** Correctness of expressions.
      We strengthen [bisimilar]: initial environments are still related by [Renv],
      but intermediate ones must now satisfy [sim_rel].
      Note that by doing so, we use a _heterogeneous bisimulation_: the trees
      return values of different types ([alist var value * unit] for _Asm_,
      [alist var value * value] for _Imp_). The difference is nonetheless mostly
      transparent for the user, except for the use of the more general lemma [eqit_bind'].
   *)
  Lemma compile_expr_correct : forall {E} e g_imp g_asm l n,
      Renv g_imp g_asm ->
      @eutt E _ _ (sim_rel l n)
            (interp_imp (denote_expr e) g_imp)
            (interp_asm (denote_list (compile_expr n e)) g_asm l).
  Proof.
    induction e; simpl; intros.
    - (* Var case *)
      (* We first compute and eliminate taus on both sides. *)
      force_left.
      rewrite tau_eutt.

      tau_steps.

      (* We are left with [Ret] constructs on both sides, that remains to be related *)
      red; rewrite <-eqit_Ret.
      unfold lookup_default, lookup, Map_alist.

      (* On the _Asm_ side, we bind to [gen_tmp n] a lookup to [varOf v] *)
      (* On the _Imp_ side, we return the value of a lookup to [varOf v] *)
      erewrite Renv_find; [| eassumption].
      apply sim_rel_add; assumption.

    - (* Literal case *)
      (* We reduce both sides to Ret constructs *)
      tau_steps.

      red; rewrite <-eqit_Ret.
      (* _Asm_ bind the litteral to [gen_tmp n] while _Imp_ returns it *)
      apply sim_rel_add; assumption.

    (* The three binary operator cases are identical *)
    - (* Plus case *)
      (* We push [interp_locals] into the denotations *)

      do 2 setoid_rewrite denote_list_app.
      rewrite interp_asm_bind.
      rewrite interp_imp_bind.

      (* The Induction hypothesis on [e1] relates the first itrees *)
      eapply eutt_clo_bind.
      { eapply IHe1; assumption. }
      (* We obtain new related environments *)
      intros [g_imp' v] [g_asm' [l' []]] HSIM.
      (* The Induction hypothesis on [e2] relates the second itrees *)
      rewrite interp_asm_bind.
      rewrite interp_imp_bind.
      eapply eutt_clo_bind.
      { eapply IHe2.
        eapply sim_rel_Renv; eassumption. }
      (* And we once again get new related environments *)
      intros [g_imp'' v'] [g_asm'' [l'' []]] HSIM'.
      (* We can now reduce down to Ret constructs that remains to be related *)
      tau_steps.
      red. rewrite <- eqit_Ret.

      clear -HSIM HSIM'. unfold lookup_default, lookup, Map_alist.
      erewrite sim_rel_find_tmp_n_trans; eauto.
      erewrite sim_rel_find_tmp_n; eauto.
      eapply sim_rel_binary_op; eauto.

    - (* Sub case *)
      (* We push [interp_locals] into the denotations *)
      do 2 setoid_rewrite denote_list_app.
      rewrite interp_asm_bind.
      rewrite interp_imp_bind.

      (* The Induction hypothesis on [e1] relates the first itrees *)
      eapply eutt_clo_bind.
      { eapply IHe1; assumption. }
      (* We obtain new related environments *)
      intros [g_imp' v] [g_asm' [l' []]] HSIM.
      (* The Induction hypothesis on [e2] relates the second itrees *)
      rewrite interp_asm_bind.
      rewrite interp_imp_bind.
      eapply eutt_clo_bind.
      { eapply IHe2.
        eapply sim_rel_Renv; eassumption. }
      (* And we once again get new related environments *)
      intros [g_imp'' v'] [g_asm'' [l'' []]]  HSIM'.
      (* We can now reduce down to Ret constructs that remains to be related *)
      tau_steps.
      red. rewrite <- eqit_Ret.

      clear -HSIM HSIM'. unfold lookup_default, lookup, Map_alist.
      erewrite sim_rel_find_tmp_n_trans; eauto.
      erewrite sim_rel_find_tmp_n; eauto.
      eapply sim_rel_binary_op; eauto.

    - (* Mul case *)
      (* We push [interp_locals] into the denotations *)
      do 2 setoid_rewrite denote_list_app.
      rewrite interp_asm_bind.
      rewrite interp_imp_bind.

      (* The Induction hypothesis on [e1] relates the first itrees *)
      eapply eutt_clo_bind.
      { eapply IHe1; assumption. }
      (* We obtain new related environments *)
      intros [g_imp' v] [g_asm' [l' []]] HSIM.
      (* The Induction hypothesis on [e2] relates the second itrees *)
      rewrite interp_asm_bind.
      rewrite interp_imp_bind.
      eapply eutt_clo_bind.
      { eapply IHe2.
        eapply sim_rel_Renv; eassumption. }
      (* And we once again get new related environments *)
      intros [g_imp'' v'] [g_asm'' [l'' []]] HSIM'.
      (* We can now reduce down to Ret constructs that remain to be related *)
      tau_steps.
      red. rewrite <- eqit_Ret.

      clear -HSIM HSIM'. unfold lookup_default, lookup, Map_alist.
      erewrite sim_rel_find_tmp_n_trans; eauto.
      erewrite sim_rel_find_tmp_n; eauto.
      eapply sim_rel_binary_op; eauto.
  Qed.

  (** Correctness of the assign statement.
      The resulting list of instructions is denoted as
      denoting the expression followed by setting the variable.
   *)
  Lemma compile_assign_correct : forall {E} e x,
      bisimilar eq
        ((v <- denote_expr e ;; trigger (Imp.SetVar x v)) : itree (ImpState +' E) unit)
        ((denote_list (compile_assign x e)) : itree (Reg +' Memory +' E) unit).
  Proof.
    red; intros.
    unfold compile_assign.
    (* We push interpreters inside of the denotations *)
    rewrite denote_list_app.
    rewrite interp_asm_bind.
    rewrite interp_imp_bind.

    (* By correctness of the compilation of expressions,
       we can match the head trees.
     *)
    eapply eutt_clo_bind.
    { eapply compile_expr_correct; eauto. }

    (* Once again, we get related environments *)
    intros [g_imp' v]  [g_asm' [l' y]] HSIM.
    simpl in HSIM.

    (* We can now reduce to Ret constructs *)
    tau_steps.
    red. rewrite <- eqit_Ret.

    (* And remains to relate the results *)
    unfold state_invariant.
    unfold lookup_default, lookup, Map_alist.
    rewrite sim_rel_find_tmp_n; eauto; simpl.
    apply sim_rel_Renv in HSIM.
    split; auto.
    eapply Renv_write_local; eauto.
    eauto.
  Qed.

  (* The first parameter of [bisimilar] is unnecessary for this development.
     The return type is heterogeneous, the singleton type [F 1] on one side
     and [unit] on the other, hence we instantiate the parameter with the trivial
     relation.
   *)
  Definition TT {A B}: A -> B -> Prop  := fun _ _ => True.
  Hint Unfold TT: core.

  Definition equivalent {E} `{Exit -< E} (s:stmt) (t:asm 1 1) : Prop :=
    bisimilar TT (E := E) (denote_imp s) (denote_asm t f0).

  Inductive RI : (unit + unit) -> (unit + unit + unit) -> Prop :=
  | RI_inl : RI (inl tt) (inl (inl tt))
  | RI_inr : RI (inr tt) (inr tt).

  (* Utility: slight rephrasing of [while] to facilitate rewriting
     in the main theorem.*)
  Lemma while_is_loop {E} (body : itree E (unit+unit)) :
    while body
          ≈ iter (C := ktree _) (fun l : unit + unit =>
                    match l with
                    | inl _ => x <- body;; match x with inl _ => Ret (inl (inl tt)) | inr _ => Ret (inr tt) end
                    | inr _ => Ret (inl (inl tt))   (* Enter loop *)
                    end) (inr tt).
  Proof.
    unfold while.
    rewrite! unfold_iter_ktree.
    rewrite bind_ret_l, tau_eutt.
    rewrite unfold_iter_ktree.
    rewrite !bind_bind.
    eapply eutt_clo_bind. reflexivity.
    intros. subst.
    destruct u2 as [[]|[]].
    2 : { force_right. reflexivity. }
    rewrite bind_ret_l, !tau_eutt.
    unfold iter, Iter_Kleisli.
    apply eutt_iter' with (RI := fun _ r => inl tt = r).
    - intros _ _ [].
      rewrite <- bind_ret_r at 1.
      eapply eutt_clo_bind; try reflexivity.
      intros [|[]] _ []; apply eqit_Ret; auto; constructor; auto.
    - constructor.
  Qed.

  Definition to_itree' {E A} (f : ktree_fin E 1 A) : itree E (fin A) := f f0.
  Lemma fold_to_itree' {E} (f : ktree_fin E 1 1) : f f0 = to_itree' f.
  Proof. reflexivity. Qed.

  Global Instance Proper_to_itree' {E A} :
    Proper (eq2 ==> eutt eq) (@to_itree' E A).
  Proof.
    repeat intro.
    apply H.
  Qed.

  Notation Inr_Kleisli := Inr_Kleisli.

  (** Correctness of the compiler.
      After interpretation of the [Locals], the source _Imp_ statement
      denoted as an [itree] and the compiled _Asm_ program denoted
      as an [itree] are equivalent up-to-taus.
      The correctness is termination sensitive, but nonetheless a simple
      induction on statements.
      We are only left with reasoning about the functional correctness of
      the compiler, all control-flow related reasoning having been handled
      in isolation.
   *)
  Theorem compile_correct {E} {HasExit : Exit -< E} (s : stmt) :
    equivalent (E := E) s (compile s).
  Proof.
    unfold equivalent.
    induction s.

    - (* Assign *)
      simpl.
      (* We push [denote_asm] inside of the combinators *)
      rewrite raw_asm_block_correct.
      rewrite denote_after.

      (* The head trees match by correctness of assign *)
      rewrite <- (bind_ret_r (ITree.bind (denote_expr e) _)).
      eapply bisimilar_bind'.
      { eapply compile_assign_correct; auto. }

      (* And remains to trivially relate the results *)

      intros []; simpl.
      repeat intro.
      force_left; force_right.
      Transparent eutt. red.
      rewrite <- eqit_Ret; auto.
      unfold state_invariant; auto.

    - (* Seq *)
      (* We commute [denote_asm] with [seq_asm] *)
      rewrite fold_to_itree'; simpl.
      rewrite seq_asm_correct. unfold to_itree'.

      (* And the result is immediate by indcution hypothesis *)
      eapply bisimilar_bind'.
      { eassumption. }
      intros [] ? _. rewrite (unique_f0 a').
      eassumption.

    - (* If *)
      (* We commute [denote_asm] with [if_asm] *)
      rewrite fold_to_itree'. simpl.
      rewrite if_asm_correct.
      unfold to_itree'.

      (* We now need to line up the evaluation of the test,
         and eliminate them by correctness of [compile_expr] *)
      repeat intro.
      rewrite interp_asm_bind.
      rewrite interp_imp_bind.
      eapply eutt_clo_bind.
      { apply compile_expr_correct; auto. }

      (* We get in return [sim_rel] related environments *)
      intros [g_imp' v] [g_asm' [l' x]] HSIM.

      (* We know that interpreting [GetVar tmp_if] is eutt to [Ret (g_asm,v)] *)
      generalize HSIM; intros EQ.  eapply sim_rel_get_tmp0 in EQ.
      unfold tmp_if.
      rewrite interp_asm_bind.
      rewrite EQ; clear EQ.
      rewrite bind_ret_; simpl.

      (* We can weaken [sim_rel] down to [Renv] *)
      apply sim_rel_Renv in HSIM.
      (* And finally conclude in both cases *)
      destruct v; simpl; auto.

    - (* While *)
      (* We commute [denote_asm] with [while_asm], and restructure the
         _Imp_ [loop] with [while_is_loop] *)
      simpl; rewrite fold_to_itree'.
      rewrite while_is_loop.
      rewrite while_asm_correct.
      Local Opaque denote_asm.

      unfold to_itree'.
      unfold loop. unfold iter at 2.
      unfold Iter_sub, Inr_sub, Inr_Kleisli, inr_, lift_ktree, cat, Cat_sub, cat, Cat_Kleisli.
      unfold from_bif, FromBifunctor_ktree_fin.
      cbn. rewrite 2 bind_ret_l. cbn.
      eapply (bisimilar_iter (fun x x' => (x = inl tt /\ x' = f0) \/ (x = inr tt /\ x' = fS f0))).
      2: {
        right. split. auto. apply unique_fin; reflexivity.
        }
      (* The two cases correspond to entering the loop, or exiting it*)
      intros ? ? [[] | []]; subst; cbn.

      (* The exiting case is trivial *)
      2:{ repeat intro.
          unfold to_bif, ToBifunctor_ktree_fin. rewrite !bind_ret_l. cbn.
          force_left. force_right.
          red; rewrite <- eqit_Ret; auto.
          unfold state_invariant. simpl.
          split; auto.
          setoid_rewrite split_fin_sum_L_L_f1.
          constructor. left. auto.
      }

      (* We now need to line up the evaluation of the test,
         and eliminate them by correctness of [compile_expr] *)
      repeat intro.
      rewrite !interp_imp_bind.
      rewrite !interp_asm_bind.
      rewrite !bind_bind.

      eapply eutt_clo_bind.
      { apply compile_expr_correct; auto. }

      intros [g_imp' v] [g_asm' [l' x]] HSIM.
      rewrite !interp_asm_bind.
      rewrite !bind_bind.

      (* We know that interpreting [GetVar tmp_if] is eutt to [Ret (g_asm,v)] *)
      generalize HSIM; intros EQ. eapply sim_rel_get_tmp0 in EQ.
      unfold tmp_if.

      rewrite EQ; clear EQ.
      rewrite bind_ret_; simpl.

      (* We can weaken [sim_rel] down to [Renv] *)
      apply sim_rel_Renv in HSIM.
      (* And now consider both cases *)
      destruct v; simpl; auto.
      + (* The false case is trivial *)
        force_left; force_right.
        red.
        rewrite <- eqit_Ret.
        unfold state_invariant. simpl.
        split; auto; constructor; auto.

      + (* In the true case, we line up the body of the loop to use the induction hypothesis *)
        rewrite !interp_asm_bind.
        rewrite !interp_imp_bind.
        rewrite !bind_bind.
        eapply eutt_clo_bind.
        { eapply IHs; auto. }
        intros [g_imp'' v''] [g_asm'' [l'' x']] [HSIM' ?].
        force_right; force_left.
        apply eqit_Ret.
        setoid_rewrite split_fin_sum_L_L_f1.
        constructor; auto.
        simpl. constructor; left; auto.

    - (* Skip *)

      simpl.
      unfold id_asm.
      pose proof (@pure_asm_correct).
      do 5 red in H. rewrite H.
      red. intros.
      setoid_rewrite interp_asm_ret.
      unfold interp_imp.
      rewrite interp_ret. unfold interp_map. rewrite interp_state_ret.
      apply eqit_Ret.
      unfold state_invariant. auto.
Qed.

End Correctness.

(* ================================================================= *)
(** ** Closing word. *)

(** Through this medium-sized example, we have seen how to use [itree]s to
    denote two languages, how to run them and how to prove correct a compiler
    between them.
    We have emphasized that the theory of [ktree]s allowed us to decouple
    all reasoning about the control-flow from the proof of the compiler itself.
    The resulting proof is entirely structurally inductive and equational. In
    particular, we obtain a final theorem relating potentially infinite
    computations without having to write any cofixed-point.

    If this result is encouraging, one might always wonder how things scale.

    A first good sanity check is to extend the languages with a _Print_
    instruction.
    It requires to add a new event to the language and therefore makes the
    correctness theorem relate trees actually still containing events.
    This change, which a good exercise to try, turns out to be as
    straightforward as one would hope. The only new lemma needed is to show
    that [interp_locals] leaves the new [Print] event untouched.
    This extension can be found in the _tutorial-print_ branch.

    More importantly, our compiler is fairly stupid and inefficient: it creates
    blocks for each compiled statement! One would hope to easily write and
    prove an optimization coalescing elementary blocks together.

    A first example of optimization at the [asm] level proved correct is
    demonstrated in the _AsmOptimization.v_ file.
 *)