(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Compare_dec.
Require Import ZArith.
Require Import Utils.
Require Import BrandRelation.
Require Import ForeignData.
Require Import Data.
Require Import DataLift.
Require Import DataNorm.
Require Import ForeignOperators.
Require Import Iterators.
Require Import RecOperators.
Require Import OperatorsUtils.
Require Import SortBy.
Require Export UnaryOperators.

Section UnaryOperatorsSem.
  Context {fdata:foreign_data}.

  Definition nat_arith_unary_op_eval (op:nat_arith_unary_op) (z:Z) :=
    match op with
    | NatAbs => Z.abs z
    | NatLog2 => Z.log2 z
    | NatSqrt => Z.sqrt z
    end.

  Definition float_arith_unary_op_eval (op:float_arith_unary_op) (f:float) :=
    match op with
    | FloatNeg => float_neg f
    | FloatSqrt => float_sqrt f
    | FloatExp => float_exp f
    | FloatLog => float_log f
    | FloatLog10 => float_log10 f
    | FloatCeil => float_ceil f
    | FloatFloor => float_floor f
    | FloatAbs => float_absolute f
    end.

  Context (h:brand_relation_t).
  Context {foperators:foreign_operators}.

  Global Instance ToString_data : ToString data
    := { toString := foreign_operators_unary_data_tostring }.

  Fixpoint defaultDataToString (d:data) : string
    := match d with
       | dunit => "unit"%string
       | dnat n => toString n
       | dfloat n => toString n
       | dbool b => toString b
       | dstring s => stringToString s
       | dcoll l => string_bracket
                      "["%string
                      (String.concat ", "%string
                              (map defaultDataToString l))
                      "]"%string
       | drec lsd => string_bracket
                       "{"%string
                       (String.concat ", "%string
                               (map (fun xy => let '(x,y):=xy in
                                               (append (stringToString x) (append "->"%string
                                                                                (defaultDataToString y)))
                                    ) lsd))
                       "}"%string
       | dleft d => string_bracket
                      "Left("%string
                      (defaultDataToString d)
                      ")"%string
       | dright d => string_bracket
                       "Right("%string
                       (defaultDataToString d)
                       ")"%string
       | dbrand b d => (string_bracket
                          "<"
                          (append (@toString _ ToString_brands b)
                                  (append ":" (defaultDataToString d)))
                          ">")
       | dforeign fd => toString fd
       end.

  Definition unary_op_eval (uop:unary_op) (d:data) : option data :=
    match uop with
    | OpIdentity => Some d
    | OpNeg => unudbool negb d
    | OpRec s => Some (drec ((s,d) :: nil))
    | OpDot s =>
      match d with
      | drec r => edot r s
      | _ => None
      end
    | OpRecRemove s =>
      match d with
      | drec r => Some (drec (rremove r s))
      | _ => None
      end
    | OpRecProject sl =>
      match d with
      | drec r => Some (drec (rproject r sl))
      | _ => None
      end
    | OpBag => Some (dcoll (d :: nil))
    | OpSingleton =>
      match d with
      | dcoll (d'::nil) => Some (dsome d')
      | dcoll _ => Some dnone
      | _ => None
      end
    | OpFlatten =>
      lift_oncoll (fun l => (lift dcoll (oflatten l))) d
    | OpDistinct =>
      rondcoll (@bdistinct data data_eq_dec) d
    | OpOrderBy sc =>
      data_sort sc d (* XXX Some very limited/hackish sorting XXX *)
    | OpCount =>
      lift dnat (ondcoll (fun z => Z_of_nat (bcount z)) d)
    | OpToString =>
      Some (dstring (foreign_operators_unary_data_tostring d))
    | OpToText =>
      Some (dstring (foreign_operators_unary_data_totext d))
    | OpLength =>
      unndstring (fun s => Z_of_nat (String.length s)) d
    | OpSubstring start olen =>
      match d with
      | dstring s =>
        Some (dstring (
                  let real_start :=
                      (match start with
                       | 0%Z => 0
                       | Z.pos p => Pos.to_nat p
                       | Z.neg n => (String.length s) - (Pos.to_nat n)
                       end) in
                  let real_olen :=
                      match olen with
                      | Some len =>
                        match len with
                        | 0%Z => 0
                        | Z.pos p => Pos.to_nat p
                        | Z.neg n => 0
                        end
                      | None => (String.length s) - real_start
                      end in
                  (substring real_start real_olen s)))
      | _ => None
      end
    | OpLike pat =>
      match d with
      | dstring s => Some (dbool (string_like s pat None))
      | _ => None
      end
    | OpLeft => Some (dleft d)
    | OpRight => Some (dright d)
    | OpBrand b => Some (dbrand (canon_brands h b) d)
    | OpUnbrand =>
      match d with
      | dbrand _ d' => Some d'
      | _ => None
      end
    | OpCast b =>
      match d with
      | dbrand b' _ =>
        if (sub_brands_dec h b' b)
        then
          Some (dsome d)
        else
          Some (dnone)
      | _ => None
      end
    | OpNatUnary op =>
      match d with
      | dnat n => Some (dnat (nat_arith_unary_op_eval op n))
      | _ => None
      end
    | OpNatSum =>
      lift dnat (lift_oncoll dsum d)
    | OpNatMin =>
      match d with
      | dcoll l => lifted_min l
      | _ => None
      end
    | OpNatMax =>
      match d with
      | dcoll l => lifted_max l
      | _ => None
      end
    | OpNatMean =>
      lift dnat (lift_oncoll darithmean d)
    | OpFloatOfNat =>
      match d with
      | dnat n => Some (dfloat (float_of_int n))
      | _ => None
      end
    | OpFloatUnary op =>
      match d with
      | dfloat n => Some (dfloat (float_arith_unary_op_eval op n))
      | _ => None
      end
    | OpFloatTruncate =>
      match d with
      | dfloat f => Some (dnat (float_truncate f))
      | _ => None
      end
    | OpFloatSum =>
      lift_oncoll lifted_fsum d
    | OpFloatMean =>
      lift_oncoll lifted_farithmean d
    | OpFloatBagMin =>
      lift_oncoll lifted_fmin d
    | OpFloatBagMax =>
      lift_oncoll lifted_fmax d
    | OpForeignUnary fu => foreign_operators_unary_interp h fu d
    end.

  Lemma data_normalized_edot l s o :
    edot l s = Some o ->
    data_normalized h (drec l) ->
    data_normalized h o.
  Proof.
    unfold edot.
    inversion 2; subst.
    apply assoc_lookupr_in in H.
    rewrite Forall_forall in H2.
    specialize (H2 _ H).
    simpl in *; trivial.
  Qed.

  Lemma data_normalized_filter l :
    data_normalized h (drec l) ->
    forall f, data_normalized h (drec (filter f l)).
  Proof.
    inversion 1; subst; intros.
    constructor.
    - apply Forall_filter; trivial.
    - apply (@sorted_over_filter string ODT_string); trivial.
  Qed.

  Lemma data_normalized_rremove l :
    data_normalized h (drec l) ->
    forall s, data_normalized h (drec (rremove l s)).
  Proof.
    unfold rremove; intros.
    apply data_normalized_filter; trivial.
  Qed.

   Lemma data_normalized_rproject l :
    data_normalized h (drec l) ->
    forall l2, data_normalized h (drec (rproject l l2)).
  Proof.
    unfold rremove; intros.
    unfold rproject.
    apply data_normalized_filter; trivial.
  Qed.

  Lemma data_normalized_bdistinct l :
    data_normalized h (dcoll l) -> data_normalized h (dcoll (bdistinct l)).
  Proof.
    inversion 1; subst.
    constructor.
    apply bdistinct_Forall; trivial.
  Qed.

  Lemma dnnone : data_normalized h dnone.
  Proof.
    repeat constructor.
  Qed.

  Lemma dnsome d :
    data_normalized h d ->
    data_normalized h (dsome d).
  Proof.
    repeat constructor; trivial.
  Qed.

  Hint Constructors data_normalized Forall : qcert.
  Hint Resolve dnnone dnsome : qcert.

  Lemma unary_op_eval_normalized {u d o} :
    unary_op_eval u d = Some o ->
    data_normalized h d ->
    data_normalized h o.
  Proof.
    unary_op_cases (destruct u) Case; simpl;
    try solve [inversion 1; subst; eauto 3 with qcert
              | destruct d; inversion 1; subst; eauto 3 with qcert].
    - Case "OpDot"%string.
      destruct d; try discriminate.
      intros. eapply data_normalized_edot; eauto.
    - Case "OpRecRemove"%string.
      destruct d; try discriminate.
      inversion 1; subst.
      intros; apply data_normalized_rremove; eauto.
    - Case "OpRecProject"%string.
      destruct d; try discriminate.
      inversion 1; subst.
      intros; apply data_normalized_rproject; eauto.
    - Case "OpSingleton"%string.
      destruct d; simpl; try discriminate.
      destruct l.
      + inversion 1. inversion 1; subst; qeauto.
      + destruct l; inversion 1; subst; eauto 2 with qcert.
        rewrite <- data_normalized_dcoll; intros [??]; qeauto.
    - Case "OpFlatten"%string.
      destruct d; simpl; try discriminate.
      unfold oflatten.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      intros.
      inversion H; subst.
      constructor.
      apply (lift_flat_map_Forall e H1); intros.
      match_destr_in H0.
      inversion H0; subst.
      inversion H2; trivial.
    - Case "OpDistinct"%string.
      destruct d; try discriminate.
      unfold rondcoll.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      simpl in *. inversion e; subst.
      intros; apply data_normalized_bdistinct; trivial.
    - Case "OpOrderBy"%string.
      apply data_sort_normalized.
    - Case "OpUnbrand"%string.
      destruct d; simpl; try discriminate.
      inversion 1; subst.
      inversion 1; subst; trivial.
    - Case "OpCast"%string.
      destruct d; simpl; try discriminate.
      match_destr; inversion 1; subst; qeauto.
    - Case "OpNatSum"%string.
      destruct d; simpl; try discriminate.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      qeauto.
    - Case "OpNatMin"%string.
      destruct d; simpl; try discriminate.
      unfold lifted_min.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      qeauto.
    - Case "OpNatMax"%string.
      destruct d; simpl; try discriminate.
      unfold lifted_min.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      qeauto.
    - Case "OpNatMean"%string.
      destruct d; simpl; try discriminate.
      intros.
      apply some_lift in H.
      destruct H as [???]; subst.
      qeauto.
    - Case "OpFloatSum"%string.
      destruct d; simpl; try discriminate.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      qeauto.
    - Case "OpFloatMean"%string.
      destruct d; simpl; try discriminate.
      intros.
      apply some_lift in H.
      destruct H as [???]; subst.
      qeauto.
    - Case "OpFloatBagMin"%string.
      destruct d; simpl; try discriminate.
      unfold lifted_min.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      qeauto.
    - Case "OpFloatBagMax"%string.
      destruct d; simpl; try discriminate.
      unfold lifted_min.
      intros ll; apply some_lift in ll.
      destruct ll; subst.
      qeauto.
    - Case "OpForeignUnary"%string.
      intros eqq dn.
      eapply foreign_operators_unary_normalized in eqq; eauto.
  Qed.

End UnaryOperatorsSem.


Require Import Event_system Term_system ConcreteEvidence Cvm_St.
Require Import Cvm_Impl Helpers_CvmSemantics CvmSemantics.
Require Import Axioms_Io External_Facts Auto AutoApp.

Require Import Appraisal_Defs Impl_appraisal_alt.

Require Import Anno_Term_Defs.

Require Import Coq.Arith.Peano_dec.

Require Import StructTactics Appraisal_Evidence Helpers_Appraisal.

Require Import Lia Coq.Program.Tactics Coq.Program.Equality.

Require Import List.
Import ListNotations.

(*
Set Nested Proofs Allowed.
 *)

Lemma ggc_app: forall p0 sigbs H4 e',
    EvSub (ggc p0 sigbs H4) e' ->
    exists e'',
      EvSub
        (ggc p0 (checkSigF H4 p0 sigbs) e'')
        (build_app_comp_evC e').
Proof.
  intros.
  generalizeEverythingElse e'.
  induction e'; intros;
    ff.
  -
    evSubFacts.
    edestruct IHe'; eauto.
  -
    ff.
    invc H.
    +
      exists ((build_app_comp_evC e')).
      econstructor.
    +
      edestruct IHe'; eauto.

  -
    evSubFacts.
    +
      edestruct IHe'1; eauto.
    +
      edestruct IHe'2; eauto.
  -
    evSubFacts.
    +
      edestruct IHe'1; eauto.
    +
      edestruct IHe'2; eauto.
Defined.

Lemma appraisal_correct_sig : forall t annt e e' p ev,
    annoP annt t ->
    not_none_none t ->
    not_hash_sig_term_ev t e ->
    cvm_evidence_denote annt p e = e' ->

    sigEvent annt p (et_fun e) ev ->
    appEvent_Sig_EvidenceC ev (build_app_comp_evC e').
Proof.
  intros.
  sigEventFacts.
  sigEventPFacts.

  edestruct gg_preserved'.
  2: { eassumption. }
  2: { eassumption. }
  eassumption.
  eassumption.
  reflexivity.

  destruct_conjs.

  edestruct ggc_app.
  eassumption.

  econstructor.
  dd.
  eassumption.
Defined.

Lemma appraisal_correct : forall t annt e' p ev e,
    annoP annt t ->
    not_none_none t ->
    cvm_evidence_denote annt p e = e' ->
    measEvent annt p (et_fun e) ev ->
    appEvent_EvidenceC ev (build_app_comp_evC e').
Proof.
  intros.
  measEventFacts.
  evEventFacts.
  edestruct uu_preserved'.
  eassumption.
  eassumption.
  eassumption.
  reflexivity.

  destruct_conjs.
    (*
    assert (e0 = et_fun H2).
    {
      Search (_ = et_fun _).
      eapply etfun_reconstruct; eauto.
    }
    subst.
     *)

  apply uuc_app in H5.

  assert (e0 = et_fun H2).
  {
    eapply etfun_reconstruct; eauto.
  }
  subst.
  assert (H1 = encodeEv H2).
  {

    eapply recon_encodeEv.
    eapply wf_recon.
    eassumption.
    eassumption.
  }
  rewrite H6 in *.

  eapply aeuc.
  eassumption.
  destruct_conjs.

   eapply ahuc.
    eassumption.
    eapply hhc_app.
    eassumption.
Defined.

Require Import Impl_appraisal Appraisal_AltImpls_Eq.

Lemma appraisal_correct_sig_alt :
  forall t annt pt e e' tr tr' p p' bits' et' ev ee i i',
    anno_parP pt t ->
    annoP_indexed annt t i i' ->
    well_formed_r_annt annt ->
    not_none_none t ->
    not_hash_sig_term_ev t e ->
    wf_ec ee ->
    reconstruct_evP ee e ->
    copland_compile pt
                    {| st_ev := ee; st_trace := tr; st_pl := p; st_evid := i |} =
    (Some tt, {| st_ev := (evc bits' et');
                 st_trace := tr';
                 st_pl := p';
                 st_evid := i'|}) ->

    sigEvent annt p (get_et ee) ev ->
    Some e' = Impl_appraisal.build_app_comp_evC et' bits' ->
    appEvent_Sig_EvidenceC ev e'.
Proof.
  intros.
  wrap_ccp.
  do_wfec_preserved.
  do_somerecons.
  destruct ee.
  assert (et_fun e = e0).
  {
    symmetry.
    eapply etfun_reconstruct.
    eauto.
  }
  subst.

  erewrite appraisal_alt.
  eapply appraisal_correct_sig.
  econstructor. repeat eexists. invc H0. eassumption.
  eassumption.
  eassumption.

  eapply cvm_raw_evidence_denote_fact; eauto.
  eassumption.
  eassumption.
  eassumption.
  reflexivity.
Defined.

Lemma appraisal_correct_sig_alt_et :
  forall t annt pt bits et et' et'' e e' tr tr' p p' bits' ev i i',
    anno_parP pt t ->
    annoP_indexed annt t i i' ->
    well_formed_r_annt annt ->
    not_none_none t ->
    not_hash_sig_term_ev t e ->
    wf_ec (evc bits et) ->
    et' = aeval annt p et ->
    reconstruct_evP (evc bits et) e ->
    copland_compile pt
                    {| st_ev := (evc bits et); st_trace := tr; st_pl := p; st_evid := i |} =
    (Some tt, {| st_ev := (evc bits' et'');
                 st_trace := tr';
                 st_pl := p';
                 st_evid := i'|}) ->

    sigEvent annt p et ev ->
    Some e' = Impl_appraisal.build_app_comp_evC et' bits' ->
    appEvent_Sig_EvidenceC ev e'.
Proof.
  intros.
  wrap_ccp.
  assert (et'' =  (aeval annt p et)).
  {
    rewrite <- eval_aeval'.

    assert (t = unanno annt).
    {
      invc H0.
      erewrite <- anno_unanno at 1.
      rewrite H5.
      tauto.
    }
    subst.

    eapply cvm_refines_lts_evidence.
    eassumption.
    eassumption.
  }

  subst.
  invc H7.
  eapply appraisal_correct_sig_alt; eauto.
Defined.

Lemma appraisal_correct_alt :
  forall t annt pt e' tr tr' p p' bits' et' ev ee i i',
    anno_parP pt t ->
    annoP_indexed annt t i i' ->
    well_formed_r_annt annt ->
    not_none_none t ->
    wf_ec ee ->
    copland_compile pt
                    {| st_ev := ee; st_trace := tr; st_pl := p; st_evid := i |} =
    (Some tt, {| st_ev := (evc bits' et');
                 st_trace := tr';
                 st_pl := p'; st_evid := i' |}) ->

    measEvent annt p (get_et ee) ev ->
    Some e' = Impl_appraisal.build_app_comp_evC et' bits' ->
    appEvent_EvidenceC ev e'.
Proof.
  intros.
  wrap_ccp.
  do_wfec_preserved.
  do_somerecons.
  destruct ee.
  assert (e = et_fun H9).
  {
    eapply etfun_reconstruct.
    eauto.
  }
  subst.

  erewrite appraisal_alt.
  eapply appraisal_correct.
  econstructor. repeat eexists. invc H0. eassumption.
  eassumption.
  eapply cvm_raw_evidence_denote_fact; eauto.

  eassumption.
  eassumption.
  eassumption.
  reflexivity.
Defined.

Lemma appraisal_correct_alt_et :
  forall t annt pt e' tr tr' p p' bits bits' et et' et'' ev i i',
    anno_parP pt t ->
    annoP_indexed annt t i i' ->
    well_formed_r_annt annt ->
    not_none_none t ->
    wf_ec (evc bits et) ->
    et' = aeval annt p et ->
    copland_compile pt
                    {| st_ev := (evc bits et); st_trace := tr; st_pl := p; st_evid := i |} =
    (Some tt, {| st_ev := (evc bits' et'');
                 st_trace := tr';
                 st_pl := p';
                 st_evid := i'|}) ->

    measEvent annt p et ev ->
    Some e' = Impl_appraisal.build_app_comp_evC et' bits' ->
    appEvent_EvidenceC ev e'.
Proof.
  intros.
  wrap_ccp.
  assert (et'' = (aeval annt p et)).
  {
    assert (t = unanno annt).
    {
      invc H0.
      erewrite <- anno_unanno at 1.
      rewrite H4.
      tauto.
    }
    subst.

    erewrite <- eval_aeval'.
    eapply cvm_refines_lts_evidence.
    eassumption.
    eassumption.
  }

  subst.

  eapply appraisal_correct_alt.
  6: {
    wrap_ccp.
    eassumption.
  }
  eauto.
  eauto.
  eauto.
  eauto.
  eauto.
  eauto.
  eauto.
Defined.


Require Import TLA.
Require Import Rules.
Require Import Arith.
Require Import ZArith.
Require Import Omega.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Basic.
Require Import Rules.

Open Scope tla.

Inductive Mode := Record | Play.

Module Type MemParams <: BasicParams.
  Parameter PatternIsh : Type.
  Parameter IsPattern : PatternIsh -> Prop.
  Parameter NilPattern : PatternIsh.
  Parameter NilPatternPattern : IsPattern NilPattern.
  Parameter EqNilPatternClassical : forall p, IsPattern p -> p = NilPattern \/ p <> NilPattern.
  Parameter MaxMemoryLen : nat.
  Parameter MaxMemoryLenGtZ : (0 < MaxMemoryLen)%nat.

  Fixpoint IsListPattern (ls : list PatternIsh) : Prop :=
    match ls with
      | nil => True
      | (cons h tl) => IsPattern h /\ IsListPattern tl
    end.

End MemParams.

Module ParamsFromMem (Params : MemParams) <: BasicParams.
  Definition PatternIsh := list Params.PatternIsh.
  Definition IsPattern := Params.IsListPattern.
  Definition NilPattern : PatternIsh := nil.
  Theorem NilPatternPattern : IsPattern NilPattern.
  Proof.
    unfold IsPattern, NilPattern.
    simpl. auto.
  Qed.
  Theorem EqNilPatternClassical : forall p, IsPattern p -> p = NilPattern \/ p <> NilPattern.
  Proof.
    intros p H.
    unfold NilPattern, IsPattern.
    destruct p. left; auto. right; intros F; inversion F.
  Qed.
End ParamsFromMem.

Module Memory (Params : MemParams).
  Import Params.

  Hint Resolve NilPatternPattern.

  Record St := {
      ready : bool;
      status : MemStatus;
      mode : Mode;
      memory : list PatternIsh;
      output : list PatternIsh}.

  Section Model.
    Variable st st' : St.
    Let ready' := (st').(ready). Let ready := st.(ready).
    Let status' := (st').(status). Let status := st.(status).
    Let mode' := (st').(mode). Let mode := st.(mode).
    Let memory' := (st').(memory). Let memory := st.(memory).
    Let output' := (st').(output). Let output := st.(output).

    Definition TypeInvariant := IsListPattern memory /\ IsListPattern output.

    Definition Initialize :=
      ready = false
      /\ ready' = true
      /\ (mode = Play -> output = nil)
      /\ match status' with
          | Valid => mode' = Record /\ memory' = nil
          | _ => mode' = mode /\ memory' = memory
         end
      /\ output' = output.

    Definition Reset :=
      ready' = false
      /\ memory' = nil
      /\ output' = nil
      /\ ignore st.

    Definition Flush :=
      ready = true
      /\ status = Valid
      /\ mode = Record
      /\ memory' = nil
      /\ output' = nil
      /\ ready' = ready
      /\ status' = status
      /\ mode' = mode.

    Definition Write p :=
      ready = true
      /\ status = Valid
      /\ mode = Record
      /\ (length memory < MaxMemoryLen)%nat
      /\ (p <> NilPattern -> memory' = cons p memory)
      /\ (p = NilPattern -> memory' = memory)
      /\ ready' = ready
      /\ status' = status
      /\ mode' = mode
      /\ output' = output.

    Definition StartPlay :=
      ready = true
      /\ status = Valid
      /\ mode = Record
      /\ output = nil
      /\ memory <> nil
      /\ mode' = Play
      /\ ready' = ready /\ status' = status /\ memory' = memory /\ output' = output.

    Definition DoPlay :=
      ready = true
      /\ status = Valid
      /\ mode = Play
      /\ exists h t, memory = cons h t
      /\ memory' = t
      /\ output' = cons h output
      /\ ready' = ready /\ status'= status /\ mode' = mode.

    Definition EndPlay :=
      ready = true
      /\ status = Valid
      /\ mode = Play
      /\ memory = nil
      /\ mode' = Record
      /\ output' = output
      /\ ready' = ready /\ status' = status /\ memory' = memory.

    Definition PowerOn :=
      ready = false
      /\ IsListPattern memory
      /\ (length memory <= MaxMemoryLen)%nat
      /\ output = nil.

    Definition Next :=
      Initialize
      \/ Reset
      \/ Flush
      \/ (exists p, IsPattern p /\ Write p)
      \/ StartPlay
      \/ DoPlay
      \/ EndPlay.
  End Model.

  Definition Fairness :=
     WF Initialize
     `/\ WF DoPlay
     `/\ WF EndPlay.

  Definition Spec := ` PowerOn `/\ [][Next] `/\ Fairness.

  Lemma Next_TypeInvariant : forall st st', TypeInvariant st
      -> Next st st' -> TypeInvariant st'.
  Proof.
    intros st st' tst next.
    unfold TypeInvariant in *.
    destruct tst as (memst,patst).
    destruct st, st'. simpl in *.
    destruct next as [
      (H0,(H1,(H2,(H3,H4))))
      |[(H0,(H1,(H2,H3)))
      |[(H0,(H1,(H2,(H3,(H4,(H5,(H6,H7)))))))
      |[(p,(isPatP,(H0,(H1,(H2,(H3,(H4,(H5,(H6,(H7,(H8,H9)))))))))))
      |[(H0,(H1,(H2,(H3,(H4,(H5,(H6,(H7,(H8,H9)))))))))
      |[(H0,(H1,(H2,(h,(t,(H4,(H5,(H6,(H7,(H8,H9))))))))))
      |(H0,(H1,(H2,(H3,(H4,(H5,(H6,(H7,H8))))))))
    ]]]]]];
    simpl in *.
    destruct status1; destruct H3 as (H3,H5); rewrite H5; rewrite H4; repeat split; auto.
    rewrite H1, H2; repeat split; auto.
    rewrite H3, H4; repeat split; auto.
    rewrite H9; split; auto.
    assert (H : p = NilPattern \/ p <> NilPattern). apply EqNilPatternClassical. auto.
    destruct H as [H|H]. apply H5 in H. rewrite H. auto.
    apply H4 in H. rewrite H. split; auto.
    rewrite H8, H9; repeat split; auto.
    rewrite H4 in memst. destruct memst as (iPt,memst).
    rewrite H6, H5; repeat split; auto.
    rewrite H8. rewrite H5. repeat split; auto.
  Qed.

  Theorem Spec_TypeInvariant : valid (Spec `=> [] ` TypeInvariant).
  Proof.
    apply tla_inv_gen.
    intros s H. destruct H as (H,_).
    unfold PowerOn, TypeInvariant in *; simpl in *.
    destruct H as (_,(H,(_,H0))). rewrite H0. repeat split; auto.
    intros s. apply Next_TypeInvariant.
  Qed.
(*
  Definition ValidIsDefined st := (st.(ready) = true /\ st.(status) = Valid)
                                  -> exists lst, st.(memory) = lst.

  Lemma Next_ValidIsDefined : forall st st', ValidIsDefined st -> Next st st'
    -> ValidIsDefined st'.
  Proof.
    intros st st' valDef next H.
    destruct H as (H,H0).
    unfold ValidIsDefined in *.
    destruct next as [
    (_,(_,(H1,_)))
    |[(H1,_)
    |[(_,(_,(_,(H1,_))))
    |[(p,(isPatp,(memls,(H1,(_,(_,(_,(_,(H2,(H3,_))))))))))
    |[(H1,(H2,(_,(_,(_,(_,(_,(H3,_))))))))
    |[(_,(_,(_,(_,(t,(_,(H1,_)))))))
    |(_,(_,(_,(H1,(_,(_,(_,(_,H2))))))))]]]]]]; simpl in *.
    apply H1 in H0. destruct H0 as (_,H0). exists nil. auto.
    rewrite H1 in H. inversion H.
    exists nil. auto.
    assert (H4 : p = NilPattern \/ p <> NilPattern). apply EqNilPatternClassical; auto.
    destruct H4 as [H4|H4]. exists memls. apply H3 in H4. rewrite H4. auto.
    exists ((p :: memls)%list). apply H2 in H4. auto.
    rewrite H3. apply valDef. split; auto.
    exists t. auto.
    rewrite H2. exists nil; auto.
  Qed.

  Theorem Spec_ValidIsDefined : valid (Spec `=> [] ` ValidIsDefined).
  Proof.
    apply tla_inv_gen.
    intros s H H0. destruct H0 as (H0,H1). destruct H as ((H,_),_). rewrite H0 in H.
    inversion H.
    intros s. simpl. apply Next_ValidIsDefined.
  Qed.
*)
  Module FROMMEM := ParamsFromMem (Params).
  Module BASIC := Basic.Basic (FROMMEM).

  Definition refinement_mapping (st : St) : BASIC.St :=
    match st with
      | {|  ready := ready0;
            status := status0;
            memory := memory0;
            mode := mode0;
            output := output0 |} =>
              {|  BASIC.ready := ready0;
                  BASIC.status := status0;
                  BASIC.memory := match mode0 with
                                  | Record => memory0
                                  | Play => ((List.rev output0) ++ memory0)%list
                                  end;
                  BASIC.output := match mode0 with
                                  | Record => List.rev output0
                                  | Play => nil
                                  end |}
    end.

  Lemma Next_refinement : forall st st', TypeInvariant st -> Next st st' ->
      (BASIC.Next (refinement_mapping st) (refinement_mapping st') \/
      (refinement_mapping st = refinement_mapping st')).
  Proof.
    intros st st' typInv next.
    unfold Next, BASIC.Next in *.
    destruct next as [
      (H0,(H1,(H2,(H3,H4))))
      |[(H0,(H1,(H2,H3)))
      |[(H0,(H1,(H2,(H3,(H4,(H5,(H6,H7)))))))
      |[(p,(isPatP,(H0,(H1,(H2,(H3,(H4,(H5,(H6,(H7,(H8,H9)))))))))))
      |[(H0,(H1,(H2,(H3,(H4,(H5,(H6,(H7,(H8,H9)))))))))
      |[(H0,(H1,(H2,(h,(t,(H4,(H5,(H6,(H7,(H8,H9))))))))))
      |(H0,(H1,(H2,(H3,(H4,(H5,(H6,(H7,H8))))))))
    ]]]]]].

    left. left.
    unfold BASIC.Initialize.
    destruct st, st'; simpl in *. rewrite <- H0, H1, H4.
    destruct status1; repeat split; auto; destruct H3 as (H3,H5);
    try (rewrite H3); try (rewrite H5); auto.
    destruct mode0; auto; intuition; rewrite H; auto.

    left. right. left.
    unfold BASIC.Reset, ignore.
    destruct st, st'; simpl in *. rewrite H0, H1, H2; simpl.
    destruct mode1; repeat split; auto.

    left. right. right. left.
    unfold Flush, BASIC.Flush in *.
    destruct st, st'; simpl in *.
    rewrite H7.
    rewrite H6, H5, H4, H3, H2, H1. repeat split; auto.

    left. right. right. right. left.
    unfold Write, BASIC.Write in *.
    assert (H10 : p = NilPattern \/ p <> NilPattern). apply EqNilPatternClassical; auto.
    destruct st, st'; simpl in *.
    rewrite H8. rewrite H0, H1, H2, H6, H7, H9, H1.
    destruct H10 as [H10|H10].
    apply H5 in H10.
    rewrite H10. exists FROMMEM.NilPattern; intuition.
    apply H4 in H10. rewrite H10.
    destruct typInv as (ty,_). simpl in ty.
    exists ((p :: memory0)%list). repeat split; auto. intros H; inversion H.

    right.
    destruct st, st'. simpl in *.
    rewrite H9, H8, H7, H6, H5, H3, H2, H1, H0. simpl in *.
    auto.

    right.
    destruct st, st'. simpl in *.
    rewrite H9, H8, H7, H6, H5, H4, H2, H1, H0.
    simpl.
    rewrite <- List.app_assoc.
    simpl. auto.

    left. right. right. right. right.
    unfold BASIC.Run.
    destruct st, st'; simpl in *.
    rewrite H8, H7, H6, H5, H4, H3, H2, H1, H0.
    repeat split; auto.
    rewrite List.app_nil_r. auto.
    rewrite List.app_nil_r in H. auto.
  Qed.

End Memory.


(** * Propositional self-duality of groupoid categories *)
Require Import Category.Core GroupoidCategory.Core Category.Paths Category.Dual.
Require Import HoTT.Types HoTT.UnivalenceImpliesFunext.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.

Lemma path_groupoid_dual `{Univalence} `{IsTrunc 1 X}
: (groupoid_category X)^op = groupoid_category X.
Proof.
  repeat match goal with
           | _ => intro
           | _ => progress cbn
           | _ => reflexivity
           | _ => apply path_forall
           | _ => apply (path_universe (symmetry _ _))
           | _ => exact (center _)
           | _ => progress rewrite ?transport_path_universe, ?transport_path_universe_V
           | _ => progress path_category
           | _ => progress path_induction
         end.
Qed.


Require Import Platform.tests.Thread0 Platform.tests.ListBuilder Platform.Bootstrap.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := (heapSize + 50) * 4.
End M'.

Import M'.

Module E := ListBuilder.Make(M').
Import E.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 1.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 1.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "test"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREmain[_] globalSched =?> 1 * 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSched =?> 1 * mallocHeap 0];;

        Goto "test"!"main"
      end
    }}.

  Theorem ok0 : moduleOk boot.
    vcgen; abstract (unfold globalSched, localsInvariantMain; genesis).
  Qed.

  Definition m1 := link boot E.T.T.m.
  Definition m := link E.m m1.

  Lemma ok1 : moduleOk m1.
    link ok0 E.T.T.ok.
  Qed.

  Theorem ok : moduleOk m.
    link E.ok ok1.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $ (size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok.
  Qed.
End boot.

End Make.


Require Import Coqlib.
Require Import Asm.
Require Import Globalenvs.
Require Import Integers.

Require Import ProgPropDec.
Require Import PeekTactics.
Require Import PeekLib.
Require Import PregTactics.
Require Import StepLib.
Require Import AsmBits.
Require Import MemoryAxioms.
Require Import GlobalPerms.
Require Import FindInstrLib.
Require Import AsmCallingConv.

Lemma step_nextinstr_same_block :
  forall p rs m md rs' m' md' t,
    no_PC_overflow_prog p ->
    step_bits (Genv.globalenv p) (State_bits rs m md) t (State_bits rs' m' md') ->
    forall b ofs bits b' ofs' bits',
      rs PC = Values.Vint bits ->
      psur md bits = Some (b,ofs) ->
      rs' PC = Values.Vint bits' ->
      psur md' bits' = Some (b',ofs') ->
      rs' PC = nextinstr rs PC ->
      b = b'.
Proof.
  intros.
  NP _app step_md step_bits.
  NP _app step_gp step_bits.
  NP _app md_extends_step step_bits.
  repeat break_and.
  repeat match goal with
           | [ H : global_perms _ _ |- _ ] => eapply global_perms_valid_globals in H
         end.
  assert (is_global (Genv.globalenv p) b ofs). {
    unfold is_global.
    left. unfold in_code_range.
    invs; repeat unify_PC; repeat unify_psur;
    unfold fundef in *; repeat collapse_match;
    try NP apex in_range_find_instr find_instr;
    try omega.
    rewrite Int.unsigned_zero. omega.
  } idtac.

  assert (Int.unsigned (Int.add ofs Int.one) = Int.unsigned ofs + 1). {
    unfold Int.add. rewrite Int.unsigned_one.
    invs; repeat unify_PC; repeat unify_psur;
    try solve [
          erewrite unsigned_repr_PC; eauto;
          left; replace (Int.unsigned ofs + 1 - 1) with (Int.unsigned ofs) in * by omega; eassumption].
    rewrite Int.unsigned_zero. rewrite Int.unsigned_repr.
    omega. unfold Int.max_unsigned.
    unfold Int.modulus. unfold Int.wordsize.
    unfold Wordsize_32.wordsize.
    unfold two_power_nat.
    unfold shift_nat.
    simpl. omega.
  } idtac.
  erewrite weak_valid_pointer_sur in H2; eauto.
  break_and.
  preg_simpl_hyp H5.
  rewrite H1 in H5.
  erewrite weak_valid_pointer_sur in H4; eauto.
  break_and. simpl in H5.
  unify_PC.
  app pinj_add H2. instantiate (1 := Int.one) in H2.
  eapply pinj_extends in H2; eauto.
  assert (Memory.Mem.weak_valid_pointer m' b (Int.unsigned (Int.add ofs Int.one)) = true). {
    rewrite Memory.Mem.weak_valid_pointer_spec.
    rewrite H12. right.
    replace (Int.unsigned ofs + 1 - 1) with (Int.unsigned ofs) by omega.
    eapply H9. assumption.
  } idtac.
  name (conj H4 H14) Hpsur1. erewrite <- weak_valid_pointer_sur in Hpsur1; eauto.
  name (conj H2 H15) Hpsur2. erewrite <- weak_valid_pointer_sur in Hpsur2; eauto.
  unify_psur. reflexivity.
Qed.

Definition labeled_jump (i : instruction) (l : label) : Prop :=
  match i with
    | Pjmp_l l' => l = l'
    | Pjcc _ l' => l = l'
    | Pjcc2 _ _ l' => l = l'
    | Pjmptbl _ ls => In l ls
    | _ => False
  end.

Inductive in_same_block (s1 s2 : state_bits) : Prop :=
  | in_b :
      forall rs m rs' m' b i i' bits bits' md md',
        s1 = State_bits rs m md ->
        s2 = State_bits rs' m' md' ->
        rs PC = Values.Vint bits ->
        rs' PC = Values.Vint bits' ->
        psur md bits = Some (b,i) ->
        psur md' bits' = Some (b,i') ->
        in_same_block s1 s2.

Lemma labeled_jump_same_block :
  forall p rs m md t rs' m' md' bits b ofs bits' b' ofs' f i,
    (exists l, labeled_jump i l) ->
    no_PC_overflow_prog p ->
    step_bits (Genv.globalenv p) (State_bits rs m md) t (State_bits rs' m' md') ->
    rs PC = Values.Vint bits ->
    psur md bits = Some (b,ofs) ->
    rs' PC = Values.Vint bits' ->
    psur md' bits' = Some (b',ofs') ->
    Genv.find_funct_ptr (Genv.globalenv p) b = Some (AST.Internal f) ->
    find_instr (Int.unsigned ofs) (fn_code f) = Some i ->
    b = b'.
Proof.
  intros.
  invs; repeat unify_PC; repeat unify_psur; unfold fundef in *; try find_one_instr; unify_find_funct_ptr; unify_find_instr; simpl in H; try solve [break_exists; inv_false].

  assert ((exists l', labeled_jump i l' /\ goto_label_bits md f0 l' b rs m = Nxt rs' m' md') \/ rs' PC = nextinstr rs PC). {
    break_exists; destruct i; simpl in H; try inv_false; simpl in H21.
    left. exists l. split; eauto. simpl. auto.
    repeat break_match_hyp; try congruence.
    left. exists l. split; auto. simpl. auto.
    right. inv H21. reflexivity.
    repeat break_match_hyp; try congruence; try solve [right; congruence].
    left. exists l. split; auto. simpl. auto.
    repeat break_match_hyp; try congruence.
    left. exists l. split; auto.
    simpl. app list_nth_z_in Heqo.
  } idtac.

  destruct H3;
    try solve [
          eapply step_nextinstr_same_block; eauto].
  clear H.
  break_exists.
  break_and.

  unfold goto_label_bits in *.
  repeat break_match_hyp; try congruence.
  inv H3.
  clear H21.

  preg_simpl_hyp H4.
  inv H4.

  app label_pos_find_instr Heqo.
  assert (is_global (Genv.globalenv p) b (Int.repr (z-1))). {
    unfold is_global.
    left. unfold in_code_range.
    unfold fundef in *. collapse_match.
    apex in_range_find_instr Heqo.
    erewrite unsigned_repr_PC; eauto. omega.
  } idtac.

  assert (Int.unsigned (Int.repr z) - 1 = Int.unsigned (Int.repr (z - 1))). {
    erewrite unsigned_repr_PC; eauto.
    erewrite unsigned_repr_PC; eauto.
  } idtac.
  assert (Memory.Mem.weak_valid_pointer m' b (Int.unsigned (Int.repr z)) = true). {
    rewrite Memory.Mem.weak_valid_pointer_spec.
    right. eapply global_perms_valid_globals in H23.
    unfold valid_globals in *.
    rewrite H7.
    eapply H23. auto.
  } idtac.

  name (conj Heqo0 H8) Hpsur.
  erewrite <- weak_valid_pointer_sur in Hpsur; eauto.
  congruence.
Qed.

Lemma step_no_call_nextinstr_or_label :
  forall p rs m md rs' m' md' t f i,
    no_PC_overflow_prog p ->
    no_builtin_clobber_PC_prog p ->
    step_bits (Genv.globalenv p) (State_bits rs m md) t (State_bits rs' m' md') ->
    forall b ofs bits b' ofs' bits',
      rs PC = Values.Vint bits ->
      psur md bits = Some (b,ofs) ->
      rs' PC = Values.Vint bits' ->
      psur md' bits' = Some (b',ofs') ->
      Genv.find_funct_ptr (Genv.globalenv p) b = Some (AST.Internal f) ->
      find_instr (Int.unsigned ofs) (fn_code f) = Some i ->
      ~ is_call_return i ->
      rs' PC = nextinstr rs PC \/ (exists l, labeled_jump i l).
Proof.
  intros.
    invs; repeat unify_PC; repeat unify_psur;
    unfold fundef in *; repeat unify_find_funct_ptr;
    try solve [left; reflexivity]; unify_find_instr.

    Focus 2.
    left. unfold nextinstr_nf.
    unfold undef_regs. fold undef_regs.
    unfold nextinstr.
    rewrite Pregmap.gss.
    repeat rewrite Pregmap.gso by congruence.
    repeat rewrite Pregmap.gss.
    assert (code_of_prog (fn_code f0) p). {
      app Genv.find_funct_ptr_inversion H6. unfold code_of_prog.
      destruct f0. simpl. eauto.
    } idtac.
    app H0 H3.
    app H3 H18.

    rewrite set_regs_not_in by tauto.
    rewrite undef_regs_not_in by tauto.
    reflexivity.

    destruct i;
      simpl in H22;
      simpl in H8;
      try inv_false;
      try solve [right; simpl; eauto];
      unfold exec_load_bits in *;
      unfold exec_store_bits in *;
      unfold exec_big_load_bits in *;
      unfold exec_big_store_bits in *;
      unfold compare_floats in *;
      unfold compare_floats32 in *;
      repeat (break_match_hyp; try congruence);
      try st_inv;
      try solve [left; preg_simpl; reflexivity].
    app list_nth_z_in Heqo.
Qed.

Lemma step_no_call_same_block :
  forall p rs m md rs' m' md' t f i,
    no_PC_overflow_prog p ->
    no_builtin_clobber_PC_prog p ->
    step_bits (Genv.globalenv p) (State_bits rs m md) t (State_bits rs' m' md') ->
    forall b ofs bits b' ofs' bits',
      rs PC = Values.Vint bits ->
      psur md bits = Some (b,ofs) ->
      rs' PC = Values.Vint bits' ->
      psur md' bits' = Some (b',ofs') ->
      Genv.find_funct_ptr (Genv.globalenv p) b = Some (AST.Internal f) ->
      find_instr (Int.unsigned ofs) (fn_code f) = Some i ->
      ~ is_call_return i ->
      b = b'.
Proof.
  intros.
  NP _app step_no_call_nextinstr_or_label step_bits.
  break_or.
  eapply step_nextinstr_same_block; eauto.
  eapply labeled_jump_same_block; eauto.
Qed.


Require Import Proofs.ScopeInvariant.
Goal WellScopedProgram program.
Proof.
repeat (lazy; constructor).
(* This is for the NoDup goals: *)
all: rewrite ?IntSetProofs.In_cons_iff; intuition congruence.
Qed.
Require Import Proofs.JoinPointInvariants.
Goal isJoinPointsValidProgram program.
Proof.
repeat (lazy; constructor).
Qed.


From Coq Require Import Program.Basics Morphisms.

From ITree Require Import
     ITree
     ITreeFacts.

From ITree.Extra Require Import
     Secure.SecureEqHalt
     Secure.SecureEqEuttTrans
     Secure.SecureEqProgInsens
.

From SecureExample Require Import
     Utils_tutorial
     Fin
     KTreeFin
     LabelledImp
     LabelledAsm
     LabelledImp2Asm
     LabelledImp2AsmCorrectness
     LabelledImpHandler
     LabelledImpTypes
     LabelledImpTypesProgInsens
.

Import ITreeNotations.

Import Monads.
Open Scope monad_scope.

Section SecurityPreservation.

Context (Γ : var -> sensitivity).
Context (l : sensitivity).

Instance labell_equiv_equiv {Γ' l'} : Equivalence (labelled_equiv sensitivity_lat Γ' l').
Proof.
  constructor; red; intros; red; red; intros; auto.
  - rewrite H; auto.
  - rewrite H; auto.
Qed.

Definition labelled_sim : map -> (registers * memory) -> Prop :=
  fun g_imp g_asm => labelled_equiv sensitivity_lat Γ l g_imp (snd g_asm).

Definition asm_eq : registers * memory -> registers * memory -> Prop :=
  fun '(regs1, mem1) '(regs2, mem2) => labelled_equiv sensitivity_lat Γ l mem1 mem2.

Lemma state_rel_aux:
  forall (p1 : map * unit) (p2 : registers * memory * fin 1),
    rcompose (product_rel (labelled_equiv sensitivity_lat Γ l) eq) (state_invariant TT) p1 p2 ->
    product_rel labelled_sim TT p1 p2.
Proof.
  intros [σ [] ] [ [regs mem] ?] Hcomp. inv Hcomp.
  destruct r2 as [σ' [] ]. destruct REL1. split; red; auto.
  cbn. red in REL2. destruct REL2 as [Hst _ ]. cbn in *.
  assert (labelled_equiv _ Γ l σ' mem).
  { red in Hst. do 2 red. intros. auto. }
  etransitivity; eauto.
Qed.

Lemma state_rel_aux':
  forall x0 x1 : registers * memory * fin 1,
    flip
      (rcompose
         (flip
            (rcompose (product_rel (LabelledImpTypes.labelled_equiv sensitivity_lat Γ l) (@eq unit) )
                      (state_invariant TT))) (state_invariant TT)) x0 x1 ->
    product_rel asm_eq eq x0 x1.
Proof.
  intros [ [regs1  mem1] ? ] [ [reg2 mem2] ? ].
  intros H. inv H. inv REL1. split; cbn.
  2 :  setoid_rewrite unique_f0; auto.
   inv REL0. inv REL3. inv REL2. destruct r0. destruct r2. cbn in *.
   subst. transitivity m0.
   cbv; intros; auto. transitivity m; auto. cbv; intros; auto.
Qed.

Section ProgressSensitive.

Definition labelled_bisimilar {A B : Type} (RAB : A -> B -> Prop)
           (t1 : itree ((impExcE _) +' stateE +' (IOE _)) A ) (t2 : itree ((impExcE _) +'
 Reg +' Memory +' (IOE _)) B) :=
  forall (g_imp : map) (g_asm : memory) (regs : registers),
    labelled_equiv _ Γ l g_imp g_asm ->
    eqit_secure _ (priv_exc_io sensitivity_lat) (product_rel labelled_sim RAB) true true l (interp_imp _ t1 g_imp ) (interp_asm t2 (regs, g_asm)).

Lemma compile_preserves_ps_security : forall (c : stmt _),
    label_state_sec_eutt _ Γ l eq  (interp_imp _ (denote_stmt _ c)) (interp_imp _ (denote_stmt _ c)) ->
    labelled_bisimilar TT (denote_stmt _ c) (denote_asm (compile c) f0 ) .
Proof.
  intros s Hsecs. red in Hsecs. red. intros g_imp g_asm regs Hs.
  assert (labelled_equiv _ Γ l g_imp g_imp). reflexivity.
  specialize (compile_correct s) as Heutt. do 2 red in Heutt.
  assert (Renv g_asm g_asm). reflexivity.
  specialize (Hsecs g_imp g_asm Hs).
  specialize (Heutt g_asm g_asm regs H0) .
  specialize (eutt_secure_eqit_secure) as Htrans.
  eapply Htrans in Heutt; eauto.
  eapply SecureEqEuttHalt.eqit_secure_RR_imp; try apply Heutt.
  apply state_rel_aux; auto.
Qed.

Lemma compile_preserves_ps_ni : forall (c : stmt _),
    label_state_sec_eutt _ Γ l eq  (interp_imp _ (denote_stmt _ c)) (interp_imp _ (denote_stmt _ c)) ->
    forall σ1 σ2, asm_eq σ1 σ2 ->
             eqit_secure _ (priv_exc_io _) (product_rel asm_eq eq) true true l
             (interp_asm (denote_asm (compile c) f0) σ1) ((interp_asm (denote_asm (compile c) f0)) σ2).
Proof.
  intros c Hsecc [regs1 mem1] [regs2 mem2]. intros Hasmeq.
  assert (labelled_equiv _ Γ l mem1 mem1). reflexivity.
  assert (labelled_equiv _ Γ l mem2 mem2). reflexivity.
  specialize (compile_correct c) as Heutt. do 2 red in Heutt.
  assert (Renv mem1 mem1). reflexivity.
  assert (Renv mem2 mem2). reflexivity.
  do 2 red in Hsecc.
  assert (Hmem12 : labelled_equiv _ Γ l mem1 mem2). auto.
  specialize (Hsecc mem1 mem2 Hmem12) as Hsecc'.
  specialize (Heutt mem1 mem1 regs1 H1) as Heutt1.
  specialize (Heutt mem2 mem2 regs2 H2) as Heutt2.
  specialize (eutt_secure_eqit_secure) as Htrans.
  eapply Htrans in Heutt1 as Heutt1'; eauto.
  eapply Htrans in Heutt2 as Heutt2'; eauto.
  eapply Htrans in Hsecc'; eauto.
  apply eqit_secure_sym in Hsecc'.
  eapply Htrans in Hsecc'; eauto.
  apply eqit_secure_sym in Hsecc'.
  eapply SecureEqEuttHalt.eqit_secure_RR_imp; try apply Hsecc'; eauto.
  intros.
  apply state_rel_aux'; auto.
Qed.

End ProgressSensitive.

Section ProgressInsensitive.

Definition labelled_pi_bisimilar {A B : Type} (RAB : A -> B -> Prop)
           (t1 : itree ((impExcE _) +' stateE +' (IOE _)) A ) (t2 : itree ((impExcE _) +'
 Reg +' Memory +' (IOE _)) B) :=
  forall (g_imp : map) (g_asm : memory) (regs : registers),
    labelled_equiv _ Γ l g_imp g_asm ->
    pi_eqit_secure _ (priv_exc_io _) (product_rel labelled_sim RAB) true true l (interp_imp _ t1 g_imp ) (interp_asm t2 (regs, g_asm)).

Lemma compile_preserves_pi_security : forall (c : stmt _),
    label_state_pi_sec_eutt _ Γ l eq  (interp_imp _ (denote_stmt _ c)) (interp_imp _ (denote_stmt _ c)) ->
    labelled_pi_bisimilar TT (denote_stmt _ c) (denote_asm (compile c) f0 ) .
Proof.
  intros s Hsecs. red in Hsecs. red. intros g_imp g_asm regs Hs.
  assert (labelled_equiv _ Γ l g_imp g_imp). reflexivity.
  specialize (compile_correct s) as Heutt. do 2 red in Heutt.
  assert (Renv g_asm g_asm). reflexivity.
  specialize (Hsecs g_imp g_asm Hs).
  specialize (Heutt g_asm g_asm regs H0) .
  specialize (pi_eqit_secure_mixed_trans) as Htrans.
  eapply Htrans in Heutt; eauto.
  eapply pi_eqit_secure_RR_imp; try apply Heutt.
  apply state_rel_aux; auto.
Qed.

Lemma compile_preserves_pi_ni : forall (c : stmt _),
    label_state_pi_sec_eutt _ Γ l eq  (interp_imp _ (denote_stmt _ c)) (interp_imp _ (denote_stmt _ c)) ->
    forall σ1 σ2, asm_eq σ1 σ2 ->
             pi_eqit_secure _ (priv_exc_io _) (product_rel asm_eq eq) true true l
             (interp_asm (denote_asm (compile c) f0) σ1) ((interp_asm (denote_asm (compile c) f0)) σ2).
Proof.
  intros c Hsecc [regs1 mem1] [regs2 mem2]. intros Hasmeq.
  assert (labelled_equiv _ Γ l mem1 mem1). reflexivity.
  assert (labelled_equiv _ Γ l mem2 mem2). reflexivity.
  specialize (compile_correct c) as Heutt. do 2 red in Heutt.
  assert (Renv mem1 mem1). reflexivity.
  assert (Renv mem2 mem2). reflexivity.
  do 2 red in Hsecc.
  assert (Hmem12 : labelled_equiv _ Γ l mem1 mem2). auto.
  specialize (Hsecc mem1 mem2 Hmem12) as Hsecc'.
  specialize (Heutt mem1 mem1 regs1 H1) as Heutt1.
  specialize (Heutt mem2 mem2 regs2 H2) as Heutt2.
  specialize (pi_eqit_secure_mixed_trans) as Htrans.
  eapply Htrans in Heutt1 as Heutt1'; eauto.
  eapply Htrans in Heutt2 as Heutt2'; eauto.
  eapply Htrans in Hsecc'; eauto.
  apply pi_eqit_secure_sym in Hsecc'.
  eapply Htrans in Hsecc'; eauto.
  apply pi_eqit_secure_sym in Hsecc'.
  eapply pi_eqit_secure_RR_imp; try apply Hsecc'; eauto.
  intros.
  apply state_rel_aux'; auto.
Qed.

End ProgressInsensitive.

End SecurityPreservation.
(*
stmt :=
     | throw
     | try c1 catch c2

itree (state +' IOE +' Exc) tt

denote_throw := trigger Throw

denote_catch

block := ...
         | throw

compile p : asm 1 1

compile p : asm 1 2

*)


Require Import Terms.
Require Import LNaVSyntax.
Require Import LNaVBigStep. (* reusing helpers *)

(** * Continuations and partial configurations *)

Inductive Frame : Type :=
| RLet : Var -> Tm -> Frame
| RRet : Env -> Frame
| RBrk : Lab -> Lab -> Frame. (* final label + original pc *)

Definition Cont := list Frame.

Definition PCfg := prod (prod Lab Env) Cont.

Inductive RCfg : Type :=
| CR : Tm -> RCfg    (* term to be reduced *)
| CA : Atom -> RCfg.  (* return atom *)

Definition Cfg := prod PCfg RCfg.

Notation "v @ L" := (v,L) (at level 5).

Notation "<< pc , r , k , X >>" := (((pc, r), k), X) (at level 5).

(** * Small-step semantics defined as a total(!) function *)

Definition step (c : Cfg) : Cfg :=
  match c with
  (* s_var *)
  | << pc, rho, k, CR (TVar x) >> =>
    match get rho x with
    | Some a =>
      << pc, rho, k, CA a >>
    | None =>
      << pc, rho, k, CA (D eUnbound)@bot >>
    end
  (* s_const *)
  | << pc, rho, k, CR (TConst c) >> =>
    << pc, rho, k, CA (V (VConst c))@bot>>
  (* s_let_start *)
  | << pc, rho, k, CR (TLet x t1 t2) >> =>
    << pc, rho, RLet x t2 :: k, CR t1 >>
  (* s_let_bind *)
  | << pc, rho, RLet x t :: k, CA a >> =>
    << pc, (x,a) :: rho, RRet rho :: k, CR t >>
  (* s_abs *)
  | << pc, rho, k, CR (TAbs x t) >> =>
    << pc, rho, k, CA (V (VClos rho x t))@bot >>
  (* s_app *)
  | << pc, rho, k, CR (TApp x1 x2) >> =>
    match get rho x1, get rho x2 with
    | Some ((V (VClos rho' x t))@L), Some a =>
      << pc\_/L, (x,a) :: rho', RRet rho :: k, CR t >>
    | Some (b,L),_ =>
      << pc\_/L, rho, k, CA (D (propagate_nav b))@bot >>
    | _, _ =>
      << pc, rho, k, CA (D eUnbound)@bot >>
    end
  (* s_return *)
  | << pc, rho, RRet rho' :: k, CA a >> =>
    << pc, rho', k, CA a >>
  (* s_inx *)
  | << pc, rho, k, CR (TInx d x) >> =>
    match get rho x with
    | Some a =>
      << pc, rho, k, CA (V (VInx d a))@bot >>
    | _ =>
      << pc, rho, k, CA (D eUnbound)@bot >>
    end
  (* s_match *)
  | << pc, rho, k, CR (TMatch x x' t1 t2) >> =>
    match get rho x with
    | Some (V (VInx DLeft a), l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t1 >>
    | Some (V (VInx DRight a), l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t2 >>
    | Some (V _, l) =>
      << pc\_/l, rho, k, CA (D eType)@bot >>
    | Some (D e, l) =>
      << pc\_/l, rho, k, CA (D e)@bot >>
    | _ =>
      << pc, rho, k, CA (D eUnbound)@bot >>
    end
  (* s_tag *)
  | << pc, rho, k, CR (TTag x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc, rho, k, CA (tag_box b)@l >>
    | _ =>
      << pc, rho, k, CA (D (eUnbound))@bot >>
    end
  (* s_bop *)
  | << pc, rho, k, CR (TBOp bo x' x'') >> =>
    match get rho x', get rho x'' with
    | Some (b', l0'), Some (b'', l0'') =>
      << pc, rho, k, CA (bop_box bo b' b'', l0' \_/ l0'') >>
    | _, _ =>
      << pc, rho, k, CA (D (eUnbound))@bot >>
    end
  (* s_bracket_start *)
  | << pc, rho, k, CR (TBracket x t) >> =>
    match get rho x with
    | Some ((V (VConst (CLab L)))@L') =>
      << pc\_/L', rho, RBrk L (pc\_/L') :: k, CR t >>
    | Some (b,L') =>
      << pc\_/L', rho, k, CA (D (propagate_nav b))@bot >>
    | None =>
      << pc, rho, k, CA (D (eUnbound))@bot >>
    end
  (* s_bracket_end *)
  | << pc, rho, RBrk L' pc' :: k, CA (b@L) >> =>
    if flows_dec (L \_/ pc) (L' \_/ pc') then
      << pc', rho, k, CA (b@L')>>
    else
      << pc', rho, k, CA ((D eBracket)@L')>>
  (* s_label_of *)
  | << pc, rho, k, CR (TLabelOf x) >> =>
    match get rho x with
    | Some (_,l) =>
      << pc, rho, k, CA (V (VConst (CLab l)))@bot >>
    | _ =>
      << pc, rho, k, CA (D (eUnbound))@bot >>
    end
  (* s_get_pc *)
  | << pc, rho, k, CR TGetPc >> =>
    << pc, rho, k, CA (V (VConst (CLab pc)))@bot >>
  (* s_mk_nav *)
  | << pc, rho, k, CR (TMkNav x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc, rho, k, CA (mk_nav_box b)@l >>
    | _ =>
      << pc, rho, k, CA (D (eUnbound))@bot >>
    end
  (* s_to_sum *)
  | << pc, rho, k, CR (TToSum x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc, rho, k, CA (to_sum_box b)@l >>
    | _ =>
      << pc, rho, k, CA (D (eUnbound))@bot >>
    end
  (* stack underflow (you're already done?) *)
  | << pc, rho, nil, CA _ >> =>
      << pc, rho, nil, CA (D (eStack))@bot >>
  (* terms not from this language *)
  | << pc, rho, k, CR (TThrow _) >> =>
      << pc, rho, k, CA (D (eLanguage))@bot >>
  | << pc, rho, k, CR (TCatch _ _ _) >> =>
      << pc, rho, k, CA (D (eLanguage))@bot >>
  end.

Definition final (c : Cfg) : bool :=
  match c with
  | << pc, rho, nil, CA _ >> => true
  | _ => false
  end.

Fixpoint nstep (n : nat) (cm : Cfg*nat) : Cfg*nat :=
  match n with
  | S n' =>
    match cm with
    | (c,m) => if final c then (c,m) else nstep n' (step c, m+1)
    end
  | O => cm
  end.

Definition mstep (n : nat) (t : Tm) : Cfg*nat :=
  nstep n (<< bot, nil, nil, CR t >>, 0).

Definition sstep (n : nat) (t : Tm) : option ((Atom*Lab)*nat) :=
  match mstep n t with
  | (<< pc, rho, nil, CA a >>, m) => Some ((a,pc),m)
  | _ => None (* looping or need more steps *)
  end.

Definition tstep_no := 1000.

Definition tstep (t : Tm) : option Atom :=
  match sstep tstep_no t with
  | Some ((a,_pc), m) => Some a
  | None => None (* looping or need more steps *)
  end.

(* Correspondence *)
Fixpoint multistep (n : nat) (c : Cfg) : Cfg :=
  match n with
  | S n' => multistep n' (step c)
  | O => c
  end.

Lemma multistep_trans_general : forall n1 n2 cfg1 cfg2 cfg3,
  multistep n1 cfg1 = cfg2 ->
  multistep n2 cfg2 = cfg3 ->
  exists n3, multistep n3 cfg1 = cfg3.
Proof.
  intros n1.
  induction n1; intros n2 cfg1 cfg2 cfg3 Hstep1 Hstep2.
  Case "n1 = 0".
    exists n2. simpl in Hstep1. subst. reflexivity.
  Case "S n1".
    simpl in Hstep1.
    remember (step cfg1) as cfg1'.
    specialize (IHn1 n2 cfg1' cfg2 cfg3 Hstep1 Hstep2).
    destruct IHn1 as [n Hstep1'].
    exists (S n). simpl. rewrite <- Heqcfg1'. assumption.
Qed.

Ltac solve_var H k f := exists 1; simpl; rewrite H; destruct k; try destruct f; eauto.
Ltac immediate k f := exists 1; simpl; destruct k; try destruct f; eauto.

Definition steps cfg1 cfg2 := exists n, multistep n cfg1 = cfg2.
Hint Unfold steps.

Lemma multistep_trans : forall cfg1 cfg2 cfg3,
  steps cfg1 cfg2 ->
  steps cfg2 cfg3 ->
  steps cfg1 cfg3.
Proof.
  intros cfg1 cfg2 cfg3 Hstep1 Hstep2.
  destruct Hstep1 as [n1 Hstep1]. destruct Hstep2 as [n2 Hstep2].
  eauto using multistep_trans_general.
Qed.

Lemma big_to_small : forall r t pc a pc' k,
  r |- t, pc ==> a, pc' ->
  steps <<pc, r, k, CR t>> <<pc', r, k, CA a>>.
Proof.
  intros r t pc a pc' k Heval. generalize dependent k.
  (eval_cases (induction Heval) Case); intro k.
  Case "eval_var". solve_var H k f.
  Case "eval_const". immediate k f.
  Case "eval_let".
    assert (steps << pc, r, k, CR (TLet x t t') >> << pc, r, RLet x t' :: k, CR t >>)
      by immediate k f.
    specialize (IHHeval1 (RLet x t' :: k)).
    assert (steps << pc', r, RLet x t' :: k, CA a >> << pc', (x,a) :: r, RRet r :: k, CR t' >>)
      by immediate k f.
    specialize (IHHeval2 (RRet r :: k)).
    assert (steps << pc'', x @ a :: r, RRet r :: k, CA a' >> << pc'', r, k, CA a' >>)
      by immediate k f.
    eauto using multistep_trans.
  Case "eval_abs". immediate k f.
  Case "eval_app".
    assert (steps << pc, r, k, CR (TApp x' x'') >> << pc\_/l, x@a::r', RRet r::k, CR t >>).
      exists 1; simpl; unfold Atom; rewrite H, H0; destruct k; try destruct f; eauto.
    specialize (IHHeval (RRet r :: k)).
    assert (steps <<pc', x@a::r', RRet r :: k, CA a'>> << pc', r, k, CA a'>>)
      by immediate k f.
    eauto using multistep_trans.
  Case "eval_app_no_abs".
    exists 1. simpl. unfold Atom. rewrite H. destruct b; try destruct v; destruct k; try destruct f;
      try solve [simpl in H0; exfalso; auto]; auto.
  Case "eval_inx".
    solve_var H k f.
  Case "eval_match".
    assert (steps << pc, r, k, CR (TMatch x x' t' t'') >>
                  << pc\_/l, x'@a::r, RRet r::k, CR (d_choose d t' t'') >>).
      fold Atom in H. destruct d; solve_var H k f.
    specialize (IHHeval (RRet r::k)).
    assert (steps << pc', x'@a::r, RRet r::k, CA a' >> << pc', r, k, CA a' >>).
      immediate k f.
    eauto using multistep_trans.
  Case "eval_match_no_sum".
    exists 1. simpl. unfold Atom. rewrite H. destruct b; try destruct v; destruct k; try destruct f;
      try solve [simpl in H0; exfalso; auto]; auto.
  Case "eval_tag".
    fold Atom in H. solve_var H k f.
  Case "eval_bop".
    fold Atom in H, H0.
    exists 1; simpl; rewrite H, H0; destruct k; try destruct f; eauto.
  Case "eval_bracket".
    remember (flows_dec (l'' \_/ pc') (l \_/ (pc \_/ l'))) as flow.
    assert (steps << pc, r, k, CR (TBracket x t) >> << pc\_/l',r,RBrk l (pc\_/l')::k,CR t>>).
      fold Atom in H. solve_var H k f.
    specialize (IHHeval (RBrk l (pc\_/l') ::k)).
    assert (steps << pc', r, RBrk l (pc \_/ l') :: k, CA b @ l'' >>
                  << pc \_/ l', r, k, CA (if flow then b else D eBracket) @l >>).
      destruct flow; immediate k f; rewrite <- Heqflow; eauto.
    eauto using multistep_trans.
  Case "eval_bracket_no_lab".
    exists 1. simpl. unfold Atom. rewrite H. destruct b; try destruct v; try destruct c;
      destruct k; try destruct f; try solve [simpl in H0; exfalso; auto]; auto.
  Case "eval_label_of".
    fold Atom in H. solve_var H k f.
  Case "eval_get_pc".
    immediate k f.
  Case "eval_mk_nav".
    fold Atom in H. solve_var H k f.
  Case "eval_to_sum".
    fold Atom in H. solve_var H k f.
Qed.

(* MMG: to here.  Started running into some problems lining everything
   up, since this development is actually rather different from the
   old one.  I think this general approach will work, but we need to
   reconcile issues with unbound variables, get rid of stack
   underflows, and probably relation-ize the step function.  (At which
   point, we can either prove that the relation and function match, or
   just redo the previous proof for the relation...)
*)

(*
Reserved Notation "r |= cfg , pc1 ==> a , pc2" (at level 80).
Inductive evalCfg : Env -> Cfg -> Lab -> Atom -> Lab -> Prop :=
| evalCfgT : forall r pc r' pc' k (t:Tm) a a' pc'' pc''',
    r' |- t, pc' ==> a, pc'' ->
    r |= << pc'', r', k, CA a >>, pc ==> a', pc''' ->
    r |= << pc', r', k, CR t >>, pc ==> a', pc'''

| evalCfgNilA : forall r pc pc' a,
    r |= << pc, r, nil, CA a >>, pc' ==> a, pc
(*
| evalCfgLet : forall r t pc a pc' x t' k a' pc'' pc''',
    r |- t,pc' ==> a,pc'' ->
    r |= << pc'', x@a::r, RRet r::k, CR t' >>,pc ==> a',pc''' ->
    r |= << pc', r, RLet x t'::k, CR t >>,pc ==> a',pc'''
| evalCfgRet : forall r pc a pc' r' k a1,
    r |= << pc', r', k, CA a1 >>, pc ==> a, pc' ->
    r |= << pc', r, RRet r' :: k, CA a1 >>, pc ==> a, pc'
*)
where "r |= cfg , pc1 ==> a , pc2" := (evalCfg r cfg pc1 a pc2).
Hint Constructors evalCfg.

(** [evalCfg] is preserved by stepping back. *)
Lemma evalCfg_anti_step : forall r pc pc' a conf conf',
  r |= conf', pc ==> a, pc' ->
  step conf = conf' ->
  r |= conf, pc ==> a, pc'.
Proof.
intros r pc pc' a conf conf' HevalCfg Hstep.
destruct conf as [[[pc'' r'] k] [t | a']].
Tm_cases (destruct t) Case.
Case "TVar".
  remember (get r' v) as av.
  destruct av.
  simpl in Hstep.
  rewrite <- Heqav in Hstep.
  destruct k; try destruct f; subst;
    solve [eapply evalCfgT; try apply HevalCfg;
           apply eval_var; unfold maps; rewrite <- Heqav; auto].
  simpl in Hstep.
  destruct k; try destruct f; rewrite <- Heqav in Hstep.
  subst. invsc HevalCfg.
  eapply evalCfgT; try apply HevalCfg.

Case "s_app_l". invs HevalCfg.
SCase "evalCfgAppL". invs H8. invs H12. invs H13. invs H19. invs H15. eauto.
Case "s_app_r". invs HevalCfg.
SCase "evalCfgAppR". invs H8. eauto.
Case "s_classify_r". invs HevalCfg.
SCase "evalCfgLabR". invs H8. invs H11. invs H12. econstructor; eauto. eauto.
Case "s_classify_l". invs HevalCfg.
SCase "evalCfgLabl". invs H8. eauto.
Case "s_lab_of_push". invs HevalCfg.
SCase "evalCfgLabOf". invs H8. econstructor; eauto. eauto.
Case "s_cmp_l". invs HevalCfg.
SCase "evalCfgCmpL". invs H8. invs H11. invs H12. econstructor; eauto. eauto.
Case "s_join_l". invs HevalCfg.
SCase "evalCfgJoinL". invs H8. invs H11. invs H12. econstructor; eauto. eauto.
Qed.

*)


(* Require Import Modal.
Require Import SecOrder.  *)
Require Export ST_setup.
Require Import Correctness_ST_world_model.
Require Import List_machinery_impl.

(* A specific choice of pa_l that doesn't alter Ip, as proved below in Lemmas ineffective_Ip
   and ineffective_Ip - used later in proof of correctness_ST *)
Fixpoint ineffective_pa_l (W : Set) (Ip : predicate -> W -> Prop) (n : nat)
                     (l : nlist n (* nlist_pred n *)) : nlist_pa W n :=
  match l with
  | niln => niln_pa W
  | consn m P l' => consn_pa W m (Ip P) (ineffective_pa_l W Ip m l')
  end.

Lemma  ineffective_Ip2 : forall (W : Set) (l : list predicate) (Ip : predicate -> W -> Prop) ,
   alt_Ip_list Ip (nlist_list_pa W (length l)
       (ineffective_pa_l W Ip (length l) (list_nlist(*_pred*) l))) l
   = Ip.
Proof.
  intros W l.
  induction l.
    intros.
    simpl.
    reflexivity.

    intros.
    simpl.
    rewrite (IHl Ip).
    rewrite unalt_fun.
    reflexivity.
Qed.

(* ---------------------------------------------------------------------------- *)

Theorem correctness_ST : forall (W:Set) (R: W -> W -> Prop) (x:FOvariable)
                        (Iv: FOvariable -> W) (Ip: predicate -> W -> Prop)
                        (phi:Modal) ,
       (mturnst_frame W R phi) <->
                (SOturnst W Iv Ip R (uni_closed_SO (allFO x (ST phi x)))).
Proof.
  intros.
  unfold mturnst_frame.
  split.
    unfold uni_closed_SO.
    intros.
    apply nlist_list_closed_SO.
    intros.
    rewrite <- (Ip_V_Ip W) with (Ip := (alt_Ip_list Ip
                  (nlist_list_pa W (length (preds_in (allFO x (ST phi x)))) pa_l)
                  (preds_in (allFO x (ST phi x))))).
    apply correctness_ST_model.
    apply H.

    intros.
    apply (correctness_ST_model W R V phi x Iv).
    remember (preds_in (allFO x (ST phi x))) as l.
    assert (alt_Ip_list (V_to_Ip W V)
       (nlist_list_pa W (length l)
          (ineffective_pa_l W (V_to_Ip W V) (length l) (list_nlist(*_pred*) l))) l =
              V_to_Ip W V) as H0.
      rewrite Heql.
      apply ineffective_Ip2.
    rewrite <- H0.
    apply (nlist_list_closed_SO W Iv R (allFO x (ST phi x)) l (V_to_Ip W V)).
    rewrite Heql.
    pose proof (Ip_uni_closed W (allFO x (ST phi x)) Iv Ip (V_to_Ip W V) R H) as H1.
    apply H1.
Qed.

Theorem correctness_ST_loc : forall (W:Set) (R: W -> W -> Prop) (x:FOvariable)
                        (Iv: FOvariable -> W) (Ip: predicate -> W -> Prop) (w : W)
                        (phi:Modal) ,
       (mturnst_frame_loc W R w phi) <->
                (SOturnst W (alt_Iv Iv w x) Ip R (uni_closed_SO (ST phi x))).
Proof.
  intros.
  unfold mturnst_frame.
  split.
    unfold uni_closed_SO.
    intros.
    apply nlist_list_closed_SO.
    intros.
    rewrite <- (Ip_V_Ip W) with (Ip := (alt_Ip_list Ip
                  (nlist_list_pa W (length (preds_in (ST phi x))) pa_l)
                  (preds_in (ST phi x)))).
    apply correctness_ST_world.
    apply H.

    intros. intros V.
    apply (correctness_ST_world W R V phi w x Iv).
    remember (preds_in (allFO x (ST phi x))) as l.
    assert (alt_Ip_list (V_to_Ip W V)
       (nlist_list_pa W (length l)
          (ineffective_pa_l W (V_to_Ip W V) (length l) (list_nlist(*_pred*) l))) l =
              V_to_Ip W V) as H0.
      rewrite Heql.
      apply ineffective_Ip2.
    rewrite <- H0.
    apply (nlist_list_closed_SO W _ R (ST phi x) l (V_to_Ip W V)).
    rewrite Heql.
    pose proof (Ip_uni_closed W (ST phi x) _ Ip (V_to_Ip W V) R H) as H1.
    apply H1.
Qed.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RmiOps.Specs.realm_activate_ops.
Require Import RmiOps.LowSpecs.realm_activate_ops.
Require Import RmiOps.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       measurement_finish_spec
       set_rd_state_spec
    .

  Lemma realm_activate_ops_spec_exists:
    forall habd habd'  labd rd
           (Hspec: realm_activate_ops_spec rd habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', realm_activate_ops_spec0 rd labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata. destruct rd.
    unfold realm_activate_ops_spec0, realm_activate_ops_spec in *.
    repeat autounfold in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * );
    eexists; (split; [reflexivity| constructor; try reflexivity]).
  Qed.

End Refine.