From iris.program_logic Require Export language ectx_language ectxi_language.
From iris_io.prelude Require Export base.
From iris_io Require Export lang_proph_erased.
From iris.algebra Require Export ofe.
From stdpp Require Import gmap.

Module Plang_fully_erased.

  Record fully_erased_state : Type :=
    { FEHeap : gmap loc val;
      FEProph : (gset loc);
      FEIO : list (ioTag * val * val)
    }.

  Definition update_FEheap σ h :=
    {| FEHeap := h; FEProph := FEProph σ; FEIO := FEIO σ |}.

  Definition update_FEproph σ ι :=
    {| FEHeap := FEHeap σ; FEProph := ι; FEIO := FEIO σ |}.

   Definition update_FEIO σ τ :=
    {| FEHeap := FEHeap σ; FEProph := FEProph σ; FEIO := τ |}.

  Inductive fully_erased_head_step :
    expr → fully_erased_state → expr → fully_erased_state → list expr → Prop :=
  (* β *)
  | FEBetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      fully_erased_head_step (App (Rec e1) e2) σ e1.[(Rec e1), e2/] σ []
  | FEZetaS e1 e2 v1 σ :
      to_val e1 = Some v1 →
      fully_erased_head_step (LetIn e1 e2) σ e2.[e1/] σ []
  | FELamBetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      fully_erased_head_step (App (Lam e1) e2) σ e1.[e2/] σ []
  | FESeqS e1 e2 v1 σ :
      to_val e1 = Some v1 →
      fully_erased_head_step (Seq e1 e2) σ e2 σ []
  (* Products *)
  | FEFstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      fully_erased_head_step (Fst (Pair e1 e2)) σ e1 σ []
  | FESndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      fully_erased_head_step (Snd (Pair e1 e2)) σ e2 σ []
  (* Sums *)
  | FECaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      fully_erased_head_step (Case (InjL e0) e1 e2) σ e1.[e0/] σ []
  | FECaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      fully_erased_head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ []
    (* nat bin op *)
  | FEBinOpS op a b σ :
      fully_erased_head_step (BinOp op (#n a) (#n b)) σ (of_val (binop_eval op a b)) σ []
  (* If then else *)
  | FEIfFalse e1 e2 σ :
      fully_erased_head_step (If (#♭ false) e1 e2) σ e2 σ []
  | FEIfTrue e1 e2 σ :
      fully_erased_head_step (If (#♭ true) e1 e2) σ e1 σ []
  (* Recursive Types *)
  | FEUnfold_Fold e v σ :
      to_val e = Some v →
      fully_erased_head_step (Unfold (Fold e)) σ e σ []
  (* Polymorphic Types *)
  | FETBeta e σ :
      fully_erased_head_step (TApp (TLam e)) σ e σ []
  (* Concurrency *)
  | FEForkS e σ:
      fully_erased_head_step (Fork e) σ Unit σ [e]
  (* Reference Types *)
  | FEAllocS e v σ l :
     to_val e = Some v → (FEHeap σ) !! l = None →
     fully_erased_head_step (Alloc e) σ (Loc l) (update_FEheap σ (<[l:=v]>(FEHeap σ))) []
  | FELoadS l v σ :
     (FEHeap σ) !! l = Some v →
     fully_erased_head_step (Load (Loc l)) σ (of_val v) σ []
  | FEStoreS l e v σ :
     to_val e = Some v → is_Some ((FEHeap σ) !! l) →
     fully_erased_head_step (Store (Loc l) e) σ Unit (update_FEheap σ (<[l:=v]>(FEHeap σ))) []
  (* Compare and swap *)
  | FECasFailS l e1 v1 e2 v2 vl σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     (FEHeap σ) !! l = Some vl → vl ≠ v1 →
     fully_erased_head_step (CAS (Loc l) e1 e2) σ (#♭ false) σ []
  | FECasSucS l e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     (FEHeap σ) !! l = Some v1 →
     fully_erased_head_step (CAS (Loc l) e1 e2) σ (#♭ true) (update_FEheap σ (<[l:=v2]>(FEHeap σ))) []
  (* Prophecy operational semantics *)
  | FECreate_PrS σ :
      fully_erased_head_step Create_Pr σ (Pr (fresh (FEProph σ)))
                       (update_FEproph σ ({[fresh (FEProph σ)]} ∪ (FEProph σ))) []
  | FEAssignS e v e' v' σ :
      to_val e = Some v → to_val e' = Some v' →
     fully_erased_head_step (Assign_Pr e e') σ Unit σ []
  | FERandS b σ : fully_erased_head_step Rand σ (Bool b) σ []
  | FEIOS t e v v' σ : to_val e = Some v →
                    fully_erased_head_step (IO (IOtag t) e) σ (of_val v')
                              (update_FEIO σ ((FEIO σ) ++ [(t, v, v')])) [].

  (** Basic properties about the language *)
  Lemma val_stuck e1 σ1 e2 σ2 ef :
    fully_erased_head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 e2 σ2 ef :
    fully_erased_head_step (fill_item Ki e) σ1 e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom (gset loc) (FEHeap σ)) in
    to_val e = Some v → fully_erased_head_step (Alloc e) σ (Loc l)
                                         (update_FEheap σ (<[l:=v]>(FEHeap σ))) [].
  Proof. by intros; apply FEAllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.

  Lemma val_head_stuck e1 σ1 e2 σ2 efs : fully_erased_head_step e1 σ1 e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item
                                        fully_erased_head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.

End Plang_fully_erased.

Canonical Structure PFE_ectxi_lang :=
  EctxiLanguage Plang_fully_erased.lang_mixin.
Canonical Structure PFE_ectx_lang :=
  EctxLanguageOfEctxi PFE_ectxi_lang.
Canonical Structure PFE_lang :=
  LanguageOfEctx PFE_ectx_lang.

Export Plang_fully_erased.


(* Generated by coq-of-rust *)
Require Import CoqOfRust.CoqOfRust.

Import Root.std.prelude.rust_2015.

Module checked.
  Module MathError.
    Inductive t : Set :=
    | DivisionByZero
    | NonPositiveLogarithm
    | NegativeSquareRoot.
  End MathError.
  Definition MathError := MathError.t.

  Module Impl__crate_fmt_Debug_for_MathError.
    Definition Self := MathError.

    Definition fmt
        (self : ref Self)
        (f : mut_ref _crate.fmt.Formatter)
        : _crate.fmt.Result :=
      match self with
      | MathError.DivisionByZero =>
        _crate.fmt.ImplFormatter.write_str f "DivisionByZero"
      | MathError.NonPositiveLogarithm =>
        _crate.fmt.ImplFormatter.write_str f "NonPositiveLogarithm"
      | MathError.NegativeSquareRoot =>
        _crate.fmt.ImplFormatter.write_str f "NegativeSquareRoot"
      end.

    Global Instance M_fmt : Method "fmt" _ := {|
      method := fmt;
    |}.
    Global Instance AF_fmt : MathError.AssociatedFunction "fmt" _ := {|
      MathError.associated_function := fmt;
    |}.
    Global Instance AFT_fmt : _crate.fmt.Debug.AssociatedFunction "fmt" _ := {|
      _crate.fmt.Debug.associated_function := fmt;
    |}.

    Global Instance I : _crate.fmt.Debug.Class Self := {|
      _crate.fmt.Debug.fmt := fmt;
    |}.
  End Impl__crate_fmt_Debug_for_MathError.

  Definition MathResult : Set := Result.

  Definition div (x : f64) (y : f64) : MathResult :=
    if (eqb y 0 (* 0.0 *) : bool) then
      Err MathError.DivisionByZero
    else
      Ok (div x y).

  Definition sqrt (x : f64) : MathResult :=
    if (lt x 0 (* 0.0 *) : bool) then
      Err MathError.NegativeSquareRoot
    else
      Ok (method "sqrt" x).

  Definition ln (x : f64) : MathResult :=
    if (le x 0 (* 0.0 *) : bool) then
      Err MathError.NonPositiveLogarithm
    else
      Ok (method "ln" x).

  Definition op_ (x : f64) (y : f64) : MathResult :=
    let ratio :=
      match branch (div x y) with
      | Break {| Break.0 := residual; |} => Return (from_residual residual)
      | Continue {| Continue.0 := val; |} => val
      end in
    let ln :=
      match branch (ln ratio) with
      | Break {| Break.0 := residual; |} => Return (from_residual residual)
      | Continue {| Continue.0 := val; |} => val
      end in
    sqrt ln.

  Definition op (x : f64) (y : f64) : unit :=
    match op_ x y with
    | Err (why) =>
      _crate.rt.panic_display
        match why with
        | MathError.NonPositiveLogarithm => "logarithm of non-positive number"
        | MathError.DivisionByZero => "division by zero"
        | MathError.NegativeSquareRoot => "square root of negative number"
        end
    | Ok (value) =>
      _crate.io._print
        (_crate.fmt.ImplArguments.new_v1
          [ ""; "\n" ]
          [ _crate.fmt.ImplArgumentV1.new_display value ]) ;;
      tt
    end.
End checked.

Module MathError.
  Inductive t : Set :=
  | DivisionByZero
  | NonPositiveLogarithm
  | NegativeSquareRoot.
End MathError.
Definition MathError := MathError.t.

Module Impl__crate_fmt_Debug_for_MathError.
  Definition Self := MathError.

  Definition fmt
      (self : ref Self)
      (f : mut_ref _crate.fmt.Formatter)
      : _crate.fmt.Result :=
    match self with
    | MathError.DivisionByZero =>
      _crate.fmt.ImplFormatter.write_str f "DivisionByZero"
    | MathError.NonPositiveLogarithm =>
      _crate.fmt.ImplFormatter.write_str f "NonPositiveLogarithm"
    | MathError.NegativeSquareRoot =>
      _crate.fmt.ImplFormatter.write_str f "NegativeSquareRoot"
    end.

  Global Instance M_fmt : Method "fmt" _ := {|
    method := fmt;
  |}.
  Global Instance AF_fmt : MathError.AssociatedFunction "fmt" _ := {|
    MathError.associated_function := fmt;
  |}.
  Global Instance AFT_fmt : _crate.fmt.Debug.AssociatedFunction "fmt" _ := {|
    _crate.fmt.Debug.associated_function := fmt;
  |}.

  Global Instance I : _crate.fmt.Debug.Class Self := {|
    _crate.fmt.Debug.fmt := fmt;
  |}.
End Impl__crate_fmt_Debug_for_MathError.

Definition MathResult : Set := Result.

Definition div (x : f64) (y : f64) : MathResult :=
  if (eqb y 0 (* 0.0 *) : bool) then
    Err MathError.DivisionByZero
  else
    Ok (div x y).

Definition sqrt (x : f64) : MathResult :=
  if (lt x 0 (* 0.0 *) : bool) then
    Err MathError.NegativeSquareRoot
  else
    Ok (method "sqrt" x).

Definition ln (x : f64) : MathResult :=
  if (le x 0 (* 0.0 *) : bool) then
    Err MathError.NonPositiveLogarithm
  else
    Ok (method "ln" x).

Definition op_ (x : f64) (y : f64) : MathResult :=
  let ratio :=
    match branch (div x y) with
    | Break {| Break.0 := residual; |} => Return (from_residual residual)
    | Continue {| Continue.0 := val; |} => val
    end in
  let ln :=
    match branch (ln ratio) with
    | Break {| Break.0 := residual; |} => Return (from_residual residual)
    | Continue {| Continue.0 := val; |} => val
    end in
  sqrt ln.

Definition op (x : f64) (y : f64) : unit :=
  match op_ x y with
  | Err (why) =>
    _crate.rt.panic_display
      match why with
      | MathError.NonPositiveLogarithm => "logarithm of non-positive number"
      | MathError.DivisionByZero => "division by zero"
      | MathError.NegativeSquareRoot => "square root of negative number"
      end
  | Ok (value) =>
    _crate.io._print
      (_crate.fmt.ImplArguments.new_v1
        [ ""; "\n" ]
        [ _crate.fmt.ImplArgumentV1.new_display value ]) ;;
    tt
  end.

Definition main (_ : unit) : unit :=
  checked.op 1 (* 1.0 *) 10 (* 10.0 *) ;;
  tt.


Require Import Thread Arrays8 MoreArrays Buffers Io.

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

Module Type S.
  Parameters globalSched globalSock : W.

  Parameter inbuf_size : nat.
  Axiom inbuf_size_lower : (inbuf_size >= 2)%nat.
  Axiom inbuf_size_upper : (N_of_nat (inbuf_size * 4) < Npow2 32)%N.

  Parameters port numWorkers : W.
End S.

Module Make(M : S).
Import M.

Module M'''.
  Definition globalSched := M.globalSched.

  Open Scope Sep_scope.

  Definition globalInv (fs : files) : HProp := Ex fr, globalSock =*> fr * [| fr %in fs |].
End M'''.

Module T := Thread.Make(M''').

Import T M'''.
Export T M'''.

Module MyM.
  Definition sched := sched.
  Definition globalInv := globalInv.
End MyM.

Ltac unf := unfold MyM.sched, MyM.globalInv, M'''.globalSched, M'''.globalInv in *.

Module MyIo := Io.Make(MyM).

Definition hints : TacPackage.
  prepare (materialize_buffer, buffer_split_tagged) buffer_join_tagged.
Defined.

Definition mainS := SPEC reserving 49
  PREmain[_] globalSched =?> 1 * globalSock =?> 1 * mallocHeap 0.

Definition handlerS := SPEC reserving 99
  Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0.

Definition bsize := (inbuf_size * 4)%nat.

Definition m := bimport [[ "buffers"!"bmalloc" @ [bmallocS],
                           "scheduler"!"init"@ [T.Q''.initS], "scheduler"!"exit" @ [T.Q''.exitS],
                           "scheduler"!"spawn" @ [T.Q''.spawnS], "scheduler"!"listen" @ [T.Q''.listenS],
                           "scheduler"!"accept" @ [T.Q''.acceptS], "scheduler"!"close" @ [T.Q''.closeS],
                           "scheduler"!"read" @ [T.Q''.readS], "io"!"writeAll" @ [MyIo.writeAllS] ]]
  bmodule "echo" {{
    bfunctionNoRet "handler"("buf", "fr", "n") [handlerS]
      "buf" <-- Call "buffers"!"bmalloc"(inbuf_size)
      [Al fs, PREmain[V, R] R =?>8 bsize * sched fs * globalInv fs * mallocHeap 0];;

      [Al fs, PREmain[V] V "buf" =?>8 bsize * sched fs * globalInv fs * mallocHeap 0]
      While (0 = 0) {
        "fr" <-- Call "scheduler"!"accept"($[globalSock])
        [Al fs, PREmain[V, R] [| R %in fs |] * V "buf" =?>8 bsize * sched fs * globalInv fs * mallocHeap 0];;

        "n" <-- Call "scheduler"!"read"("fr", "buf", bsize)
        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 bsize * sched fs * globalInv fs * mallocHeap 0];;

        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 bsize * sched fs * globalInv fs * mallocHeap 0]
        While ("n" <> 0) {
          If ("n" <= bsize) {
            Call "io"!"writeAll"("fr", "buf", 0, "n")
            [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 bsize * sched fs * globalInv fs * mallocHeap 0]
          } else {
            Skip
          };;

          "n" <-- Call "scheduler"!"read"("fr", "buf", bsize)
          [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 bsize * sched fs * globalInv fs * mallocHeap 0]
        };;

        Call "scheduler"!"close"("fr")
        [Al fs, PREmain[V] V "buf" =?>8 bsize * sched fs * globalInv fs * mallocHeap 0]
      }
    end with bfunctionNoRet "main"("fr", "x") [mainS]
      Init
      [Al fs, Al v, PREmain[_] sched fs * globalSock =*> v * mallocHeap 0];;

      "fr" <- 0;;
      [Al fs, PREmain[_] sched fs * globalSock =?> 1 * mallocHeap 0]
      While ("fr" < numWorkers) {
        Spawn("echo"!"handler", 100)
        [Al fs, PREmain[_] sched fs * globalSock =?> 1 * mallocHeap 0];;
        "fr" <- "fr" + 1
      };;

      "fr" <-- Call "scheduler"!"listen"(port)
      [Al fs, Al v, PREmain[_, R] [| R %in fs |] * sched fs * globalSock =*> v * mallocHeap 0];;

      globalSock *<- "fr";;

      Exit 50
    end
  }}.

Lemma le_bsize : forall w : W,
  w <= natToW bsize
  -> (wordToNat w <= bsize)%nat.
  intros; pre_nomega;
    rewrite wordToNat_natToWord_idempotent in * by apply inbuf_size_upper; assumption.
Qed.

Local Hint Immediate le_bsize.

Lemma inbuf_size_small : (N.of_nat inbuf_size < Npow2 32)%N.
  specialize inbuf_size_upper;  generalize (Npow2 32); intros; nomega.
Qed.

Hint Rewrite Nat2N.inj_mul N2Nat.inj_mul : N.
Lemma le_inbuf_size : natToW 2 <= natToW inbuf_size.
  pre_nomega; rewrite wordToNat_natToWord_idempotent by apply inbuf_size_small;
    rewrite wordToNat_natToWord_idempotent by reflexivity; apply inbuf_size_lower.
Qed.

Local Hint Immediate le_inbuf_size.

Lemma roundTrip_inbuf_size : wordToNat (natToW inbuf_size) = inbuf_size.
  rewrite wordToNat_natToWord_idempotent by apply inbuf_size_small; auto.
Qed.

Lemma roundTrip_bsize : wordToNat (natToW bsize) = bsize.
  rewrite wordToNat_natToWord_idempotent by apply inbuf_size_upper; auto.
Qed.

Hint Rewrite roundTrip_inbuf_size roundTrip_bsize : sepFormula.

Theorem goodSize_bsize : goodSize bsize.
  apply inbuf_size_upper.
Qed.

Local Hint Immediate goodSize_bsize.

Ltac t := try solve [ sep unf hints; auto ];
  unf; unfold localsInvariantMain; post; evaluate hints; descend;
    try match_locals; sep unf hints; auto.

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.

End Make.


Require Import VST.floyd.proofauto.
Require Import qsort4a.
Require Import spec_qsort4.
Require Import verif_qsort4_aux1.
Require Import float_lemmas.
Require Import Permutation.
Set Nested Proofs Allowed.

Lemma is_finite_Float_of_int:
 forall i,  Binary.is_finite 53 1024 (Float.of_int i) = true.
Admitted. (* need this lemma from the Flocq people... *)

Lemma def_float_of_int:
  forall i, def_float (Vfloat (Float.of_int i)).
Proof.
intros.
simpl.
apply is_finite_Float_of_int.
Qed.

Lemma body_compar_double:  semax_body Vprog Gprog f_compar_double compar_double_spec.
Proof.
start_function.
destruct H as [? [_ ?]].
destruct H0 as [? [_ ?]].
forward.
entailer!.
destruct x; try contradiction; simpl; auto.
forward.
entailer!.
destruct y; try contradiction; simpl; auto.
destruct x; try contradiction. rename f into x.
destruct y; try contradiction. rename f into y.
forward_if (
  EX c:Datatypes.comparison,
  PROP(match c with
              | Eq => ord_eq double_le_order (Vfloat x) (Vfloat y)
              | Lt => ord_lt double_le_order (Vfloat x) (Vfloat y)
              | Gt => ord_lt double_le_order (Vfloat y) (Vfloat x)
             end)
  (LOCAL (temp _t'1
              (Vint (Int.repr (match c with Lt => -1 | Eq => 0 | Gt => 1 end))))
  (SEP (data_at shp tdouble (Vfloat x) p; data_at shq tdouble (Vfloat y) q))))%assert.
-
forward.
Exists Lt.
entailer!.
hnf. simpl. unfold f_le.
intuition.
red.
rewrite Float.cmp_le_lt_eq.
rewrite orb_true_iff; auto.
red in H11.
rewrite Float.cmp_le_lt_eq in H11.
rewrite orb_true_iff in H11; auto.
destruct H11.
rewrite (Float.cmp_swap Cgt) in H10.
apply Float.cmp_lt_gt_false in H10; auto.
eapply Float.cmp_lt_eq_false; eauto.
rewrite <- Float.cmp_swap; auto.
-
forward_if.
+
forward.
forward.
Exists Eq.
entailer!.
hnf. simpl. unfold f_le.
intuition.
red.
rewrite Float.cmp_le_lt_eq.
rewrite orb_true_iff.
auto.
red.
rewrite <- Float.cmp_swap; simpl.
rewrite Float.cmp_ge_gt_eq.
rewrite orb_true_iff.
auto.
+
forward.
forward.
Exists Gt.
entailer!.
hnf. simpl. unfold f_le.
intuition.
red.
rewrite Float.cmp_le_lt_eq.
rewrite orb_true_iff.
pose proof (f_cmp_false Clt x y H H0 H3).
simpl in H9.
rewrite Float.cmp_ge_gt_eq in H9.
rewrite orb_true_iff in H9.
destruct H9; auto.
left.
rewrite <- Float.cmp_swap; auto.
right.
rewrite <- Float.cmp_swap; auto.
red in H12.
rewrite Float.cmp_le_lt_eq in H12.
rewrite orb_true_iff in H12.
destruct H12.
rewrite H3 in H11; inv H11.
rewrite H4 in H11; inv H11.
-
Intros c; forward; Exists c.
entailer!.
Qed.

Search (int->float).

Fixpoint upto (n: nat) (k: Z) : list val :=
 match n with
 | O => nil
 | S n' => Vfloat (Float.of_int (Int.repr k)) ::
                upto n' (Z.succ k)
 end.

Lemma Zlength_upto: forall i k,
  0 <= i -> Zlength (upto (Z.to_nat i) k) = i.
Proof.
intros.
rewrite <- (Z2Nat.id i) at 2 by lia.
rewrite <- (Z2Nat.id i) in H by lia.
revert k; induction (Z.to_nat i); intros.
simpl. reflexivity.
unfold upto; fold upto.
rewrite Zlength_cons.
rewrite Nat2Z.inj_succ.
rewrite IHn; auto.
lia.
Qed.

Lemma upto_another:
  forall i k, 0 <= i ->
    upto (Z.to_nat (i+1)) k =
   upto (Z.to_nat i) k ++ [Vfloat (Float.of_int (Int.repr (i+k)))].
Proof.
intros.
replace (i+1) with (Z.succ i) by lia.
rewrite Z2Nat.inj_succ by lia.
rewrite <- (Z2Nat.id i) at 3 by lia.
clear.
revert k; induction (Z.to_nat i); intros.
simpl.
rewrite Z.add_0_l; auto.
change (upto (S (S n)) k) with
 (Vfloat (Float.of_int (Int.repr k)) ::
 upto (S n) (Z.succ k)).
rewrite (IHn (Z.succ k)).
rewrite app_comm_cons.
f_equal.
f_equal.
f_equal.
f_equal.
f_equal.
rewrite Nat2Z.inj_succ.
lia.
Qed.

Opaque upto.

Definition main_printf_loop :=
        (Ssequence
          (Sset _i (Econst_int (Int.repr 0) tint))
          (Sloop
            (Ssequence
              (Sifthenelse (Ebinop Olt (Etempvar _i tint)
                             (Econst_int (Int.repr 666666) tint) tint)
                Sskip
                Sbreak)
              (Ssequence
                (Sset _t'1
                  (Ederef
                    (Ebinop Oadd (Evar _a (tarray tdouble 666666))
                      (Etempvar _i tint) (tptr tdouble)) tdouble))
                (Scall None
                  (Evar _printf (Tfunction (Tcons (tptr tschar) Tnil) tint
                                  {|cc_vararg:=true; cc_unproto:=false; cc_structret:=false|}))
                  ((Evar ___stringlit_1 (tarray tschar 4)) ::
                   (Etempvar _t'1 tdouble) :: nil))))
            (Sset _i
              (Ebinop Oadd (Etempvar _i tint) (Econst_int (Int.repr 1) tint)
                tint)))).

Lemma verif_main_printf_loop:
 forall (Espec : OracleKind)
  (gv : globals)
  (bl : list (reptype tdouble))
  (H : Permutation (upto (Z.to_nat N6) 0) bl)
  (H0 : sorted (ord_le double_le_order) bl),
 semax (func_tycontext f_main Vprog Gprog nil)
  (PROP ( )
   LOCAL (gvars gv)
   SEP (data_at Ews (tarray tdouble N6) bl (gv _a);
   data_at Ers (tarray tschar 4)
     (map (Vint oo cast_int_int I8 Signed)
        [Int.repr 37; Int.repr 102; Int.repr 10; Int.repr 0])
     (gv ___stringlit_1))) main_printf_loop
  (normal_ret_assert
     (PROP ( )
      LOCAL (gvars gv)
      SEP (data_at Ews (tarray tdouble N6) bl (gv _a);
      data_at Ers (tarray tschar 4)
        (map (Vint oo cast_int_int I8 Signed)
           [Int.repr 37; Int.repr 102; Int.repr 10; Int.repr 0])
        (gv ___stringlit_1)))).
Admitted.  (* I claim that it is all right to Admit this lemma because
 the technical report, "A benchmark for C program verification",
 in the table on page 3, lists a blank (not an X)
 in row "qsort" column "I/O".  Therefore we don't have to verify
 the input/output in this benchmark.   *)

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward_for_simple_bound N6
  (EX i:Z,
   PROP() LOCAL (gvars gv)
   SEP (data_at Ews (tarray tdouble N6)
            (upto (Z.to_nat i) 0 ++ list_repeat (Z.to_nat (N6-i)) Vundef) (gv _a);
          data_at Ers (tarray tschar 4)
           (map (Vint oo cast_int_int I8 Signed)
               [Int.repr 37; Int.repr 102; Int.repr 10; Int.repr 0])
            (gv ___stringlit_1);
           has_ext tt)).
-
rewrite <- N6_eq.
auto.
-
rewrite <- N6_eq.
entailer!.
change (upto (Z.to_nat 0) 0) with (@nil val).
unfold app. cancel.
-
forward.
entailer!.
apply derives_refl'.
f_equal.
replace (Z.to_nat (N6 - i))
  with (S (Z.to_nat (N6-(i+1)))).
2:{ clear - H. replace (N6-i) with (Z.succ (N6-(i+1))) by lia.
     rewrite Z2Nat.inj_succ by lia. auto.
}
 unfold list_repeat; fold @list_repeat.
 rewrite upd_Znth_app2.
2:{  rewrite Zlength_upto by lia. autorewrite with sublist. lia. }
 rewrite Zlength_upto by lia.
 rewrite Z.sub_diag.
 rewrite upd_Znth0.
 rewrite upto_another by lia.
 rewrite app_ass. f_equal. simpl. normalize.
-
(* after the for-loop *)
autorewrite with sublist.
set (al := upto (Z.to_nat N6) 0).
make_func_ptr _compar_double.
assert (H_ok:
complete_legal_cosu_type tdouble = true /\
               align_compatible_rec cenv_cs tdouble 0 /\
               no_volatiles tdouble). {
  split3; try reflexivity.
  eapply align_compatible_rec_by_value.
  reflexivity.
  apply Z.divide_0_r.
}
assert (Hdef: Forall (ord_def double_le_order) al). {
 clear.
 subst al.
 forget 0 as k.
 revert k; induction (Z.to_nat N6); simpl; intros.
 constructor.
 change (upto (S n) k) with
   (Vfloat (Float.of_int (Int.repr k)) :: upto n (Z.succ k)).
 constructor; auto.
 red. simpl. red.
 pose proof (def_float_of_int (Int.repr k)).
 split3; auto.
 apply f_le_refl; auto.
}
pose (w := Build_qsort_witness _ tdouble H_ok
                    double_le_order al Hdef).
assert (Zlength al = N6) by (subst al; rewrite Zlength_upto; rep_lia).
forward_call (Ews, gv _a, gv _compar_double, w);
   simpl qsort_t;
   simpl qsort_ord;
   simpl qsort_al;
  change (@reptype _ tdouble) with val.
+
rewrite <- N6_eq.
entailer!.
rewrite H; auto.
+
rewrite H.
cancel.
+
rewrite H.
split3; auto.
simpl sizeof.
computable.
simpl sizeof.
split; try rep_lia.
+
clear w H_ok Hdef.
rewrite H.
Intros bl.
deadvars!.
unfold Sfor.
fold main_printf_loop.
apply seq_assoc1.
eapply semax_seq'.
change (SEP (?R1; ?R2; ?R3)) with (@SEPx environ ([R1;R2]++[R3])).
rewrite (app_nil_end [gvars gv]).
eapply semax_frame_PQR.
unfold closed_wrt_modvars;  auto 50 with closed.
apply verif_main_printf_loop; auto.
unfold app.
forward.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                Jacques-Henri Jourdan, INRIA Paris                   *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for x86 in 64-bit mode *)

Require Import ZArith.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.

Definition ptr64 := true.

Definition big_endian := false.

Definition align_int64 := 8%Z.
Definition align_float64 := 8%Z.

Definition splitlong := negb ptr64.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  unfold splitlong. destruct ptr64; simpl; congruence.
Qed.

Program Definition default_pl_64 : bool * nan_pl 53 :=
  (true, iter_nat 51 _ xO xH).

Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  false.                        (**r always choose first NaN *)

Program Definition default_pl_32 : bool * nan_pl 24 :=
  (true, iter_nat 22 _ xO xH).

Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
  false.                        (**r always choose first NaN *)

Definition float_of_single_preserves_sNaN := false.

Global Opaque ptr64 big_endian splitlong
              default_pl_64 choose_binop_pl_64
              default_pl_32 choose_binop_pl_32
              float_of_single_preserves_sNaN.


(** * Dexter 2 FA1.2 Liquidity token contract *)
(** This file contains an implementation of Dexter2 liquidity contract
    https://gitlab.com/dexter2tz/dexter2tz/-/blob/1cec9d9333eba756603d6cd90ea9c70d482a5d3d/lqt_fa12.mligo
    In addition this file contains proof of functional correctness w.r.t the
    informal specification https://gitlab.com/dexter2tz/dexter2tz/-/blob/1cec9d9333eba756603d6cd90ea9c70d482a5d3d/docs/informal-spec/dexter2-lqt-fa12.md

    This contract is an extension of a basic FA1.2 token contract with
    an extra entrypoint that allows an admin to mint and burn tokens.
    It is used in the Dexter2 exchange paired with an instance of the
    Dexter2 CPMM contract. The purpose of this contract is to keep track
    of ownership of the exchanges funds. A user who owns x% of the supply
    of liquidity tokens owns x% of the exchanges trading reserve.
*)
From ConCert.Utils Require Import Extras.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution Require Import InterContractCommunication.
From ConCert.Execution Require Import ContractCommon.
From Coq Require Import ZArith_base.
From Coq Require Import List. Import ListNotations.

Definition non_zero_amount (amt : Z) : bool := (0 <? amt)%Z.

(** * Contract types *)

Section LQTFA12Types.
  Context {BaseTypes : ChainBase}.
  Open Scope N_scope.
  Set Nonrecursive Elimination Schemes.

  (* Dummy implementation of callbacks. *)
  Record callback := {
    return_addr : Address;
  }.

  Definition callback_addr (c : callback)
                           : Address :=
    c.(return_addr).
  Coercion callback_addr : callback >-> Address.

  Record transfer_param :=
    build_transfer_param {
      from : Address;
      to : Address;
      value : N
  }.

  Record approve_param :=
    build_approve_param {
      spender : Address;
      value_ : N
  }.

  Record mintOrBurn_param :=
    build_mintOrBurn_param {
      quantity : Z;
      target : Address
  }.

  Record getAllowance_param :=
    build_getAllowance_param {
      request : (Address * Address);
      allowance_callback : callback
  }.

  Record getBalance_param :=
    build_getBalance_param {
      owner_ : Address;
      balance_callback : callback
  }.

  Record getTotalSupply_param :=
    build_getTotalSupply_param {
      request_ : unit;
      supply_callback : callback
  }.

  Record State :=
    build_state {
      tokens : FMap Address N;
      allowances : FMap (Address * Address) N;
      admin : Address;
      total_supply : N
  }.

  Record Setup :=
    build_setup {
      admin_ : Address;
      lqt_provider : Address;
      initial_pool : N
  }.

  Definition Error : Type := nat.
  Definition default_error : Error := 1%nat.

  (* Any contract that wants to receive callback messages from the FA1.2 liquidity contract
    should have this type as its Msg type. The contract may have other endpoints,
    as composed in the 'other_msg' constructor. *)
  Inductive FA12ReceiverMsg {Msg' : Type} :=
  | receive_allowance : N -> FA12ReceiverMsg
  | receive_balance_of : N -> FA12ReceiverMsg
  | receive_total_supply : N -> FA12ReceiverMsg
  | other_msg : Msg' -> FA12ReceiverMsg.

  (* Liquidity FA1.2 Endpoints. *)
  Inductive Msg :=
  | msg_transfer : transfer_param -> Msg
  | msg_approve : approve_param -> Msg
  | msg_mint_or_burn : mintOrBurn_param -> Msg
  | msg_get_allowance : getAllowance_param -> Msg
  | msg_get_balance : getBalance_param -> Msg
  | msg_get_total_supply : getTotalSupply_param -> Msg.

  (* begin hide *)
  MetaCoq Run (make_setters transfer_param).
  MetaCoq Run (make_setters approve_param).
  MetaCoq Run (make_setters mintOrBurn_param).
  MetaCoq Run (make_setters getAllowance_param).
  MetaCoq Run (make_setters getBalance_param).
  MetaCoq Run (make_setters getTotalSupply_param).
  MetaCoq Run (make_setters State).
  MetaCoq Run (make_setters Setup).
  (* end hide *)

  Definition mintedOrBurnedTokens (msg : option Msg) : Z :=
    match msg with
    | Some (msg_mint_or_burn param) => param.(quantity)
    | _ => 0
    end.

  Class LqtTokenInterface
        `{Serializable State}
        `{Serializable Msg}
        `{Serializable Setup} :=
    { lqt_contract : Contract Setup Msg State Error;

      lqt_total_supply_correct :
      forall (bstate : ChainState) (caddr : Address)
        (trace : ChainTrace empty_state bstate),
        env_contracts bstate caddr = Some (lqt_contract : WeakContract) ->
        exists (cstate : State) (depinfo : DeploymentInfo Setup)
          (inc_calls : list (ContractCallInfo Msg)),
            contract_state bstate caddr = Some cstate /\
            deployment_info Setup trace caddr = Some depinfo /\
            incoming_calls Msg trace caddr = Some inc_calls /\
            (let initial_tokens := initial_pool (deployment_setup depinfo) in
            Z.of_N (total_supply cstate) =
              (Z.of_N initial_tokens +
                  sumZ (fun callInfo => mintedOrBurnedTokens (call_msg callInfo))
                      (filter (callFrom (admin cstate)) inc_calls))%Z) }.

End LQTFA12Types.

Module Type Dexter2LqtSerializable.
  Section D2LqtSerializable.

    Context `{ChainBase}.

    Axiom callback_serializable : Serializable callback.

    Axiom transfer_param_serializable : Serializable transfer_param.

    Axiom approve_param_serializable : Serializable approve_param.

    Axiom mintOrBurn_param_serializable : Serializable mintOrBurn_param.

    Axiom getAllowance_param_serializable : Serializable getAllowance_param.

    Axiom getBalance_param_serializable : Serializable getBalance_param.

    Axiom getTotalSupply_param_serializable : Serializable getTotalSupply_param.

    Axiom FA12ReceiverMsg_serializable : forall {Msg : Type} `{Serializable Msg}, Serializable (@FA12ReceiverMsg Msg).

    Axiom msg_serializable : Serializable Msg.

    Axiom state_serializable : Serializable State.

    Axiom setup_serializable : Serializable Setup.

  End D2LqtSerializable.
End Dexter2LqtSerializable.

Module D2LqtSInstances <: Dexter2LqtSerializable.
  Section Serialization.
    Context `{ChainBase}.

    Instance callback_serializable : Serializable callback :=
    Derive Serializable callback_rect <Build_callback>.

    Instance transfer_param_serializable : Serializable transfer_param :=
      Derive Serializable transfer_param_rect <build_transfer_param>.

    Instance approve_param_serializable : Serializable approve_param :=
      Derive Serializable approve_param_rect <build_approve_param>.

    Instance mintOrBurn_param_serializable : Serializable mintOrBurn_param :=
      Derive Serializable mintOrBurn_param_rect <build_mintOrBurn_param>.

    Instance getAllowance_param_serializable : Serializable getAllowance_param :=
      Derive Serializable getAllowance_param_rect <build_getAllowance_param>.

    Instance getBalance_param_serializable : Serializable getBalance_param :=
      Derive Serializable getBalance_param_rect <build_getBalance_param>.

    Instance getTotalSupply_param_serializable : Serializable getTotalSupply_param :=
      Derive Serializable getTotalSupply_param_rect <build_getTotalSupply_param>.

    Instance FA12ReceiverMsg_serializable {Msg : Type}
                                         `{Serializable Msg}
                                          : Serializable (@FA12ReceiverMsg Msg) :=
      Derive Serializable (@FA12ReceiverMsg_rect Msg) <
        (@receive_allowance Msg),
        (@receive_balance_of Msg),
        (@receive_total_supply Msg),
        (@other_msg Msg)>.

    Instance msg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <msg_transfer,
                                  msg_approve,
                                  msg_mint_or_burn,
                                  msg_get_allowance,
                                  msg_get_balance,
                                  msg_get_total_supply>.

    Instance state_serializable : Serializable State :=
      Derive Serializable State_rect <build_state>.

    Instance setup_serializable : Serializable Setup :=
      Derive Serializable Setup_rect <build_setup>.
  End Serialization.
End D2LqtSInstances.

(** * Contract functions *)
Module Dexter2Lqt (SI : Dexter2LqtSerializable).
  Import SI.

  (* begin hide *)
  #[global] Existing Instance callback_serializable.
  #[global] Existing Instance transfer_param_serializable.
  #[global] Existing Instance approve_param_serializable.
  #[global] Existing Instance mintOrBurn_param_serializable.
  #[global] Existing Instance getAllowance_param_serializable.
  #[global] Existing Instance getBalance_param_serializable.
  #[global] Existing Instance getTotalSupply_param_serializable.
  #[global] Existing Instance FA12ReceiverMsg_serializable.
  #[global] Existing Instance msg_serializable.
  #[global] Existing Instance state_serializable.
  #[global] Existing Instance setup_serializable.
  (* end hide *)

  Section DexterLqtDefs.
    Context `{BaseTypes : ChainBase}.
    Open Scope N_scope.

    Definition find_allowance (k : Address * Address)
                              (m : FMap (Address * Address) N)
                              : option N :=
      FMap.find k m.

    Definition update_allowance (k : Address * Address)
                                (val : option N)
                                (m : FMap (Address * Address) N)
                                : FMap (Address * Address) N :=
      FMap.update k val m.

    Definition empty_allowance : FMap (Address * Address) N :=
      FMap.empty.

    (** ** Transfer *)
    (** Transfers [amount] tokens, if [from] has enough tokens to transfer
        and [sender] is allowed to send that much on behalf of [from] *)
    Definition try_transfer (sender : Address)
                            (param : transfer_param)
                            (state : State)
                            : result State Error :=
      let allowances_ := state.(allowances) in
      let tokens_ := state.(tokens) in
      do allowances_ <- (* Update allowances *)
        (if address_eqb sender param.(from)
        then Ok allowances_
        else
          let allowance_key := (param.(from), sender) in
          let authorized_value := with_default 0 (find_allowance allowance_key allowances_) in
            do _ <- throwIf (authorized_value <? param.(value)) default_error; (* NotEnoughAllowance *)
            Ok (update_allowance allowance_key (maybe (authorized_value - param.(value))) allowances_)
        ) ;
      do tokens_ <- (* Update from balance *)
        (let from_balance := with_default 0 (AddressMap.find param.(from) tokens_) in
          do _ <- throwIf (from_balance <? param.(value)) default_error; (* NotEnoughBalance *)
          Ok (AddressMap.update param.(from) (maybe (from_balance - param.(value))) tokens_)
        ) ;
      let tokens_ :=
        let to_balance := with_default 0 (AddressMap.find param.(to) tokens_) in
          AddressMap.update param.(to) (maybe (to_balance + param.(value))) tokens_ in
        Ok (state<|tokens := tokens_|>
                  <|allowances := allowances_|>).

    (** ** Approve *)
    (** The caller approves the [spender] to transfer up to [amount] tokens on behalf of the [sender] *)
    Definition try_approve (sender : Address)
                           (param : approve_param)
                           (state : State)
                           : result State Error :=
      let allowances_ := state.(allowances) in
      let allowance_key := (sender, param.(spender)) in
      let previous_value := with_default 0 (find_allowance allowance_key allowances_) in
      do _ <- throwIf (andb (0 <? previous_value) (0 <? param.(value_))) default_error; (* UnsafeAllowanceChange *)
      let allowances_ := update_allowance allowance_key (maybe param.(value_)) allowances_ in
        Ok (state<|allowances := allowances_|>).

    (** ** Mint or burn *)
    (** If [quantity] is positive
        then creates [quantity] tokens and gives them to [target]
        else removes [quantity] tokens from [target].
        Can only be called by [admin] *)
    Definition try_mint_or_burn (sender : Address)
                                (param : mintOrBurn_param)
                                (state : State)
                                : result State Error :=
      do _ <- throwIf (address_neqb sender state.(admin)) default_error;
      let tokens_ := state.(tokens) in
      let old_balance := with_default 0 (AddressMap.find param.(target) tokens_) in
      let new_balance := (Z.of_N old_balance + param.(quantity))%Z in
      do _ <- throwIf (new_balance <? 0)%Z default_error; (* Cannot burn more than the target's balance. *)
      let tokens_ := AddressMap.update param.(target) (maybe (Z.to_N new_balance)) tokens_ in
      let total_supply_ := Z.abs_N (Z.of_N state.(total_supply) + param.(quantity))%Z in
        Ok (state<|tokens := tokens_|>
                  <|total_supply := total_supply_|>).

    Definition mk_callback (to_addr : Address)
                           (msg : @FA12ReceiverMsg unit)
                           : ActionBody :=
      act_call to_addr 0 (serialize msg).

    Definition receive_allowance_ n := @receive_allowance unit n.
    Definition receive_balance_of_ n := @receive_balance_of unit n.
    Definition receive_total_supply_ n := @receive_total_supply unit n.

    (** ** Get allowance *)
    (** Get the quantity that [snd request] is allowed to spend on behalf of [fst request] *)
    Definition try_get_allowance (sender : Address)
                                 (param : getAllowance_param)
                                 (state : State)
                                 : list ActionBody :=
      let value := with_default 0 (find_allowance param.(request) state.(allowances)) in
        [mk_callback param.(allowance_callback) (receive_allowance_ value)].

    (** ** Get balance *)
    (** Get the quantity of tokens belonging to [owner] *)
    Definition try_get_balance (sender : Address)
                               (param : getBalance_param)
                               (state : State)
                               : list ActionBody :=
      let value := with_default 0 (AddressMap.find param.(owner_) state.(tokens)) in
        [mk_callback param.(balance_callback) (receive_balance_of_ value)].

    (** ** Get total supply *)
    (** Get the total supply of tokens *)
    Definition try_get_total_supply (sender : Address)
                                    (param : getTotalSupply_param)
                                    (state : State)
                                    : list ActionBody :=
      let value := state.(total_supply) in
        [mk_callback param.(supply_callback) (receive_total_supply_ value)].

    (** ** Init *)
    (** Initalize contract storage *)
    Definition init_lqt (chain : Chain)
                        (ctx : ContractCallContext)
                        (setup : Setup)
                        : result State Error :=
      Ok {|
        tokens := AddressMap.add setup.(lqt_provider)
                                 setup.(initial_pool)
                                 AddressMap.empty;
        allowances := empty_allowance;
        admin := setup.(admin_);
        total_supply := setup.(initial_pool);
      |}.

    (** ** Receive *)
    (** Contract main entrypoint *)
    Open Scope Z_scope.
    Definition receive_lqt (chain : Chain)
                          (ctx : ContractCallContext)
                          (state : State)
                          (maybe_msg : option Msg)
                          : result (State * list ActionBody) Error :=
      let sender := ctx.(ctx_from) in
      let without_statechange acts := Ok (state, acts) in
      do _ <- throwIf (non_zero_amount ctx.(ctx_amount)) default_error; (* DontSendTez *)
      match maybe_msg with
      | Some (msg_transfer param) =>
          without_actions (try_transfer sender param state)
      | Some (msg_approve param) =>
          without_actions (try_approve sender param state)
      | Some (msg_mint_or_burn param) =>
          without_actions (try_mint_or_burn sender param state)
      | Some (msg_get_allowance param) =>
          without_statechange (try_get_allowance sender param state)
      | Some (msg_get_balance param) =>
          without_statechange (try_get_balance sender param state)
      | Some (msg_get_total_supply param) =>
          without_statechange (try_get_total_supply sender param state)
      (* Transfer actions to this contract are not allowed *)
      | None => Err default_error
      end.
    Close Scope Z_scope.

    Definition contract : Contract Setup Msg State Error :=
      build_contract init_lqt receive_lqt.

  End DexterLqtDefs.
End Dexter2Lqt.

Module DEX2LQT := Dexter2Lqt D2LqtSInstances.


From Perennial.program_proof Require Import disk_prelude.
From Goose.github_com.mit_pdos.gokv Require Import aof.
From Perennial.program_proof.lockservice Require Import grove_ffi.
From Perennial.algebra Require Import mlist auth_map.
From iris.algebra Require Import mono_nat.
From Perennial.Helpers Require Import ModArith.

Section aof_proof.
Context `{!heapGS Σ}.
Context `{!filesysG Σ}.

Class aofG Σ := AofG {
  aof_flistG :> fmlistG u8 Σ ;
  aof_mnatG :> inG Σ mono_natUR ;
  aof_mapG :> mapG Σ u64 unit ;
  aof_tokG :> inG Σ (exclR unitO) ;
}.

Record aof_vol_names := mk_aof_vol_names {
  logdata : gname ;
  predurabledata : gname ;
  len : gname ;
  len_toks : gname ;
}.

Context `{!aofG Σ}.

Implicit Types γ : aof_vol_names.
Implicit Types aof_ctx : (list u8) → iProp Σ.

Definition aof_lenN := nroot .@ "aof_len".
Definition aof_len_invariant γ : iProp Σ :=
  ∃ (l:u64),
    own γ.(len) (mono_nat_auth (1/2) (int.nat l)) ∗
    [∗ set] x ∈ (fin_to_set u64), x [[γ.(len_toks)]]↦ () ∨ ⌜int.nat x > int.nat l⌝
.

Definition aof_length_lb γ (l:u64) : iProp Σ :=
  own γ.(len) (mono_nat_lb (int.nat l)).

Definition list_safe_size (l:list u8) := int.nat (length l) = length l.

Definition aof_mu_invariant (aof_ptr:loc) γ aof_ctx : iProp Σ :=
  ∃ membuf_sl membufC predurableC (durlen genlength:u64),
  "Hmembuf" ∷ aof_ptr ↦[AppendOnlyFile :: "membuf"] (slice_val membuf_sl) ∗
  "HdurableLength" ∷ aof_ptr ↦[AppendOnlyFile :: "durableLength"]{1/2} #durlen ∗
  "Hmembuf_sl" ∷ typed_slice.is_slice membuf_sl byteT 1 membufC ∗
  "Hpredurable" ∷ fmlist γ.(predurabledata) (1/2) predurableC ∗
  "Hlogdata" ∷ fmlist γ.(logdata) (1/2)%Qp (predurableC ++ membufC) ∗
  "Hlength" ∷ aof_ptr ↦[AppendOnlyFile :: "length"] #genlength ∗
  "%Hlengthsafe" ∷ ⌜list_safe_size (predurableC ++ membufC)⌝ ∗
  "Hlen_toks" ∷ ([∗ set] x ∈ (fin_to_set u64), x [[γ.(len_toks)]]↦ () ∨ ⌜int.nat x ≤ int.nat genlength⌝) ∗
  "Hmembuf_fupd" ∷ (aof_ctx predurableC ={⊤}=∗ aof_ctx (predurableC ++ membufC)
     ∗ (∀ oldlen, own γ.(len) (mono_nat_auth (1/2) oldlen) ={⊤}=∗
        own γ.(len) (mono_nat_auth (1/2) (int.nat genlength))
       )
  ) ∗
  "#Hdurlen_lb" ∷ aof_length_lb γ durlen
.

Definition aofN := nroot .@ "aof".

Definition is_aof aof_ptr γ (aof_ctx : (list u8) → iProp Σ) : iProp Σ :=
  ∃ mu_ptr (lenCond_ptr durCond_ptr:loc),
  "#Hmu" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "mu"] mu_ptr) ∗
  "#HlengthCond" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "lengthCond"] #lenCond_ptr) ∗
  "#HdurableCond" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "durableCond"] #durCond_ptr) ∗
  "#HlenCond" ∷ is_cond lenCond_ptr mu_ptr ∗
  "#HdurCond" ∷ is_cond durCond_ptr mu_ptr ∗
  "#Hmu_inv" ∷ is_lock aofN mu_ptr (aof_mu_invariant aof_ptr γ aof_ctx) ∗
  "#Haof_len_inv" ∷ inv aof_lenN (aof_len_invariant γ)
.

(* TODO: upgrade to WPC *)
Lemma wp_CreateAppendOnlyFile (fname:string) data aof_ctx :
  {{{
       fname f↦{1} data ∗
       aof_ctx data
  }}}
    CreateAppendOnlyFile #(str fname)
  {{{
       aof_ptr γ, RET #aof_ptr; is_aof aof_ptr γ aof_ctx
  }}}.
Proof.
  iIntros (Φ) "Hpre HΦ".
  wp_lam.

  wp_apply (wp_allocStruct).
  { admit. (* TODO: typechecking *) }
  iIntros (l) "Hl".
  iDestruct (struct_fields_split with "Hl") as "Hl".
  iNamed "Hl".

  wp_pures.
  wp_apply (wp_new_free_lock).
  iIntros (mu) "Hmu_free".

  wp_pures.
  wp_storeField.

  wp_loadField.
  wp_apply (wp_newCond' with "Hmu_free").
  iIntros (lengthCond) "[Hmu_free HlengthCond]".
  wp_storeField.

  wp_loadField.
  wp_apply (wp_newCond' with "Hmu_free").
  iIntros (durableCond) "[Hmu_free HdurableCond]".
  wp_storeField.

  iAssert ((|={⊤}=> ∃ γ, is_aof l γ aof_ctx ∗ fmlist γ.(predurabledata) (1 / 2) data
            ∗ l ↦[AppendOnlyFile :: "durableLength"]{1 / 2} #0
            ∗ own γ.(len) (mono_nat_auth (1/2) 0))
          )%I with "[-Hpre HΦ]" as ">HH".
  {
    (* need to allocate ghost state and freeze stuff *)
    iExists (mk_aof_vol_names _ _ _ _).
    admit.
  }
  iDestruct "HH" as (γ) "(#His_aof & Hpredur & HdurLen & Hlen)".
  wp_apply (wp_fork with "[-HΦ]").
  {
    iNext.
    iNamed "His_aof".
    wp_loadField.
    wp_apply (acquire_spec with "Hmu_inv").
    iIntros "[Hlocked Haof_own]".
    wp_pures.
    iAssert (∃ data', fname f↦ (data++data') ∗ aof_ctx (data++data') ∗ fmlist γ.(predurabledata) (1/2) (data ++ data')
            ∗ l ↦[AppendOnlyFile :: "durableLength"]{1 / 2} #(U64 (length data'))
            ∗ own γ.(len) (mono_nat_auth (1/2) (length (data')))
            )%I with "[Hpre Hpredur HdurLen Hlen]" as "Hfile_ctx".
    { iExists []; iFrame. rewrite app_nil_r. iFrame. }
    wp_forBreak.
    wp_pures.

    iNamed "Haof_own".
    wp_loadField.
    wp_apply (wp_slice_len).
    wp_pures.
    wp_if_destruct.
    {
      wp_loadField.
      wp_apply (wp_condWait with "[- Hfile_ctx]").
      { iFrame "#∗". iExists _, _, _, _; iFrame "∗#". done. }
      iIntros "[Hlocked Haof_own]".
      wp_pures.
      iLeft.
      iFrame.
      done.
    }

    wp_loadField.
    wp_pures.
    wp_loadField.
    wp_pures.

    wp_apply (wp_new_slice).
    { done. }
    iIntros (empty_membuf_sl) "Hmembuf_empty".
    wp_apply (wp_storeField with "Hmembuf").
    { unfold AppendOnlyFile. unfold field_ty. simpl. apply slice_val_ty. }
    iIntros "Hmembuf".

    wp_pures.
    wp_loadField.

    iDestruct "Hfile_ctx" as (data') "(Hfile & Hctx & Hpredur & HdurLen & Hlen)".

    iDestruct (fmlist_agree_1 with "Hpredur Hpredurable") as %Hpredur.
    rewrite Hpredur.
    iCombine "Hpredur Hpredurable" as "Hpredur".
    iMod (fmlist_update (predurableC ++ membufC) with "Hpredur") as "[Hpredur _]".
    { by apply prefix_app_r. }
    iDestruct "Hpredur" as "[Hpredur Hpredurable]".
    wp_apply (release_spec with "[-Hfile Hctx Hpredur Hmembuf_fupd Hmembuf_sl HdurLen Hlen]").
    { iFrame "#∗". iNext. iExists _, [], (predurableC ++ membufC), _. iFrame "∗#".
      rewrite app_nil_r.
      iFrame.
      iSplitL ""; first done.
      iIntros "$ !> $ !>".
      done.
    }

    wp_pures.

    iDestruct (typed_slice.is_slice_sz with "Hmembuf_sl") as %Hsz.
    wp_bind (AtomicAppend _ _).
    iApply wpc_wp.
    wpc_apply (wpc_AtomicAppend with "[$Hfile $Hmembuf_sl]").
    iSplit.
    { iModIntro. iIntros. instantiate (1:=(True)%I). done. }
    iNext.
    iIntros "[Hfile _]".
    iMod ("Hmembuf_fupd" with "Hctx") as "[Hctx Hlen_fupd]".
    wp_pures.

    wp_loadField.
    wp_apply (acquire_spec with "Hmu_inv").
    iIntros "[Hlocked Haof_own]".
    iRename "Hdurlen_lb" into "Hdurlen_lb_old".
    iNamed "Haof_own".
    wp_pures.

    iDestruct (struct_field_mapsto_agree with "HdurLen HdurableLength") as %Heq.
    rewrite Heq.
    iCombine "HdurLen HdurableLength" as "HdurLen".
    wp_storeField.

    wp_loadField.
    iMod ("Hlen_fupd" with "Hlen") as "Hlen".
    iEval (rewrite mono_nat_auth_lb_op) in "Hlen".
    iDestruct "Hlen" as "[Hlen #Hlenlb]".

    wp_apply (wp_condBroadcast).
    { iFrame "#". }
    wp_pures.
    iLeft.
    iFrame.
    iSplitL ""; first done.
    iDestruct "HdurLen" as "[HdurableLength HdurLen]".
    iSplitR "Hpredur HdurLen Hlen Hfile Hctx".
    {
      iExists _, _, _, _; iFrame "∗#".
      iSplitL ""; first done.
      unfold aof_length_lb.
      rewrite Hlengthsafe.
      iFrame "#".
    }
    {
      rewrite -Hpredur.
      repeat rewrite -app_assoc.
      iExists _; iFrame.
    }
  }
  wp_pures.
  iApply "HΦ".
  iFrame "#".
Admitted.

Definition aof_log_own γ data :=
  fmlist γ.(logdata) (1/2)%Qp data.

Lemma wp_AppendOnlyFile__Append aof_ptr γ data_sl aof_ctx (oldData newData:list u8) Q :
length newData > 0 →
list_safe_size newData →
is_aof aof_ptr γ aof_ctx -∗
  {{{
       typed_slice.is_slice data_sl byteT 1 newData ∗ aof_log_own γ oldData ∗
       (aof_ctx oldData ={⊤}=∗ aof_ctx (oldData ++ newData) ∗ Q)
  }}}
    AppendOnlyFile__Append #aof_ptr (slice_val data_sl)
  {{{
       (l:u64), RET #l; aof_log_own γ (oldData ++ newData) ∗
                        (aof_length_lb γ l ={⊤}=∗ ▷ Q)
  }}}.
Proof.
  intros HnewDataLen HnewDataSafe.
  iIntros "#Haof" (Φ) "!# Hpre HΦ".
  iNamed "Haof".
  wp_lam.
  wp_pures.

  wp_loadField.
  wp_apply (acquire_spec with "Hmu_inv").
  iIntros "[Hlocked Haof]".
  iNamed "Haof".
  iDestruct "Hpre" as "(HnewData & Haof_log & Hfupd)".
  wp_pures.

  wp_loadField.
  iDestruct (is_slice_sz with "HnewData") as %Hsz.
  wp_apply (typed_slice.wp_SliceAppendSlice (V:=u8) with "[$Hmembuf_sl $HnewData]").
  iIntros (membuf_sl') "Hmembuf_sl".
  wp_apply (wp_storeField with "Hmembuf").
  { unfold AppendOnlyFile. unfold field_ty. simpl. apply slice_val_ty. }
  iIntros "Hmembuf".

  wp_pures.

  (* overflow guard *)
  wp_forBreak_cond.
  wp_pures.
  repeat wp_loadField.
  wp_apply (wp_slice_len).
  wp_loadField.
  wp_pures.
  wp_if_destruct.
  {
    wp_pures.
    iLeft. iFrame "∗#". done.
  }
  iRight.
  iSplitL ""; first done.
  rewrite typed_slice.list_untype_length in Hsz.

  wp_loadField.
  wp_apply (wp_slice_len).
  wp_pures.
  rewrite -HnewDataSafe in Hsz Heqb.
  assert (U64 (length newData) = data_sl.(Slice.sz)) as HH.
  {
    apply Z2Nat.inj in Hsz.
    { word_cleanup. naive_solver. }
    { word_cleanup. naive_solver. }
    word.
  }
  rewrite -HH.
  rewrite -HH in Heqb.
  wp_pures.
  wp_storeField.

  wp_loadField.
  wp_pures.

  wp_loadField.
  wp_apply (wp_condSignal).
  { iFrame "#". }

  wp_pures.

  unfold aof_log_own.
  iDestruct (fmlist_agree_1 with "Haof_log Hlogdata") as %->.
  iCombine "Haof_log Hlogdata" as "Haof_log".

  iMod (fmlist_update ((predurableC ++ membufC) ++ newData) with "Haof_log") as "[Haof_log _]".
  { apply prefix_app_r. done. }

  iDestruct "Haof_log" as "[Hlogdata Haof_log]".

  rewrite -app_assoc.
  (* Want to prove membuf_fupd, and the postcondition *)
  set (membufC' := membufC ++ newData) in *.

  iAssert (([∗ set] x ∈ fin_to_set u64, x [[γ.(len_toks)]]↦ () ∨
                      ⌜int.nat x <= length (predurableC ++ membufC)⌝ ∨
                      ⌜length (predurableC ++ membufC') < int.nat x⌝
          ) ∗
          ([∗ set] x ∈ fin_to_set u64, x [[γ.(len_toks)]]↦ () ∨
                      ⌜int.nat x ≤ length (predurableC ++ membufC')⌝
          ))%I
    with "[Hlen_toks]"
    as "HH".
  {
    iApply big_sepS_sep.
    iApply (big_sepS_impl with "Hlen_toks").
    iModIntro.
    iIntros (x ?) "Hx".
    iDestruct "Hx" as "[Hx|%Hineq]".
    {
      destruct (bool_decide (length (predurableC ++ membufC') < int.nat x)) as [|] eqn:Hineq.
      {
        apply bool_decide_eq_true in Hineq.
        iSplitR "Hx".
        { iRight; iRight. done. }
        iLeft. iFrame.
      }
      {
        apply bool_decide_eq_false in Hineq.
        iSplitL "Hx".
        { iFrame. }
        iRight.
        iPureIntro.
        word.
      }
    }
    {
      iSplitL.
      {
        iRight; iLeft. done.
      }
      iRight. iPureIntro.
      replace (membufC') with (membufC ++ newData) by done.
      rewrite app_assoc.
      rewrite app_length.
      word.
    }
  }

  iDestruct "HH" as "[Htoks Hlen_toks]".

  (* TODO: factor this into a lemma *)
  assert (int.Z (word.add (U64 (length (predurableC ++ membufC))) (U64 (length newData))) =
          int.Z (U64 (length (predurableC ++ membufC))) + int.Z (U64 (length newData))).
  {
    assert (int.Z (word.add (length (predurableC ++ membufC)) (length newData)) >= int.Z (length (predurableC ++ membufC)))%Z by lia.
    destruct (bool_decide ((int.Z (U64 (length (predurableC ++ membufC)))) + (int.Z (U64 (length newData))) < 2 ^ 64 ))%Z eqn:Hnov.
    {
      apply bool_decide_eq_true in Hnov.
      rewrite word.unsigned_add.
      rewrite wrap_small.
      { word. }
      split.
      {
        apply Z.add_nonneg_nonneg.
        { word_cleanup. naive_solver. }
        { word_cleanup. naive_solver. }
      }
      { done. }
    }
    apply bool_decide_eq_false in Hnov.
    assert (int.Z (U64 (length (predurableC ++ membufC))) + int.Z (U64 (length newData)) >= 2 ^ 64)%Z.
    { lia. }
    apply sum_overflow_check in H0.
    contradiction.
  }
  assert (int.nat (U64 (length (predurableC ++ membufC'))) = (length (predurableC ++ membufC'))) as Hsafesize'.
  {
    replace (membufC') with (membufC ++ newData) by done.
    rewrite app_assoc.
    rewrite app_length.
    word_cleanup.
    rewrite -Hlengthsafe.
    repeat (rewrite Nat2Z.inj_add).
    replace (length newData) with (Z.to_nat (Z.of_nat (length newData))) by lia.
    rewrite -Z2Nat.inj_add.
    {
      rewrite Z2Nat.inj_iff.
      {
        rewrite Z2Nat.id.
        {
          rewrite wrap_small; first word.
          split.
          {
            apply Z.add_nonneg_nonneg; word_cleanup; naive_solver.
          }
          {
            rewrite Nat2Z.id.
            rewrite -HnewDataSafe.
            replace (Z.of_nat (int.nat (length newData))) with (int.Z (length newData)); last first.
            { rewrite u64_Z_through_nat. done. }
            destruct (bool_decide (int.Z (length (predurableC ++ membufC)) + (int.Z (length newData)) < 2 ^ 64)) eqn:Hnov.
            { apply bool_decide_eq_true in Hnov. done. }
            {
              apply bool_decide_eq_false in Hnov.
              assert (int.Z (U64 (length (predurableC ++ membufC))) + (int.Z (length newData)) >= 2 ^ 64)%Z.
              { lia. }
              apply sum_overflow_check in H4.
              contradiction.
            }
          }
        }
        naive_solver.
      }
      {
        word_cleanup.
        unfold word.wrap.
        by apply Z_mod_lt.
      }
      {
        word_cleanup.
        apply Z.add_nonneg_nonneg; word_cleanup; naive_solver.
      }
    }
    { naive_solver. }
    { lia. }
  }

  iAssert (|={⊤}=> (
  aof_ctx predurableC
                   ={⊤}=∗ aof_ctx (predurableC ++ membufC')
                          ∗ (own γ.(len) (mono_nat_auth (1 / 2) (length predurableC))
                             ={⊤}=∗ own γ.(len)
                                      (mono_nat_auth (1 / 2)
                                         (length (predurableC ++ membufC'))))
  ) ∗ (aof_length_lb γ (U64 (length (predurableC ++ membufC'))) ={⊤}=∗ ▷ Q))%I with "[Hmembuf_fupd Hfupd Htoks]" as "HH".
  {
    (* allocate invariant to escrow Q *)
    iMod (own_alloc (Excl ())) as "HQtok".
    { done. }
    iDestruct "HQtok" as (γtok) "Htok".
    iMod (own_alloc (Excl ())) as "HQexcl".
    { done. }
    iDestruct "HQexcl" as (γq) "HQexcl".
    iDestruct (big_sepS_elem_of_acc _ _ (U64 (length (predurableC ++ membufC'))) with "Htoks") as "[Hlen_tok Hlen_toks_rest]".
    { set_solver. }
    iDestruct "Hlen_tok" as "[Hlen_tok|%Hbad]"; last first.
    {
      exfalso.
      rewrite Hsafesize' in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      word.
    }
    iMod (inv_alloc aofN _ (own γtok (Excl ()) ∗ aof_length_lb γ (U64 (length (predurableC ++ membufC'))) ∨ (U64 (length (predurableC ++ membufC')) [[γ.(len_toks)]]↦ ()) ∨ Q ∗ own γq (Excl ())) with "[Hlen_tok]") as "#HQinv".
    {
      iRight. iLeft.
      iFrame.
    }
    iSplitR "Htok"; last first.
    {
      iModIntro.
      iIntros "Haof_lb".
      iInv "HQinv" as "Hq" "Hqclose".
      iDestruct "Hq" as "[>[Htok2 _]|Hq]".
      { iDestruct (own_valid_2 with "Htok Htok2") as %Hbad. contradiction. }
      iDestruct "Hq" as "[>Hlentok|Hq]".
      {
        iInv "Haof_len_inv" as ">Ha" "Haclose".
        unfold aof_len_invariant.
        iDestruct "Ha" as (l) "[Hlen Ha]".
        iDestruct (own_valid_2 with "Hlen Haof_lb") as %Hineq.
        apply mono_nat_both_frac_valid in Hineq as [_ Hineq].
        iDestruct (big_sepS_elem_of_acc _ _ (U64 (length (predurableC ++ membufC'))) with "Ha") as "[Ha Harest]".
        { set_solver. }
        iDestruct "Ha" as "[Hlentok2|%Hbad]"; last first.
        { exfalso. lia. }
        iDestruct (ptsto_conflict with "Hlentok Hlentok2") as %Hbad.
        done.
      }
      iMod ("Hqclose" with "[Htok Haof_lb]").
      { iLeft. iNext. iFrame. }
      iDestruct "Hq" as "[$ _]".
      by iModIntro.
    }

    iModIntro.
    iIntros "Hctx".
    iMod ("Hmembuf_fupd" with "Hctx") as "[Hctx Hmembuf_fupd]".
    iMod ("Hfupd" with "Hctx") as "[$ HQ]".
    iModIntro.

    (* length stuff *)
    iIntros "Hlen".
    iInv "HQinv" as "Hq" "Hqclose".
    iDestruct "Hq" as "[[_ >Hlb]|Hq]".
    {
      iDestruct (own_valid_2 with "Hlen Hlb") as %Hbad.
      exfalso.
      apply mono_nat_both_frac_valid in Hbad as [_ Hbad].
      rewrite Hsafesize' in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      lia.
    }
    iDestruct "Hq" as "[>Hlen_tok|[_ >HQexcl2]]"; last first.
    { iDestruct (own_valid_2 with "HQexcl HQexcl2") as %Hbad. contradiction. }

    iDestruct ("Hlen_toks_rest" with "[$Hlen_tok]") as "Hlen_toks".
    iMod ("Hqclose" with "[HQexcl HQ]") as "_".
    { iRight; iRight; iFrame. }

    iMod ("Hmembuf_fupd" with "Hlen") as "Hlen".

    (* Use tokens to update mono_nat counter *)
    iInv "Haof_len_inv" as ">Ha" "Haclose".
    iDestruct "Ha" as (len) "[Hlen2 Ha]".
    iDestruct (own_valid_2 with "Hlen Hlen2") as %Hleneq.
    apply mono_nat_auth_frac_op_valid in Hleneq as [_ <-].
    iCombine "Hlen Hlen2" as "Hlen".
    rewrite mono_nat_auth_frac_op.
    rewrite Qp.half_half.
    iMod (own_update _ _ (mono_nat_auth 1 (length (predurableC ++ membufC'))) with "Hlen") as "Hlen".
    {
      apply mono_nat_update.
      repeat rewrite app_length.
      lia.
    }
    iEval (rewrite -Qp.half_half) in "Hlen".
    rewrite -mono_nat_auth_frac_op.
    iDestruct "Hlen" as "[Hlen Hlen2]".

    iMod ("Haclose" with "[Ha Hlen_toks Hlen2]") as "_".
    {
      iNext. iExists _. rewrite -Hsafesize'.
      iFrame.
      iApply (big_sepS_impl with "[Ha Hlen_toks]").
      { iApply big_sepS_sep. iFrame. }

      iModIntro.
      iIntros (x ?) "Hx".
      destruct (bool_decide (int.nat (length (predurableC ++ membufC')) < int.nat x)) as [|] eqn:Hineq.
      {
        apply bool_decide_eq_true in Hineq.
        iRight.
        iPureIntro.
        word.
      }
      {
        apply bool_decide_eq_false in Hineq.
        iLeft.
        iDestruct "Hx" as "[[$|%Hbad] [$|%Hineq2]]".
        exfalso.
        word.
      }
    }
    iFrame.
    by iModIntro.
  }

  iMod "HH" as "[Hmembuf_fupd HfupdQ]".

  wp_loadField.
  wp_apply (release_spec with "[-HΦ Haof_log HfupdQ]").
  {
    iFrame "#∗".
    iNext.
    iExists _, _, _, _.
    iFrame "#∗".
    iSplitR ""; last done.
    replace (word.add (length (predurableC ++ membufC)) (length newData)) with
        (U64 (length (predurableC ++ membufC'))); last first.
    {
      repeat rewrite app_length.
      rewrite -word.ring_morph_add.
      word_cleanup.
      repeat (rewrite Nat2Z.inj_add).
      rewrite Z.add_assoc.
      done.
    }
    iFrame.
  }
  wp_pures.
  iApply "HΦ".
  iFrame.
  iIntros "#Hlb".
  iMod ("HfupdQ" with "[Hlb]") as "$"; last by iModIntro.
  replace (U64 (length (predurableC ++ membufC'))) with
      (word.add (length (predurableC ++ membufC)) (length newData)).
  { iFrame "#". }

  repeat rewrite app_length.
  repeat (rewrite Nat2Z.inj_add).
  rewrite Z.add_assoc.
  rewrite -word.ring_morph_add.
  unfold U64.
  done.
Qed.

Lemma wp_AppendOnlyFile__WaitAppend aof_ptr γ (l:u64) aof_ctx :
is_aof aof_ptr γ aof_ctx -∗
  {{{
       True
  }}}
    AppendOnlyFile__WaitAppend #aof_ptr #l
  {{{
       RET #(); aof_length_lb γ l
  }}}.
Proof.
  iIntros "#Haof" (Φ) "!# _ HΦ".
  wp_lam.
  wp_pures.
  iNamed "Haof".
  wp_loadField.
  wp_apply (acquire_spec with "Hmu_inv").
  iIntros "[Hlocked Haof_own]".
  wp_pures.
  wp_apply (wp_forBreak_cond' with "[-]").
  {
    iNamedAccu.
  }
  iModIntro.
  iNamed 1.

  wp_pures.
  iNamed "Haof_own".
  wp_loadField.
  wp_pures.
  wp_if_destruct.
  {
    wp_pures.
    wp_loadField.
    wp_apply (wp_condWait with "[- HΦ]").
    {
      iFrame "#∗".
      iExists _, _, _, _. iFrame "#∗".
      done.
    }
    iIntros "[Hlocked Haof_own]".
    wp_pures.
    iLeft.
    iFrame.
    done.
  }
  iSpecialize ("HΦ" with "[Hdurlen_lb]").
  {
    assert (int.nat l ≤ int.nat durlen) as Hineq.
    {
      word.
    }
    unfold aof_length_lb.
    replace (int.nat durlen)%nat with ((int.nat durlen) `max` int.nat l)%nat by word.
    rewrite -mono_nat_lb_op.
    iDestruct "Hdurlen_lb" as "[_ $]".
  }
  iRight.
  iSplitL ""; first done.
  wp_pures.

  wp_loadField.
  wp_apply (release_spec with "[- HΦ]").
  {
    iFrame "#∗".
    iExists _, _, _, _. iFrame "#∗".
    done.
  }
  iFrame.
Qed.

End aof_proof.


Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.Reflective.Syntax.
Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Reflective.ParserSyntax.
Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Reflective.ParserSemantics.
Require Import Fiat.Parsers.Reflective.PartialUnfold.
Require Import Fiat.Parsers.Reflective.ParserPartialUnfold.
Require Import Fiat.Parsers.Reflective.ParserLogicalRelations.
Set Implicit Arguments.

Section polypnormalize.
  Context (is_valid_nonterminal : list nat -> nat -> bool)
          (strlen : nat)
          (char_at_matches_interp : nat -> Reflective.RCharExpr Ascii.ascii -> bool)
          (split_string_for_production : nat * (nat * nat) -> nat -> nat -> list nat).

  Let interp {T} := interp_has_parse_term (T := T) is_valid_nonterminal strlen char_at_matches_interp split_string_for_production.

  Lemma polypnormalize_correct {T} (term : polyhas_parse_term T)
    : ParserSyntaxEquivalence.has_parse_term_equiv
        nil
        (term interp_TypeCode) (term (normalized_of interp_TypeCode))
      -> interp (term _) = interp (polypnormalize term _).
  Proof.
    subst interp.
    apply polypnormalize_correct; assumption.
  Qed.
End polypnormalize.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.
Require Import Wf_nat.

Require Import BDDvar_ad_nat.
Require Import bdd1.
Require Import bdd2.
Require Import bdd3.
Require Import bdd4.
Require Import bdd5_1.
Require Import bdd5_2.
Require Import bdd6.
Require Import bdd7.
Require Import BDDdummy_lemma_2.
Require Import BDDdummy_lemma_3.
Require Import BDDdummy_lemma_4.
Require Import bdd8.
Require Import bdd9.
Require Import bdd10.
Require Import bdd11.

Definition is_tauto (be : bool_expr) :=
  Neqb BDDone
    (fst
       (snd (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))).

Definition is_valid (be : bool_expr) :=
  forall vb : var_binding, bool_fun_of_bool_expr be vb = true.

Lemma initBDDor_memo_OK : BDDor_memo_OK initBDDconfig initBDDor_memo.
Proof.
  unfold BDDor_memo_OK in |- *. intros. discriminate H.
Qed.

Lemma initBDDneg_memo_OK : BDDneg_memo_OK initBDDconfig initBDDneg_memo.
Proof.
  unfold BDDneg_memo_OK in |- *. intros. discriminate H.
Qed.

Lemma initBDDneg_memo_OK_2 : BDDneg_memo_OK_2 initBDDconfig initBDDneg_memo.
Proof.
  unfold BDDneg_memo_OK_2 in |- *. intros. discriminate H.
Qed.

Lemma is_tauto_is_correct :
 forall be : bool_expr, is_tauto be = true -> is_valid be.
Proof.
  unfold is_tauto, is_valid in |- *. intros.
  elim
   (BDDof_bool_expr_correct be initBDDconfig initBDDneg_memo initBDDor_memo
      initBDDconfig_OK initBDDneg_memo_OK_2 initBDDor_memo_OK).
  intros. elim H1. intros. elim H3. intros. elim H5. intros. elim H7. intros.
  rewrite <- (Neqb_complete _ _ H) in H9.
  exact
   (bool_fun_eq_trans _ _ _ (bool_fun_eq_symm _ _ H9)
      (bool_fun_of_BDDone _ H0) vb).
Qed.

Lemma is_tauto_is_complete :
 forall be : bool_expr, is_valid be -> is_tauto be = true.
Proof.
  unfold is_tauto, is_valid in |- *. intros.
  elim
   (BDDof_bool_expr_correct be initBDDconfig initBDDneg_memo initBDDor_memo
      initBDDconfig_OK initBDDneg_memo_OK_2 initBDDor_memo_OK).
  intros. elim H1. intros. elim H3. intros. elim H5. intros. elim H7. intros.
  rewrite <-
   (BDDunique
      (fst (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))
      H0 BDDone
      (fst
         (snd
            (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))))
   .
  reflexivity.
  unfold config_node_OK in |- *. unfold node_OK in |- *. right. left. reflexivity.
  exact H2.
  apply bool_fun_eq_symm.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_bool_expr be). exact H9.
  apply bool_fun_eq_trans with (bf2 := bool_fun_one). exact H.
  apply bool_fun_eq_symm. exact (bool_fun_of_BDDone _ H0).
Qed.