Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.
Set Universe Polymorphism.

From Coq Require Import
     Relation_Definitions
     RelationClasses
.

Require Import Fix.
Require Import GHC.Base.
Require Import Adverb.Adverb.
Require Import ClassesOfFunctors.DictDerive.
Require Import ClassesOfFunctors.Laws.
Require Import ClassesOfFunctors.Selective.

Open Scope adverb_scope.

(* begin conditionally_adv *)
(* Conditionally *)
Inductive ReifiedSelective (E : Type -> Type) (R : Type) : Type :=
| EmbedS (e : E R)
| PureS (r : R)
| SelectBy {X Y : Type} (f : X -> ((Y -> R) + R))
           (a : ReifiedSelective E X) (b : ReifiedSelective E Y).
(* end conditionally_adv *)

Definition selectByCA {E A B C} :
  (A -> ((B -> C) + C)) -> ReifiedSelective E A -> ReifiedSelective E B -> ReifiedSelective E C :=
  SelectBy.

Definition selectCA {E A B} (a : ReifiedSelective E (A + B)) (b : ReifiedSelective E (A -> B)) : ReifiedSelective E B :=
  selectByCA (fun x => match x with
                  | inl x => inl (fun y => y x)
                  | inr x => inr x
                  end) a b.

Definition pureCA {E A} : A -> ReifiedSelective E A := PureS.

Definition fmap__CA {E A B}
           (f : A -> B) (a : ReifiedSelective E A) : ReifiedSelective E B :=
  selectByCA inl (pureCA f) a.

Definition ap__CA {E A B} (f : ReifiedSelective E (A -> B))
           (a : ReifiedSelective E A) : ReifiedSelective E B :=
  selectCA (fmap__CA inl f) (fmap__CA (fun a f => f a) a).

Definition liftA2__CA {E A B C} (f : A -> B -> C)
           (a : ReifiedSelective E A) (b : ReifiedSelective E B) : ReifiedSelective E C :=
  ap__CA (ap__CA (pureCA f) a) b.

Global Instance Functor__CA {E : Type -> Type} : Functor (ReifiedSelective E) :=
  fun r k => k {| fmap__      := fun {a} {b} => fmap__CA ;
              op_zlzd____ := fun {a} {b} => fmap__CA ∘ const |}.

Global Program Instance Applicative__ReifiedSelective {E : Type -> Type} :
  Applicative (ReifiedSelective E) :=
  fun r k => k {| liftA2__ := fun {a b c} => liftA2__CA ;
               op_zlztzg____ := fun {a b} => ap__CA ;
               op_ztzg____ := fun {a b} fa => liftA2__CA id ((fmap__CA ∘ const) id fa) ;
               pure__ := fun {a} => pureCA |}.

Global Program Instance Selective__ReifiedSelective {E : Type -> Type} :
  Selective (ReifiedSelective E) :=
  fun r k => k {| select__ := fun _ _ => selectCA |}.

Definition fmapSum {A B C} (f : A -> B) (a : sum C A) : sum C B :=
  match a with
  | inl c => inl c
  | inr a => inr (f a)
  end.

Definition branch {E A B C} (b : ReifiedSelective E (A + B))
           (l : ReifiedSelective E (A -> C))
           (r : ReifiedSelective E (B -> C)) : ReifiedSelective E C :=
  selectCA (selectCA (fmap (fmapSum inl) b) (fmap (fun f a => inr (f a)) l)) r.

Definition ifS {E A} (b : ReifiedSelective E bool)
           (t e : ReifiedSelective E A) : ReifiedSelective E A :=
  branch (fmap (fun b : bool => if b then inl tt else inr tt) b)
         (fmap (fun a _ => a) t) (fmap (fun a _ => a) e).

Definition pand {E} (x y : ReifiedSelective E bool) : ReifiedSelective E bool :=
  ifS x y (pureCA false).

Definition interpS
  {E I : Type -> Type} `{Monad I}
  {EqI : forall (A : Type), relation (I A)} {A : Type}
  (interpE : forall A, E A -> I A) :=
  let fix go {A : Type} (t : ReifiedSelective E A) : I A :=
    match t with
    | EmbedS e => interpE _ e
    | PureS a => return_ a
    | SelectBy f a b =>  go a >>= (fun x =>
                                    match f x with
                                    | inl y => fmap y (go b)
                                    | inr r => return_ r
                                    end)
    end
  in @go A.

(** * The adverb simulation. *)
Global Instance ReifiedSelectiveSim :
  ReifiedSelective ⊧ Monad__Dict UNDER IdT :=
  {| interp := fun _ I D =>
                 @interpS _ _
                   (monaddict_functor I D)
                   (monaddict_applicative I D)
                   (monaddict_monad I D)
  |}.

Reserved Notation "a ≅ b" (at level 42).

Declare Scope conditionally_scope.

Inductive ConditionallyBisim {E : Type -> Type}
  : forall {A : Type}, relation (ReifiedSelective E A) :=
| conditionally_congruence :
  forall {A B} (a1 a2 : ReifiedSelective E (A + B))
    (b1 b2 : ReifiedSelective E (A -> B)),
    a1 ≅ a2 ->
    b1 ≅ b2 ->
    select a1 b1 ≅ select a2 b2
| conditionally_id : forall {A} (a : ReifiedSelective E (A + A)),
    select a (pure id) ≅ fmap (fun x => match x with
                                     | inl x => x
                                     | inr x => x
                                     end) a
| conditioanlly_distr : forall {A B} (x : A + B)
                          (y z : ReifiedSelective E (A -> B)),
    select (pure x) (y *> z) ≅ (select (pure x) y *> select (pure x) z)
| conditionally_assoc : forall {A B C}
                          (x : ReifiedSelective E (A + B))
                          (y : ReifiedSelective E (C + (A -> B)))
                          (z : ReifiedSelective E (C -> A -> B))
                          (f : (A + B) -> ((A + A) + (C * A + B)))
                          g (h : (C -> A -> B) -> (C * A) -> B),
    (forall x, f x = match x with
                | inl x => inl (inr x)
                | inr x => inr (inr x)
                end) ->
    (forall (y : C + (A -> B)) (a : A + A),
        g y a = let i a :=
                  match y with
                  | inl c => inl (c, a)
                  | inr k => inr (k a)
                  end in
                match a with
                | inl a => i a
                | inr a => i a
                end) ->
    (forall f p, h f p = f (fst p) (snd p)) ->
      select x (select y z) ≅ select (select (fmap f x) (fmap g y)) (fmap h z)
| conditionally_force : forall {A B} (a : ReifiedSelective E B) (b : ReifiedSelective E (A -> B)),
    select (fmap inr a) b ≅ a
| conditionally_refl : forall A (a : ReifiedSelective E A), a ≅ a
| conditionally_sym : forall A (a b : ReifiedSelective E A), a ≅ b -> b ≅ a
| conditionally_trans : forall A (a b c : ReifiedSelective E A), a ≅ b -> b ≅ c -> a ≅ c
where "a ≅ b" := (ConditionallyBisim a b) : conditionally_scope.

Global Program Instance ReifiedConditionally__Adverb : Adverb ReifiedSelective :=
  {| Bisim := fun _ _ => ConditionallyBisim ;
     Refines := fun _ _ => ConditionallyBisim
  |}.
Next Obligation.
  constructor.
  - intros a. constructor.
  - intros a b. constructor. assumption.
  - intros a b c ? ?. econstructor; eassumption.
Qed.
Next Obligation.
  constructor.
  - intros a. constructor.
  - intros a b c ? ?. econstructor; eassumption.
Qed.

Theorem soundness_of_conditionally :
  forall {E I : Type -> Type} {A : Type}
    {EqI : forall (A : Type), relation (I A) } `{forall A, Equivalence (EqI A) }
    {D : Monad__Dict I}
    {_ : @MonadLaws I EqI (monaddict_functor _ D) (monaddict_applicative _ D)
           (monaddict_monad _ D)}
    {_ : @MonadCongruenceLaws I EqI (monaddict_functor _ D)
           (monaddict_applicative _ D) (monaddict_monad _ D)}
    (interpE : forall A, E A -> I A) (x y : ReifiedSelective E A),
    (* The theorem states that [Bisim] is an under-approximation of
       [EqI]. *)
    Bisim (Adverb:=ReifiedConditionally__Adverb) x y ->
    EqI _ (interp (C0:=D)(EqI:=EqI)(AdverbSim:=ReifiedSelectiveSim) interpE x)
      (interp (C0:=D)(EqI:=EqI)(AdverbSim:=ReifiedSelectiveSim) interpE y).
