Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.Exp.
Require Export Iron.Language.SystemF2Effect.Value.Relation.Wf.
Require Export Iron.Language.SystemF2Effect.Value.Operator.LiftX.
Require Export Iron.Language.SystemF2Effect.Store.Prop.

(********************************************************************)
(* Store Environment holds the types of locations. *)
Definition stenv := list ty.

(* Types of primops.
   We keep this separate from the main typing judgement to make it easy
   to add new primops. *)
Fixpoint typeOfOp1 (op : op1) : ty
 := match op with
    | OSucc    => TFun TNat TNat  (TBot KEffect)
    | OIsZero  => TFun TNat TBool (TBot KEffect)
    end.

(* Types of Value expressions *)
Inductive
  TypeV : kienv -> tyenv -> stenv -> stprops
        -> val  -> ty
        -> Prop :=

  (* Variables.
     We get the type of a variable from the type environment. *)
  | TvVar
    :  forall ke te se sp i t
    ,  get i te = Some t
    -> KindT  ke sp t KData
    -> TypeV  ke te se sp (VVar i) t

  (* Store locations.
     We get the type of a location from the store typing.
     The type of a location must be a Reference because we need somewhere
     to attach the region variable. Our primitive types don't have region
     annotations themselves. *)
  | TvLoc
    :  forall ke te se sp l r t
    ,  get l se = Some (TRef r t)
    -> KindT  ke sp       (TRef r t) KData
    -> TypeV  ke te se sp (VLoc l)   (TRef r t)

  (* Value abstraction.
     The body is checked in an environment extended with the type of
     of the formal parameter. *)
  | TvLam
    :  forall ke te se sp t1 t2 x2 e2
    ,  KindT  ke sp t1 KData
    -> TypeX  ke (te :> t1) se sp x2 t2 e2
    -> TypeV  ke te         se sp (VLam t1 x2) (TFun t1 e2 t2)

  (* Type abstraction.
     The body is checked in an environemnt extended with the kind of
     the formal parameter. As the parameter kind is pushed onto the base
     of the kind environment we need to lift any references to kinds
     higher in the stack across the new one. The body expression must
     be pure because we don't have anywhere to store the effect of the
     body in the type of the overall abstraction. This is different for
     value abstractions, where the function constructor has an effect
     annotation. *)
  | TvLAM
    :  forall ke te se sp k1 t2 x2
    ,  TypeX (ke :> k1) (liftTE 0 te) (liftTE 0 se) sp x2 t2 (TBot KEffect)
    -> TypeV ke          te            se   sp (VLAM k1 x2) (TForall k1 t2)

  (* Primitive constants.
     We get the types of these from the 'typeOfConst' function so we can
     add new sorts of constants without changing the proof. *)
  | TvConst
    :  forall ke te se sp c t
    ,  t = typeOfConst c
    -> TypeV  ke te se sp (VConst c) t

  with TypeX :  kienv -> tyenv -> stenv -> stprops
             -> exp   -> ty -> ty
             -> Prop :=

  (* Embed values in the expression language.
     All values are pure because they can't be stepped further, which
     in turn means they can't perform any more effectful actions. *)
  | TxVal
    :  forall ke te se sp v1 t1
    ,  TypeV  ke te se sp v1 t1
    -> TypeX  ke te se sp (XVal v1) t1 (TBot KEffect)

  (* Let-bindings. *)
  | TxLet
    :  forall ke te se sp t1 x1 t2 x2 e1 e2
    ,  KindT  ke sp t1 KData
    -> TypeX  ke te         se sp x1 t1 e1
    -> TypeX  ke (te :> t1) se sp x2 t2 e2
    -> TypeX  ke te         se sp (XLet t1 x1 x2) t2 (TSum e1 e2)

  (* Value application. *)
  | TxApp
    :  forall ke te se sp t11 t12 v1 v2 e1
    ,  TypeV  ke te se sp v1 (TFun t11 e1 t12)
    -> TypeV  ke te se sp v2 t11
    -> TypeX  ke te se sp (XApp v1 v2) t12 e1

  (* Type application. *)
  | TvAPP
    :  forall ke te se sp v1 k11 t12 t2
    ,  TypeV  ke te se sp v1 (TForall k11 t12)
    -> KindT  ke sp t2 k11
    -> TypeX  ke te se sp (XAPP v1 t2) (substTT 0 t2 t12) (TBot KEffect)

  (* Store Operators ******************)
  (* Create a private region. *)
  | TxPrivate
    :  forall ke te se sp x t tL e eL
    ,  lowerTT 0 t                = Some tL
    -> lowerTT 0 (maskOnVarT 0 e) = Some eL
    -> TypeX (ke :> KRegion) (liftTE 0 te) (liftTE 0 se) sp x            t  e
    -> TypeX ke              te            se            sp (XPrivate x) tL eL

  (* Extend an existing region. *)
  | TxExtend
    :  forall ke te se sp r1 x2 t e eL
    ,  lowerTT 0 (maskOnVarT 0 e) = Some eL
    -> KindT ke sp r1 KRegion
    -> TypeX (ke :> KRegion) (liftTE 0 te) (liftTE 0 se) sp x2 t e
    -> TypeX ke te se  sp (XExtend r1 x2) (substTT 0 r1 t) (TSum eL (TAlloc r1))

  (* Allocate a new heap binding. *)
  | TxOpAlloc
    :  forall ke te se sp r1 v2 t2
    ,  KindT  ke sp r1 KRegion
    -> TypeV  ke te se sp v2 t2
    -> TypeX  ke te se sp (XAlloc r1 v2) (TRef r1 t2) (TAlloc r1)

  (* Read a value from a heap binding. *)
  | TxOpRead
    :  forall ke te se sp v1 r1 t2
    ,  KindT  ke sp r1 KRegion
    -> TypeV  ke te se sp v1 (TRef r1 t2)
    -> TypeX  ke te se sp (XRead r1 v1)     t2    (TRead r1)

  (* Write a value to a heap binding. *)
  | TxOpWrite
    :  forall ke te se sp v1 v2 r1 t2
    ,  KindT  ke sp r1 KRegion
    -> TypeV  ke te se sp v1 (TRef r1 t2)
    -> TypeV  ke te se sp v2 t2
    -> TypeX  ke te se sp (XWrite r1 v1 v2) TUnit (TWrite r1)

  (* Primtive Operators ***************)
  | TxOpPrim
    :  forall ke te se sp op v1 t11 t12 e
    ,  typeOfOp1 op = TFun t11 t12 e
    -> TypeV  ke te se sp v1 t11
    -> TypeX  ke te se sp (XOp1 op v1) t12 e.

Hint Constructors TypeV.
Hint Constructors TypeX.

(********************************************************************)
(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TypeV _ _ _ _ (VVar   _)     _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VLoc   _)     _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VLam   _ _)   _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VLAM   _ _)   _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VConst _)     _    |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XVal   _)     _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XLet   _ _ _) _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XApp   _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XAPP   _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XPrivate _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XExtend  _ _) _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XAlloc _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XRead  _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XWrite _ _ _) _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XOp1   _ _)   _ _  |- _ ] => inverts H
   end).


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_constructor6 (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair intInc hmapPush.

(* Check eval_state tvm_address _. *)

(* Locate "address". *)

Lemma DePoolContract_Ф_constructor6_exec: forall  ( minStake validatorAssurance: Z )
                                                  ( proxyCode: TvmCell )
                                                  ( validatorWallet : Z )
                                                  ( participantRewardFraction : Z )
                                                  ( l: Ledger ),
let lv := exec_state (↓ ValidatorBase_Ф_Constructor2 validatorWallet) l in
let lv := {$ lv With (RoundsBase_ι_m_roundQty, 0) $} in
let address := eval_state tvm_address l in
let wid := addressWid address in
    let wid0 := wid =? 0 in
let tvm_pubkey := eval_state tvm_pubkey l in
let msg_pubkey := eval_state msg_pubkey l in
    let pubkeys :=  msg_pubkey =? tvm_pubkey in
    let tvm_pubkey0 := negb (tvm_pubkey =? 0) in
    let minstake1 := minStake >=? x1_ton in
    let minStakeValidator := minStake <=? validatorAssurance in
let proxy_code_hash := tvm_hash proxyCode in
let PROXY_CODE_HASH := DePool_ι_PROXY_CODE_HASH in
    let proxyCodeSame := proxy_code_hash =? PROXY_CODE_HASH in
    let validatorStdAddrWithoutAnyCast := isStdAddrWithoutAnyCast validatorWallet in
   (*  let associationStdAddrWithoutAnyCast := isStdAddrWithoutAnyCast validatorWallet in  *)
    let participantRewardFraction0 := ( ( participantRewardFraction >? 0 ) &&
                                        ( participantRewardFraction <? 100 ) )%bool in
let validatorRewardFraction := 100 - participantRewardFraction in
let CRITICAL_THRESHOLD := DePool_ι_CRITICAL_THRESHOLD in
   (*  let if1 : bool := balanceThreshold >=? CRITICAL_THRESHOLD in *)
let balance := eval_state tvm_balance l in
let DEPOOL_CONSTRUCTOR_FEE :=  DePoolLib_ι_DEPOOL_CONSTRUCTOR_FEE in
let MIN_PROXY_BALANCE := DePoolLib_ι_MIN_PROXY_BALANCE in
let PROXY_CONSTRUCTOR_FEE := DePoolLib_ι_PROXY_CONSTRUCTOR_FEE in
    let balance2 := balance >? CRITICAL_THRESHOLD + DEPOOL_CONSTRUCTOR_FEE +
                                2 * ( MIN_PROXY_BALANCE + PROXY_CONSTRUCTOR_FEE ) in

    let roundTimeParams := eval_state ConfigParamsBase_Ф_roundTimeParams l in
    let curValidatorData := eval_state ConfigParamsBase_Ф_getCurValidatorData l in
    let prevValidatorHash := eval_state ConfigParamsBase_Ф_getPrevValidatorHash l in

let sender := eval_state (↓ msg_sender) l in
let isDepool : bool := ((tvm_pubkey =? tvm_hash (toCell (builder_store default sender 0))) ||
                       (tvm_pubkey =? tvm_hash (toCell (builder_store default sender 1))))%bool in
(*** end of require section ****)
let la := exec_state (↓ tvm_accept) lv in
let address := eval_state (↓ tvm_address) la in

let b0 := builder_store default address 0 in
let b1 := builder_store default address 1 in
let pk0 := tvm_hash (toCell b0) in
let pk1 := tvm_hash (toCell b1) in
let data0 := tvm_buildEmptyData pk0 in
let data1 := tvm_buildEmptyData pk1 in
let stateInit0 := tvm_buildStateInit proxyCode data0 in
let stateInit1 := tvm_buildStateInit proxyCode data1 in
let m_proxies := eval_state (↑3 ε ProxyBase_ι_m_proxies) l in
let (epa0, lp0) := run (↓ tvm_newE DePoolProxyContractD
                                {|| cmessage_wid ::= $ xInt0 !- $ xInt1 ,
                                cmessage_value ::= $ DePoolLib_ι_MIN_PROXY_BALANCE !+ $ DePoolLib_ι_PROXY_CONSTRUCTOR_FEE ,
                                cmessage_stateInit ::= $ stateInit0 ||}
                                DePoolProxyContract_Ф_constructor5 ) la in
let (epa1, lp1) := run (↓ tvm_newE DePoolProxyContractD
                                {|| cmessage_wid ::= $ xInt0 !- $ xInt1 ,
                                cmessage_value ::= $ DePoolLib_ι_MIN_PROXY_BALANCE !+ $ DePoolLib_ι_PROXY_CONSTRUCTOR_FEE ,
                                cmessage_stateInit ::= $ stateInit1 ||}
                                DePoolProxyContract_Ф_constructor5 ) lp0 in
let pa0 := errorMapDefault Datatypes.id epa0 (-1) in
let pa1 := errorMapDefault Datatypes.id epa1 (-1) in
let lp1' := {$ lp1 With (DePoolContract_ι_m_poolClosed, false);
                         (DePoolContract_ι_m_minStake, minStake);
                         (DePoolContract_ι_m_validatorAssurance, validatorAssurance);
                         (DePoolContract_ι_m_participantRewardFraction, participantRewardFraction);
                         (DePoolContract_ι_m_validatorRewardFraction, validatorRewardFraction)  ;
                         (ProxyBase_ι_m_proxies, hmapPush pa1 (hmapPush pa0 m_proxies)  )  $} in

