(*

  Copyright 2014 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 Export csubst3.
Require Export alphaeq3.

Lemma aeq_lsubstc_mk_subtype_ex {o} :
  forall (t1 t2 : @NTerm o)
         (sub : CSubstitution)
         (w : wf_term (mk_subtype t1 t2)) (c : cover_vars (mk_subtype t1 t2) sub),
  {w1 : wf_term t1
   & {w2 : wf_term t2
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
   & alphaeqc (lsubstc (mk_subtype t1 t2) w sub c)
              (mkc_subtype (lsubstc t1 w1 sub c1) (lsubstc t2 w2 sub c2)) }}}}.
Proof.
  introv.
  pose proof (lsubstc_mk_subtype_ex t1 t2 sub w c) as h.
  exrepnd.
  exists w1 w2 c1 c2.
  rw h1.
  unfold alphaeqc; simpl.
  unfold mk_subtype, mk_vsubtype, mk_member, mk_equality, mk_function.
  repeat prove_alpha_eq4.
  pose proof (ex_fresh_var (all_vars (csubst t2 sub))) as fvs.
  exrepnd.
  apply (al_bterm_aux [v]); simpl; auto.
  { apply disjoint_singleton_l.
    allrw in_app_iff; allrw not_over_or; sp. }
  repeat (rw @lsubst_aux_trivial_cl_term2; eauto 3 with slow);
  apply cover_vars_iff_closed_lsubstc; auto.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2008-02-22, 2009-10-20 (rpo)

convert CoLoR terms into Coccinelle terms
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil ATerm VecUtil.
From CoLoR Require VecUtil more_list APosition AContext ordered_set.
From Coq Require Inverse_Image Max.

(***********************************************************************)
(** convert a CoLoR signature into a Coccinelle signature *)

From CoLoR Require Import term_spec EqUtil.

Module Make_Signature (Import S : SIG) <: Signature.
  Module Symb <: decidable_set.S.
    Definition A := symbol Sig.
    Definition eq_bool := @beq_symb Sig.
    Lemma eq_bool_ok : forall a1 a2,
      match eq_bool a1 a2 with true => a1 = a2 | false => ~ a1 = a2 end.
    Proof.
      intros a1 a2. unfold eq_bool. case_beq_symb Sig a1 a2. refl.
      rewrite <- (beq_ko (@beq_symb_ok Sig)). hyp.
    Qed.
  End Symb.
  Definition arity (f : Sig) := Free (arity f).
End Make_Signature.

(***********************************************************************)
(** convert CoLoR variables to Coccinelle variables *)

From CoLoR Require Import NatUtil.

Module Var <: decidable_set.S.
  Definition A := nat.
  Definition eq_bool := beq_nat.
  Lemma eq_bool_ok : forall a1 a2,
    match eq_bool a1 a2 with true => a1 = a2 | false => ~ a1 = a2 end.
  Proof.
    intros a1 a2. unfold eq_bool. case_beq_nat a1 a2. refl.
    rewrite <- (beq_ko beq_nat_ok). hyp.
  Qed.
End Var.

(***********************************************************************)
(** convert CoLoR terms into Coccinelle terms *)

From Coq Require Import List Relations.
From CoLoR Require Import term SN ASubstitution.

