From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils
  PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICUtils PCUICPosition.
From MetaCoq.PCUIC Require Export PCUICCumulativitySpec.
From MetaCoq.PCUIC Require Export PCUICCases PCUICNormal.
Require Import MLTTTyping LogicalRelation.

Fixpoint LR_rec0
  (c : context) (t : term) (rEq rTe : term -> Type)
  (rTeEq  : term -> term -> Type) (lr : LR rec0 c t rEq rTe rTeEq ) :
  forall
  (P0 : forall {c t rEq rTe rTeEq} ,
   @LR zero rec0 c t rEq rTe rTeEq  -> Type),
  (forall (Γ : context) (A : term) (neA : [Γ ||-ne A]),
    P0 (LRne rec0 neA))
  ->
  (forall (Γ : context) (A : term) (H0 : [ Γ ||-0Π A ]) (H1 : [ LR rec0 ||-1Π H0 ]),
    (forall {Δ} (h : [ |- Δ]),
      P0(H1.(_F1) h)) ->
    (forall {Δ a} (h1 : [ |- Δ ])
      (h2 : [ Δ ||-1 a ::: F H0 | {|valid := H1.(_F1) h1|} ]),
      P0 (_G1 H1 h1 h2)) ->
    P0 (LRPi rec0 H0 H1))
  ->
   P0 lr.
Proof.
   intros.
   destruct lr.
   1,4 : inversion l_.
   eapply X; try eassumption.
   eapply X0; try eassumption;
   destruct H1; destruct H0;
   intros;
   apply LR_rec0; try assumption.
Defined.

