(**
 * Copyright (C) 2022 BedRock Systems, Inc.
 * All rights reserved.
 *
 * SPDX-License-Identifier: LGPL-2.1 WITH BedRock Exception for use over network, see repository root for details.
 *)

Require Import iris.algebra.agree.
Require Import iris.proofmode.proofmode.
Require Import bedrock.lang.bi.spec.frac_splittable.
Require Import bedrock.lang.cpp.logic.
Require Import bedrock.lang.algebra.frac_auth.
Require Import bedrock.lang.cpp.logic.own_instances.
Require Import bedrock.lang.proofmode.own_obs.

Set Printing Coercions.

(**
Well-typed ghost resources:

- [afrac.auth (g : afrac.gname A) (q : Qp) (x : A) : mpred]
represents fractional ownership of ghost cell [g] currently containing
the authoritative state [x]

- [afrac.frag (g : afrac.gname A) (q : Qp) (x : A) : mpred]
represents fractional ownership of ghost cell [g] currently containing
the fragmentative state [x]
*)
Module Type AUTH_FRAC.

  (** CMRA *)

  Parameter G : ∀ (A : Type) (Σ : gFunctors), Set.
  Existing Class G.
  Parameter Σ : ∀ (A : Type), gFunctors.
  #[global] Declare Instance subG {A Σ} : subG (AUTH_FRAC.Σ A) Σ -> G A Σ.

  (** Ghosts *)

  Parameter gname : ∀ (A : Type), Set.

  #[global] Declare Instance gname_inhabited A : Inhabited (gname A).
  #[global] Declare Instance gname_eq_dec A : EqDecision (gname A).
  #[global] Declare Instance gname_countable A : Countable (gname A).

  (** Predicates *)

  Parameter auth : ∀ {A} `{Σ : cpp_logic, !AUTH_FRAC.G A Σ}
    (g : gname A) (q : Qp) (x : A), mpred.
  Parameter frag : ∀ {A} `{Σ : cpp_logic, !AUTH_FRAC.G A Σ}
    (g : gname A) (q : Qp) (x : A), mpred.

  Section properties.
    Context {A} `{Σ : cpp_logic, !AUTH_FRAC.G A Σ}.

    (** Structure *)

    #[global] Declare Instance auth_objective : Objective3 auth.
    #[global] Declare Instance auth_frac g : FracSplittable_1 (auth g).
    #[global] Declare Instance auth_agree g : AgreeF1 (auth g).

    #[global] Declare Instance frag_objective : Objective3 frag.
    #[global] Declare Instance frag_frac g : FracSplittable_1 (frag g).
    #[global] Declare Instance frag_agree g : AgreeF1 (frag g).

    #[global] Declare Instance auth_frag_agree g q1 q2 x1 x2 :
      Observe2 [| x1 = x2 |] (auth g q1 x1) (frag g q2 x2).

    (** Allocation *)

    #[local] Notation OWN g x := (auth g 1 x ** frag g 1 x) (only parsing).

(*  (* Stronger allocation rules may not be needed for now. *)
    Axiom alloc_strong_dep : ∀ (f : gname A -> A) (P : gname A -> Prop),
      pred_infinite P ->
      |-- |==> Exists g, [| P g |] ** OWN g (f g).

    Axiom alloc_cofinite_dep : ∀ (f : gname A -> A) (G : gset (gname A)),
      |-- |==> Exists g, [| g ∉ G |] ** OWN g (f g).

    Axiom alloc_dep : ∀ (f : gname A -> A),
      |-- |==> Exists g, OWN g (f g).

    Axiom alloc_strong : ∀ (P : gname A -> Prop) x,
      pred_infinite P ->
      |-- |==> Exists g, [| P g |] ** OWN g x.

    Axiom alloc_cofinite : ∀ (G : gset (gname A)) x,
      |-- |==> Exists g, [| g ∉ G |] ** OWN g x.
*)

    Axiom alloc : ∀ x, |-- |==> Exists g, OWN g x.

    (** Updates *)

    Axiom update : ∀ g x y, |-- auth g 1 x -* frag g 1 x -* |==> OWN g y.

    (** TODO: Automation (generically derivable) *)

  End properties.

End AUTH_FRAC.

(**
TODO: unify with [bedrock.algebra.frac_auth_agree].
*)
Module afrac : AUTH_FRAC.

  (** CMRA *)

  #[local] Notation RA A := (frac_authR (agreeR (leibnizO A))).
  Class G (A : Type) (Σ : gFunctors) : Set := G_inG :> inG Σ (RA A).
  Definition Σ (A : Type) : gFunctors := #[ GFunctor (RA A) ].
  Lemma subG {A Σ} : subG (afrac.Σ A) Σ -> G A Σ.
  Proof. solve_inG. Qed.

  (** Ghosts *)

  Definition gname (A : Type) : Set := iprop.gname.
  #[local] Instance  gname_inhabited A : Inhabited (gname A) := _.
  #[local] Instance  gname_eq_dec A : EqDecision (gname A) := _.
  #[local] Instance  gname_countable A : Countable (gname A) := _.

  (** Predicates *)

  Section defs.
    Context {A} `{Σ : cpp_logic, !afrac.G A Σ}.

    #[local] Notation to_agree := (to_agree (A:=leibnizO A)).

    Definition auth (g : gname A) (q : Qp) (x : A) : mpred :=
      own g (●F{q} (to_agree x)).

    Definition frag (g : gname A) (q : Qp) (x : A) : mpred :=
      own g (◯F{q} (to_agree x)).

    #[local] Instance auth_objective : Objective3 auth := _.
    #[local] Instance auth_frac g : FracSplittable_1 (auth g).
    Proof. solve_frac. Qed.
    #[local] Instance auth_agree g : AgreeF1 (auth g).
    Proof.
      (**
      TODO (PDS): Shouldn't need to expose [to_agree].
      *)
      intros. rewrite -(inj_iff to_agree). apply _.
    Qed.

    #[local] Instance frag_objective : Objective3 frag := _.
    #[local] Instance frag_frac g : FracSplittable_1 (frag g).
    Proof. solve_frac. Qed.
    #[local] Instance frag_agree g : AgreeF1 (frag g).
    Proof.
      (**
      TODO (PDS): own_frac_auth_frag_frac_agree_L missing in
      bedrock.lang.proofmode.own_obs
      *)
      intros. iIntros "F1 F2".
      iDestruct (own_valid_2 with "F1 F2") as %Hv. iModIntro. iPureIntro.
      move: Hv. rewrite -frac_auth_frag_op frac_auth_frag_valid=>-[] _.
      by rewrite to_agree_op_valid_L.
    Qed.

    #[local] Instance auth_frag_agree g q1 q2 x1 x2 :
      Observe2 [| x1 = x2 |] (auth g q1 x1) (frag g q2 x2).
    Proof.
      (**
      TODO (PDS): Problem with [own_frac_auth_agree_L]
      *)
      intros. iIntros "A F".
      iDestruct (observe_2 [| _ ≼ _ |] with "A F") as %Hinc.
      iModIntro. iPureIntro. move: Hinc.
      move/to_agree_included. by fold_leibniz.
    Qed.

    #[local] Notation OWN g x := (auth g 1 x ** frag g 1 x) (only parsing).

    Lemma alloc x : |-- |==> Exists g, OWN g x.
    Proof.
      iMod (own_alloc (●F{1} (to_agree x) ⋅ ◯F{1} (to_agree x))) as (g) "[A F]".
      { by apply frac_auth_valid. }
      iExists g. by iFrame "A F".
    Qed.

    Lemma update g x y :
      |-- auth g 1 x -* frag g 1 x -* |==> OWN g y.
    Proof.
      iIntros "A F". iMod (own_update_2 with "A F") as "[$$]"; last done.
      by apply frac_auth_update_1.
    Qed.
  End defs.