let (r2, lr2) := run (↓ DePoolContract_Ф_generateRound) lp1' in
let (r1, lr1) := run (↓ DePoolContract_Ф_generateRound) lr2 in
let (r0, lr0) := run (↓ DePoolContract_Ф_generateRound) lr1 in
let (rpre0, lrpre0) := run (↓ DePoolContract_Ф_generateRound) lr0 in

let now := eval_state (↓ tvm_now) lrpre0 in
let validationEnd := errorMapDefaultF snd curValidatorData (fun _ => 0) in
let electionsStartBefore := errorMapDefaultF snd roundTimeParams (fun _ => 0) in
let areElectionsStarted := now >=? validationEnd - electionsStartBefore  in
let vhash := if areElectionsStarted then  (errorMapDefaultF (fst ∘ fst) curValidatorData (fun _ => 0)) else (errorMapDefaultF Datatypes.id prevValidatorHash (fun _ => 0)) in

let r0 := {$ r0 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_Pooling) $} in
let r2 := {$ r2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_Completed);
                     (RoundsBase_ι_Round_ι_completionReason, RoundsBase_ι_CompletionReasonP_ι_FakeRound);
                     (RoundsBase_ι_Round_ι_unfreeze, 0)  $} in
let r1 := {$ r1 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze);
                     (RoundsBase_ι_Round_ι_completionReason, RoundsBase_ι_CompletionReasonP_ι_FakeRound);
                     (RoundsBase_ι_Round_ι_unfreeze, 0);
                     (RoundsBase_ι_Round_ι_vsetHashInElectionPhase, vhash)  $} in

let lsetPre0 := exec_state (↓ RoundsBase_Ф_setRound (rpre0 ->> RoundsBase_ι_Round_ι_id) rpre0) lrpre0 in
let lset0 := exec_state (↓ RoundsBase_Ф_setRound (r0 ->> RoundsBase_ι_Round_ι_id) r0) lsetPre0 in
let lset1 := exec_state (↓ RoundsBase_Ф_setRound (r1 ->> RoundsBase_ι_Round_ι_id) r1) lset0 in
let lset2 := exec_state (↓ RoundsBase_Ф_setRound (r2 ->> RoundsBase_ι_Round_ι_id) r2) lset1 in

exec_state (↓ DePoolContract_Ф_Constructor6 minStake validatorAssurance
                                          proxyCode validatorWallet
                                          participantRewardFraction) l =
if (wid0) then
    if (pubkeys) then
        if (tvm_pubkey0) then
            if (minstake1) then
                if (minStakeValidator) then
                    if (proxyCodeSame) then
                        if (validatorStdAddrWithoutAnyCast) then
                            if (participantRewardFraction0) then
                                if (balance2) then
                                    if isDepool then
                                         if (errorValueIsValue roundTimeParams) then
                                            if (errorValueIsValue curValidatorData) then
                                                if (errorValueIsValue prevValidatorHash) then  lset2
                                                 else lp1'
                                            else lp1'
                                        else lp1'
                                    else la
                                else lv
                            else lv
                        else lv
                    else lv
                else lv
            else lv
        else lv
    else lv
else lv.

Proof.
    intros.
    destructLedger l.
    compute.

    repeat rewrite letIf.  idtac.
    repeat rewrite matchIf.  idtac.
    repeat rewrite letIf.  idtac.
    repeat rewrite matchIf.  idtac.
    repeat rewrite letIf.  idtac.

    all: repeat destructIf_solve2. (* idtac. *)

    (* idtac.*)

   (* Require Import depoolContract.Lib.CommonStateProofs.
    all: apply ledgerEq; auto. idtac.
    simpl.

    apply RoundsBaseEq; auto. idtac.
    simpl. idtac.

    all: try congruence. *)

Qed.

Lemma DePoolContract_Ф_constructor6_eval: forall  ( minStake validatorAssurance: Z )
                                                  ( proxyCode: TvmCell )
                                                  ( validatorWallet : Z )
                                                  ( participantRewardFraction : Z )
                                                  ( l: Ledger ),
let address := eval_state tvm_address l in
let wid := addressWid address in
    let wid0 := wid =? 0 in
let tvm_pubkey := eval_state tvm_pubkey l in
let msg_pubkey := eval_state msg_pubkey l in
    let pubkeys :=  msg_pubkey =? tvm_pubkey in
    let tvm_pubkey0 := negb (tvm_pubkey =? 0) in
    let minstake1 := minStake >=? x1_ton in
    let minStakeValidator := minStake <=? validatorAssurance in
let proxy_code_hash := tvm_hash proxyCode in
let PROXY_CODE_HASH :=  DePool_ι_PROXY_CODE_HASH in
    let proxyCodeSame := proxy_code_hash =? PROXY_CODE_HASH in
    let validatorStdAddrWithoutAnyCast := isStdAddrWithoutAnyCast validatorWallet in
   (*  let associationStdAddrWithoutAnyCast := isStdAddrWithoutAnyCast validatorWallet in  *)
    let participantRewardFraction0 := ( ( participantRewardFraction >? 0 ) &&
                                        ( participantRewardFraction <? 100 ) )%bool in
let validatorRewardFraction := 100 - participantRewardFraction in
let CRITICAL_THRESHOLD :=  DePool_ι_CRITICAL_THRESHOLD  in
   (*  let if1 : bool := balanceThreshold >=? CRITICAL_THRESHOLD in *)
let balance := eval_state tvm_balance l in
let DEPOOL_CONSTRUCTOR_FEE := DePoolLib_ι_DEPOOL_CONSTRUCTOR_FEE  in
let MIN_PROXY_BALANCE :=  DePoolLib_ι_MIN_PROXY_BALANCE in
let PROXY_CONSTRUCTOR_FEE :=  DePoolLib_ι_PROXY_CONSTRUCTOR_FEE in
    let balance2 := balance >? CRITICAL_THRESHOLD + DEPOOL_CONSTRUCTOR_FEE +
                                2 * ( MIN_PROXY_BALANCE + PROXY_CONSTRUCTOR_FEE ) in

    let roundTimeParams := eval_state ConfigParamsBase_Ф_roundTimeParams l in
    let curValidatorData := eval_state ConfigParamsBase_Ф_getCurValidatorData l in
    let prevValidatorHash := eval_state ConfigParamsBase_Ф_getPrevValidatorHash l in

let sender := eval_state (↓ msg_sender) l in
let isDepool : bool := ((tvm_pubkey =? tvm_hash (toCell (builder_store default sender 0))) ||
                       (tvm_pubkey =? tvm_hash (toCell (builder_store default sender 1))))%bool in

eval_state (↓ DePoolContract_Ф_Constructor6 minStake validatorAssurance
                                          proxyCode validatorWallet
                                          participantRewardFraction) l =

if (wid0) then
    if (pubkeys) then
        if (tvm_pubkey0) then
            if (minstake1) then
                if (minStakeValidator) then
                    if (proxyCodeSame) then
                        if (validatorStdAddrWithoutAnyCast) then
                            if (participantRewardFraction0) then
                                if (balance2) then
                                    if isDepool then
                                        if (errorValueIsValue roundTimeParams) then
                                            if (errorValueIsValue curValidatorData) then
                                                if (errorValueIsValue prevValidatorHash) then Value I
                                                else errorMapDefaultF (fun _ => Value I) prevValidatorHash (fun er => Error er)
                                            else errorMapDefaultF (fun _ => Value I) curValidatorData (fun er => Error er)
                                        else errorMapDefaultF (fun _ => Value I) roundTimeParams (fun er => Error er)
                                    else Error (eval_state (↑ε10 DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL) l)
                                else Error (eval_state (↑ε7 Errors_ι_BAD_ACCOUNT_BALANCE) l )
                            else Error (eval_state (↑ε7 Errors_ι_BAD_PART_REWARD) l)
                        else Error (eval_state (↑ε7 Errors_ι_VALIDATOR_IS_NOT_STD) l)
                    else Error (eval_state (↑ε7 Errors_ι_BAD_PROXY_CODE) l)
                else Error (eval_state (↑ε7 Errors_ι_BAD_STAKES) l)
            else Error (eval_state (↑ε7 Errors_ι_BAD_STAKES) l)
        else Error (eval_state (↑ε7 Errors_ι_CONSTRUCTOR_NO_PUBKEY) l)
    else Error (eval_state (↑ε7 Errors_ι_IS_NOT_OWNER) l)
else  Error (eval_state (↑ε7 Errors_ι_NOT_WORKCHAIN0) l) .

Proof.
    intros.
    destructLedger l.
    compute.

    Time repeat destructIf_solve. idtac.

    all: try congruence.

Qed.

End DePoolContract_Ф_constructor6.


Require Import Coqlib.
Require Import Maps.
Require Import LibTactics.

Require Import Integers.
Open Scope Z_scope.
Import ListNotations.

Set Asymmetric Patterns.

Require Import state.
Require Import language.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import logic.

Require Import lemmas.
Require Import lemmas_ins.

Require Import Coq.Logic.FunctionalExtensionality.

Require Import integer_lemma.

Require Import sep_lemma.
Require Import reg_lemma.
Require Import derived_rule.

Require Import tm_dly_lemma.

Require Import code.
Require Import ctxswitch_spec.

Require Import lemma1.

Require Import AdjustCWP.

Open Scope nat.
Open Scope code_scope.
Open Scope mem_scope.

Theorem Ta0StartAdjustCWPProof :
  forall vl,
    spec |- {{ ta0_start_adjust_cwp_pre vl }}
             ta0_start_adjust_cwp
           {{ ta0_start_adjust_cwp_post vl }}.
