(** This file implements an interface to [expr] that
 ** makes star, emp, and pure assertions apparent.
 **)
(* Require Import ExtLib.Data.Positive. *)
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Tactics.
Require Import BILogic Pure.
Require Import MirrorCore.EnvI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.TypedFoldApp.
(*
Require Import MirrorCore.Ext.Expr.
Require Import MirrorCore.Ext.AppFull.
*)

Set Implicit Arguments.
Set Strict Implicit.

(** NOTE: This could work on arbitrary expr's **)
Section seplog_fold.
  Variable typ : Type.
  Variable RType_typ : RType typ.
  Variable Typ2_Fun : Typ2 _ Fun.
  Variable sym : Type.
  Variable RSym_sym : RSym sym.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Let Expr_expr := @Expr_expr typ sym _ _ _.
  Local Existing Instance Expr_expr.

  Variable T : Type.
  Variable SL : typ.

  Record SepLogArgs : Type :=
  { do_other : expr typ sym -> list (expr typ sym * T) -> T
  ; do_pure : expr typ sym -> T
  ; do_emp : T
  ; do_star : T -> T -> T
  }.

  Record SepLogSpec : Type :=
  { is_pure : expr typ sym -> bool
  ; is_emp : expr typ sym -> bool
  ; is_star : expr typ sym -> bool
  }.

  Variable sla : SepLogArgs.
  Variable sls : SepLogSpec.

  Record SepLogSpecOk (sls : SepLogSpec)
         (OPS : ILogic.ILogicOps (typD SL))
         (BI : BILOperators (typD SL)) : Type :=
  { _PureOp : @PureOp (typD SL)
  ; _Pure : @Pure _ OPS BI _PureOp
  ; His_pure : forall e,
                 sls.(is_pure) e = true ->
                 forall us vs val,
                   exprD us vs e SL = Some val ->
                   pure val
  ; His_emp : forall e,
                sls.(is_emp) e = true ->
                forall us vs,
                  exprD us vs e SL = Some empSP
  ; His_star : forall e,
                 sls.(is_star) e = true ->
                 forall us vs,
                   exprD us vs e (tyArr SL (tyArr SL SL)) =
                   Some match eq_sym (typ2_cast SL (tyArr SL SL)) in _ = t
                              return t
                        with
                          | eq_refl =>
                            match eq_sym (typ2_cast SL SL) in _ = t
                                  return _ -> t
                            with
                              | eq_refl => sepSP
                            end
                        end
  }.

  Record SepLogArgsOk (R_t : expr typ sym -> T -> tenv typ -> tenv typ -> Prop) :=
  { otherOk
    : forall e es tus tvs,
        @typeof_apps typ sym _ _ _ tus tvs e (List.map fst es) = Some SL ->
        (forall x y,
           In (x,y) es ->
           typeof_expr tus tvs x = Some SL ->
           R_t x y tus tvs) ->
        R_t (apps e (List.map fst es)) (sla.(do_other) e es) tus tvs
  ; pureOk
    : forall e tus tvs,
        typeof_expr tus tvs e = Some SL ->
        sls.(is_pure) e = true ->
        R_t e (sla.(do_pure) e) tus tvs
  ; empOk
    : forall e tus tvs,
        typeof_sym e = Some SL ->
        sls.(is_emp) (Inj e) = true ->
        R_t (Inj e) sla.(do_emp) tus tvs
  ; starOk
    : forall e l r l_res r_res tus tvs,
        typeof_sym e = Some (tyArr SL (tyArr SL SL)) ->
        typeof_expr tus tvs l = Some SL ->
        typeof_expr tus tvs r = Some SL ->
        sls.(is_star) (Inj e) = true ->
        R_t l l_res tus tvs ->
        R_t r r_res tus tvs ->
        R_t (apps (Inj e) (l :: r :: nil)) (sla.(do_star) l_res r_res) tus tvs
  }.

  Require Import ExtLib.Structures.Applicative.
  Instance Applicative_Lazy : Applicative Lazy :=
  { ap := fun _ _ f x z =>
            match f z , x z with
              | Some f , Some x => Some (f x)
              | _ , _ => None
            end
  ; pure := fun _ x => fun _ => Some x }.

  (** NOTE: This does not need to be typed! **)
  Definition AppFullFoldArgs_SepLogArgs
  : AppFullFoldArgs typ sym T.
  refine
    match sla , sls with
      | {| do_other := do_other
         ; do_pure := do_pure
         ; do_star := do_star
         ; do_emp := do_emp |}
      , {| is_pure := is_pure
         ; is_star := is_star
         ; is_emp := is_emp |} =>
        @Build_AppFullFoldArgs
          typ sym T
          (fun v _ _ =>
             if is_pure (Var v) then
               Some (do_pure (Var v))
             else
               if is_emp (Var v) then
                 Some do_emp
               else
                 Some (do_other (Var v) nil))
          (fun u _ _ =>
             if is_pure (UVar u) then
               Some (do_pure (UVar u))
             else
               if is_emp (UVar u) then
                 Some do_emp
               else
                 Some (do_other (UVar u) nil))
          (fun i _ _ =>
             if is_emp (Inj i) then
               Some do_emp
             else
               if is_pure (Inj i) then
                 Some (do_pure (Inj i))
               else
                 Some (do_other (Inj i) nil))
          (fun tus tvs t f fres args z =>
             if is_star f then
               match args with
                 | (_,_,l) :: (_,_,r) :: nil =>
                   match l z , r z with
                     | Some l , Some r =>
                       Some (do_star l r)
                     | _ , _ => None
                   end
                 | _ => Some do_emp
               end
             else
               let original := apps f (map (fun x => snd (fst x)) args) in
               if is_pure original then
                 Some (do_pure original)
               else
                 ap (pure (do_other f))
                    (mapT (fun tev => let '(t,e,v) := tev in
                                      match v tt with
                                        | None => None
                                        | Some v => Some (e,v)
                                      end) args))
          (fun tus tvs t _ e eres _ =>
             if is_pure (Abs t e) then
               Some (do_pure (Abs t e))
             else
               if is_emp (Abs t e) then
                 Some do_emp
               else
                 Some (do_other (Abs t e) nil))
    end.
  Defined.

(* TODO(gmalecha): Port the proof!
  Section sound.
    Hypothesis BILOps : BILOperators (typD nil SL).
    Context R_t `{slaok : SepLogArgsOk R_t}.

    Lemma atomic_ok
    : forall ts (tus tvs : tenv typ) e (t : typ),
        typeof_expr ts tus tvs e = Some t ->
        t = SL ->
        R_t e (sla.(do_other) e nil) tus tvs.
    Proof.
      destruct slaok. simpl; intros. subst.
      change e with (apps e nil) at 1.
      eapply (otherOk0 ts e nil tus tvs); simpl.
      { unfold typeof_apps. simpl. rewrite H. reflexivity. }
      { intuition. }
    Qed.

    Hypothesis is_starOk
    : forall i,
        sls.(is_star) (Inj i) = true ->
        typeof_sym i = Some (tyArr SL (tyArr SL SL)).

    Lemma lem_other
    : forall ts0 t rs tus tvs l_res do_atomic_app0,
        Forall2
          (fun (t0 : typ) (x : expr sym * (tenv typ -> tenv typ -> T)) =>
             typeof_expr tus tvs (fst x) = Some t0 /\
             (t0 = SL -> R_t (fst x) (snd x tus tvs) tus tvs)) ts0 rs ->
        forall e : expr sym,
          typeof_expr tus tvs (apps e (map fst rs)) = Some t ->
          (fold_right tyArr t ts0 = SL -> R_t e (l_res tus tvs) tus tvs) ->
          typeof_apps RSym_sym tus tvs e (map fst rs) = Some SL ->
          (forall (e0 : expr sym) (es : list (expr sym * T)) (tus0 tvs0 : tenv typ),
             typeof_apps RSym_sym tus0 tvs0 e0 (map fst es) = Some SL ->
             (forall (x : expr sym) (y : T),
                In (x, y) es -> typeof_expr tus0 tvs0 x = Some SL -> R_t x y tus0 tvs0) ->
             R_t (apps e0 (map fst es)) (do_atomic_app0 e0 es) tus0 tvs0) ->
          R_t (apps e (map fst rs))
              (do_atomic_app0 e
                              (map
                                 (fun x : expr sym * (tenv typ -> tenv typ -> T) =>
                                    (fst x, snd x tus tvs)) rs)) tus tvs.
    Proof.
      intros.
      specialize (H3 e (map
                          (fun x : expr sym * (tenv typ -> tenv typ -> T) =>
                             (fst x, snd x tus tvs)) rs) tus tvs).
      rewrite map_map in *. simpl in *.
      eapply H3; eauto.
      clear - H. induction H; simpl; intuition.
      inv_all. subst. rewrite H1 in *. inv_all; subst.
      eauto.
    Qed.

    Definition AppFullFoldArgsOk_SepLogsOk
    : AppFullFoldArgsOk _ (AppFullFoldArgs_SepLogArgs sla)
                        (fun t e res tus tvs =>
                           t = SL ->
                           R_t e res tus tvs).
    Proof.
      remember sla as s; destruct s; simpl; remember sls as s; destruct s.
      constructor.
      { simpl; intros.
        replace do_other0 with (sla.(do_other)).
        eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. }
      { simpl; intros.
        replace do_other0 with (sla.(do_other)).
        eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. }
      { simpl; intros.
        consider (is_emp0 v); intros.
        { replace do_emp0 with (sla.(do_emp)).
          eapply (@empOk _ slaok); eauto.
          Cases.rewrite_all_goal. auto.
          rewrite <- Heqs0. simpl. auto.
          rewrite <- Heqs. reflexivity. }
        { replace do_other0 with (sla.(do_other)).
          eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. } }
      { simpl; intros.
        replace do_other0 with (sla.(do_other)).
        eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. }
      { intros. subst ft. simpl.
        assert (typeof_apps RSym_sym tus tvs l (map fst rs) = Some SL).
        { rewrite <- typeof_expr_apps. congruence. }
        generalize (otherOk slaok). rewrite <- Heqs. simpl.
        destruct l; eauto using lem_other.
        consider (is_star0 s); eauto using lem_other; intros.
        { generalize H4. eapply is_starOk in H4.
          unfold typeof_apps in H3.
          simpl in H3. rewrite H4 in *.
          inversion H1; clear H1; try subst.
          { subst rs ts0; intros.
            simpl in *. clear - H3. inv_all.
            symmetry in H3. eapply tyArr_circ_L in H3. intuition. }
          { subst rs ts0. inversion H7; clear H7.
            { subst l l'; intros; simpl in *.
              rewrite H4 in *. forward.
              intuition. inv_all. subst y t0.
              clear - H8. symmetry in H8.
              eapply tyArr_circ_L in H8. intuition. }
            { subst l l'. inversion H8; clear H8.
              { subst l0 l'0. intuition. subst t.
                destruct y, y0; simpl in *.
                rewrite H8 in *. rewrite H6 in *. rewrite H4 in *.
                unfold type_of_apply in *. forward.
                inv_all.
                subst x0 x t1 t2 t3 p0 p.
                replace do_star0 with (sla.(do_star));
                  [ | rewrite <- Heqs; reflexivity ].
                eapply (starOk slaok); eauto.
                rewrite <- Heqs0. auto. }
              { exfalso. clear Heqs Heqs0. subst.
                simpl in H3. intuition.
                rewrite H2 in *. rewrite H6 in *. rewrite H1 in *.
                forward. inv_all; try subst.
                clear H15 H13. subst x x0 x1.
                clear - H14.
                eapply type_of_applys_circle_False in H14. auto. } } } } }
    Qed.

    Definition seplog_fold (sla : SepLogArgs) : expr sym -> tenv typ -> tenv typ -> T :=
      app_fold_args (AppFullFoldArgs_SepLogArgs sla).

    Theorem seplog_fold_sound
    : forall e tus tvs result,
        seplog_fold sla e tus tvs = result ->
        typeof_expr tus tvs e = Some SL ->
        R_t e result tus tvs.
    Proof.
      intros.
      eapply (app_fold_args_sound AppFullFoldArgsOk_SepLogsOk) in H; eauto.
    Qed.
  End sound.
*)

(*
  Variable OPS : ILogic.ILogicOps (typD ts nil SL).
  Variable BI : BILOperators (typD ts nil SL).
  Variable slsok : SepLogSpecOk sls OPS BI.

  Require Import Relations.
  Require Import ExtLib.Data.HList.

  Record SepLogArgsSemOk
         (TD : T -> forall tus tvs, tenv typ -> tenv typ -> option (typD ts nil SL))
         (R : forall tus tvs,
                relation (hlist (typD ts nil) tus ->
                          hlist (typD ts nil) tvs ->
                          typD ts nil SL)) :=
  { atomic_appOk
    : forall e es tus tvs val,
        exprD' tus tvs (apps e es) SL = Some val ->
        R tus tvs val (TD (sla.(do_other) e es))
  ; pureOk
    : forall e tus tvs,
        typeof_expr tus tvs e = Some SL ->
        sls.(is_pure) e = true ->
        R_t e (sla.(do_pure) e) tus tvs
  ; empOk
    : forall e tus tvs,
        typeof_sym e = Some SL ->
        sls.(is_emp) e = true ->
        R_t (Inj e) sla.(do_emp) tus tvs
  ; starOk
    : forall e l r l_res r_res tus tvs,
        typeof_sym e = Some (tyArr SL (tyArr SL SL)) ->
        typeof_expr tus tvs l = Some SL ->
        typeof_expr tus tvs r = Some SL ->
        sls.(is_star) e = true ->
        R_t l l_res tus tvs ->
        R_t r r_res tus tvs ->
        R_t (apps (Inj e) (l :: r :: nil)) (sla.(do_star) l_res r_res) tus tvs
  }.
*)

End seplog_fold.


Require Import Crypto.Util.Notations.

Local Set Boolean Equality Schemes.
Local Set Decidable Equality Schemes.
Local Set Implicit Arguments.
Inductive ErrorT {ErrT T} :=
| Success (v : T)
| Error (msg : ErrT).

Global Arguments ErrorT : clear implicits.
Declare Scope error_scope.
Delimit Scope error_scope with error.
Bind Scope error_scope with ErrorT.

Definition invert_result {ErrT T} (v : ErrorT ErrT T)
  := match v return match v with Success _ => T | _ => ErrT end with
     | Success v => v
     | Error msg => msg
     end.

Definition bind {A B ErrT} (x : ErrorT ErrT A) (k : A -> ErrorT ErrT B) : ErrorT ErrT B
  := match x with
     | Success v => k v
     | Error msg => Error msg
     end.

Definition map2 {ErrT1 ErrT2 A B} (f : A -> B) (fe : ErrT1 -> ErrT2) (x : ErrorT ErrT1 A) : ErrorT ErrT2 B
  := match x with
     | Success v => Success (f v)
     | Error e => Error (fe e)
     end.

Definition map {ErrT A B} (f : A -> B) : ErrorT ErrT A -> ErrorT ErrT B
  := map2 f id.

Definition map_error {ErrT1 ErrT2 A} (fe : ErrT1 -> ErrT2) : ErrorT ErrT1 A -> ErrorT ErrT2 A
  := map2 id fe.

Definition error_bind {ErrT1 ErrT2 A} (x : ErrorT ErrT1 A) (k : ErrT1 -> ErrorT ErrT2 A) : ErrorT ErrT2 A
  := match x with
     | Success v => Success v
     | Error msg => k msg
     end.

Notation "x <- y ; f" := (bind y (fun x => f%error)) : error_scope.

(** ** Equality for [ErrorT] *)
Section ErrorT.
  Local Notation ErrorT_code u v
    := (match u, v with
        | Success u', Success v'
        | Error u', Error v'
          => u' = v'
        | Success _, _
        | Error _, _
          => False
        end).

  (** *** Equality of [ErrorT] is a [match] *)
  Definition path_ErrorT {A B} (u v : ErrorT A B) (p : ErrorT_code u v)
    : u = v.
  Proof. destruct u, v; first [ apply f_equal | exfalso ]; exact p. Defined.

  (** *** Equivalence of equality of [ErrorT] with [ErrorT_code] *)
  Definition unpath_ErrorT {A B} {u v : ErrorT A B} (p : u = v)
    : ErrorT_code u v.
  Proof. subst v; destruct u; reflexivity. Defined.

  Definition path_ErrorT_iff {A B}
             (u v : @ErrorT A B)
    : u = v <-> ErrorT_code u v.
  Proof.
    split; [ apply unpath_ErrorT | apply path_ErrorT ].
  Defined.

  (** *** Eta-expansion of [@eq (ErrorT _ _)] *)
  Definition path_ErrorT_eta {A B} {u v : @ErrorT A B} (p : u = v)
    : p = path_ErrorT u v (unpath_ErrorT p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (ErrorT _ _)] *)
  Definition path_ErrorT_rect {A B} {u v : @ErrorT A B} (P : u = v -> Type)
             (f : forall p, P (path_ErrorT u v p))
    : forall p, P p.
  Proof. intro p; specialize (f (unpath_ErrorT p)); destruct u, p; exact f. Defined.
  Definition path_ErrorT_rec {A B u v} (P : u = v :> @ErrorT A B -> Set) := path_ErrorT_rect P.
  Definition path_ErrorT_ind {A B u v} (P : u = v :> @ErrorT A B -> Prop) := path_ErrorT_rec P.
End ErrorT.

(** ** Useful Tactics *)
(** *** [inversion_ErrorT] *)
Ltac induction_path_ErrorT H :=
  induction H as [H] using path_ErrorT_rect;
  try match type of H with
      | False => exfalso; exact H
      end.
Ltac inversion_ErrorT_step :=
  match goal with
  | [ H : Success _ = Success _ |- _ ]
    => induction_path_ErrorT H
  | [ H : Success _ = Error _ |- _ ]
    => induction_path_ErrorT H
  | [ H : Error _ = Success _ |- _ ]
    => induction_path_ErrorT H
  | [ H : Error _ = Error _ |- _ ]
    => induction_path_ErrorT H
  end.
Ltac inversion_ErrorT := repeat inversion_ErrorT_step.


Require Import Arith.
Require Import Zee.vals.
Require Import Zee.dec Zee.maplike.
Require Import Lia.
Require Import String.

Section Frame.
  Context {A : Set}.
  Definition V := @V A.
  Definition SecTyV := @SecTyV A.

(*  Definition Lab := @Lab A.
  Definition Ty := @Ty A.
  Definition LabVar := @LabVar A.
  Definition SecTy := @SecTy A.
  Definition AtomSecTy := @AtomSecTy A.
*)

  Definition Range : Type := nat * nat.
  Opaque Range.

  Class HasRange (A : Type) :=
    {
      dom: A -> Range
    }.
  Hint Constructors HasRange.

  Global Instance HasRange_Range : HasRange Range.
  Proof.
    constructor.
    eapply id.
  Defined.

  Definition in_range {T : Type} `{HasRange T} (n : nat) (x : T) : Prop :=
    let (n1, n2) := dom x in n1 <= n /\ n <= n1 + n2.
  Hint Unfold in_range.

  Infix "∈" := in_range (at level 70).
  Infix "∉" := (fun n r => not (in_range n r)) (at level 80).

  Lemma in_range_dec {T : Type} `{HasRange T} n r:
    { n ∈ r } + { n ∉ r }.
  Proof.
    destruct (dom r) as [n1 n2] eqn:?H.
    unfold in_range.
    rewrite -> H0.
    destruct (le_dec n1 n).
    - destruct (le_dec n (n1 + n2)).
      + left.
        split; assumption.
      + right.
        intro.
        eapply n0.
        eapply (proj2 H1).
    - right.
      intro.
      eapply n0.
      eapply (proj1 H1).
  Defined.

  Class HasVersion (A : Type) :=
    {
      version: A -> Version
    }.
  Hint Constructors HasVersion.

  Record EFrame (M : Type) `{MapLike M nat V} :=
    {
      range_of : Range;
      mem_of : M;
      version_of: Version
    }.
  Hint Constructors EFrame.
  Global Arguments Build_EFrame { _ } { _ }.
  Global Arguments range_of { _ } { _ }.
  Global Arguments mem_of { _ } { _ }.
  Global Arguments version_of { _ } { _ }.

  Global Instance HasRange_EFrame {M : Type} `{MapLike M nat V} :
    HasRange (EFrame M) := {}.
  intros.
  eapply (dom (range_of X)).
  Defined.

  Global Instance HasVersion_EFrame {M : Type} `{MapLike M nat V} :
    HasVersion (EFrame M) := {}.
  intros.
  eapply (version_of X).
  Defined.

  Global Instance ReadableMapLike_EFrame {M : Type} `{MapLike M nat V} :
    ReadableMapLike (EFrame M) nat V := {}.
  - intros efr n.
    eapply (mem_of efr ? n).
  - eapply (Build_EFrame (0, 0) ∅ 0).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_EFrame {M : Type} `{MapLike M nat V} :
    WriteableMapLike (EFrame M) nat V := {}.
  intros n v efr.
  eapply (Build_EFrame (dom efr) (mem_of efr [n ↦ v]) (version_of efr)).
  Defined.

  Global Instance MapLike_EFrame {M : Type} `{MapLike M nat V} :
    MapLike (EFrame M) nat V := {}.
  - intros.
    simpl.
    eapply lookup_update_eq.
  - intros.
    simpl.
    eapply lookup_update_neq.
    assumption.
  Defined.

  Definition fp_of {T : Type} `{HasRange T} (x : T) := fst (dom x).
  Definition sp_of {T : Type} `{HasRange T} (x : T) := fst (dom x) + snd (dom x).
  Hint Unfold fp_of sp_of.

  Definition wf_EFrame {M : Type} `{MapLike M nat V} (efr : EFrame M) : Prop :=
    forall a, a ∈ efr -> efr ? a <> None.
  Hint Unfold wf_EFrame.

  Record PFrame (Var Arg Loc : Type) `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} :=
    {
      pvar_of : Var;
      parg_of : Arg;
      ploc_of : Loc;
    }.
  Hint Constructors PFrame.
  Global Arguments Build_PFrame { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments pvar_of { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments parg_of { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments ploc_of { _ } { _ } { _ } { _ } { _ } { _ }.

  Global Instance ReadableMapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : ReadableMapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  - intros pfr x.
    eapply (pvar_of pfr ? x).
  - eapply (Build_PFrame ∅ ∅ ∅).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : WriteableMapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  intros x τℓ pfr.
  eapply (Build_PFrame (pvar_of pfr [x ↦ τℓ]) (parg_of pfr) (ploc_of pfr)).
  Defined.

  Global Instance MapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : MapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  - intros.
    simpl.
    eapply lookup_update_eq.
  - intros.
    simpl.
    eapply lookup_update_neq.
    assumption.
  Defined.

  Global Instance FinMapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : FinMapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  - intros pfr.
    eapply (values (pvar_of pfr)).
  - cbn.
    eapply values_empty.
  - intros.
    eapply values_add.
  Defined.

  Definition upd_loc {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} (x : string) (τ : SecTyV) (pfr : PFrame Var Arg Loc): PFrame Var Arg Loc.
    eapply (Build_PFrame (pvar_of pfr)
                         (parg_of pfr)
                         (update x τ (ploc_of pfr))).
  Defined.

  Definition upd_arg {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} (x : string) (τ : SecTyV) (pfr : PFrame Var Arg Loc): PFrame Var Arg Loc.
    eapply (Build_PFrame (pvar_of pfr)
                         (update x τ (parg_of pfr))
                         (ploc_of pfr)).
  Defined.

  Definition upd_var {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} (x : string) (τℓ : A + SecTyV) (pfr : PFrame Var Arg Loc) : PFrame Var Arg Loc.
    eapply (Build_PFrame (update x τℓ (pvar_of pfr))
                         (parg_of pfr)
                         (ploc_of pfr)).
  Defined.
  Hint Unfold upd_loc upd_arg upd_var.

  Record Frame (Var Arg Loc Mem : Type) `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V} :=
    {
      pframe_of : PFrame Var Arg Loc;
      eframe_of : EFrame Mem
    }.
  Hint Constructors Frame.

  Global Arguments pframe_of { _ } { _ } { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments eframe_of { _ } { _ } { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments Build_Frame { _ } { _ } { _ } { _ } { _ } { _ } { _ } { _ }.

  Global Instance ReadableMapLike_nat_V_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V} : ReadableMapLike (Frame Var Arg Loc Mem) nat V := {}.
  - exact (fun fr n => eframe_of fr ? n).
  - eapply (Build_Frame ∅ ∅).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_nat_V_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: WriteableMapLike (Frame Var Arg Loc Mem) nat V := {}.
  exact (fun n v fr => Build_Frame (pframe_of fr) (eframe_of fr [n ↦ v])).
  Defined.

  Global Instance MapLike_nat_V_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: MapLike (Frame Var Arg Loc Mem) nat V := {}.
  Proof.
    - intros.
      simpl.
      eapply lookup_update_eq.
    - intros.
      simpl.
      eapply lookup_update_neq; assumption.
  Defined.
  Hint Resolve MapLike_nat_V_Fr.

  Global Instance HasVersion_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V} : HasVersion (Frame Var Arg Loc Mem).
  constructor.
  intros.
  eapply (version (eframe_of X)).
  Defined.
  Hint Resolve HasVersion_Fr.

  Global Instance ReadableMapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: ReadableMapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  - exact (fun fr x => pframe_of fr ? x).
  - eapply (Build_Frame ∅ ∅).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: WriteableMapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  exact (fun x τℓ fr => Build_Frame (pframe_of fr [x ↦ τℓ]) (eframe_of fr)).
  Defined.

  Global Instance MapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: MapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  - intros.
    simpl.
    eapply lookup_update_eq.
  - intros.
    simpl.
    eapply lookup_update_neq; assumption.
  Defined.
  Hint Resolve MapLike_var_ty_or_sec_Fr.

  Global Instance FinMapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: FinMapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  exact (fun fr => values (pframe_of fr)).
  - cbn.
    eapply values_empty.
  - intros.
    cbn.
    eapply values_add.
  Defined.
  Hint Resolve FinMapLike_var_ty_or_sec_Fr.

  Global Instance HasRange_Frame {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: HasRange (Frame Var Arg Loc Mem) := {}.
  intros fr.
  eapply (dom (eframe_of fr)).
  Defined.

End Frame.

Infix "∈" := in_range (at level 70).
Infix "∉" := (fun n r => not (in_range n r)) (at level 80).


From RecoveryRefinement Require Import Lib.
Require Import Spec.HoareTactics.

Require Import Examples.Logging.Impl.

From Classes Require Import Classes.

Opaque plus.
Opaque lt.

Import EqualDecNotation.

Record LogValues :=
  { values :> list block;
    values_ok: length values = LOG_LENGTH }.

Coercion addresses : Descriptor >-> list.

Record PhysicalState :=
  { p_hdr: LogHdr;
    p_desc: Descriptor;
    p_log_values: LogValues;
    p_data_region: disk; }.

Inductive PhyDecode (d: disk) : PhysicalState -> Prop :=
| phy_decode hdr desc (log_values:LogValues) data
             (Hhdr: index d 0 = Some (LogHdr_fmt.(encode) hdr))
             (Hdesc: index d 1 = Some (Descriptor_fmt.(encode) desc))
             (Hlog_values: forall i,
                 i < LOG_LENGTH ->
                 index d (2+i) = index log_values i)
             (Hdata: forall i,
                 index d (2+LOG_LENGTH+i) = index data i) :
    PhyDecode d {| p_hdr := hdr;
                   p_desc := desc;
                   p_log_values := log_values;
                   p_data_region := data; |}
.

Lemma log_length_nonzero : LOG_LENGTH > 0.
  unfold LOG_LENGTH.
  lia.
Qed.

(* coercion magic makes this theorem seem odd - the proof comes from inside
log_values *)
Lemma length_log (log_values:LogValues) :
  length log_values = LOG_LENGTH.
Proof.
  destruct log_values; auto.
Qed.

#[export] Hint Rewrite length_log : length.

(* TODO: Hint Rewrite length_descriptor breaks a proof here *)

Theorem PhyDecode_disk_bound d ps :
  PhyDecode d ps ->
  length d >= 2 + LOG_LENGTH.
Proof.
  pose proof log_length_nonzero.
  inversion 1; subst.
  specialize (Hlog_values (LOG_LENGTH-1) ltac:(lia)).
  rewrite (index_inbounds log_values (LOG_LENGTH-1)) in Hlog_values;
    autorewrite with length;
    try lia.
  apply index_some_bound in Hlog_values.
  lia.
Qed.

Theorem PhyDecode_data_len d ps :
  PhyDecode d ps ->
  length ps.(p_data_region) = length d - 2 - LOG_LENGTH.
Proof.
  inversion 1; subst; simpl.
  apply length_bounds.
  - apply index_none_bound.
    rewrite <- Hdata; array.
  - assert (length d <= 2 + LOG_LENGTH + length data); try lia.
    apply index_none_bound.
    rewrite Hdata; array.
Qed.

Theorem PhyDecode_disk_len d ps :
  PhyDecode d ps ->
  length d = 2 + LOG_LENGTH + length ps.(p_data_region).
Proof.
  intros.
  pose proof (PhyDecode_disk_bound H).
  pose proof (PhyDecode_data_len H).
  lia.
Qed.

Lemma one_disk_failure_unfold s s' r :
  D.one_disk_failure s s' r ->
  s' = s.
Proof.
  inversion 1; auto.
Qed.

Lemma ODLayer_crash s s' r :
  D.ODLayer.(crash_step) s s' r ->
  s' = s.
Proof.
  simpl; eauto using one_disk_failure_unfold.
Qed.

Global Hint Resolve ODLayer_crash : core.

Ltac match_abs :=
  match goal with
  | [ H: PhyDecode ?d _ |- PhyDecode ?d _ ] => exact H
  | [ H: PhyDecode ?d ?ps |- context[PhyDecode ?d _] ] =>
    match goal with
    | |- exists _, _ => solve [ destruct ps; descend; eauto ]
    end
  end.

Ltac simplify :=
  repeat match goal with
         | _ => match_abs
         | _ => progress propositional
         | [ H: D.one_disk_failure _ _ _ |- _ ] =>
           apply one_disk_failure_unfold in H
         | [ H: D.ODLayer.(sem).(crash_step) _ _ _ |- _ ] =>
           apply ODLayer_crash in H
         | |- _ /\ _ => split; [ solve [ auto ] | ]
         | |- _ /\ _ => split; [ | solve [ auto ] ]
         | _ => destruct_tuple
         | [ u: unit |- _ ] => destruct u
         | [ H: (_, _) = (_, _) |- _ ] => inv_clear H
         | _ => progress cbn [pre post alternate] in *
         end.

Ltac finish :=
  repeat match goal with
         | _ => match_abs
         | _ => solve [ eauto ]
         | _ => congruence
         | _ => lia
         end.

Lemma and_wlog (P Q:Prop) :
  P ->
  (P -> Q) ->
  P /\ Q.
Proof.
  firstorder.
Qed.

Ltac split_wlog :=
  repeat match goal with
         | _ => match_abs
         | |- _ /\ _ => apply and_wlog
         | [ H: _ \/ _ |- _ ] => destruct H
         | _ => progress propositional
         | _ => solve [ auto ]
         end.

Ltac split_cases :=
  repeat match goal with
         | _ => match_abs
         | |- _ /\ _ => split
         | [ H: _ \/ _ |- _ ] => destruct H
         | _ => progress propositional
         | _ => solve [ eauto ]
         end.

(* specs for one-disk primitives (restatement of semantics as specs) *)
Ltac prim :=
  eapply proc_hspec_impl; [ unfold spec_impl | eapply op_spec_sound ];
  simpl in *;
  propositional;
  (intuition eauto);
  propositional;
  repeat match goal with
         | [ H: D.one_disk_failure _ _ _ |- _ ] =>
           apply one_disk_failure_unfold in H
         end.

Local Notation proc_hspec := (Hoare.proc_hspec D.ODLayer.(sem)).
Arguments Hoare.proc_hspec {Op State} sem {T}.

Theorem read_ok a :
  proc_hspec
    (read a)
    (fun state =>
       {| pre := True;
          post state' r :=
            index state a ?|= eq r /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold read.
  prim;
    repeat match goal with
           | [ H: D.op_step _ _ _ _ |- _ ] => invert H; clear H
           end;
    propositional;
    auto.
  destruct (index s' a); simpl; finish.
Qed.

Theorem write_ok a v :
  proc_hspec
    (write a v)
    (fun state =>
       {| pre := True;
          post state' r :=
            r = tt /\
            state' = assign state a v;
          alternate state' _ :=
            state' = state \/
            state' = assign state a v; |}).
Proof.
  unfold write.
  prim;
    repeat match goal with
           | [ H: D.op_step _ _ _ _ |- _ ] => invert H; clear H
           end;
    propositional;
    auto.
Qed.

Theorem size_ok :
  proc_hspec
    (size)
    (fun state =>
       {| pre := True;
          post state' r :=
            r = length state /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold size.
  prim;
    repeat match goal with
           | [ H: D.op_step _ _ _ _ |- _ ] => invert H; clear H
           end;
    propositional;
    auto.
Qed.

Local Hint Resolve read_ok write_ok size_ok : core.

Ltac step :=
  step_proc; simplify; eauto.

Opaque index.
Opaque D.ODLayer.

Theorem gethdr_ok ps :
  proc_hspec
    gethdr
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            r = ps.(p_hdr) /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold gethdr.
  step.
  step.
  inversion H; subst; simpl in *.
  replace (index state 0) in *; simpl in *; subst.
  rewrite LogHdr_fmt.(encode_decode); eauto.
Qed.

Local Hint Resolve gethdr_ok : core.

Lemma phy_writedesc:
  forall (ps : PhysicalState) (desc : Descriptor) (s : D.State),
    PhyDecode s ps ->
    PhyDecode (assign s 1 (Descriptor_fmt.(encode) desc))
              {|
                p_hdr := ps.(p_hdr);
                p_desc := desc;
                p_log_values := ps.(p_log_values);
                p_data_region := ps.(p_data_region) |}.
Proof.
  intros ps desc s H.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; constructor; intros; array.
Qed.

Local Hint Resolve phy_writedesc : core.

Lemma phy_writehdr:
  forall (ps : PhysicalState) (hdr : LogHdr) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    PhyDecode (assign s 0 (LogHdr_fmt.(encode) hdr))
              {| p_hdr := hdr;
                 p_desc := ps.(p_desc);
                 p_log_values := ps.(p_log_values);
                 p_data_region := ps.(p_data_region) |}.
Proof.
  intros ps hdr s H.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; constructor; intros; array.
Qed.

Local Hint Resolve phy_writehdr : core.

Ltac spec_impl :=
  eapply proc_hspec_impl; [ unfold spec_impl | solve [ eauto] ];
  simplify.

Theorem writehdr_ok ps hdr :
  proc_hspec
    (writehdr hdr)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            PhyDecode state' {| p_hdr := hdr;
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |};
          alternate state' _ :=
            PhyDecode state' ps \/
            PhyDecode state' {| p_hdr := hdr;
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |}
       |}).
Proof.
  unfold writehdr.
  spec_impl; split_wlog.
Qed.

Local Hint Resolve writehdr_ok : core.

Theorem writedesc_ok ps desc :
  proc_hspec
    (writedesc desc)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            r = tt /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := desc;
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |};
          alternate state' _ :=
            PhyDecode state' ps \/
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := desc;
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |}
       |}).
Proof.
  unfold writedesc.
  spec_impl; split_wlog.
Qed.

Local Hint Resolve writedesc_ok : core.

Definition log_assign (log_values:LogValues) i b : LogValues :=
  {| values := assign log_values i b;
     values_ok := ltac:(autorewrite with length; auto); |}.

Local Hint Resolve addresses_length : core.

Definition desc_assign (desc:Descriptor) i a : Descriptor :=
  {| addresses := assign desc i a;
     addresses_length := ltac:(autorewrite with length; auto); |}.

Lemma phy_set_log_value:
  forall (ps : PhysicalState) (i : nat) (a : addr) (v : block),
    i < LOG_LENGTH ->
    forall s : D.State,
      PhyDecode s
                {|
                  p_hdr := ps.(p_hdr);
                  p_desc := add_addr ps.(p_desc) i a;
                  p_log_values := ps.(p_log_values);
                  p_data_region := ps.(p_data_region) |} ->
      PhyDecode (assign s (2 + i) v)
                {|
                  p_hdr := ps.(p_hdr);
                  p_desc := desc_assign ps.(p_desc) i a;
                  p_log_values := log_assign ps.(p_log_values) i v;
                  p_data_region := ps.(p_data_region) |}.
Proof.
  intros ps i a v Hbound s H.
  pose proof (PhyDecode_disk_len H); simpl in *.
  inv_clear H; constructor; intros;
    cbn [log_assign values]; array.

  destruct (i == i0); subst; array.
Qed.

Local Hint Resolve phy_set_log_value : core.

Theorem getdesc_ok ps :
  proc_hspec
    (getdesc)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            r = ps.(p_desc) /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold getdesc.
  step.
  step.
  inv_clear H; simpl in *.
  replace (index state 1) in *; simpl in *; propositional.
  rewrite Descriptor_fmt.(encode_decode); eauto.
Qed.

Local Hint Resolve getdesc_ok : core.

Theorem set_desc_ok ps desc i a v :
  proc_hspec
    (set_desc desc i a v)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 ps.(p_desc) = desc /\
                 i < LOG_LENGTH;
          post state' r :=
            r = tt /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                           p_desc := desc_assign desc i a;
                           p_log_values :=
                             log_assign ps.(p_log_values) i v;
                           p_data_region := ps.(p_data_region) |};
          alternate state' _ :=
            exists desc' log_values',
              PhyDecode state' {| p_hdr := ps.(p_hdr);
                              p_desc := desc';
                              p_log_values := log_values';
                              p_data_region := ps.(p_data_region); |};
       |}).
