From iris.algebra Require Import agree gmap auth.
From iris.proofmode Require Import tactics.
From aneris.aneris_lang Require Import
     network tactics proofmode lifting lang.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.examples.ccddb.spec Require Import spec resources.

(* Resources and socket protocols for session guarantees *)

Section res.
  Context `{!DB_params, !DB_time, !DB_events}.

  Definition rep_id := nat.
  Definition seq_id := nat.

  Inductive log_req :=
  | LInit (db : rep_id)
  | LRead (db : rep_id) (k : Key) (s : lhst) (h : gmem)
  | LWrite (db : rep_id) (k : Key) (v : SerializableVal) (s : lhst) (h : gmem).

  Definition req_db (lrq : log_req) : rep_id :=
    match lrq with
    | LInit db => db
    | LRead db _ _ _ => db
    | LWrite db _ _ _ _ => db
    end.

  Definition req_map := gmapUR nat (agreeR (leibnizO log_req)).
  Context `{!inG Σ (authUR req_map)}.

  Definition is_req γ (n : seq_id) (rq : log_req) :=
    own γ (◯ {[ n := to_agree rq]}).

  Instance is_req_persistent γ n req : Persistent (is_req γ n req).
  Proof. apply _. Qed.

  Lemma is_req_agree γ n rq rq' :
    is_req γ n rq ⊢ is_req γ n rq' -∗ ⌜rq = rq'⌝.
  Proof.
    iIntros "H1 H2".
    rewrite /is_req.
    iDestruct (own_valid_2 with "H1 H2") as %Hvalid.
    iPureIntro.
    rewrite -auth_frag_op in Hvalid.
    revert Hvalid.
    rewrite auth_frag_valid.
    intros Hvalid.
    specialize (Hvalid n).
    rewrite lookup_op !lookup_singleton in Hvalid.
    rewrite -Some_op in Hvalid.
    revert Hvalid.
    rewrite Some_valid.
    intros Hvalid.
    apply @to_agree_op_inv in Hvalid.
    apply leibniz_equiv in Hvalid.
    simplify_eq.
    done.
  Qed.

  Lemma is_req_alloc γ (M : req_map) n rq :
    n ∉ dom M →
    own γ (● M) ⊢
    |==> own γ (● <[n := to_agree rq]> M) ∗ is_req γ n rq.
  Proof.
    iIntros (Hi) "HM".
    iMod (own_update _ _ (● <[n := to_agree rq]> M ⋅
                         ◯ {[n := to_agree rq]}) with "HM") as "[$ $]";
      last done.
    apply auth_update_alloc.
    apply @alloc_singleton_local_update; last done.
    apply (not_elem_of_dom (D := gset nat)); done.
  Qed.

  Lemma request_init : True ⊢ |==> ∃ γ, own γ (● ∅).
  Proof.
    iIntros "_".
    iApply own_alloc.
    apply auth_auth_valid; done.
  Qed.

  Lemma is_req_auth_disagree γ M (n : nat) rq :
    own γ (● M) ⊢ is_req γ n rq -∗ ⌜n ∈ dom M⌝.
  Proof.
    iIntros "Hown Hisreq".
    rewrite /is_req.
    iDestruct (own_valid_2 with "Hown Hisreq") as "Hown".
    iDestruct "Hown" as %[Hvalid _]%auth_both_valid_discrete.
    iPureIntro.
    apply dom_included in Hvalid.
    rewrite dom_singleton_L in Hvalid.
    set_solver.
  Qed.

End res.

Section serialization.
  Context `{!DB_params}.

  Definition seq_id_serialization := int_serialization.

  Definition req_init_serialization := string_serialization.

  Definition req_read_serialization := string_serialization.

  Definition req_write_serialization :=
    prod_serialization string_serialization DB_serialization.

  Definition req_serialization :=
    prod_serialization
      seq_id_serialization
      (sum_serialization
         req_init_serialization
         (sum_serialization
            req_read_serialization
            req_write_serialization)).

  Definition resp_init_serialization := string_serialization.

  Definition resp_read_serialization :=
    sum_serialization
      unit_serialization
      DB_serialization.

  Definition resp_write_serialization := string_serialization.

  Definition resp_serialization :=
    prod_serialization
      seq_id_serialization
      (sum_serialization
         resp_init_serialization
         (sum_serialization
            resp_read_serialization
            resp_write_serialization)).

  Global Instance: ∀ sid : Z, Serializable req_serialization (#sid, InjLV #"I").
  Proof. apply _. Qed.

  Global Instance:
    ∀ (sid : Z) (k : Key),
      Serializable req_serialization (#sid, InjRV (InjLV #k)).
  Proof. apply _. Qed.

  Global Instance:
    ∀ (sid : Z) (k : Key) (v : val),
      DB_Serializable v →
      Serializable req_serialization (#sid, InjRV (InjRV (#k, v))).
  Proof. apply _. Qed.

  Global Instance:
    ∀ sid : Z, Serializable resp_serialization (#sid, InjLV #"Ok").
  Proof. apply _. Qed.

  Global Instance:
    ∀ sid : Z, Serializable resp_serialization (#sid, InjRV (InjLV (InjLV #()))).
  Proof. apply _. Qed.

  Global Instance:
    ∀ (sid : Z) (v : val),
      DB_Serializable v →
      Serializable resp_serialization (#sid, InjRV (InjLV (InjRV v))).
  Proof. apply _. Qed.

  Global Instance:
    ∀ sid : Z, Serializable resp_serialization (#sid, InjRV (InjRV #"Ok")).
  Proof. apply _. Qed.

  Typeclasses Opaque req_serialization resp_serialization.
  Global Opaque req_serialization resp_serialization.

End serialization.

Section protocols.

  Definition SM_N : namespace := nroot.@"SM".

  Context `{!anerisG Mdl Σ, !lockG Σ}.
  Context `{!DB_params}.
  Context `{!DB_time, !DB_events}.
  Context `{!DB_resources Mdl Σ}.
  Context `{!Maximals_Computing}.
  Context `{!inG Σ (authUR req_map)}.

  (* Deserialized request *)
  Inductive des_req :=
  | DInit
  | DRead (k : Key)
  | DWrite (k : Key) (v : val).

  Definition des_req_to_val (r : des_req) : val :=
    match r with
    | DInit => (InjLV #"I")
    | DRead k => (InjRV (InjLV #k))
    | DWrite k v => (InjRV (InjRV (#k, v)))
    end.

  (* Deserialized response *)
  Inductive des_resp :=
  | RInit
  | RRead (v : val)
  | RWrite.

  Definition des_resp_to_val (r : des_resp) : val :=
    match r with
    | RInit => (InjLV #"Ok")
    | RRead v => (InjRV (InjLV v))
    | RWrite => (InjRV (InjRV #"Ok"))
    end.

  (* Variable msg_to_resp : message_body -> option (seq_id * des_resp). *)

  (* Consistency between physical and logical requests *)
  Inductive cons_req : des_req -> log_req -> Prop :=
  | ConsReqInit db : cons_req DInit (LInit db)
  | ConsReqRead db k s h : cons_req (DRead k) (LRead db k s h)
  | ConsReqWrite db k (v : SerializableVal) s h :
      cons_req (DWrite k v) (LWrite db k v s h).

  (* Consistency between a physical response and its logical request *)
  Inductive cons_res : des_resp -> log_req -> Prop :=
  | ConsResInit db : cons_res RInit (LInit db)
  | ConsResRead db k s h v : cons_res (RRead v) (LRead db k s h)
  | ConsResWrite db k v s h : cons_res (RWrite) (LWrite db k v s h).

  (* Socket protocols *)
  Definition init_post (db : rep_id) : iProp Σ :=
    ∃ s,
     Seen db s
     ∗ ([∗ set] k ∈ DB_keys, ∃ h, OwnMemSnapshot k h)
     ∗ GlobalInv.

  Definition read_post (db : rep_id) (k : Key) (s : lhst) (h : gmem)
             (vo : val) : iProp Σ :=
    ∃ s' h',
      ⌜s ⊆ s'⌝
      ∗ ⌜h ⊆ h'⌝
      ∗ Seen db s'
      ∗ OwnMemSnapshot k h'
      ∗ ((⌜vo = NONEV⌝ ∗ ⌜restrict_key k s' = ∅⌝)
         ∨
         (∃ e v, ⌜vo = SOMEV v⌝
                ∗ ⌜AE_val e = v⌝
                ∗ ⌜AE_key e = k⌝
                ∗ ⌜e ∈ Maximals (restrict_key k s')⌝
                ∗ ⌜(erasure e) ∈ h'⌝)).

  Definition write_post (db : rep_id) (k : Key) (v : val) (s : lhst)
             (h : gmem) : iProp Σ :=
    ∃ e s' h',
      ⌜AE_key e = k⌝
      ∗ ⌜AE_val e = v⌝
      ∗ ⌜s ⊆ s'⌝
      ∗ ⌜h ⊆ h'⌝
      ∗ Seen db s'
      ∗ OwnMemSnapshot k h'
      ∗ ⌜e ∉ s⌝
      ∗ ⌜e ∈ s'⌝
      ∗ ⌜(erasure e) ∉ h⌝
      ∗ ⌜(erasure e) ∈ h' ⌝
      ∗ ⌜(erasure e) ∈ Maximals h'⌝
      ∗ ⌜Maximum s' = Some e⌝.

  Definition db_si (db : rep_id) : socket_interp Σ :=
    (λ msg, ∃ ϕ (sid : nat) drq γ lrq,
        (m_sender msg) ⤇ ϕ ∗
        ⌜s_is_ser req_serialization
          (#sid, des_req_to_val drq)%V (m_body msg)⌝ ∗
        is_req γ sid lrq ∗
        ⌜req_db lrq = db⌝ ∗
        ⌜cons_req drq lrq⌝ ∗
        let (pre, post) :=
          match lrq with
          | LInit db => (True, fun _ => init_post db)
          | LRead db k s h =>
            (⌜k ∈ DB_keys⌝ ∗ Seen db s ∗ OwnMemSnapshot k h,
             fun res => ∃ vo, ⌜res = RRead vo⌝ ∗
                           read_post db k s h vo)
          | LWrite db k v s h =>
            (⌜k ∈ DB_keys⌝ ∗ Seen db s ∗ OwnMemSnapshot k h,
             fun _ => write_post db k v s h)
          end
        in
        pre ∗ □ (∀ res, (∃ dres, ⌜s_is_ser resp_serialization
                                (#sid, des_resp_to_val dres) (m_body res)⌝ ∗
                               is_req γ sid lrq
                               ∗ ⌜cons_res dres lrq⌝
                               ∗ post dres)
                        -∗ ϕ res))%I.

  Global Instance db_si_persistent db m : Persistent (db_si db m).
  Proof.
    rewrite /Persistent.
    iDestruct 1 as (Φ i drq γ lrq) "(#?&#?&#?&#?&#?&Hm)".
    destruct lrq eqn:Heq.
    - iDestruct "Hm" as "[_ #?]".
      iModIntro.
      iExists _, _, _, _, lrq; rewrite Heq.
      iFrame "#".
    - iDestruct "Hm" as "[#? #?]".
      iModIntro.
      iExists _, _, _, _, lrq; rewrite Heq.
      iFrame "#".
    - iDestruct "Hm" as "[#? #?]".
      iModIntro.
      iExists _, _, _, _, lrq; rewrite Heq.
      iFrame "#".
  Qed.

  Definition resp_body_post dres lrq vo : iProp Σ :=
    ⌜cons_res dres lrq⌝
    ∗ match lrq with
      | LInit db => init_post db
      | LRead db k s h => ⌜dres = RRead vo⌝ ∗
        read_post db k s h vo
      | LWrite db k v s h => write_post db k v s h
      end.

  Definition client_si (γ : gname) : socket_interp Σ :=
    (λ msg, ∃ (sid : nat) dres lrq vo,
        ⌜s_is_ser resp_serialization
         (#sid, des_resp_to_val dres) (m_body msg)⌝
         ∗ is_req γ sid lrq
         ∗  resp_body_post dres lrq vo)%I.
End protocols.

Global Hint Constructors cons_req : core.
Global Hint Constructors cons_res : core.


Require Import FP.Data.Error.
Require Import FP.Classes.
Require Import FP.CoreData.
Require Import FP.CoreClasses.
Require Import FP.DerivingEverything.
Require Import FP.Data.Identity.

Import CoreDataNotation.
Import CoreClassesNotation.
Import ClassesNotation.

Inductive error_t E m A := ErrorT { run_error_t : m (error E A) }.
Arguments ErrorT {E m A} _.
Arguments run_error_t {E m A} _.

Definition error_b E := error_t E identity.

Section error_t_Bijection.
  Context {E:Type} {m:Type -> Type} {A:Type}.

  Global Instance IR_run_error_t_eq
    : InjectionRespect (error_t E m A) (m (error E A)) run_error_t eq eq.
  Proof.
    constructor ; [congruence|].
    unfold Proper,"<==" ; intros ; destruct x,y ; simpl in * ; congruence.
  Qed.

  Global Instance II_ErrorT_eq
    : InjectionInverse (m (error E A)) (error_t E m A) ErrorT run_error_t eq.
  Proof.
    constructor ; auto.
  Qed.
End error_t_Bijection.

Module error_t_DE_Arg <: DE_IdxTransformer_Arg.
  Definition T := error_t.
  Definition U E m A := m (error E A):Type.
  Definition to : forall {E m A}, T E m A -> U E m A := @run_error_t.
  Definition from : forall {E m A}, U E m A -> T E m A := @ErrorT.
  Definition IR_to {E m A} : InjectionRespect (T E m A) (U E m A) to eq eq := _.
  Definition II_from {E m A} : InjectionInverse (U E m A) (T E m A) from to eq := _.
  Definition _DE_IdxTransformerI : DE_IdxTransformerI' U.
  Proof. unfold U ; econstructor ; econstructor ; eauto with typeclass_instances. Defined.
End error_t_DE_Arg.
Module error_t_DE := DE_IdxTransformer error_t_DE_Arg.
Import error_t_DE.

Section Proper.
  Context {E m A} `{! Eqv  E ,! F_Eqv m ,! Eqv A }.
  Global Instance ErrorT_Proper : Proper eqv (@ErrorT E m A).
  Proof.
    unfold Proper.
    logical_eqv_intro.
    unfold eqv ; simpl ; auto.
  Qed.
  Global Instance run_error_t_Proper : Proper eqv (@run_error_t E m A).
  Proof.
    unfold Proper.
    logical_eqv_intro.
    destruct x,y ; simpl.
    apply InjectionRespect_beta ; auto.
  Qed.