Module Make_Term (Import S : SIG) <: Term.

  Notation aterm := (term Sig). Notation aterms := (vector aterm).
  Notation AVar := ATerm.Var.

  Module Sig := Make_Signature S.

  Include (term.Make' Sig Var).

  Fixpoint term_of_aterm (t : aterm) :=
    match t with
      | AVar x => Var x
      | Fun f ts =>
        let fix terms_of_aterms n (ts : aterms n) :=
          match ts with
            | Vnil => nil
            | Vcons u us => term_of_aterm u :: terms_of_aterms _ us
          end in Term f (terms_of_aterms (arity f) ts)
    end.

  Fixpoint terms_of_aterms n (ts : aterms n) :=
    match ts with
      | Vnil => nil
      | Vcons u us => term_of_aterm u :: terms_of_aterms us
    end.

  Lemma terms_of_aterms_eq : forall n (ts : aterms n),
    (fix terms_of_aterms n (ts : aterms n) :=
      match ts with
        | Vnil => nil
        | Vcons u us => term_of_aterm u :: terms_of_aterms _ us
      end) n ts = terms_of_aterms ts.

  Proof. induction ts; simpl; intros. refl. rewrite IHts. refl. Qed.

  Lemma term_of_aterm_fun : forall f ts,
    term_of_aterm (Fun f ts) = Term f (terms_of_aterms ts).

  Proof. intros. simpl. rewrite terms_of_aterms_eq. refl. Qed.

  Import VecUtil.

  Lemma terms_of_aterms_cast : forall n (ts : aterms n) p (e : n=p),
    terms_of_aterms (Vcast ts e) = terms_of_aterms ts.

  Proof.
    induction ts; destruct p; simpl; intros; try discr.
    rewrite Vcast_refl. refl.
    inversion e. subst p. rewrite Vcast_cons. simpl.
    rewrite IHts. refl.
  Qed.

  Lemma terms_of_aterms_app : forall n (ts : aterms n) p (us : aterms p),
    terms_of_aterms (Vapp ts us) = terms_of_aterms ts ++ terms_of_aterms us.

  Proof. induction ts; simpl; intros. refl. rewrite IHts. refl. Qed.

  Lemma length_terms_of_aterms : forall n (ts : aterms n),
    length (terms_of_aterms ts) = n.

  Proof. induction ts; simpl; intros. refl. rewrite IHts. refl. Qed.

  Fixpoint sub_of_asub (s : ASubstitution.substitution Sig) n :=
    match n with
      | 0 => nil
      | S n' => (n', term_of_aterm (s n')) :: sub_of_asub s n'
    end.

Import more_list.

Notation find := (@find _ eq_var_bool _).

  Lemma find_sub_of_asub : forall s n v, find v (sub_of_asub s n) =
    if bgt_nat n v then Some (term_of_aterm (s v)) else None.

  Proof.
    induction n; intros. refl. simpl sub_of_asub. simpl more_list.find.
    rewrite IHn. unfold eq_var_bool. case_beq_nat v n.
    assert (bgt_nat (S v) v = true). rewrite bgt_nat_ok. lia. rewrite H. refl.
    case_eq (bgt_nat n v); intros; case_eq (bgt_nat (S n) v); intros.
    refl. rewrite bgt_nat_ok in H0. rewrite bgt_nat_ko in H1. lia.
    rewrite bgt_nat_ok in H1. rewrite bgt_nat_ko in H0.
    rewrite (beq_ko beq_nat_ok) in H. lia. refl.
  Qed.

  Lemma term_of_aterm_sub : forall s k t, k > maxvar t ->
    term_of_aterm (sub s t) = apply_subst (sub_of_asub s k) (term_of_aterm t).

  Proof.
    intros s k t; pattern t; apply ATerm.term_ind
      with (Q := fun n (ts : aterms n) =>
        k > maxvars ts -> terms_of_aterms (Vmap (sub s) ts) =
        map (apply_subst (sub_of_asub s k)) (terms_of_aterms ts)); clear t.
    simpl. intros. rewrite find_sub_of_asub. case_eq (bgt_nat k x); intros.
    refl. rewrite bgt_nat_ko in H0. lia.
    intros. simpl sub. rewrite !term_of_aterm_fun. simpl.
    f_equal. apply H. hyp.
    refl. intros t n ts. simpl. rewrite maxvars_cons, gt_max.
    intros. destruct H1. rewrite H. 2: hyp. rewrite H0. 2: hyp. refl.
  Qed.

  Import APosition AContext.

  Lemma term_of_aterm_fill : forall u t c, term_of_aterm (fill c t) =
    replace_at_pos (term_of_aterm (fill c u)) (term_of_aterm t) (pos_context c).

  Proof.
    induction c; intros. refl. simpl fill. simpl pos_context.
    rewrite !term_of_aterm_fun, replace_at_pos_unfold.
    f_equal.
    rewrite !terms_of_aterms_cast, !terms_of_aterms_app. simpl.
    rewrite replace_at_pos_list_replace_at_pos_in_subterm, <- IHc. refl.
    rewrite length_terms_of_aterms. refl.
  Qed.

  Lemma is_a_pos_context : forall u c,
    is_a_pos (term_of_aterm (fill c u)) (pos_context c) = true.

  Proof.
    induction c; intros. refl. simpl fill. rewrite term_of_aterm_fun. simpl.
    rewrite terms_of_aterms_cast, terms_of_aterms_app. simpl.
    assert (nth_error (terms_of_aterms t ++ term_of_aterm (fill c u) ::
      terms_of_aterms t0) i = nth_error (terms_of_aterms t ++ term_of_aterm
        (fill c u) :: terms_of_aterms t0) (length (terms_of_aterms t))).
    f_equal. rewrite length_terms_of_aterms. refl.
    rewrite H, nth_error_at_pos. hyp.
  Qed.

End Make_Term.

(***********************************************************************)
(** module type for using Coccinelle's RPO *)

From CoLoR Require Import rpo rpo_extension.

Module Type PRECEDENCE.
  Parameter Sig : Signature.
  Parameter status : Sig -> status_type.
  Parameter prec_nat : Sig -> nat.
  Parameter bb : nat.
  Parameter prec_eq_status :
    forall f g, prec_eq prec_nat f g -> status f = status g.
End PRECEDENCE.

(***********************************************************************)
(** convert Coccinelle RPO into a CoLoR WeakRedPair *)

From CoLoR Require Import ARedPair ARelation RelUtil BoolUtil.

Module WP_RPO (Import P : PRECEDENCE) <: WeakRedPair.

  Definition Prec := Precedence status prec_nat prec_eq_status.

  Module S. Definition Sig := Sig. End S.

  Module Import Term := Make_Term S.

  Module Import Rpo := rpo.Make Term.

  Notation rpo := (rpo Prec P.bb).

  Definition Sig := Sig.
  Definition succ := transp (Rof rpo term_of_aterm).

  Import Inverse_Image.

  Lemma wf_succ : WF succ.

  Proof.
    apply wf_WF_transp. apply wf_inverse_image with (f:=term_of_aterm).
    apply wf_rpo. apply (prec_wf prec_nat).
  Qed.

  Import Max.

  Lemma sc_succ : substitution_closed succ.

  Proof.
    intros t u s h. unfold succ, transp, Rof. set (k:=max(maxvar t)(maxvar u)).
    rewrite term_of_aterm_sub with (k:=S k). 2: apply le_n_S; apply le_max_r.
    rewrite term_of_aterm_sub with (k:=S k). 2: apply le_n_S; apply le_max_l.
    apply rpo_subst. hyp.
  Qed.

  Notation empty_rpo_infos := (empty_rpo_infos Prec P.bb).
  Notation rpo_eval := (rpo_eval empty_rpo_infos P.bb).
  Notation rpo_eval_is_sound := (rpo_eval_is_sound_weak empty_rpo_infos P.bb).

  Import ordered_set.

  Definition bsucc t u :=
    match rpo_eval (term_of_aterm t) (term_of_aterm u) with
      | Some Greater_than => true
      | _ => false
    end.

  Lemma bsucc_ok : forall t u, bsucc t u = true -> succ t u.

  Proof.
    intros t u. unfold bsucc.
    gen (rpo_eval_is_sound (term_of_aterm t) (term_of_aterm u)).
    case (rpo_eval (term_of_aterm t) (term_of_aterm u)); try discr.
    destruct c; try discr. unfold succ, transp, Rof. auto.
  Qed.

  Lemma bsucc_sub : rel_of_bool bsucc << succ.

  Proof. intros t u. unfold rel. intro h. apply bsucc_ok. hyp. Qed.

  Definition equiv_aterm := Rof (equiv Prec) term_of_aterm.

  Definition succeq := succ U equiv_aterm.

  Lemma sc_succeq : substitution_closed succeq.

  Proof.
    intros t u s [h|h]. left. apply sc_succ. hyp. right.
    unfold equiv_aterm, Rof. set (k := max (maxvar t) (maxvar u)).
    rewrite term_of_aterm_sub with (k:=S k). 2: apply le_n_S; apply le_max_l.
    rewrite term_of_aterm_sub with (k:=S k). 2: apply le_n_S; apply le_max_r.
    apply equiv_subst. hyp.
  Qed.

  Lemma cc_succ : context_closed succ.

  Proof.
    intros t u c h. unfold succ, transp, Rof.
    rewrite term_of_aterm_fill with (u := AVar 0) (t:=t),
            term_of_aterm_fill with (u := AVar 0) (t:=u).
    apply rpo_add_context. hyp. apply is_a_pos_context.
  Qed.

  Lemma cc_equiv_aterm : context_closed equiv_aterm.

  Proof.
    intros t u c h. unfold equiv_aterm, Rof.
    rewrite term_of_aterm_fill with (u := AVar 0) (t:=t),
            term_of_aterm_fill with (u := AVar 0) (t:=u).
    apply equiv_add_context. hyp. apply is_a_pos_context.
  Qed.

  Lemma cc_succeq : context_closed succeq.

  Proof.
    intros t u c [h|h]. left. apply cc_succ. hyp.
    right. apply cc_equiv_aterm. hyp.
  Qed.

  Lemma refl_succeq : reflexive succeq.

  Proof.
    intro t. right. apply Eq.
  Qed.

  Lemma succ_succeq_compat : absorbs_left succ succeq.

  Proof.
    intros t v [u [[h1|h1] h2]]. apply rpo_trans with (term_of_aterm u); hyp.
    unfold succ, transp, Rof. rewrite equiv_rpo_equiv_1. apply h2. hyp.
  Qed.

  Definition bsucceq t u :=
    match rpo_eval (term_of_aterm t) (term_of_aterm u) with
      | Some Greater_than | Some Equivalent => true
      | _ => false
    end.

  Lemma bsucceq_ok : forall t u, bsucceq t u = true -> succeq t u.

  Proof.
    intros t u. unfold bsucceq.
    gen (rpo_eval_is_sound (term_of_aterm t) (term_of_aterm u)).
    case (rpo_eval (term_of_aterm t) (term_of_aterm u)); try discr.
    destruct c; try discr; unfold succeq, Relation_Operators.union,
      equiv_aterm, succ, transp, Rof; auto.
  Qed.

  Definition bsucceq_sub : rel_of_bool bsucceq << succeq.

  Proof. intros t u. unfold rel. intro h. apply bsucceq_ok. hyp. Qed.

  Lemma trans_succ : transitive succ.

  Proof.
    unfold succ. apply transp_trans. apply Rof_trans.
    intros t u v htu huv. apply rpo_trans with u; hyp.
  Qed.

  Lemma trans_equiv_aterm : transitive equiv_aterm.

  Proof.
    unfold equiv_aterm. apply Rof_trans.
    apply (@RelationClasses.Equivalence_Transitive _ _ (equiv_equiv Prec)).
  Qed.

  Lemma trans_succeq : transitive succeq.

  Proof.
    unfold succeq, Relation_Operators.union, transitive. intuition.
    left. apply trans_succ with y; hyp.
    left. revert H. unfold equiv_aterm, succ, transp, Rof. intro.
    rewrite <- equiv_rpo_equiv_2. apply H1. hyp.
    left. revert H1. unfold equiv_aterm, succ, transp, Rof. intro.
    rewrite equiv_rpo_equiv_1. apply H. hyp.
    right. apply trans_equiv_aterm with y; hyp.
  Qed.

End WP_RPO.

(***********************************************************************)
(** decide compatibility of statuses wrt precedences *)

Definition beq_status s1 s2 :=
  match s1, s2 with
    | Lex, Lex
    | Mul, Mul => true
    | _, _ => false
  end.

Lemma beq_status_ok : forall s1 s2, beq_status s1 s2 = true <-> s1 = s2.

Proof.
beq_symb_ok.
Qed.

Section prec_eq_status.

  Variables (Sig : Signature) (status : Sig -> status_type)
    (prec_nat : Sig -> nat).

  Lemma prec_eq_ok : forall f g,
    prec_eq_bool prec_nat f g = true <-> prec_eq prec_nat f g.

  Proof.
    intros f g. gen (prec_eq_bool_ok prec_nat f g). intuition.
    rewrite H1 in H. hyp. case_eq (prec_eq_bool prec_nat f g); intros.
    refl. rewrite H2 in H. absurd (prec_eq prec_nat f g); hyp.
  Qed.

  Definition bprec_eq_status_symb f g :=
    implb (prec_eq_bool prec_nat f g) (beq_status (status f) (status g)).

  Lemma bprec_eq_status_symb_ok : forall f g,
    bprec_eq_status_symb f g = true
    <-> (prec_eq prec_nat f g -> status f = status g).

  Proof.
    intros f g. unfold bprec_eq_status_symb, implb.
    case_eq (prec_eq_bool prec_nat f g); intros.
    rewrite prec_eq_ok in H. rewrite beq_status_ok. intuition.
    intuition. rewrite <- prec_eq_ok, H in H1. discr.
  Qed.

  Section bprec_eq_status_aux1.

    Variable f : Sig.

    Fixpoint bprec_eq_status_aux1 b gs :=
      match gs with
        | nil => b
        | g :: gs' => bprec_eq_status_aux1 (b && bprec_eq_status_symb f g) gs'
      end.

    Lemma bprec_eq_status_aux1_true : forall gs b,
      bprec_eq_status_aux1 b gs = true -> b = true.

    Proof.
      induction gs; simpl; intros. hyp.
      cut (b && bprec_eq_status_symb f a = true). rewrite andb_eq. intuition.
      apply IHgs. hyp.
    Qed.

    Arguments bprec_eq_status_aux1_true [gs b] _.

    Lemma bprec_eq_status_aux1_ok : forall gs b,
      bprec_eq_status_aux1 b gs = true ->
      forall g, In g gs -> prec_eq prec_nat f g -> status f = status g.

    Proof.
      induction gs; simpl; intros. contr. destruct H0.
      subst g. ded (bprec_eq_status_aux1_true H). rewrite andb_eq in H0.
      destruct H0. rewrite bprec_eq_status_symb_ok in H2. intuition.
      eapply IHgs. apply H. hyp. hyp.
    Qed.

  End bprec_eq_status_aux1.

  Arguments bprec_eq_status_aux1_ok [f gs b] _ _ _ _.

  Fixpoint bprec_eq_status_aux2 b fs :=
    match fs with
      | nil => b
      | f :: fs' => bprec_eq_status_aux2 (bprec_eq_status_aux1 f b fs') fs'
    end.

  Lemma bprec_eq_status_aux2_true : forall fs b,
    bprec_eq_status_aux2 b fs = true -> b = true.

  Proof.
    induction fs; simpl; intros. hyp. eapply bprec_eq_status_aux1_true.
    apply IHfs. apply H.
  Qed.

  Arguments bprec_eq_status_aux2_true [fs b] _.

  Lemma bprec_eq_status_aux2_ok : forall fs b,
    bprec_eq_status_aux2 b fs = true -> forall f g, In f fs -> In g fs ->
      prec_eq prec_nat f g -> status f = status g.

  Proof.
    induction fs; simpl; intros. contr. destruct H0; destruct H1.
    subst f. subst g. refl.
    subst f. ded (bprec_eq_status_aux2_true H).
    apply (bprec_eq_status_aux1_ok H0); hyp.
    subst g. ded (bprec_eq_status_aux2_true H).
    sym. apply (bprec_eq_status_aux1_ok H1). hyp. apply prec_eq_sym. hyp.
    eapply IHfs; ehyp.
  Qed.

  Definition bprec_eq_status := bprec_eq_status_aux2 true.

  Variable (Fs : list Sig) (Fs_ok : forall f, In f Fs).

  Lemma bprec_eq_status_ok : bprec_eq_status Fs = true ->
    forall f g, prec_eq prec_nat f g -> status f = status g.

  Proof.
    intros. eapply bprec_eq_status_aux2_ok. ehyp.
    apply Fs_ok. apply Fs_ok. hyp.
  Qed.

End prec_eq_status.

Arguments bprec_eq_status_ok [Sig] _ _ [Fs] _ _ _ _ _.

Ltac prec_eq_status s p o := apply (bprec_eq_status_ok s p o); check_eq
  || fail 10 "statuses incompatible with precedences".


Require Export PredMonad.Ordered4.Monad.

Import OTNotations.

(***
 *** Monads with State Effects
 ***)

(* State effects = get and put *)
Class MonadStateOps `(MOps:MonadOps) `(St:OType) : Type :=
  {
    getM : M @t@ St ;
    putM : St -o> M @t@ OTunit
  }.

Class MonadState `{MonadStateOps} : Prop :=
  {
    monad_state_monad :> Monad MOps;

    monad_state_get :
      forall `{A:OType} (m : M @t@ A),
        bindM @o@ getM @o@ (mkOTerm _ (fun _ => m)) =o= m ;

    monad_state_get_put :
      forall `{A:OType} (f : St -o> OTunit -o> M @t@ A),
        bindM @o@ getM @o@
              (mkOTerm (St -o> M @t@ A)
                       (fun s => bindM @o@ (putM @o@ s) @o@ (f @o@ s)))
        =o= bindM @o@ getM @o@
                  (mkOTerm (St -o> M @t@ A) (fun s => f @o@ s @o@ tt)) ;

    monad_state_put_get :
      forall `{A:OType} s (f : OTunit -o> St -o> M @t@ A),
        bindM @o@ (putM @o@ s) @o@
              (mkOTerm (OTunit -o> M @t@ A) (fun u => bindM @o@ getM @o@ (f @o@ u)))
        =o= bindM @o@ (putM @o@ s) @o@
                  (mkOTerm (OTunit -o> M @t@ A) (fun u => f @o@ u @o@ s)) ;

    monad_state_put_put :
      forall `{A:OType} s1 s2 (f : OTunit -o> OTunit -o> M @t@ A),
        bindM @o@ (putM @o@ s1) @o@
              (mkOTerm (OTunit -o> M @t@ A)
                       (fun u => bindM @o@ (putM @o@ s2) @o@ (f @o@ u)))
        =o= bindM @o@ (putM @o@ s2) @o@ (f @o@ tt)
  }.

(***
 *** The State Monad Transformer
 ***)

Instance StateT `(St:OType) `(MOps:MonadOps) :
  OTypeF (fun `(A:OType) => Pfun St (M @t@ (St *o* A)))
         (fun `(A:OType) => OTarrow_R St (M @t@ (St *o* A))) :=
  fun `(A:OType) => St -o> M @t@ (St *o* A).

Set Printing All.
Typeclasses eauto := debug.
Instance StateT_MonadOps `(St:OType) `(MOps:MonadOps) : MonadOps (StateT St MOps) :=
  {returnM :=
     fun `(A:OType) =>
       mkOTerm (A -o> St -o> M @t@ (St *o* A))
               (fun x s => returnM @o@ (s, x));
   bindM :=
     fun A B m f =>
       fun s => do s_x <- m s; f (snd s_x) (fst s_x);
   lrM := fun {A} _ => LR_Op_fun }.

(* The Monad instance for StateT *)
Global Instance StateT_Monad : Monad (StateT).
Proof.
  constructor; intros; unfold StateT, returnM, bindM, lrM, StateT_MonadOps.
  - auto with typeclass_instances.
  - prove_lr_proper.
  - prove_lr_proper.
  - intros R1 R2 subR; apply LRFun_Proper_subrelation; apply monad_proper_lrM;
      apply LRPair_Proper_subrelation; try assumption; reflexivity.
  - prove_lr.
  - transitivity (fun s => do s_x <- m s; returnM s_x).
    + split; build_lr_fun; apply monad_proper_bind; prove_lr.
    + prove_lr; autorewrite with LR; prove_lr.
  - prove_lr.
Qed.

Global Instance StateT_MonadStateOps : MonadStateOps S StateT :=
  { getM := fun s => returnM (s, s)
  ; putM := fun s _ => returnM (s, tt)
  }.

Global Instance StateT_MonadState : MonadState S StateT.
Proof.
  constructor; intros;
    unfold StateT, returnM, bindM, lrM, getM, putM,
    StateT_MonadOps, StateT_MonadStateOps.
  - auto with typeclass_instances.
  - prove_lr_proper.
  - prove_lr_proper.
  - prove_lr.
  - prove_lr.
  - prove_lr.
  - prove_lr.
Qed.

End StateT.


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

(**********************************************************************)
(*                  LambdaFactor Calculus                             *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus  from Project Coq                                  *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                           General.v                                *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega.
Require Import ArithRing.

(* some general-purpose tactics *)

Ltac eapply2 H := eapply H; eauto.

Ltac split_all := simpl; intros;
match goal with
| H : _ /\ _ |- _ => inversion_clear H; split_all
| H : if ?b then False else False |-_=> generalize H; clear H; case b; split_all
| |- if ?b then True else True => case b; auto
| H : false = true |-_=> inversion H
| H : exists _, _ |- _ => inversion H; clear H; split_all
| _ =>  try (split; split_all); try contradiction
end; try congruence; auto.

Ltac noway := intros; assert False by omega; contradiction.

Ltac exist x := exists x; split_all.

Ltac gen_case H W :=
  generalize H; clear H; case W; split_all.

Ltac gen2_case H0 H1 W :=
  generalize H0 H1; clear H0 H1; case W; split_all.

Ltac gen3_case H0 H1 H2 W :=
  generalize H0 H1 H2; clear H0 H1 H2; case W; split_all.

Ltac gen4_case H0 H1 H2 H3 W :=
  generalize H0 H1 H2 H3; clear H0 H1 H2 H3; case W; split_all.

Ltac gen_inv H W :=
  generalize H; clear H; inversion W; split_all.

Ltac gen2_inv H0 H1 W :=
  generalize H0 H1; clear H0 H1; inversion W; split_all.

Ltac gen3_inv H0 H1 H2 W :=
  generalize H0 H1 H2; clear H0 H1 H2; inversion W; split_all.

Ltac gen4_inv H0 H1 H2 H3 W :=
  generalize H0 H1 H2 H3; clear H0 H1 H2 H3; inversion W; split_all.

Ltac gen_case_inv H M := gen_case H M; inversion H; auto.

Ltac invsub := match goal with | H : _ = _ |- _ => inversion H; subst; clear H; invsub | _ => split_all end.

(* some arithmetic *)

Ltac dropS :=
match goal with
| |- S ?m <= S?n => cut(m<= n); [split_all; omega |]
| |- S ?m < S?n => cut(m< n); [split_all; omega |]
| |- S ?m >= S?n => cut(m>= n); [split_all; omega |]
| |- S ?m > S?n => cut(m> n); [split_all; omega |]
end.

Lemma times_distributive : forall m n p, (m+n) * p = m*p + n * p.
Proof. split_all. ring. Qed.

Lemma times_distributive2 :
forall m n p q, (m+n) * (p+q) = m*p + n * p + m*q + n*q.
Proof. split_all. ring. Qed.

Lemma times_positive: forall m n, m>0 -> n>0 -> m*n >0 .
Proof.
split_all. gen_case H m; gen_case H0 n; split_all; try noway.
case (n1 + n0 * S n1); split_all; omega.
Qed.

Lemma  times_monotonic:  forall m1 m2 n1 n2, 0< m1 -> 0 < m2 -> m1 < n1 -> m2 < n2 -> m1 * m2 < n1 * n2.
Proof.
split_all.
replace n1 with (n1 - m1 + m1) by omega.
replace n2 with (n2 - m2 + m2) by omega.
rewrite times_distributive2.
cut(0 < (n1 - m1) * (n2 - m2) + m1 * (n2 - m2) + (n1 - m1) * m2).
split_all; omega.
replace m1 with (1+ (pred m1)) by omega.
replace (n2 - m2) with (1+ (pred (n2 - m2))) by omega.
rewrite times_distributive2.
simpl.
case((pred m1 * 1 + (pred (n2 - m2) + 0) + pred m1 * pred (n2 - m2)));
case((n1 - S (pred m1)) * S (pred (n2 - m2)));
case((n1 - S (pred m1)) * m2); split_all; omega.
Qed.

Lemma  times_monotonic2:  forall m1 m2 n1 n2, 0< m1 -> 0 < m2 -> m1 <= n1 -> m2 < n2 -> m1 * m2 < n1 * n2.
Proof.
split_all.
replace n1 with (n1 - m1 + m1) by omega.
replace n2 with (n2 - m2 + m2) by omega.
rewrite times_distributive2.
assert(0 < (n1 - m1) * (n2 - m2) + m1 * (n2 - m2) + (n1 - m1) * m2).
replace m1 with (1+ (pred m1)) by omega.
replace (n2 - m2) with (1+ (pred (n2 - m2))) by omega.
rewrite times_distributive2.
simpl.
case((pred m1 * 1 + (pred (n2 - m2) + 0) + pred m1 * pred (n2 - m2)));
case((n1 - S (pred m1)) * S (pred (n2 - m2)));
case((n1 - S (pred m1)) * m2); split_all; omega.
gen_case H3 ((n1 - m1) * (n2 - m2) + m1 * (n2 - m2) + (n1 - m1) * m2); split_all; try noway.  omega.
Qed.

Fixpoint exp (m n:nat) {struct n}: nat :=
match n with
| O => 1
| S n => m * exp m n
end.

Notation "x ^ y" := (exp x y).

Lemma exp_positive: forall n m, m>0 -> exp m n >0 .
Proof.
induction n; split_all.
assert(m^n >0) by eapply2 IHn.
eapply2 times_positive.
Qed.

Lemma max_is_max : forall m n, max m n >= m /\ max m n >= n.
Proof.
double induction m n; split_all; try omega.
elim (H0 n); split_all; omega.
elim (H0 n); split_all; omega.
Qed.

Lemma max_succ: forall m n, S (max m n) = max (S m) (S n).
Proof. double induction m n; split_all.  Qed.

Lemma max_pred: forall m n, pred (max m n) = max (pred m) (pred n).
Proof. double induction m n; split_all. case n; split_all. Qed.

Lemma max_max : forall m n p, m >= max n p -> m>= n /\ m>= p.
Proof.
induction m; intros n p. case n; case p; split_all; subst; try noway; try omega.
intros.
assert(m >= pred (max n p)) by omega.
rewrite max_pred in H0.
elim (IHm (pred n) (pred p)); split_all; omega.
Qed.

Lemma max_max2 : forall m n k, k>= m -> k>= n -> k>= max m n.
Proof.
double induction m n; split_all.
assert(pred k >= max n1 n) .  eapply2 H0. omega. omega. omega.
Qed.

Lemma max_zero : forall m, max m 0 = m.
Proof. induction m; split_all. Qed.

Lemma max_plus: forall m n k, max m n +k = max (m+k) (n+k).
Proof.
double induction m n; split_all.
induction k; split_all.
assert(max k (S (n0+k)) >= S(n0+k)) by eapply2 max_is_max.
assert(S(n0+k) >= max k (S(n0+k))) . eapply2 max_max2.
omega.
omega.
case k; split_all.
assert(max (n+S n1) n1 >= n+ S n1) by  eapply2 max_is_max.
assert(n+ S n1 >= max (n+S n1) n1) . eapply2 max_max2.
omega.
omega.
Qed.

Lemma max_minus: forall m n k, max m n -k = max (m-k) (n-k).
Proof.
double induction m n; split_all.
case k; split_all.
rewrite max_zero. omega.
case k; split_all.
Qed.

Lemma max_monotonic : forall m1 m2 n1 n2, m1 >= n1 -> m2 >= n2 -> max m1 m2 >= max n1 n2.
Proof.
double induction m1 m2; split_all.
assert (n1 = 0) by omega; subst.
assert (n2 = 0) by omega; subst.
split_all.
assert (n1 = 0) by omega; subst. split_all.
assert (n2 = 0) by omega; subst.
assert(max n1 0 = n1) . case n1; split_all.
rewrite H2; auto.
assert(n0 >= pred n1) by omega.
cut(max n0 n >= pred (max n1 n2)).
intro.
omega.
rewrite max_pred.
eapply2 H0.
omega.
Qed.

Lemma max_succ_zero : forall k n, max k (S n) = 0 -> False .
Proof. split_all. assert(max k (S n) >= S n) by eapply2 max_is_max. noway. Qed.
Ltac max_out :=
match goal with
| H : max _ (S _) = 0  |- _ => assert False by (eapply2 max_succ_zero); noway
| H : max ?m ?n = 0 |- _ =>
assert (m = 0) by (assert (max m n >= m) by eapply2 max_is_max; omega);
assert (n = 0) by (assert (max m n >= n) by eapply2 max_is_max; omega);
clear H; try omega; try noway
| H : max ?m ?n <= 0 |- _ =>
assert (m = 0) by (assert (max m n >= m) by eapply2 max_is_max; omega);
assert (n = 0) by (assert (max m n >= n) by eapply2 max_is_max; omega);
clear H; try omega; try noway
end.

Lemma min_is_min : forall m n, min m n <= m /\ min m n <= n.
Proof.
double induction m n; split_all; try omega.
elim (H0 n); split_all; omega.
elim (H0 n); split_all; omega.
Qed.

Lemma min_succ: forall m n, S (min m n) = min (S m) (S n).
Proof. double induction m n; split_all.  Qed.

Lemma min_pred: forall m n, pred (min m n) = min (pred m) (pred n).
Proof. double induction m n; split_all. case n; split_all. Qed.

Lemma min_zero : forall m, min m 0 = 0.
Proof. induction m; split_all. Qed.

Lemma min_min : forall m n p, m <= min n p -> m<= n /\ m<= p.
Proof.
induction m; split_all; try omega.
gen_case H n; gen_case H p; try noway.
assert(m<= min n0 n1) by omega.
assert(m<= n0 /\ m<= n1) by eapply2 IHm; split_all; omega.
gen_case H p; try noway.
rewrite min_zero in *.
noway.
assert(m<= pred (min n (S n0))) by omega.
rewrite min_pred in H0.
simpl in *.
elim (IHm (pred n) n0); split_all.
omega.
Qed.

Lemma min_min2 : forall m n k, k<= m -> k<= n -> k<= min m n.
Proof.
double induction m n; split_all.
assert(pred k <= min n1 n) .  eapply2 H0. omega. omega. omega.
Qed.

Lemma min_plus: forall m n k, min m n +k = min (m+k) (n+k).
Proof.
double induction m n; split_all.
induction k; split_all.
assert(min k (S (n0+k)) <= k) by eapply2 min_is_min.
assert(k <= min k (S(n0+k))) . eapply2 min_min2.
omega.
omega.
case k; split_all.
assert(min (n+S n1) n1 <= n1) by  eapply2 min_is_min.
assert(n1 <= min (n+S n1) n1) . eapply2 min_min2.
omega.
omega.
Qed.

Lemma min_minus: forall m n k, min m n -k = min (m-k) (n-k).
Proof.
double induction m n; split_all.
case k; split_all.
rewrite min_zero. omega.
case k; split_all.
Qed.

Lemma min_monotonic : forall m1 m2 n1 n2, m1 <= n1 -> m2 <= n2 -> min m1 m2 <= min n1 n2.
Proof.
double induction m1 m2; split_all; try omega.
gen_case H1 n1; try noway.
gen_case H2 n2; try noway.
assert(min n0 n <= min n3 n4).
eapply2 H0; try omega.
omega.
Qed.

Lemma decidable_nats : forall (m n: nat), m=n \/ m<>n.
Proof.
 double induction m n.
left; split_all.
split_all; right; congruence.
split_all; right; congruence.
split_all.
elim(H0 n); split_all.
Qed.


Require Export VST.concurrency.paco.src.paconotation VST.concurrency.paco.src.pacotac VST.concurrency.paco.src.pacodef VST.concurrency.paco.src.pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 3
*)

(** 1 Mutual Coinduction *)

Section Arg3_1.

Definition monotone3 T0 T1 T2 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall x0 x1 x2 r r' (IN: gf r x0 x1 x2) (LE: r <3= r'), gf r' x0 x1 x2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable gf : rel3 T0 T1 T2 -> rel3 T0 T1 T2.
Arguments gf : clear implicits.

Theorem paco3_acc: forall
  l r (OBG: forall rr (INC: r <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3 gf rr),
  l <3= paco3 gf r.
Proof.
  intros; assert (SIM: paco3 gf (r \3/ l) x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_mon: monotone3 (paco3 gf).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_mult_strong: forall r,
  paco3 gf (upaco3 gf r) <3= paco3 gf r.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Corollary paco3_mult: forall r,
  paco3 gf (paco3 gf r) <3= paco3 gf r.
Proof. intros; eapply paco3_mult_strong, paco3_mon; eauto. Qed.

Theorem paco3_fold: forall r,
  gf (upaco3 gf r) <3= paco3 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco3_unfold: forall (MON: monotone3 gf) r,
  paco3 gf r <3= gf (upaco3 gf r).
Proof. unfold monotone3; intros; destruct PR; eauto. Qed.

End Arg3_1.

Hint Unfold monotone3.
Hint Resolve paco3_fold.

Arguments paco3_acc            [ T0 T1 T2 ].
Arguments paco3_mon            [ T0 T1 T2 ].
Arguments paco3_mult_strong    [ T0 T1 T2 ].
Arguments paco3_mult           [ T0 T1 T2 ].
Arguments paco3_fold           [ T0 T1 T2 ].
Arguments paco3_unfold         [ T0 T1 T2 ].

Instance paco3_inst  T0 T1 T2 (gf : rel3 T0 T1 T2->_) r x0 x1 x2 : paco_class (paco3 gf r x0 x1 x2) :=
{ pacoacc    := paco3_acc gf;
  pacomult   := paco3_mult gf;
  pacofold   := paco3_fold gf;
  pacounfold := paco3_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg3_2.

Definition monotone3_2 T0 T1 T2 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall x0 x1 x2 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2) (LE_0: r_0 <3= r'_0)(LE_1: r_1 <3= r'_1), gf r'_0 r'_1 x0 x1 x2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable gf_0 gf_1 : rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.

Theorem paco3_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_2_0 gf_0 gf_1 rr r_1),
  l <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco3_2_0 gf_0 gf_1 (r_0 \3/ l) r_1 x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_2_1 gf_0 gf_1 r_0 rr),
  l <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco3_2_1 gf_0 gf_1 r_0 (r_1 \3/ l) x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_2_0_mon: monotone3_2 (paco3_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_2_1_mon: monotone3_2 (paco3_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_2_0_mult_strong: forall r_0 r_1,
  paco3_2_0 gf_0 gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_2_1_mult_strong: forall r_0 r_1,
  paco3_2_1 gf_0 gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Corollary paco3_2_0_mult: forall r_0 r_1,
  paco3_2_0 gf_0 gf_1 (paco3_2_0 gf_0 gf_1 r_0 r_1) (paco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco3_2_0_mult_strong, paco3_2_0_mon; eauto. Qed.

Corollary paco3_2_1_mult: forall r_0 r_1,
  paco3_2_1 gf_0 gf_1 (paco3_2_0 gf_0 gf_1 r_0 r_1) (paco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco3_2_1_mult_strong, paco3_2_1_mon; eauto. Qed.

Theorem paco3_2_0_fold: forall r_0 r_1,
  gf_0 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco3_2_1_fold: forall r_0 r_1,
  gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco3_2_0_unfold: forall (MON: monotone3_2 gf_0) (MON: monotone3_2 gf_1) r_0 r_1,
  paco3_2_0 gf_0 gf_1 r_0 r_1 <3= gf_0 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone3_2; intros; destruct PR; eauto. Qed.

Theorem paco3_2_1_unfold: forall (MON: monotone3_2 gf_0) (MON: monotone3_2 gf_1) r_0 r_1,
  paco3_2_1 gf_0 gf_1 r_0 r_1 <3= gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone3_2; intros; destruct PR; eauto. Qed.

End Arg3_2.

Hint Unfold monotone3_2.
Hint Resolve paco3_2_0_fold.
Hint Resolve paco3_2_1_fold.

Arguments paco3_2_0_acc            [ T0 T1 T2 ].
Arguments paco3_2_1_acc            [ T0 T1 T2 ].
Arguments paco3_2_0_mon            [ T0 T1 T2 ].
Arguments paco3_2_1_mon            [ T0 T1 T2 ].
Arguments paco3_2_0_mult_strong    [ T0 T1 T2 ].
Arguments paco3_2_1_mult_strong    [ T0 T1 T2 ].
Arguments paco3_2_0_mult           [ T0 T1 T2 ].
Arguments paco3_2_1_mult           [ T0 T1 T2 ].
Arguments paco3_2_0_fold           [ T0 T1 T2 ].
Arguments paco3_2_1_fold           [ T0 T1 T2 ].
Arguments paco3_2_0_unfold         [ T0 T1 T2 ].
Arguments paco3_2_1_unfold         [ T0 T1 T2 ].

Instance paco3_2_0_inst  T0 T1 T2 (gf_0 gf_1 : rel3 T0 T1 T2->_) r_0 r_1 x0 x1 x2 : paco_class (paco3_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2) :=
{ pacoacc    := paco3_2_0_acc gf_0 gf_1;
  pacomult   := paco3_2_0_mult gf_0 gf_1;
  pacofold   := paco3_2_0_fold gf_0 gf_1;
  pacounfold := paco3_2_0_unfold gf_0 gf_1 }.

Instance paco3_2_1_inst  T0 T1 T2 (gf_0 gf_1 : rel3 T0 T1 T2->_) r_0 r_1 x0 x1 x2 : paco_class (paco3_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2) :=
{ pacoacc    := paco3_2_1_acc gf_0 gf_1;
  pacomult   := paco3_2_1_mult gf_0 gf_1;
  pacofold   := paco3_2_1_fold gf_0 gf_1;
  pacounfold := paco3_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg3_3.

Definition monotone3_3 T0 T1 T2 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall x0 x1 x2 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2) (LE_0: r_0 <3= r'_0)(LE_1: r_1 <3= r'_1)(LE_2: r_2 <3= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable gf_0 gf_1 gf_2 : rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.
Arguments gf_2 : clear implicits.

Theorem paco3_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco3_3_0 gf_0 gf_1 gf_2 (r_0 \3/ l) r_1 r_2 x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco3_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \3/ l) r_2 x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \3/ l) x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_3_0_mon: monotone3_3 (paco3_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_1_mon: monotone3_3 (paco3_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_2_mon: monotone3_3 (paco3_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_0_mult_strong: forall r_0 r_1 r_2,
  paco3_3_0 gf_0 gf_1 gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_1_mult_strong: forall r_0 r_1 r_2,
  paco3_3_1 gf_0 gf_1 gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_2_mult_strong: forall r_0 r_1 r_2,
  paco3_3_2 gf_0 gf_1 gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Corollary paco3_3_0_mult: forall r_0 r_1 r_2,
  paco3_3_0 gf_0 gf_1 gf_2 (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco3_3_0_mult_strong, paco3_3_0_mon; eauto. Qed.

Corollary paco3_3_1_mult: forall r_0 r_1 r_2,
  paco3_3_1 gf_0 gf_1 gf_2 (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco3_3_1_mult_strong, paco3_3_1_mon; eauto. Qed.

Corollary paco3_3_2_mult: forall r_0 r_1 r_2,
  paco3_3_2 gf_0 gf_1 gf_2 (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco3_3_2_mult_strong, paco3_3_2_mon; eauto. Qed.

Theorem paco3_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco3_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco3_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco3_3_0_unfold: forall (MON: monotone3_3 gf_0) (MON: monotone3_3 gf_1) (MON: monotone3_3 gf_2) r_0 r_1 r_2,
  paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <3= gf_0 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone3_3; intros; destruct PR; eauto. Qed.

Theorem paco3_3_1_unfold: forall (MON: monotone3_3 gf_0) (MON: monotone3_3 gf_1) (MON: monotone3_3 gf_2) r_0 r_1 r_2,
  paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <3= gf_1 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone3_3; intros; destruct PR; eauto. Qed.

Theorem paco3_3_2_unfold: forall (MON: monotone3_3 gf_0) (MON: monotone3_3 gf_1) (MON: monotone3_3 gf_2) r_0 r_1 r_2,
  paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <3= gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone3_3; intros; destruct PR; eauto. Qed.

End Arg3_3.

Hint Unfold monotone3_3.
Hint Resolve paco3_3_0_fold.
Hint Resolve paco3_3_1_fold.
Hint Resolve paco3_3_2_fold.

Arguments paco3_3_0_acc            [ T0 T1 T2 ].
Arguments paco3_3_1_acc            [ T0 T1 T2 ].
Arguments paco3_3_2_acc            [ T0 T1 T2 ].
Arguments paco3_3_0_mon            [ T0 T1 T2 ].
Arguments paco3_3_1_mon            [ T0 T1 T2 ].
Arguments paco3_3_2_mon            [ T0 T1 T2 ].
Arguments paco3_3_0_mult_strong    [ T0 T1 T2 ].
Arguments paco3_3_1_mult_strong    [ T0 T1 T2 ].
Arguments paco3_3_2_mult_strong    [ T0 T1 T2 ].
Arguments paco3_3_0_mult           [ T0 T1 T2 ].
Arguments paco3_3_1_mult           [ T0 T1 T2 ].
Arguments paco3_3_2_mult           [ T0 T1 T2 ].
Arguments paco3_3_0_fold           [ T0 T1 T2 ].
Arguments paco3_3_1_fold           [ T0 T1 T2 ].
Arguments paco3_3_2_fold           [ T0 T1 T2 ].
Arguments paco3_3_0_unfold         [ T0 T1 T2 ].
Arguments paco3_3_1_unfold         [ T0 T1 T2 ].
Arguments paco3_3_2_unfold         [ T0 T1 T2 ].

Instance paco3_3_0_inst  T0 T1 T2 (gf_0 gf_1 gf_2 : rel3 T0 T1 T2->_) r_0 r_1 r_2 x0 x1 x2 : paco_class (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2) :=
{ pacoacc    := paco3_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco3_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco3_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco3_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco3_3_1_inst  T0 T1 T2 (gf_0 gf_1 gf_2 : rel3 T0 T1 T2->_) r_0 r_1 r_2 x0 x1 x2 : paco_class (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2) :=
{ pacoacc    := paco3_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco3_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco3_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco3_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco3_3_2_inst  T0 T1 T2 (gf_0 gf_1 gf_2 : rel3 T0 T1 T2->_) r_0 r_1 r_2 x0 x1 x2 : paco_class (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2) :=
{ pacoacc    := paco3_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco3_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco3_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco3_3_2_unfold gf_0 gf_1 gf_2 }.


(* Flat Combiner *)
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.heap_lang.lib Require Import spin_lock.
From iris.algebra Require Import auth frac agree excl agree gset gmap.
From iris.base_logic Require Import big_op saved_prop.
From iris_atomic Require Import misc peritem sync.

Definition doOp : val :=
  λ: "p",
     match: !"p" with
       InjL "req" => "p" <- InjR ((Fst "req") (Snd "req"))
     | InjR "_" => #()
     end.

Definition try_srv : val :=
  λ: "lk" "s",
    if: try_acquire "lk"
      then let: "hd" := !"s" in
           iter "hd" doOp;;
           release "lk"
      else #().

Definition loop: val :=
  rec: "loop" "p" "s" "lk" :=
    match: !"p" with
    InjL "_" =>
        try_srv "lk" "s";;
        "loop" "p" "s" "lk"
    | InjR "r" => "r"
    end.

Definition install : val :=
  λ: "f" "x" "s",
     let: "p" := ref (InjL ("f", "x")) in
     push "s" "p";;
     "p".

Definition mk_flat : val :=
  λ: <>,
   let: "lk" := newlock #() in
   let: "s" := new_stack #() in
   λ: "f" "x",
      let: "p" := install "f" "x" "s" in
      let: "r" := loop "p" "s" "lk" in
      "r".

Definition reqR := prodR fracR (agreeR valC). (* request x should be kept same *)
Definition toks : Type := gname * gname * gname * gname * gname. (* a bunch of tokens to do state transition *)
Class flatG Σ := FlatG {
  req_G :> inG Σ reqR;
  sp_G  :> savedPropG Σ (ofe_funCF val idCF)
}.

Definition flatΣ : gFunctors :=
  #[ GFunctor (constRF reqR);
     savedPropΣ (ofe_funCF val idCF) ].

Instance subG_flatΣ {Σ} : subG flatΣ Σ → flatG Σ.
Proof. intros [?%subG_inG [? _]%subG_inv]%subG_inv. split; apply _. Qed.

Section proof.
  Context `{!heapG Σ, !lockG Σ, !flatG Σ} (N: namespace).

  Definition init_s (ts: toks) :=
    let '(_, γ1, γ3, _, _) := ts in (own γ1 (Excl ()) ∗ own γ3 (Excl ()))%I.

  Definition installed_s R (ts: toks) (f x: val) :=
    let '(γx, γ1, _, γ4, γq) := ts in
    (∃ (P: val → iProp Σ) Q,
       own γx ((1/2)%Qp, to_agree x) ∗ P x ∗ ({{ R ∗ P x }} f x {{ v, R ∗ Q x v }}) ∗
       saved_prop_own γq (Q x) ∗ own γ1 (Excl ()) ∗ own γ4 (Excl ()))%I.

  Definition received_s (ts: toks) (x: val) γr :=
    let '(γx, _, _, γ4, _) := ts in
    (own γx ((1/2/2)%Qp, to_agree x) ∗ own γr (Excl ()) ∗ own γ4 (Excl ()))%I.

  Definition finished_s (ts: toks) (x y: val) :=
    let '(γx, γ1, _, γ4, γq) := ts in
    (∃ Q: val → val → iProp Σ,
       own γx ((1/2)%Qp, to_agree x) ∗ saved_prop_own γq (Q x) ∗
       Q x y ∗ own γ1 (Excl ()) ∗ own γ4 (Excl ()))%I.

  Definition p_inv R (γm γr: gname) (ts: toks) (p : loc) :=
    ( (* INIT *)
      (∃ y: val, p ↦ InjRV y ∗ init_s ts) ∨
      (* INSTALLED *)
      (∃ f x: val, p ↦ InjLV (f, x) ∗ installed_s R ts f x) ∨
      (* RECEIVED *)
      (∃ f x: val, p ↦ InjLV (f, x) ∗ received_s ts x γr) ∨
      (* FINISHED *)
      (∃ x y: val, p ↦ InjRV y ∗ finished_s ts x y))%I.

  Definition p_inv' R γm γr : val → iProp Σ :=
    (λ v: val, ∃ ts (p: loc), ⌜v = #p⌝ ∗ inv N (p_inv R γm γr ts p))%I.

  Definition srv_bag R γm γr s := (∃ xs, is_bag_R N (p_inv' R γm γr) xs s)%I.

  Definition installed_recp (ts: toks) (x: val) (Q: val → iProp Σ) :=
    let '(γx, _, γ3, _, γq) := ts in
    (own γ3 (Excl ()) ∗ own γx ((1/2)%Qp, to_agree x) ∗ saved_prop_own γq Q)%I.

  Lemma install_spec R P Q (f x: val) (γm γr: gname) (s: loc):
    {{{ inv N (srv_bag R γm γr s) ∗ P ∗ ({{ R ∗ P }} f x {{ v, R ∗ Q v }}) }}}
      install f x #s
    {{{ p ts, RET #p; installed_recp ts x Q ∗ inv N (p_inv R γm γr ts p) }}}.
  Proof.
    iIntros (Φ) "(#? & HP & Hf) HΦ".
    wp_seq. wp_let. wp_let. wp_alloc p as "Hl".
    iApply fupd_wp.
    iMod (own_alloc (Excl ())) as (γ1) "Ho1"; first done.
    iMod (own_alloc (Excl ())) as (γ3) "Ho3"; first done.
    iMod (own_alloc (Excl ())) as (γ4) "Ho4"; first done.
    iMod (own_alloc (1%Qp, to_agree x)) as (γx) "Hx"; first done.
    iMod (saved_prop_alloc (F:=(ofe_funCF val idCF)) Q) as (γq) "#?".
    iDestruct (own_update with "Hx") as ">[Hx1 Hx2]"; first by apply pair_l_frac_op_1'.
    iModIntro. wp_let. wp_bind (push _ _).
    iMod (inv_alloc N _ (p_inv R γm γr (γx, γ1, γ3, γ4, γq) p)
          with "[-HΦ Hx2 Ho3]") as "#HRx"; first eauto.
    { iNext. iRight. iLeft. iExists f, x. iFrame.
      iExists (λ _, P), (λ _ v, Q v).
      iFrame. iFrame "#". }
    iApply (push_spec N (p_inv' R γm γr) s #p
            with "[-HΦ Hx2 Ho3]")=>//.
    { iFrame "#". iExists (γx, γ1, γ3, γ4, γq), p.
      iSplitR; first done. iFrame "#". }
    iNext. iIntros "?".
    wp_seq. iApply ("HΦ" $! p (γx, γ1, γ3, γ4, γq)).
    iFrame. iFrame "#".
  Qed.

  Lemma doOp_f_spec R γm γr (p: loc) ts:
    f_spec N (p_inv R γm γr ts p) doOp (own γr (Excl ()) ∗ R)%I #p.
  Proof.
    iIntros (Φ) "(#H1 & Hor & HR) HΦ".
    wp_rec. wp_bind (! _)%E.
    iInv N as "Hp" "Hclose".
    iDestruct "Hp" as "[Hp | [Hp | [Hp | Hp]]]"; subst.
    - iDestruct "Hp" as (y) "[>Hp Hts]".
      wp_load. iMod ("Hclose" with "[-Hor HR HΦ]").
      { iNext. iFrame "#". iLeft. iExists y. iFrame. }
      iModIntro. wp_match. iApply ("HΦ" with "[Hor HR]"). iFrame.
    - destruct ts as [[[[γx γ1] γ3] γ4] γq].
      iDestruct "Hp" as (f x) "(>Hp & Hts)".
      iDestruct "Hts" as (P Q) "(>Hx & Hpx & Hf' & HoQ & >Ho1 & >Ho4)".
      iAssert (|==> own γx (((1/2/2)%Qp, to_agree x) ⋅
                            ((1/2/2)%Qp, to_agree x)))%I with "[Hx]" as ">[Hx1 Hx2]".
      { iDestruct (own_update with "Hx") as "?"; last by iAssumption.
        rewrite -{1}(Qp_div_2 (1/2)%Qp).
        by apply pair_l_frac_op'. }
      wp_load. iMod ("Hclose" with "[-Hf' Ho1 Hx2 HoQ HR HΦ Hpx]").
      { iNext. iFrame. iFrame "#". iRight. iRight. iLeft. iExists f, x. iFrame. }
      iModIntro. wp_match. wp_proj. wp_proj.
      wp_bind (f _). iApply wp_wand_r. iSplitL "Hpx Hf' HR".
      { iApply "Hf'". iFrame. }
      iIntros (v) "[HR HQ]". wp_value.
      iInv N as "Hx" "Hclose".
      iDestruct "Hx" as "[Hp | [Hp | [Hp | Hp]]]"; subst.
      * iDestruct "Hp" as (?) "(_ & >Ho1' & _)".
        iApply excl_falso. iFrame.
      * iDestruct "Hp" as (? ?) "[>? Hs]". iDestruct "Hs" as (? ?) "(_ & _ & _ & _ & >Ho1' & _)".
        iApply excl_falso. iFrame.
      * iDestruct "Hp" as (? x5) ">(Hp & Hx & Hor & Ho4)".
        wp_store. iDestruct (m_frag_agree' with "[Hx Hx2]") as "[Hx %]"; first iFrame.
        subst. rewrite Qp_div_2. iMod ("Hclose" with "[-HR Hor HΦ]").
        { iNext. iDestruct "Hp" as "[Hp1 Hp2]". iRight. iRight.
          iRight. iExists x5, v. iFrame. iExists Q. iFrame. }
        iApply "HΦ". iFrame.
      * iDestruct "Hp" as (? ?) "[? Hs]". iDestruct "Hs" as (?) "(_ & _ & _ & >Ho1' & _)".
        iApply excl_falso. iFrame.
    - destruct ts as [[[[γx γ1] γ3] γ4] γq]. iDestruct "Hp" as (? x) "(_ & _ & >Ho2' & _)".
      iApply excl_falso. iFrame.
    - destruct ts as [[[[γx γ1] γ3] γ4] γq]. iDestruct "Hp" as (x' y) "[Hp Hs]".
        iDestruct "Hs" as (Q) "(>Hx & HoQ & HQxy & >Ho1 & >Ho4)".
        wp_load. iMod ("Hclose" with "[-HΦ HR Hor]").
        { iNext. iRight. iRight. iRight. iExists x', y. iFrame. iExists Q. iFrame. }
        iModIntro. wp_match. iApply "HΦ". iFrame.
  Qed.

  Definition own_γ3 (ts: toks) := let '(_, _, γ3, _, _) := ts in own γ3 (Excl ()).
  Definition finished_recp (ts: toks) (x y: val) :=
    let '(γx, _, _, _, γq) := ts in
    (∃ Q, own γx ((1 / 2)%Qp, to_agree x) ∗ saved_prop_own γq (Q x) ∗ Q x y)%I.

  Lemma loop_iter_doOp_spec R (γm γr: gname) xs:
  ∀ (hd: loc),
    {{{ is_list_R N (p_inv' R γm γr) hd xs ∗ own γr (Excl ()) ∗ R }}}
      iter #hd doOp
    {{{ RET #(); own γr (Excl ()) ∗ R }}}.
  Proof.
    induction xs as [|x xs' IHxs].
    - iIntros (hd Φ) "[Hxs ?] HΦ".
      simpl. wp_rec. wp_value. wp_let.
      iDestruct "Hxs" as (?) "Hhd".
      wp_load. wp_match. by iApply "HΦ".
    - iIntros (hd Φ) "[Hxs HRf] HΦ". simpl.
      iDestruct "Hxs" as (hd' ?) "(Hhd & #Hinv & Hxs')".
      wp_rec. wp_value. wp_let. wp_bind (! _)%E.
      iInv N as "H" "Hclose".
      iDestruct "H" as (ts p) "[>% #?]". subst.
      wp_load. iMod ("Hclose" with "[]").
      { iNext. iExists ts, p. eauto. }
      iModIntro. wp_match. wp_proj. wp_bind (doOp _).
      iDestruct (doOp_f_spec R γm γr p ts) as "Hf".
      iApply ("Hf" with "[HRf]").
      { iFrame. iFrame "#". }
      iNext. iIntros "HRf".
      wp_seq. wp_proj. iApply (IHxs with "[-HΦ]")=>//.
      iFrame "#"; first by iFrame. eauto.
  Qed.

  Lemma try_srv_spec R (s: loc) (lk: val) (γr γm γlk: gname) Φ :
    inv N (srv_bag R γm γr s) ∗
    is_lock N γlk lk (own γr (Excl ()) ∗ R) ∗ Φ #()
    ⊢ WP try_srv lk #s {{ Φ }}.
  Proof.
    iIntros "(#? & #? & HΦ)". wp_seq. wp_let.
    wp_bind (try_acquire _). iApply (try_acquire_spec with "[]"); first done.
    iNext. iIntros ([]); last by (iIntros; wp_if).
    iIntros "[Hlocked [Ho2 HR]]".
    wp_if. wp_bind (! _)%E.
    iInv N as "H" "Hclose".
    iDestruct "H" as (xs' hd') "[>Hs Hxs]".
    wp_load. iDestruct (dup_is_list_R with "[Hxs]") as ">[Hxs1 Hxs2]"; first by iFrame.
    iMod ("Hclose" with "[Hs Hxs1]").
    { iNext. iFrame. iExists xs', hd'. by iFrame. }
    iModIntro. wp_let. wp_bind (iter _ _).
    iApply wp_wand_r. iSplitL "HR Ho2 Hxs2".
    { iApply (loop_iter_doOp_spec R _ _ _ _ (λ _, own γr (Excl ()) ∗ R)%I with "[-]")=>//.
      iFrame "#". iFrame. eauto. }
    iIntros (f') "[Ho HR]". wp_seq.
    iApply (release_spec with "[Hlocked Ho HR]"); first iFrame "#∗".
    iNext. iIntros. done.
  Qed.

  Lemma loop_spec R (p s: loc) (lk: val)
        (γs γr γm γlk: gname) (ts: toks):
    {{{ inv N (srv_bag R γm γr s) ∗ inv N (p_inv R γm γr ts p) ∗
        is_lock N γlk lk (own γr (Excl ()) ∗ R) ∗ own_γ3 ts }}}
      loop #p #s lk
    {{{ x y, RET y; finished_recp ts x y }}}.
  Proof.
    iIntros (Φ) "(#? & #? & #? & Ho3) HΦ".
    iLöb as "IH". wp_rec. repeat wp_let.
    wp_bind (! _)%E. iInv N as "Hp" "Hclose".
    destruct ts as [[[[γx γ1] γ3] γ4] γq].
    iDestruct "Hp" as "[Hp | [Hp | [ Hp | Hp]]]".
    + iDestruct "Hp" as (?) "(_ & _ & >Ho3')".
      iApply excl_falso. iFrame.
    + iDestruct "Hp" as (f x) "(>Hp & Hs')".
      wp_load. iMod ("Hclose" with "[Hp Hs']").
      { iNext. iFrame. iRight. iLeft. iExists f, x. iFrame. }
      iModIntro. wp_match. wp_bind (try_srv _ _). iApply try_srv_spec=>//.
      iFrame "#". wp_seq. iApply ("IH" with "Ho3"); eauto.
    + iDestruct "Hp" as (f x) "(Hp & Hx & Ho2 & Ho4)".
      wp_load. iMod ("Hclose" with "[-Ho3 HΦ]").
      { iNext. iFrame. iRight. iRight. iLeft. iExists f, x. iFrame. }
      iModIntro. wp_match.
      wp_bind (try_srv _ _). iApply try_srv_spec=>//.
      iFrame "#". wp_seq. iApply ("IH" with "Ho3"); eauto.
    + iDestruct "Hp" as (x y) "[>Hp Hs']".
      iDestruct "Hs'" as (Q) "(>Hx & HoQ & HQ & >Ho1 & >Ho4)".
      wp_load. iMod ("Hclose" with "[-Ho4 HΦ Hx HoQ HQ]").
      { iNext. iFrame. iLeft. iExists y. iFrame. }
      iModIntro. wp_match. iApply ("HΦ" with "[-]"). iFrame.
      iExists Q. iFrame.
  Qed.

  Lemma mk_flat_spec (γm: gname): mk_syncer_spec mk_flat.
  Proof.
    iIntros (R Φ) "HR HΦ".
    iMod (own_alloc (Excl ())) as (γr) "Ho2"; first done.
    wp_seq. wp_bind (newlock _).
    iApply (newlock_spec _ (own γr (Excl ()) ∗ R)%I with "[$Ho2 $HR]")=>//.
    iNext. iIntros (lk γlk) "#Hlk".
    wp_let. wp_bind (new_stack _).
    iApply (new_bag_spec N (p_inv' R γm γr))=>//.
    iNext. iIntros (s) "#Hss".
    wp_let. iApply "HΦ". rewrite /synced.
    iAlways. iIntros (f). wp_let. iAlways.
    iIntros (P Q x) "#Hf".
    iIntros "!# Hp". wp_let. wp_bind (install _ _ _).
    iApply (install_spec R P Q f x γm γr s with "[-]")=>//.
    { iFrame. iFrame "#". eauto. }
    iNext. iIntros (p [[[[γx γ1] γ3] γ4] γq]) "[(Ho3 & Hx & HoQ) #?]".
    wp_let. wp_bind (loop _ _ _).
    iApply (loop_spec with "[-Hx HoQ]")=>//.
    { iFrame "#". iFrame. }
    iNext. iIntros (? ?) "Hs".
    iDestruct "Hs" as (Q') "(Hx' & HoQ' & HQ')".
    destruct (decide (x = a)) as [->|Hneq].
    - iDestruct (saved_prop_agree with "[HoQ HoQ']") as "Heq"; first by iFrame.
      wp_let. iDestruct (uPred.cofe_funC_equivI with "Heq") as "Heq".
      iSpecialize ("Heq" $! a0). by iRewrite "Heq" in "HQ'".
    - iExFalso. iCombine "Hx" "Hx'" as "Hx".
      iDestruct (own_valid with "Hx") as %[_ H1].
      rewrite pair_op //=  in H1=>//. apply to_agree_comp_valid in H1.
      fold_leibniz. done.
  Qed.

End proof.