Proof.
  intros until y. intro Hbisim. induction Hbisim.
  - unfold interp. cbn.
    apply bind_cong.
    + apply H1.
    + apply IHHbisim1.
    + intros. destruct a.
      * unfold monaddict_fmap.
        pose proof bind_cong. unfold ">>=" in H2.
        specialize (H2 I EqI _ _ _ H1 (A -> B) B).
        unfold monaddict_monad in H2. apply H2.
        -- rewrite <- IHHbisim2. reflexivity.
        -- reflexivity.
      * reflexivity.
  - unfold interp. cbn.
    rewrite monad_left_id; [|assumption].
    unfold monaddict_fmap.
    pose proof bind_cong. unfold ">>=" in H2.
    specialize (H2 I EqI _ _ _ H1 (A + A) A).
    unfold monaddict_monad in H2. apply H2.
    + reflexivity.
    + intros. destruct a0.
      * pose proof monad_left_id. unfold ">>=" in H3.
        specialize (H3 I EqI _ _ _ H0 (A -> A) A).
        unfold monaddict_monad in H3. rewrite H3.
        reflexivity.
      * reflexivity.
  - unfold interp. cbn.
    rewrite !monad_left_id.
    pose proof monad_assoc as assoc. unfold ">>=" in assoc.
    specialize (assoc I EqI _ _ _ H0).
    unfold monaddict_monad in assoc.
    pose proof monad_left_id as left_id. unfold ">>=" in left_id.
    specialize (left_id I EqI _ _ _ H0).
    unfold monaddict_monad in left_id.
    pose proof left_id as left_id'.
    unfold return_ in left_id'.
    destruct x.
    + unfold monaddict_fmap. unfold ">>=", monaddict_monad.
      rewrite !assoc.
      pose proof (assoc ((B -> B) -> (B -> B) + B) ((B -> B) + B) B) as Ht;
        rewrite !Ht; clear Ht.
      rewrite !left_id.
      pose proof (left_id ((B -> B) -> (B -> B) + B) B) as Ht; rewrite !Ht; clear Ht.
      rewrite !assoc, !left_id.
      pose proof (left_id (((B -> B) -> B -> B) -> ((B -> B) -> B -> B) + (B -> B)) B) as Ht;
        rewrite !Ht; clear Ht.
      rewrite !assoc, !left_id.
      pose proof (left_id ((B -> B) -> B -> B) B) as Ht; rewrite !Ht; clear Ht.
      unfold "∘". rewrite !left_id'.
      rewrite !assoc, !left_id.
      pose proof (left_id ((B -> B) -> ((B -> B) -> B -> B) -> B -> B) B) as Ht.
      rewrite !Ht; clear Ht.
      rewrite !assoc, !left_id.
      pose proof (left_id (B -> B -> B) B) as Ht; rewrite !Ht; clear Ht.
      rewrite !assoc.
      pose proof (left_id (A + B) B) as Ht; rewrite !Ht; clear Ht.
      rewrite !assoc.
      pose proof bind_cong as cong. unfold ">>=" in cong.
      specialize (cong I EqI _ _ _ H1).
      unfold monaddict_monad in cong. apply cong; [reflexivity|]. intros.
      rewrite !left_id'. repeat rewrite !assoc, !left_id.
      rewrite !assoc. apply cong; [reflexivity|]. intros.
      rewrite !left_id'. reflexivity.
    + unfold monaddict_fmap. unfold ">>=", monaddict_monad.
      repeat rewrite !assoc, !left_id. unfold "∘".
      rewrite !left_id'. repeat rewrite !assoc, !left_id.
      rewrite !left_id'. repeat rewrite !assoc, !left_id.
      rewrite !left_id'. reflexivity.
    + assumption.
  - unfold interp. cbn. unfold monaddict_fmap. unfold ">>=", monaddict_monad.
    pose proof monad_assoc as assoc. unfold ">>=" in assoc.
    specialize (assoc I EqI _ _ _ H0).
    unfold monaddict_monad in assoc.
    pose proof monad_left_id as left_id. unfold ">>=" in left_id.
    specialize (left_id I EqI _ _ _ H0).
    unfold monaddict_monad in left_id.
    pose proof left_id as left_id'.
    unfold return_ in left_id'.
    repeat rewrite !assoc, !left_id. rewrite !assoc.
    pose proof monad_right_id as right_id.
    specialize (right_id I EqI _ _ _ H0).
    pose proof bind_cong as cong. unfold ">>=" in cong.
    specialize (cong I EqI _ _ _ H1).
    unfold monaddict_monad in cong. apply cong; [reflexivity|]. intros [].
    + unfold "∘". rewrite !assoc, !left_id'. simpl.
      rewrite H2. repeat rewrite !assoc, !left_id.
      rewrite !assoc. apply cong; [reflexivity|]. intros.
      destruct a0.
      * rewrite !assoc, !left_id'. rewrite H3. simpl.
        repeat rewrite !assoc, !left_id. rewrite !assoc.
        apply cong; [reflexivity|]. intros.
        rewrite !left_id'. rewrite H4. cbn. reflexivity.
      * rewrite !left_id, !left_id'. rewrite H3. simpl.
        reflexivity.
    + unfold "∘". rewrite !left_id'.
      rewrite H2. rewrite !left_id. reflexivity.
  - unfold interp. cbn. unfold monaddict_fmap. unfold ">>=", monaddict_monad.
    pose proof monad_assoc as assoc. unfold ">>=" in assoc.
    specialize (assoc I EqI _ _ _ H0).
    unfold monaddict_monad in assoc.
    pose proof monad_left_id as left_id. unfold ">>=" in left_id.
    specialize (left_id I EqI _ _ _ H0).
    unfold monaddict_monad in left_id.
    pose proof left_id as left_id'.
    unfold return_ in left_id'.
    repeat rewrite !assoc, !left_id. rewrite !assoc.
    pose proof monad_right_id as right_id.
    specialize (right_id I EqI _ _ _ H0).
    pose proof (right_id _ (@interpS E I (monaddict_functor I D)
                              (monaddict_applicative I D)
                              (fun (r : Type) (k : Monad__Dict I -> r) => k D) EqI B interpE a)).
    etransitivity; [|apply H2].
    pose proof bind_cong as cong. unfold ">>=" in cong.
    specialize (cong I EqI _ _ _ H1).
    unfold monaddict_monad in cong.
    unfold ">>=". unfold monaddict_monad.
    apply cong; [reflexivity|]. intros.
    unfold "∘". rewrite left_id'. reflexivity.
  - unfold interp. cbn. reflexivity.
  - unfold interp. cbn. symmetry. assumption.
  - unfold interp. cbn. etransitivity; eassumption.
Qed.


(* Hendra : DEX big step semantics, looking into BigStepLoad.v as reference *)

  Import DEX_Dom DEX_Prog.

  Open Scope type_scope.
  Definition DEX_InitCallState :=  DEX_Method * DEX_Registers.t.
  Definition DEX_IntraNormalState := DEX_PC * ((*DEX_Heap.t **) DEX_Registers.t).
(*  Definition IntraExceptionState := Heap.t * Location. *)
  Definition DEX_ReturnState := (*DEX_Heap.t **) DEX_ReturnVal.

  Inductive DEX_NormalStep (p:DEX_Program) : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState  -> Prop :=
  | nop : forall (*h*) m pc pc' regs,

    instructionAt m pc = Some DEX_Nop ->
    next m pc = Some pc' ->

    DEX_NormalStep p m (pc, regs(*h, regs*)) (pc', regs(*h, regs*))

  | const : forall (*h*) m pc pc' regs regs' k rt v,

    instructionAt m pc = Some (DEX_Const k rt v) ->
    In rt (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (-2^31 <= v < 2^31)%Z ->
    DEX_METHOD.valid_reg m rt ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.const v))) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))

  | move_step_ok : forall (*h*) m pc pc' regs regs' k rt rs v,

    instructionAt m pc = Some (DEX_Move k rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some v = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt v ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))
(* DEX Method
  | moveresult_step_ok : forall h m pc pc' l l' k rt v,

    instructionAt m pc = Some (DEX_MoveResult k rt) ->
    next m pc = Some pc' ->
    Some v = DEX_Registers.get l DEX_Registers.ret ->
    DEX_METHOD.valid_reg m rt ->
    l' = DEX_Registers.update l rt v ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l'))