End Proper.
Hint Extern 9 (Proper eqv (ErrorT (E:=?E) (m:=?m) (A:=?A))) =>
  let H := fresh "H" in
  pose (H:=(ErrorT_Proper (E:=E) (m:=m) (A:=A))) ; apply H
  : typeclass_instances.
Hint Extern 9 (Proper eqv (run_error_t (E:=?E) (m:=?m) (A:=?A))) =>
  let H := fresh "H" in
  pose (H:=(run_error_t_Proper (E:=E) (m:=m) (A:=A))) ; apply H
  : typeclass_instances.

Section Monad.
  Context {E:Type} {m} `{! Monad m }.

  Definition error_t_mret {A} (a:A) : error_t E m A := ErrorT $ mret $ Success a.
  Arguments error_t_mret {A} a /.

  Definition error_t_mbind {A B} (aMM:error_t E m A) (k:A -> error_t E m B) : error_t E m B :=
    ErrorT begin
      aM <- run_error_t aMM ;;
      match aM with
      | Failure e => mret $ Failure e
      | Success a => run_error_t $ k a
      end
    end.
  Arguments error_t_mbind {A B} aMM k /.
  Global Instance error_t_Monad : Monad (error_t E m) :=
    { mret := @error_t_mret
    ; mbind := @error_t_mbind
    }.

  Section error_t_MonadWF.
    Context `{! Eqv E ,! PER_WF E ,! F_Eqv m ,! F_PER_WF m ,! MonadWF m }.

    Global Instance error_t_MonadWF : MonadWF (error_t E m).
    Proof.
      constructor ; intros.
      - apply InjectionRespect_beta ; simpl.
        rewrite Monad_left_unit ; repeat (logical_eqv ; repeat fold_error).
      - apply InjectionRespect_beta ; simpl.
        transitivity (run_error_t aM >>= mret).
        + logical_eqv.
          destruct x,y ; inversion H ; subst ; clear H ; logical_eqv.
        + rewrite Monad_right_unit ; logical_eqv.
      - apply InjectionRespect_beta ; simpl.
        rewrite Monad_associativity ; repeat (logical_eqv ; repeat fold_error).
        destruct x,y ; inversion H ; subst ; clear H ; repeat (logical_eqv ; repeat fold_error) ; simpl.
        rewrite Monad_left_unit ; repeat (logical_eqv ; repeat fold_error) ; simpl.
        repeat (logical_eqv ; repeat fold_error).
      - unfold Proper ; logical_eqv_intro.
        apply InjectionRespect_beta ; simpl.
        repeat (logical_eqv ; repeat fold_error).
      - unfold Proper ; logical_eqv_intro.
        apply InjectionRespect_beta ; simpl.
        repeat (logical_eqv ; repeat fold_error).
    Qed.
  End error_t_MonadWF.
End Monad.

Section MonadCatch.
  Context {E:Type} {m} `{! Monad m }.
  Definition error_t_mthrow {A} (e:E) : error_t E m A := ErrorT $ mret $ Failure e.
  Arguments error_t_mthrow {A} e /.
  Definition error_t_mcatch {A} (aM:error_t E m A) (k:E -> error_t E m A) : error_t E m A :=
    ErrorT begin
      am <- run_error_t aM ;;
      match am with
      | Success a => mret $ Success a
      | Failure e => run_error_t $ k e
      end
    end.
  Arguments error_t_mcatch {A} aM k /.
  Global Instance error_t_MonadCatch : MonadCatch E (error_t E m) :=
    { mthrow := @error_t_mthrow
    ; mcatch := @error_t_mcatch
    }.

  Section error_t_MonadCatchWF.
    Context `{! Eqv E ,! PER_WF E ,! F_Eqv m ,! F_PER_WF m ,! MonadWF m }.

    Global Instance error_t_MonadCatchWF : MonadCatchWF E (error_t E m).
    Proof.
      constructor ; intros ; unfold mcatch,mthrow ; simpl.
      - apply InjectionRespect_beta ; simpl.
        rewrite Monad_left_unit ; repeat (logical_eqv ; repeat fold_error).
      - apply InjectionRespect_beta ; simpl.
        rewrite Monad_left_unit ; repeat (logical_eqv ; repeat fold_error).
      - apply InjectionRespect_beta ; simpl.
        rewrite Monad_left_unit ; repeat (logical_eqv ; repeat fold_error).
      - unfold Proper ; logical_eqv_intro ; simpl ; logical_eqv.
      - unfold Proper ; logical_eqv_intro ; simpl ; repeat (logical_eqv ; repeat fold_error).
    Qed.
  End error_t_MonadCatchWF.
End MonadCatch.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Export syntax_ott.
Require Import
        rules_inf
        Infrastructure
        KeyProperties
        SubtypingInversion
        Disjointness
        Deterministic
        Progress
        Consistency.

Require Import List. Import ListNotations.
Require Import Arith Lia.

(* requires algo_sub Top A -> toplike A *)
Lemma TypedReduce_trans : forall v v1 v2 A B,
    value v -> TypedReduce v A v1 -> TypedReduce v1 B v2 -> TypedReduce v B v2.
Proof with eauto.
  introv Val Red1 Red2. gen B v2.
  induction* Red1; introv Red2; inductions Red2...
  inverts* Val.
Qed.

Lemma consistent_afterTR : forall v A B C v1 v2,
    value v -> Typing nil v Inf C -> TypedReduce v A v1 -> TypedReduce v B v2 -> consistencySpec v1 v2.
Proof.
  unfold consistencySpec. introv Val Typ Red1 Red2 Ord Red1' Red2'.
  forwards* r1: TypedReduce_trans Red1 Red1'. forwards* r2: TypedReduce_trans Red2 Red2'.
  forwards*: TypedReduce_unique r1 r2.
Qed.

Lemma TypedReduce_preservation: forall v v' A B,
    value v -> TypedReduce v A v'-> Typing nil v Inf B -> exists C, pType v' C /\ Typing nil v' Inf C /\ subsub C A.
Proof with eauto.
  introv Val Red Typ. (* '. forwards* (B&Typ&Sub): Typing_chk2inf Typ'. *)
  gen B. lets Red': Red.
  induction Red; intros; try solve [jauto].
  - (* absv *)
    simpl. exists. splits*.
    inverts Typ. applys Typ_abs. intros. apply~ Typing_chk_sub.
  - (* rcd *)
    inverts Val. inverts Typ; forwards* (?&?&?&?): IHRed.
  - (* mergel *)
    inverts Val. inverts Typ; forwards*: IHRed.
  - (* merger *)
    inverts Val. inverts Typ; forwards*: IHRed.
  - (* merge_and *)
    forwards (?&?&?&?): IHRed1 Val Red1 Typ.
    forwards (?&?&?&?): IHRed2 Val Red2 Typ.
    lets Con: consistent_afterTR Val Typ Red1 Red2.
    eapply consistent_complete in Con...
    exists. splits*.
Qed.

Lemma TypedReduce_consistent : forall v A B C v1 v2,
    value v -> Typing nil v Inf C -> TypedReduce v A v1 -> TypedReduce v B v2 -> consistent v1 v2.
Proof with eauto.
  intros v A B C v1 v2 Val Typ Red1 Red2.
  forwards* (?&?&?&?): TypedReduce_preservation Red1.
  forwards* (?&?&?&?): TypedReduce_preservation Red2.
  forwards*: TypedReduce_prv_value Red1.
  forwards*: TypedReduce_prv_value Red2.
  apply~ consistent_complete...
  forwards*: consistent_afterTR Red1 Red2.
Qed.

Lemma papp_consistent : forall v1 v2 v e1 e2 A B C,
    value v1 -> value v2 -> value v ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B -> Typing nil v Inf C ->
    papp v1 (vl_exp v) e1 -> papp v2 (vl_exp v) e2 -> consistent v1 v2 -> consistent e1 e2.
Proof with (solve_false; eauto).
  introv Val1 Val2 Val3 Typ1 Typ2 Typ3 P1 P2 Cons.
  gen A B C. lets P1': P1. lets P2': P2.
  inductions P1; inductions P2; intros; try solve [applys* C_disjoint].
  - forwards* [?|(?&?)]: consistent_lams_inv Cons.
    + applys* C_disjoint.
    + subst. forwards*: TypedReduce_unique H0 H2.
      subst*.
  - lets* (?&?): consistent_merger Cons. inverts* Typ2.
  - lets* (?&?): consistent_merger Cons. inverts* Typ2.
  - lets* (?&?): consistent_mergel Cons. inverts* Typ1.
  - lets* (?&?): consistent_mergel Cons. inverts* Typ1.
  - (* merge ~ merge *)
    inverts Val1. lets~ (?&?): consistent_mergel Cons.
    inverts* Typ1.
Qed.

Lemma papp_consistent2 : forall v1 v2 l e1 e2 A B,
    value v1 -> value v2 ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B ->
    papp v1 (vl_la l) e1 -> papp v2 (vl_la l) e2 -> consistent v1 v2 -> consistent e1 e2.
Proof with (solve_false; eauto).
  introv Val1 Val2 Typ1 Typ2 P1 P2 Cons.
  gen A B. lets P1': P1. lets P2': P2.
  inductions P1; inductions P2; intros;
    try solve [applys* C_disjoint];
    try solve [inverts Val1; inverts Typ1; applys* C_disjoint];
    try solve [inverts Val2; inverts Typ2; applys* C_disjoint];
    try solve [lets* (?&?): consistent_mergel Cons; inverts* Typ1];
    try solve [lets* (?&?): consistent_merger Cons; inverts* Typ2].
  - inverts Cons.
    + inverts P1'. inverts P2'. subst*.
    + enough (consistent (e_rcd l v) (e_rcd l v0)). eauto.
      applys* C_disjoint H3.
Qed.

Lemma papp_preservation : forall v1 v2 e A,
    value v1 -> value v2 ->
    Typing nil (e_app v1 v2) Inf A ->
    papp v1 (vl_exp v2) e ->
    Typing nil e Inf A.
Proof with eauto.
  intros v1 v2 e A Val1 Val2 Typ P. gen A.
  inductions P; intros; inverts Typ as Typ1 Typ2 Typ3.
  - (* abs *)
    forwards* (T & Htyp & Hsub): Typing_chk2inf Typ3.
    forwards (? & p1 & p2 & p3): TypedReduce_preservation Htyp...
    inverts Typ1 as t1. inverts Typ2.
    eapply Typ_anno. pick fresh y. rewrite (@subst_exp_intro y)...
    forwards~ t1': (t1 y). rewrite_env([]++[(y,B0)]++ []) in t1'.
    lets~ (?&s1&s2): Typing_subst_2 t1' p2 p3.
    apply subsub2sub in s2. forwards*: Typing_chk_sub s2.
  - (* top *)
    inverts Typ1. inverts* Typ2.
  - (* merge *)
    forwards* (T & Htyp & Hsub): Typing_chk2inf Typ3.
    inverts Val1.
    inverts Typ1; inverts Typ2;
      assert (algo_sub (t_and A2 B2) A2) by auto_sub;
      assert (algo_sub (t_and A2 B2) B2) by auto_sub;
      forwards~: IHP1 v2; [ applys* Typ_app H7 | auto | applys* Typ_app H8 | auto ];
      forwards~: IHP2 v2; [ applys* Typ_app H9 | auto | applys* Typ_app H10 | auto ].
    + apply~ Typ_merge. applys* arrTyp_arr_disjoint H6.
    + apply~ Typ_mergev. applys* papp_consistent P1 P2.
Qed.

Lemma papp_preservation2 : forall v1 l e A,
    value v1 ->
    Typing nil (e_proj v1 l) Inf A ->
    papp v1 (vl_la l) e ->
    Typing nil e Inf A.
Proof with eauto.
  intros v1 l e A Val1 Typ P. gen A.
  inductions P; intros; inverts Typ as Typ1 Typ2 Typ3.
  - (* rcd *)
    inverts Typ1. inverts* Typ2.
  - (* top *)
    inverts Typ1. inverts* Typ2.
  - (* merge *)
    inverts Val1.
    inverts Typ1; inverts Typ2;
      forwards~: IHP1 l; [ applys* Typ_proj H7 | auto | applys* Typ_proj H8 | auto ];
      forwards~: IHP2 l; [ applys* Typ_proj H9 | auto | applys* Typ_proj H10 | auto ].
    + apply~ Typ_merge. applys* arrTyp_rcd_disjoint H6.
    + apply~ Typ_mergev. applys* papp_consistent2 P1 P2.
Qed.

Inductive step_or_v : exp -> exp -> Prop :=
| ST_v : forall v, value v -> step_or_v v v
| ST_s : forall e1 e2, step e1 e2 -> step_or_v e1 e2.

