Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Fix.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope grammar_fixedpoint_scope.

Section grammar_fixedpoint.
  Context {Char : Type}.

  Context (gdata : grammar_fixedpoint_data)
          (G : pregrammar' Char).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Lemma pre_Fix_grammar_fixedpoint_correct_valid
        (P : default_nonterminal_carrierT -> state gdata -> Type)
        (Pinit : forall nt, is_true (is_valid_nonterminal initial_nonterminals_data nt)
                            -> P nt ⊥)
        (IH : forall nt st v,
            st nt = v
            -> is_true (is_valid_nonterminal initial_nonterminals_data nt)
            -> P nt v
            -> P nt (v ⊔ step_constraints gdata st nt v))
    : forall nt, is_true (is_valid_nonterminal initial_nonterminals_data nt) -> P nt (lookup_state (pre_Fix_grammar gdata initial_nonterminals_data) nt).
  Proof.
    specialize (fun nt st => IH nt st _ eq_refl).
    assert (Hvalid' : forall nt,
               is_true (is_valid_nonterminal initial_nonterminals_data nt)
               -> match FMapPositive.PositiveMap.find
                          (nonterminal_to_positive nt)
                          (aggregate_state_max gdata initial_nonterminals_data)
                  with
                  | Some v => P nt v
                  | None => False
                  end).
    { intros nt Hvalid.
      pose proof (find_aggregate_state_max_spec gdata G (nonterminal_to_positive nt)) as Hvalid'.
      rewrite nonterminal_to_positive_to_nonterminal in Hvalid'.
      edestruct Hvalid' as [Hvalid'0 Hvalid'1].
      simpl in *.
      rewrite Hvalid'1 by (split; [ reflexivity | assumption ]).
      eauto. }
    pose proof (fun nt (pf : is_true (is_valid_nonterminal (@initial_nonterminals_data _ (@rdp_list_predata _ G)) nt))
                => match eq_sym pf in (_ = b)
                         return (if b then ⊥ else ⊤) =
                                lookup_state (aggregate_state_max gdata initial_nonterminals_data) nt
                                -> _
                   with
                   | eq_refl => eq_rect _ (P nt) (Pinit _ pf) _
                   end (eq_sym (lookup_state_aggregate_state_max gdata G nt))) as Pinit'.
    unfold pre_Fix_grammar, pre_Fix_grammar_helper.
    let Rwf := lazymatch goal with |- context[Fix ?Rwf _ _ ?v] => Rwf end in
    let v := lazymatch goal with |- context[Fix Rwf _ _ ?v] => v end in
    pose proof (fun nt => IH nt (lookup_state v)) as IHv;
      specialize (fun nt pf => IHv nt pf (Pinit' _ pf));
      induction (Rwf v) as [a Ha IHa].
    rewrite Init.Wf.Fix_eq by (intros; edestruct Sumbool.sumbool_of_bool; trivial).
    edestruct Sumbool.sumbool_of_bool; [ intros; apply Pinit'; assumption | ].
    fold (pre_Fix_grammar_helper (gdata := gdata) initial_nonterminals_data) in *.
    destruct (aggregate_state_eq a (aggregate_step a)) eqn:Heq.
    { intuition congruence. }
    { apply step_lt in Heq.
      intros nt.
      apply IHa; eauto; intros; try apply IH;
        repeat match goal with
               | _ => progress intros
               | _ => rewrite find_aggregate_step
               | _ => rewrite lookup_state_aggregate_step
               | _ => rewrite nonterminal_to_positive_to_nonterminal
               | _ => tauto
               | _ => assumption
               | _ => progress unfold lookup_state, PositiveMapExtensions.find_default, state, option_map, option_rect in *
               | [ H : forall nt, is_true (?P nt) -> _, H' : is_true (?P _) |- _ ]
                 => specialize (H _ H')
               | [ |- ?P ?nt (_ ⊔ _) ] => apply P_lub
               | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
               | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
               end. }
  Qed.

  Lemma pre_Fix_grammar_fixedpoint_correct
        (P : default_nonterminal_carrierT -> state gdata -> Type)
        (Pbot : forall nt, is_true (is_valid_nonterminal initial_nonterminals_data nt)
                          -> P nt ⊥)
        (Ptop : forall nt, is_valid_nonterminal initial_nonterminals_data nt = false
                           -> P nt ⊤)
        (IH : forall nt st v,
            st nt = v
            -> is_true (is_valid_nonterminal initial_nonterminals_data nt)
            -> P nt v
            -> P nt (v ⊔ step_constraints gdata st nt v))
    : forall nt, P nt (lookup_state (pre_Fix_grammar gdata initial_nonterminals_data) nt).
  Proof.
    intro nt.
    destruct (is_valid_nonterminal (@initial_nonterminals_data _ (@rdp_list_predata _ G)) nt) eqn:Hvalid.
    { apply pre_Fix_grammar_fixedpoint_correct_valid; eauto with nocore. }
    { simpl rewrite lookup_state_invalid_pre_Fix_grammar; [ | assumption ]. eauto with nocore. }
  Qed.

  Lemma pre_Fix_grammar_fixedpoint_correct_stronger'
        (P : default_nonterminal_carrierT -> state gdata -> Type)
        (Pbot : forall nt, is_true (is_valid_nonterminal initial_nonterminals_data nt)
                          -> P nt ⊥)
        (Ptop : forall nt, is_valid_nonterminal initial_nonterminals_data nt = false
                           -> P nt ⊤)
        (IH : forall nt st,
            (forall nt', is_valid_nonterminal initial_nonterminals_data nt' = false -> st nt' = ⊤)
            -> (forall nt', P nt' (st nt'))
            -> P nt (st nt ⊔ step_constraints gdata st nt (st nt)))
    : forall nt, is_true (is_valid_nonterminal initial_nonterminals_data nt) -> P nt (lookup_state (pre_Fix_grammar gdata initial_nonterminals_data) nt).
  Proof.
    assert (Htop : forall nt', is_valid_nonterminal initial_nonterminals_data nt' = false -> lookup_state (aggregate_state_max gdata initial_nonterminals_data) nt' = ⊤).
    { intros nt' Hinvalid.
      simpl rewrite lookup_state_aggregate_state_max; simpl in *; rewrite Hinvalid.
      reflexivity. }
    assert (Hvalid' : forall nt,
               is_true (is_valid_nonterminal initial_nonterminals_data nt)
               -> match FMapPositive.PositiveMap.find
                          (nonterminal_to_positive nt)
                          (aggregate_state_max gdata initial_nonterminals_data)
                  with
                  | Some v => P nt v
                  | None => False
                  end).
    { intros nt Hvalid.
      pose proof (find_aggregate_state_max_spec gdata G (nonterminal_to_positive nt)) as Hvalid'.
      rewrite nonterminal_to_positive_to_nonterminal in Hvalid'.
      edestruct Hvalid' as [Hvalid'0 Hvalid'1].
      simpl rewrite Hvalid'1; [ | split; [ reflexivity | assumption ] ].
      eauto. }
    pose proof (fun nt
                => match is_valid_nonterminal (@initial_nonterminals_data _ (@rdp_list_predata _ G)) nt as b
                         return is_valid_nonterminal (@initial_nonterminals_data _ (@rdp_list_predata _ G)) nt = b
                                -> (if b then ⊥ else ⊤) =
                                   lookup_state (aggregate_state_max gdata initial_nonterminals_data) nt
                                -> _
                   with
                   | true => fun pf => eq_rect _ (P nt) (Pbot _ pf) _
                   | false => fun pf => eq_rect _ (P nt) (Ptop _ pf) _
                   end eq_refl (eq_sym (lookup_state_aggregate_state_max gdata G nt))) as Pinit'.
    unfold pre_Fix_grammar, pre_Fix_grammar_helper.
    let Rwf := lazymatch goal with |- context[Fix ?Rwf _ _ ?v] => Rwf end in
    let v := lazymatch goal with |- context[Fix Rwf _ _ ?v] => v end in
    pose proof (fun nt => IH nt (lookup_state v)) as IHv;
      specialize (fun nt => IHv nt Htop Pinit');
      induction (Rwf v) as [a Ha IHa].
    rewrite Init.Wf.Fix_eq by (intros; edestruct Sumbool.sumbool_of_bool; trivial).
    edestruct Sumbool.sumbool_of_bool; [ intros; apply Pinit'; assumption | ].
    fold (pre_Fix_grammar_helper (gdata := gdata) initial_nonterminals_data) in *.
    destruct (aggregate_state_eq a (aggregate_step a)) eqn:Heq.
    { intuition congruence. }
    { apply step_lt in Heq.
      intros nt.
      simpl @nonterminal_carrierT in *.
      apply IHa; eauto; intros; try apply IH;
        repeat match goal with
               | _ => progress intros
               | _ => rewrite find_aggregate_step
               | _ => rewrite lookup_state_aggregate_step
               | _ => rewrite nonterminal_to_positive_to_nonterminal
               | _ => tauto
               | _ => assumption
               | _ => progress subst
               | _ => progress unfold lookup_state, PositiveMapExtensions.find_default, state, option_map, option_rect in *
               | [ H : ?A -> ?B, H' : ?A |- _ ]
                 => specialize (H H')
               | [ H : is_true true -> _ |- _ ] => specialize (H eq_refl)
               | [ |- is_true true ] => reflexivity
               | [ |- is_true false ] => exfalso
               | [ |- ?P ?nt (_ ⊔ _) ] => apply P_lub
               | _ => rewrite top_lub_l
               | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
               | [ H : forall nt : default_nonterminal_carrierT, _ |- _ ]
                 => repeat match goal with
                           | [ nt' : default_nonterminal_carrierT |- _ ]
                             => unique pose proof (H nt')
                           | [ H' : context[is_valid_nonterminal _ ?nt'] |- _ ]
                             => unique pose proof (H nt')
                           | [ |- context[is_valid_nonterminal _ ?nt'] ]
                             => unique pose proof (H nt')
                           end;
                      clear H
               | [ H : forall a b, is_true (is_valid_nonterminal ?ls ?nt) -> _ |- _ ]
                 => destruct (is_valid_nonterminal ls nt) eqn:?
               | [ P_lub : forall a b, _ -> _ -> _ -> ?P ?nt (_ ⊔ _) |- ?P ?nt (_ ⊔ _) ] => apply P_lu
               | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
               | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
               end. }
  Qed.

  Lemma pre_Fix_grammar_fixedpoint_correct_stronger
        (P : default_nonterminal_carrierT -> state gdata -> Type)
        (Pbot : forall nt, is_true (is_valid_nonterminal initial_nonterminals_data nt)
                            -> P nt ⊥)
        (Ptop : forall nt, is_valid_nonterminal initial_nonterminals_data nt = false
                           -> P nt ⊤)
        (IH : forall nt st,
            (forall nt', is_valid_nonterminal initial_nonterminals_data nt' = false -> st nt' = ⊤)
            -> (forall nt', P nt' (st nt'))
            -> is_true (is_valid_nonterminal initial_nonterminals_data nt)
            -> P nt (st nt ⊔ step_constraints gdata st nt (st nt)))
    : forall nt, P nt (lookup_state (pre_Fix_grammar gdata initial_nonterminals_data) nt).
  Proof.
    intro nt.
    destruct (is_valid_nonterminal (@initial_nonterminals_data _ (@rdp_list_predata _ G)) nt) eqn:Hvalid.
    { apply pre_Fix_grammar_fixedpoint_correct_stronger'; eauto with nocore.
      { intros nt'' st'' Hfalse H''.
        move IH at bottom.
        specialize (IH nt'').
        let v := match type of IH with context[is_true ?v] => v end in
        destruct v eqn:Hvalid'; eauto; [].
        { rewrite Hfalse by assumption.
          rewrite top_lub_l.
          eauto. } } }
    { simpl rewrite lookup_state_invalid_pre_Fix_grammar; [ | assumption ]. eauto with nocore. }
  Qed.
End grammar_fixedpoint.


(* -*- coding:utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Logic *)
Notation "∀  x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity) : type_scope.
Notation "∃  x .. y , P" := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity) : type_scope.

Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope.
Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.

(* Abstraction *)
Notation "'λ'  x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity).


Require Import GHC.Types.

Definition arrow  := (fun (x y :Type) => x -> y).

Definition seq {A} {B} (a : A) (b:B) := b.

(* Coq has no levity polymorphism, so map everything to Type *)
Definition TYPE (_ : RuntimeRep) := Type.

(* Unpeel class: A directed form of Coercible, where a is the newtype type,
   and b the base type *)
Class Unpeel a b :=
  { unpeel : a -> b
  ; repeel : b -> a }.

#[export] Instance Unpeel_refl a : Unpeel a a := Build_Unpeel _ _ (fun x => x) (fun x => x).

#[export] Instance Unpeel_arrow
  a b c d
  `{Unpeel b a}
  `{Unpeel c d}
  : Unpeel (b -> c) (a -> d) :=
  { unpeel f x := unpeel (f (repeel x))
  ; repeel f x := repeel (f (unpeel x))
  }.

#[export] Instance Unpeel_pair
  a b c d
  `{Unpeel a b}
  `{Unpeel c d}
  : Unpeel (a * c) (b * d) :=
  { unpeel '(x,y) := (unpeel x, unpeel y)
  ; repeel '(x,y) := (repeel x, repeel y)
  }.

Require Coq.Lists.List.
#[export] Instance Unpeel_list a b
   `{Unpeel a b} : Unpeel (list a) (list b) :=
  { unpeel x := Coq.Lists.List.map unpeel x
  ; repeel x := Coq.Lists.List.map repeel x
  }.

Class Coercible a b := { coerce : a -> b }.

#[export] Instance Coercible_Unpeel
  a b c
  {U1 : Unpeel a c}
  {U2 : Unpeel b c}
  : Coercible a b :=
  { coerce x := @repeel b c U2 (@unpeel a c U1 x) }.


From CasperCBC Require Import Lib.Preamble VLSM.Common VLSM.Composition VLSM.Decisions VLSM.ProjectionTraces.

(** * VLSM Common Futures and Decision Consistency *)

(**
In this module we provide a definition for the [HasCommonFuturesEstimates]
property and then we show that a VLSM equiped with this property
has [final_and_consistent] decisions.
*)

Section CommonFutures.

Context
  {message : Type}
  {index : Type}
  {IndEqDec : EqDecision index}
  (IM : index -> VLSM message)
  {i0 : Inhabited index}
  (constraint : composite_label IM -> composite_state IM * option message -> Prop)
  (X := composite_vlsm IM constraint)
  {CV : consensus_values}
  (ID : forall i : index, vdecision (IM i))
  (IE : forall i : index, Estimator (vstate (IM i)) C)
  (DE : forall i : index, composite_projection_decision_estimator_property IM constraint ID IE i)
  .

(**
Let us fix an indexed set of VLSMs <<IM>> and their composition <<X>> using <<constraint>>.
For each component of index i, let <<IE i>> be an [Estimator] for Xi and let
<<ID i>> be a [decision] function for Xi, linked together by the
[decision_estimator_property].

*)

(** ** Common futures estimates definition *)

(**
We say that the composition <<X>> [HasCommonFutureEstimates] if there
exists a function [union] taking composite states to composit states
such that for each composite state <<s>>, its [union_is_reachable] from <<s>>,
and the [union_has_consistent_estimators]; i.e.,
all components yields the same estimates.
*)

Class HasCommonFutureEstimates :=
  { union : vstate X -> vstate X
  ; union_is_reachable
    : forall
      (s : vstate X)
      (Hps : protocol_state_prop X s)
      , in_futures X s (union s)
  ; union_has_consistent_estimators
    : forall
      (s : vstate X)
      (Hps : protocol_state_prop X s)
      (i j : index)
      (c : C),
      estimator (union s i) c <-> estimator (union s j) c
  }.

(** ** Final and consistent decisions

If a [VLSM] composition <<X>> [HasCommonFuturesEstimates] and its component
decisions are linked with the corresponding estimators through the
[decision_estimator_property], then <<X>> has [final_and_consistent]
decisions.
*)

Lemma consistent_estimator_decisions
  (HCFE : HasCommonFutureEstimates)
  : final_and_consistent IM constraint ID.
Proof.
  unfold final_and_consistent; intros.
  specialize (in_futures_protocol_snd X s1 s2 Hfuture); intros Hps2.
  specialize (union_is_reachable s2 Hps2); intro HcmnFuture.
  specialize (union_has_consistent_estimators s2 Hps2 j k)
  ; intros HconsEst.
  specialize (in_futures_trans X s1 s2 (union s2) Hfuture HcmnFuture)
  ; intro HcmnFuture1.
  specialize (in_futures_projection IM constraint j s1 (union s2) HcmnFuture1)
  ; intros HFuture1.
  assert (Dej := DE j).
  specialize (Dej (s1 j) c1 HDecided1 (union s2 j) HFuture1).
  specialize (in_futures_projection IM constraint k s2 (union s2) HcmnFuture)
  ; intros HFuture2.
  assert (Dek := DE k).
  specialize (Dek (s2 k) c2 HDecided2 (union s2 k) HFuture2).
  specialize (estimator_total (union s2 j)); intros [c Hc].
  specialize (HconsEst c).
  specialize (Dej c Hc).
  apply HconsEst in Hc.
  specialize (Dek c Hc).
  subst.
  reflexivity.
Qed.

End CommonFutures.


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 RVIC2.Specs.rvic_set_flag.
Require Import RVIC2.LowSpecs.rvic_set_flag.
Require Import RVIC2.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
       interrupt_bitmap_dword_spec
       interrupt_bit_spec
       atomic_bit_set_release_64_spec
       get_bitmap_loc_spec
    .

  Lemma shiftl4:
    forall n, Z.shiftl n 4 = n * 16.
  Proof.
    intros. Local Transparent Z.shiftl.
    unfold Z.shiftl; simpl. omega.
    Local Opaque Z.shiftl.
  Qed.

  Lemma rvic_set_flag_spec_exists:
    forall habd habd'  labd intid bitmap
           (Hspec: rvic_set_flag_spec intid bitmap habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', rvic_set_flag_spec0 intid bitmap labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. inv Hrel. destruct bitmap.
    unfold rvic_set_flag_spec, rvic_set_flag_spec0 in *.
    repeat autounfold in *. simpl 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 * ).
    - (solve_bool_range; grewrite). (solve_bool_range; grewrite). (solve_bool_range; grewrite).
      extract_if. rewrite shiftl4. apply andb_true_iff; split; bool_rel; omega. grewrite.
      (solve_bool_range; grewrite). rewrite a_plus_16; try omega.
      repeat (simpl_htarget; grewrite; simpl in * ).
      eexists; split. reflexivity. constructor.
      rewrite a_plus_16'; try omega. reflexivity.
    - (solve_bool_range; grewrite). (solve_bool_range; grewrite). (solve_bool_range; grewrite).
      extract_if. rewrite shiftl4. apply andb_true_iff; split; bool_rel; omega. grewrite.
      (solve_bool_range; grewrite). rewrite a_plus_16; try omega.
      repeat (simpl_htarget; grewrite; simpl in * ).
      eexists; split. reflexivity. constructor.
      rewrite a_plus_16'; try omega. reflexivity.
  Qed.

End Refine.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef1.Specs.data_destroy1.
Require Import TableDataOpsRef1.LowSpecs.data_destroy1.
Require Import TableDataOpsRef1.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
       data_destroy_spec
    .

  Lemma data_destroy1_spec_exists:
    forall habd habd'  labd g_rd map_addr res
      (Hspec: data_destroy1_spec g_rd map_addr habd = Some (habd', res))
      (Hrel: relate_RData habd labd),
    exists labd', data_destroy1_spec0 g_rd map_addr labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    Local Opaque peq ptr_eq.
    intros. duplicate Hrel. destruct D. clear hrepl lrepl. destruct g_rd.
    unfold data_destroy1_spec, data_destroy1_spec0 in *.
    unfold Assertion in *. rm_bind Hspec; rm_bind'. simpl in *.
    unfold Assertion; rm_bind'; grewrite.
    repeat simpl_hyp Hspec; extract_prop_dec; simpl_query_oracle; rm_bind'; grewrite.
    - repeat destruct_con.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C3; simpl in *.
      repeat (grewrite; simpl).
      assert(Hwalk: repl habd (oracle habd
                                      (EVT CPU_ID (RTT_WALK (g_rtt (gnorm (gs (share habd)) @ z)) z0 1) :: oracle habd (log habd) ++ log habd)) s1 = Some s1).
      destruct Hrel. grewrite. destruct valid_ho0. rewrite Hright_log_nil. reflexivity.
      eapply RightLogMover.
      apply walk_right. omega. omega. apply RightLogOracle. simpl.
      rewrite_oracle_rel rel_oracle Hwalk; simpl in *.
      repeat (grewrite; simpl).
      rewrite_oracle_rel rel_oracle C; simpl in *.
      repeat (grewrite; try simpl_htarget; simpl).
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - repeat destruct_con.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C; simpl in *.
      repeat (grewrite; simpl).
      assert(Hwalk: repl habd (oracle habd
                                      (EVT CPU_ID (RTT_WALK (g_rtt (gnorm (gs (share habd)) @ z)) z0 1) :: oracle habd (log habd) ++ log habd)) s0 = Some s0).
      destruct Hrel. grewrite. destruct valid_ho0. rewrite Hright_log_nil. reflexivity.
      eapply RightLogMover.
      apply walk_right. omega. omega. apply RightLogOracle. simpl.
      rewrite_oracle_rel rel_oracle Hwalk; simpl in *.
      repeat (grewrite; simpl).
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity. simpl_htarget. reflexivity.
    - repeat destruct_con.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; simpl).
      assert(Hwalk: repl habd (oracle habd
                                      (EVT CPU_ID (RTT_WALK (g_rtt (gnorm (gs (share habd)) @ z)) z0 1) :: oracle habd (log habd) ++ log habd)) s = Some s).
      destruct Hrel. grewrite. destruct valid_ho0. rewrite Hright_log_nil. reflexivity.
      eapply RightLogMover.
      apply walk_right. omega. omega. apply RightLogOracle. simpl.
      rewrite_oracle_rel rel_oracle Hwalk; simpl in *.
      repeat (grewrite; simpl).
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - rewrite_oracle_rel rel_oracle C2.
      repeat destruct_con.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      repeat (grewrite; simpl).
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - rewrite_oracle_rel rel_oracle C2.
      repeat (grewrite; simpl).
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
  Qed.

End Refine.


Require Export MinBFTprops2.
Require Export MinBFTsame.
Require Export MinBFTass_mon.
Require Export MinBFTass_tlearn.
Require Export MinBFTass_uniq.
Require Export MinBFTass_new2.
Require Export MinBFTass_tknew.
Require Export ComponentAxiom.

Section MinBFTagreement.

  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 agreement :
    forall (eo : EventOrdering) (e1 e2 : Event) r1 r2 i l1 l2,
      AXIOM_authenticated_messages_were_sent_or_byz eo MinBFTsys
      -> In (send_accept (accept r1 i) l1) (M_output_sys_on_event MinBFTsys e1)
      -> In (send_accept (accept r2 i) l2) (M_output_sys_on_event MinBFTsys e2)
      -> r1 = r2.
  Proof.
    introv sendbyz send1 send2.
    applydup in_output_implies_is_replica in send1 as isrep1.
    applydup in_output_implies_is_replica in send2 as isrep2.

    unfold is_replica in *.
    destruct isrep1 as [i1 isrep1].
    destruct isrep2 as [i2 isrep2].
    unfold M_output_sys_on_event in send1; rewrite isrep1 in send1; simpl in send1.
    unfold M_output_sys_on_event in send2; rewrite isrep2 in send2; simpl in send2.

    applydup @accepted_counter_if_know_UI_primary in send1 as statea.
    applydup @accepted_counter_if_know_UI_primary in send2 as stateb.
    exrepnd.

    applydup preserves_view_init_ls in statea0 as eqv1; auto.
    applydup preserves_view_init_ls in stateb0 as eqv2; auto.
    rewrite eqv1, eqv2 in *.
    clear eqv1 eqv2.

    applydup M_run_ls_on_event_MinBFT_to_components in statea0; repnd; auto;[].
    applydup M_run_ls_on_event_MinBFT_to_components in stateb0; repnd; auto;[].

    pose proof (request_data_was_verified e1 s4 s3 initial_view r1 ui0) as ka.
    repeat (autodimp ka hyp); try (complete (eexists; eauto)); exrepnd;[].

    pose proof (request_data_was_verified e2 s2 s1 initial_view r2 ui) as kb.
    repeat (autodimp kb hyp); try (complete (eexists; eauto)); exrepnd;[].

    assert (ex_node_e e1) as ex1 by (unfold ex_node_e; allrw; simpl; eauto).
    assert (ex_node_e e2) as ex2 by (unfold ex_node_e; allrw; simpl; eauto).

    pose proof (DERIVED_RULE_trusted_knowledge_unique3_true
                  (MkEventN e1 ex1) (MkEventN e2 ex2) (MkEventN e2 ex2)
                  [] []
                  (MinBFTprimary initial_view)
                  ui0
                  ui
                  (ui2counter ui0)
                  (ui2counter ui)
                  (minbft_data_rdata (request_data initial_view r1 ui0))
                  (minbft_data_rdata (request_data initial_view r2 ui))) as knc.
    unfold rule_true in knc; simpl in knc.
    repeat (autodimp knc hyp); eauto 2 with minbft;[|].

    { Opaque ASSUMPTION_trusted_learns_if_gen.
      Opaque ASSUMPTION_trusted_knew_or_learns_or_gen.
      Opaque ASSUMPTION_monotonicity.
      Opaque ASSUMPTION_generates_new.
      Opaque ASSUMPTION_disseminate_unique.
      introv vt vd vc vn xx yy zz.
      induction es using Vector.caseS'; simpl in *.
      clear vt vd vc vn es.
      repndors; subst; unfold seq_concl, seq_event in *;
        simpl in *; introv; simpl in *; tcsp;
          try (complete (unfold data_is_owned_by; minbft_simp; allrw; auto));
          try (complete (apply ASSUMPTION_trusted_learns_if_gen_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_trusted_knew_or_learns_or_gen_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_monotonicity_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_disseminate_unique_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_generates_new_true; auto; destruct h0; auto));
          try (complete (eexists; simpl;allrw; simpl; eauto));
          try (complete (repeat (eexists; dands; eauto)));
          try (complete (allrw; auto));
          try (complete (rewrite (state_usig_same_keys e1) in ka; auto; rewrite isrep1 in ka;
                         unfold generated_for; simpl; dands; auto; introv xx; ginv; eexists; eauto));
          try (complete (rewrite (state_usig_same_keys e2) in kb; auto; rewrite isrep2 in kb;
                         unfold generated_for; simpl; dands; auto; introv xx; ginv; eexists; eauto)). }

    unfold sequent_true in knc; simpl in knc; repeat (autodimp knc hyp); tcsp;[].
    inversion knc; subst; subst; auto.
  Qed.

End MinBFTagreement.


From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import Lustre.LSyntax.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import Transcription.Tr.

From Velus Require Import CoreExpr.CEIsFree.
From Velus Require Import CoreExpr.CEClocking.
From Velus Require Import Lustre.LClocking.
From Velus Require Import NLustre.IsDefined.
From Velus Require Import NLustre.IsFree.
From Velus Require Import NLustre.Memories.
From Velus Require Import NLustre.NLOrdered.
From Velus Require Import NLustre.NLClocking.

From Coq Require Import String.
From Coq Require Import Permutation.

From Coq Require Import List.
Import List.ListNotations.

From compcert Require Import common.Errors.
Open Scope error_monad_scope.

(** * Clocking Preservation for Transcription *)

Module Type TRCLOCKING
       (Import Ids  : IDS)
       (Import Op   : OPERATORS)
       (Import OpAux: OPERATORS_AUX  Op)
       (L           : LSYNTAX    Ids Op)
       (LC          : LCLOCKING  Ids Op L)
       (Import CE   : CESYNTAX       Op)
       (NL          : NLSYNTAX   Ids Op CE)
       (Import Ord  : NLORDERED  Ids Op CE NL)
       (Import Mem  : MEMORIES   Ids Op CE NL)
       (Import IsD  : ISDEFINED  Ids Op CE NL Mem)
       (Import CEIsF: CEISFREE   Ids Op CE)
       (Import IsF  : ISFREE     Ids Op CE NL CEIsF)
       (Import CEClo: CECLOCKING Ids Op CE)
       (NLC         : NLCLOCKING Ids Op CE NL Ord Mem IsD CEIsF IsF CEClo)
       (Import TR   : TR Ids Op OpAux L CE NL).

  Lemma envs_eq_in :
    forall env cenv x ck,
      envs_eq env cenv ->
      find_clock env x = OK ck ->
      In (x, ck) cenv.
  Proof.
    unfold find_clock, envs_eq. intros * Heq Hin.
    cases_eqn HH. inv Hin. apply Heq; eauto.
  Qed.

  Lemma find_clock_det :
    forall env x ck ck',
      find_clock env x = OK ck ->
      find_clock env x = OK ck' ->
      ck = ck'.
  Proof.
    unfold find_clock. intros. cases. congruence.
  Qed.

  Lemma wc_lexp :
    forall G vars e e',
      to_lexp e = OK e' ->
      LC.wc_exp G vars e ->
      (exists ck,
          L.clockof e = [ck]
          /\ wc_exp vars e' ck).
  Proof.
    intros * Hto Hwc. revert dependent e'.
    induction e using L.exp_ind2; intros; inv Hto; inv Hwc.
    - exists Cbase. split; constructor.
    - simpl. unfold L.clock_of_nclock, stripname. simpl. esplit; split; eauto.
      monadInv H0. now constructor.
    - simpl. unfold L.clock_of_nclock, stripname. simpl. esplit; split; eauto.
      monadInv H0. now constructor.
    - simpl. unfold L.clock_of_nclock, stripname. simpl. esplit; split; eauto.
      monadInv H0. constructor. apply IHe in EQ as (?&?&?); eauto.
      congruence.
    - simpl. unfold L.clock_of_nclock, stripname. simpl. esplit; split; eauto.
      monadInv H0. constructor.
      + apply IHe1 in EQ as (?&?&?); eauto. congruence.
      + apply IHe2 in EQ1 as (?&?&?); eauto. congruence.
    - cases.
      simpl. unfold L.clock_of_nclock, stripname. simpl. esplit; split; eauto.
      take (_ = OK e') and monadInv it. simpl_Foralls.
      constructor; auto.
      take (_ -> _) and apply it in EQ as (?& Heq &?); auto.
      unfold L.clocksof in *. simpl in *. rewrite app_nil_r in *.
      rewrite Heq in *. simpl_Foralls. congruence.
  Qed.

  Lemma wc_exp_cexp :
    forall vars e ck,
      wc_exp vars e ck ->
      wc_cexp vars (Eexp e) ck.
  Proof.
    now constructor.
  Qed.

  Lemma wc_cexp :
    forall G vars e e',
      to_cexp e = OK e' ->
      LC.wc_exp G vars e ->
      (exists ck,
          L.clockof e = [ck]
          /\ wc_cexp vars e' ck).
  Proof.
    intros * Hto Hwc. revert dependent e'.
    induction e using L.exp_ind2; intros;
      unfold to_cexp in Hto; try monadInv Hto;
        repeat (take (to_lexp _ = _) and eapply wc_lexp in it as (?&?&?);
                eauto); eauto using wc_exp_cexp.
    - cases. monadInv Hto.
      simpl_Foralls.
      simpl. unfold L.clock_of_nclock, stripname. simpl. esplit; split; eauto.
      inv Hwc. simpl_Foralls. constructor; simpl; auto.
      + take (_ -> _) and apply it in EQ as (?& Heq &?); auto.
        unfold L.clocksof in *. simpl in *. rewrite app_nil_r in *.
        rewrite Heq in *. simpl_Foralls. congruence.
      + take (LC.wc_exp _ _ e0 -> _) and apply it in EQ1 as (?& Heq &?); auto.
        unfold L.clocksof in *. simpl in *. rewrite app_nil_r in *.
        rewrite Heq in *. simpl_Foralls. congruence.
    - cases. monadInv Hto.
      simpl_Foralls.
      simpl. unfold L.clock_of_nclock, stripname. simpl. esplit; split; eauto.
      inv Hwc. simpl_Foralls. constructor; simpl; auto.
      + eapply wc_lexp in EQ as (?& Heq &?); eauto. congruence.
      + take (_ -> _) and apply it in EQ1 as (?& Heq &?); auto.
        unfold L.clocksof in *. simpl in *. rewrite app_nil_r in *.
        rewrite Heq in *. simpl_Foralls. congruence.
      + take (LC.wc_exp _ _ e1 -> _) and apply it in EQ0 as (?& Heq &?); auto.
        unfold L.clocksof in *. simpl in *. rewrite app_nil_r in *.
        rewrite Heq in *. simpl_Foralls. congruence.
  Qed.

  (* correctness of substition extension *)
  Lemma instck_sub_ext :
    forall bck sub ck ck' P,
      instck bck sub ck = Some ck' ->
      instck bck (fun x => match sub x with
                        | None => P x
                        | s => s
                        end) ck = Some ck'.
  Proof.
    intros * Hinst.
    revert dependent ck'. induction ck; intros; auto.
    inv Hinst.
    destruct (instck bck sub ck) eqn:?; try discriminate.
    destruct (sub i) eqn:Hs; try discriminate.
    specialize (IHck c eq_refl).
    simpl. now rewrite IHck, Hs.
  Qed.

  Lemma wc_equation :
    forall G Hprefs P env envo vars e e',
      to_global G Hprefs = OK P ->
      to_equation env envo e = OK e' ->
      envs_eq env vars ->
      LC.wc_global G ->
      LC.wc_equation G vars e ->
      NLC.wc_equation P vars e'.
  Proof.
    intros ?????? [xs [|? []]] e' Hg Htr Henvs Hwcg (Hwc & Hlift & Hf2);
      try (inv Htr; cases; discriminate).
    destruct e; simpl in *; simpl_Foralls; try monadInv Htr.
    - constructor; eauto using envs_eq_in.
      eapply envs_eq_find in Henvs; eauto.
      pose proof (find_clock_det _ _ _ _ EQ Henvs) as ->.
      repeat constructor.
    - constructor; eauto using envs_eq_in.
      monadInv EQ1. destruct a. inv EQ0.
      unfold L.clock_of_nclock, stripname in *; simpl in *.
      take (LC.wc_exp _ _ _) and inv it; simpl in *; subst.
      + eapply envs_eq_find with (x:=i) in Henvs; eauto.
        rewrite EQ in Henvs; inv Henvs.
        now repeat constructor.
      + eapply envs_eq_find with (x:=x) in Henvs; eauto.
        rewrite EQ in Henvs; inv Henvs.
        now repeat constructor.
    - constructor; eauto using envs_eq_in. destruct a.
      monadInv EQ1. monadInv EQ0.
      take (LC.wc_exp _ _ _) and inv it.
      eapply wc_lexp in EQ1 as (?&?&?); eauto.
      unfold L.clock_of_nclock, stripname in *. simpl in *.
      eapply envs_eq_find in Henvs; eauto.
      pose proof (find_clock_det _ _ _ _ EQ Henvs) as ->.
      repeat constructor.
      congruence.
    - constructor; eauto using envs_eq_in. destruct a.
      monadInv EQ1. monadInv EQ0.
      take (LC.wc_exp _ _ _) and inv it.
      eapply wc_lexp in EQ0 as (?&?&?); eauto.
      eapply wc_lexp in EQ1 as (?&?&?); eauto.
      unfold L.clock_of_nclock, stripname in *. simpl in *.
      eapply envs_eq_find in Henvs; eauto.
      pose proof (find_clock_det _ _ _ _ EQ Henvs) as ->.
      repeat constructor; congruence.
    - cases; try monadInv Htr.
      constructor; eauto using envs_eq_in.
      take (LC.wc_exp _ _ _) and inv it. simpl_Foralls.
      eapply wc_lexp in EQ2 as (?& Heq &?); eauto.
      take (Forall2 eq _ _) and rewrite Forall2_eq in it.
      unfold L.clocksof in it. simpl in *. rewrite app_nil_r in *.
      rewrite Heq in it. rewrite it in *.
      eapply envs_eq_find in Henvs; eauto.
      pose proof (find_clock_det _ _ _ _ EQ0 Henvs) as ->.
      congruence.
    - cases; try monadInv Htr; monadInv EQ1; monadInv EQ0.
    - cases; try monadInv Htr; monadInv EQ1; monadInv EQ0.
      constructor; eauto using envs_eq_in. constructor.
      take (LC.wc_exp _ _ _) and inv it. simpl_Foralls.
      eapply wc_lexp in EQ1 as (?& Heq &?); eauto.
      unfold L.clock_of_nclock, stripname in *. simpl in *.
      eapply envs_eq_find in Henvs; eauto.
      pose proof (find_clock_det _ _ _ _ EQ Henvs) as ->.
      constructor; auto.
      rewrite app_nil_r in *.
      take (Forall (eq _) _) and rewrite Heq in it. now inv it.
    - cases; try monadInv Htr; monadInv EQ1.
      constructor; eauto using envs_eq_in.
      take (LC.wc_exp _ _ _) and inv it. simpl_Foralls.
      unfold L.clock_of_nclock, stripname in *. simpl in *. rewrite app_nil_r in *.
      eapply envs_eq_find in Henvs; eauto.
      pose proof (find_clock_det _ _ _ _ EQ Henvs) as ->.
      constructor; auto.
      + eapply wc_cexp in EQ0 as (?& Heq &?); eauto.
        rewrite Heq in *. now simpl_Foralls.
      + eapply wc_cexp in EQ1 as (?& Heq &?); eauto.
        rewrite Heq in *. now simpl_Foralls.
    - cases; try monadInv Htr; monadInv EQ1.
      constructor; eauto using envs_eq_in.
      take (LC.wc_exp _ _ _) and inv it. simpl_Foralls.
      unfold L.clock_of_nclock, stripname in *. simpl in *. rewrite app_nil_r in *.
      eapply envs_eq_find in Henvs; eauto.
      pose proof (find_clock_det _ _ _ _ EQ Henvs) as ->.
      constructor; auto.
      + eapply wc_lexp in EQ0 as (?& Heq &?); eauto. congruence.
      + eapply wc_cexp in EQ1 as (?& Heq &?); eauto.
        rewrite Heq in *. now simpl_Foralls.
      + eapply wc_cexp in EQ2 as (?& Heq &?); eauto.
        rewrite Heq in *. now simpl_Foralls.
    - cases; monadInv Htr;
        take (LC.wc_exp _ _ _) and inversion_clear it
        as [| | | | | | | | | |???? bck sub Wce ? WIi WIo|?????? bck sub Wce ? WIi WIo];
        eapply find_node_global in Hg as (n' & Hpref & Hfind & Hton); eauto;
          assert (find_base_clock (L.clocksof l) = bck) as ->
            by (take (L.find_node _ _ = Some n) and
                     pose proof (LC.wc_find_node _ _ n Hwcg it) as (?& (Wcin &?));
                apply find_base_clock_bck;
                [rewrite L.clocksof_nclocksof; eapply LC.WellInstantiated_bck; eauto;
                 unfold idck; rewrite map_length; exact (L.n_ingt0 n)
                | apply LC.WellInstantiated_parent in WIi;
                  rewrite L.clocksof_nclocksof, Forall_map;
                  eapply Forall_impl; eauto; now simpl]).
      + econstructor; eauto; try discriminate;
          rewrite app_nil_r in *.
        (* We can't use [sub] directly because some variables
           in the left side of the equation may have no image bu [sub].
           -> see LClocking.wc_equation *)
        * instantiate (1 := fun x => match sub x with
                                  | None => assoc_ident x (combine (L.idents (L.n_out n)) xs)
                                  | s => s
                                  end).
          (* inputs *)
          erewrite <- (to_node_in n n'); eauto.
          apply mmap_inversion in EQ.
          pose proof (L.n_nodup n) as Hdup.
          remember (L.n_in n) as ins. clear Heqins.
          revert dependent ins.
          revert dependent x.
          induction l as [| e].
          { intros. inv EQ. simpl in WIi. inv WIi.
            take ([] = _) and apply symmetry, map_eq_nil in it.
            now subst. }
          intros le Htr ins WIi.
          inv Htr. simpl in WIi.
          take (Forall _ (e::_)) and inv it.
          take (to_lexp e = _) and pose proof it as Tolexp; eapply wc_lexp in it as (ck & Hck & Wce);
            eauto.
          rewrite L.clockof_nclockof in Hck.
          destruct (L.nclockof e) as [|nc []] eqn:Hcke; simpl in *; inv Hck.
          inversion WIi as [|???? Wi ? Hmap]. subst.
          unfold idck in Hmap.
          apply symmetry, map_cons'' in Hmap as ((?&(?&?))&?&?&?&?). subst.
          unfold LC.WellInstantiated in Wi. destruct Wi; simpl in *.
          constructor; eauto.
          2:{ eapply IHl; eauto. now apply nodupmembers_cons in Hdup. }
          split; simpl; eauto.
          2:{ exists (stripname nc). split. apply Wce. auto using instck_sub_ext. }
          simpl in *. take (sub _ = _) and rewrite it. destruct nc as (ck & []).
          2:{ simpl.
              rewrite assoc_ident_false. constructor.
              apply nodupmembers_cons in Hdup as [Hin].
              rewrite <- In_InMembers_combine. unfold L.idents. intro Hin'.
              apply in_map_iff in Hin' as ((?&?)&?&?). simpl in *. subst.
              eapply Hin, In_InMembers.
              repeat rewrite in_app_iff. right; right; left; eauto.
              apply Forall2_length in Hf2. apply Forall2_length in WIo.
              unfold L.idents, idck in *. repeat rewrite map_length in *.
              congruence.
          }
          simpl. destruct e; take (LC.wc_exp G vars _) and inv it;
                   inv Hcke; inv Tolexp.
          -- constructor.
          -- destruct tys; take (map _ _ = [_]) and inv it.
        * (* outputs *)
          unfold idck in *.
          erewrite <- (to_node_out n n'); eauto.
          clear - Hlift Hf2 WIo.
          apply Forall2_forall. split.
          2:{ apply Forall2_length in Hlift. apply Forall2_length in WIo.
              repeat rewrite map_length in *. congruence. }
          intros (?&(?&?)) ? Hin. split.
          -- destruct (sub i) eqn:Hsub.
             apply Forall2_swap_args in Hlift.
             pose proof (Forall2_trans_ex _ _ _ _ _ WIo Hlift) as Ho.
             rewrite Forall2_map_1 in Ho.
             eapply Forall2_In in Hin; eauto.
             destruct Hin as (?&?&(Heq&?)&Hl). simpl in *.
             rewrite Hsub in Heq. rewrite <- Heq in Hl. simpl in Hl.
             now subst.
             unfold L.idents. apply assoc_ident_true.
             2:{ rewrite combine_map_fst, in_map_iff.
                 esplit; split; eauto. now simpl. }
             apply NoDup_NoDupMembers_combine.
             pose proof (L.n_nodup n) as Hdup.
             rewrite fst_NoDupMembers in Hdup. repeat rewrite map_app in Hdup.
             eauto using NoDup_app_l, NoDup_app_r.
          -- rewrite Forall2_map_2 in Hf2. rewrite Forall2_map_2 in WIo.
             apply Forall2_swap_args in Hf2.
             pose proof (Forall2_trans_ex _ _ _ _ _ WIo Hf2) as Ho.
             rewrite Forall2_map_1 in Ho.
             eapply Forall2_In in Hin; eauto.
             destruct Hin as (?&?&(Heq&?)&Hl). simpl in *.
             esplit; split; eauto.
             eauto using instck_sub_ext.
        * intros (y, cky) E; inv E.
          take (LC.wc_exp _ _ _) and inv it; auto.

      + econstructor; eauto; try discriminate;
          rewrite app_nil_r in *.
        (* We can't use [sub] directly because some variables
           in the left side of the equation may have no image bu [sub].
           -> see LClocking.wc_equation *)
        * instantiate (1 := fun x => match sub x with
                                  | None => assoc_ident x (combine (L.idents (L.n_out n)) xs)
                                  | s => s
                                  end).
          (* inputs *)
          erewrite <- (to_node_in n n'); eauto.
          apply mmap_inversion in EQ.
          pose proof (L.n_nodup n) as Hdup.
          remember (L.n_in n) as ins. clear Heqins.
          revert dependent ins.
          revert dependent x.
          induction l as [| e].
          { intros. inv EQ. simpl in WIi. inv WIi.
            take ([] = _) and apply symmetry, map_eq_nil in it.
            now subst. }
          intros le Htr ins WIi.
          inv Htr. simpl in WIi.
          take (Forall _ (e::_)) and inv it.
          take (to_lexp e = _) and pose proof it as Tolexp; eapply wc_lexp in it as (ck & Hck & Wce);
            eauto.
          rewrite L.clockof_nclockof in Hck.
          destruct (L.nclockof e) as [|nc []] eqn:Hcke; simpl in *; inv Hck.
          inversion WIi as [|???? Wi ? Hmap]. subst.
          unfold idck in Hmap.
          apply symmetry, map_cons'' in Hmap as ((?&(?&?))&?&?&?&?). subst.
          unfold LC.WellInstantiated in Wi. destruct Wi; simpl in *.
          constructor; eauto.
          2:{ eapply IHl; eauto. now apply nodupmembers_cons in Hdup. }
          split; simpl; eauto.
          2:{ exists (stripname nc). split. apply Wce. auto using instck_sub_ext. }
          simpl in *. take (sub _ = _) and rewrite it. destruct nc as (ck & []).
          2:{ simpl.
              rewrite assoc_ident_false. constructor.
              apply nodupmembers_cons in Hdup as [Hin].
              rewrite <- In_InMembers_combine. unfold L.idents. intro Hin'.
              apply in_map_iff in Hin' as ((?&?)&?&?). simpl in *. subst.
              eapply Hin, In_InMembers.
              repeat rewrite in_app_iff. right; right; left; eauto.
              apply Forall2_length in Hf2. apply Forall2_length in WIo.
              unfold L.idents, idck in *. repeat rewrite map_length in *.
              congruence.
          }
          simpl. destruct e; take (LC.wc_exp G vars _) and inv it;
                   inv Hcke; inv Tolexp.
          -- constructor.
          -- destruct tys; take (map _ _ = [_]) and inv it.
        * (* outputs *)
          unfold idck in *.
          erewrite <- (to_node_out n n'); eauto.
          clear - Hlift Hf2 WIo.
          apply Forall2_forall. split.
          2:{ apply Forall2_length in Hlift. apply Forall2_length in WIo.
              repeat rewrite map_length in *. congruence. }
          intros (?&(?&?)) ? Hin. split.
          -- destruct (sub i) eqn:Hsub.
             apply Forall2_swap_args in Hlift.
             pose proof (Forall2_trans_ex _ _ _ _ _ WIo Hlift) as Ho.
             rewrite Forall2_map_1 in Ho.
             eapply Forall2_In in Hin; eauto.
             destruct Hin as (?&?&(Heq&?)&Hl). simpl in *.
             rewrite Hsub in Heq. rewrite <- Heq in Hl. simpl in Hl.
             now subst.
             unfold L.idents. apply assoc_ident_true.
             2:{ rewrite combine_map_fst, in_map_iff.
                 esplit; split; eauto. now simpl. }
             apply NoDup_NoDupMembers_combine.
             pose proof (L.n_nodup n) as Hdup.
             rewrite fst_NoDupMembers in Hdup. repeat rewrite map_app in Hdup.
             eauto using NoDup_app_l, NoDup_app_r.
          -- rewrite Forall2_map_2 in Hf2. rewrite Forall2_map_2 in WIo.
             apply Forall2_swap_args in Hf2.
             pose proof (Forall2_trans_ex _ _ _ _ _ WIo Hf2) as Ho.
             rewrite Forall2_map_1 in Ho.
             eapply Forall2_In in Hin; eauto.
             destruct Hin as (?&?&(Heq&?)&Hl). simpl in *.
             esplit; split; eauto.
             eauto using instck_sub_ext.
  Qed.

  Lemma wc_node :
    forall G P n n' Hpref Hprefs,
      to_node n Hpref = OK n' ->
      to_global G Hprefs = OK P ->
      LC.wc_global G ->
      LC.wc_node G n ->
      NLC.wc_node P n'.
  Proof.
    intros * Htn Hwcg Htg Hwc.
    unfold NLC.wc_node.
    erewrite <- (to_node_in n n'), <- (to_node_out n n'), <- (to_node_vars n n');
      eauto.
    inversion Hwc as (?&?&?& WCeq). repeat (split; try tauto).
    now setoid_rewrite  Permutation_app_comm at 2.
    unfold to_node in Htn. cases. inv Htn. simpl.
    revert dependent x. induction (L.n_eqs n) as [| e]; intros * Hmmap.
    now inv Hmmap. inv WCeq.
    apply mmap_cons in Hmmap as (e' & es & -> & Htoeq & Hmmap).
    constructor; eauto using wc_equation, envs_eq_node.
  Qed.

  Lemma wc_transcription :
    forall G P Hprefs,
      LC.wc_global G ->
      to_global G Hprefs = OK P ->
      NLC.wc_global P.
  Proof.
    induction G as [| n]. inversion 2. constructor.
    intros * Hwt Htr. monadInv Htr.
    inversion_clear Hwt as [|???? Hf ].
    constructor; eauto using wc_node.
  Qed.

End TRCLOCKING.

Module TrClockingFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (OpAux : OPERATORS_AUX  Op)
       (L     : LSYNTAX    Ids Op)
       (LC    : LCLOCKING  Ids Op L)
       (CE    : CESYNTAX       Op)
       (NL    : NLSYNTAX   Ids Op CE)
       (Ord   : NLORDERED  Ids Op CE NL)
       (Mem   : MEMORIES   Ids Op CE NL)
       (IsD   : ISDEFINED  Ids Op CE NL Mem)
       (CEIsF : CEISFREE   Ids Op CE)
       (IsF   : ISFREE     Ids Op CE NL CEIsF)
       (CEClo : CECLOCKING Ids Op CE)
       (NLC   : NLCLOCKING Ids Op CE NL Ord Mem IsD CEIsF IsF CEClo)
       (TR    : TR Ids Op OpAux L CE NL)
<: TRCLOCKING Ids Op OpAux L LC CE NL Ord Mem IsD CEIsF IsF CEClo NLC TR.
  Include TRCLOCKING Ids Op OpAux L LC CE NL Ord Mem IsD CEIsF IsF CEClo NLC TR.
End TrClockingFun.


Theorem frame8TraceInd:
                let u:= (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) in
                let u':= (c 1 3, (ub (c 1 3) pk (bk 5) (x3tt 1 0), TWO)) in
                let v:= (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) in
                let v':= (c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO)) in
                let u1 := (label (c 0 3) (x6t 0 1), (kc (nonce 3), THREE)) in
                let v1:= (label (c 0 4) (x7t 0 1), (kc (nonce 4), THREE)) in
                let u1' := (label (c 1 3) (x6t 1 0), (kc (nonce 3), THREE)) in
                let v1' := (label (c 1 4) (x7t 1 0), (kc (nonce 4), THREE)) in
   [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1),
   msg (pke 2), bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10),
   bol (to (x3tt 0 1)) #? A, bol (acpt 0 3 5 (x3tt 0 1)),
   msg {u}_ 2 ^^ 11, bol (to (x4ttt 0 1)) #? B,
   bol (acpt 1 4 6 (x3tt 0 1)), msg {v}_ 2 ^^ 12,
   bol (to (x5t 0 1)) #? M, bol (tau 1 (x5t 0 1)) #? {u}_ 2 ^^ 11,
   bol (tau 2 (x5t 0 1)) #? {v}_ 2 ^^ 12,
   bol (!((tau 3 (x5t 0 1)) #? {u}_ 2 ^^ 11)) & (!((tau 3 (x5t 0 1)) #? {v}_ 2 ^^ 12)),
   bol ((tau 3 u)#? TWO) & ((tau 3 v) #? TWO) & ((tau 3 (dec (tau 3 (x5t 0 1)) (ske 2))) #? TWO), msg (shufl ((tau 1 u), (tau 2 u)) ((tau 1 v), (tau 2 v)) ((tau 1 (dec (tau 3 (x5t 0 1)) (ske 2))),  (tau 2 (dec (tau 3 (x5t 0 1)) (ske 2))))), bol ((to (x6t 0 1)) #? A) & (distbb x6t 0 1), bol (acc1 0 1 3 5)& (bcheck (c 0 3) (x6t 0 1)), msg (e1 0 3 x6t 1 13), bol ((to (x7t 0 1)) #? B) & (distbb x7t 0 1), bol (acc2 0 1 4 6)& (bcheck (c 1 4) (x7t 0 1)), msg (e1 0 4 x7t 1 14),  bol (to (x8t 0 1)) #? M, bol (tau 1 (x8t 0 1)) #? {u1}_ 2 ^^ 11,
   bol (tau 2 (x8t 0 1)) #? {v1}_ 2 ^^ 12,
   bol (!((tau 3 (x8t 0 1)) #? {u1}_ 2 ^^ 11)) & (!((tau 3 (x8t 0 1)) #? {v1}_ 2 ^^ 12)), msg (If (let D := ((d 1 (x8t 0 1)), ((d 2 (x8t 0 1)), (d 3 (x8t 0 1)))) in
                             let kOcc := (isin (bk 3) D) & (isin (bk 4) D) in
                             let kdnOcc := !(isin (bk 3) D) or !(isin (bk 4) D) in
                                   (mchecks x8t 0 1 THREE)& (kOcc or kdnOcc)) then  (shufl ((tau 1 u1), (tau 2 u1)) ((tau 1 v1), (tau 2 v1)) ((tau 1 (dec (tau 3 (x8t 0 1)) (ske 2))),  (tau 2 (dec (tau 3 (x8t 0 1)) (ske 2))))) else O) ] ~

[msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1),
   msg (pke 2), bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10),
   bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)),
   msg {u'}_2 ^^ 11, bol (to (x4ttt 1 0)) #? B,
   bol (acpt 0 4 6 (x3tt 1 0)), msg {v'}_ 2 ^^ 12,
   bol (to (x5t 1 0)) #? M, bol (tau 1 (x5t 1 0)) #? {u'}_ 2 ^^ 11,
   bol (tau 2 (x5t 1 0)) #? {v'}_ 2 ^^ 12,
   bol (!((tau 3 (x5t 1 0)) #? {u'}_ 2 ^^ 11)) & (! ((tau 3 (x5t 1 0)) #? {v'}_ 2 ^^ 12)),
   bol ((tau 3 u')#? TWO) & ((tau 3 v') #? TWO) & ((tau 3 (dec (tau 3 (x5t 1 0)) (ske 2))) #? TWO), msg (shufl ((tau 1 u'), (tau 2 u')) ((tau 1 v'), (tau 2 v')) ((tau 1 (dec (tau 3 (x5t 1 0)) (ske 2))),  (tau 2 (dec (tau 3 (x5t 1 0)) (ske 2))))), bol ((to (x6t 1 0)) #? A) & (distbb x6t 1 0), bol (acc1 1 1 3 5)& (bcheck (c 1 3) (x6t 1 0)), msg (e1 1 3 x6t 0 13), bol ((to (x7t 1 0)) #? B) & (distbb x7t 1 0), bol (acc2 1 0 4 6)& (bcheck (c 0 4) (x7t 1 0)), msg (e1 1 4 x7t 0 14), bol (to (x5t 1 0)) #? M, bol (tau 1 (x8t 1 0)) #? {u1'}_ 2 ^^ 13,
   bol (tau 2 (x8t 1 0)) #? {v1'}_ 2 ^^ 14,
   bol (!((tau 3 (x8t 1 0)) #? {u1'}_ 2 ^^ 13)) & (! ((tau 3 (x8t 1 0)) #? {v1'}_ 2 ^^ 14)),   msg (If
   (let D := ((d 1 (x8t 1 0)), ((d 2 (x8t 1 0)), (d 3 (x8t 1 0)))) in
                             let kOcc := (isin (bk 3) D) & (isin (bk 4) D) in
                             let kdnOcc := !(isin (bk 3) D) or !(isin (bk 4) D) in
                             (mchecks x8t 1 0 THREE)& (kOcc or kdnOcc)) then (shufl ((tau 1 u1'), (tau 2 u1')) ((tau 1 v1'), (tau 2 v1')) ((tau 1 (dec (tau 3 (x8t 1 0)) (ske 2))),  (tau 2 (dec (tau 3 (x8t 1 0)) (ske 2))))) else O)].


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* 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 Coq.Arith.Arith Coq.Vectors.Vector
     Coq.NArith.NArith.
Require Import Cava.Arrow.ArrowExport.

Require Import Aes.Pkg Aes.Sbox.

Import VectorNotations.
Import KappaNotation.
Open Scope kind_scope.

Program Definition aes_key_expand
  (sbox_impl: SboxImpl)
  : <<
   (* Bit (1* cfg_valid_i *1) *) (*cfg_valid_i is used for gating assertions only. *)
      Bit (* op_i *)
    , Bit (* step_i *)
    , Bit (* clear_i *)
    , Vector Bit 4 (* round_i *)
    (* , Vector Bit 4 (1* key_len_e *1) *)
    , Vector (Vector (Vector Bit 8) 4) 8 (* input key *)
    , Unit
    >> ~> << Vector (Vector (Vector Bit 8) 4) 8>> :=
  <[\op_i step_i clear_i round_i key_i =>
    (* if (key_len_i == AES_256 && rnd[0] == 1'b0) begin
    use_rcon = 1'b0;
    end *)
    let use_rcon = round_i[#0] in
    let clear_i =
      round_i == #0 in

    (* rcon_d = (op_i == CIPH_FWD) ? aes_mul2(rcon_q) :
                (op_i == CIPH_INV) ? aes_div2(rcon_q) : 8'h01; *)
    letrec rcon = delay (
      if clear_i
      then
        if op_i == !CIPH_FWD
        then #1
        else #64
      else if use_rcon
      then
        if op_i == !CIPH_FWD
        then !aes_mul2 rcon
        else !aes_div2 rcon
      else
        rcon
        ) in

    (* AES_256: begin
      unique case (op_i)
        CIPH_FWD: rot_word_in = key_i[7];
        CIPH_INV: rot_word_in = key_i[3];
        default:  rot_word_in = key_i[7]; *)
    let rot_word_in =
      if op_i == !CIPH_FWD
      then key_i[#7]
      else key_i[#3] in

    (* assign rot_word_out = aes_circ_byte_shift(rot_word_in, 2'h3); *)
    let rot_word_out = !aes_circ_byte_shift rot_word_in #3 in

    (* assign sub_word_in = use_rot_word ? rot_word_out : rot_word_in; *)
    let sub_word_in =
      if use_rcon (* for AES_256 use_rcon == use_rot_word *)
      then rot_word_out
      else rot_word_in in

    let sub_word_out = !(map <[!(aes_sbox sbox_impl) !CIPH_FWD]>) sub_word_in in
    let sub_word_out_flat = !(flatten (n:=4)) sub_word_out in

    (* assign rcon_add_in  = sub_word_out[7:0]; *)
    let rcon_add_in = sub_word_out_flat[:7:0] in
    (* assign rcon_add_out = rcon_add_in ^ rcon_q; *)
    let rcon_add_out = rcon_add_in ^ rcon in
    (* assign rcon_added   = {sub_word_out[31:8], rcon_add_out}; *)
    let rcon_added   = concat rcon_add_out sub_word_out_flat[:31:8] in

    (* // Mux output coming from Rcon & SubWord
    assign irregular = use_rcon ? rcon_added : sub_word_out; *)
    let irregular = if use_rcon then rcon_added else sub_word_out_flat in

    (* AES_256: begin
        unique case (op_i)
          CIPH_FWD: begin
            if (rnd == 0) begin
              // Round 0: Nothing to be done
              // The Full Key registers are not updated
              regular = {key_i[3:0], key_i[7:4]};
            end else begin
              // Shift down old upper half
              regular[3:0] = key_i[7:4];
              // Generate new upper half
              regular[4]   = irregular ^ key_i[0];
              for (int i=1; i<4; i++) begin
                regular[i+4] = regular[i+4-1] ^ key_i[i];
              end
            end // rnd == 0
          end

        endcase
      end *)
    let regular =
      if round_i == #0
      then concat key_i[:7:4] key_i[:3:0]
      else
        if op_i == !CIPH_FWD
        then
          (* todo: this is a "scan" op *)
          let regular_4 = (!reshape irregular) ^ key_i[#0] in
          let regular_5 = regular_4 ^ key_i[#1] in
          let regular_6 = regular_5 ^ key_i[#2] in
          let regular_7 = regular_6 ^ key_i[#3] in
          snoc (snoc (snoc (snoc key_i[:7:4] regular_4) regular_5) regular_6) regular_7

          (* CIPH_INV: begin
            if (rnd == 0) begin
              // Round 0: Nothing to be done
              // The Full Key registers are not updated
              regular = {key_i[3:0], key_i[7:4]};
            end else begin
              // Shift up old lower half
              regular[7:4] = key_i[3:0];
              // Generate new lower half
              regular[0]   = irregular ^ key_i[4];
              for (int i=0; i<3; i++) begin
                regular[i+1] = key_i[4+i] ^ key_i[4+i+1];
              end
            end // rnd == 0
          end *)
        else
          let regular_0 = (!reshape irregular) ^ key_i[#4] in
          let regular_1 = key_i[#4] ^ key_i[#5] in
          let regular_2 = key_i[#5] ^ key_i[#6] in
          let regular_3 = key_i[#6] ^ key_i[#7] in
          cons regular_0 (cons regular_1 (cons regular_2 (cons regular_3 key_i[:3:0])))
      in
    regular
    ]>.


From iris.proofmode Require Import proofmode.
From iris.program_logic Require Export weakestpre.
From RobustSafety Require Export persistent_pred.
From RobustSafety Require Export rules.
From iris.algebra Require Import list.
From iris.base_logic Require Import invariants.
From iris.prelude Require Import options.
Import uPred.

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

(** interp : is a unary logical relation. *)
Section logrel.
  Context `{heapIG Σ}.
  Notation D := (persistent_predO val (iPropI Σ)).
  Implicit Types interp : D.

  Local Arguments ofe_car !_.

  Program Definition interp_prod : D -n> D :=
    λne interp, PersPred (λ w, ▷ ∃ w1 w2, ⌜w = PairV w1 w2⌝ ∧ interp w1 ∧ interp w2)%I.
  Solve Obligations with solve_proper.
  Instance interp_prod_contractive : Contractive interp_prod.
  Proof. solve_contractive. Qed.

  Program Definition interp_sum : D -n> D :=
    λne interp,
      PersPred (λ w, ▷ ((∃ w1, ⌜w = InjLV w1⌝ ∧ interp w1) ∨ (∃ w2, ⌜w = InjRV w2⌝ ∧ interp w2)))%I.
  Solve Obligations with solve_proper.
  Instance interp_sum_contractive : Contractive interp_sum.
  Proof. solve_contractive. Qed.

  Program Definition interp_arrow : D -n> D :=
    λne interp, PersPred (λ w, □ ∀ v, ▷ interp v → WP App (of_val w) (of_val v) ? {{ interp }})%I.
  Solve Obligations with solve_proper.
  Instance interp_arrow_contractive : Contractive interp_arrow.
  Proof.
    intros n interp interp' Hinterps w.
    rewrite /interp_arrow /=.
    f_equiv.
    f_equiv; intros v.
    f_equiv.
    - solve_contractive.
    - apply wp_contractive; first apply _.
      destruct n; first done.
      apply Hinterps.
  Qed.

  Program Definition interp_ref_inv (l : loc) : D -n> iPropO Σ :=
    λne interp, (∃ v, l ↦ v ∗ interp v)%I.
  Solve Obligations with solve_proper.

  Program Definition interp_ref : D -n> D :=
    λne interp, PersPred (λ w, ∃ l, ⌜w = LocV l⌝ ∧ inv (logN .@ l) (interp_ref_inv l interp))%I.
  Solve Obligations with solve_proper.
  Instance interp_ref_contractive : Contractive interp_ref.
  Proof. solve_contractive. Qed.

  Program Definition interp_of (w : val) : (D -n> D) :=
    λne interp, match w return D with
      | RecV _ | LamV _ => interp_arrow interp
      | UnitV => PersPred (λ _, True)
      | NatV _ => PersPred (λ _, True)
      | BoolV _ => PersPred (λ _, True)
      | PairV _ _ => interp_prod interp
      | InjLV _ | InjRV _ => interp_sum interp
      | LocV _ => interp_ref interp
      end%I.
  Next Obligation.
  Proof. intros []; solve_proper. Qed.

  Instance interp_of_contractive w : Contractive (interp_of w).
  Proof.
    destruct w; cbn -[interp_arrow interp_prod interp_sum interp_ref]; apply (_ : Contractive _).
  Qed.

  Program Definition interp_one : D -n> D :=
    λne interp, PersPred (λ w, interp_of w interp w).
  Next Obligation.
  Proof.
    intros ???? w; cbn -[interp_of]; f_equiv; by apply contractive_ne; first apply _.
  Qed.
  Instance interp_one_contractive : Contractive interp_one.
  Proof.
    intros n interp interp' Hinterps w; cbn -[interp_of]; f_equiv; apply (_ : Contractive _); done.
  Qed.

  Definition interp : D := fixpoint interp_one.

  Lemma interp_unfold : interp ≡ interp_one interp.
  Proof. rewrite /interp; apply fixpoint_unfold. Qed.

  Definition interp_env (vs : list val) : iProp Σ := [∗ list] v ∈ vs, interp v.

  Definition interp_expr (e : expr) : iProp Σ := WP e ? {{ interp }}%I.

  Global Instance interp_env_persistent vs : Persistent (interp_env vs) := _.

  Lemma interp_env_Some_l vs x v :
    vs !! x = Some v → interp_env vs ⊢ interp v.
  Proof.
    iIntros (?) "Henv".
    iApply (big_sepL_elem_of with "Henv").
    apply elem_of_list_lookup_2 with x; done.
  Qed.

  Lemma interp_env_nil : ⊢ interp_env [].
  Proof. done. Qed.
  Lemma interp_env_cons vs v :
    interp_env (v :: vs) ⊣⊢ interp v ∗ interp_env vs.
  Proof. done. Qed.

  (* The logical relation *)

  Definition logrel (e : expr) : iProp Σ := □ ∀ vs, interp_env vs -∗ interp_expr e.[env_subst vs].

End logrel.

Global Typeclasses Opaque interp_env.