End afrac.


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

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

Local Open Scope struct_scope.

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

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

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

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

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

Import DePoolSpec.LedgerClass.SolidityNotations.

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

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

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

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo.
Opaque DePoolContract_Ф_startRoundCompleting ProxyBase_Ф__recoverStake.

Lemma DePoolContract_Ф_updateRound2_exec : forall ( Л_round2 : RoundsBase_ι_Round )
                                                  ( Л_prevValidatorHash : XInteger256 )
                                                  ( Л_curValidatorHash : XInteger256 )
                                                  ( Л_validationStart : XInteger32 )
                                                  (l: Ledger) ,
let round2 := Л_round2 in
let if1 : bool  :=  eqb ( round2 ->> RoundsBase_ι_Round_ι_step )  RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest in
let if2 : bool  :=  eqb ( round2 ->> RoundsBase_ι_Round_ι_completionReason )  RoundsBase_ι_CompletionReasonP_ι_Undefined in
let if3 : bool  :=  eqb (round2 ->> RoundsBase_ι_Round_ι_step )  RoundsBase_ι_RoundStepP_ι_Completing in
let round2 := if if1 then
                      if if2 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze);
                                                 (RoundsBase_ι_Round_ι_completionReason, RoundsBase_ι_CompletionReasonP_ι_NoValidatorRequest);
                                                 (RoundsBase_ι_Round_ι_unfreeze, 0) $}
                             else {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze);
                                                 (RoundsBase_ι_Round_ι_unfreeze, 0) $}
                      else round2 in
let oldMessages := VMState_ι_messages ( Ledger_ι_VMState l ) in
let oldEvents := VMState_ι_events ( Ledger_ι_VMState l ) in
let newMessage  := {|  contractAddress :=  0 ;
                        contractFunction := DePoolContract_Ф_completeRoundWithChunkF round2->>RoundsBase_ι_Round_ι_id 1 ;
                        contractMessage := {| messageValue := 0 ;
                                              messageFlag  := 0 ;
                                              messageBounce := false
                                                  |} |} in
let l' :=   if if1 then l
                   else if if3 then {$ l With (VMState_ι_messages, newMessage :: oldMessages ) $}
                               else l
                      in
let if4 : bool :=  ( ( negb ( eqb ( round2 ->> RoundsBase_ι_Round_ι_vsetHashInElectionPhase ) Л_curValidatorHash ) )  &&
                     ( negb ( eqb ( round2 ->> RoundsBase_ι_Round_ι_vsetHashInElectionPhase ) Л_prevValidatorHash ) )  &&
                     (  eqb (round2 ->> RoundsBase_ι_Round_ι_unfreeze) DePoolLib_ι_MAX_TIME ) )%bool   in
let round2 := if if4 then {$ round2 with (RoundsBase_ι_Round_ι_unfreeze, Л_validationStart + round2->>RoundsBase_ι_Round_ι_stakeHeldFor) $}
                       else round2 in
let if5 : bool  := ( eval_state tvm_now  l ) >=? ( (round2 ->> RoundsBase_ι_Round_ι_unfreeze) +
                                                   DePoolLib_ι_ELECTOR_UNFREEZE_LAG ) in
let if6 : bool := (( eqb (round2 ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze ) &&
                     negb ( eqb (round2 ->> RoundsBase_ι_Round_ι_completionReason) RoundsBase_ι_CompletionReasonP_ι_Undefined ))%bool in
(* let if7 : bool := ( round2 ->> RoundsBase_ι_Round_ι_participantQty ) =? 0  in *)
let if8 : bool :=  ( ( eqb (round2 ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingValidationStart ) ||
                     ( eqb (round2 ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze ))%bool in
(* let round2' := if if5 then
                            if if6 then
                                   eval_state ( ↓ DePoolContract_Ф_startRoundCompleting round2 round2 ->> RoundsBase_ι_Round_ι_completionReason) l'
                                    else if if8 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_WaitingReward) $}
                                                else round2
                     else round2 in    *)
let l'' := if if5 then if if6 then exec_state ( ↓ DePoolContract_Ф_startRoundCompleting round2 round2 ->> RoundsBase_ι_Round_ι_completionReason) l'
                              else if if8 then  exec_state ( ↓ ProxyBase_Ф__recoverStake round2 ->> RoundsBase_ι_Round_ι_proxy
                                                                                round2 ->> RoundsBase_ι_Round_ι_id
                                                                                round2 ->> RoundsBase_ι_Round_ι_elector ) l'
                                          else l'
                     else l' in

exec_state ( ↓ DePoolContract_Ф_updateRound2 Л_round2 Л_prevValidatorHash Л_curValidatorHash Л_validationStart ) l = l''.

 Proof.

  intros.

  destructLedger l.
  destruct Л_round2.
  compute. idtac.

  Time do 3 destructIf_solve. idtac.

  -

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  time repeat destructIf_solve. idtac.
  destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

Qed.

Lemma DePoolContract_Ф_updateRound2_eval : forall ( Л_round2 : RoundsBase_ι_Round )
                                                   ( Л_prevValidatorHash : XInteger256 )
                                                   ( Л_curValidatorHash : XInteger256 )
                                                   ( Л_validationStart : XInteger32 )
                                                   (l: Ledger) ,
let round2 := Л_round2 in
let if1 : bool  :=  eqb ( round2 ->> RoundsBase_ι_Round_ι_step )  RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest in
let if2 : bool  :=  eqb ( round2 ->> RoundsBase_ι_Round_ι_completionReason )  RoundsBase_ι_CompletionReasonP_ι_Undefined in
let if3 : bool  :=  eqb (round2 ->> RoundsBase_ι_Round_ι_step )  RoundsBase_ι_RoundStepP_ι_Completing in
let round2 := if if1 then
                      if if2 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze);
                                                 (RoundsBase_ι_Round_ι_completionReason, RoundsBase_ι_CompletionReasonP_ι_NoValidatorRequest);
                                                 (RoundsBase_ι_Round_ι_unfreeze, 0) $}
                             else {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze);
                                                 (RoundsBase_ι_Round_ι_unfreeze, 0) $}
                      else round2 in
