From Undecidability.TM Require Import Util.TM_facts.

(* * Basic 1-Tape Machines *)

(* ** Helper functions *)
Section Mk_Mono.
  Variable (sig state : finType).
  Variable mono_trans : state -> option sig -> state * (option sig * move).
  Variable (init : state) (fin : state -> bool).

  Definition Mk_Mono_TM : TM sig 1.
  Proof.
    split with (state := state).
    - intros (q&tape).
      pose proof (mono_trans q (tape[@Fin0])) as (q', act).
      apply (q', [| act |]).
    - apply init.
    - apply fin.
  Defined. (* because definition *)

  Variable (F : finType) (R : Rel (tape sig) (F * tape sig)).

  Definition Mk_R_p : Rel (tapes sig 1) (F * tapes sig 1) :=
      fun tps1 '(p, tps2) => R (tps1[@Fin0]) (p, tps2[@Fin0]).

End Mk_Mono.

Arguments Mk_R_p { sig F } ( R ) x y /.

(* ** Do a single action *)
Section DoAct.
  Variable sig : finType.
  Variable c : sig.

  Variable act : option sig * move.

  Definition DoAct_TM :=
    {|
      trans := fun '(q, sym) => (true, [| act |]);
      start := false;
      halt x := x;
    |}.

  Definition DoAct : pTM sig unit 1 := (DoAct_TM; fun _ => tt).

  Definition DoAct_Rel : pRel sig unit 1 :=
    Mk_R_p (ignoreParam (fun t t' => t' = doAct t act)).

  Lemma DoAct_Sem : DoAct ⊨c(1) DoAct_Rel.
  Proof. intros t. destruct_tapes. cbn. unfold initc; cbn. eexists (mk_mconfig _ _); cbn; eauto. Qed.

End DoAct.

Arguments DoAct : simpl never.
Arguments DoAct_Rel { sig } act x y /.

(* *** Derived Machines *)

Section DoAct_Derived.
  Variable sig : finType.
  Variable c : sig. (* for Write *)
  Variable (D : move). (* for Move *)

  Definition Write : pTM sig unit 1 := DoAct (Some c, Nmove).

  Definition Write_Rel : pRel sig unit 1 :=
    Mk_R_p (ignoreParam (fun t t' => t' = midtape (left t) c (right t))).

  Lemma Write_Sem :
    Write ⊨c(1) Write_Rel.
  Proof.
    eapply RealiseIn_monotone.
    - apply DoAct_Sem.
    - reflexivity.
    - hnf. firstorder.
  Qed.

  Definition Move : pTM sig unit 1 := DoAct (None, D).

  Definition Move_Rel : pRel sig unit 1 :=
    Mk_R_p (ignoreParam (fun t t' => t' = tape_move (sig := sig) t D)).

  Lemma Move_Sem :
    Move ⊨c(1) Move_Rel.
  Proof.
    eapply RealiseIn_monotone.
    - apply DoAct_Sem.
    - reflexivity.
    - hnf. firstorder.
  Qed.

  Definition WriteMove : pTM sig unit 1 := DoAct (Some c, D).

  Definition WriteMove_Rel : pRel sig unit 1 :=
    Mk_R_p (ignoreParam (fun t t' => t' = tape_move (tape_write t (Some c)) D)).

  Lemma WriteMove_Sem :
    WriteMove ⊨c(1) WriteMove_Rel.
  Proof.
    eapply RealiseIn_monotone.
    - apply DoAct_Sem.
    - reflexivity.
    - hnf. firstorder.
  Qed.

End DoAct_Derived.

Arguments Write : simpl never.
Arguments Write_Rel { sig } c x y / : rename.

Arguments Move : simpl never.
Arguments Move { sig } D.
Arguments Move_Rel { sig } ( D ) x y /.

Arguments WriteMove : simpl never.
Arguments WriteMove_Rel { sig } (w D) x y / : rename.

(* ** Read a symbol *)

Section CaseChar.
  Variable sig : finType.
  Variable (F : finType) (f : option sig -> F).

  Definition CaseChar_TM : TM sig 1 :=
    {|
      trans := fun '(_, sym) => (Some (f sym[@Fin0]), [| (None, Nmove) |]);
      start := None;
      halt := fun s => match s with
                    | None => false
                    | Some _ => true
                    end;
    |}.

  Definition CaseChar : pTM sig F 1 := (CaseChar_TM; fun s => match s with None => f None (* not terminated yet *) | Some y => y end).

  Definition CaseChar_Rel : pRel sig F 1 :=
    fun t '(y, t') =>
      y = f (current t[@Fin0]) /\
      t' = t.

  Definition CaseChar_Sem : CaseChar ⊨c(1) CaseChar_Rel.
  Proof.
    intros t. destruct_tapes. cbn. unfold initc; cbn. cbv [step]; cbn. unfold current_chars; cbn.
    eexists (mk_mconfig _ _); cbv [step]; cbn. split. eauto. cbn. auto.
  Qed.

End CaseChar.

Arguments CaseChar : simpl never.
Arguments CaseChar {sig F} f.
Arguments CaseChar_Rel sig F f x y /.

Section ReadChar.

  Variable sig : finType.

  Definition ReadChar : pTM sig (option sig) 1 := CaseChar id.

  Definition ReadChar_Rel : pRel sig (option sig) 1 :=
    fun t '(y, t') =>
      y = current t[@Fin0] /\
      t' = t.

  Definition ReadChar_Sem : ReadChar ⊨c(1) ReadChar_Rel.
  Proof.
    eapply RealiseIn_monotone.
    - apply CaseChar_Sem.
    - reflexivity.
    - intros tin (yout, tout) (->&->). hnf. split; auto.
  Qed.

End ReadChar.

Arguments ReadChar : simpl never.
Arguments ReadChar {sig}.
Arguments ReadChar_Rel sig x y /.

(* ** Tactic Support *)

Ltac smpl_TM_Mono :=
  once lazymatch goal with
  | [ |- DoAct _ ⊨ _] => eapply RealiseIn_Realise; eapply DoAct_Sem
  | [ |- DoAct _ ⊨c(_) _] => eapply DoAct_Sem
  | [ |- projT1 (DoAct _) ↓ _] => eapply RealiseIn_TerminatesIn; eapply DoAct_Sem
  | [ |- Write _ ⊨ _] => eapply RealiseIn_Realise; eapply Write_Sem
  | [ |- Write _ ⊨c(_) _] => eapply Write_Sem
  | [ |- projT1 (Write _) ↓ _] => eapply RealiseIn_TerminatesIn; eapply Write_Sem
  | [ |- Move _ ⊨ _] => eapply RealiseIn_Realise; eapply Move_Sem
  | [ |- Move _ ⊨c(_) _] => eapply Move_Sem
  | [ |- projT1 (Move _) ↓ _] => eapply RealiseIn_TerminatesIn; eapply Move_Sem
  | [ |- WriteMove _ _ ⊨ _] => eapply RealiseIn_Realise; eapply WriteMove_Sem
  | [ |- WriteMove _ _ ⊨c(_) _] => eapply WriteMove_Sem
  | [ |- projT1 (WriteMove _ _) ↓ _] => eapply RealiseIn_TerminatesIn; eapply WriteMove_Sem
  | [ |- CaseChar _ ⊨ _] => eapply RealiseIn_Realise; eapply CaseChar_Sem
  | [ |- CaseChar _ ⊨c(_) _] => eapply CaseChar_Sem
  | [ |- projT1 (CaseChar _) ↓ _] => eapply RealiseIn_TerminatesIn; eapply CaseChar_Sem
  | [ |- ReadChar ⊨ _] => eapply RealiseIn_Realise; eapply ReadChar_Sem
  | [ |- ReadChar ⊨c(_) _] => eapply ReadChar_Sem
  | [ |- projT1 (ReadChar) ↓ _] => eapply RealiseIn_TerminatesIn; eapply ReadChar_Sem
  end.

Smpl Add smpl_TM_Mono : TM_Correct.


(** * Facts about H-VHDL Abstract Syntax *)

Require Import common.CoqLib.
Require Import common.ListLib.

Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.WellDefinedDesign.
Require Import hvhdl.HVhdlTypes.

(** ** Facts about [FoldLCs] and [foldl_cs] *)