Proof.
  unfold set_desc.
  step; split_cases; simplify; finish.
  spec_impl; split_wlog; simplify; finish.
Qed.

Local Hint Resolve set_desc_ok : core.

Theorem phy_log_size_ok ps :
  proc_hspec
    (log_size)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            state' = state /\
            r = length ps.(p_data_region);
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold log_size.
  step.
  step.
  pose proof (PhyDecode_data_len H).
  intuition eauto.
  lia.
Qed.

Local Hint Resolve phy_log_size_ok : core.

Lemma sel_log_value d ps i :
  PhyDecode d ps ->
  i < LOG_LENGTH ->
  sel d (2 + i) = sel ps.(p_log_values) i.
Proof.
  intros; inv_clear H; simpl.
  apply sel_index_eq.
  eauto.
Qed.

Theorem get_logwrite_ok ps desc i :
  proc_hspec
    (get_logwrite desc i)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 i < LOG_LENGTH /\
                 ps.(p_desc) = desc;
          post state' r :=
            state' = state /\
            r = (sel ps.(p_desc) i, sel ps.(p_log_values) i);
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold get_logwrite.
  step.
  step.
  intuition eauto.
  pose proof (PhyDecode_disk_len H).
  f_equal.
  (* BUG: rewrite does not try to instantiate def using the typeclass without
  the (def:=_) *)
  rewrite (index_inbounds (def:=_)) in H1 by lia.
  simpl in *; propositional.
  auto using sel_log_value.
