Require Import Coq.omega.Omega.
Require Import Coq.Arith.Arith Bedrock.Platform.AutoSep Bedrock.Platform.Bags Bedrock.Platform.Malloc Bedrock.Platform.Queue Bedrock.Platform.Misc.
Import W_W_Bag.

Set Implicit Arguments.

Record tq_args (world : Type) := {
  World : world;
  Pointer : W;
  Settings : settings;
  Mem : smem
}.

Module Type S.
  Parameter world : Type.

  Parameter evolve : world -> world -> Prop.
  Axiom evolve_refl : forall w, evolve w w.
  Axiom evolve_trans : forall w1 w2 w3, evolve w1 w2 -> evolve w2 w3 -> evolve w1 w3.

  Parameter globalInv : world -> W -> hpropB (tq_args world :: nil).
End S.

Definition localsInvariantExit (pre : vals -> W -> qspec) (rpStashed : bool) (adjustSp : W -> W)
  (ns : list string) (_ : nat) : assert :=
  st ~> let sp := adjustSp st#Sp in
    [| sp <> 0 |]
    /\ Ex vs, let res := wordToNat (sel vs "ss") - S (length ns) in
      [| freeable sp (wordToNat (sel vs "ss")) |]
      /\ qspecOut (pre (sel vs) st#Rv) (fun pre =>
        ![ locals ("rp" :: ns) vs res sp * pre ] st).

Notation "'PREexit' [ vs ] pre" := (localsInvariantExit (fun vs _ => pre%qspec%Sep))
  (at level 89).

Notation "'PREexit' [ vs , rv ] pre" := (localsInvariantExit (fun vs rv => pre%qspec%Sep))
  (at level 89).

Module Make(M : S).
Import M.

(* What does it mean for a program counter to be valid for a suspended thread? *)

