Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.
(* Require Import MultiSigWallet.Proofs.CPDT. *)

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

(* Require Import MultiSigWallet.MultiSigWalletFunctions.
Module MultiSigWalletFunctions := MultiSigWalletFunctions XTypesSig StateMonadSig.
Import MultiSigWalletFunctions. *)

(*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.

Import DePoolSpec.
Import LedgerClass.
Import SolidityNotations.
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 10.

Require Import depoolContract.Lib.Tactics.

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.

Existing Instance monadStateT.
Existing Instance monadStateStateT.

Lemma ledgerEq: forall (l l': Ledger) ,
(*  A l = A l' ->
 C l = C l' ->  *)
 Ledger_ι_DebugDePool l = Ledger_ι_DebugDePool l' ->
 Ledger_ι_ValidatorBase l = Ledger_ι_ValidatorBase l' ->
 Ledger_ι_ProxyBase l = Ledger_ι_ProxyBase l' ->
 Ledger_ι_ConfigParamsBase l = Ledger_ι_ConfigParamsBase l' ->
 Ledger_ι_ParticipantBase l = Ledger_ι_ParticipantBase l' ->
 Ledger_ι_DePoolHelper l = Ledger_ι_DePoolHelper l' ->
 Ledger_ι_Errors l = Ledger_ι_Errors l' ->
 Ledger_ι_InternalErrors l = Ledger_ι_InternalErrors l' ->
 Ledger_ι_DePoolLib l = Ledger_ι_DePoolLib l' ->
 Ledger_ι_DePoolProxyContract l = Ledger_ι_DePoolProxyContract l' ->
 Ledger_ι_RoundsBase l = Ledger_ι_RoundsBase l' ->
 Ledger_ι_DePoolContract l = Ledger_ι_DePoolContract l' ->
 Ledger_ι_DePool l = Ledger_ι_DePool l' ->
 Ledger_ι_Participant l = Ledger_ι_Participant l' ->
 Ledger_ι_TestElector l = Ledger_ι_TestElector l' ->
 Ledger_ι_VMState l = Ledger_ι_VMState l' ->
 Ledger_ι_LocalState l = Ledger_ι_LocalState l' -> l = l' .
Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

Lemma DePoolLib_ι_ParticipantEq : forall (l l': DePoolLib_ι_Participant) ,
 DePoolLib_ι_Participant_ι_roundQty l = DePoolLib_ι_Participant_ι_roundQty l' ->
 DePoolLib_ι_Participant_ι_reward l = DePoolLib_ι_Participant_ι_reward l' ->
 DePoolLib_ι_Participant_ι_haveVesting l = DePoolLib_ι_Participant_ι_haveVesting l' ->
 DePoolLib_ι_Participant_ι_haveLock l = DePoolLib_ι_Participant_ι_haveLock l' ->
 DePoolLib_ι_Participant_ι_reinvest l = DePoolLib_ι_Participant_ι_reinvest l' ->
 DePoolLib_ι_Participant_ι_withdrawValue l = DePoolLib_ι_Participant_ι_withdrawValue l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma DePoolLib_ι_RequestEq : forall (l l': DePoolLib_ι_Request) ,
 DePoolLib_ι_Request_ι_queryId l = DePoolLib_ι_Request_ι_queryId l' ->
 DePoolLib_ι_Request_ι_validatorKey l = DePoolLib_ι_Request_ι_validatorKey l' ->
 DePoolLib_ι_Request_ι_stakeAt l = DePoolLib_ι_Request_ι_stakeAt l' ->
 DePoolLib_ι_Request_ι_maxFactor l = DePoolLib_ι_Request_ι_maxFactor l' ->
 DePoolLib_ι_Request_ι_adnlAddr l = DePoolLib_ι_Request_ι_adnlAddr l' ->
 DePoolLib_ι_Request_ι_signature l = DePoolLib_ι_Request_ι_signature l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma ErrorsEq : forall (l l': Errors) ,
 Errors_ι_IS_NOT_OWNER l = Errors_ι_IS_NOT_OWNER l' ->
 Errors_ι_IS_NOT_PROXY l = Errors_ι_IS_NOT_PROXY l' ->
 Errors_ι_IS_EXT_MSG l = Errors_ι_IS_EXT_MSG l' ->
 Errors_ι_IS_NOT_VALIDATOR l = Errors_ι_IS_NOT_VALIDATOR l' ->
 Errors_ι_DEPOOL_IS_CLOSED l = Errors_ι_DEPOOL_IS_CLOSED l' ->
 Errors_ι_NO_SUCH_PARTICIPANT l = Errors_ι_NO_SUCH_PARTICIPANT l' ->
 Errors_ι_IS_NOT_DEPOOL l = Errors_ι_IS_NOT_DEPOOL l' ->
 Errors_ι_INVALID_ROUND_STEP l = Errors_ι_INVALID_ROUND_STEP l' ->
 Errors_ι_INVALID_QUERY_ID l = Errors_ι_INVALID_QUERY_ID l' ->
 Errors_ι_IS_NOT_ELECTOR l = Errors_ι_IS_NOT_ELECTOR l' ->
 Errors_ι_IS_NOT_OWNER_OR_SELF_CALL l = Errors_ι_IS_NOT_OWNER_OR_SELF_CALL l' ->
 Errors_ι_BAD_STAKES l = Errors_ι_BAD_STAKES l' ->
 Errors_ι_CONSTRUCTOR_NO_PUBKEY l = Errors_ι_CONSTRUCTOR_NO_PUBKEY l' ->
 Errors_ι_VALIDATOR_IS_NOT_STD l = Errors_ι_VALIDATOR_IS_NOT_STD l' ->
 Errors_ι_BAD_PART_REWARD l = Errors_ι_BAD_PART_REWARD l' ->
 Errors_ι_BAD_MINIMUM_BALANCE l = Errors_ι_BAD_MINIMUM_BALANCE l' ->
 Errors_ι_BAD_PROXY_CODE l = Errors_ι_BAD_PROXY_CODE l' ->
 Errors_ι_NOT_WORKCHAIN0 l = Errors_ι_NOT_WORKCHAIN0 l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma InternalErrorsEq : forall (l l': InternalErrors) ,
 InternalErrors_ι_ERROR507 l = InternalErrors_ι_ERROR507 l' ->
 InternalErrors_ι_ERROR508 l = InternalErrors_ι_ERROR508 l' ->
 InternalErrors_ι_ERROR509 l = InternalErrors_ι_ERROR509 l' ->
 InternalErrors_ι_ERROR511 l = InternalErrors_ι_ERROR511 l' ->
 InternalErrors_ι_ERROR513 l = InternalErrors_ι_ERROR513 l' ->
 InternalErrors_ι_ERROR516 l = InternalErrors_ι_ERROR516 l' ->
 InternalErrors_ι_ERROR517 l = InternalErrors_ι_ERROR517 l' ->
 InternalErrors_ι_ERROR518 l = InternalErrors_ι_ERROR518 l' ->
 InternalErrors_ι_ERROR519 l = InternalErrors_ι_ERROR519 l' ->
 InternalErrors_ι_ERROR521 l = InternalErrors_ι_ERROR521 l' ->
 InternalErrors_ι_ERROR522 l = InternalErrors_ι_ERROR522 l' ->
 InternalErrors_ι_ERROR523 l = InternalErrors_ι_ERROR523 l' ->
 InternalErrors_ι_ERROR524 l = InternalErrors_ι_ERROR524 l' ->
 InternalErrors_ι_ERROR525 l = InternalErrors_ι_ERROR525 l' ->
 InternalErrors_ι_ERROR526 l = InternalErrors_ι_ERROR526 l' ->
 InternalErrors_ι_ERROR527 l = InternalErrors_ι_ERROR527 l' ->
 InternalErrors_ι_ERROR528 l = InternalErrors_ι_ERROR528 l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma DePoolLibEq : forall (l l': DePoolLib) ,
 DePoolLib_ι_PROXY_FEE l = DePoolLib_ι_PROXY_FEE l' ->
 DePoolLib_ι_MIN_PROXY_BALANCE l = DePoolLib_ι_MIN_PROXY_BALANCE l' ->
 DePoolLib_ι_PROXY_CONSTRUCTOR_FEE l = DePoolLib_ι_PROXY_CONSTRUCTOR_FEE l' ->
 DePoolLib_ι_DEPOOL_CONSTRUCTOR_FEE l = DePoolLib_ι_DEPOOL_CONSTRUCTOR_FEE l' ->
 DePoolLib_ι_ELECTOR_FEE l = DePoolLib_ι_ELECTOR_FEE l' ->
 DePoolLib_ι_MAX_UINT64 l = DePoolLib_ι_MAX_UINT64 l' ->
 DePoolLib_ι_MAX_TIME l = DePoolLib_ι_MAX_TIME l' ->
 DePoolLib_ι_ELECTOR_UNFREEZE_LAG l = DePoolLib_ι_ELECTOR_UNFREEZE_LAG l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma DePoolEq : forall (l l': DePoolContract) ,
 DePoolContract_ι_STAKE_FEE l = DePoolContract_ι_STAKE_FEE l' ->
 DePoolContract_ι_RET_OR_REINV_FEE l = DePoolContract_ι_RET_OR_REINV_FEE l' ->
 DePoolContract_ι_MAX_MSGS_PER_TR l = DePoolContract_ι_MAX_MSGS_PER_TR l' ->
 DePoolContract_ι_MAX_QTY_OF_OUT_ACTIONS l = DePoolContract_ι_MAX_QTY_OF_OUT_ACTIONS l' ->
 DePoolContract_ι_VALUE_FOR_SELF_CALL l = DePoolContract_ι_VALUE_FOR_SELF_CALL l' ->
 DePoolContract_ι_PROXY_CODE_HASH l = DePoolContract_ι_PROXY_CODE_HASH l' ->
 DePoolContract_ι_STATUS_SUCCESS l = DePoolContract_ι_STATUS_SUCCESS l' ->
 DePoolContract_ι_STATUS_STAKE_TOO_SMALL l = DePoolContract_ι_STATUS_STAKE_TOO_SMALL l' ->
 DePoolContract_ι_STATUS_DEPOOL_CLOSED l = DePoolContract_ι_STATUS_DEPOOL_CLOSED l' ->
 DePoolContract_ι_STATUS_NO_PARTICIPANT l = DePoolContract_ι_STATUS_NO_PARTICIPANT l' ->
 DePoolContract_ι_STATUS_PARTICIPANT_HAVE_ALREADY_VESTING l = DePoolContract_ι_STATUS_PARTICIPANT_HAVE_ALREADY_VESTING l' ->
 DePoolContract_ι_STATUS_WITHDRAWAL_PERIOD_GREATER_TOTAL_PERIOD l = DePoolContract_ι_STATUS_WITHDRAWAL_PERIOD_GREATER_TOTAL_PERIOD l' ->
 DePoolContract_ι_STATUS_TOTAL_PERIOD_MORE_18YEARS l = DePoolContract_ι_STATUS_TOTAL_PERIOD_MORE_18YEARS l' ->
 DePoolContract_ι_STATUS_WITHDRAWAL_PERIOD_IS_ZERO l = DePoolContract_ι_STATUS_WITHDRAWAL_PERIOD_IS_ZERO l' ->
 DePoolContract_ι_STATUS_TOTAL_PERIOD_IS_NOT_DIVED_BY_WITHDRAWAL_PERIOD l = DePoolContract_ι_STATUS_TOTAL_PERIOD_IS_NOT_DIVED_BY_WITHDRAWAL_PERIOD l' ->
 DePoolContract_ι_STATUS_PERIOD_PAYMENT_IS_ZERO l = DePoolContract_ι_STATUS_PERIOD_PAYMENT_IS_ZERO l' ->
 DePoolContract_ι_STATUS_REMAINING_STAKE_LESS_THAN_MINIMAL l = DePoolContract_ι_STATUS_REMAINING_STAKE_LESS_THAN_MINIMAL l' ->
 DePoolContract_ι_STATUS_PARTICIPANT_HAVE_ALREADY_LOCK l = DePoolContract_ι_STATUS_PARTICIPANT_HAVE_ALREADY_LOCK l' ->
 DePoolContract_ι_STATUS_TRANSFER_AMOUNT_IS_TOO_BIG l = DePoolContract_ι_STATUS_TRANSFER_AMOUNT_IS_TOO_BIG l' ->
 DePoolContract_ι_STATUS_TRANSFER_SELF l = DePoolContract_ι_STATUS_TRANSFER_SELF l' ->
 DePoolContract_ι_STATUS_TRANSFER_TO_OR_FROM_VALIDATOR l = DePoolContract_ι_STATUS_TRANSFER_TO_OR_FROM_VALIDATOR l' ->
 DePoolContract_ι_STATUS_FEE_TOO_SMALL l = DePoolContract_ι_STATUS_FEE_TOO_SMALL l' ->
 DePoolContract_ι_STATUS_INVALID_ADDRESS l = DePoolContract_ι_STATUS_INVALID_ADDRESS l' ->
 DePoolContract_ι_STATUS_INVALID_BENEFICIARY l = DePoolContract_ι_STATUS_INVALID_BENEFICIARY l' ->
 DePoolContract_ι_STATUS_NO_ELECTION_ROUND l = DePoolContract_ι_STATUS_NO_ELECTION_ROUND l' ->
 DePoolContract_ι_STATUS_INVALID_ELECTION_ID l = DePoolContract_ι_STATUS_INVALID_ELECTION_ID l' ->
 DePoolContract_ι_m_poolClosed l = DePoolContract_ι_m_poolClosed l' ->
 DePoolContract_ι_m_minStake l = DePoolContract_ι_m_minStake l' ->
 DePoolContract_ι_m_validatorAssurance l = DePoolContract_ι_m_validatorAssurance l' ->
 DePoolContract_ι_m_participantRewardFraction l = DePoolContract_ι_m_participantRewardFraction l' ->
 DePoolContract_ι_m_validatorRewardFraction l = DePoolContract_ι_m_validatorRewardFraction l' ->
 DePoolContract_ι_m_balanceThreshold l = DePoolContract_ι_m_balanceThreshold l' ->
 DePoolContract_ι_CRITICAL_THRESHOLD l = DePoolContract_ι_CRITICAL_THRESHOLD l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma ValidatorBaseEq : forall (l l': ValidatorBase) ,
 ValidatorBase_ι_m_validatorWallet l = ValidatorBase_ι_m_validatorWallet l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma ProxyBaseEq : forall (l l': ProxyBase) ,
 ProxyBase_ι_m_proxies l = ProxyBase_ι_m_proxies l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma ParticipantBaseEq : forall (l l': ParticipantBase) ,
 ParticipantBase_ι_m_participants l = ParticipantBase_ι_m_participants l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma DePoolHelperEq : forall (l l': DePoolHelper) ,
 DePoolHelper_ι_TICKTOCK_FEE l = DePoolHelper_ι_TICKTOCK_FEE l' ->
 DePoolHelper_ι__timerRate l = DePoolHelper_ι__timerRate l' ->
 DePoolHelper_ι__fwdFee l = DePoolHelper_ι__fwdFee l' ->
 DePoolHelper_ι__epsilon l = DePoolHelper_ι__epsilon l' ->
 DePoolHelper_ι_m_dePoolPool l = DePoolHelper_ι_m_dePoolPool l' ->
 DePoolHelper_ι_m_poolHistory l = DePoolHelper_ι_m_poolHistory l' ->
 DePoolHelper_ι_m_timer l = DePoolHelper_ι_m_timer l' ->
 DePoolHelper_ι_m_timeout l = DePoolHelper_ι_m_timeout l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma DePoolProxyContractEq : forall (l l': DePoolProxyContract) ,
 DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL l = DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL l' ->
 DePoolProxyContract_ι_ERROR_BAD_BALANCE l = DePoolProxyContract_ι_ERROR_BAD_BALANCE l' ->
 DePoolProxyContract_ι_m_dePool l = DePoolProxyContract_ι_m_dePool l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma InvestParamsEq : forall (l l': RoundsBase_ι_InvestParams) ,
 RoundsBase_ι_InvestParams_ι_amount l = RoundsBase_ι_InvestParams_ι_amount l' ->
 RoundsBase_ι_InvestParams_ι_lastWithdrawalTime l = RoundsBase_ι_InvestParams_ι_lastWithdrawalTime l' ->
 RoundsBase_ι_InvestParams_ι_withdrawalPeriod l = RoundsBase_ι_InvestParams_ι_withdrawalPeriod l' ->
 RoundsBase_ι_InvestParams_ι_withdrawalValue l = RoundsBase_ι_InvestParams_ι_withdrawalValue l' ->
 RoundsBase_ι_InvestParams_ι_owner l = RoundsBase_ι_InvestParams_ι_owner l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma StakeValueEq : forall (l l': RoundsBase_ι_StakeValue) ,
 RoundsBase_ι_StakeValue_ι_ordinary l = RoundsBase_ι_StakeValue_ι_ordinary l' ->
 RoundsBase_ι_StakeValue_ι_vesting l = RoundsBase_ι_StakeValue_ι_vesting l' ->
 RoundsBase_ι_StakeValue_ι_lock l = RoundsBase_ι_StakeValue_ι_lock l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

Lemma RoundEq : forall (l l': RoundsBase_ι_Round) ,
 RoundsBase_ι_Round_ι_id l = RoundsBase_ι_Round_ι_id l' ->
 RoundsBase_ι_Round_ι_supposedElectedAt l = RoundsBase_ι_Round_ι_supposedElectedAt l' ->
 RoundsBase_ι_Round_ι_unfreeze l = RoundsBase_ι_Round_ι_unfreeze l' ->
 RoundsBase_ι_Round_ι_stakeHeldFor l = RoundsBase_ι_Round_ι_stakeHeldFor l' ->
 RoundsBase_ι_Round_ι_vsetHashInElectionPhase l = RoundsBase_ι_Round_ι_vsetHashInElectionPhase l' ->
 RoundsBase_ι_Round_ι_step l = RoundsBase_ι_Round_ι_step l' ->
 RoundsBase_ι_Round_ι_completionReason l = RoundsBase_ι_Round_ι_completionReason l' ->
 RoundsBase_ι_Round_ι_stake l = RoundsBase_ι_Round_ι_stake l' ->
 RoundsBase_ι_Round_ι_recoveredStake l = RoundsBase_ι_Round_ι_recoveredStake l' ->
 RoundsBase_ι_Round_ι_unused l = RoundsBase_ι_Round_ι_unused l' ->
 RoundsBase_ι_Round_ι_isValidatorStakeCompleted l = RoundsBase_ι_Round_ι_isValidatorStakeCompleted l' ->
 RoundsBase_ι_Round_ι_grossReward l = RoundsBase_ι_Round_ι_grossReward l' ->
 RoundsBase_ι_Round_ι_rewards l = RoundsBase_ι_Round_ι_rewards l' ->
 RoundsBase_ι_Round_ι_participantQty l = RoundsBase_ι_Round_ι_participantQty l' ->
 RoundsBase_ι_Round_ι_stakes l = RoundsBase_ι_Round_ι_stakes l' ->
 RoundsBase_ι_Round_ι_validatorStake l = RoundsBase_ι_Round_ι_validatorStake l' ->
 RoundsBase_ι_Round_ι_validatorRemainingStake l = RoundsBase_ι_Round_ι_validatorRemainingStake l' ->
 RoundsBase_ι_Round_ι_handledStakesAndRewards l = RoundsBase_ι_Round_ι_handledStakesAndRewards l' ->
 RoundsBase_ι_Round_ι_validatorRequest l = RoundsBase_ι_Round_ι_validatorRequest l' ->
 RoundsBase_ι_Round_ι_elector l = RoundsBase_ι_Round_ι_elector l' ->
 RoundsBase_ι_Round_ι_proxy l = RoundsBase_ι_Round_ι_proxy l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma LastRoundInfoEq : forall (l l': DePool_ι_LastRoundInfo) ,
 DePool_ι_LastRoundInfo_ι_supposedElectedAt l = DePool_ι_LastRoundInfo_ι_supposedElectedAt l' ->
 DePool_ι_LastRoundInfo_ι_participantRewardFraction l = DePool_ι_LastRoundInfo_ι_participantRewardFraction l' ->
 DePool_ι_LastRoundInfo_ι_validatorRewardFraction l = DePool_ι_LastRoundInfo_ι_validatorRewardFraction l' ->
 DePool_ι_LastRoundInfo_ι_participantQty l = DePool_ι_LastRoundInfo_ι_participantQty l' ->
 DePool_ι_LastRoundInfo_ι_roundStake l = DePool_ι_LastRoundInfo_ι_roundStake l' ->
 DePool_ι_LastRoundInfo_ι_validatorWallet l = DePool_ι_LastRoundInfo_ι_validatorWallet l' ->
 DePool_ι_LastRoundInfo_ι_validatorPubkey l = DePool_ι_LastRoundInfo_ι_validatorPubkey l' ->
 DePool_ι_LastRoundInfo_ι_validatorAssurance l = DePool_ι_LastRoundInfo_ι_validatorAssurance l' ->
 DePool_ι_LastRoundInfo_ι_reward l = DePool_ι_LastRoundInfo_ι_reward l' ->
 DePool_ι_LastRoundInfo_ι_reason l = DePool_ι_LastRoundInfo_ι_reason l' ->
 DePool_ι_LastRoundInfo_ι_isDePoolClosed l = DePool_ι_LastRoundInfo_ι_isDePoolClosed l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

Lemma RoundsBaseEq : forall (l l': RoundsBase) ,
 RoundsBase_ι_m_rounds l = RoundsBase_ι_m_rounds l' ->
 RoundsBase_ι_m_roundQty l = RoundsBase_ι_m_roundQty l' ->
 RoundsBase_ι_lastRoundInfo l = RoundsBase_ι_lastRoundInfo l' -> l = l' .
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma RoundsBase_ι_TruncatedRoundEq : forall (l l': RoundsBase_ι_TruncatedRound) ,
 RoundsBase_ι_TruncatedRound_ι_id l = RoundsBase_ι_TruncatedRound_ι_id l' ->
 RoundsBase_ι_TruncatedRound_ι_supposedElectedAt l = RoundsBase_ι_TruncatedRound_ι_supposedElectedAt l' ->
 RoundsBase_ι_TruncatedRound_ι_unfreeze l = RoundsBase_ι_TruncatedRound_ι_unfreeze l' ->
 RoundsBase_ι_TruncatedRound_ι_stakeHeldFor l = RoundsBase_ι_TruncatedRound_ι_stakeHeldFor l' ->
 RoundsBase_ι_TruncatedRound_ι_vsetHashInElectionPhase l = RoundsBase_ι_TruncatedRound_ι_vsetHashInElectionPhase l' ->
 RoundsBase_ι_TruncatedRound_ι_step l = RoundsBase_ι_TruncatedRound_ι_step l' ->
 RoundsBase_ι_TruncatedRound_ι_completionReason l = RoundsBase_ι_TruncatedRound_ι_completionReason l' ->
 RoundsBase_ι_TruncatedRound_ι_stake l = RoundsBase_ι_TruncatedRound_ι_stake l' ->
 RoundsBase_ι_TruncatedRound_ι_recoveredStake l = RoundsBase_ι_TruncatedRound_ι_recoveredStake l' ->
 RoundsBase_ι_TruncatedRound_ι_unused l = RoundsBase_ι_TruncatedRound_ι_unused l' ->
 RoundsBase_ι_TruncatedRound_ι_isValidatorStakeCompleted l = RoundsBase_ι_TruncatedRound_ι_isValidatorStakeCompleted l' ->
 RoundsBase_ι_TruncatedRound_ι_rewards l = RoundsBase_ι_TruncatedRound_ι_rewards l' ->
 RoundsBase_ι_TruncatedRound_ι_participantQty l = RoundsBase_ι_TruncatedRound_ι_participantQty l' ->
 RoundsBase_ι_TruncatedRound_ι_validatorStake l = RoundsBase_ι_TruncatedRound_ι_validatorStake l' ->
 RoundsBase_ι_TruncatedRound_ι_validatorRemainingStake l = RoundsBase_ι_TruncatedRound_ι_validatorRemainingStake l' ->
 RoundsBase_ι_TruncatedRound_ι_handledStakesAndRewards l = RoundsBase_ι_TruncatedRound_ι_handledStakesAndRewards l' ->  l = l'.
 Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

 Lemma VMStateEq : forall (l l':  VMState ) ,

	VMState_ι_pubkey l =
	VMState_ι_pubkey l' ->

	VMState_ι_msg_pubkey l =
	VMState_ι_msg_pubkey l' ->

	VMState_ι_now l =
	VMState_ι_now l' ->

	VMState_ι_logstr l =
	VMState_ι_logstr l' ->

	VMState_ι_balance l =
	VMState_ι_balance l' ->

	VMState_ι_address l =
	VMState_ι_address l' ->

	VMState_ι_ltime l =
	VMState_ι_ltime l' ->

	VMState_ι_code l =
	VMState_ι_code l' ->
 VMState_ι_events l = VMState_ι_events l' ->
 VMState_ι_savedDePoolContracts l = VMState_ι_savedDePoolContracts l' ->
 VMState_ι_msg_sender l = VMState_ι_msg_sender l' ->
 VMState_ι_msg_value l = VMState_ι_msg_value l' ->
 VMState_ι_messages l = VMState_ι_messages l' ->
 VMState_ι_msg_data l = VMState_ι_msg_data l' ->
 VMState_ι_transactions l = VMState_ι_transactions l' ->
 l = l' .
Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.

Lemma LocalStateEq : forall (l l':  LocalState ) ,
LocalState_ι__addStakes_Л_participant l = LocalState_ι__addStakes_Л_participant  l' ->
LocalState_ι__addStakes_Л_round  l = LocalState_ι__addStakes_Л_round   l' ->
LocalState_ι__addStakes_Л_sv l = LocalState_ι__addStakes_Л_sv  l' ->

LocalState_ι__returnOrReinvestForParticipant_Л_attachedValue l = LocalState_ι__returnOrReinvestForParticipant_Л_attachedValue  l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_newLock  l = LocalState_ι__returnOrReinvestForParticipant_Л_newLock  l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_newStake  l = LocalState_ι__returnOrReinvestForParticipant_Л_newStake  l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_newVesting  l = LocalState_ι__returnOrReinvestForParticipant_Л_newVesting   l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_participant  l = LocalState_ι__returnOrReinvestForParticipant_Л_participant  l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_reward  l = LocalState_ι__returnOrReinvestForParticipant_Л_reward  l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_round0  l = LocalState_ι__returnOrReinvestForParticipant_Л_round0  l' ->

LocalState_ι__returnOrReinvest_Л_chunkSize  l = LocalState_ι__returnOrReinvest_Л_chunkSize  l' ->
LocalState_ι__returnOrReinvest_Л_round2  l = LocalState_ι__returnOrReinvest_Л_round2  l' ->
LocalState_ι__returnOrReinvest_Л_round0  l = LocalState_ι__returnOrReinvest_Л_round0   l' ->
LocalState_ι__returnOrReinvest_Л_startIndex  l = LocalState_ι__returnOrReinvest_Л_startIndex  l' ->

LocalState_ι_addVestingOrLock_Л_participant  l = LocalState_ι_addVestingOrLock_Л_participant  l' ->
LocalState_ι_addVestingOrLock_Л_l  l = LocalState_ι_addVestingOrLock_Л_l  l' ->
LocalState_ι_addVestingOrLock_Л_v l = LocalState_ι_addVestingOrLock_Л_v  l' ->

LocalState_ι_completeRound_Л_i  l = LocalState_ι_completeRound_Л_i  l' ->
LocalState_ι_completeRound_Л_msgQty  l = LocalState_ι_completeRound_Л_msgQty  l' ->
LocalState_ι_completeRound_Л_restParticipant  l = LocalState_ι_completeRound_Л_restParticipant   l' ->

LocalState_ι_cutWithdrawalValueAndActivateStake_Л_p  l = LocalState_ι_cutWithdrawalValueAndActivateStake_Л_p  l' ->
LocalState_ι_cutWithdrawalValueAndActivateStake_Л_withdrawal  l = LocalState_ι_cutWithdrawalValueAndActivateStake_Л_withdrawal  l' ->

LocalState_ι_getRounds_Л_pair  l = LocalState_ι_getRounds_Л_pair  l' ->
LocalState_ι_getRounds_Л_rounds l = LocalState_ι_getRounds_Л_rounds  l' ->

LocalState_ι_onFailToRecoverStake_Л_round  l = LocalState_ι_onFailToRecoverStake_Л_round  l' ->

LocalState_ι_onSuccessToRecoverStake_Л_round  l = LocalState_ι_onSuccessToRecoverStake_Л_round  l' ->

LocalState_ι_terminator_Л_round1  l = LocalState_ι_terminator_Л_round1  l' ->

LocalState_ι_transferStakeInOneRound_Л_deltaDestinationStake  l = LocalState_ι_transferStakeInOneRound_Л_deltaDestinationStake  l' ->
LocalState_ι_transferStakeInOneRound_Л_destinationParticipant  l = LocalState_ι_transferStakeInOneRound_Л_destinationParticipant  l' ->
LocalState_ι_transferStakeInOneRound_Л_newSourceStake  l = LocalState_ι_transferStakeInOneRound_Л_newSourceStake  l' ->
LocalState_ι_transferStakeInOneRound_Л_round  l = LocalState_ι_transferStakeInOneRound_Л_round  l' ->
LocalState_ι_transferStakeInOneRound_Л_sourceParticipant  l = LocalState_ι_transferStakeInOneRound_Л_sourceParticipant  l' ->
LocalState_ι_transferStakeInOneRound_Л_sourceStake  l = LocalState_ι_transferStakeInOneRound_Л_sourceStake  l' ->

LocalState_ι_transferStake_Л_amount  l = LocalState_ι_transferStake_Л_amount  l' ->
LocalState_ι_transferStake_Л_destParticipant  l = LocalState_ι_transferStake_Л_destParticipant  l' ->
LocalState_ι_transferStake_Л_pair  l = LocalState_ι_transferStake_Л_pair l' ->
LocalState_ι_transferStake_Л_rounds  l = LocalState_ι_transferStake_Л_rounds  l' ->
LocalState_ι_transferStake_Л_srcParticipant  l = LocalState_ι_transferStake_Л_srcParticipant  l' ->
LocalState_ι_transferStake_Л_totalSrcStake  l = LocalState_ι_transferStake_Л_totalSrcStake l' ->
LocalState_ι_transferStake_Л_transferred  l = LocalState_ι_transferStake_Л_transferred  l' ->

LocalState_ι_updateRound2_Л_round2  l = LocalState_ι_updateRound2_Л_round2  l' ->

LocalState_ι_updateRounds_Л_round0  l = LocalState_ι_updateRounds_Л_round0  l' ->
LocalState_ι_updateRounds_Л_round1  l = LocalState_ι_updateRounds_Л_round1  l' ->
LocalState_ι_updateRounds_Л_round2  l = LocalState_ι_updateRounds_Л_round2  l' ->

LocalState_ι_withdrawStakeInPoolingRound_Л_participant  l = LocalState_ι_withdrawStakeInPoolingRound_Л_participant  l' ->
LocalState_ι_withdrawStakeInPoolingRound_Л_round  l = LocalState_ι_withdrawStakeInPoolingRound_Л_round  l' ->
LocalState_ι_withdrawStakeInPoolingRound_Л_sv  l = LocalState_ι_withdrawStakeInPoolingRound_Л_sv  l' ->
LocalState_ι_withdrawStakeInPoolingRound_Л_targetAmount  l = LocalState_ι_withdrawStakeInPoolingRound_Л_targetAmount  l' ->

LocalState_ι_constructor5_Л_ok l = LocalState_ι_constructor5_Л_ok l' ->

LocalState_ι__returnOrReinvestForParticipant_Л_round2 l = LocalState_ι__returnOrReinvestForParticipant_Л_round2 l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_lostFunds l = LocalState_ι__returnOrReinvestForParticipant_Л_lostFunds l' ->
LocalState_ι__returnOrReinvestForParticipant_Л_params l = LocalState_ι__returnOrReinvestForParticipant_Л_params l' ->
LocalState_ι_totalParticipantFunds_Л_stakes l = LocalState_ι_totalParticipantFunds_Л_stakes l' ->
LocalState_ι_totalParticipantFunds_Л_pair l = LocalState_ι_totalParticipantFunds_Л_pair l' ->
LocalState_ι_updateRounds_Л_roundPre0 l = LocalState_ι_updateRounds_Л_roundPre0 l' ->
LocalState_ι_cutDePoolReward_Л_reward l = LocalState_ι_cutDePoolReward_Л_reward l' ->
LocalState_ι_onBounce_Л_optRound l = LocalState_ι_onBounce_Л_optRound l' ->
LocalState_ι_startRoundCompleting_Л_round l = LocalState_ι_startRoundCompleting_Л_round l' ->
       l = l' .
Proof.
 intros. destruct l. destruct l'.
 simpl in H. simpl in * |-.
 subst. auto.
Qed.


Require StlcFix.SpecSyntax.
Require StlcIso.SpecSyntax.
Require Import StlcIso.SpecTyping.
Require Import StlcIso.LemmasTyping.
Require Import StlcFix.SpecTyping.
Require Import StlcFix.LemmasTyping.
Require Import StlcFix.CanForm.
Require Import StlcFix.SpecEvaluation.
Require Import StlcFix.LemmasEvaluation.
(* Require Import StlcIso.SpecScoping. *)
(* Require Import StlcIso.LemmasScoping. *)
(* Require Import StlcIso.DecideEval. *)
Require Import UValFI.UVal.
Require Import LogRelFI.PseudoType.
Require Import LogRelFI.LemmasPseudoType.
Require Import LogRelFI.LR.
Require Import LogRelFI.LemmasLR.
Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Wf_nat.
Require Import Db.Lemmas.
(* Require Import StlcIso.Fix. *)

Local Ltac crushLRMatch :=
  match goal with
    | [ |- _ ∧ _ ] => split
    | [ H : valrel _ _ ?τ ?ts ?tu   |- OfType ?τ ?ts ?tu ] => refine (valrel_implies_OfType H)
    | [ H : valrel ?d _ ?τ ?ts ?tu  |- termrel ?d _ ?τ ?ts ?tu ] => apply valrel_in_termrel
    | [ H : valrel ?d ?w ?τ ?ts ?tu |- valrel ?d ?w' ?τ ?ts ?tu ] => refine (valrel_mono _ H); lia
    | [ H : valrel _ _ _ ?ts _ |- F.Value ?ts ] => refine (proj1 (valrel_implies_Value H))
    | [ H : valrel _ _ _ _ ?tu |- I.Value ?tu ] => refine (proj2 (valrel_implies_Value H))
    | [ H : OfType _ ?ts _ |- F.Value ?ts ] => refine (proj1 (OfType_implies_Value H))
    | [ H : OfType _ _ ?tu |- I.Value ?tu ] => refine (proj2 (OfType_implies_Value H))
    | [ |- valrel _ _ _ _ _] => rewrite -> valrel_fixp; unfold valrel'
    | [ |- context[ lev ]] => unfold lev
    | [ H : context[ lev ] |- _ ] => unfold lev in *
  end.

Local Ltac crush :=
  repeat
    (try assumption;
     simpl;
     destruct_conjs;
     subst*;
     repeat crushLRMatch;
     crushOfType;
     repeat apply validTy_fxToIs;
     F.crushTyping;
     I.crushTyping;
     trivial;
     try reflexivity
    ); try lia; eauto.

Section ValueRelation.

  (* Lambda abstraction *)
  Lemma valrel_lambda {d τ' τ ts tu w} :
    ValidPTy τ → ValidPTy τ' →
    OfType (ptarr τ' τ) (F.abs (repEmul τ') ts) (I.abs (fxToIs τ') tu) →
    (∀ w' vs vu, w' < w → (d = dir_gt -> I.size vu <= w') -> valrel d w' τ' vs vu → termrel d w' τ (ts [beta1 vs]) (tu [beta1 vu])) →
    valrel d w (ptarr τ' τ) (F.abs (repEmul τ') ts) (I.abs (fxToIs τ') tu).
  Proof.
    crush.
    repeat eexists; crush.
    now eapply H2.
  Qed.

  (* Unit *)
  Lemma valrel_unit {d w} :
    valrel d w ptunit F.unit I.unit.
  Proof. crush. Qed.

  (* True *)
  Lemma valrel_true {d w} :
    valrel d w ptbool F.true I.true.
  Proof. crush. Qed.

  (* False *)
  Lemma valrel_false {d w} :
    valrel d w ptbool F.false I.false.
  Proof. crush. Qed.

  (* Pair *)
  Lemma valrel_pair'' {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ ts₁ tu₁ →
    OfType τ₂ ts₂ tu₂ →
    (forall w', w' < w → valrel d w' τ₁ ts₁ tu₁) →
    (forall w', w' < w → valrel d w' τ₂ ts₂ tu₂) →
    valrel d w (ptprod τ₁ τ₂) (F.pair ts₁ ts₂) (I.pair tu₁ tu₂).
  Proof.
    crush.
  Qed.

  Lemma valrel_pair' {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₁ ts₁ tu₁ →
    valrel d w τ₂ ts₂ tu₂ →
    valrel d (S w) (ptprod τ₁ τ₂) (F.pair ts₁ ts₂) (I.pair tu₁ tu₂).
  Proof. crush. Qed.

  Lemma valrel_pair {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₁ ts₁ tu₁ →
    valrel d w τ₂ ts₂ tu₂ →
    valrel d w (ptprod τ₁ τ₂) (F.pair ts₁ ts₂) (I.pair tu₁ tu₂).
  Proof. crush. Qed.

  Lemma valrel_0_pair {d τ₁ τ₂ vs₁ vu₁ vs₂ vu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ vs₁ vu₁ →
    OfType τ₂ vs₂ vu₂ →
    valrel d 0 (ptprod τ₁ τ₂) (F.pair vs₁ vs₂) (I.pair vu₁ vu₂).
  Proof. crush. Qed.

  (* Inl *)
  Lemma valrel_0_inl {d τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ vs vu →
    valrel d 0 (ptsum τ₁ τ₂) (F.inl vs) (I.inl vu).
  Proof. crush. Qed.

  Lemma valrel_inl {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₁ vs vu →
    valrel d w (ptsum τ₁ τ₂) (F.inl vs) (I.inl vu).
  Proof. crush. Qed.

  Lemma valrel_inl' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₁ vs vu →
    valrel d (S w) (ptsum τ₁ τ₂) (F.inl vs) (I.inl vu).
  Proof. crush. Qed.

  Lemma valrel_inl'' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ vs vu →
    (∀ w', w' < w → valrel d w' τ₁ vs vu) →
    valrel d w (ptsum τ₁ τ₂) (F.inl vs) (I.inl vu).
  Proof. crush. Qed.

  (* Inr *)
  Lemma valrel_0_inr {d τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₂ vs vu →
    valrel d 0 (ptsum τ₁ τ₂) (F.inr vs) (I.inr vu).
  Proof. crush. Qed.

  Lemma valrel_inr {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₂ vs vu →
    valrel d w (ptsum τ₁ τ₂) (F.inr vs) (I.inr vu).
  Proof. crush. Qed.

  Lemma valrel_inr' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₂ vs vu →
    valrel d (S w) (ptsum τ₁ τ₂) (F.inr vs) (I.inr vu).
  Proof. crush. Qed.

  Lemma valrel_inr'' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₂ vs vu →
    (∀ w', w' < w → valrel d w' τ₂ vs vu) →
    valrel d w (ptsum τ₁ τ₂) (F.inr vs) (I.inr vu).
  Proof. crush. Qed.

  (* double check with Marco that these hypothesis are kosher *)
  Lemma valrel_unk {d w n p vu τ} :
    OfType (pEmulDV n p τ) (unkUVal n) vu → p = imprecise →
    valrel d w (pEmulDV n p τ) (unkUVal n) vu.
  Proof.
    intros eq vvu; subst.
    repeat crushLRMatch.
    - unfold OfType, OfTypeStlcFix, OfTypeStlcIso in *; split; simpl; split; try trivial;
      eauto using unkUVal_Value, unkUValT; crush.
    - destruct n; [|left]; eauto.
  Qed.

  Lemma valrel_inUnit {d w n p vs vu} :
    vs = F.unit ∧ vu = I.unit →
    valrel d w (pEmulDV (S n) p I.tunit) (F.inl vs) vu.
  Proof.
    destruct 1 as [? ?]; subst.
    repeat crushLRMatch.
    - assert (⟪ F.empty ⊢ F.unit : F.tunit ⟫) by constructor.
      unfold OfType, OfTypeStlcFix, OfTypeStlcIso; split; simpl; crush.
    - right. exists F.unit. crush.
  Qed.

  Lemma valrel_inUnit' {d w n p vs vu} :
    valrel d w ptunit vs vu →
    valrel d w (pEmulDV (S n) p I.tunit) (F.inl vs) vu.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    destruct vr as [_ vr].
    simpl in vr.
    apply valrel_inUnit.
    crush.
  Qed.

  Lemma valrel_inBool {d w n p vs vu} :
    (vs = F.true ∧ vu = I.true) ∨ (vs = F.false ∧ vu = I.false) →
    valrel d w (pEmulDV (S n) p I.tbool) (inBool n vs) vu.
  Proof.
    intros eqs;
    repeat crushLRMatch.
    - assert (⟪ F.empty ⊢ vs : F.tbool ⟫);
      destruct eqs as [[? ?]|[? ?]]; subst; eauto with typing;
      unfold OfType, OfTypeStlcFix, OfTypeStlcIso; simpl;
      eauto using inBool_Value, inBoolT with typing.
    - right. exists vs. unfold is_inl. eauto.
  Qed.

  Lemma valrel_inBool' {d w n p vs vu} :
    valrel d w ptbool vs vu →
    valrel d w (pEmulDV (S n) p I.tbool) (inBool n vs) vu.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    destruct vr as [_ vr].
    simpl in vr.
    apply valrel_inBool.
    crush.
  Qed.

  Lemma valrel_inProd {d w n p τ₁ τ₂ vs₁ vs₂ vu₁ vu₂} :
    OfType (pEmulDV n p τ₁) vs₁ vu₁ →
    OfType (pEmulDV n p τ₂) vs₂ vu₂ →
    (forall w', w' < w → valrel d w' (pEmulDV n p τ₁) vs₁ vu₁) →
    (forall w', w' < w → valrel d w' (pEmulDV n p τ₂) vs₂ vu₂) →
    valrel d w (pEmulDV (S n) p (I.tprod τ₁ τ₂)) (inProd n (F.pair vs₁ vs₂)) (I.pair vu₁ vu₂).
  Proof.
    intros ot₁ ot₂ vr₁ vr₂.
    destruct (OfType_implies_Value ot₁).
    destruct (OfType_implies_Value ot₂).
    repeat crushLRMatch.
    - unfold OfType, OfTypeStlcFix, OfTypeStlcIso in *; crush.
    - right. exists (F.pair vs₁ vs₂). unfold is_inl; cbn.
      crush.
  Qed.

  Lemma valrel_inProd' {d w n p τ₁ τ₂ vs₁ vs₂ vu₁ vu₂} :
    (valrel d w (pEmulDV n p τ₁) vs₁ vu₁) →
    (valrel d w (pEmulDV n p τ₂) vs₂ vu₂) →
    valrel d (S w) (pEmulDV (S n) p (I.tprod τ₁ τ₂)) (inProd n (F.pair vs₁ vs₂)) (I.pair vu₁ vu₂).
  Proof.
    intros vr₁ vr₂.
    eapply valrel_inProd; crush.
 Qed.

  Lemma valrel_inProd'' {d w n p τ₁ τ₂ vs vu} :
    valrel d w (ptprod (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu →
    valrel d w (pEmulDV (S n) p (I.tprod τ₁ τ₂)) (inProd n vs) vu.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    destruct vr as [val vr].
    simpl in vr; unfold prod_rel in vr.
    destruct vs; try contradiction.
    destruct vu; try contradiction.
    destruct val as ((? & ?) & (? & ?)).
    destruct vr as (? & ?).
    simpl in H0.
    simpl in H2.
    F.stlcCanForm.
    I.stlcCanForm.
    destruct H as (? & ?).
    eapply valrel_inProd; crush.
  Qed.

  Lemma valrel_inSum_l {d w n p vs vs' vu vu' τl τr} :
    ValidTy τl -> ValidTy τr ->
    OfType (pEmulDV n p τl) vs vu →
    (forall w', w' < w → valrel d w' (pEmulDV n p τl) vs vu) →
    vs' = F.inl vs ∧ vu' = I.inl vu →
    valrel d w (pEmulDV (S n) p (I.tsum τl τr)) (F.inl vs') vu'.
  Proof.
    intros vτl vτr ot vr eq.
    destruct (OfType_implies_Value ot).
    assert (F.Value vs') by (crush).
    assert (I.Value vu') by (crush).
    assert ⟪ F.empty ⊢ vs' : UValFI n τl ⊎ UValFI n τr ⟫
      by (destruct ot as [[? ?] ?]; crush).
    assert ⟪ I.empty i⊢ vu' : I.tsum τl τr ⟫
      by (destruct ot as [? [? ?]]; crush).
    repeat crushLRMatch.
    - crush.
    - right. exists vs'. split.
      + unfold is_inl; reflexivity.
      + crush.
  Qed.

  Lemma valrel_inSum_r {d w n p vs vs' vu vu' τl τr} :
    ValidTy τl -> ValidTy τr ->
    OfType (pEmulDV n p τr) vs vu →
    (forall w', w' < w → valrel d w' (pEmulDV n p τr) vs vu) →
    vs' = F.inr vs ∧ vu' = I.inr vu →
    valrel d w (pEmulDV (S n) p (I.tsum τl τr)) (F.inl vs') vu'.
  Proof.
    intros vτl vτr ot vr eq.
    destruct (OfType_implies_Value ot).
    assert (F.Value vs') by (crush).
    assert (I.Value vu') by (crush).
    assert ⟪ F.empty ⊢ vs' : UValFI n τl ⊎ UValFI n τr ⟫
      by (destruct ot as [[? ?] ?]; crush).
    assert ⟪ I.empty i⊢ vu' : I.tsum τl τr ⟫
      by (destruct ot as [? [? ?]]; crush).
    repeat crushLRMatch.
    - crush.
    - right. exists vs'. split.
      + unfold is_inl; reflexivity.
      + crush.
  Qed.

  (* Lemma valrel_inSum {d w n p vs vs' vu vu' τ τ'} : *)
  (*   OfType (pEmulDV n p (I.tsum τ τ')) vs vu → *)
  (*   (forall w', w' < w → valrel d w' (pEmulDV n p (I.tsum τ τ')) vs vu) → *)
  (*   (vs' = F.inl vs ∧ vu' = I.inl vu) ∨ (vs' = F.inr vs ∧ vu' = I.inr vu) → *)
  (*   valrel d w (pEmulDV (S n) p (I.tsum τ τ')) (F.inl vs') vu'. *)
  (* Proof. *)
  (*   intros ot vr eqs. *)
  (*   destruct (OfType_implies_Value ot). *)
  (*   assert (F.Value vs') by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   assert (I.Value vu') by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   destruct ot as [[? ?] [? ?]]. *)
  (*   assert ⟪ F.empty ⊢ vs' : (UValFI n τ) ⊎ (UValFI n τ') ⟫. *)
  (*   destruct eqs as [[? ?]|[? ?]]; crush. *)
  (*     by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   assert ⟨ 0 ⊢ vu' ⟩ *)
  (*          by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   crush. *)
  (*   right. exists vs'. right. right. right. left. *)
  (*   destruct eqs as [[? ?]|[? ?]]; crush. *)
  (* Qed. *)

  Lemma valrel_inSum' {d w n p vs vs' vu vu' τl τr} :
    ValidTy τl -> ValidTy τr ->
    (
      valrel d w (pEmulDV n p τl) vs vu
      ∧ (vs' = F.inl vs ∧ vu' = I.inl vu)
    ) ∨ (
      valrel d w (pEmulDV n p τr) vs vu
      ∧ (vs' = F.inr vs ∧ vu' = I.inr vu)
    ) →
    valrel d (S w) (pEmulDV (S n) p (I.tsum τl τr)) (F.inl vs') vu'.
  Proof.
    intros vτl vτr.
    destruct 1;
    destruct H;
    [refine (valrel_inSum_l _ _ _ _ H0) | refine (valrel_inSum_r _ _ _ _ H0)];
    crush.
  Qed.

  Lemma valrel_inSum'' {d w n p vs vu τl τr} :
    ValidTy τl -> ValidTy τr ->
    valrel d w (ptsum (pEmulDV n p τl) (pEmulDV n p τr)) vs vu →
    valrel d w (pEmulDV (S n) p (I.tsum τl τr)) (F.inl vs) vu.
  Proof.
   intros vτl vτr vr.
   rewrite valrel_fixp in vr.
   destruct vr as [val vr].
   destruct val as ((? & ?) & ? & ?).
   simpl in H0.
   simpl in H2.
   F.stlcCanForm;
   I.stlcCanForm;
     simpl in vr; unfold sum_rel in vr;
     try contradiction;
     [eapply valrel_inSum_l | eapply valrel_inSum_r]; auto;
     crush.
  Qed.

  Lemma valrel_inArr {d w n p vs vu τ₁ τ₂} :
    valrel d w (ptarr (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu →
    valrel d w (pEmulDV (S n) p (I.tarr τ₁ τ₂)) (F.inl vs) vu.
  Proof.
    intros vr.
    crush.
    - destruct (valrel_implies_OfType vr) as [[_ ?] _].
      eauto.
    - destruct (valrel_implies_OfType vr) as (_ & _ & ?).
      crush.
    - right. exists vs. split.
      + crush.
      + rewrite valrel_fixp in vr; destruct vr as [[_ ?] vrarr].
        crush.
  Qed.

  (* Lemma valrel_0_inRec {d n p vs vu τ} : *)
  (*   OfType (pEmulDV (S n) p τ[beta1 (I.trec τ)]) vs vu → *)
  (*   valrel d 0 (pEmulDV (S n) p τ[beta1 (I.trec τ)]) vs vu. *)
  (* Proof. *)
  (*   intro ot. *)
  (*   destruct ot as [[? ?] [? ?]]. *)
  (*   crush. *)
  (*   unfold UValFI in H0. *)
  (*   F.stlcCanForm. *)
  (*   right. *)
  (*   2: destruct p; [right | left; auto]. *)
  (*   revert H2 H4. *)
  (*   generalize τ[beta1 (I.trec τ)] as τ'. *)
  (*   intros τ' H2 H4. *)
  (*   dependent destruction τ'; cbn. *)
  (*   exists x. *)
  (*   crush. *)
  (*   exists unit. *)
  (*   F.stlcCanForm. *)
  (*   I.stlcCanForm. *)
  (*   crush. *)
  (*   exists x. *)
  (*   crush. *)
  (*   unfold sum_rel. *)
  (*   F.stlcCanForm. *)
  (*   dependent induction n. *)
  (*   unfold UValFI in H0. *)

  (* Lemma valrel_inRec {d w n p vs vu τ} : *)
  (*   valrel d w (pEmulDV n p τ[beta1 (I.trec τ)]) vs vu → *)
  (*   valrel d w (pEmulDV (S n) p (I.trec τ)) (F.inl vs) (I.fold_ vu). *)
  (* Proof. *)
  (*   intros vr. *)
  (*   crush. *)
  (*   - destruct (valrel_implies_OfType vr) as [[_ ?] _]. *)
  (*     eauto. *)
  (*   - destruct (valrel_implies_OfType vr) as (_ & _ & ?). *)
  (*     eauto. *)
  (*   - right. exists vs. split. *)
  (*     + crush. *)
  (*     + exists vu. split. reflexivity. *)
  (*       destruct (valrel_implies_OfType vr) as [[? ?] [? ?]]. *)
  (*       dependent induction n. *)
  (*       intro w'; *)
  (*       rewrite valrel_fixp in vr; destruct vr as [[_ ?] vrrec]; *)
  (*       crush. *)
  (*       dependent induction τ; crush. *)
  (* Qed. *)
  Lemma valrel_0_inRec {n dir p vs vu τ} :
    OfType (pEmulDV (S n) p (I.trec τ)) (F.inl vs) (fold_ vu) →
    valrel dir 0 (pEmulDV (S n) p (I.trec τ)) (F.inl vs) (fold_ vu).
  Proof.
    rewrite valrel_fixp;
    unfold valrel';
      intros ot;
      split;
      destruct ot as [[? ?] [? ?]];
      crush;
      right;
      exists vs; crush;
      exists vu; crush.
  Qed.

  Lemma valrel_inRec {d w n p vs vu τ} :
    ValidTy (trec τ) →
    valrel d w (pEmulDV n p τ[beta1 (I.trec τ)]) vs vu →
    valrel d (S w) (pEmulDV (S n) p (I.trec τ)) (F.inl vs) (I.fold_ vu).
  Proof.
    intros [clτ crτ] vr.
    crush.
    - destruct (valrel_implies_OfType vr) as [[_ ?] _].
      eauto.
    - destruct (valrel_implies_OfType vr) as (_ & _ & ?).
      eauto.
    - now constructor.
    - right. exists vs. split.
      + crush.
      + exists vu. split. reflexivity.
        destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
        dependent induction n.
        intro w';
        rewrite valrel_fixp in vr; destruct vr as [[_ ?] vrrec];
        crush.
        dependent induction τ; crush.
  Qed.

  Lemma valrel_inRec' {d w n p vs vu τ} :
    ValidTy (trec τ) →
    valrel d w (pEmulDV n p τ[beta1 (I.trec τ)]) vs vu →
    valrel d w (pEmulDV (S n) p (I.trec τ)) (F.inl vs) (I.fold_ vu).
  Proof.
    eauto using valrel_inRec, valrel_mono with arith.
  Qed.
End ValueRelation.

Ltac valrelIntro :=
  match goal with
    | |- valrel _ _ (ptarr ?τ _) (F.abs (repEmul ?τ) _) (I.abs (fxToIs ?τ) _) => eapply valrel_lambda
    | |- valrel _ _ ptunit F.unit I.unit => apply valrel_unit
    (* | |- valrel _ _ ptbool F.true I.true => apply valrel_true *)
    (* | |- valrel _ _ ptbool F.false I.false => apply valrel_false *)
    (* | |- valrel _ ?w (ptprod _ _) (F.pair _ _) (I.pair _ _) => *)
    (*   match w with *)
    (*     | O   => apply valrel_0_pair *)
    (*     | S _ => apply valrel_pair' *)
    (*     | _   => apply valrel_pair *)
    (*   end *)
    | |- valrel _ ?w (ptsum _ _) (F.inl _) (I.inl _) =>
      match w with
        | O   => apply valrel_0_inl
        | S _ => apply valrel_inl'
        | _   => apply valrel_inl
      end
    | |- valrel _ ?w (ptsum _ _) (F.inr _) (I.inr _) =>
      match w with
        | O   => apply valrel_0_inr
        | S _ => apply valrel_inr'
        | _   => apply valrel_inr
      end
    | [ H : valrel ?d _ ?τ ?ts ?tu |- valrel ?d _ ?τ ?ts ?tu ] =>
      refine (valrel_mono _ H); try lia
  end.

Section TermRelation.

  (* Eval context *)
  (* related terms plugged in related contexts are still related (lemma 20 in TR) *)
  Lemma termrel_ectx {d w τ₁ τ₂ ts Cs tu Cu} (eCs : F.ECtx Cs) (eCu : I.ECtx Cu) :
    termrel d w τ₁ ts tu →
    (∀ w' (fw' : w' ≤ w) vs vu, valrel d w' τ₁ vs vu → termrel d w' τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    termrel d w τ₂ (F.pctx_app ts Cs) (I.pctx_app tu Cu).
  Proof.
    intros tr cr Cs' Cu' eCs' eCu' cr'.
    rewrite <- F.pctx_cat_app.
    rewrite <- I.pctx_cat_app.
    refine (tr (F.pctx_cat Cs Cs') (I.pctx_cat Cu Cu') _ _ _); eauto using F.ectx_cat, I.ectx_cat.
    intros w' fw' vs vu vr.
    destruct (valrel_implies_Value vr) as [vvs vvu].
    rewrite -> F.pctx_cat_app.
    rewrite -> I.pctx_cat_app.
    refine (cr w' fw' vs vu vr Cs' Cu' eCs' eCu' _).
    refine (contrel_mono fw' cr').
  Qed.

  Lemma termrel_ectx' {d w τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termrel d w τ₁ ts tu →
    (∀ w' (fw' : w' ≤ w) vs vu, valrel d w' τ₁ vs vu → termrel d w' τ₂ (F.pctx_app vs Cs) (I.pctx_app vu Cu)) →
    ts' = F.pctx_app ts Cs →
    tu' = I.pctx_app tu Cu →
    F.ECtx Cs → I.ECtx Cu →
    termrel d w τ₂ ts' tu'.
  Proof.
    intros; subst; eauto using termrel_ectx.
  Qed.

  (* Application *)
  Lemma valrel_app {d w τ₁ τ₂ vs₁ vs₂ vu₁ vu₂} :
    valrel d w (ptarr τ₁ τ₂) vs₁ vu₁ →
    valrel d w τ₁ vs₂ vu₂ →
    termrel d w τ₂ (F.app vs₁ vs₂) (I.app vu₁ vu₂).
  Proof.
    (* destruct assumptions *)
    intros vr₁ vr₂.
    rewrite -> valrel_fixp in vr₁.
    destruct vr₁ as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptarr in ot.
    destruct ot as (tsb & tub & eqs & equ & _); subst.
    destruct (valrel_implies_Value vr₂) as [vvs₂ vvu₂].

    eapply termrel_size_right'.
    intros szvs.

    (* beta-reduce *)
    assert (es : F.eval (F.app (F.abs (repEmul τ₁) tsb) vs₂) (tsb [beta1 vs₂])) by
        (refine (F.eval_ctx₀ F.phole _ I); refine (F.eval_beta vvs₂)).
    assert (es1 : F.evaln (F.app (F.abs (repEmul τ₁) tsb) vs₂) (tsb [beta1 vs₂]) 1) by
        (unfold F.evaln; eauto with eval; lia).
    assert (eu : I.eval (I.app (I.abs (fxToIs τ₁) tub) vu₂) (tub [beta1 vu₂])) by
        (refine (I.eval_ctx₀ I.phole _ I); refine (I.eval_beta vvu₂)).
    assert (eu1 : I.evaln (I.app (I.abs (fxToIs τ₁) tub) vu₂) (tub [beta1 vu₂]) 1) by
        (unfold I.evaln; eauto with eval).
    destruct w; try apply termrel_zero.
    refine (termrel_antired w es1 eu1 _ _ _); unfold lev in *; simpl; try lia.

    (* use assumption for function body *)
    destruct hyp as (tsb' & tub' & τ₁' & τ₂' & eq1 & eq2 & hyp).
    inversion eq1; inversion eq2; subst.
    eapply hyp; try lia; eauto using valrel_mono.
    intros ->.
    specialize (szvs eq_refl).
    cbn in szvs.
    lia.
  Qed.

  Lemma termrel_app {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    termrel d w (ptarr τ₁ τ₂) ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ₁ ts₂ tu₂) →
    termrel d w τ₂ (F.app ts₁ ts₂) (I.app tu₁ tu₂).
  Proof.
    intros tr₁ tr₂.
    change (F.app _ _) with (F.pctx_app ts₁ (F.papp₁ F.phole ts₂)).
    change (I.app _ _) with (I.pctx_app tu₁ (I.papp₁ I.phole tu₂)).
    refine (termrel_ectx _ _ tr₁ _); crush.
    destruct (valrel_implies_Value H) as [vvs vvu].
    change (F.app _ _) with (F.pctx_app ts₂ (F.papp₂ vs F.phole)).
    change (I.app _ _) with (I.pctx_app tu₂ (I.papp₂ vu I.phole)).
    refine (termrel_ectx _ _ (tr₂ w' fw')  _); crush.
    refine (valrel_app _ H0); crush.
  Qed.

  Lemma termrel_ite {d w τ ts₁ ts₂ ts₃ tu₁ tu₂ tu₃} :
    termrel d w ptbool ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ ts₂ tu₂) →
    (∀ w', w' ≤ w → termrel d w' τ ts₃ tu₃) →
    termrel d w τ (F.ite ts₁ ts₂ ts₃) (I.ite tu₁ tu₂ tu₃).
  Proof.
    intros tr₁ tr₂ tr₃.

    (* first evaluate ts₁ and tu₁ *)
    change (F.ite _ _ _) with (F.pctx_app ts₁ (F.pite₁ F.phole ts₂ ts₃)).
    change (I.ite _ _ _) with (I.pctx_app tu₁ (I.pite₁ I.phole tu₂ tu₃)).
    refine (termrel_ectx _ _ tr₁ _); crush.

    (* then evaluate the if-statement *)
    rewrite -> valrel_fixp in H.
    destruct H as [ot [[? ?]|[? ?]]]; subst; clear ot.
    - assert (F.eval (F.ite F.true ts₂ ts₃) ts₂) by
          (apply (F.eval_ctx₀ F.phole); try refine (F.eval_ite_true u u); simpl; intuition).
      assert (esn : F.evaln (F.ite F.true ts₂ ts₃) ts₂ 1).
      { unfold F.evaln; eauto with eval. }
      assert (I.eval (I.ite I.true tu₂ tu₃) tu₂).
      { apply (I.eval_eval₀); try refine I.eval_ite_true; simpl; intuition. }
      assert (eun : I.evaln (I.ite I.true tu₂ tu₃) tu₂ 1) by (unfold I.evaln; eauto with eval).
      refine (termrel_antired w' esn eun _ _ _); crush.
    - assert (F.eval (F.ite F.false ts₂ ts₃) ts₃) by
          (apply (F.eval_ctx₀ F.phole); try refine (F.eval_ite_false _ _); simpl; intuition).
      assert (esn : F.evaln (F.ite F.false ts₂ ts₃) ts₃ 1) by (unfold F.evaln; eauto with eval).
      assert (I.eval (I.ite I.false tu₂ tu₃) tu₃) by
          (apply (I.eval_eval₀); try refine I.eval_ite_false; simpl; intuition).
      assert (eun : I.evaln (I.ite I.false tu₂ tu₃) tu₃ 1) by (unfold I.evaln; eauto with eval).
      refine (termrel_antired w' esn eun _ _ _); crush.
  Qed.

  (* Pair *)
  Lemma termrel_pair {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w τ₁ ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ₂ ts₂ tu₂) →
    termrel d w (ptprod τ₁ τ₂) (F.pair ts₁ ts₂) (I.pair tu₁ tu₂).
  Proof.
    intros vτ₁ vτ₂ tr₁ tr₂.
    change (F.pair _ _) with (F.pctx_app ts₁ (F.ppair₁ F.phole ts₂)).
    change (I.pair _ _) with (I.pctx_app tu₁ (I.ppair₁ I.phole tu₂)).
    refine (termrel_ectx _ _ tr₁ _); crush.
    destruct (valrel_implies_Value H) as [vvs₂ vvu₂].
    change (F.pair _ _) with (F.pctx_app ts₂ (F.ppair₂ vs F.phole)).
    change (I.pair _ _) with (I.pctx_app tu₂ (I.ppair₂ vu I.phole)).
    refine (termrel_ectx _ _ (tr₂ w' fw')  _); crush.
    eauto using valrel_in_termrel, valrel_mono, valrel_pair.
  Qed.

  (* Proj₁ *)
  Lemma termrel_proj₁ {d w τ₁ τ₂ ts tu} :
    termrel d w (ptprod τ₁ τ₂) ts tu →
    termrel d w τ₁ (F.proj₁ ts) (I.proj₁ tu).
  Proof.
    intros tr.

    (* first evaluate ts and tu *)
    change (F.proj₁ _) with (F.pctx_app ts (F.pproj₁ F.phole)).
    change (I.proj₁ _) with (I.pctx_app tu (I.pproj₁ I.phole)).
    refine (termrel_ectx _ _ tr _); crush.

    (* then evaluate the projection *)
    rewrite -> valrel_fixp in H.
    destruct H as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as [vr₁ vr₂].

    assert (F.eval (F.proj₁ (F.pair vs₁ vs₂)) vs₁) by
        (apply (F.eval_ctx₀ F.phole); try refine (F.eval_proj₁ _ _); simpl; intuition).
    assert (esn : F.evaln (F.proj₁ (F.pair vs₁ vs₂)) vs₁ 1) by (unfold F.evaln; eauto with eval).
    assert (I.eval (I.proj₁ (I.pair vu₁ vu₂)) vu₁) by
        (apply (I.eval_eval₀); try refine (I.eval_proj₁ _ _); simpl; intuition).
    assert (eun : I.evaln (I.proj₁ (I.pair vu₁ vu₂)) vu₁ 1) by (unfold I.evaln; eauto with eval).
    destruct w'; try apply termrel_zero.
    refine (termrel_antired w' esn eun _ _ _); crush.

    (* then conclude *)
    apply valrel_in_termrel.
    apply vr₁; intuition; lia.
  Qed.

  Lemma termrel₀_proj₁ {d w τ₁ τ₂ ts tu} :
    valrel d (S w) (ptprod τ₁ τ₂) ts tu →
    termrel₀ d w τ₁ (F.proj₁ ts) (I.proj₁ tu).
  Proof.
    intros vr.

    rewrite -> valrel_fixp in vr.
    destruct vr as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as [vr₁ vr₂].

    assert (F.eval (F.proj₁ (F.pair vs₁ vs₂)) vs₁) by
        (apply (F.eval_ctx₀ F.phole); try refine (F.eval_proj₁ _ _); simpl; crush).
    assert (esn : clos_refl_trans_1n F.Tm F.eval (F.proj₁ (F.pair vs₁ vs₂)) vs₁) by (eauto with eval).
    assert (I.eval (I.proj₁ (I.pair vu₁ vu₂)) vu₁) by
        (apply (I.eval_eval₀); try refine (I.eval_proj₁ _ _); simpl; intuition).
    assert (eun : I.evalStar (I.proj₁ (I.pair vu₁ vu₂)) vu₁)
      by (unfold I.evalStar; eauto with eval).
    refine (termrel₀_antired_star esn eun _); crush.

    eapply valrel_in_termrel₀.
    apply vr₁; crush.
  Qed.

  Lemma termrel₀_proj₂ {d w τ₁ τ₂ ts tu} :
    valrel d (S w) (ptprod τ₁ τ₂) ts tu →
    termrel₀ d w τ₂ (F.proj₂ ts) (I.proj₂ tu).
  Proof.
    intros vr.

    rewrite -> valrel_fixp in vr.
    destruct vr as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as [vr₁ vr₂].

    assert (F.eval (F.proj₂ (F.pair vs₁ vs₂)) vs₂) by
        (apply (F.eval_ctx₀ F.phole); try refine (F.eval_proj₂ _ _); simpl; intuition).
    assert (esn : clos_refl_trans_1n F.Tm F.eval (F.proj₂ (F.pair vs₁ vs₂)) vs₂) by (eauto with eval).
    assert (I.eval (I.proj₂ (I.pair vu₁ vu₂)) vu₂) by
        (apply (I.eval_eval₀); try refine (I.eval_proj₂ _ _); simpl; intuition).
    assert (eun : I.evalStar (I.proj₂ (I.pair vu₁ vu₂)) vu₂)
      by (unfold I.evalStar; eauto with eval).
    refine (termrel₀_antired_star esn eun _); crush.

    eapply valrel_in_termrel₀.
    apply vr₂; crush.
  Qed.

  (* Proj₂ *)
  Lemma termrel_proj₂ {d w τ₁ τ₂ ts tu} :
    termrel d w (ptprod τ₁ τ₂) ts tu →
    termrel d w τ₂ (F.proj₂ ts) (I.proj₂ tu).
  Proof.
    intros tr.

    (* first reduce ts and tu *)
    change (F.proj₂ _) with (F.pctx_app ts (F.pproj₂ F.phole)).
    change (I.proj₂ _) with (I.pctx_app tu (I.pproj₂ I.phole)).
    refine (termrel_ectx _ _ tr _); crush.

    (* then evaluate the projection *)
    rewrite -> valrel_fixp in H.
    destruct H as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as [vr₁ vr₂].

    assert (F.eval (F.proj₂ (F.pair vs₁ vs₂)) vs₂) by
        (apply (F.eval_ctx₀ F.phole); try refine (F.eval_proj₂ _ _); simpl; intuition).
    assert (esn : F.evaln (F.proj₂ (F.pair vs₁ vs₂)) vs₂ 1) by (unfold F.evaln; eauto with eval).
    assert (I.eval (I.proj₂ (I.pair vu₁ vu₂)) vu₂) by
        (apply I.eval_eval₀; try refine (I.eval_proj₂ _ _); simpl; intuition).
    assert (eun : I.evaln (I.proj₂ (I.pair vu₁ vu₂)) vu₂ 1)
      by (unfold I.evaln; eauto with eval).
    destruct w'; try apply termrel_zero.
    refine (termrel_antired w' esn eun _ _ _); crush.

    apply valrel_in_termrel.
    apply vr₂; crush.
  Qed.

  (* Inl *)
  Lemma termrel_inl {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w τ₁ ts tu →
    termrel d w (ptsum τ₁ τ₂) (F.inl ts) (I.inl tu).
  Proof.
    intros vτ₁ vτ₂ tr.
    change (F.inl ts) with (F.pctx_app ts (F.pinl F.phole)).
    change (I.inl tu) with (I.pctx_app tu (I.pinl I.phole)).
    refine (termrel_ectx _ _ tr _); crush.
    apply valrel_in_termrel; crush.
  Qed.

  (* Inr *)
  Lemma termrel_inr {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w τ₂ ts tu →
    termrel d w (ptsum τ₁ τ₂) (F.inr ts) (I.inr tu).
  Proof.
    intros vτ₁ vτ₂ tr.
    change (F.inr ts) with (F.pctx_app ts (F.pinr F.phole)).
    change (I.inr tu) with (I.pctx_app tu (I.pinr I.phole)).
    refine (termrel_ectx _ _ tr _); crush.
    apply valrel_in_termrel; crush.
  Qed.

  (* Caseof *)
  Lemma termrel_caseof {d w τ τ₁ τ₂ ts₁ ts₂ ts₃ tu₁ tu₂ tu₃} :
    termrel d w (ptsum τ₁ τ₂) ts₁ tu₁ →
    (∀ w' vs₁ vu₁, w' < w → valrel d w' τ₁ vs₁ vu₁ → termrel d w' τ (ts₂ [beta1 vs₁]) (tu₂ [ beta1 vu₁])) →
    (∀ w' vs₂ vu₂, w' < w → valrel d w' τ₂ vs₂ vu₂ → termrel d w' τ (ts₃ [beta1 vs₂]) (tu₃ [ beta1 vu₂])) →
    termrel d w τ (F.caseof ts₁ ts₂ ts₃) (I.caseof tu₁ tu₂ tu₃).
  Proof.
    intros tr₁ tr₂ tr₃.

    (* first evaluate ts₁ and tu₁ *)
    change (F.caseof _ _ _) with (F.pctx_app ts₁ (F.pcaseof₁ F.phole ts₂ ts₃)).
    change (I.caseof _ _ _) with (I.pctx_app tu₁ (I.pcaseof₁ I.phole tu₂ tu₃)).
    refine (termrel_ectx _ _ tr₁ _); crush.

    (* then evaluate the caseof *)
    rewrite -> valrel_fixp in H.
    destruct H as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptsum in ot.
    destruct ot as (vs' & vu' & [(? & ? & ot)|[(? & ?)|[(? & ?)|(? & ? & ot)]]]);
      subst; cbn in *; try contradiction;
      destruct (OfType_implies_Value ot) as [vvs vvu]; clear ot.
    - assert (F.eval (F.caseof (F.inl vs') ts₂ ts₃) (ts₂ [beta1 vs'])) by
          (apply (F.eval_ctx₀ F.phole); try refine (F.eval_case_inl _); simpl; intuition).
      assert (esn : F.evaln (F.caseof (F.inl vs') ts₂ ts₃) (ts₂ [beta1 vs']) 1) by (unfold F.evaln; eauto with eval).
      assert (I.eval (I.caseof (I.inl vu') tu₂ tu₃) (tu₂ [beta1 vu'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inl _); simpl; intuition).
      assert (eun : I.evaln (I.caseof (I.inl vu') tu₂ tu₃) (tu₂ [beta1 vu']) 1) by (unfold I.evaln; eauto with eval).
      destruct w'; try apply termrel_zero.
      refine (termrel_antired w' esn eun _ _ _); crush.
    - assert (F.eval (F.caseof (F.inr vs') ts₂ ts₃) (ts₃ [beta1 vs'])) by
          (apply (F.eval_ctx₀ F.phole); try refine (F.eval_case_inr _); simpl; intuition).
      assert (esn : F.evaln (F.caseof (F.inr vs') ts₂ ts₃) (ts₃ [beta1 vs']) 1) by (unfold F.evaln; eauto with eval).
      assert (I.eval (I.caseof (I.inr vu') tu₂ tu₃) (tu₃ [beta1 vu'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inr _); simpl; intuition).
      assert (eun : I.evaln (I.caseof (I.inr vu') tu₂ tu₃) (tu₃ [beta1 vu']) 1) by (unfold I.evaln; eauto with eval).
      destruct w'; try apply termrel_zero.
      refine (termrel_antired w' esn eun _ _ _); crush.
  Qed.

  Lemma termreli₀_caseof {d dfc w τ τ₁ τ₂ vs₁ ts₂ ts₃ vu₁ tu₂ tu₃} :
    valrel d (S w) (ptsum τ₁ τ₂) vs₁ vu₁ →
    (∀ vs₁ vu₁, valrel d w τ₁ vs₁ vu₁ → termreli₀ d dfc (S w) τ (ts₂ [beta1 vs₁]) (tu₂ [ beta1 vu₁])) →
    (∀ vs₂ vu₂, valrel d w τ₂ vs₂ vu₂ → termreli₀ d dfc (S w) τ (ts₃ [beta1 vs₂]) (tu₃ [ beta1 vu₂])) →
    termreli₀ d dfc (S w) τ (F.caseof vs₁ ts₂ ts₃) (I.caseof vu₁ tu₂ tu₃).
  Proof.
    intros vr₁ tr₂ tr₃.

    (* then evaluate the caseof *)
    rewrite -> valrel_fixp in vr₁.
    destruct vr₁ as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptsum in ot.
    destruct ot as (vs' & vu' & [(? & ? & ot)|[(? & ?)|[(? & ?)|(? & ? & ot)]]]);
      subst; cbn in *; try contradiction;
      destruct (OfType_implies_Value ot) as [vvs vvu]; clear ot.
    - assert (F.eval (F.caseof (F.inl vs') ts₂ ts₃) (ts₂ [beta1 vs'])) by
          (apply (F.eval_ctx₀ F.phole); try refine (F.eval_case_inl _); simpl; intuition).
      assert (esn : clos_refl_trans_1n F.Tm F.eval (F.caseof (F.inl vs') ts₂ ts₃) (ts₂ [beta1 vs'])) by (eauto with eval).
      assert (I.eval (I.caseof (I.inl vu') tu₂ tu₃) (tu₂ [beta1 vu'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inl _); simpl; intuition).
      assert (eun : I.evalStar (I.caseof (I.inl vu') tu₂ tu₃) (tu₂ [beta1 vu'])) by (unfold I.evalStar; eauto with eval).
      refine (termreli₀_antired_star esn eun _); crush.
    - assert (F.eval (F.caseof (F.inr vs') ts₂ ts₃) (ts₃ [beta1 vs'])) by
          (apply (F.eval_ctx₀ F.phole); try refine (F.eval_case_inr _); simpl; intuition).
      assert (esn : clos_refl_trans_1n F.Tm F.eval (F.caseof (F.inr vs') ts₂ ts₃) (ts₃ [beta1 vs'])) by (eauto with eval).
      assert (I.eval (I.caseof (I.inr vu') tu₂ tu₃) (tu₃ [beta1 vu'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inr _); simpl; intuition).
      assert (eun : I.evalStar (I.caseof (I.inr vu') tu₂ tu₃) (tu₃ [beta1 vu'])) by (unfold I.evalStar; eauto with eval).
      refine (termreli₀_antired_star esn eun _); crush.
  Qed.

  (* Seq *)
  Lemma termrel_seq {d w τ ts₁ ts₂ tu₁ tu₂} :
    termrel d w ptunit ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ ts₂ tu₂) →
    termrel d w τ (F.seq ts₁ ts₂) (I.seq tu₁ tu₂).
  Proof.
    intros tr₁ tr₂.

    (* first evaluate ts₁ and tu₁ *)
    change (F.seq _ _) with (F.pctx_app ts₁ (F.pseq₁ F.phole ts₂)).
    change (I.seq _ _) with (I.pctx_app tu₁ (I.pseq₁ I.phole tu₂)).
    refine (termrel_ectx _ _ tr₁ _); crush.

    (* then reduce to ts₂ and tu₂ *)
    rewrite -> valrel_fixp in H.
    destruct H as [ot [eq₁ eq₂]]; subst.
    assert (F.eval (F.seq F.unit ts₂) ts₂) by
        (apply (F.eval_ctx₀ F.phole); try refine (F.eval_seq_next _); simpl; intuition).
    assert (esn : F.evaln (F.seq F.unit ts₂) ts₂ 1) by (unfold F.evaln; eauto with eval).
    assert (I.eval (I.seq I.unit tu₂) tu₂) by
        (apply (I.eval_ctx₀ I.phole); try refine (I.eval_seq_next _); simpl; intuition).
    assert (eun : I.evaln (I.seq I.unit tu₂) tu₂ 1) by (unfold I.evaln; eauto with eval).

    (* assert (∀ Cu, I.ECtx Cu → I.eval (I.pctx_app (I.seq I.unit tu₂) Cu) (I.pctx_app tu₂ Cu)) by  *)
    (*     (intros Cu eCu; apply (I.eval_ctx₀ Cu); try refine (I.eval_seq_next _); simpl; intuition). *)
    (* assert (eun : ∀ Cu, I.ECtx Cu → I.evaln (I.pctx_app (I.seq I.unit tu₂) Cu) (I.pctx_app tu₂ Cu) 1) by eauto using I.evaln. *)

    (* attempt at using evalMax instead of doing manual labor *)
    (* pose (e := evalMax 2 (I.seq I.unit (var 0)) nil (idm UTm · tu₂) I). *)

    refine (termrel_antired w' esn eun _ _ _); try lia.

    (* conclude *)
    apply tr₂; intuition.
  Qed.

  (* Fixt *)
  Lemma termrel_fix' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    valrel d w (ptarr (ptarr τ₁ τ₂) (ptarr τ₁ τ₂)) vs vu →
    termrel d w (ptarr τ₁ τ₂) (F.fixt (repEmul τ₁) (repEmul τ₂) vs) (I.ufix₁ vu (fxToIs τ₁) (fxToIs τ₂)).
  Proof.
    (* well-founded induction on w *)
    intros vτ₁ vτ₂.
    revert w vs vu.
    refine (well_founded_ind lt_wf
                             (fun w =>
                                ∀ vs vu,
                                  valrel d w (ptarr (ptarr τ₁ τ₂) (ptarr τ₁ τ₂)) vs vu →
                                  termrel d w (ptarr τ₁ τ₂) (F.fixt (repEmul τ₁) (repEmul τ₂) vs) (I.ufix₁ vu (fxToIs τ₁) (fxToIs τ₂))) _).
    intros w indHyp vs vu.

    (* destruct valrel assumption *)
    intros vr.
    rewrite -> valrel_fixp in vr.
    destruct vr as [ot hyp]; cbn in hyp.
    apply OfType_inversion_ptarr in ot.
    destruct ot as (tsb & tub & ? & ? & ?);
      destruct hyp as (tsb' & tub' & τ₁' & τ₂' & -> & -> & hyp);
      crush.

    eapply termrel_size_right'.
    intros szvs.
    cbn in szvs.

    (* evaluate *)
    assert (es : F.fixt (repEmul τ₁) (repEmul τ₂) (F.abs (repEmul (ptarr τ₁ τ₂)) tsb) --> tsb [beta1 (F.abs (repEmul τ₁) (F.app (F.fixt (repEmul τ₁) (repEmul τ₂) (F.abs (repEmul τ₁ ⇒ repEmul τ₂) tsb[wkm↑])) (F.var 0)))]) by (refine (eval_ctx₀ F.phole _ _); constructor).
    assert (es1 : F.evaln (F.fixt (repEmul τ₁) (repEmul τ₂) (F.abs (repEmul (ptarr τ₁ τ₂)) tsb)) (tsb [beta1 (F.abs (repEmul τ₁) (F.app (F.fixt (repEmul τ₁) (repEmul τ₂) (F.abs (repEmul τ₁ ⇒ repEmul τ₂) tsb[wkm↑])) (F.var 0)))])  1) by
        (unfold F.evaln; eauto with eval; lia).
    assert (es2 : I.evaln (I.ufix₁ (I.abs (fxToIs (ptarr τ₁ τ₂)) tub) (fxToIs τ₁) (fxToIs τ₂)) (tub[beta1 (I.abs (fxToIs τ₁) (I.app (I.ufix₁ (I.abs (I.tarr (fxToIs τ₁) (fxToIs τ₂)) tub[wkm↑]) (fxToIs τ₁) (fxToIs τ₂)) (I.var 0)))]) 3) by
        (eauto using I.ufix₁_evaln' with eval).
    destruct w; try apply termrel_zero.
    refine (termrel_antired w es1 es2 _ _ _); unfold lev in *; simpl; try lia.
    clear es es1 es2.

    (* use the assumption about tsb and tub we extracted from vr *)
    refine (hyp w _ _ _ _ _); try lia.
    {
      intros ->; cbn.
      specialize (szvs eq_refl).
      lia.
    }

    (* prove valrel for values being substituted into tsb and tub *)
    rewrite -> valrel_fixp.
    unfold valrel'; cbn; split; intros.
    - (* first the OfType relation *)
      crush.
      eapply I.ufix₁_typing.
      crush.
      crush.
      crush.
      crush.
      apply ValidTy_arr; crush.
    - (* prove the termrel of the body of the abstractions *)
      repeat eexists; try reflexivity.
      intros w' fw ts' tu' szvu vr.
      refine (termrel_app (τ₁ := τ₁) (τ₂ := τ₂) _ _);
        repeat fold apTm I.apTm;
        crush.
      change (I.abs _ (tub[wkm↑][wkm↑][(beta1 tu')↑↑])) with ((I.abs (I.tarr (fxToIs τ₁) (fxToIs τ₂)) tub)[wkm][wkm][(beta1 tu')↑]).
      change (F.abs _ _) with  ((F.abs (repEmul τ₁ ⇒ repEmul τ₂) tsb)[wkm][(beta1 ts')]).
      rewrite <- apply_wkm_comm.
      rewrite -> ?apply_wkm_beta1_cancel.
      change (I.app _ _) with (I.ufix₁ (I.abs (I.tarr (fxToIs τ₁) (fxToIs τ₂)) tub) (fxToIs τ₁) (fxToIs τ₂)).
      (* the goal is now what we set out to prove initially but in a strictly
             later world, so we can use the induction hypothesis from our
             well-founded induction on worlds *)
      refine (indHyp _ _ _ _ _); crush.
      unfold OfType, OfTypeStlcFix, OfTypeStlcIso.
      apply ValidTy_arr;
      crush.
      repeat eexists; try reflexivity.
      intros w'' fw'.
      eapply hyp; lia.
  Qed.

  Lemma termrel_fix {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    termrel d w (ptarr (ptarr τ₁ τ₂) (ptarr τ₁ τ₂)) ts tu →
    termrel d w (ptarr τ₁ τ₂) (F.fixt (repEmul τ₁) (repEmul τ₂) ts) (I.app (I.ufix (fxToIs τ₁) (fxToIs τ₂)) tu).
  Proof.
    intros vτ₁ vτ₂ tr.

    (* first normalize ts and tu *)
    change (F.fixt _ _ _) with (F.pctx_app ts (F.pfixt (repEmul τ₁) (repEmul τ₂) F.phole)).
    change (I.app _ _) with (I.pctx_app tu (I.papp₂ (I.ufix (fxToIs τ₁) (fxToIs τ₂)) I.phole)).
    refine (termrel_ectx _ _ tr _); crush.
    destruct (valrel_implies_Value H) as [vvs vvu].

    (* next, reduce (I.app I.ufix tu) by one step in the conclusion *)
    assert (es1 : F.evaln (F.fixt (repEmul τ₁) (repEmul τ₂) vs) (F.fixt (repEmul τ₁) (repEmul τ₂) vs) 0) by
        (unfold F.evaln; eauto with eval).
    assert (es2 : I.evaln (I.app (I.ufix (fxToIs τ₁) (fxToIs τ₂)) vu) (I.ufix₁ vu (fxToIs τ₁) (fxToIs τ₂)) 1)
      by (unfold I.evaln; eauto using I.ufix_eval₁' with eval).
    refine (termrel_antired w' es1 es2 _ _ _); unfold lev in *; simpl; try lia.

    (* then defer to valrel_fix *)
    apply termrel_fix'; crush.
  Qed.

  (* Lemma termrel₀_pEmulDV {d w n p τ ts tu} : *)
  (*   termrel₀ d w (pEmulDV (S n) p τ) ts tu → *)
  (*   termrel₀ d w (pEmulDV) *)

End TermRelation.


From Coq Require Import FSets.FMapPositive.
From Coq Require Import PArith.
From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import Obc.ObcSyntax.
From Velus Require Import Obc.ObcSemantics.
From Velus Require Import Obc.ObcTyping.

From Coq Require Import Relations.
From Coq Require Import Morphisms.
From Coq Require Import Setoid.

Import List.

(** * Equivalence of Obc programs *)

(**

To prove the soundness of the if-then-else fusing optimization, we
define (and prove some properties about) equivalence of Obc
programs.

 *)
Module Type EQUIV
       (Ids          : IDS)
       (Import Op    : OPERATORS)
       (Import OpAux : OPERATORS_AUX    Op)
       (Import Syn   : OBCSYNTAX    Ids Op OpAux)
       (Import Sem   : OBCSEMANTICS Ids Op OpAux Syn)
       (Import Typ   : OBCTYPING    Ids Op OpAux Syn Sem).

  Definition stmt_eval_eq s1 s2: Prop :=
    forall prog menv env menv' env',
      stmt_eval prog menv env s1 (menv', env')
      <->
      stmt_eval prog menv env s2 (menv', env').

  Lemma stmt_eval_eq_refl:
    reflexive stmt stmt_eval_eq.
  Proof. now apply iff_refl. Qed.

  Lemma stmt_eval_eq_sym:
    symmetric stmt stmt_eval_eq.
  Proof.
    intros s1 s2 Heq prog menv env menv' env'.
    split; apply Heq.
  Qed.

  Lemma stmt_eval_eq_trans:
    transitive stmt stmt_eval_eq.
  Proof.
    intros s1 s2 s3 Heq1 Heq2 prog menv env menv' env'.
    split; intro HH; [apply Heq2, Heq1|apply Heq1, Heq2]; exact HH.
  Qed.

  Add Relation stmt (stmt_eval_eq)
      reflexivity proved by stmt_eval_eq_refl
      symmetry proved by stmt_eval_eq_sym
      transitivity proved by stmt_eval_eq_trans
        as stmt_eval_equiv.

  Instance stmt_eval_eq_Proper:
    Proper (eq ==> eq ==> eq ==> stmt_eval_eq ==> eq ==> iff) stmt_eval.
  Proof.
    intros prog' prog HR1 menv' menv HR2 env' env HR3 s1 s2 Heq r' r HR4;
    subst; destruct r as [menv' env'].
    now apply Heq.
  Qed.

  Instance stmt_eval_eq_Comp_Proper:
    Proper (stmt_eval_eq ==> stmt_eval_eq ==> stmt_eval_eq) Comp.
  Proof.
    intros s s' Hseq t t' Hteq prog menv env menv' env'.
    split; inversion_clear 1;
    [rewrite Hseq, Hteq in *; econstructor; eassumption
    |rewrite <-Hseq, <-Hteq in *; econstructor; eassumption].
  Qed.

  Lemma Comp_assoc:
    forall s1 s2 s3,
      stmt_eval_eq (Comp s1 (Comp s2 s3)) (Comp (Comp s1 s2) s3).
  Proof.
    intros prog s1 s2 s3 menv env menv' env'.
    split;
      intro HH;
      repeat progress
             match goal with
             | H:stmt_eval _ _ _ (Comp _ _) _ |- _ => inversion H; subst; clear H
             | |- _ => repeat econstructor; now eassumption
             end.
  Qed.

  Lemma stmt_eval_eq_Comp_Skip1:
    forall s, stmt_eval_eq (Comp Skip s) s.
  Proof.
    split; eauto using stmt_eval.
    inversion_clear 1; now chase_skip.
  Qed.

  Lemma stmt_eval_eq_Comp_Skip2:
    forall s, stmt_eval_eq (Comp s Skip) s.
  Proof.
    split; eauto using stmt_eval.
    inversion_clear 1; now chase_skip.
  Qed.

  Instance stmt_eval_eq_Ifte_Proper:
    Proper (eq ==> stmt_eval_eq ==> stmt_eval_eq ==> stmt_eval_eq) Ifte.
  Proof.
    intros e e' Heeq s s' Hseq t t' Hteq prog menv env menv' env'.
    rewrite <-Heeq.
    split; inversion_clear 1;
      destruct b;
      try match goal with
          | H: exp_eval _ _ _ _ |- _ => apply Iifte with (1:=H)
          | H: stmt_eval _ _ _ _ _ |- _ =>
            (rewrite <-Hseq in H
             || rewrite <-Hteq in H
             || rewrite Hseq in H
                                || rewrite Hteq in H)
          end;
      try match goal with
          | H:val_to_bool ?v = Some true |- _ =>
            apply val_to_bool_true' in H
          | H:val_to_bool ?v = Some false |- _ =>
            apply val_to_bool_false' in H
          end; subst;
        econstructor; try eassumption;
          try apply val_to_bool_true;
          try apply val_to_bool_false';
          easy.
  Qed.

  (** A refinement relation for Obc.
      Refining programs are allowed to replace [None] by any value. *)

  Import Env.Notations.

  Lemma exp_eval_refines:
    forall menv' env1 env2 e v,
      env2 ⊑ env1 ->
      exp_eval menv' env2 e (Some v) ->
      exp_eval menv' env1 e (Some v).
  Proof.
    intros menv' env1 env2.
    induction e; intros v Henv; inversion 1; subst; eauto using exp_eval.
    - take (Env.find _ _ = Some _) and (rewrite it; apply Henv in it as (v' & -> & <-));
        eauto using exp_eval.
    - take (Env.find _ _ = Some _) and apply Henv in it as (v' & -> & ?);
        eauto using exp_eval.
  Qed.

  Lemma exp_eval_refines':
    forall menv env1 env2 e vo,
      env2 ⊑ env1 ->
      exp_eval menv env2 e vo ->
      exists vo', exp_eval menv env1 e vo' /\ (forall v, vo = Some v -> vo' = Some v).
  Proof.
    intros menv env1 env2.
    induction e; intros vo Henv; inversion 1; subst;
      eauto using exp_eval, exp_eval_refines.
    destruct (Env.find i env2).
    - eauto using exp_eval_refines.
    - exists (Env.find i env1); split; eauto using exp_eval.
      discriminate.
  Qed.

  Lemma Forall2_exp_eval_refines':
    forall menv env1 env2 es vos,
      env2 ⊑ env1 ->
      Forall2 (exp_eval menv env2) es vos ->
      exists vos',
        Forall2 (exp_eval menv env1) es vos'
        /\ Forall2 (fun vo vo' => forall v, vo = Some v -> vo' = Some v) vos vos'.
  Proof.
    intros menv env1 env2 es vos Henv Hvos.
    induction Hvos; eauto.
    apply exp_eval_refines' with (1:=Henv) in H.
    destruct H as (vo' & Heval & Hvo').
    destruct IHHvos as (vos' & Hevals & Hvos').
    eauto using Forall2_cons.
  Qed.

  (* If a statement s' refines s, it should be possible to use s' instead
     of s. *)

  Definition stmt_refines prog1 prog2 P s1 s2 : Prop :=
    forall menv env1 env2 menv' env2',
      P env1 env2 ->
      env2 ⊑ env1 ->
      stmt_eval prog2 menv env2 s2 (menv', env2') ->
      (exists env1',
          env2' ⊑ env1'
          /\ stmt_eval prog1 menv env1 s1 (menv', env1')).

  Definition method_refines prog1 prog2 P m1 m2 : Prop :=
    m1.(m_in) = m2.(m_in)
    /\ m1.(m_out) = m2.(m_out)
    /\ stmt_refines prog1 prog2 (P m1.(m_in)) m1.(m_body) m2.(m_body).

  Definition class_refines prog1 prog2 P c1 c2 : Prop :=
    forall f m2,
      find_method f c2.(c_methods) = Some m2 ->
      exists m1,
        find_method f c1.(c_methods) = Some m1
        /\ method_refines prog1 prog2 (P f) m1 m2.

  Definition program_refines
             (P : ident -> ident -> list (ident * type)
                  -> Env.t val -> Env.t val -> Prop)
             (prog1 prog2 : program) : Prop :=
    (PFix ltsuffix2_wf
          (fun (progs : program * program)
               (program_refines :
                  (forall (progs' : program * program),
                      ltsuffix2 progs' progs -> Prop)) =>
             forall n c2 prog2'
                    (Hf2: find_class n (snd progs) = Some (c2, prog2')),
             exists (c1 : class) (prog1' : program)
                    (Hf1: find_class n (fst progs) = Some (c1, prog1')),
               class_refines prog1' prog2' (P n) c1 c2
               /\ program_refines (prog1', prog2')
                                  (conj (find_class_ltsuffix n (fst progs) c1 prog1' Hf1)
                                        (find_class_ltsuffix n (snd progs) c2 prog2' Hf2))
    )) (prog1, prog2).

  Lemma program_refines_def:
    forall (P : ident -> ident -> list (ident * type)
                -> Env.t val -> Env.t val -> Prop) prog1 prog2,
      program_refines P prog1 prog2 <->
      (forall n c2 prog2',
          find_class n prog2 = Some (c2, prog2') ->
          exists (c1 : class) (prog1' : program),
            find_class n prog1 = Some (c1, prog1')
            /\ class_refines prog1' prog2' (P n) c1 c2
            /\ program_refines P prog1' prog2').
  Proof.
    intros.
    unfold program_refines at 1.
    rewrite PFix_eq.
    - split; intros HH n c2 prog2' Hfind;
        destruct (HH n c2 prog2' Hfind) as (c1' & prog1' & Hfind' & Hcr & Hfix);
        eauto.
    - intros * H. now setoid_rewrite H.
  Qed.

  Lemma program_refines_by_class':
    forall (Pc : class -> class -> Prop) P p1 p2,
      wt_program p2 ->
      Forall2 (fun c1 c2 => forall p1' p2',
                   wt_program p2' ->
                   wt_class p2' c2 ->
                   program_refines P p1' p2' ->
                   Forall2 Pc p1' p2' ->
                   Pc c1 c2 ->
                   c1.(c_name) = c2.(c_name)
                   /\ class_refines p1' p2' (P c1.(c_name)) c1 c2) p1 p2 ->
      Forall2 Pc p1 p2 ->
      program_refines P p1 p2.
  Proof.
    intros Pc P p1 p2 WTp Hfa.
    pose proof (Forall2_length _ _ _ Hfa) as Hlen.
    revert WTp Hfa.
    pattern p1, p2.
    apply forall2_right; auto.
    now intros; rewrite program_refines_def; inversion 1.
    clear Hlen. intros c1 c2 p1' p2' Hfa' WTp2' Hpr' Hpc'.
    inversion_clear Hpr' as [|? ? ? ? Hcr' Hpr].
    inversion_clear Hpc' as [|? ? ? ? Hpc Hpcs].
    inversion_clear WTp2' as [|? ? WTc WTp Hnodup].
    apply Hfa' in Hpr; auto. clear Hfa'.
    destruct (Hcr' _ _ WTp WTc Hpr Hpcs Hpc) as [Hcn Hcr].
    rewrite program_refines_def.
    intros n c2' p2'' Hfind2.
    simpl in Hfind2.
    destruct (ident_eqb c2.(c_name) n) eqn:Heq.
    - inv Hfind2. apply ident_eqb_eq in Heq.
      rewrite <-Heq, <-Hcn.
      simpl. setoid_rewrite ident_eqb_refl. eauto.
    - rewrite program_refines_def in Hpr.
      destruct (Hpr _ _ _ Hfind2) as (c1' & p1''' & Hfind1 & Hcr1 & Hpr1).
      exists c1', p1'''. simpl.
      setoid_rewrite Hcn. setoid_rewrite Heq. auto.
  Qed.

  Lemma stmt_refines_strengthen:
    forall P Q p1 p2 s1 s2,
      stmt_refines p1 p2 P s1 s2 ->
      (forall env1 env2, Q env1 env2 -> P env1 env2) ->
      stmt_refines p1 p2 Q s1 s2.
  Proof.
    intros P Q p1 p2 s1 s2 Hr HQP menv env1 env2 menv' env2' HQ Henv Heval.
    eapply Hr in Heval; eauto.
  Qed.

  Instance stmt_refines_Proper:
    Proper (eq ==> eq ==>
               pointwise_relation _
               (pointwise_relation _ (Basics.flip Basics.impl))
               ==> eq ==> eq ==> Basics.impl) stmt_refines.
  Proof.
    intros p1 p2 Hp12 p3 p4 Hp34 pre1 pre2 Hpre s1 s2 Hs12 s3 s4 Hs34 HH.
    subst p2 p4 s2 s4. apply stmt_refines_strengthen with (1:=HH).
    intros env1 env2 Hpre2. apply (Hpre env1 env2 Hpre2).
  Qed.

  Lemma program_refines_stmt_call_eval:
    forall P p1 p2 omenv omenv' clsid f vos vos' rvos,
      program_refines P p1 p2 ->
      (forall cls prog' m,
          find_class clsid p2 = Some (cls, prog') ->
          find_method f cls.(c_methods) = Some m ->
          length vos = length m.(m_in) ->
          length vos' = length m.(m_in) ->
          P clsid f m.(m_in) (Env.adds_opt (map fst m.(m_in)) vos' vempty)
                             (Env.adds_opt (map fst m.(m_in)) vos vempty)) ->
      stmt_call_eval p2 omenv clsid f vos omenv' rvos ->
      Forall2 (fun vo vo' => forall v, vo = Some v -> vo' = Some v) vos vos' ->
      exists rvos',
        stmt_call_eval p1 omenv clsid f vos' omenv' rvos'
        /\ Forall2 (fun vo' vo => forall v, vo = Some v -> vo' = Some v) rvos' rvos.
  Proof.
    intros * Hpr HP Hcall Hvos.
    inversion_clear Hcall as [? ? ? ? ? ? ? ? ? ? ? Hfindc Hfindm Hlvos Heval Hrvos].
    rewrite program_refines_def in Hpr.
    assert (Hfindc2:=Hfindc). assert (Hfindm2:=Hfindm).
    apply Hpr in Hfindc as (c & p & Hfindc & Hcr & Hpr').
    apply Hcr in Hfindm as (m & Hfindm & (Hm1 & Hm2 & Hsr)).
    assert ((Env.adds_opt (map fst fm.(m_in)) vos vempty)
              ⊑ (Env.adds_opt (map fst m.(m_in)) vos' vempty)) as Henv.
    { rewrite <-Hm1. apply Env.refines_adds_opt.
      - reflexivity.
      - now apply Forall2_swap_args in Hvos.
      - apply fst_NoDupMembers. pose proof m.(m_nodupvars) as Hnd.
        rewrite app_assoc in Hnd. now repeat apply NoDupMembers_app_l in Hnd.
      - apply Forall_forall; setoid_rewrite Env.Props.P.F.empty_in_iff; auto.
    }
    eapply Hsr in Heval as (env1' & Henv1' & Heval'); eauto.
    - exists (map (fun x => Env.find x env1') (map fst fm.(m_out))).
      split; [econstructor; eauto|].
      + apply Forall2_length in Hvos. now rewrite <-Hvos, Hm1.
      + rewrite Forall2_map_2, <-Hm2. apply Forall2_same. apply Forall_forall; auto.
      + rewrite Forall2_map_1. apply Forall2_impl_In with (2:=Hrvos).
        intros x vo Hxin Hvoin Hfind v Hv. subst.
        now apply Henv1' in Hv as (? & -> & ?).
    - rewrite Hm1. apply Forall2_length in Hvos.
      eapply HP; eauto. now rewrite <-Hvos, Hlvos.
  Qed.

  Lemma wt_stmt_program_refines:
    forall P p1 p2 insts mems vars s,
      program_refines P p1 p2 ->
      wt_stmt p2 insts mems vars s ->
      wt_stmt p1 insts mems vars s.
  Proof.
    intros * Hpr WTs.
    induction s; inv WTs; eauto using wt_stmt.
    rewrite program_refines_def in Hpr.
    match goal with H:find_class _ _ = _ |- _ =>
      apply Hpr in H as (c & p1' & Hfindc & Hcr & Hpr') end.
    match goal with H:find_method _ _ = _ |- _ =>
      apply Hcr in H as (m' & Hfindm & (Hmi & Hmo & Hmr)) end.
    rewrite <-Hmi, <-Hmo in *.
    econstructor; eauto.
  Qed.

End EQUIV.

Module EquivFun
       (Ids          : IDS)
       (Op           : OPERATORS)
       (Import OpAux : OPERATORS_AUX    Op)
       (Import Syn   : OBCSYNTAX    Ids Op OpAux)
       (Import Sem   : OBCSEMANTICS Ids Op OpAux Syn)
       (Import Typ   : OBCTYPING    Ids Op OpAux Syn Sem)
  <: EQUIV Ids Op OpAux Syn Sem Typ.
  Include EQUIV Ids Op OpAux Syn Sem Typ.
End EquivFun.


(* 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                                                     *)

Require Export DistributedReferenceCounting.machine2.machine.
Require Export DistributedReferenceCounting.machine2.cardinal.
Require Export DistributedReferenceCounting.machine2.comm.

Unset Standard Proposition Elimination Names.

Section ROOTED.

Variable s0 : Site.

Definition rooted_fun (s1 s2 : Site) (m : Message) :=
  match m with
  | copy => if eq_site_dec s1 s0 then 1%Z else 0%Z
  | dec => if eq_site_dec s2 s0 then 1%Z else 0%Z
  | inc_dec s3 =>
      if eq_site_dec s3 s0
      then
       if eq_site_dec s2 owner then 1%Z else 0%Z
      else 0%Z
  end.

Definition rooted (s1 s2 : Site) (q : queue Message) :=
  reduce Message (rooted_fun s1 s2) q.

Definition sigma_rooted (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) rooted bm.

End ROOTED.

Section ROOTED1.

Lemma sigma_rooted_post_message :
 forall (m : Message) (s0 s1 s2 : Site) (b : Bag_of_message),
 s0 <> owner ->
 sigma_rooted s0 (Post_message Message m b s1 s2) =
 (sigma_rooted s0 b + rooted_fun s0 s1 s2 m)%Z.
Proof.
  unfold sigma_rooted in |- *.
  unfold Post_message in |- *.
  unfold change_queue in |- *.
  intros.
  rewrite sigma_table2_change.
  simpl in |- *.
  omega.
  apply finite_site.
  apply finite_site.
Qed.

Lemma rooted_first_out :
 forall (s0 s1 s2 : Site) (q : queue Message) (m : Message),
 first Message q = value Message m ->
 rooted s0 s1 s2 (first_out Message q) =
 (rooted s0 s1 s2 q - rooted_fun s0 s1 s2 m)%Z.
Proof.
  intros.
  unfold rooted in |- *.
  apply reduce_first_out.
  auto.
Qed.

Lemma sigma_rooted_collect_message :
 forall (m : Message) (s0 s1 s2 : Site) (b : Bag_of_message),
 first Message (b s1 s2) = value Message m ->
 s0 <> owner ->
 sigma_rooted s0 (Collect_message Message b s1 s2) =
 (sigma_rooted s0 b - rooted_fun s0 s1 s2 m)%Z.
Proof.
  unfold sigma_rooted, Collect_message, change_queue in |- *.
  intros.
  rewrite sigma_table2_change.
  rewrite (rooted_first_out s0 s1 s2 (b s1 s2) m).
  simpl in |- *.
  omega.
  auto.
  apply finite_site.
  apply finite_site.
Qed.

Lemma rooted_fun_positive_or_null :
 forall (s0 x y : Site) (a : Message), (rooted_fun s0 x y a >= 0)%Z.
Proof.
  intros.
  unfold rooted_fun in |- *.
  elim a.
  case (eq_site_dec y s0).
  intro; omega.
  intro; omega.
  intro.
  case (eq_site_dec s s0).
  case (eq_site_dec y owner).
  intros; omega.
  intros; omega.
  intros; omega.
  case (eq_site_dec x s0).
  intros; omega.
  intros; omega.
Qed.

Lemma rooted_positive_or_null :
 forall (s0 x y : Site) (q : queue Message), (rooted s0 x y q >= 0)%Z.
Proof.
  intros.
  unfold rooted in |- *.
  apply reduce_positive_or_null.
  intro.
  apply rooted_fun_positive_or_null.
Qed.

End ROOTED1.

Section INVARIANT2.

Lemma invariant2_init :
 forall s0 : Site, st config_init s0 = sigma_rooted s0 (bm config_init).
Proof.
  intros.
  simpl in |- *.
  unfold send_init, sigma_rooted, bag_init in |- *.
  unfold sigma2_table in |- *.
  unfold sigma_table in |- *.
  unfold Z_id in |- *.
  unfold rooted in |- *.
  simpl in |- *.
  rewrite sigma_null.
  rewrite sigma_null.
  auto.
Qed.

Lemma invariant2_ind :
 forall s0 : Site,
 s0 <> owner ->
 forall (c : Config) (t : class_trans c),
 legal c ->
 st c s0 = sigma_rooted s0 (bm c) ->
 st (transition c t) s0 = sigma_rooted s0 (bm (transition c t)).
Proof.
  simple induction t.

  (* 1 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  unfold Inc_send_table in |- *.
  unfold rooted_fun in |- *.
  case (eq_site_dec s1 s0).
  intro; rewrite e.
  unfold update_table in |- *; rewrite here.
  omega.
  intro; unfold update_table in |- *; rewrite elsewhere.
  omega.
  auto.
  auto.

  (* 2 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_collect_message with (m := dec).
  unfold Dec_send_table in |- *.
  unfold rooted_fun in |- *.
  case (eq_site_dec s2 s0).
  intro; rewrite e0.
  unfold update_table in |- *; rewrite here.
  omega.
  intros; unfold update_table in |- *; rewrite elsewhere.
  omega.
  auto.
  auto.
  auto.

  (* 3 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  rewrite sigma_rooted_collect_message with (m := inc_dec s3).
  unfold Inc_send_table, rooted_fun in |- *.
  unfold update_table in |- *; rewrite elsewhere.
  case (eq_site_dec s3 s0).
  case (eq_site_dec owner owner).
  intros; omega.
  intro; elim n.
  auto.
  intros; omega.
  auto.
  auto.
  auto.
  auto.

  (* 4 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  rewrite sigma_rooted_collect_message with (m := copy).
  unfold rooted_fun in |- *.
  case (eq_site_dec s1 s0).
  intro; omega.
  intro; omega.
  auto.
  auto.
  auto.

  (* 5 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_collect_message with (m := copy).
  unfold rooted_fun in |- *.
  rewrite case_ineq.
  omega.
  auto.
  auto.
  auto.

  (* 6 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  rewrite sigma_rooted_collect_message with (m := copy).
  unfold rooted_fun in |- *.
  case (eq_site_dec s1 s0).
  rewrite case_eq.
  intro; omega.
  intro; omega.
  auto.
  auto.
  auto.

  (* 7 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  unfold rooted_fun in |- *.
  rewrite case_ineq.
  omega.
  auto.
  auto.
Qed.

Lemma invariant2 :
 forall (c0 : Config) (s0 : Site),
 legal c0 -> s0 <> owner -> st c0 s0 = sigma_rooted s0 (bm c0).

Proof.
  intros.
  elim H.
  apply invariant2_init.
  intros.
  apply invariant2_ind.
  auto.
  auto.
  auto.
Qed.

Lemma positive_st :
 forall (c : Config) (s0 s5 : Site),
 s0 <> owner ->
 legal c -> In_queue Message (inc_dec s0) (bm c s5 owner) -> (st c s0 > 0)%Z.
Proof.
  intros c s0 s5 H HA.
  rewrite invariant2.
  unfold sigma_rooted in |- *.
  intros.
  apply sigma2_strictly_positive with (x := s5) (y := owner).
  auto.
  exact eq_site_dec.

  apply in_s_LS.
  apply in_s_LS.
  intros.
  unfold rooted in |- *.
  intros.
  simpl in |- *.
  intros.
  simpl in |- *.
  apply reduce_positive_or_null.
  intro.
  apply rooted_fun_positive_or_null.

  generalize H0.
  elim (bm c s5 owner).
  simpl in |- *; intuition.

  intros.
  generalize H2.
  case d.
  simpl in |- *.
  intros.
  elim H3.
  intro; discriminate.

  intro.
  generalize (H1 H4).
  intro.
  case (eq_site_dec owner s0).
  intros; omega.

  intros; omega.

  simpl in |- *.
  intros.
  case (eq_site_dec s s0).
  intro.
  case (eq_site_dec owner owner).
  intro.
  generalize (rooted_positive_or_null s0 s5 owner q).
  intro.
  omega.

  intro.
  elim n; auto.

  intro.
  elim H3.
  intro; elim n.
  inversion H4.
  auto.

  intro.
  generalize (H1 H4).
  intro.
  omega.

  simpl in |- *.
  intro.
  elim H3.
  intro; discriminate.

  intro.
  generalize (H1 H4).
  intro.
  case (eq_site_dec s5 s0).
  intro; omega.

  intro; omega.

  auto.

  auto.
Qed.

End INVARIANT2.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import ssrmatching.

(*Set Debug SsrMatching.*)

Tactic Notation "at" "[" ssrpatternarg(pat) "]" tactic(t) :=
  let name := fresh in
  let def_name := fresh in
  ssrpattern pat;
  intro name;
  pose proof (refl_equal name) as def_name;
  unfold name at 1 in def_name;
  t def_name;
  [ rewrite <- def_name | idtac.. ];
  clear name def_name.

Lemma test (H : True -> True -> 3 = 7) : 28 = 3 * 4.
Proof.
at [ X in X * 4 ] ltac:(fun place => rewrite -> H in place).
- reflexivity.
- trivial.
- trivial.
Qed.