Qed.

Local Hint Resolve get_logwrite_ok : core.

Lemma phy_index_data:
  forall (ps : PhysicalState) (a : nat) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    forall v : block,
      index s (2 + LOG_LENGTH + a) ?|= eq v ->
      index ps.(p_data_region) a ?|= eq v.
Proof.
  intros ps a s H v H0.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; simpl in *.

  destruct (index_dec data a);
    propositional;
    autorewrite with array in *;
    auto.

  rewrite (index_inbounds (def:=_)) in * by lia; simpl.
  simpl in *; propositional.
  apply sel_index_eq; auto.
Qed.

Local Hint Resolve phy_index_data : core.

Theorem data_read_ok ps a :
  proc_hspec
    (data_read a)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            state' = state /\
            index ps.(p_data_region) a ?|= eq r;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold data_read.
  spec_impl; finish.
Qed.

Local Hint Resolve data_read_ok : core.

Lemma phy_data_write:
  forall (ps : PhysicalState) (a : nat) (v : block) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    PhyDecode (assign s (2 + LOG_LENGTH + a) v)
              {|
                p_hdr := ps.(p_hdr);
                p_desc := ps.(p_desc);
                p_log_values := ps.(p_log_values);
                p_data_region := assign ps.(p_data_region) a v |}.