let oldMessages := VMState_ι_messages ( Ledger_ι_VMState l ) in
let newMessage  := {|  contractAddress :=  0 ;
                        contractFunction := DePoolContract_Ф_completeRoundWithChunkF round2->>RoundsBase_ι_Round_ι_id 1 ;
                        contractMessage := {| messageValue := 0 ;
                                              messageFlag  := 0 ;
                                              messageBounce := false
                                                  |} |} in
let l' :=   if if1 then l
                   else if if3 then {$ l With (VMState_ι_messages, newMessage :: oldMessages ) $}
                               else l
                      in

let if4 : bool :=  (( negb ( eqb ( round2 ->> RoundsBase_ι_Round_ι_vsetHashInElectionPhase ) Л_curValidatorHash ) )  &&
                    ( negb ( eqb ( round2 ->> RoundsBase_ι_Round_ι_vsetHashInElectionPhase ) Л_prevValidatorHash ) )  &&
                    ( eqb (round2 ->> RoundsBase_ι_Round_ι_unfreeze) DePoolLib_ι_MAX_TIME  ) )%bool   in
let round2 := if if4 then {$ round2 with (RoundsBase_ι_Round_ι_unfreeze, Л_validationStart + round2->>RoundsBase_ι_Round_ι_stakeHeldFor) $}
                       else round2 in
let if5 : bool  := ( eval_state tvm_now  l ) >=? ( (round2 ->> RoundsBase_ι_Round_ι_unfreeze) +
                                                   DePoolLib_ι_ELECTOR_UNFREEZE_LAG ) in
let if6 : bool := (( eqb (round2 ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze ) &&
                     negb ( eqb (round2 ->> RoundsBase_ι_Round_ι_completionReason) RoundsBase_ι_CompletionReasonP_ι_Undefined ))%bool in
let if8 : bool :=  ( ( eqb (round2 ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingValidationStart ) ||
                     ( eqb (round2 ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze ))%bool in
let round2 := if if5 then
                            if if6 then
                                   eval_state ( ↓ DePoolContract_Ф_startRoundCompleting round2 round2 ->> RoundsBase_ι_Round_ι_completionReason) l'
                                    else if if8 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_WaitingReward) $}
                                                else round2
                     else round2 in

eval_state ( ↓ DePoolContract_Ф_updateRound2 Л_round2 Л_prevValidatorHash Л_curValidatorHash Л_validationStart ) l = round2.

Proof.

  intros.

  destructLedger l.
  destruct Л_round2.
  compute. idtac.

  Time do 3 destructIf_solve. idtac.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  time repeat destructIf_solve. idtac.
  destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (0 =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

  - idtac.

  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_curValidatorHash);
  destruct (RoundsBase_ι_Round_ι_vsetHashInElectionPhase =? Л_prevValidatorHash);
  destruct (RoundsBase_ι_Round_ι_unfreeze =? DePoolLib_ι_MAX_TIME);
  try discriminate. idtac.

  all: time repeat destructIf_solve. idtac.
  all: destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

 Qed.

End DePoolContract_Ф_updateRound2.


Set Primitive Projections.
Set Implicit Arguments.

Record prod {A} {B}:= pair { fst : A ; snd : B }.
Notation " A * B " := (@prod A B) : type_scope.
Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
Notation pr1 := (@projT1 _ _).
Arguments prod : clear implicits.

Check (@projT1 _ (fun x : nat => x = x)).
Check (fun s : @sigT nat (fun x : nat => x = x) => s.(projT1)).

Record rimpl {b : bool} {n : nat} := { foo : forall {x : nat}, x = n }.

Check (fun r : @rimpl true 0 => r.(foo) (x:=0)).
Check (fun r : @rimpl true 0 => @foo true 0 r 0).
Check (fun r : @rimpl true 0 => foo r (x:=0)).
Check (fun r : @rimpl true 0 => @foo _ _ r 0).
Check (fun r : @rimpl true 0 => r.(@foo _ _)).
Check (fun r : @rimpl true 0 => r.(foo)).

Notation "{ x : T  & P }" := (@sigT T P).
Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
(* Notation "{ x : T * U  & P }" := (@sigT (T * U) P). *)

Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
Arguments idpath {A a} , [A] a.
Class IsEquiv {A B : Type} (f : A -> B) := {}.

Local Instance isequiv_tgt_compose A B
: @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
           (A -> B)
           (@compose A {xy : B * B & fst xy = snd xy} B
                     (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)).
(* Toplevel input, characters 220-223: *)
(* Error: Cannot infer this placeholder. *)

Local Instance isequiv_tgt_compose' A B
: @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
           (A -> B)
           (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)).
(* Toplevel input, characters 221-232: *)
(* Error: *)
(* In environment *)
(* A : Type *)
(* B : Type *)
(* The term "pr1" has type "sigT ?30 -> ?29" while it is expected to have type *)
(*  "{xy : B * B & fst xy = snd xy} -> ?27 * B". *)

Local Instance isequiv_tgt_compose'' A B
: @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
           (A -> B)
           (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _)
                                                                  (fun s => s.(projT1)))).
(* Toplevel input, characters 15-241:
Error:
Cannot infer an internal placeholder of type "Type" in environment:

A : Type
B : Type
x : ?32
. *)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export cvterm.
Require Export alphaeq.
Require Export list.  (* WTF!!! *)

