(* ** Some Hoare Rules *)

From Undecidability Require Import TMTac TM.Util.Prelim.
From Undecidability.TM Require Export Compound.Multi Combinators.Combinators.
From Undecidability.TM.Hoare Require Import HoareLogic HoareRegister.

(* *** Nop *)

(* A classic example for Hoare logic *)

Lemma Nop_Spec (sig : finType) (n : nat) (P : Assert sig n) :
  Triple P Nop (fun _ => P).
Proof.
  eapply TripleI,Realise_monotone.
  { TM_Correct. }
  { intros tin ([], tout) ->. hnf. auto. }
Qed.

Lemma Nop_SpecT (sig : finType) (n : nat) (P : Assert sig n) :
  TripleT P 0 Nop (fun _ => P).
Proof.
  split.
  - eapply Consequence_pre. apply Nop_Spec. firstorder.
  - eapply TerminatesIn_monotone.
    + TM_Correct.
    + firstorder.
Qed.

Lemma Nop_SpecT_con (sig : finType) (n : nat) (P : Assert sig n) k :
  TripleT P k Nop (fun _ => P).
Proof.
  eapply ConsequenceT_pre.
  - apply Nop_SpecT.
  - auto.
  - lia.
Qed.

(* *** [Relabel] *)

Lemma Relabel_Spec (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (Q : F1 -> Assert sig n) (pM : pTM sig F1 n) (f : F1->F2) :
  Triple P pM Q ->
  Triple P (Relabel pM f) (fun y' t => exists y'', y' = f y'' /\ Q y'' t).
Proof.
  intros HT. eapply TripleI, Realise_monotone.
  { TM_Correct. apply HT. }
  { intros tin (yout, tout) H. TMSimp. intros. eauto. }
Qed.

Lemma Relabel_Spec_con (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (Q : F1 -> Assert sig n) (Q' : F2 -> Assert sig n) (pM : pTM sig F1 n) (f : F1->F2) :
  Triple P pM Q ->
  (forall yout, Entails (Q yout) (Q' (f yout))) ->
  Triple P (Relabel pM f) Q'.
Proof.
  intros.
  eapply Consequence_post.
  - apply Relabel_Spec; eauto.
  - setoid_rewrite Entails_iff in H0. setoid_rewrite Entails_iff. intros. TMSimp. eauto.
Qed.

Lemma Relabel_SpecT (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (k : nat) (Q : F1 -> Assert sig n) (pM : pTM sig F1 n) (f : F1->F2) :
  TripleT P k pM Q ->
  TripleT P k (Relabel pM f) (fun y' t => exists y'', y' = f y'' /\ Q y'' t).
Proof.
  split.
  - apply Relabel_Spec; eauto.
  - eapply TerminatesIn_monotone.
    + TM_Correct. apply H.
    + firstorder.
Qed.

Lemma Relabel_SpecT_con (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (k : nat) (Q : F1 -> Assert sig n) (Q' : F2 -> Assert sig n) (pM : pTM sig F1 n)
      (f : F1->F2) :
  TripleT P k pM Q ->
  (forall yout, Entails (Q yout) (Q' (f yout))) ->
  TripleT P k (Relabel pM f) Q'.
Proof.
  intros.
  eapply ConsequenceT_post.
  - apply Relabel_SpecT; eauto.
  - setoid_rewrite Entails_iff in H0. setoid_rewrite Entails_iff. intros. TMSimp. firstorder.
Qed.

(* *** [Return] *)

Lemma Return_Spec (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (Q : F1 -> Assert sig n) (pM : pTM sig F1 n) (y : F2) :
  Triple P pM Q ->
  Triple P (Return pM y) (fun y' t => y' = y /\ exists y'', Q y'' t).
Proof.
  intros HT. eapply TripleI, Realise_monotone.
  { TM_Correct. apply HT. }
  { intros tin (yout, tout) H. TMSimp. intros. eauto. }
Qed.

Lemma Return_Spec_con (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (Q : F1 -> Assert sig n) (Q' : F2 -> Assert sig n) (pM : pTM sig F1 n) (y : F2) :
  Triple P pM Q ->
  (forall yout, Entails (Q yout) (Q' y)) ->
    Triple P (Return pM y) Q'.
Proof.
  intros.
  eapply Consequence_post.
  - apply Return_Spec; eauto.
  - setoid_rewrite Entails_iff in H0. setoid_rewrite Entails_iff. intros ? ? (->&(?&?)). eauto.
Qed.

Lemma Return_SpecT (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (k : nat) (Q : F1 -> Assert sig n) (pM : pTM sig F1 n) (y : F2) :
  TripleT P k pM Q ->
  TripleT P k (Return pM y) (fun y' t => y' = y /\ exists y'', Q y'' t).
Proof.
  split.
  - apply Return_Spec; eauto.
  - eapply TerminatesIn_monotone.
    + TM_Correct. apply H.
    + firstorder.
Qed.

Lemma Return_SpecT_con (sig : finType) (F1 F2 : finType) (n : nat) (P : Assert sig n) (k : nat) (Q : F1 -> Assert sig n) (Q' : F2 -> Assert sig n) (pM : pTM sig F1 n) (y : F2) :
  TripleT P k pM Q ->
  (forall yout, Entails (Q yout) (Q' y)) ->
  TripleT P k (Return pM y) Q'.
Proof.
  intros.
  eapply ConsequenceT_post.
  - apply Return_SpecT; eauto.
  - setoid_rewrite Entails_iff in H0. setoid_rewrite Entails_iff. intros ? ? (->&(?&?)). eauto.
Qed.

(* *** Sequential Composition *)

Lemma Seq_Spec (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : pTM sig F2 n)
      (P : Assert sig n) (Q : F1 -> Assert sig n) (R : F2 -> Assert sig n) :
  Triple P pM1 Q ->
  (forall ymid, Triple (Q ymid) pM2 R) ->
  Triple P (pM1;;pM2) R.
Proof.
  intros HT1 HT2.
  eapply TripleI, Realise_monotone.
  { TM_Correct. apply HT1.
    (* We need a little hack here, because we don't know yet in which label [pM1] will terminate. *)
    instantiate (1 := fun tin '(yout, tout) =>
                        forall (ymid : F1),
                          Q ymid tin ->
                          R yout tout).
    {
      clear HT1 P pM1. setoid_rewrite Triple_iff in HT2. unfold Realise in *.
      intros tin k outc HLoop.
      intros ymid Hmid.
      specialize HT2 with (1 := HLoop). cbn in *.
      eapply HT2; eauto.
    }
  }
  {
    intros tin (yout, tout) H. TMSimp.
    intros. modpon H. modpon H0. eapply H0.
  }
Qed.

(* Version that disregards labels of [Q] *)
Lemma Seq_Spec' (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : pTM sig F2 n)
      (P : Assert sig n) (Q : Assert sig n) (R : F2 -> Assert sig n) :
  Triple P pM1 (fun _ => Q) ->
  (Triple Q pM2 R) ->
  Triple P (pM1;;pM2) R.
Proof. eauto using Seq_Spec. Qed.

(* Swapped proof obligations (for backwards reasoning) *)
Lemma Seq_Spec_swapped (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : pTM sig F2 n)
      (P : Assert sig n) (Q : F1 -> Assert sig n) (R : F2 -> Assert sig n) :
  (forall ymid, Triple (Q ymid) pM2 R) ->
  Triple P pM1 Q ->
  Triple P (pM1;;pM2) R.
Proof. eauto using Seq_Spec. Qed.

Lemma Seq_Spec_swapped' (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : pTM sig F2 n)
      (P : Assert sig n) (Q : Assert sig n) (R : F2 -> Assert sig n) :
  (Triple Q pM2 R) ->
  Triple P pM1 (fun _ => Q) ->
  Triple P (pM1;; pM2) R.
Proof. eauto using Seq_Spec. Qed.

(* Version with termination *)

(* This strong lemma is usually not needed, because the output label of [M1] usually is irrelevant (and [tt] most of the time). *)
Lemma Seq_SpecT_strong (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : pTM sig F2 n)
      (P : Assert sig n) (Q : F1 -> Assert sig n) (R : F2 -> Assert sig n)
      (k k1 k2 : nat) :
  TripleT P k1 pM1 Q -> (* Correctness of [pM1] *)
  (forall (ymid : F1), TripleT (Q ymid) k2 pM2 R) -> (* Correctness of [pM2] (for every output label of [pM1]) *)
  (forall tin ymid tmid, P tin -> Q ymid tmid -> 1 + k1 + k2 <= k) ->
  TripleT P k (pM1;; pM2) R.
Proof. (* We need the same hack here as in the partital correctness lemma. *)
  intros H1 H2 H3.
  split.
  - eapply Seq_Spec.
    + apply H1.
    + cbn. apply H2.
  - eapply TerminatesIn_monotone.
    {
      apply Seq_TerminatesIn'. (* We need the stronger version here *)
      - apply H1.
      - apply H1.
      - instantiate (1 := fun tmid k2' => exists ymid, Q ymid tmid /\ k2 <= k2').
        {
          clear H1 H3. setoid_rewrite TripleT_iff in H2. unfold TerminatesIn in *. firstorder.
        }
    }
    {
      clear H1 H2.
      intros tin k' (HP&Hk). unfold Triple_TRel in *.
      exists k1. repeat split; eauto.
      unfold Triple_Rel. intros ymid tmid HQ. modpon HQ.
      specialize H3 with (1 := HP) (2 := HQ).
      exists k2. split; eauto.
      lia.
    }
Qed.

Lemma Seq_SpecT (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : pTM sig F2 n)
      (P : Assert sig n) (Q : F1 -> Assert sig n) (R : F2 -> Assert sig n)
      (k k1 k2 : nat) :
  TripleT P k1 pM1 Q -> (* Correctness of [pM1] *)
  (forall (ymid : F1), TripleT (Q ymid) k2 pM2 R) -> (* Correctness of [pM2] (for every output label of [pM1]) *)
  1 + k1 + k2 <= k ->
  TripleT P k (pM1;; pM2) R.
Proof. intros. eapply Seq_SpecT_strong; eauto. Qed.

Lemma Seq_SpecT' (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : pTM sig F2 n)
      (P : Assert sig n) (Q : Assert sig n) (R : F2 -> Assert sig n)
      (k k1 k2 : nat) :
  TripleT P k1 pM1 (fun _ => Q) ->
  (TripleT Q k2 pM2 R) ->
  1 + k1 + k2 <= k ->
  TripleT P k (pM1;;pM2) R.
Proof. eauto using Seq_SpecT. Qed.

(* *** If *)

Lemma If_Spec (sig : finType) (n : nat) (F : finType) (pM1 : pTM sig bool n) (pM2 pM3 : pTM sig F n)
      (P : Assert sig n) (Q : bool -> Assert sig n) (R : F -> Assert sig n) :
  Triple P pM1 Q ->
  Triple (Q true)  pM2 R ->
  Triple (Q false) pM3 R ->
  Triple P (If pM1 pM2 pM3) R.
Proof.
  rewrite !Triple_iff. intros H1 H2 H3.
  eapply Realise_monotone.
  - TM_Correct; eauto.
  - intros tin (yout, tout) H. cbn in *. firstorder.
Qed.

(* Stronger version where we make a case-distinction, like in [If_TerminatesIn] *)
Lemma If_SpecT (sig : finType) (n : nat) (F : finType) (pM1 : pTM sig bool n) (pM2 pM3 : pTM sig F n)
      (P : Assert sig n) (Q : bool -> Assert sig n) (R : F -> Assert sig n)
      (k k1 k2 k3 : nat) :
  TripleT P k1 pM1 Q ->
  TripleT (Q true)  k2 pM2 R ->
  TripleT (Q false) k3 pM3 R ->
  (forall tin yout tout, P tin -> Q yout tout ->
                    (1 + k1 + if yout then k2 else k3) <= k) ->
  TripleT P k (If pM1 pM2 pM3) R.
Proof.
  intros H1 H2 H3 H4. split.
  - eapply If_Spec.
    + apply H1.
    + apply H2.
    + apply H3.
  - eapply TerminatesIn_monotone.
    { apply If_TerminatesIn'. (* We need the strong version of [If_TerminatesIn] here! *)
      - apply H1.
      - apply H1.
      - apply H2.
      - apply H3. }
    {
      unfold Triple_Rel, Triple_TRel. intros tin k' (H&Hk).
      specialize H4 with (1 := H).
      exists k1. repeat split.
      - assumption.
      - reflexivity.
      - intros tmid ymid Hmid. modpon Hmid.
        modpon H4. destruct ymid; cbn in *.
        + exists k2. repeat split; auto. lia.
        + exists k3. repeat split; auto. lia.
    }
Qed.

(* more usable version for register machines *)
Lemma If_SpecTReg (sig : finType) (n : nat) (F : finType) (pM1 : pTM _ bool n) (pM2 pM3 : pTM _ F n)
      (P : Spec sig n) (Q : bool -> Spec sig n) (R : F -> Spec sig n)
      (k k1 k2 k3 : nat) :
  TripleT ≃≃( P) k1 pM1 (fun y => ≃≃( Q y)) ->
  TripleT ≃≃( Q true)  k2 pM2 (fun y => ≃≃( R y)) ->
  TripleT ≃≃( Q false) k3 pM3 (fun y => ≃≃(  R y)) ->
  (implList (fst P) (forall b, implList (fst (Q b)) (1 + k1 + (if b then k2 else k3) <= k))) ->
  TripleT ≃≃( P) k (If pM1 pM2 pM3) (fun y => ≃≃( R y)).
Proof.
  intros H1 H2 H3 H4. eapply If_SpecT. 1-3:eassumption. cbn.
  intros. do 2 setoid_rewrite implList_iff in H4. specialize H4 with (b:=yout). destruct P,(Q yout). eapply H4;cbn. all:eapply tspecE;eauto.
Qed.

(* Version were we don't care about the output label of [M1] *)
Lemma If_SpecT_weak (sig : finType) (n : nat) (F : finType) (pM1 : pTM sig bool n) (pM2 pM3 : pTM sig F n)
      (P : Assert sig n) (Q : bool -> Assert sig n) (R : F -> Assert sig n)
      (k k1 k2 k3 : nat) :
  TripleT P k1 pM1 Q ->
  TripleT (Q true)  k2 pM2 R ->
  TripleT (Q false) k3 pM3 R ->
  (1 + k1 + max k2 k3 <= k) ->
  TripleT P k (If pM1 pM2 pM3) R.
Proof.
  intros. eapply If_SpecT; eauto.
  intros. destruct yout.
  + assert (k2 <= max k2 k3) by apply Nat.le_max_l. lia.
  + assert (k3 <= max k2 k3) by apply Nat.le_max_r. lia.
Qed.

(* Equally weak version with the same bound for the number of steps of [pM2] and [pM3]. *)
Lemma If_SpecT_weak' (sig : finType) (n : nat) (F : finType) (pM1 : pTM sig bool n) (pM2 pM3 : pTM sig F n)
      (P : Assert sig n) (Q : bool -> Assert sig n) (R : F -> Assert sig n)
      (k k1 k2 : nat) :
  TripleT P k1 pM1 Q ->
  TripleT (Q true)  k2 pM2 R ->
  TripleT (Q false) k2 pM3 R ->
  (1 + k1 + k2 <= k) ->
  TripleT P k (If pM1 pM2 pM3) R.
Proof.
  intros H1 H2 H3 H4.
  eapply ConsequenceT_pre.
  - eapply If_SpecT_weak with (k2 := k2) (k3 := k2); eauto.
  - auto.
  - now rewrite Nat.max_id.
Qed.

(* *** Switch *)

Lemma Switch_Spec (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : F1 -> pTM sig F2 n)
      (P : Assert sig n) (Q : F1 -> Assert sig n) (R : F2 -> Assert sig n) :
  Triple P pM1 Q ->
  (forall (y : F1), Triple (Q y) (pM2 y) R) ->
  Triple P (Switch pM1 pM2) R.
Proof.
  intros H1 H2.
  eapply TripleI, Realise_monotone.
  - apply Switch_Realise.
    + apply H1.
    + apply H2.
  - intros tin (yout, tout) H. cbn in *. firstorder.
Qed.

Lemma Switch_SpecT (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : F1 -> pTM sig F2 n)
      (P : Assert sig n) (Q : F1 -> Assert sig n) (R : F2 -> Assert sig n)
      (k k1 k2 : nat) :
  TripleT P k1 pM1 Q ->
  (forall (y : F1), TripleT (Q y) k2 (pM2 y) R) ->
  (1 + k1 + k2 <= k) ->
  TripleT P k (Switch pM1 pM2) R.
Proof.
  intros H1 H2 H3.
  split.
  - eapply Switch_Spec.
    + apply H1.
    + apply H2.
  - eapply TerminatesIn_monotone.
    + apply Switch_TerminatesIn.
      * apply H1.
      * apply H1.
      * apply H2.
    + unfold Triple_TRel. intros tin k' (H&Hk).
      exists k1, k2. repeat split; eauto. lia.
Qed.

(* Stronger version, where the running time depends on the output label of [pM1] *)
Lemma Switch_SpecT_strong (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM sig F1 n) (pM2 : F1 -> pTM sig F2 n)
      (P : Assert sig n) (Q : F1 -> Assert sig n) (R : F2 -> Assert sig n)
      (k k1 : nat) (k2 : F1 -> nat) :
  TripleT P k1 pM1 Q ->
  (forall (y : F1), TripleT (Q y) (k2 y) (pM2 y) R) ->
  (forall tin yout tout, P tin -> Q yout tout -> 1 + k1 + k2 yout <= k) ->
  TripleT P k (Switch pM1 pM2) R.
Proof.
  intros H1 H2 H3.
  split.
  - eapply Switch_Spec.
    + apply H1.
    + apply H2.
  - eapply TerminatesIn_monotone.
    + apply Switch_TerminatesIn'.
      * apply H1.
      * apply H1.
      * apply H2.
    + unfold Triple_TRel. intros tin k' (H&Hk).
      exists k1. repeat split.
      * assumption.
      * reflexivity.
      * unfold Triple_Rel. intros tmid ymid Hmid. modpon Hmid.
        specialize H3 with (1 := H) (2 := Hmid).
        exists (k2 ymid). repeat split; eauto. lia.
Qed.

Lemma Switch_SpecTReg (sig : finType) (n : nat) (F1 F2 : finType) (pM1 : pTM _ F1 n) (pM2 : F1 -> pTM _ F2 n)
     (P : Spec sig n) Q R
      (k k1 : nat) (f : F1 -> nat) :
  TripleT ≃≃(P) k pM1 (fun y => ≃≃(Q y)) ->
  (forall (y : F1), TripleT ≃≃(Q y) (f y) (pM2 y) (fun y => ≃≃(R y))) ->
  (implList (fst P) (forall y, implList (fst (Q y)) (1 + k + f y <= k1))) ->
  TripleT ≃≃(P) k1 (Switch pM1 pM2) (fun y => ≃≃(R y)).
Proof.
  intros H1 H2 H3. eapply Switch_SpecT_strong. 1-2:eassumption.
  intros. destruct P. eapply tspecE in H as []. eapply implListE in H3. 2:easy.
  setoid_rewrite implList_iff in H3. apply H3.
  cbn in H0. destruct Q. eapply tspecE;eassumption.
Qed.

(* *** While *)

(* Obviously, the rules for [While] are a bit more complicated. *)

(* This is the most general, but totally useless, lemma. The problem is that the "abstract state" of the machine changes when the loop is executed again. *)
Lemma While_Spec0 (sig : finType) (n : nat) (F : finType) {inF : inhabitedC F} (pM : pTM sig (option F) n)
      (P : Assert sig n) (Q : option F -> Assert sig n) (R : F -> Assert sig n) :
  Triple P pM Q ->
  (forall yout tout, Q (Some yout) tout -> R yout tout) ->
  (forall tmid, Q None tmid -> P tmid) ->
  Triple P (While pM) R.
Proof.
  intros H1 H3 H2.
  eapply TripleI, Realise_monotone.
  { TM_Correct. apply H1. }
  { clear H1.
    unfold Triple_Rel in *.
    apply WhileInduction; firstorder.
  }
Qed.

(* We have an abstract specification [P x] for an (abstract) type [X]. As invariant, we require that there always exists an [x:X] such that [P x]
holds for the input tape. At the end, we assert that the assertion [R] holds (without knowledge of the abstract [x]).

To apply this  have three proof-obligations: First, we show the correctness of the machine [M]. First, we show that whenever [M] terminates in [None],
there must be another [x':X] such that the invariant still holds. Finally, if [M] terminated in [Some yout], the postcondition must hold. *)

(* In the correctness rule for [While], we share an "abstract" version of the state between the precondition [P x] and the postcondition [R x].
The first proof obligation is to instantiate the correctness of [M]: [forall x, {P x} pM {Q x}], where [Q x] is the (abstracted) postcondition of [M].
Then we have to show that whenever [M] terminates in [Some yout] for the abstract state [x], the postcondition [R yout x] is satisfied.
For the loop invariant, when [M] terminates in [None], the abstract state [x] has changed. We choose a new abstract state [x'] and show that
when the postcondition is satisfied for this abstract state [x'], then the postcondition is also satisfied for [x] and the input tape.

Note that this is similar to the way we proof realisation of a [While M]. There, we also share "abstract" variables in the "precondition" and the
"postcondition" of the realisation. *)
Lemma While_Spec (sig : finType) (n : nat) (F : finType) {inF : inhabitedC F} (pM : pTM sig (option F) n)
      (X : Type)
      (P : X -> Assert sig n) (Q : X -> option F -> Assert sig n) (R : X -> F -> Assert sig n) :
  (forall x, Triple (P x) pM (Q x)) ->
  (forall x yout tmid tout, P x tmid -> Q x (Some yout) tout -> R x yout tout) ->
  (forall x tin tmid, P x tin -> Q x None tmid -> exists x', P x' tmid /\ forall yout tout, R x' yout tout -> R x yout tout) ->
  forall (x : X), Triple (P x) (While pM) (R x).
Proof.
  intros H1 H2 H3.
  enough (While pM ⊨ fun tin '(yout, tout) => forall (x : X), P x tin -> R x yout tout) as H.
  { (* Note that we can not apply [Realise_monotone] here, because we need to "push" [x] inside the relation. *)
    clear H1 H2 H3. intros. rewrite Triple_iff.  unfold Triple_Rel, Realise in *. eauto.
  }
  {
    eapply Realise_monotone.
    { clear H2 H3.
      apply While_Realise with (R := fun tin '(yout, tout) => forall (x : X), P x tin -> Q x yout tout).
      hnf. setoid_rewrite Triple_iff in H1. unfold Triple_Rel in *. firstorder. }
    {
      clear H1. apply WhileInduction; intros.
      - eapply H2; eauto.
      - specialize HStar with (1 := H).
        specialize H3 with (1 := H) (2 := HStar) as (x'&H3&H3').
        eapply H3'; eauto.
    }
  }
Qed.

(* For Register machines, we handle the pure part of the assertion differently for a more in-line rule. *)
Lemma While_SpecReg (sig : finType) (n : nat) (F : finType) {inF : inhabitedC F} (pM : pTM _ (option F) n)
      (X : Type)
      (P : X -> Spec sig n) (Q : X -> option F -> Spec sig n) (R : X -> F -> Spec sig n) :
  (forall x, Triple ≃≃( P x) pM (fun y => ≃≃( Q x y))) ->
  (forall x , implList (fst (P x))
       (forall yout, implList (fst (Q x (Some yout))) (Entails ≃≃( [],snd (Q x (Some yout))) ≃≃( R x yout)))
     /\ (implList (fst (Q x None)) (exists x', Entails ≃≃( [],snd (Q x None)) ≃≃( P x')
                                    /\ (forall yout, Entails ≃≃( R x' yout) ≃≃( R x yout))))) ->
  forall (x : X), Triple ≃≃( P x) (While pM) (fun y => ≃≃( R x y)).
Proof.
  intros H1 H2. eapply While_Spec with (1:=H1).
  - intros ? ? ? ? ?. revert tout. apply EntailsE.
    specialize (H2 x) as [H2 ?]. destruct (P x);cbn in *. apply tspecE in H as [H _].
    do 2 setoid_rewrite implList_iff in H2. specialize (H2 H yout).
    destruct (Q x (Some yout));cbn in *. eapply tspec_introPure. rewrite implList_iff. eauto.
  - intros **. specialize (H2 x) as [? H2]. destruct (P x);cbn in *.
    apply tspecE in H as [H _]. setoid_rewrite implList_iff in H2.
    destruct (Q x None);cbn in *.
    eapply tspecE in H0 as (H0&?). specialize (H2 H0) as (x'&H2&H'). eexists x'.
    split. {eapply (EntailsE H2). eapply tspecI. now hnf. easy. }
    intros ? . now eapply EntailsE.
Qed.

(* Termination rule: We additionally have an abstract running time function [f : X -> nat]. The machine [M] terminates in time [g x] for every
abstract [x]. We have to show that [f x] also decreases by [1 + g x] whenever [While M] repeats the loop. *)
Lemma While_SpecT (sig : finType) (n : nat) (F : finType) {inF : inhabitedC F} (pM : pTM sig (option F) n)
      (X : Type) (f g : X -> nat)
      (P : X -> Assert sig n) (Q : X -> option F -> Assert sig n) (R : X -> F -> Assert sig n) :
  (forall x, TripleT (P x) (g x) pM (Q x)) ->
  (forall x yout tmid tout, P x tmid -> Q x (Some yout) tout -> R x yout tout /\ g x <= f x) ->
  (forall x tin tmid, P x tin -> Q x None tmid -> exists x', P x' tmid /\ 1 + g x + f x' <= f x /\ forall yout tout, R x' yout tout -> R x yout tout) ->
  forall (x : X), TripleT (P x) (f x) (While pM) (R x).
Proof.
  intros H1 H2 H3 x.
  split.
  { eapply While_Spec; eauto.
    - intros y yout tmid tout Hp Hq. specialize H2 with (1 := Hp) (2 := Hq). firstorder.
    - intros x' tin tmid Hp Hq. specialize H3 with (1 := Hp) (2 := Hq). firstorder.
  }
  enough (projT1 (While pM) ↓ (fun tin k => exists x, P x tin /\ f x <= k)) as H.
  { clear H1 H2 H3. unfold Triple_TRel, TerminatesIn. firstorder. }
  {
    clear x. (* The [x] was pushed into the relation. *)
    eapply TerminatesIn_monotone.
    {
      clear H2 H3. (* Again, we encode [H1] (the correctness and termination of [M]) into a nice relation. *)
      apply While_TerminatesIn with (R := fun tin '(yout, tout) => forall (x : X), P x tin -> Q x yout tout)
                                    (T := fun tin k' => exists (x : X), P x tin /\ g x <= k').
      - hnf. setoid_rewrite TripleT_iff in H1. unfold Triple_TRel in *.
        intros tin k' outc HLoop x Hx.
        specialize H1 with (x := x) as (H1&H1').
        setoid_rewrite Triple_iff in H1.
        unfold Triple_Rel, Realise in H1; clear H1'.
        firstorder.
      - hnf. setoid_rewrite TripleT_iff in H1. unfold Triple_TRel in *.
        intros tin k' (x&H&Hk). specialize H1 with (x := x) as (H1&H1').
        unfold Triple_TRel, TerminatesIn in H1'; clear H1. firstorder.
    }
    {
      clear H1. (* Already encoded in the relation *)
      apply WhileCoInduction; intros.
      hnf in HT. destruct HT as (x&HPx&Hk).
      exists (g x). split.
      - exists x. split; eauto.
      - intros [ y | ].
        + clear H3. (* Termination case *)
          intros tmid H.
          specialize H with (1 := HPx).
          specialize H2 with (1 := HPx) (2 := H) as (H3&H3').
          lia.
        + clear H2. (* Loop case *)
          intros tmid H.
          specialize H with (1 := HPx).
          specialize H3 with (1 := HPx) (2 := H) as (x'&H2&H2').
          exists (f x'). unfold Triple_TRel. repeat split.
          * exists x'. split; [assumption|lia].
          * lia.
    }
  }
Qed.

Lemma While_SpecTReg (sig : finType) (n : nat) (F : finType) {inF : inhabitedC F} (pM : pTM _ (option F) n)
      (X : Type) (f__loop f__step : X -> nat)
      (PRE : X -> Spec sig n) (INV : X -> option F -> Spec sig n) (POST : X -> F -> Spec sig n) :
  (forall x, TripleT ≃≃( PRE x) (f__step x) pM (fun y => ≃≃( INV x y))) ->
  (forall x , implList (fst (PRE x)) (forall yout, implList (fst (INV x (Some yout))) (Entails ≃≃( [],snd (INV x (Some yout))) ≃≃( POST x yout) /\ f__step x <= f__loop x))
     /\ (implList (fst (INV x None)) (exists x', Entails ≃≃( [],snd (INV x None)) ≃≃( PRE x') /\ 1 + f__step x + f__loop x' <= f__loop x
                                    /\ (forall yout, Entails ≃≃( POST x' yout) ≃≃( POST x yout))))) ->
  forall (x : X), TripleT ≃≃( PRE x) (f__loop x) (While pM) (fun y => ≃≃( POST x y)).
Proof.
  intros H1 H2. eapply While_SpecT with (1:=H1).
  - intros x y ? ? ? H'.
    specialize (H2 x) as [H2 ?]. setoid_rewrite implList_iff in H2. destruct (PRE _).  apply tspecE in H as [H _].
    specialize (H2 H y).
    destruct (POST x y). destruct (INV x (Some _)). specialize (tspecE H') as [H'1 ?].
    setoid_rewrite implList_iff in H2. specialize (H2 H'1) as []. split. 2:easy. eapply H2. eapply tspecI. all:easy.
  - intros **. specialize (H2 x) as [? H2]. destruct (PRE _). destruct (INV _ _).
    apply tspecE in H as [H _]. setoid_rewrite implList_iff in H2.
    eapply tspecE in H0 as (H0&?). specialize (H2 H0) as (x'&H2&?&H'). eexists x'.
    split. {eapply (EntailsE H2). eapply tspecI. now hnf. easy. }
    split. easy.
    intros ? . now eapply EntailsE.
Qed.

Lemma While_SpecTReg' (sig : finType) (n : nat) (F : finType) {inF : inhabitedC F} (pM : pTM _ (option F) n)
      (X : Type) (f g : X -> nat)
      P' Q' R' (P : X -> SpecV sig n) (Q : X -> option F -> SpecV sig n) (R : X -> F -> SpecV sig n) :
  (forall x, TripleT ≃≃( P' x, P x) (g x) pM (fun y => ≃≃( Q' x y, Q x y))) ->
  (forall x , implList (P' x)
       (forall yout, implList (Q' x (Some yout)) (Entails ≃≃( [],Q x (Some yout)) ≃≃( R' x yout,R x yout) /\ g x <= f x))
     /\ (implList (Q' x None) (exists x', Entails ≃≃( [],Q x None) ≃≃( P' x', P x') /\ 1 + g x + f x' <= f x
                                    /\ (forall yout, Entails ≃≃( R' x' yout,R x' yout) ≃≃( R' x yout,R x yout))))) ->
  forall (x : X), TripleT ≃≃( P' x,P x) (f x) (While pM) (fun y => ≃≃( R' x y,R x y)).
Proof.
  intros H1 H2. eapply While_SpecTReg with (INV := fun _ _ => (_,_)). all:easy.
Qed.


(** File generated by coq-of-ocaml *)
Require Import CoqOfOCaml.CoqOfOCaml.
Require Import CoqOfOCaml.Settings.

Definition t (a : Set) : Set := list a.

Fixpoint length_aux {A : Set} (len : int) (function_parameter : list A) : int :=
  match function_parameter with
  | [] => len
  | cons _ l_value => length_aux (Z.add len 1) l_value
  end.

Definition length {A : Set} (l_value : list A) : int := length_aux 0 l_value.

Definition cons_value {A : Set} (a_value : A) (l_value : list A) : list A :=
  cons a_value l_value.

Definition nth_opt {A : Set} (l_value : list A) (n_value : int) : option A :=
  if CoqOfOCaml.Stdlib.lt n_value 0 then
    None
  else
    let fix nth_aux {B : Set} (l_value : list B) (n_value : int) : option B :=
      match l_value with
      | [] => None
      | cons a_value l_value =>
        if equiv_decb n_value 0 then
          Some a_value
        else
          nth_aux l_value (Z.sub n_value 1)
      end in
    nth_aux l_value n_value.

Definition append {A : Set} : list A -> list A -> list A :=
  CoqOfOCaml.Stdlib.app.

Fixpoint rev_append {A : Set} (l1 : list A) (l2 : list A) : list A :=
  match l1 with
  | [] => l2
  | cons a_value l_value => rev_append l_value (cons a_value l2)
  end.

Definition rev {A : Set} (l_value : list A) : list A := rev_append l_value nil.

Fixpoint flatten {A : Set} (function_parameter : list (list A)) : list A :=
  match function_parameter with
  | [] => nil
  | cons l_value r_value => CoqOfOCaml.Stdlib.app l_value (flatten r_value)
  end.

Definition concat {A : Set} : list (list A) -> list A := flatten.

Fixpoint map {a b : Set} (f_value : a -> b) (function_parameter : list a)
  : list b :=
  match function_parameter with
  | [] => nil
  | cons a_value l_value =>
    let r_value := f_value a_value in
    cons r_value (map f_value l_value)
  end.

Definition mapi {a b : Set} (f_value : int -> a -> b) (l_value : list a)
  : list b :=
  let fix aux (i_value : int) (function_parameter : list a) : list b :=
    match function_parameter with
    | [] => nil
    | cons a_value l_value =>
      let r_value := f_value i_value a_value in
      cons r_value (aux (Z.add i_value 1) l_value)
    end in
  aux 0 l_value.

Definition rev_map {A B : Set} (f_value : A -> B) (l_value : list A) : list B :=
  let fix rmap_f (accu : list B) (function_parameter : list A) : list B :=
    match function_parameter with
    | [] => accu
    | cons a_value l_value => rmap_f (cons (f_value a_value) accu) l_value
    end in
  rmap_f nil l_value.

Fixpoint iter {A : Set} (f_value : A -> unit) (function_parameter : list A)
  : unit :=
  match function_parameter with
  | [] => tt
  | cons a_value l_value =>
    let '_ := f_value a_value in
    iter f_value l_value
  end.

Definition iteri {A : Set} (f_value : int -> A -> unit) (l_value : list A)
  : unit :=
  let fix aux (i_value : int) (function_parameter : list A) : unit :=
    match function_parameter with
    | [] => tt
    | cons a_value l_value =>
      let '_ := f_value i_value a_value in
      aux (Z.add i_value 1) l_value
    end in
  aux 0 l_value.

Fixpoint fold_left {A B : Set}
  (f_value : A -> B -> A) (accu : A) (l_value : list B) : A :=
  match l_value with
  | [] => accu
  | cons a_value l_value => fold_left f_value (f_value accu a_value) l_value
  end.

Fixpoint fold_right {A B : Set}
  (f_value : A -> B -> B) (l_value : list A) (accu : B) : B :=
  match l_value with
  | [] => accu
  | cons a_value l_value => f_value a_value (fold_right f_value l_value accu)
  end.

Fixpoint for_all {A : Set} (p_value : A -> bool) (function_parameter : list A)
  : bool :=
  match function_parameter with
  | [] => true
  | cons a_value l_value => andb (p_value a_value) (for_all p_value l_value)
  end.

Fixpoint _exists {A : Set} (p_value : A -> bool) (function_parameter : list A)
  : bool :=
  match function_parameter with
  | [] => false
  | cons a_value l_value => orb (p_value a_value) (_exists p_value l_value)
  end.

Fixpoint find_opt {A : Set} (p_value : A -> bool) (function_parameter : list A)
  : option A :=
  match function_parameter with
  | [] => None
  | cons x_value l_value =>
    if p_value x_value then
      Some x_value
    else
      find_opt p_value l_value
  end.

Fixpoint find_map {A B : Set}
  (f_value : A -> option B) (function_parameter : list A) : option B :=
  match function_parameter with
  | [] => None
  | cons x_value l_value =>
    match f_value x_value with
    | (Some _) as result_value => result_value
    | None => find_map f_value l_value
    end
  end.

Definition find_all {A : Set} (p_value : A -> bool) : list A -> list A :=
  let fix find (accu : list A) (function_parameter : list A) : list A :=
    match function_parameter with
    | [] => rev accu
    | cons x_value l_value =>
      if p_value x_value then
        find (cons x_value accu) l_value
      else
        find accu l_value
    end in
  find nil.

Definition filter {A : Set} : (A -> bool) -> list A -> list A := find_all.

Definition filteri {A : Set} (p_value : int -> A -> bool) (l_value : list A)
  : list A :=
  let fix aux (i_value : int) (acc : list A) (function_parameter : list A)
    : list A :=
    match function_parameter with
    | [] => rev acc
    | cons x_value l_value =>
      aux (Z.add i_value 1)
        (if p_value i_value x_value then
          cons x_value acc
        else
          acc) l_value
    end in
  aux 0 nil l_value.

Definition filter_map {A B : Set} (f_value : A -> option B)
  : list A -> list B :=
  let fix aux (accu : list B) (function_parameter : list A) : list B :=
    match function_parameter with
    | [] => rev accu
    | cons x_value l_value =>
      match f_value x_value with
      | None => aux accu l_value
      | Some v_value => aux (cons v_value accu) l_value
      end
    end in
  aux nil.

Definition concat_map {a b : Set} (f_value : a -> list b) (l_value : list a)
  : list b :=
  let fix aux (acc : list b) (function_parameter : list a) : list b :=
    match function_parameter with
    | [] => rev acc
    | cons x_value l_value =>
      let xs := f_value x_value in
      aux (rev_append xs acc) l_value
    end in
  aux nil l_value.

Definition fold_left_map {a b c : Set}
  (f_value : a -> b -> a * c) (accu : a) (l_value : list b) : a * list c :=
  let fix aux (accu : a) (l_accu : list c) (function_parameter : list b)
    : a * list c :=
    match function_parameter with
    | [] => (accu, (rev l_accu))
    | cons x_value l_value =>
      let '(accu, x_value) := f_value accu x_value in
      aux accu (cons x_value l_accu) l_value
    end in
  aux accu nil l_value.

Definition partition {A : Set} (p_value : A -> bool) (l_value : list A)
  : list A * list A :=
  let fix part (yes : list A) (no : list A) (function_parameter : list A)
    : list A * list A :=
    match function_parameter with
    | [] => ((rev yes), (rev no))
    | cons x_value l_value =>
      if p_value x_value then
        part (cons x_value yes) no l_value
      else
        part yes (cons x_value no) l_value
    end in
  part nil nil l_value.

Fixpoint split {a b : Set} (l_value : list (a * b)) : list a * list b :=
  match l_value with
  | [] => (nil, nil)
  | cons (x_value, y_value) l_value =>
    let '(rx, ry) := split l_value in
    ((cons x_value rx), (cons y_value ry))
  end.

Fixpoint combine {A B : Set} (l1 : list A) (l2 : list B) : list (A * B) :=
  match (l1, l2) with
  | (cons a1 l1, cons a2 l2) => cons (a1, a2) (combine l1 l2)
  | (_, _) => nil
  end.

Fixpoint compare_lengths {A B : Set} (l1 : list A) (l2 : list B) : int :=
  match (l1, l2) with
  | ([], []) => 0
  | ([], _) => (-1)
  | (_, []) => 1
  | (cons _ l1, cons _ l2) => compare_lengths l1 l2
  end.

Fixpoint compare_length_with {A : Set} (l_value : list A) (n_value : int)
  : int :=
  match l_value with
  | [] =>
    if equiv_decb n_value 0 then
      0
    else
      if CoqOfOCaml.Stdlib.gt n_value 0 then
        (-1)
      else
        1
  | cons _ l_value =>
    if CoqOfOCaml.Stdlib.le n_value 0 then
      1
    else
      compare_length_with l_value (Z.sub n_value 1)
  end.

Fixpoint equal {A B : Set}
  (eq_value : A -> B -> bool) (l1 : list A) (l2 : list B) : bool :=
  match (l1, l2) with
  | ([], []) => true
  | (([], cons _ _) | (cons _ _, [])) => false
  | (cons a1 l1, cons a2 l2) => andb (eq_value a1 a2) (equal eq_value l1 l2)
  end.

Fixpoint compare {A B : Set} (cmp : A -> B -> int) (l1 : list A) (l2 : list B)
  : int :=
  match (l1, l2) with
  | ([], []) => 0
  | ([], cons _ _) => (-1)
  | (cons _ _, []) => 1
  | (cons a1 l1, cons a2 l2) =>
    let c_value := cmp a1 a2 in
    if nequiv_decb c_value 0 then
      c_value
    else
      compare cmp l1 l2
  end.


(*
 * Copyright 2015-2016 IBM Corporation
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** This module defines possible interleavings of lists. *)

Require Import List.
Require Import ListSet.
Require Import Bool.
Require Import Permutation.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Equivalence.
Require Import RelationClasses.
Require Import Omega.
Require Import LibUtilsCoqLibAdd.
Require Import LibUtilsLift.
Require Import LibUtilsListAdd.
Require Import LibUtilsAssoc.
Require Import LibUtilsSublist.
Require Import LibUtilsBag.

Section interleaving.

  Inductive is_interleaved {A} : list (list A) -> list A -> Prop
    :=
      is_interleaved_concat (ls1 ls2:list (list A)) :
        Permutation ls1 ls2 ->
        is_interleaved ls2 (concat ls1)
    | is_interleaved_cons lh ls1 ls2 l x :
        is_interleaved (lh::ls1) l ->
        Permutation ((x::lh)::ls1) ls2 ->
        is_interleaved ls2 (x::l).

  Lemma is_interleaved_concat_simple {A:Type} (l:list (list A)) :
    is_interleaved l (concat l).
  Proof.
    apply is_interleaved_concat.
    reflexivity.
  Qed.

  Lemma is_interleaved_cons_simple {A:Type} (x:A) lh ls l :
    is_interleaved (lh::ls) l ->
    is_interleaved ((x::lh)::ls) (x::l).
  Proof.
    intros isl.
    eapply is_interleaved_cons; try eassumption.
    reflexivity.
  Qed.

  Global Instance is_interleaved_perm_proper {A}  :
    Proper ((@Permutation (list A)) ==> eq ==> iff) (@is_interleaved A).
  Proof.
    cut (Proper ((@Permutation (list A)) ==> eq ==> Basics.impl) (@is_interleaved A)); unfold Proper, respectful; [intros H | ]; intros l1 l2 perm ? l ?; subst.
    { split; intros isl.
      - eapply H; eauto.
      - symmetry in perm.
        eapply H; eauto.
    }
    intros isl.
    revert l2 perm.
    induction isl; simpl; intros l2 perm.
    - rewrite perm in H.
      constructor; trivial.
    - assert (inn:In (x::lh) ls2).
      { rewrite <- H; simpl; eauto. }
      destruct (in_split _ _ inn) as [ls11 [ls12 ?]]; subst.
      clear inn.
      apply Permutation_cons_app_inv in H.
      specialize (IHisl (lh::ls11++ls12)).
      econstructor.
      + apply IHisl.
        rewrite H; trivial.
      + rewrite <- perm.
        apply Permutation_cons_app; trivial.
  Qed.

  Lemma is_interleaved_refl {A} (l:list A) : is_interleaved (l::nil) l.
  Proof.
    generalize (is_interleaved_concat_simple (l::nil)); simpl.
    rewrite app_nil_r; trivial.
  Qed.

  Lemma is_interleaved_nil_l {A:Type} (l:list A) : is_interleaved nil l <-> l = nil.
  Proof.
    split; intros H.
    - cut (forall x, Permutation nil x -> is_interleaved x l -> l = nil).
      { intros HH; apply (HH nil); trivial. }
      clear; intros.
      revert H.
      induction H0; simpl; trivial; intros perm.
      + apply Permutation_nil in perm; subst; simpl; trivial.
        symmetry in H; apply Permutation_nil in H; subst; simpl; trivial.
      +  apply Permutation_nil in perm; subst; simpl; trivial.
         symmetry in H; apply Permutation_nil in H; subst; simpl; trivial.
         discriminate.
    - subst.
      apply (is_interleaved_concat_simple nil).
  Qed.

  Lemma is_interleaved_perm_concat {A} {ls} {l:list A}:
    is_interleaved ls l -> Permutation l (concat ls).
  Proof.
    induction 1; simpl.
    - apply Permutation_concat; trivial.
    - rewrite IHis_interleaved.
      rewrite <- H0.
      simpl; reflexivity.
  Qed.

  Lemma is_interleaved_both_perm {A:Type} {ls} {l1 l2:list A} :
    is_interleaved ls l1 ->
    is_interleaved ls l2 ->
    Permutation l1 l2.
  Proof.
    intros isl1 isl2.
    rewrite (is_interleaved_perm_concat isl1).
    rewrite (is_interleaved_perm_concat isl2).
    reflexivity.
  Qed.

  Lemma is_interleaved_In {A:Type} (ls:list (list A)) l x :
    is_interleaved ls l ->
    In x l <-> exists l', In l' ls /\ In x l'.
  Proof.
    intros isl.
    rewrite (is_interleaved_perm_concat isl).
    apply concat_In.
  Qed.

  Lemma is_interleaved_sublist {A:Type} {ls} {l:list A} :
    is_interleaved ls l ->
    Forall (fun x => sublist x l) ls.
  Proof.
    induction 1.
    - rewrite <- H.
      apply concat_sublist.
    - invcs IHis_interleaved.
      rewrite <- H0.
      constructor.
      + constructor; trivial.
      + revert H4.
        apply Forall_impl; intros ? subl.
        constructor; trivial.
  Qed.

  Lemma is_interleaved_cons_nil_f {A} {ls:list (list A)} {l:list A} :
    is_interleaved ls l -> is_interleaved (nil :: ls) l.
  Proof.
    intros isl.
    induction isl.
    - rewrite <- H.
      generalize (is_interleaved_concat_simple (nil::ls1)); simpl; trivial.
    - rewrite <- H.
      rewrite perm_swap in IHisl.
      rewrite perm_swap.
      apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_cons_list {A} a ls2 (l2:list A) :
    is_interleaved ls2 l2 ->
    is_interleaved (a::ls2) (a++l2).
  Proof.
    intros isl.
    induction a; simpl.
    - apply is_interleaved_cons_nil_f; trivial.
    - apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_app {A} ls1 l1 ls2 (l2:list A) :
    is_interleaved ls1 l1 ->
    is_interleaved ls2 l2 ->
    is_interleaved (ls1++ls2) (l1++l2).
  Proof.
    intros isl1 isl2.
    induction isl1; rewrite <- H; clear ls0 H.
    - induction ls1; simpl; trivial.
      destruct a; simpl.
      + apply is_interleaved_cons_nil_f; trivial.
      + apply is_interleaved_cons_simple.
        rewrite app_ass.
        apply is_interleaved_cons_list; trivial.
    - apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_map {A B:Type} (f:A->B) ls (l:list A) :
    is_interleaved ls l ->
    is_interleaved (map (map f) ls) (map f l).
  Proof.
    intros isl.
    induction isl; simpl; intros.
    - rewrite concat_map.
      apply is_interleaved_concat.
      apply Permutation_map; trivial.
    - rewrite <- H; simpl.
      apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_filter {A:Type} f ls (l:list A) :
    is_interleaved ls l ->
    is_interleaved (map (filter f) ls) (filter f l).
  Proof.
    intros isl.
    induction isl; simpl; intros.
    - rewrite concat_filter.
      apply is_interleaved_concat.
      apply Permutation_map; trivial.
    - rewrite <- H; simpl.
      destruct (f x); trivial.
      apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_filter_nil_f {A:Type} {ls} {l:list A} :
    is_interleaved ls l ->
    is_interleaved (filter_nil ls) l.
  Proof.
    intros isl.
    - induction isl; simpl in *.
      + unfold filter_nil. rewrite <- (Permutation_filter _ _ _ H).
        generalize (is_interleaved_concat_simple (filter_nil ls1)); intros isl.
        rewrite concat_filter_nil in isl; trivial.
      + rewrite <- H; simpl.
        apply is_interleaved_cons_simple.
        destruct lh; simpl; trivial.
        apply is_interleaved_cons_nil_f; trivial.
  Qed.

  Lemma is_interleaved_filter_nil {A:Type} ls (l:list A) :
    is_interleaved ls l <->
    is_interleaved (filter_nil ls) l.
  Proof.
    split; intros isl.
    - apply is_interleaved_filter_nil_f; trivial.
    - revert ls isl.
      induction l; simpl; intros ls isl.
      + invcs isl.
        rewrite H.
        apply concat_nil_r in H.
        induction ls; trivial.
        * apply (is_interleaved_concat_simple nil).
        * { destruct a; simpl in *.
            - apply is_interleaved_cons_nil_f; auto.
            - rewrite H1 in H.
              invcs H.
              discriminate.
          }
      + invcs isl.
        * symmetry in H1.
          destruct (Permutation_filter_pullback_r H1) as [ll [? perm2]]; subst.
          fold (@filter_nil A) in *; rewrite concat_filter_nil in *.
          apply is_interleaved_concat; symmetry; trivial.
        * symmetry in H3.
          destruct (filter_perm_head H3).
          symmetry in H3.
          rewrite H; simpl.
          apply is_interleaved_cons_simple.
          apply IHl.
          { replace (filter_nil (lh :: ls1 ++ x)) with (filter_nil (lh::ls1)); trivial.
            - apply is_interleaved_filter_nil_f; trivial.
            - generalize (Permutation_filter not_nil _ _ H); intros perm2.
              rewrite <- H3 in perm2.
              rewrite filter_app in perm2.
              generalize (Permutation_filter not_nil _ _ H3); intros perm3.
              unfold filter_nil in *.
              rewrite filter_filter in perm3.
              rewrite <- H3 in perm3.
              rewrite <- perm3 in perm2.
              rewrite filter_filter in perm2.
              generalize (Permutation_app_inv_l (filter not_nil ((a :: lh) :: ls1)) nil (filter not_nil x)); intros inv.
              rewrite app_nil_r in inv.
              specialize (inv perm2).
              apply Permutation_nil in inv.
              simpl.
              rewrite filter_app, inv.
              rewrite app_nil_r; trivial.
          }
  Qed.

  Lemma is_interleaved_cons_nil {A} ls (l:list A) :
    is_interleaved ls l <-> is_interleaved (nil :: ls) l.
  Proof.
    split; intros isl.
    - apply is_interleaved_cons_nil_f; trivial.
    - apply is_interleaved_filter_nil in isl.
      simpl in isl.
      apply is_interleaved_filter_nil; trivial.
  Qed.

  Lemma is_interleaved_app_cons_nil {A} ls1 ls2 (l:list A) :
    is_interleaved (ls1 ++ nil :: ls2) l <-> is_interleaved (ls1++ls2) l.
  Proof.
    rewrite <- (@Permutation_cons_app (list A) (ls1 ++ ls2) ls1 ls2)
    ; try reflexivity.
    symmetry.
    apply is_interleaved_cons_nil.
  Qed.

  Lemma is_interleaved_nil_r {A:Type} (ls:list (list A)) :
    is_interleaved ls nil <-> Forall (eq nil) ls.
  Proof.
    split; intros H.
    - apply is_interleaved_perm_concat in H.
      apply Permutation_nil in H.
      apply concat_nil_r in H.
      trivial.
    - generalize (is_interleaved_concat_simple ls); intros isl.
      apply concat_nil_r in H.
      rewrite H in isl; trivial.
  Qed.

  (*
    Lemma is_interleaved_concat_inside {A} {ls1 ls2 ls3} {l:list A} :
      is_interleaved (ls1++(concat ls2)::ls3) l ->
      is_interleaved (ls1++ls2++ls3) l.
    Proof.

    Lemma is_interleaved_distr {A} ls1 ls2 ls3 l2 (l:list A) :
          is_interleaved (ls1++ls2++ls3) l ->
          is_interleaved ls2 l2 ->
          is_interleaved (ls1++l2::ls3) l.
    Proof.
   *)

  (*
    Lemma is_interleaved_In {A:Type} (ls:list (list A)) l x :
      is_interleaved ls l ->
      In x l <-> exists l', In l' ls /\ In x l'.
    Proof.
      intros isl.
      rewrite (is_interleaved_perm_concat isl).
      apply concat_In.
    Qed.
   *)

  Lemma is_interleaved_lookup_none {A B} {dec:EqDec A eq} {ls:list (list (A*B))} l x :
    is_interleaved ls l ->
    lookup dec l x = None <->
    Forall (fun ll => lookup dec ll x = None) ls.
  Proof.
    intros isl.
    split; intros.
    - rewrite Forall_forall; intros.
      case_eq (lookup dec x0 x); trivial; intros.
      apply lookup_in in H1.
      generalize (is_interleaved_In _ _ (x,b) isl); intros [Hf Hb].
      cut_to Hb.
      + apply in_dom in Hb.
        destruct (in_dom_lookup dec Hb); congruence.
      + eauto.
    - apply is_interleaved_perm_concat in isl.
      case_eq (lookup dec l x); trivial; intros.
      apply lookup_in in H0.
      rewrite isl in H0.
      apply concat_In in H0.
      destruct H0 as [? [inn1 inn2]].
      rewrite Forall_forall in H.
      specialize (H _ inn1).
      apply lookup_none_nin in H.
      apply in_dom in inn2.
      congruence.
  Qed.

  Lemma is_interleaved_lookup_some {A B} {dec:EqDec A eq} {ls:list (list (A*B))} l x v :
    is_interleaved ls l ->
    lookup dec l x = Some v ->
    exists ll, In ll ls /\ lookup dec ll x = Some v.
  Proof.
    intros isl; induction isl; intros lo.
    - destruct (concat_lookup_some_break lo) as [ll1 [ll2 [ll3 [eqq [inn nin]]]]].
      subst.
      exists ll2; split; trivial.
      rewrite <- H.
      rewrite in_app_iff; simpl; eauto.
    - simpl in lo.
      destruct x0.
      destruct (dec x a); unfold equiv in *.
      + invcs lo.
        exists ((a,v)::lh); simpl.
        split.
        * rewrite <- H; simpl; eauto.
        * match_destr; congruence.
      + destruct (IHisl lo) as [ll [inn1 inn2]].
        simpl in inn1.
        destruct inn1.
        * subst.
          exists ((a,b)::ll); simpl.
          { split.
            - rewrite <- H; simpl; eauto.
            - rewrite inn2.
              destruct (dec x a); congruence.
          }
        * exists ll; split; trivial.
          rewrite <- H; simpl; eauto.
  Qed.

  Lemma is_interleaved_disjoint_lookup_equiv {A B} {dec:EqDec A eq} {ls:list (list (A*B))} :
    all_disjoint (map domain ls) ->
    forall l1 l2,
      is_interleaved ls l1 ->
      is_interleaved ls l2 ->
      lookup_equiv l1 l2.
  Proof.
    intros ad l1 l2 isl1 isl2 x.
    case_eq (lookup dec l1 x).
    - intros ? inn.
      destruct (is_interleaved_lookup_some _ _ _ isl1 inn)
        as [ll [inn1 inn2]].
      case_eq (lookup dec l2 x).
      + intros ? inn'.
        destruct (is_interleaved_lookup_some _ _ _ isl2 inn')
          as [ll' [inn1' inn2']].
        cut (ll = ll').
        { congruence. }
        generalize (is_interleaved_both_perm isl1 isl2); intros perm.
        apply lookup_in in inn.
        apply lookup_in in inn'.
        rewrite perm in inn.
        apply lookup_in_domain in inn2.
        apply lookup_in_domain in inn2'.
        eapply all_disjoint_domain_has_same_eq; eauto.
      + intros inn'.
        apply (is_interleaved_lookup_none _ x isl2) in inn'.
        apply (is_interleaved_lookup_none _ x isl1) in inn'.
        congruence.
    - intros inn'.
      apply (is_interleaved_lookup_none _ x isl1) in inn'.
      apply (is_interleaved_lookup_none _ x isl2) in inn'.
      congruence.
  Qed.

  Lemma is_interleaved_disjoint_update_first {A B} dec ls (l:list (A*B)) v d:
    all_disjoint (map domain ls) ->
    is_interleaved ls l ->
    is_interleaved (map (fun l0 : list (A * B) => update_first dec l0 v d) ls)
                   (update_first dec l v d).
  Proof.
    intros disj isl.
    revert disj.
    induction isl; intros disj.
    - rewrite <- (Permutation_map domain H) in disj.
      rewrite update_first_concat_disjoint_push by trivial.
      econstructor.
      rewrite H; trivial.
    - rewrite <- (Permutation_map domain H) in disj.
      destruct x; simpl in *.
      cut_to IHisl.
      + rewrite <- H; clear ls2 H; simpl.
        assert (nin: Forall (fun x => ~ In a x) (map domain ls1)).
        { invcs disj.
          revert H1; apply Forall_impl.
          intros ? disj.
          apply disjoint_cons_inv1 in disj; tauto.
        }
        destruct (dec v a); simpl.
        * subst.
          { replace (map (fun l0 : list (A * B) => update_first dec l0 a d) ls1)
              with (map id ls1).
            - rewrite map_id.
              eapply is_interleaved_cons; eauto.
            - apply map_ext_in; intros.
              rewrite nin_update; trivial.
              apply lookup_nin_none.
              rewrite Forall_forall in nin.
              apply nin.
              apply in_map_iff.
              eauto.
          }
        * econstructor; eauto.
      + invcs disj.
        constructor; trivial.
        revert H2; apply Forall_impl.
        intros ? disj.
        apply disjoint_cons_inv1 in disj; tauto.
  Qed.

  Lemma is_interleaved_singleton_inv {A B} (l1 l2:list (A*B)) :
    is_interleaved (l1::nil) l2 -> l1 = l2.
  Proof.
    revert l1; induction l2; intros l1 isl.
    - apply is_interleaved_nil_r in isl.
      invcs isl; trivial.
    - invcs isl.
      + symmetry in H1; apply Permutation_length_1_inv in H1; subst.
        simpl in H; rewrite app_nil_r in H; subst; simpl.
        rewrite app_nil_r; trivial.
      + symmetry in H3.
        apply Permutation_length_1_inv in H3.
        invcs H3.
        f_equal; auto.
  Qed.

  Lemma is_interleaved_cons_inv {A B} {dec:EqDec A eq} (a:(A*B)) l1 l2 l3 :
    all_disjoint (map domain ((a::l1)::l2)) ->
    is_interleaved ((a::l1)::l2) (a::l3) ->
    is_interleaved (l1::l2) l3.
  Proof.
    revert l1 l3.
    induction l2; simpl; intros l1 l3 disj isl.
    - apply is_interleaved_singleton_inv in isl.
      invcs isl.
      apply is_interleaved_refl.
    - invcs isl.
      + assert (inn1:In(a::l1) ls1).
        { rewrite H1; trivial; simpl; eauto. }
        destruct (in_split _ _ inn1)
          as [ll1 [ll2 eqq]]; subst; clear inn1.
        symmetry in H1.
        apply Permutation_cons_app_inv in H1.
        assert (nin:~ In a (concat ll1)).
        { intros inn.
          assert (inn1:In a (concat (ll1 ++ ll2))).
          { rewrite concat_app, in_app_iff; eauto. }
          rewrite <- H1 in inn1; simpl in inn1.
          rewrite in_app_iff in inn1.
          invcs disj.
          invcs H3.
          destruct a; simpl in *.
          destruct inn1 as [inn1|inn1].
          - apply in_dom in inn1.
            apply (H5 a); simpl; eauto.
          - apply concat_In in inn1.
            destruct inn1 as [? [inn1 inn2]].
            rewrite Forall_forall in H6.
            specialize (H6 (domain x)).
            cut_to H6.
            + apply in_dom in inn2.
              apply (H6 a); simpl; eauto.
            + apply in_map; trivial.
        }
        rewrite concat_app in H.
        case_eq (concat ll1); [intros eqq | intros ?? eqq]
        ; rewrite eqq in *.
        * simpl in H; invcs H.
          apply concat_nil_r in eqq.
          change (is_interleaved ((l1::nil)++a0 :: l2) (l1 ++ nil++concat ll2)).
          { apply is_interleaved_app.
            - apply is_interleaved_refl.
            - rewrite H1.
              apply is_interleaved_app.
              + apply is_interleaved_nil_r; trivial.
              + apply is_interleaved_concat_simple.
          }
        * invcs H.
          simpl in nin; intuition.
      + destruct (Permutation_in_nin_inv H3 a) as [eqq perm].
        * simpl; eauto.
        * invcs disj.
          invcs H1.
          rewrite Forall_forall in *.
          destruct a; simpl in *.
          { rewrite in_app_iff; intros [inn|inn].
            - apply in_dom in inn.
              apply (H5 a); simpl; eauto.
            - apply concat_In in inn.
              destruct inn as [? [inn1 inn2]].
              specialize (H6 (domain x)).
              cut_to H6.
              + apply in_dom in inn2.
                apply (H6 a); simpl; eauto.
              + apply in_map; trivial.
          }
        * invcs eqq.
          rewrite perm in H2; trivial.
  Qed.

  Lemma is_interleaved_in_dom_cons_inv {A B} {dec:EqDec A eq} {a:(A*B)} {l1 l2 l3} :
    is_interleaved (l1::l2) (a::l3) ->
    all_disjoint (map domain (l1::l2)) ->
    In (fst a) (domain l1) ->
    exists l1', l1 = a::l1'.
  Proof.
    intros isl disj inn.
    destruct a; simpl in *.
    invcs isl.
    - assert (perm:Permutation (filter_nil ls1) (filter_nil (l1::l2))).
      { apply Permutation_filter; trivial. }
      rewrite <- concat_filter_nil in H.
      assert (nnil:not_nil l1 = true).
      { destruct l1; simpl in *; tauto. }
      simpl in perm; rewrite nnil in perm.
      case_eq (filter_nil ls1); [intros eqq | intros ?? eqq]
      ; rewrite eqq in *; simpl in *; try discriminate.
      destruct l; simpl in *.
      + cut False; [contradiction | ].
        revert eqq; clear.
        induction ls1; simpl; try discriminate.
        destruct a; simpl; trivial; try discriminate.
      + invcs H.
        destruct (Permutation_in_nin_inv perm (a,b))
          as [eqq2 perm2].
        * simpl; eauto.
        * rewrite concat_In.
          intros [x [inn1 inn2]].
          invcs disj.
          rewrite Forall_forall in H2.
          specialize (H2 (domain x)).
          { cut_to H2.
            - apply (H2 a); trivial; eapply in_dom; eauto.
            - apply in_map; trivial.
              unfold filter_nil in inn1.
              apply filter_In in inn1; tauto.
          }
        * subst; eauto.
    - destruct (Permutation_in_nin_inv H3 (a,b))
        as [eqq perm].
      + simpl; eauto.
      + rewrite concat_In.
        intros [x [inn1 inn2]].
        invcs disj.
        rewrite Forall_forall in H1.
        specialize (H1 (domain x)).
        cut_to H1.
        * apply (H1 a); trivial; eapply in_dom; eauto.
        * apply in_map; trivial.
      + subst; eauto.
  Qed.

  Lemma is_interleaved_in_cons_inv {A B} {dec:EqDec A eq} {a:(A*B)} {l1 l2 l3} :
    is_interleaved (l1::l2) (a::l3) ->
    all_disjoint (map domain (l1::l2)) ->
    In a l1 ->
    exists l1', l1 = a::l1'.
  Proof.
    intros; eapply is_interleaved_in_dom_cons_inv; eauto.
    destruct a.
    eapply in_dom; eauto.
  Qed.

  Lemma is_interleaved_cons_dom_eq {A B} {dec:EqDec A eq} {a:A} {b b':B} {l1 l2 l3} :
    is_interleaved (((a, b)::l1)::l2) ((a,b')::l3) ->
    all_disjoint (map domain (((a,b)::l1)::l2)) ->
    b = b'.
  Proof.
    intros isl disj.
    destruct (is_interleaved_in_dom_cons_inv isl disj); simpl; [eauto | ].
    invcs H; trivial.
  Qed.

  Lemma is_interleaved_cons_dom_inv {A B} {dec:EqDec A eq} {a:A} {b b':B} {l1 l2 l3} :
    is_interleaved (((a, b)::l1)::l2) ((a,b')::l3) ->
    all_disjoint (map domain (((a,b)::l1)::l2)) ->
    is_interleaved (l1::l2) l3.
  Proof.
    intros isl disj.
    rewrite <- (is_interleaved_cons_dom_eq isl disj) in isl.
    eapply is_interleaved_cons_inv; eauto.
  Qed.

End interleaving.

Section close_enough.

  Definition close_enough_lists {A B:Type} (l1 l2:list (A*B)) :=
    exists (ls:list (list (A*B))),
      all_disjoint (map domain ls) /\
      is_interleaved ls l1 /\
      is_interleaved ls l2.

  Global Instance close_enough_lists_refl {A B} : Reflexive (@close_enough_lists A B).
  Proof.
    intros x.
    exists (x::nil); simpl; repeat split.
    - repeat constructor.
    - apply is_interleaved_refl.
    - apply is_interleaved_refl.
  Qed.

  Global Instance close_enough_lists_symm {A B} : Symmetric (@close_enough_lists A B).
  Proof.
    intros x y [l [disj [isl1 isl2]]].
    exists l; eauto.
  Qed.

  (* This should be true, but would take more work to prove.
       This can be proven by exhibiting a finer witness.  In general, in fact,
       we can group things by clumping all the same domain stuff together *)
  (*
    Global Instance close_enough_lists_trans {A B} : Transitive (@close_enough_lists A B).
    Proof.
      intros x y z [xyl [xydisj [xyisl1 xyisl2]]] [yzl [yzdisj [yzisl1 yzisl2]]].
      red.
      assert (perm:Permutation xyl yzl).
      - apply is_interleaved_perm_concat in xyisl2.
        apply is_interleaved_perm_concat in yzisl1.
        rewrite xyisl2 in yzisl1.

    Qed.
   *)

  Global Instance close_enough_lists_lookup_equiv {A B} {dec:EqDec A eq} :
    subrelation (@close_enough_lists A B) lookup_equiv.
  Proof.
    intros l1 l2 [l [disj [isl1 isl2]]].
    eapply is_interleaved_disjoint_lookup_equiv; eauto.
  Qed.

  Lemma close_enough_update_first {A B} dec (l1 l2:list (A*B)) v d :
    close_enough_lists l1 l2 ->
    close_enough_lists (update_first dec l1 v d) (update_first dec l2 v d).
  Proof.
    intros [l [disj [isl1 isl2]]].
    red.
    exists (map (fun l => update_first dec l v d) l).
    repeat split.
    - rewrite map_map.
      replace (map (fun x : list (A * B) => domain (update_first dec x v d)) l)
        with (map domain l); trivial.
      apply map_ext; intros.
      rewrite domain_update_first; trivial.
    - apply is_interleaved_disjoint_update_first; trivial.
    - apply is_interleaved_disjoint_update_first; trivial.
  Qed.

  Hint Resolve disjoint_nil_l disjoint_nil_r : list.

  Lemma close_enough_lists_cons {A B} {dec:EqDec A eq} (a:(A*B)) l1 l2 :
    close_enough_lists l1 l2 ->
    close_enough_lists (a::l1) (a::l2).
  Proof.
    destruct a.
    intros [l [disj [isl1 isl2]]].
    destruct (in_in_split_domain_or dec l a)
      as [[m1 [ma [m2 [eqq [inn nin]]]]]|nin].
    - subst.
      exists (m1++((a,b)::ma)::m2).
      assert (perm1: Permutation (m1 ++ ((a, b) :: ma) :: m2) (((a, b) :: ma)::m1 ++ m2)).
      { rewrite <- Permutation_cons_app; try reflexivity. }
      assert (perm2: Permutation (m1 ++ ma :: m2) (ma::m1 ++ m2)).
      { rewrite <- Permutation_cons_app; try reflexivity. }
      repeat rewrite perm1.
      repeat rewrite perm2 in *.
      repeat split.
      + repeat rewrite map_app in *; simpl in *.
        invcs disj.
        constructor; trivial.
        revert H1; apply Forall_impl; intros.
        intros ?; simpl; intros inn1 inn2.
        eapply H; try eapply inn2.
        destruct inn1; subst; trivial.
      + econstructor; eauto.
      + econstructor; eauto.
    - exists (((a,b)::nil)::l); simpl.
      repeat split.
      + constructor; trivial.
        rewrite Forall_map.
        revert nin; apply Forall_impl; intros.
        apply disjoint_cons1; auto with list.
      + econstructor; eauto.
        apply is_interleaved_cons_nil in isl1; trivial.
      + econstructor; eauto.
        apply is_interleaved_cons_nil in isl2; trivial.
  Qed.

  Lemma close_enough_lists_cons_invs {A B} {dec:EqDec A eq} (a:A) (b b':B) l1 l2 :
    close_enough_lists ((a,b)::l1) ((a,b')::l2) ->
    b = b' /\ close_enough_lists l1 l2.
  Proof.
    intros [ll [disj [isl1 isl2]]].
    assert (inn1:In a (domain (concat ll))).
    { apply is_interleaved_perm_concat in isl1.
      rewrite <- isl1; simpl; eauto.
    }
    destruct (in_in_split_domain_first dec inn1)
      as [m1 [ma [m2 [eqq [inn nin]]]]]
    ; subst; clear inn1.
    rewrite <- Permutation_cons_app in isl1; try reflexivity.
    rewrite <- Permutation_cons_app in isl2; try reflexivity.
    rewrite <- Permutation_cons_app in disj; try reflexivity.
    assert(inn1:In (a, b) ma).
    { apply is_interleaved_perm_concat in isl1.
      assert (inn2:In (a,b) (concat (ma :: m1 ++ m2))).
      { rewrite <- isl1; simpl; eauto. }
      simpl in inn2.
      rewrite concat_app in inn2.
      repeat rewrite in_app_iff in inn2.
      invcs disj; rewrite Forall_forall in H1.
      destruct inn2 as [inn2|[inn2|inn2]]; trivial.
      - apply concat_In in inn2.
        destruct inn2 as [x [inn3 inn4]].
        specialize (H1 (domain x)).
        cut_to H1.
        + elim (H1 a); trivial; eapply in_dom; eauto.
        + rewrite map_app, in_app_iff.
          left; apply in_map; trivial.
      - apply concat_In in inn2.
        destruct inn2 as [x [inn3 inn4]].
        specialize (H1 (domain x)).
        cut_to H1.
        + elim (H1 a); trivial; eapply in_dom; eauto.
        + rewrite map_app, in_app_iff.
          right; apply in_map; trivial.
    }
    destruct (is_interleaved_in_cons_inv isl1 disj inn1) as [mm ?]; subst.
    apply is_interleaved_cons_inv in isl1; trivial.
    split.
    - apply (is_interleaved_cons_dom_eq isl2); trivial.
    - apply is_interleaved_cons_dom_inv in isl2; trivial.
      exists (mm::m1++m2); repeat split; trivial.
      simpl in disj.
      apply all_disjoint_cons_inv in disj.
      tauto.
  Qed.

  Lemma close_enough_lists_cons_inv {A B} {dec:EqDec A eq} (a:(A*B)) l1 l2 :
    close_enough_lists (a::l1) (a::l2) ->
    close_enough_lists l1 l2.
  Proof.
    destruct a.
    apply close_enough_lists_cons_invs.
  Qed.

End close_enough.


From iris.heap_lang Require Export spawn.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".
Import uPred.

Definition parN : namespace := nroot .@ "par".

Definition par : val :=
  λ: "fs",
    let: "handle" := spawn (Fst "fs") in
    let: "v2" := Snd "fs" #() in
    let: "v1" := join "handle" in
    ("v1", "v2").
Notation "e1 ||| e2" := (par (Pair (λ: <>, e1) (λ: <>, e2)))%E : expr_scope.

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapG Σ, !spawnG Σ}.

(* Notice that this allows us to strip a later *after* the two Ψ have been
   brought together.  That is strictly stronger than first stripping a later
   and then merging them, as demonstrated by [tests/joining_existentials.v].
   This is why these are not Texan triples. *)
Lemma par_spec (Ψ1 Ψ2 : val → iProp Σ) e (f1 f2 : val) (Φ : val → iProp Σ) :
  to_val e = Some (f1,f2)%V →
  WP f1 #() {{ Ψ1 }} -∗ WP f2 #() {{ Ψ2 }} -∗
  (▷ ∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
  WP par e {{ Φ }}.
Proof.
  iIntros (?) "Hf1 Hf2 HΦ".
  rewrite /par. wp_value. wp_let. wp_proj.
  wp_apply (spawn_spec parN with "Hf1"); try wp_done; try solve_ndisj.
  iIntros (l) "Hl". wp_let. wp_proj. wp_bind (f2 _).
  iApply (wp_wand with "Hf2"); iIntros (v) "H2". wp_let.
  wp_apply (join_spec with "[$Hl]"). iIntros (w) "H1".
  iSpecialize ("HΦ" with "[-]"); first by iSplitL "H1". by wp_let.
Qed.

Lemma wp_par (Ψ1 Ψ2 : val → iProp Σ)
    (e1 e2 : expr) `{!Closed [] e1, Closed [] e2} (Φ : val → iProp Σ) :
  WP e1 {{ Ψ1 }} -∗ WP e2 {{ Ψ2 }} -∗
  (∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
  WP e1 ||| e2 {{ Φ }}.
Proof.
  iIntros "H1 H2 H". iApply (par_spec Ψ1 Ψ2 with "[H1] [H2] [H]"); try wp_done.
  by wp_let. by wp_let. auto.
Qed.
End proof.


From Coq.Lists Require Import List.
From Equations Require Import Equations.

(* This type is from VST: https://github.com/PrincetonUniversity/VST/blob/v2.1/floyd/compact_prod_sum.v#L6 *)
Fixpoint compact_prod (T: list Type): Type :=
  match T with
  | nil => unit
  | t :: nil => t
  | t :: T0 => (t * compact_prod T0)%type
  end.

(* The rest is a nonsensical, just to give a minimalistic reproducible example *)
Inductive Foo :=
| Foo1 : list Foo -> Foo
| Foo2 : list Foo -> Foo.

Equations foo_type (t : Foo) : Type :=
  foo_type (Foo1 fs) := compact_prod (List.map foo_type fs);
  foo_type (Foo2 fs) := compact_prod (List.map foo_type fs).

(* Moving val nato the return type, rather than having it as an argument might be unnecessary if
   https://github.com/mattam82/Coq-Equations/issues/73 was fixed *)
Equations do_foo (t : Foo) : forall (val : foo_type t), nat := {
  do_foo (Foo1 fs) := fun val => do_foo1 fs val;
  do_foo (Foo2 fs) := fun val => do_foo2 fs val }

  where
    do_foo1 (fs:list Foo) : forall (val : compact_prod (map foo_type fs)), nat := {
    do_foo1 _ := fun val => 0}

  where
    do_foo2 (fs : list Foo) : forall val : compact_prod (List.map foo_type fs), nat by struct fs := {
    do_foo2 nil := fun val => 0;
    do_foo2 (cons var nil) :=
      fun val => do_foo var val;
    do_foo2 _ := fun val => 0
}.