Proof.
  intros ps a v s H.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; constructor; intros; simpl in *; array.
  destruct (a == i); subst; array.
  destruct (index_dec data i); propositional; array.
Qed.

Local Hint Resolve phy_data_write : core.

Theorem data_write_ok ps a v :
  proc_hspec
    (data_write a v)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state r :=
            r = tt /\
            PhyDecode state {| p_hdr := ps.(p_hdr);
                           p_desc := ps.(p_desc);
                           p_log_values := ps.(p_log_values);
                           p_data_region :=
                             assign ps.(p_data_region) a v; |};
          alternate state' _ :=
            exists data,
              (data = ps.(p_data_region) \/
               data = assign ps.(p_data_region) a v) /\
              PhyDecode state' {| p_hdr := ps.(p_hdr);
                              p_desc := ps.(p_desc);
                              p_log_values := ps.(p_log_values);
                              p_data_region := data |};
       |}).
Proof.
  unfold data_write.
  spec_impl; split_wlog; simplify; finish.
Qed.

Local Hint Resolve data_write_ok : core.

Theorem log_write_ok ps a v :
  proc_hspec
    (log_write a v)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            match r with
            | TxnD.WriteOK =>
              let hdr := ps.(p_hdr) in
              exists pf,
                PhyDecode state'
                          {| p_hdr := hdr_inc hdr pf;
                             p_desc :=
                               desc_assign ps.(p_desc) hdr.(log_length) a;
                             p_log_values :=
                               log_assign ps.(p_log_values) hdr.(log_length) v;
                             p_data_region := ps.(p_data_region); |}
            | TxnD.WriteErr =>
              state' = state /\
              ps.(p_hdr).(log_length) = LOG_LENGTH
            end;
          alternate state' _ :=
            (* if we crash the log will still be uncommited, so just promise
            that the data is unaffected *)
            exists hdr desc log_values,
              PhyDecode state' {| p_hdr := hdr;
                              p_desc := desc;
                              p_log_values := log_values;
                              p_data_region := ps.(p_data_region) |} /\
              hdr.(committed) = ps.(p_hdr).(committed);
       |}).