Lemma wf_less_than {o} :
  forall (a b : @NTerm o),
    wf_term (mk_less_than a b) <=> (wf_term a # wf_term b).
Proof.
  introv.
  unfold mk_less_than.
  rw <- @wf_less_iff; split; intro k; repnd; dands; eauto 3 with slow.
Qed.

Lemma wf_le {o} :
  forall (a b : @NTerm o),
    wf_term (mk_le a b) <=> (wf_term a # wf_term b).
Proof.
  introv.
  unfold mk_le.
  rw @wf_not.
  rw @wf_less_than; dands; split; sp.
Qed.

Lemma wf_term_mk_natk {o} :
  forall (t : @NTerm o), wf_term (mk_natk t) <=> wf_term t.
Proof.
  introv.
  unfold mk_natk, mk_natk_aux.
  rw <- @wf_set_iff.
  rw @wf_prod.
  rw @wf_le.
  rw @wf_less_than.
  split; introv k; repnd; dands; eauto 3 with slow.
Qed.

Lemma cover_vars_upto_product {o} :
  forall vs (a : @NTerm o) v b sub,
    cover_vars_upto (mk_product a v b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b (csub_filter sub [v]) (v :: vs).
Proof.
  sp; repeat (rw cover_vars_eq); unfold cover_vars_upto; simpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw subvars_app_l.
  allrw subvars_remove_nvars; simpl.
  allrw @dom_csub_csub_filter.
  allrw subvars_prop; simpl; split; sp; apply_in_hyp pp;
  allrw in_app_iff; allrw in_remove_nvars; allrw in_single_iff; sp.
  generalize (deq_nvar v x); intro q; sp.
  right; right; sp.
Qed.

Lemma cover_vars_upto_prod {o} :
  forall vs (a b : @NTerm o) sub,
    cover_vars_upto (mk_prod a b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b sub vs.
Proof.
  introv.
  rw @cover_vars_upto_product.
  split; intro k; repnd; dands; auto.
  - allunfold @cover_vars_upto.
    allrw subvars_prop; introv i.
    applydup k in i; allsimpl; allrw in_app_iff; repndors; subst; tcsp.
    + pose proof (newvar_prop b); sp.
    + rw @dom_csub_csub_filter in i0.
      rw in_remove_nvars in i0; sp.
  - allunfold @cover_vars_upto.
    allrw subvars_prop; introv i.
    applydup k in i; allsimpl; allrw in_app_iff; repndors; tcsp.
    rw @dom_csub_csub_filter.
    rw in_remove_nvars; simpl.
    destruct (deq_nvar (newvar b) x) as [j|j]; subst; tcsp.
    right; right; sp.
Qed.

Lemma cover_vars_upto_less {o} :
  forall vs (a b c d : @NTerm o) sub,
    cover_vars_upto (mk_less a b c d) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b sub vs
        # cover_vars_upto c sub vs
        # cover_vars_upto d sub vs.
Proof.
  introv.
  unfold cover_vars_upto; simpl.
  allrw remove_nvars_nil_l.
  allrw app_nil_r.
  allrw subvars_app_l.
  sp.
Qed.

Lemma cover_vars_upto_mk_true {o} :
  forall (sub : @CSub o) vs, cover_vars_upto mk_true sub vs.
Proof.
  introv; unfold cover_vars_upto; simpl; auto.
Qed.
Hint Resolve cover_vars_upto_mk_true : slow.

Lemma cover_vars_upto_less_than {o} :
  forall vs (a b : @NTerm o) sub,
    cover_vars_upto (mk_less_than a b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b sub vs.
Proof.
  introv.
  rw @cover_vars_upto_less.
  split; introv k; repnd; dands; eauto 3 with slow; tcsp.
Qed.

Lemma cover_vars_upto_not {o} :
  forall vs (a : @NTerm o) sub,
    cover_vars_upto (mk_not a) sub vs
    <=> cover_vars_upto a sub vs.
Proof.
  introv.
  unfold mk_not.
  rw @cover_vars_upto_fun; split; introv k; repnd; dands; eauto 3 with slow.
Qed.

Lemma cover_vars_upto_le {o} :
  forall vs (a b : @NTerm o) sub,
    cover_vars_upto (mk_le a b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b sub vs.
Proof.
  introv.
  unfold mk_le.
  rw @cover_vars_upto_not.
  rw @cover_vars_upto_less_than.
  split; sp.
Qed.

Lemma cover_vars_mk_int {o} :
  forall (s : @CSub o), cover_vars mk_int s.
Proof.
  introv.
  rw @cover_vars_eq; simpl; auto.
Qed.
Hint Resolve cover_vars_mk_int : slow.

Lemma cover_vars_upto_mk_zero {o} :
  forall (s : @CSub o) vs, cover_vars_upto mk_zero s vs.
Proof.
  introv.
  unfold cover_vars_upto; simpl; auto.
Qed.
Hint Resolve cover_vars_upto_mk_zero : slow.

Lemma cover_vars_mk_natk {o} :
  forall (t : @NTerm o) s,
    cover_vars (mk_natk t) s <=> cover_vars t s.
Proof.
  introv.
  unfold mk_natk, mk_natk_aux.
  rw @cover_vars_set.
  rw @cover_vars_upto_prod.
  rw @cover_vars_upto_le.
  rw @cover_vars_upto_less_than.
  split; introv k; repnd; dands; eauto 3 with slow; tcsp;
  try (complete (apply cover_vars_upto_var; simpl; tcsp)).

  - unfold cover_vars_upto in k; allsimpl.
    rw @cover_vars_eq.
    apply subvars_cons_r_weak_if_not_in in k;[|apply newvar_prop].
    rw @dom_csub_csub_filter in k.
    eapply subvars_trans;[exact k|].
    rw subvars_prop; introv i; allsimpl; allrw in_remove_nvars; tcsp.

  - unfold cover_vars_upto; allsimpl.
    rw @cover_vars_eq in k.
    rw @dom_csub_csub_filter.
    eapply subvars_trans;[exact k|].
    rw subvars_prop; introv i; allsimpl; allrw in_remove_nvars; allsimpl.
    destruct (deq_nvar (newvar t) x); tcsp.
    right; sp.
Qed.

Lemma cover_vars_mk_tnat {o} :
  forall (s : @CSub o), cover_vars mk_tnat s.
Proof.
  introv.
  unfold mk_tnat.
  rw @cover_vars_set; dands; eauto 3 with slow.
  apply cover_vars_upto_le; dands; eauto 3 with slow.
  apply cover_vars_upto_var; simpl; sp.
Qed.
Hint Resolve cover_vars_mk_tnat : slow.

Lemma sub_find_sub_filter_trivial {o} :
  forall (s : @Sub o) x, sub_find (sub_filter s [x]) x = None.
Proof.
  introv.
  rw @sub_find_sub_filter_eq; rw memvar_singleton; boolvar; auto.
Qed.
Hint Rewrite @sub_find_sub_filter_trivial : slow.

Lemma sub_find_sub_filter_trivial2 {o} :
  forall (s : @Sub o) x y, sub_find (sub_filter (sub_filter s [x]) [y]) x = None.
Proof.
  introv.
  allrw @sub_find_sub_filter_eq.
  allrw memvar_singleton; boolvar; auto.
Qed.
Hint Rewrite @sub_find_sub_filter_trivial2 : slow.

Lemma beq_var_newvar_trivial1 {o} :
  forall v (t : @NTerm o),
    LIn v (free_vars t)
    -> beq_var v (newvar t) = false.
Proof.
  introv i; boolvar; auto.
  pose proof (newvar_prop t) as h; allsimpl; allrw not_over_or; tcsp.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import sequents2.

Lemma pointwise_implies_pairwise {o} :
  forall lib (s : @csequent o),
    AN_sequent_true_pairwise lib s -> VR_sequent_true lib s.
Proof.
  introv seq.
  unfold VR_sequent_true.
  unfold AN_sequent_true_pairwise in seq.
  introv.
  generalize (seq s1 s2); clear seq; intro seq.
  destruct (destruct_csequent s); destruct ec; exrepnd; intros sim eqh; auto.
Qed.

Definition pairwise_sequent_true {o} lib (s : @baresequent o) :=
  {c : wf_csequent s & AN_sequent_true_pairwise lib (mk_wcseq s c)}.

Definition pairwise_rule_true2 {o} lib (R : @rule o) : Type :=
  forall pwf   : pwf_sequent (goal R),
  forall cargs : args_constraints (sargs R) (hyps (goal R)),
  forall hyps  : (forall s, LIn s (subgoals R) -> pairwise_sequent_true lib s),
    pairwise_sequent_true lib (goal R).

Definition pairwise_rule_true3 {o} lib (R : @rule o) : Type :=
  forall pwf   : wf_bseq (goal R),
  forall cargs : args_constraints (sargs R) (hyps (goal R)),
  forall hyps  : (forall s, LIn s (subgoals R) -> pairwise_sequent_true lib s),
    pairwise_sequent_true lib (goal R).

Lemma pairwise_rule_true3_implies_pairwise_rule_true2 {o} :
  forall lib (R : @rule o), pairwise_rule_true3 lib R -> pairwise_rule_true2 lib R.
Proof.
  introv rt wf args imp.
  unfold pairwise_rule_true3 in rt.
  repeat (autodimp rt hyp); eauto 3 with slow.
Qed.
Hint Resolve pairwise_rule_true3_implies_pairwise_rule_true2 : slow.

Lemma AN_sequent_true_pairwise_all {o} :
  forall lib (S : @csequent o),
    AN_sequent_true_pairwise lib S
    <=>
    forall s1 s2,
      match destruct_csequent S with
      | cseq_comps H T wh wt ct ec =>
        forall pC1 : cover_vars T s1,
        forall pC2 : cover_vars T s2,
          similarity lib s1 s2 H
          -> eq_hyps lib s1 s2 H
          -> match ec with
             | Some (existT _ ext (we, ce)) =>
               forall pt1 : cover_vars ext s1,
               forall pt2 : cover_vars ext s2,
                 tequality lib (lsubstc T wt s1 pC1)
                           (lsubstc T wt s2 pC2)
                           # equality lib (lsubstc ext we s1 pt1)
                           (lsubstc ext we s2 pt2)
                           (lsubstc T wt s1 pC1)
             | None => tequality lib (lsubstc T wt s1 pC1)
                                 (lsubstc T wt s2 pC2)
             end
      end.
Proof.
  unfold AN_sequent_true_pairwise; split; intro h;
    destruct (destruct_csequent S); destruct ec; exrepnd; introv.

  { introv sim eqh; introv.
    pose proof (h s2 s3 sim eqh) as h.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC1) in h; auto.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC2) in h; auto.
    rewrite lsubstc_replace with (w2 := s1) (p2 := pt1) in h; auto.
    rewrite lsubstc_replace with (w2 := s1) (p2 := pt2) in h; auto. }

  { introv sim eqh.
    pose proof (h s1 s2 sim eqh) as h.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC1) in h; auto.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC2) in h; tcsp. }

  { introv eqh; eapply h; auto. }

  { introv eqh; dands; auto. }
Qed.

Lemma AN_sequent_true_pairwise_ex {o} :
  forall lib (S : @csequent o),
    AN_sequent_true_pairwise lib S
    <=>
    forall s1 s2,
      match destruct_csequent S with
      | cseq_comps H T wh wt ct ec =>
        similarity lib s1 s2 H
        -> eq_hyps lib s1 s2 H
        -> {pC1 : cover_vars T s1
            & {pC2 : cover_vars T s2
            & tequality lib (lsubstc T wt s1 pC1)
                        (lsubstc T wt s2 pC2)
              #
              match ec with
              | Some (existT _ ext (we, ce)) =>
                {pt1 : cover_vars ext s1
                 & {pt2 : cover_vars ext s2
                 & equality lib (lsubstc ext we s1 pt1)
                            (lsubstc ext we s2 pt2)
                            (lsubstc T wt s1 pC1)}}
              | None => True
              end}}
      end.
Proof.
  unfold AN_sequent_true_pairwise; split; intro h;
    destruct (destruct_csequent S); destruct ec; exrepnd; introv; auto.

  { introv sim eqh.
    pose proof (h s2 s3 sim eqh) as h; repnd.
    exists (s_cover_typ1 lib T s2 s3 hs ct sim)
           (s_cover_typ2 lib T s2 s3 hs ct sim); sp.
    exists (s_cover_ex1 lib t s2 s3 hs s0 sim)
           (s_cover_ex2 lib t s2 s3 hs s0 sim); sp. }

  { introv sim eqh.
    pose proof (h s1 s2 sim eqh) as h; repnd.
    exists (s_cover_typ1 lib T s1 s2 hs ct sim)
           (s_cover_typ2 lib T s1 s2 hs ct sim); sp. }

  { introv eqh.
    pose proof (h s2 s3 p eqh) as h; exrepnd.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC1); auto.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC2); auto.
    rewrite lsubstc_replace with (w2 := s1) (p2 := pt1); auto.
    rewrite lsubstc_replace with (w2 := s1) (p2 := pt2); auto. }

  { introv eqh.
    pose proof (h s1 s2 p eqh ) as h; exrepnd.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC1); auto.
    rewrite lsubstc_replace with (w2 := wt) (p2 := pC2); auto. }