*)
(* DEX Object
 (** <addlink>instanceof</addlink>: Determine if object is of given type *)
  | instanceof_step_ok1 : forall h m pc pc' l loc rt r t l',

    instructionAt m pc = Some (DEX_InstanceOf rt r t) ->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get l r ->
    assign_compatible p h (Ref loc) (DEX_ReferenceType t) ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m r ->
    l' = DEX_Registers.update l' rt (Num (I (Int.const 1))) ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l'))
 (** <addlink>instanceof</addlink>: with object == null *)
  | instanceof_step_ok2 : forall h m pc pc' l rt r t v l',

    instructionAt m pc = Some (DEX_InstanceOf rt r t) ->
    next m pc = Some pc' ->
    Some v = DEX_Registers.get l r ->
    isReference v ->
    (~ assign_compatible p h v (DEX_ReferenceType t) \/ v=Null) ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m r ->
    l' = DEX_Registers.update l' rt (Num (I (Int.const 0))) ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l'))

  (** <addlink>arraylength</addlink>: Get length of array *)
  | arraylength_step_ok : forall h m pc pc' l l' loc length tp a rt rs,

    instructionAt m pc = Some (DEX_ArrayLength rt rs)->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get l rs ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.LocationArray length tp a) ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    l' = DEX_Registers.update l rt (Num (I length)) ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l'))

  (** <addlink>new</addlink>: Create new object *)
  | new_step_ok : forall h m pc pc' l l' c loc h' rt,

    instructionAt m pc = Some (DEX_New rt (DEX_ClassType c)) ->
    next m pc = Some pc' ->
    DEX_Heap.new h p (DEX_Heap.LocationObject c) = Some (pair loc h') ->
    DEX_METHOD.valid_reg m rt ->
    l' = DEX_Registers.update l rt (Ref loc) ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h', l'))

 (** Create new array (<addlink>anewarray</addlink>, <addlink>newarray</addlink>) *)
 (** OutOfMemory is not considered in Bicolano *)
  | newarray_step_ok : forall h m pc pc' l l' i t loc h_new rt rl,

    instructionAt m pc = Some (DEX_NewArray rt rl t) ->
    next m pc = Some pc' ->
    DEX_Heap.new h p (DEX_Heap.LocationArray i t (m,pc)) = Some (pair loc h_new) ->
    Some (Num (I i)) = DEX_Registers.get l rl ->
    (0 <= Int.toZ i)%Z ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rl ->
    l' = DEX_Registers.update l rt (Ref loc) ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h_new, l'))
*)

  | goto_step_ok : forall (*h*) m pc regs o,

    instructionAt m pc = Some (DEX_Goto o) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) ((DEX_OFFSET.jump pc o), regs(*h, l*))
(*
  | packedswitch_step_ok1 : forall h m pc l v r firstKey size list_offset n o,

    instructionAt m pc = Some (DEX_PackedSwitch r firstKey size list_offset) ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    (firstKey <= Int.toZ v < firstKey + (Z_of_nat size))%Z ->
    length list_offset = size ->
    Z_of_nat n = ((Int.toZ v) - firstKey)%Z ->
    nth_error list_offset n = Some o ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) ((DEX_OFFSET.jump pc o), (h, l))

  | packedswitch_step_ok2 : forall h m pc pc' l v r firstKey size list_offset,

    instructionAt m pc = Some (DEX_PackedSwitch r firstKey size list_offset) ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    length list_offset = size ->
    (Int.toZ v < firstKey \/ firstKey + (Z_of_nat size) <= Int.toZ v)%Z ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l))

  | sparseswitch_step_ok1 : forall h m pc l v v' o r size listkey,

    instructionAt m pc = Some (DEX_SparseSwitch r size listkey) ->
    length listkey = size ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    List.In (pair v' o) listkey ->
    v' = Int.toZ v ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) ((DEX_OFFSET.jump pc o), (h, l))

  | sparseswitch_step_ok2 : forall h m pc pc' l v r size listkey,

    instructionAt m pc = Some (DEX_SparseSwitch r size listkey) ->
    length listkey = size ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    (forall v' o, List.In (pair v' o) listkey ->  v' <> Int.toZ v) ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l))
*)
  | ifcmp_step_jump : forall (*h*) m pc regs va vb cmp ra rb o,

    instructionAt m pc = Some (DEX_Ifcmp cmp ra rb o) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    SemCompInt cmp (Int.toZ va) (Int.toZ vb) ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->

    DEX_NormalStep p m (pc, regs(*h, l*)) ((DEX_OFFSET.jump pc o), regs(*h, l*))

  | ifcmp_step_continue : forall (*h*) m pc pc' regs va vb cmp ra rb o,

    instructionAt m pc = Some (DEX_Ifcmp cmp ra rb o) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    ~SemCompInt cmp (Int.toZ va) (Int.toZ vb) ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs(*h, l*))

  | ifz_step_jump : forall (*h*) m pc regs v cmp r o,

    instructionAt m pc = Some (DEX_Ifz cmp r o) ->
    In r (DEX_Registers.dom regs) ->
    Some (Num (I v)) = DEX_Registers.get regs r ->
    SemCompInt cmp (Int.toZ v) (0) ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, regs(*h, l*)) ((DEX_OFFSET.jump pc o), regs(*h, l*))

  | ifz_step_continue : forall (*h*) m pc pc' regs v cmp r o,

    instructionAt m pc = Some (DEX_Ifz cmp r o) ->
    In r (DEX_Registers.dom regs) ->
    Some (Num (I v)) = DEX_Registers.get regs r ->
    ~SemCompInt cmp (Int.toZ v) (0) ->
    next m pc = Some pc' ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs(*h, l*))

(* DEX Object
   (** Load value from array *)
  | aget_step_ok : forall h m pc pc' l l' loc val i length t a k rt ra ri,

    instructionAt m pc = Some (DEX_Aget k rt ra ri) ->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get l ra ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.LocationArray length t a) ->
    compat_ArrayKind_type k t ->
    Some (Num (I i)) = DEX_Registers.get l ri ->
    (0 <= Int.toZ i < Int.toZ length)%Z ->
    DEX_Heap.get h (DEX_Heap.ArrayElement loc (Int.toZ i)) = Some val ->
    compat_ArrayKind_value k val ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m ri ->
    l' = DEX_Registers.update l rt (conv_for_stack val) ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l'))

  (** Store into array *)
  | aput_step_ok : forall h m pc pc' l loc val i length tp k a rs ra ri,

    instructionAt m pc = Some (DEX_Aput k rs ra ri) ->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get l ra ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.LocationArray length tp a) ->
    Some val = DEX_Registers.get l rs ->
    assign_compatible p h val tp ->
    Some (Num (I i)) = DEX_Registers.get l ri ->
    (0 <= Int.toZ i < Int.toZ length)%Z ->
    compat_ArrayKind_type k tp ->
    compat_ArrayKind_value k val ->
    DEX_METHOD.valid_reg m rs ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m ri ->

    DEX_NormalStep p m (pc, (h, l))
                   (pc',((DEX_Heap.update h (DEX_Heap.ArrayElement loc (Int.toZ i)) (conv_for_array val tp)), l))

  (** <addlink>iget</addlink>: Fetch field from object *)
  | iget_step_ok : forall h m pc pc' l l' loc f v cn k rt ro,

    instructionAt m pc = Some (DEX_Iget k rt ro f) ->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get l ro ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.LocationObject cn) ->
    defined_field p cn f ->
    DEX_Heap.get h (DEX_Heap.DynamicField loc f) = Some v ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m ro ->
    l' = DEX_Registers.update l rt v ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l'))

  (** <addlink>iput</addlink>: Set field in object *)
  | iput_step_ok : forall h m pc pc' l f loc cn v k rs ro,

    instructionAt m pc = Some (DEX_Iput k rs ro f) ->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get l ro ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.LocationObject cn) ->
    defined_field p cn f ->
    Some v = DEX_Registers.get l rs ->
    assign_compatible p h v (DEX_FIELDSIGNATURE.type (snd f)) ->
    DEX_METHOD.valid_reg m rs ->
    DEX_METHOD.valid_reg m ro ->

    DEX_NormalStep p m (pc, (h, l))
           (pc, ((DEX_Heap.update h (DEX_Heap.DynamicField loc f) v), l))