Proof.
  unfold log_write.
  step_proc; split_wlog; simplify; finish.
  destruct (hdr_full r).
  { step; simplify; finish. }
  destruct ps; eauto.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
Qed.

(* this is just a physical description of [apply_at]; it precisely encodes the
data since we can't accurately abstract it that this level (we need to refer to
the old disk, which isn't tracked in these specs) *)
Theorem apply_at_ok ps desc i :
  proc_hspec
    (apply_at desc i)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 desc = ps.(p_desc) /\
                 i < LOG_LENGTH;
          post state' r :=
            r = tt /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region :=
                              let a := sel ps.(p_desc) i in
                              let v := sel ps.(p_log_values) i in
                              assign ps.(p_data_region) a v; |};
          alternate state' _ :=
            exists data,
              (data = ps.(p_data_region) \/
               let a := sel ps.(p_desc) i in
               let v := sel ps.(p_log_values) i in
               data = assign ps.(p_data_region) a v) /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region := data; |};
       |}).
Proof.
  unfold apply_at.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
Qed.

Lemma log_subslice_len_ok:
  forall state : D.ODLayer.(State),
    ~ length state < 2 + LOG_LENGTH -> length (subslice state 2 LOG_LENGTH) = LOG_LENGTH.
Proof.
  intros.
  rewrite length_subslice; lia.