Proof.
  intros.
  unfold ta0_start_adjust_cwp_pre.
  unfold ta0_start_adjust_cwp_post.
  hoare_ex_intro_pre.
  renames x' to fmg, x'0 to fmo, x'1 to fml, x'2 to fmi.
  renames x'3 to id, x'6 to vi, x'4 to F, x'5 to vy, x'12 to vz, x'13 to vn.
  renames x'7 to ll, x'8 to ct, x'9 to nt, x'10 to nctx, x'11 to nstk.
  eapply Pure_intro_rule.
  introv Hlglv.
  hoare_lift_pre 13.
  eapply Pure_intro_rule.
  introv Hnctx.
  hoare_lift_pre 13.
  eapply Pure_intro_rule.
  introv Hct.
  unfold ta0_start_adjust_cwp.

  eapply backward_rule.
  introv Hs.
  simpl_sep_liftn_in Hs 2.
  eapply Regs_Global_combine_GenRegs in Hs; eauto.
  destruct fmg, fmo, fml, fmi.

  (** getcwp g4 *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply getcwp_rule_reg_fm; eauto.
  simpl upd_genreg.

  (** rd wim g7 *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply rd_rule_reg_wim; eauto.
  simpl upd_genreg.

  (** set 1 g6 *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply set_rule_reg; eauto.
  simpl upd_genreg.

  (** sll g6 g4 g4 *)
  eapply seq_rule.
  TimReduce_simpl.
  eapply sll_rule_reg; eauto.
  simpl; eauto.
  simpl upd_genreg.

  eapply hoare_pure_gen' with (pu := $ 0 <=ᵤᵢ id <=ᵤᵢ $ 7 /\ $ 0 <=ᵤᵢ vi <=ᵤᵢ $ 7).
  {
    introv Hs.
    simpl_sep_liftn_in Hs 2.
    unfold FrameState in Hs.
    asrt_to_line_in Hs 3.
    simpl_sep_liftn_in Hs 4.
    eapply sep_pure_l_elim in Hs.
    destruct Hs; eauto.
  }

  eapply Pure_intro_rule.
  introv Hid_inrange.
  destruct Hid_inrange as [Hid_inrange Hvi_inrange].
  rewrite get_range_0_4_stable; eauto.

  eapply Seq_conseq_rule.
  eapply Ta0AdjustCWPProof; eauto.
  introv Hs.
  unfold ta0_adjust_cwp_pre.
  sep_ex_intro.
  eapply sep_pure_l_intro; eauto.
  simpl_sep_liftn 2.
  eapply GenRegs_split_Regs_Global; eauto.
  do 11 sep_cancel1 1 1.
  instantiate (1 := Aemp).
  eapply astar_emp_intro_r; eauto.
  simpl get_frame_nth.
  eapply sep_pure_l_intro; eauto.
  split; eauto.
  instantiate (1 := id).
  split; eauto.
  eapply rotate_end; eauto.
  simpl; eauto.

  introv Hs.
  unfold ta0_adjust_cwp_post in Hs.
  eauto.
Qed.


Set Implicit Arguments.

Require Import ADT.

Module Make (Import E : ADT).

  Require Import Inv.
  Module Import InvMake := Make E.
  Import Semantics.
  Import SemanticsMake.
  Require Import WordMap.
  Require Import FMapFacts.
  Module Properties := Properties WordMap.
  Module Facts := Facts WordMap.

  Lemma make_triples_Word : forall pairs outs, length outs = length pairs -> map (@Word _) (make_triples pairs outs) = map fst pairs.
    induction pairs; destruct outs; simpl; intuition.
    f_equal; auto.
  Qed.

  Lemma make_triples_Word_ADTIn : forall pairs outs, length outs = length pairs -> map (fun x => (Word x, ADTIn x)) (make_triples pairs outs) = pairs.
    induction pairs; destruct outs; simpl; intuition.
    f_equal; auto.
  Qed.

  Lemma make_triples_ADTIn : forall pairs outs, length outs = length pairs -> map (@ADTIn _) (make_triples pairs outs) = map snd pairs.
    induction pairs; destruct outs; simpl; intuition.
    f_equal; auto.
  Qed.

  Lemma make_triples_length : forall pairs outs, length outs = length pairs -> length (make_triples pairs outs) = length pairs.
    induction pairs; destruct outs; simpl; intuition.
  Qed.

  Import WordMap.

  Lemma separated_Equal : forall h1 h2 a b,
    WordMap.Equal h1 h2
    -> Semantics.separated (ADTValue := ADTValue) h1 a b
    -> Semantics.separated h2 a b.
    unfold Semantics.separated; intuition.
    right; intro; apply H1.
    eapply Properties.F.In_m; eauto.
  Qed.

  Lemma good_inputs_Equal : forall A h1 h2 pairs,
    WordMap.Equal (elt := A) h1 h2
    -> Semantics.good_inputs h1 pairs
    -> Semantics.good_inputs h2 pairs.
    unfold Semantics.good_inputs; intuition.
    eapply Forall_weaken; [ | eassumption ].
    unfold Semantics.word_adt_match; intros.
    destruct x; simpl in *.
    destruct s; auto.
    erewrite <- Facts.find_m; eauto.
  Qed.

  Hint Constructors Semantics.RunsTo.

  Lemma store_out_Equal : forall triples h1 h2,
    WordMap.Equal h1 h2
    -> WordMap.Equal
    (fold_left (Semantics.store_out (ADTValue:=ADTValue)) triples h1)
    (fold_left (Semantics.store_out (ADTValue:=ADTValue)) triples h2).
    induction triples; simpl; intuition.
    apply IHtriples.
    unfold Semantics.store_out.
    destruct a; simpl.
    destruct ADTIn; auto.
    destruct ADTOut; auto.
    apply Properties.F.add_m; auto.
    apply Properties.F.remove_m; auto.
  Qed.

  Lemma heap_upd_option_Equal : forall h1 h2 a b,
    WordMap.Equal h1 h2
    -> WordMap.Equal (heap_upd_option h1 a b) (heap_upd_option h2 a b).
    unfold heap_upd_option, Semantics.heap_upd_option; intros.
    destruct b; auto.
    apply Properties.F.add_m; auto.
  Qed.

  Ltac t :=
    repeat match goal with
             | [ x := _ |- _ ] => subst x
             | [ H : forall h : WordMap.t _, _, H' : WordMap.Equal _ _ |- _ ] =>
               apply H in H'; clear H;
                 destruct H'; intuition
           end; eauto.

  Lemma RunsTo_Equal : forall env s st st',
    Semantics.RunsTo (ADTValue := ADTValue) env s st st'
    -> forall h, WordMap.Equal (snd st) h
      -> exists h', WordMap.Equal (snd st') h'
        /\ Semantics.RunsTo (ADTValue := ADTValue) env s (fst st, h) (fst st', h').
    induction 1; intuition eauto.

    t.
    t.
    t.
    t.
    t.

    t.
    simpl in *.
    descend; eauto.
    change (fst v) with (fst (fst v, h)) at 2.
    eapply RunsToCallInternal; eauto.

    t.
    descend; eauto.
    change (fst v) with (fst (fst v, h)) at 2.
    eapply RunsToCallForeign; eauto.
    simpl; eapply good_inputs_Equal; eauto.
    simpl; eapply separated_Equal; eauto.
    apply store_out_Equal; auto.
    simpl.
    apply heap_upd_option_Equal.
    apply store_out_Equal; auto.

    simpl.
    descend; eauto.
    change h with (snd (fst v, h)) at 2.
    change (fst v) with (fst (fst v, h)) at 2.
    eauto.

    t.
    descend; eauto; econstructor.
  Qed.

  Lemma Safe_Equal : forall env s vs h h',
    Semantics.Safe (ADTValue := ADTValue) env s (vs, h)
    -> WordMap.Equal h h'
    -> Semantics.Safe env s (vs, h').
    intros.
    apply (Safe_coind (fun s st =>
      exists h, WordMap.Equal h (snd st)
        /\ Semantics.Safe env s (fst st, h))); eauto; intuition idtac;
    try match goal with
          | [ H : Logic.ex _ |- _ ] => destruct H; intuition idtac
        end.

    inversion_clear H3; eauto.

    inversion_clear H4.
    eapply RunsTo_Equal in H2.
    destruct H2; intuition idtac.
    apply H5 in H6.
    descend; eauto.
    apply Properties.F.Equal_sym; auto.
    apply Properties.F.Equal_sym; auto.

    inversion_clear H3; simpl in *; intuition subst.
    eauto.
    eauto.

    intros.
    destruct H1; intuition.
    inversion H3; clear H3.

    subst loop0 loop1.
    subst.
    left; intuition.
    eauto.
    simpl in *.
    eapply RunsTo_Equal in H1.
    destruct H1; intuition idtac.
    apply H8 in H4.
    descend; eauto.
    apply Properties.F.Equal_sym; auto.
    apply Properties.F.Equal_sym; auto.

    subst loop0 loop1.
    subst.
    right; intuition.

    inversion_clear H3; simpl in *.
    subst vs0 heap fs.
    subst; simpl in *.
    eauto 10.
    subst vs0 heap fs.
    subst; simpl in *.
    right; descend; eauto.
    eapply good_inputs_Equal; eauto.

    inversion_clear H4.
    tauto.
  Qed.

  Require Import RepInv.

  Module Make(R : RepInv E).
    Module Import Inner := InvMake.Make(R).

    Require Import LayoutHintsUtil.

    Lemma is_heap_Equal : forall h h',
      WordMap.Equal h h'
      -> is_heap h ===> is_heap h'.
      intros; apply starL_permute; unfold heap_elements; intuition.
      apply NoDupA_NoDup; apply WordMap.elements_3w.
      apply NoDupA_NoDup; apply WordMap.elements_3w.

      apply In_InA' in H0.
      apply InA_In.
      apply Properties.F.elements_mapsto_iff in H0.
      apply Properties.F.elements_mapsto_iff.
      eapply Properties.F.Equal_mapsto_iff; eauto.
      apply Properties.F.Equal_sym; auto.

      apply In_InA' in H0.
      apply InA_In.
      apply Properties.F.elements_mapsto_iff in H0.
      apply Properties.F.elements_mapsto_iff.
      eapply Properties.F.Equal_mapsto_iff; eauto.
    Qed.
  End Make.

  Lemma fold_weaken : forall k v ls h1 h2,
    WordMap.MapsTo k v (fold_left store_out ls h1)
    -> (forall k' v', WordMap.MapsTo k' v' h1 -> WordMap.MapsTo k' v' h2)
    -> WordMap.MapsTo k v (fold_left store_out ls h2).
    induction ls; simpl; intuition.
    eapply IHls; eauto.
    unfold store_out, Semantics.store_out; intros.
    destruct a; simpl in *.
    destruct ADTIn; auto.
    destruct ADTOut; auto.
    apply Properties.F.add_mapsto_iff;
      apply Properties.F.add_mapsto_iff in H1; intuition subst.
    eauto.

    apply Properties.F.remove_mapsto_iff;
      apply Properties.F.remove_mapsto_iff in H1; intuition subst.
    eauto.
  Qed.

  Lemma fold_fwd : forall k v ls h,
    WordMap.MapsTo k v (fold_left store_pair ls h)
    -> WordMap.MapsTo k v h
    \/ List.In (k, inr v) ls.
    induction ls; simpl; intuition.
    apply IHls in H; intuition.
    unfold store_pair in H0; simpl in H0.
    destruct b; simpl in *; auto.
    apply Properties.F.add_mapsto_iff in H0; intuition subst.
    eauto.
  Qed.

  Lemma foldp_bwd : forall k ls h,
    WordMap.In k h \/ (exists v, List.In (k, inr v) ls)
    -> WordMap.In k (fold_left store_pair ls h).
    induction ls; simpl; intuition.
    firstorder.
    destruct H0; intuition.
    eauto.
    eapply IHls.
    unfold store_pair; simpl.
    unfold heap_upd; simpl.
    left.
    apply Properties.F.add_in_iff.
    auto.
    destruct H0; intuition.
    injection H0; clear H0; intros; subst.
    apply IHls.
    unfold store_pair; simpl.
    unfold heap_upd; simpl.
    left.
    apply Properties.F.add_in_iff.
    auto.
    eauto.
  Qed.

  Lemma foldp_fwd : forall k ls h,
    WordMap.In k (fold_left store_pair ls h)
    -> WordMap.In k h \/ (exists v, List.In (k, inr v) ls).
    induction ls; simpl; intuition.
    apply IHls in H; clear IHls; intuition.
    unfold store_pair in H0; simpl in H0.
    destruct b; simpl; auto.
    unfold heap_upd in H0; simpl in H0.
    apply Properties.F.add_in_iff in H0; intuition subst.
    eauto.
    destruct H0.
    eauto.
  Qed.

  Lemma fold_fwd' : forall k v ls h,
    WordMap.MapsTo k v (fold_left store_out ls h)
    -> (WordMap.MapsTo k v h /\ forall a o, ~List.In {| Word := k; ADTIn := inr a; ADTOut := o |} ls)
    \/ exists a, List.In {| Word := k; ADTIn := inr a; ADTOut := Some v |} ls.
    induction ls; simpl; intuition.
    apply IHls in H; intuition.

    unfold store_out, Semantics.store_out in H; simpl in H.
    destruct a; simpl in *.
    destruct ADTIn.
    left; intuition eauto.
    discriminate.
    destruct ADTOut.
    apply Properties.F.add_mapsto_iff in H; intuition subst.
    eauto.
    left; intuition.
    eauto 2.
    apply Properties.F.remove_mapsto_iff in H; intuition subst.
    left; intuition.
    eauto 2.
    destruct H0.
    eauto.
  Qed.

  Lemma heap_merge_store_out :
    forall h pairs outs,
      good_inputs h pairs ->
      let h1 := make_heap pairs in
      let triples := make_triples pairs outs in
      WordMap.Equal (heap_merge (heap_diff h h1) (fold_left store_out triples h1))
      (fold_left store_out triples h).
    simpl; intros.
    unfold heap_merge, heap_diff.
    apply Properties.F.Equal_mapsto_iff; intuition.

    apply Properties.update_mapsto_iff in H0; intuition.

    eapply fold_weaken; eauto.
    intros.
    destruct H.
    apply fold_fwd in H0; intuition.
    apply Properties.F.empty_mapsto_iff in H3; tauto.
    eapply Forall_forall in H; try apply H3.
    hnf in H; simpl in H.
    apply WordMap.find_2; auto.

    apply Properties.diff_mapsto_iff in H0; intuition subst.

    Lemma In_make_heap' : forall k pairs h,
      WordMap.In (elt:=ADTValue) k (fold_left store_pair pairs h)
      -> WordMap.In k h \/ exists a, List.In (k, inr a) pairs.
      induction pairs; simpl; intuition.
      apply IHpairs in H; intuition.
      unfold store_pair in H0; simpl in H0.
      destruct b; auto.
      unfold heap_upd in H0.
      apply Properties.F.add_in_iff in H0; intuition subst.
      eauto.
      destruct H0; intuition subst.
      eauto.
    Qed.

    Lemma In_make_heap : forall k pairs,
      WordMap.In (elt:=ADTValue) k (make_heap pairs)
      -> exists a, List.In (k, inr a) pairs.
      intros.
      apply In_make_heap' in H; intuition eauto.
      apply Properties.F.empty_in_iff in H0; tauto.
    Qed.

    Lemma keep_when_agrees : forall k e pairs h outs,
      ~WordMap.In k (make_heap pairs)
      -> WordMap.MapsTo k e h
      -> WordMap.MapsTo k e (fold_left store_out (make_triples pairs outs) h).
      induction pairs; destruct outs; simpl; intuition.
      apply IHpairs; clear IHpairs; intros.
      apply H.
      unfold make_heap.
      apply foldp_bwd; right.
      apply In_make_heap in H1; destruct H1; intuition subst.
      simpl; eauto.
      unfold store_out, Semantics.store_out; simpl.
      destruct a; simpl in *.
      destruct a; auto.
      destruct a0.
      apply WordMap.add_2; auto.
      intro; subst.
      exfalso.
      apply H.
      apply foldp_bwd; simpl; eauto.
      apply WordMap.remove_2; auto.
      intro; subst.
      exfalso.
      apply H.
      apply foldp_bwd; simpl; eauto.
    Qed.

    eapply keep_when_agrees; eauto.

    apply fold_fwd' in H0; intuition idtac.

    Focus 2.
    destruct H1.
    destruct H.

    apply Properties.update_mapsto_iff; left.

    Lemma get_pair : forall k x e pairs outs h,
      Semantics.disjoint_ptrs pairs
      -> List.In {| Word := k; ADTIn := inr x; ADTOut := Some e |} (make_triples pairs outs)
      -> WordMap.MapsTo k e (fold_left store_out (make_triples pairs outs) h).
      induction pairs; destruct outs; simpl; intuition.
      simpl in *; intuition.
      injection H1; clear H1; intros; subst.
      assert (WordMap.MapsTo k e (store_out h {| Word := k; ADTIn := inr x; ADTOut := Some e |})).
      unfold store_out, Semantics.store_out; simpl.
      apply WordMap.add_1; auto.
      generalize dependent (store_out h {| Word := k; ADTIn := inr x; ADTOut := Some e |}).
      assert (forall v, ~List.In (k, inr v) pairs).
      intuition.
      hnf in H.
      simpl in H.
      inversion_clear H.
      apply H1.
      change k with (fst (k, @inr W _ v)).
      apply in_map.
      apply filter_In; tauto.
      generalize dependent H0.
      clear.
      generalize dependent outs.
      induction pairs; destruct outs; simpl; intuition.
      apply IHpairs; eauto.
      unfold store_out, Semantics.store_out; simpl.
      destruct a; simpl in *.
      destruct a; auto.
      destruct a0.
      apply WordMap.add_2; auto.
      intro; subst; eauto.
      apply WordMap.remove_2; auto.
      intro; subst; eauto.

      apply IHpairs.
      hnf in H.
      simpl in H.
      destruct b; simpl in *; auto.
      inversion H; auto.
      auto.
    Qed.

    eapply get_pair; eauto.

    case_eq (WordMap.mem k (make_heap pairs)); intros.

    apply Properties.update_mapsto_iff; left; intuition.

    Lemma get_pair' : forall k e pairs outs h,
      Semantics.disjoint_ptrs pairs
      -> WordMap.MapsTo k e h
      -> (forall a o, ~List.In {| Word := k; ADTIn := inr a; ADTOut := o |} (make_triples pairs outs))
      -> WordMap.MapsTo k e (fold_left store_out (make_triples pairs outs) h).
      induction pairs; destruct outs; simpl; intuition.
      apply IHpairs.
      hnf in H.
      simpl in H.
      destruct b; simpl in H; auto.
      inversion H; auto.
      simpl.
      unfold store_out, Semantics.store_out; simpl.
      destruct b; auto.
      destruct a0; simpl in *.
      apply WordMap.add_2; auto.
      intro; subst; eauto.
      apply WordMap.remove_2; auto.
      intro; subst; eauto.
      simpl in *.
      eauto.
    Qed.

    apply get_pair'; auto.
    destruct H; auto.
    apply WordMap.mem_2 in H1.
    apply In_make_heap in H1; destruct H1.
    destruct H.
    eapply Forall_forall in H; [ | eassumption ].
    hnf in H; simpl in H.
    apply WordMap.find_1 in H0.
    rewrite H0 in H; injection H; clear H; intros; subst.

    unfold make_heap.

    Lemma grab_it : forall k x pairs h,
      List.In (k, inr x) pairs
      -> Semantics.disjoint_ptrs pairs
      -> WordMap.MapsTo k x (fold_left store_pair pairs h).
      induction pairs; simpl; intuition.
      injection H1; clear H1; intros; subst.
      hnf in H0.
      simpl in H0.
      inversion_clear H0.
      generalize dependent H.
      clear IHpairs H1.
      assert (WordMap.MapsTo k x (store_pair h (k, inr x))).
      unfold store_pair; simpl.
      apply WordMap.add_1; auto.
      generalize dependent (store_pair h (k, inr x)).
      induction pairs; simpl in *; intuition.
      simpl in *; intuition subst.
      apply IHpairs.
      unfold store_pair; simpl.
      apply WordMap.add_2; auto.
      auto.

      apply IHpairs; auto.
      hnf in H0.
      simpl in H0.
      inversion_clear H0; auto.
    Qed.

    apply grab_it; auto.

    apply Properties.update_mapsto_iff; right; intuition.
    apply Properties.diff_mapsto_iff; intuition.
    apply Properties.F.not_mem_in_iff in H3; tauto.
    assert (~WordMap.In k (make_heap pairs)).
    intro.
    apply Properties.F.not_mem_in_iff in H4; tauto.
    clear H1.
    apply H4; clear H4.

    Lemma i_didn't_do_it : forall k ls h,
      (forall a o, ~List.In {| Word := k; ADTIn := inr a; ADTOut := o |} ls)
      -> WordMap.In k (fold_left store_out ls h)
      -> WordMap.In k h.
      induction ls; simpl; intuition.
      apply IHls in H0; eauto.
      unfold store_out, Semantics.store_out in H0.
      destruct a; simpl in *.
      destruct ADTIn; auto.
      destruct ADTOut.
      apply Properties.F.add_in_iff in H0; intuition subst.
      exfalso; eauto.
      apply Properties.F.remove_in_iff in H0; intuition subst.
    Qed.

    eapply i_didn't_do_it; eauto.
  Qed.

End Make.


From mathcomp Require Import
     all_ssreflect.

From PoS_NSB Require Import
     Parameters.

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

(** * Blocks
    This file contain the basic record representing a block.
**)
Record Block :=
  MkBlock
    { sl : Slot
    ; pred : Hash
    ; bid : Party }.

(* Type synononym for blocks *)
Definition Chain := seq Block.
Definition Chains := seq Chain.
Definition BlockPool := seq Block.

(* Decidable equality for Blocks *)
Definition eq_block (b b' : Block) :=
  match b, b' with
  | MkBlock sl pt bid, MkBlock sl' pt' bid' =>
    [&& sl == sl', pt == pt' & bid == bid']
  end.

Lemma eq_blockP : Equality.axiom eq_block.
Proof.
  case => sl pt bid; case => sl' pt' bid' .
  rewrite /eq_block.
  do ! (case: _ /eqP; [move => -> |by constructor; case]).
  by constructor.
Qed.

(* Canonial structures for block *)
Canonical Block_eqMixin := Eval hnf in EqMixin eq_blockP.
Canonical Block_eqType := Eval hnf in EqType Block Block_eqMixin.

(** Parameters for block *)
Parameter GenesisBlock : Block.
Parameter HashB : Block -> Hash.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.

Require Import ValidationUtil.

Lemma recKind_valid : recKind_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G i k triv0 triv1 H0 H1.
  valid_rewrite.
  constructor.
  assert (equivctx (hyp_tml (app Defs.kind i) :: G)
                    (hyp_tml (kuniv i) :: G)) as Hctx.
  {constructor. apply def_kindh_l. apply equivctx_refl. }
  rewrite -> def_kind in * |- *.
  apply tr_rec_kind_formation; eauto using deq_intro.
  Qed.

Lemma recKindEq_valid : recKindEq_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G i k l triv0 triv1 H0 H1.
  valid_rewrite.
  constructor.
  assert (equivctx (hyp_tml (app Defs.kind i) :: G)
                    (hyp_tml (kuniv i) :: G)) as Hctx.
  {constructor. apply def_kindh_l. apply equivctx_refl. }
  rewrite -> def_kind in * |- *.
  apply tr_rec_kind_formation; eauto using deq_intro.
Qed.

Lemma recForm_valid : recForm_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G a triv0 H.
  valid_rewrite.
  constructor.
  eauto using deqtype_intro.
Qed.

 Lemma recEq_valid : recEq_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G a b triv0 H.
  valid_rewrite.
  constructor.
  eauto using deqtype_intro.
 Qed.

Lemma recFormUniv_valid : recFormUniv_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G a i triv0 triv1 H0 H1.
  valid_rewrite.
  assert (equivctx (hyp_tml (app Defs.univ i) :: G)
                    (hyp_tml (univ i) :: G)) as Hctx.
  {constructor. apply def_univh_l. apply equivctx_refl. }
  rewrite -> def_univ in * |- *.
  constructor.
  apply tr_rec_formation_univ; eauto using deq_intro.
  Qed.

  Lemma recEqUniv_valid : recEqUniv_obligation.
 unfoldtop. autounfold with valid_hint.
  intros G a b i triv0 triv1 H0 H1.
  valid_rewrite.
  assert (equivctx (hyp_tml (app Defs.univ i) :: G)
                    (hyp_tml (univ i) :: G)) as Hctx.
  {constructor. apply def_univh_l. apply equivctx_refl. }
  rewrite -> def_univ in * |- *.
  constructor.
  apply tr_rec_formation_univ; eauto using deq_intro.
Qed.

Lemma recUnroll_valid : recUnroll_obligation.
 unfoldtop. autounfold with valid_hint.
 intros G a triv0 H.
 valid_rewrite.
 apply tr_rec_unroll.
 eauto using deqtype_intro.
Qed.

Lemma recBisimilar_valid : recBisimilar_obligation.
 unfoldtop. autounfold with valid_hint.
 intros G a b triv0 triv1 H0.
 valid_rewrite.
 constructor; eauto using deqtype_intro.
Qed.

Hint Rewrite def_rec : prepare.

Lemma recUnrollUniv_valid : recUnrollUniv_obligation.
Proof.
prepare.
intros G a i ext1 ext0 Hi Ha.
apply tr_rec_unroll_univ; auto.
Qed.


Require Import
        Fiat.Computation
        Fiat.Common.DecideableEnsembles
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.Formats.Base.FMapFormat
        Fiat.Narcissus.Formats.Base.LaxTerminalFormat.

Section SequenceFormat.

  Context {T : Type}. (* Target Type *)
  Context {cache : Cache}. (* State Type *)
  Context {monoid : Monoid T}. (* Target type is a monoid. *)

  Definition sequence_Format
             {S : Type}
             (format1 format2 : FormatM S T)
    := (fun s => compose _ (format1 s) (format2 s))%comp.

  Definition sequence_Decode
             {S S' T : Type}
             {cache : Cache}
             (decode1 : DecodeM (S' * T) T)
             (decode2 : S' -> DecodeM (S * T) T)
    : DecodeM (S * T) T :=
    fun t env =>
      `(s', t', env') <- decode1 t env;
        decode2 s' t' env'.

  Definition sequence_Decode'
             {S S' : Type}
             (decode1 : DecodeM (S' * T) T)
             (decode2 : S' -> DecodeM (S * T) T)
    : DecodeM (S' * S * T) T :=
      fun t env =>
      `(s', t', env') <- decode1 t env;
      `(s, t', env'') <- decode2 s' t' env';
      Ok ((s', s), t', env'').

  Definition sequence_Encode
             {S : Type}
             (encode1 encode2 : EncodeM S T)
    := (fun s env =>
          `(t1, env') <- encode1 s env ;
          `(t2, env'') <- encode2 s env';
          Ok (mappend t1 t2, env'')).

  Notation "x ++ y" := (sequence_Format x y) : format_scope .

  Lemma CorrectEncoder_sequence
        {S : Type}
        (format1 format2 : FormatM S T)
        (encode1 encode2 : EncodeM S T)
        (encode1_correct : CorrectEncoder format1 encode1)
        (encode1_consistent : (* If the first format produces *some*
                                 environment that makes the second format
                                 (and thus the composite format) non-empty,
                                 the encoder must also produce an environment
                                 that makes the second format non-empty. *)
           forall s env tenv' tenv'',
             format1 s env ∋ tenv'
             -> format2 s (snd tenv') ∋ tenv''
             -> exists tenv3 tenv4,
                 encode1 s env = Ok tenv3
                 /\ format2 s (snd tenv3) ∋ tenv4)
        (encode2_correct : CorrectEncoder format2 encode2)
    : CorrectEncoder (format1 ++ format2)
                     (sequence_Encode encode1 encode2).
  Proof.
    unfold CorrectEncoder, sequence_Encode, sequence_Format, compose,
    DecodeBindOpt, BindOpt in *; intuition; intros.
    - destruct (encode1 a env) as [ [t1 xxenv] | ] eqn: ? ;
        simpl in *; try discriminate.
      destruct (encode2 a xxenv) as [ [t2 xxxenv] | ] eqn: ? ;
        simpl in *; try discriminate; injections.
      repeat computes_to_econstructor; eauto.
    -  unfold Bind2 in *; computes_to_inv; destruct v;
         destruct v0; simpl in *.
       destruct (encode1 a env) as [ [t1 xxenv] | ] eqn: ? ;
         simpl in *.
       2: { eapply H0; eauto. rewrite Heqh. constructor. }
       eapply H2; try eassumption.
       destruct (encode2 a xxenv) as [ [t2' xxxenv] | ] eqn: ? ;
         simpl in *; injections.
       + inversion H3.
       + specialize (encode1_consistent _ _ _ _ H4 H4');
           destruct_ex; split_and.
         rewrite H6 in Heqh; injections; simpl in *.
         destruct x0; elimtype False.
         eapply H2.
         rewrite Heqh0; constructor.
         eassumption.
  Qed.

  Lemma Sequence_decode_correct
        {S V1 V2 : Type}
        {P : CacheDecode -> Prop}
        {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
        (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
        (view1 : S -> V1 -> Prop)
        (view2 : V1 -> S -> V2 -> Prop)
        (Source_Predicate : S -> Prop)
        (View_Predicate2 : V1 -> V2 -> Prop)
        (View_Predicate1 : V1 -> Prop)
        (consistency_predicate : V1 -> S -> Prop)
        (format1 format2 : FormatM S T )
        (decode1 : DecodeM (V1 * T) T)
        (view_format1 : FormatM V1 T)
      (*consistency_predicate_refl :
         forall a, consistency_predicate (proj' a) (proj a))
      (proj_predicate_OK :
         forall s, predicate (proj s)
                   -> proj_predicate (proj' s) *)
      (decode1_pf :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid Source_Predicate View_Predicate1 view1 format1 decode1 P view_format1)
      (*pred_pf : forall s, predicate s -> predicate' s *)
      (consistency_predicate_OK :
         forall s v1 t1 t2 env xenv xenv',
           computes_to (format1 s env) (t1, xenv)
           -> computes_to (view_format1 v1 env) (t2, xenv')
           -> view1 s v1
           -> consistency_predicate v1 s)

      (decode2 : V1 -> DecodeM (V2 * T) T)
      (view_format2 : V1 -> FormatM V2 T)
      (view_format3 : FormatM (V1 * V2) T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectDecoder monoid (fun s => Source_Predicate s
                                          /\ consistency_predicate v1 s)
                         (View_Predicate2 v1) (view2 v1) format2 (decode2 v1) P (view_format2 v1))
      (view_format3_OK : forall v1 t1 env1 xenv1 v2 t2 xenv2,
          view_format1 v1 env1 (t1, xenv1)
          -> view_format2 v1 v2 xenv1 (t2, xenv2)
          -> View_Predicate1 v1
          -> view_format3 (v1, v2) env1 (mappend t1 t2, xenv2))
    : CorrectDecoder
      monoid
      Source_Predicate
      (fun v1v2 => View_Predicate1 (fst v1v2) /\ View_Predicate2 (fst v1v2) (snd v1v2))
      (fun s v1v2 => view1 s (fst v1v2) /\ view2 (fst v1v2) s (snd v1v2))
      (format1 ++ format2)
      (sequence_Decode' decode1 decode2) P
      view_format3.
Proof.
  unfold cache_inv_Property, sequence_Decode, sequence_Format, compose in *;
    split.
  { intros env env' xenv s t ext ? env_pm pred_pm com_pf.
    unfold compose, Bind2 in com_pf; computes_to_inv; destruct v;
      destruct v0.
    destruct (fun H => proj1 (decode1_pf (proj1 P_inv_pf)) _ _ _ _ _ (mappend t1 ext) env_OK env_pm H com_pf); eauto; destruct_ex; split_and; simpl in *; injections; eauto.
    unfold sequence_Decode', DecodeBindOpt2, BindOpt.
    setoid_rewrite <- mappend_assoc; rewrite H0.
    pose proof (proj2 (decode1_pf H3) _ _ _ _ _ _ env_pm env_OK H0);
      split_and; destruct_ex; split_and.
    destruct (fun H => proj1 (decode2_pf x H5 H9)
                             _ _ _ _ _ ext H4 H2 H com_pf').
    split; try eassumption.
    eauto.
    destruct_ex; split_and.
    simpl.
    rewrite H12; eexists _, _; simpl; intuition eauto.
    apply unfold_computes.
    rewrite unfold_computes in H1.
    eapply view_format3_OK; eauto.
  }
  { intros ? ? ? ? t; intros.
    unfold sequence_Decode', DecodeBindOpt2, BindOpt in H1.
    destruct (decode1 t env') as [ [ [? ?] ? ] | ] eqn : ? ;
      simpl in *; try discriminate.
    generalize Heqh; intros Heqh'.
    eapply (proj2 (decode1_pf (proj1 P_inv_pf))) in Heqh; eauto.
    split_and; destruct_ex; split_and.
    subst.
    destruct (decode2 v0 t0 c) as [ [ [? ?] ? ] | ] eqn : ? ;
      simpl in *; try discriminate; injections.
    eapply (proj2 (decode2_pf _ H5 H7)) in Heqh; eauto.
    destruct Heqh as [? ?]; destruct_ex; split_and; subst.
    setoid_rewrite mappend_assoc.
    split; eauto.
    eexists _, _; repeat split; eauto.
    apply unfold_computes.
    eapply view_format3_OK; try eassumption.
    apply unfold_computes; eassumption.
    apply unfold_computes; eassumption.
  }
Qed.

End SequenceFormat.

Notation "x ++ y" := (sequence_Format x y) : format_scope .


Require Import floyd.proofauto.

Import ListNotations.
Require sha.sha.
Require sha.SHA256.
Local Open Scope logic.

Require Import sha.spec_sha.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC_refined_fp.

Require Import sha.hmac_sha256.

Require Import HMAC_definitions.
Require Import HMAC_lemmas.

Lemma loopbodyLE: forall Espec
(A : ARGS)
(a : HMAC_Refined.Args)
(KV : val)
(text' : name _text)
(key' : name _key)
(digest' : name _digest)
(textlen' : name _text_len)
(keylen' : name _key_len)
(VALS : VALUES)
(isByteKey : Forall isbyteZ (key a))
(i : Z)
(Delta := func_tycontext f_hmac_sha256 Vprog Gtot)
(H : 0 <= i < 64),
@semax Espec  (initialized _i Delta)
  (PROP  ()
   LOCAL  (`(eq (Vint (Int.repr i))) (eval_id _i);
   `(eq (Vint (Int.repr 64))) (eval_expr (Econst_int (Int.repr 64) tint));
   `(eq (TEXT A)) (eval_id _text); `(eq (KEY A)) (eval_id _key);
   `(eq KV) (eval_var sha._K256 (tarray tuint 64));
   `(eq (TEXTLEN A)) (eval_id _text_len);
   `(eq (KEYLEN A)) (eval_id _key_len); `(eq (DIGEST A)) (eval_id _digest);
   `(eq (k_ipad VALS)) (eval_var _k_ipad (tarray tuchar 65));
   `(eq (k_opad VALS)) (eval_var _k_opad (tarray tuchar 65));
   `(eq (tk VALS)) (eval_var _tk (tarray tuchar 32));
   `(eq (tk2 VALS)) (eval_var _tk2 (tarray tuchar 32));
   `(eq (bufferIn VALS)) (eval_var _bufferIn (tarray tuchar 1024));
   `(eq (bufferOut VALS)) (eval_var _bufferOut (tarray tuchar 1024)))
   SEP
   (`(array_at tuchar Tsh
        (cVint
           (force_int
            oo ZnthV tuchar
                 (map Vint
                    (map Int.repr
                       (map Byte.unsigned
                          (map Byte.repr (HMAC_FUN.mkKey (key a)))))))) i 64
        (k_opad VALS));
   `(array_at tuchar Tsh
       (cVint
          (force_int
           oo ZnthV tuchar
                (map Vint
                   (map Int.repr
                      (map Byte.unsigned
                         (map Byte.repr (HMAC_FUN.mkKey (key a)))))))) i 64
       (k_ipad VALS));
   `(array_at tuchar Tsh
       (cVint
          (force_int
           oo ZnthV tuchar
                (map Vint
                   (map Int.repr
                      (map Byte.unsigned
                         (HMAC_FUN.mkArg
                            (map Byte.repr (HMAC_FUN.mkKey (key a))) Opad))))))
       0 i (k_opad VALS));
   `(array_at tuchar Tsh
       (cVint
          (force_int
           oo ZnthV tuchar
                (map Vint
                   (map Int.repr
                      (map Byte.unsigned
                         (HMAC_FUN.mkArg
                            (map Byte.repr (HMAC_FUN.mkKey (key a))) Ipad))))))
       0 i (k_ipad VALS))))
  (Ssequence
     (Sassign
        (Ederef
           (Ebinop Oadd (Evar _k_ipad (tarray tuchar 65)) (Etempvar _i tint)
              (tptr tuchar)) tuchar)
        (Ebinop Oxor
           (Ederef
              (Ebinop Oadd (Evar _k_ipad (tarray tuchar 65))
                 (Etempvar _i tint) (tptr tuchar)) tuchar)
           (Econst_int (Int.repr 54) tint) tint))
     (Sassign
        (Ederef
           (Ebinop Oadd (Evar _k_opad (tarray tuchar 65)) (Etempvar _i tint)
              (tptr tuchar)) tuchar)
        (Ebinop Oxor
           (Ederef
              (Ebinop Oadd (Evar _k_opad (tarray tuchar 65))
                 (Etempvar _i tint) (tptr tuchar)) tuchar)
           (Econst_int (Int.repr 92) tint) tint)))
  (normal_ret_assert
     (PROP  (0 <= i + 1 <= 64)
      LOCAL  (`(eq (Vint (Int.repr i))) (eval_id _i);
   `(eq (Vint (Int.repr 64))) (eval_expr (Econst_int (Int.repr 64) tint));
   `(eq (TEXT A)) (eval_id _text); `(eq (KEY A)) (eval_id _key);
   `(eq KV) (eval_var sha._K256 (tarray tuint 64));
   `(eq (TEXTLEN A)) (eval_id _text_len);
   `(eq (KEYLEN A)) (eval_id _key_len); `(eq (DIGEST A)) (eval_id _digest);
   `(eq (k_ipad VALS)) (eval_var _k_ipad (tarray tuchar 65));
   `(eq (k_opad VALS)) (eval_var _k_opad (tarray tuchar 65));
   `(eq (tk VALS)) (eval_var _tk (tarray tuchar 32));
   `(eq (tk2 VALS)) (eval_var _tk2 (tarray tuchar 32));
   `(eq (bufferIn VALS)) (eval_var _bufferIn (tarray tuchar 1024));
   `(eq (bufferOut VALS)) (eval_var _bufferOut (tarray tuchar 1024)))
      SEP
      (`(array_at tuchar Tsh
           (cVint
              (force_int
               oo ZnthV tuchar
                    (map Vint
                       (map Int.repr
                          (map Byte.unsigned
                             (map Byte.repr (HMAC_FUN.mkKey (key a))))))))
           (i + 1) 64 (k_opad VALS));
      `(array_at tuchar Tsh
          (cVint
             (force_int
              oo ZnthV tuchar
                   (map Vint
                      (map Int.repr
                         (map Byte.unsigned
                            (map Byte.repr (HMAC_FUN.mkKey (key a))))))))
          (i + 1) 64 (k_ipad VALS));
      `(array_at tuchar Tsh
          (cVint
             (force_int
              oo ZnthV tuchar
                   (map Vint
                      (map Int.repr
                         (map Byte.unsigned
                            (HMAC_FUN.mkArg
                               (map Byte.repr (HMAC_FUN.mkKey (key a))) Opad))))))
          0 (i + 1) (k_opad VALS));
      `(array_at tuchar Tsh
          (cVint
             (force_int
              oo ZnthV tuchar
                   (map Vint
                      (map Int.repr
                         (map Byte.unsigned
                            (HMAC_FUN.mkArg
                               (map Byte.repr (HMAC_FUN.mkKey (key a))) Ipad))))))
          0 (i + 1) (k_ipad VALS))))).
Proof. intros.
     remember (cVint
             (force_int
              oo ZnthV tuchar
                   (map Vint
                      (map Int.repr
                         (map Byte.unsigned
                            (map Byte.repr (HMAC_FUN.mkKey (key a)))))))) as KKEY.
     remember (cVint
            (force_int
             oo ZnthV tuchar
                  (map Vint
                     (map Int.repr
                        (map Byte.unsigned
                           (HMAC_FUN.mkArg
                              (map Byte.repr (HMAC_FUN.mkKey (key a))) Opad)))))) as OPAD.
     remember (cVint
            (force_int
             oo ZnthV tuchar
                  (map Vint
                     (map Int.repr
                        (map Byte.unsigned
                           (HMAC_FUN.mkArg
                              (map Byte.repr (HMAC_FUN.mkKey (key a))) Ipad)))))) as IPAD.
destruct (nth_mapVintZ i (map Byte.unsigned (map Byte.repr (HMAC_FUN.mkKey (key a))))) as [n Hn].
    rewrite Zlength_correct, map_length. rewrite map_length, HMAC_FUN.mkKey_length. simpl. assumption.
simple eapply semax_seq'.

eapply semax_pre0; [ apply now_later | ].
{ eapply semax_post_flipped'.
   eapply NEWsemax_loadstore_array.
     reflexivity. trivial. reflexivity. reflexivity. reflexivity.
     { entailer; repeat instantiate_Vptr.
       destruct (k_ipad VALS) eqn:?Hipad; try contradiction.
       rewrite <- Hipad in *.
       repeat apply andp_right; rel_expr.
       intro; simpl. rewrite <- H0. rewrite Hipad. reflexivity.
       simpl typeof. simpl.
         instantiate (2:=Tsh). repeat rewrite sepcon_assoc. rewrite sepcon_comm.
         erewrite (split3_array_at' i tuchar Tsh _ i _ (k_ipad VALS)).
         rewrite array_at_emp. normalize. rewrite (sepcon_comm TT). repeat rewrite sepcon_assoc.
         apply sepcon_derives. rewrite Hipad. unfold add_ptr_int. simpl. rewrite mul_repr, Z.mul_1_l. cancel.
         entailer.
         reflexivity.
         reflexivity.
         reflexivity.
         reflexivity.
         omega.
         discriminate.
         intros; simpl.
           unfold ZnthV, cVint. simpl. if_tac. omega.
           rewrite Hn. simpl. reflexivity.
         reflexivity.
     }
     instantiate (5:=1%nat). reflexivity.
     trivial.
     trivial.
     split; omega.

   eapply derives_refl.
}

  normalize.

   assert (Keyisbyte: Forall isbyteZ (HMAC_FUN.mkKey (key a))).
     unfold HMAC_FUN.mkKey.
     destruct (Zlength (key a) >? Z.of_nat SHA256_BlockSize);
       apply zeropad_isbyteZ; trivial.
     apply isbyte_sha.
eapply semax_pre0; [ apply now_later | ].
{ eapply semax_post_flipped'.
   eapply NEWsemax_loadstore_array.
     reflexivity. trivial. reflexivity. reflexivity. reflexivity.
     { entailer; repeat instantiate_Vptr.
       destruct (k_opad VALS) eqn:?Hopad; try contradiction.
       rewrite <- Hopad in *.
       repeat apply andp_right; rel_expr.
       intro; simpl. rewrite <- H0. rewrite Hopad. reflexivity.
       simpl typeof. simpl.
         instantiate (2:=Tsh). repeat rewrite sepcon_assoc. rewrite sepcon_comm.
         erewrite (split3_array_at' i tuchar Tsh _ i _ (k_opad VALS)); try reflexivity.
         rewrite array_at_emp. normalize.
         rewrite <- (sepcon_comm (array_at tuchar Tsh
  (cVint
     (force_int
      oo ZnthV tuchar
           (map Vint
              (map Int.repr
                 (map Byte.unsigned (map Byte.repr (HMAC_FUN.mkKey (key a))))))))
  (Z.succ i) 64 (k_opad VALS))).
         repeat rewrite <- sepcon_assoc. apply sepcon_derives. entailer.
         rewrite Hopad. unfold add_ptr_int. simpl. rewrite mul_repr, Z.mul_1_l. cancel.
         omega.
         discriminate.
         intros; simpl.
           unfold ZnthV, cVint. simpl. if_tac. omega.
           rewrite Hn. simpl. reflexivity.
         reflexivity.
     }
     instantiate (5:=0%nat). reflexivity.
     trivial.
     trivial.
     split; omega.

   entailer. rewrite (split_array_at (i+1) tuchar Tsh _ i 64); try omega.
   rewrite (split_array_at (i+1) tuchar Tsh _ i 64); try omega.
   rewrite (split_array_at i tuchar Tsh _ 0 (i+1)); try omega.
   rewrite (split_array_at i tuchar Tsh _ 0 (i+1)); try omega.
   cancel.
   assert (ARITH1: forall PAD BPAD
     (HPAD: PAD = Byte.intval BPAD) k, i <= k < i+1 ->
     (upd
     (cVint
        (force_int
         oo ZnthV tuchar
              (map Vint
                 (map Int.repr
                    (map Byte.unsigned
                       (map Byte.repr (HMAC_FUN.mkKey (key a)))))))) i
     (Vint (Int.zero_ext 8 (Int.xor n (Int.repr PAD))))) k
     = (cVint
         (force_int
          oo ZnthV tuchar
               (map Vint
                  (map Int.repr
                     (map Byte.unsigned
                        (HMAC_FUN.mkArg
                           (map Byte.repr (HMAC_FUN.mkKey (key a))) BPAD)))))) k).
   { intros. unfold cVint, ZnthV, upd. if_tac. subst; simpl. 2: omega.
     if_tac. omega. simpl. f_equal.

    rewrite map_unsigned_Brepr_isbyte in Hn; trivial.
    rewrite (nth_indep _ _ (Vint Int.zero)) in Hn.
     erewrite mapnth' in Hn; try reflexivity.
     inversion Hn; clear Hn.
    rewrite H17.
    eapply nthD_1 in H17. instantiate (1:=Z0) in H17.
    destruct H17 as [z [KeyZ [NZ NN]]].
    rewrite Forall_forall in Keyisbyte. apply Keyisbyte in KeyZ.
     unfold HMAC_FUN.mkArg.
     rewrite (nth_indep _ _ (Vint Int.zero)).
     erewrite mapnth'. unfold force_int. 2: reflexivity.
     erewrite mapnth'. simpl.
     Focus 2. instantiate (1:=Z0). reflexivity.
     erewrite mapnth'.
     Focus 2. instantiate (1:=Byte.zero). reflexivity.
     erewrite mapnth'. simpl.
     Focus 2. instantiate (1:=(Byte.zero, Byte.zero)). reflexivity.
     rewrite combine_nth.
     unfold sixtyfour. rewrite nth_Nlist. simpl. unfold Opad.
     erewrite mapnth'.
     Focus 2. instantiate (1:=0). reflexivity.
     rewrite NZ. clear NZ. subst n.
     apply Int.same_bits_eq. clear - KeyZ. intros.
        unfold Int.zero_ext. (*, Int.Zzero_ext. simpl.*)
     rewrite Int.testbit_repr; trivial.
     rewrite Int.testbit_repr; trivial.
     rewrite Int.Zzero_ext_spec; try omega.

     rewrite sha_lemmas.Ztest_Inttest, Int.bits_xor; trivial.
     rewrite Ztest_Bytetest.
     if_tac.
        assert (iB: 0 <= i < Byte.zwordsize).
          unfold Byte.zwordsize; simpl; omega.
        rewrite Byte.bits_xor; trivial.
        repeat rewrite Int.testbit_repr; trivial.
        repeat rewrite Byte.testbit_repr; trivial.
     rewrite Byte.bits_above. trivial. apply H0.

    destruct H as [_ H]. apply Z2Nat.inj_lt in H; try omega. apply H.
    rewrite map_length. unfold sixtyfour. rewrite HMAC_FUN.mkKey_length, length_Nlist. reflexivity.
    repeat rewrite map_length. rewrite combine_length. rewrite map_length.
      unfold sixtyfour. rewrite HMAC_FUN.mkKey_length, length_Nlist. simpl.
      destruct H as [_ H]. apply Z2Nat.inj_lt in H; try omega. apply H.
    rewrite HMAC_FUN.mkKey_length. simpl.
      destruct H as [_ H]. apply Z2Nat.inj_lt in H; try omega. apply H.
    repeat rewrite map_length. rewrite HMAC_FUN.mkKey_length. simpl.
      destruct H as [_ H]. apply Z2Nat.inj_lt in H; try omega. apply H.
  }

  assert (Arth92 := ARITH1 54 Ipad (eq_refl _)).
  assert (Arth54 := ARITH1 92 Opad (eq_refl _)). clear ARITH1.
  erewrite (array_at_ext tuchar Tsh _ _ i (i+1) Arth92).
  erewrite (array_at_ext tuchar Tsh _ _ i (i+1) Arth54).
  clear Arth54 Arth92; cancel.

  assert (ARITH1: forall PAD k, i + 1 <= k < 64 ->
    upd (cVint
     (force_int
      oo ZnthV tuchar
           (map Vint
              (map Int.repr
                 (map Byte.unsigned (map Byte.repr (HMAC_FUN.mkKey (key a))))))))
     i (Vint (Int.zero_ext 8 (Int.xor n (Int.repr PAD)))) k
   = cVint (force_int
      oo ZnthV tuchar
        (map Vint
           (map Int.repr
              (map Byte.unsigned (map Byte.repr (HMAC_FUN.mkKey (key a)))))))
    k).
   { clear. intros. unfold upd. if_tac. subst. omega. trivial. }

  rewrite (array_at_ext tuchar Tsh _ _ (i+1) 64 (ARITH1 92)).
  rewrite (array_at_ext tuchar Tsh _ _ (i+1) 64 (ARITH1 54)). cancel.
 }
Qed.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* 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.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                     SF-Calculus                                    *)
(*                  as Wave Calculus                                  *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

(** The operators S and F are enough, but more may be added in future. *)

Inductive operator := | Node .

(** The terms of SF-calculus are either variables (given as de Bruijn indices), operators or applications.
Terms are called combinations if they do not use any variables. *)

Inductive SF:  Set :=
  | Ref : nat -> SF
  | Op  : operator -> SF
  | App : SF -> SF -> SF
.


Require Import Program.
From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Require Import SimMemory.
Require Import Simulation.

Set Implicit Arguments.

Lemma sim_adequacy
      ths_src sc_src mem_src
      ths_tgt sc_tgt mem_tgt
      (WF_SRC: Configuration.wf (Configuration.mk ths_src sc_src mem_src))
      (WF_TGT: Configuration.wf (Configuration.mk ths_tgt sc_tgt mem_tgt))
      (CONSISTENT_SRC: Configuration.consistent (Configuration.mk ths_src sc_src mem_src))
      (CONSISTENT_TGT: Configuration.consistent (Configuration.mk ths_tgt sc_tgt mem_tgt))
      (SC: TimeMap.le sc_src sc_tgt)
      (MEMORY: sim_memory mem_src mem_tgt)
      (SIM: sim ths_src sc_src mem_src ths_tgt sc_tgt mem_tgt):
  behaviors Configuration.step (Configuration.mk ths_tgt sc_tgt mem_tgt) <1=
  behaviors Configuration.step (Configuration.mk ths_src sc_src mem_src).
Proof.
  s. i.
  revert WF_SRC WF_TGT CONSISTENT_SRC CONSISTENT_TGT SC MEMORY SIM.
  revert ths_src sc_src mem_src.
  dependent induction PR; i.
  - punfold SIM. exploit SIM; eauto; try refl. i. des.
    exploit TERMINAL0; eauto. i. des.
    eapply rtc_tau_step_behavior; eauto.
    econs 1. auto.
  - destruct c2.
    punfold SIM. exploit SIM; eauto; try refl. i. des.
    exploit STEP0; eauto. i. des. inv SIM0; [|done].
    eapply rtc_tau_step_behavior; eauto.
    exploit Configuration.step_future; try apply STEP; eauto. i. des.
    exploit Configuration.rtc_step_future; eauto. i. des.
    inv STEP_SRC. econs 2; eauto.
    exploit Configuration.step_future; try apply STEP1; eauto. i. des.
    eapply IHPR; eauto.
  - destruct c2.
    punfold SIM. exploit SIM; eauto; try refl. i. des.
    exploit STEP0; eauto. i. des. inv SIM0; [|done].
    eapply rtc_tau_step_behavior; eauto.
    exploit Configuration.step_future; try apply STEP; eauto. i. des.
    exploit Configuration.rtc_step_future; eauto. i. des.
    inv STEP_SRC.
    + eapply IHPR; eauto.
    + econs 3; eauto.
      exploit Configuration.step_future; try apply STEP1; eauto. s. i. des.
      eapply IHPR; eauto.
Qed.


(** * Mapping predicates over [StringLike] things *)
Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Basics.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Common.SetoidInstances.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section for_first_char.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition for_first_char (str : String) (P : Char -> Prop)
    := forall ch,
         take 1 str ~= [ ch ]
         -> P ch.

  Global Instance for_first_char_Proper
  : Proper (beq ==> pointwise_relation _ impl ==> impl) for_first_char.
  Proof.
    unfold pointwise_relation, respectful, for_first_char, impl.
    intros ?? H' ?? H'' H''' ? H.
    rewrite <- H' in H.
    eauto using is_char_Proper.
  Qed.

  Global Instance for_first_char_Proper_flip
  : Proper (beq ==> pointwise_relation _ (flip impl) ==> flip impl) for_first_char.
  Proof.
    unfold pointwise_relation, respectful, for_first_char, flip, impl.
    intros ?? H' ?? H'' H''' ? H.
    rewrite H' in H.
    eauto using is_char_Proper.
  Qed.

  Global Instance for_first_char_Proper_iff
  : Proper (beq ==> pointwise_relation _ iff ==> iff) for_first_char.
  Proof.
    unfold pointwise_relation, respectful.
    repeat intro; split;
    apply for_first_char_Proper; try assumption; repeat intro;
    match goal with
      | [ H : _ |- _ ] => apply H; assumption
    end.
  Qed.

  Lemma for_first_char_nil (str : String) P
  : length str = 0 -> for_first_char str P.
  Proof.
    intros H ch H'.
    apply length_singleton in H'.
    rewrite ?take_length, ?drop_length, H in H'.
    simpl in H'; omega.
  Qed.

  Lemma helper
        (P : nat -> nat -> Type)
        n
        (H0 : forall n0, P (min 1 (n - n0)) n0)
        (H1 : forall n0, P 1 (n0 + n))
        {n0}
  : P 1 n0.
  Proof.
    destruct (Compare_dec.le_dec n n0) as [H'|H'].
    { specialize (H1 (n0 - n)).
      rewrite Nat.sub_add in H1 by assumption; assumption. }
    { apply Compare_dec.not_le in H'.
      specialize (H0 n0).
      destruct (n - n0) as [|[|]] eqn:?; simpl in *; trivial; omega. }
  Defined.

  Lemma for_first_char__take n (str : String) P
  : for_first_char str P
    <-> for_first_char (take (S n) str) P.
  Proof.
    unfold for_first_char; repeat (split || intro);
    repeat match goal with
                         | [ H : _ |- _ ] => setoid_rewrite drop_length in H
                         | [ H : _ |- _ ] => setoid_rewrite take_length in H
                         | [ H : _ |- _ ] => setoid_rewrite drop_take in H
                         | [ H : _ |- _ ] => setoid_rewrite take_take in H
                         | [ H : _ |- _ ] => setoid_rewrite drop_drop in H
                         | [ H : _ /\ _ |- _ ] => destruct H
                         | [ H : context[min 1 ?x] |- _ ] => destruct x eqn:?; simpl in H
                         | [ H : is_true (take 0 _ ~= [ _ ]) |- _ ] => exfalso; apply length_singleton in H
                         | _ => omega
                         | _ => progress simpl in *; omega
                         | _ => solve [ eauto ]
                         | _ => solve [ eapply (@helper (fun a b => take a (drop b str) ~= [ ch ] -> P ch)); eauto ]
                       end.
  Qed.

  Lemma for_first_char_singleton (str : String) P ch
  : str ~= [ ch ] -> (P ch <-> for_first_char str P).
  Proof.
    intro H.
    pose proof (length_singleton _ _ H).
    unfold for_first_char.
    split; intro H'; repeat intro.
    { repeat match goal with
               | _ => intro
               | _ => omega
               | [ H : _ |- _ ] => rewrite drop_0 in H
               | [ H : _, H' : _ |- _ ] => rewrite (singleton_take H') in H
               | [ H : _ |- False ] => apply length_singleton in H
               | [ H : _ |- _ ] => rewrite take_length in H
               | [ H : _ |- _ ] => rewrite drop_length in H
               | [ H : ?x = 1, H' : context[?x] |- _ ] => rewrite H in H'
               | _ => erewrite singleton_unique; eassumption
               | [ H : appcontext[min] |- _ ] => revert H; apply Min.min_case_strong
             end. }
    { match goal with
        | [ H : _ |- _ ] => apply H
      end.
      rewrite take_long; trivial; omega. }
  Qed.

  Lemma for_first_char_singleton_length (str : String) P (H : length str = 1)
  : for_first_char str P <-> (forall ch, str ~= [ ch ] -> P ch).
  Proof.
    split.
    { intro H''.
      intros ch' H'''.
      apply (for_first_char_singleton _ _ _ H'''); assumption. }
    { destruct (singleton_exists _ H) as [ch H'].
      intro H''.
      apply (for_first_char_singleton _ P ch H'); eauto. }
  Qed.

  Global Opaque for_first_char.

  Lemma for_first_char_exists (str : String) P (H : length str >= 1)
  : for_first_char str P <-> (exists ch, take 1 str ~= [ ch ] /\ P ch).
  Proof.
    rewrite (for_first_char__take 0).
    assert (H' : length (take 1 str) = 1)
      by (rewrite take_length; apply Min.min_case_strong; omega).
    destruct (singleton_exists _ H') as [ch H''].
    rewrite for_first_char_singleton_length by exact H'.
    split; intros.
    { exists ch; split; eauto. }
    { destruct_head ex.
      destruct_head and.
      repeat match goal with
               | [ H : is_true (?str ~= [ ?ch ])%string_like, H' : is_true (?str ~= [ ?ch' ])%string_like |- _ ]
                 => assert (ch = ch') by (eapply singleton_unique; eassumption);
                   clear H'
             end.
      subst; assumption. }
  Qed.

  Lemma for_first_char_False (str : String) P
  : (forall ch, ~P ch) -> for_first_char str P -> length str = 0.
  Proof.
    intros H' H.
    case_eq (length str); trivial.
    pose proof (singleton_exists (take 1 str)) as H''.
    rewrite take_length in H''.
    intros n H'''.
    rewrite H''' in *.
    specialize (H'' eq_refl).
    destruct H'' as [ch H''].
    apply (for_first_char__take 0) in H.
    apply (for_first_char_singleton _ _ _ H'') in H.
    specialize (H' ch).
    exfalso; eauto.
  Qed.

  Lemma for_first_char_combine (str : String) (P P' : Char -> Prop) (T : Prop) (H : forall ch, P ch -> P' ch -> T)
        (H0 : for_first_char str P)
        (H1 : for_first_char str P')
  : length str = 0 \/ T.
  Proof.
    case_eq (length str).
    { left; reflexivity. }
    { intros n H'; right.
      pose proof (singleton_exists (take 1 str)) as H''.
      rewrite take_length, H' in H''.
      specialize (H'' eq_refl).
      destruct H'' as [ch H''].
      specialize (H ch).
      apply (for_first_char__take 0) in H0.
      apply (for_first_char__take 0) in H1.
      apply (for_first_char_singleton _ _ _ H'') in H0.
      apply (for_first_char_singleton _ _ _ H'') in H1.
      eauto. }
  Qed.

  Definition first_char_in (str : String) (ls : list Char)
    := for_first_char str (fun ch => List.In ch ls).

  Definition for_first_char__impl__first_char_in {str ls} {P : _ -> Prop}
             (H : forall ch, P ch -> List.In ch ls)
  : impl (for_first_char str P) (first_char_in str ls).
  Proof.
    unfold first_char_in.
    apply for_first_char_Proper; trivial; reflexivity.
  Qed.

  Definition first_char_in__impl__for_first_char {str ls} {P : _ -> Prop}
             (H : forall ch, List.In ch ls -> P ch)
  : impl (first_char_in str ls) (for_first_char str P).
  Proof.
    unfold first_char_in.
    apply for_first_char_Proper; trivial; reflexivity.
  Qed.

  Global Instance first_char_in__Proper
  : Proper (beq ==> eq ==> impl) first_char_in.
  Proof.
    unfold pointwise_relation, respectful, first_char_in, impl.
    repeat intro; subst.
    match goal with
      | [ H : _ |- _ ] => rewrite <- H; assumption
    end.
  Qed.

  Global Instance first_char_in__Proper_iff
  : Proper (beq ==> eq ==> iff) first_char_in.
  Proof.
    unfold pointwise_relation, respectful, first_char_in, impl.
    repeat intro; subst.
    match goal with
      | [ H : _ |- _ ] => rewrite <- H; reflexivity
    end.
  Qed.

  Lemma first_char_in__take n (str : String) ls
  : first_char_in str ls
    <-> first_char_in (take (S n) str) ls.
  Proof.
    unfold first_char_in; apply for_first_char__take.
  Qed.

  Lemma first_char_in_nil (str : String)
  : first_char_in str nil <-> length str = 0.
  Proof.
    unfold first_char_in.
    split.
    { eapply for_first_char_False; simpl; eauto. }
    { apply for_first_char_nil. }
  Qed.

  Lemma first_char_in_empty (str : String) (H : length str = 0) ls
  : first_char_in str ls.
  Proof.
    unfold first_char_in.
    apply for_first_char_nil; assumption.
  Qed.

  Lemma first_char_in_singleton_str (str : String) ls ch (H : str ~= [ ch ])
  : first_char_in str ls <-> List.In ch ls.
  Proof.
    unfold first_char_in.
    rewrite <- for_first_char_singleton; try eassumption; reflexivity.
  Qed.

  Lemma first_char_in__app_or_iff (str : String) (ls1 ls2 : list Char)
  : first_char_in str (ls1 ++ ls2)
    <-> (first_char_in str ls1 \/ first_char_in str ls2).
  Proof.
    unfold first_char_in.
    setoid_rewrite List.in_app_iff.
    rewrite !(for_first_char__take 0 str).
    generalize (singleton_exists (take 1 str)).
    rewrite take_length.
    case_eq (length str).
    { intros H _.
      split; intro H0;
      [ left; apply first_char_in_empty
      | apply for_first_char_nil ];
      rewrite take_length, H; reflexivity. }
    { intros ? ? H.
      specialize (H eq_refl).
      destruct H as [ch H].
      rewrite <- !for_first_char_singleton by eassumption; tauto. }
  Qed.

  Lemma first_char_in__or_app (str : String) (ls1 ls2 : list Char)
  : first_char_in str ls1 \/ first_char_in str ls2 -> first_char_in str (ls1 ++ ls2).
  Proof.
    unfold first_char_in.
    intros [?|?]; repeat intro;
    (eapply for_first_char_Proper; [ .. | eassumption ]; [ reflexivity | ]; intros ??);
    apply List.in_or_app; eauto.
  Qed.

  Global Opaque first_char_in.

  Definition first_char_in__iff__for_first_char' {str ls} {P : _ -> Prop}
             (H : forall ch, P ch <-> List.In ch ls)
  : first_char_in str ls <-> for_first_char str P.
  Proof.
    split_iff.
    split; first [ apply for_first_char__impl__first_char_in | apply first_char_in__impl__for_first_char ];
    assumption.
  Qed.

  Definition first_char_in__iff__for_first_char {str ls}
  : first_char_in str ls <-> for_first_char str (fun ch => List.In ch ls).
  Proof.
    apply first_char_in__iff__for_first_char'; reflexivity.
  Qed.

  Lemma first_char_in_exists (str : String) ls (H : length str >= 1)
  : first_char_in str ls <-> (exists ch, take 1 str ~= [ ch ] /\ List.In ch ls).
  Proof.
    erewrite first_char_in__iff__for_first_char, for_first_char_exists by assumption.
    reflexivity.
  Qed.

  Lemma forall_chars__impl__for_first_char (str : String) P (H : forall_chars str P)
  : for_first_char str P.
  Proof.
    case_eq (length str).
    { apply for_first_char_nil. }
    { intros n H'.
      eapply forall_chars_take in H.
      apply (for_first_char__take 0).
      apply for_first_char_singleton_length.
      { rewrite take_length, H'; reflexivity. }
      { apply forall_chars_singleton_length.
        { rewrite take_length, H'; reflexivity. }
        { eassumption. } } }
  Qed.

  Lemma for_first_char__for_first_char__iff_short (str : String) P (H : length str <= 1)
  : forall_chars str P <-> for_first_char str P.
  Proof.
    case_eq (length str).
    { intro H'.
      split; intro.
      { apply for_first_char_nil; assumption. }
      { apply forall_chars_nil; assumption. } }
    { intros [|] H'; [ | exfalso; omega ].
      rewrite forall_chars_singleton_length by assumption.
      rewrite for_first_char_singleton_length by assumption.
      reflexivity. }
  Qed.

End for_first_char.


(** Libraries. *)
Require Import String.
Require Import CoqlibC Errors ErrorsC.
Require Import AST Linking Smallstep.
(** Command-line flags. *)
Require Import Compopts.
(** newly added **)
Require Import BehaviorsC.
Require Export Compiler.
Require Import Simulation.
Require Import Sem SimProg Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem Sound SimSymb.
Require Import SemProps AdequacyLocal.

Require SimMemInjInvC.

Require Import RUSC.

Require Import MutrecHeader.
Require Import MutrecAspec MutrecBspec MutrecABspec MutrecA MutrecB.
Require Import MutrecABproof MutrecAproof MutrecBproof.

Require IdSimAsmIdInv.
Require IdSimClightIdInv.

Definition mutrec_relations :=
  fun r => exists P, r = mkPR (SimMemInjInvC.SimMemInjInv SimMemInjInv.top_inv P)
                              (SimMemInjInvC.SimSymbIdInv P)
                              SoundTop.Top.

Lemma asm_self_related (asm: Asm.program)
  :
    self_related mutrec_relations [(AsmC.module asm)].
Proof.
  intros r RELIN. unfold mutrec_relations in *. ss.
  des; clarify; eapply relate_single_program; intros WF.
  exploit IdSimAsmIdInv.asm_inj_inv_id; ss; eauto.
Qed.

Lemma clight_self_related (cls: Clight.program)
  :
    self_related mutrec_relations [(ClightC.module2 cls)].
Proof.
  intros r RELIN. unfold mutrec_relations in *. ss.
  des; clarify; eapply relate_single_program; intros WF.
  exploit IdSimClightIdInv.clight_inj_inv_id; ss; eauto.
Qed.

Lemma asms_self_related (asms: list Asm.program)
  :
    self_related mutrec_relations (map AsmC.module asms).
Proof.
  induction asms; ss; ii.
  exploit IHasms; ss; eauto. i.
  eapply (@program_relation.horizontal _ [(AsmC.module a)] _ [(AsmC.module a)]); eauto.
  eapply asm_self_related; eauto.
Qed.

Lemma clights_self_related (cls: list Clight.program)
  :
    self_related mutrec_relations (map ClightC.module2 cls).
Proof.
  induction cls; ss; ii.
  exploit IHcls; ss; eauto. i.
  eapply (@program_relation.horizontal _ [(ClightC.module2 a)] _ [(ClightC.module2 a)]); eauto.
  eapply clight_self_related; eauto.
Qed.

Require IdSimMutrecAIdInv.

Lemma specA_self_related
  :
    self_related mutrec_relations [MutrecAspec.module].
Proof.
  intros r RELIN. unfold mutrec_relations in *. ss.
  des; clarify; eapply relate_single_program; intros WF.
  exploit IdSimMutrecAIdInv.a_inj_inv_id; ss; eauto.
Qed.

Require IdSimMutrecBIdInv.

Lemma specB_self_related
  :
    self_related mutrec_relations [MutrecBspec.module].
Proof.
  intros r RELIN. unfold mutrec_relations in *. ss.
  des; clarify; eapply relate_single_program; intros WF.
  exploit IdSimMutrecBIdInv.b_inj_inv_id; ss; eauto.
Qed.

Lemma MutrecA_rusc
  :
    rusc mutrec_relations [MutrecAspec.module] [(ClightC.module2 MutrecA.prog)].
Proof.
  eapply (@relate_single_rusc
            _
            (SimMemInjInvC.SimMemInjInv SimMemInjInv.top_inv MutrecAproof.memoized_inv)
            (SimMemInjInvC.SimSymbIdInv MutrecAproof.memoized_inv)
            SoundTop.Top).
  - set MutrecAproof.sim_mod. unfold relate_single. i. esplits; ss; eauto.
  - unfold mutrec_relations. eauto.
Qed.

Lemma MutrecB_rusc
  :
    rusc mutrec_relations [MutrecBspec.module] [(AsmC.module MutrecB.prog)].
Proof.
  eapply (@relate_single_rusc
            _
            (SimMemInjInvC.SimMemInjInv SimMemInjInv.top_inv MutrecBproof.memoized_inv)
            (SimMemInjInvC.SimSymbIdInv MutrecBproof.memoized_inv)
            SoundTop.Top).
  - set MutrecBproof.sim_mod. unfold relate_single. i. esplits; ss; eauto.
  - unfold mutrec_relations. eauto.
Qed.

Theorem MutrecAB_AB_rusc
  :
    rusc bot1 [(MutrecABspec.module)] [(MutrecAspec.module) ; (MutrecBspec.module)]
.
Proof.
  unfold rusc. i. eapply mutrecABcorrect.
Qed.

Lemma MutrecAB_impl_rusc
 :
   rusc mutrec_relations
        [MutrecABspec.module]
        [(ClightC.module2 MutrecA.prog); (AsmC.module MutrecB.prog)].
Proof.
 etrans.
 - eapply rusc_mon; [|eapply MutrecAB_AB_rusc]; ss.
 - hexploit rusc_horizontal.
   + eapply MutrecA_rusc.
   + eapply MutrecB_rusc.
   + eapply specA_self_related.
   + eapply specB_self_related.
   + eapply clight_self_related.
   + eapply asm_self_related.
   + i. eauto.
Qed.

Theorem Mutrec_correct
        (srcs: list Clight.program)
        (hands: list Asm.program)
  :
    improves (sem ((map ClightC.module2 srcs) ++ (map AsmC.module hands) ++ [MutrecABspec.module]))
             (sem ((map ClightC.module2 srcs) ++ (map AsmC.module hands) ++ [(ClightC.module2 MutrecA.prog); (AsmC.module MutrecB.prog)])).
Proof.
  replace (map ClightC.module2 srcs ++ map AsmC.module hands ++ [MutrecABspec.module]) with
      ((map ClightC.module2 srcs ++ map AsmC.module hands) ++ [MutrecABspec.module]); cycle 1.
  { rewrite app_assoc. auto. }
  replace (map ClightC.module2 srcs ++ map AsmC.module hands
               ++ [ClightC.module2 MutrecA.prog; AsmC.module prog]) with
      ((map ClightC.module2 srcs ++ map AsmC.module hands) ++ [ClightC.module2 MutrecA.prog; AsmC.module prog]); cycle 1.
  { rewrite app_assoc. auto. }
  eapply rusc_adequacy_left_ctx.
  - eapply MutrecAB_impl_rusc.
  - eapply self_related_horizontal.
    + eapply clights_self_related.
    + eapply asms_self_related.
Qed.


From ch2o_compcert Require Export ch2o_lp64 ifs_ch2o.
From ch2o Require Import stringmap frontend_sound.

Local Open Scope string_scope.

Definition alloc_program_result: frontend_state K.
Proof.
set (a:=alloc_program (K:=K) decls ∅).
assert (match a with inl _ => False | inr _ => True end). { exact I. }
destruct a. { elim H. }
destruct p.
exact f.
Defined.

Definition Γ: env K := to_env alloc_program_result.
Definition δ: funenv K := to_funenv alloc_program_result.
Definition m0: mem K := to_mem alloc_program_result.
Definition S0 := initial_state m0 "main" [].

Goal env_t Γ = ∅.
Proof.
reflexivity.
Qed.

Goal stringmap_to_list (env_f Γ) = [("main", ([], sintT%T))].
reflexivity.
Qed.

(*

Compute stringmap_to_list δ.

*)

Goal stringmap_to_list δ = [
  ("main",
   if{# intV{sintT} 1} skip else skip ;;
   if{# intV{sintT} 0} skip else skip ;;
   ret
     (cast{sintT%T} (
        # intV{sintT} 17 / # intV{sintT} 2 /
        (# intV{sintT} 15 / # intV{sintT} 5))))
].
Proof.
reflexivity.
Qed.

Lemma δ_main: δ !! ("main": funname) = Some (
   if{# intV{sintT} 1} skip else skip ;;
   if{# intV{sintT} 0} skip else skip ;;
   ret
     (cast{sintT%T} (
        # intV{sintT} 17 / # intV{sintT} 2 /
        (# intV{sintT} 15 / # intV{sintT} 5))) : stmt K).
Proof.
reflexivity.
Qed.

Goal m0 = ∅.
Proof.
reflexivity.
Qed.

Goal S0 = State [] (Call "main" []) m0.
Proof.
reflexivity.
Qed.

Lemma alloc_program_eq: alloc_program decls empty = mret () alloc_program_result.
Proof.
reflexivity.
Qed.

Lemma Γ_valid: ✓ Γ.
Proof.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma δ_valid: ✓{Γ,'{m0}} δ.
Proof.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma m0_valid: ✓{Γ} m0.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.