Qed.

Tactic Notation "seq_true_pairwise" :=
  rw @AN_sequent_true_pairwise_all;
  simpl;
  introv sim eqh;
  introv;
  proof_irr;
  GC.

Ltac seq_true_pairwise_ltac H :=
  trw_h AN_sequent_true_pairwise_ex  H;
  simpl in H.

Tactic Notation "seq_true_pairwise" "in" ident(H) :=
  seq_true_pairwise_ltac H.

Ltac prove_eq_hyps_snoc :=
  match goal with
  | [ |- eq_hyps _ (snoc ?s1 (?x1,?t1)) (snoc ?s2 (?x2,?t2)) (snoc ?hs ?h) ] =>
    let wf := fresh "wf" in
    let cov1 := fresh "cov1" in
    let cov2 := fresh "cov2" in
    assert (wf_term (htyp h)) as wf;
    [simpl;auto
    |assert (cover_vars (htyp h) s1) as cov1;
     [simpl;auto
     |assert (cover_vars (htyp h) s2) as cov2;
      [simpl;auto
      |apply eq_hyps_snoc;
       exists s1 s2 t1 t2 wf cov1 cov2;
       simpl;dands;auto
      ]
     ]
    ]
  end.


From iris.base_logic Require Import invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.algebra Require Import excl.
From iris_examples.concurrent_stacks Require Import specs.
From iris.prelude Require Import options.

(** Stack 4: Helping, CAP spec. *)