Definition susp (w : world) (sc pc sp : W) : HProp := fun s m =>
  (Ex pc_tq : W, [| s.(Labels) ("threadq"!"ADT")%SP = Some pc_tq |]
    /\ ExX (* tq *) : tq_args world, Cptr pc_tq (_ ~> PropX.Forall #0)
    /\ ExX (* pre *) : settings * state, Cptr pc #0
    /\ ExX (* inv *) : settings * smem, #0 (s, m)
    /\ Al st : state, Al w' : world,
    [| evolve w w' |]
    /\ ![ #0 * (fun x y => Lift (Lift (Var0 {| World := w';
                                               Pointer := sc;
                                               Settings := x;
                                               Mem := y |})))
      * (fun x y => Lift (Lift (globalInv w' sc x y)))
      * ^[mallocHeap 0] ] (s, st)
    /\ [| Regs st Sp = sp |]
    ---> #1 (s, st))%PropX.

Lemma susp_intro : forall specs w sc pc sp P stn st,
  (exists pc_tq, stn.(Labels) ("threadq"!"ADT")%SP = Some pc_tq
    /\ exists tq, specs pc_tq = Some (fun _ => PropX.Forall tq)
      /\ exists pre, specs pc = Some (fun x => pre x)
        /\ exists inv, interp specs (![ inv * P ] (stn, st))
          /\ forall st' w', interp specs ([| evolve w w' |]
            /\ ![ inv
              * (fun x y => tq {| World := w';
                                  Pointer := sc;
                                  Settings := x;
                                  Mem := y |})
              * substH (globalInv w' sc) tq * mallocHeap 0 ] (stn, st')
            /\ [| Regs st' Sp = sp |]
            ---> pre (stn, st'))%PropX)
  -> interp specs (![ susp w sc pc sp * P ] (stn, st)).
  cptr.
Qed.

Lemma susp_elim : forall specs w sc pc sp P stn st,
  interp specs (![ susp w sc pc sp * P ] (stn, st))
  -> (exists pc_tq, stn.(Labels) ("threadq"!"ADT")%SP = Some pc_tq
    /\ exists tq, specs pc_tq = Some (fun _ => PropX.Forall tq)
      /\ exists pre, specs pc = Some (fun x => pre x)
        /\ exists inv, interp specs (![ inv * P ] (stn, st))
          /\ forall st' w', interp specs ([| evolve w w' |]
            /\ ![ inv * (fun x y => tq {| World := w';
                                          Pointer := sc;
                                          Settings := x;
                                          Mem := y |}) * substH (globalInv w' sc) tq * mallocHeap 0 ] (stn, st')
            /\ [| Regs st' Sp = sp |]
            ---> pre (stn, st'))%PropX).
  cptr.
  propxFo; eauto.
  descend; eauto.
  rewrite <- sepFormula_eq; descend.
  step auto_ext.
  eauto.
  make_Himp.
  apply Himp_refl.
Qed.

Inductive mergeSusp : Prop := MS.
Inductive splitSusp : Prop := SS.

Hint Constructors mergeSusp splitSusp.

Module Type TQ.
  Parameter susps : world -> bag -> W -> HProp.
  Parameter tq : world -> W -> HProp.

  Axiom tq_extensional : forall w sc, HProp_extensional (tq w sc).

  Axiom susps_empty_bwd : forall w sc, Emp ===> susps w empty sc.
  Axiom susps_add_bwd : forall w sc b pc sp, pc = pc -> mergeSusp -> susp w sc pc sp * susps w b sc ===> susps w (b %+ (pc, sp)) sc.
  Axiom susps_del_fwd : forall w sc b pc sp, (pc, sp) %in b -> susps w b sc ===> susp w sc pc sp * susps w (b %- (pc, sp)) sc.

  (* Below, the extra [locals] is a temporary stack for the threadq to use during sensitive
   * stack manipulations when the threads' own stacks may not be safe to touch. *)

  Axiom tq_fwd : forall w sc, tq w sc ===> Ex b, Ex p, Ex sp, Ex vs, (sc ==*> p, sp) * (sc ^+ $8) =?> 2
    * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 sp
    * queue b p * susps w b sc.

  Axiom tq_bwd : forall w sc, (Ex b, Ex p, Ex sp, Ex vs, (sc ==*> p, sp) * (sc ^+ $8) =?> 2
    * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 sp
    * queue b p * susps w b sc) ===> tq w sc.

  Axiom tq_weaken : forall w w' sc,
    evolve w w'
    -> tq w sc ===>* tq w' sc.
End TQ.

Module Tq : TQ.
  Open Scope Sep_scope.

  Definition susps (w : world) (b : bag) (sc : W) : HProp :=
    starB (fun p => susp w sc (fst p) (snd p)) b.

  Theorem susps_empty_bwd : forall w sc, Emp ===> susps w empty sc.
    intros; apply starB_empty_bwd.
  Qed.

  Theorem susps_add_bwd : forall w sc b pc sp, pc = pc -> mergeSusp -> susp w sc pc sp * susps w b sc ===> susps w (b %+ (pc, sp)) sc.
    intros; eapply Himp_trans; [ | apply starB_add_bwd ].
    unfold susps; simpl.
    apply Himp_star_comm.
  Qed.

  Theorem susps_del_fwd : forall w sc b pc sp, (pc, sp) %in b -> susps w b sc ===> susp w sc pc sp * susps w (b %- (pc, sp)) sc.
    intros; eapply Himp_trans; [ apply starB_del_fwd; eauto | apply Himp_refl ].
  Qed.

  Definition tq (w : world) (sc : W) : HProp :=
    Ex b, Ex p, Ex sp, Ex vs, (sc ==*> p, sp) * (sc ^+ $8) =?> 2
      * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 sp
      * queue b p * susps w b sc.

  Theorem tq_extensional : forall w sc, HProp_extensional (tq w sc).
    reflexivity.
  Qed.

  Theorem tq_fwd : forall w sc, tq w sc ===> Ex b, Ex p, Ex sp, Ex vs, (sc ==*> p, sp) * (sc ^+ $8) =?> 2
    * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 sp
    * queue b p * susps w b sc.
    unfold tq; sepLemma.
  Qed.

  Theorem tq_bwd : forall w sc, (Ex b, Ex p, Ex sp, Ex vs, (sc ==*> p, sp) * (sc ^+ $8) =?> 2
    * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 sp
    * queue b p * susps w b sc) ===> tq w sc.
    unfold tq; sepLemma.
  Qed.

  Theorem into_ex : forall A (P P' : A -> _),
    (forall x, P x ===>* P' x)
    -> exB P ===>* exB P'.
    unfold HimpWeak; propxFo.
    apply H in H0; eauto.
  Qed.

  Theorem into_star : forall P P' Q Q',
    P ===>* P'
    -> Q ===>* Q'
    -> P * Q ===>* P' * Q'.
    unfold HimpWeak; propxFo.
    apply H in H1; apply H0 in H4; eauto.
  Qed.

  Theorem weak_refl : forall P,
    P ===>* P.
    unfold HimpWeak; auto.
  Qed.

  Theorem tq_weaken : forall w w' sc,
    evolve w w'
    -> tq w sc ===>* tq w' sc.
    unfold tq; intros; repeat match goal with
                                | [ |- exB _ ===>* exB _ ] => apply into_ex; intro
                                | [ |- (_ * _ ===>* _ * _)%Sep ] => apply into_star; try apply weak_refl
                              end.
    apply starB_weaken_weak; intros.
    unfold HimpWeak; propxFo; descend; eauto.
    eapply Imply_trans; [ | apply H5 ]; clear H5.
    descend.
    apply andL; apply injL; intro.
    apply andR; [ apply injR | ].
    eapply evolve_trans; eauto.
    apply Imply_refl.
  Qed.
End Tq.

Import Tq.
Export Tq.
Hint Immediate tq_extensional.

Definition locals_expose ns vs ss sp := locals ns vs ss sp.
Opaque mult.
Require Import Coq.Arith.Arith.
Transparent mult.

Lemma expose_stack : forall ns vs ss sp,
  locals_expose ns vs ss sp ===> sp =?> (length ns + ss).
  unfold locals_expose, locals; intros; eapply Himp_trans; [ | apply allocated_join ].
  instantiate (1 := length ns).
  2: omega.
  Opaque mult.
  sepLemma.
  eapply Himp_trans; [ apply Himp_star_comm | ].
  eapply Himp_star_frame.
  eapply Himp_trans; [ apply ptsto32m_allocated | ].
  rewrite length_toArray; apply Himp_refl.
  apply allocated_shift_base.
  unfold natToW; rewrite mult_comm; words.
  omega.
  Transparent mult.
Qed.

Definition hints : TacPackage.
  prepare (tq_fwd, create_stack, expose_stack) (tq_bwd, susps_empty_bwd, susps_add_bwd).
Defined.

(* What is a valid initial code pointer for a thread, given the requested stack size? *)

Definition ginv w sc := substH (globalInv w sc) (fun x => tq (World x) (Pointer x) (Settings x) (Mem x)).

Definition starting (w : world) (sc pc : W) (ss : nat) : HProp := fun s m =>
  (ExX (* pre *) : settings * state, Cptr pc #0
    /\ [| semp m |]
    /\ Al st : state, Al vs, Al w',
      [| evolve w w' |]
      /\ [| Regs st Sp <> 0 /\ freeable (Regs st Sp) (1 + ss) |]
      /\ ![ ^[locals ("rp" :: nil) vs ss (Regs st Sp) * tq w' sc * ginv w' sc * mallocHeap 0] ] (s, st)
      ---> #0 (s, st))%PropX.

Local Hint Resolve split_a_semp_a semp_smem_emp.

Lemma starting_intro : forall specs sc w pc ss P stn st,
  (exists pre, specs pc = Some (fun x => pre x)
    /\ interp specs (![ P ] (stn, st))
    /\ forall st' vs w', interp specs ([| evolve w w' |]
      /\ [| Regs st' Sp <> 0 /\ freeable (Regs st' Sp) (1 + ss) |]
      /\ ![ locals ("rp" :: nil) vs ss (Regs st' Sp)
      * tq w' sc * ginv w' sc * mallocHeap 0 ] (stn, st')
    ---> pre (stn, st'))%PropX)
  -> interp specs (![ starting w sc pc ss * P ] (stn, st)).
  cptr.
Qed.

Lemma starting_elim : forall specs w sc pc ss P stn st,
  interp specs (![ starting w sc pc ss * P ] (stn, st))
  -> (exists pre, specs pc = Some (fun x => pre x)
    /\ interp specs (![ P ] (stn, st))
    /\ forall st' vs w', interp specs ([| evolve w w' |]
      /\ [| Regs st' Sp <> 0 /\ freeable (Regs st' Sp) (1 + ss) |]
      /\ ![ locals ("rp" :: nil) vs ss (Regs st' Sp)
      * tq w' sc * ginv w' sc * mallocHeap 0 ] (stn, st')
    ---> pre (stn, st'))%PropX).
  cptr.
  generalize (split_semp _ _ _ H0 H); intros; subst; auto.
  rewrite <- sepFormula_eq; descend; step auto_ext.
  eauto.
  eauto.
  make_Himp.
  apply Himp_refl.
Qed.

Definition susp' (w : world) (sc pc sp : W) : HProp := fun s m =>
  (ExX (* pre *) : settings * state, Cptr pc #0
    /\ ExX (* inv *) : settings * smem, #0 (s, m)
    /\ Al st : state, Al w' : world,
    [| evolve w w' |]
    /\ ![ #0 * ^[tq w' sc * ginv w' sc * mallocHeap 0] ] (s, st)
    /\ [| Regs st Sp = sp |]
    ---> #1 (s, st))%PropX.

Lemma susp_convert : forall specs w sc pc sp P stn st pc_tq,
  interp specs (![ susp' w sc pc sp * P ] (stn, st))
  -> Labels stn (labl "threadq" "ADT") = Some pc_tq
  -> specs pc_tq = Some (fun _ => PropX.Forall (fun x => tq (World x) (Pointer x) (Settings x) (Mem x)))
  -> interp specs (![ susp w sc pc sp * P ] (stn, st)).
  cptr.
  descend; step auto_ext.
  eauto.
  step auto_ext.
Qed.

Lemma susp'_intro : forall specs w sc pc sp P stn st,
  (exists pre, specs pc = Some (fun x => pre x)
    /\ exists inv, interp specs (![ inv * P ] (stn, st))
      /\ forall st' w', interp specs ([| evolve w w' |]
        /\ ![ inv * tq w' sc * ginv w' sc * mallocHeap 0 ] (stn, st')
        /\ [| Regs st' Sp = sp |]
        ---> pre (stn, st'))%PropX)
  -> interp specs (![ susp' w sc pc sp * P ] (stn, st)).
  cptr.
  descend; step auto_ext.
  eauto.
  descend; step auto_ext.
Qed.

Definition initS : spec := SPEC reserving 12
  Al w,
  PRE[_] mallocHeap 0
  POST[R] tq w R * mallocHeap 0.

Definition isEmptyS : spec := SPEC("sc") reserving 4
  Al w,
  PRE[V] tq w (V "sc") * mallocHeap 0
  POST[_] tq w (V "sc") * mallocHeap 0.

Definition spawnWithStackS : spec := SPEC("sc", "pc", "sp") reserving 14
  Al w,
  PRE[V] tq w (V "sc") * susp' w (V "sc") (V "pc") (V "sp") * mallocHeap 0
  POST[_] tq w (V "sc") * mallocHeap 0.

Definition spawnS : spec := SPEC("sc", "pc", "ss") reserving 18
  Al w,
  PRE[V] [| V "ss" >= $2 |] * tq w (V "sc") * starting w (V "sc") (V "pc") (wordToNat (V "ss") - 1) * mallocHeap 0
  POST[_] tq w (V "sc") * mallocHeap 0.

Definition localsInvariantExit' (pre : vals -> W -> qspec) (rpStashed : bool) (adjustSp : W -> W)
  (ns : list string) (_ : nat) : assert :=
  st ~> let sp := adjustSp st#Sp in
    Ex vs, qspecOut (pre (sel vs) st#Rv) (fun pre =>
      ![ locals ("rp" :: ns) vs 14 sp * pre ] st).

Local Notation "'PREexit'' [ vs ] pre" := (localsInvariantExit' (fun vs _ => pre%qspec%Sep))
  (at level 89).

Local Notation "'PREexit'' [ vs , rv ] pre" := (localsInvariantExit' (fun vs rv => pre%qspec%Sep))
  (at level 89).

Definition exitS : spec := SPEC("sc", "ss") reserving 0
  Al w,
  PREexit[V] [| V "ss" >= $3 |] * tq w (V "sc") * ginv w (V "sc") * mallocHeap 0.

Local Notation "'bexit' name ( x1 , .. , xN ) [ p ] b 'end'" :=
  (let p' := p in
   let vars := cons x1 (.. (cons xN nil) ..) in
    {| FName := name;
      FPrecondition := Precondition p' None;
      FBody := b%SP;
      FVars := vars;
      FReserved := Reserved p' |})
  (no associativity, at level 95, name at level 0, p at level 0, only parsing) : SPfuncs_scope.

Definition yieldS : spec := SPEC("sc") reserving 19
  Al w,
  PRE[V] tq w (V "sc") * ginv w (V "sc") * mallocHeap 0
  POST[_] Ex w', [| evolve w w' |] * tq w' (V "sc") * ginv w' (V "sc") * mallocHeap 0.

(* Next, some hijinks to prevent unnecessary unfolding of distinct memory cells for the threadq's stack. *)

Definition stackSize := 21.

Lemma stackSize_bound : natToW stackSize >= natToW 2.
  unfold stackSize; auto.
Qed.

Hint Immediate stackSize_bound.

Lemma stackSize_split : stackSize = length ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) + 14.
  reflexivity.
Qed.

Opaque stackSize.

Definition yieldInvariantCont (pre : vals -> W -> qspec) (rpStashed : bool) (adjustSp : W -> W)
  (ns : list string) (res : nat) : assert :=
  st ~> let sp := adjustSp st#Sp in
    Ex vs, qspecOut (pre (sel vs) st#Rv) (fun pre =>
      ![ ^[locals ("rp" :: ns) vs res sp * pre] ] st).

Local Notation "'PREy' [ vs ] pre" := (yieldInvariantCont (fun vs _ => pre%qspec%Sep))
  (at level 89).

Notation "'badt' name p 'end'" :=
  {| FName := name;
    FPrecondition := (fun _ => PropX.Forall p);
    FBody := Diverge;
    FVars := nil;
    FReserved := 0 |}
  (no associativity, at level 95, name at level 0, p at level 0, only parsing) : SPfuncs_scope.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS],
    "queue"!"init" @ [Queue.initS], "queue"!"isEmpty" @ [Queue.isEmptyS],
    "queue"!"enqueue" @ [enqueueS], "queue"!"dequeue" @ [dequeueS] ]]
  bmodule "threadq" {{
    badt "ADT"
      (fun x => tq (World x) (Pointer x) (Settings x) (Mem x))
    end with bfunction "init"("q", "sp", "r") [initS]
      "q" <-- Call "queue"!"init"()
      [PRE[_, R] mallocHeap 0
       POST[R'] Ex sp, Ex vs, (R' ==*> R, sp) * (R' ^+ $8) =?> 2
         * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 sp
         * mallocHeap 0];;

      "sp" <-- Call "malloc"!"malloc"(0, stackSize)
      [PRE[V, R] R =?> stackSize * mallocHeap 0
        POST[R'] Ex vs, (R' ==*> V "q", R) * (R' ^+ $8) =?> 2 * mallocHeap 0
         * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 R];;

      Assert [PRE[V] mallocHeap 0
        POST[R] (R ==*> V "q", V "sp") * (R ^+ $8) =?> 2 * mallocHeap 0];;

      "r" <-- Call "malloc"!"malloc"(0, 4)
      [PRE[V, R] R =?> 4
       POST[R'] [| R' = R |] * (R ==*> V "q", V "sp") * (R ^+ $8) =?> 2 ];;
      "r" *<- "q";;
      "r" + 4 *<- "sp";;
      Return "r"
    end with bfunction "isEmpty"("sc") [isEmptyS]
      "sc" <-* "sc";;
      "sc" <-- Call "queue"!"isEmpty"("sc")
      [PRE[_, R] Emp
       POST[R'] [| R' = R |] ];;
      Return "sc"
    end with bfunction "spawnWithStack"("sc", "pc", "sp") [spawnWithStackS]
      Assert* [("threadq","ADT")] [Al w,
        PRE[V] tq w (V "sc") * susp w (V "sc") (V "pc") (V "sp") * mallocHeap 0
        POST[_] tq w (V "sc") * mallocHeap 0];;

      "sc" <-* "sc";;
      Note [mergeSusp];;
      Call "queue"!"enqueue"("sc", "pc", "sp")
      [Al w, Al b, Al sc,
        PRE[V] susps w (b %+ (V "pc", V "sp")) sc
         POST[_] susps w (b %+ (V "pc", V "sp")) sc];;
      Return 0
    end with bfunction "spawn"("sc", "pc", "ss") [spawnS]
      "ss" <-- Call "malloc"!"malloc"(0, "ss")
      [Al w, Al ss,
        PRE[V, R] tq w (V "sc") * starting w (V "sc") (V "pc") (ss - 1) * mallocHeap 0
          * R =?> ss * [| (ss >= 2)%nat |] * [| R <> 0 |] * [| freeable R ss |]
        POST[_] tq w (V "sc") * mallocHeap 0];;

      Assert [Al w, Al ss, Al vs,
        PRE[V] tq w (V "sc") * starting w (V "sc") (V "pc") ss * mallocHeap 0
          * locals ("rp" :: nil) vs ss (V "ss") * [| V "ss" <> 0 |] * [| freeable (V "ss") (1 + ss) |]
        POST[_] tq w (V "sc") * mallocHeap 0];;

      Assert* [("threadq","ADT")]
      [Al w,
        PRE[V] tq w (V "sc") * susp' w (V "sc") (V "pc") (V "ss") * mallocHeap 0
        POST[_] tq w (V "sc") * mallocHeap 0];;

      Call "threadq"!"spawnWithStack"("sc", "pc", "ss")
      [PRE[_] Emp
       POST[_] Emp];;
      Return 0
    end with bexit "exit"("sc", "ss", "curPc", "curSp", "newPc", "newSp") [exitS]
      Rp <-* "sc" + 4;;
      Rp + 4 *<- "sc";;
      Rp + 8 *<- "ss";;
      Rp + 12 *<- Sp;;
      Sp <- Rp;;

      Call "malloc"!"free"(0, "curPc", "ss")
      [Al w, Al q, Al qp, Al tsp,
        PREexit'[V] (V "sc" ==*> qp, tsp) * queue q qp * (V "sc" ^+ $8) =?> 2
          * susps w q (V "sc") * ginv w (V "sc") * mallocHeap 0];;

      "curPc" <-* "sc";;
      "curSp" <-- Call "queue"!"isEmpty"("curPc")
      [Al w, Al q, Al tsp,
        PREexit'[V, R] [| (q %= empty) \is R |]
          * queue q (V "curPc") * (V "sc" ==*> V "curPc", tsp)
          * (V "sc" ^+ $8) =?> 2 * susps w q (V "sc") * ginv w (V "sc") * mallocHeap 0];;

      If ("curSp" = 1) {
        (* No threads left to run.  Let's loop forever! *)
        Diverge
      } else {
        (* Pick a thread to switch to. *)

        "curSp" <- "sc" + 8;;
        Call "queue"!"dequeue"("curPc", "curSp")
        [Al w, Al q, Al tsp, Al pc, Al sp,
          PREexit'[V] [| (pc, sp) %in q |] * queue (q %- (pc, sp)) (V "curPc")
            * susps w (q %- (pc, sp)) (V "sc") * susp w (V "sc") pc sp
            * (V "sc" ==*> V "curPc", tsp, pc, sp) * ginv w (V "sc") * mallocHeap 0];;

        "sc" + 4 *<- Sp;;
        Rp <-* "sc" + 8;;
        Sp <-* "sc" + 12;;
        IGoto* [("threadq","ADT")] Rp
      }
    end with bfunction "yield"("sc", "ss", "curPc", "curSp", "newPc", "newSp") [yieldS]
      "ss" <-* "sc";;
      (* Using "curPc" as a temporary before getting to its primary use... *)
      "curPc" <-- Call "queue"!"isEmpty"("ss")
      [Al w, Al q, Al tsp, Al vs,
        PRE[V, R] [| (q %= empty) \is R |]
          * queue q (V "ss") * (V "sc" ==*> V "ss", tsp) * (V "sc" ^+ $8) =?> 2 * susps w q (V "sc")
          * ginv w (V "sc") * mallocHeap 0
          * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 tsp
        POST[_] Ex w', [| evolve w w' |] * tq w' (V "sc") * ginv w' (V "sc") * mallocHeap 0];;

      If ("curPc" = 1) {
        (* No other threads to run.  Simply returning to caller acts like a yield. *)
        Rp <- $[Sp+0];;
        IGoto* [("threadq","ADT")] Rp
      } else {
        (* Pick a thread to switch to. *)
        "curPc" <- "sc" + 8;;
        Call "queue"!"dequeue"("ss", "curPc")
        [Al w, Al q, Al tsp, Al vs, Al pc, Al sp,
          PRE[V] [| (pc, sp) %in q |] * queue (q %- (pc, sp)) (V "ss")
            * susps w (q %- (pc, sp)) (V "sc") * susp w (V "sc") pc sp
            * (V "sc" ==*> V "ss", tsp, pc, sp) * ginv w (V "sc") * mallocHeap 0
            * locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil) vs 14 tsp
          POST[_] Ex w', [| evolve w w' |] * tq w' (V "sc") * ginv w' (V "sc") * mallocHeap 0];;
        "newPc" <-* "sc" + 8;;
        "newSp" <-* "sc" + 12;;

        Assert [Al w,
          PRE[V] susp w (V "sc") (V "newPc") (V "newSp") * tq w (V "sc") * ginv w (V "sc") * mallocHeap 0
          POST[_] Ex w', [| evolve w w' |] * tq w' (V "sc") * ginv w' (V "sc") * mallocHeap 0];;

        (* Initialize the temporary stack with data we will need, then switch to using it as our stack. *)
        "curPc" <-* "sc" + 4;;
        "ss" <-* "sc";;
        "curPc" + 4 *<- "sc";;
        "curPc" + 8 *<- "ss";;
        "curPc" + 12 *<- $[Sp+0];;
        "curPc" + 16 *<- Sp;;
        "curPc" + 20 *<- "newPc";;
        "curPc" + 24 *<- "newSp";;
        Sp <- "curPc";;

        Assert* [("threadq","ADT")]
        [PREy[V] Ex w, Ex sp, Ex b, (V "sc" ==*> V "ss", sp) * (V "sc" ^+ $8) =?> 2
          * queue b (V "ss") * susps w b (V "sc") * ginv w (V "sc") * mallocHeap 0
          * susp w (V "sc") (V "newPc") (V "newSp") * susp w (V "sc") (V "curPc") (V "curSp")];;

        Note [mergeSusp];;

        (* Enqueue current thread; note that variable references below resolve in the temporary stack. *)
        Call "queue"!"enqueue"("ss", "curPc", "curSp")
        [PREy[V] Ex w, Ex b, Ex p, Ex sp, (V "sc" ==*> p, sp) * (V "sc" ^+ $8) =?> 2
          * queue b p * susps w b (V "sc") * ginv w (V "sc")
          * mallocHeap 0 * susp w (V "sc") (V "newPc") (V "newSp")];;

        (* Jump to dequeued thread. *)
        "sc" + 4 *<- Sp;;
        Rp <- "newPc";;
        Sp <- "newSp";;
        IGoto* [("threadq","ADT")] Rp
      }
    end
  }}.

Local Hint Extern 1 (@eq W _ _) => words.

Ltac t := abstract (sep hints;
  try (apply himp_star_frame; [ reflexivity | apply susps_del_fwd; assumption ]);
    eauto).

Lemma wordBound : forall w : W,
  natToW 2 <= w
  -> (wordToNat w >= 2)%nat.
  intros; pre_nomega;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity; assumption.
Qed.

Local Hint Immediate wordBound.

Hint Rewrite <- minus_n_O : sepFormula.

Transparent evalInstrs.

Theorem evalInstrs_app_fwd_None : forall stn is1 is2 st,
  evalInstrs stn st (is1 ++ is2) = None
  -> evalInstrs stn st is1 = None
  \/ exists st', evalInstrs stn st is1 = Some st' /\ evalInstrs stn st' is2 = None.
  induction is1; simpl; intuition eauto.
  destruct (evalInstr stn st a); eauto.
Qed.

Theorem evalInstrs_app_fwd_Some : forall stn is1 is2 st st',
  evalInstrs stn st (is1 ++ is2) = Some st'
  -> exists st'', evalInstrs stn st is1 = Some st'' /\ evalInstrs stn st'' is2 = Some st'.
  induction is1; simpl; intuition eauto.
  destruct (evalInstr stn st a); eauto.
  discriminate.
Qed.

Opaque evalInstrs.

Require Import Coq.Logic.Eqdep.

Hint Immediate evolve_refl.

Theorem ok : moduleOk m.
  vcgen.

  t.

  t.
  t.
  t.
  t.
  t.
  t.
  t.
  t.
  t.

  post.
  rewrite stackSize_split in H0.
  assert (NoDup ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil)) by NoDup.
  evaluate hints; descend; repeat (step hints; descend); auto.

  t.
  t.
  t.
  t.
  t.

  t.
  t.
  t.
  t.
  t.
  t.
  t.
  t.

  t.
  t.
  t.

  post.
  toFront ltac:(fun P => match P with
                           | susp' _ _ _ _ => idtac
                         end) H0.
  eapply susp_convert in H0; eauto.
  t.

  t.
  t.
  t.
  t.
  t.
  t.
  t.

  t.
  t.
  t.
  t.
  t.
  t.

  post.
  match goal with
    | [ H : context[?X - 1] |- _ ] =>
      replace X with (length ("rp" :: nil) + (X - length ("rp" :: nil))) in H
  end.
  assert (NoDup ("rp" :: nil)) by NoDup.
  evaluate hints; sep hints; auto.
  evaluate hints; simpl; omega.

  post; evaluate auto_ext.
  match goal with
    | [ H : interp _ _ |- _ ] =>
      toFront ltac:(fun P => match P with
                               | starting _ _ _ _ => idtac
                             end) H;
      apply starting_elim in H; post; descend
  end.
  toFront_conc ltac:(fun P => match P with
                                | susp' _ _ _ _ => idtac
                              end);
  apply susp'_intro; descend.
  2: instantiate (5 := locals ("rp" :: nil) x2 x1 (sel x4 "ss")); sep_auto.
  eauto.
  eapply Imply_trans; [ | apply H6 ]; clear H6.
  descend; step auto_ext.
  step auto_ext.
  eauto.
  rewrite H6; auto.
  step auto_ext.
  step auto_ext.
  sep_auto.

  t.
  sep_auto; auto.
  t.
  t.
  t.

  t.

  post.

  Transparent evalInstrs.

  Transparent evalInstrs.

  Transparent evalInstrs.

  Opaque evalInstrs.

  change (evalInstrs stn st
    ((Binop Rv (LvMem (Sp + 4)%loc) Plus 4
      :: Assign Rp (LvMem Rv)
      :: Binop Rv Rp Plus 4
      :: Assign (LvMem Rv) (LvMem (Sp + 4)%loc)
      :: Binop Rv Rp Plus 8
      :: Assign (LvMem Rv) (LvMem (Sp + 8)%loc)
      :: Binop Rv Rp Plus 12
      :: Assign (LvMem Rv) Sp
      :: Assign Sp Rp :: nil)
      ++ (Binop Rv Sp Plus 28
      :: Assign (LvMem (Rv + 4)%loc) 0
      :: Binop Rv Sp Plus 28
      :: Assign (LvMem (Rv + 8)%loc) (LvMem (Sp + 12)%loc)
      :: Binop Rv Sp Plus 28
      :: Assign (LvMem (Rv + 12)%loc) (LvMem (Sp + 8)%loc)
      :: Binop Sp Sp Plus 28 :: nil)) = None) in H0.

  apply evalInstrs_app_fwd_None in H0.
  destruct H0 as [ | [ ? [ ] ] ].
  evaluate hints.
  generalize dependent H0; evaluate hints; intro.

  change (locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil)
    (upd (upd (upd x4 "sc" (sel x0 "sc")) "ss" (sel x0 "ss")) "curPc" (Regs st Sp))
    14 x5)
    with (locals_call ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil)
      (upd (upd (upd x4 "sc" (sel x0 "sc")) "ss" (sel x0 "ss")) "curPc" (Regs st Sp))
      14 x5
      ("rp" :: "base" :: "p" :: "n" :: nil) 0 28) in H5.
  assert (ok_call ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil)
    ("rp" :: "base" :: "p" :: "n" :: nil)
    14 0 28)
  by (split; [ simpl; omega
    | split; [ simpl; omega
      | split; [ NoDup
        | reflexivity ] ] ]).
  evaluate hints.

  propxFo.
  change (evalInstrs stn x
    ((Binop Rv (LvMem (Sp + 4)%loc) Plus 4
      :: Assign Rp (LvMem Rv)
      :: Binop Rv Rp Plus 4
      :: Assign (LvMem Rv) (LvMem (Sp + 4)%loc)
      :: Binop Rv Rp Plus 8
      :: Assign (LvMem Rv) (LvMem (Sp + 8)%loc)
      :: Binop Rv Rp Plus 12
      :: Assign (LvMem Rv) Sp
      :: Assign Sp Rp :: nil)
      ++ (Binop Rv Sp Plus 28
      :: Assign (LvMem (Rv + 4)%loc) 0
      :: Binop Rv Sp Plus 28
      :: Assign (LvMem (Rv + 8)%loc) (LvMem (Sp + 12)%loc)
      :: Binop Rv Sp Plus 28
      :: Assign (LvMem (Rv + 12)%loc) (LvMem (Sp + 8)%loc)
      :: Binop Sp Sp Plus 28 :: nil)) = Some st) in H2.

  apply evalInstrs_app_fwd_Some in H2.
  destruct H2 as [ ? [ ] ].
  generalize dependent H2; evaluate hints; intro.
  change (locals ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil)
    (upd (upd (upd x5 "sc" (sel x1 "sc")) "ss" (sel x1 "ss")) "curPc" (Regs x Sp))
    14 x6)
    with (locals_call ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil)
      (upd (upd (upd x5 "sc" (sel x1 "sc")) "ss" (sel x1 "ss")) "curPc" (Regs x Sp))
      14 x6
      ("rp" :: "base" :: "p" :: "n" :: nil) 2 28) in H6.
  assert (ok_call ("rp" :: "sc" :: "ss" :: "curPc" :: "curSp" :: "newPc" :: "newSp" :: nil)
    ("rp" :: "base" :: "p" :: "n" :: nil)
    14 2 28)
  by (split; [ simpl; omega
    | split; [ simpl; omega
      | split; [ NoDup
        | reflexivity ] ] ]).
  change (locals ("rp" :: "sc" :: "ss" :: nil) x1 (wordToNat (sel x1 "ss") - 3) (Regs x Sp))
  with (locals_expose ("rp" :: "sc" :: "ss" :: nil) x1 (wordToNat (sel x1 "ss") - 3) (Regs x Sp)) in H6.
  evaluate hints.
  replace (S (S (S (wordToNat (sel x1 "ss") - 3)))) with (wordToNat (sel x1 "ss")) in H12.
  descend.
  step hints.
  step hints.
  step hints.
  unfold localsInvariantExit'; descend; step hints.
  descend; step hints.
  descend; step hints.
  generalize H9; clear.
  intros; pre_nomega.
  rewrite wordToNat_natToWord_idempotent in H9 by reflexivity; omega.

  t.
  t.
  unfold localsInvariantExit'; t.
  t.
  t.
  t.

  unfold localsInvariantExit'; post; evaluate hints.
  descend.
  step hints.
  2: step hints.
  eauto.
  step hints.
  descend; step hints.
  descend; step hints.
  apply susps_del_fwd; assumption.

  t.
  t.

  post; evaluate hints.
  match goal with
    | [ H : interp _ _ |- _ ] =>
      toFront ltac:(fun P => match P with
                               | susp _ _ _ _ => idtac
                             end) H;
      apply susp_elim in H; post
  end.
  descend.
  step auto_ext.
  match goal with
    | [ H : _ |- _ ] => eapply (Imply_sound (H _ _)); clear H; eauto
  end.
  propxFo.
  unfold labl in H7; rewrite H1 in H7; injection H7; clear H1 H7; intros; subst.
  rewrite H9 in H2; injection H2; clear H2 H9; intros; subst.
  apply (f_equal (fun f => f (stn, st))) in H.
  injection H; clear H; intros; subst.
  do 2 apply inj_pair2 in H; subst; simpl.
  change (fun x y => tq x2 (sel x7 "sc") x y) with (tq x2 (sel x7 "sc")).
  change (fun st m => subst (globalInv x2 (sel x7 "sc") st m)
    (fun x : tq_args world => tq (World x) (Pointer x) (Settings x) (Mem x)))
    with (ginv x2 (sel x7 "sc")).
  step hints.

  t.
  t.
  t.
  t.

  post.
  evaluate hints.
  descend.
  step hints.
  step hints.
  step hints.
  descend; step hints.
  instantiate (2 := x8).
  instantiate (3 := upd x2 "ss" x9).
  descend; cancel hints.
  sep hints.
  sep hints.
  sep hints; auto.

  t.
  t.
  t.

  t.
  t.

  post; evaluate hints; descend.
  step hints.
  2: step hints.
  eauto.
  step hints.
  descend; step hints.
  instantiate (2 := x3).
  instantiate (3 := upd (upd x6 "curPc" (Regs x0 Rv)) "curPc" (sel x6 "sc" ^+ $8)).
  descend; cancel hints.
  step hints.
  apply himp_star_frame; [ reflexivity | apply susps_del_fwd; assumption ].
  step hints.
  sep hints; auto.

  t.
  t.
  t.
  t.

  post; evaluate hints.
  descend.
  instantiate (1 := upd (upd (upd (upd (upd (upd x7 "sc" (sel x3 "sc")) "ss" x9) "curPc"
    (sel x3 "rp")) "curSp" (Regs x0 Sp)) "newPc" (sel x3 "newPc")) "newSp" (sel x3 "newSp")); descend.
  toFront_conc ltac:(fun P => match P with
                                | susp _ _ (sel _ "rp") _ => idtac
                              end).
  apply susp_intro; descend; eauto.
  match goal with
    | [ _ : context[locals ?ns ?v ?a (Regs ?st Sp)] |- interp specs (![?P * _] _) ] =>
      equate P (locals ns v a (Regs st Sp) * (fun x y => x2 (x, y)))%Sep
  end.
  step hints.
  step auto_ext.
  step auto_ext.
  change (fun (x11 : ST.settings) (y : smem) => tq w' (sel x3 "sc") x11 y)
    with (tq w' (sel x3 "sc")).
  change (fun (st : ST.settings) (m0 : smem) =>
    subst (globalInv w' (sel x3 "sc") st m0)
      (fun x11 : tq_args world =>
        tq (World x11) (Pointer x11) (Settings x11) (Mem x11))) with (ginv w' (sel x3 "sc")).
  step auto_ext.

  t.
  t.

  post; evaluate hints; descend.
  instantiate (3 := x3).
  step hints.
  step hints.
  step hints.
  unfold yieldInvariantCont; descend; step hints.
  instantiate (8 := x3 %+ (sel x0 "curPc", sel x0 "curSp")).
  descend; step hints.

  t.
  t.

  post; evaluate hints.
  match goal with
    | [ H : interp _ _ |- _ ] =>
      toFront ltac:(fun P => match P with
                               | susp _ _ _ _ => idtac
                             end) H;
      apply susp_elim in H; post
  end.
  descend.
  step auto_ext.
  match goal with
    | [ H : _ |- _ ] => eapply (Imply_sound (H _ _)); eauto
  end.
  unfold labl in H7; rewrite H1 in H7; injection H7; clear H1 H7; intros; subst.
  rewrite H8 in H2; injection H2; clear H2 H8; intros; subst.
  apply (f_equal (fun f => f (stn, st))) in H1.
  injection H1; clear H1; intros; subst.
  do 2 apply inj_pair2 in H1; subst; simpl.
  instantiate (1 := x3).
  change (fun x y => tq x3 (sel x2 "sc") x y) with (tq x3 (sel x2 "sc")).
  change (fun st m => subst (globalInv x3 (sel x2 "sc") st m)
    (fun x : tq_args world => tq (World x) (Pointer x) (Settings x) (Mem x)))
    with (ginv x3 (sel x2 "sc")).
  propxFo.
  step hints.
Qed.

Transparent stackSize.

End Make.


From CoreErlang.BigStep Require Import Tactics.
From CoreErlang.BigStep Require Export FunctionalBigStep.

Import ListNotations.

(**
  Equivalence between the big-step and functional big-step semantics
*)

Section Soundness.

Lemma restrict_soundness :
forall {A : Type} {env modules own_module exps a v} {id : nat} {id' eff' eff1 x x0 x1 defexp defval} {f : nat -> Environment -> (list ErlModule) -> string -> nat -> A -> SideEffectList -> ResultType},
(forall i : nat,
    i < Datatypes.length (a :: exps) ->
    exists clock : nat,
      f clock env modules own_module (nth_def (id' :: x1) id 0 i) (nth i (a :: exps) defexp)
        (nth_def (eff' :: x0) eff1 [] i) =
      Result (nth_def (id' :: x1) id 0 (S i)) (inl [nth i (v :: x) defval])
        (nth_def (eff' :: x0) eff1 [] (S i)))
->
(forall i : nat,
    i < Datatypes.length (exps) ->
    exists clock : nat,
      f clock env modules own_module (nth_def x1 id' 0 i) (nth i exps defexp)
        (nth_def x0 eff' [] i) =
      Result (nth_def x1 id' 0 (S i)) (inl [nth i x defval])
        (nth_def x0 eff' [] (S i))).
Proof.
  intros.
  assert (S i < S (length exps)) as A1.
  { simpl. lia. } pose (E := H (S i) A1).
  destruct E. simpl nth_def in H1. simpl nth in H. exists x2. simpl. exact H1.
Qed.
(*
Lemma fbs_single_list_soundness :
forall {exps vals eff ids env id eff1},
  (forall i : nat,
    i < Datatypes.length exps ->
    exists clock : nat,
      fbs_single clock env (nth_def ids id 0 i) (nth i exps ErrorExp) (nth_def eff eff1 [] i) =
      Result (nth_def ids id 0 (S i)) (inl [nth i vals ErrorValue])
        (nth_def eff eff1 [] (S i))) ->
  length exps = length vals ->
  length exps = length eff ->
  length exps = length ids
->
  exists clock, fbs_values (fbs_single clock) env id exps eff1 = Result (last ids id) (inl vals) (last eff eff1).
Proof.
  induction exps; intros.
  * apply eq_sym, length_zero_iff_nil in H0.
    apply eq_sym, length_zero_iff_nil in H1.
    apply eq_sym, length_zero_iff_nil in H2. subst.
    exists 1. simpl. auto.
  * pose (EE1 := element_exist _ _ H0).
    pose (EE2 := element_exist _ _ H1).
    pose (EE3 := element_exist _ _ H2).
    destruct EE1 as [v], EE2 as [eff'], EE3 as [id'], H3, H4, H5. subst.
    inversion H0. inversion H1. inversion H2.

    pose (P := H 0 (Nat.lt_0_succ _)). destruct P as [cl1]. simpl in H3.

    epose (P2 := IHexps _ _ _ _ _ _ (restrict_soundness H) _ _ _).
    Unshelve.
    2-4: auto.
    destruct P2 as [cl2].
    exists (cl1 + cl2).
    simpl fbs_values.
    apply bigger_clock_single with (clock' := cl1 + cl2) in H3. 2: lia.
    apply bigger_clock_list with (clock' := cl1 + cl2) in H7.
      2: lia. 2: intros; apply clock_increase_single; auto.
    rewrite H3, H7.
    rewrite last_element_equal with (def2 := id).
    rewrite last_element_equal with (def2 := eff1). auto.
Qed.

Lemma fbs_single_list_soundness_exception :
forall {exps vals eff ids env id eff1 id' ex eff' i},
(forall j : nat,
    j < i ->
    exists clock : nat,
      fbs_single clock env (nth_def ids id 0 j) (nth j exps ErrorExp) (nth_def eff eff1 [] j) =
      Result (nth_def ids id 0 (S j)) (inl [nth j vals ErrorValue])
        (nth_def eff eff1 [] (S j)))
->
(exists clock : nat,
       fbs_single clock env (last ids id) (nth i exps ErrorExp) (last eff eff1) =
       Result id' (inr ex) eff')
->
i < Datatypes.length exps ->
Datatypes.length vals = i ->
Datatypes.length eff = i ->
Datatypes.length ids = i
->
  exists clock, fbs_values (fbs_single clock) env id exps eff1 = Result id' (inr ex) eff'.
Proof.
  induction exps; intros.
  * inversion H1.
  * destruct i.
    - apply length_zero_iff_nil in H2.
      apply length_zero_iff_nil in H3.
      apply length_zero_iff_nil in H4. subst.
      destruct H0. exists x. simpl in *. rewrite H0. auto.
    - pose (P1 := element_exist _ _ (eq_sym H2)).
      pose (P2 := element_exist _ _ (eq_sym H3)).
      pose (P3 := element_exist _ _ (eq_sym H4)).
      destruct P1 as [v0']. destruct P2 as [eff0']. destruct P3 as [id0'].
      destruct H5, H6, H7. subst.
      pose (P := H 0 (Nat.lt_0_succ _)). destruct P. simpl in H5.
      simpl in H1. apply Nat.succ_lt_mono in H1.
      simpl in H2, H3, H4.
      apply eq_add_S in H2. apply eq_add_S in H3. apply eq_add_S in H4.
      rewrite <- last_element_equal, <- last_element_equal in H0.
      epose (P2 := IHexps _ _ _ _ _ _ _ _ _ _ _ H0 H1 H2 H3 H4).
      destruct P2. exists (x2 + x3).
      simpl.
      apply bigger_clock_single with (clock' := x2 + x3) in H5.
      apply bigger_clock_list with (clock' := x2 + x3) in H6.
      rewrite H5, H6. auto.
      1, 3: lia.
      intros. apply clock_increase_single. auto.
  Unshelve.
  intros. epose (H (S j) _). exact e.
  Unshelve.
  lia.
Qed.
 *)
Lemma fbs_expr_list_soundness :
forall {exps : list Expression} {vals eff ids env modules own_module id eff1},
(forall i : nat,
    i < Datatypes.length exps ->
    exists clock : nat,
      fbs_expr clock env modules own_module (nth_def ids id 0 i) (nth i exps ErrorExp) (nth_def eff eff1 [] i) =
      Result (nth_def ids id 0 (S i)) (inl [nth i vals ErrorValue])
        (nth_def eff eff1 [] (S i))) ->
  length exps = length vals ->
  length exps = length eff ->
  length exps = length ids
->
  exists clock, fbs_values (fbs_expr clock) env modules own_module id exps eff1 = Result (last ids id) (inl vals) (last eff eff1).
Proof.
  induction exps; intros.
  * apply eq_sym, length_zero_iff_nil in H0.
    apply eq_sym, length_zero_iff_nil in H1.
    apply eq_sym, length_zero_iff_nil in H2. subst.
    exists 1. simpl. auto.
  * pose (EE1 := element_exist _ _ H0).
    pose (EE2 := element_exist _ _ H1).
    pose (EE3 := element_exist _ _ H2).
    destruct EE1 as [v], EE2 as [eff'], EE3 as [id'], H3, H4, H5. subst.
    inversion H0. inversion H1. inversion H2.

    pose (P := H 0 (Nat.lt_0_succ _)). destruct P as [cl1]. simpl in H3.

    epose (P2 := IHexps _ _ _ _ _ _ _ _ (restrict_soundness H) _ _ _).
    Unshelve.
    2-4: auto.
    destruct P2 as [cl2].
    exists (cl1 + cl2).
    simpl fbs_values.
    apply bigger_clock_expr with (clock' := cl1 + cl2) in H3. 2: lia.
    apply bigger_clock_list with (clock' := cl1 + cl2) in H7.
      2: lia. 2: intros; apply clock_increase_expr; auto.
    rewrite H3, H7.
    rewrite last_element_equal with (def2 := id).
    rewrite last_element_equal with (def2 := eff1). auto.
Qed.

Lemma fbs_expr_list_soundness_exception :
forall {exps : list Expression} {vals eff ids env modules own_module id eff1 id' ex eff' i},
(forall j : nat,
    j < i ->
    exists clock : nat,
      fbs_expr clock env modules own_module (nth_def ids id 0 j) (nth j exps ErrorExp) (nth_def eff eff1 [] j) =
      Result (nth_def ids id 0 (S j)) (inl [nth j vals ErrorValue])
        (nth_def eff eff1 [] (S j)))
->
(exists clock : nat,
       fbs_expr clock env modules own_module (last ids id) (nth i exps ErrorExp) (last eff eff1) =
       Result id' (inr ex) eff')
->
i < Datatypes.length exps ->
Datatypes.length vals = i ->
Datatypes.length eff = i ->
Datatypes.length ids = i
->
  exists clock, fbs_values (fbs_expr clock) env modules own_module id exps eff1 = Result id' (inr ex) eff'.
Proof.
  induction exps; intros.
  * inversion H1.
  * destruct i.
    - apply length_zero_iff_nil in H2.
      apply length_zero_iff_nil in H3.
      apply length_zero_iff_nil in H4. subst.
      destruct H0. exists x. simpl in *. rewrite H0. auto.
    - pose (P1 := element_exist _ _ (eq_sym H2)).
      pose (P2 := element_exist _ _ (eq_sym H3)).
      pose (P3 := element_exist _ _ (eq_sym H4)).
      destruct P1 as [v0']. destruct P2 as [eff0']. destruct P3 as [id0'].
      destruct H5, H6, H7. subst.
      pose (P := H 0 (Nat.lt_0_succ _)). destruct P. simpl in H5.
      simpl in H1. apply Nat.succ_lt_mono in H1.
      simpl in H2, H3, H4.
      apply eq_add_S in H2. apply eq_add_S in H3. apply eq_add_S in H4.
      rewrite <- last_element_equal, <- last_element_equal in H0.
      epose (P2 := IHexps _ _ _ _ _ _ _ _ _ _ _ _ _ H0 H1 H2 H3 H4).
      destruct P2. exists (x2 + x3).
      simpl.
      apply bigger_clock_expr with (clock' := x2 + x3) in H5.
      apply bigger_clock_list with (clock' := x2 + x3) in H6.
      rewrite H5, H6. auto.
      1, 3: lia.
      intros. apply clock_increase_expr. auto.
  Unshelve.
  intros. epose (H (S j) _). exact e.
  Unshelve.
  lia.
Qed.

Lemma fbs_case_soundness :
forall {l id' eff2 id'' res eff3 vals env modules own_module i guard exp bindings},
(forall j : nat,
     j < i ->
     forall (gg ee : Expression) (bb : list (Var * Value)),
     match_clause vals l j = Some (gg, ee, bb) ->
     exists clock : nat,
       fbs_expr clock (add_bindings bb env) modules own_module id' gg eff2 = Result id' (inl [ffalse]) eff2) ->
match_clause vals l i = Some (guard, exp, bindings) ->
(exists clock : nat,
       fbs_expr clock (add_bindings bindings env) modules  own_module id' guard eff2 =
       Result id' (inl [ttrue]) eff2) ->
(exists clock : nat,
       fbs_expr clock (add_bindings bindings env) modules own_module id' exp eff2 = Result id'' res eff3) ->
exists clock, fbs_case l env modules own_module id' eff2 vals (fbs_expr clock) = Result id'' res eff3.
Proof.
  induction l; intros.
  * inversion H0.
  * destruct i.
    - simpl in H0. destruct H1, H2. exists (x + x0).
      destruct a, p. simpl. destruct (match_valuelist_to_patternlist vals l0).
      + inversion H0. subst.
        apply bigger_clock_expr with (clock' := x + x0) in H1. rewrite H1.
        unfold ttrue. rewrite eqb_refl, Nat.eqb_refl, list_eqb_refl.
        simpl.
        apply bigger_clock_expr with (clock' := x + x0) in H2. rewrite H2. auto.
        1,3: lia. apply effect_eqb_refl.
      + congruence.
    - simpl. destruct a, p.
      case_eq (match_clause vals ((l0, e0, e) :: l) 0); intros.
       + destruct p, p.
         pose (H 0 (Nat.lt_0_succ _) _ _ _ H3). simpl in H3. destruct e3.
         destruct (match_valuelist_to_patternlist vals l0). 2: congruence.
         inversion H3. subst.
         epose (IHl id' eff2 id'' res eff3 vals env modules own_module i guard exp bindings _ _ _ _).
         destruct e. exists (x + x0).
         apply bigger_clock_expr with (clock' := x + x0) in H4.
         apply bigger_clock_case with (clock' := x + x0) in H5.
         rewrite H4. unfold ffalse. simpl.
         replace (((id' =? id') && list_eqb effect_eqb eff2 eff2)%bool) with true.
         2: { symmetry. apply andb_true_intro. rewrite Nat.eqb_refl. rewrite effect_list_eqb_refl. auto. }
         apply H5.

         Unshelve.
         all: try lia.
         ** intros. eapply H with (j := S j). lia.
            simpl. exact H6.
         ** exact H0.
         ** auto.
         ** auto.
       + simpl in H3. simpl.
         destruct (match_valuelist_to_patternlist vals l0). 1: congruence.
         epose (IHl id' eff2 id'' res eff3 vals env modules own_module i guard exp bindings _ _ _ _).
         destruct e1. destruct H2. exists (x + x0).
         apply bigger_clock_expr with (clock' := x + x0) in H2.
         apply bigger_clock_case with (clock' := x + x0) in H4.
         rewrite H4. unfold ffalse. simpl. auto.
         all: lia.
         Unshelve.
         ** intros. eapply H with (j := S j). lia.
            simpl. exact H5.
         ** exact H0.
         ** auto.
         ** auto.
Qed.

Theorem fbs_case_if_clause_sound :
forall {l env modules own_module eff2 id' vals},
(forall j : nat,
     j < Datatypes.length l ->
     forall (gg ee : Expression) (bb : list (Var * Value)),
     match_clause vals l j = Some (gg, ee, bb) ->
     exists clock : nat,
       fbs_expr clock (add_bindings bb env) modules own_module id' gg eff2 = Result id' (inl [ffalse]) eff2)
->
exists clock, fbs_case l env modules own_module id' eff2 vals (fbs_expr clock) = Result id' (inr if_clause) eff2.
Proof.
  induction l; intros.
  * exists 0. auto.
  * destruct a, p.
    case_eq (match_clause vals ((l0, e0, e) :: l) 0); intros.
    - destruct p, p.
      pose (P := H 0 (Nat.lt_0_succ _) _ _ _ H0).
      simpl in H0.
      assert (exists clock : nat,
            fbs_expr clock (add_bindings l1 env) modules own_module id' e1 eff2 = Result id' (inl [ffalse]) eff2).
      { auto. } clear P. simpl.
      destruct (match_valuelist_to_patternlist vals l0). 2: congruence.
      inversion H0. subst. destruct H1.
      epose (IHl env modules own_module eff2 id' vals _). destruct e.
      exists (x + x0).
      apply bigger_clock_expr with (clock' := x + x0) in H1.
      apply bigger_clock_case with (clock' := x + x0) in H2.
      rewrite H1, H2.
      replace (((id' =? id') && list_eqb effect_eqb eff2 eff2)%bool) with true.
      2: { symmetry. apply andb_true_intro. rewrite Nat.eqb_refl. rewrite effect_list_eqb_refl. auto. }
      simpl. auto.
      all: lia.
      Unshelve.
      + intros. eapply H with (j := S j). simpl. lia. simpl. exact H3.
    - simpl.
      simpl in H0. destruct (match_valuelist_to_patternlist vals l0). 1: congruence.
      epose (IHl env modules own_module eff2 id' vals _). destruct e1.
      exists x. rewrite H1. auto.
      Unshelve.
      + intros. eapply H with (j := S j). simpl. lia. simpl. exact H2.
Qed.

Theorem fbs_soundness :
(forall env modules own_module id exp eff id' res eff',
  | env, modules, own_module, id, exp, eff| -e> | id', res, eff' |
  ->
  exists clock, fbs_expr clock env modules own_module id exp eff = Result id' res eff'
  )(*
/\
(forall env id exp eff id' res eff',
  | env, id, exp, eff| -s> | id', res, eff' |
  ->
  exists clock, fbs_single clock env id exp eff = Result id' res eff')*) .
Proof.
  intros. induction H.
  * pose (P := fbs_expr_list_soundness H3 H H0 H1). destruct P.
    exists (S x). simpl. rewrite H4, H5. auto.
  * pose (P := fbs_expr_list_soundness_exception H4 IHeval_expr H H0 H1 H2). destruct P.
    exists (S x). simpl. auto.
  * exists 1. auto.
  * exists 1. auto.
  * exists 1. simpl. rewrite H. auto.
  * exists 1. simpl. rewrite H. auto.
  * exists 1. simpl. rewrite H,  H0, H1, H2. auto.
  * exists 1. auto.
  * pose (P := fbs_expr_list_soundness H3 H H0 H1). destruct P.
    exists (S x). simpl. rewrite H4, H5, H6. auto.
  * destruct IHeval_expr1 as [cl1], IHeval_expr2 as [cl2].
    exists (S (cl1 + cl2)). simpl.
    apply bigger_clock_expr with (clock' := cl1 + cl2) in H1.
    apply bigger_clock_expr with (clock' := cl1 + cl2) in H2.
    rewrite H1, H2. 2-3: lia. auto.
  * destruct IHeval_expr1. pose (P := fbs_case_soundness H3 H1 IHeval_expr2 IHeval_expr3). destruct P.
    exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H6.
    apply bigger_clock_case with (clock' := x + x0) in H7.
    rewrite H6. assumption.
    all: lia.
  * destruct IHeval_expr1. destruct IHeval_expr2.
     epose (P := fbs_expr_list_soundness H5 _ _ _).
    Unshelve. 2-4: auto.
    destruct P.  exists (S (x + x0 + x1)). simpl.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H9.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H10.
    apply bigger_clock_list with (clock' := x + x0 + x1) in H11.
    rewrite H9. rewrite H10. rewrite H11. rewrite H6.
    rewrite H7 at 1. rewrite H7 at 1. simpl. rewrite H8. reflexivity.
    2: intros; apply clock_increase_expr; auto.
    all: lia.
  * destruct IHeval_expr1. destruct IHeval_expr2. destruct IHeval_expr3.
      epose (P := fbs_expr_list_soundness H5 _ _ _).
    Unshelve. 2-4: auto.
    destruct P.  exists (S (x + x0 + x1 + x2)). simpl.

    apply bigger_clock_expr with (clock' := x + x0 + x1 + x2) in H8.
    apply bigger_clock_expr with (clock' := x + x0 + x1 + x2) in H9.
    apply bigger_clock_expr with (clock' := x + x0 + x1 + x2) in H10.
    apply bigger_clock_list with (clock' := x + x0 + x1 + x2) in H11.
    rewrite H8. rewrite H9. rewrite H11.  rewrite H6.  auto.
    2: intros; apply clock_increase_expr; auto.
    all: lia.
  * epose (P := fbs_expr_list_soundness H3 _ _ _).
    Unshelve. 2-4: auto.
    destruct P. exists (S x). simpl. rewrite H6.
    rewrite H4 at 1. rewrite H4 at 1. rewrite <- H5. simpl. auto.
  * destruct IHeval_expr1, IHeval_expr2.
    epose (P := fbs_expr_list_soundness H5 _ _ _).
    Unshelve. 2-4: auto.
    destruct P. exists (S (x + x0 + x1)). simpl.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H7.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H8.
    apply bigger_clock_list with (clock' := x + x0 + x1) in H9.
    rewrite H7. rewrite H9.
    apply Nat.eqb_eq in H1. rewrite H1. auto.
    2: intros; apply clock_increase_expr; auto.
    all: lia.
  * destruct IHeval_expr1, IHeval_expr2. exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H2.
    apply bigger_clock_expr with (clock' := x + x0) in H3.
    rewrite H2, H3. apply eq_sym, Nat.eqb_eq in H0. rewrite H0. auto.
    all: lia.
  * destruct IHeval_expr1, IHeval_expr2. exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H1.
    apply bigger_clock_expr with (clock' := x + x0) in H2.
    rewrite H1, H2. auto.
    all: lia.
  * destruct IHeval_expr. exists (S x). simpl. auto.
  * epose (P := fbs_expr_list_soundness H4 _ _ _). destruct P. exists (S x).
    simpl. unfold exps, vals in H9. rewrite H9.
    rewrite make_map_consistent. rewrite H5. simpl. rewrite H7, H8. rewrite H6. auto.
    lia.
  * destruct IHeval_expr. exists (S x). simpl. rewrite H0. auto.
  * destruct IHeval_expr1, IHeval_expr2. exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H1.
    apply bigger_clock_expr with (clock' := x + x0) in H2.
    rewrite H1, H2. auto.
    all: lia.
  * epose (P := fbs_expr_list_soundness_exception H4 IHeval_expr _ _ _ _).
    destruct P. exists (S x). simpl. rewrite H6. auto.
  * destruct IHeval_expr1, IHeval_expr2. exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H2.
    apply bigger_clock_expr with (clock' := x + x0) in H3.
    rewrite H2, H3. apply eq_sym, Nat.eqb_eq in H0. rewrite H0. auto.
    all: lia.
  * destruct IHeval_expr1, IHeval_expr2. exists (S (x + x0)). simpl. simpl in H2.
    apply bigger_clock_expr with (clock' := x + x0) in H1.
    apply bigger_clock_expr with (clock' := x + x0) in H2.
    rewrite H1, H2. auto.
    all: lia.
  * destruct IHeval_expr. exists (S x). simpl. rewrite H0. auto.
  * destruct IHeval_expr. pose (P := fbs_case_if_clause_sound H1).
    destruct P. exists (S (x + x0)).
    apply bigger_clock_expr with (clock' := x + x0) in H2.
    apply bigger_clock_case with (clock' := x + x0) in H3.
    simpl. rewrite H2, H3. auto. all: lia.
  * destruct IHeval_expr1. destruct IHeval_expr2.
    epose (P := fbs_expr_list_soundness_exception H6 IHeval_expr3 _ _ _ _).
    destruct P. exists (S x + x0 + x1). simpl.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H8.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H9.
    apply bigger_clock_list with (clock' := x + x0 + x1) in H10.
    rewrite H8, H9, H10. reflexivity.
    2: intros; apply clock_increase_expr; auto.
    all: lia.

  * destruct IHeval_expr. exists (S x). simpl. rewrite H0. auto.
  * destruct IHeval_expr1. destruct IHeval_expr2.
    exists (S (x + x0)).
    apply bigger_clock_expr with (clock' := x + x0) in H1.
    apply bigger_clock_expr with (clock' := x + x0) in H2.
    simpl. rewrite H1. rewrite H2. auto. all: lia.
  * destruct IHeval_expr1. destruct IHeval_expr2.
    epose (P := fbs_expr_list_soundness H5 _ _ _). destruct P.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H9.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H10.
    apply bigger_clock_list with (clock' := x + x0 + x1) in H11.
    exists (S (x + x0 + x1)).
    simpl. rewrite H9. rewrite H10. rewrite H11. subst.
    2,4,5: lia.
    - destruct v. 1,3,4,5,6: auto.
      destruct l.
      -- congruence.
      -- auto.
    - intros. apply clock_increase_expr. auto.

  * destruct IHeval_expr1. destruct IHeval_expr2.
    epose (P := fbs_expr_list_soundness H5 _ _ _). destruct P.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H9.
    apply bigger_clock_expr with (clock' := x + x0 + x1) in H10.
    apply bigger_clock_list with (clock' := x + x0 + x1) in H11.
    exists (S (x + x0 + x1)).
    simpl. rewrite H9. rewrite H10. rewrite H11. subst.
    2,4,5: lia.
    - destruct v'. 1,3,4,5,6: auto.
      destruct l.
      -- congruence.
      -- auto.
    - intros. apply clock_increase_expr. auto.

  * epose (P := fbs_expr_list_soundness_exception H4 IHeval_expr _ _ _ _).
    destruct P. exists (S x). simpl. rewrite H6. auto.
  * destruct IHeval_expr. exists (S x). simpl. rewrite H0. auto.
  * destruct IHeval_expr1.
    epose (P := fbs_expr_list_soundness_exception H5 IHeval_expr2 _ _ _ _).
    destruct P. exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H7.
    apply bigger_clock_list with (clock' := x + x0) in H8.
    rewrite H7, H8. auto.
    1,3: lia. intros. apply clock_increase_expr. auto.
  * destruct IHeval_expr.
    epose (P := fbs_expr_list_soundness H4 _ _ _). destruct P.
    exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H8.
    apply bigger_clock_list with (clock' := x + x0) in H9.
    rewrite H8, H9. destruct v; try congruence.
    1-5: rewrite H6, H7; auto.
    1,3: lia.
    intros. apply clock_increase_expr. auto.
  * destruct IHeval_expr.
    epose (P := fbs_expr_list_soundness H4 _ _ _). destruct P.
    exists (S (x + x0)). simpl.
    apply bigger_clock_expr with (clock' := x + x0) in H8.
    apply bigger_clock_list with (clock' := x + x0) in H9.
    rewrite H8, H9.
    apply Nat.eqb_neq in H5. rewrite H5. rewrite H6, H7. auto.
    1,3: lia.
    intros. apply clock_increase_expr. auto.
  * destruct IHeval_expr. exists (S x). simpl. rewrite H0. auto.
  * destruct IHeval_expr. exists (S x). simpl. rewrite H0. auto.
  * epose (P := fbs_expr_list_soundness_exception H5 IHeval_expr _ _ _ _).
    destruct P. exists (S x). simpl. unfold exps in H7.
    rewrite H7. auto.
  Unshelve.
  all: auto.
  - unfold exps, vals. rewrite length_make_map_exps, length_make_map_vals. lia. lia.
  - unfold exps. rewrite length_make_map_exps. auto.
  - unfold exps. rewrite length_make_map_exps. auto.
  - unfold exps. rewrite length_make_map_exps. lia.
  - unfold vals. case_eq (modulo_2 (i)); intros.
    + rewrite e in H1. rewrite length_make_map_vals.
      pose (n_div_2_mod_0 _ e). rewrite e0. lia. lia.
    + rewrite e in H1. rewrite length_make_map_vals2.
      pose (n_div_2_mod_1 _ e). rewrite e0. lia. lia.
Qed.

End Soundness.

Section Correctness.

Lemma list_expr_correct :
forall {l env modules own_module id eff id' vl eff' clock},
fbs_values (fbs_expr clock) env own_module modules id l eff = Result id' (inl vl) eff'
->
(
exists idl effl,
  length l = length vl /\
  length l = length idl /\
  length l = length effl /\
  eff' = last effl eff /\
  id' = last idl id /\
  (forall i, i < length l ->
    fbs_expr clock env own_module modules (nth_def idl id 0 i) (nth i l ErrorExp) (nth_def effl eff [] i) =
      Result (nth_def idl id 0 (S i)) (inl [nth i vl ErrorValue]) (nth_def effl eff [] (S i))
  )
)
.
Proof.
  induction l; intros.
  * inversion H. subst. exists []. exists [].
    repeat (split; auto).
    intros. inversion H0.
  * simpl in H.
    case_eq (fbs_expr clock env own_module modules id a eff); intros. destruct res.
    - rewrite H0 in H.
      destruct v. congruence. destruct v0. 2: congruence.
      case_eq (fbs_values (fbs_expr clock) env own_module modules id0 l eff0); intros. destruct res.
         + rewrite H1 in H. inversion H. subst.
           pose (IHl _ _ _ _ _ _ _ _ _ H1). inversion e. inversion H2.
           destruct H3, H4, H5, H6, H7.
           exists (id0 :: x). exists (eff0 :: x0).
           split. 2: split. 3: split. 4: split. 5: split.
           1-3 : simpl; lia.
           ** rewrite last_element_equal with (def2 := eff) in H6. auto.
           ** rewrite last_element_equal with (def2 := id) in H7. auto.
           ** intros. destruct i.
             -- simpl. assumption.
             -- simpl in H9.
                (* setoid failure for simple rewrite *)
                assert (i < length l). { lia. }
                apply H8. assumption.
         + rewrite H1 in H. discriminate.
         + rewrite H1 in H. discriminate.
         + rewrite H1 in H. discriminate.
    - rewrite H0 in H. discriminate.
    - rewrite H0 in H. discriminate.
    - rewrite H0 in H. discriminate.
Qed.

Lemma list_expr_exception_correct :
forall {l : list Expression} {env modules own_module id eff id' ex eff' clock},
fbs_values (fbs_expr clock) env modules own_module id l eff = Result id' (inr ex) eff'
->
(
exists vals idl effl,
  length vals < length l /\
  length vals = length idl /\
  length vals = length effl /\
  (forall i, i < length vals ->
    fbs_expr clock env modules own_module (nth_def idl id 0 i) (nth i l ErrorExp) (nth_def effl eff [] i) =
      Result (nth_def idl id 0 (S i)) (inl [nth i vals ErrorValue]) (nth_def effl eff [] (S i))
  ) /\
  fbs_expr clock env modules own_module (last idl id) (nth (length vals) l ErrorExp) (last effl eff) = Result id' (inr ex) eff'
)
.
Proof.
  induction l; intros.
  * inversion H.
  * simpl in H.
    case_eq (fbs_expr clock env modules own_module id a eff); intros. destruct res.
    - rewrite H0 in H. destruct v. congruence. destruct v0. 2: congruence.
      case_eq (fbs_values (fbs_expr clock) env modules own_module id0 l eff0); intros. destruct res.
         + rewrite H1 in H. inversion H.
         + rewrite H1 in H. inversion H. subst.
           pose (IHl env modules own_module id0 eff0 id' ex eff' clock H1).
           destruct e. destruct H2, H2.
           destruct H2, H3, H4, H5.
           exists (v::x). exists (id0::x0). exists (eff0::x1).
           split. 2: split. 3: split. 4: split.
           all: try (simpl; lia).
           ** intros. destruct i.
             -- simpl. assumption.
             -- apply H5. simpl in H7. lia.
           ** rewrite last_element_equal with (def2 := id) in H6.
              rewrite last_element_equal with (def2 := eff) in H6.
              assumption.
         + rewrite H1 in H. congruence.
         + rewrite H1 in H. congruence.
    - rewrite H0 in H. inversion H. subst.
      exists []. exists []. exists [].
      split. 2: split. 3: split. 4: split.
      all: auto.
      + simpl. lia.
      + intros. inversion H1.
    - rewrite H0 in H. discriminate.
    - rewrite H0 in H. discriminate.
Qed.
(*
Lemma list_single_correct :
forall {l env id eff id' vl eff' clock},
fbs_values (fbs_single clock) env id l eff = Result id' (inl vl) eff'
->
(
exists idl effl,
  length l = length vl /\
  length l = length idl /\
  length l = length effl /\
  eff' = last effl eff /\
  id' = last idl id /\
  (forall i, i < length l ->
    fbs_single clock env (nth_def idl id 0 i) (nth i l ErrorExp) (nth_def effl eff [] i) =
      Result (nth_def idl id 0 (S i)) (inl [nth i vl ErrorValue]) (nth_def effl eff [] (S i))
  )
)
.
Proof.
  induction l; intros.
  * inversion H. subst. exists []. exists [].
    repeat (split; auto).
    intros. inversion H0.
  * simpl in H.
    case_eq (fbs_single clock env id a eff); intros. destruct res.
    - rewrite H0 in H.
      destruct v. congruence. destruct v0. 2: congruence.
      case_eq (fbs_values (fbs_single clock) env id0 l eff0); intros. destruct res.
         + rewrite H1 in H. inversion H. subst.
           pose (IHl _ _ _ _ _ _ _ H1). inversion e. inversion H2.
           destruct H3, H4, H5, H6, H7.
           exists (id0 :: x). exists (eff0 :: x0).
           split. 2: split. 3: split. 4: split. 5: split.
           1-3 : simpl; lia.
           ** rewrite last_element_equal with (def2 := eff) in H6. auto.
           ** rewrite last_element_equal with (def2 := id) in H7. auto.
           ** intros. destruct i.
             -- simpl. assumption.
             -- simpl in H9.
                (* setoid failure for simple rewrite *)
                assert (i < length l). { lia. }
                apply H8. assumption.
         + rewrite H1 in H. discriminate.
         + rewrite H1 in H. discriminate.
         + rewrite H1 in H. discriminate.
    - rewrite H0 in H. discriminate.
    - rewrite H0 in H. discriminate.
    - rewrite H0 in H. discriminate.
Qed. *)

Lemma case_correctness l env modules own_module id0 eff0 v clock id' res eff' :
  fbs_case l env modules own_module id0 eff0 v  (fbs_expr clock) = Result id' res eff'
->
  (exists i guard exp bindings, i < length l /\
    match_clause v l i = Some (guard, exp, bindings) /\
    (forall j : nat, j < i ->
      (forall gg ee bb, match_clause v l j = Some (gg, ee, bb) ->
        (fbs_expr clock (add_bindings bb env) modules own_module id0 gg eff0 = Result id0 (inl [ffalse]) eff0 )
      )

    ) /\
    fbs_expr clock (add_bindings bindings env) modules own_module id0 guard eff0 = Result id0 (inl [ttrue]) eff0 /\
    fbs_expr clock (add_bindings bindings env) modules own_module id0 exp eff0 = Result id' res eff')
\/
  ((forall j : nat, j < length l ->
      (forall gg ee bb, match_clause v l j = Some (gg, ee, bb) ->
        (fbs_expr clock (add_bindings bb env) modules own_module id0 gg eff0 = Result id0 (inl [ffalse]) eff0 )))
  /\
  res = inr if_clause /\ id' = id0 /\ eff' = eff0
  )
.
Proof.
  induction l; intros.
  * simpl in H. inversion H. subst.
    right. split. 2: auto. intros. inversion H0.
  * simpl in H. destruct a, p.
    case_eq (match_valuelist_to_patternlist v l0); intros; rewrite H0 in H.
    - case_eq (fbs_expr clock (add_bindings (match_valuelist_bind_patternlist v l0) env)
        modules own_module id0 e0 eff0); intros; rewrite H1 in H.
      + destruct res0. 2: congruence. destruct v0. congruence. destruct v1. 2: congruence.
        case_eq (((id =? id0) && list_eqb effect_eqb eff0 eff)%bool); intros; rewrite H2 in H. 2: congruence.
        destruct v0; try congruence.
        destruct l1; try congruence.
        case_eq ((s =? "true")%string); intros; rewrite H3 in H.
        ** rewrite eqb_eq in H3. apply eq_sym, Bool.andb_true_eq in H2. destruct H2.
           symmetry in H2, H4. rewrite Nat.eqb_eq in H2.
           apply effect_list_eqb_eq in H4. subst.
           left. exists 0, e0, e, (match_valuelist_bind_patternlist v l0).
           split. 2: split. 3: split. 4: split.
           -- simpl. lia.
           -- simpl. rewrite H0. auto.
           -- intros. inversion H2.
           -- auto.
           -- auto.
        ** case_eq ((s =? "false")%string); intros; rewrite H4 in H. 2: congruence.
           rewrite eqb_eq in H4. subst.
           pose (P := IHl H). destruct P.
           -- destruct H4, H4, H4, H4, H4, H5, H6, H7.
              left. exists (S x), x0, x1, x2.
              split. 2: split. 3: split. 4: split.
              all: auto.
              ++ simpl. lia.
              ++ intros. destruct j.
                 *** subst. simpl in H10. rewrite H0 in H10. inversion H10. subst.
                     unfold ffalse.
                     apply eq_sym, Bool.andb_true_eq in H2. destruct H2.
                     symmetry in H2, H11. rewrite Nat.eqb_eq in H2.
                     apply effect_list_eqb_eq in H11. subst. exact H1.
                 *** apply Nat.succ_lt_mono in H9.
                     simpl in H10.
                     pose (P := H6 j H9 _ _ _ H10). auto.
          -- right. destruct H4, H5, H6. subst. split. 2: split. 3: split.
             all: auto.
             ++ intros. destruct j.
                *** subst. simpl in H6. rewrite H0 in H6. inversion H6. subst.
                    apply eq_sym, Bool.andb_true_eq in H2. destruct H2.
                    symmetry in H2, H7. rewrite Nat.eqb_eq in H2.
                    apply effect_list_eqb_eq in H7. subst. exact H1.
                *** simpl in H5. apply Nat.succ_lt_mono in H5.
                     simpl in H6.
                     pose (P := H4 j H5 _ _ _ H6). auto.
      + congruence.
      + congruence.
    - pose (P := IHl H). destruct P.
      + destruct H1, H1, H1, H1, H1, H2, H3, H4.
        left. exists (S x), x0, x1, x2.
        split. 2: split. 3: split. 4: split.
        all: auto.
        ** simpl. lia.
        ** intros. destruct j.
           -- subst. simpl in H7. rewrite H0 in H7. congruence.
           -- apply Nat.succ_lt_mono in H6.
              simpl in H7.
              pose (P := H3 j H6 _ _ _ H7). auto.
     + right. destruct H1, H2, H3. subst. split. 2: split. 3: split.
       all: auto.
       ** intros. destruct j.
          -- subst. simpl in H3. rewrite H0 in H3. congruence.
          -- simpl in H2. apply Nat.succ_lt_mono in H2.
             simpl in H3.
             pose (P := H1 j H2 _ _ _ H3). auto.
Qed.
(*
Lemma list_single_exception_correct :
forall {l : list SingleExpression} {env id eff id' ex eff' clock},
fbs_values (fbs_single clock) env id l eff = Result id' (inr ex) eff'
->
(
exists vals idl effl,
  length vals < length l /\
  length vals = length idl /\
  length vals = length effl /\
  (forall i, i < length vals ->
    fbs_single clock env (nth_def idl id 0 i) (nth i l ErrorExp) (nth_def effl eff [] i) =
      Result (nth_def idl id 0 (S i)) (inl [nth i vals ErrorValue]) (nth_def effl eff [] (S i))
  ) /\
  fbs_single clock env (last idl id) (nth (length vals) l ErrorExp) (last effl eff) = Result id' (inr ex) eff'
)
.
Proof.
  induction l; intros.
  * inversion H.
  * simpl in H.
    case_eq (fbs_single clock env id a eff); intros. destruct res.
    - rewrite H0 in H. destruct v. congruence. destruct v0. 2: congruence.
      case_eq (fbs_values (fbs_single clock) env id0 l eff0); intros. destruct res.
         + rewrite H1 in H. inversion H.
         + rewrite H1 in H. inversion H. subst.
           pose (IHl env id0 eff0 id' ex eff' clock H1).
           destruct e. destruct H2, H2.
           destruct H2, H3, H4, H5.
           exists (v::x). exists (id0::x0). exists (eff0::x1).
           split. 2: split. 3: split. 4: split.
           all: try (simpl; lia).
           ** intros. destruct i.
             -- simpl. assumption.
             -- apply H5. simpl in H7. lia.
           ** rewrite last_element_equal with (def2 := id) in H6.
              rewrite last_element_equal with (def2 := eff) in H6.
              assumption.
         + rewrite H1 in H. congruence.
         + rewrite H1 in H. congruence.
    - rewrite H0 in H. inversion H. subst.
      exists []. exists []. exists [].
      split. 2: split. 3: split. 4: split.
      all: auto.
      + simpl. lia.
      + intros. inversion H1.
    - rewrite H0 in H. discriminate.
    - rewrite H0 in H. discriminate.
Qed. *)

Theorem fbs_expr_correctness :
(forall clock {env modules own_module id exp eff id' res eff'},
  fbs_expr clock env modules own_module id exp eff = Result id' res eff'
 ->
  | env, modules, own_module, id, exp, eff| -e> | id', res, eff' |)
(* with fbs_single_correctness :
(forall clock {env id exp eff id' res eff'},
  fbs_single clock env [] id exp eff = Result id' res eff'
 ->
  | env, id, exp, eff| -s> | id', res, eff' |) *).
Proof.
  induction clock; intros.
  * inversion H.
  * destruct exp; simpl in H.
    - destruct res.
      + apply list_expr_correct in H.  destruct H, H, H, H0, H1, H2, H3.
      (* CONTINUE *)
        eapply eval_values with (vals := v) (eff := x0) (ids := x); auto. (* intros.
        eapply IHclock in H4. exact H4. exact H5. *)
      + apply list_expr_exception_correct in H. destruct H, H, H, H, H0, H1, H2.
        eapply eval_values_ex with (vals := x) (eff := x1) (ids := x0); auto. auto.
        (*intros. eapply IHclock in H2. exact H2. exact H4. eapply IHclock in H3. exact H3. *)
    - inversion H. apply eval_nil.
    - inversion H. apply eval_lit.
    - case_eq (get_value env (inl v)); intros; rewrite H0 in H.
      2: congruence. inversion H. apply eval_var. auto.
    - case_eq (get_value env (inr f)).
      + intros. rewrite H0 in H.
        inversion H. apply eval_funid. auto.
      + intros. rewrite H0 in H. destruct get_own_modfunc eqn:MOD.
        ++ inversion H. eapply eval_funid_module. all: auto. exact MOD.
        ++ congruence.
    - inversion H. apply eval_fun.
    - case_eq (fbs_expr clock env modules own_module id exp2 eff); intros; rewrite H0 in H.
      destruct res0. destruct v. congruence. destruct v0. 2: congruence.
      + apply IHclock in H0.
        case_eq (fbs_expr clock env modules own_module id0 exp1 eff0); intros; rewrite H1 in H.
        destruct res0. destruct v0. congruence. destruct v1. 2: congruence.
        ** apply IHclock in H1. inversion H. subst.
           eapply eval_cons. exact H0. exact H1.
        ** apply IHclock in H1. inversion H. subst.
           eapply eval_cons_hd_ex. exact H0. exact H1.
        ** congruence.
        ** congruence.
      + eapply IHclock in H0. inversion H. subst.
        eapply eval_cons_tl_ex. exact H0.
      + congruence.
      + congruence.
    - case_eq (fbs_values (fbs_expr clock) env modules own_module id l eff); intros; rewrite H0 in H.
      destruct res0.
      + apply list_expr_correct in H0. destruct H0, H0, H0, H1, H2, H3, H4.
        inversion H. subst.
        eapply eval_tuple with (vals := v) (eff := x0) (ids := x); auto.
        (*intros. eapply IHclock in H5. exact H5. exact H3.*)
      + apply list_expr_exception_correct in H0. destruct H0, H0, H0, H0, H1, H2, H3.
        inversion H. subst.
        eapply eval_tuple_ex with (vals := x) (eff := x1) (ids := x0); auto. auto.
        (*intros. eapply IHclock in H3. exact H3. exact H5. eapply IHclock in H4. exact H4. *)
      + congruence.
      + congruence.
    - case_eq (fbs_expr clock env modules own_module id exp1 eff).
        -- intros. rewrite H0 in H. destruct res0.
          --- destruct v; try congruence.
              destruct v0; try congruence.
              case_eq (fbs_expr clock env modules own_module id0 exp2 eff0 ).
                + intros. rewrite H1 in H.
                  destruct res0.
                  ++ destruct v0; try congruence.
                    destruct v1; try congruence.
                    case_eq (fbs_values (fbs_expr clock) env modules own_module id1 l eff1).
                        ** intros. rewrite H2 in H.
                          destruct res0.
                          *** destruct v.
                            **** apply IHclock in H0, H1. inversion H. subst.
                                  apply list_expr_correct in H2.
                                  destruct H2, H2, H2, H3, H4, H5, H6.
                                  eapply eval_call_mexp_badarg_ex with
                                  (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff'); auto.
                                  exact H0. exact H1. congruence.
                            **** destruct l0.
                              ***** destruct v0.
                                ****** apply IHclock in H0, H1. inversion H. subst.
                                        apply list_expr_correct in H2.
                                        destruct H2, H2, H2, H3, H4, H5, H6.
                                        eapply eval_call_fexp_badarg_ex with
                                        (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff');  auto.
                                        exact H0. exact H1. congruence.
                                ****** destruct l0.
                                  ******* destruct get_modfunc eqn:MOD.
                                          ********  apply IHclock in H0, H1, H.
                                                    apply list_expr_correct in H2.
                                                    destruct H2, H2, H2, H3, H4, H5, H6.
                                                    rewrite H5, H6 in H.
                                                    eapply eval_call_module with (vals := v1) (eff := x0) (ids := x); auto.
                                                    exact H0. exact H1.
                                                    exact MOD. exact H.
                                          ********  apply IHclock in H0, H1. inversion H. subst.
                                                    apply list_expr_correct in H2.
                                                    destruct H2, H2, H2, H3, H4, H5, H6.
                                                    eapply eval_call with (vals := v1) (eff := x0) (ids := x); auto.
                                                    exact H0. exact H1. auto.
                                                    rewrite <- surjective_pairing.
                                                    rewrite H5. auto.
                                  ******* apply IHclock in H0, H1. inversion H. subst.
                                          apply list_expr_correct in H2.
                                          destruct H2, H2, H2, H3, H4, H5, H6.
                                          eapply eval_call_fexp_badarg_ex with
                                          (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x1) (ids:=x0) (id''':= id') (eff4:= eff');  auto.
                                          exact H0. exact H1. congruence.
                                ****** apply IHclock in H0, H1. inversion H. subst.
                                        apply list_expr_correct in H2.
                                        destruct H2, H2, H2, H3, H4, H5, H6.
                                        eapply eval_call_fexp_badarg_ex with
                                        (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff');  auto.
                                        exact H0. exact H1. congruence.
                                ****** apply IHclock in H0, H1. inversion H. subst.
                                        apply list_expr_correct in H2.
                                        destruct H2, H2, H2, H3, H4, H5, H6.
                                        eapply eval_call_fexp_badarg_ex with
                                        (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff');  auto.
                                        exact H0. exact H1. congruence.
                                ****** apply IHclock in H0, H1. inversion H. subst.
                                        apply list_expr_correct in H2.
                                        destruct H2, H2, H2, H3, H4, H5, H6.
                                        eapply eval_call_fexp_badarg_ex with
                                        (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff');  auto.
                                        exact H0. exact H1. congruence.
                                ****** apply IHclock in H0, H1. inversion H. subst.
                                        apply list_expr_correct in H2.
                                        destruct H2, H2, H2, H3, H4, H5, H6.
                                        eapply eval_call_fexp_badarg_ex with
                                        (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff');  auto.
                                        exact H0. exact H1. congruence.
                              ***** apply IHclock in H0, H1. inversion H. subst.
                                    apply list_expr_correct in H2.
                                    destruct H2, H2, H2, H3, H4, H5, H6.
                                    eapply eval_call_mexp_badarg_ex with
                                    (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x1) (ids:=x0) (id''':= id') (eff4:= eff'); auto.
                                    exact H0. exact H1. congruence.
                            **** apply IHclock in H0, H1. inversion H. subst.
                                  apply list_expr_correct in H2.
                                  destruct H2, H2, H2, H3, H4, H5, H6.
                                  eapply eval_call_mexp_badarg_ex with
                                  (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff'); auto.
                                  exact H0. exact H1. congruence.
                            **** apply IHclock in H0, H1. inversion H. subst.
                                  apply list_expr_correct in H2.
                                  destruct H2, H2, H2, H3, H4, H5, H6.
                                  eapply eval_call_mexp_badarg_ex with
                                  (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff'); auto.
                                  exact H0. exact H1. congruence.
                            **** apply IHclock in H0, H1. inversion H. subst.
                                  apply list_expr_correct in H2.
                                  destruct H2, H2, H2, H3, H4, H5, H6.
                                  eapply eval_call_mexp_badarg_ex with
                                  (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff'); auto.
                                  exact H0. exact H1. congruence.
                            **** apply IHclock in H0, H1. inversion H. subst.
                                  apply list_expr_correct in H2.
                                  destruct H2, H2, H2, H3, H4, H5, H6.
                                  eapply eval_call_mexp_badarg_ex with
                                  (params:= l) (fexp:= exp2) (vals:=v1) (eff:=x0) (ids:=x) (id''':= id') (eff4:= eff'); auto.
                                  exact H0. exact H1. congruence.
                          *** apply IHclock in H0, H1. inversion H. subst.
                              apply list_expr_exception_correct in H2.
                              destruct H2, H2, H2, H2, H3, H4, H5.
                              eapply eval_call_ex with (vals := x) (eff := x1) (ids := x0); auto.
                              auto. exact H0. exact H1.

                        ** intros; rewrite H2 in H; congruence.
                        ** intros; rewrite H2 in H; congruence.
                  ++ apply IHclock in H0, H1. inversion H. subst.
                       eapply eval_call_fexp_ex. exact H0. exact H1.
                + intros. rewrite H1 in H. congruence.
                + intros. rewrite H1 in H. congruence.

          --- apply IHclock in H0. inversion H. subst.
              eapply eval_call_mexp_ex with (params:= l) (fexp:= exp2)  in H0. auto.
        -- intros. rewrite H0 in H. congruence.
        -- intros. rewrite H0 in H. congruence.

    (*TODO: !!!!!!!!!!!!!!!!!!!!*)

      (*+ apply IHclock in H0. apply IHclock in H1.
      case_eq (fbs_values (fbs_expr clock) env [] id l eff); intros. *)

    (*case_eq (fbs_values (fbs_expr clock) env [] id l eff); intros; rewrite H0 in H.
      destruct res0.
      + apply list_expr_correct in H0. destruct H0, H0, H0, H1, H2, H3, H4.
        inversion H. subst.
        eapply eval_call with (vals := v) (eff := x0) (ids := x); auto.
        (*intros. eapply IHclock in H5. exact H5. exact H3.  *)
        ** rewrite <- surjective_pairing. auto.
      + apply list_expr_exception_correct in H0. destruct H0, H0, H0, H0, H1, H2, H3.
        inversion H. subst.
        eapply eval_call_ex with (vals := x) (eff := x1) (ids := x0); auto. auto.
        (*intros. eapply IHclock in H3. exact H3. exact H5. eapply IHclock in H4. exact H4. *)
      + congruence.
      + congruence.*)
    - case_eq (fbs_values (fbs_expr clock) env modules own_module id l eff); intros; rewrite H0 in H.
      destruct res0.
      + apply list_expr_correct in H0. destruct H0, H0, H0, H1, H2, H3, H4.
        inversion H. subst.
        eapply eval_primop with (vals := v) (eff := x0) (ids := x); auto.
        (*intros. eapply IHclock in H5. exact H5. exact H3.*)
        ** rewrite <- surjective_pairing. auto.
      + apply list_expr_exception_correct in H0. destruct H0, H0, H0, H0, H1, H2, H3.
        inversion H. subst.
        eapply eval_primop_ex with (vals := x) (eff := x1) (ids := x0); auto. auto.
        (*intros. eapply IHclock in H3. exact H3. exact H5. eapply IHclock in H4. exact H4. *)
      + congruence.
      + congruence.
    - case_eq (fbs_expr clock env modules own_module id exp eff); intros; rewrite H0 in H.
      destruct res0. destruct v. congruence. destruct v0. 2: congruence.
      + apply IHclock in H0.
        case_eq (fbs_values (fbs_expr clock) env modules own_module id0 l eff0); intros; rewrite H1 in H.
        destruct res0; try (apply list_expr_correct in H1; destruct H1, H1, H1, H2, H3, H4, H5).
        ** destruct v; inversion H; subst.
          -- eapply eval_app_badfun_ex with (vals := v0) (eff := x0) (ids := x);auto.
              auto. (*exact H0. intros. eapply IHclock in H6. exact H6. exact H4.*)
              intros; try (pose (P := H6 j H4); apply fbs_expr_correctness in P; exact P).
              congruence.
          -- eapply eval_app_badfun_ex with (vals := v0) (eff := x0) (ids := x);auto.
              auto. (*exact H0. intros. eapply IHclock in H6. exact H6. exact H4.*)
              intros; try (pose (P := H6 j H4); apply fbs_expr_correctness in P; exact P).
              congruence.
          -- case_eq (Datatypes.length vl =? Datatypes.length v0); intros; rewrite H4 in *.
            ++ apply Nat.eqb_eq in H4.
              eapply eval_app with (vals := v0) (eff := x0) (ids := x); auto.
              *** exact H0.
              *** auto.
              (****  intros. eapply IHclock in H6. exact H6. exact H5.*)
              *** apply IHclock in H8. exact H8.
            ++ apply Nat.eqb_neq in H4. inversion H. subst.
              eapply eval_app_badarity_ex with (vals := v0) (eff := x0) (ids := x); auto.
              *** exact H0.
              (**** intros. eapply IHclock in H6. exact H6. auto.*)

          -- eapply eval_app_badfun_ex with (vals := v0) (eff := x0) (ids := x);auto.
              (*exact H0. intros. eapply IHclock in H6. exact H6. exact H4.*)
              intros; try (pose (P := H6 j H4); apply fbs_expr_correctness in P; exact P).
              auto.
              congruence.
          -- eapply eval_app_badfun_ex with (vals := v0) (eff := x0) (ids := x);auto.
              (*exact H0. intros. eapply IHclock in H6. exact H6. exact H4.*)
              intros; try (pose (P := H6 j H4); apply fbs_expr_correctness in P; exact P).
              auto.
              congruence.
          -- eapply eval_app_badfun_ex with (vals := v0) (eff := x0) (ids := x);auto.
          (*exact H0. intros. eapply IHclock in H6. exact H6. exact H4.*)
          intros; try (pose (P := H6 j H4); apply fbs_expr_correctness in P; exact P).
          auto.
          congruence.

    (* 1-2, 4-6: eapply eval_app_badfun_ex with (vals := v0) (eff := x0) (ids := x);auto.
          -- exact H0. intros. eapply IHclock in H6. exact H6. exact H4.
          intros; try (pose (P := H6 j H4); apply fbs_expr_correctness in P; exact P).
          congruence.
          -- case_eq (Datatypes.length vl =? Datatypes.length v0); intros; rewrite H4 in *.
             ++ apply Nat.eqb_eq in H4.
                eapply eval_app with (vals := v0) (eff := x0) (ids := x); auto.
                *** exact H0.
                *** auto.
                *** apply IHclock in H8. auto.
             ++ apply Nat.eqb_neq in H4. inversion H. subst.
                eapply eval_app_badarity_ex with (vals := v0) (eff := x0) (ids := x); auto.
                *** exact H0.*)
        ** apply list_expr_exception_correct in H1. destruct H1, H1, H1, H1, H2, H3, H4.
           apply IHclock in H5. inversion H. subst.
           eapply eval_app_param_ex with (vals := x) (eff := x1) (ids := x0); auto.
           *** exact H1.
           *** exact H0.
           (**** intros. eapply IHclock in H4. exact H4. exact H6.
           *** exact H5.*)
        ** congruence.
        ** congruence.
      + apply IHclock in H0. inversion H. subst.
        eapply eval_app_closure_ex. auto.
      + congruence.
      + congruence.
    - case_eq (fbs_expr clock env modules own_module id exp eff); intros; rewrite H0 in H.
      destruct res0.
      + apply IHclock in H0.
        apply case_correctness in H. destruct H.
        ** destruct H, H, H, H, H, H1, H2, H3.
           eapply eval_case with (i := x).
           -- exact H0.
           -- auto.
           -- exact H1.
           -- intros. pose (P := H2 j H5 gg ee bb H6). apply IHclock in P. exact P.
           -- apply IHclock in H3. auto.
           -- apply IHclock in H4. auto.
        ** destruct H, H1, H2. subst. eapply eval_case_clause_ex.
           -- exact H0.
           -- intros. pose (P := H j H1 gg ee bb H2). apply IHclock in P. auto.
      + apply IHclock in H0. inversion H. subst.
        apply eval_case_pat_ex. auto.
      + congruence.
      + congruence.
    - case_eq (fbs_expr clock env modules own_module id exp1 eff); intros; rewrite H0 in H.
      destruct res0.
      + case_eq (Datatypes.length v =? Datatypes.length l); intros; rewrite H1 in H.
        ** apply Nat.eqb_eq in H1. apply IHclock in H.
           apply IHclock in H0.
           eapply eval_let.
           -- exact H0.
           -- auto.
           -- exact H.
        ** congruence.
      + inversion H. subst.
        apply eval_let_ex. apply IHclock in H0. auto.
      + congruence.
      + congruence.
    - case_eq (fbs_expr clock env modules own_module id exp1 eff); intros; rewrite H0 in H.
      destruct res0. destruct v. congruence. destruct v0. 2: congruence.
      + apply IHclock in H. apply IHclock in H0.
        eapply eval_seq. exact H0. exact H.
      + inversion H. subst.
        apply eval_seq_ex. apply IHclock in H0. auto.
      + congruence.
      + congruence.
    - eapply eval_letrec. apply IHclock in H. auto.
    - case_eq (fbs_values (fbs_expr clock) env modules own_module id (make_map_exps l) eff); intros; rewrite H0 in H.
      destruct res0.
      + apply list_expr_correct in H0. destruct H0, H0, H0, H1, H2, H3, H4.
        case_eq (make_map_vals_inverse v); intros; rewrite H6 in H. 2: congruence.
        destruct p. inversion H. subst.
        pose (P := make_map_inverse_length _ _ _ H6). destruct P.
        eapply eval_map with (ids := x) (eff := x0) (kvals := l0) (vvals := l1); auto.
        ** rewrite length_make_map_exps in H0. lia.
        ** rewrite length_make_map_exps in H0. lia.
        ** rewrite length_make_map_exps in H2. lia.
        ** rewrite length_make_map_exps in H1. lia.
        ** intros. pose (P := H5 i H7). apply IHclock in P.
           apply make_map_inverse_relation in H6. subst. exact P.
        ** apply surjective_pairing.
     + apply list_expr_exception_correct in H0. destruct H0, H0, H0, H0, H1, H2, H3.
        inversion H. subst.
        apply IHclock in H4.
        assert (exists kvals vvals, x = make_map_vals kvals vvals /\ length kvals = length vvals + length x mod 2). { apply map_correcness. }
        destruct H5, H5, H5.
        eapply eval_map_ex with (ids := x0) (eff := x1) (kvals := x2) (vvals := x3); auto.
        ** rewrite length_make_map_exps in H0. lia.
        ** pose (modulo_2 (length x)). destruct o.
           -- rewrite H7 in H6. rewrite Nat.add_0_r in H6. pose (length_make_map_vals _ _ H6).
              subst. rewrite H6 in e0. pose (n_div_2_mod_0 _ H7). rewrite <- H2. lia.
           -- rewrite H7 in H6. rewrite Nat.add_1_r in H6. pose (length_make_map_vals2 _ _ H6).
              subst. rewrite <- H2. pose (n_div_2_mod_1 _ H7). lia.
        ** rewrite <- H2. pose (modulo_2 (length x)). destruct o.
           -- rewrite H7 in *. rewrite Nat.add_0_r in *. pose (length_make_map_vals _ _ H6).
              pose (n_div_2_mod_0 _ H7). subst. lia.
           -- rewrite H7 in *. rewrite Nat.add_1_r in *. pose (length_make_map_vals2 _ _ H6).
              pose (n_div_2_mod_1 _ H7). subst. lia.
        ** lia.
        ** intros. rewrite <- H2 in H7. pose (P := H3 j H7). rewrite <- H5. apply IHclock in P. auto.
        ** rewrite <- H2. auto.
      + congruence.
      + congruence.
    - case_eq (fbs_expr clock env modules own_module id exp1 eff); intros; rewrite H0 in H.
      destruct res0.
      + case_eq (Datatypes.length v =? Datatypes.length vl1); intros; rewrite H1 in H.
        2: congruence.
        apply Nat.eqb_eq in H1.
        apply IHclock in H0. apply IHclock in H.
        eapply eval_try.
        *** exact H0.
        *** auto.
        *** exact H.
      + apply IHclock in H0.
        eapply eval_catch.
        *** exact H0.
        *** apply IHclock in H. exact H.
      + congruence.
      + congruence.
Qed.

End Correctness.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  mutex.

Record condition `{!heapGS Σ} {mutex_unboxed} {mutex : mutex Σ mutex_unboxed} {unboxed : bool} := {
  condition_make : val ;
  condition_wait : val ;
  condition_signal : val ;
  condition_broadcast : val ;

  condition_inv : val → iProp Σ ;

  condition_inv_persistent t :
    Persistent (condition_inv t) ;

  condition_make_spec :
    {{{ True }}}
      condition_make #()
    {{{ t, RET t; condition_inv t }}} ;

  condition_wait_spec t mtx P :
    {{{ condition_inv t ∗ mutex.(mutex_inv) mtx P ∗ mutex.(mutex_locked) mtx ∗ P }}}
      condition_wait t mtx
    {{{ RET #(); mutex.(mutex_locked) mtx ∗ P }}} ;

  condition_signal_spec t :
    {{{ condition_inv t }}}
      condition_signal t
    {{{ RET #(); True }}} ;

  condition_broadcast_spec t :
    {{{ condition_inv t }}}
      condition_broadcast t
    {{{ RET #(); True }}} ;

  condition_unboxed :
    if unboxed then ∀ t,
      condition_inv t -∗
      ⌜val_is_unboxed t⌝
    else
      True ;
}.
#[global] Arguments condition _ {_ _} _ _ : assert.
#[global] Arguments Build_condition {_ _ _ _} _ {_ _ _ _ _ _} _ _ _ _ _ : assert.
#[global] Existing Instance condition_inv_persistent.

Section condition.
  Context `{!heapGS Σ} {mutex_unboxed} {mutex : mutex Σ mutex_unboxed} {unboxed} (condition : condition Σ mutex unboxed).

  #[local] Definition condition_wait_until_aux (cond : val) : val :=
    rec: "condition_wait_until_aux" "t" "mtx" :=
      if: cond #() then #() else (
        condition.(condition_wait) "t" "mtx" ;;
        "condition_wait_until_aux" "t" "mtx"
      ).
  Definition condition_wait_until cond : val :=
    λ: "t" "mtx",
      condition_wait_until_aux cond "t" "mtx".

  Definition condition_wait_while (cond : val) :=
    condition_wait_until (λ: <>, ~ cond #()).

  Lemma condition_wait_until_spec (cond : val) t mtx P Φ :
    {{{
      condition.(condition_inv) t ∗ mutex.(mutex_inv) mtx P ∗
      mutex.(mutex_locked) mtx ∗ P ∗ Φ false ∗
      {{{ mutex.(mutex_locked) mtx ∗ P ∗ Φ false }}}
        cond #()
      {{{ (b : bool), RET #b; mutex.(mutex_locked) mtx ∗ P ∗ Φ b }}}
    }}}
      condition_wait_until cond t mtx
    {{{
      RET #();
      mutex.(mutex_locked) mtx ∗ P ∗ Φ true
    }}}.
  Proof.
    iIntros "%Ψ (#Hinv_t & #Hinv_mtx & Hlocked & HP & HΦ & #Hcond) HΨ".
    wp_rec. wp_pures.
    iLöb as "HLöb".
    wp_rec. wp_pures.
    wp_apply ("Hcond" with "[$]"). iIntros "%b (Hlocked & HP & HΦ)".
    destruct b; wp_pures.
    { iApply "HΨ". iFrame. done. }
    wp_apply (condition_wait_spec _  _ _ P with "[$]"). iIntros "(Hlocked & HP)".
    wp_pures.
    iApply ("HLöb" with "[$] [$] [$] [$]").
  Qed.

  Lemma condition_wait_while_spec (cond : val) t mtx P Φ :
    {{{
      condition.(condition_inv) t ∗ mutex.(mutex_inv) mtx P ∗
      mutex.(mutex_locked) mtx ∗ P ∗ Φ true ∗
      {{{ mutex.(mutex_locked) mtx ∗ P ∗ Φ true }}}
        cond #()
      {{{ (b : bool), RET #b; mutex.(mutex_locked) mtx ∗ P ∗ Φ b }}}
    }}}
      condition_wait_while cond t mtx
    {{{
      RET #();
      mutex.(mutex_locked) mtx ∗ P ∗ Φ false
    }}}.
  Proof.
    iIntros "%Ψ (#Hinv_t & #Hinv_mtx & Hlocked & HP & HΦ & #Hcond) HΨ".
    wp_apply (condition_wait_until_spec _ _ _ P (λ b, Φ (negb b)) with "[$Hlocked $HP $HΦ]"); last done.
    iFrame "#". clear. iIntros "%Ψ !> (Hlocked & HP & HΦ) HΨ".
    wp_pures.
    wp_apply ("Hcond" with "[$]"). iIntros "%b (Hlocked & HP & HΦ)".
    destruct b; wp_pures; iApply "HΨ"; iFrame; done.
  Qed.
End condition.

#[global] Opaque condition_wait_until.
#[global] Opaque condition_wait_while.