Qed.

Theorem phy_log_init_ok :
  proc_hspec
    (log_init)
    (fun state =>
       {| pre := True;
          post state' r :=
            match r with
            | Initialized =>
              exists ps, PhyDecode state' ps /\
                    ps.(p_hdr).(committed) = false /\
                    ps.(p_hdr).(log_length) = 0
            | InitFailed => state' = state
            end;
          alternate state' _ := True |}).
Proof.
  unfold log_init.
  step.
  destruct matches.
  - step.
  - unfold writehdr, writedesc.
    repeat step.
    exists {| p_hdr := empty_hdr;
          p_desc := default;
           p_log_values := {| values := subslice state 2 LOG_LENGTH;
                               values_ok := ltac:(auto using log_subslice_len_ok) |};
            p_data_region := subslice state (2+LOG_LENGTH) (length state - 2 - LOG_LENGTH); |};
      simpl.
    intuition eauto.
    constructor; intros; simpl; array.
    destruct (index_dec state (2 + LOG_LENGTH + i)); propositional; array.
Qed.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef2.Layer.
Require Import TableDataOpsRef3.Code.table_unmap3.

Require Import TableDataOpsRef3.LowSpecs.table_unmap3.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _table_unmap ↦ gensem table_unmap_spec
      ⊕ _table_unmap2 ↦ gensem table_unmap2_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_table_unmap: block.
    Hypothesis h_table_unmap_s : Genv.find_symbol ge _table_unmap = Some b_table_unmap.
    Hypothesis h_table_unmap_p : Genv.find_funct_ptr ge b_table_unmap
                                 = Some (External (EF_external _table_unmap
                                                  (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                        (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap_spec.

    Variable b_table_unmap2: block.
    Hypothesis h_table_unmap2_s : Genv.find_symbol ge _table_unmap2 = Some b_table_unmap2.
    Hypothesis h_table_unmap2_p : Genv.find_funct_ptr ge b_table_unmap2
                                  = Some (External (EF_external _table_unmap2
                                                   (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                         (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap2_spec.

    Lemma table_unmap3_body_correct:
      forall m d d' env le g_rd_base g_rd_offset map_addr level res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (Hspec: table_unmap3_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned map_addr)) (VZ64 (Int64.unsigned level)) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) table_unmap3_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec table_unmap3_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


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.