Definition mk_offer : val :=
  λ: "v", ("v", ref #0).
Definition revoke_offer : val :=
  λ: "v", if: CAS (Snd "v") #0 #2 then SOME (Fst "v") else NONE.
Definition take_offer : val :=
  λ: "v", if: CAS (Snd "v") #0 #1 then SOME (Fst "v") else NONE.

Definition mk_mailbox : val := λ: "_", ref NONEV.
Definition put : val :=
  λ: "r" "v",
    let: "off" := mk_offer "v" in
    "r" <- SOME "off";;
    revoke_offer "off".
Definition get : val :=
  λ: "r",
    let: "offopt" := !"r" in
    match: "offopt" with
      NONE => NONE
    | SOME "x" => take_offer "x"
    end.

Definition mk_stack : val := λ: "_", (mk_mailbox #(), ref NONEV).
Definition push : val :=
  rec: "push" "p" "v" :=
    let: "mailbox" := Fst "p" in
    let: "s" := Snd "p" in
    match: put "mailbox" "v" with
      NONE => #()
    | SOME "v'" =>
      let: "tail" := ! "s" in
      let: "new" := SOME (ref ("v'", "tail")) in
      if: CAS "s" "tail" "new" then #() else "push" "p" "v'"
    end.
Definition pop : val :=
  rec: "pop" "p" :=
    let: "mailbox" := Fst "p" in
    let: "s" := Snd "p" in
    match: get "mailbox" with
      NONE =>
      match: !"s" with
        NONE => NONEV
      | SOME "l" =>
        let: "pair" := !"l" in
        if: CAS "s" (SOME "l") (Snd "pair")
        then SOME (Fst "pair")
        else "pop" "p"
      end
    | SOME "x" => SOME "x"
    end.

Definition channelR := exclR unitR.
Class channelG Σ := {channel_inG :> inG Σ channelR}.

Section proofs.
  Context `{!heapGS Σ, !channelG Σ} (N : namespace).

  Implicit Types l : loc.

  Definition Nside_channel := N .@ "side_channel".
  Definition Nstack := N .@ "stack".
  Definition Nmailbox := N .@ "mailbox".

  Definition inner_mask : coPset := ⊤ ∖ ↑Nside_channel ∖ ↑Nstack.

  Lemma inner_mask_includes :
     ⊤ ∖ ↑ N ⊆ inner_mask.
  Proof. solve_ndisj. Qed.

  Lemma inner_mask_promote (P Q : iProp Σ) :
     (P ={⊤ ∖ ↑ N}=∗ Q) -∗ (P ={inner_mask}=∗ Q).
  Proof.
    iIntros "Himp P".
    iMod (fupd_mask_subseteq (⊤ ∖ ↑ N)) as "H"; first by apply inner_mask_includes.
    iDestruct ("Himp" with "P") as "HQ".
    iMod "HQ".
    by iMod "H".
  Qed.

  Definition revoke_tok γ := own γ (Excl ()).
  Definition can_push P Q v : iProp Σ :=
    (∀ (xs : list val), P xs ={inner_mask}=∗ P (v :: xs) ∗ Q #())%I.
  Definition access_inv (P : list val → iProp Σ) : iProp Σ :=
    (|={⊤ ∖ ↑Nside_channel, inner_mask}=> ∃ vs, (▷ P vs) ∗
      ((▷ P vs) ={inner_mask, ⊤ ∖ ↑Nside_channel}=∗ True))%I.

  Definition stages γ P Q l (v : val) :=
    ((l ↦ #0 ∗ can_push P Q v)  ∨
     (l ↦ #1 ∗ Q #()) ∨
     (l ↦ #1 ∗ revoke_tok γ) ∨
     (l ↦ #2 ∗ revoke_tok γ))%I.

  Definition is_offer γ P Q (v : val) : iProp Σ :=
    (∃ v' l, ⌜v = (v', #l)%V⌝ ∗ inv Nside_channel (stages γ P Q l v'))%I.

  Lemma mk_offer_works P Q v :
    {{{ can_push P Q v }}}
      mk_offer v
    {{{ o γ, RET o; is_offer γ P Q o ∗ revoke_tok γ }}}.
  Proof.
    iIntros (Φ) "HP HΦ".
    wp_lam. wp_alloc l as "Hl".
    iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
    iMod (inv_alloc Nside_channel _ (stages γ P Q l v) with "[Hl HP]") as "#Hinv".
    { iNext; iLeft; iFrame. }
    wp_pures; iModIntro; iApply "HΦ"; iFrame; iExists _, _; auto.
  Qed.

  Lemma revoke_works γ P Q v :
    {{{ is_offer γ P Q v ∗ revoke_tok γ }}}
      revoke_offer v
    {{{ v', RET v'; (∃ v'' : val, ⌜v' = InjRV v''⌝ ∗ can_push P Q v'') ∨ (⌜v' = InjLV #()⌝ ∗ (Q #())) }}}.
  Proof.
    iIntros (Φ) "[Hinv Hγ] HΦ". iDestruct "Hinv" as (v' l) "[-> #Hinv]".
    wp_lam. wp_pures. wp_bind (CmpXchg _ _ _).
    iInv Nside_channel as "Hstages" "Hclose".
    iDestruct "Hstages" as "[[Hl HP] | [[Hl HQ] | [[Hl H] | [Hl H]]]]".
    - wp_cmpxchg_suc.
      iMod ("Hclose" with "[Hl Hγ]") as "_".
      { iNext; iRight; iRight; iFrame. }
      iModIntro.
      wp_pures.
      by iApply "HΦ"; iLeft; iExists _; iFrame.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl Hγ]") as "_".
      { iNext; iRight; iRight; iLeft; iFrame. }
      iModIntro.
      wp_pures.
      iApply ("HΦ" with "[HQ]"); iRight; auto.
    - wp_cmpxchg_fail.
      iDestruct (own_valid_2 with "H Hγ") as %[].
    - wp_cmpxchg_fail.
      iDestruct (own_valid_2 with "H Hγ") as %[].
  Qed.

  Lemma take_works γ P Q Q' o Ψ :
    let do_pop : iProp Σ :=
        (∀ v xs, P (v :: xs) ={inner_mask}=∗ P xs ∗ Ψ (SOMEV v))%I in
    {{{ is_offer γ P Q o ∗ access_inv P ∗ (do_pop ∧ Q') }}}
      take_offer o
    {{{ v', RET v';
        (∃ v'' : val, ⌜v' = InjRV v''⌝ ∗ Ψ v') ∨ (⌜v' = InjLV #()⌝ ∗ (do_pop ∧ Q')) }}}.
  Proof.
    simpl; iIntros (Φ) "[H [Hopener Hupd]] HΦ"; iDestruct "H" as (v l) "[-> #Hinv]".
    wp_lam. wp_proj. wp_bind (CmpXchg _ _ _).
    iInv Nside_channel as "Hstages" "Hclose".
    iDestruct "Hstages" as "[[Hl Hpush] | [[Hl HQ] | [[Hl Hγ] | [Hl Hγ]]]]".
    - iMod "Hopener" as (xs) "[HP Hcloser]".
      wp_cmpxchg_suc.
      iMod ("Hpush" with "HP") as "[HP HQ]".
      iMod ("Hupd" with "HP") as "[HP HΨ]".
      iMod ("Hcloser" with "HP") as "_".
      iMod ("Hclose" with "[Hl HQ]") as "_".
      { iRight; iLeft; iFrame. }
      iApply fupd_mask_intro_subseteq; first done.
      wp_pures.
      iApply "HΦ"; iLeft; auto.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl HQ]") as "_".
      { iRight; iLeft; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; auto.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl Hγ]").
      { iRight; iRight; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; auto.
    - wp_cmpxchg_fail.
      iMod ("Hclose" with "[Hl Hγ]").
      { iRight; iRight; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; auto.
  Qed.

  Definition mailbox_inv P l : iProp Σ :=
    (l ↦ NONEV ∨ (∃ v' γ Q, l ↦ SOMEV v' ∗ is_offer γ P Q v'))%I.

  Definition is_mailbox P v : iProp Σ :=
    (∃ l, ⌜v = #l⌝ ∗ inv Nmailbox (mailbox_inv P l))%I.

  Lemma mk_mailbox_works P :
    {{{ True }}} mk_mailbox #() {{{ v, RET v; is_mailbox P v }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam. wp_alloc l as "Hl".
    iMod (inv_alloc Nmailbox _ (mailbox_inv P l) with "[Hl]") as "#Hinv".
    { iNext; by iLeft. }
    iModIntro.
    iApply "HΦ"; iExists _; auto.
  Qed.

  Lemma get_works Q P Ψ mailbox :
    let do_pop : iProp Σ :=
        (∀ v xs, P (v :: xs) ={inner_mask}=∗ P xs ∗ Ψ (SOMEV v))%I in
    {{{ is_mailbox P mailbox ∗ access_inv P ∗ (do_pop ∧ Q) }}}
      get mailbox
    {{{ ov, RET ov; (∃ v, ⌜ov = SOMEV v⌝ ∗ Ψ ov) ∨ (⌜ov = NONEV⌝ ∗ (do_pop ∧ Q)) }}}.
  Proof.
    simpl; iIntros (Φ) "[Hmail [Hopener Hpush]] HΦ". iDestruct "Hmail" as (l) "[-> #Hmail]".
    wp_lam. wp_bind (Load _).
    iInv Nmailbox as "[Hnone | Hsome]" "Hclose".
    - wp_load.
      iMod ("Hclose" with "[Hnone]") as "_".
      { by iLeft. }
      iModIntro.
      wp_pures.
      iApply "HΦ"; iRight; by iFrame.
    - iDestruct "Hsome" as (v' γ Q') "[Hl #Hoffer]".
      wp_load.
      iMod ("Hclose" with "[Hl Hoffer]") as "_".
      { iNext; iRight; iExists _, _, _; by iFrame. }
      iModIntro.
      wp_let. wp_match. wp_apply (take_works with "[Hpush Hopener]"); by iFrame.
  Qed.

  Lemma put_works P Q mailbox v :
    {{{ is_mailbox P mailbox ∗ can_push P Q v }}}
      put mailbox v
    {{{ o, RET o; (∃ v', ⌜o = SOMEV v'⌝ ∗ can_push P Q v') ∨ (⌜o = NONEV⌝ ∗ Q #()) }}}.
  Proof.
    iIntros (Φ) "[Hmail Hpush] HΦ". iDestruct "Hmail" as (l) "[-> #Hmail]".
    wp_lam. wp_let. wp_apply (mk_offer_works with "Hpush").
    iIntros (o γ) "[#Hoffer Hrev]".
    wp_let. wp_bind (Store _ _). wp_pures.
    iInv Nmailbox as "[Hnone | Hsome]" "Hclose".
    - wp_store.
      iMod ("Hclose" with "[Hnone]") as "_".
      { iNext; iRight; iExists _, _, _; by iFrame. }
      iModIntro.
      wp_pures.
      wp_apply (revoke_works with "[Hrev]"); first auto.
      iIntros (v') "H"; iApply "HΦ"; auto.
    - iDestruct "Hsome" as (v' γ' Q') "[Hl _]". wp_store.
      iMod ("Hclose" with "[Hl]") as "_".
      { iNext; iRight; iExists _, _, _; by iFrame. }
      iModIntro.
      wp_pures.
      wp_apply (revoke_works with "[Hrev]"); first auto.
      iIntros (v'') "H"; iApply "HΦ"; auto.
  Qed.

  Definition oloc_to_val (ol: option loc) : val :=
    match ol with
    | None => NONEV
    | Some loc => SOMEV (#loc)
    end.
  Local Instance oloc_to_val_inj : Inj (=) (=) oloc_to_val.
  Proof. intros [|][|]; simpl; congruence. Qed.

  Fixpoint is_list xs v : iProp Σ :=
    (match xs, v with
     | [], None => True
     | x :: xs, Some l => ∃ t, l ↦□ (x, oloc_to_val t)%V ∗ is_list xs t
     | _, _ => False
     end)%I.

  Lemma is_list_dup xs v :
    is_list xs v -∗ is_list xs v ∗ match v with
      | None => True
      | Some l => ∃ h t, l ↦□ (h, oloc_to_val t)%V
      end.
  Proof.
    destruct xs, v; simpl; auto; first by iIntros "[]".
    iIntros "H"; iDestruct "H" as (t) "[#Hl Hstack]".
    iSplitL; first by (iExists _; iFrame). by iExists _, _.
  Qed.

  Lemma is_list_empty xs :
    is_list xs None -∗ ⌜xs = []⌝.
  Proof.
    destruct xs; iIntros "Hstack"; auto.
  Qed.

  Lemma is_list_cons xs l h t :
    l ↦□ (h, t) -∗
    is_list xs (Some l) -∗
    ∃ ys, ⌜xs = h :: ys⌝.
  Proof.
    destruct xs; first by iIntros "? %".
    iIntros "Hl Hstack"; iDestruct "Hstack" as (t') "(Hl' & Hrest)".
    iDestruct (mapsto_agree with "Hl Hl'") as "%"; simplify_eq; iExists _; auto.
  Qed.

  Definition stack_inv P l :=
    (∃ v xs, l ↦ oloc_to_val v ∗ is_list xs v ∗ P xs)%I.

  Definition is_stack_pred P v :=
    (∃ mailbox l, ⌜v = (mailbox, #l)%V⌝ ∗ is_mailbox P mailbox ∗ inv Nstack (stack_inv P l))%I.

  Theorem mk_stack_works (P : list val → iProp Σ) :
    {{{ P [] }}} mk_stack #() {{{ v, RET v; is_stack_pred P v }}}.
  Proof.
    iIntros (Φ) "HP HΦ".
    wp_lam.
    wp_alloc l as "Hl".
    wp_apply mk_mailbox_works ; first done. iIntros (v) "#Hmailbox".
    iMod (inv_alloc Nstack _ (stack_inv P l) with "[Hl HP]") as "#Hinv".
    { by iNext; iExists None, []; iFrame. }
    wp_pures. iModIntro; iApply "HΦ"; iExists _; auto.
  Qed.

  Theorem push_works P s v Ψ :
    {{{ is_stack_pred P s ∗ ∀ xs, P xs ={⊤ ∖ ↑ N}=∗ P (v :: xs) ∗ Ψ #()}}}
      push s v
    {{{ RET #(); Ψ #() }}}.
  Proof.
    iIntros (Φ) "[Hstack Hupd] HΦ". iDestruct "Hstack" as (mailbox l) "(-> & #Hmailbox & #Hinv)".
    iAssert (∀ (xs : list val), P xs ={inner_mask}=∗ P (v :: xs) ∗ Ψ #())%I with "[Hupd]" as "Hupd".
    { iIntros (xs). by iApply inner_mask_promote. }
    iLöb as "IH" forall (v).
    wp_lam. wp_pures.
    wp_apply (put_works with "[Hupd]"); first auto. iIntros (o) "H".
    iDestruct "H" as "[Hsome | [-> HΨ]]".
    - iDestruct "Hsome" as (v') "[-> Hupd]".
      wp_match.
      wp_bind (Load _).
      iInv Nstack as (list xs) "(Hl & Hlist & HP)" "Hclose".
      wp_load.
      iMod ("Hclose" with "[Hl Hlist HP]") as "_".
      { iNext; iExists _, _; iFrame. }
      clear xs.
      iModIntro.
      wp_let. wp_alloc l' as "Hl'". wp_pures. wp_bind (CmpXchg _ _ _).
      iInv Nstack as (list' xs) "(Hl & Hlist & HP)" "Hclose".
      destruct (decide (list = list')) as [ -> |].
      * wp_cmpxchg_suc. { destruct list'; left; done. }
        iMod (mapsto_persist with "Hl'") as "#Hl'".
        iMod (fupd_mask_subseteq inner_mask) as "Hupd'"; first solve_ndisj.
        iMod ("Hupd" with "HP") as "[HP HΨ]".
        iMod "Hupd'" as "_".
        iMod ("Hclose" with "[Hl HP Hlist]") as "_".
        { iNext; iExists (Some _), (v' :: xs); iFrame; iExists _; iFrame; auto. }
        iModIntro.
        wp_pures.
        by iApply ("HΦ" with "HΨ").
      * wp_cmpxchg_fail.
      { destruct list, list'; simpl; congruence. }
      { destruct list'; left; done. }
        iMod ("Hclose" with "[Hl HP Hlist]").
        { iExists _, _; iFrame. }
        iModIntro.
        wp_pures.
        iApply ("IH" with "HΦ Hupd").
    - wp_match. iApply ("HΦ" with "HΨ").
  Qed.

  Theorem pop_works P s Ψ :
    {{{ is_stack_pred P s ∗
        (∀ v xs, P (v :: xs) ={⊤ ∖ ↑ N}=∗ P xs ∗ Ψ (SOMEV v)) ∧
        (P [] ={⊤ ∖ ↑ N}=∗ P [] ∗ Ψ NONEV) }}}
      pop s
    {{{ v, RET v; Ψ v }}}.
  Proof.
    iIntros (Φ) "(Hstack & Hupd) HΦ".
    iDestruct "Hstack" as (mailbox l) "(-> & #Hmailbox & #Hinv)".
    iDestruct (bi.and_mono_r with "Hupd") as "Hupd"; first apply inner_mask_promote.
    iDestruct (bi.and_mono_l _ _ (∀ (v : val) (xs : list val), _)%I with "Hupd") as "Hupd".
    { iIntros "Hupdcons". iIntros (v xs). iSpecialize ("Hupdcons" $! v xs). iApply (inner_mask_promote with "Hupdcons"). }
    iLöb as "IH".
    wp_lam. wp_proj. wp_let. wp_proj. wp_let.
    wp_apply (get_works _ _ (λ v, Ψ v) with "[Hupd]").
    { iSplitR; first done.
      iFrame.
      iInv Nstack as (v xs) "(Hl & Hlist & HP)" "Hclose".
      iModIntro.
      iExists xs; iSplitL "HP"; first auto.
      iIntros "HP".
      iMod ("Hclose" with "[HP Hl Hlist]") as "_".
      { iNext; iExists _, _; iFrame. }
      auto. }
    iIntros (ov) "[Hsome | [-> Hupd]]".
    - iDestruct "Hsome" as (v) "[-> HΨ]".
      wp_pures.
      iApply ("HΦ" with "HΨ").
    - wp_match. wp_bind (Load _).
      iInv Nstack as (v xs) "(Hl & Hlist & HP)" "Hclose".
      wp_load.
      iDestruct (is_list_dup with "Hlist") as "[Hlist H]".
    destruct v as [l'|]; last first.
      * iDestruct (is_list_empty with "Hlist") as %->.
        iMod (fupd_mask_subseteq inner_mask) as "Hupd'"; first solve_ndisj.
        iMod ("Hupd" with "HP") as "[HP HΨ]".
        iMod "Hupd'" as "_".
        iMod ("Hclose" with "[Hlist Hl HP]") as "_".
        { iNext; iExists _, _; iFrame. }
        iModIntro.
        wp_match.
        iApply ("HΦ" with "HΨ").
      * iDestruct "H" as (h t) "Hl'".
        iMod ("Hclose" with "[Hlist Hl HP]") as "_".
        { iNext; iExists _, _; iFrame. }
        iModIntro.
        wp_match. wp_bind (Load _).
        iInv Nstack as (v xs') "(Hl & Hlist & HP)" "Hclose".
        wp_load.
        iMod ("Hclose" with "[Hlist Hl HP]") as "_".
        { iNext; iExists _, _; iFrame. }
        iModIntro.
        wp_pures. wp_bind (CmpXchg _ _ _).
        iInv Nstack as (v' xs'') "(Hl & Hlist & HP)" "Hclose".
        destruct (decide (v' = (Some l'))) as [ -> |].
        + wp_cmpxchg_suc.
          iDestruct (is_list_cons with "Hl' Hlist") as (ys) "%".
          simplify_eq.
          iMod (fupd_mask_subseteq inner_mask) as "Hupd'"; first solve_ndisj.
          iDestruct "Hupd" as "[Hupdcons _]".
          iMod ("Hupdcons" with "HP") as "[HP HΨ]".
          iMod "Hupd'" as "_".
          iDestruct "Hlist" as (t') "(Hl'' & Hlist)".
          iDestruct (mapsto_agree with "Hl' Hl''") as "%"; simplify_eq.
          iMod ("Hclose" with "[Hlist Hl HP]") as "_".
          { iNext; iExists _, _; iFrame. }
          iModIntro.
          wp_pures.
          iApply ("HΦ" with "HΨ").
        + wp_cmpxchg_fail. { destruct v'; simpl; congruence. }
          iMod ("Hclose" with "[Hlist Hl HP]") as "_".
          { iNext; iExists _, _; iFrame. }
          iModIntro.
          wp_pures.
          iApply ("IH" with "HΦ Hupd").
  Qed.
End proofs.

Program Definition spec {Σ} `{heapGS Σ, channelG Σ} : concurrent_stack Σ :=
  {| is_stack := is_stack_pred; new_stack := mk_stack; stack_push := push; stack_pop := pop |} .
Solve Obligations of spec with eauto using pop_works, push_works, mk_stack_works.