Section FoldLCsFacts.

  Functional Scheme foldl_cs_ind := Induction for foldl_cs Sort Prop.

  Lemma FoldLCs_ex :
    forall {A : Type} (f : A -> cs -> A) cstmt a, exists res, FoldLCs f cstmt a res.
  Proof.
    induction cstmt; intros; try
                               (match goal with
                                | |- exists _, FoldLCs ?f ?cstmt ?a _ =>
                                    exists (f a cstmt); constructor
                                end).
    destruct (IHcstmt1 a) as (res, FoldLCs1).
    destruct (IHcstmt2 res) as (res', FoldLCs2).
    eexists; econstructor.
    eexact (FoldLCs1). eexact FoldLCs2.
  Qed.

  Lemma FoldLCs_determ :
    forall {A : Type} {f : A -> cs -> A} {cstmt a res res'},
      FoldLCs f cstmt a res ->
      FoldLCs f cstmt a res' ->
      res = res'.
  Proof.
    induction cstmt; try (inversion_clear 1; inversion_clear 1; auto).
    assert (e : a' = a'0) by (eapply IHcstmt1; eauto).
    rewrite e in *; eapply IHcstmt2; eauto.
  Qed.

  Lemma foldl_cs_build_list_by_app_In :
    forall {A : Type} {f : list A -> cs -> list A},
      (forall lofAs1 a,
        exists lofAs2, f lofAs1 a = lofAs1 ++ lofAs2) ->
      forall {cstmt} {lofAs} a, In a lofAs -> In a (foldl_cs f cstmt lofAs).
  Proof.
    intros A f ex_app cstmt lofAs.
    functional induction (foldl_cs f cstmt lofAs) using foldl_cs_ind; cbn.
    1, 2, 4: (match goal with
              | |- forall (_ : _), _ -> In _ (_ ?acc ?cstmt)  =>
                  destruct (ex_app acc cstmt) as [ acc1 f_app ];
                  rewrite f_app; auto
              end).
    auto.
  Qed.

  Lemma foldl_cs_build_list_by_app_nil :
    forall {A : Type} {f : list A -> cs -> list A} {g : cs -> list A},
      (forall lofAs1 a, f lofAs1 a = lofAs1 ++ g a) ->
      forall {cstmt} {lofAs}, foldl_cs f cstmt lofAs = lofAs ++ foldl_cs f cstmt [].
  Proof.
    intros A f g ex_app.
    induction cstmt; cbn; intros lofAs.
    1, 2, 4: match goal with
             | |- ?f ?acc ?cstmt = ?acc ++ ?f [] ?cstmt  =>
                 rewrite (ex_app acc cstmt); rewrite (ex_app [] cstmt); auto
             end.
    rewrite (IHcstmt1 lofAs).
    rewrite (IHcstmt2 (lofAs ++ foldl_cs f cstmt1 [])).
    rewrite (IHcstmt2 (foldl_cs f cstmt1 [])).
    rewrite app_assoc; reflexivity.
  Qed.

End FoldLCsFacts.

(** ** Facts about [get_cids] *)

Section GetCIdsFacts.

  Lemma get_cids_InCs :
    forall cstmt id__c id__e g i o, InCs (cs_comp id__c id__e g i o) cstmt -> In id__c (get_cids cstmt).
  Proof.
    unfold get_cids.
    set (build_cids := (fun (cids : list HVhdlTypes.ident) (cstmt : cs) => match cstmt with
                                                                           | cs_comp id _ _ _ _ => cids ++ [id]
                                                                           | _ => cids
                                                                           end)).
    intros cstmt.
    functional induction (foldl_cs build_cids cstmt []) using foldl_cs_ind;
    try (solve [inversion_clear 1]).

    (* CASE [cstmt = cs_comp] *)
    - inversion_clear 1; cbn; auto.

    (* CASE [cs_comp ∈ cstmt1 || cstmt2] *)
    - inversion_clear 1 as [ InCs0 | InCs1 ].
      (* SUBCASE [cs_comp ∈ cstmt1] *)
      + eapply foldl_cs_build_list_by_app_In; eauto; destruct a; cbn.
        1, 3, 4: (exists []; eapply app_nil_end).
        exists [id__c0]; reflexivity.
      + eauto.
  Qed.

  Lemma get_cids_app:
    forall cstmt1 cstmt2 : cs, get_cids (cs_par cstmt1 cstmt2) = get_cids cstmt1 ++ get_cids cstmt2.
  Proof.
    unfold get_cids.
    set (build_cids := (fun (cids : list HVhdlTypes.ident) (cstmt : cs) => match cstmt with
                                                                           | cs_comp id _ _ _ _ => cids ++ [id]
                                                                           | _ => cids
                                                                           end)).
    cbn; intros *.
    erewrite @foldl_cs_build_list_by_app_nil with (lofAs := foldl_cs build_cids cstmt1 [])
                                                  (g := fun cstmt => match cstmt with
                                                                     | cs_comp id _ _ _ _ => [id]
                                                                     | _ => []
                                                                     end).
    reflexivity.
    destruct a; cbn.
    1, 3, 4: (eapply app_nil_end).
    reflexivity.
  Qed.

  Lemma get_cids_In_ex:
    forall (cstmt : cs) (id__c : ident),
      In id__c (get_cids cstmt) ->
      exists (id__e : ident) (g : genmap) (i : inputmap) (o : outputmap), InCs (cs_comp id__c id__e g i o) cstmt.
  Proof.
    induction cstmt; try (solve [inversion_clear 1]).
    inversion_clear 1 as [ eq_idc | False_ ];
      [ subst; exists id__e, g, i, o; reflexivity | destruct False_ ].
    rewrite get_cids_app.
    intros id__c In_app; edestruct in_app_or as [ In1 | In2 ]; eauto;
      [ edestruct IHcstmt1 as [ id__e [ g [ i [ o InCs1 ] ] ] ]
      | edestruct IHcstmt2 as [ id__e [ g [ i [ o InCs2 ] ] ] ] ];
      eauto; do 4 eexists; [ left | right ]; eauto.
  Qed.

End GetCIdsFacts.

(** ** Facts about [InCs] *)

Section InCsFacts.

  Lemma InCs_NoDup_comp_eq :
    forall {cstmt id__c id__e0 g0 i0 o0 id__e1 g1 i1 o1},
      InCs (cs_comp id__c id__e0 g0 i0 o0) cstmt ->
      InCs (cs_comp id__c id__e1 g1 i1 o1) cstmt ->
      NoDup (get_cids cstmt) ->
      cs_comp id__c id__e0 g0 i0 o0 = cs_comp id__c id__e1 g1 i1 o1.
  Proof.
    induction cstmt; try (solve [inversion 1]).
    destruct 1; destruct 1; reflexivity.

    inversion_clear 1 as [ InCs0 | InCs0 ];
      inversion_clear 1 as [ InCs1 | InCs1 ]; intros NoDup_par;
      [ eapply IHcstmt1; eauto | | | eapply IHcstmt2; eauto ].

    (* CASE [c0, c1 ∈ cstmt1] and CASE [c0, c1 ∈ cstmt2]. *)
    1,4 : (rewrite get_cids_app in NoDup_par; eauto with nodup).

    (* CASE [c0 ∈ cstmt1] and [c1 ∈ cstmt2], and CASE [c0 ∈ cstmt2]
       and [c1 ∈ cstmt1]. Contradicts NoDup in the two cases. *)
    1, 2: (elimtype False;
           rewrite get_cids_app in NoDup_par;
           eapply nodup_app_not_in; eauto; eapply get_cids_InCs; eauto).
  Qed.

End InCsFacts.

Lemma flatten_cs_ex : forall beh, exists lofcs, FlattenCs beh lofcs.
Proof.
  induction beh.

  (* CASE simple Process *)
  - exists [cs_ps id__p vars body]; auto.

  (* CASE simple Component Instance *)
  - exists [cs_comp id__c id__e g i o]; auto.

  (* CASE parallel stmts *)
  - lazymatch goal with
    | [ IH1: exists _, _, IH2: exists _, _ |- _ ] =>
      inversion_clear IH1 as (lofcs1, Hflat1);
        inversion_clear IH2 as (lofcs2, Hflat2);
        exists (lofcs1 ++ lofcs2);
        auto
    end.

  (* CASE null *)
  - exists nil; auto.
Qed.

(** FlattenCs is a deterministic relation *)

Lemma flatten_cs_determ :
  forall {behavior lofcs },
    FlattenCs behavior lofcs ->
    forall {lofcs'},
    FlattenCs behavior lofcs' ->
    lofcs = lofcs'.
Proof.
  induction 1; only 1 - 6: inversion_clear 1; auto.
  - inversion H1; auto.
  - rewrite (IHFlattenCs l0 H1); reflexivity.
  - inversion_clear H1; rewrite (IHFlattenCs l' H2); reflexivity.
  - rewrite (IHFlattenCs l0 H1); reflexivity.
  - inversion_clear H1; rewrite (IHFlattenCs l' H2); reflexivity.
  - inversion_clear 1 in H H0; auto.
    + inversion H; apply IHFlattenCs2; auto.
    + inversion H; rewrite (IHFlattenCs2 l0 H2); reflexivity.
    + inversion H; rewrite (IHFlattenCs2 l0 H2); reflexivity.
    + rewrite (IHFlattenCs1 l0 H2); rewrite (IHFlattenCs2 l'0 H3); reflexivity.
Defined.


Definition Pi2_C (A B:Ens) : class.
Proof.
apply (Build_class' (Pi2_P (OrdPair A B)) ).
intros.
eapply (Pi2_sound_lem1 _ a); assumption.
Defined.

(* (Pi2_sound_lem2 _ _ _ _)
Check (Build_class (Pi2_P (OrdPair A B)) ).
Search Comp.
*)

(* definitions for classes *)
(* DEPRECATED
Definition cPair (A B:class) : class.
Proof.
unshelve eapply Build_class'.
+ intro x. exact (cEQ x A \/ cEQ x B).
+ intros a b aeqb H.
  destruct H as [H1|H2].
  * left.
    unfold cEQ in *|-*.
    rewrite axExt in aeqb.
    intro z.
    symmetry.
    rewrite <- H1.
    exact (aeqb z).
  * right.
    unfold cEQ in *|-*.
    rewrite axExt in aeqb.
    intro z.
    symmetry.
    rewrite <- H2.
    exact (aeqb z).
Defined.
*)
(* DEPRECATED
Definition cPow (A:class) : class.
Proof.
unshelve eapply Build_class'.
+ intro x. exact (issubclass x A).
+ simpl. intros a b aeqb H.
  unfold issubclass in * |- *.
  intros x bx.
  apply axExtC in aeqb.
  unfold cEQ in aeqb.
  rewrite <- (aeqb x) in bx.
  apply (H x bx).
Defined.
*)
(* (A:Ens->Prop) is also fine. *)
(*Definition cUnion (A:class) : class.
Proof.
unshelve eapply Build_class.
+ intro x. exact (exists z : Ens, A z /\ IN x z).
+ apply two_sided. intros a b aeqb H.
  destruct H as [z [K1 K2]].
  exists z. split. exact K1.
  apply IN_sound_left with (E:=a); assumption.
Defined.*)

(*forall z : Ens, a z -> b z
exact (issubclass x A).
exact (cEQ x A \/ cEQ x B).
    unfold stro*)

-----------------------------
(*
Definition Build_class' : forall Vprty : Ens -> Prop,
       (forall a b : Ens, EQ a b -> Vprty a -> Vprty b) -> class.
Proof. intros.
unshelve eapply Build_class.
exact Vprty.
apply two_sided. exact H.
Defined.
*)

----------------------------
(* Existential quantification *)
(* Rename:
EXType  to  ex
EXTypei to  ex_intro
*)

(* Cartesian product in Type *)
(*Inductive prod_t (A B : Type) : Type :=
    pair_t : A -> B -> prod_t A B.*)
(* Rename:
prod_t  to  prod
pair    to  pair
*)

(* Recursive Definition of the extentional equality on sets *)
(* BEST
Fixpoint EQ (E1 E2: Ens) {struct E2}: Prop.
Proof.
destruct E1 as [A f].
destruct E2 as [B g].
apply and.
exact (forall x : A, exists y : B, EQ (f x) (g y)).
exact (forall y : B, exists x : A, EQ (f x) (g y)).
Show Proof.
Defined.
*)

(* Both "{struct E1}" and "{struct E2}" works good. *)

(* ===================================== *)
(* START OF THE WORKING BUT USELESS CODE *)
(* ===================================== *)

(*
'isas' is a constructive version of 'ias'.
*)
Record isas (C : class) := {
 dmn : Ens;
 eqvias: cEQ C dmn; (*forall w : Ens, c w <-> IN w dmn;*)
}.

Theorem jhkl (x:Ens) (A:class) (H:cEQ A x): isas A.
Proof.
unshelve eapply Build_isas.
exact x. exact H.
Defined.

Theorem scosisas : forall (s : class) (m : Ens),
       (forall x : Ens, s x -> m x) -> isas s.
Proof. intros s m sc.
unshelve eapply Build_isas.
exact (Comp m s).
intro w.
split.
+ intro u.
  pose(y:=sc w u).
  (*unfold esiacf in * |- *.*)
  apply IN_P_Comp.
  * intros w1 w2 K H.
    rewrite <- (sound' s). exact K. exact H. (*apply (rewr _ _  K H).*)
  * exact y.
  * exact u.
+ intro u.
  apply (IN_Comp_P m).
  apply sound2rewr.
  exact u.
Defined.

(* strange proofs ... *)
Lemma cIN_sound_right' (A:class) (D k:Ens): A k -> cEQ A D -> IN k D.
Proof.
intros H K. unfold cEQ in K. apply K in H. simpl in H. exact H.
Defined.

Lemma cIN_sound_iff (A:class) (D k:Ens) (K:cEQ A D): A k <-> IN k D.
Proof.
split; intros H;
apply K in H; (*simpl in H;*) exact H. (*twice*)
Defined.

Definition decid (A:Type) := sum A (A->False).

Record xclass := {
 clprj :> class;
 ciset :  decid (isas clprj);
}.

Definition xPair (A B:xclass) : xclass.
Proof.
ueapp Build_xclass.
exact (cPair (clprj A) (clprj B)).
left.
destruct (ciset A) as [ASE|APC], (ciset B) as [BSE|BPC].
+ unshelve eapply Build_isas.
  exact (Paire (dmn _ ASE) (dmn _ BSE)).
  intro z; split; intro x.
  - simpl in x. destruct x as [HA|HB].
    * simpl.
      change _ with (IN z (Paire (dmn A ASE) (dmn B BSE))).
      exists true; simpl.
      apply axExtC.
      intro k; split; intro m.
  ++ simpl. simpl in m.
     apply (HA k) in m.
     eapply (eqvias A ASE ). exact m.
     (* eapply cIN_sound_right. exact m.
     exact (eqvias A ASE).*)
  ++ simpl. simpl in m.
     apply (HA k). eapply (eqvias A ASE ) in m. assumption.
    * simpl.
      change _ with (IN z (Paire (dmn A ASE) (dmn B BSE))).
      exists false; simpl.
      apply axExtC.
      intro k; split; intro m.
  ++ simpl. simpl in m.
     apply (HB k) in m.
     eapply (eqvias B BSE ). exact m.
     (* eapply cIN_sound_right. exact m.
     exact (eqvias A ASE).*)
  ++ simpl. simpl in m.
     apply (HB k). eapply (eqvias B BSE ) in m. assumption.
  - simpl in * |- *.
    destruct x as [m J].
    destruct m; simpl in J.
    * left. apply axExtC in J.
(*    eapply cEQ_tran.
      apply J.
      intros a. split; intro h.
simpl in h.
simpl.*)
Abort.
(* END OF THE WORKING BUT USELESS CODE *)


From Mtac2 Require Import Mtac2.

Set Universe Polymorphism.

Set Printing Universes.

(* Demonstrate that id indeed has the right type *)
Definition test@{i j} : Type@{i} -> Type@{max(i,j)} := id.

(* Demonstrate that ltac gets it right *)
Lemma testL@{i j} : Type@{i} -> Type@{max(i,j)}.
Proof. exact id. Qed.

(* M.ret somehow works in 8.8 *)
Lemma testM@{i j} : Type@{i} -> Type@{max(i,j)}.
MProof.
M.ret id.
Qed.

(* runTac works too *)
Lemma testMTac@{i j} : Type@{i} -> Type@{max(i,j)}.
MProof.
T.exact id.
Qed.

(* apply doesn't generate a new universe index (it used to be the case) *)
Lemma testMTacApply@{i j} : Type@{i} -> Type@{max(i,j)}.
MProof.
T.apply (@id).
Qed.

(* and ltac's 8.8  doesn't do that either *)
Lemma testLApply@{i j} : Type@{i} -> Type@{max(i,j)}.
Proof. apply @id. Qed.

Notation "p '=e>' b" := (pbase p%core (fun _ => b%core) UniEvarconv)
  (no associativity, at level 201) : pattern_scope.
Notation "p '=e>' [ H ] b" := (pbase p%core (fun H => b%core) UniEvarconv)
  (no associativity, at level 201, H at next level) : pattern_scope.

Definition test_match@{k m+} {A:Type@{k}} (x:A) : tactic :=
  mmatch A with
  | [? B:Type@{m}] B =e> T.exact x
  end.

Lemma testMmatch@{i j} : Type@{i} -> Type@{max(i,j)}.
MProof.
test_match (fun x=>x).
Qed.

Lemma testMmatch'@{i j} : Type@{i} -> Type@{j}.
MProof.
test_match (fun x=>x).
Qed.
Print testMmatch.
Print testMmatch'.

Definition testdef : Type -> Type := fun x=>x.
Lemma testret : Type -> Type.
MProof.
M.ret (fun x=>x).
Qed. (* If this fails we likely swapped LHS & RHS of the cumulative unification in [ifM] *)
Print testret.

Lemma testexact : Type -> Type.
MProof.
T.exact (fun x=>x).
Qed.
About testexact.


Require compcert.backend.Mach.

Import Coqlib.
Import Integers.
Import AST.
Import Values.
Import Memory.
Import Globalenvs.
Import Events.
Import Smallstep.
Import Locations.
Import Conventions.
Export Mach.

Section WITHCONFIG.
Context `{compiler_config: CompilerConfiguration}.

(** Execution of Mach functions with Asm-style arguments (long long 64-bit integers NOT allowed) *)

Inductive initial_state (lm: regset) (init_sp: val) (p: Mach.program) (i: ident) (sg: signature) (args: list val) (m: mem): state -> Prop :=
| initial_state_intro
    b
    (Hb: Genv.find_symbol (Genv.globalenv p) i = Some b)
    (Hargs: extcall_arguments lm m init_sp sg args)
  :
      initial_state lm init_sp p i sg args m (Callstate nil b lm m)
.

Inductive final_state (lm: regset) (sg: signature): state -> (list val * mem) -> Prop :=
| final_state_intro
    rs
    v
    (Hv: v = List.map rs (loc_result sg))
    (** Callee-save registers.
        We use Val.lessdef instead of eq because the Stacking pass does not exactly preserve their values. *)
    (CALLEE_SAVE: forall r,
       ~ In r destroyed_at_call ->
       Val.lessdef (lm r) (rs r))
    m :
    final_state lm sg (Returnstate nil rs m) (v, m)
.

Definition semantics
           (return_address_offset: function -> code -> int -> Prop)
           (lm: regset) (init_sp init_ra: val)
           (p: Mach.program) (i: ident) (sg: signature) (args: list val) (m: mem) :=
  Semantics (Mach.step return_address_offset init_sp init_ra) (initial_state lm init_sp p i sg args m) (final_state lm sg) (Genv.globalenv p).

End WITHCONFIG.


From Undecidability Require Import TM.Util.Prelim TM.Util.TM_facts.

Set Default Goal Selector "!".

(* * Mirror Operator *)

Section Mirror.
  Variable (n : nat) (sig : finType).

  Definition mirror_act : (option sig * move) -> (option sig * move) :=
    map_snd mirror_move.

  Definition mirror_acts : Vector.t (option sig * move) n -> Vector.t (option sig * move) n :=
    Vector.map mirror_act.

  Variable F : finType.
  Variable pM : pTM sig F n.

  Definition Mirror_trans :
    state (projT1 pM) * Vector.t (option sig) n ->
    state (projT1 pM) *
    Vector.t (option sig * move) n :=
    fun qsym =>
      let (q', act) := trans qsym in
      (q', mirror_acts act).

  Definition MirrorTM : TM sig n :=
    {|
      trans := Mirror_trans;
      start := start (projT1 pM);
      halt := halt (m := projT1 pM);
    |}.

  Definition Mirror : pTM sig F n :=
    (MirrorTM; projT2 pM).

  Definition mirrorConf : mconfig sig (state (projT1 pM)) n -> mconfig sig (state (projT1 pM)) n :=
    fun c => mk_mconfig (cstate c) (mirror_tapes (ctapes c)).

  Lemma mirrorConf_involution c : mirrorConf (mirrorConf c) = c.
  Proof. destruct c as [q t]. unfold mirrorConf. cbn. f_equal. apply mirror_tapes_involution. Qed.

  Lemma mirrorConf_injective c1 c2 : mirrorConf c1 = mirrorConf c2 -> c1 = c2.
  Proof. destruct c1 as [q1 t1], c2 as [q2 t2]. unfold mirrorConf. cbn. intros H; inv H. f_equal. now apply mirror_tapes_injective. Qed.

  Lemma current_chars_mirror_tapes (t : tapes sig n) :
    current_chars (mirror_tapes t) = current_chars t.
  Proof. apply Vector.eq_nth_iff; intros i ? <-. autounfold with tape. now simpl_tape. Qed.

  Lemma doAct_mirror (t : tape sig) (act : option sig * move) :
    doAct (mirror_tape t) act = mirror_tape (doAct t (mirror_act act)).
  Proof. now destruct act as [ [ s | ] [ | | ]]; cbn; simpl_tape. Qed.

  Lemma doAct_mirror_multi (t : tapes sig n) (acts : Vector.t (option sig * move) n) :
    doAct_multi (mirror_tapes t) acts = mirror_tapes (doAct_multi t (mirror_acts acts)).
  Proof. apply Vector.eq_nth_iff; intros i ? <-. unfold doAct_multi, mirror_acts, mirror_tapes. simpl_tape. apply doAct_mirror. Qed.

  Lemma mirror_step c :
    step (M := projT1 pM) (mirrorConf c) = mirrorConf (step (M := projT1 Mirror) c).
  Proof.
    unfold step; cbn -[doAct_multi]. unfold Mirror_trans. cbn.
    destruct c as [q t]; cbn. rewrite current_chars_mirror_tapes.
    destruct (trans (q, current_chars t)) as [q' acts].
    unfold mirrorConf; cbn. f_equal. apply doAct_mirror_multi.
  Qed.

  Lemma mirror_lift k c1 c2 :
    loopM (M := projT1 Mirror)             c1  k = Some             c2 ->
    loopM (M := projT1 pM    ) (mirrorConf c1) k = Some (mirrorConf c2).
  Proof.
    unfold loopM. intros HLoop.
    apply loop_lift with (lift := mirrorConf) (f' := step (M:=projT1 pM)) (h' := haltConf (M:=projT1 pM)) in HLoop; auto.
    - intros ? _. now apply mirror_step.
  Qed.

  Lemma mirror_unlift k c1 c2 :
    loopM (M := projT1     pM) (mirrorConf c1) k = Some (mirrorConf c2) ->
    loopM (M := projT1 Mirror) (           c1) k = Some (           c2).
  Proof.
    unfold loopM. intros HLoop.
    apply loop_unlift with (lift := mirrorConf) (f := step (M:=MirrorTM)) (h := haltConf (M:=MirrorTM)) in HLoop
      as (? & HLoop & <- % mirrorConf_injective); auto.
    - intros ? _. now apply mirror_step.
  Qed.

  Definition Mirror_Rel (R : pRel sig F n) : pRel sig F n :=
    fun t '(l, t') => R (mirror_tapes t) (l, mirror_tapes t').

  Lemma Mirror_Realise R :
    pM ⊨ R -> Mirror ⊨ Mirror_Rel R.
  Proof.
    intros HRealise. intros t i outc HLoop.
    apply (HRealise (mirror_tapes t) i (mirrorConf outc)).
    now apply mirror_lift in HLoop.
  Qed.

  Definition Mirror_T (T : tRel sig n) : tRel sig n :=
    fun t k => T (mirror_tapes t) k.

  Lemma Mirror_Terminates T :
    projT1 pM ↓ T -> projT1 Mirror ↓ Mirror_T T.
  Proof.
    intros HTerm. hnf. intros t1 k H1. hnf in HTerm. specialize (HTerm (mirror_tapes t1) k H1) as (outc&H).
    exists (mirrorConf outc). apply mirror_unlift. cbn. now rewrite mirrorConf_involution.
  Qed.

  Lemma Mirror_RealiseIn R (k : nat) :
    pM ⊨c(k) R -> Mirror ⊨c(k) Mirror_Rel R.
  Proof.
    intros H.
    eapply Realise_total. split.
    - eapply Mirror_Realise. now eapply Realise_total.
    - eapply TerminatesIn_monotone.
      + eapply Mirror_Terminates. now eapply Realise_total.
      + firstorder.
  Qed.

End Mirror.

Arguments Mirror : simpl never.
Arguments Mirror_Rel { n sig F } R x y /.
Arguments Mirror_T { n sig } T x y /.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.DataCenter.

Declare ML Module "mirrorsolve".

SetSMTSolver "cvc4".
SetSMTLang "BV".

Lemma datacenter_self_equiv:
  lang_equiv_state
    (P4A.interp DataCenter.aut)
    (P4A.interp DataCenter.aut)
    DataCenter.ParseEth0
    DataCenter.ParseEth0.
Proof.
  solve_lang_equiv_state_admit DataCenter.state_eqdec DataCenter.state_eqdec true.
Time Admitted.


Require Import Raft.
Require Import RaftRefinementInterface.
Require Import CommonDefinitions.

Section RequestVoteReplyTermSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition requestVoteReply_term_sanity (net : network) : Prop :=
    forall t p,
      In p (nwPackets net) ->
      pBody p = RequestVoteReply t true ->
      t <= currentTerm (snd (nwState net (pDst p))).

  Class requestVoteReply_term_sanity_interface : Prop :=
    {
      requestVoteReply_term_sanity_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          requestVoteReply_term_sanity net
    }.
End RequestVoteReplyTermSanity.


From iris.proofmode Require Import tactics.
From iris.program_logic Require Export weakestpre.
From iris.base_logic Require Export invariants.
From iris_examples.logrel.F_mu_ref Require Export rules_binary typing.
From iris.algebra Require Import list.
From stdpp Require Import tactics.
Import uPred.

(* HACK: move somewhere else *)
Ltac auto_equiv :=
  (* Deal with "pointwise_relation" *)
  repeat lazymatch goal with
  | |- pointwise_relation _ _ _ _ => intros ?
  end;
  (* Normalize away equalities. *)
  repeat match goal with
  | H : _ ≡{_}≡ _ |-  _ => apply (discrete_iff _ _) in H
  | _ => progress simplify_eq
  end;
  (* repeatedly apply congruence lemmas and use the equalities in the hypotheses. *)
  try (f_equiv; fast_done || auto_equiv).

Definition logN : namespace := nroot .@ "logN".

(** interp : is a unary logical relation. *)
Section logrel.
  Context `{heapG Σ, cfgSG Σ}.
  Notation D := (prodO valO valO -n> iPropO Σ).
  Implicit Types τi : D.
  Implicit Types Δ : listO D.
  Implicit Types interp : listO D → D.

  Definition interp_expr (τi : listO D -n> D) (Δ : listO D)
      (ee : expr * expr) : iProp Σ := (∀ K,
    ⤇ fill K (ee.2) →
    WP ee.1 {{ v, ∃ v', ⤇ fill K (of_val v') ∗ τi Δ (v, v') }})%I.
  Global Instance interp_expr_ne n :
    Proper (dist n ==> dist n ==> (=) ==> dist n) interp_expr.
  Proof. solve_proper. Qed.

  Program Definition ctx_lookup (x : var) : listO D -n> D := λne Δ,
    from_option id (cconst True)%I (Δ !! x).
  Solve Obligations with solve_proper.

  Program Definition interp_unit : listO D -n> D := λne Δ ww,
    (⌜ww.1 = UnitV⌝ ∧ ⌜ww.2 = UnitV⌝)%I.
  Solve Obligations with solve_proper_alt.

  Program Definition interp_prod
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ ww,
    (∃ vv1 vv2, ⌜ww = (PairV (vv1.1) (vv2.1), PairV (vv1.2) (vv2.2))⌝ ∧
                interp1 Δ vv1 ∧ interp2 Δ vv2)%I.
  Solve Obligations with repeat intros ?; simpl; auto_equiv.

  Program Definition interp_sum
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ ww,
    ((∃ vv, ⌜ww = (InjLV (vv.1), InjLV (vv.2))⌝ ∧ interp1 Δ vv) ∨
     (∃ vv, ⌜ww = (InjRV (vv.1), InjRV (vv.2))⌝ ∧ interp2 Δ vv))%I.
  Solve Obligations with repeat intros ?; simpl; auto_equiv.

  Program Definition interp_arrow
          (interp1 interp2 : listO D -n> D) : listO D -n> D :=
    λne Δ ww,
    (□ ∀ vv, interp1 Δ vv →
             interp_expr
               interp2 Δ (App (of_val (ww.1)) (of_val (vv.1)),
                          App (of_val (ww.2)) (of_val (vv.2))))%I.
  Solve Obligations with repeat intros ?; simpl; auto_equiv.

  Program Definition interp_forall
      (interp : listO D -n> D) : listO D -n> D := λne Δ ww,
    (□ ∀ τi,
          ⌜∀ ww, Persistent (τi ww)⌝ →
          interp_expr
            interp (τi :: Δ) (TApp (of_val (ww.1)), TApp (of_val (ww.2))))%I.
  Solve Obligations with repeat intros ?; simpl; auto_equiv.

  Program Definition interp_rec1
      (interp : listO D -n> D) (Δ : listO D) (τi : D) : D := λne ww,
    (□ ∃ vv, ⌜ww = (FoldV (vv.1), FoldV (vv.2))⌝ ∧ ▷ interp (τi :: Δ) vv)%I.
  Solve Obligations with repeat intros ?; simpl; auto_equiv.

  Global Instance interp_rec1_contractive
    (interp : listO D -n> D) (Δ : listO D) : Contractive (interp_rec1 interp Δ).
  Proof. by solve_contractive. Qed.

  Lemma fixpoint_interp_rec1_eq (interp : listO D -n> D) Δ x :
    fixpoint (interp_rec1 interp Δ) x ≡ interp_rec1 interp Δ (fixpoint (interp_rec1 interp Δ)) x.
  Proof. exact: (fixpoint_unfold (interp_rec1 interp Δ) x). Qed.

  Program Definition interp_rec (interp : listO D -n> D) : listO D -n> D := λne Δ,
    fixpoint (interp_rec1 interp Δ).
  Next Obligation.
    intros interp n Δ1 Δ2 HΔ; apply fixpoint_ne => τi ww. solve_proper.
  Qed.

  Program Definition interp_ref_inv (ll : loc * loc) : D -n> iPropO Σ := λne τi,
    (∃ vv, ll.1 ↦ vv.1 ∗ ll.2 ↦ₛ vv.2 ∗ τi vv)%I.
  Solve Obligations with repeat intros ?; simpl; auto_equiv.

  Program Definition interp_ref
      (interp : listO D -n> D) : listO D -n> D := λne Δ ww,
    (∃ ll, ⌜ww = (LocV (ll.1), LocV (ll.2))⌝ ∧
           inv (logN .@ ll) (interp_ref_inv ll (interp Δ)))%I.
  Solve Obligations with repeat intros ?; simpl; auto_equiv.

  Fixpoint interp (τ : type) : listO D -n> D :=
    match τ return _ with
    | TUnit => interp_unit
    | TProd τ1 τ2 => interp_prod (interp τ1) (interp τ2)
    | TSum τ1 τ2 => interp_sum (interp τ1) (interp τ2)
    | TArrow τ1 τ2 => interp_arrow (interp τ1) (interp τ2)
    | TVar x => ctx_lookup x
    | TForall τ' => interp_forall (interp τ')
    | TRec τ' => interp_rec (interp τ')
    | Tref τ' => interp_ref (interp τ')
    end.
  Notation "⟦ τ ⟧" := (interp τ).

  Definition interp_env (Γ : list type)
      (Δ : listO D) (vvs : list (val * val)) : iProp Σ :=
    (⌜length Γ = length vvs⌝ ∗ [∗] zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vvs)%I.
  Notation "⟦ Γ ⟧*" := (interp_env Γ).

  Class env_Persistent Δ :=
    ctx_persistentP : Forall (λ τi, ∀ vv, Persistent (τi vv)) Δ.
  Global Instance ctx_persistent_nil : env_Persistent [].
  Proof. by constructor. Qed.
  Global Instance ctx_persistent_cons τi Δ :
    (∀ vv, Persistent (τi vv)) → env_Persistent Δ → env_Persistent (τi :: Δ).
  Proof. by constructor. Qed.
  Global Instance ctx_persistent_lookup Δ x vv :
    env_Persistent Δ → Persistent (ctx_lookup x Δ vv).
  Proof. intros HΔ; revert x; induction HΔ=>-[|?] /=; apply _. Qed.
  Global Instance interp_persistent τ Δ vv :
    env_Persistent Δ → Persistent (⟦ τ ⟧ Δ vv).
  Proof.
    revert vv Δ; induction τ=> vv Δ HΔ; simpl; try apply _.
    rewrite /Persistent fixpoint_interp_rec1_eq /interp_rec1 /= intuitionistically_into_persistently.
    by apply persistently_intro'.
  Qed.
  Global Instance interp_env_base_persistent Δ Γ vs :
  env_Persistent Δ → TCForall Persistent (zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vs).
  Proof.
    intros HΔ. revert vs.
    induction Γ => vs; simpl; destruct vs; constructor; apply _.
  Qed.
  Global Instance interp_env_persistent Γ Δ vvs :
    env_Persistent Δ → Persistent (⟦ Γ ⟧* Δ vvs) := _.

  Lemma interp_weaken Δ1 Π Δ2 τ :
    ⟦ τ.[upn (length Δ1) (ren (+ length Π))] ⟧ (Δ1 ++ Π ++ Δ2)
    ≡ ⟦ τ ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Π Δ2. induction τ=> Δ1 Π Δ2; simpl; auto.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi ww /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. by apply (IHτ (_ :: _)).
    - intros ww; simpl; properness; auto. by apply IHτ.
  Qed.

  Lemma interp_subst_up Δ1 Δ2 τ τ' :
    ⟦ τ ⟧ (Δ1 ++ interp τ' Δ2 :: Δ2)
    ≡ ⟦ τ.[upn (length Δ1) (τ' .: ids)] ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Δ2; induction τ=> Δ1 Δ2; simpl; auto.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi ww /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..].
      case EQ: (x - length Δ1) => [|n]; simpl.
      { symmetry. asimpl. apply (interp_weaken [] Δ1 Δ2 τ'). }
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. apply (IHτ (_ :: _)).
    - intros ww; simpl; properness; auto. by apply IHτ.
  Qed.

  Lemma interp_subst Δ2 τ τ' v : ⟦ τ ⟧ (⟦ τ' ⟧ Δ2 :: Δ2) v ≡ ⟦ τ.[τ'/] ⟧ Δ2 v.
  Proof. apply (interp_subst_up []). Qed.

  Lemma interp_env_length Δ Γ vvs : ⟦ Γ ⟧* Δ vvs ⊢ ⌜length Γ = length vvs⌝.
  Proof. by iIntros "[% ?]". Qed.

  Lemma interp_env_Some_l Δ Γ vvs x τ :
    Γ !! x = Some τ → ⟦ Γ ⟧* Δ vvs ⊢ ∃ vv, ⌜vvs !! x = Some vv⌝ ∧ ⟦ τ ⟧ Δ vv.
  Proof.
    iIntros (?) "[Hlen HΓ]"; iDestruct "Hlen" as %Hlen.
    destruct (lookup_lt_is_Some_2 vvs x) as [v Hv].
    { by rewrite -Hlen; apply lookup_lt_Some with τ. }
    iExists v; iSplit. done. iApply (big_sepL_elem_of with "HΓ").
    apply elem_of_list_lookup_2 with x.
    rewrite lookup_zip_with; by simplify_option_eq.
  Qed.

  Lemma interp_env_nil Δ : ⟦ [] ⟧* Δ [].
  Proof. iSplit; simpl; auto. Qed.
  Lemma interp_env_cons Δ Γ vvs τ vv :
    ⟦ τ :: Γ ⟧* Δ (vv :: vvs) ⊣⊢ ⟦ τ ⟧ Δ vv ∗ ⟦ Γ ⟧* Δ vvs.
  Proof.
    rewrite /interp_env /= (assoc _ (⟦ _ ⟧ _ _)) -(comm _ ⌜_ = _⌝%I) -assoc.
    by apply sep_proper; [apply pure_proper; lia|].
  Qed.

  Lemma interp_env_ren Δ (Γ : list type) vvs τi :
    ⟦ subst (ren (+1)) <$> Γ ⟧* (τi :: Δ) vvs ⊣⊢ ⟦ Γ ⟧* Δ vvs.
  Proof.
    apply sep_proper; [apply pure_proper; by rewrite fmap_length|].
    revert Δ vvs τi; induction Γ=> Δ [|v vs] τi; csimpl; auto.
    apply sep_proper; auto. apply (interp_weaken [] [τi] Δ).
  Qed.

End logrel.

Typeclasses Opaque interp_env.
Notation "⟦ τ ⟧" := (interp τ).
Notation "⟦ τ ⟧ₑ" := (interp_expr (interp τ)).
Notation "⟦ Γ ⟧*" := (interp_env Γ).


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 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 Simulator.
Require Export PBFT.
Require Export PBFTcollision_resistant.
Require Import Ascii String.
(*Require Import SHA256.*)

(*
    We'll define here an instance of PBFT so that we can simulate it.
 *)

(* ================== INSTANCE OF PBFT ================== *)

Section PBFTinstance.

(*  Class NumNodes := MkNumNodes { total_num_faults : nat; total_num_clients : nat }.
  Context { p_num_nodes : NumNodes }.*)

  (* ============================================ *)
  (* total_num_faults *)
  Definition F := 1.

  (* total_num_clients is C+1 *)
  Definition C := 0.

  (* max requests in progress *)
  Definition MIP := 2.

  (* water-mark range *)
  Definition WMR := 100.

  (* checkpoint period *)
  Definition CP := 50.
  (* ============================================ *)

  Definition pbft_digest : Set := list nat.

  Lemma pbft_digest_deq : Deq pbft_digest.
  Proof.
    introv; apply list_eq_dec.
    apply deq_nat.
  Defined.

  Inductive sending_key_stub : Set :=
  | pbft_sending_key_stub.

  Inductive receiving_key_stub : Set :=
  | pbft_receiving_key_stub.

  Definition pbft_sending_key   : Set := sending_key_stub.
  Definition pbft_receiving_key : Set := receiving_key_stub.

  (*Definition F : nat := 1.*)
  Definition nreps (F : nat) : nat := 3 * F + 1.

  Definition replica (F : nat) : Set := nat_n (nreps F).

  Lemma replica_deq (F : nat) : Deq (replica F).
  Proof.
    apply nat_n_deq.
  Defined.

  Definition reps2nat (F : nat) : replica F -> nat_n (nreps F) := fun n => n.

  Lemma bijective_reps2nat (F : nat) : bijective (reps2nat F).
  Proof.
    exists (fun n : nat_n (nreps F) => n); introv; unfold reps2nat; auto.
  Defined.

  Definition nclients (C : nat) : nat := S C.

  Definition client (C : nat) : Set := nat_n (nclients C).

  Definition client0 (C : nat) : client C.
  Proof.
    exists 0.
    apply leb_correct.
    unfold nclients.
    omega.
  Defined.

  Lemma client_deq (C : nat) : Deq (client C).
  Proof.
    apply nat_n_deq.
  Defined.

  Definition clients2nat (C : nat) : client C -> nat_n (nclients C) := fun n => n.

  Lemma bijective_clients2nat (C : nat) : bijective (clients2nat C).
  Proof.
    exists (fun n : nat_n (nclients C) => n); introv; unfold clients2nat; auto.
  Defined.

  Inductive operation :=
  | opr_add (n : nat)
  | opr_sub (n : nat).

  Lemma operation_deq : Deq operation.
  Proof.
    introv; destruct x as [n|n], y as [m|m]; prove_dec;
      destruct (deq_nat n m); subst; prove_dec.
  Defined.

  Definition smState : Set := nat.
  Definition result : Set := nat.

  Definition operation_upd (C : nat) (c : client C) (state : smState) (opr : operation) : result * smState :=
    match opr with
    | opr_add m => let k := state + m in (k,k)
    | opr_sub m => let k := state - m in (k,k)
    end.

  Inductive PBFTtoken_stub : Set :=
  | pbft_token_stub.

  Definition pbft_token : Set := PBFTtoken_stub.

  Lemma pbft_token_deq : Deq pbft_token.
  Proof.
    introv; destruct x, y; simpl; prove_dec.
  Defined.

  Global Instance PBFT_I_context : PBFTcontext :=
    MkPBFTcontext
      (* max in progress *)
      MIP

      (* water mark range *)
      WMR

      (* checkpoint period *)
      CP

      (* digest type *)
      pbft_digest

      (* digest decider *)
      pbft_digest_deq

      (* token type *)
      pbft_token

      (* token decider *)
      pbft_token_deq

      (* sending key type *)
      pbft_sending_key

      (* receiving key type *)
      pbft_receiving_key

      (* number of faults *)
      F

      (* replica type *)
      (replica F)

      (* Replica decider *)
      (replica_deq F)

      (* replica 2 nat *)
      (reps2nat F)

      (* proof that reps2nat is bijective *)
      (bijective_reps2nat F)

      (* number of clients *)
      (nclients C)

      (* client type *)
      (client C)

      (* client decider *)
      (client_deq C)

      (* client 2 nat *)
      (clients2nat C)

      (* proof that clients2nat is bijective *)
      (bijective_clients2nat C)

      (* operation type *)
      operation

      (* operation decider *)
      operation_deq

      (* result type *)
      result

      (* result decider *)
      deq_nat

      (* state type *)
      smState

      (* initial state *)
      0

      (* update function *)
      (operation_upd C)

      (* delay in ms *)
      1000.

  Definition pbft_create_signature
             (m  : PBFTBare_Msg)
             (ks : sending_keys) : PBFTtokens := [pbft_token_stub].

  Definition pbft_verify_signature
             (m : PBFTBare_Msg)
             (n : name)
             (k : receiving_key)
             (a : pbft_token) : bool := true.

  Global Instance PBFT_I_auth : PBFTauth :=
    MkPBFTauth pbft_create_signature pbft_verify_signature.

  Definition pbft_lookup_replica_sending_key   (src : Rep)    : pbft_sending_key   := pbft_sending_key_stub.
  Definition pbft_lookup_replica_receiving_key (dst : Rep)    : pbft_receiving_key := pbft_receiving_key_stub.
  Definition pbft_lookup_client_receiving_key  (c   : Client) : pbft_receiving_key := pbft_receiving_key_stub.

  Definition initial_pbft_local_key_map_replicas (src : name) : local_key_map :=
    match src with
    | PBFTreplica i =>
      MkLocalKeyMap
        [MkDSKey (map PBFTreplica reps) (pbft_lookup_replica_sending_key i)]
        (List.app
           (map (fun c => MkDRKey [PBFTclient  c] (pbft_lookup_client_receiving_key  c)) clients)
           (map (fun m => MkDRKey [PBFTreplica m] (pbft_lookup_replica_receiving_key m)) reps))
    | PBFTclient _ => MkLocalKeyMap [] []
    end.

  Global Instance PBFT_I_keys : PBFTinitial_keys :=
    MkPBFTinitial_keys initial_pbft_local_key_map_replicas.

  Definition pbft_simple_create_hash_messages (msgs : list PBFTmsg) : PBFTdigest := [].
  Definition pbft_simple_verify_hash_messages (msgs : list PBFTmsg) (d : PBFTdigest) := true.
  Definition pbft_simple_create_hash_state_last_reply (smst : PBFTsm_state) (lastr : LastReplyState) : PBFTdigest := [].
  Definition pbft_simple_verify_hash_state_last_reply (smst : PBFTsm_state) (lastr : LastReplyState) (d : PBFTdigest) := true.

  Global Instance PBFT_I_hash : PBFThash :=
    MkPBFThash
      pbft_simple_create_hash_messages
      pbft_simple_verify_hash_messages
      pbft_simple_create_hash_state_last_reply
      pbft_simple_verify_hash_state_last_reply.

  (*Lemma simple_create_hash_messages_collision_resistant :
  forall msgs1 msgs2,
    simple_create_hash_messages msgs1 = simple_create_hash_messages msgs2
    -> msgs1 = msgs2.
Proof.
  introv h.
  unfold simple_create_hash_messages in *.
Admitted.

Lemma simple_create_hash_state_last_reply_collision_resistant :
  forall sm1 sm2 last1 last2,
    simple_create_hash_state_last_reply sm1 last1 = simple_create_hash_state_last_reply sm2 last2
    -> sm1 = sm2 /\ last1 = last2.
Proof.
  introv h.
Admitted.

Global Instance PBFT_I_hash_axioms : PBFThash_axioms.
Proof.
  exact (Build_PBFThash_axioms
           (* create_hash_message is collision resistant *)
           simple_create_hash_messages_collision_resistant

           (* create_hash_state_last_reply is collision resistant *)
           simple_create_hash_state_last_reply_collision_resistant
        ).
Defined.
   *)

  (* ================== TIME ================== *)

  Definition time_I_type : Set := unit.

  Definition time_I_get_time : unit -> time_I_type := fun _ => tt.

  Definition time_I_sub : time_I_type -> time_I_type -> time_I_type := fun _ _ => tt.

  Definition time_I_2string : time_I_type -> string := fun _ => "".

  Global Instance TIME_I : Time.
  Proof.
    exists time_I_type.
    { exact time_I_get_time. }
    { exact time_I_sub. }
    { exact time_I_2string. }
  Defined.

  (* ================== PRETTY PRINTING ================== *)

  (* FIX: to replace when extracting *)
  Definition print_endline : string -> unit := fun _ => tt.
  Definition nat2string (n : nat) : string := "-".

  Definition CR : string := String (ascii_of_nat 13) "".

  (* Fix: to finish *)
  Definition tokens2string (toks : Tokens) : string := "-".

  (* Fix: to finish *)
  Definition digest2string (d : pbft_digest) : string := "-".

  (* Fix: to finish *)
  Definition result2string (r : result) : string := "-".

  (* Fix: there's only one client anyway *)
  Definition client2string (c : client C) : string := "-".

  Definition timestamp2string (ts : Timestamp) : string :=
    match ts with
    | time_stamp n => nat2string n
    end.

  Definition view2string (v : View) : string :=
    match v with
    | view n => nat2string n
    end.

  Definition seq2string (s : SeqNum) : string :=
    match s with
    | seq_num n => nat2string n
    end.

  Definition operation2string (opr : operation) : string :=
    match opr with
    | opr_add n => str_concat ["+", nat2string n]
    | opr_sub n => str_concat ["-", nat2string n]
    end.

  Definition nat_n2string {m} (n : nat_n m) : string := nat2string (proj1_sig n).

  Definition replica2string (r : replica F) : string := nat_n2string r.

  Definition bare_request2string (br : Bare_Request) : string :=
    match br with
    | null_req => str_concat [ "null_req"]
    | bare_req opr ts c => str_concat [operation2string opr, ",", timestamp2string ts, ",", client2string c]
    end.

  Definition request2string (r : Request) : string :=
    match r with
    | req br a => str_concat ["REQUEST(", bare_request2string br, ",", tokens2string a, ")"]
    end.

  Fixpoint requests2string (rs : list Request) : string :=
    match rs with
    | [] => ""
    | [r] => request2string r
    | r :: rs => str_concat [request2string r, ",", requests2string rs]
    end.

  Definition bare_pre_prepare2string (bpp : Bare_Pre_prepare) : string :=
    match bpp with
    | bare_pre_prepare v s reqs => str_concat [view2string v, ",", seq2string s, ",", requests2string reqs]
    end.

  Definition bare_prepare2string (bp : Bare_Prepare) : string :=
    match bp with
    | bare_prepare v s d i => str_concat [view2string v, ",", seq2string s, ",", digest2string d, ",", replica2string i]
    end.

  Definition bare_commit2string (bc : Bare_Commit) : string :=
    match bc with
    | bare_commit v s d i => str_concat [view2string v, ",", seq2string s, ",", digest2string d, ",", replica2string i]
    end.

  Definition bare_reply2string (br : Bare_Reply) : string :=
    match br with
    | bare_reply v ts c i res => str_concat [view2string v, ",", timestamp2string ts, ",", client2string c, ",", replica2string i, ",", result2string res]
    end.

  Definition pre_prepare2string (pp : Pre_prepare) : string :=
    match pp with
    | pre_prepare b a => str_concat ["PRE_PREPARE(",bare_pre_prepare2string b, ",", tokens2string a, ")"]
    end.

  Definition prepare2string (p : Prepare) : string :=
    match p with
    | prepare bp a => str_concat ["PREPARE(", bare_prepare2string bp, ",", tokens2string a, ")"]
    end.

  Definition commit2string (c : Commit) : string :=
    match c with
    | commit bc a => str_concat ["COMMIT(", bare_commit2string bc, ",", tokens2string a, ")"]
    end.

  Definition reply2string (r : Reply) : string :=
    match r with
    | reply br a => str_concat ["REPLY(", bare_reply2string br, ",", tokens2string a, ")"]
    end.

  Definition debug2string (d : Debug) : string :=
    match d with
    | debug r s => str_concat ["DEBUG(", replica2string r, ",", s, ")"]
    end.

  Definition bare_checkpoint2string (bc : Bare_Checkpoint) : string :=
    match bc with
    | bare_checkpoint v n d i => str_concat [view2string v, ",", seq2string n, ",", digest2string d, ",", replica2string i]
    end.

  Definition checkpoint2string (c : Checkpoint) : string :=
    match c with
    | checkpoint bc a => str_concat ["CHECKPOINT(", bare_checkpoint2string bc, ",", tokens2string a, ")"]
    end.

  Definition check_ready2string (c : CheckReady) : string := "CHECK-READY()".

  Definition check_stable2string (c : CheckStableChkPt) : string := "CHECK-STABLE()".

  Definition start_timer2string (t : StartTimer) : string :=
    match t with
    | start_timer r v => str_concat ["START-TIMER(", bare_request2string r, "," , view2string v, ")"]
    end.

  Definition expired_timer2string (t : ExpiredTimer) : string :=
    match t with
    | expired_timer r v => str_concat ["EXPIRED-TIMER(", bare_request2string r, "," , view2string v, ")"]
    end.

  (* FIX *)
  Definition stable_chkpt2string (stable : StableChkPt) : string := "-".

  (* FIX *)
  Definition checkpoint_cert2string (cert : CheckpointCert) : string := "-".

  (* FIX *)
  Definition prepared_infos2string (l : list PreparedInfo) : string := "-".

  Definition bare_view_change2string (bvc : Bare_ViewChange) : string :=
    match bvc with
    | bare_view_change v n stable cert preps i =>
      str_concat
        [view2string v,
         ",",
         seq2string n,
         ",",
         stable_chkpt2string stable,
         ",",
         checkpoint_cert2string cert,
         ",",
         prepared_infos2string preps,
         ",",
         replica2string i
        ]
    end.

  Definition view_change2string (vc : ViewChange) : string :=
    match vc with
    | view_change bvc a => str_concat ["VIEW-CHANGE(", bare_view_change2string bvc, ",", tokens2string a, ")"]
    end.

  (* FIX *)
  Definition view_change_cert2string (V : ViewChangeCert) : string := "-".

  Fixpoint pre_prepares2string (l : list Pre_prepare) : string :=
    match l with
    | [] => ""
    | [r] => pre_prepare2string r
    | r :: rs => str_concat [pre_prepare2string r, ",", pre_prepares2string rs]
    end.

  Definition bare_new_view2string (bnv : Bare_NewView) : string :=
    match bnv with
    | bare_new_view v V OP NP =>
      str_concat
        [
          view2string v,
          ",",
          view_change_cert2string V,
          ",",
          pre_prepares2string OP,
          ",",
          pre_prepares2string NP
        ]
    end.

  Definition new_view2string (nv : NewView) : string :=
    match nv with
    | new_view bnv a => str_concat ["NEW-VIEW(", bare_new_view2string bnv, ",", tokens2string a, ")"]
    end.

  Definition check_bcast_new_view2string (c : CheckBCastNewView) : string :=
    match c with
    | check_bcast_new_view i => str_concat ["CHECK-BCAST-NEW-VIEW(", nat2string i, ")"]
    end.

  Definition msg2string (m : PBFTmsg) : string :=
    match m with
    | PBFTrequest r              => request2string r
    | PBFTpre_prepare pp         => pre_prepare2string pp
    | PBFTprepare p              => prepare2string p
    | PBFTcommit c               => commit2string c
    | PBFTcheckpoint c           => checkpoint2string c
    | PBFTcheck_ready c          => check_ready2string c
    | PBFTcheck_stable c         => check_stable2string c
    | PBFTcheck_bcast_new_view c => check_bcast_new_view2string c
    | PBFTstart_timer t          => start_timer2string t
    | PBFTexpired_timer t        => expired_timer2string t
    | PBFTview_change v          => view_change2string v
    | PBFTnew_view v             => new_view2string v
    | PBFTdebug d                => debug2string d
    | PBFTreply r                => reply2string r
    end.

  Definition name2string (n : name) : string :=
    match n with
    | PBFTreplica r => replica2string r
    | PBFTclient c => client2string c
    end.

  Fixpoint names2string (l : list name) : string :=
    match l with
    | [] => ""
    | [n] => name2string n
    | n :: ns => str_concat [name2string n, ",", names2string ns]
    end.

  Definition delay2string (delay : nat) : string := nat2string delay.

  Definition DirectedMsg2string (dm : DirectedMsg) : string :=
    match dm with
    | MkDMsg msg dst delay =>
      str_concat [msg2string msg, ":", "[", names2string dst, "]", ":", delay2string delay]
    end.

  Fixpoint DirectedMsgs2string (l : DirectedMsgs) : string :=
    match l with
    | [] => ""
    | [dm] => DirectedMsg2string dm
    | dm :: dmsgs => str_concat [DirectedMsg2string dm, CR, DirectedMsgs2string dmsgs]
    end.

  Definition TimedDirectedMsg2string (m : TimedDirectedMsg) : string :=
    match m with
    | MkTimedDMsg dm time => str_concat [DirectedMsg2string dm, ":", time_I_2string time]
    end.

  Fixpoint TimedDirectedMsgs2string (l : TimedDirectedMsgs) : string :=
    match l with
    | [] => ""
    | [dm] => TimedDirectedMsg2string dm
    | dm :: dmsgs => str_concat [TimedDirectedMsg2string dm, CR, TimedDirectedMsgs2string dmsgs]
    end.

  Definition MonoSimulationState2string (s : MonoSimulationState) : string :=
    match s with
    | MkMonoSimState ty sys step out_inflight in_inflight delivered =>
      str_concat
        [CR,
         "====== STEP ======",
         CR,
         nat2string step,
         CR,
         "====== IN FLIGHT (from outside the system) ======",
         CR,
         DirectedMsgs2string out_inflight,
         CR,
         "====== IN FLIGHT (from inside the system) ======",
         CR,
         DirectedMsgs2string in_inflight,
         CR,
         "====== DELIVERED ======",
         CR,
         TimedDirectedMsgs2string delivered,
         CR]
    end.

  Definition pbft_state2string (s : PBFTstate) :=
      str_concat
        ["(checkpoint state size:"
         , nat2string (List.length (chk_state_others (cp_state s)))
         ,")"
         ,"(ready size:"
         , nat2string (List.length (ready s))
         ,")"
         ,"(buffered requests:"
         , nat2string (List.length (request_buffer (primary_state s)))
         ,")"
         ,"(log size:"
         , nat2string (List.length (log s))
         ,")"
        ].

  (* ================== SYSTEM ================== *)

  Definition dummy_initial_state : PBFTstate :=
    Build_State
      (MkLocalKeyMap [] [])
      initial_view
      []
      initial_checkpoint_state
      PBFTsm_initial_state
      initial_next_to_execute
      initial_ready
      initial_last_reply
      initial_view_change_state
      initial_primary_state.

  Definition PBFTdummySM : MStateMachine PBFTstate :=
    MhaltedSM dummy_initial_state.

  Definition PBFTmono_sys : NMStateMachine PBFTstate :=
    fun name =>
      match name with
      | PBFTreplica n => PBFTreplicaSM n
      | _ => MhaltedSM dummy_initial_state
      end.

  Definition mk_request_to (rep : Rep) (ts : nat) (opr : nat) : DirectedMsg :=
    let ts   := time_stamp ts in
    let breq := bare_req (opr_add opr) ts (client0 C) in
    let dst  := PBFTreplica rep in (* the leader *)
    let toks := [ pbft_token_stub ] : Tokens in (* we just send empty lists here to authenticate messages *)
    let req  := req breq toks in
    let msg  := PBFTrequest req in
    MkDMsg msg [dst] 0.

  Definition mk_request (ts : nat) (opr : nat) : DirectedMsg :=
    mk_request_to (PBFTprimary initial_view) ts opr.

  (* n request starting with number start *)
  Fixpoint mk_requests_start (n start opr : nat) : DirectedMsgs :=
    match n with
    | 0 => []
    | S m => List.app (mk_requests_start m start opr) [mk_request (n + start) opr]
    end.

  Definition mk_requests (n opr : nat) : DirectedMsgs :=
    mk_requests_start n 0 opr.

  Record InitRequests :=
    MkInitRequests
      {
        num_requests     : nat;
        starting_seq_num : nat;
        req_operation    : nat;
      }.

  Definition PBFTinit_msgs (msgs : DirectedMsgs) : MonoSimulationState :=
    MkInitMonoSimState PBFTmono_sys msgs.

  Definition PBFTinit (init : InitRequests) : MonoSimulationState :=
    PBFTinit_msgs
      (mk_requests_start
         (num_requests init)
         (starting_seq_num init)
         (req_operation init)).

  Definition PBFTsimul_list (init : InitRequests) (L : list nat) : MonoSimulationState :=
    mono_run_n_steps L (PBFTinit init).

  Definition PBFTsimul_list_msgs (msgs : DirectedMsgs) (L : list nat) : MonoSimulationState :=
    mono_run_n_steps L (PBFTinit_msgs msgs).

  (* [switch] is the list of steps at which we want to switch to sending messages
   coming from the outside (from clients) instead of keeping on sending messages
   coming from the inside (from replicas). *)
  Definition PBFTsimul_n
             (init     : InitRequests) (* This is to generate an initial list of requests *)
             (rounds   : Rounds)
             (switches : Switches) : MonoSimulationState :=
    mono_iterate_n_steps rounds switches (PBFTinit init).

  Definition PBFTsimul_n_msgs
             (msgs     : DirectedMsgs)
             (rounds   : Rounds)
             (switches : Switches) : MonoSimulationState :=
    mono_iterate_n_steps rounds switches (PBFTinit_msgs msgs).

End PBFTinstance.

(* ================== EXTRACTION ================== *)

Extraction Language Ocaml.

(* printing stuff *)
Extract Inlined Constant print_endline => "Prelude.print_coq_endline".
Extract Inlined Constant nat2string    => "Prelude.char_list_of_int".
Extract Inlined Constant CR            => "['\n']".

(* numbers *)
Extract Inlined Constant Nat.modulo    => "(mod)".

(* lists *)
Extract Inlined Constant forallb => "List.for_all".
Extract Inlined Constant existsb => "List.exists".
Extract Inlined Constant length  => "List.length".
Extract Inlined Constant app     => "List.append".
Extract Inlined Constant map     => "List.map".
Extract Inlined Constant filter  => "List.filter".

(* timing stuff *)
Extract Inlined Constant time_I_type     => "float".
Extract Inlined Constant time_I_get_time => "Prelude.Time.get_time".
Extract Inlined Constant time_I_sub      => "Prelude.Time.sub_time".
Extract Inlined Constant time_I_2string  => "Prelude.Time.time2string".

(* == crypto stuff == *)
(* === COMMENT OUT THIS PART IF YOU DON'T WANT TO USE KEYS === *)
Extract Inlined Constant pbft_sending_key   => "Nocrypto.Rsa.priv".
Extract Inlined Constant pbft_receiving_key => "Nocrypto.Rsa.pub".
Extract Inlined Constant pbft_lookup_replica_sending_key   => "RsaKeyFun.lookup_replica_sending_key".
Extract Inlined Constant pbft_lookup_replica_receiving_key => "RsaKeyFun.lookup_replica_receiving_key".
Extract Inlined Constant pbft_lookup_client_receiving_key  => "RsaKeyFun.lookup_client_receiving_key".

Extract Inlined Constant pbft_create_signature => "RsaKeyFun.sign_list".
Extract Inlined Constant pbft_verify_signature => "RsaKeyFun.verify_one".
Extract Inlined Constant pbft_token => "Cstruct.t".
Extract Inlined Constant pbft_token_deq => "(=)".
(* === --- === *)

(* == hashing stuff == *)
Extract Inlined Constant pbft_digest => "Cstruct.t".
Extract Inlined Constant pbft_digest_deq => "(=)".
Extract Inlined Constant pbft_simple_create_hash_messages => "Obj.magic (Hash.create_hash_objects)".
Extract Inlined Constant pbft_simple_verify_hash_messages => "Obj.magic (Hash.verify_hash_objects)".
Extract Inlined Constant pbft_simple_create_hash_state_last_reply => "Obj.magic (Hash.create_hash_pair)".
Extract Inlined Constant pbft_simple_verify_hash_state_last_reply => "Obj.magic (Hash.verify_hash_pair)".
(* === --- === *)

Require Export ExtrOcamlBasic.
Require Export ExtrOcamlNatInt.
Require Export ExtrOcamlString.

Definition local_replica (*(F C : nat)*) :=
  @PBFTreplicaSM
    (@PBFT_I_context (*(MkNumNodes F C)*))
    PBFT_I_auth
    PBFT_I_keys
    PBFT_I_hash.

Extraction "pbft/PbftReplicaEx.ml" pbft_state2string lrun_sm MonoSimulationState2string PBFTdummySM local_replica.


Require Export DTimeQ.
Require Export MicroBFTheader.
Require Export ComponentSM.
Require Export ComponentSM2.
Require Export toString.

Section MicroBFT.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc : DTimeContext }.

  Context { microbft_context : MicroBFT_context }.
  Context { m_initial_keys   : MicroBFT_initial_keys }.
  Context { u_initial_keys   : USIG_initial_keys }.

  (* ===============================================================
     USIG
     =============================================================== *)

  Record USIG_state :=
    Build_USIG
      {
        usig_id            : MicroBFT_node;
        usig_counter       : nat;
        usig_local_keys    : local_key_map;
      }.

  Record preUI :=
    Build_preUI
      {
        pre_ui_id      : MicroBFT_node;
        pre_ui_counter : nat;
      }.

  Record UI :=
    Build_UI
      {
        ui_pre     :> preUI;
        ui_digest  : MicroBFT_digest;
      }.

  Definition UIs := list UI.

  Definition ui2rep     (ui : UI) : MicroBFT_node := pre_ui_id (ui_pre ui).
  Definition ui2counter (ui : UI) : nat := pre_ui_counter (ui_pre ui).
  Definition ui2digest  (ui : UI) : MicroBFT_digest := ui_digest ui.

  (* ===============================================================
     Bare messages
     =============================================================== *)

  Record Commit :=
    commit
      {
        commit_n  : nat;
        commit_ui : UI
      }.

  Record Accept :=
    accept
      {
        accept_r : nat;
        accept_c : nat;
      }.

  Definition commit2sender (c : Commit) : MicroBFT_node :=
    pre_ui_id (commit_ui c).

  (* ===============================================================
     Bare message type
     =============================================================== *)

  Inductive MicroBFT_Bare_Msg : Set :=
  | MicroBFT_msg_bare_request (n : nat) (pui : preUI).

  (* =========== Msg type =========== *)

  Inductive MicroBFT_msg :=
  | MicroBFT_request (n : nat)
  | MicroBFT_commit  (c : Commit)
  | MicroBFT_accept  (a : Accept).

  Global Instance MicroBFT_I_Msg : Msg := MkMsg MicroBFT_msg.

  Definition MicroBFTmsg2status (m : MicroBFT_msg) : msg_status :=
    match m with
    | MicroBFT_request _ => MSG_STATUS_EXTERNAL
    | MicroBFT_commit  _ => MSG_STATUS_PROTOCOL
    | MicroBFT_accept  _ => MSG_STATUS_INTERNAL
    end.

  Global Instance MicroBFT_I_MsgStatus : MsgStatus := MkMsgStatus MicroBFTmsg2status.

  (* back to the definition of usig *)

  Record HashData :=
    Build_HashData
      {
        hd_msg : nat;
        hd_pre : preUI;
      }.

  (* hash of the whole usig *)
  Class USIG_hash :=
    MkMicroBFThash
      {
        create_hash_usig  : HashData -> local_key_map -> MicroBFT_digest;
        verify_hash_usig  : HashData -> MicroBFT_digest -> local_key_map -> bool;
        verify_create_hash_usig :
          forall (hd : HashData) (keys : local_key_map),
            verify_hash_usig hd (create_hash_usig hd keys) keys = true;
      }.
  Context { usig_hash : USIG_hash }.
  Hint Rewrite verify_create_hash_usig : microbft.

  Definition USIG_initial (r : MicroBFT_node) : USIG_state :=
    Build_USIG
      r
      0
      (usig_initial_keys r).

  Definition getReplicaId (u : USIG_state) : MicroBFT_node := usig_id u.

  Definition increment_USIG (u : USIG_state) : USIG_state :=
    Build_USIG
      (usig_id         u)
      (S               (usig_counter u))
      (usig_local_keys u).

  (* 1st USIG counter will be [1] *)
  Definition create_UI (msg : nat) (u : USIG_state) : USIG_state * UI :=
    (* increment current counter of the usig *)
    let u' := increment_USIG u in
    (* creates the data to hash *)
    let pre := Build_preUI (usig_id u') (usig_counter u') in
    let hd := Build_HashData msg pre in
    (* hashes the data *)
    let d  := create_hash_usig hd (usig_local_keys u') in
    (* builds UI *)
    let ui := Build_UI pre d in
    (u', ui).

  Definition verify_UI (msg : nat) (ui : UI) (u : USIG_state) : bool :=
    (* creates the data to hash *)
    let hd  := Build_HashData msg (ui_pre ui) in
    (* the keys are supposed to be the receiving keys for [ui_id ui] *)
    verify_hash_usig hd (ui2digest ui) (usig_local_keys u).

  Inductive USIG_input_interface :=
  | create_ui_in (msg   : nat)
  | verify_ui_in (msgui : nat * UI).

  Inductive USIG_output_interface :=
  | create_ui_out (ui : UI)
  | verify_ui_out (b  : bool)
  (* default output *)
  | verify_ui_out_def.

  Definition CIOusig : ComponentIO :=
    MkComponentIO USIG_input_interface USIG_output_interface verify_ui_out_def.

  (* ===============================================================
     Crypto
     =============================================================== *)

  Global Instance MicroBFT_I_Data : Data := MkData MicroBFT_Bare_Msg.

  Class MicroBFT_auth :=
    MkMicroBFT_auth
      {
        MicroBFT_create : data -> sending_keys -> list MicroBFT_digest;
        MicroBFT_verify : data -> name -> receiving_key -> MicroBFT_digest -> bool
      }.

  Context { microbft_auth : MicroBFT_auth }.

  Global Instance MicroBFT_I_AuthFun : AuthFun :=
    MkAuthFun
      MicroBFT_create
      MicroBFT_verify.

  (* ===============================================================
        Authenticated Messages
        =============================================================== *)

  (* we are here extracting the sender of the message *)
  Definition MicroBFT_msg_auth (m : msg) : option  name :=
    match m with
    | MicroBFT_request _ => None
    | MicroBFT_commit  c => Some (commit2sender c)
    | MicroBFT_accept  a => None
    end.

  (* FIX : Why do we need n here? *)
  Definition MicroBFT_data_auth (n : name) (d : data) : option name :=
    match d with
    | MicroBFT_msg_bare_request n pui => Some (pre_ui_id pui)
    end.

  Global Instance MicroBFT_I_DataAuth : DataAuth := MkDataAuth MicroBFT_data_auth.

  Definition commit2auth_data (c : Commit) : AuthenticatedData :=
    match c with
    | commit n ui => MkAuthData (MicroBFT_msg_bare_request n ui) [ui_digest ui]
    end.

  Definition MicroBFT_get_contained_auth_data (m : msg) : list AuthenticatedData :=
    match m with
    | MicroBFT_request _ => []
    | MicroBFT_commit  c => [commit2auth_data c]
    | MicroBFT_accept  a => []
    end.

  Global Instance MicroBFT_I_ContainedAuthData : ContainedAuthData :=
    MkContainedAuthData MicroBFT_get_contained_auth_data.

  (* ===============================================================
     Decidability for different types of messages
     =============================================================== *)

  Definition UI_dec : Deq UI.
  Proof.
    introv.
    destruct x as [p1 d1], y as [p2 d2], p1 as [i1 c1], p2 as [i2 c2].
    destruct (MicroBFT_nodeDeq i1 i2); subst; prove_dec.
    destruct (deq_nat c1 c2); subst; prove_dec.
    destruct (MicroBFT_digestdeq d1 d2); subst; prove_dec.
  Defined.

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

  Definition broadcast2others F : DirectedMsg :=
    F [MicroBFT_backup1, MicroBFT_backup2].

  (* ===============================================================
     Sending functions
     =============================================================== *)

  Definition send_commit (c : Commit) (n : list name) : DirectedMsg :=
    MkDMsg (MicroBFT_commit c) n ('0).

  Definition send_accept (a : Accept) (n : list name) : DirectedMsg :=
    MkDMsg (MicroBFT_accept a) n ('0).

  (* ===============================================================
     Log
     =============================================================== *)

  Definition LOG_state := list Commit.

  Definition LOG_initial : LOG_state := [].

  Inductive LOG_input_interface :=
  | log_new (c : Commit).

  Inductive LOG_output_interface :=
  | log_out (b : bool).

  Definition CIOlog : ComponentIO :=
    MkComponentIO LOG_input_interface LOG_output_interface (log_out true).

  (* ===============================================================
     State of some replica
     =============================================================== *)

  Definition update_highest_received_counter_value (ui : UI) (n : nat) : nat :=
    if n <? ui2counter ui
    then ui2counter ui
    else n.

  Record MAIN_state :=
    Build_State
      {

        (* state of the local state machine *)
        sm_state : nat;

        (* the highest sequence number received from the primary *)
        prim     : nat;

      }.

  Definition initial_state : MAIN_state :=
    Build_State 0 0.

  Definition update_sm_state
             (s : MAIN_state)
             (x : nat) : MAIN_state :=
    Build_State (sm_state s + x) (prim s).

  Global Instance MicroBFT_I_baseFunIO : baseFunIO :=
    MkBaseFunIO (fun nm =>
                   if CompNameKindDeq (comp_name_kind nm) "USIG" then CIOusig
                   else if CompNameKindDeq (comp_name_kind nm) "LOG" then CIOlog
                        else CIOdef).

  Definition preUSIGname : PreCompName := MkPreCompName "USIG" 0.
  Definition USIGname : CompName := MkCN "USIG" 0 true.

  Global Instance MicroBFT_I_baseStateFun : baseStateFun :=
    MkBaseStateFun (fun nm =>
                      if CompNameKindDeq (comp_name_kind nm) "USIG" then USIG_state
                      else if CompNameKindDeq (comp_name_kind nm) "LOG" then LOG_state
                           else if CompNameKindDeq (comp_name_kind nm) msg_comp_name_kind
                                then MAIN_state
                                else unit).

  Global Instance MicroBFT_I_IOTrustedFun : IOTrustedFun :=
    MkIOTrustedFun
      (fun _ =>
         MkIOTrusted
           USIG_input_interface
           USIG_output_interface
           verify_ui_out_def).

  Global Instance MicroBFT_I_trustedStateFun : trustedStateFun :=
    MkTrustedStateFun (fun _ => USIG_state).

  Definition USIG_update : M_Update 0 USIGname _ :=
    fun (s : USIG_state) (m : USIG_input_interface) =>
      interp_s_proc
        (match m with
         | create_ui_in r =>
           let (s', ui) := create_UI r s in
           [R] (s', create_ui_out ui)
         | verify_ui_in (r,ui) =>
           let b := verify_UI r ui s in
           [R] (s, verify_ui_out b)
         end).

  Definition USIG_comp (n : MicroBFT_node) : M_StateMachine 1 USIGname :=
    build_m_sm USIG_update (USIG_initial n).

  Definition LOGname : CompName := MkCN "LOG" 0 false.

  Definition LOG_update : M_Update 0 LOGname _ :=
    fun (l : LOG_state) (m : LOG_input_interface) =>
      interp_s_proc
        (match m with
         | log_new r =>
           let l' := r :: l in
           [R] (l', log_out true)
         end).

  Definition LOG_comp : M_StateMachine 1 LOGname :=
    build_m_sm LOG_update LOG_initial.

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

  Definition on_create_ui_out {A} (f : UI -> A) (d : unit -> A) (out : USIG_output_interface) : A :=
    match out with
    | create_ui_out ui => f ui
    | _ => d tt
    end.

  Definition call_create_ui {A} (m : nat) (d : unit -> Proc A) (f : UI -> Proc A) :=
    (USIGname [C] (create_ui_in m))
      [>>=] on_create_ui_out f d.

  Notation "a >>cui>>=( d ) f" := (call_create_ui a d f) (at level 80, right associativity).

  Definition if_true_verify_ui_out {A} (f d : unit -> A) (out : USIG_output_interface) : A :=
    match out with
    | verify_ui_out b => if b then f tt else d tt
    | _ => d tt
    end.

  Definition call_verify_ui {A} (mui : nat * UI) (d f : unit -> Proc A) :=
    (USIGname [C] (verify_ui_in mui))
      [>>=] if_true_verify_ui_out f d.

  Notation " a >>vui>>=( d ) f" := (call_verify_ui a d f) (at level 80, right associativity).

  Definition on_data_message {A} (m : MicroBFT_msg) (d : unit -> Proc A) (f : nat -> Proc A) : Proc A :=
    match m with
    | MicroBFT_request m => f m
    | _ => d tt
    end.

  Notation "a >>odm>>=( d ) f" := (on_data_message a d f) (at level 80, right associativity).

  Definition on_commit {A} (m : MicroBFT_msg) (d : unit -> Proc A) (f : Commit -> Proc A) : Proc A :=
    match m with
    | MicroBFT_commit c => f c
    | _ => d tt
    end.

  Notation "a >>oc>>=( d ) f" := (on_commit a d f) (at level 80, right associativity).

  Definition MAINname := msg_comp_name 0.

  Definition received_prior_counter (ui : UI) (s : MAIN_state) : bool :=
    match ui2counter ui with
    | 0 => false (* 0 is not a valid counter *)
    | 1 => true (* 1st counter *)
    | S n => if deq_nat n (prim s) then true else false
    end.

  Definition is_primary (n : MicroBFT_node) : bool :=
    if MicroBFT_nodeDeq n MicroBFT_primary then true else false.

  Definition not_primary (n : MicroBFT_node) : bool :=
    negb (is_primary n).

  Definition valid_commit
             (slf : MicroBFT_node)
             (c   : Commit)
             (s   : MAIN_state) : bool :=
    is_primary (commit2sender c)
      && not_primary slf
      && received_prior_counter (commit_ui c) s.

  Definition invalid_commit
             (slf : MicroBFT_node)
             (c   : Commit)
             (s   : MAIN_state) : bool :=
    negb (valid_commit slf c s).

  Definition update_highest_received_counter (ui : UI) (s : MAIN_state) : MAIN_state :=
    Build_State
      (sm_state          s)
      (update_highest_received_counter_value ui (prim s)).

  Definition handle_request (slf : MicroBFT_node) : UProc MAINname _ :=
    (* in case M_Update 0 _ := is output type it complains that "The term "m" has type "cio_I" while it is expected to have type "data_message"." *)
    fun state m =>
      if not_primary slf then [R] (state, []) else

      m >>odm>>=(fun _ => [R] (state,[])) fun m =>

      let state1 := update_sm_state state m in
      let m' := sm_state state1 in

      (* create_UI and update of the current state *)
      m' >>cui>>=(fun _ => [R](state1, [])) fun ui =>

      (* create request *)
      let c := commit m' ui in

      (* we log this request *)
      (LOGname [C] (log_new c)) [>>=] fun _ =>

      (* we broadcast the request message to all replicas *)
      [R] (state1, [broadcast2others (send_commit c)]).

  Definition handle_commit (slf : MicroBFT_node) : UProc MAINname _ :=
    fun state m =>
      m >>oc>>=(fun _ => [R] (state,[])) fun c =>
      if invalid_commit slf c state then [R] (state, []) else

      (* we check whether the ui is created by some usig *)
      let n  := commit_n c in
      let ui := commit_ui c in
      (n,ui) >>vui>>=(fun _ => [R] (state, [])) fun _ =>

      let state1 := update_highest_received_counter (commit_ui c) state in

      (* we log this request *)
      (LOGname [C] (log_new c)) [>>=] fun _ =>

      (* we broadcast the commit message to all replicas *)
      let acc := accept n (ui2counter ui) in
      [R] (state1, [send_accept acc [slf]]).

  Definition handle_accept (slf : MicroBFT_node) : UProc MAINname _ :=
    fun (state : MAIN_state) m => [R](state,[]).

  Definition MAIN_update (slf : MicroBFT_node) : M_Update 1 MAINname _ :=
    fun (s : MAIN_state) m =>
      interp_s_proc
        (match m with
         | MicroBFT_request _ => handle_request slf s m
         | MicroBFT_commit  _ => handle_commit  slf s m
         | MicroBFT_accept  _ => handle_accept  slf s m
         end).

  Definition MAIN_comp (slf : MicroBFT_node) : n_proc 2 MAINname :=
    build_m_sm (MAIN_update slf) initial_state.

  (*Definition MicroBFT_nstate (n : name) :=
    match n with
    | MicroBFT_replica _ => MAIN_state
    | _ => unit
    end.*)

  Definition MicroBFTsubs (n : MicroBFT_node) : n_procs _ :=
    [
      MkPProc USIGname (USIG_comp n),
      MkPProc LOGname LOG_comp
    ].

  Definition MicroBFTsubs_new (s1 : USIG_state) (s2 : LOG_state) : n_procs _ :=
    [
      MkPProc USIGname (build_m_sm USIG_update s1),
      MkPProc LOGname  (build_m_sm LOG_update s2)
    ].

  Definition MicroBFTsubs_new_u (u : USIG_state) : n_procs _ :=
    [
      MkPProc USIGname (build_m_sm USIG_update u),
      MkPProc LOGname  LOG_comp
    ].

  Definition MicroBFTsubs_new_l n (l : LOG_state) : n_procs _ :=
    [
      MkPProc USIGname (USIG_comp n),
      MkPProc LOGname  (build_m_sm LOG_update l)
    ].

  Definition MicroBFT_replicaSM_new (r : MicroBFT_node) (s : MAIN_state) : n_proc 2 MAINname :=
    build_m_sm (MAIN_update r) s.

  Notation MicroBFTls := (LocalSystem 2 0).

  Definition MicroBFTlocalSys (slf : MicroBFT_node) : MicroBFTls :=
    MkPProc _ (MAIN_comp slf) :: incr_n_procs (MicroBFTsubs slf).

  Definition MicroBFTlocalSys_new
             (n  : MicroBFT_node)
             (s  : MAIN_state)
             (s1 : USIG_state)
             (s2 : LOG_state) : MicroBFTls :=
    MkPProc _ (MicroBFT_replicaSM_new n s) :: incr_n_procs (MicroBFTsubs_new s1 s2).

  Definition MicroBFTfunLevelSpace :=
    MkFunLevelSpace
      (fun n => 2)
      (fun n => 0).

  Definition MicroBFTsys : M_USystem MicroBFTfunLevelSpace (*name -> M_StateMachine 2 msg_comp_name*) :=
    MicroBFTlocalSys.

  Lemma eq_cons :
    forall {T} (x1 x2 : T) l1 l2,
      x1 :: l1 = x2 :: l2 -> x1 = x2 /\ l1 = l2.
  Proof.
    introv h; inversion h; auto.
  Qed.

  Lemma MicroBFTsubs_new_inj :
    forall a b c d,
      MicroBFTsubs_new a b = MicroBFTsubs_new c d
      -> a = c /\ b = d.
  Proof.
    introv h.
    repeat (apply eq_cons in h; repnd); GC.
    apply decomp_p_nproc in h0.
    apply decomp_p_nproc in h1.
    inversion h0; inversion h1; subst; simpl in *; auto.
  Qed.

  Lemma MicroBFTlocalSys_new_inj :
    forall a1 a2 b1 b2 c1 c2 d1 d2,
      MicroBFTlocalSys_new a1 b1 c1 d1 = MicroBFTlocalSys_new a2 b2 c2 d2
      -> b1 = b2 /\ c1 = c2 /\ d1 = d2.
  Proof.
    introv h.
    apply eq_cons in h; repnd.
    apply decomp_p_nproc in h0.
    inversion h0; subst.
    apply incr_n_procs_inj in h.
    apply MicroBFTsubs_new_inj in h; repnd; subst; tcsp.
  Qed.

  Lemma MicroBFTlocalSys_as_new :
    forall (r  : MicroBFT_node),
      MicroBFTlocalSys r
      = MicroBFTlocalSys_new
          r
          initial_state
          (USIG_initial r)
          LOG_initial.
  Proof.
    introv; eauto.
  Qed.

  Definition USIGlocalSys (s : USIG_state) : LocalSystem 1 0 :=
    [MkPProc _ (build_m_sm USIG_update s)].

  Definition LOGlocalSys (s : LOG_state) : LocalSystem 1 0 :=
    [MkPProc _ (build_m_sm LOG_update s)].

End MicroBFT.

Hint Rewrite @verify_create_hash_usig : microbft.

Notation MicroBFTls := (LocalSystem 2 0).


(**************************  uc/OS-II  ******************************)
(*************************** OS_MUTEX.C *****************************)
(****Proofs for API Fucntion:  OS_EVENT* OSMutexCreate(int8u prio)***)
(***************************** Code: ********************************)
(**
OS_EVENT∗ ·OSMutexCreate·(⌞prio @ Int8u⌟)··{
           ⌞pevent @ OS_EVENT∗⌟;

1          If (prio′ ≥ ′OS_LOWEST_PRIO)
           {
12              RETURN 〈OS_EVENT ∗〉 NULL
           };ₛ
13         ENTER_CRITICAL;ₛ
14         If (OSTCBPrioTbl′[prio′] !=ₑ NULL)
           {
15              EXIT_CRITICAL;ₛ
16              RETURN 〈OS_EVENT ∗〉 NULL
           };ₛ
17         pevent′ =ₑ OSEventFreeList′;ₛ
18         If (OSEventFreeList′ !=ₑ NULL)
           {
19              OSEventFreeList′ =ₑ  〈OS_EVENT∗〉 OSEventFreeList′→OSEventListPtr
           };ₛ
20         IF (pevent′ !=ₑ NULL)
           {
21              OS_EventWaitListInit(pevent′);ₛ
22              pevent′→OSEventType =ₑ ′OS_EVENT_TYPE_MUTEX;ₛ
23              pevent′→OSEventCnt  =ₑ ((〈Int16u〉prio′) ≪ ′8) |ₑ ′OS_MUTEX_AVAILABLE;ₛ
24              pevent′→OSEventPtr  =ₑ NULL;ₛ
25              pevent ′ → OSEventListPtr =ₑ OSEventList ′;ₛ
26              OSTCBPrioTbl′[prio′] =ₑ 〈OS_TCB ∗〉 PlaceHolder;ₛ
27              OSEventList′ =ₑ pevent′;ₛ
28              EXIT_CRITICAL;ₛ
29              RETURN pevent′
            }
            ELSE
            {
30              EXIT_CRITICAL;ₛ
31              RETURN 〈OS_EVENT ∗〉 NULL
            }
 }·.
*)
Require Import ucos_include.
Require Import os_ucos_h.
Require Import OSMutex_common.
Require Import mutex_absop_rules.
(*Require Import OSQPendPure.*)
Local Open Scope code_scope.
Local Open Scope Z_scope.
Local Open Scope int_scope.

(*------------------- OS MUTEX Create -------------------------*)

Theorem OSMutexCreateRight:
  forall vl p r tid,
    Some p = BuildPreA' os_api OSMutexCreate mutexcreapi vl OSLInv tid init_lg->
    Some r = BuildRetA' os_api OSMutexCreate mutexcreapi vl OSLInv tid init_lg->
    exists t d1 d2 s,
      os_api OSMutexCreate = Some (t, d1, d2, s) /\ {| OS_spec, GetHPrio, OSLInv, I, r, Afalse |} |- tid {{ p }} s {{ Afalse }}.
Proof.
  init_spec.
  hoare unfold.
  hoare forward;  pauto.
  (* destruct (Int.ltu (Int.repr OS_LOWEST_PRIO) i).
   * intro; tryfalse.
   * intro; tryfalse.
   * destruct (Int.eq i (Int.repr OS_LOWEST_PRIO) ).
   * intro; tryfalse.
   * intro; tryfalse.
   * destruct (Int.ltu (Int.repr OS_LOWEST_PRIO) i);
   * destruct (Int.eq i (Int.repr OS_LOWEST_PRIO) ).
   * intro; tryfalse.
   * intro; tryfalse.
   * intro; tryfalse.
   * intro; tryfalse. *)
  hoare unfold.
  hoare abscsq.
  apply noabs_oslinv.

  eapply mutexcre_error_absinfer.
  can_change_aop_solver.
  pauto.
  hoare forward.
  hoare forward .
  hoare unfold.
  assert  (Int.unsigned i < OS_LOWEST_PRIO).
  pauto.
  int auto.
  elim H; intros.
  int auto.
  int auto.
  elim H; intros.
  int auto.
  int auto.
  unfold OS_LOWEST_PRIO; omega.
  unfold OS_LOWEST_PRIO; omega.
  clear H.
  hoare forward prim.
  hoare unfold.
  unfold OS_LOWEST_PRIO in *.
  assert (rule_type_val_match OS_TCB ∗ (nth_val' (Z.to_nat (Int.unsigned i)) v'5) = true).
  Require Import symbolic_lemmas.
  apply array_type_vallist_match_imp_rule_type_val_match.
  rewrite H6.
  clear -H0.
  mauto.
  auto.
  hoare forward.

  math simpls.

  auto.

  unfolds in H7.
  clear -H7.
  remember ( nth_val' (Z.to_nat (Int.unsigned i)) v'5 ).
  destruct v; simpl; intro; tryfalse.
  destruct a; simpl in H; tryfalse.

  clear -H7.
  unfolds in H7.
  remember ( nth_val' (Z.to_nat (Int.unsigned i)) v'5 ).
  destruct v; simpl; intro; tryfalse.
  destruct a; simpl in H; tryfalse.

  hoare unfold.
  hoare forward prim.
  unfold AOSTCBPrioTbl.
  sep pauto.
  go.
  hoare abscsq.
  apply noabs_oslinv.
  apply  mutexcre_error_absinfer.
  go.
  math simpl.
  auto.
  hoare forward.
  hoare forward.
  hoare unfold.
  hoare forward.
  pauto.

  destruct v'0; hoare unfold.

  hoare unfold.
  hoare forward.
  (* intro; tryfalse.
   * intro; tryfalse. *)
  hoare unfold.
  false.
  int auto.
  hoare unfold.
  instantiate (1:=Afalse).
  hoare forward.
  hoare unfold.

  hoare forward.
  (* intro; tryfalse.
   * intro; tryfalse. *)
  hoare unfold; false.
  int auto.
  hoare unfold.
  hoare forward prim.
  sep_unfold.
  sep pauto.
  instantiate (3:=nil).
  unfold ecbf_sll.
  simpl ecbf_sllseg.

  sep pauto.
  sep cancel 2%nat 1%nat.
  sep cancel 2%nat 1%nat.
  eauto.

  auto.
  auto.
  go.

  hoare abscsq.
  apply noabs_oslinv.

  eapply  mutexcre_error_absinfer.
  can_change_aop_solver.
  math simpl.
  auto.
  hoare forward.
  instantiate (1:=Afalse) in H11.
  apply adisj_elim in H11.
  elim H11; intros; sep auto.

  (* succ *)
  hoare unfold.
  hoare forward.
  (* intro; tryfalse.
   * intro; tryfalse. *)
  hoare forward.
  go.
  pauto.
  hoare forward.
  Focus 2.
  hoare_split_pure_all.
  clear -H11.
  false.
  elim H11; intros.
  int auto.
  int auto.

  hoare unfold.
  hoare forward.
  (* intro; tryfalse. *)

  Focus 2.
  hoare unfold.
  false.
  clear -H24.
  elim H24; intros; int auto.

  instantiate (1:=Afalse).

  hoare unfold.
  hoare forward.
  sep cancel Astruct.
  rewrite (@intlemma1 v'22 v'24); auto.
  sep cancel Aarray.
  sep cancel Aisr.
  sep cancel Aie.
  sep cancel Ais.
  sep cancel Acs.
  sep cancel 1%nat 1%nat.
  eauto.
  splits; eauto.
  go.
  intro.
  intros.
  sep pauto.
  sep cancel p_local.
  simpl ; auto.

  intro.
  intros.
  sep pauto.
  sep cancel p_local.
  simpl ; auto.
  hoare unfold.
  hoare forward.
  hoare forward.
  math simpls.
  change ( Int.ltu ($ 8) Int.iwordsize ) with true.
  (* simpl; intro; tryfalse. *)
  (* change ( Int.ltu ($ 8) Int.iwordsize ) with true. *)
  (* simpl; intro; tryfalse. *)
  hoare forward.
  hoare unfold.
  hoare forward.
  pauto.
  hoare unfold.
  unfold os_mutex.PlaceHolder.
  hoare forward.
  eapply forward_rule2.
  Local Open Scope list_scope.
  match goal with
  | |- {|_ ,_, _, _, _, _|}|- _ {{?P}}?x ′ [_] =ₑ _ {{_}} =>
   match find_dom_lenv P with
     | (none _, _) => fail
     | (some ?m, Some ?ls) =>
       let ret1 := constr:(var_notin_dom x ls) in
       let ret2 := eval compute in ret1 in
                                    match ret2 with
                                      | true =>
                                        match find_aop P with
                                          | none _ => assert (3=12)
                                          | some ?n =>
                                            match find_gvararray P x with
                                              | none _ => assert (1=11)
                                              | some ?o =>
                                                hoare lifts (n :: m :: o :: nil) pre;
                                                  eapply assign_rule_array_g_aop;
                                                  idtac(*
                                                  [ intro s; split; intro H; exact H
                                                  | simpl; auto
                                                  | symbolic
                                                      execution
                                                  | symbolic
                                                      execution
                                                  | intuition auto
                                                  | try omega
                                                  | apply
                                                      aux_for_hoare_lemmas.assign_type_match_true;
                                                    simpl; auto
                                                  | try omega ]*)
                                            end
                                        end
                                      | false => assert (2=2)
                                    end
   end
  end.

  intro s.
  split.
  intro HHH.
  exact HHH.
  intro HHH; exact HHH.
  simpl; auto.

  2:symbolic execution.
  intros.
  sep normal; sep eexists.  eapply cast_rv_tptr.
  eapply addrof_gvar_rv.
  apply  astar_l_anotinlenv_intro.
  sep cancel 21%nat 1%nat.
  eauto.
  intro.
  apply astar_l_adomlenv_elim in H34.
  elim H34; intros.
  unfolds in H36.
  clear -H35 H36.
  unfolds in H35.
  simpljoin.
  destruct x.
  lets adfsadf: H36 OSPlaceHolder t.
  elim adfsadf; intros.
  assert (   ListSet.set_In (OSPlaceHolder, t)
                            ((prio, Int8u) :: (pevent, OS_EVENT ∗) :: nil)).
  apply H1.
  eexists; eauto.
  unfolds in H2.
  simpl in H2.
  elim H2; intros; tryfalse.
  elim H3; intros; tryfalse.
  auto.
  math simpls.
  tauto.
  clear -H0.
  bsimplr.
  omega.
  apply eq_vptr.
  do 2 eexists.
  splits; eauto.
  rewrite H6.
  clear -H0.
  bsimplr.
  omega.
  intro; intros.
  sep eexists.
  sep cancel p_local.
  simpl; auto.
  intro.
  intros.
  eauto.

  hoare_assert_pure ( EcbMod.get v'13 (v'25, Int.zero) = None).
  sep lifts (5::7::nil)%nat in H34.

  (* in OSQ *)
  Require Import OSQCreatePure.
  lets Hs : ecblist_star_not_inh H27 H34.
  auto.

  hoare unfold.
  hoare forward.

  inverts H33.
  hoare abscsq.
  apply noabs_oslinv.
  eapply mutexcre_succ_absinfer.
  go.
  math simpl.
  auto.
  apply create_val_inj_lemma0 in H8.

  eapply mutex_createpure; eauto.

  unfold OS_LOWEST_PRIO.
  int auto.
  eauto.
  hoare forward prim.
  unfold AOSEventFreeList.
  unfold AECBList.
  unfold AOSTCBPrioTbl.
  unfold AECBList in H27.
  sep pauto.
  unfold ecbf_sll.
  sep cancel ecbf_sllseg.
  Local Open Scope int_scope.
  instantiate (4:=( (V$OS_EVENT_TYPE_MUTEX
                      :: Vint32 Int.zero ::  val_inj
                      (or
                         (val_inj
                            (if Int.ltu ($ 8) Int.iwordsize
                             then Some (Vint32 (i<<ᵢ$ 8))
                             else None)) (V$OS_MUTEX_AVAILABLE))
                      :: Vnull :: v'29 :: v'20 :: nil), INIT_EVENT_TBL) :: v'4).

  instantiate (3:= ( (DMutex (val_inj
                                (or
                                   (val_inj
                                      (if Int.ltu ($ 8) Int.iwordsize
                                       then Some (Vint32 (i<<ᵢ$ 8))
                                       else None)) (V$OS_MUTEX_AVAILABLE)))  Vnull) :: v'3)).
  unfold evsllseg; fold evsllseg.

  unfold AEventNode.
  unfold AEventData.
  unfold AMsgData.
  unfold AOSQCtr.
  unfold_msg.
  sep pauto.
  sep cancel evsllseg.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel 3%nat 1%nat.
  sep cancel 3%nat 1%nat.
  eauto.
  unfolds; simpl; auto.
  apply RL_Tbl_init_prop.
  unfolds; simpl; auto.
  simpl.
  auto.
  unfolds.
  splits; try unfolds;
  math simpl; auto.
  go.
  clear -H0.
  unfold OS_MUTEX_AVAILABLE.
  mauto.

  eapply val_inj_eq' in H8.
  destruct H8.
  simpljoin.
  lets tmp:val_eq_some_not_zero H8 H36.
  apply R_PrioTbl_P_update_vhold; auto.
  apply RL_RTbl_PrioTbl_P_update_vhold;auto.

  eapply val_inj_eq' in H8.
  destruct H8.
  simpljoin.

  lets tmp:val_eq_some_not_zero H8 H36.
  auto.

  splits.
  rewrite array_type_vallist_match_is_all_elem_p.
  apply all_elem_hold_for_upd.
  rewrite <-  array_type_vallist_match_is_all_elem_p.
  auto.
  pauto.
  rewrite update_nth_val_len_eq.
  auto.

  eapply  ECBList_Mutex_Create_prop; eauto.
  apply create_val_inj_lemma0 in H8.
  lets aaa: nth_val'_imply_nth_val H8.
  rewrite H6.
  clear -H0.
  mauto.

  lets bbb: priotbl_null_no_tcb H5 aaa.

  eapply Mutex_Create_TCB_prop; eauto.
  pauto.

  hoare forward.
  instantiate (1:=Afalse) in H24.
  apply adisj_elim in H24.
  elim H24; intros; sep auto.
Qed.