Require Export ComponentSM3.
Require Export TrIncprops2.

Section TrIncsm_mon.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma les_update_counter :
    forall l a b, les l (update_counter a b l).
  Proof.
    induction l; introv; simpl; tcsp.
    destruct a0; simpl; tcsp.
    dands; try apply max_prop2; apply les_reflexive.
  Qed.
  Hint Resolve les_update_counter : minbft.

  Lemma getCounter_nil :
    forall cid, getCounter cid [] = 0.
  Proof.
    introv; unfold getCounter; simpl; destruct cid; auto.
  Qed.
  Hint Rewrite getCounter_nil : minbft.

  Lemma getCounter_0_cons :
    forall a l, getCounter 0 (a :: l) = a.
  Proof.
    tcsp.
  Qed.
  Hint Rewrite getCounter_0_cons : minbft.

  Lemma pos_implies_not_all_zeros_nil :
    forall cid new,
      0 < new
      -> ~ all_zeros (update_counter cid new []).
  Proof.
    induction cid; introv h q; simpl in *; tcsp.
    { destruct new; simpl in *; tcsp. }
    { apply IHcid in q; tcsp. }
  Qed.
  Hint Resolve pos_implies_not_all_zeros_nil : minbft.

  Lemma implies_lts_update_counter :
    forall cid new l,
      getCounter cid l < new
      -> lts l (update_counter cid new l).
  Proof.
    induction cid; introv h; simpl in *; tcsp.

    { destruct l; simpl in *; tcsp; autorewrite with minbft in *.

      { destruct new; simpl; tcsp. }

      { left; dands; eauto 3 with minbft; try apply les_reflexive.
        apply Nat.max_lt_iff; tcsp. } }

    { destruct l; simpl in *; tcsp; autorewrite with minbft in *; eauto 3 with minbft. }
  Qed.
  Hint Resolve implies_lts_update_counter : minbft.

  Lemma USIG_sm_mon :
    forall n l s1 s2,
      trusted_run_sm_on_inputs s1 (USIG_comp n) l = s2
      -> trinc_counters s1 = trinc_counters s2
         \/
         lts (trinc_counters s1) (trinc_counters s2).
  Proof.
    unfold trusted_run_sm_on_inputs.
    induction l; introv run; simpl in *; subst; tcsp.
    destruct a; repnd; simpl in *; tcsp;[].
    unfold update_state in *; simpl in *.
    autorewrite with comp in *.

    unfold try_update_TRINC in *; simpl in *; dest_cases w;[].

    match goal with
    | [ |- _ \/ lts (trinc_counters ?a) (trinc_counters ?b) ] =>
      pose proof (IHl (update_TRINC msg0 msg s1) b) as IHl
    end; repeat (autodimp IHl hyp); simpl in *; repndors; tcsp; try omega; smash_minbft2.

    { right; rewrite <- IHl; eauto 3 with minbft. }

    { right; eapply lts_transitive;[|eauto]; eauto 3 with minbft. }
  Qed.

End TrIncsm_mon.

Hint Resolve les_update_counter : minbft.
Hint Resolve pos_implies_not_all_zeros_nil : minbft.
Hint Resolve implies_lts_update_counter : minbft.

Hint Rewrite getCounter_nil : minbft.
Hint Rewrite getCounter_0_cons : minbft.


Add Rec LoadPath "." as DEP_AI.

Require Import language.
Require Import values.
Require Import operational_semantics.

Require Import over_instrumented_values.
Require Import oitval_instantiation.
Require Import oitval_val_conversion.

(*****************************************************************************)
(*                   We define now the Mini-ML dynamic semantics
                     in the style of Natural Semantics  *)
(*****************************************************************************)

Inductive val_of_with_injection : label -> val -> oitenv -> expr -> val -> Prop :=
| Val_of_with_injection_Num :
  forall (l:label) (vl:val) (v:Z) (c:oitenv),
    val_of_with_injection l vl c (Num v) (V_Num v)
| Val_of_with_injection_Ident :
  forall (l:label) (vl v:val) (c:oitenv) (i:identifier) (uu:oitval),
    assoc_ident_in_oitenv i c = Ident_in_oitenv uu
    -> Some v = instantiate_oitval l vl uu
    -> val_of_with_injection l vl c (Var i) v