#[export]
Hint Constructors step_or_v : core.

(* to prove the consistent merge case in preservation_subsub *)
Lemma consistent_steps: forall e1 e2 e1' e2' A B,
    Typing [] e1 Inf A -> Typing [] e2 Inf B ->
    step_or_v e1 e1' -> step_or_v e2 e2' -> consistent e1 e2 ->
    (forall (e e' : exp) (A : typ),
         size_exp e < (size_exp e1 + size_exp e2) -> Typing [] e Inf A -> step e e' -> exists C, [] ⊢ e' ⇒ C /\ subsub C A) ->
    consistent e1' e2'.
Proof with (simpl; elia).
  introv Typ1 Typ2 ST1 ST2 Cons IH. gen e1' e2' A B.
  induction Cons; intros; try solve [inverts ST1; inverts ST2; solve_false; eauto].
    + (* e:A ~ e:B *)
      inverts ST1 as ST1'; inverts ST2 as ST2'; solve_false; eauto.
      inverts Typ1 as H_check_e. inverts H_check_e as H_inf_e.
      inverts ST1' as Hv1 Hs1; inverts ST2' as Hv2 Hs2; solve_false.
      * forwards*: TypedReduce_consistent Hs1 Hs2.
      * forwards*: step_unique Hv1 Hv2. subst*.
    + (* rcd *)
      inverts keep Typ1. inverts keep Typ2.
      inverts ST1 as ST1'; inverts ST2 as ST2'; solve_false; eauto;
        inverts ST1' as Hv1 Hs1; inverts ST2' as Hv2 Hs2; solve_false.
      * (* value VS step *)
        applys C_rcd. applys* IHCons. intros.
        forwards* (?&?&?): IH H3...
      * (* step VS value *)
        applys C_rcd. applys* IHCons. intros.
        forwards* (?&?&?): IH H3...
      * (* step VS step *)
        applys C_rcd. applys* IHCons. intros.
        forwards* (?&?&?): IH H3...
    + (* disjoint *)
      inverts ST1 as ST1'; [unify_pType e1' | unify_pType u1];
        inverts ST2 as ST2'; try unify_pType e2'; try unify_pType u2.
      * (* value VS value *)
        applys* C_disjoint.
      * (* value VS step *)
        forwards* (?&?&?): IH u2... assert (0 < size_exp e1') by eauto using size_exp_min.
        elia.
        forwards~: step_prv_prevalue ST2'. unify_pType e2'.
        applys* C_disjoint.
      * (* step VS value *)
        forwards* (?&?&?): IH u1... assert (size_exp e2' >0) by eauto using size_exp_min. lia.
        forwards~: step_prv_prevalue ST1'. unify_pType e1'.
        applys* C_disjoint.
      * (* step VS step *)
        forwards* (?&?&?): IH u1. assert (size_exp u2 >0) by eauto using size_exp_min. lia.
        forwards* (?&?&?): IH u2. assert (size_exp u1 >0) by eauto using size_exp_min. lia.
        forwards~: step_prv_prevalue ST1'. unify_pType e1'.
        forwards~: step_prv_prevalue ST2'. unify_pType e2'.
        applys* C_disjoint.
    + (* merge on left *)
      inverts ST1 as ST1'; [ | inverts ST1' as ST1_1 ST1_2 ]; inverts Typ1;
        try solve [
              forwards*: IHCons1; try introv p1 p2 p3; try applys~ IH p2 p3; try (simpl; lia);
              forwards*: IHCons2; try introv p1 p2 p3; try applys~ IH p2 p3; try (simpl; lia)].
    + (* merge on right *)
      inverts ST2 as ST2'; [ | inverts ST2' as ST2_1 ST2_2 ]; inverts Typ2;
        try solve [
              forwards*: IHCons1; try introv p1 p2 p3; try applys~ IH p2 p3; try (simpl; lia);
              forwards*: IHCons2; try introv p1 p2 p3; try applys~ IH p2 p3; try (simpl; lia)].
Qed.

Ltac indExpDirSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : dirflag |- _ ] => (gen h) end;
  repeat match goal with | [ h : exp |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
    | intros ].

Definition size_dir dir :=
  match dir with
  | Inf => 0
  | Chk => 1
  end.

Theorem preservation_subsub : forall e e' dir A,
    Typing nil e dir A ->
    step e e' ->
    exists C, Typing nil e' dir C /\ subsub C A.
Proof with (simpl; try lia; auto; try eassumption; auto).
  introv Typ J. gen A e'.
  indExpDirSize ((size_exp e) + (size_dir dir)).
  inverts keep Typ as Ht1 Ht2 Ht3 Ht4;
    try solve [inverts J]; repeat simpl in SizeInd.
  - (* typing_app *)
    inverts J as J1 J2 J3; try forwards* (?&?&S2): IH J2; assert (size_exp e1 >0) by eauto using size_exp_min; elia.
     + forwards*: papp_preservation J3.
    + lets* ( ?&? & Harr & Hsub ): arrTyp_arr_subsub Ht2 S2.
    forwards* (?&?): subsub_arr_inv Hsub.
    + exists. split*. applys* Typ_app Ht2. applys* Typing_chk_sub.
  - (* typing_proj *)
    inverts J as J1 J2 J3; try forwards* (?&?&S2): IH J1; elia.
    + forwards*: papp_preservation2 J2.
    + lets* ( ? & Harr & Hsub ): arrTyp_rcd_subsub Ht2 S2.
      forwards* (?&?): subsub_rcd_inv Hsub.
  - (* typing_rcd *)
    (* disjoint *)
    inverts J as J1 J2 J3;
    try forwards* (?&?&?): IH J1; elia;
    try forwards* (?&?&?): IH J2; elia.
  - (* typing_merge *)
    (* disjoint *)
    inverts J as J1 J2 J3;
    try forwards* (?&?&?): IH J1; elia;
    try forwards* (?&?&?): IH J2; elia.
  - (* typing_anno *)
    inverts Ht1. inverts J as J1 J2 J3.
    + lets* (?&?): TypedReduce_preservation J2.
    + forwards* (?&?&?): IH J1...
      exists A. split*. apply subsub2sub in H2.
      assert (algo_sub x A) by auto_sub. lets*: Typ_sub.
  - (* typing_fix *)
    inverts J as Lc. pick_fresh x.
    rewrite* (@subst_exp_intro x).
    forwards~ Typ_chk: Ht1.
    rewrite_env(nil++[(x,A)]++nil) in Typ_chk.
    lets~ (?&?&?): Typing_subst_2 Typ_chk Typ.
    apply subsub2sub in H0. forwards*: Typing_chk_sub H H0.
  - (* typing_mergev *) (* consistent merge *)
    inverts J as J1 J2 J3; forwards*: consistent_steps Ht4;
      (* consistent e1' e2' *)
      try introv p1 p2 p3; try forwards* (?&?&?): IH p2 p3; elia;
        (* typing for the two terms *)
        try forwards* (?&?&?): IH J1; elia; try forwards* (?&?&?): IH J2; elia.
  - (* subsumption *)
    forwards* (?&?&?): IH J...
    apply subsub2sub in H0.
    assert (algo_sub x A) by auto_sub.
    exists* A.
Qed.

Theorem preservation : forall e e' dir A,
    Typing nil e dir A ->
    step e e' ->
    Typing nil e' Chk A.
Proof.
  intros e e' dir A H H0.
  lets* (?&?&?): preservation_subsub H H0.
  apply subsub2sub in H2.
  destruct dir.
  - sapply* Typ_sub.
  - sapply* Typing_chk_sub.
Qed.

(* Type Safety *)
Theorem preservation_multi_step : forall e e' dir A,
    Typing nil e dir A ->
    e ->* e' ->
    exists C, Typing nil e' dir C /\ subsub C A.
Proof.
  introv Typ Red.
  gen A. induction* Red.
  intros.
  lets* (?&?&?): preservation_subsub Typ H.
  forwards* (?&?&?): IHRed H0.
  exists x0. split*.
  forwards*: subsub_trans H3 H1.
Qed.

Theorem type_safety : forall e e' dir A,
    Typing nil e dir A ->
    e ->* e' ->
    value e' \/ exists e'', step e' e''.