(*TODO : get a good induction principle*)
(*Scheme LR_rect := Induction for LR Sort Type.*)
Fixpoint LR_rec1
  (c : context) (t : term) (rEq rTe : term -> Type)
  (rTeEq  : term -> term -> Type) (lr : LR rec1 c t rEq rTe rTeEq ) :
  forall
  (P0 : forall {c t rEq rTe rTeEq} ,
   @LR zero rec0 c t rEq rTe rTeEq  -> Type)
  (P1 : forall {c t rEq rTe rTeEq} ,
   @LR one rec1 c t rEq rTe rTeEq  -> Type),
  (forall (Γ : context) (A : term) (neA : [Γ ||-ne A]),
    P0 (LRne rec0 neA))
  ->
  (forall (Γ : context) (A : term) (H0 : [ Γ ||-0Π A ]) (H1 : [ LR rec0 ||-1Π H0 ]),
    (forall {Δ} (h : [ |- Δ]),
      P0 (H1.(_F1) h)) ->
    (forall {Δ a} (h1 : [ |- Δ ])
      (h2 : [ Δ ||-1 a ::: F H0 | {|valid := H1.(_F1) h1|} ]),
      P0 (_G1 H1 h1 h2)) ->
    P0 (LRPi rec0 H0 H1))
  ->

  (forall (Γ : context) (h : [  |- Γ]) {l' l_},
    P1 (LRU rec1 h l' l_))
  ->
  (forall (Γ : context) (A : term) (neA : [Γ ||-ne A]),
    P1 (LRne rec1 neA))
  ->
  (forall (Γ : context) (A : term) (H0 : [ Γ ||-0Π A ]) (H1 : [ LR rec1 ||-1Π H0 ]),
  (forall {Δ} (h : [ |- Δ]),
    P1 (H1.(_F1) h)) ->
  (forall {Δ a} (h1 : [ |- Δ ])
    (h2 : [ Δ ||-1 a ::: F H0 | {|valid := H1.(_F1) h1|} ]),
    P1 (_G1 H1 h1 h2)) ->
  P1 (LRPi rec1 H0 H1))
  ->

  (forall (Γ : context) (A : term) {l' l_}
    (H : [kit0 | Γ ||- A]),

    P0 H.(valid) ->
    P1 (@LRemb _ _ _ _ l' l_ H)) ->

    P1 lr.
Proof.
  intros.
  destruct lr.
  eapply X1; try eassumption.
  eapply X2; try eassumption.
  destruct H1;destruct H0.
  eapply X3;
  intros;
  eapply LR_rec1; try eassumption.
  eapply X4.
  destruct H.
  inversion valid.
  1, 4 : inversion l_0.
  all : eapply LR_rec0; assumption.
Defined.

Definition LR_rect0 : forall
  (P0 : forall {c t rEq rTe rTeEq} ,
   @LR zero rec0 c t rEq rTe rTeEq  -> Type),
  (forall (Γ : context) (A : term) (neA : [Γ ||-ne A]),
    P0 (LRne rec0 neA))
  ->
  (forall (Γ : context) (A : term) (H0 : [ Γ ||-0Π A ]) (H1 : [ LR rec0 ||-1Π H0 ]),
    (forall {Δ} (h : [ |- Δ]),
      P0(H1.(_F1) h)) ->
    (forall {Δ a} (h1 : [ |- Δ ])
      (h2 : [ Δ ||-1 a ::: F H0 | {|valid := H1.(_F1) h1|} ]),
      P0 (_G1 H1 h1 h2)) ->
    P0 (LRPi rec0 H0 H1))
  ->
   forall(c : context) (t : term) (rEq rTe : term -> Type)
  (rTeEq  : term -> term -> Type) (lr : LR rec0 c t rEq rTe rTeEq ),
   P0 lr.
Proof.
  intros.
  eapply LR_rec0; eassumption.
Defined.

Definition LR_rect1 :
  forall
  (P0 : forall {c t rEq rTe rTeEq} ,
   @LR zero rec0 c t rEq rTe rTeEq  -> Type)
  (P1 : forall {c t rEq rTe rTeEq} ,
   @LR one rec1 c t rEq rTe rTeEq  -> Type),
  (forall (Γ : context) (A : term) (neA : [Γ ||-ne A]),
    P0 (LRne rec0 neA))
  ->
  (forall (Γ : context) (A : term) (H0 : [ Γ ||-0Π A ]) (H1 : [ LR rec0 ||-1Π H0 ]),
    (forall {Δ} (h : [ |- Δ]),
      P0 (H1.(_F1) h)) ->
    (forall {Δ a} (h1 : [ |- Δ ])
      (h2 : [ Δ ||-1 a ::: F H0 | {|valid := H1.(_F1) h1|} ]),
      P0 (_G1 H1 h1 h2)) ->
    P0 (LRPi rec0 H0 H1))
  ->

  (forall (Γ : context) (h : [  |- Γ]) {l' l_},
    P1 (LRU rec1 h l' l_))
  ->
  (forall (Γ : context) (A : term) (neA : [Γ ||-ne A]),
    P1 (LRne rec1 neA))
  ->
  (forall (Γ : context) (A : term) (H0 : [ Γ ||-0Π A ]) (H1 : [ LR rec1 ||-1Π H0 ]),
  (forall {Δ} (h : [ |- Δ]),
    P1 (H1.(_F1) h)) ->
  (forall {Δ a} (h1 : [ |- Δ ])
    (h2 : [ Δ ||-1 a ::: F H0 | {|valid := H1.(_F1) h1|} ]),
    P1 (_G1 H1 h1 h2)) ->
  P1 (LRPi rec1 H0 H1))
  ->

  (forall (Γ : context) (A : term) {l' l_}
    (H : [kit0 | Γ ||- A]),

    P0 H.(valid) ->
    P1 (@LRemb _ _ _ _ l' l_ H)) ->
  forall (c : context) (t : term) (rEq rTe : term -> Type)
  (rTeEq  : term -> term -> Type) (lr : LR rec1 c t rEq rTe rTeEq ),
    P1 lr.
Proof.
  intros.
  eapply LR_rec1; eassumption.
Defined.


From Autosubst Require Export Autosubst.
From iris.program_logic Require Export language ectx_language ectxi_language.

(** Expressions *)
Inductive expr :=
| Var (x : var)
| Lam (e : {bind 1 of expr})
| App (e1 e2 : expr)
(* Base types *)
| Unit
(* Products *)
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
(* Sums *)
| InjL (e : expr)
| InjR (e : expr)
| Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
(* Recursive Types *)
| Fold (e : expr)
| Unfold (e : expr).

Coercion App : expr >-> Funclass.

Instance Ids_expr : Ids expr. derive. Defined.
Instance Rename_expr : Rename expr. derive. Defined.
Instance Subst_expr : Subst expr. derive. Defined.
Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

(** Values *)
Inductive val :=
| LamV (e : {bind 1 of expr})
| UnitV
| PairV (v1 v2 : val)
| InjLV (v : val)
| InjRV (v : val)
| FoldV (v : val).

Fixpoint of_val (v : val) : expr :=
  match v with
  | LamV e => Lam e
  | UnitV => Unit
  | PairV v1 v2 => Pair (of_val v1) (of_val v2)
  | InjLV v => InjL (of_val v)
  | InjRV v => InjR (of_val v)
  | FoldV v => Fold (of_val v)
  end.
(* Notation "# v" := (of_val v) (at level 20). *)

Coercion of_val : val >-> expr.

Fixpoint to_val (e : expr) : option val :=
  match e with
  | Lam e => Some (LamV e)
  | Unit => Some UnitV
  | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
  | InjL e => InjLV <$> to_val e
  | InjR e => InjRV <$> to_val e
  | Fold e => v ← to_val e; Some (FoldV v)
  | _ => None
  end.

(** Evaluation contexts of depth 1 *)
(** General evalution contexts are represented by `list ectx_item` *)
Inductive ectx_item :=
| AppLCtx (e2 : expr)
| AppRCtx (v1 : val)
| PairLCtx (e2 : expr)
| PairRCtx (v1 : val)
| FstCtx
| SndCtx
| InjLCtx
| InjRCtx
| CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
| FoldCtx
| UnfoldCtx.

Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
  match Ki with
  | AppLCtx e2 => App e e2
  | AppRCtx v1 => App (of_val v1) e
  | PairLCtx e2 => Pair e e2
  | PairRCtx v1 => Pair (of_val v1) e
  | FstCtx => Fst e
  | SndCtx => Snd e
  | InjLCtx => InjL e
  | InjRCtx => InjR e
  | CaseCtx e1 e2 => Case e e1 e2
  | FoldCtx => Fold e
  | UnfoldCtx => Unfold e
  end.

Definition state : Type := ().

(** Head steps *)
Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
(* β *)
| BetaS e1 e2 v2 σ :
    to_val e2 = Some v2 →
    head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
(* Products *)
| FstS e1 v1 e2 v2 σ :
    to_val e1 = Some v1 → to_val e2 = Some v2 →
    head_step (Fst (Pair e1 e2)) σ [] e1 σ []
| SndS e1 v1 e2 v2 σ :
    to_val e1 = Some v1 → to_val e2 = Some v2 →
    head_step (Snd (Pair e1 e2)) σ [] e2 σ []
(* Sums *)
| CaseLS e0 v0 e1 e2 σ :
    to_val e0 = Some v0 →
    head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
| CaseRS e0 v0 e1 e2 σ :
    to_val e0 = Some v0 →
    head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ []
(* Recursive Types *)
| Unfold_Fold e v σ :
    to_val e = Some v →
    head_step (Unfold (Fold e)) σ [] e σ [].

Lemma to_of_val v : to_val (of_val v) = Some v.
Proof. by induction v; simplify_option_eq. Qed.

Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof.
  revert v; induction e; intros; simplify_option_eq; auto with f_equal.
Qed.

Instance of_val_inj : Inj (=) (=) of_val.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

Lemma fill_item_val Ki e :
  is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

Lemma val_stuck e1 σ1 κ e2 σ2 ef :
  head_step e1 σ1 κ e2 σ2 ef → to_val e1 = None.
Proof. destruct 1; naive_solver. Qed.

Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 ef :
  head_step (fill_item Ki e) σ1 κ e2 σ2 ef → is_Some (to_val e).
Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
  to_val e1 = None → to_val e2 = None →
  fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
  destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
  repeat match goal with
          | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
          end; auto.
Qed.

Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
Proof. destruct 1; naive_solver. Qed.

Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
Proof.
  split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
          fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
Qed.

Canonical Structure stateO := leibnizO state.
Canonical Structure valO := leibnizO val.
Canonical Structure exprO := leibnizO expr.

(** `EctxiLanguage` naturally extents our evaluation contexts of depth 1, and it naturally defines our total reduction relation *)
Canonical Structure ectxi_lang := EctxiLanguage lang_mixin.
Canonical Structure ectx_lang := EctxLanguageOfEctxi ectxi_lang.
Canonical Structure lang := LanguageOfEctx ectx_lang.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

(** Definition of halting *)
Definition Halts (e : expr) :=
  ∃ v, rtc erased_step ([e], tt) ([of_val v], tt).


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
*)

Require Import Way.Tactics.

Require Import Way.List.
Require Import Way.Nat.

Lemma has_le_fold_max : forall (n : nat) (l : list nat), has n l -> n <= fold max 0 l.
Proof.
  intro n;
  induction l;
  [ infer
  | infer from eq_nat_dec le_max_l (le_trans n (fold max 0 l)) le_max_r ].
Defined.

Lemma fold_max_lt_not_has :
  forall (n : nat) (l : list nat), fold max 0 l < n -> ~ has n l.
Proof.
  intros n l;
  infer from has_le_fold_max (le_lt_trans n (fold max 0 l)) (lt_irrefl n).
Defined.

Lemma fresh_nat : forall (l : list nat), {n : nat | ~ has n l}.
Proof.
  intro l;
  exists (S (fold max 0 l));
  infer from fold_max_lt_not_has.
Defined.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Lia.
Require Import Ascii.

Require Import FinProof.All.

Require Import UMLang.All.
Require Import UMLang.LocalClassGenerator.ClassGenerator.
Require Import UMLang.GlobalClassGenerator.ClassGenerator.

Require Import UrsusStdLib.Solidity.All.
Require Import UrsusStdLib.Solidity.unitsNotations.
Require Import UrsusTVM.Solidity.All.

Import UrsusNotations.
Local Open Scope xlist_scope.
Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope glist_scope.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.

From elpi Require Import elpi.

Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Require Import SetcodeMultisig.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import FinProof.CommonInstances.

Require Import CommonQCEnvironment.
Require Import SetcodeMultisig_LocalState.
Require Import CommonForProps.

Definition dummyRequest : UpdateRequestLRecord := Eval compute in default.

Definition REU_1 l id (codeHash :  option uint256) (owners :  optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let m_lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in (* TODO *)
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let l' := exec_state (Uinterpreter (_removeExpiredTransactions rec def)) l in
  let ret_l := exec_state (Uinterpreter (_removeExpiredUpdateRequests rec def)) l in
  let m_updateRequests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
  let m_updateRequests' := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) ret_l) in
  let m_updateRequestsMask := toValue (eval_state (sRReader (m_updateRequestsMask_right rec def) ) ret_l) in
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  hmapIsMember id m_updateRequests = true ->
  N.shiftr 32 (uint2N id) + m_lifetime <= tvm_now <->
  hmapIsMember id m_updateRequests = true /\
  hmapIsMember id m_updateRequests' = false /\
  N.shiftl (uint2N id) (uint2N m_updateRequestsMask) = 0.

Definition CUE_1 l (updateId :  uint64) (code : optional cell_) : Prop :=
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() || ) l) in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  isError (eval_state (Uinterpreter (executeUpdate rec def updateId code)) l) = false ->
  hmapIsMember msgPubkey custodians = true.

Definition CUE_2 l id (updateId :  uint64) (code : optional cell_) (custodianIndex :  uint8) (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let l' := exec_state (Uinterpreter (_confirmUpdate rec def updateId custodianIndex)) l in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  correctState l ->
  isError (eval_state (Uinterpreter (executeUpdate rec def updateId code)) l) = false ->
  hmapIsMember msgPubkey custodians = true ->
  REU_1 l' id codeHash owners reqConfirms lifetime.

Definition CUE_3 l id (updateId :  uint64) (code : optional cell_) (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let l' := exec_state (Uinterpreter (executeUpdate rec def updateId code)) l in
  let m_updateRequests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l') in
  let u := xMaybeMapDefault (fun x => x) (hmapLookup id m_updateRequests) dummyRequest  in
  let tr_id := getPruvendoRecord UpdateRequest_ι_id u in
  correctState l ->
  isError (eval_state (Uinterpreter (executeUpdate rec def updateId code)) l) = false ->
  hmapIsMember id m_updateRequests = true ->
  REU_1 l' id codeHash owners reqConfirms lifetime ->
  tr_id = id.

Definition CUE_4 l id (updateId :  uint64)  (code : optional cell_) (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let l' := exec_state (Uinterpreter (executeUpdate rec def updateId code)) l in
  let m_updateRequests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l') in
  let m_custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l') in
  let u := xMaybeMapDefault (fun x => x) (hmapLookup id m_updateRequests) dummyRequest  in
  let tr_id := getPruvendoRecord UpdateRequest_ι_id u in
  let signs := uint2N (getPruvendoRecord UpdateRequest_ι_signs u) in
  correctState l ->
  isError (eval_state (Uinterpreter (executeUpdate rec def updateId code)) l) = false ->
  hmapIsMember id m_updateRequests = true ->
  REU_1 l' id codeHash owners reqConfirms lifetime ->
  tr_id = id -> 3 * signs >= 2 * (length_ m_custodians)
  .

Definition CUE_6_2 l (updateId :  uint64)  (code : optional cell_) : Prop :=
  let l' := exec_state (Uinterpreter (executeUpdate rec def updateId code)) l in
  let m_updateRequests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l') in
  let m_updateRequests_old := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
  let m_lifetime := toValue (eval_state (sRReader (m_lifetime_right rec def) ) l') in
  let m_lifetime_old := toValue (eval_state (sRReader (m_lifetime_right rec def) ) l) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let expiredRequests := xHMapFilter (fun k v =>
    N.leb ((N.shiftr (uint2N k) 32) + uint2N m_lifetime_old) tvm_now
  ) m_updateRequests_old in
  let commonRequests := xHMapFilter (fun k v =>
    andb (hmapIsMember k m_updateRequests_old)
    (Common.eqb v (hmapFindWithDefault dummyRequest k m_updateRequests_old))) m_updateRequests in
  let ur := xMaybeMapDefault (fun x => x) (hmapLookup updateId m_updateRequests_old) dummyRequest  in
  let owners := getPruvendoRecord UpdateRequest_ι_custodians ur in
  let reqConfirms := getPruvendoRecord UpdateRequest_ι_reqConfirms ur in
  let lifetime := getPruvendoRecord UpdateRequest_ι_lifetime ur in
  let ecode := (toValue (eval_state (sRReader || tvm->code() ||) l')) in
  let ecode_old := (toValue (eval_state (sRReader || tvm->code() ||) l)) in
  let ccode := (toValue (eval_state (sRReader || tvm->currentCode() ||) l')) in
  let ccode_old := (toValue (eval_state (sRReader || tvm->currentCode() ||) l)) in
  let m_custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l') in
  let m_custodians_old := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let m_ownerKey_old := toValue (eval_state (sRReader (m_ownerKey_right rec def) ) l) in
  let m_ownerKey := toValue (eval_state (sRReader (m_ownerKey_right rec def) ) l') in
  let m_defaultRequiredConfirmations := toValue (eval_state (sRReader (m_defaultRequiredConfirmations_right rec def) ) l') in
  let m_defaultRequiredConfirmations_old := toValue (eval_state (sRReader (m_defaultRequiredConfirmations_right rec def) ) l) in
  let DEFAULT_LIFETIME := toValue (eval_state (sRReader (DEFAULT_LIFETIME_right rec def) ) l) in
  let m_requestsMask := toValue (eval_state (sRReader (m_requestsMask_right rec def) ) l') in
  let m_updateRequestsMask := toValue (eval_state (sRReader (m_updateRequestsMask_right rec def) ) l') in
  let m_transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  correctState l ->
  isError (eval_state (Uinterpreter (executeUpdate rec def updateId code)) l) = false ->
  length_ m_updateRequests_old - length_ expiredRequests - 1 = length_ m_updateRequests /\
  length_ commonRequests = length_ m_updateRequests_old /\
  (xMaybeIsSome code = true ->
        ccode = xMaybeMapDefault Datatypes.id code default /\
        ecode = xMaybeMapDefault Datatypes.id code default
  ) /\
  (xMaybeIsSome code = false ->
        ccode = ccode_old /\ ecode = ecode_old) /\
  (xMaybeIsSome owners = true -> length_ (xMaybeMapDefault Datatypes.id owners default) >= length_ m_custodians ) /\
  (xMaybeIsSome owners = true -> checkMap1 m_custodians = true) /\
  checkMap2 m_custodians (N.to_nat (length_ (xMaybeMapDefault Datatypes.id owners default))) (xMaybeMapDefault Datatypes.id owners default) = true /\
  (xMaybeIsSome owners = false -> m_custodians = m_custodians_old /\ m_ownerKey = m_ownerKey_old) /\
  (xMaybeIsSome reqConfirms = true -> uint2N m_defaultRequiredConfirmations = N.min (length_ m_custodians) (uint2N (xMaybeMapDefault Datatypes.id reqConfirms default))) /\
  (xMaybeIsSome reqConfirms = false -> m_defaultRequiredConfirmations = m_defaultRequiredConfirmations_old) /\
  (xMaybeIsSome lifetime = false -> m_lifetime = m_lifetime_old) /\
  (xMaybeIsSome lifetime = true -> uint2N (xMaybeMapDefault Datatypes.id lifetime default) > 0 -> m_lifetime = (xMaybeMapDefault Datatypes.id lifetime default)) /\
  (xMaybeIsSome lifetime = true -> uint2N (xMaybeMapDefault Datatypes.id lifetime default) = 0 -> m_lifetime = DEFAULT_LIFETIME) /\
  N.land (uint2N m_updateRequestsMask) (0xFFFFFFFF) = 0 /\
  m_transactions = default /\
  m_updateRequests = default /\
  uint2N m_requestsMask = 0.


From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq fintype ssrint.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.

Require Import lib.utils.
Require Import common.types.
Require Import concrete.concrete.
Require Import concrete.int_32.
Require Import symbolic.symbolic.
Require Import symbolic.int_32.
Require Import symbolic.refinement_common.
Require Import symbolic.backward.
Require Import symbolic.rules.
Require Import cfi.classes.
Require Import cfi.rules.
Require Import cfi.symbolic.
Require Import cfi.abstract.
Require Import cfi.refinementAS.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module CFIInstances.

Section WithClasses.

(* ---------------------------------------------------------------- *)
(* int32 instance *)

Definition mt := concrete_int_32_mt.
Instance ops : machine_ops mt := concrete_int_32_ops.

Definition id_size := word 28.
Definition id := [eqType of id_size].
Definition bound := 2 ^ 28.

Definition word_to_id (w : mword mt) : option id_size :=
  if ord_of_word w < bound then Some (as_word (ord_of_word w))
  else None.

Definition id_to_word (x : id) : mword mt :=
  as_word (ord_of_word x).

Lemma id_to_wordK : pcancel id_to_word word_to_id.
Proof.
move=> x; rewrite /word_to_id /id_to_word.
have hx := valP (ord_of_word x) : ord_of_word x < bound.
by rewrite !as_wordK ?[in LHS]hx ?valwK ?(ltn_trans hx) /bound ?ltn_exp2l.
Qed.

Lemma word_to_idK : ocancel word_to_id id_to_word.
Proof.
move=> w; rewrite /word_to_id /id_to_word.
have [hb|] // := boolP (_ < 2 ^ 28).
by rewrite [in X in Some X](lock as_word) /= -lock as_wordK // valwK.
Qed.

Instance ids : cfi_id mt := {
 id := id;
 word_to_id := word_to_id;
 id_to_word := id_to_word
}.
Proof.
  - by apply id_to_wordK.
  - by move=> w x h; move: (word_to_idK w); rewrite h.
Defined.

(* Encoding of tags:
      DATA           --> 0
      INSTR None     --> 1
      INSTR (Some x) --> x*4+2
*)

Definition encode_cfi_tag (t : cfi_tag) : word 30 :=
 match t with
   DATA => @wpack [:: 28; 2] [hseq 0; 0]%w
 | INSTR None => @wpack [:: 28; 2] [hseq 0; 1]%w
 | INSTR (Some x) => @wpack [:: 28; 2] [hseq x; as_word 2]%w
 end.

Definition decode_cfi_tag (t : word 30) : option cfi_tag :=
  let: [hseq k; t] := @wunpack [:: 28; 2] t in
  if t == 0%w then
    if k == 0%w then Some DATA
    else None
  else if t == 1%w then
    if k == 0%w then Some (INSTR None)
    else None
  else if t == as_word 2 then
    Some (INSTR (Some (k : @classes.id _ ids)))
  else None.

Lemma encode_cfi_tagK : pcancel encode_cfi_tag decode_cfi_tag.
Proof.
by case=> [[k|]|] /=; rewrite /decode_cfi_tag wpackK.
Qed.

Lemma decode_cfi_tagK : ocancel decode_cfi_tag encode_cfi_tag.
Proof.
move=> w; rewrite /decode_cfi_tag.
case E: (wunpack _) => [k [t []]]; move: E.
have [{t}->|] := altP (t =P _).
  have [{k}->|hk] //= := altP (k =P _).
  by move=> <-; rewrite wunpackK.
have [{t}-> _|] := altP (t =P 1%w).
  have [{k}->|hk] //= := altP (k =P _).
  by move=> <-; rewrite wunpackK.
have [{t}-> _ _|] //= := altP (t =P as_word 2).
by move=> <-; rewrite wunpackK.
Qed.

Import DoNotation.

Instance encodable_tag : encodable mt cfi_tags := {
  decode k m := fun (w : mword mt) =>
    let: [hseq ut; w'] := @wunpack [:: 30; 2] w in
    if w' == 0%w then None
    else
      match k return option (wtag cfi_tags k) with
      | Symbolic.M =>
        if w' == 1%w then
          do! ut <- decode_cfi_tag ut;
          Some (@User cfi_tags ut)
        else if w' == as_word 2 then
          do! ut <- decode_cfi_tag ut;
          Some (@Entry cfi_tags ut)
        else None
      | Symbolic.P =>
        if w' == 1%w then
          do! ut <- decode_cfi_tag ut;
          Some ut
        else None
      | Symbolic.R =>
        if w' == 1%w then
          do! ut <- decode_cfi_tag ut;
          Some ut
        else None
      end
}.
Proof.
  - by eauto.
  - by move=> tk _; rewrite 2!wunpackS.
Qed.

Section Refinement.

Variable cfg : id -> id -> bool.

(* XXX: Removing the explicit argument here causes Coq to throw a
Not_found when closing the Refinement section below, probably a bug to
be reported. *)

Instance sp : Symbolic.params := Sym.sym_cfi cfg.

Variable mi : refinement_common.monitor_invariant.
Variable stable : Symbolic.syscall_table mt.
Variable atable : Abs.syscall_table mt.

Inductive refine_state (ast : Abs.state mt) (cst : Concrete.state mt) : Prop :=
| rs_intro : forall (sst : Symbolic.state mt),
               refinement_common.refine_state mi stable sst cst ->
               RefinementAS.refine_state stable ast sst ->
               refine_state ast cst.
Hint Constructors refine_state.

Hypothesis implementation_correct :
  monitor_code_bwd_correctness mi stable.

Hypothesis refine_syscalls_correct : RefinementAS.refine_syscalls stable atable stable.

Hypothesis syscall_sem :
  forall ac ast ast',
    @Abs.sem mt ac ast = Some ast' ->
       let '(Abs.State imem _ _ _ b) := ast in
       let '(Abs.State imem' _ _ _ b') := ast' in
         imem = imem' /\ b' = b.

Hypothesis syscall_preserves_instruction_tags :
  forall sc st st',
    Sym.instructions_tagged (cfg := cfg) (Symbolic.mem st) ->
    Symbolic.sem sc st = Some st' ->
    Sym.instructions_tagged (cfg := cfg) (Symbolic.mem st').

Hypothesis syscall_preserves_valid_jmp_tags :
  forall sc st st',
    Sym.valid_jmp_tagged stable (Symbolic.mem st) ->
    Symbolic.sem sc st = Some st' ->
    Sym.valid_jmp_tagged stable (Symbolic.mem st').

Hypothesis syscall_preserves_entry_tags :
  forall sc st st',
    Sym.entry_points_tagged stable (Symbolic.mem st) ->
    Symbolic.sem sc st = Some st' ->
    Sym.entry_points_tagged stable (Symbolic.mem st').

Hypothesis syscall_preserves_register_tags :
  forall sc st st',
    Sym.registers_tagged (cfg:=cfg) (Symbolic.regs st) ->
    Symbolic.sem sc st = Some st' ->
    Sym.registers_tagged (Symbolic.regs st').

Hypothesis syscall_preserves_jump_tags :
  forall sc st st',
    Sym.jumps_tagged (cfg:=cfg) (Symbolic.mem st) ->
    Symbolic.sem sc st = Some st' ->
    Sym.jumps_tagged (Symbolic.mem st').

Hypothesis syscall_preserves_jal_tags :
  forall sc st st',
    Sym.jals_tagged (cfg:=cfg) (Symbolic.mem st) ->
    Symbolic.sem sc st = Some st' ->
    Sym.jals_tagged (Symbolic.mem st').

Lemma backwards_refinement_as ast sst sst' :
  RefinementAS.refine_state stable ast sst ->
  exec (Symbolic.step stable) sst sst' ->
  exists ast',
    exec (fun ast ast' => Abs.step atable cfg ast ast') ast ast' /\
    RefinementAS.refine_state stable ast' sst'.
Proof.
move => REF EXEC.
elim: EXEC ast REF=> {sst sst'} [sst _|sst sst' sst'' _ STEPS EXEC IH] ast REF.
  by eauto 7.
have [ast' [STEPA REF']] :=
  RefinementAS.backwards_simulation refine_syscalls_correct syscall_sem
                                    syscall_preserves_instruction_tags
                                    syscall_preserves_valid_jmp_tags
                                    syscall_preserves_entry_tags
                                    syscall_preserves_register_tags
                                    syscall_preserves_jump_tags
                                    syscall_preserves_jal_tags
                                    REF STEPS.
by have [ast'' [EXECA REF'']] := IH ast' REF'; eauto 7.
Qed.

Lemma backwards_refinement (ast : Abs.state mt) (cst cst' : Concrete.state mt) :
  refine_state ast cst ->
  exec (Concrete.step _ masks) cst cst' ->
  in_user cst' ->
  exists ast',
    exec (fun ast ast' => Abs.step atable cfg ast ast') ast ast' /\
    refine_state ast' cst'.
Proof.
move => [sst SC AS] EXECC INUSER.
have [sst' EXECS SC'] := backward.backwards_refinement SC EXECC INUSER.
by have [ast' [EXECA AS']] := backwards_refinement_as AS EXECS; eauto.
Qed.

End Refinement.

End WithClasses.

End CFIInstances.