| Val_of_with_injection_Lambda :
  forall (l:label) (vl v:val) (c:oitenv) (c':env) (x:identifier) (e:expr),
    Some c' = instantiate_oitenv l vl c
    -> v = V_Closure x e c'
    -> val_of_with_injection l vl c (Lambda x e) v
| Val_of_with_injection_Rec :
  forall (l:label) (vl v:val) (c:oitenv) (c':env) (f x:identifier) (e:expr),
    Some c' = instantiate_oitenv l vl c
    -> v = V_Rec_Closure f x e c'
    -> val_of_with_injection l vl c (Rec f x e) v
| Val_of_with_injection_Apply :
  forall (l:label) (vl:val) (c:oitenv) (c1:env) (e1 e2 e:expr) (x:identifier) (v2 v:val),
    val_of_with_injection l vl c e1 (V_Closure x e c1)
    -> val_of_with_injection l vl c e2 v2
    -> val_of_with_injection l vl (OITEnv_cons x (val_to_oitval v2) (env_to_oitenv c1)) e v
    -> val_of_with_injection l vl c (Apply e1 e2) v
| Val_of_with_injection_Apply_rec :
  forall (l:label) (vl:val) (c : oitenv) (c1 : env) (e1 e2 e : expr) (f x : identifier) (v2 v : val),
    val_of_with_injection l vl c e1 (V_Rec_Closure f x e c1) ->
    val_of_with_injection l vl c e2 v2 ->
    val_of_with_injection l vl (env_to_oitenv (add_env  f (V_Rec_Closure f x e c1) (add_env x v2 c1))) e v ->
    val_of_with_injection l vl c (Apply e1 e2) v
| Val_of_with_injection_Let_in :
  forall (l:label) (vl:val) (c : oitenv) (i : identifier) (e1 e2 : expr) (v1 v2 : val),
    val_of_with_injection l vl c e1 v1
    -> val_of_with_injection l vl (OITEnv_cons i (val_to_oitval v1) c) e2 v2
    -> val_of_with_injection l vl c (Let_in i e1 e2) v2

| Val_of_with_injection_If_true :
  forall (l:label) (vl:val) (c : oitenv) (e e1 e2 : expr) (v : val),
    val_of_with_injection l vl c e (V_Bool true)
    -> val_of_with_injection l vl c e1 v
    -> val_of_with_injection l vl c (If e e1 e2) v

| Val_of_with_injection_If_false :
  forall (l:label) (vl:val) (c : oitenv) (e e1 e2 : expr) (v : val),
    val_of_with_injection l vl c e (V_Bool false)
    -> val_of_with_injection l vl c e2 v
    -> val_of_with_injection l vl c (If e e1 e2) v

| Val_of_with_injection_Match :
  forall (l:label) (vl:val) (c:oitenv) (c_p:env) (e e1 : expr) (p : pattern) (v v_e : val) (br2 : option (identifier*expr)),
    val_of_with_injection l vl c e v_e
    -> is_filtered v_e p = Filtered_result_Match c_p
    -> val_of_with_injection l vl (conc_oitenv (env_to_oitenv c_p) c) e1 v
    -> val_of_with_injection l vl c (Expr_match e (p,e1) br2) v
| Val_of_with_injection_Match_var :
  forall (l:label) (vl:val) (c : oitenv) (e e1 e2 : expr) (p : pattern) (v v_e : val) (x : identifier),
    val_of_with_injection l vl c e v_e
    -> is_filtered v_e p = Filtered_result_Match_var
    -> val_of_with_injection l vl (OITEnv_cons x (val_to_oitval v_e) c) e2 v
    -> val_of_with_injection l vl c (Expr_match e (p,e1) (Some (x,e2))) v

| Val_of_with_injection_Constr0 : forall (l:label) (vl:val)  c n,
  val_of_with_injection l vl c (Constr0 n) (V_Constr0 n)
| Val_of_with_injection_Constr1 : forall (l:label) (vl:val)  c n e v,
  val_of_with_injection l vl c e v
  -> val_of_with_injection l vl c (Constr1 n e) (V_Constr1 n v)

| Val_of_with_injection_Couple : forall (l:label) (vl:val)  c (e1 e2 : expr) (v1 v2 : val),
  val_of_with_injection l vl c e1 v1
  -> val_of_with_injection l vl c e2 v2
  -> val_of_with_injection l vl c (Couple e1 e2) (V_Couple v1 v2)

| Val_of_with_injection_Annot_eq : forall (l:label) (vl:val) c (e : expr),
  val_of_with_injection l vl c (Annot l e) vl

| Val_of_with_injection_Annot_neq : forall (l:label) (vl:val) c (l' : label) (e : expr) v,
  val_of_with_injection l vl c e v
  -> neq_label l l'
  -> val_of_with_injection l vl c (Annot l' e) v
  .

Hint Constructors val_of_with_injection : val_of_with_injection.


Require Export Iron.Language.SystemF2Effect.Value.
Require Export Iron.Language.SystemF2Effect.Step.Frame.
Require Export Iron.Language.SystemF2Effect.Step.FreshF.
Require Export Iron.Language.SystemF2Effect.Step.SuppF.
Require Export Iron.Language.SystemF2Effect.Store.
Require Export Iron.Language.SystemF2Effect.Store.LiveE.

(********************************************************************)
(* Type of a frame stack.
   The frame stack is like a continuation that takes an expression of
   a certain type and produces a new expression. *)
Inductive
 TypeF :  kienv -> tyenv
       -> stenv -> stprops
       -> stack -> ty -> ty
       -> ty -> Prop :=
 | TfNil
   :  forall ke te se sp t
   ,  KindT  ke sp t KData
   -> TypeF  ke te se sp nil t t (TBot KEffect)

 | TfConsLet
   :  forall ke te se sp fs t1 x2 t2 e2 t3 e3
   ,  KindT  ke sp t1 KData
   -> TypeX  ke (te :> t1) se sp                    x2 t2 e2
   -> TypeF  ke te         se sp fs                 t2 t3 e3
   -> TypeF  ke te         se sp (fs :> FLet t1 x2) t1 t3 (TSum e2 e3)

 | TfConsPriv
   :  forall ke te se sp fs t1 t2 e2 p
   ,  In (SRegion p) sp
   -> NoPrivFs p fs
   -> LiveE  fs e2
   -> TypeF  ke te se sp fs                   t1 t2 e2
   -> TypeF  ke te se sp (fs :> FPriv None p) t1 t2 e2

 | TfConsExt
   :  forall ke te se sp fs t0 t1 e2 p1 p2
   ,  In (SRegion p1) sp
   -> In (SRegion p2) sp
   -> FreshFs     p2 fs
   -> FreshSuppFs p2 se fs
   -> LiveE  fs (TSum e2 (TAlloc (TRgn p1)))
   -> TypeF  ke te se sp fs                         (mergeT p1 p2 t0) t1 e2
   -> TypeF  ke te se sp (fs :> FPriv (Some p1) p2) t0 t1 (TSum e2 (TAlloc (TRgn p1))).

Hint Constructors TypeF.

(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_typef :=
 repeat (try
  (match goal with
   | [ H: TypeF _ _ _ _ (_ :> FLet  _ _) _ _ _ |- _ ] => inverts H
   | [ H: TypeF _ _ _ _ (_ :> FPriv _ _) _ _ _ |- _ ] => inverts H
   end);
 try inverts_type).

(********************************************************************)
Lemma typeF_kindT_effect
 :  forall ke te se sp fs t1 t2 e
 ,  TypeF  ke te se sp fs t1 t2 e
 -> KindT  ke sp e KEffect.
Proof.
 intros.
 induction H; auto.
 - eapply KiSum; eauto.
 - eapply KiSum; auto.
   eapply KiCon1; snorm.
Qed.
Hint Resolve typeF_kindT_effect.

Lemma typeF_kindT_wfT
 :  forall ke te se sp fs t1 t2 e
 ,  TypeF  ke te se sp fs t1 t2 e
 -> WfT (length ke) e.
Proof. eauto. Qed.
Hint Resolve typeF_kindT_wfT.

Lemma typeF_kindT_t1
 :  forall ke te se sp fs t1 t2 e
 ,  TypeF  ke te se sp fs t1 t2 e
 -> KindT  ke sp t1 KData.
Proof.
 intros. induction H; eauto 2.
Qed.
Hint Resolve typeF_kindT_t1.

Lemma typeF_kindT_t2
 :  forall ke te se sp fs t1 t2 e
 ,  TypeF  ke te se sp fs t1 t2 e
 -> KindT  ke sp t2 KData.
Proof. intros. induction H; auto. Qed.
Hint Resolve typeF_kindT_t2.

(********************************************************************)
Lemma typeF_coversFs
 :  forall ke te se sp fs t1 t2 e
 ,  TypeF  ke te se sp fs t1 t2 e
 -> CoversFs se fs.
Proof.
 intros. gen ke te se sp t1 t2 e.
 induction fs as [|f]; intros.
 - eauto.
 - eapply Forall_cons; eauto.
   + inverts H.
     * eapply typeX_coversX; eauto.
     * unfold CoversF; snorm.
     * unfold CoversF; snorm.
   + inverts H; eapply IHfs; eauto.
Qed.

Lemma typeF_stenv_snoc
 :  forall ke te se sp fs t1 t2 t3 e
 ,  ClosedT t3
 -> TypeF ke te se         sp fs t1 t2 e
 -> TypeF ke te (t3 <: se) sp fs t1 t2 e.
Proof.
 intros.
 induction H0; eauto.

 - eapply TfConsExt; auto.
   eapply freshSuppFs_coveredFs.
   eapply typeF_coversFs; eauto. auto.
Qed.
Hint Resolve typeF_stenv_snoc.

Lemma typeF_stprops_snoc
 :  forall ke te se sp fs t1 t2 p e
 ,  TypeF  ke te se sp        fs t1 t2 e
 -> TypeF  ke te se (p <: sp) fs t1 t2 e.
Proof. intros. induction H; eauto. Qed.
Hint Resolve typeF_stprops_snoc.

Lemma typeF_freshFs
 :  forall ke te se sp fs t1 t2 e p
 ,  not (In (SRegion p) sp)
 -> TypeF ke te se sp fs t1 t2 e
 -> FreshFs p fs.
Proof.
 intros. gen ke te se sp t1 t2 e.
 induction fs; intros; auto.
 destruct a.
 - inverts H0.
   eapply freshFs_cons; eauto.
   simpl. rip. eauto.
   eapply freshX_typeX; eauto.
 - inverts H0.
   * eapply freshFs_cons; eauto.
     lets D: (@in_not_in stprop) H4 H.
     have (p <> n) by congruence.
     simpl. auto.
    * eapply freshFs_cons; eauto.
     snorm.
      + lets D: (@in_not_in stprop) H5 H.
        congruence.
      + lets D: (@in_not_in stprop) H5 H.
        congruence.
Qed.
Hint Resolve typeF_freshFs.

Lemma typeF_freshSuppFs
 :  forall ke te se sp fs t1 t2 e p
 ,  not (In (SRegion p) sp)
 -> TypeF ke te se sp fs t1 t2 e
 -> FreshSuppFs p se fs.
Proof.
 intros. gen ke te se sp t1 t2 e.
 induction fs as [|f]; intros; auto.
 eapply Forall_cons; auto.
 - clear IHfs.
   destruct f; snorm; inverts H0.
   + simpl.
     eapply freshSuppX_typeX; eauto.
 - inverts H0; eapply IHfs; eauto.
Qed.

Lemma typeF_allocRegion_noprivFs
 : forall ke te se sp fs t1 t2 e p
 ,  p = allocRegion sp
 -> TypeF ke te se sp fs t1 t2 e
 -> NoPrivFs p fs.
Proof.
 intros.
 eapply freshFs_noprivFs.
 eapply typeF_freshFs.
 lets D: allocRegion_fresh sp.
 rewrite <- H in D. eauto. eauto.
Qed.
Hint Resolve typeF_allocRegion_noprivFs.

Lemma typeF_mergeTE
 :  forall ke te se sp fs t1 t2 e p1 p2
 ,  FreshFs     p2 fs
 -> FreshFreeFs p2 te fs
 -> FreshSuppFs p2 se fs
 -> TypeF ke te se sp fs t1 t2 e
 -> TypeF ke (mergeTE p1 p2 te) (mergeTE p1 p2 se) sp fs t1 t2 e.
Proof.
 intros. gen ke te se sp t1 t2 e. gen p1 p2.
 induction fs as [|f]; intros.

 Case "nil".
 { inverts H2. eauto.
 }

 Case "cons".
 { destruct f.

   - SCase "FLet".
     have (FreshFs p2 fs). rip.

     have HF: (FreshF  p2 (FLet t e0))
      by (eapply freshFs_tail; eauto).
     unfold FreshF in HF. rip.

     inverts H2.
     eapply TfConsLet; auto.
     + rewrite mergeTE_rewind; auto.
       eapply mergeX_typeX_freshX; eauto.
       * inverts H0; snorm.
       * inverts H1; snorm.
     + eapply IHfs; eauto.

   - SCase "FPriv".
     inverts H2.
     * eapply TfConsPriv; auto.
       eapply IHfs; eauto.
     * eapply TfConsExt; eauto.
       have (FreshSuppFs p2 se fs).
       eapply freshSuppFs_mergeTE; auto.
 }
Qed.


From mathcomp Require Import ssreflect ssrfun eqtype seq ssrint.
From CoqUtils Require Import fmap fset word.

Require Extraction.
Require extraction.ExtrOcamlString.

Require Import Intermediate.Machine.
Require Import Common.Definitions.
Require Import MicroPolicies.Instance.
Require Import MicroPolicies.Printer.
Require Import I2MP.Encode.
Require Import I2MP.Linearize.

Require Import MicroPolicies.Utils.
Import DoNotation.

Definition test_program : Intermediate.program :=
  let c0 := [fmap (0, [:: ICall 1 0; IReturn])] in
  let c0_i := Component.mkCompInterface
                fset0
                (fset [:: (1, 0)]) in
  let c1 := [fmap (0, [:: IConst (IInt 5) R_COM; IReturn])] in
  let c1_i := Component.mkCompInterface
                (fset [:: 0])
                fset0 in
  Intermediate.mkProg
    [fmap (0, c0_i); (1, c1_i)] (* Interface: nothing imported/exported*)
    [fmap (0, c0); (1, c1)] (* code *)
    (emptym) (* Pre-allocated buffers *)
    (Some 0). (* Main procedure idtac *)

Definition test_alloc : Intermediate.program :=
  let c0 := [fmap (0, [:: IConst (IInt 5) R_ONE ; IAlloc R_COM R_ONE; IReturn])] in
  let c0_i := Component.mkCompInterface fset0 fset0 in
  Intermediate.mkProg
    emptym (* Interface: nothing imported/exported*)
    [fmap (0, c0)] (* code *)
    (emptym) (* Pre-allocated buffers *)
    (Some 0). (* Main procedure idtac *)

Definition test_program_machine := load (encode (linearize test_program)).
Definition test_alloc_machine := load (encode (linearize test_alloc)).

Extraction "/tmp/tl_test.ml" coqstring_of_state test_program_machine test_alloc_machine stepf.


(* begin hide *)

From mathcomp Require Import all_ssreflect.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Asymmetric Patterns.

From Equations Require Import Equations.

Require Import String.
Require Import QString.

Require Import SeqExtra.

Notation Name := string.

(* end hide *)
(**
   #

GraphQL Response

         This file contains the basic building blocks to define a GraphQL Response.

#
 *)

Section Response.

  (* Unsetting because the automatically generated induction principle is not good enough. *)
  Unset Elimination Schemes.

  Variable (Scalar : eqType).

  (** * Response
      ----
      Here we define a general Response structure, which is in essence a JSON tree.
      We later use this definition to build a GraphQL Response.

      A response can be either:
      - an optional _scalar_ values (to account for null values),
      - an object, mapping keys to other responses, or
      - an array of response values.
   *)
  Inductive ResponseValue : Type :=
  | Leaf : option Scalar -> ResponseValue
  | Object : seq (Name * ResponseValue) -> ResponseValue
  | Array : seq ResponseValue -> ResponseValue.

  Set Elimination Schemes.

  (** * GraphQL Response
      ----

      A GraphQL Response is, in essence, a JSON Object, mapping keys
      to other response values.
   *)
  Definition GraphQLResponse := seq (Name * ResponseValue).

  (** We define some auxiliary definitions *)
  (** ---- *)
  (**
     Gets the size of the response tree.
   *)

  Equations rsize (response : ResponseValue) : nat :=
    {
      rsize (Leaf _) := 1;
      rsize (Object rt) := (lrsize rt).+1;
      rsize (Array rt) := (list_size rsize rt).+1
    }
  where lrsize (r : seq (Name * ResponseValue)) : nat :=
          {
            lrsize [::] := 0;
            lrsize (hd :: tl) := rsize hd.2 + lrsize tl
          }.

  (** ---- *)
  (**
     This predicate checks whether the responses are non-redundant.

     Non-redundancy means that there are no duplicated keys.
   *)

  Equations is_non_redundant (response : ResponseValue) : bool :=
          {
            is_non_redundant (Leaf _) := true;

            is_non_redundant (Object rt) := are_non_redundant rt;

            is_non_redundant (Array rt) := all is_non_redundant rt
          }
  where are_non_redundant (responses : seq (Name * ResponseValue)) : bool  :=
    {
      are_non_redundant [::] := true;

      are_non_redundant ((k, q) :: qs) := [&& is_non_redundant q,
                                          all (fun kq => kq.1 != k) qs &
                                          are_non_redundant qs]
    }.

End Response.

(* begin hide *)
Arguments ResponseValue [Scalar].
Arguments Leaf [Scalar].
Arguments Object [Scalar].
Arguments Array [Scalar].
Arguments is_non_redundant [Scalar].
Arguments are_non_redundant [Scalar].
(* end hide *)

Delimit Scope response_scope with RESP.
Open Scope response_scope.

Notation "{- ρ -}" := (Object ρ) : response_scope.

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

        Previous ← Query
        Continue Reading → Query Semantics

#
*)


Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Language.
Require Import Loc.

Require Import Event.
Require Import Time.

Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import Cover.
Require Import Mapping.
Require Import Pred.
Require Import Trace.
Require Import MemoryProps.
Require Import PFConsistent.
Require Import PFConsistentStrong.

Set Implicit Arguments.

Module FutureCertify.
  Section FutureCertify.
    Variable (lang: language).

    Lemma cap_steps_current_steps
          th0 th1 mem1 sc1
          (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
          (MEMORY: Memory.closed (Thread.memory th0))
          (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
          (CAP: Memory.cap (Thread.memory th0) mem1)
          (SC_MAX: Memory.max_concrete_timemap mem1 sc1)
          (STEPS: rtc (@Thread.tau_step lang)
                      (Thread.mk lang (Thread.state th0) (Thread.local th0) sc1 mem1)
                      th1)
          (CONSISTENT: Local.promise_consistent (Thread.local th1))
      :
        exists lc' sc' mem',
          (<<STEPS: rtc (@Thread.tau_step lang)
                        th0
                        (Thread.mk lang (Thread.state th1) lc' sc' mem')>>) /\
          (<<CONSISTENT: Local.promise_consistent lc'>>)
    .
    Proof.
      eapply pred_steps_thread_steps in STEPS.
      destruct th0, th1. ss.
      hexploit steps_map.
      { eapply ident_map_le. }
      { eapply ident_map_bot. }
      { eapply ident_map_eq. }
      { i. eapply ident_map_mappable_evt. }
      { eapply STEPS. }
      { ss. }
      { ss. }
      { ss. }
      { eapply Local.cap_wf; eauto. }
      { eapply LOCAL. }
      { eauto. }
      { eapply Memory.cap_closed; eauto. }
      { eauto. }
      { eapply Memory.max_concrete_timemap_closed; eauto. }
      { eapply map_ident_in_memory_local; eauto; ss.
        eapply ident_map_lt.
      }
      { econs.
        { i. destruct msg as [val released|]; auto. right.
          exists to, from, (Message.concrete val released), (Message.concrete val released).
          eapply Memory.cap_inv in GET; eauto. des; ss. esplits; eauto.
          { refl. }
          { eapply ident_map_message. }
          { refl. }
        }
        { i. eapply CAP in GET. left. exists fto, ffrom, fto, ffrom. splits; ss.
          { refl. }
          { refl. }
          { i. econs; eauto. }
        }
      }
      { eapply mapping_map_lt_collapsable_unwritable. eapply ident_map_lt. }
      { eapply ident_map_timemap. }
      { eapply Memory.max_concrete_timemap_spec; eauto.
        eapply Memory.cap_closed_timemap; eauto. }
      { instantiate (1:=fun _ => True). ss. }
      i. des. esplits.
      { eapply rtc_implies; try apply STEP. i. inv H. inv TSTEP. econs; eauto. }
      { inv LOCAL0. eapply promise_consistent_mon; cycle 1; eauto.
        { refl. }
        eapply promise_consistent_map; eauto.
        { eapply ident_map_le; eauto. }
        { eapply ident_map_eq; eauto. }
      }
    Qed.

    Definition future_certify lang (e:Thread.t lang): Prop :=
      forall sc1 mem1
        (FUTURE: Memory.future_weak (Thread.memory e) mem1)
        (FUTURE: TimeMap.le (Thread.sc e) sc1)
        (WF: Local.wf (Thread.local e) mem1)
        (SC: Memory.closed_timemap sc1 mem1)
        (MEM: Memory.closed mem1),
        (<<FAILURE: Thread.steps_failure (Thread.mk lang (Thread.state e) (Thread.local e) sc1 mem1)>>) \/
        exists e2,
          (<<STEPS: rtc (@Thread.tau_step lang) (Thread.mk lang (Thread.state e) (Thread.local e) sc1 mem1) e2>>) /\
          (<<PROMISES: (Local.promises (Thread.local e2)) = Memory.bot>>).

    Lemma future_certify_exists
          e
          (LOCAL: Local.wf (Thread.local e) (Thread.memory e))
          (MEMORY: Memory.closed (Thread.memory e))
          (SC: Memory.closed_timemap (Thread.sc e) (Thread.memory e))
          (CONSISTENT: @Thread.consistent lang e):
      future_certify e.
    Proof.
      eapply consistent_pf_consistent_super_strong in CONSISTENT; eauto. des.
      exploit (@concrete_promise_max_timemap_exists (Thread.memory e) (Local.promises (Thread.local e))).
      { eapply MEMORY. } i. des.
      ii. exploit (CONSISTENT0 mem1 TimeMap.bot sc1); eauto. i. des.
      eapply Trace.silent_steps_tau_steps in STEPS; cycle 1.
      { eapply List.Forall_impl; eauto. i. ss. des. auto. }
      unguard. des.
      { left. unfold Thread.steps_failure. destruct e1. ss. esplits; eauto. }
      { right. esplits; eauto. }
    Qed.

    Lemma future_consistent
          e sc' mem'
          (LOCAL: Local.wf (Thread.local e) (Thread.memory e))
          (MEMORY: Memory.closed (Thread.memory e))
          (SC: Memory.closed_timemap (Thread.sc e) (Thread.memory e))
          (CONSISTENT: @Thread.consistent lang e)
          (SC_FUTURE: TimeMap.le (Thread.sc e) sc')
          (MEM_FUTURE: Memory.future_weak (Thread.memory e) mem')
          (LOCAL': Local.wf (Thread.local e) mem')
          (MEMORY': Memory.closed mem')
          (SC': Memory.closed_timemap sc' mem'):
      Thread.consistent (Thread.mk lang (Thread.state e) (Thread.local e) sc' mem').
    Proof.
      ii. ss.
      eapply future_certify_exists; try exact CONSISTENT; eauto.
      - etrans; eauto. eapply Memory.cap_future_weak; eauto.
      - etrans; eauto.
        hexploit Memory.cap_closed_timemap; try exact SC'; eauto. i.
        hexploit Memory.max_concrete_timemap_spec; eauto.
      - eapply Local.cap_wf; eauto.
      - eapply Memory.max_concrete_timemap_closed; eauto.
      - eapply Memory.cap_closed; eauto.
    Qed.
  End FutureCertify.
End FutureCertify.


(** following discussions with J. Gross, D. Grayson and V. Voevodsky *)

Require Import Foundations.Generalities.uuu.
Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.
Require Import RezkCompletion.auxiliary_lemmas_HoTT.
Require Import RezkCompletion.precategories.
Require Import RezkCompletion.functors_transformations.
Require Import RezkCompletion.limits.aux_lemmas_HoTT.

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
Local Notation "f ;; g" := (compose f g)(at level 50).
Local Notation "# F" := (functor_on_morphisms F)(at level 3).

Section Cone.

Variables J C : precategory.

Variable F : functor J C.

Definition ConeData := total2 (
  fun a : C => forall j : J, a --> F j).

Definition ConeTop (a : ConeData) : C := pr1 a.
Definition ConeMor (a : ConeData) (j : J) : ConeTop a --> F j := (pr2 a) j.

Lemma eq_ConeData_eq (a b : ConeData) (p q : a == b) :
   base_paths _ _ p == base_paths _ _ q -> p == q.
Proof.
  intro H.
  apply (eq_equalities_between_pairs _ _ _ _ _ _ H).
  apply uip.
  apply (impred 2); intro j.
  apply (pr2 (_ --> _ )).
Defined.

Definition ConeProp (a : ConeData) :=
  forall j j' (f : j --> j'), ConeMor a j ;; #F f == ConeMor a j'.

Lemma isaprop_ConeProp (a : ConeData) : isaprop (ConeProp a).
Proof.
  repeat (apply impred; intro).
  apply (pr2 (_ --> _)).
Qed.

Definition Cone := total2 (fun a : ConeData => ConeProp a).

Definition ConeData_from_Cone : Cone -> ConeData := fun a => pr1 a.

Lemma eq_Cone_eq (a b : Cone) (p q : a == b) :
   base_paths _ _ (base_paths _ _ p) ==
   base_paths _ _ (base_paths _ _ q) -> p == q.
Proof.
  intro H.
  assert (H2 : base_paths _ _ p == base_paths _ _ q).
  apply eq_ConeData_eq.
  apply H.
  apply (eq_equalities_between_pairs _ _ _ _ _ _ H2).
  apply uip.
  apply isasetaprop.
  apply isaprop_ConeProp.
Defined.

Coercion ConeData_from_Cone : Cone >-> ConeData.

Definition ConeProp_from_Cone (a : Cone) : ConeProp a := pr2 a.
Coercion ConeProp_from_Cone : Cone >-> ConeProp.

Lemma cone_prop (a : Cone) :
  forall j j' (f : j --> j'), ConeMor a j ;; #F f == ConeMor a j'.
Proof.
  exact (pr2 a).
Qed.

Definition Cone_eq (a b : Cone) : pr1 a == pr1 b -> a == b.
Proof.
  intro H.
  apply (total2_paths H).
  apply proofirrelevance.
  apply isaprop_ConeProp.
Defined.

Definition Cone_Mor (M N : Cone) :=
  total2 (fun f : ConeTop M --> ConeTop N =>
        forall j : J, f ;; ConeMor N j == ConeMor M j).

Lemma isaset_Cone_Mor (M N : Cone) : isaset (Cone_Mor M N).
Proof.
  apply (isofhleveltotal2 2).
  apply (pr2 (_ --> _ )).
  intros.
  apply hlevelntosn.
  apply impred.
  intros.
  apply (pr2 (_ --> _ )).
Qed.

Definition ConeConnect {M N : Cone} (f : Cone_Mor M N) :
    ConeTop M --> ConeTop N := pr1 f.

Lemma Cone_Mor_eq (M N : Cone) (f g : Cone_Mor M N) :
   ConeConnect f == ConeConnect g -> f == g.
Proof.
  intro H.
  apply (total2_paths H).
  apply proofirrelevance.
  apply impred; intro; apply (pr2 (_ --> _)).
Qed.

Lemma cone_mor_prop M N (f : Cone_Mor M N) :
    forall j : J, ConeConnect f ;; ConeMor N j == ConeMor M j.
Proof.
  exact (pr2 f).
Qed.

Definition Cone_id (A : Cone) : Cone_Mor A A.
Proof.
  exists (identity _).
  intros; apply id_left.
Defined.

Definition Cone_comp (A B D : Cone) (f : Cone_Mor A B)
        (g : Cone_Mor B D) : Cone_Mor A D.
Proof.
  exists (ConeConnect f ;; ConeConnect g).
  intro j.
  (* make this proof opaque *)
  rewrite <- assoc.
  rewrite cone_mor_prop.
  rewrite cone_mor_prop.
  apply idpath.
Defined.

Definition Cone_precategory_ob_mor : precategory_ob_mor :=
   precategory_ob_mor_pair Cone
   (fun a b => hSetpair (Cone_Mor a b) (isaset_Cone_Mor a b)).

Definition Cone_precategory_data : precategory_data.
Proof.
  exists Cone_precategory_ob_mor.
  exists Cone_id.
  exact Cone_comp.
Defined.

Lemma is_precategory_Cone : is_precategory Cone_precategory_data.
Proof.
  repeat split; simpl.

  intros;
  apply Cone_Mor_eq;
  simpl; apply id_left.

  intros;
  apply Cone_Mor_eq;
  simpl; apply id_right.

  intros;
  apply Cone_Mor_eq;
  simpl; apply assoc.
Qed.

Definition CONE : precategory := tpair _ _ is_precategory_Cone.

(* this should not need the pr1 before f *)

Definition iso_projects_from_CONE (a b : CONE) (f : iso a b) :
  is_isomorphism (ConeConnect (pr1 f)).
Proof.
  exists (ConeConnect (inv_from_iso f)).
  split; simpl.
  apply (base_paths _ _ (pr1 (pr2 (pr2 f)))).
  apply (base_paths _ _ (pr2 (pr2 (pr2 f)))).
Defined.

Definition ConeConnectIso {a b : CONE} (f : iso a b) :
   iso (ConeTop (pr1 a)) (ConeTop (pr1 b)) :=
 tpair _ _ (iso_projects_from_CONE a b f).

Lemma ConeConnectIso_identity_iso (a : CONE) :
   ConeConnectIso (identity_iso a) == identity_iso _ .
Proof.
  apply eq_iso.
  apply idpath.
Qed.

Lemma ConeConnectIso_inj (a b : CONE) (f g : iso a b) :
   ConeConnectIso f == ConeConnectIso g -> f == g.
Proof.
  intro H.
  apply eq_iso; simpl in *.
  apply Cone_Mor_eq.
  apply (base_paths _ _ H).
Qed.

Section CONE_category.

Hypothesis is_cat_C : is_category C.

Definition isotoid_CONE_pr1 (a b : CONE) : iso a b -> pr1 a == pr1 b.
Proof.
  intro f.
  apply (total2_paths (isotoid _ is_cat_C (ConeConnectIso f))).
  pathvia ((fun c : J =>
     idtoiso (!isotoid C is_cat_C (ConeConnectIso f));; pr2 (pr1 a) c)).
  apply transportf_isotoid_dep'.
  apply funextsec.
  intro t.
  pathvia (idtoiso (isotoid C is_cat_C (iso_inv_from_iso (ConeConnectIso f)));;
       pr2 (pr1 a) t).
  apply cancel_postcomposition.
  apply maponpaths. apply maponpaths.
  apply inv_isotoid.
  pathvia (iso_inv_from_iso (ConeConnectIso f);; pr2 (pr1 a) t).
  apply cancel_postcomposition.
  set (H := idtoiso_isotoid _ is_cat_C _ _ (iso_inv_from_iso (ConeConnectIso f))).
  simpl in *.
  apply (base_paths _ _ H).
  simpl.
  apply (pr2 (inv_from_iso f)).
Defined.

Definition isotoid_CONE {a b : CONE} : iso a b -> a == b.
Proof.
  intro f.
  apply Cone_eq.
  apply (isotoid_CONE_pr1 _ _ f).
Defined.

Lemma eq_CONE_pr1 (M N : CONE) (p q : M == N) : base_paths _ _ p == base_paths _ _ q -> p == q.
Proof.
  intro H.
  simpl in *.
  apply (eq_equalities_between_pairs _ _ _ _ _ _ H).
  apply proofirrelevance.
  apply isapropifcontr.
  apply isaprop_ConeProp.
Defined.

Lemma base_paths_isotoid_CONE (M : CONE):
base_paths (pr1 M) (pr1 M)
      (base_paths M M (isotoid_CONE (identity_iso M))) ==
    base_paths (pr1 M) (pr1 M) (idpath (pr1 M)).
Proof.
  pathvia (base_paths (pr1 M) (pr1 M) (isotoid_CONE_pr1 M M (identity_iso M))).
  unfold Cone_eq.
  apply maponpaths.
  apply base_total_path.
  pathvia (isotoid C is_cat_C (ConeConnectIso (identity_iso M))).
  unfold isotoid_CONE_pr1.
  apply base_total_path.
  pathvia (isotoid C is_cat_C (identity_iso (ConeTop (pr1 M)))).
  apply maponpaths, ConeConnectIso_identity_iso.
  apply isotoid_identity_iso.
Defined.

Lemma isotoid_CONE_idtoiso (M N : CONE) : forall p : M == N, isotoid_CONE (idtoiso p) == p.
Proof.
  intro p.
  induction p.
  apply eq_Cone_eq.
  apply base_paths_isotoid_CONE.
Qed.

Lemma ConeConnect_idtoiso (M N : CONE) (p : M == N):
  ConeConnect (pr1 (idtoiso p)) == idtoiso ((base_paths _ _ (base_paths _ _  p))).
Proof.
  destruct p.
  apply idpath.
Qed.

Lemma idtoiso_isotoid_CONE (M N : CONE) : forall f : iso M N, idtoiso (isotoid_CONE f) == f.
Proof.
  intro f.
  apply eq_iso.
  simpl.
  apply Cone_Mor_eq.
  rewrite ConeConnect_idtoiso.
  unfold isotoid_CONE.
  unfold Cone_eq.
  rewrite base_total_path.
  unfold isotoid_CONE_pr1.
  rewrite base_total_path.
  simpl.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.

Lemma is_category_CONE : is_category CONE.
Proof.
  unfold is_category.
  intros a b.
  apply (gradth _  (@isotoid_CONE a b)).
  apply isotoid_CONE_idtoiso.
  apply idtoiso_isotoid_CONE.
Defined.

End CONE_category.

End Cone.

Implicit Arguments CONE [J C].
Implicit Arguments ConeConnect [J C].