Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
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.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Import SolidityNotations. *)
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
(*Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

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 depoolContract.Lib.CommonStateProofs.

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

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.

(* Require Import MultiSigWallet.Specifications._validatelimit_inlineSpec.
Module _validatelimit_inlineSpec := _validatelimit_inlineSpec MultiSigWalletSpecSig.
Import _validatelimit_inlineSpec. *)

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.

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

(* Opaque tvm_accept DePoolContract_Ф_checkPureDePoolBalance RoundsBase_Ф_getRound1. *)

Lemma ifSimpleState: forall X (b: bool) (f g: Ledger -> X * Ledger),
(if b then SimpleState f else SimpleState g ) =
SimpleState (if b then f else  g).
Proof.
  intros. destruct b; auto.
Qed.

Lemma ifFunApply: forall X (b: bool) (f g: Ledger -> X * Ledger) l,
(if b then f else  g ) l =
(if b then f l else g l).
Proof.
  intros. destruct b; auto.
Qed.

Lemma fstImplies : forall  X Y T (f: X*T) (g: X -> Y)  ,  (let (x, _) := f in g x) = g (fst f).
Proof.
  intros.
  destruct f; auto.
Qed.

Lemma sndImplies : forall  X Y T (f: X*T) (g: T -> Y)  ,  (let (_, t) := f in g t) = g (snd f).
Proof.
  intros.
  destruct f; auto.
Qed.

Lemma fstsndImplies : forall  X Y T (f: X*T) (g: X -> T -> Y)  ,  (let (x, t) := f in g x t) = g (fst f) (snd f).
Proof.
  intros.
  destruct f; auto.
Qed.

Ltac pr_numgoals := let n := numgoals in idtac "There are" n "goals".

(* function acceptRewardAndStartRoundCompleting(Round round2, uint64 value) private returns (Round) {
        uint64 effectiveStake = round2.stake - round2.unused;
        uint64 reward = value - effectiveStake;
        reward = cutDePoolReward(reward, round2);
        round2.rewards = math.muldiv(reward, m_participantRewardFraction, 100);
        round2.rewards -= math.min(round2.rewards, round2.participantQty * RET_OR_REINV_FEE);
        uint64 validatorReward = math.muldiv(reward, m_validatorRewardFraction, 100);
        if (validatorReward != 0)
            m_validatorWallet.transfer(validatorReward, false, 1);
        uint64 associationReward = math.muldiv(reward, m_associationRewardFraction, 100);
        if (associationReward != 0)
            m_association.transfer(associationReward, false, 1);
        round2 = startRoundCompleting(round2, CompletionReason.RewardIsReceived);
        return round2; }*)

Opaque DePoolContract_Ф_cutDePoolReward  DePoolContract_Ф_startRoundCompleting.

Opaque intMin.

Lemma DePoolContract_Ф_acceptRewardAndStartRoundCompleting_eval : forall ( Л_round2 : RoundsBase_ι_Round )
                                                                          ( Л_value : XInteger64 )
                                                                          (l: Ledger) ,
eval_state ( DePoolContract_Ф_acceptRewardAndStartRoundCompleting Л_round2 Л_value ) l =

let round2 := Л_round2 in
let effectiveStake := ( round2 ->> RoundsBase_ι_Round_ι_stake ) - ( round2 ->> RoundsBase_ι_Round_ι_unused ) in
let reward := Л_value - effectiveStake in
let round2 := {$ round2 with RoundsBase_ι_Round_ι_grossReward := reward $} in
let (reward, l_cutDePoolReward) := run ( ↓ ( DePoolContract_Ф_cutDePoolReward reward round2 ) ) l in
let newReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_participantRewardFraction ) l_cutDePoolReward ) / 100 in
let newReward' := newReward - (intMin newReward ((round2 ->> RoundsBase_ι_Round_ι_participantQty)*
                                                (eval_state ( ↑12 ε DePoolContract_ι_RET_OR_REINV_FEE ) l_cutDePoolReward )) ) in
let round2' := {$ round2 with RoundsBase_ι_Round_ι_rewards := newReward' $} in

let validatorReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_validatorRewardFraction ) l_cutDePoolReward ) / 100 in
let if1 : bool := ( negb ( validatorReward =? 0 ) ) in
let l1 := if if1 then exec_state (  tvm_transfer (  eval_state ( ↑2 ε ValidatorBase_ι_m_validatorWallet ) l_cutDePoolReward )
                                                validatorReward
                                                false
                                                 1
                                                default ) l_cutDePoolReward else l_cutDePoolReward in

let associationReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_associationRewardFraction ) l1 ) / 100  in
let if2 : bool := ( negb ( associationReward =? 0 ) ) in
let l2 := if if2 then exec_state (  tvm_transfer (  eval_state ( ↑12 ε DePoolContract_ι_m_association ) l1 )
                                                associationReward
                                                false
                                                1
                                                default ) l1 else l1 in
 eval_state ( ↓ ( DePoolContract_Ф_startRoundCompleting round2' RoundsBase_ι_CompletionReasonP_ι_RewardIsReceived ) ) l2.
 Proof.
  intros.
  destruct Л_round2.
  destruct l as
   (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState).
  destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState.

  compute. idtac.

  Time  repeat (

      time match goal with
        | |- ?x =>
          match x with
            | context [if ?b then _ else _] =>  idtac "if..." b;
                                              repeat rewrite ifSimpleState ;
                                              repeat rewrite ifFunApply ;
                                              case_eq b ; (* use case_eq to see destruction results *)
                                              simpl  ; intros
            | context  [match DePoolContract_Ф_cutDePoolReward ?a ?b
                                    with
                                    | SimpleState s => s
                                    end ?m] => idtac "found DePoolContract_Ф_cutDePoolReward ..."  a b ;
                                                let p := fresh"p" in
                                                destruct (DePoolContract_Ф_cutDePoolReward a b ) as (p);
                                                let v := fresh"v" in
                                                let l := fresh"l" in
                                                destruct (p m) as [v l];
                                                let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                                                let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                                                let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                                                let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                                                let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                                                let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                                                let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                                                let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                                                let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                                                let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                                                let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                                                let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                                                let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                                                let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                                                let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                                                let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                                                let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                                                destruct l as
                                                (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState);
                                              destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState;
                                                (* destruct v ; *)
                                                simpl
            | context  [match DePoolContract_Ф_startRoundCompleting ?a ?b
                  with
                  | SimpleState s => s
                  end ?m] => idtac "found DePoolContract_Ф_startRoundCompleting ..."  a b;
                              let p := fresh"p" in
                              destruct (DePoolContract_Ф_startRoundCompleting a b) as (p);
                              let v := fresh"v" in
                              let l := fresh"l" in
                              destruct (p m) as [v l];
                              let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                              let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                              let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                              let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                              let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                              let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                              let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                              let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                              let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                              let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                              let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                              let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                              let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                              let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                              let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                              let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                              let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                              destruct l as
                              (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState);
                            destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState;
                            (*  destruct v ; *)
                              simpl
            | _ =>  idtac "solving..." x; tryif solve [auto] then idtac "solved" else idtac "not solved"
          end
      end) .

      all: pr_numgoals.
 Qed.

Lemma DePoolContract_Ф_acceptRewardAndStartRoundCompleting_exec : forall ( Л_round2 : RoundsBase_ι_Round )
                                                                          ( Л_value : XInteger64 )
                                                                          (l: Ledger) ,
exec_state ( DePoolContract_Ф_acceptRewardAndStartRoundCompleting Л_round2 Л_value ) l =

let round2 := Л_round2 in
let effectiveStake := ( round2 ->> RoundsBase_ι_Round_ι_stake ) - ( round2 ->> RoundsBase_ι_Round_ι_unused ) in
let reward := Л_value - effectiveStake in
let round2 := {$ round2 with RoundsBase_ι_Round_ι_grossReward := reward $} in
let (reward, l_cutDePoolReward) := run ( ↓ ( DePoolContract_Ф_cutDePoolReward reward round2 ) ) l in
let newReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_participantRewardFraction ) l_cutDePoolReward ) / 100 in
let newReward' := newReward - (intMin newReward ((round2 ->> RoundsBase_ι_Round_ι_participantQty)*
                                                (eval_state ( ↑12 ε DePoolContract_ι_RET_OR_REINV_FEE ) l_cutDePoolReward )) ) in
let round2' := {$ round2 with RoundsBase_ι_Round_ι_rewards := newReward' $} in

let validatorReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_validatorRewardFraction ) l_cutDePoolReward ) / 100 in
let if1 : bool := ( negb ( validatorReward =? 0 ) ) in
let l1 := if if1 then exec_state (  tvm_transfer (  eval_state ( ↑2 ε ValidatorBase_ι_m_validatorWallet ) l_cutDePoolReward )
                                                validatorReward
                                                false
                                                 1
                                                default ) l_cutDePoolReward else l_cutDePoolReward in

let associationReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_associationRewardFraction ) l1 ) / 100  in
let if2 : bool := ( negb ( associationReward =? 0 ) ) in
let l2 := if if2 then exec_state (  tvm_transfer (  eval_state ( ↑12 ε DePoolContract_ι_m_association ) l1 )
                                                associationReward
                                                false
                                                1
                                                default ) l1 else l1 in
 exec_state ( ↓ ( DePoolContract_Ф_startRoundCompleting round2' RoundsBase_ι_CompletionReasonP_ι_RewardIsReceived ) ) l2.
 Proof.
  intros.
  destruct Л_round2.
  destruct l as
   (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState).
  destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState.

  compute. idtac.

  Time  repeat (

      time match goal with
        | |- ?x =>
          match x with
            | context [if ?b then _ else _] =>  idtac "if..." b;
                                              repeat rewrite ifSimpleState ;
                                              repeat rewrite ifFunApply ;
                                              case_eq b ; (* use case_eq to see destruction results *)
                                              simpl  ; intros
            | context  [match DePoolContract_Ф_cutDePoolReward ?a ?b
                                    with
                                    | SimpleState s => s
                                    end ?m] => idtac "found DePoolContract_Ф_cutDePoolReward ..."  a b ;
                                                let p := fresh"p" in
                                                destruct (DePoolContract_Ф_cutDePoolReward a b ) as (p);
                                                let v := fresh"v" in
                                                let l := fresh"l" in
                                                destruct (p m) as [v l];
                                                let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                                                let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                                                let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                                                let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                                                let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                                                let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                                                let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                                                let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                                                let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                                                let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                                                let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                                                let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                                                let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                                                let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                                                let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                                                let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                                                let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                                                destruct l as
                                                (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState);
                                              destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState;
                                                (* destruct v ; *)
                                                simpl
            | context  [match DePoolContract_Ф_startRoundCompleting ?a ?b
                  with
                  | SimpleState s => s
                  end ?m] => idtac "found DePoolContract_Ф_startRoundCompleting ..."  a b;
                              let p := fresh"p" in
                              destruct (DePoolContract_Ф_startRoundCompleting a b) as (p);
                              let v := fresh"v" in
                              let l := fresh"l" in
                              destruct (p m) as [v l];
                              let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                              let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                              let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                              let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                              let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                              let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                              let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                              let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                              let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                              let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                              let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                              let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                              let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                              let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                              let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                              let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                              let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                              destruct l as
                              (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState);
                            destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState;
                            (*  destruct v ; *)
                              simpl
            | _ =>  idtac "solving..." x; tryif solve [auto] then idtac "solved" else idtac "not solved"
          end
      end) .

      all: pr_numgoals.
 Qed.


Require Import Coq.omega.Omega.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Eq.
Require Import ExtLib.Tactics.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.AbsAppI.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprD.

Set Implicit Arguments.
Set Strict Implicit.

Section raw_types.
  Context {typ func : Set}.

  Fixpoint lower (skip : nat) (_by : nat) (e : expr typ func) {struct e}
  : option (expr typ func) :=
    match e with
      | Var v => if v ?[ lt ] skip then Some (Var v)
                 else if (v - skip) ?[ lt ] _by then None
                      else Some (Var (v - _by))
      | Inj f => Some (Inj f)
      | UVar u => Some (UVar u)
      | App a b =>
        ap (ap (pure App) (lower skip _by a)) (lower skip _by b)
      | Abs t a =>
        ap (pure (Abs t)) (lower (S skip) _by a)
    end.

  Fixpoint lift (skip : nat) (_by : nat) (e : expr typ func) {struct e}
  : expr typ func :=
    match e with
      | Var v => Var (if v ?[ lt ] skip then v else (v + _by))
      | Inj f => Inj f
      | UVar u => UVar u
      | App a b =>
        App (lift skip _by a) (lift skip _by b)
      | Abs t a =>
        Abs t (lift (S skip) _by a)
    end.

End raw_types.

Section types.
  Context {typ : Set}.
  Context {func : Set}.
  Context {RType_typD : RType typ}.
  Context {Typ2_Fun : Typ2 RType_typD RFun}.
  Context {RSym_func : RSym func}.

  (** Reasoning principles **)
  Context {RTypeOk_typD : RTypeOk}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
  Context {RSymOk_func : RSymOk RSym_func}.

  Theorem typeof_expr_lower
  : forall tus e tvs tvs' tvs'' e',
      lower (length tvs) (length tvs') e = Some e' ->
      typeof_expr tus (tvs ++ tvs'') e' =
      typeof_expr tus (tvs ++ tvs' ++ tvs'') e.
  Proof using.
    intros tus e tvs tvs' tvs''; revert tvs.
    induction e; simpl; intros; simpl in *; forward; inv_all; subst; auto.
    { consider (v ?[ lt ] length tvs); intros; forward; inv_all; subst.
      { simpl.
        repeat rewrite ListNth.nth_error_app_L by omega. reflexivity. }
      { simpl.
        repeat rewrite ListNth.nth_error_app_R by omega.
        f_equal. omega. } }
    { eapply IHe1 in H. eapply IHe2 in H0.
      simpl. rewrite H0. rewrite H. reflexivity. }
    { simpl. specialize (IHe (t :: tvs)).
      simpl in *. eapply IHe in H.
      destruct H. reflexivity. }
  Qed.

  Theorem lambda_exprD_lower
  : forall tus tvs tvs' tvs'' e t val e',
      lower (length tvs) (length tvs') e = Some e' ->
      lambda_exprD tus (tvs ++ tvs' ++ tvs'') t e = Some val ->
      exists val',
        lambda_exprD tus (tvs ++ tvs'') t e' = Some val' /\
        forall us vs vs' vs'',
          val us (hlist_app vs (hlist_app vs' vs'')) =
          val' us (hlist_app vs vs'').
  Proof using RTypeOk_typD RSymOk_func Typ2Ok_Fun.
    intros tus tvs tvs' tvs'' e. revert tvs.
    induction e; simpl; intros;
    autorewrite with exprD_rw in *; simpl in *; forward; inv_all; subst.
    { consider (v ?[ lt ] length tvs); intros; forward.
      { inv_all; subst.
        autorewrite with exprD_rw. simpl.
        generalize (@nth_error_get_hlist_nth_appL _ typD (tvs' ++ tvs'') _ _ H).
        generalize (@nth_error_get_hlist_nth_appL _ typD tvs'' _ _ H).
        intros.
        forward_reason; Cases.rewrite_all_goal.
        rewrite H6 in *.
        inv_all. subst.
        destruct x0; destruct x1; simpl in *.
        rewrite H3 in *. rewrite H1 in *. inv_all; subst.
        simpl in *. rewrite H2. eexists; split; eauto.
        intros. simpl. rewrite H7. rewrite H5. reflexivity. }
      { inv_all; subst.
        autorewrite with exprD_rw. simpl.
        consider (nth_error_get_hlist_nth typD (tvs ++ tvs'') (v - length tvs')); intros.
        { destruct s.
          eapply nth_error_get_hlist_nth_appR in H1; [ simpl in * | omega ].
          destruct H1 as [ ? [ ? ? ] ].
          eapply nth_error_get_hlist_nth_appR in H1; [ simpl in * | omega ].
          eapply nth_error_get_hlist_nth_appR in H3; [ simpl in * | omega ].
          forward_reason.
          replace (v - length tvs' - length tvs)
             with (v - length tvs - length tvs') in H3 by omega.
          rewrite H1 in *. inv_all; subst. rewrite H2.
          eexists; split; eauto. intros.
          rewrite H4. rewrite H6. rewrite H5. reflexivity. }
        { exfalso.
          rewrite nth_error_get_hlist_nth_None in H3.
          eapply nth_error_get_hlist_nth_Some in H1. destruct H1. clear H1.
          simpl in *.
          repeat rewrite ListNth.nth_error_app_R in * by omega.
          replace (v - length tvs' - length tvs)
             with (v - length tvs - length tvs') in H3 by omega.
          congruence. } } }
    { autorewrite with exprD_rw. rewrite H0. simpl. eauto. }
    { autorewrite with exprD_rw.
      generalize H4.
      eapply typeof_expr_lower in H4; rewrite H4; clear H4.
      rewrite H0. simpl. intro.
      eapply IHe1 in H; eauto.
      eapply IHe2 in H4; eauto.
      forward_reason.
      Cases.rewrite_all_goal.
      eexists; split; eauto. intros.
      unfold AbsAppI.exprT_App.
      match goal with
        | |- match ?X with _ => _ end _ _ _ _ =
             match ?Y with _ => _ end _ _ _ _ =>
          change Y with X ; generalize X
      end; intros.
      autorewrite with eq_rw.
      clear - H4 H5. destruct e3; simpl.
      rewrite H5. rewrite H4. reflexivity. }
    { autorewrite with exprD_rw in *; simpl in *.
      destruct (typ2_match_case t0).
      { destruct H1 as [ ? [ ? [ ? ? ] ] ].
        rewrite H1 in *; clear H1.
        generalize dependent (typ2_cast x x0).
        destruct x1. simpl in *. intros.
        specialize (IHe (t :: tvs)). simpl in *.
        repeat first [ rewrite eq_option_eq in *
                     | rewrite eq_Const_eq in *
                     | rewrite eq_Arr_eq in * ].
        forward; inv_all; subst.
        eapply IHe in H2; eauto.
        forward_reason; Cases.rewrite_all_goal.
        simpl. eexists; split; eauto.
        intros. eapply FunctionalExtensionality.functional_extensionality.
        intros.
        specialize (H2 us (Hcons x2 vs)).
        simpl in H2. rewrite H2. reflexivity. }
      { rewrite H1 in *. congruence. } }
    { autorewrite with exprD_rw. rewrite H1. simpl.
      rewrite H2. eauto. }
  Qed.

  Theorem typeof_expr_lift
  : forall tus e tvs tvs' tvs'',
      typeof_expr tus (tvs ++ tvs' ++ tvs'') (lift (length tvs) (length tvs') e) =
      typeof_expr tus (tvs ++ tvs'') e.
  Proof using.
    intros tus e tvs; revert tvs; induction e; simpl; intros;
    Cases.rewrite_all_goal; auto.
    { consider (v ?[ lt ] length tvs); intros.
      { repeat rewrite ListNth.nth_error_app_L by auto.
        reflexivity. }
      { repeat rewrite ListNth.nth_error_app_R by omega.
        f_equal. omega. } }
    { specialize (IHe (t :: tvs)). simpl in *.
      rewrite IHe. reflexivity. }
  Qed.

  Theorem lambda_exprD_lift
  : forall tus e tvs tvs' tvs'' t,
      match lambda_exprD tus (tvs ++ tvs'') t e with
        | None => True
        | Some val =>
          match lambda_exprD tus (tvs ++ tvs' ++ tvs'') t (lift (length tvs) (length tvs') e) with
            | None => False
            | Some val' =>
              forall us vs vs' vs'',
                val us (hlist_app vs vs'') =
                val' us (hlist_app vs (hlist_app vs' vs''))
          end
      end.
  Proof using RTypeOk_typD RSymOk_func Typ2Ok_Fun.
    induction e; simpl; intros; autorewrite with exprD_rw; simpl;
    forward; inv_all; subst; Cases.rewrite_all_goal; auto.
    { consider (v ?[ lt ] length tvs); intros.
      { generalize (@nth_error_get_hlist_nth_appL _ typD (tvs' ++ tvs'') _ _ H).
        generalize (@nth_error_get_hlist_nth_appL _ typD tvs'' _ _ H).
        clear H. intros.
        forward_reason.
        revert H3. revert H0. Cases.rewrite_all_goal. destruct x1.
        intros; simpl in *. destruct x0; simpl in *.
        inv_all. subst.
        Cases.rewrite_all_goal.
        intros.
        rewrite H4. rewrite H6. reflexivity. }
      { eapply nth_error_get_hlist_nth_appR in H0; [ simpl in * | omega ].
        forward_reason.
        consider (nth_error_get_hlist_nth typD (tvs ++ tvs' ++ tvs'')
           (v + length tvs')); intros.
        { destruct s. forward.
          eapply nth_error_get_hlist_nth_appR in H3; [ simpl in * | omega ].
          forward_reason.
          eapply nth_error_get_hlist_nth_appR in H3; [ simpl in * | omega ].
          forward_reason.
          replace (v + length tvs' - length tvs - length tvs')
             with (v - length tvs) in H3 by omega.
          rewrite H0 in *. inv_all; subst.
          rewrite H1. congruence. }
        { rewrite nth_error_get_hlist_nth_None in H3.
          eapply nth_error_get_hlist_nth_Some in H0. destruct H0.
          clear H0. simpl in *.
          repeat rewrite ListNth.nth_error_app_R in H3 by omega.
          replace (v + length tvs' - length tvs - length tvs')
             with (v - length tvs) in H3 by omega.
          congruence. } } }
    { rewrite typeof_expr_lift. rewrite H.
      specialize (IHe1 tvs tvs' tvs'' (typ2 t0 t)).
      specialize (IHe2 tvs tvs' tvs'' t0).
      forward. inv_all. subst.
      unfold AbsAppI.exprT_App.
      autorewrite_with_eq_rw.
      rewrite <- IHe1. rewrite <- IHe2. reflexivity. }
    { destruct (typ2_match_case t0).
      { destruct H0 as [ ? [ ? [ ? ? ] ] ].
        rewrite H0 in *; clear H0.
        generalize dependent (typ2_cast x x0).
        destruct x1. simpl.
        intros. rewrite eq_option_eq in *.
        forward. inv_all; subst.
        specialize (IHe (t :: tvs) tvs' tvs'' x0).
        revert IHe. simpl. Cases.rewrite_all_goal.
        intros; forward.
        eapply FunctionalExtensionality.functional_extensionality.
        intros. eapply (IHe us (Hcons x1 vs)). }
      { rewrite H0 in *. congruence. } }
  Qed.

End types.


From iris.algebra Require Export ofe.
Set Default Proof Using "Type".

Section language_mixin.
  Context {expr val state : Type}.
  Context (of_val : val → expr).
  Context (to_val : expr → option val).
  Context (prim_step : expr → state → expr → state → list expr → Prop).

  Record LanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None
  }.
End language_mixin.

Structure language := Language {
  expr : Type;
  val : Type;
  state : Type;
  of_val : val → expr;
  to_val : expr → option val;
  prim_step : expr → state → expr → state → list expr → Prop;
  language_mixin : LanguageMixin of_val to_val prim_step
}.
Delimit Scope expr_scope with E.
Delimit Scope val_scope with V.
Bind Scope expr_scope with expr.
Bind Scope val_scope with val.

Arguments Language {_ _ _ _ _ _} _.
Arguments of_val {_} _.
Arguments to_val {_} _.
Arguments prim_step {_} _ _ _ _ _.

Canonical Structure stateC Λ := leibnizC (state Λ).
Canonical Structure valC Λ := leibnizC (val Λ).
Canonical Structure exprC Λ := leibnizC (expr Λ).

Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.

Class LanguageCtx {Λ : language} (K : expr Λ → expr Λ) := {
  fill_not_val e :
    to_val e = None → to_val (K e) = None;
  fill_step e1 σ1 e2 σ2 efs :
    prim_step e1 σ1 e2 σ2 efs →
    prim_step (K e1) σ1 (K e2) σ2 efs;
  fill_step_inv e1' σ1 e2 σ2 efs :
    to_val e1' = None → prim_step (K e1') σ1 e2 σ2 efs →
    ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 e2' σ2 efs;
  fill_inj : Inj (=) (=) K;
}.

Instance language_ctx_id Λ : LanguageCtx (@id (expr Λ)).
Proof. constructor; try naive_solver. intros ???; auto. Qed.

Inductive atomicity := StronglyAtomic | WeaklyAtomic.

Section language.
  Context {Λ : language}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.

  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. apply language_mixin. Qed.
  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof. apply language_mixin. Qed.
  Lemma val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None.
  Proof. apply language_mixin. Qed.

  Definition reducible (e : expr Λ) (σ : state Λ) :=
    ∃ e' σ' efs, prim_step e σ e' σ' efs.
  Definition irreducible (e : expr Λ) (σ : state Λ) :=
    ∀ e' σ' efs, ¬prim_step e σ e' σ' efs.
  Definition stuck (e : expr Λ) (σ : state Λ) :=
    to_val e = None ∧ irreducible e σ.

  (* [Atomic WeaklyAtomic]: This (weak) form of atomicity is enough to open
     invariants when WP ensures safety, i.e., programs never can get stuck.  We
     have an example in lambdaRust of an expression that is atomic in this
     sense, but not in the stronger sense defined below, and we have to be able
     to open invariants around that expression.  See `CasStuckS` in
     [lambdaRust](https://gitlab.mpi-sws.org/FP/LambdaRust-coq/blob/master/theories/lang/lang.v).

     [Atomic StronglyAtomic]: To open invariants with a WP that does not ensure
     safety, we need a stronger form of atomicity.  With the above definition,
     in case `e` reduces to a stuck non-value, there is no proof that the
     invariants have been established again. *)
  Class Atomic (a : atomicity) (e : expr Λ) : Prop :=
    atomic σ e' σ' efs :
      prim_step e σ e' σ' efs →
      if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').

  Inductive step (ρ1 ρ2 : cfg Λ) : Prop :=
    | step_atomic e1 σ1 e2 σ2 efs t1 t2 :
       ρ1 = (t1 ++ e1 :: t2, σ1) →
       ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) →
       prim_step e1 σ1 e2 σ2 efs →
       step ρ1 ρ2.

  Inductive istep (i: nat) (ρ1 ρ2 : cfg Λ) : Prop :=
    | istep_atomic e1 σ1 e2 σ2 efs t1 t2 :
       ρ1 = (t1 ++ e1 :: t2, σ1) →
       ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) →
       prim_step e1 σ1 e2 σ2 efs →
       length t1 = i →
       istep i ρ1 ρ2.

  Lemma of_to_val_flip v e : of_val v = e → to_val e = Some v.
  Proof. intros <-. by rewrite to_of_val. Qed.

  Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ.
  Proof. unfold reducible, irreducible. naive_solver. Qed.
  Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
  Proof. intros (?&?&?&?); eauto using val_stuck. Qed.
  Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ.
  Proof. intros [??] ??? ?%val_stuck. by destruct (to_val e). Qed.
  Global Instance of_val_inj : Inj (=) (=) (@of_val Λ).
  Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma strongly_atomic_atomic e a :
    Atomic StronglyAtomic e → Atomic a e.
  Proof. unfold Atomic. destruct a; eauto using val_irreducible. Qed.

  Lemma reducible_fill `{LanguageCtx Λ K} e σ :
    to_val e = None → reducible (K e) σ → reducible e σ.
  Proof.
    intros ? (e'&σ'&efs&Hstep); unfold reducible.
    apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
  Qed.
  Lemma irreducible_fill `{LanguageCtx Λ K} e σ :
    to_val e = None → irreducible e σ → irreducible (K e) σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill. Qed.

  Lemma step_Permutation (t1 t1' t2 : list (expr Λ)) σ1 σ2 :
    t1 ≡ₚ t1' → step (t1,σ1) (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ step (t1',σ1) (t2',σ2).
  Proof.
    intros Ht [e1 σ1' e2 σ2' efs tl tr ?? Hstep]; simplify_eq/=.
    move: Ht; rewrite -Permutation_middle (symmetry_iff (≡ₚ)).
    intros (tl'&tr'&->&Ht)%Permutation_cons_inv.
    exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor].
    by rewrite -!Permutation_middle !assoc_L Ht.
  Qed.

  Class PureExec (P : Prop) (e1 e2 : expr Λ) := {
    pure_exec_safe σ :
      P → reducible e1 σ;
    pure_exec_puredet σ1 e2' σ2 efs :
      P → prim_step e1 σ1 e2' σ2 efs → σ1 = σ2 ∧ e2 = e2' ∧ efs = [];
  }.

  Lemma hoist_pred_pure_exec (P : Prop) (e1 e2 : expr Λ) :
    (P → PureExec True e1 e2) →
    PureExec P e1 e2.
  Proof. intros HPE. split; intros; eapply HPE; eauto. Qed.

  (* We do not make this an instance because it is awfully general. *)
  Lemma pure_exec_ctx K `{LanguageCtx Λ K} e1 e2 φ :
    PureExec φ e1 e2 →
    PureExec φ (K e1) (K e2).
  Proof.
    intros [Hred Hstep]. split.
    - unfold reducible in *. naive_solver eauto using fill_step.
    - intros σ1 e2' σ2 efs ? Hpstep.
      destruct (fill_step_inv e1 σ1 e2' σ2 efs) as (e2'' & -> & ?); [|exact Hpstep|].
      + destruct (Hred σ1) as (? & ? & ? & ?); eauto using val_stuck.
      + edestruct (Hstep σ1 e2'' σ2 efs) as (-> & -> & ->); auto.
  Qed.

  (* This is a family of frequent assumptions for PureExec *)
  Class IntoVal (e : expr Λ) (v : val Λ) :=
    into_val : to_val e = Some v.

  Class AsVal (e : expr Λ) := as_val : is_Some (to_val e).
  (* There is no instance [IntoVal → AsVal] as often one can solve [AsVal] more
  efficiently since no witness has to be computed. *)
  Global Instance as_vals_of_val vs : TCForall AsVal (of_val <$> vs).
  Proof.
    apply TCForall_Forall, Forall_fmap, Forall_true=> v.
    rewrite /AsVal /= to_of_val; eauto.
  Qed.
End language.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal82.

From lfind Require Import LFind.
Require Import Arith.
Lemma lfind_state  (y:lst):@eq lst (qreva (rev y) Nil) (append y Nil).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal82_theorem0_71_qreva_rev/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (y:lst) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


Require Stacklayout.

Import Coqlib.
Import Integers.
Import AST.
Import Values.
Import Memory.
Import Locations.

(* Free all argument memory locations to consider the
   semantics of the C-style primitive being implemented
   and compiled in a C-style context
*)

Section WITHMEMORYMODEL.
Context `{memory_model: Mem.MemoryModel}.

Definition free_extcall_arg sp m e :=
  match e with
    | S Outgoing ofs ty =>
      match sp with
        | Vptr b o =>
          let of :=(Ptrofs.unsigned (Ptrofs.add o (Ptrofs.repr (Stacklayout.fe_ofs_arg + 4 * ofs)))) in
          Mem.free m b of (of + size_chunk (chunk_of_type ty))
        | _ => None
      end
    | _ => Some m (* provide for other calling conventions *)
  end.

Fixpoint free_extcall_args sp m l :=
  match l with
    | nil => Some m
    | e :: l' =>
      match free_extcall_arg sp m e with
        | Some m' =>
          free_extcall_args sp m' l'
        | _ => None
      end
  end.

Lemma free_extcall_arg_extends  sp m e m':
  free_extcall_arg sp m e = Some m' ->
  Mem.extends m' m.
Proof.
  destruct e.
  {
    simpl.
    inversion 1; subst.
    apply Mem.extends_refl.
  }
  unfold free_extcall_arg.
  destruct sl; try discriminate.
  { inversion 1; subst; apply Mem.extends_refl. }
  { inversion 1; subst; apply Mem.extends_refl. }
  destruct sp; try discriminate.
  intros. eapply Mem.free_left_extends; eauto.
  apply Mem.extends_refl.
Qed.

Corollary free_extcall_args_extends sp l:
  forall m m',
  free_extcall_args sp m l = Some m' ->
  Mem.extends m' m.
Proof.
  induction l; simpl.
  {
    inversion 1; subst.
    apply Mem.extends_refl.
  }
  intros m m' H.
  destruct (free_extcall_arg sp m a) eqn:FREE ; try discriminate.
  eapply Mem.extends_extends_compose; eauto.
  eapply free_extcall_arg_extends; eauto.
Qed.

Lemma free_extcall_args_parallel_extends sp sp_
      (LESSDEF: Val.lessdef sp sp_)
      l:
  forall m m',
    free_extcall_args sp m l = Some m' ->
    forall m_,
      Mem.extends m m_ ->
      exists m'_,
        free_extcall_args sp_ m_ l = Some m'_ /\
        Mem.extends m' m'_.
Proof.
  induction l; simpl.
  {
    inversion 1; subst; eauto.
  }
  unfold free_extcall_arg.
  destruct a; auto.
  destruct sl; auto.
  destruct sp; try discriminate.
  inversion LESSDEF; subst.
  set (o := Ptrofs.unsigned
              (Ptrofs.add i (Ptrofs.repr (Stacklayout.fe_ofs_arg + 4 * pos)))).
  intros m m' H m_ H0.
  destruct (Mem.free m b o (o + size_chunk (chunk_of_type ty))) eqn:FREE; try discriminate.
  exploit Mem.free_parallel_extends; eauto.
  destruct 1 as (? & FREE_ & EXT).
  rewrite FREE_.
  eauto.
Qed.

End WITHMEMORYMODEL.


From iris.bi Require Export bi plainly.
From iris.proofmode Require Import tactics.
From iris Require Import options.
Import bi.

(** The "core" of an assertion is its maximal persistent part,
    i.e. the conjunction of all persistent assertions that are weaker
    than P (as in, implied by P). *)
Definition coreP `{!BiPlainly PROP} (P : PROP) : PROP :=
  (* TODO: Looks like we want notation for affinely-plainly; that lets us avoid
  using conjunction/implication here. *)
  (∀ Q : PROP, <affine> ■ (Q -∗ <pers> Q) -∗ <affine> ■ (P -∗ Q) -∗ Q)%I.
Instance: Params (@coreP) 1 := {}.
Typeclasses Opaque coreP.

Section core.
  Context `{!BiPlainly PROP}.
  Implicit Types P Q : PROP.

  Lemma coreP_intro P : P -∗ coreP P.
  Proof.
    rewrite /coreP. iIntros "HP" (Q) "_ HPQ".
    (* FIXME: Cannot apply HPQ directly. This works if we move it to the
    persistent context, but why should we? *)
    iDestruct (affinely_plainly_elim with "HPQ") as "HPQ".
    by iApply "HPQ".
  Qed.

  Global Instance coreP_persistent P : Persistent (coreP P).
  Proof.
    rewrite /coreP /Persistent. iIntros "HC" (Q).
    iApply persistently_wand_affinely_plainly. iIntros "#HQ".
    iApply persistently_wand_affinely_plainly. iIntros "#HPQ".
    iApply "HQ". iApply "HC"; auto.
  Qed.
  Global Instance coreP_affine P : Affine P → Affine (coreP P).
  Proof. intros ?. rewrite /coreP /Affine. iIntros "HC". iApply "HC"; eauto. Qed.

  Global Instance coreP_ne : NonExpansive (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.
  Global Instance coreP_proper : Proper ((⊣⊢) ==> (⊣⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.

  Global Instance coreP_mono : Proper ((⊢) ==> (⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.
  Global Instance coreP_flip_mono :
    Proper (flip (⊢) ==> flip (⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.

  Lemma coreP_wand P Q : <affine> ■ (P -∗ Q) -∗ coreP P -∗ coreP Q.
  Proof.
    rewrite /coreP. iIntros "#HPQ HP" (R) "#HR #HQR". iApply ("HP" with "HR").
    iIntros "!> !> HP". iApply "HQR". by iApply "HPQ".
  Qed.

  Lemma coreP_elim P : Persistent P → coreP P -∗ P.
  Proof. rewrite /coreP. iIntros (?) "HCP". iApply "HCP"; auto. Qed.

  (** The [<affine>] modality is needed for general BIs:
  - The right-to-left direction corresponds to elimination of [<pers>], which
    cannot be done without [<affine>].
  - The left-to-right direction corresponds the introduction of [<pers>]. The
    [<affine>] modality makes it stronger since it appears in the LHS of the
    [⊢] in the premise. As a user, you have to prove [<affine> coreP P ⊢ Q],
    which is weaker than [coreP P ⊢ Q]. *)
  Lemma coreP_entails P Q : (<affine> coreP P ⊢ Q) ↔ (P ⊢ <pers> Q).
  Proof.
    split.
    - iIntros (HP) "HP". iDestruct (coreP_intro with "HP") as "#HcP {HP}".
      iIntros "!>". by iApply HP.
    - iIntros (->) "HcQ". by iDestruct (coreP_elim with "HcQ") as "#HQ".
  Qed.
  (** A more convenient variant of the above lemma for affine [P]. *)
  Lemma coreP_entails' P Q `{!Affine P} : (coreP P ⊢ Q) ↔ (P ⊢ □ Q).
  Proof.
    rewrite -(affine_affinely (coreP P)) coreP_entails. split.
    - rewrite -{2}(affine_affinely P). by intros ->.
    - intros ->. apply affinely_elim.
  Qed.
End core.


Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.sample_mark.env_unionfind_arr.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.graph.UnionFind.
Require Import RamifyCoq.msl_application.UnionFindGraph.
Require Import RamifyCoq.msl_application.ArrayGraph.
Require Import RamifyCoq.floyd_ext.share.
Require Import RamifyCoq.sample_mark.spatial_array_graph.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.

Local Coercion UGraph_LGraph: Graph >-> LGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.
Existing Instances maGraph finGraph liGraph.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh:wshare, n: Z
  PRE [ 67%positive OF tint]
     PROP (4 <= n <= Int.max_unsigned)
     LOCAL (temp 67%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: pointer_val,
     PROP (malloc_compatible n (pointer_val_val v))
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (memory_block sh n (pointer_val_val v)).

Definition whole_graph sh g x := (@full_graph_at mpred SAGA_VST pointer_val (SAG_VST sh) g x).

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, V: Z
    PRE [_V OF tint]
      PROP (0 < V <= Int.max_signed / 8)
      LOCAL (temp _V (Vint (Int.repr V)))
      SEP ()
    POST [tptr vertex_type]
      EX g: Graph, EX rt: pointer_val,
      PROP (forall i: Z, 0 <= i < V -> vvalid g i)
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (whole_graph sh g rt).

Definition find_spec :=
  DECLARE _find
  WITH sh: wshare, g: Graph, subsets: pointer_val, i: Z
    PRE [_subsets OF (tptr vertex_type), _i OF tint]
      PROP (vvalid g i)
      LOCAL (temp _subsets (pointer_val_val subsets); temp _i (Vint (Int.repr i)))
      SEP (whole_graph sh g subsets)
    POST [tint]
      EX g': Graph, EX rt: Z,
      PROP (uf_equiv g g' /\ uf_root g' i rt)
      LOCAL (temp ret_temp (Vint (Int.repr rt)))
      SEP (whole_graph sh g' subsets).

Definition union_spec :=
 DECLARE _Union
  WITH sh: wshare, g: Graph, subsets: pointer_val, x: Z, y: Z
  PRE [ _subsets OF (tptr vertex_type), _x OF tint, _y OF tint]
          PROP  (vvalid g x /\ vvalid g y)
          LOCAL (temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x)); temp _y (Vint (Int.repr y)))
          SEP   (whole_graph sh g subsets)
  POST [ Tvoid ]
        EX g': Graph,
        PROP (uf_union g x y g')
        LOCAL ()
        SEP (whole_graph sh g' subsets).

Definition Gprog : funspecs := ltac:(with_library prog [mallocN_spec; makeSet_spec; find_spec; union_spec]).

Fixpoint prog_list_helper (i: nat) (n: nat) : list (val * val) :=
  match n with
  | O => nil
  | S n' => if (le_dec i n') then (Vundef, Vundef) :: prog_list_helper i n'
            else (Vint (Int.repr (Z.of_nat (n'))), Vint (Int.repr 0)) :: prog_list_helper i n'
  end.

Definition progressive_list (i: nat) (n: nat) := rev (prog_list_helper i n).

Lemma progressive_list_repeat: forall n, list_repeat n (Vundef, Vundef) = progressive_list O n.
Proof.
  induction n; unfold progressive_list; simpl; auto. unfold progressive_list in IHn. rewrite <- IHn.
  change ((Vundef, Vundef) :: list_repeat n (Vundef, Vundef)) with (((Vundef, Vundef) :: nil) ++ list_repeat n (Vundef, Vundef)).
  change ((Vundef, Vundef) :: nil) with (list_repeat 1 (Vundef, Vundef)). rewrite !list_repeat_app. rewrite Nat.add_comm. auto.
Qed.

Lemma progressive_list_length: forall i n, length (progressive_list i n) = n.
Proof. intros. unfold progressive_list. rewrite rev_length. induction n; simpl; auto. destruct (le_dec i n); simpl; rewrite IHn; auto. Qed.

Definition progressive_array sh i V rt := data_at sh (tarray vertex_type V) (progressive_list (Z.to_nat i) (Z.to_nat V)) (pointer_val_val rt).

Lemma upd_Znth_twice: forall {A: Type} i (l: list A) v1 v2, 0 <= i < Zlength l -> upd_Znth i (upd_Znth i l v1) v2 = upd_Znth i l v2.
Proof.
  intros. unfold upd_Znth. f_equal; [|f_equal].
  - rewrite sublist0_app1.
    + rewrite sublist_same; auto. rewrite Zlength_sublist; omega.
    + rewrite Zlength_sublist; omega.
  - assert (Zlength (sublist 0 i l) = i) by (rewrite Zlength_sublist; omega). rewrite sublist_app2; rewrite H0. 2: omega.
    assert (i + 1 - i = 1) by omega. rewrite H1. clear H1. rewrite Zlength_app. rewrite H0. rewrite Zlength_cons. unfold Z.succ.
    rewrite Zlength_sublist; [|omega..]. assert (i + (Zlength l - (i + 1) + 1) - i = Zlength l - i) by omega. rewrite H1; clear H1.
    rewrite sublist_1_cons. rewrite sublist_same; [auto | omega |]. rewrite Zlength_sublist; omega.
Qed.

Lemma prog_list_helper_gt: forall i j n, (i >= n)%nat -> (j >= n)%nat -> prog_list_helper i n = prog_list_helper j n.
Proof. intros. revert i j H H0. induction n; intros; simpl; auto. destruct (le_dec i n), (le_dec j n); [exfalso; omega ..|]. f_equal. apply IHn; omega. Qed.

Lemma upd_Znth_progressive_list: forall i V,
    0 <= i < Z.of_nat V -> upd_Znth i (progressive_list (Z.to_nat i) V) (Vint (Int.repr i), Vint (Int.repr 0)) = progressive_list (Z.to_nat (i + 1)) V.
Proof.
  intros. induction V. 1: exfalso; simpl in H; intuition. rewrite Nat2Z.inj_succ in H. unfold Z.succ in H. unfold progressive_list. simpl. destruct (le_dec (Z.to_nat i) V).
  - destruct (le_dec (Z.to_nat (i + 1)) V).
    + simpl. assert (0 <= i < Z.of_nat V) by (apply inj_le in l0; rewrite Z2Nat.id in l0; omega). unfold progressive_list in IHV. rewrite <- IHV; auto.
      rewrite upd_Znth_app1; auto. change (rev (prog_list_helper (Z.to_nat i) V)) with (progressive_list (Z.to_nat i) V).
      rewrite Zlength_correct, progressive_list_length. auto.
    + assert (Z.to_nat (i + 1) > V)%nat by omega. apply inj_gt in H0. rewrite Z2Nat.id in H0. 2: omega. assert (i = Z.of_nat V) by omega. subst i.
      clear IHV l n H0 H. rewrite Nat2Z.id. simpl. rewrite upd_Znth_char.
      * f_equal. change 1 with (Z.of_nat 1). rewrite <- Nat2Z.inj_add, Nat2Z.id. f_equal. apply prog_list_helper_gt; omega.
      * change (rev (prog_list_helper V V)) with (progressive_list V V). rewrite Zlength_correct, progressive_list_length. auto.
  - exfalso. assert (Z.to_nat i > V)%nat by omega. apply inj_gt in H0. rewrite Z2Nat.id in H0; omega.
Qed.

Lemma progressive_nat_inc_list: forall n i, (i >= n)%nat -> map (fun x : Z => (Vint (Int.repr x), Vint (Int.repr 0))) (nat_inc_list n) = progressive_list i n.
Proof.
  induction n; intros; unfold progressive_list in *; simpl; auto. destruct (le_dec i n). 1: exfalso; omega. rewrite map_app. simpl. rewrite <- IHn; intuition.
Qed.

Lemma body_makeSet: semax_body Vprog Gprog f_makeSet makeSet_spec.
Proof.
  start_function. forward_call (sh, Z.mul V 8).
  - assert (Int.min_signed <= 8 <= Int.max_signed) by rep_omega.
    assert (Int.min_signed <= V <= Int.max_signed). {
      split; rewrite Z.le_lteq; left.
      - rep_omega.
      - apply Z.le_lt_trans with (Int.max_signed / 8); [intuition | apply Z.div_lt; omega].
    } rewrite !Int.signed_repr; auto. split. 1: omega.
    assert (Z.mul 8 (Int.max_signed /8) <= Int.max_signed) by (apply Z_mult_div_ge; intuition). rep_omega.
  - split. 1: omega. assert (Z.mul 8 (Int.max_signed /8) <= Int.max_signed) by (apply Z_mult_div_ge; intuition). rep_omega.
  - Intros rt.
    assert (memory_block sh (V * 8) (pointer_val_val rt) = data_at_ sh (tarray vertex_type V) (pointer_val_val rt)). {
      assert (memory_block sh (V * 8) (pointer_val_val rt) = memory_block sh (sizeof (tarray vertex_type V)) (pointer_val_val rt)). {
        simpl sizeof. rewrite Zmax0r. 2: intuition. assert (V * 8 = 8 * V)%Z by omega. rewrite H1. auto.
      } rewrite <- memory_block_data_at_; auto. apply malloc_compatible_field_compatible; auto.
      unfold malloc_compatible in *. destruct (pointer_val_val rt); auto. destruct H0. split; auto. simpl sizeof. rewrite Zmax0r; intuition.
    } rewrite H1. clear H1.
    assert (data_at_ sh (tarray vertex_type V) (pointer_val_val rt) = data_at sh (tarray vertex_type V) (progressive_list O (Z.to_nat V)) (pointer_val_val rt)). {
      unfold data_at_, field_at_, data_at. assert (default_val (nested_field_type (tarray vertex_type V) []) = list_repeat (Z.to_nat V) (Vundef, Vundef)) by reflexivity.
      rewrite H1. rewrite progressive_list_repeat. auto.
    } rewrite H1. clear H1.
    forward_for_simple_bound V
      (EX i: Z,
       PROP ()
       LOCAL (temp _subsets (pointer_val_val rt); temp _V (Vint (Int.repr V)))
       SEP (progressive_array sh i V rt)); unfold progressive_array.
    + destruct H. apply Z.le_trans with (Int.max_signed / 8); auto. rewrite Z.lt_eq_cases. left. apply Z_div_lt; intuition.
    + entailer.
    + Opaque Znth. forward. remember (Znth i (progressive_list (Z.to_nat i) (Z.to_nat V))) as lll. destruct lll. forward.
      assert (0 <= i < Zlength (progressive_list (Z.to_nat i) (Z.to_nat V))) by (split; [|rewrite Zlength_correct, progressive_list_length, Z2Nat.id]; omega).
      rewrite upd_Znth_same, upd_Znth_twice; [|auto ..]. unfold progressive_array, data_at.
      rewrite upd_Znth_progressive_list. 2: rewrite Z2Nat.id; omega. entailer. Transparent Znth.
    + forward. Exists (makeSet_discrete_Graph (Z.to_nat V)) rt. entailer!.
      * intros. simpl. rewrite makeSet_vvalid. rewrite Z2Nat.id; omega.
      * unfold whole_graph, full_graph_at. simpl. Exists (Z.to_nat V). apply andp_right; intros; [apply andp_right; apply prop_right|].
        -- intros. rewrite makeSet_vvalid. intuition.
        -- rewrite Z2Nat.id; omega.
        -- simpl. unfold vcell_array_at, SAG_VST. rewrite map_length, nat_inc_list_length. rewrite Z2Nat.id. 2: intuition.
           assert (map (fun x : Z => vgamma (makeSet_discrete_LabeledGraph (Z.to_nat V)) x) (nat_inc_list (Z.to_nat V)) =
                   map (fun x => (0%nat, x)) (nat_inc_list (Z.to_nat V))). {
             apply list_map_exten. intros. unfold vgamma, UnionFindGraph.vgamma. simpl. rewrite makeSet_dst. simpl. auto.
           } rewrite H6. clear H6. rewrite list_map_compose. unfold vgamma2cdata. simpl. rewrite <- progressive_nat_inc_list; intuition.
Qed.

Lemma whole_graph_fold: forall n sh g p,
    (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) -> Z.of_nat n <= Int.max_signed / 8 ->
    data_at sh (tarray vertex_type (Z.of_nat n)) (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g) x)) (nat_inc_list n)) (pointer_val_val p) = whole_graph sh g p.
Proof.
  intros. apply pred_ext; unfold whole_graph, full_graph_at, vcell_array_at, SAG_VST; [apply (exp_right n)|Intros n']; rewrite map_length, nat_inc_list_length, list_map_compose.
  - apply andp_right; auto. apply andp_right; apply prop_right; auto.
  - destruct (lt_eq_lt_dec n n') as [[? | ?] | ?]; [exfalso | subst n' | exfalso]; auto.
    + assert (vvalid (lg_gg g) (Z.of_nat n)) by (rewrite <- H1; intuition). rewrite <- H in H3. intuition.
    + assert (vvalid (lg_gg g) (Z.of_nat n')) by (rewrite <- H; intuition). rewrite <- H1 in H3. intuition.
Qed.

Lemma whole_graph_unfold: forall sh g p,
    whole_graph sh g p =
    EX n: nat, !! (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) && !!(Z.of_nat n <= Int.max_signed / 8) &&
                  (data_at sh (tarray vertex_type (Z.of_nat n)) (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g) x)) (nat_inc_list n)) (pointer_val_val p)).
Proof.
  intros. unfold whole_graph, full_graph_at, vcell_array_at, SAG_VST.
  apply pred_ext; Intros n; apply (exp_right n); apply andp_right; [apply andp_right; apply prop_right| |apply andp_right; apply prop_right|];
    auto; rewrite map_length, nat_inc_list_length, list_map_compose; auto.
Qed.

Lemma Znth_nat_inc_list: forall {A: Type} {d: Inhabitant A} n (f: Z -> A) i, 0 <= i < Z.of_nat n -> Znth i (map f (nat_inc_list n)) = f i.
Proof.
  intros. rewrite Znth_map. 2: rewrite Zlength_correct, nat_inc_list_length; auto. f_equal. induction n.
  - exfalso. simpl in H. intuition.
  - simpl. assert (0 <= i < Z.of_nat n \/ i = Z.of_nat n). {
      rewrite Nat2Z.inj_succ in H. destruct H. rewrite Z.lt_succ_r, Z.lt_eq_cases in H0. destruct H0; [left | right]; auto.
    } assert (Zlength (nat_inc_list n) = Z.of_nat n) by (rewrite Zlength_correct, nat_inc_list_length; auto). destruct H0.
    + rewrite app_Znth1. 2: rewrite H1; destruct H0; auto. apply IHn; auto.
    + rewrite app_Znth2. 2: rewrite H1; intuition. rewrite H0, H1. replace (Z.of_nat n - Z.of_nat n) with 0 by omega. rewrite Znth_0_cons. auto.
Qed.

Lemma graph_same_size: forall (g g': Graph) n n', (forall x : Z, vvalid g x <-> vvalid g' x) -> (forall v : Z, 0 <= v < Z.of_nat n' <-> vvalid (lg_gg g') v) ->
                                                  (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) -> n = n'.
Proof.
  intros. assert (forall v, 0 <= v < Z.of_nat n' <-> 0 <= v < Z.of_nat n). intros. rewrite H0. rewrite H1. symmetry. apply H. clear -H2.
  destruct (lt_eq_lt_dec n n'); [destruct s|]; auto; exfalso.
  - specialize (H2 (Z.of_nat n)). omega.
  - specialize (H2 (Z.of_nat n')). omega.
Qed.

Lemma list_eq_Znth {A} {d: Inhabitant A}: forall (l1 l2: list A) n, length l1 = n -> length l2 = n -> (forall j, 0 <= j < Z.of_nat n -> Znth j l1 = Znth j l2) -> l1 = l2.
Proof.
  intros l1 l2 n. revert l1 l2. induction n; intros.
  - simpl in *. destruct l1, l2; simpl in *; [auto | exfalso; intuition..].
  - destruct l1, l2; simpl in H, H0; [exfalso; intuition..| ]. assert (a = a0) by (specialize (H1 0); rewrite !Znth_0_cons in H1; apply H1; rewrite Nat2Z.inj_succ; omega).
    subst a0. cut (l1 = l2); intros. 1: subst l2; auto. inversion H. inversion H0. apply (IHn _ _); auto. intros. specialize (H1 (j + 1)).
    assert (0 < j + 1) by omega. assert (j + 1 - 1 = j) by omega. rewrite !Znth_pos_cons in H1; auto. rewrite !H6 in H1. apply H1. rewrite Nat2Z.inj_succ. omega.
Qed.

Lemma upd_Znth_Graph_redirect_parent: forall (i root : Z) (g: Graph) n (Hw: weak_valid g root) (Hv: vvalid g i) (Hi: ~ reachable g root i),
    0 <= i < Z.of_nat n -> 0 <= root < Z.of_nat n -> upd_Znth i (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g) m)) (nat_inc_list n))
                                                              (Vint (Int.repr root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g) i)))) =
                                                     map (fun m : Z => vgamma2cdata (vgamma (lg_gg (Graph_gen_redirect_parent g i root Hw Hv Hi)) m))(nat_inc_list n).
Proof.
  intros.
  assert (Zlength (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g) m)) (nat_inc_list n)) = Z.of_nat n) by (rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto).
  apply (list_eq_Znth _ _ n).
  - rewrite <- (Nat2Z.id n) at 2. rewrite <- Zlength_length. 2: omega. rewrite upd_Znth_Zlength; auto. rewrite <- H1 in H. auto.
  - rewrite list_length_map, nat_inc_list_length; auto.
  - intros. rewrite Znth_nat_inc_list; auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto. rewrite Znth_nat_inc_list; auto.
    unfold vgamma2cdata, vgamma, UnionFindGraph.vgamma. simpl. unfold graph_gen.updateEdgeFunc. unfold EquivDec.equiv_dec, Z_EqDec, zeq. destruct (Z.eq_dec j i).
    + subst j. destruct (Z.eq_dec i i). 2: exfalso; apply n0; auto. f_equal. destruct (Z_lt_dec root 0); [exfalso; omega | auto].
    + f_equal. destruct (Z.eq_dec i j). 1: exfalso; intuition. auto.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function. rewrite whole_graph_unfold. Intros n. forward.
  assert (H_BOUND: 0 <= i < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length, H0; assumption). forward.
  - apply prop_right. rewrite H0. auto.
  - rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list. 2: rewrite H0; auto. simpl id.
    forward_if
      (EX g': Graph, EX rt: Z,
       PROP (uf_equiv g g' /\ uf_root g' i rt)
       LOCAL (temp _p (Vint (Int.repr rt)); temp _subsets (pointer_val_val subsets); temp _i (Vint (Int.repr i)))
       SEP (whole_graph sh g' subsets)).
    + rewrite whole_graph_fold; [|intuition..]. destruct (vgamma (lg_gg g) i) eqn: ?. forward_call (sh, g, subsets, z).
      * unfold vgamma, UnionFindGraph.vgamma in Heqp. inversion Heqp. clear Heqp. destruct (Z_lt_dec (dst (lg_gg g) i) 0). 1: exfalso; apply H2; auto.
        destruct ((proj2 (@only_one_edge _ _ _ _ _ _ (liGraph g) _ i H)) (eq_refl i)) as [_ ?]. destruct (valid_graph g _ H3) as [_ [? | ?]]; auto.
        hnf in H6. exfalso. apply n1. auto.
      * Intros vret. destruct vret as [g' root]. simpl fst in *. simpl snd in *. rewrite whole_graph_unfold. Intros n'. forward. Opaque Znth. forward. Transparent Znth.
        -- apply prop_right. rewrite H5. destruct H3. rewrite <- H3. auto.
        -- assert (n' = n). {
             destruct H3, (lt_eq_lt_dec n n'); [destruct s|]; auto; exfalso.
             - specialize (H3 (Z.of_nat n)). specialize (H0 (Z.of_nat n)). specialize (H5 (Z.of_nat n)). rewrite <- H0 in H3. rewrite <- H3 in H5. omega.
             - specialize (H3 (Z.of_nat n')). specialize (H0 (Z.of_nat n')). specialize (H5 (Z.of_nat n')). rewrite <- H0 in H3. rewrite <- H3 in H5. omega.
           } subst n'. assert (z <> i) by (unfold vgamma, UnionFindGraph.vgamma in Heqp; inversion Heqp; intro; apply H2; rewrite H9 in H7; rewrite H9; subst i; auto).
           assert (weak_valid g' root) by (right; destruct H4; apply reachable_foot_valid in H4; auto).
           assert (vvalid g' i) by (destruct H3 as [? _]; rewrite <- H3; apply H).
           assert (~ reachable g' root i) by (apply (uf_equiv_not_reachable g g' i n0 z root); auto).
           apply (exp_right (Graph_gen_redirect_parent g' i root H8 H9 H10)). apply (exp_right root). rewrite Znth_nat_inc_list. 2: rewrite H0; auto.
           Opaque vgamma2cdata. Opaque vgamma. entailer !; [split|]. Transparent vgamma. Transparent vgamma2cdata.
           ++ apply (graph_gen_redirect_parent_equiv g g' i n0 z); auto.
           ++ apply (uf_root_gen_dst_same g' (liGraph g') i i root); auto.
              ** rewrite <- (uf_equiv_root_the_same g g' i root); auto.
                 apply (uf_root_edge _ (liGraph g) _ z); [| apply (vgamma_not_dst g i n0 z) | rewrite (uf_equiv_root_the_same g g')]; auto.
              ** apply reachable_refl; auto.
           ++ rewrite whole_graph_unfold. apply (exp_right n). entailer. unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma.
              cut ((upd_Znth i (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g') x)) (nat_inc_list n))
                             (Vint (Int.repr root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g') i))))) =
                   (map (fun x : Z => vgamma2cdata (vgamma (lg_gg (Graph_gen_redirect_parent g' i root H8 H9 H10)) x)) (nat_inc_list n))); intros.
              ** rewrite <- H15. apply derives_refl.
              ** rewrite <- H0 in H. destruct H4. apply reachable_foot_valid in H4. rewrite <- H5 in H4. clear -H H4. rewrite <- upd_Znth_Graph_redirect_parent; auto.
    + unfold vgamma2cdata at 1. unfold vgamma at 1. unfold UnionFindGraph.vgamma. forward. rewrite whole_graph_fold; [|intuition..]. apply (exp_right g).
      simpl projT2. simpl id. apply (exp_right i). entailer !.
      split; [|split]. 1: apply (uf_equiv_refl _  (liGraph g)). 2: rewrite <- H2; reflexivity. destruct (Z_lt_dec (dst (lg_gg g) i) 0).
      * split. 1: apply reachable_refl; auto. intros. destruct H4 as [[? ?] ?]. destruct H4 as [[? ?] [? ?]]. simpl in H4. subst z. destruct l0.
        -- simpl in H5. auto.
        -- simpl in H6. destruct H6. assert (strong_evalid g z) by (destruct l0; [|destruct H6]; auto). destruct H8 as [? [? ?]]. symmetry in H4.
           destruct (@only_one_edge _ _ _ _ _ _ (liGraph g) _ z H) as [? _]. specialize (H11 (conj H4 H8)). simpl in H11. subst z. rewrite <- H0 in H10.
           destruct H10. assert (dst g i < 0) by apply l. exfalso; omega.
      * destruct (vvalid_src_evalid _ (liGraph g) i H) as [_ ?]. destruct (valid_graph g _ H4) as [_ [? | ?]]. 1: simpl in H5; exfalso; auto. simpl id in *.
        rewrite <- H0 in H5. rewrite <- H0 in H. apply repr_inj_unsigned in H2.
        -- exfalso. rewrite H0 in H. assert (reachable g i i) by (apply reachable_refl; auto). pose proof (dst_not_reachable _ (liGraph g) _ _ _ H H2 H6). auto.
        -- split. 1: omega. rewrite Z.lt_eq_cases. left. apply Z.lt_trans with (Int.max_signed / 8). 2: reflexivity. destruct H5. apply Z.lt_le_trans with (Z.of_nat n); auto.
        -- split. 1: omega. rewrite Z.lt_eq_cases. left. apply Z.lt_trans with (Int.max_signed / 8). 2: compute; auto. destruct H. apply Z.lt_le_trans with (Z.of_nat n); auto.
    + Intros g' rt. forward. apply (exp_right g'). apply (exp_right rt). entailer !.
Qed.

Lemma bounded_vertex: forall v n, 0 <= v < n -> n <= Int.max_signed / 8 -> Int.min_signed <= v <= Int.max_signed.
Proof.
  intros. destruct H. split.
  - apply Z.le_trans with 0; auto. rewrite Z.lt_eq_cases. left. apply Int.min_signed_neg.
  - apply Z.le_trans with n. 1: rewrite Z.lt_eq_cases; left; auto. apply Z.le_trans with (Int.max_signed / 8); auto. rewrite Z.lt_eq_cases; left. apply Z_div_lt; intuition.
Qed.

Lemma body_union: semax_body Vprog Gprog f_Union union_spec.
Proof.
  start_function. destruct H.
  forward_call (sh, g, subsets, x). Intros vret. destruct vret as [g1 x_root]. simpl fst in *. simpl snd in *.
  assert (vvalid g1 y) by (destruct H1 as [? _]; rewrite <- H1; apply H0).
  forward_call (sh, g1, subsets, y). Intros vret. destruct vret as [g2 y_root]. simpl fst in *. simpl snd in *.
  forward_if
    (PROP (x_root <> y_root)
     LOCAL (temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root));
     temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
     temp _y (Vint (Int.repr y)))  SEP (whole_graph sh g2 subsets)).
  - forward. apply (exp_right g2). entailer. rewrite whole_graph_unfold. Intros n. apply prop_right. apply (the_same_root_union g g1 g2 x y y_root); auto.
    assert (x_root = y_root). {
      assert (Int.signed (Int.repr x_root) = Int.signed (Int.repr y_root)) by (rewrite H6; auto). rewrite !Int.signed_repr in H10; auto.
      - apply (bounded_vertex _ (Z.of_nat n)); auto. destruct H5. apply reachable_foot_valid in H5. rewrite <- H8 in H5; auto.
      - apply (bounded_vertex _ (Z.of_nat n)); auto. destruct H4. destruct H2. apply reachable_foot_valid in H2. rewrite H4 in H2. rewrite <- H8 in H2; auto.
    } subst y_root. apply H2.
  - forward. entailer!.
  - rewrite whole_graph_unfold. Intros n.
    assert (0 <= x_root < Z.of_nat n) by (destruct H4; destruct H2; apply reachable_foot_valid in H2; rewrite H4 in H2; rewrite <- H7 in H2; auto).
    assert (H_XROOT_BOUND: 0 <= x_root < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length; apply H9). forward.
    rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list; auto. simpl id. unfold vgamma2cdata at 1. unfold vgamma at 1.
    unfold UnionFindGraph.vgamma. assert (0 <= y_root < Z.of_nat n) by (destruct H5; apply reachable_foot_valid in H5; rewrite <- H7 in H5; auto).
    assert (H_YROOT_BOUND: 0 <= y_root < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length; apply H10). forward.
    rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list; auto. unfold vgamma2cdata at 1. unfold vgamma at 1. unfold UnionFindGraph.vgamma. simpl id.
    forward_if
      (EX g': Graph,
       PROP (uf_union g x y g')
       LOCAL (temp _yRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))); temp _xRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root))));
              temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root)); temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
              temp _y (Vint (Int.repr y)))
       SEP (whole_graph sh g' subsets)).
    + Opaque Znth. forward. rewrite Znth_nat_inc_list; auto.
      assert (weak_valid g2 y_root) by (right; rewrite <- H7; auto). assert (vvalid g2 x_root) by (rewrite <- H7; auto).
      assert (~ reachable g2 y_root x_root) by (intro; destruct H5; specialize (H15 _ H14); auto).
      apply (exp_right (Graph_gen_redirect_parent g2 x_root y_root H12 H13 H14)). unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma.
      Opaque vgamma2cdata. Opaque vgamma. entailer !. Transparent vgamma. Transparent vgamma2cdata.
      * apply (diff_root_union_1 g g1 g2 x y x_root y_root); auto.
      * rewrite whole_graph_unfold. apply (exp_right n). rewrite <- upd_Znth_Graph_redirect_parent; auto. entailer!.
    + assert (weak_valid g2 x_root) by (right; rewrite <- H7; auto). assert (vvalid g2 y_root) by (rewrite <- H7; auto).
      assert (~ reachable g2 x_root y_root) by (intro; rewrite (uf_equiv_root_the_same g1 g2) in H2; auto; destruct H2; specialize (H15 _ H14); auto).
      forward_if
        (EX g': Graph,
         PROP (uf_union g x y g')
         LOCAL (temp _yRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))); temp _xRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root))));
                temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root)); temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
                temp _y (Vint (Int.repr y)))
         SEP (whole_graph sh g' subsets)).
      * forward. rewrite Znth_nat_inc_list; auto. apply (exp_right (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14)). unfold vgamma2cdata at 2. unfold vgamma at 2.
        unfold UnionFindGraph.vgamma. Opaque vgamma2cdata. Opaque vgamma. entailer!. Transparent vgamma. Transparent vgamma2cdata.
        -- apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
        -- rewrite whole_graph_unfold. apply (exp_right n). rewrite <- upd_Znth_Graph_redirect_parent; auto. entailer!.
      * forward. rewrite Znth_nat_inc_list; auto. remember (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14) as g3.
        assert (uf_union g x y g3) by (rewrite Heqg3; simpl; apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto).
        unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma. forward. apply (exp_right (Graph_vgen g3 x_root ((vlabel (lg_gg g2) x_root) + 1)%nat)).
        Opaque vgamma2cdata. Opaque vgamma. entailer !. Transparent vgamma. Transparent vgamma2cdata.
        rewrite upd_Znth_diff; auto; [|rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto..]. rewrite Znth_nat_inc_list; auto.
        rewrite whole_graph_unfold. apply (exp_right n). entailer !.
        cut (upd_Znth x_root (upd_Znth y_root (map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg g2) x0)) (nat_inc_list n))
                                        (Vint (Int.repr x_root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))))
                       (let (x0, _) := vgamma2cdata (vgamma (lg_gg g2) x_root) in x0, Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root) + 1))) =
             map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg (Graph_vgen (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14) x_root
                                                                        (vlabel (lg_gg g2) x_root + 1)%nat)) x0)) (nat_inc_list n)); intros.
        -- rewrite <- H23. apply derives_refl.
        -- clear -H6 H9 H10. assert (Zlength (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g2) m)) (nat_inc_list n)) = Z.of_nat n) by
               (rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto).
           assert (Zlength (upd_Znth y_root (map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg g2) x0)) (nat_inc_list n))
                                     (Vint (Int.repr x_root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root))))) = Z.of_nat n) by
               (rewrite upd_Znth_Zlength; auto; rewrite <- H in H10; auto). apply (list_eq_Znth _ _ n).
           ++ rewrite <- (Nat2Z.id n) at 2. rewrite <- Zlength_length. 2: omega. rewrite <- H in H10, H9. rewrite upd_Znth_Zlength; auto; rewrite upd_Znth_Zlength; auto.
           ++ rewrite list_length_map, nat_inc_list_length; auto.
           ++ intros. rewrite Znth_nat_inc_list; auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto.
              rewrite Znth_nat_inc_list; auto. unfold vgamma2cdata, vgamma, UnionFindGraph.vgamma. simpl.
              unfold graph_gen.updateEdgeFunc, graph_gen.update_vlabel, EquivDec.equiv_dec, Z_EqDec, zeq. destruct (Z.eq_dec j x_root).
              ** subst j. destruct (Z.eq_dec y_root x_root). 1: exfalso; auto. destruct (Z.eq_dec x_root x_root). 2: exfalso; apply n1; auto. do 3 f_equal.
                 transitivity (Z.succ (Z.of_nat (vlabel (lg_gg g2) x_root))). 2: rewrite <- Nat2Z.inj_succ; f_equal; unfold Z_EqDec; omega. rewrite Z.add_1_r. auto.
              ** destruct (Z.eq_dec j y_root).
                 --- subst j. destruct (Z.eq_dec y_root y_root). 2: exfalso; apply n1; auto. destruct (Z.eq_dec x_root y_root). 1: exfalso; auto. destruct (Z_lt_dec x_root 0).
                     1: destruct H9; exfalso; omega. auto.
                 --- destruct (Z.eq_dec y_root j). 1: exfalso; apply n1; auto. destruct (Z.eq_dec x_root j). 1: exfalso; auto. auto.
    + Intros g'. forward. apply (exp_right g'). entailer!.
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2017 - Pset 4 *)

Require Import Frap.

Set Implicit Arguments.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

(* A copy of the parallel transition-system combinator from TransitionSystem.v *)

Record threaded_state shared private := {
  Shared : shared;
  Private : private
}.

Inductive parallel1 shared private1 private2
  (init1 : threaded_state shared private1 -> Prop)
  (init2 : threaded_state shared private2 -> Prop)
  : threaded_state shared (private1 * private2) -> Prop :=
| Pinit : forall sh pr1 pr2,
  init1 {| Shared := sh; Private := pr1 |}
  -> init2 {| Shared := sh; Private := pr2 |}
  -> parallel1 init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.

Inductive parallel2 shared private1 private2
          (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
          (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
          : threaded_state shared (private1 * private2)
            -> threaded_state shared (private1 * private2) -> Prop :=
| Pstep1 : forall sh pr1 pr2 sh' pr1',
  (* First thread gets to run. *)
  step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1', pr2) |}
| Pstep2 : forall sh pr1 pr2 sh' pr2',
  (* Second thread gets to run. *)
  step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1, pr2') |}.

Definition parallel shared private1 private2
           (sys1 : trsys (threaded_state shared private1))
           (sys2 : trsys (threaded_state shared private2)) := {|
  Initial := parallel1 sys1.(Initial) sys2.(Initial);
  Step := parallel2 sys1.(Step) sys2.(Step)
|}.

(* Now, we come to the main problem to be solved: prove the correctness of a
 * famous locking algorithm, applied to the particular example of incrementing a
 * counter from the lecture code.  Instead of assuming that a correct
 * implementation of locking is provided to us, we provide our own, on top of
 * basic atomic read/write operations on shared variables!
 * Specifically, we use Peterson's Algorithm, which you can read about here:
 *   https://en.wikipedia.org/wiki/Peterson%27s_algorithm *)

(** Instantiated to our setting, it's equivalent to this code.

  bool flag[2] = {false, false};
  bool turn = false;
  int global = 0;

  oneThread(me, other) {
    int local;

    flag[me] = true;
    turn = other;
    while (flag[other] && turn == other);
    local = global;
    global = local + 1;
    flag[me] = false;
  }

  The idea is that we run "oneThread(0, 1)" in parallel with "oneThread(1, 0)".
  After both threads finish, "global" had better be holding the value 2.
*)

(* We formalize local states with this type, standing for the different points
 * before, between, and after the lines of code, in order.  Note that, as with
 * the example from lecture, only the [Write] state needs to store the value of
 * variable "local". *)
Inductive increment_program :=
| SetFlag : increment_program
| SetTurn : increment_program
| ReadFlag : increment_program
| ReadTurn : increment_program
| Read : increment_program
| Write : nat -> increment_program
| UnsetFlag : increment_program
| Done : increment_program.

(* Record of global variables *)
Record inc_state := {
  Flag1 : bool;
  Flag2 : bool;
  (* The two cells of the "flag" array, represented as separate variables *)
  Turn : bool;
  (* Global variable "turn", representing with "false" for 0 and "true" for 1 *)
  Global : nat
  (* Global variable "global", represented more directly *)
}.

Definition increment_state := threaded_state inc_state increment_program.

(* The next two relations translate the single-thread code in a tedious way. *)

Inductive increment_init : increment_state -> Prop :=
| IncInit :
  increment_init {| Shared := {| Flag1 := false; Flag2 := false; Turn := false; Global := O |};
                    Private := SetFlag |}.

Inductive increment_step : bool (* This Boolean is set iff parameter "me" would
                                 * be 1. *)
                           -> increment_state -> increment_state -> Prop :=
| IncSetFlag1 : forall fl1 fl2 tu g,
  increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetFlag |}
                 {| Shared := {| Flag1 := true; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetTurn |}
| IncSetFlag2 : forall fl1 fl2 tu g,
  increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := true; Turn := tu; Global := g |};
                    Private := SetTurn |}
| IncSetTurn : forall am2 fl1 fl2 tu g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadFlag |}
| IncReadFlag1True : forall fl1 fl2 tu g,
  fl2 = true
  -> increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadTurn |}
| IncReadFlag1False : forall fl1 fl2 tu g,
  fl2 = false
  -> increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
| IncReadFlag2True : forall fl1 fl2 tu g,
  fl1 = true
  -> increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadTurn |}
| IncReadFlag2False : forall fl1 fl2 tu g,
  fl1 = false
  -> increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
| IncReadTurnTrue : forall am2 fl1 fl2 g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadFlag |}
| IncReadTurnFalse : forall am2 fl1 fl2 g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := am2; Global := g |};
                    Private := ReadTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := am2; Global := g |};
                    Private := Read |}
| IncRead : forall am2 fl1 fl2 tu g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Write g |}
| IncWrite : forall am2 fl1 fl2 tu g v,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Write v |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := S v |};
                    Private := UnsetFlag |}
| IncUnsetFlag1 : forall fl1 fl2 tu g,
  increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := UnsetFlag |}
                 {| Shared := {| Flag1 := false; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Done |}
| IncUnsetFlag2 : forall fl1 fl2 tu g,
  increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := UnsetFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := false; Turn := tu; Global := g |};
                    Private := Done |}.

Definition increment_sys am2 := {|
  Initial := increment_init;
  Step := increment_step am2
|}.

Definition increment2_sys := parallel (increment_sys false) (increment_sys true).

(* The natural correctness condition, looking nearly the same as for the example
 * from lecture *)
Definition increment2_correct (s : threaded_state inc_state (increment_program * increment_program)) :=
  s.(Private) = (Done, Done)
  -> s.(Shared).(Global) = 2.

Module Type S.
  Axiom increment2_ok :
    invariantFor increment2_sys increment2_correct.
End S.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C X X0 G Gprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ X0 A /\ (wd_ X0 C /\ (wd_ X B /\ (wd_ X C /\ (col_ X G A /\ (col_ X0 G B /\ (col_ X Gprime A /\ (col_ X0 Gprime B /\ (col_ C X0 A /\ (col_ C X B /\ col_ A X B))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.