(** *Notice: This file is very sketchy at the moment. Read at your own risk.*)

From mathcomp.ssreflect Require Import ssreflect seq ssrbool ssrnat.

Require Import Coq.ZArith.ZArith.

Require Import compcert.common.Memory.

(*Require Import VST.concurrency.juicy_machine.

Require Import VST.concurrency.concurrent_machine.
Require Import VST.concurrency.scheduler.*)
Require Import VST.msl.eq_dec.

Require Import VST.concurrency.konig.

Section cardinality.
(*Here goes cardinality stuff*)
End cardinality.

Section filtered_konig.
  Variable X: Type.
  Axiom X_dec: forall x y:X, {x=y} + {x<>y}.
  Variable Filter: X -> Prop.
  Variable R: X->X->Prop.
  Axiom  preservation :  forall P P', Filter P -> R P P' -> Filter P'.

  Record TT :Type:= mkTT {thing: X; prf: Filter thing}.
  Inductive RR: TT->TT->Prop:=
  | stepstep: forall P x' (stp: R (thing P) x'), RR P (mkTT x' (preservation _ _ (prf P) stp)).

  Lemma filtered_to_unfiltered_safe:
    forall P,
      konig.safe _ RR P ->
      konig.safe X R (thing P).
  Proof.
    cofix.
    move => P sf.
    inversion sf; subst x.
    inversion H; subst P0.
    apply: (safe_cons _ _ (thing P) x'0 stp).
    replace x'0 with (thing x').
    by apply: filtered_to_unfiltered_safe.
    by rewrite -H2.
  Qed.
  Lemma unfiltered_to_filtered_safeN:
    forall n P,
      konig.safeN X R n (thing P) ->
      konig.safeN _ RR n P.
  Proof.
    induction n.
    - constructor.
    - move=> P sf.
      inversion sf.
      apply: (safeS _ _ n P (mkTT x' (preservation _ _ (prf P) H0)))=> /=.
      by constructor.
      by apply: IHn.
  Qed.

  Inductive cardinality {X} (P:X->Prop): nat -> Prop:=
  |Cardinality n (f:nat-> X): (forall i j, i<n -> j<n -> i<>j -> f(i)<>f(j)) ->
                           (forall i, i<n -> P (f i)) ->
                           (forall x, P x -> exists i, i < n /\ f i = x) ->
                           cardinality P n.
  Inductive cardinality' {X} (P:X->Prop): nat -> Prop:=
  |Cardinality' n (f:nat-> X): (forall i j, i<n -> j<n -> i<>j  -> f(i)<>f(j)) ->
                            (forall i, i<n -> P (f i)) ->
                            cardinality' P n.

  Lemma repetition_dec: forall (f:nat -> X) x n,  (exists i, i<n /\ f(i) = x) \/ (forall i, i<n -> f i <> x).
              Proof.
                induction n=>//.
                - constructor 2 => //.
                - move: IHn=> [[]i [] A B| A].
                  + constructor; exists i; split =>//; auto.
                  + destruct (X_dec (f n) x).
                    * left; exists n; split=> //.
                    * right=> i ineq.
                      { destruct (Nat.eq_dec i n).
                        - subst i => //.
                        - apply: A=>//.
                          destruct (le_lt_dec n i) as [HH|HH]; move: HH=> /leP // /leP ineq2.
                        contradict n1. move: ineq=> /leP ineq.
                        omega.
                      }
              Qed.
  Lemma finite_cardinality:
    forall (P:X->Prop) (EM: forall x, P x \/ ~ P x), finite P -> exists n, cardinality P n.
  Proof.
    move => P EM [] n [] f FIN.
    cut (forall n2,
            (exists f0 n0,
                (n0 <= n2) /\
               (forall i j, i<n0 -> j<n0 -> i <> j -> f0(i)<>f0(j)) /\
               (forall i, i<n0 -> P (f0 i)) /\
               (forall i, i<n2 -> P (f i) -> exists i0, i0<n0 /\ f i = f0 i0)  /\
               (forall i, i<n0 -> exists j, j<n2 /\ f j = f0 i)) \/
               (exists n1, n1<=n2 /\ cardinality P n1)
        ).
    { move => HH; move: (HH n) => [ [] f0 [] n0 [] A [] B []  C [] D E  | [] n0 [] HH0 HH1 ].
      - exists n0; exists f0 => //.
        move =>  x Px. move: (FIN x Px)=> [] i [] /leP /D D' fi.
        move: Px; rewrite -fi => /D' [] i0 [] ineqi0 fifi0. rewrite fifi0.
        by exists i0; split.
      - by exists n0.
    }
    { induction n2.
      - left; exists f, 0; repeat split=>//.
      - move: IHn2=> [].
        + move => [] f0 [] n0 [] ineq02 [] inject0 [] prf0 [] subset complete.
          destruct (Compare.le_or_le_S n n2) as [A | A]; move:A=> /leP ineq.
          * right. exists n0; split => //; auto.
            apply: (Cardinality P n0 f0)=> //.
            move=> x Px. move: (FIN x Px)=> [] i [] /leP ineq' fi.
            assert (H:i< n2).
            { apply/ltP; move: ineq' ineq=> /ltP ineq' /leP ineq; omega. }
            move: Px; rewrite -fi => /(subset _ H) []  i' [] ineq0' fifo.
            by rewrite fifo; exists i'; split.
          * { pose (new_x:= f n2).
              (*check if new_x is in P*)
              destruct (EM new_x) as [Pnew_x | nPnew_x].
              - left; destruct (repetition_dec f new_x n2) as [HH|HH]; move: HH.
                + move=> [] i [] ineq2 fi.
                  { exists f0, n0; repeat split=>//; auto.
                    - move=> j ineqj Px.
                      destruct (Nat.eq_dec j n2).
                      + subst j.
                        move: Px.
                        rewrite -/new_x -fi => /(subset i ineq2) => [] [] i' [] ineqi' fifi'.
                        by exists i'; split.
                      + apply: subset=>//.
                        destruct (lt_dec j n2) as [HH|HH];
                          move:HH ineqj=> /leP // /leP HH /leP ineqj. by contradict n1; omega.
                    - move => i0 /complete [] j [] ineq0 fjfi0.
                      exists j; split=>//.
                      apply/leP. move: ineq0=> /leP HH; omega.
                  }
                + { move => HH.
                    pose (f0':= eq_dec.upd f0 n0 new_x); exists f0', n0.+1; repeat split => //.
                    - move => i j ineqi ineqj diffij.
                      destruct (Nat.eq_dec i n0);destruct (Nat.eq_dec j n0); try subst=> //.
                      + rewrite /f0' eq_dec.upd_eq eq_dec.upd_neq=> // .
                        assert (Hj: j < n0).
                        { apply/ltP; move: ineqj=> /ltP ineqj; omega. }
                        move: Hj=> /complete [] j' []ineq' <-.
                        move => eq.
                        eapply HH.
                        exact ineq'.
                        symmetry; exact eq.
                      + rewrite /f0' eq_dec.upd_eq eq_dec.upd_neq=> // .
                        assert (Hi: i < n0).
                        { apply/ltP; move: ineqi=> /ltP ineqi; omega. }
                        move: Hi=> /complete [] i' []ineq' <-.
                        move => eq.
                        eapply HH.
                        exact ineq'.
                        exact eq.
                        move=> HHH; apply: diffij; symmetry; exact HHH.
                      + rewrite /f0' eq_dec.upd_neq=>//; auto;
                        rewrite eq_dec.upd_neq=>//; auto.
                        assert (ineqi':  i < n0).
                        { apply/ltP ; move: ineqi=> /ltP ineqi; omega. }
                        assert (ineqj':  j < n0).
                        { apply/ltP ; move: ineqj=> /ltP ineqj; omega. }
                          by move: inject0 => /(_ _ _ ineqi' ineqj' diffij).
                    - move=> i0 ineqi0; destruct (Nat.eq_dec i0 n0).
                        by subst; rewrite /f0' eq_dec.upd_eq.
                        rewrite /f0' eq_dec.upd_neq; [apply: prf0|
                                                      move=> HHH; apply: n1; symmetry; exact HHH].
                        apply/ltP ; move: ineqi0=> /ltP ineqi0; omega.
                    - move => i0 ineq0 Px; destruct (Nat.eq_dec i0 n2).
                        by subst; exists n0; split =>//; rewrite /f0' eq_dec.upd_eq.
                        move: (subset i0)=> [] //.
                        apply/ltP ; move: ineq0=> /ltP ineq0; omega.
                        move=> i0' [] A B. exists i0'; split=>//. auto.
                        rewrite /f0' eq_dec.upd_neq=> //.
                        move: A=>/ltP A. omega.
                    - move=> i ineq0; destruct (Nat.eq_dec n0 i).
                      + subst i; rewrite /f0' eq_dec.upd_eq=> //.
                        exists n2; split=>//.
                      + rewrite /f0' eq_dec.upd_neq=> //.
                        assert (ineqi':  i < n0).
                        { apply/ltP ; move: ineq0=> /ltP ineq0; omega. }
                        move: ineqi'=> /complete [] j [] ineqj <-.
                        exists j; split=>//. apply/ltP; move: ineqj=> /ltP ineqj; omega.

                  }
                + left; exists f0, n0; repeat split=> //.
                  * auto.
                  * move => i0 ineq0. destruct (Nat.eq_dec i0 n2).
                      by subst; move=> Px; exfalso; apply nPnew_x.
                      assert (H:i0<n2).
                      { apply/ltP ; move: ineq0=> /ltP ineq0; omega. }
                        by move /(subset _ H).
                  * move=> i /complete [] j [] ineq' eqj; exists j; split=> //.
                    apply/ltP; move: ineq' =>/ltP ineq';omega.

            }
        + move => [] n0 [] /leP /(le_trans _ _ n2.+1) A B; right; exists n0; split=> //.
          apply/leP; apply: A; omega.
    }
Qed.

  Lemma filtered_konigsafe:
    forall (x : X),
      (forall P : Prop, P \/ ~ P) ->
      (forall x0 : X, Filter x0 -> finite (R x0)) ->
      Filter x ->
      (forall n : nat, safeN X R n x) -> konig.safe X R x.
  Proof.
    move => x EM blah inF sfN.
    replace x with (thing (mkTT x inF)) by reflexivity.
    eapply filtered_to_unfiltered_safe.
    eapply concurrency.konig.konigsafe => //.

    move=> [] xx prfx.
    rewrite /finite.

    assert (EM': forall x0, R xx x0 \/ ~ R xx x0) by (move=>x0; apply EM;auto).
    move: (blah _ prfx)=> /(finite_cardinality _ EM') [] n car.
    inversion car; subst n0.

    exists n.
    assert (HH: forall i, i < n -> Filter (f i)) by move => i / H0 / (preservation _ _ prfx) //.
    assert (refl:forall i n, (i < n)%coq_nat -> is_true (i < n)) by move => i' n' /ltP //.
    pose (f0:= fun i =>
                 match le_lt_dec n i with
                 | left _ =>  mkTT xx prfx
                 | right ineq => mkTT (f i) (HH i (refl i n ineq))
                 end ).

    exists f0 => [] [] xx' prfx' /= stepstep. inversion stepstep.
    move: stp0; subst x'=> /= /H1 [] i0 [] /ltP A B.
    exists i0; split=> //.
    rewrite /f0.
    destruct (le_lt_dec n i0) => //.
    move: A l=> /ltP A /leP.
    move: A => /ltP FALSE1 /leP FALSE2; omega.
    clear stepstep.
    remember (HH i0 (refl i0 n l)) as prfx''. clear Heqprfx''.
    move: prfx' prfx''.
    dependent rewrite B => P1 P2; f_equal.
    apply: ProofIrrelevance.PI.proof_irrelevance.

    move => n.
    apply: unfiltered_to_filtered_safeN=> //.
  Qed.

End filtered_konig.

Section Safety.
  Context (ST:Type)(SCH:Type).
  Context (STEP:ST->SCH->ST->SCH-> Prop).
  Context (valid: ST-> SCH -> Prop).

  Axiom schedule_dec:
    forall (U U':SCH), {U=U'} + {U<>U'}.

  Inductive ksafe (st:ST) U: nat -> Prop :=
  |sft0: ksafe st U 0
  |sft_step: forall n st' U', STEP st U st' U' -> (forall U'', valid st' U'' -> ksafe st' U'' n) -> ksafe st U (S n).

  CoInductive safe st U: Prop:=
  | csft_step: forall st' U', STEP st U st' U' -> (forall U'', valid st' U'' -> safe st' U'') -> safe st U.

  (*The proof relies on the sets of states: SST's*)
  Definition SST:= ST -> Prop.
  Definition is_in (st:ST)(P:SST):= P st.
  (*Notation enth:= (List.nth_error).*)
  Infix "\In":= (is_in) (at level 20, right associativity).

  (*Generalizes a non-deterministic relation to sets *)
  Inductive SStep {X Y: Type} (R: X -> X -> Y -> Prop)(valid:X->Y->Prop) (P P':X -> Prop) : Prop:=
  | blahblah: (forall x y, P x -> valid x y -> exists x', R x x' y /\ P' x') ->
              (forall x', P' x' -> exists x y, R x x' y /\ P x /\ valid x y) ->
              SStep R valid P P'.
  Definition SST_step : SST -> SST -> Prop := SStep (fun st st' U => exists U', STEP st U st' U') valid.

  (*Instantiating koning's variables *)
  Definition SsafeN:= konig.safeN SST SST_step.
  Definition Ssafe:= konig.safe (SST) SST_step.
  (*Initial state is singleton.*)
  Inductive P_init {st_init:ST}: SST:=
  |ItIsMe: P_init st_init.

  Lemma finite_P_init: forall {st}, finite (@P_init st).
  Proof. by move =>st; exists 1, (fun _ => st) => st' []; exists 0; split. Qed.

  Lemma SsafeN_ksafe': forall n P,
      SsafeN n P -> forall st U, st \In P -> valid st U -> ksafe st U n.
  Proof.
    induction n.
    - constructor.
    - move=> P HH st U inP VAL.
      inversion HH; subst.
      inversion H0.
      move: VAL inP => /H H' /H'  [] st' [][] U' STP inx'.
      apply: (sft_step st U n st' U' STP)=> U'' VALID'.
      apply: (IHn x' _ )=>//.
  Qed.

  Corollary SsafeN_ksafe: forall n st,
      SsafeN n (@P_init st) -> forall U, valid st U -> ksafe st U n.
  Proof. move=> n st mysN U VAL. apply: (SsafeN_ksafe' n P_init mysN) => //. Qed.

  Lemma ksafe_SsafeN': forall n P,
      (forall st U, st \In P -> valid st U -> ksafe st U n) ->
      SsafeN n P.
  Proof.
    induction n.
    - constructor.
    - move=> P HH.
      pose (P':= fun st' => exists st U U',
                     P st /\
                     valid st U /\
                     STEP st U st' U' /\
                     (forall U'', valid st' U'' -> ksafe st' U'' n)).
      apply: (safeS _ _ n P P').
    - constructor.
      + move => st U inP VAL.
        move: (inP) (VAL)=> /HH HH' /HH' ksf.
        inversion ksf.
        exists st'; split; [exists U'| ] =>//.
        rewrite /is_in /P'.
        exists st, U, U'=>//.
      + move => st'.
        rewrite /is_in /P'=> [] [] st [] U [] U' []inP[] VAL[] STP CONDITION.
        exists st, U; split;[exists  U' | ]=>//.
    - eapply IHn => st' U [] st [] UU [] U' [] inP [] VAL [] STP COND;
      by apply: COND.
  Qed.

  Lemma ksafe_SsafeN: forall st_init,
      (forall U, valid st_init U) ->
      forall n, (forall U, ksafe st_init U n) ->
           SsafeN n (@P_init st_init).
  Proof.
    move => st_init all_valid n Uksf.
    apply ksafe_SsafeN' => st' U' [] val.
    apply: Uksf.
  Qed.

  Lemma Ssafe_safe': forall P,
      Ssafe P -> forall st U, st \In P -> valid st U -> safe st U.
  Proof.
    cofix=> P SF st U.
    inversion SF; subst x; rename x' into P'.
    inversion H => /H1 H1' /H1' [] st' [] [] U' STP inP'.
    apply: (csft_step _ _ st' U')=>// U'' VAL'.
    apply: (Ssafe_safe' P')=> //.
  Qed.

  Lemma Ssafe_safe: forall st_init,
      (forall U, valid st_init U) ->
      Ssafe (@P_init st_init) -> forall U, safe st_init U.
  Proof.
    move=> st all_valid SF U.
    apply: (Ssafe_safe' _ SF).
    - by constructor.
    - by apply: all_valid.
  Qed.

  (* This is too weak... but is a good example*)
  Lemma SsafeN_Ssafe:
    (forall P: Prop, P \/ ~ P) ->
    forall P,
      (forall P, finite (SST_step P)) ->
      (forall n, SsafeN n P) ->
      Ssafe P.
  Proof. by move => EM P A B; apply: (concurrency.konig.konigsafe). Qed.

  (*This is strong enough *)
  Lemma finite_Ssafe_safe':
    (forall P : Prop, P \/ ~ P) ->
    (forall P : ST -> Prop, finite P -> finite (SST_step P)) ->
    forall P, (finite P) ->
         ( forall n : nat, safeN (ST -> Prop) SST_step n P) ->
         Ssafe P.
  Proof. by move => EM FIN P FINP; apply: ( filtered_konigsafe _ finite). Qed.

  Lemma finite_Ssafe_safe:
    (forall P : Prop, P \/ ~ P) ->
    (forall P : ST -> Prop, finite P -> finite (SST_step P)) ->
    forall st, ( forall n : nat, safeN (ST -> Prop) SST_step n (@P_init st)) ->
          Ssafe (@P_init st).
  Proof. move => EM FIN P; apply: finite_Ssafe_safe'=>//. apply: finite_P_init. Qed.

  Definition possible_image {X Y} (STEP:X-> Y-> X (*-> Y*) -> Prop) (valid: X -> Y -> Prop)  st st' U:= valid st U /\ (* exists U',  *) STEP st U st' (* U' *).
  Definition finite_on_x {X Y} (A:X->Y->Prop):=
    exists n (f: nat -> X), forall x y, A x y -> exists i, (i < n) /\ f i = x.
  (** This lemma is actually easy. It's unique, under prop_ext. **)
  Require Import VST.msl.Axioms.
  Lemma finite_rel_generalize' {X Y} (V: X -> Y -> Prop) (R: X -> X -> Y -> Prop):
    (forall x, finite_on_x (possible_image (fun x x' y => R x y x') V x)) ->
    forall (P:X -> Prop), finite P ->
                 finite (fun x' => exists x y, P x /\ V x y /\ R x x' y).
  Proof.
    move=> FINx P [] n [] Pf FINp.
    unfold possible_image, finite_on_x in FINx.
    pose (PN:= fun n x => exists i, Pf i = x /\ i < n /\ P x).
    cut (forall n, finite (fun x' => exists x y, (PN n) x /\ V x y /\ R x x' y)).
    { move => /(_ n) [] N [] F HH.
      exists N, F => x' [] x [] y [] Px [] Vxy Rxx.
      cut (exists x y, PN n x /\ V x y /\ R x x' y).
      - by move=> /HH.
      - exists x, y; repeat split; [ |assumption| assumption].
        move: (Px) => /FINp [] i [] ineq Pfi.
        exists i; repeat split=> //; by apply/ltP.
    }
    { (*Prove the cut condition*)
      induction n0.
      - exists 1, (fun _ => Pf 0) => x' [] x [] y [] PNx [] Vxy Rxx'.
        exists 0; move : PNx => [] i []Pfi [] /ltP HH.
        contradict HH; clear; omega.
      - move: IHn0 => [] N [] F HH.
        pose (new_x:= Pf n0).
        move: (FINx new_x)=> [] nn [] fn HHH.
        exists (N + nn).
        exists (fun i => if (i < N) then F i else fn (i - N)) => x' [] x [] y [][] i [] Pfi []ineqi Px.
        destruct (Nat.eq_dec i n0) as [e|ne].
        + rewrite e in Pfi.
          rewrite /new_x Pfi in HHH.
          move => /HHH [] i0 [] ineqi0 fni0 .
          exists (N + i0); split.
          * apply/ltP; rewrite ltn_add2l; assumption.
          * replace (N + i0 < N) with false.
            replace (N + i0 - N) with i0.
            assumption.
            rewrite /addn /addn_rec /subn /subn_rec;
              omega.
            symmetry.
            cut (~ (N + i0 < N)).
            apply: introF; apply: idP.
            move: ineqi0=> /ltP ineqi0 /ltP.
            rewrite /addn /addn_rec => NN.
            clear - NN ineqi0. omega.
        + move=> [] Vxy Rxxy.
          cut ((exists (x0 : X) (y : Y), PN n0 x0 /\ V x0 y /\ R x0 x' y)).
          move=> /HH [] i0 [] ineqi0  Fi0.
          exists i0; split.
          * rewrite /addn /addn_rec ;omega.
          * by move: ineqi0=> /ltP ->.

            {
              exists x, y; repeat split=> //.
              exists i; repeat split=>//.
              apply/ltP. move: ineqi=> /ltP ineqi'; omega. }
  }
  Qed.
  Lemma power_set_finite {X}:
    (forall P : Prop, P \/ ~ P) ->
    forall P: X-> Prop, finite P ->
               finite (fun A => subset A P).
  Proof.
    move => EM P [] n; move: P.
    induction n.
    - move => P [] f FINp.
      exists 1, (fun _ _ => False).
      move=> P'. rewrite /subset => SUB.
      exists 0; split; [omega|].
      apply extensionality=> x'; apply prop_ext; split.
      move=>HH;exfalso; assumption.
      move=>/SUB /FINp []i [] HH _. omega. (* i < 0 -> False*)
    - move => P [] f FIN.
      cut ((exists f0 : nat -> X,
           forall x : X,
           (fun x0 : X => P x0 /\ f n <> x0) x ->
           exists i : nat, (i < n)%coq_nat /\ f0 i = x)).
      move=> /IHn [] n' [] f' FIN'.
      exists (2 * n').
      exists (fun i x => if odd i then  f' ((i - 1) /2) x \/ x = f n else  f' (i/ 2) x).
      move=> P'  SUB.
      cut (subset (fun x : X => P' x /\ f n <> x) (fun x : X => P x /\ f n <> x)).
      move=> /FIN' [] i [] ineqi fi'.
      destruct (EM (P' (f n))) as [yes|no].
      + { exists (2 * i + 1); split;
          [rewrite /addn /addn_rec /muln /muln_rec; omega|].
          rewrite odd_add addbC odd_mul.
          replace ((2 * i + 1 - 1) / 2) with i.
          - simpl; apply extensionality=> x'; apply prop_ext; rewrite fi'; split.
            + move=> [[] | ->] //.
            + destruct (EM (f n = x')).
              * by move=> Px'; right.
              * by move=> Px'; left; split.
                rewrite /addn /addn_rec /subn /subn_rec /muln /muln_rec.
                rewrite Nat.add_sub Nat.mul_comm Nat.div_mul; [reflexivity | omega].
        }

      + { exists (2 * i); split.
        rewrite /addn /addn_rec /muln /muln_rec; omega.
        rewrite odd_mul.
        rewrite /muln /muln_rec Nat.mul_comm Nat.div_mul /= ; [|omega].
        apply extensionality=> x'; apply prop_ext; rewrite fi'; split.
          * by move=> [].
          * move => Px'; split => // EQ.
              by apply:no; rewrite EQ.

        }
      (*CUT: subset (fun x : X => P' x /\ f n <> x) (fun x : X => P x /\ f n <> x)*)
        { move=> x [] Px' fnx'; split=> //.
            by apply: SUB. }
        { exists f => x [] /FIN [] i [] ineqi fi fnx.
        exists i; split; [|assumption].
        destruct (Nat.eq_dec i n) as [e|ne].
        - subst i; contradict fnx; assumption.
        - omega.
        }
  Qed.

  Lemma subset_finite {X}: forall (P P': X-> Prop), finite P -> subset P' P -> finite P'.
  Proof. move=> P P' [] n [] f HH SUB. by exists n, f => x / SUB / HH. Qed.

  Lemma finite_rel_generalize {X Y} (V: X -> Y -> Prop) (R: X -> X -> Y -> Prop):
    forall (propositional_extentionality: True),
      (forall P : Prop, P \/ ~ P) ->
      (forall x, finite_on_x (possible_image (fun x x' y => R x y x') V x)) ->
      forall (P:X -> Prop), finite P ->
                   finite (SStep R V P).
  Proof.
    move => _ EM /finite_rel_generalize' H P /H HH.
    apply: subset_finite.
    - apply: power_set_finite; [assumption|apply: HH].
    - clear=> Pp HH x' Ppx.
      inversion HH.
      move: Ppx=> / H0 [] x [] y [] Rxxy [] Px Vx.
      exists x, y; repeat split=> //.
  Qed.

  Lemma ksafe_safe':
    (forall P: Prop, P \/ ~ P) ->
    forall (propositional_extentionality: True),
    forall (branches_finitely_on_the_state: forall x : ST,
          @finite_on_x _ _ (possible_image (fun x y x' => exists y', STEP x y x' y') valid x)),
    forall st,
      (forall n U, valid st U -> ksafe st U n) ->
      (forall U, valid st U -> safe st U).
  Proof.
    move => EM PROP_EXT FINIT st KS U VAL.
    apply: (Ssafe_safe' (@P_init st)) => // .
    apply: finite_Ssafe_safe' =>//.
    - by move => st' FINst; apply: (finite_rel_generalize _ _ PROP_EXT).
      - apply: finite_P_init.
      - move=> n. eapply ksafe_SsafeN'; eauto.
        move => st0 U0 ImIn VAL0.
        inversion ImIn as [H0].
        subst. apply KS=> //.
  Qed.

  Lemma ksafe_safe:
    (forall P: Prop, P \/ ~ P) ->
    forall (propositional_extentionality: True),
    forall (branches_finitely_on_the_state: forall x : ST,
          @finite_on_x _ _ (possible_image (fun x y x' => exists y', STEP x y x' y') valid x)),
    forall st,
      (forall U : SCH, valid st U) ->
      (forall n U, ksafe st U n) ->
      (forall U, safe st U).
  Proof.
    move => EM PROP_EXT FINIT st all_valid SF.
    apply: Ssafe_safe =>//.
    apply: finite_Ssafe_safe=>//.
      by move => st' FINst; apply: (finite_rel_generalize _ _ PROP_EXT).
        by move=> n; apply: ksafe_SsafeN.
  Qed.
   Lemma safe_ksafe':
    forall st,
      (forall U, valid st U -> safe st U) ->
      (forall U, valid st U -> forall n, ksafe st U n).
  Proof.
    move => st SF U VAL n; move: st SF U VAL.
    induction n.
    - constructor.
    - move=> st SF U VAL; specialize (SF _ VAL); inversion SF.
      apply: (sft_step _ _ _ st' U' H)=> U'' VAL'.
      apply: IHn=>//.
  Qed.

  Lemma safe_ksafe:
    forall st,
      (forall U : SCH, valid st U) ->
      (forall U, safe st U) ->
      (forall n U, ksafe st U n).
  Proof. move => st all_valid SF n U; apply: safe_ksafe'=>//. Qed.

End Safety.


Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List. Import ListNotations.
Require Import bedrock2.MetricLogging.
Require Import coqutil.Macros.unique.
Require Import bedrock2.Memory.
Require Import compiler.util.Common.
Require Import coqutil.Decidable.
Require Import coqutil.Datatypes.PropSet.
Require Import coqutil.Byte.
Require Import bedrock2.Syntax.
Require Import coqutil.Z.Lia.
Require Import coqutil.Tactics.Simp.
Require Import bedrock2.Semantics.
Require Import coqutil.Datatypes.ListSet.
Require Import coqutil.Map.OfListWord.
Require Import coqutil.Word.Bitwidth.
Require Import coqutil.Word.Interface.
Local Hint Mode Word.Interface.word - : typeclass_instances.

Inductive bbinop: Type :=
| BEq
| BNe
| BLt
| BGe
| BLtu
| BGeu.

Section Syntax.
  Context {varname: Type}.

  Inductive operand: Type :=
  | Var (v: varname)
  | Const (c: Z)
  .

  Inductive bcond: Type :=
    | CondBinary (op: bbinop) (x y: varname)
    | CondNez (x: varname)
  .

  Inductive stmt: Type :=
    | SLoad(sz: Syntax.access_size)(x: varname)(a: varname)(offset: Z)
    | SStore(sz: Syntax.access_size)(a: varname)(v: varname)(offset: Z)
    | SInlinetable(sz: Syntax.access_size)(x: varname)(t: list Byte.byte)(i: varname)
    | SStackalloc(x : varname)(nbytes: Z)(body: stmt)
    | SLit(x: varname)(v: Z)
    | SOp(x: varname)(op: bopname)(y: varname)(z: operand)
    | SSet(x y: varname)
    | SIf(cond: bcond)(bThen bElse: stmt)
    | SLoop(body1: stmt)(cond: bcond)(body2: stmt)
    | SSeq(s1 s2: stmt)
    | SSkip
    | SCall(binds: list varname)(f: String.string)(args: list varname)
    | SInteract(binds: list varname)(a: String.string)(args: list varname).

  Definition stmt_size_body(rec: stmt -> Z)(s: stmt): Z :=
    match s with
    | SLoad sz x a o => 1
    | SStore sz a v o => 1
    | SInlinetable sz x t i => 1 + (Z.of_nat (length t) + 3) / 4 + 2
    | SStackalloc x a body => 1 + rec body
    | SLit x v => 8
    | SOp x op y z => 2
    | SSet x y => 1
    | SIf cond bThen bElse => 1 + (rec bThen) + 1 + (rec bElse)
    | SLoop body1 cond body2 => (rec body1) + 1 + (rec body2) + 1
    | SSeq s1 s2 => (rec s1) + (rec s2)
    | SSkip => 0
    (* TODO only works because all registers are callee-saved.
       And we still need to account for the code emitted by compile_function somewhere. *)
    | SCall binds f args => Z.of_nat (List.length args) + 1 + Z.of_nat (List.length binds)
    | SInteract binds f args => 7 (* TODO don't hardcode a magic number *)
    end.

  Fixpoint stmt_size(s: stmt): Z := stmt_size_body stmt_size s.
  Lemma stmt_size_unfold : forall s, stmt_size s = stmt_size_body stmt_size s.
  Proof. destruct s; reflexivity. Qed.

  Local Arguments Z.add _ _ : simpl never.

  Lemma stmt_size_nonneg: forall s, 0 <= stmt_size s.
  Proof.
    induction s; simpl; try blia.
    assert (0 <= (Z.of_nat (Datatypes.length t) + 3) / 4). {
      apply Z.div_pos; blia.
    }
    blia.
  Qed.

  Fixpoint modVars_as_list(veq: varname -> varname -> bool)(s: stmt): list varname :=
    match s with
    | SSkip | SStore _ _ _ _ => []
    | SStackalloc x n body => list_union veq [x] (modVars_as_list veq body)
    | SLoad _ x _ _ | SLit x _ | SOp x _ _ _ | SSet x _ | SInlinetable _ x _ _ => [x]
    | SIf _ s1 s2 | SLoop s1 _ s2 | SSeq s1 s2 =>
        list_union veq (modVars_as_list veq s1) (modVars_as_list veq s2)
    | SCall binds _ _ | SInteract binds _ _ => list_union veq binds []
    end.

  Definition ForallVars_bcond_gen{R: Type}(and: R -> R -> R)(P: varname -> R)(cond: bcond): R :=
    match cond with
    | CondBinary _ x y => and (P x) (P y)
    | CondNez x => P x
    end.

  Definition Forall_vars_stmt_gen{R: Type}(T: R)(and: R -> R -> R)
             (P_bcond: bcond -> R)
             (P_vars: varname -> R)
             (P_calls: list varname -> list varname -> R): stmt -> R :=
    fix rec s :=
      match s with
      | SLoad _ x a _ => and (P_vars x) (P_vars a)
      | SStore _ a x _ => and (P_vars a) (P_vars x)
      | SInlinetable _ x _ i => and (P_vars x) (P_vars i)
      | SStackalloc x n body => and (P_vars x) (rec body)
      | SLit x _ => P_vars x
      | SOp x _ y z => let op_z := match z with
                                   | Var v => P_vars v
                                   | Const _ => T
                                   end in
                       and (P_vars x) (and (P_vars y) (op_z))
      | SSet x y => and (P_vars x) (P_vars y)
      | SIf c s1 s2 => and (P_bcond c) (and (rec s1) (rec s2))
      | SLoop s1 c s2 => and (P_bcond c) (and (rec s1) (rec s2))
      | SSeq s1 s2 => and (rec s1) (rec s2)
      | SSkip => T
      | SCall binds _ args => P_calls binds args
      | SInteract binds _ args => P_calls binds args
      end.

  Definition ForallVars_bcond(P_vars: varname -> Prop)(cond: bcond): Prop :=
    Eval unfold ForallVars_bcond_gen in ForallVars_bcond_gen and P_vars cond.

  Definition Forall_vars_stmt(P_vars: varname -> Prop): stmt -> Prop :=
    Eval unfold Forall_vars_stmt_gen in
      Forall_vars_stmt_gen True and (ForallVars_bcond P_vars) P_vars
                           (fun binds args => (List.length binds <= 8)%nat /\
                                              (List.length args <= 8)%nat /\
                                              Forall P_vars binds /\
                                              Forall P_vars args).

  Definition forallbVars_bcond(P_vars: varname -> bool)(cond: bcond): bool :=
    Eval unfold ForallVars_bcond_gen in ForallVars_bcond_gen andb P_vars cond.

  Definition forallb_vars_stmt(P_vars: varname -> bool): stmt -> bool :=
    Eval unfold Forall_vars_stmt_gen in
      Forall_vars_stmt_gen true andb (forallbVars_bcond P_vars) P_vars
                           (fun binds args => (List.length binds <=? 8)%nat &&
                                              (List.length args <=? 8)%nat &&
                                              forallb P_vars binds &&
                                              forallb P_vars args).

  Lemma forallb_vars_stmt_correct
        (P: varname -> Prop)(p: varname -> bool)
        (p_correct: forall x, p x = true <-> P x):
    forall s, forallb_vars_stmt p s = true <-> Forall_vars_stmt P s.
  Proof.
    assert (p_correct_fw: forall x, p x = true -> P x). {
      intros. eapply p_correct. assumption.
    }
    assert (p_correct_bw: forall x, P x -> p x = true). {
      intros. eapply p_correct. assumption.
    }
    clear p_correct.
    induction s; split; simpl; intros; unfold ForallVars_bcond, forallbVars_bcond in *;
      repeat match goal with
             | c: bcond |- _ => destruct c
             | H: andb _ _ = true |- _ => eapply Bool.andb_true_iff in H
             | H: (_ <=? _)%nat = true |- _ => eapply Nat.leb_le in H
             | H: _ /\ _ |- _ => destruct H
             | H: _ <-> _ |- _ => destruct H
             | |- andb _ _ = true => apply Bool.andb_true_iff
             | |- _ /\ _ => split
             | |- (_ <=? _)%nat = true => eapply Nat.leb_le
             | y: operand |- _ => destruct y
             end;
      eauto using List.Forall_to_forallb, List.forallb_to_Forall.
  Qed.

  Lemma ForallVars_bcond_impl: forall (P Q: varname -> Prop),
      (forall x, P x -> Q x) ->
      forall s, ForallVars_bcond P s -> ForallVars_bcond Q s.
  Proof.
    intros. destruct s; simpl in *; intuition eauto.
  Qed.

  Lemma Forall_vars_stmt_impl: forall (P Q: varname -> Prop),
      (forall x, P x -> Q x) ->
      forall s, Forall_vars_stmt P s -> Forall_vars_stmt Q s.
  Proof.
    induction s; intros; simpl in *;
      repeat match goal with
          | y : operand |- _ => destruct y
          | _ => intuition eauto using ForallVars_bcond_impl, Forall_impl
          end.
  Qed.
End Syntax.

Arguments bcond: clear implicits.
Arguments stmt: clear implicits.

Local Open Scope Z_scope.

Section FlatImp1.
  Context {varname: Type} {varname_eqb: varname -> varname -> bool}.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width}.
  Context {mem: map.map word byte} {locals: map.map varname word}
          {env: map.map String.string (list varname * list varname * stmt varname)}.
  Context {ext_spec: ExtSpec}.

  Section WithEnv.
    Variable (e: env).

    Definition eval_bbinop(op: bbinop)(x y: word): bool :=
      match op with
      | BEq  => word.eqb x y
      | BNe  => negb (word.eqb x y)
      | BLt  => word.lts x y
      | BGe  => negb (word.lts x y)
      | BLtu => word.ltu x y
      | BGeu => negb (word.ltu x y)
      end.

    Definition eval_bcond(st: locals)(cond: bcond varname): option bool :=
      match cond with
      | CondBinary op x y =>
        match map.get st x, map.get st y with
        | Some mx, Some my => Some (eval_bbinop op mx my)
        | _, _ => None
        end
      | CondNez x =>
        match  map.get st x  with
        | Some mx => Some (negb (word.eqb mx (word.of_Z 0)))
        | None => None
        end
      end.
  End WithEnv.

  (* returns the set of modified vars *)
  Fixpoint modVars(s: stmt varname): set varname :=
    match s with
    | SLoad sz x y o => singleton_set x
    | SStore sz x y o => empty_set
    | SInlinetable sz x t i => singleton_set x
    | SStackalloc x n body => union (singleton_set x) (modVars body)
    | SLit x v => singleton_set x
    | SOp x op y z => singleton_set x
    | SSet x y => singleton_set x
    | SIf cond bThen bElse =>
        union (modVars bThen) (modVars bElse)
    | SLoop body1 cond body2 =>
        union (modVars body1) (modVars body2)
    | SSeq s1 s2 =>
        union (modVars s1) (modVars s2)
    | SSkip => empty_set
    | SCall binds funcname args => of_list binds
    | SInteract binds funcname args => of_list binds
    end.

  Definition accessedVarsBcond(cond: bcond varname): set varname :=
    match cond with
    | CondBinary _ x y =>
        union (singleton_set x) (singleton_set y)
    | CondNez x =>
        singleton_set x
    end.
End FlatImp1.

Module exec.
  Section FlatImpExec.
    Context {varname: Type} {varname_eqb: varname -> varname -> bool}.
    Context {width: Z} {BW: Bitwidth width} {word: word.word width}.
    Context {mem: map.map word byte} {locals: map.map varname word}
            {env: map.map String.string (list varname * list varname * stmt varname)}.
    Context {ext_spec: ExtSpec}.
    Context {varname_eq_spec: EqDecider varname_eqb}
            {word_ok: word.ok word}
            {mem_ok: map.ok mem}
            {locals_ok: map.ok locals}
            {env_ok: map.ok env}
            {ext_spec_ok: ext_spec.ok ext_spec}.

    Variable (e: env).

    Local Notation metrics := MetricLog.

    (* COQBUG(unification finds Type instead of Prop and fails to downgrade *)
    Implicit Types post : trace -> mem -> locals -> metrics -> Prop.

    Definition lookup_op_locals (l: locals) (o: operand) :=
      match o with
      | Var vo => map.get l vo
      | Const co => Some (word.of_Z co)
      end.

    (* alternative semantics which allow non-determinism *)
    Inductive exec:
      stmt varname ->
      trace -> mem -> locals -> metrics ->
      (trace -> mem -> locals -> metrics -> Prop)
    -> Prop :=
    | interact: forall t m mKeep mGive l mc action argvars argvals resvars outcome post,
        map.split m mKeep mGive ->
        map.getmany_of_list l argvars = Some argvals ->
        ext_spec t mGive action argvals outcome ->
        (forall mReceive resvals,
            outcome mReceive resvals ->
            exists l', map.putmany_of_list_zip resvars resvals l = Some l' /\
            forall m', map.split m' mKeep mReceive ->
            post (((mGive, action, argvals), (mReceive, resvals)) :: t) m' l'
                 (addMetricInstructions 1
                 (addMetricStores 1
                 (addMetricLoads 2 mc)))) ->
        exec (SInteract resvars action argvars) t m l mc post
    | call: forall t m l mc binds fname args params rets fbody argvs st0 post outcome,
        map.get e fname = Some (params, rets, fbody) ->
        map.getmany_of_list l args = Some argvs ->
        map.putmany_of_list_zip params argvs map.empty = Some st0 ->
        exec fbody t m st0 (addMetricInstructions 100 (addMetricJumps 100 (addMetricLoads 100 (addMetricStores 100 mc)))) outcome ->
        (forall t' m' mc' st1,
            outcome t' m' st1 mc' ->
            exists retvs l',
              map.getmany_of_list st1 rets = Some retvs /\
              map.putmany_of_list_zip binds retvs l = Some l' /\
              post t' m' l' (addMetricInstructions 100 (addMetricJumps 100 (addMetricLoads 100 (addMetricStores 100 mc'))))) ->
        exec (SCall binds fname args) t m l mc post
        (* TODO think about a non-fixed bound on the cost of function preamble and postamble *)
    | load: forall t m l mc sz x a o v addr post,
        map.get l a = Some addr ->
        load sz m (word.add addr (word.of_Z o)) = Some v ->
        post t m (map.put l x v)
             (addMetricLoads 2
             (addMetricInstructions 1 mc)) ->
        exec (SLoad sz x a o) t m l mc post
    | store: forall t m m' mc l sz a o addr v val post,
        map.get l a = Some addr ->
        map.get l v = Some val ->
        store sz m (word.add addr (word.of_Z o)) val = Some m' ->
        post t m' l
             (addMetricLoads 1
             (addMetricInstructions 1
             (addMetricStores 1 mc))) ->
        exec (SStore sz a v o) t m l mc post
    | inlinetable: forall sz x table i v index t m l mc post,
        (* compiled riscv code uses x as a tmp register and this shouldn't overwrite i *)
        x <> i ->
        map.get l i = Some index ->
        load sz (map.of_list_word table) index = Some v ->
        post t m (map.put l x v)
             (addMetricLoads 4
             (addMetricInstructions 3
             (addMetricJumps 1 mc))) ->
        exec (SInlinetable sz x table i) t m l mc post
    | stackalloc: forall t mSmall l mc x n body post,
        n mod (bytes_per_word width) = 0 ->
        (forall a mStack mCombined,
            anybytes a n mStack ->
            map.split mCombined mSmall mStack ->
            exec body t mCombined (map.put l x a) (addMetricLoads 1 (addMetricInstructions 1 mc))
             (fun t' mCombined' l' mc' =>
              exists mSmall' mStack',
                anybytes a n mStack' /\
                map.split mCombined' mSmall' mStack' /\
                post t' mSmall' l' mc')) ->
        exec (SStackalloc x n body) t mSmall l mc post
    | lit: forall t m l mc x v post,
        post t m (map.put l x (word.of_Z v))
             (addMetricLoads 8
             (addMetricInstructions 8 mc)) ->
        exec (SLit x v) t m l mc post
    | op: forall t m l mc x op y y' z z' post,
        map.get l y = Some y' ->
        lookup_op_locals l z = Some z' ->
        post t m (map.put l x (interp_binop op y' z'))
             (addMetricLoads 2
             (addMetricInstructions 2 mc)) ->
        exec (SOp x op y z) t m l mc post
    | set: forall t m l mc x y y' post,
        map.get l y = Some y' ->
        post t m (map.put l x y')
             (addMetricLoads 1
             (addMetricInstructions 1 mc)) ->
        exec (SSet x y) t m l mc post
    | if_true: forall t m l mc cond  bThen bElse post,
        eval_bcond l cond = Some true ->
        exec bThen t m l
             (addMetricLoads 2
             (addMetricInstructions 2
             (addMetricJumps 1 mc))) post ->
        exec (SIf cond bThen bElse) t m l mc post
    | if_false: forall t m l mc cond bThen bElse post,
        eval_bcond l cond = Some false ->
        exec bElse t m l
             (addMetricLoads 2
             (addMetricInstructions 2
             (addMetricJumps 1 mc))) post ->
        exec (SIf cond bThen bElse) t m l mc post
    | loop: forall t m l mc cond body1 body2 mid1 mid2 post,
        (* This case is carefully crafted in such a way that recursive uses of exec
         only appear under forall and ->, but not under exists, /\, \/, to make sure the
         auto-generated induction principle contains an IH for all recursive uses. *)
        exec body1 t m l mc mid1 ->
        (forall t' m' l' mc',
            mid1 t' m' l' mc' ->
            eval_bcond l' cond <> None) ->
        (forall t' m' l' mc',
            mid1 t' m' l' mc' ->
            eval_bcond l' cond = Some false ->
            post t' m' l'
                 (addMetricLoads 1
                 (addMetricInstructions 1
                 (addMetricJumps 1 mc')))) ->
        (forall t' m' l' mc',
            mid1 t' m' l' mc' ->
            eval_bcond l' cond = Some true ->
            exec body2 t' m' l' mc' mid2) ->
        (forall t'' m'' l'' mc'',
            mid2 t'' m'' l'' mc'' ->
            exec (SLoop body1 cond body2) t'' m'' l''
                 (addMetricLoads 2
                 (addMetricInstructions 2
                 (addMetricJumps 1 mc''))) post) ->
        exec (SLoop body1 cond body2) t m l mc post
    | seq: forall t m l mc s1 s2 mid post,
        exec s1 t m l mc mid ->
        (forall t' m' l' mc', mid t' m' l' mc' -> exec s2 t' m' l' mc' post) ->
        exec (SSeq s1 s2) t m l mc post
    | skip: forall t m l mc post,
        post t m l mc ->
        exec SSkip t m l mc post.

    Lemma det_step: forall t0 m0 l0 mc0 s1 s2 t1 m1 l1 mc1 post,
        exec s1 t0 m0 l0 mc0 (fun t1' m1' l1' mc1' => t1' = t1 /\ m1' = m1 /\ l1' = l1 /\ mc1 = mc1') ->
        exec s2 t1 m1 l1 mc1 post ->
        exec (SSeq s1 s2) t0 m0 l0 mc0 post.
    Proof.
      intros.
      eapply seq; [eassumption|].
      intros. simpl in *. simp.
      assumption.
    Qed.

    Lemma seq_cps: forall s1 s2 t m (l: locals) mc post,
        exec s1 t m l mc (fun t' m' l' mc' => exec s2 t' m' l' mc' post) ->
        exec (SSeq s1 s2) t m l mc post.
    Proof.
      intros. eapply seq. 1: eassumption. simpl. clear. auto.
    Qed.

    Lemma call_cps: forall fname params rets binds args fbody argvs t (l: locals) m mc st post,
        map.get e fname = Some (params, rets, fbody) ->
        map.getmany_of_list l args = Some argvs ->
        map.putmany_of_list_zip params argvs map.empty = Some st ->
        exec fbody t m st (addMetricInstructions 100 (addMetricJumps 100 (addMetricLoads 100 (addMetricStores 100 mc))))
             (fun t' m' st' mc' =>
                exists retvs l',
                  map.getmany_of_list st' rets = Some retvs /\
                    map.putmany_of_list_zip binds retvs l = Some l' /\
                    post t' m' l' (addMetricInstructions 100 (addMetricJumps 100 (addMetricLoads 100 (addMetricStores 100 mc'))))) ->
      exec (SCall binds fname args) t m l mc post.
    Proof.
      intros. eapply call; try eassumption.
      cbv beta. intros *. exact id.
    Qed.

    Lemma loop_cps: forall body1 cond body2 t m l mc post,
      exec body1 t m l mc (fun t m l mc => exists b,
        eval_bcond l cond = Some b /\
        (b = false -> post t m l (addMetricLoads 1 (addMetricInstructions 1 (addMetricJumps 1 mc)))) /\
        (b = true -> exec body2 t m l mc (fun t m l mc =>
           exec (SLoop body1 cond body2) t m l
                (addMetricLoads 2 (addMetricInstructions 2 (addMetricJumps 1 mc))) post))) ->
      exec (SLoop body1 cond body2) t m l mc post.
    Proof.
      intros. eapply loop. 1: eapply H. all: cbv beta; intros; simp.
      - congruence.
      - replace b with false in * by congruence. clear b. eauto.
      - replace b with true in * by congruence. clear b. eauto.
      - assumption.
    Qed.

    Lemma weaken: forall t l m mc s post1,
        exec s t m l mc post1 ->
        forall post2,
          (forall t' m' l' mc', post1 t' m' l' mc' -> post2 t' m' l' mc') ->
          exec s t m l mc post2.
    Proof.
      induction 1; intros; try solve [econstructor; eauto].
      - eapply interact; try eassumption.
        intros; simp.
        edestruct H2; [eassumption|].
        simp. eauto 10.
      - eapply call.
        4: eapply IHexec.
        all: eauto.
        intros. simp.
        specialize H3 with (1 := H5).
        simp. eauto 10.
      - eapply stackalloc. 1: assumption.
        intros.
        eapply H1; eauto.
        intros. simp. eauto 10.
    Qed.

    Lemma seq_assoc: forall s1 s2 s3 t m l mc post,
        exec (SSeq s1 (SSeq s2 s3)) t m l mc post ->
        exec (SSeq (SSeq s1 s2) s3) t m l mc post.
    Proof.
      intros. simp.
      eapply seq_cps.
      eapply seq_cps.
      eapply weaken. 1: eassumption. intros.
      specialize H8 with (1 := H). simp.
      eapply weaken. 1: eassumption. intros.
      eauto.
    Qed.

    Lemma seq_assoc_bw: forall s1 s2 s3 t m l mc post,
        exec (SSeq (SSeq s1 s2) s3) t m l mc post ->
        exec (SSeq s1 (SSeq s2 s3)) t m l mc post.
    Proof. intros. simp. eauto 10 using seq. Qed.

    Ltac equalities :=
      repeat match goal with
             | H1: ?e = ?e1, H2: ?e = ?e2 |- _ =>
               progress (let H := fresh in assert (e1 = e2) as H by congruence; ensure_new H; simp)
             | H1: ?P, H2: ?P |- _ => clear H2
             end;
      simp.

    Lemma intersect: forall t l m mc s post1,
        exec s t m l mc post1 ->
        forall post2,
          exec s t m l mc post2 ->
          exec s t m l mc (fun t' m' l' mc' => post1 t' m' l' mc' /\ post2 t' m' l' mc').
    Proof.
      induction 1; intros;
        match goal with
        | H: exec _ _ _ _ _ _ |- _ => inversion H; subst; clear H
        end;
        equalities;
        try solve [econstructor; eauto | exfalso; congruence].

      - (* SInteract *)
        pose proof ext_spec.unique_mGive_footprint as P.
        specialize P with (1 := H1) (2 := H14).
        destruct (map.split_diff P H H7). subst mKeep0 mGive0.
        eapply @interact.
        + eassumption.
        + eassumption.
        + eapply ext_spec.intersect; [exact H1|exact H14].
        + simpl. intros. simp.
          edestruct H2 as (? & ? & ?); [eassumption|].
          edestruct H15 as (? & ? & ?); [eassumption|].
          simp.
          equalities.
          eauto 10.

      - (* SCall *)
        rename IHexec into IH.
        specialize IH with (1 := H16).
        eapply @call; [..|exact IH|]; eauto.
        rename H3 into Ex1.
        rename H17 into Ex2.
        move Ex1 before Ex2.
        intros. simpl in *. simp.
        edestruct Ex1; [eassumption|].
        edestruct Ex2; [eassumption|].
        simp.
        equalities.
        eauto 10.

      - (* SStackalloc *)
        eapply @stackalloc. 1: eassumption.
        intros.
        rename H0 into Ex1, H12 into Ex2.
        eapply weaken. 1: eapply H1. 1,2: eassumption.
        1: eapply Ex2. 1,2: eassumption.
        cbv beta.
        intros. simp.
        lazymatch goal with
          | A: map.split _ _ _, B: map.split _ _ _ |- _ =>
            specialize @map.split_diff with (4 := A) (5 := B) as P
        end.
        edestruct P; try typeclasses eauto. 2: subst; eauto 10.
        eapply anybytes_unique_domain; eassumption.

      - (* SLoop *)
        eapply @loop.
        + eapply IHexec. exact H10.
        + simpl. intros. simp. eauto.
        + simpl. intros. simp. eauto.
        + simpl. intros. simp. eapply H3; [eassumption..|]. (* also an IH *)
          eapply H18; eassumption.
        + simpl. intros. simp. eapply H5; [eassumption..|]. (* also an IH *)
          eapply H19; eassumption.

      - (* SSeq *)
        pose proof IHexec as IH1.
        specialize IH1 with (1 := H5).
        eapply @seq; [exact IH1|].
        intros; simpl in *.
        destruct H2.
        eauto.
    Qed.

  End FlatImpExec.
End exec.
Notation exec := exec.exec.

Section FlatImp2.
  Context (varname: Type).
  Context {varname_eqb: varname -> varname -> bool}.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width}.
  Context {mem: map.map word byte} {locals: map.map varname word}
          {env: map.map String.string (list varname * list varname * stmt varname)}.
  Context {ext_spec: ExtSpec}.
  Context {varname_eq_spec: EqDecider varname_eqb}
          {word_ok: word.ok word}
          {mem_ok: map.ok mem}
          {locals_ok: map.ok locals}
          {env_ok: map.ok env}
          {ext_spec_ok: ext_spec.ok ext_spec}.

  Definition SimState: Type := trace * mem * locals * MetricLog.
  Definition SimExec(e: env)(c: stmt varname): SimState -> (SimState -> Prop) -> Prop :=
    fun '(t, m, l, mc) post =>
      exec e c t m l mc (fun t' m' l' mc' => post (t', m', l', mc')).

  Lemma modVarsSound: forall e s initialT (initialSt: locals) initialM (initialMc: MetricLog) post,
      exec e s initialT initialM initialSt initialMc post ->
      exec e s initialT initialM initialSt initialMc
           (fun finalT finalM finalSt _ => map.only_differ initialSt (modVars s) finalSt).
  Proof.
    induction 1;
      try solve [ econstructor; [eassumption..|simpl; map_solver locals_ok] ].
    - eapply exec.interact; try eassumption.
      intros; simp.
      edestruct H2; try eassumption. simp.
      eexists; split; [eassumption|].
      simpl. try split; eauto.
      intros.
      eapply map.only_differ_putmany. eassumption.
    - eapply exec.call. 4: exact H2. (* don't pick IHexec! *) all: try eassumption.
      intros; simpl in *; simp.
      edestruct H3; try eassumption. simp.
      do 2 eexists; split; [|split]; try eassumption.
      eapply map.only_differ_putmany. eassumption.
    - eapply exec.stackalloc; try eassumption.
      intros.
      eapply exec.weaken.
      + eapply exec.intersect.
        * eapply H0; eassumption.
        * eapply H1; eassumption.
      + simpl. intros. simp.
        do 2 eexists. split; [eassumption|]. split; [eassumption|]. map_solver locals_ok.
    - eapply exec.if_true; try eassumption.
      eapply exec.weaken; [eassumption|].
      simpl; intros. map_solver locals_ok.
    - eapply exec.if_false; try eassumption.
      eapply exec.weaken; [eassumption|].
      simpl; intros. map_solver locals_ok.
    - eapply @exec.loop with
          (mid1 := fun t' m' l' mc' => mid1 t' m' l' mc' /\
                                   map.only_differ l (modVars body1) l')
          (mid2 := fun t' m' l' mc' => mid2 t' m' l' mc' /\
                                   map.only_differ l (modVars (SLoop body1 cond body2)) l').
      + eapply exec.intersect; eassumption.
      + intros. simp. eauto.
      + intros. simp. simpl. map_solver locals_ok.
      + intros. simp. simpl in *.
        eapply exec.intersect; [eauto|].
        eapply exec.weaken.
        * eapply H3; eassumption.
        * simpl. intros. map_solver locals_ok.
      + intros. simp. simpl in *.
        eapply exec.weaken.
        * eapply H5; eassumption.
        * simpl. intros. map_solver locals_ok.
    - eapply @exec.seq with
          (mid := fun t' m' l' mc' => mid t' m' l' mc' /\ map.only_differ l (modVars s1) l').
      + eapply exec.intersect; eassumption.
      + simpl; intros. simp.
        eapply exec.weaken; [eapply H1; eauto|].
        simpl; intros.
        map_solver locals_ok.
  Qed.

End FlatImp2.


(** * Definition of the generic part of the interface of the correctness proof of the CFG parser *)
Require Import Coq.Classes.Morphisms.
Require Import Coq.Arith.EqNat.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.GenericBaseTypes.
Require Import Fiat.Parsers.BaseTypes.

Set Implicit Arguments.

Section correctness.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {predata : @parser_computational_predataT Char}
          {gendata : @generic_parser_dataT Char}.

  Class generic_parser_correctness_dataT :=
    { parse_nt_is_correct
      : forall (str : String)
               (nt : nonterminal_carrierT)
               (expected_result : bool)
               (actual_result : parse_nt_T),
        Prop;
      parse_item_is_correct
      : forall (str : String)
               (it : item Char)
               (expected_result : bool)
               (actual_result : parse_item_T),
          Prop;
      parse_production_is_correct
      : forall (str : String)
               (p : production_carrierT)
               (expected_result : bool)
               (actual_result : parse_production_T),
          Prop;
      parse_productions_is_correct
      : forall (str : String)
               (p : list production_carrierT)
               (expected_result : bool)
               (actual_result : parse_productions_T),
          Prop;

      parse_nt_is_correct_Proper
      : Proper (beq ==> eq ==> eq ==> eq ==> Basics.impl) parse_nt_is_correct;
      parse_item_is_correct_Proper
      : Proper (beq ==> eq ==> eq ==> eq ==> Basics.impl) parse_item_is_correct;
      parse_production_is_correct_Proper
      : Proper (beq ==> eq ==> eq ==> eq ==> Basics.impl) parse_production_is_correct;
      parse_productions_is_correct_Proper
      : Proper (beq ==> eq ==> eq ==> eq ==> Basics.impl) parse_productions_is_correct;

      parse_nt_is_correct_disjoint
      : forall str nt v,
          parse_nt_is_correct str nt true v -> parse_nt_is_correct str nt false v -> False;
      parse_item_is_correct_disjoint
      : forall str it v,
          parse_item_is_correct str it true v -> parse_item_is_correct str it false v -> False;
      parse_production_is_correct_disjoint
      : forall str p v,
          parse_production_is_correct str p true v -> parse_production_is_correct str p false v -> False;
      parse_productions_is_correct_disjoint
      : forall str ps v,
          parse_productions_is_correct str ps true v -> parse_productions_is_correct str ps false v -> False;

      ret_Terminal_true_correct
      : forall str offset len ch,
          len = 0 \/ offset + len <= length str
          -> (beq_nat len 1 && char_at_matches offset str ch)%bool = true
          -> parse_item_is_correct
               (substring offset len str) (Terminal ch)
               true (ret_Terminal_true (unsafe_get offset str));
      ret_Terminal_false_correct
      : forall str it ch,
          parse_item_is_correct str it false (ret_Terminal_false ch);
      ret_NonTerminal_true_correct
      : forall str nt b rv,
          is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) = true
          -> parse_nt_is_correct str (of_nonterminal nt) b rv
          -> parse_item_is_correct str (NonTerminal nt) b (ret_NonTerminal_true nt rv);
      ret_NonTerminal_false_correct
      : forall str nt,
          parse_item_is_correct str (NonTerminal nt) false (ret_NonTerminal_false nt);
      ret_production_nil_true_is_correct
      : forall str offset len prod_idx,
          to_production prod_idx = nil ->
          len = 0 ->
          parse_production_is_correct
            (substring offset len str) prod_idx
            true ret_production_nil_true;
      ret_production_nil_false_is_correct
      : forall str prod_idx,
          parse_production_is_correct str prod_idx false ret_production_nil_false;
      ret_orb_production_base_is_correct
      : forall str prod_idx,
          parse_production_is_correct str prod_idx false ret_orb_production_base;
      ret_orb_production_is_correct
      : forall str prod_idx b1 b2 rv1 rv2,
          parse_production_is_correct str prod_idx b1 rv1
          -> parse_production_is_correct str prod_idx b2 rv2
          -> parse_production_is_correct str prod_idx (orb b1 b2) (ret_orb_production rv1 rv2);
      ret_production_cons_is_correct
      : forall str offset len split_loc prod_idx it its b1 b2 rv1 rv2,
          to_production prod_idx = cons it its
          -> parse_item_is_correct (substring offset (min split_loc len) str) it b1 rv1
          -> parse_production_is_correct (substring (offset + split_loc) (len - split_loc) str) (production_tl prod_idx) b2 rv2
          -> parse_production_is_correct (substring offset len str) prod_idx (andb b1 b2) (ret_production_cons rv1 rv2);
      ret_orb_productions_base_is_correct
      : forall str prods,
          parse_productions_is_correct str prods false ret_orb_productions_base;
      ret_orb_productions_is_correct
      : forall str p ps b1 b2 rv1 rv2,
          parse_production_is_correct str p b1 rv1
          -> parse_productions_is_correct str ps b2 rv2
          -> parse_productions_is_correct str (p::ps) (orb b1 b2) (ret_orb_productions rv1 rv2);
      ret_nt_is_correct
      : forall str nt b v,
          is_valid_nonterminal initial_nonterminals_data nt = true
          -> parse_productions_is_correct str (nonterminal_to_production nt) b v
          -> parse_nt_is_correct str nt b (ret_nt (to_nonterminal nt) v);
      ret_nt_invalid_is_correct
      : forall str nt,
          parse_nt_is_correct str nt false ret_nt_invalid
    }.

  Section better_proper.
    Local Existing Instances parse_nt_is_correct_Proper parse_item_is_correct_Proper parse_production_is_correct_Proper parse_productions_is_correct_Proper.
    Local Ltac t :=
      repeat intro; subst;
      match goal with
      | [ H : beq _ _ |- _ ] => symmetry in H
      end;
      let R := match goal with |- ?R _ _ _ _ => R end in
      let c := constr:(_ : Proper _ R) in
      eapply c; first [ eassumption | reflexivity ].
    Global Instance parse_nt_is_correct_Proper_useful
      : Proper (eq ==> beq ==> eq ==> eq ==> eq ==> Basics.flip Basics.impl) (@parse_nt_is_correct).
    Proof. t. Qed.
    Global Instance parse_item_is_correct_Proper_useful
      : Proper (eq ==> beq ==> eq ==> eq ==> eq ==> Basics.flip Basics.impl) (@parse_item_is_correct).
    Proof. t. Qed.
    Global Instance parse_production_is_correct_Proper_useful
      : Proper (eq ==> beq ==> eq ==> eq ==> eq ==> Basics.flip Basics.impl) (@parse_production_is_correct).
    Proof. t. Qed.
    Global Instance parse_productions_is_correct_Proper_useful
      : Proper (eq ==> beq ==> eq ==> eq ==> eq ==> Basics.flip Basics.impl) (@parse_productions_is_correct).
    Proof. t. Qed.
  End better_proper.
End correctness.

Create HintDb generic_parser_correctness discriminated.
#[global]
Hint Resolve ret_Terminal_true_correct ret_Terminal_false_correct ret_NonTerminal_true_correct ret_NonTerminal_false_correct ret_production_nil_true_is_correct ret_production_nil_false_is_correct ret_orb_production_base_is_correct ret_orb_production_is_correct ret_production_cons_is_correct ret_orb_productions_base_is_correct ret_orb_productions_is_correct ret_nt_is_correct ret_nt_invalid_is_correct : generic_parser_correctness.


Require Import VST.floyd.proofauto.
Require Import WandDemo.wand_frame.

Ltac pull_left_wand :=
   match goal with
   | |- ?A |-- _ =>
       match A with
       | context [?P -* ?Q] =>
           let frame := fresh "frame" in evar (frame: list mpred);
           apply derives_trans with ((P -* Q) * fold_right_sepcon frame);
           [ solve [cancel] | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp]
       end
   end.

Ltac right_ver :=
   match goal with
   | |- (?P -* ?Q) * ?A |-- _ =>
       match A with
       | context [?Q -* ?R] =>
           let frame := fresh "frame" in evar (frame: list mpred);
           apply derives_trans with ((P -* Q) * ((Q -* R) * fold_right_sepcon frame));
           [ apply sepcon_derives; [apply derives_refl | solve [cancel]]
           | rewrite <- sepcon_assoc;
             eapply derives_trans;
             [ apply sepcon_derives; [apply wand_frame_ver | apply derives_refl]
             | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp ]]
       end
   end.

Ltac left_ver :=
   match goal with
   | |- (?Q -* ?R) * ?A |-- _ =>
       match A with
       | context [?P -* ?Q] =>
           let frame := fresh "frame" in evar (frame: list mpred);
           apply derives_trans with ((Q -* R) * ((P -* Q) * fold_right_sepcon frame));
           [ apply sepcon_derives; [apply derives_refl | solve [cancel]]
           | rewrite <- sepcon_assoc;
             eapply derives_trans;
             [ apply sepcon_derives; [rewrite sepcon_comm; apply wand_frame_ver | apply derives_refl]
             | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp ]]
       end
   end.

Ltac apply_wand_frame_ver :=
  try (
    pull_left_wand;
    repeat right_ver;
    repeat left_ver;
    match goal with
    | |- (?P -* ?Q) * ?A |-- _ =>
           let PQ := fresh "PQ" in
           set (PQ := P -* Q);
           apply_wand_frame_ver;
           subst PQ
    end).

Ltac apply_one_wand_frame_elim :=
  match goal with
  | |- (?P -* ?Q) * ?A |-- _ =>
       let frame := fresh "frame" in evar (frame: list mpred);
       apply derives_trans with (P * (P -* Q) * fold_right_sepcon frame);
       [ solve [cancel]
       | eapply derives_trans;
         [ apply sepcon_derives; [apply wand_frame_elim | apply derives_refl]
         | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp ]]
   end.

Ltac apply_wand_frame_elim :=
  repeat (
    pull_left_wand;
    apply_one_wand_frame_elim
  ).

Goal forall A B C D E F G H: mpred, (B -* C) * E * (A -* B) * (F -* G) * (C -* D) * (G -* H) |-- A * F -* D * E * H.
  intros.
  apply_wand_frame_ver.
  apply -> wand_sepcon_adjoint.
  apply_wand_frame_elim.
  cancel.
Qed.


Require Import ChargeCore.Logics.ILogic.
Require Import Setoid Morphisms RelationClasses Program.Basics Omega.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section ILogicEmbed.
  Context {A} `{ILOpsA: ILogicOps A}.
  Context {B} `{ILOpsB: ILogicOps B}.

  Class EmbedOp : Type := { embed : A -> B }.

  Class Embed {EmbOp: EmbedOp} : Type := {
     embed_sound p q : p |-- q -> embed p |-- embed q;

     embedlforall T f : Forall x : T, embed (f x) -|- embed (Forall x : T, f x);
     embedlexists T f : Exists x : T, embed (f x) -|- embed (Exists x : T, f x);
     embedImpl a b : (embed a) -->> (embed b) -|- embed (a -->> b)
  }.
End ILogicEmbed.

Arguments EmbedOp _ _ : clear implicits.
Arguments Embed _ {ILOpsA} _ {ILOpsB EmbOp} : rename.

Section ILogicEmbedOps.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.

  Definition lembedand (a : A) (b : B) := (embed a) //\\ b.
  Definition lembedimpl (a : A) (b : B) := (embed a) -->> b.

End ILogicEmbedOps.

Section ILEmbedId.

  Context {A : Type} `{ILA : ILogic A}.

  Instance EmbedOpId : EmbedOp A A := { embed := id }.
  Global Instance EmbedId : Embed A A.
  Proof.
    split; firstorder.
  Qed.

End ILEmbedId.

Section ILogicEmbedCompose.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.
  Context {C} {HC: ILogicOps C} {HE: EmbedOp B C} {HBC : Embed B C} {ILC: ILogic C}.

  Instance embedOpCompose : EmbedOp A C := { embed := fun x => embed (embed x) }.

  Program Instance embedCompose : Embed A C.
  Next Obligation.
  	do 2 apply embed_sound; assumption.
  Qed.
  Next Obligation.
  	split;
  	rewrite embedlforall; apply embed_sound; rewrite embedlforall; reflexivity.
  Qed.
  Next Obligation.
  	split;
  	rewrite embedlexists; apply embed_sound; rewrite embedlexists; reflexivity.
  Qed.
  Next Obligation.
  	split;
  	rewrite embedImpl; apply embed_sound; rewrite embedImpl; reflexivity.
  Qed.

End ILogicEmbedCompose.

Infix "/\\" := lembedand (at level 75, right associativity).
Infix "->>" := lembedimpl (at level 77, right associativity).

Section ILogicEmbedFacts.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.

  Global Instance embed_lentails_m :
    Proper (lentails ==> lentails) embed.
  Proof.
    intros a b Hab; apply embed_sound; assumption.
  Qed.

  Global Instance embed_lequiv_m :
    Proper (lequiv ==> lequiv) embed.
  Proof.
    intros a b Hab; split; destruct Hab; apply embed_sound; assumption.
  Qed.

  Global Instance lembedimpl_lentails_m:
    Proper (lentails --> lentails ++> lentails) lembedimpl.
  Proof.
    intros P P' HP Q Q' HQ; red in HP.
    unfold lembedimpl. rewrite <- HP, HQ; reflexivity.
  Qed.

  Global Instance lembedimpl_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) lembedimpl.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply lembedimpl_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance lembedand_lentails_m:
    Proper (lentails ==> lentails ==> lentails) lembedand.
  Proof.
    intros P P' HP Q Q' HQ.
    unfold lembedand. rewrite HP, HQ. reflexivity.
  Qed.

  Global Instance lembedand_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) lembedand.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply lembedand_lentails_m; (apply HP || apply HQ).
  Qed.

  Lemma embedland a b : embed a //\\ embed b -|- embed (a //\\ b).
  Proof.
    do 2 rewrite land_is_forall; rewrite <- embedlforall; split;
    apply lforallR; intro x; apply lforallL with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlor a b : embed a \\// embed b -|- embed (a \\// b).
  Proof.
    do 2 rewrite lor_is_exists; erewrite <- embedlexists; split;
    apply lexistsL; intro x; apply lexistsR with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlfalse : embed lfalse -|- lfalse.
  Proof.
    rewrite lfalse_is_exists; erewrite <- embedlexists; split;
    [apply lexistsL; intro x; destruct x | apply lfalseL].
  Qed.

  Lemma embedltrue : embed ltrue -|- ltrue.
  Proof.
    rewrite ltrue_is_forall; rewrite <- embedlforall; split;
    [apply ltrueR | apply lforallR; intro x; destruct x].
  Qed.

  Lemma embedlandC (P R : B) (Q : A) : P //\\ Q /\\ R -|- Q /\\ P //\\ R.
  Proof.
  	unfold lembedand; rewrite <- landA, (landC P), landA; reflexivity.
  Qed.

  Lemma embedlimplC (P R : B) (Q : A) : P -->> Q ->> R -|- Q ->> P -->> R.
  Proof.
    unfold lembedimpl. do 2 rewrite limplAdj2.
    rewrite landC. reflexivity.
  Qed.

  Lemma limpllandC (P Q R : B) : P //\\ (Q -->> R) |-- Q -->> P //\\ R.
  Proof.
  	apply limplAdj; rewrite landA; apply landR.
  	+ apply landL1. reflexivity.
  	+ apply landL2. apply limplL; [reflexivity | apply landL1; reflexivity].
  Qed.

  Lemma embed_existsL (P : A) : Exists x : |-- P, ltrue |-- embed P.
  Proof.
  	apply lexistsL; intro H.
  	rewrite <- H. rewrite embedltrue. apply ltrueR.
  Qed.

End ILogicEmbedFacts.

Section EmbedProp.
  Context {A : Type} `{HIL: ILogic A} {HPropOp: EmbedOp Prop A} {HProp: Embed Prop A}.

  Lemma embedPropExists (p : Prop) : embed p |-- Exists x : p, ltrue.
  Proof.
    assert (p |-- Exists x : p, (|-- ltrue)). {
      intros Hp. exists Hp. apply ltrueR.
    } etransitivity.
    rewrite H. reflexivity.
    rewrite <- embedlexists. apply lexistsL. intros Hp.
    apply lexistsR with Hp. apply ltrueR.
  Qed.

  Lemma embedPropExistsL (p : Prop) (P : A) : Exists x : p, P |-- embed p.
  Proof.
    assert (Exists x : p, ltrue |-- p). {
      intros HP. destruct HP as [HP _]. apply HP.
    }
    etransitivity; [|rewrite <- H]; [reflexivity|].
    rewrite <- embedlexists. apply lexistsL; intro Hp.
    apply lexistsR with Hp. rewrite embedltrue. apply ltrueR.
  Qed.

  (* TODO rename embedPropExists to embedPropExistsR *)
  Lemma embedPropExists' (p : Prop) : Exists x : p, ltrue -|- embed p.
  Proof.
  	split; [apply embedPropExistsL | apply embedPropExists].
  Qed.

  Lemma embedPropL (p : Prop) C (H: p -> |-- C) :
    embed p |-- C.
  Proof.
  	rewrite embedPropExists.
  	apply lexistsL; intro Hp.
  	apply H; apply Hp.
  Qed.

  Lemma embedPropR (p : Prop) (P : A) (H : p) : P |-- embed p.
  Proof.
    assert (ltrue |-- p) by (intros _; assumption).
    rewrite <- H0, embedltrue; apply ltrueR.
  Qed.

  Lemma lpropandL (p: Prop) Q C (H: p -> Q |-- C) :
    p /\\ Q |-- C.
  Proof.
    unfold lembedand.
    apply landAdj.
    apply embedPropL.
    intros Hp.
    apply limplAdj.
    apply landL2.
    apply H. assumption.
  Qed.

  Lemma lpropandR C (p: Prop) Q (Hp: p) (HQ: C |-- Q) :
    C |-- p /\\ Q.
  Proof.
    unfold lembedand.
    apply landR; [|assumption].
    rewrite <- embedPropR. apply ltrueR. assumption.
  Qed.

  Lemma lpropimplL (p: Prop) (Q C: A) (Hp: p) (HQ: Q |-- C) :
    p ->> Q |-- C.
  Proof.
    unfold lembedimpl.
    rewrite <- embedPropR, limplTrue; assumption.
  Qed.

  Lemma lpropimplR C (p: Prop) Q (H: p -> C |-- Q) :
    C |-- p ->> Q.
  Proof.
    unfold lembedimpl.
    apply limplAdj. rewrite landC. apply lpropandL. assumption.
  Qed.

  (* Derivable but useful *)
  Lemma lpropandTrue P : True /\\ P -|- P.
  Proof.
    split.
    + apply lpropandL; intros _; reflexivity.
    + apply landR.
      * replace True with (@ltrue Prop _) by reflexivity.
        rewrite embedltrue. apply ltrueR.
      * reflexivity.
  Qed.

  Lemma lpropandFalse P : False /\\ P -|- lfalse.
  Proof.
    split.
    + apply lpropandL; intros H; destruct H.
    + apply lfalseL.
  Qed.

End EmbedProp.

Section EmbedProp'.
  Context {A : Type} `{HILA: ILogic A} {HPropOpA: EmbedOp Prop A} {HPropA: Embed Prop A}.
  Context {B : Type} `{HILB: ILogic B} {HPropOpB: EmbedOp Prop B} {HPropB: Embed Prop B}.
  Context {HEmbOp : EmbedOp B A} {Hemb: Embed B A}.

  Lemma lpropandAL (p : B) (q : A) (P : Prop) : P /\\ p /\\ q |-- (P /\\ p) /\\ q.
  Proof.
    apply lpropandL; intros HP; apply landR.
    + apply landL1; apply embed_sound; apply landR.
      * apply embedPropR. assumption.
      * reflexivity.
    + apply landL2; reflexivity.
  Qed.

  Lemma lpropandAC (p : B) (q : A) (P : Prop) : p /\\ P /\\ q -|- P /\\ p /\\ q.
  Proof.
  	unfold lembedand. do 2 rewrite <- landA; rewrite (landC (embed p)); reflexivity.
  Qed.

  Lemma lpropandAR (p : B) (q : A) (P : Prop) : (P /\\ p) /\\ q |-- P /\\ p /\\ q.
  Proof.
  	apply landR.
  	+ apply landL1.
  	  unfold lembedand; rewrite <- embedland; apply landL1.
  	  rewrite embedPropExists, <- embedlexists.
  	  apply lexistsL; intro Hp.
  	  apply embedPropR; apply Hp.
  	+ unfold lembedand; rewrite <- embedland; apply landR.
  	  * apply landL1; apply landL2. reflexivity.
  	  * apply landL2; reflexivity.
 Qed.

 Lemma lpropimplAL (p : B) (q : A) (P : Prop) : (P ->> p) /\\ q |-- P ->> (p /\\ q).
 Proof.
    unfold lembedimpl, lembedand. apply limplAdj. rewrite landA.
    rewrite <- embedImpl. apply limplL. apply landL2.
    rewrite embedPropExists. apply lexistsL; intro Hp.
    rewrite <- (embedPropR ltrue); [apply embedltrue | apply Hp].
    apply landR; [apply landL1|apply landL2; apply landL1]; reflexivity.
 Qed.

 Lemma lpropimplAR (p : B) (q : A) (P : Prop) : p /\\ (P ->> q) |-- P ->> (p /\\ q).
 Proof.
    unfold lembedimpl, lembedand. rewrite landC. apply limplAdj. rewrite landA.
    apply limplL. apply landL2; reflexivity.
    apply landR; [apply landL2; apply landL1|apply landL1]; reflexivity.
 Qed.

  Lemma embedPropR2 (p : Prop) (P : A) (H : p) : P |-- embed (embed p).
  Proof.
    assert (ltrue |-- p) by (intros _; assumption).
    rewrite <- H0. do 2 rewrite embedltrue. apply ltrueR.
  Qed.

  Lemma embedPropL2 (p : Prop) (C : A) (H: p -> |-- C) :
    embed (embed p) |-- C.
  Proof.
  	rewrite embedPropExists, <- embedlexists.
  	apply lexistsL; intro Hp. rewrite embedltrue.
  	apply H; apply Hp.
  Qed.

End EmbedProp'.

Section EmbedPropProp.

Instance EmbedOpPropProp : EmbedOp Prop Prop := { embed := fun P => P }.
Instance EmbedPropProp : Embed Prop Prop.
Proof.
  split; firstorder.
Qed.

End EmbedPropProp.

Section EmbedPropInj.
  Context {A : Type} `{ILA : ILogic A}.
  Context {EmbOp1 : EmbedOp Prop A} {Emb1 : Embed Prop A}.
  Context {EmbOp2 : EmbedOp Prop A} {Emb2 : Embed Prop A}.

  Lemma emb_prop_eq (P : Prop) : @embed _ _ EmbOp1 P -|- @embed _ _ EmbOp2 P.
  Proof.
    split; rewrite embedPropExists; apply lexistsL; intro Hp;
      (rewrite <- (embedPropR ltrue); [apply ltrueR | apply Hp]).
  Qed.

End EmbedPropInj.


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

Implicit Types t : val.

Record random `{!heapGS Σ} {unboxed : bool} := {
  random_make : val ;
  random_gen : val ;

  random_inv : val → iProp Σ ;

  random_inv_persistent t :
    Persistent (random_inv t) ;

  random_make_spec :
    {{{ True }}}
      random_make #()
    {{{ t, RET t; random_inv t }}} ;

  random_gen_spec t (ub : Z) :
    (0 < ub)%Z →
    {{{ random_inv t }}}
      random_gen t #ub
    {{{ n, RET #n; ⌜0 ≤ n < ub⌝%Z }}} ;

  random_unboxed :
    if unboxed then ∀ t,
      random_inv t -∗
      ⌜val_is_unboxed t⌝
    else
      True ;
}.
#[global] Arguments random _ {_} _ : assert.
#[global] Arguments Build_random {_ _} _ {_ _ _ _} _ _ _ : assert.
#[global] Existing Instance random_inv_persistent.

Section random.
  Context `{!heapGS Σ} {unboxed} (random : random Σ unboxed).

  Definition random_gen_Z : val :=
    λ: "t" "lb" "ub",
      "lb" + random.(random_gen) "t" ("ub" - "lb").
  Definition random_gen_nat :=
    random_gen_Z.
  Definition random_gen_bool : val :=
    λ: "t",
      random.(random_gen) "t" #2.

  Lemma random_gen_Z_spec t lb ub :
    (lb < ub)%Z →
    {{{ random.(random_inv) t }}}
      random_gen_Z t #lb #ub
    {{{ n, RET #n; ⌜lb ≤ n < ub⌝%Z }}}.
  Proof.
    iIntros "%Hlt %Φ Hinv HΦ".
    wp_rec. wp_pures.
    wp_apply (random_gen_spec with "Hinv"); first lia. iIntros "%n %Hn".
    wp_pures.
    iApply "HΦ". iPureIntro. lia.
  Qed.
  Lemma random_gen_nat_spec t lb ub :
    lb < ub →
    {{{ random.(random_inv) t }}}
      random_gen_nat t #lb #ub
    {{{ n, RET #n; ⌜lb ≤ n < ub⌝ }}}.
  Proof.
    iIntros "%Hlt %Φ Hinv HΦ".
    wp_rec. wp_pures.
    wp_apply (random_gen_spec with "Hinv"); first lia. iIntros "%n %Hn".
    wp_pures.
    destruct (Z_of_nat_complete n) as (m & ->); first lia.
    assert ((lb + m)%Z = lb + m) as -> by lia.
    iApply "HΦ". iPureIntro. lia.
  Qed.
  Lemma random_gen_bool_spec t :
    {{{ random.(random_inv) t }}}
      random_gen_bool t
    {{{ b, RET #(bool_to_Z b); True }}}.
  Proof.
    iIntros "%Φ Hinv HΦ".
    wp_rec. wp_pures.
    wp_apply (random_gen_spec with "Hinv"); first done. iIntros "%n %Hn".
    assert (∃ (b : bool), n = bool_to_Z b) as (b & ->).
    { assert (n = 0 ∨ n = 1) as [-> | ->] by lia; [exists false | exists true]; done. }
    iApply "HΦ". done.
  Qed.
End random.

#[global] Opaque random_gen_Z.
#[global] Opaque random_gen_nat.
#[global] Opaque random_gen_bool.