*)

  (** <addlink>ineg</addlink>: Negate [int] *)
  | ineg_step : forall (*h*) m pc regs regs' pc' rt rs v,

    instructionAt m pc = Some (DEX_Ineg rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.neg v))) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))

  (** <addlink>ineg</addlink>: Not [int] (one's complement) *)
  | inot_step : forall (*h*) m pc regs regs' pc' rt rs v,

    instructionAt m pc = Some (DEX_Inot rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.not v))) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))

  (** <addlink>i2b</addlink>: Convert [int] to [byte] *)
  | i2b_step_ok : forall (*h*) m pc pc' regs regs' rt rs v,

    instructionAt m pc = Some (DEX_I2b rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (b2i (i2b v)))) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))

 (** <addlink>i2s</addlink>: Convert [int] to [short] *)
  | i2s_step_ok : forall (*h*) m pc pc' regs regs' rt rs v,

    instructionAt m pc = Some (DEX_I2s rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (s2i (i2s v)))) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))

  | ibinop_step_ok : forall (*h*) m pc pc' regs regs' op rt ra rb va vb,

    instructionAt m pc = Some (DEX_Ibinop op rt ra rb) ->
    In rt (DEX_Registers.dom regs) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (*(op = DivInt \/ op = RemInt -> ~ Int.toZ i2 = 0) -> at this moment there is no exception*)
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->
    regs' = DEX_Registers.update regs rt (Num (I (SemBinopInt op va vb))) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))

  | ibinopconst_step_ok : forall (*h*) m pc pc' regs regs' op rt r va v,

    instructionAt m pc = Some (DEX_IbinopConst op rt r v) ->
    In r (DEX_Registers.dom regs) ->
    In rt (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (*(op = DivInt \/ op = RemInt -> ~ Int.toZ i2 = 0) -> at this moment there is no exception*)
    Some (Num (I va)) = DEX_Registers.get regs r ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m r ->
    regs' = DEX_Registers.update regs rt (Num (I (SemBinopInt op va (Int.const v)))) ->

    DEX_NormalStep p m (pc, regs(*h, l*)) (pc', regs'(*h, l'*))
.

(*  Inductive JVMExceptionStep  (p:Program) : Method -> IntraNormalState -> ShortClassName -> Prop :=
  | arraylength_NullPointerException : forall h m pc s l,

    instructionAt m pc = Some Arraylength ->

    JVMExceptionStep p m (pc,(h,(Null::s),l))  NullPointerException

  | athrow_NullPointerException : forall h m pc s l,

    instructionAt m pc = Some Athrow ->

    JVMExceptionStep p m (pc,(h,(Null::s),l)) NullPointerException

  | checkcast_ClassCastException : forall h m pc s l loc t,

    instructionAt m pc = Some (Checkcast t) ->
    ~ assign_compatible p h (Ref loc) (ReferenceType t) ->

    JVMExceptionStep p m (pc,(h,(Ref loc::s),l)) ClassCastException

  | getfield_NullPointerException : forall h m pc s l f ,

    instructionAt m pc = Some (Getfield f) ->

    JVMExceptionStep p m (pc,(h,(Null::s),l)) NullPointerException

 | ibinop_ArithmeticException : forall h m pc s l op i1 i2,

    instructionAt m pc = Some (Ibinop op) ->
    op = DivInt \/ op = RemInt ->
    Int.toZ i2 = 0%Z ->

    JVMExceptionStep p m (pc,(h,(Num (I i2)::Num (I i1)::s),l)) ArithmeticException

  | invokevirtual_NullPointerException : forall h m pc s l mid args,

    instructionAt m pc = Some (Invokevirtual mid) ->
    length args = length (METHODSIGNATURE.parameters (snd mid)) ->

    JVMExceptionStep p m (pc,(h,(args++Null::s),l)) NullPointerException

  | newarray_NegativeArraySizeException : forall h m pc s l t i,

    instructionAt m pc = Some (Newarray t) ->
    (~ 0 <= Int.toZ i)%Z ->

    JVMExceptionStep p m (pc,(h,(Num (I i)::s),l)) NegativeArraySizeException

  | putfield_NullPointerException : forall h m pc s l f v,

    instructionAt m pc = Some (Putfield f) ->

    JVMExceptionStep p m (pc,(h,(v::Null::s),l)) NullPointerException

  | vaload_NullPointerException : forall h m pc s l i k,

    instructionAt m pc = Some (Vaload k) ->

    JVMExceptionStep p m (pc,(h,((Num (I i))::Null::s),l)) NullPointerException

  | vaload_ArrayIndexOutOfBoundsException : forall h m pc s l loc i length t k a,

    instructionAt m pc = Some (Vaload k) ->
    Heap.typeof h loc = Some (Heap.LocationArray length t a) ->
    compat_ArrayKind_type k t ->
    (~ 0 <= Int.toZ i < Int.toZ length)%Z ->

    JVMExceptionStep p m (pc,(h,((Num (I i))::(Ref loc)::s),l)) ArrayIndexOutOfBoundsException

  | vastore_NullPointerException : forall h m pc s l val i k,

    instructionAt m pc = Some (Vastore k) ->
    compat_ArrayKind_value k val ->

    JVMExceptionStep p m (pc,(h,(val::(Num (I i))::Null::s),l)) NullPointerException

  | vastore_ArrayIndexOutOfBoundsException : forall h m pc s l loc val i t length k a,

    instructionAt m pc = Some (Vastore k) ->
    Heap.typeof h loc = Some (Heap.LocationArray length t a) ->
    (~ 0 <= Int.toZ i < Int.toZ length)%Z ->
    compat_ArrayKind_type k t ->
    compat_ArrayKind_value k val ->

    JVMExceptionStep p m (pc,(h,(val::(Num (I i))::(Ref loc)::s),l)) ArrayIndexOutOfBoundsException

  | vastore_ArrayStoreException : forall h m pc s l loc val i t k length a,

    instructionAt m pc = Some (Vastore k) ->
    Heap.typeof h loc = Some (Heap.LocationArray length t a) ->
    ~ assign_compatible p h val t ->
    (0 <= Int.toZ i < Int.toZ length)%Z ->
    compat_ArrayKind_type k t ->
    compat_ArrayKind_value k val ->

    JVMExceptionStep p m (pc,(h,(val::(Num (I i))::(Ref loc)::s),l)) ArrayStoreException
.

  Inductive ExceptionStep (p:Program) : Method -> IntraNormalState -> IntraExceptionState -> Prop :=
  | athrow : forall h m pc s l loc cn,

    instructionAt m pc = Some Athrow ->
    Heap.typeof h loc = Some (Heap.LocationObject cn) ->
    subclass_name p cn javaLangThrowable ->
    ExceptionStep p m (pc,(h,(Ref loc::s),l)) (h,loc)

  | jvm_exception : forall h m pc s l h' loc (e:ShortClassName),

    JVMExceptionStep p m (pc,(h,s,l)) e ->
    Heap.new h p (Heap.LocationObject (javaLang,e)) = Some (loc,h') ->

    ExceptionStep p m (pc,(h,s,l)) (h',loc).
*)

(* DEX Method
  Inductive DEX_CallStep (p:DEX_Program) : DEX_Method -> DEX_IntraNormalState -> DEX_InitCallState -> Prop :=
  | invokestatic : forall h m pc l mid M args bM n,

    instructionAt m pc = Some (DEX_Invokestatic mid n args) ->
    findMethod p mid = Some M ->
    DEX_METHOD.isNative M = false ->
    length args = length (DEX_METHODSIGNATURE.parameters (snd mid)) ->
    DEX_METHOD.body M = Some bM ->
    DEX_METHOD.isStatic M = true ->

    DEX_CallStep p m (pc,(h, l)) (M, (listreg2regs l (length args) args))

  | invokevirtual : forall h m pc l mid M args loc bM n,

    instructionAt m pc = Some (DEX_Invokevirtual mid n args) ->
    (*lookup p cn mid (pair cl M) ->*)
    findMethod p mid = Some M ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.LocationObject (fst mid)) ->
    length args = length (DEX_METHODSIGNATURE.parameters (snd mid)) ->
    DEX_METHOD.body M = Some bM ->
    DEX_METHOD.isStatic M = false ->

    DEX_CallStep p m (pc,(h, l)) (M,(listreg2regs l (length args) args))
  .
*)

  Inductive DEX_ReturnStep (p:DEX_Program) : DEX_Method -> DEX_IntraNormalState -> DEX_ReturnState -> Prop :=
  | void_return : forall (*h*) m pc regs,

    instructionAt m pc = Some DEX_Return ->
    DEX_METHODSIGNATURE.result (DEX_METHOD.signature m) = None ->

    DEX_ReturnStep p m (pc, regs(*h, l*)) (Normal None)(*h, Normal None*)

  | vreturn : forall (*h*) m pc regs val t k rs,
    (* Implicit in the assumption is that the register has a value in it *)
    instructionAt m pc = Some (DEX_VReturn k rs) ->
    In rs (DEX_Registers.dom regs) ->
    DEX_METHODSIGNATURE.result (DEX_METHOD.signature m) = Some t ->
    assign_compatible p (*h*) val t ->
    compat_ValKind_value k val ->
    Some val = DEX_Registers.get regs rs ->

    DEX_ReturnStep p m (pc, regs(*h, l*)) (Normal (Some val))(*h, Normal (Some val)*)
.

(* DEX Method
  Inductive DEX_call_and_return : DEX_Method -> DEX_IntraNormalState -> DEX_InitCallState -> DEX_IntraNormalState -> DEX_ReturnState -> DEX_IntraNormalState -> Prop :=
  | call_and_return_void : forall m pc h l m' l' bm' h'' pc',
      next m pc = Some pc' ->
      DEX_METHOD.body m' = Some bm' ->
      DEX_call_and_return
                 m
                 (pc, (h,l))
                 (m', l')
                  (DEX_BYTECODEMETHOD.firstAddress bm',(h, l'))
                 (h'', Normal None)
                 (pc',(h'', l))
  | call_and_return_value : forall m pc h l m' l' bm' h'' v pc' l'',
      next m pc = Some pc' ->
      DEX_METHOD.body m' = Some bm' ->
      l'' = DEX_Registers.update l DEX_Registers.ret v ->
      DEX_call_and_return
                 m
                 (pc, (h, l))
                 (m', l')
                 (DEX_BYTECODEMETHOD.firstAddress bm',(h, l'))
                 (h'', Normal (Some v))
                 (pc',(h'', l'')).
*)

(*
  Inductive call_and_return_exception : Method -> IntraNormalState -> InitCallState -> IntraNormalState -> ReturnState -> IntraExceptionState -> Prop :=
  | call_and_return_exception_def : forall m pc h s l m' l' bm' h'' s' loc,
      METHOD.body m' = Some bm' ->
      call_and_return_exception
                 m
                 (pc,(h,s,l))
                 (m',(s',l'))
                 (BYTECODEMETHOD.firstAddress bm',(h,OperandStack.empty,l'))
                 (h'',Exception loc)
                 (h'',loc).
*)
  Inductive DEX_exec_intra (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_IntraNormalState -> Prop :=
  | exec_intra_normal : forall s1 s2,
     DEX_NormalStep p m s1 s2 ->
     DEX_exec_intra p m s1 s2
  (*| exec_exception : forall pc1 h1 h2 loc2 s1 l1 pc',
   ExceptionStep p m (pc1,(h1,s1,l1)) (h2,loc2) ->
   CaughtException p m (pc1,h2,loc2) pc' ->
   exec_intra p m (pc1,(h1,s1,l1)) (pc',(h2,Ref loc2::OperandStack.empty,l1))*)
.

  Inductive DEX_exec_return (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_ReturnState -> Prop :=
  | exec_return_normal : forall s (*h*) ov,
     DEX_ReturnStep p m s (Normal ov)(*h,Normal ov*) ->
     DEX_exec_return p m s (Normal ov)(*h,Normal ov*)
(*  | exec_return_exception : forall pc1 h1 h2 loc2 s1 l1,
     ExceptionStep p m (pc1,(h1,s1,l1)) (h2,loc2) ->
     UnCaughtException  p m (pc1,h2,loc2) ->
     exec_return p m (pc1,(h1,s1,l1)) (h2,Exception loc2)*)
.

(* DEX Method
  Inductive DEX_exec_call (p:DEX_Program) (m:DEX_Method) :
   DEX_IntraNormalState -> DEX_ReturnState -> DEX_Method  -> DEX_IntraNormalState -> DEX_IntraNormalState+DEX_ReturnState -> Prop :=
 | exec_call_normal : forall m2 pc1 pc1' h1 l1 l2 h2 bm2 ov l1',
     DEX_CallStep p m (pc1,(h1, l1 )) (m2, l2) ->
     DEX_METHOD.body m2 = Some bm2 ->
     next m pc1 = Some pc1' ->
     l1' = DEX_Registers.update l1 DEX_Registers.ret ov ->
     DEX_exec_call p m
        (pc1,(h1, l1))
        (h2,Normal (Some ov))
        m2
        (DEX_BYTECODEMETHOD.firstAddress bm2, (h1, l2))
        (inl _ (pc1',(h2, l1')))
(*
 | exec_call_caught : forall m2 pc1 pc1' h1 s1 l1 os l2 h2 loc bm2,
     CallStep p m (pc1,(h1,s1,l1 )) (m2,(os,l2)) ->
     METHOD.body m2 = Some bm2 ->
     CaughtException p m (pc1, h2, loc) pc1' ->
     exec_call p m
        (pc1,(h1,s1,l1))
        (h2,Exception loc)
        m2
        (BYTECODEMETHOD.firstAddress bm2,(h1,OperandStack.empty,l2))
        (inl _(pc1',(h2,Ref loc::nil,l1)))
 | exec_call_uncaught : forall m2 pc1 h1 s1 l1 os l2 h2 loc bm2,
     CallStep p m (pc1,(h1,s1,l1 )) (m2,(os,l2)) ->
     METHOD.body m2 = Some bm2 ->
     UnCaughtException p m (pc1, h2, loc)  ->
     exec_call p m
       (pc1,(h1,s1,l1))
       (h2,Exception loc)
       m2
       (BYTECODEMETHOD.firstAddress bm2,(h1,OperandStack.empty,l2))
       (inr _ (h2,Exception loc))*).
*)

 Inductive DEX_IntraStep (p:DEX_Program) :
    DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop :=
  | IntraStep_res :forall m s ret,
     DEX_exec_return p m s ret ->
     DEX_IntraStep p m s (inr _ ret)
  | IntraStep_intra_step:forall m s1 s2,
     DEX_exec_intra p m s1 s2 ->
     DEX_IntraStep p m s1 (inl _ s2)
(* DEX Method
  | IntraStep_call :forall m m' s1 s' ret' r,
     DEX_exec_call p m s1 ret' m' s' r ->
     TransStep_l (DEX_IntraStep p m') s' (inr _ ret') ->
     DEX_IntraStep p m s1 r*) .

 Definition DEX_IntraStepStar p m s r := TransStep_l (DEX_IntraStep p m) s r.

 Definition DEX_IntraStepStar_intra p m s s' := DEX_IntraStepStar p m s (inl _ s').

 Definition DEX_BigStep  p m s ret := DEX_IntraStepStar p m s (inr _ ret).

 Inductive DEX_ReachableStep (P:DEX_Program) :
      (DEX_Method*DEX_IntraNormalState)->(DEX_Method*DEX_IntraNormalState) ->Prop :=
   | ReachableIntra : forall M s s',
       DEX_IntraStep P M s (inl _ s') ->
       DEX_ReachableStep P (M,s) (M,s')
(* DEX Method
   | Reachable_invS : forall M pc h l M' l' bm',
       DEX_CallStep P M (pc,(h, l)) (M', l') ->
       DEX_METHOD.body M' = Some bm' ->
       DEX_ReachableStep P (M, (pc,(h, l)))
         (M', (DEX_BYTECODEMETHOD.firstAddress bm',(h, l')))*).

 Definition DEX_Reachable P M s s' :=
   exists M',  ClosReflTrans (DEX_ReachableStep P) (M,s) (M',s').


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RunSMC.Layer.
Require Import TableAux.Code.table_maps_block.

Require Import TableAux.LowSpecs.table_maps_block.

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) :=
    _pgte_read ↦ gensem pgte_read_spec
      ⊕ _entry_to_phys ↦ gensem entry_to_phys_spec
      ⊕ _addr_is_level_aligned ↦ gensem addr_is_level_aligned_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_pgte_read: block.
    Hypothesis h_pgte_read_s : Genv.find_symbol ge _pgte_read = Some b_pgte_read.
    Hypothesis h_pgte_read_p : Genv.find_funct_ptr ge b_pgte_read
                               = Some (External (EF_external _pgte_read
                                                (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tulong cc_default))
                                      (Tcons Tptr (Tcons tulong Tnil)) tulong cc_default).
    Local Opaque pgte_read_spec.

    Variable b_entry_to_phys: block.
    Hypothesis h_entry_to_phys_s : Genv.find_symbol ge _entry_to_phys = Some b_entry_to_phys.
    Hypothesis h_entry_to_phys_p : Genv.find_funct_ptr ge b_entry_to_phys
                                   = Some (External (EF_external _entry_to_phys
                                                    (signature_of_type (Tcons tulong (Tcons tulong Tnil)) tulong cc_default))
                                          (Tcons tulong (Tcons tulong Tnil)) tulong cc_default).
    Local Opaque entry_to_phys_spec.

    Variable b_addr_is_level_aligned: block.
    Hypothesis h_addr_is_level_aligned_s : Genv.find_symbol ge _addr_is_level_aligned = Some b_addr_is_level_aligned.
    Hypothesis h_addr_is_level_aligned_p : Genv.find_funct_ptr ge b_addr_is_level_aligned
                                           = Some (External (EF_external _addr_is_level_aligned
                                                            (signature_of_type (Tcons tulong (Tcons tulong Tnil)) tuint cc_default))
                                                  (Tcons tulong (Tcons tulong Tnil)) tuint cc_default).
    Local Opaque addr_is_level_aligned_spec.

    Ltac solve_func64 val :=
      try unfold Monad.bind; try unfold ret; simpl;
      match goal with
      | [|- match ?v with | Some _ => _ | None => None end = _] =>
          replace v with (Some (VZ64 (Int64.unsigned (Int64.repr val))))
      end.

    Ltac solve_func val :=
      try unfold Monad.bind; try unfold ret; simpl;
      match goal with
      | [|- match ?v with | Some _ => _ | None => None end = _] =>
          replace v with (Some (Int.unsigned (Int.repr val)))
      end.

    Lemma table_maps_block_body_correct:
      forall m d env le table_base table_offset level ipa_state res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTtable: PTree.get _table le = Some (Vptr table_base (Int.repr table_offset)))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (HPTipa_state: PTree.get _ipa_state le = Some (Vlong ipa_state))
             (Hspec: table_maps_block_spec0 (table_base, table_offset) (VZ64 (Int64.unsigned level)) (VZ64 (Int64.unsigned ipa_state)) d = Some (Int.unsigned res)),
           exists le', (exec_stmt ge env le ((m, d): mem) table_maps_block_body E0 le' (m, d) (Out_return (Some (Vint res, tuint)))).
    Proof.
      solve_code_proof Hspec table_maps_block_body.
      - eexists. repeat big_vcgen.
        solve_func64 z0. reflexivity.
        symmetry. repeat sstep. assumption. somega.
        solve_func64 z2. reflexivity.
        symmetry. repeat sstep.
        rewrite C8. reflexivity.
        somega. somega. somega. somega.
        solve_proof_low.
        simpl. solve_proof_low.
      - get_loop_body. clear_hyp.
        set (Hloop := C11). simpl; solve_proof_low.
        remember
            (PTree.set _i (Vint (Int.repr 0))
                (PTree.set _ret (Vint (Int.repr 1))
                  (PTree.set _t'5 (Vint (Int.repr z3))
                      (PTree.set _base_pa (Vlong (Int64.repr z2))
                        (PTree.set _t'2 (Vlong (Int64.repr z2))
                            (PTree.set _pgte (Vlong (Int64.repr z0))
                              (PTree.set _t'1 (Vlong (Int64.repr z0)) le)))))))
            as le_loop.
        remember 512 as num.
        set (P := fun le0 m0 => m0 = (m, d) /\ le0 = le_loop).
        set (Q := fun (le0: temp_env) m0 => m0 = (m, d) /\ le0 ! _ret = Some (Vint res)).
        set (Inv := fun le0 m0 n => exists i' ret',
                        table_maps_block_loop0 (Z.to_nat (num - n)) 0 1 (table_base, table_offset) z2
                                               (Int64.unsigned level) (Int64.unsigned ipa_state) d =
                          Some (Int.unsigned i', Int.unsigned ret') /\ Int.unsigned i' = num - n /\
                          m0 = (m, d) /\ 0 <= n /\ n <= num /\ le0 ! _i = Some (Vint i') /\
                          le0 ! _table = Some (Vptr table_base (Int.repr table_offset)) /\
                          le0 ! _level = Some (Vlong level) /\
                          le0 ! _ipa_state = Some (Vlong ipa_state) /\
                          le0 ! _ret = Some (Vint ret') /\
                          le0 ! _base_pa = Some (Vlong (Int64.repr z2))).
        assert(loop_succ: forall N, Z.of_nat N <= num -> exists i' ret',
                    table_maps_block_loop0 (Z.to_nat (num - Z.of_nat N)) 0 1
                                           (table_base, table_offset) z2
                                           (Int64.unsigned level) (Int64.unsigned ipa_state) d =
                      Some (Int.unsigned i', Int.unsigned ret')).
        { add_int Hloop z4; try somega.
          induction N. rewrite Z.sub_0_r. rewrite Hloop. intros. repeat eexists; reflexivity.
          intros. erewrite loop_ind_sub1 in IHN; try omega.
          rewrite Nat2Z.inj_succ, succ_plus_1 in H.
          assert(Hcc: Z.of_nat N <= num) by omega.
          apply IHN in Hcc. destruct Hcc as (? & ? & Hnext).
          Local Opaque Z.of_nat. simpl in Hnext. clear Heqle_loop.
          simpl_func Hnext; try add_int' z; try somega; try add_int' z1; try somega; repeat eexists. }
        assert (T: LoopProofSimpleWhile.t (external_calls_ops := CompatExternalCalls.compatlayer_extcall_ops L) cond body ge (PTree.empty _) P Q).
        { apply LoopProofSimpleWhile.make with (W:=Z) (lt:=fun z1 z2 => (0 <= z2 /\ z1 < z2)) (I:=Inv).
          - apply Zwf_well_founded.
          - unfold P, Inv. intros ? ? CC. destruct CC as [CC1 CC2].
            rewrite CC2 in *. exists num.
            replace (num - num) with 0 by omega. simpl.
            exists (Int.repr 0). exists (Int.repr 1).
            rewrite Heqnum. rewrite Heqle_loop.
            repeat eexists; first [reflexivity|assumption|solve_proof_low].
          - intros ? ? ? I. unfold Inv in I.
            destruct I as (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?).
            set (Hnow := H).
            rewrite Heqbody, Heqcond in *.
            destruct (n >? 0) eqn:Hn; bool_rel.
            + eexists. eexists. split_and.
              * solve_proof_low.
              * solve_proof_low.
              * intro CC. inversion CC.
              * assert(Hlx: Z.of_nat (Z.to_nat (n-1)) <= num) by (rewrite Z2Nat.id; omega).
                apply loop_succ in Hlx. rewrite Z2Nat.id in Hlx; try omega.
                intro. destruct Hlx as (? & ? & Hnext). duplicate Hnext.
                rewrite loop_nat_sub1 in Hnext; try somega.
                simpl in Hnext. rewrite Hnow in Hnext.
                autounfold in Hnext; repeat simpl_hyp Hnext;
                  repeat destruct_con; bool_rel; contra; inversion Hnext.
                rewrite H12, H13 in *; eexists; eexists; split.
                repeat big_vcgen.
                solve_func64 z1. reflexivity.
                symmetry. repeat sstep. assumption. somega.
                solve_proof_low. somega. somega. somega. somega. somega. somega.
                somega. somega. simpl.
                solve_proof_low. solve_proof_low.
                solve_proof_low. somega.
                exists (n-1); split. split; solve_proof_low.
                solve_proof_low; unfold Inv; repeat eexists; first[eassumption|solve_proof_low].
                rewrite <- (Int.repr_unsigned x2). rewrite <- H13.
                rewrite Int.repr_unsigned. assumption.

                rewrite H12, H13 in *; eexists; eexists; split.
                repeat big_vcgen.
                solve_func64 z1. reflexivity.
                symmetry. repeat sstep. assumption. somega.
                solve_proof_low. somega. somega. somega. somega. somega. somega.
                somega. somega. simpl.
                solve_proof_low. solve_proof_low.
                solve_proof_low. somega.
                exists (n-1); split. split; solve_proof_low.
                solve_proof_low; unfold Inv; repeat eexists; first[eassumption|solve_proof_low].
                rewrite H12. rewrite H13. rewrite D. sstep. reflexivity.
                rewrite H12. sstep. omega.

                rewrite H12, H13 in *; eexists; eexists; split.
                repeat big_vcgen.
                solve_func64 z1. reflexivity.
                symmetry. repeat sstep. assumption. somega.
                solve_proof_low. somega. somega. somega. somega. somega. somega.
                somega. somega. somega. somega.  simpl.
                solve_proof_low. solve_proof_low.
                solve_proof_low. somega.
                exists (n-1); split. split; solve_proof_low.
                solve_proof_low; unfold Inv; repeat eexists; first[eassumption|solve_proof_low].
                rewrite H12. rewrite H13. rewrite D. sstep. reflexivity.
                rewrite H12. sstep. omega.
            + eexists. eexists. split_and.
              * solve_proof_low.
              * solve_proof_low.
              * intro. unfold Q.
                assert (n=0) by omega. clear Heqle_loop. subst.
                sstep. rewrite Hloop in Hnow. inv Hnow.
                split_and; first[reflexivity|solve_proof_low].
              * intro CC. inversion CC. }
        assert (Pre: P le_loop (m, d)) by (split; reflexivity).
        pose proof (LoopProofSimpleWhile.termination _ _ _ _ _ _ T _ (m, d) Pre) as LoopProof.
        destruct LoopProof as (le' & m' & (exec & Post)).
        unfold exec_stmt in exec. rewrite Heqle_loop in exec.
        unfold Q in Post. destruct Post as (Post & Hle'). rewrite Post in exec.

        eexists. repeat big_vcgen.
        solve_func64 z0. reflexivity.
        symmetry. repeat sstep. assumption. somega. somega.
        solve_func64 z2. reflexivity.
        symmetry. repeat sstep.
        solve_func z3. reflexivity.
        symmetry. sstep. assumption. somega. somega. somega. somega.
        solve_proof_low. simpl.
        solve_proof_low.
      Qed.

  End BodyProof.

End CodeProof.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module LockProtocol.
Section LockProtocol.

Variable server : nid.
Variable clients : seq nid.

Hypothesis Hnin : server \notin clients.
Hypothesis Huniq : uniq clients.

Lemma client_not_server n : n \in clients -> (n == server) = false.
Proof.
  move=>H.
  case E: (n == server)=>//.
  move/eqP in E. subst n.
  move: (Hnin).
  by rewrite H.
Qed.

Definition nodes := [:: server] ++ clients.

Lemma client_nodes n : n \in clients -> n \in nodes.
Proof.
  by rewrite inE orbC/= =>->.
Qed.

Notation epoch := nat (only parsing).

Record server_state :=
  ServerState {
      outstanding : seq nid;
      current_epoch : epoch;
      current_holder : option nid
    }.

Inductive client_state :=
| NotHeld
| Held of epoch.

Definition acquire_tag := 0.
Definition grant_tag := 1.
Definition release_tag := 2.

Definition msg_from_server ms e :=
  (tag ms == grant_tag) && (tms_cont ms == [:: e]).

Definition msg_from_client ms :=
  ((tag ms == acquire_tag) || (tag ms == release_tag)) &&
  (tms_cont ms == [::]).

Definition coh_msg pkt e :=
  if from pkt == server
  then to pkt \in clients /\ msg_from_server (content pkt) e
  else if from pkt \in clients
  then to pkt == server /\ msg_from_client (content pkt)
  else False.

Definition st := ptr_nat 1.

Definition client_local_coh (cs : client_state) :=
  [Pred h | h = st :-> cs].

Definition server_local_coh (ss : server_state) :=
  [Pred h | h = st :-> ss].

Definition local_coh (n : nid) :=
  [Pred h | valid h /\
   if n == server
   then exists ss, server_local_coh ss h
   else n \in clients /\
        exists cs, client_local_coh cs h].

Definition soup_coh : Pred soup :=
  [Pred s |
    valid s /\
    forall m ms, find m s = Some ms -> active ms -> exists e, coh_msg ms e].

Lemma soup_coh_post_msg d m:
    soup_coh (dsoup d) -> (exists e, coh_msg m e) -> soup_coh (post_msg (dsoup d) m).1.
Proof.
move=>[H1 H2][y]Cm; split=>[|i ms/=]; first by rewrite valid_fresh.
rewrite findUnL; last by rewrite valid_fresh.
case: ifP=>E; first by move/H2.
by move/findPt_inv=>[Z G]; subst i m; exists y.
Qed.

Definition state_coh d :=
  forall n, n \in nodes -> local_coh n (getLocal n d).

Definition lock_coh d :=
  let: dl := dstate d in
  let: ds := dsoup d in
  [/\ soup_coh ds
   , dom dl =i nodes
   , valid dl
   & state_coh d].

Lemma l1 d: lock_coh d -> valid (dstate d).
Proof. by case. Qed.

Lemma l2 d: lock_coh d -> valid (dsoup d).
Proof. by case; case. Qed.

Lemma l3 d: lock_coh d -> dom (dstate d) =i nodes.
Proof. by case. Qed.

Definition LockCoh := CohPred (CohPredMixin l1 l2 l3).

Lemma consume_coh d m : LockCoh d -> soup_coh (consume_msg (dsoup d) m).
Proof.
move=>C; split=>[|m' msg]; first by apply: consume_valid; rewrite (cohVs C).
case X: (m == m');[move/eqP: X=><-{m'}|].
- case/(find_mark (cohVs C))=>tms[E]->{msg}.
  by case:(C); case=>_/(_ m tms E).
rewrite eq_sym in X.
rewrite (mark_other (cohVs C) X)=>E.
by case:(C); case=>_; move/(_ m' msg E).
Qed.

Lemma coh_dom_upd this d s :
  this \in nodes -> LockCoh d -> dom (upd this s (dstate d)) =i nodes.
Proof.
move=>D C z; rewrite -(cohDom C) domU inE/=.
by case: ifP=>///eqP->{z}; rewrite (cohDom C) D; apply: cohVl C.
Qed.

Definition server_send_step (ss : server_state) (to : nid) : server_state :=
  if to \in clients
  then if outstanding ss is _ :: out'
       then ServerState out' (S (current_epoch ss)) (Some to)
       else ss
  else ss.

Definition client_send_step (cs : client_state) : client_state :=
  NotHeld. (* ! *)

Definition server_recv_step (ss : server_state) (from : nid)
           (mtag : nat) (mbody : seq nat) : server_state :=
  if mtag == acquire_tag
  then
    ServerState (rcons (outstanding ss) from) (current_epoch ss) (current_holder ss)
  else (* mtag == release_tag *)
    ServerState (outstanding ss) (current_epoch ss) None.

Definition client_recv_step (cs : client_state) (from : nid)
           (mtag : nat) (mbody : seq nat) : client_state :=
  if mbody is [:: e]
  then Held e
  else NotHeld.

Section GetterLemmas.

Lemma getLocal_coh n d (C : LockCoh d):
  n \in nodes ->
  valid (getLocal n d) /\
  if n == server
  then exists (ss : server_state),
      getLocal n d = st :-> ss
  else (n \in clients) /\
       exists (cs : client_state),
           getLocal n d = st :-> cs.
Proof.
  by case: C=>_ _ _ /(_ n)G; rewrite /local_coh/=.
Qed.

Lemma getLocal_server_st_tp d (C : LockCoh d) s:
  find st (getLocal server d) = Some s ->
  dyn_tp s = server_state.
Proof.
have pf: server \in nodes by rewrite inE eqxx.
move: (getLocal_coh C pf); rewrite eqxx; move =>[V][s']Z; rewrite Z in V *.
rewrite findPt /=.
by case =><-.
Qed.

Lemma getLocal_client_st_tp n d (C : LockCoh d) (H : n \in clients) s:
  find st (getLocal n d) = Some s ->
  dyn_tp s = client_state.
Proof.
have pf: n \in nodes by rewrite inE/= orbC H.
move: (getLocal_coh C pf); rewrite H=>[[V]].
rewrite client_not_server//.
move=>[_][cs] L. rewrite L in V *.
rewrite findPt /=.
by case=> <-.
Qed.

Definition getSt_server d (C : LockCoh d) : server_state :=
  match find st (getLocal server d) as f return _ = f -> _ with
    Some v => fun epf => icast (sym_eq (getLocal_server_st_tp C epf)) (dyn_val v)
  | _ => fun epf => ServerState [::] 0 None
  end (erefl _).

Lemma getSt_server_K d (C : LockCoh d) m :
  getLocal server d = st :-> m -> getSt_server C = m.
Proof.
move=>E; rewrite /getSt_server/=.
have pf: server \in nodes by rewrite inE eqxx.
have V: valid (getLocal server d) by case: (getLocal_coh C pf).
move: (getLocal_server_st_tp C); rewrite !E=>/= H.
by apply: eqc.
Qed.

Program Definition getSt_client c d (C : LockCoh d) (pf : c \in nodes) : client_state.
case X: (c \in clients); last by exact: NotHeld.
exact: (match find st (getLocal c d) as f return _ = f -> _ with
    Some v => fun epf => icast (sym_eq (getLocal_client_st_tp C X epf)) (dyn_val v)
  | _ => fun epf => NotHeld
  end (erefl _)).
Defined.

Lemma getSt_client_K c d (C : LockCoh d) (pf : c \in nodes) m :
  c \in clients -> getLocal c d = st :-> m -> getSt_client C pf = m.
Proof.
move=>X E; rewrite /getSt_client/=.
have V: valid (getLocal c d) by case: (getLocal_coh C pf).
move: (getLocal_client_st_tp C); rewrite X !E=>/= H.
by apply: eqc.
Qed.

End GetterLemmas.

Section ServerGenericSendTransitions.

Definition HServ this to := (this == server /\ to \in clients).

Variable the_tag : nat.

Variable prec : server_state -> nid -> seq nid -> Prop.

Hypothesis prec_safe :
  forall this to s m,
    HServ this to ->
    prec s to m ->
    coh_msg (Msg (TMsg the_tag m) this to true) (current_epoch s).

Notation coh := LockCoh.

Definition server_send_safe (this n : nid)
           (d : dstatelet) (msg : seq nat) :=
  HServ this n /\
  exists (C : coh d), prec (getSt_server C) n msg.

Lemma server_send_safe_coh this to d m : server_send_safe this to d m -> coh d.
Proof. by case=>_[]. Qed.

Lemma server_send_this_in this to : HServ this to -> this \in nodes.
Proof. by case=>/eqP->; rewrite inE eqxx. Qed.

Lemma server_send_to_in this to : HServ this to -> to \in nodes.
Proof. by case=>_; rewrite /nodes inE/= orbC=>->. Qed.

Lemma server_send_safe_in this to d m : server_send_safe this to d m ->
                                  this \in nodes /\ to \in nodes.
Proof.
by case=>[]=>G _; move/server_send_to_in: (G)->; case: G=>/eqP-> _; rewrite inE eqxx.
Qed.

Definition server_step (this to : nid) (d : dstatelet)
           (msg : seq nat)
           (pf : server_send_safe this to d msg) :=
  let C := server_send_safe_coh pf in
  let s := getSt_server C in
  Some (st :-> server_send_step s to).

Lemma server_step_coh : s_step_coh_t coh the_tag server_step.
Proof.
move=>this to d msg pf h[]->{h}.
have C : (coh d) by case: pf=>?[].
have E: this = server by case: pf=>[][]/eqP.
split=>/=.
- apply: soup_coh_post_msg; first by case:(server_send_safe_coh pf).
  case: (pf)=>H[C']P/=.
  eexists.
  by apply: (prec_safe _ P).
- by apply: coh_dom_upd=>//; case: (server_send_safe_in pf).
- by rewrite validU; apply: cohVl C.
move=>n Ni. rewrite /local_coh/=.
rewrite /getLocal/=findU; case: ifP=>B; last by case: C=>_ _ _/(_ n Ni).
move/eqP: B=>Z; subst n this; rewrite eqxx (cohVl C)/=.
split.
by rewrite validPt.
by eexists.
Qed.

Lemma server_step_def this to d msg :
      server_send_safe this to d msg <->
      exists b pf, @server_step this to d msg pf = Some b.
Proof.
split=>[pf/=|]; last by case=>?[].
set b := let C := server_send_safe_coh pf in
         let s := getSt_server C in
         st :-> (server_send_step s to).
by exists b, pf.
Qed.

Definition server_send_trans :=
  SendTrans server_send_safe_coh server_send_safe_in server_step_def server_step_coh.

End ServerGenericSendTransitions.

Section ServerSendTransitions.

Definition server_send_grant_prec (ss : server_state) to m :=
  exists rest e,
    ss = ServerState (to :: rest) e None /\
    m = [:: e].

Program Definition server_send_grant_trans : send_trans LockCoh :=
  @server_send_trans grant_tag server_send_grant_prec _.
Next Obligation.
case: H=>/eqP->H; rewrite /coh_msg eqxx; split=>//=.
case: H0=>[rest] [e] []-> ->/=. by rewrite /msg_from_server /= eqxx.
Qed.

End ServerSendTransitions.

Section ServerGenericReceiveTransitions.

Notation coh := LockCoh.

Variable the_tag : nat.
Variable server_recv_wf : forall d, coh d -> nid -> nid -> TaggedMessage -> bool.

Definition rs_step : receive_step_t coh :=
  fun this (from : nid) (m : seq nat) d (pf : coh d) (pt : this \in nodes) =>
    if (this == server)
    then let s := getSt_server pf in
         st :-> server_recv_step s from the_tag m
    else getLocal this d.

Lemma rs_step_coh : r_step_coh_t server_recv_wf the_tag rs_step.
Proof.
move=>d from this m C pf tms D F Wf T/=.
rewrite /rs_step; case X: (this == server); last first.
- split=>/=; first by apply: consume_coh.
  + by apply: coh_dom_upd.
  + by rewrite validU; apply: cohVl C.
  by move=>n Ni/=; case: (C)=>_ _ _/(_ n Ni)=>L; rewrite -(getLocalU)// (cohVl C).
split=>/=; first by apply: consume_coh.
- by apply: coh_dom_upd.
- by rewrite validU; apply: cohVl C.
move=>n Ni/=; rewrite /local_coh/=.
rewrite /getLocal/=findU; case: ifP=>B/=; last by case: (C)=>_ _ _/(_ n Ni).
move/eqP: B X=>Z/eqP X; subst n this; rewrite eqxx (cohVl C)/=.
split; first by rewrite validPt.
by eexists.
Qed.

Definition rs_recv_trans := ReceiveTrans rs_step_coh.

End ServerGenericReceiveTransitions.

Section ServerReceiveTransitions.

Definition s_matches_tag (ss : server_state) from t :=
  (t == acquire_tag) ||
  ((t == release_tag) && (current_holder ss == Some from)).

Definition server_msg_wf d (C : LockCoh d) (this from : nid) :=
  [pred m : TaggedMessage | s_matches_tag (getSt_server C) from (tag m)].

Definition server_recv_acquire_trans := rs_recv_trans acquire_tag server_msg_wf.

Definition server_recv_release_trans := rs_recv_trans release_tag server_msg_wf.

End ServerReceiveTransitions.

Section ClientGenericSendTransitions.

Definition HClient this to := (this \in clients /\ to == server).

Variable the_tag : nat.

Variable prec : client_state -> nid -> seq nat -> Prop.

Hypothesis prec_safe :
  forall this to s m,
    HClient this to ->
    prec s to m ->
    msg_from_client (TMsg the_tag m).

Notation coh := LockCoh.

Lemma client_send_this_in this to : HClient this to -> this \in nodes.
Proof. case=>H _. by apply /client_nodes. Qed.

Definition client_send_safe (this n : nid)
           (d : dstatelet) (msg : seq nat) :=
  HClient this n /\
  exists (HC : HClient this n) (C : coh d), prec (getSt_client C (client_send_this_in HC)) n msg.

Lemma client_send_safe_coh this to d m : client_send_safe this to d m -> coh d.
Proof. by case => _[?][C]. Qed.

Lemma client_send_to_in this to : HClient this to -> to \in nodes.
Proof. by case=>_ /eqP->; rewrite /nodes inE/= eqxx. Qed.

Lemma client_send_safe_in this to d m : client_send_safe this to d m ->
                                  this \in nodes /\ to \in nodes.
Proof.
case=>_[HC][C]_.
split.
- exact: (client_send_this_in HC).
exact: (client_send_to_in HC).
Qed.

Definition client_step (this to : nid) (d : dstatelet)
           (msg : seq nat)
           (pf : client_send_safe this to d msg) :=
  let C := client_send_safe_coh pf in
  let s := getSt_client C (client_send_this_in (proj1 pf)) in
  Some (st :-> client_send_step s).

Lemma client_step_coh : s_step_coh_t coh the_tag client_step.
Proof.
move=>this to d msg pf h[]->{h}.
have C : (coh d) by exact: (client_send_safe_coh pf).
have E: this \in clients by case: pf=>_[][].
split=>/=.
- apply: soup_coh_post_msg; first by case:(client_send_safe_coh pf).
  case: (pf)=>_[H][C']P/=.
  exists 0.
  rewrite/coh_msg/= client_not_server// E.
  split; first by case: (H).
  by apply: (prec_safe H P).
- by apply: coh_dom_upd=>//; case: (client_send_safe_in pf).
- by rewrite validU; apply: cohVl C.
move=>n Ni. rewrite /local_coh/=.
rewrite /getLocal/=findU; case: ifP=>B; last by case: C=>_ _ _/(_ n Ni).
move/eqP: B=>Z; subst n.
rewrite client_not_server// (cohVl C)/=.
split.
- by rewrite validPt.
split=>//.
by eexists.
Qed.

Lemma client_step_def this to d msg :
      client_send_safe this to d msg <->
      exists b pf, @client_step this to d msg pf = Some b.
Proof.
split=>[pf/=|]; last by case=>?[].
set b := let C := client_send_safe_coh pf in
         let s := getSt_client C (client_send_this_in (proj1 pf)) in
         st :-> (client_send_step s).
by exists b, pf.
Qed.

Definition client_send_trans :=
  SendTrans client_send_safe_coh client_send_safe_in client_step_def client_step_coh.

End ClientGenericSendTransitions.

Section ClientSendTransitions.

Definition client_send_acquire_prec (cs : client_state) (to : nid) (m : seq nat) :=
  cs = NotHeld /\
  m = [::].

Program Definition client_send_acquire_trans : send_trans LockCoh :=
  @client_send_trans acquire_tag client_send_acquire_prec _.
Next Obligation.
apply/andP=>/=.
split=>//.
by case: H0=>_/eqP.
Qed.

Definition client_send_release_prec (cs : client_state) (to : nid) (m : seq nat) :=
  (exists e, cs = Held e) /\
  m = [::].

Program Definition client_send_release_trans : send_trans LockCoh :=
  @client_send_trans release_tag client_send_release_prec _.
Next Obligation.
apply/andP=>/=.
split=>//.
by case: H0=>_/eqP.
Qed.

End ClientSendTransitions.

Section ClientGenericReceiveTransitions.

Notation coh := LockCoh.

Variable the_tag : nat.
Variable client_recv_wf : forall d, coh d -> nid -> nid -> TaggedMessage -> bool.

Definition rc_step : receive_step_t coh :=
  fun this (from : nid) (m : seq nat) d (pf : coh d) (pt : this \in nodes) =>
    if (this \in clients)
    then let s := getSt_client pf pt in
         st :-> client_recv_step s from the_tag m
    else getLocal this d.

Lemma rc_step_coh : r_step_coh_t client_recv_wf the_tag rc_step.
Proof.
move=>d from this m C pf tms D F Wf T/=.
rewrite /rc_step; case X: (this \in clients); last first.
- split=>/=; first by apply: consume_coh.
  + by apply: coh_dom_upd.
  + by rewrite validU; apply: cohVl C.
  have Y: forall z : nat_eqType, z \in nodes -> local_coh z (getLocal z d)
      by case: (C).
  by move=>n Ni/=; move: (Y n Ni)=>L; rewrite -(getLocalU)// (cohVl C).
split=>/=; first by apply: consume_coh.
- by apply: coh_dom_upd.
- by rewrite validU; apply: cohVl C.
move=>n Ni/=; rewrite /local_coh/=.
rewrite /getLocal/=findU; case: ifP=>B/=; last by case: (C)=>_ _ _/(_ n Ni).
move/eqP: B X=>Z/eqP X/= ;rewrite !(cohVl C); subst n.
split; first done.
move/eqP: X => X.
rewrite client_not_server X//.
split=>//.
by eexists _.
Qed.

Definition rc_recv_trans := ReceiveTrans rc_step_coh.

End ClientGenericReceiveTransitions.

Section ClientReceiveTransitions.

Definition client_msg_wf d (_ : LockCoh d) (this from : nid) :=
  [pred m : TaggedMessage | true].

Definition client_receive_grant_trans := rc_recv_trans grant_tag client_msg_wf.

End ClientReceiveTransitions.

Section Protocol.

Variable l : Label.

(* All send-transitions *)
Definition lock_sends :=
  [::
     server_send_grant_trans;
     client_send_acquire_trans;
     client_send_release_trans
  ].

(* All receive-transitions *)
Definition lock_receives :=
  [::
     server_recv_acquire_trans;
     server_recv_release_trans;
     client_receive_grant_trans
  ].

Program Definition LockProtocol : protocol :=
  @Protocol _ l _ lock_sends lock_receives _ _.

End Protocol.
End LockProtocol.

Module Exports.
Section Exports.

Definition LockProtocol := LockProtocol.

End Exports.
End Exports.

End LockProtocol.

Export LockProtocol.Exports.