Proof.
  introv Typ Red. gen A.
  induction Red; intros.
  lets*: progress Typ.
  lets* (?&?&?): preservation_subsub Typ H.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RmiOps.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition smc_realm_destroy_spec (rd_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match rd_addr with
    | VZ64 addr =>
      rely is_int64 addr;
      rely prop_dec (cur_rec (priv adt) = None);
      let gidx := __addr_to_gidx addr in
      if (GRANULE_ALIGNED addr) && (is_gidx gidx) then
        when adt == query_oracle adt;
        let gn := (gs (share adt)) @ gidx in
        rely prop_dec (glock gn = None);
        let e0 := EVT CPU_ID (ACQ gidx) in
        if (g_tag (ginfo gn) =? GRANULE_STATE_RD) && (gcnt gn =? 0) then
          rely prop_dec (gtype gn = GRANULE_STATE_RD);
          rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
          rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
          rely prop_dec ((buffer (priv adt)) @ SLOT_REC_LIST = None);
          let rtt_gidx := g_rtt (gnorm gn) in
          let recl_gidx := g_rec_list (gnorm gn) in
          rely is_gidx rtt_gidx; rely is_gidx recl_gidx;
          let gn := (gs (share adt)) @ gidx in
          let gn_rtt := (gs (share adt)) @ rtt_gidx in
          let gn_recl := (gs (share adt)) @ recl_gidx in
          rely prop_dec (glock gn_rtt = None);
          rely prop_dec (glock gn_recl = None);
          rely (g_tag (ginfo gn) =? GRANULE_STATE_RD);
          rely (g_tag (ginfo gn_rtt) =? GRANULE_STATE_TABLE);
          rely (g_tag (ginfo gn_recl) =? GRANULE_STATE_REC_LIST);
          rely (gtype gn =? GRANULE_STATE_RD);
          rely (gtype gn_rtt =? GRANULE_STATE_TABLE);
          rely (gtype gn_recl =? GRANULE_STATE_REC_LIST);
          rely is_int64 (g_refcount (ginfo gn_rtt));
          let e := EVT CPU_ID (ACQ rtt_gidx) in
          if g_refcount (ginfo gn_rtt) =? 0 then
            let grd' := gn {gnorm: zero_granule_data_normal} {grec: zero_granule_data_rec}
                          {ginfo: (ginfo gn) {g_tag: GRANULE_STATE_DELEGATED}} in
            let grecl' := gn_recl {ginfo: (ginfo gn_recl) {g_tag: GRANULE_STATE_DELEGATED}}
                                  {gnorm: zero_granule_data_normal} {grec: zero_granule_data_rec} in
            let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_rd: 0} {g_tag: GRANULE_STATE_DELEGATED}}
                                {gnorm: zero_granule_data_normal} {grec: zero_granule_data_rec} in
            let e1 := EVT CPU_ID (ACQ recl_gidx) in
            let e' := EVT CPU_ID (REL rtt_gidx (grtt' {glock: Some CPU_ID})) in
            let e'' := EVT CPU_ID (REL recl_gidx (grecl' {glock: Some CPU_ID})) in
            let e''' := EVT CPU_ID (REL gidx (grd' {glock: Some CPU_ID})) in
            Some (adt {log: e''' :: e'' :: e' :: e1 :: e :: e0 :: (log adt)}
                      {share: (share adt) {gs: (gs (share adt)) # rtt_gidx == (grtt' {gtype: GRANULE_STATE_DELEGATED})
                                                                # recl_gidx == (grecl' {gtype: GRANULE_STATE_DELEGATED})
                                                                # gidx == (grd' {gtype: GRANULE_STATE_DELEGATED})}},
                  VZ64 0)
          else
            let e' := EVT CPU_ID (REL rtt_gidx (gn_rtt {glock: Some CPU_ID})) in
            let e'' := EVT CPU_ID (REL gidx (gn {glock: Some CPU_ID})) in
            Some (adt {log: e'' :: e' :: e :: e0 :: log adt}, VZ64 1)
        else
          let e' := EVT CPU_ID (REL gidx (gn {glock: Some CPU_ID})) in
          Some (adt {log: e' :: e0 :: (log adt)}, VZ64 1)
      else Some (adt, VZ64 1)
    end.

End Spec.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import VST.zlist.Zlist.
Require Import Poulet4.Utils.Utils.
Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.Members.
Require Import ProD3.core.SvalRefine.
Require Import ProD3.core.AssertionLang.
Require Import ProD3.core.AssertionNotations.
Require Import ProD3.core.Hoare.
Require Import ProD3.core.EvalExpr.
Require Import Coq.ZArith.BinInt.
Require Import Hammer.Tactics.Tactics.
Require Import Hammer.Plugin.Hammer.

Local Open Scope string_scope.

Section EvalBuiltin.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := ValueLvalue.

Notation ident := string.

Context {target : @Target tags_t (@Expression tags_t)}.

Definition header_isValid (sv : Sval) : option bool :=
  match sv with
  | ValBaseHeader _ is_valid => is_valid
  | _ => None
  end.

Definition isValid (sv : Sval) : option bool :=
  match sv with
  | ValBaseHeader _ is_valid => is_valid
  | ValBaseUnion fields =>
      match lift_option (map header_isValid (map snd fields)) with
      | Some valid_bits => Some (fold_left orb valid_bits false)
      | None => None
      end
  | _ => None
  end.

Lemma header_isValid_sound : forall sv sv' b,
  sval_refine sv sv' ->
  exec_isValid read_ndetbit sv' b ->
  bit_refine (header_isValid sv) (Some b).
Proof.
  intros.
  inv H0.
  - inv H; inv H4; inv H1; constructor.
  - inv H. constructor.
Qed.

Lemma lift_option_some_inv : forall {A : Type} (ol : list (option A)) (al : list A),
  lift_option ol = Some al ->
  ol = map Some al.
Proof.
  induction ol; intros; inv H.
  - auto.
  - destruct a. 2 : inv H1.
    destruct (lift_option ol). 2 : inv H1.
    inv H1. erewrite IHol by eauto. auto.
Qed.

Lemma Forall2_map : forall {A B C D : Type} (R : A -> B -> Prop) (f : C -> A) (g : D -> B) cl dl,
  Forall2 (fun c d => R (f c) (g d)) cl dl <-> Forall2 R (map f cl) (map g dl).
Proof.
  intros.
  change (fun (c : C) (d : D) => _) with (fun c d => (fun a d => R a (g d)) (f c) d).
  rewrite ForallMap.Forall2_map_l, ForallMap.Forall2_map_r.
  reflexivity.
Qed.

Lemma Forall2_bit_refine_Some_inv : forall al bl,
  Forall2 bit_refine (map Some al) (map Some bl) ->
  al = bl.
Proof.
  induction al; intros.
  - destruct bl; inv H; auto.
  - destruct bl; inv H; inv H3; f_equal; auto.
Qed.

Global Instance Inhabitant_string : Inhabitant string := "".

Lemma Forall2_forall_range2 : forall {A B : Type} {da : Inhabitant A} {db : Inhabitant B} al bl (P : A -> B -> Prop),
  Forall2 P al bl <->
    (Zlength al = Zlength bl /\ forall_range2 0 (Zlength al) 0 al bl P).
Proof.
  intros; split; intro.
  - induction H.
    + unfold forall_range2, forall_i. list_solve.
    + unfold forall_range2, forall_i. destruct IHForall2. list_solve.
  - generalize dependent bl; induction al; intros.
    + assert (bl = []) by list_solve; subst.
      constructor.
    + destruct bl. 1 : list_solve.
      constructor. {
        destruct (H).
        specialize (H1 0%Z ltac:(list_solve)).
        list_solve.
      }
      apply IHal. unfold forall_range2, forall_i. destruct H. list_solve.
Qed.

Hint Rewrite @Forall2_forall_range2 : list_prop_rewrite.

Lemma isValid_sound : forall sv sv' b,
  sval_refine sv sv' ->
  exec_isValid read_ndetbit sv' b ->
  bit_refine (isValid sv) (Some b).
Proof.
  intros.
  inv H0.
  - inv H; inv H4; inv H1; constructor.
  - simpl.
    inv H.
    assert (Forall2 sval_refine (map snd kvs) (map snd fields)) as H3'. {
      unfold AList.all_values in H3.
      range_form. destruct H1. destruct H3.
      list_simplify.
      intro; intros.
      list_simplify.
      clear -H13.
      hauto use: Z.add_0_r unfold: sval_refine.
    }
    clear H3. rename H3' into H3.
    assert (Forall2 bit_refine (map header_isValid (map snd kvs)) (map Some valid_bits)). {
      range_form.
      list_simplify.
      intro; intros.
      destruct H1; destruct H3; list_simplify.
      rewrite Z.add_0_r in H13, H14.
      eapply header_isValid_sound; eassumption.
    }
    clear -H.
    simpl.
    destruct (lift_option (map header_isValid (map snd kvs))) eqn:H_list_option.
    2 : constructor.
    apply lift_option_some_inv in H_list_option.
    rewrite H_list_option in H. clear H_list_option.
    assert (l = valid_bits). {
      list_simplify.
      destruct H.
      list_simplify.
      inv H8. list_solve.
    }
    rewrite H0.
    constructor.
Qed.

Definition setValid (sv : Sval) : Sval :=
  match sv with
  | ValBaseHeader fields _ =>
      ValBaseHeader fields (Some true)
  | _ => sv
  end.

Definition setInvalid (sv : Sval) : Sval :=
  match sv with
  | ValBaseHeader fields _ =>
      ValBaseHeader fields (Some false)
  | _ => sv
  end.

Definition push_front (sv : Sval) (count : Z) : Sval :=
  match sv with
  | ValBaseStack headers next =>
      push_front headers next count
  | _ => sv
  end.

Lemma push_front_sound : forall sv headers next count,
  (count >= 0)%Z ->
  sval_refine sv (ValBaseStack headers next) ->
  sval_refine (push_front sv count) (Semantics.push_front headers next count).
Proof.
  intros.
  inv H0.
  unfold push_front, Semantics.push_front.
  constructor.
  range_form. destruct H3. rewrite H0.
  destruct (count <=? Zlength headers)%Z eqn:?.
  - list_simplify.
    + intro; intros.
      list_simplify. apply sval_refine_uninit_sval_of_sval_trans. auto.
    + intro; intros.
      list_solve.
  - list_simplify.
    + intro; intros.
      list_simplify. apply sval_refine_uninit_sval_of_sval_trans. auto.
    + intro; intros.
      list_solve.
Qed.

Definition pop_front (sv : Sval) (count : Z) : Sval :=
  match sv with
  | ValBaseStack headers next =>
      pop_front headers next count
  | _ => sv
  end.

Lemma pop_front_sound : forall sv headers next count,
  (count >= 0)%Z ->
  sval_refine sv (ValBaseStack headers next) ->
  sval_refine (pop_front sv count) (Semantics.pop_front headers next count).
Proof.
  intros.
  inv H0.
  unfold pop_front, Semantics.pop_front.
  constructor.
  range_form. destruct H3. rewrite H0.
  destruct (count <=? Zlength headers)%Z eqn:?.
  - list_simplify.
    + intro; intros.
      list_simplify. apply sval_refine_uninit_sval_of_sval_trans. auto.
    + intro; intros.
      list_solve.
  - list_simplify.
    + intro; intros.
      list_simplify. apply sval_refine_uninit_sval_of_sval_trans. auto.
    + intro; intros.
      list_solve.
Qed.

Definition eval_builtin (a : mem_assertion) (lv : Lval) (fname : ident) (args : list Sval) : option (mem_assertion * Sval) :=
  if fname =? "isValid" then
    match eval_read a lv with
    | Some hdr =>
        Some (a, ValBaseBool (isValid hdr))
    | None => None
    end
  else if fname =? "setValid" then
    match eval_read a lv with
    | Some hdr =>
        match eval_write a lv (setValid hdr) with
        | Some a' => Some (a', ValBaseNull)
        | None => None
        end
    | None => None
    end
  else if fname =? "setInvalid" then
    match eval_read a lv with
    | Some hdr =>
        match eval_write a lv (setInvalid hdr) with
        | Some a' => Some (a', ValBaseNull)
        | None => None
        end
    | None => None
    end
  else if fname =? "push_front" then
    match args with
    | [ValBaseInteger count] =>
      match eval_read a lv with
      | Some hdr =>
          match eval_write a lv (push_front hdr count) with
          | Some a' => Some (a', ValBaseNull)
          | None => None
          end
      | None => None
      end
    | _ => None
    end
  else if fname =? "pop_front" then
    match args with
    | [ValBaseInteger count] =>
      match eval_read a lv with
      | Some hdr =>
          match eval_write a lv (pop_front hdr count) with
          | Some a' => Some (a', ValBaseNull)
          | None => None
          end
      | None => None
      end
    | _ => None
    end
  else
    None.

Lemma eval_builtin_sound : forall p a_mem a_ext lv fname args a_mem' retv,
  NoDup (map fst a_mem) ->
  eval_builtin a_mem lv fname args = Some (a_mem', retv) ->
  hoare_builtin p (ARG args (MEM a_mem (EXT a_ext))) lv fname (RET retv (MEM a_mem' (EXT a_ext))).
Proof.
  unfold hoare_builtin; intros * H_NoDup; intros.
  inv H1.
  - unfold eval_builtin in H. simpl in H.
    destruct (eval_read a_mem lv) eqn:H_eval_read. 2 : inv H.
    eapply eval_read_sound in H_eval_read; eauto.
    specialize (H_eval_read _ _ ltac:(apply H0) H2).
    pose proof (isValid_sound _ _ _ H_eval_read H3).
    inv H.
    split. 2 : apply H0.
    intro; intros.
    inv H. constructor. inv H5. auto.
  - unfold eval_builtin in H. simpl in H.
    destruct (eval_read a_mem lv) eqn:H_eval_read. 2 : inv H.
    eapply eval_read_sound in H_eval_read; eauto.
    specialize (H_eval_read _ _ ltac:(apply H0) H2).
    destruct (eval_write a_mem lv (setValid v)) eqn:H_eval_write. 2 : inv H.
    eapply eval_write_sound in H_eval_write; eauto.
    assert (sval_refine (setValid v) (ValBaseHeader fields (Some true))). {
      inv H_eval_read.
      constructor; [constructor | auto].
    }
    specialize (H_eval_write _ _ _ ltac:(apply H0) ltac:(eassumption) ltac:(eassumption)).
    inv H.
    split. 2 : auto.
    intro; intros. inv H. constructor.
  - unfold eval_builtin in H. simpl in H.
    destruct (eval_read a_mem lv) eqn:H_eval_read. 2 : inv H.
    eapply eval_read_sound in H_eval_read; eauto.
    specialize (H_eval_read _ _ ltac:(apply H0) H2).
    destruct (eval_write a_mem lv (setInvalid v)) eqn:H_eval_write. 2 : inv H.
    eapply eval_write_sound in H_eval_write; eauto.
    assert (sval_refine (setInvalid v) (ValBaseHeader fields (Some false))). {
      inv H_eval_read.
      constructor; [constructor | auto].
    }
    specialize (H_eval_write _ _ _ ltac:(apply H0) ltac:(eassumption) ltac:(eassumption)).
    inv H.
    split. 2 : auto.
    intro; intros. inv H. constructor.
  - unfold eval_builtin in H. simpl in H.
    destruct H0. inv H0; inv H8; inv H9.
    destruct (eval_read a_mem lv) eqn:H_eval_read. 2 : inv H.
    eapply eval_read_sound in H_eval_read; eauto.
    specialize (H_eval_read _ _ ltac:(apply H1) H3).
    destruct (eval_write a_mem lv (push_front v count)) eqn:H_eval_write. 2 : inv H.
    eapply eval_write_sound in H_eval_write; eauto.
    specialize (H_eval_write _ _ _ ltac:(apply H1) ltac:(eapply push_front_sound; eassumption) ltac:(eassumption)).
    inv H.
    split. 2 : auto.
    intro; intros. inv H. constructor.
  - unfold eval_builtin in H. simpl in H.
    destruct H0. inv H0; inv H8; inv H9.
    destruct (eval_read a_mem lv) eqn:H_eval_read. 2 : inv H.
    eapply eval_read_sound in H_eval_read; eauto.
    specialize (H_eval_read _ _ ltac:(apply H1) H3).
    destruct (eval_write a_mem lv (pop_front v count)) eqn:H_eval_write. 2 : inv H.
    eapply eval_write_sound in H_eval_write; eauto.
    specialize (H_eval_write _ _ _ ltac:(apply H1) ltac:(eapply pop_front_sound; eassumption) ltac:(eassumption)).
    inv H.
    split. 2 : auto.
    intro; intros. inv H. constructor.
Qed.

End EvalBuiltin.

#[export] Hint Resolve eval_builtin_sound : hoare.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.

Require Import Language Types.
Require Import Lemmas.
Require Import Low_eq.
Require Import Label.

Require Import Simulation_L.
Require Import simulation_full.
Require Import preservation.
Require Import execution.

Require Import progress.

Lemma low_eq_preservation : forall ct  ctn1 ctns1 h1 ctn2 ctns2 h2
                                   ctn1' ctns1' h1'
                                   ctn2' ctns2' h2' φ T,
    valid_config (Config ct  ctn1 ctns1 h1 ) ->
    valid_config (Config ct  ctn2 ctns2 h2 ) ->
    config_has_type ct empty_context (Config ct ctn1  ctns1 h1) T ->
    config_has_type ct empty_context (Config ct ctn2  ctns2 h2) T ->
    L_equivalence_heap h1 h2 φ ->
    parallel_reduction (Config ct ctn1 ctns1 h1)
                           (Config ct ctn2 ctns2 h2)
                           (Config ct ctn1' ctns1' h1')
                           (Config ct ctn2' ctns2' h2') ->
     L_equivalence_config (Config ct ctn1 ctns1 h1 )
                          (Config ct ctn2 ctns2 h2)  φ ->

          exists  φ', (L_equivalence_heap h1' h2'  φ')  /\ L_equivalence_config (Config ct ctn1' ctns1' h1')  (Config ct ctn2' ctns2' h2')  φ'.
Proof with eauto.
  intros  ct  ctn1 ctns1 h1 ctn2 ctns2 h2 ctn1' ctns1' h1' ctn2' ctns2' h2'  φ  T.
  intro H_valid1. intro H_valid2.
  intro H_typing1. intro H_typing2.
  intro H_bijection.
  intro H_p_execution.
  intro H_low_eq.

  inversion H_p_execution; subst; auto.
  -
    apply  simulation_L with t1 fs1 lb1 sf1 ctns1 h1
                             t2 fs2 lb2 sf2 ctns2 h2
                             φ T; auto; inversion H_valid1; inversion H_valid2; auto.

  - try (eauto using simulation_H2H_H).
  - try (eauto using simulation_H_H2H).
  - try (eauto using simulation_H2L_H2L).
  -
    try (eauto using simulation_Terminal_H2H).
Qed. Hint Resolve low_eq_preservation.

Lemma two_exes_to_parallel_execution : forall ct ctn1 ctns_stack1 h1
                                                    ctn2 ctns_stack2 h2 lb1' sf1' lb2' sf2'
                                                    final_v1  final_v2  h1' h2' T  φ n,
    valid_config (Config ct  ctn1 ctns_stack1 h1 ) ->
    valid_config (Config ct  ctn2 ctns_stack2 h2 ) ->
    config_has_type ct empty_context (Config ct ctn1  ctns_stack1 h1) T ->
    config_has_type ct empty_context (Config ct ctn2  ctns_stack2 h2) T ->
    two_terminate_num (Config ct ctn1 ctns_stack1 h1)
                  (Config ct ctn2 ctns_stack2 h2)
                  (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                  (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                  n ->
    L_equivalence_config (Config ct ctn1 ctns_stack1 h1 )
            (Config ct ctn2 ctns_stack2 h2)  φ ->
    value final_v1 -> value final_v2 ->
    L_equivalence_heap h1 h2 φ ->
    multi_step_p_reduction (Config ct ctn1 ctns_stack1 h1)
                           (Config ct ctn2 ctns_stack2 h2)
                           (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                           (Config ct (Container final_v2 nil lb2' sf2') nil h2') .
Proof with eauto.
  intros ct ctn1 ctns_stack1 h1
         ctn2 ctns_stack2 h2 lb1' sf1' lb2' sf2'
         final_v1  final_v2  h1' h2' T  φ n.
  intro H_valid1. intro H_valid2.
  intro H_typing1. intro H_typing2.
  intro H_reduction.
  intro H_low_eq.
  intro Hv_final1. intro Hv_final2.
  intro H_bijection.
(*
  remember (Config ct ctn1 ctns_stack1 h1) as config1.
  remember (Config ct ctn2 ctns_stack2 h2) as config2.
  *)
  generalize dependent ctn1. generalize dependent ctn2.
  generalize dependent ctns_stack1. generalize dependent ctns_stack2.
  generalize dependent h1. generalize dependent h2. generalize dependent  φ.

  induction n as [ n IHn ] using (well_founded_induction lt_wf).
  intros; subst; auto.

  destruct ctn1. rename l into lb1. rename f into fs1. rename s into sf1. rename t into t1.
  destruct ctn2. rename l into lb2. rename f into fs2. rename s into sf2. rename t into t2.

  assert  (terminal_state  (Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
             \/ (exists config', (Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1) ==> config')).
  eauto using Progress.

  assert  (terminal_state  (Config ct (Container t2 fs2 lb2 sf2) ctns_stack2 h2)
             \/ (exists config', (Config ct (Container t2 fs2 lb2 sf2) ctns_stack2 h2) ==> config')).
  eauto using Progress.

  assert (exists m0 n0, terminate_num (Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
                                        (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                                        m0 /\
                        terminate_num (Config ct (Container t2 fs2 lb2 sf2) ctns_stack2 h2)
                                        (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                                        n0 /\ (m0 + n0 = n)).
  eauto using two_executions_split.
  destruct H1 as [m0].
  destruct H1 as [n0].
  destruct H1.
  destruct H2.

  case_eq (flow_to lb1 L_Label); intro.
  - (* conf1 is a low configuration  *)
    destruct H.
    + (* conf1 already terminated *)
      assert ((Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
                  = (Config ct (Container final_v1 nil lb1' sf1') nil h1')).
      eauto using terminated_same_as_final.
      destruct H0.
      ++ (*conf2 also terminated *)
        assert ((Config ct (Container t2 fs2 lb2 sf2) ctns_stack2 h2)
                  = (Config ct (Container final_v2 nil lb2' sf2') nil h2')).
        eauto using terminated_same_as_final.
        inversion H5; subst; auto.
        inversion H6; subst; auto.
      ++ (*conf2 steps; this is impossible*)
         inversion H_low_eq; subst; auto;
           try (inconsist).

         inversion H5; subst; auto.
         inversion H21; subst; auto.

         inversion H22; subst; auto.
         inversion H17; subst; auto.
         destruct H0 as [config2'].
         inversion H; subst; auto.

         assert (value t2).
         apply value_L_eq2 with final_v1 h1' h2 φ; auto.
         inversion H3; subst; auto; inversion H0.

    + (* conf1 steps *)
      destruct H as [config1'].
      destruct H0.
      ++ (*conf2 terminated; this is impossible *)
        assert ((Config ct (Container t2 fs2 lb2 sf2) ctns_stack2 h2)
                  = (Config ct (Container final_v2 nil lb2' sf2') nil h2')).
        eauto using terminated_same_as_final.
        inversion H5; subst; auto.
        inversion H_low_eq; subst; auto;
           try (inconsist).
        inversion H20; subst; auto.
        inversion H21; subst; auto.

        inversion H17; subst; auto.
        inversion H0; subst; auto.
        assert (value t1).
        apply value_L_eq with final_v2 h1 h2' φ; auto.
        inversion H3; subst; auto; inversion H.
      ++ (*conf2 steps*)
        destruct H0 as [config2'].
        assert (exists ctn' ctns' h', config1' =
                                      (Config ct ctn' ctns' h')).
        eauto using execution_no_exception.
        assert (exists ctn' ctns' h', config2' =
                                      (Config ct ctn' ctns' h')).
        eauto using execution_no_exception.
        destruct H5 as [ctn1'].
        destruct H5 as [ctns1'].
        destruct H5 as [h1'0]; subst; auto.
        destruct H6 as [ctn2'].
        destruct H3 as [ctns2'].
        destruct H3 as [h2'0]; subst; auto.
        inversion H_low_eq; subst; auto;
          try (inconsist).
        destruct ctn1'. destruct ctn2'.
        assert (exists  φ', L_equivalence_heap h1'0 h2'0 φ'
                /\ L_equivalence_config (Config ct (Container t f l s) ctns1' h1'0)
                                        (Config ct (Container t0 f0 l0 s0) ctns2' h2'0) φ'); auto.
        eauto using  simulation_L; auto.
        destruct H3 as [φ'].
        destruct H3.
        apply multi_p_reduction_step with
              (Config ct (Container t f l s) ctns1' h1'0)
              (Config ct (Container t0 f0 l0 s0) ctns2' h2'0).
        eauto using L_L_reduction.
        assert (exists m0', 1 + m0' = m0).
        eauto using execution_num_step_nonzero.
        destruct H6 as [m0'].
        assert (exists n0', 1 + n0' = n0).
        eauto using execution_num_step_nonzero.
        destruct H7 as [n0'].
        rewrite <- H6 in H1.
        rewrite <- H7 in H2.
        apply IHn with (m0' + n0')  φ'; auto; try (apply H5).
        rewrite <- H6. rewrite <- H7.
        assert (forall n, n < 1 + n). auto.
        pose proof H8 (n0').
        apply lt_trans with (m0' + (1 + n0')); auto.

        eauto using valid_config_preservation.
        inversion H_typing2; subst; auto.
        eauto using typing_preservation.
        eauto using valid_config_preservation.
        inversion H_typing1; subst; auto.
        eauto using typing_preservation.

        assert (forall n, 1 + n -1 = n).
        intros. induction n; auto.
        assert (terminate_num (Config ct (Container t f l s) ctns1' h1'0)
                                     (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                                     (1 + m0' - 1)).
        eauto using execution_num_step.

        assert (terminate_num (Config ct (Container t0 f0 l0 s0) ctns2' h2'0)
                                     (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                                     (1 + n0' - 1)).
        eauto using execution_num_step.
        pose proof H8 m0'. rewrite H11 in H9.
        pose proof H8 n0'. rewrite H12 in H10.
        auto.

  - (* conf1 is a high configuration  *)
    inversion H_low_eq; subst; auto.
    try (inconsist).

    destruct H.
    (* first configuration is terminated *)
    + destruct H0.
      ++ (* conf2 also terminated *)
        eauto using terminated_both_p_reduction.

      ++ (* conf2 steps *)
        destruct H0 as [config2'].
        assert (exists ctn' ctns' h', config2' =
                                      (Config ct ctn' ctns' h')).
        eauto using execution_no_exception.
        destruct H3 as [ctn2'].
        destruct H3 as [ctns2'].
        destruct H3 as [h2'0]; subst; auto.
        destruct ctn2'.
        case_eq (flow_to l L_Label); intro.
        +++ (*conf2 steps to a low configuration*)
          assert (flow_to l L_Label = false).
          inversion H; subst; auto.
          apply terminate_H_must_2H with ct t1 lb1 sf1 h1
                                         (Container t2 fs2 lb2 sf2)  ctns_stack2 h2 s f t ctns2' h2'0 T φ; auto.
          try (inconsist).
        +++ (*conf2 steps to a high configuration*)
          assert (L_equivalence_heap h1 h2'0 φ /\ L_equivalence_config (Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
                                                                          (Config ct (Container t f l s) ctns2' h2'0 )  φ); auto.
          eauto using  simulation_H_H2H; auto.
          apply multi_p_reduction_step with
              (Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
              (Config ct (Container t f l s) ctns2' h2'0).
          assert ((Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
                  = (Config ct (Container final_v1 nil lb1' sf1') nil h1')).
          eauto using terminated_same_as_final.
          inversion H6; subst; auto.
          assert (exists n0', 1 + n0' = n0).
          eauto using execution_num_step_nonzero.
          destruct H6 as [n0'].
          rewrite <- H6 in H2.
          apply IHn with (m0 + n0')  φ ; auto; try (apply H5).
          ++++ pose proof addition_exchange_all 1 n0'.
               rewrite H7 in H6. rewrite <-H6.
               rewrite <- H7.
               apply lt_addition_plus1.
          ++++ eauto using valid_config_preservation.
          ++++
            inversion H_typing2. eauto using typing_preservation.
          ++++ assert (terminate_num (Config ct (Container t f l s) ctns2' h2'0)
                                     (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                                     (1 + n0' - 1)).
               eauto using execution_num_step.
               assert (forall n, 1 + n -1 = n).
               intros. induction n; auto.
               pose proof H8 n0'.
               rewrite H9 in H7; auto.
    + (* first configuration steps  *)
      destruct H as [config1'].
      assert (exists ctn' ctns' h', config1' =
                                      (Config ct ctn' ctns' h')).
      eauto using execution_no_exception.
      destruct H3 as [ctn1'].
      destruct H3 as [ctns1'].
      destruct H3 as [h1'0]; subst; auto.
      destruct ctn1'.
      case_eq (flow_to l L_Label); intro.
      ++ (* conf1 steps to a low configuration *)
        destruct H0.
        +++ (*conf2 terminated; impossible case*)
          assert (flow_to l L_Label = false).
          inversion H0; subst; auto.
          eauto using H_terminate_must_2H.
          try (inconsist).
        +++ (*conf2 steps *)
          destruct H0 as [config2'].
          assert (exists ctn' ctns' h', config2' =
                                      (Config ct ctn' ctns' h')).
          eauto using execution_no_exception.
          destruct H5 as [ctn2'].
          destruct H5 as [ctns2'].
          destruct H5 as [h2'0]; subst; auto.
          destruct ctn2'.
          case_eq (flow_to l0 L_Label); intro.
          ++++ (* conf2 steps into low configuration  *)
             assert (L_equivalence_heap h1'0 h2'0 φ /\ L_equivalence_config (Config ct (Container t f l s) ctns1' h1'0)
                                                                         ( Config ct (Container t0 f0 l0 s0) ctns2' h2'0)  φ); auto.
             eauto using simulation_H2L_H2L.
             destruct H6.
             apply multi_p_reduction_step with
                 (Config ct (Container t f l s) ctns1' h1'0)
                 ( Config ct (Container t0 f0 l0 s0) ctns2' h2'0).
             eauto using H2L_H2L_reduction.
             assert (exists m0', 1 + m0' = m0).
             eauto using execution_num_step_nonzero.
             destruct H8 as [m0'].
             assert (exists n0', 1 + n0' = n0).
             eauto using execution_num_step_nonzero.
             destruct H9 as [n0'].
             rewrite <- H8 in H1.
             rewrite <- H9 in H2.
             apply IHn with (m0' + n0')  φ; auto; try (apply H7).
             rewrite <- H8. rewrite <- H9.
             assert (forall n, n < 1 + n). auto.
             pose proof H10 (n0').
             apply lt_trans with (m0' + (1 + n0')); auto.

             eauto using valid_config_preservation.
             inversion H_typing2; subst; auto.
             eauto using typing_preservation.

             eauto using valid_config_preservation.
             inversion H_typing1; subst; auto.
             eauto using typing_preservation.

             assert (forall n, 1 + n -1 = n).
             intros. induction n; auto.
             assert (terminate_num (Config ct (Container t f l s) ctns1' h1'0)
                                     (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                                     (1 + m0' - 1)).
             eauto using execution_num_step.

             assert (terminate_num (Config ct (Container t0 f0 l0 s0) ctns2' h2'0)
                                     (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                                     (1 + n0' - 1)).
             eauto using execution_num_step.
             pose proof H10 m0'. rewrite H13 in H11.
             pose proof H10 n0'. rewrite H14 in H12.
             auto.

          ++++ (* conf2 steps into high configuration *)
            assert (L_equivalence_heap h1 h2'0 φ /\ L_equivalence_config (Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
                                                                         ( Config ct (Container t0 f0 l0 s0) ctns2' h2'0)  φ); auto.
            eauto using simulation_H_H2H.
            destruct H6.
            apply multi_p_reduction_step with
              (Config ct (Container t1 fs1 lb1 sf1) ctns_stack1 h1)
              ( Config ct (Container t0 f0 l0 s0) ctns2' h2'0).
            eauto using H2L_H2H_reduction.
            assert (exists n0', 1 + n0' = n0).
            eauto using execution_num_step_nonzero.

            destruct H8 as [n0'].
            rewrite <- H8 in H2.
            apply IHn with (m0 + n0')  φ ; auto; try (apply H7).
          +++++ rewrite <- H8; auto.
          +++++ eauto using valid_config_preservation.
          +++++ inversion H_typing2; subst; auto.
          eauto using typing_preservation.
          +++++ assert (terminate_num (Config ct (Container t0 f0 l0 s0) ctns2' h2'0)
                                     (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                                     (1 + n0' - 1)).
          eauto using execution_num_step.
          assert (forall n, 1 + n -1 = n).
          intros. induction n; auto.
          pose proof H10 n0'.
          rewrite H11 in H9; auto.

      ++ (* conf1 steps to a high configuration *)
         assert (L_equivalence_heap h1'0 h2 φ /\  L_equivalence_config (Config ct (Container t f l s) ctns1' h1'0)
                                                                       (Config ct (Container t2 fs2 lb2 sf2) ctns_stack2 h2 )  φ).
         eauto using  simulation_H2H_H; auto.
         apply multi_p_reduction_step with
              (Config ct (Container t f l s) ctns1' h1'0)
              (Config ct (Container t2 fs2 lb2 sf2) ctns_stack2 h2).
         apply H2H_H_reduction; auto.
         assert (exists m0', 1 + m0' = m0).
         eauto using execution_num_step_nonzero.
         destruct H6 as [m0'].
         rewrite <- H6 in H1.
         apply IHn with (m0' + n0)  φ; auto; try (apply H5).
         +++ rewrite <- H6. simpl.
             assert (forall n, n < S n).
             induction n; auto.
             pose proof H7 (m0' + n0); auto.
         +++ eauto using valid_config_preservation.
         +++ inversion H_typing1; subst; auto.
           eauto using typing_preservation.
         +++ assert (terminate_num (Config ct (Container t f l s) ctns1' h1'0)
                                     (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                                     (1 + m0' - 1)).
               eauto using execution_num_step.
               assert (forall n, 1 + n -1 = n).
               intros. induction n; auto.
               pose proof H8 m0'.
               rewrite H9 in H7; auto.
Qed. Hint Resolve  two_exes_to_parallel_execution.

Lemma p_reduction_NI : forall ct ctn1 ctns_stack1 h1 ctn2 ctns_stack2 h2 lb1' sf1' lb2' sf2' final_v1  final_v2  h1' h2' φ T,
    valid_config (Config ct  ctn1 ctns_stack1 h1 ) ->
    valid_config (Config ct  ctn2 ctns_stack2 h2 ) ->
    config_has_type ct empty_context (Config ct ctn1  ctns_stack1 h1) T ->
    config_has_type ct empty_context (Config ct ctn2  ctns_stack2 h2) T ->
    multi_step_p_reduction (Config ct ctn1 ctns_stack1 h1)
                           (Config ct ctn2 ctns_stack2 h2)
                           (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                           (Config ct (Container final_v2 nil lb2' sf2') nil h2') ->
     L_equivalence_config (Config ct ctn1 ctns_stack1 h1 )
            (Config ct ctn2 ctns_stack2 h2)  φ ->
     value final_v1 -> value final_v2 ->
     L_equivalence_heap h1 h2 φ ->
     exists  φ', L_equivalence_config (Config ct (Container final_v1 nil lb1' sf1') nil h1')  (Config ct (Container final_v2 nil lb2' sf2') nil h2')  φ'.
Proof with eauto.
  intros ct ctn1 ctns_stack1 h1 ctn2 ctns_stack2 h2 lb1' sf1' lb2' sf2' final_v1  final_v2  h1' h2' φ T.
  intro H_valid1. intro H_valid2.
  intro H_typing1. intro H_typing2.
  intro H_p_execution.
  intro H_low_eq. intro Hv_final1. intro Hv_final2.
  intro H_bijection.
  remember  (Config ct ctn1 ctns_stack1 h1) as config1.
  remember  (Config ct ctn2 ctns_stack2 h2) as config2.
  generalize dependent ctn1.   generalize dependent ctn2.
  generalize dependent ctns_stack1.   generalize dependent ctns_stack2.
  generalize dependent h1.   generalize dependent h2.
  generalize dependent T. generalize dependent φ.
  induction   H_p_execution; intros; inversion   Heqconfig1; inversion   Heqconfig2; subst; auto.
  exists φ.  auto.
  induction c2; try (inversion H; fail).
  induction c2'; try (inversion H; fail).
  assert (ct = ct /\ ct = c /\ ct = c1).
  try (eauto using ct_consist_p_reduction).
  destruct H2. destruct H3. subst; auto. rename c1 into ct.

  assert (valid_config ( (Config ct c0 l h)) /\  valid_config (Config ct c2 l0 h0) ).
  try (eauto using valid_config_after_p_reduction).
  destruct H3.
  assert (exists φ', L_equivalence_heap h h0 φ' /\  L_equivalence_config (Config ct c0 l h) (Config ct c2 l0 h0) φ').
  eauto using low_eq_preservation.
  destruct H5 as [φ'].
  destruct H5.

  assert ((config_has_type ct  empty_context ((Config ct c0 l h)) T  ) /\
          (config_has_type ct  empty_context (Config ct c2 l0 h0) T  )).
  apply typing_preservation_p_reduction with ctn1 ctns_stack1 h1 ctn2 ctns_stack2 h2; auto.
  destruct H7.
  apply IHH_p_execution with φ' T h0 h l0 l c2 c0; auto; auto.
Qed. Hint Resolve  p_reduction_NI.

Theorem TINI : forall ct ctn1 ctns1 h1 ctn2 ctns2 h2 lb1' sf1' lb2' sf2' final_v1  final_v2  h1' h2' φ T m n,
    valid_config (Config ct  ctn1 ctns1 h1 ) ->
    valid_config (Config ct  ctn2 ctns2 h2 ) ->
    config_has_type ct empty_context (Config ct ctn1  ctns1 h1) T ->
    config_has_type ct empty_context (Config ct ctn2  ctns2 h2) T ->
    terminate_num (Config ct ctn1 ctns1 h1)
                  (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                  m ->
    terminate_num (Config ct ctn2 ctns2 h2)
                  (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                  n ->
    L_equivalence_config (Config ct ctn1 ctns1 h1 )
            (Config ct ctn2 ctns2 h2)  φ ->
    value final_v1 -> value final_v2 ->
     L_equivalence_heap h1 h2 φ ->
     exists  φ', L_equivalence_config (Config ct (Container final_v1 nil lb1' sf1') nil h1')  (Config ct (Container final_v2 nil lb2' sf2') nil h2')  φ'.
Proof with eauto.
  intros  ct ctn1 ctns1 h1 ctn2 ctns2 h2 lb1' sf1' lb2' sf2' final_v1  final_v2  h1' h2' φ T m n.
  intro H_valid1. intro H_valid2.
  intro H_typing1. intro H_typing2.
  intro H_execution1. intro H_execution2.
  intro H_low_eq. intro Hv_final1. intro Hv_final2.
  intro H_bijection.
  assert (two_terminate_num (Config ct ctn1 ctns1 h1)
                  (Config ct ctn2 ctns2 h2)
                  (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                  (Config ct (Container final_v2 nil lb2' sf2') nil h2')
                  (m+n)).
  eauto using  two_executions_to_one.
  assert (multi_step_p_reduction (Config ct ctn1 ctns1 h1)
                           (Config ct ctn2 ctns2 h2)
                           (Config ct (Container final_v1 nil lb1' sf1') nil h1')
                           (Config ct (Container final_v2 nil lb2' sf2') nil h2') ).
  eauto using two_exes_to_parallel_execution.
  eauto using p_reduction_NI.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(** * Main theorem of the present contribution *)

(** Proof of the following theorem [iota_unique] :
    "Simple Lambda Calculus is initial in the category of
     exponential monads". *)

Set Implicit Arguments.

Require Export Lc.
Require Export Derived_Mod.

Section Lc_exp.

Implicit Type X Y Z : Set.

Opaque app1.
Opaque lc lc_class lc_factor lc_factor1 lc_factor2.
Opaque lc_abs lc_app1 lc_abs lc_fct lc_bind.

Notation "/ x" := (lc_class x).

Definition SLC : Monad :=
  Build_Monad term slc_bind var slc_bind_bind slc_bind_var slc_var_bind.

Definition LC : Monad :=
  Build_Monad lc lc_bind lc_var lc_bind_assoc lc_bind_var lc_var_bind.

Lemma slc_bind_var : forall X Y (f : X -> SLC Y) (u : X),
  var u >>= f = f u.
Proof.
reflexivity.
Qed.

Lemma slc_bind_app : forall X Y (f : X -> SLC Y) (x y : SLC X),
  app x y >>= f = app (x >>= f)  (y >>= f).
Proof.
reflexivity.
Qed.

Lemma slc_bind_abs : forall X Y (f : X -> SLC Y) (x : Derived_Mod SLC X),
  abs x >>= f = abs (x >>>= f).
Proof.
simpl. intros. f_equal.
apply slc_bind_fun_cong.
destruct u; simpl.
2: reflexivity.
unfold shift.
rewrite slc_fct_as_bind.
reflexivity.
Qed.

Remark lc_abs_hom : forall X Y (f : X -> LC Y) (x : Derived_Mod LC X),
  lc_abs (x >>>= f) = (lc_abs x : Taut_Mod LC _) >>>= f.
Proof.
simpl. intros. rewrite lc_bind_abs. f_equal.
apply lc_bind_fun_cong. destruct u; simpl. 2:reflexivity.
rewrite lc_fct_as_bind. reflexivity.
Qed.

Let abs_hom : Mod_Hom (Derived_Mod LC) LC :=
  Build_Mod_Hom (Derived_Mod LC) LC lc_abs lc_abs_hom.

Remark lc_app1_hom : forall X Y (f : X -> LC Y) (x : LC X),
  lc_app1 ((x : Taut_Mod LC X) >>>= f) =
    (lc_app1 x : Derived_Mod LC X) >>>= f.
Proof.
simpl. intros. rewrite <- lc_bind_app1.
apply lc_bind_fun_cong.
destruct u; simpl. 2:reflexivity.
rewrite lc_fct_as_bind. reflexivity.
Qed.

Let app1_hom : Mod_Hom LC (Derived_Mod LC) :=
  Build_Mod_Hom LC (Derived_Mod LC) lc_app1 lc_app1_hom.

Definition ELC : ExpMonad :=
  Build_ExpMonad abs_hom app1_hom lc_eta lc_beta.

Variable M : ExpMonad.

Fixpoint iota_fix X (x : term X) { struct x } : M X :=
  match x with
  | var a => unit M a
  | app x y =>
      exp_app M _ (iota_fix x) >>=
        default (@unit M X) (iota_fix y)
  | abs x => exp_abs M _ (iota_fix x)
  end.

Lemma iota_fix_unit : forall X (a : X),
  iota_fix (var a) = unit M a.
Proof.
reflexivity.
Qed.

Lemma iota_fix_fct : forall X Y (f : X -> Y) (x : term X),
  iota_fix (x //- f) = iota_fix x >>- f.
Proof.
intros. generalize Y f; clear Y f.
induction x; simpl; monad.
rewrite IHx1; clear IHx1.
rewrite IHx2; clear IHx2.
unfold map.
pose (mod_hom_mbind (exp_app M)). simpl in e. rewrite e.
rewrite bind_bind.
apply bind_congr. reflexivity.
destruct a; simpl; monad.
rewrite IHx; clear IHx.
pose (mod_hom_mbind (exp_abs M)). simpl in e.
unfold map. rewrite <- e.
replace (iota_fix x >>= (fun x0 : option X => unit M (optmap f x0))) with
  (iota_fix x >>=
     default (fun u : X => unit M (f u) >>- Some (A:=Y)) (unit M None)).
reflexivity.
apply bind_congr. reflexivity.
destruct a; simpl; monad.
Qed.

Lemma iota_fix_bind : forall X Y (f : X -> term Y) (x : term X),
  iota_fix (x //= f) = iota_fix x >>= fun u => iota_fix (f u).
Proof.
intros. generalize Y f; clear Y f.
induction x; simpl; intros; monad.
rewrite IHx1; clear IHx1.
pose (mod_hom_mbind (exp_app M)). simpl in e. rewrite e.
rewrite bind_bind.
apply bind_congr. reflexivity.
destruct a; simpl. monad.
rewrite bind_unit. simpl. monad.
rewrite IHx.
pose (mod_hom_mbind (exp_abs M)). simpl in e.
unfold map. rewrite <- e.
replace (iota_fix x >>= (fun u : option X => iota_fix (comm f u))) with
 (iota_fix x >>=
   default (fun u : X => iota_fix (f u) >>- Some (A:=Y)) (unit M None)).
reflexivity.
apply bind_congr. reflexivity.
destruct a; simpl.
unfold shift. rewrite iota_fix_fct. monad. reflexivity.
Qed.

Lemma iota_fix_app1 : forall X (x : term X),
  iota_fix (app1 x) = exp_app M X (iota_fix x).
Proof.
intros; rewrite app1_app; unfold shift; simpl.
rewrite iota_fix_fct.
unfold map.
pose (mod_hom_mbind (exp_app M)). simpl in e. rewrite e.
rewrite bind_bind.
apply unit_bind_match.
destruct a; simpl; monad.
Qed.

Lemma iota_fix_eta : forall X (x : term X),
  iota_fix (abs (app1 x)) = iota_fix x.
Proof.
intros. simpl.
rewrite iota_fix_app1.
rewrite exp_eta. reflexivity.
Qed.

Lemma iota_fix_beta : forall X (x : term (option X)) y,
  iota_fix (app (abs x) y) = iota_fix (x //= default (fun a => var a) y).
Proof.
intros; simpl.
rewrite exp_beta. rewrite iota_fix_bind.
apply bind_congr. reflexivity.
destruct a; simpl; reflexivity.
Qed.

Lemma iota_fix_wd : forall X (x y : term X),
  x == y -> iota_fix x = iota_fix y.
Proof.
induction 1.
auto.
simpl. rewrite IHlcr1. rewrite IHlcr2. reflexivity.
simpl. rewrite IHlcr. reflexivity.
destruct H.
apply iota_fix_beta.
apply iota_fix_eta.
auto.
eapply trans_eq; eauto.
Qed.

Let iota X : lc X -> M X :=
  lc_factor (@iota_fix X) (@iota_fix_wd X).

Remark iota_factorize : forall X (x : term X),
  iota (/ x) = iota_fix x.
Proof.
unfold iota. intros. rewrite lc_factorize. reflexivity.
Qed.

Opaque iota.

Remark iota_bind : forall X Y (f : X -> lc Y) (x : lc X),
  iota (lc_bind f x) = iota x >>= (fun a : X => iota (f a)).
Proof.
intros.
destruct (lc_class_surj x) as [y Hy]. subst x.
destruct (lc_fun_lift f) as [f' Hf]. subst f.
rewrite lc_bind_factorize.
do 2 rewrite iota_factorize.
rewrite iota_fix_bind.
apply bind_congr. reflexivity.
intro. rewrite iota_factorize. reflexivity.
Qed.

Remark iota_var : forall X (a : X),
  iota (lc_var a) = unit M a.
Proof.
simpl. unfold lc_var. intros.
rewrite iota_factorize. reflexivity.
Qed.

Lemma iota_app1 : forall X (x : lc X),
  iota (lc_app1 x) = exp_app M X (iota x).
Proof.
intros.
destruct (lc_class_surj x) as [y Hy]. subst x.
rewrite lc_app1_factorize.
do 2 rewrite iota_factorize.
rewrite iota_fix_app1. reflexivity.
Qed.

Lemma iota_abs : forall X (x : lc (option X)),
  iota (lc_abs x) = exp_abs M X (iota x).
Proof.
intros.
destruct (lc_class_surj x) as [y Hy]. subst x.
rewrite lc_abs_factorize.
do 2 rewrite iota_factorize. reflexivity.
Qed.

Let iota_monad : Monad_Hom LC M :=
  Build_Monad_Hom LC M iota iota_bind iota_var.

Let exp_iota : ExpMonad_Hom ELC M :=
  Build_ExpMonad_Hom ELC M iota_monad iota_app1 iota_abs.

Theorem iota_unique : forall (j : ExpMonad_Hom ELC M) X (x : lc X),
  j X x = exp_iota X x.
Proof.
intros. destruct j as [[p p_bind p_var] p_app p_abs].
simpl in *. unfold lc_var in *.
destruct (lc_class_surj x) as [y Hy]. subst x.
rewrite iota_factorize.
induction y.
simpl. auto.
rewrite app_as_app1. rewrite iota_fix_bind.
rewrite iota_fix_app1. rewrite <- lc_bind_factorize.
rewrite p_bind. rewrite <- lc_app1_factorize.
rewrite p_app. rewrite IHy1.
apply bind_congr. reflexivity.
destruct a; simpl; auto.
simpl. rewrite <- lc_abs_factorize. rewrite p_abs.
replace (p (option X) (/ y)) with (iota_fix y).
reflexivity.
Qed.

End Lc_exp.


Add LoadPath "D:\sfsol".
Require Export SfLib.
Require Import String.

Definition ProgramCounter : Type := nat.

Definition clist (X : Type) := list (ProgramCounter * X).

Inductive StringIndex : Type :=
  | strAt : string -> nat -> StringIndex.

Inductive Constant : Type :=
  | cnat : nat -> Constant
  | cstr : StringIndex -> Constant
  | ctrue : Constant
  | cfalse : Constant
  | cnull : Constant.

Inductive UnaryOperator : Type :=
  | unot : UnaryOperator.

Inductive BinaryArithOperator : Type :=
  | badd : BinaryArithOperator
  | bsub : BinaryArithOperator
  | bmult : BinaryArithOperator
  | bdiv : BinaryArithOperator
  | bmod : BinaryArithOperator
  | band : BinaryArithOperator
  | bor : BinaryArithOperator
  | bxor : BinaryArithOperator.

Inductive BinaryCompOperator : Type :=
  | beq : BinaryCompOperator
  | blt : BinaryCompOperator
  | bgt : BinaryCompOperator.

Definition RegIndex := nat.

Inductive Register : Type :=
  | Reg : RegIndex -> Register.

Definition Regs := list Register.

Definition Addr := nat.

Definition Addrs := list Addr.

Inductive PrimType : Type :=
  | boolean : bool -> PrimType
  | char : nat -> PrimType
  | int : nat -> PrimType.

Inductive pTypes : Type :=
  | bT : pTypes
  | cT : pTypes
  | iT : pTypes.

Inductive Class : Type :=
  | top : Class
  | class : StringIndex -> ClassIndex -> list FieldIndex -> list MethodIndex -> Class
with ClassIndex : Type :=
  | classAt : Class -> nat -> ClassIndex
with Field : Type :=
  | field : StringIndex -> ClassIndex -> Field
with FieldIndex : Type :=
  | fieldAt : Field -> nat -> FieldIndex
with Method : Type :=
  | method : StringIndex -> ClassIndex -> list TypeIndex -> TypeIndex -> nat -> clist Instruction -> Method
with MethodIndex : Type :=
  | methodAt : Method -> nat -> MethodIndex
with Instruction : Type :=
  | nop : Instruction
  | ret : Instruction
  | retTo : Register -> Instruction
  | invoke : list rhs -> MethodIndex -> Instruction
  | goto : ProgramCounter -> Instruction
  | branch : Register -> BinaryCompOperator -> Register -> ProgramCounter -> Instruction
  | move : lhs -> rhs -> Instruction
  | unaryArith : Register -> UnaryOperator -> Register -> Instruction
  | binaryArith : Register -> Register -> BinaryArithOperator -> Register -> Instruction
  | new : Register -> ClassIndex -> Instruction
  | newarr : Register -> DalType -> Register -> Instruction
  | cast : Register -> DalType -> Register -> Instruction
with lhs : Type :=
  | reg : Register -> lhs
  | acc : Register -> Register -> lhs
  | ifield : Register -> FieldIndex -> lhs
  | sfield : FieldIndex -> lhs
with rhs : Type :=
  | l : lhs -> rhs
  | c : Constant -> rhs
with DalType : Type :=
  | refT : RefType -> DalType
  | primT : pTypes -> DalType
with TypeIndex : Type :=
  | typeAt : DalType -> nat -> TypeIndex
with RefType : Type :=
  | cls : Class -> RefType
  | arrRef : RefType -> nat -> RefType
  | arrPrim : pTypes -> nat -> RefType
with Ref : Type :=
  | lRef : Location -> Ref
  | null : Ref
with Val : Type :=
  | prim : PrimType -> Val
  | ref : Ref -> Val
  | siv : StringIndex -> Val
with Object : Type :=
  | topObj : Object
  | obj : ClassIndex -> ClassIndex -> list (FieldIndex * Val) -> Object
with Array : Type :=
  | arr : nat -> list Val -> Array
with arrOrObj : Type :=
  | ar : Array -> arrOrObj
  | ob : Object -> arrOrObj
with Location : Type :=
  | locIn : nat -> Location.

Definition RegVal := Val.

Definition RegVals := list RegVal.

Definition RegState : Type := RegVals.

Definition PCVal := nat.

Definition Program := list ClassIndex.

(* Operator Arithmetic *)

Definition top1: Class := top.

Definition top2: Class := top.

Inductive Option {X : Type} : Type :=
  | None : Option
  | Some : X -> Option.

Fixpoint nth {A:Type} (n:nat) (l:list A) : (@Option A) :=
  match l,n with
  | [],_ => None
  | cons x lst,0 => Some x
  | cons x lst,(S n') => nth n' lst
  end.

Definition areSameSI (si1 si2:StringIndex) : bool :=
  match si1,si2 with
  | (strAt s1 n1),(strAt s2 n2) => (beq_nat n1 n2)
  end.

Fixpoint isSubClass (c1 c2:Class) : bool :=
  match c1,c2 with
  | _,top => true
  | top,_ => false
  | (class si1 ci1 fi1 mi1),(class si2 ci2 fi2 mi2)=> match (areSameSI si1 si2) with
    | true => true
    | false => match ci1 with
      | (classAt c1' n) => isSubClass c1' (class si2 ci2 fi2 mi2)
      end
    end
  end.

Definition areSameClass (c1 c2:Class) : bool :=
  (andb (isSubClass c1 c2) (isSubClass c2 c1)).

Fixpoint arePrim (n1:DalType) (n2:DalType) : (@Option bool) :=
  match n1 with
  | (refT x) => None
  | (primT x) => match n2 with
    | (refT y) => None
    | (primT y) => (Some true)
    end
  end.

Fixpoint areEqualNum (n1:nat) (n2:nat) : bool :=
  match n1 with
  | O => match n2 with
    | O => true
    | _ => false
    end
  | (S n1') => match n2 with
    | O => false
    | (S n2') => (areEqualNum n1' n2')
    end
  end.

Definition areSameCI (ci1 ci2:ClassIndex) : bool :=
  match ci1,ci2 with
  | (classAt c1 n1),(classAt c2 n2) => andb (areSameClass c1 c2) (areEqualNum n1 n2)
  end.

Fixpoint areEqualBool (b1 b2:bool) : bool :=
  match b1 , b2 with
  | true,true => true
  | false,false => true
  | _,_ => false
  end.

Fixpoint isle_num (m n:nat) : bool :=
  match m with
  | O => true
  | (S m') => match n with
    | O => false
    | (S n') => (isle_num m' n')
    end
  end.

Fixpoint div (m n:nat) {struct m} : nat :=
  match m with
  | O => O
  | (S m') => match (areEqualNum n (m - (mult (div m' n) n))) with
    | true => S (div m' n)
    | false => (div m' n)
    end
  end.

Compute (div 3 0).

Definition mod (m n:nat) : nat := m - (mult (div m n) n).

Compute (mod 3 2).

Fixpoint areEqualPrim (b1 b2:PrimType): (@Option bool) :=
  match b1,b2 with
  | boolean x,boolean y => Some (areEqualBool x y)
  | char x,char y => Some (areEqualNum x y)
  | int x,int y => Some (areEqualNum x y)
  | _,_ => None
  end.

Definition castIntToChar (n: nat) : nat := (mod n 128).

Definition castBoolToCharOrInt (b: bool) : nat :=
  match b with
  | true => 1
  | false => 0
  end.

Definition castCharOrIntToBool (n:nat) : bool :=
  (negb (areEqualNum n 0)).

Definition castToChar (x:PrimType) : nat :=
  match x with
  | char x' => x'
  | int x' => (castIntToChar x')
  | boolean x' => (castBoolToCharOrInt x')
  end.

Definition castToInt (x:PrimType) : nat :=
  match x with
  | char x' => x'
  | int x' => x'
  | boolean x' => (castBoolToCharOrInt x')
  end.

Definition castToBool (x:PrimType) : bool :=
  match x with
  | char x' => (castCharOrIntToBool x')
  | int x' => (castCharOrIntToBool x')
  | boolean x' => x'
  end.

Definition addPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (int (plus (castToInt n1) (castToInt n2))).

Definition subPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (int (minus (castToInt n1) (castToInt n2))).

Definition multPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (int (mult (castToInt n1) (castToInt n2))).

Definition divPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (int (div (castToInt n1) (castToInt n2))).

Definition modPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (int (mod (castToInt n1) (castToInt n2))).

Definition andPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (boolean (andb (castToBool n1) (castToBool n2))).

Definition orPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (boolean (orb (castToBool n1) (castToBool n2))).

Definition xorPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (boolean (xorb (castToBool n1) (castToBool n2))).

Definition eqPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (boolean (negb (xorb (castToBool n1) (castToBool n2)))).

Definition ltPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (boolean (isle_num ((castToInt n1) + 1) (castToInt n2))).

Definition gtPrims (n1 n2: PrimType) : (@Option PrimType) :=
  Some (boolean (isle_num ((castToInt n2) + 1) (castToInt n1))).

Definition notPrims (n1: PrimType) : (@Option PrimType) :=
  Some (boolean (negb (castToBool n1))).

Definition applyBinArOp (bop: BinaryArithOperator) (n1 n2: PrimType) : (@Option PrimType) :=
  match bop with
  | badd => (addPrims n1 n2)
  | bsub => (subPrims n1 n2)
  | bmult => (multPrims n1 n2)
  | bdiv => (divPrims n1 n2)
  | bmod => (modPrims n1 n2)
  | band => (andPrims n1 n2)
  | bor => (orPrims n1 n2)
  | bxor => (xorPrims n1 n2)
  end.

Definition applyBinCmpOp (bop: BinaryCompOperator) (n1 n2: PrimType) : (@Option PrimType) :=
  match bop with
  | beq => (eqPrims n1 n2)
  | blt => (ltPrims n1 n2)
  | bgt => (gtPrims n1 n2)
  end.

Definition applyUnOp (uop: UnaryOperator) (n1: PrimType) : (@Option PrimType) :=
  match uop with
  | unot => (notPrims n1)
  end.

Fixpoint getInstAtInsts (pc:ProgramCounter) (insts:clist Instruction) : (@Option Instruction) :=
  match insts with
  | [] => None
  | (n,ins)::xs => match (areEqualNum n pc) with
    | true => Some ins
    | false => (getInstAtInsts pc xs)
    end
  end.

Fixpoint getInstAtMIs (pc:ProgramCounter) (mis:list MethodIndex) : (@Option Instruction) :=
  match mis with
  | [] => None
  | (methodAt (method si ci tis ti n insts) _)::xs =>
    match (getInstAtInsts pc insts) with
    | None => (getInstAtMIs pc xs)
    | x => x
    end
  end.

Fixpoint getInstAt (pc:ProgramCounter) (p:Program) : (@Option Instruction) :=
  match p with
  | [] => None
  | (classAt top _)::xs => None
  | (classAt (class si ci fi mis) _)::xs =>
    match (getInstAtMIs pc mis) with
    | None => (getInstAt pc xs)
    | x => x
    end
  end.

Fixpoint getFirstPCMethod (mi:MethodIndex) : (@Option ProgramCounter) :=
  match mi with
  | (methodAt (method si ci tis ti n insts) _) =>
    match insts with
    | [] => None
    | (x,y)::rem => Some x
    end
  end.

Definition LocalReg : Type := (list (Register*Val)).

Inductive Frame : Type :=
  | frm : (MethodIndex * ProgramCounter * LocalReg) -> Frame.

Inductive ExcFrame : Type :=
  | exc : Location * MethodIndex * ProgramCounter -> ExcFrame.

Inductive callStack : Type :=
  | cf : Frame * list Frame -> callStack
  | ce : ExcFrame * list Frame -> callStack.

Inductive ValOrRef : Type :=
  | v : Val -> ValOrRef
  | a : arrOrObj -> ValOrRef.

Definition StaticHeap : Type := list (FieldIndex * ValOrRef).

Definition Heap : Type := list arrOrObj.

Inductive Config : Type :=
  | cnf : StaticHeap * Heap * callStack -> Config.

Fixpoint getPCconfig (init:Config) : ProgramCounter :=
  match init with
  | cnf (sh,h,(ce (exc (lc,mi,pc),lst))) => pc
  | cnf (sh,h,(cf (frm (mi,pc,lrg),lst))) => pc
  end.

Fixpoint updatePCconfig (init:Config) (pc:ProgramCounter) : Config :=
  match init with
  | cnf (sh,h,(ce (exc (lc,mi,pc'),lst))) => cnf (sh,h,(ce (exc (lc,mi,pc),lst)))
  | cnf (sh,h,(cf (frm (mi,pc',lrg),lst))) => cnf (sh,h,(cf (frm (mi,pc,lrg),lst)))
  end.

Definition updateLocalReg (r:Register) (v:Val) (lr:LocalReg): LocalReg := (r,v)::lr.

Fixpoint findInLocalReg (r:Register) (lr:LocalReg): (@Option Val) :=
  match lr with
  | [] => None
  | (x,y)::rem => match (x,r) with
    | ((Reg n1),(Reg n2)) => match (areEqualNum n1 n2) with
      | true => Some y
      | false => (findInLocalReg r rem)
      end
    end
  end.

Fixpoint regToValLocalRegs (r:Register) (lr:LocalReg) : (@Option Val) :=
  match lr with
  | nil => None
  | cons (r',val) rem => match (r,r') with
    | (Reg ri,Reg ri') => match (areEqualNum ri ri') with
      | true => Some val
      | false => (regToValLocalRegs r rem)
      end
    end
  end.

Fixpoint regToValFrame (r:Register) (f:Frame) : (@Option Val) :=
  match f with
  | frm (mi,pc,lr) => regToValLocalRegs r lr
  end.

Fixpoint regToValFrames (r:Register) (fL:list Frame) : (@Option Val) :=
  match fL with
  | nil => None
  | cons f rem =>  match (regToValFrame r f) with
    | None => (regToValFrames r rem)
    | x => x
    end
  end.

Fixpoint regToVal (r:Register) (conf:Config) : (@Option Val) :=
  match conf with
  | cnf (sh,h,(ce (eF,lst))) => (regToValFrames r lst)
  | cnf (sh,h,(cf (fm,lst))) => match (regToValFrame r fm) with
    | None => (regToValFrames r lst)
    | x => x
    end
  end.

Fixpoint refToVal (rf:Ref) (conf:Config) : (@Option arrOrObj) :=
  match rf,conf with
  | (lRef (locIn n)),(cnf (sh,h,cs)) => (nth n h)
  | _,_ => None
  end.

Fixpoint accToVal (r1 r2:Register) (conf:Config) : (@Option Val) :=
  match (regToVal r1 conf),(regToVal r2 conf) with
  | None,_ => None
  | Some (ref rf),Some (prim x) => match (refToVal rf conf) with
    | Some (ar (arr n vals)) => (nth (castToInt x) vals)
    | _ => None
    end
  | _,_ => None
  end.

Fixpoint areSameFI (fi1 fi2:FieldIndex) : bool :=
  match fi1,fi2 with
  | (fieldAt (field SI1 CI1) n1),(fieldAt (field SI2 CI2) n2) => andb (andb (areSameSI SI1 SI2) (areSameCI CI1 CI2)) (areEqualNum n1 n2)
  end.

Fixpoint findFI {X:Type} (fi:FieldIndex) (l:list (FieldIndex * X)) : (@Option X) :=
  match l with
  | nil => None
  | cons (fi',val) rem => match (areSameFI fi fi') with
    | true => Some val
    | false => findFI fi rem
    end
  end.

Fixpoint ifieldToVal (r1:Register) (fi:FieldIndex) (conf:Config) : (@Option Val) :=
  match (regToVal r1 conf) with
  | Some (ref rf) => match (refToVal rf conf) with
    | Some (ob (obj ci ci2 flst)) => (findFI fi flst)
    | _ => None
    end
  | _ => None
  end.

Fixpoint sfieldToVal (fi:FieldIndex) (conf:Config) : (@Option ValOrRef) :=
  match conf with
  | (cnf (sh,h,cs)) => (findFI fi sh)
  end.

Fixpoint ValToValOrRef (val:@Option Val) : (@Option ValOrRef) :=
  match val with
  | Some x => Some (v x)
  | None => None
  end.

Fixpoint ValOrRefToVal (val:@Option ValOrRef) : (@Option Val) :=
  match val with
  | Some (v x) => Some x
  | _ => None
  end.

Definition lhsToVal (l:lhs) (conf:Config) : (@Option ValOrRef):=
  match l with
  | (reg r) => ValToValOrRef (regToVal r conf)
  | (acc r1 r2) => ValToValOrRef (accToVal r1 r2 conf)
  | (ifield r1 fi) => ValToValOrRef (ifieldToVal r1 fi conf)
  | (sfield fi) => sfieldToVal fi conf
  end.

Definition lhsToReg (l:lhs) (r:Register) (conf:Config) : (@Option (Register*ValOrRef)) :=
  match (lhsToVal l conf) with
  | Some x => Some (r,x)
  | None => None
  end.

Definition constantToVal (c:Constant) : (@Option ValOrRef) :=
  match c with
  | cnat n => Some (v (prim (int n)))
  | cstr s => Some (v (siv s))
  | ctrue => Some (v (prim (boolean true)))
  | cfalse => Some (v (prim (boolean false)))
  | cnull => Some (v (ref null))
  end.

Fixpoint rhsToVal (r:rhs) (conf:Config) : (@Option ValOrRef) :=
  match r with
  | l ls => (lhsToVal ls conf)
  | c cnst => (constantToVal cnst)
  end.

Definition rhsToReg (r:rhs) (r1:Register) (conf:Config) : (@Option (Register*ValOrRef)) :=
  match (rhsToVal r conf) with
  | Some x => Some (r1,x)
  | None => None
  end.

Fixpoint setInLocalReg (r:Register) (lr:LocalReg) (vl:@Option Val) : (@Option LocalReg) :=
  match vl,lr with
  | None,_ => None
  | Some vl,[] => None
  | Some vl,cons (r',v') rem => match r,r' with
    | Reg n,Reg n' => match (areEqualNum n n') with
      | true => Some (cons (r',vl) rem)
      | false => match (setInLocalReg r rem (Some vl)) with
        | Some lr' => Some (cons (r',v') lr')
        | None => None
        end
      end
    end
  end.

Fixpoint valToRegFrame (r:Register) (f:Frame) (vl:@Option Val) : (@Option Frame) :=
  match f with
  | frm (mi,pc,lr) => match (setInLocalReg r lr vl) with
    | Some lr' => Some (frm (mi,pc,lr'))
    | _ => None
    end
  end.

Fixpoint valToRegFrames (r:Register) (fL:list Frame) (vl:@Option Val) : @Option (list Frame) :=
  match fL,vl with
  | _,None => None
  | nil,Some vl => None
  | cons f rem,Some vl =>  match (valToRegFrame r f (Some vl)) with
    | Some f' => Some (cons f' rem)
    | None => match (valToRegFrames r rem (Some vl)) with
      | Some rem' => Some (cons f rem')
      | None => None
      end
    end
  end.

Fixpoint valToReg (r:Register) (conf:Config) (vl:@Option Val) : (@Option Config) :=
  match conf with
  | cnf (sh,h,(ce (eF,lst))) => match (valToRegFrames r lst vl) with
    | Some lst' => Some (cnf (sh,h,(ce (eF,lst))))
    | None => None
    end
  | cnf (sh,h,(cf (fm,lst))) => match (valToRegFrame r fm vl) with
    | Some fm' => Some (cnf (sh,h,(cf (fm',lst))))
    | None => match (valToRegFrames r lst vl) with
      | Some lst' => Some (cnf (sh,h,(cf (fm,lst'))))
      | None => None
      end
    end
  end.

Fixpoint setNth {X:Type} (x:X) (n:nat) (l:list X) : (@Option (list X)) :=
  match l,n with
  | [],_ => None
  | (cons x' rem),0 => Some (cons x rem)
  | (cons x' rem),S n' => match (setNth x n' rem) with
    | None => None
    | Some rem' => Some (cons x' rem')
    end
  end.

Fixpoint setAtRef (rf:Ref) (conf:Config) (vl:@Option arrOrObj) : (@Option Config) :=
  match rf,conf,vl with
  | (lRef (locIn n)),(cnf (sh,h,cs)),Some vl => match (setNth vl n h) with
    | Some h' => Some (cnf (sh,h',cs))
    | _ => None
    end
  | _,_,_ => None
  end.

Fixpoint valToAcc (r1 r2:Register) (conf:Config) (vl:@Option Val) : (@Option Config) :=
  match (regToVal r1 conf),(regToVal r2 conf),vl with
  | None,_,_ => None
  | Some (ref rf),Some (prim x),Some vl => match (refToVal rf conf) with
    | Some (ar (arr n vals)) => match (setNth vl (castToInt x) vals) with
      | None => None
      | Some vals' => (setAtRef rf conf (Some (ar (arr n vals'))))
      end
    | _ => None
    end
  | _,_,_ => None
  end.

Fixpoint setAtFI {X:Type} (x:X) (fi:FieldIndex) (l:list (FieldIndex * X)) : (@Option (list (FieldIndex * X))) :=
  match l with
  | nil => None
  | cons (fi',x') rem => match (areSameFI fi fi') with
    | true => Some (cons (fi',x) rem)
    | false => match (setAtFI x fi rem) with
      | Some rem' => Some (cons (fi',x') rem')
      | _ => None
      end
    end
  end.

Fixpoint valToIfield (r1:Register) (fi:FieldIndex) (conf:Config) (vl:@Option Val) : (@Option Config) :=
  match (regToVal r1 conf) with
  | Some (ref rf) => match (refToVal rf conf),vl with
    | Some (ob (obj ci ci2 flst)),Some vl => match (setAtFI vl fi flst) with
      | Some flst' => (setAtRef rf conf (Some (ob (obj ci ci2 flst'))))
      | _ => None
      end
    | _,_ => None
    end
  | _ => None
  end.

Fixpoint valToSfield (fi:FieldIndex) (conf:Config) (vl:@Option ValOrRef) : (@Option Config) :=
  match conf,vl with
  | (cnf (sh,h,cs)),Some vl => match (setAtFI vl fi sh) with
    | Some sh' => Some (cnf (sh',h,cs))
    | _ => None
    end
  | _,_ => None
  end.

Definition newPrim (pt:pTypes) : PrimType :=
  match pt with
  | bT => (boolean false)
  | cT => (char 0)
  | iT => (int 0)
  end.

Fixpoint createList {X:Type} (n:nat) (x:X) : list X :=
  match n with
  | 0 => nil
  | S n' => cons x (createList n' x)
  end.

Definition newArrPrim (n:nat) (pt:pTypes) : Array :=
  arr n (createList n (prim (newPrim pt))).

(*Fixpoint newObject (c:Class) : Object :=
  match c with
  | top => topObject
  | (class SI CI FIs MIs) =>
*)

Fixpoint newInstance (t:DalType) : (ValOrRef) :=
  match t with
  | (primT pt) => (v (prim (newPrim pt)))
  | (refT (cls cl)) => (v (ref null))    (*(a (ob (newObject c))) *)
  | (refT (arrRef rt n)) => (v (ref null)) (* (a (ar (newArrRef rt))) *)
  | (refT (arrPrim pt n)) => (a (ar (newArrPrim n pt)))
  end.

with

Fixpoint step (init:Config) (p:Program): (@Option Config) :=
  match (getInstAt (getPCconfig init) p) with
  | None => None
  | Some x => match x with
    | nop => Some (updatePCconfig init ((getPCconfig init)+1))
    | (goto pc) => Some (updatePCconfig init pc)
    | (invoke args m) =>
    | x => None
    end
  end.