(* begin hide *)
From mathcomp Require Import all_ssreflect.
(* Set Implicit Arguments. *)
Unset Strict Implicit.
Unset Printing Implicit Defensive.

From Equations Require Import Equations.

(* end hide *)

(**
   #

Values

         This file contains the definition of values used throughout the rest of the
         project, in graphs and queries.

#
 *)

Section Value.

  Variable (Scalar : eqType).

  (* Unsetting because the automatically generated induction principle is not good enough. *)
  Unset Elimination Schemes.

  (** ---- *)
  (**
     Values are not specified in the Spec, since GraphQL is agnostic to the underlying technology
     used. However, it is still possible to distinguish (at least) two types of values:
     - Scalar values
     - List values (collections)

     A third possible type of value could be object values but we do not include this notion yet
     (nodes in a graph would represent elements of this third kind).

   *)
  Inductive Value : Type :=
  | SValue : Scalar -> Value
  | LValue : seq Value -> Value.

  Set Elimination Schemes.

  (** ---- *)
  (**
     Defining the induction principle for [Value].
   *)
  Definition Value_rect (P : Value -> Type)
             (Pl : seq Value -> Type)
             (IH_SValue : forall s, P (SValue s))
             (IH_LValue : forall vs, Pl vs -> P (LValue vs))
             (IH_Nil : Pl [::])
             (IH_Cons : forall v, P v -> forall vs, Pl vs -> Pl (v :: vs))
    :=
    fix loop value : P value :=
      let fix F (qs : seq Value) : Pl qs :=
          match qs with
          | [::] => IH_Nil
          | hd :: tl => IH_Cons hd (loop hd) tl (F tl)
          end
      in
      match value with
      | SValue s => IH_SValue s
      | LValue vs => IH_LValue vs (F vs)
      end.

  Definition Value_rec (P : Value -> Set) := @Value_rect P.

  Definition Value_ind (P : Value -> Prop)
             (Pl : seq Value -> Prop)
             (IH_SValue : forall s, P (SValue s))
             (IH_LValue : forall vs, Pl vs -> P (LValue vs))
             (IH_Nil : Pl [::])
             (IH_Cons : forall v, P v -> forall vs, Pl vs -> Pl (v :: vs))
    :=
      fix loop value : P value :=
        let fix F (qs : seq Value) : Pl qs :=
          match qs with
          | [::] => IH_Nil
          | hd :: tl => IH_Cons hd (loop hd) tl (F tl)
          end
        in
        match value with
        | SValue s => IH_SValue s
        | LValue vs => IH_LValue vs (F vs)
        end.

  (**
     We also establish that this type has a decidable procedure for equality but
     we omit it here to unclutter the doc (it may still be seen in the source code).
   *)

  (* begin hide *)
  (** ---- *)
  (**
     ##: Value → Value → Bool

     Decidable equality between values.
   *)
  Equations value_eq (v1 v2 : Value) : bool :=
    {
      value_eq (SValue s1) (SValue s2) := s1 == s2;
      value_eq (LValue vs1) (LValue vs2) := value_seq_eq vs1 vs2;
      value_eq _ _ := false
    }
  where value_seq_eq (vs1 vs2 : seq Value) : bool :=
          {
            value_seq_eq [::] [::] := true;
            value_seq_eq (v1 :: vs1) (v2 :: vs2) := value_eq v1 v2 && value_seq_eq vs1 vs2;
            value_seq_eq _ _ := false
          }.

  (** ---- **)
  (**
     Reflexive lemma for [value_eq] and [eq].
   *)
  Lemma value_eq_axiom : Equality.axiom value_eq.
  Proof.
    rewrite /Equality.axiom => x y.
    apply: (iffP idP) => [| ->]; last first.
    - elim y using Value_ind with (Pl := fun vs1 => value_seq_eq vs1 vs1); intros; simp value_eq => //; apply/andP; split=> //.

    - move: y; elim x using Value_ind with
                   (Pl := fun vs1 => forall vs2, value_seq_eq vs1 vs2 -> vs1 = vs2) => [s | vs IHvs | | v IHv vs IHvs]; case=> //=.
      * by move=> s2; simp value_eq => /eqP ->.
      * by move=> vs2; simp value_eq => Hvseq; rewrite (IHvs vs2).
      * by move=> v2 vs2 /andP [/IHv -> /IHvs ->].
  Qed.

  Canonical value_eqType := EqType Value (EqMixin value_eq_axiom).

  (* end hide *)

End Value.

Arguments Value [Scalar].
Arguments SValue [Scalar].
Arguments LValue [Scalar].

(** #Continue Reading → Schema # *)


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.TypeInversion.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Notations.

Section language.
  Context {base_type_code : Type}
          {interp_base_type : base_type_code -> Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}.

  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).
  Local Notation interp_type := (interp_type interp_base_type).
  Local Notation interp_flat_type_gen := interp_flat_type.
  Local Notation interp_flat_type := (interp_flat_type interp_base_type).
  Local Notation Expr := (@Expr base_type_code op).

  Section with_var.
    Context {var : base_type_code -> Type}.

    Local Notation exprf := (@exprf base_type_code op var).
    Local Notation expr := (@expr base_type_code op var).

    Definition invert_Var {t} (e : exprf (Tbase t)) : option (var t)
      := match e in Syntax.exprf _ _ t'
               return option (var match t' with
                                  | Tbase t' => t'
                                  | _ => t
                                  end)
         with
         | Var _ v => Some v
         | _ => None
         end.
    Definition invert_Op {t} (e : exprf t) : option { t1 : flat_type & op t1 t * exprf t1 }%type
      := match e with Op _ _ opc args => Some (existT _ _ (opc, args)) | _ => None end.
    Definition invert_LetIn {A} (e : exprf A) : option { B : _ & exprf B * (Syntax.interp_flat_type var B -> exprf A) }%type
      := match e in Syntax.exprf _ _ t return option { B : _ & _ * (_ -> exprf t) }%type with
         | LetIn _ ex _ eC => Some (existT _ _ (ex, eC))
         | _ => None
         end.
    Definition invert_Pair {A B} (e : exprf (Prod A B)) : option (exprf A * exprf B)
      := match e in Syntax.exprf _ _ t
               return option match t with
                             | Prod _ _ => _
                             | _ => unit
                             end with
         | Pair _ x _ y => Some (x, y)%core
         | _ => None
         end.
    Definition invert_Abs {T} (e : expr T) : interp_flat_type_gen var (domain T) -> exprf (codomain T)
      := match e with Abs _ _ f => f end.

    Section const.
      Context (invert_Const : forall s d, op s d -> exprf s -> option (interp_flat_type d)).

      Fixpoint lift_option {t} : interp_flat_type t -> interp_flat_type_gen (fun t => option (interp_base_type t)) t
        := match t with
           | Tbase T => fun x => Some x
           | Unit => fun _ => tt
           | Prod A B => fun (ab : interp_flat_type A * interp_flat_type B)
                         => let '(a, b) := ab in
                            (lift_option a, lift_option b)
           end.

      Fixpoint invert_PairsConst_gen {T} (e : exprf T)
        : option (interp_flat_type_gen (fun t => option (interp_base_type t)) T)
      := match e in Syntax.exprf _ _ t return option (interp_flat_type_gen (fun t => option (interp_base_type t)) t) with
         | TT => Some tt
         | Pair tx ex ty ey
           => match @invert_PairsConst_gen tx ex, @invert_PairsConst_gen ty ey with
              | Some x, Some y => Some (x, y)
              | Some _, None | None, Some _ | None, None => None
              end
         | Op s d opv args
           => option_map lift_option (invert_Const s d opv args)
         | Var _ _
         | LetIn _ _ _ _
           => None
         end.
      Fixpoint invert_PairsConst {T} (e : exprf T)
        : option (interp_flat_type T)
      := match e in Syntax.exprf _ _ t return option (interp_flat_type t) with
         | TT => Some tt
         | Pair tx ex ty ey
           => match @invert_PairsConst tx ex, @invert_PairsConst ty ey with
              | Some x, Some y => Some (x, y)
              | Some _, None | None, Some _ | None, None => None
              end
         | Op s d opv args
           => invert_Const s d opv args
         | Var _ _
         | LetIn _ _ _ _
           => None
         end.
    End const.

    Fixpoint invert_Pairs {T} (e : exprf T) : option (interp_flat_type_gen (fun ty => exprf (Tbase ty)) T)
      := match e in Syntax.exprf _ _ t
               return option (interp_flat_type_gen (fun ty => exprf (Tbase ty)) t)
         with
         | TT => Some tt
         | Var t _ as e => Some e
         | Pair tx ex ty ey
           => match @invert_Pairs tx ex, @invert_Pairs ty ey with
              | Some x, Some y => Some (x, y)
              | Some _, None | None, Some _ | None, None => None
              end
         | Op _ t _ _ as e
         | LetIn _ _ t _ as e
           => match t return exprf t -> option (interp_flat_type_gen _ t) with
              | Tbase _ => fun e => Some e
              | _ => fun _ => None
              end e
         end.

    Definition compose {A B C} (f : expr (B -> C)) (g : expr (A -> B))
      : expr (A -> C)
      := Abs (fun v => LetIn (invert_Abs g v)
                             (invert_Abs f)).

    Definition exprf_code {t} (e : exprf t) : exprf t -> Prop
      := match e with
         | TT => fun e' => TT = e'
         | Var _ v => fun e' => invert_Var e' = Some v
         | Pair _ x _ y => fun e' => invert_Pair e' = Some (x, y)%core
         | Op _ _ opc args => fun e' => invert_Op e' = Some (existT _ _ (opc, args)%core)
         | LetIn _ ex _ eC => fun e' => invert_LetIn e' = Some (existT _ _ (ex, eC)%core)
         end.

    Definition expr_code {t} (e1 e2 : expr t) : Prop
      := invert_Abs e1 = invert_Abs e2.

    Definition exprf_encode {t} (x y : exprf t) : x = y -> exprf_code x y.
    Proof. intro p; destruct p, x; reflexivity. Defined.
    Definition expr_encode {t} (x y : expr t) : x = y -> expr_code x y.
    Proof. intro p; destruct p, x; reflexivity. Defined.

    Local Ltac t' :=
      repeat first [ intro
                   | progress simpl in *
                   | reflexivity
                   | assumption
                   | progress destruct_head False
                   | progress subst
                   | progress inversion_option
                   | progress inversion_sigma
                   | progress break_match ].
    Local Ltac t :=
      lazymatch goal with
      | [ |- _ = Some ?v -> ?e = _ ]
        => revert v;
           refine match e with
                  | Var _ _ => _
                  | _ => _
                  end
      | [ |- _ = ?v -> ?e = _ ]
        => revert v;
           refine match e with
                  | Abs _ _ _ => _
                  end
      end;
      t'.

    Lemma invert_Var_Some {t e v}
      : @invert_Var t e = Some v -> e = Var v.
    Proof. t. Defined.

    Lemma invert_Op_Some {t e v}
      : @invert_Op t e = Some v -> e = Op (fst (projT2 v)) (snd (projT2 v)).
    Proof. t. Defined.

    Lemma invert_LetIn_Some {t e v}
      : @invert_LetIn t e = Some v -> e = LetIn (fst (projT2 v)) (snd (projT2 v)).
    Proof. t. Defined.

    Lemma invert_Pair_Some {A B e v}
      : @invert_Pair A B e = Some v -> e = Pair (fst v) (snd v).
    Proof. t. Defined.

    Lemma invert_Abs_Some {A B e v}
      : @invert_Abs (Arrow A B) e = v -> e = Abs v.
    Proof. t. Defined.

    Definition exprf_decode {t} (x y : exprf t) : exprf_code x y -> x = y.
    Proof.
      destruct x; simpl; trivial;
        intro H;
        first [ apply invert_Var_Some in H
              | apply invert_Op_Some in H
              | apply invert_LetIn_Some in H
              | apply invert_Pair_Some in H ];
        symmetry; assumption.
    Defined.
    Definition expr_decode {t} (x y : expr t) : expr_code x y -> x = y.
    Proof.
      destruct x; unfold expr_code; simpl.
      intro H; symmetry in H.
      apply invert_Abs_Some in H.
      symmetry; assumption.
    Defined.
    Definition path_exprf_rect {t} {x y : exprf t} (Q : x = y -> Type)
               (f : forall p, Q (exprf_decode x y p))
      : forall p, Q p.
    Proof. intro p; specialize (f (exprf_encode x y p)); destruct x, p; exact f. Defined.
    Definition path_expr_rect {t} {x y : expr t} (Q : x = y -> Type)
               (f : forall p, Q (expr_decode x y p))
      : forall p, Q p.
    Proof. intro p; specialize (f (expr_encode x y p)); destruct x, p; exact f. Defined.
  End with_var.

  Lemma interpf_invert_Abs interp_op {T e} x
    : Syntax.interpf interp_op (@invert_Abs interp_base_type T e x)
      = Syntax.interp interp_op e x.
  Proof using Type. destruct e; reflexivity. Qed.

  Lemma interpf_invert_PairsConst invert_Const interp_op {T} e v
        (Hinvert_Const
         : forall s d opc e v, invert_Const s d opc e = Some v
                               -> interp_op s d opc (interpf interp_op e) = v)
        (H : invert_PairsConst (T:=T) invert_Const e = Some v)
    : Syntax.interpf interp_op e = v.
  Proof using Type.
    induction e;
      repeat first [ reflexivity
                   | progress subst
                   | solve [ auto ]
                   | progress inversion_option
                   | progress inversion_prod
                   | progress simpl in *
                   | progress break_innermost_match_hyps
                   | apply (f_equal2 (@pair _ _)) ].
  Qed.

  Definition Compose {A B C} (f : Expr (B -> C)) (g : Expr (A -> B))
    : Expr (A -> C)
    := fun var => compose (f var) (g var).

  Lemma InterpCompose {A B C} interp_op f g
    : forall x, Interp interp_op (@Compose A B C f g) x
                = Interp interp_op f (Interp (interp_base_type:=interp_base_type) interp_op g x).
  Proof. reflexivity. Qed.
End language.

Global Arguments invert_Var {_ _ _ _} _.
Global Arguments invert_Op {_ _ _ _} _.
Global Arguments invert_LetIn {_ _ _ _} _.
Global Arguments invert_Pair {_ _ _ _ _} _.
Global Arguments invert_Pairs {_ _ _ _} _.
Global Arguments invert_PairsConst {_ _ _ _} _ {T} _.
Global Arguments invert_Abs {_ _ _ _} _ _.

Hint Rewrite @InterpCompose : reflective_rewrite.

Module Export Notations.
  Infix "∘" := Compose : expr_scope.
  Infix "∘f" := compose : expr_scope.
  Infix "∘ᶠ" := compose : expr_scope.
End Notations.

Ltac invert_one_expr e :=
  preinvert_one_type e;
  intros ? e;
  destruct e;
  try exact I.

Ltac invert_expr_step :=
  match goal with
  | [ e : exprf _ _ (Tbase _) |- _ ] => invert_one_expr e
  | [ e : exprf _ _ (Prod _ _) |- _ ] => invert_one_expr e
  | [ e : exprf _ _ Unit |- _ ] => invert_one_expr e
  | [ e : expr _ _ (Arrow _ _) |- _ ] => invert_one_expr e
  end.

Ltac invert_expr := repeat invert_expr_step.

Ltac invert_match_expr_step :=
  match goal with
  | [ |- context[match ?e with TT => _ | _ => _ end] ]
    => invert_one_expr e
  | [ |- context[match ?e with Abs _ _ _ => _ end] ]
    => invert_one_expr e
  | [ H : context[match ?e with TT => _ | _ => _ end] |- _ ]
    => invert_one_expr e
  | [ H : context[match ?e with Abs _ _ _ => _ end] |- _ ]
    => invert_one_expr e
  end.

Ltac invert_match_expr := repeat invert_match_expr_step.

Ltac invert_expr_subst_step_helper guard_tac :=
  match goal with
  | [ H : invert_Var ?e = Some _ |- _ ] => guard_tac H; apply invert_Var_Some in H
  | [ H : invert_Op ?e = Some _ |- _ ] => guard_tac H; apply invert_Op_Some in H
  | [ H : invert_LetIn ?e = Some _ |- _ ] => guard_tac H; apply invert_LetIn_Some in H
  | [ H : invert_Pair ?e = Some _ |- _ ] => guard_tac H; apply invert_Pair_Some in H
  | [ e : expr _ _ _ |- _ ]
    => guard_tac e;
       let f := fresh e in
       let H := fresh in
       rename e into f;
       remember (invert_Abs f) as e eqn:H;
       symmetry in H;
       apply invert_Abs_Some in H;
       subst f
  | [ H : invert_Abs ?e = _ |- _ ] => guard_tac H; apply invert_Abs_Some in H
  end.
Ltac invert_expr_subst_step :=
  first [ invert_expr_subst_step_helper ltac:(fun _ => idtac)
        | subst ].
Ltac invert_expr_subst := repeat invert_expr_subst_step.

Ltac induction_expr_in_using H rect :=
  induction H as [H] using (rect _ _ _);
  cbv [exprf_code expr_code invert_Var invert_LetIn invert_Pair invert_Op invert_Abs] in H;
  try lazymatch type of H with
      | Some _ = Some _ => apply option_leq_to_eq in H; unfold option_eq in H
      | Some _ = None => exfalso; clear -H; solve [ inversion H ]
      | None = Some _ => exfalso; clear -H; solve [ inversion H ]
      end;
  let H1 := fresh H in
  let H2 := fresh H in
  try lazymatch type of H with
      | existT _ _ _ = existT _ _ _ => induction_sigma_in_using H @path_sigT_rect
      end;
  try lazymatch type of H2 with
      | _ = (_, _)%core => induction_path_prod H2
      end.
Ltac inversion_expr_step :=
  match goal with
  | [ H : _ = Var _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : _ = TT |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : _ = Op _ _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : _ = Pair _ _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : _ = LetIn _ _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : _ = Abs _ |- _ ]
    => induction_expr_in_using H @path_expr_rect
  | [ H : Var _ = _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : TT = _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : Op _ _ = _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : Pair _ _ = _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : LetIn _ _ = _ |- _ ]
    => induction_expr_in_using H @path_exprf_rect
  | [ H : Abs _ = _ |- _ ]
    => induction_expr_in_using H @path_expr_rect
  end.
Ltac inversion_expr := repeat inversion_expr_step.


(** * Definition of minimal parse trees *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Setoids.Setoid.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.Core.
Require Import Fiat.Parsers.BaseTypes.

Local Coercion is_true : bool >-> Sortclass.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  Inductive minimal_maybe_empty_productions : nonterminals_listT -> productions Char -> Type :=
  | MinMaybeEmptyHead : forall valid pat pats, minimal_maybe_empty_production valid pat
                                               -> minimal_maybe_empty_productions valid (pat::pats)
  | MinMaybeEmptyTail : forall valid pat pats, minimal_maybe_empty_productions valid pats
                                               -> minimal_maybe_empty_productions valid (pat::pats)
  with minimal_maybe_empty_production : nonterminals_listT -> production Char -> Type :=
  | MinMaybeEmptyProductionNil : forall valid, minimal_maybe_empty_production valid nil
  | MinMaybeEmptyProductionCons : forall valid it its, minimal_maybe_empty_item valid it
                                                       -> minimal_maybe_empty_production valid its
                                                       -> minimal_maybe_empty_production valid (it::its)
  with minimal_maybe_empty_item : nonterminals_listT -> item Char -> Type :=
  | MinMaybeEmptyNonTerminal : forall valid nt, is_valid_nonterminal valid (of_nonterminal nt)
                                                -> minimal_maybe_empty_productions (remove_nonterminal valid (of_nonterminal nt)) (Lookup G nt)
                                                -> minimal_maybe_empty_item valid (NonTerminal nt).

End cfg.


From stdpp Require Import namespaces.
From iris.base_logic Require Import invariants na_invariants.
From self.prob_lang Require Import notation proofmode primitive_laws spec_rules spec_tactics.
From self.logrel Require Import model rel_rules rel_tactics.
From iris.algebra Require Import auth gmap excl frac agree.
From self.prelude Require Import base.
From self.examples Require Import keyed_hash hash rng.

Set Default Proof Using "Type*".

(* A "splittable" pseudo-random number generator derived from a keyed
   hashing function.

   The idea is to be able to generate a collection of separate independent RNGs from a single keyed hash
   by having each RNG use a different key.

   Compare with rng.v, which generates a single rng from a hash function.

*)

Section rng.

  Context (MAX_RNGS_POW : nat).
  Context (MAX_SAMPLES_POW : nat).

  Definition MAX_RNGS : nat := (Nat.pow 2 MAX_RNGS_POW) - 1.
  Definition MAX_SAMPLES : nat := (Nat.pow 2 MAX_SAMPLES_POW) - 1.

  Definition init_rng_gen : val :=
    λ: "_",
      let: "f" := (init_keyed_hash MAX_RNGS_POW MAX_SAMPLES_POW) #() in
      let: "key_cntr" := ref #0 in
      (* We return an rng "generator" that gets a fresh key from key_cntr (if available) and returns
         an rng function using that key *)
      λ: "_",
        let: "k" := !"key_cntr" in
        if: #MAX_RNGS < "k" then
          NONE
        else
          "key_cntr" <- "k" + #1;;
          let: "sample_cntr" := ref #0 in
          SOME (λ: "_",
               let: "v" := !"sample_cntr" in
               let: "b" :=
                 if: "v" ≤ #MAX_SAMPLES then
                   "f" "k" "v"
                 else
                   #false
               in
               "sample_cntr" <- "v" + #1;;
               "b").

  Definition hash_rng_gen_specialized (f: val) (key_cntr: loc) : val :=
      λ: "_",
        let: "k" := ! #key_cntr in
        if: #MAX_RNGS < "k" then
          NONE
        else
          #key_cntr <- "k" + #1;;
          let: "sample_cntr" := ref #0 in
          SOME (λ: "_",
               let: "v" := !"sample_cntr" in
               let: "b" :=
                 if: "v" ≤ #MAX_SAMPLES then
                   f "k" "v"
                 else
                   #false
               in
               "sample_cntr" <- "v" + #1;;
               "b").

  Definition hash_rng_specialized (f : val) (k : nat) (c : loc) : val :=
    (λ: "_",
      let: "v" := !#c in
      let: "b" :=
        if: "v" ≤ #MAX_SAMPLES then
          f #k "v"
        else
          #false
      in
      #c <- "v" + #1;;
      "b").

  Context `{!prelogrelGS Σ}.

  (* TODO: it would be better to wrap this ghost_mapG with keyed_mapG *)
  Context {GHOST_MAP: ghost_mapG Σ (fin_hash_dom_space MAX_RNGS_POW MAX_SAMPLES_POW) (option bool)}.

  Definition khashN := nroot.@"khash".

  Definition is_keyed_hash γ f :=
    na_inv prelogrelGS_nais khashN (keyed_hash_auth MAX_RNGS_POW MAX_SAMPLES_POW γ f).
  Definition is_skeyed_hash γ f :=
    na_inv prelogrelGS_nais khashN (skeyed_hash_auth MAX_RNGS_POW MAX_SAMPLES_POW γ f).

  (* Putting is_keyed_hash seems like it makes the definition but then this is not timeless *)

  Definition hash_rng (n: nat) (g: val) : iProp Σ :=
    ∃ h k c m γ, ⌜ g = hash_rng_specialized h (fin_to_nat k) c ⌝ ∗
             ⌜ ∀ x, n <= x → x ∉ dom m ⌝ ∗
             khashfun_own MAX_RNGS_POW MAX_SAMPLES_POW γ k m ∗
             is_keyed_hash γ h ∗
             c ↦ #n.

  Definition shash_rng (n: nat) (g: val) : iProp Σ :=
    ∃ h k c m γ, ⌜ g = hash_rng_specialized h (fin_to_nat k) c ⌝ ∗
             ⌜ ∀ x, n <= x → x ∉ dom m ⌝ ∗
             khashfun_own MAX_RNGS_POW MAX_SAMPLES_POW γ k m ∗
             is_skeyed_hash γ h ∗
             c ↦ₛ #n.

  Definition hash_rng_gen (n: nat) (f: val) : iProp Σ :=
    ∃ h kcntr γ, ⌜ f = hash_rng_gen_specialized h kcntr ⌝ ∗
                  is_keyed_hash γ h ∗
                  kcntr ↦ #n ∗
                  [∗ set] k ∈ fin_to_set (fin_key_space MAX_RNGS_POW),
                     (⌜ n <= fin_to_nat k ⌝ → khashfun_own _ MAX_SAMPLES_POW γ k ∅).

  Definition shash_rng_gen (n: nat) (f: val) : iProp Σ :=
    ∃ h kcntr γ, ⌜ f = hash_rng_gen_specialized h kcntr ⌝ ∗
                  is_skeyed_hash γ h ∗
                  kcntr ↦ₛ #n ∗
                  [∗ set] k ∈ fin_to_set (fin_key_space MAX_RNGS_POW),
                     (⌜ n <= fin_to_nat k ⌝ → khashfun_own _ MAX_SAMPLES_POW γ k ∅).

  Lemma wp_init_rng_gen E :
    {{{ True }}}
      init_rng_gen #() @ E
    {{{ (f: val), RET f; hash_rng_gen 0 f }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    rewrite /init_rng_gen.
    wp_pures.
    wp_apply (wp_init_keyed_hash with "[//]").
    iIntros (h) "H". iDestruct "H" as (γ) "(Hauth&Hks)".
    wp_pures.
    wp_alloc key_cntr as "Hkc".
    wp_pures.
    iAssert (|={E}=> is_keyed_hash γ h)%I with "[Hauth]" as ">#His_keyed".
    { iApply na_inv_alloc. iNext. eauto. }
    iModIntro. iApply "HΦ".
    iExists _, _, _. iFrame "# ∗".
    iSplit; first by eauto.
    iApply (big_sepS_mono with "Hks").
    iIntros (x Helem) "$"; auto.
  Qed.

  Lemma spec_init_rng_gen E K :
    ↑specN ⊆ E →
    refines_right K (init_rng_gen #()) ={E}=∗
    ∃ f, refines_right K (of_val f) ∗ shash_rng_gen 0 f.
  Proof.
    iIntros (?) "HK".
    rewrite /init_rng_gen.
    tp_pures.
    tp_bind (init_keyed_hash _ _ _).
    rewrite refines_right_bind.
    iMod (spec_init_keyed_hash with "[$]") as (h γ) "(HK&Hauth&Hks)"; first done.
    rewrite -refines_right_bind /=.
    tp_pures.
    tp_alloc as key_cntr "Hkc".
    tp_pures.
    iAssert (|={E}=> is_skeyed_hash γ h)%I with "[Hauth]" as ">#His_keyed".
    { iApply na_inv_alloc. iNext. eauto. }
    iModIntro. iExists _. iFrame "HK".
    iExists _, _, _. iFrame "# ∗".
    iSplit; first by eauto.
    iApply (big_sepS_mono with "Hks").
    iIntros (x Helem) "$"; auto.
  Qed.

  Lemma wp_run_rng_gen k f E :
    k <= MAX_RNGS →
    {{{ ▷ hash_rng_gen k f }}}
      f #() @ E
    {{{ (g: val), RET (SOMEV g); hash_rng_gen (S k) f ∗ hash_rng 0 g }}}.
  Proof.
    iIntros (Hle Φ) "Hgen HΦ".
    iDestruct "Hgen" as (h kcntr γ) "(>->&#His&Hknctr&Hks)".

    iEval (rewrite /hash_rng_gen_specialized). wp_pures.
    wp_load. wp_pures.
    case_bool_decide; first by lia.
    wp_pures.
    wp_store.
    wp_alloc sample_cntr as "Hsc".
    wp_pures.
    iModIntro.
    rewrite /init_rng_gen.
    iApply "HΦ".
    assert (Hlt: k < S MAX_RNGS) by lia.
    set (k' := (nat_to_fin Hlt : fin_key_space MAX_RNGS_POW)).
    iDestruct (big_sepS_delete _ _ k' with "Hks") as "(Hk&Hks)".
    { apply elem_of_fin_to_set. }
    iSplitL "Hks Hknctr".
    - iExists _, _, _. iSplit; first eauto. iFrame "#".
      assert (Z.of_nat k + 1 = Z.of_nat (S k))%Z as -> by lia.
      iFrame "Hknctr".
      iApply (big_sepS_delete _ _ k').
      { apply elem_of_fin_to_set. }
      iSplitR "Hks".
      * iIntros (Hle'). iExFalso. rewrite /k' fin_to_nat_to_fin in Hle'. lia.
      * iApply (big_sepS_mono with "Hks"). iIntros (??) "H %Hle'".
        iApply "H". iPureIntro; lia.
    - iExists _, k', _, ∅, _. iFrame "Hsc #". iSplit.
      { rewrite /hash_rng_specialized. rewrite /k' fin_to_nat_to_fin //. }
      iSplit.
      { iPureIntro. set_solver. }
      iApply "Hk". rewrite /k' fin_to_nat_to_fin; auto.
  Qed.

  Lemma spec_run_rng_gen k f K E  :
    ↑specN ⊆ E →
    k <= MAX_RNGS →
    shash_rng_gen k f -∗
    refines_right K (f #()) ={E}=∗
    ∃ g, refines_right K (of_val (SOMEV g)) ∗ shash_rng_gen (S k) f ∗ shash_rng 0 g.
  Proof.
    iIntros (HE Hle) "Hgen HK".
    iDestruct "Hgen" as (h kcntr γ) "(->&#His&Hknctr&Hks)".
    iEval (rewrite /hash_rng_gen_specialized) in "HK".
    tp_pures.
    tp_load.
    tp_pures.
    case_bool_decide; first by lia.
    tp_pures.
    tp_store.
    tp_pures.
    tp_alloc as sample_cntr "Hsc".
    tp_pures.
    iModIntro.
    iExists _. iFrame "HK".
    assert (Hlt: k < S MAX_RNGS) by lia.
    set (k' := (nat_to_fin Hlt : fin_key_space MAX_RNGS_POW)).
    iDestruct (big_sepS_delete _ _ k' with "Hks") as "(Hk&Hks)".
    { apply elem_of_fin_to_set. }
    iSplitL "Hks Hknctr".
    - iExists _, _, _. iSplit; first eauto. iFrame "#".
      assert (Z.of_nat k + 1 = Z.of_nat (S k))%Z as -> by lia.
      iFrame "Hknctr".
      iApply (big_sepS_delete _ _ k').
      { apply elem_of_fin_to_set. }
      iSplitR "Hks".
      * iIntros (Hle'). iExFalso. rewrite /k' fin_to_nat_to_fin in Hle'. lia.
      * iApply (big_sepS_mono with "Hks"). iIntros (??) "H %Hle'".
        iApply "H". iPureIntro; lia.
    - iExists _, k', _, ∅, _. iFrame "Hsc #". iSplit.
      { rewrite /hash_rng_specialized. rewrite /k' fin_to_nat_to_fin //. }
      iSplit.
      { iPureIntro. set_solver. }
      iApply "Hk". rewrite /k' fin_to_nat_to_fin; auto.
  Qed.

  Lemma wp_run_rng_gen_out_of_range k f E :
    MAX_RNGS < k →
    {{{ ▷ hash_rng_gen k f }}}
      f #() @ E
    {{{ RET NONEV; hash_rng_gen k f }}}.
  Proof.
    iIntros (Hlt Φ) "Hgen HΦ".
    iDestruct "Hgen" as (h kcntr γ) "(>->&#His&Hknctr&Hks)".

    iEval (rewrite /hash_rng_gen_specialized). wp_pures.
    wp_load. wp_pures.
    case_bool_decide; last by lia.
    wp_pures.
    iApply "HΦ".
    iModIntro. iExists _, _, _. iSplit; first eauto. iFrame "#∗".
  Qed.

  Lemma spec_run_rng_gen_out_of_range k f K E  :
    ↑specN ⊆ E →
    MAX_RNGS < k →
    shash_rng_gen k f -∗
    refines_right K (f #()) ={E}=∗
    refines_right K (of_val NONEV) ∗ shash_rng_gen k f.
  Proof.
    iIntros (HE Hlt) "Hgen HK".
    iDestruct "Hgen" as (h kcntr γ) "(->&#His&Hknctr&Hks)".

    iEval (rewrite /hash_rng_gen_specialized) in "HK". tp_pures.
    tp_load. tp_pures.
    case_bool_decide; last by lia.
    tp_pures.
    iModIntro. iFrame "HK".
    iExists _, _, _. iSplit; first eauto. iFrame "#∗".
  Qed.

  Instance fin_keys_inhabited :
    Inhabited (fin (S (MAX_KEYS MAX_RNGS_POW))).
  Proof. econstructor. econstructor. Qed.

  (* Notice this is almost identical to the version in rng.v, except we need the token
     to open the invariant for the keyed hash *)
  Lemma wp_hash_rng_flip n g K E :
    ↑specN ⊆ E →
    ↑khashN ⊆ E →
    n ≤ MAX_SAMPLES →
    {{{ ▷ hash_rng n g ∗ refines_right K (flip #()) ∗ na_own prelogrelGS_nais (↑khashN) }}}
      g #() @ E
    {{{ (b : bool), RET #b; hash_rng (S n) g ∗ refines_right K #b ∗ na_own prelogrelGS_nais (↑khashN) }}}.
  Proof.
    iIntros (HN1 HN2 Hle Φ) "(Hhash&HK&Htok) HΦ".
    rewrite /hash_rng.
    iDestruct "Hhash" as (h k c m γ) "(>->&>%Hdom&Hhash&#Hkeyed_hash&Hc)".
    rewrite /hash_rng_specialized. wp_pures.
    wp_load. wp_pures.
    case_bool_decide; last by lia.
    rewrite /is_keyed_hash.
    wp_pures.
    iMod (na_inv_acc with "[$] [$]") as "(>H&Htok&Hclo)"; auto.
    iDestruct (khashfun_own_couplable _ _ _ _ _ m n with "[$] [$]") as "Hcoup"; auto.
    { apply not_elem_of_dom. auto. }
    iApply (hash.impl_couplable_elim with "[-]"); [done | done |].
    iFrame "Hcoup HK". iIntros (b) ">(Hauth&Hhash) HK".
    wp_apply (wp_khashfun_prev with "[$]").
    { rewrite lookup_insert //. }
    iIntros "(Hauth&Hhash)". wp_pures.
    wp_store. iMod ("Hclo" with "[$]") as "Htok". iModIntro. iApply "HΦ".
    iFrame. iExists _, _, _, _, _. iFrame.
    iSplit; first done.
    iSplit.
    { iPureIntro. intros x. rewrite dom_insert_L.
      set_unfold. intros Hle' [?|?]; first lia.
      eapply Hdom; last by eassumption. lia.
    }
    assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
    auto.
  Qed.

  Existing Instance timeless_skeyed_hash_auth.

  Lemma spec_hash_rng_flip_couplable n g K E :
    ↑specN ⊆ E →
    ↑khashN ⊆ E →
    n ≤ MAX_SAMPLES →
    shash_rng n g -∗
    na_own prelogrelGS_nais (↑khashN) -∗
    refines_right K (g #()) ={E}=∗
    spec_couplable (λ b, |={E}=> refines_right K #b ∗ shash_rng (S n) g ∗ na_own prelogrelGS_nais (↑khashN)).
  Proof.
    iIntros (HN1 HN2 Hle) "Hhash Htok HK".
    iDestruct "Hhash" as (h k c m γ) "(->&%Hdom&Hhash&#Hkeyed_hash&Hc)".
    rewrite /hash_rng_specialized. tp_pures.
    tp_load. tp_pures.
    case_bool_decide; last by lia.
    rewrite /is_skeyed_hash.
    tp_pures.
    iMod (na_inv_acc with "[$] [$]") as "(>H&Htok&Hclo)"; auto.
    iDestruct (khashfun_own_spec_couplable _ _ _ _ _ m n with "[$] [$]") as "Hcoup"; auto.
    { apply not_elem_of_dom. auto. }
    iModIntro.
    iApply (spec_couplable_wand with "Hcoup").
    iIntros (b) ">(Hauth&Hhash)".
    tp_bind (h #k #n).
    rewrite refines_right_bind.
    iMod (spec_khashfun_prev with "[$] [$] [$]") as "(HK&Hauth&Hhash)".
    { rewrite lookup_insert //. }
    { done. }
    rewrite -refines_right_bind/=.
    tp_pures.
    tp_store.
    tp_pures.
    iMod ("Hclo" with "[$]") as "Htok". iModIntro.
    iFrame. iExists _, _, _, _, _. iFrame.
    iSplit; first done.
    iSplit.
    { iPureIntro. intros x. rewrite dom_insert_L.
      set_unfold. intros Hle' [?|?]; first lia.
      eapply Hdom; last by eassumption. lia.
    }
    assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
    auto.
  Qed.

  Lemma wp_hash_rng_flip_out_of_range n g E:
    MAX_SAMPLES < n →
    {{{ ▷ hash_rng n g }}}
      g #() @ E
    {{{ RET #false; hash_rng (S n) g }}}.
  Proof.
    iIntros (Hlt Φ) "Hhash HΦ".
    iDestruct "Hhash" as (h k c m γ) "(>->&>%Hdom&Hhash&#Hkeyed_hash&Hc)".
    rewrite /hash_rng_specialized. wp_pures.
    wp_load. wp_pures.
    case_bool_decide; first lia.
    wp_pures. wp_store. iApply "HΦ".
    iModIntro.
    assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
    iExists _, _, _, _, _. iFrame "#∗". iSplit; first eauto.
    iPureIntro. intros. apply Hdom. lia.
  Qed.

  Lemma spec_hash_rng_flip_out_of_range n g K E :
    ↑specN ⊆ E →
    MAX_SAMPLES < n →
    shash_rng n g -∗
    refines_right K (g #()) ={E}=∗
    refines_right K #false ∗ shash_rng (S n) g.
  Proof.
    iIntros (HE Hlt) "Hhash HK".
    iDestruct "Hhash" as (h k c m γ) "(->&%Hdom&Hhash&#Hkeyed_hash&Hc)".
    rewrite /hash_rng_specialized. tp_pures.
    tp_load. tp_pures.
    case_bool_decide; first lia.
    tp_pures. tp_store. tp_pures.
    iModIntro. iFrame "HK".
    assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
    iExists _, _, _, _, _. iFrame "#∗". iSplit; first eauto.
    iPureIntro. intros. apply Hdom. lia.
  Qed.

  (* The "ideal" version that calls a tape-less flip directly *)

  Definition init_bounded_rng_gen : val :=
    λ: "_",
      let: "rng_cntr" := ref #0 in
      λ: "_",
        let: "k" := !"rng_cntr" in
        if: #MAX_RNGS < "k" then
          NONE
        else
          "rng_cntr" <- "k" + #1;;
          let: "f" := (init_bounded_rng MAX_SAMPLES) #() in
          SOME "f".

  Definition bounded_rng_gen_specialized (c : loc) : val :=
      λ: "_",
        let: "k" := !#c in
        if: #MAX_RNGS < "k" then
          NONE
        else
          #c <- "k" + #1;;
          let: "f" := (init_bounded_rng MAX_SAMPLES) #() in
          SOME "f".

  Definition bounded_rng_gen (n: nat) (g: val) : iProp Σ :=
    ∃ c, ⌜ g = bounded_rng_gen_specialized c ⌝ ∗ c ↦ #n.

  Definition sbounded_rng_gen (n: nat) (g: val) : iProp Σ :=
    ∃ c, ⌜ g = bounded_rng_gen_specialized c ⌝ ∗ c ↦ₛ #n.

  Lemma wp_init_bounded_rng_gen E :
    {{{ True }}}
      init_bounded_rng_gen #() @ E
    {{{ g, RET g; bounded_rng_gen O g }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    rewrite /init_bounded_rng_gen. wp_pures.
    wp_alloc c as "Hc".
    wp_pures. iModIntro.
    iApply "HΦ".
    iExists _. iFrame. eauto.
  Qed.

  Lemma spec_init_bounded_rng_gen E K :
    ↑specN ⊆ E →
    refines_right K (init_bounded_rng_gen #()) ={E}=∗ ∃ f, refines_right K (of_val f) ∗ sbounded_rng_gen O f.
  Proof.
    iIntros (?) "Hspec".
    rewrite /init_bounded_rng_gen.
    tp_pures.
    tp_alloc as c "Hc".
    tp_pures.
    iModIntro. iExists _. iFrame. iExists c. eauto.
  Qed.

  Lemma wp_run_bounded_rng_gen k f E :
    k <= MAX_RNGS →
    {{{ bounded_rng_gen k f }}}
      f #() @ E
    {{{ (g: val), RET (SOMEV g); bounded_rng_gen (S k) f ∗ bounded_rng MAX_SAMPLES 0 g }}}.
  Proof.
    iIntros (Hle Φ) "Hhash HΦ".
    iDestruct "Hhash" as (c ->) "Hc".
    rewrite /bounded_rng_gen_specialized.
    wp_pures. wp_load. wp_pures.
    case_bool_decide; try lia; [].
    wp_pures. wp_store.
    wp_apply (wp_init_bounded_rng with "[//]").
    iIntros (?) "H". wp_pures.
    iModIntro. iApply "HΦ".
    iFrame.
    iExists _. iSplit; first done.
    assert (Z.of_nat k + 1 = Z.of_nat (S k))%Z as -> by lia. auto.
  Qed.

  Lemma spec_run_bounded_rng_gen k f E K :
    ↑specN ⊆ E →
    k <= MAX_RNGS →
    sbounded_rng_gen k f -∗
    refines_right K (f #()) ={E}=∗
    ∃ g, refines_right K (of_val (SOMEV g)) ∗
         sbounded_rng_gen (S k) f ∗
         sbounded_rng MAX_SAMPLES O g.
  Proof.
    iIntros (? Hle) "Hgen Hspec".
    iDestruct "Hgen" as (c ->) "Hc".
    rewrite /bounded_rng_gen_specialized.
    tp_pures.
    tp_load.
    tp_pures.
    case_bool_decide; try lia; [].
    tp_pures.
    tp_store.
    tp_pures.
    tp_bind (init_bounded_rng _ _).
    rewrite refines_right_bind.
    iMod (spec_init_bounded_rng with "[$]") as (g) "(HK&Hrng)"; auto.
    rewrite -refines_right_bind /=.
    tp_pures.
    iModIntro. iExists _. iFrame. iExists c.
    assert (Z.of_nat k + 1 = Z.of_nat (S k))%Z as -> by lia. auto.
  Qed.

  Lemma wp_run_bounded_rng_gen_out_of_range k f E :
    MAX_RNGS < k →
    {{{ bounded_rng_gen k f }}}
      f #() @ E
    {{{ RET NONEV; bounded_rng_gen k f }}}.
  Proof.
    iIntros (Hle Φ) "Hhash HΦ".
    iDestruct "Hhash" as (c ->) "Hc".
    rewrite /bounded_rng_gen_specialized.
    wp_pures. wp_load. wp_pures.
    case_bool_decide; try lia; [].
    wp_pures.
    iModIntro. iApply "HΦ".
    iExists _. iFrame; eauto.
  Qed.

  Lemma spec_run_bounded_rng_gen_out_of_range k f E K :
    ↑specN ⊆ E →
    MAX_RNGS < k →
    sbounded_rng_gen k f -∗
    refines_right K (f #()) ={E}=∗
         refines_right K (of_val NONEV) ∗
         sbounded_rng_gen k f.
  Proof.
    iIntros (? Hle) "Hgen Hspec".
    iDestruct "Hgen" as (c ->) "Hc".
    rewrite /bounded_rng_gen_specialized.
    tp_pures.
    tp_load.
    tp_pures.
    case_bool_decide; try lia; [].
    tp_pures.
    iFrame.
    iModIntro. iExists _. iFrame. eauto.
  Qed.

  Lemma wp_hash_rng_flip_refine n g sg K E :
    ↑khashN ⊆ E →
    ↑specN ⊆ E →
    {{{ ▷ hash_rng n g ∗ sbounded_rng MAX_SAMPLES n sg ∗ refines_right K (sg #()) ∗
          na_own prelogrelGS_nais (↑khashN) }}}
      g #() @ E
    {{{ (b : bool), RET #b; hash_rng (S n) g ∗ sbounded_rng MAX_SAMPLES (S n) sg ∗ refines_right K #b ∗
          na_own prelogrelGS_nais (↑khashN) }}}.
  Proof.
    iIntros (HN1 HN2 Φ) "(Hhash&Hbrng&HK&Htok) HΦ".
    iDestruct "Hbrng" as (sc ->) "Hsc".
    rewrite /bounded_rng_specialized.
    tp_pures.
    tp_load.
    tp_pures.
    case_bool_decide.
    - tp_pures.
      tp_bind (flip #())%E.
      rewrite refines_right_bind.
      iApply wp_fupd.
      wp_apply (wp_hash_rng_flip with "[$HK $Hhash $Htok]"); auto.
      { lia. }
      iIntros (b) "(Hhash&HK&Htok)".
      rewrite -refines_right_bind /=.
      tp_pures.
      tp_store.
      tp_pures.
      iApply "HΦ".
      iFrame. iModIntro.
      iExists _.
      assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
      iFrame. eauto.
    - tp_pures.
      tp_store.
      tp_pures.
      wp_apply (wp_hash_rng_flip_out_of_range with "[$Hhash]"); auto.
      { lia. }
      iIntros "Hhash".
      iApply "HΦ".
      iFrame.
      iExists _.
      assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
      iFrame. eauto.
  Qed.

  Lemma wp_bounded_rng_flip_refine n g sg K E :
    ↑specN ⊆ E →
    ↑khashN ⊆ E →
    {{{ bounded_rng MAX_SAMPLES n g ∗ ▷ shash_rng n sg ∗ refines_right K (sg #()) ∗
          na_own prelogrelGS_nais (↑khashN)}}}
      g #() @ E
    {{{ (b : bool), RET #b; bounded_rng MAX_SAMPLES (S n) g ∗ shash_rng (S n) sg ∗ refines_right K #b ∗
          na_own prelogrelGS_nais (↑khashN)}}}.
  Proof.
    iIntros (HN1 HN2 Φ) "(Hbrng&Hhash&HK&Htok) HΦ".
    iDestruct "Hbrng" as (sc ->) "Hsc".
    rewrite /bounded_rng_specialized.
    wp_pures. wp_load. wp_pures.
    case_bool_decide.
    - wp_pures.
      iAssert (spec_ctx) with "[-]" as "#Hspec_ctx".
      { iDestruct "HK" as "($&_)". }
      iMod (spec_hash_rng_flip_couplable with "Hhash Htok HK") as "Hspec"; auto.
      { lia. }
      wp_apply (spec_couplable_elim with "[$Hspec $Hspec_ctx Hsc HΦ]"); auto.
      iIntros (b) ">(HK&Hhash)".
      wp_pures. wp_store.
      iModIntro. iApply "HΦ".
      iFrame "HK Hhash". iExists _.
      assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
      iFrame. eauto.
    - wp_pures.
      iMod (spec_hash_rng_flip_out_of_range with "Hhash HK") as "(HK&Hhash)"; auto.
      { lia. }
      wp_store.
      iModIntro. iApply "HΦ".
      iFrame "HK Hhash Htok". iExists _.
      assert (Z.of_nat n + 1 = Z.of_nat (S n))%Z as -> by lia.
      iFrame. eauto.
  Qed.

  Definition rngN := nroot.@"rng".

  Lemma hash_bounded_refinement :
    ⊢ REL init_rng_gen << init_bounded_rng_gen :
      lrel_unit → (lrel_unit → lrel_sum lrel_unit (lrel_unit → lrel_bool)).
  Proof.
    rel_arrow_val.
    iIntros (??) "(->&->)".
    rewrite refines_eq. iIntros (K) "HK Hown".
    iApply wp_fupd.
    wp_apply (wp_init_rng_gen with "[//]").
    iIntros (g) "Hhash_gen".
    iMod (spec_init_bounded_rng_gen with "[$]") as (f) "(HK&Hbounded_gen)"; first done.
    set (P := (∃ n, hash_rng_gen n g ∗ sbounded_rng_gen n f)%I).
    iMod (na_inv_alloc prelogrelGS_nais _ rngN P with "[Hhash_gen Hbounded_gen]") as "#Hinv".
    { iNext. iExists O. iFrame. }
    iModIntro. iExists _. iFrame.
    iIntros (v1 v2) "!> (->&->)".
    clear K.
    rewrite /P.
    iApply (refines_na_inv with "[$Hinv]") ; auto ; iIntros "[HP Hclose]".
    rewrite refines_eq. iIntros (K) "HK Hown".
    iDestruct "HP" as (m) "(Hg&>Hsf)".
    iApply wp_fupd.
    destruct (decide (m <= MAX_RNGS)) as [Hl|]; last first.
    { wp_apply (wp_run_rng_gen_out_of_range with "[$]"); first lia.
      iIntros "Hg".
      iMod (spec_run_bounded_rng_gen_out_of_range with "[$] [$]") as "(HK&Hsf)"; auto; try lia.
      iMod ("Hclose" with "[Hg Hsf $Hown]").
      { iNext. iExists _; iFrame. }
      iModIntro. iExists _; iFrame.
      iExists _, _. iLeft.
      iSplit; first eauto.
      iSplit; first eauto.
      eauto. }

    wp_apply (wp_run_rng_gen with "[$]"); first done.
    iIntros (hrng) "(Hg&Hrng)".
    iMod (spec_run_bounded_rng_gen with "Hsf HK") as (srng) "(HK&Hsf&Hsrng)"; auto.
    iMod ("Hclose" with "[Hg Hsf Hown]") as "Hown".
    { iFrame. iNext. iExists _; iFrame. }

    (* finally we show a refinement between the generated rngs *)
    set (Prng := (∃ n, hash_rng n hrng ∗ sbounded_rng MAX_SAMPLES n srng)%I).
    iMod (na_inv_alloc prelogrelGS_nais _ rngN Prng with "[Hrng Hsrng]") as "#Hinv_rng".
    { rewrite /Prng. iNext. iExists _. iFrame.  }
    iClear "Hinv".
    iModIntro. iExists _. iFrame.

    iExists _, _. iRight.
    iSplit; first eauto.
    iSplit; first eauto.

    iIntros (v1 v2) "!> (->&->)".
    clear Hl m K.
    iApply (refines_na_inv with "[$Hinv_rng]") ; auto ; iIntros "[HP Hclose]".
    rewrite refines_eq. iIntros (K) "HK Hown".
    iDestruct "HP" as (m) "(Hf&>Hsf)".
    iApply wp_fupd.
    iDestruct (na_own_acc (↑khashN) with "Hown") as "(Hown&Hclose')"; first solve_ndisj.
    wp_apply (wp_hash_rng_flip_refine with "[$Hf $Hsf $HK $Hown]"); [done | done |].
    iIntros (b) "(Hhash&Hbounded&HK&Hown)".
    iDestruct ("Hclose'" with "[$]") as "Hown".
    iMod ("Hclose" with "[-HK]").
    { iFrame. iExists _. iFrame. }
    iExists _. iFrame. eauto.
  Qed.

  Lemma bounded_hash_refinement :
    ⊢ REL init_bounded_rng_gen << init_rng_gen :
      lrel_unit → (lrel_unit → lrel_sum lrel_unit (lrel_unit → lrel_bool)).
  Proof.
    rel_arrow_val.
    iIntros (??) "(->&->)".
    rewrite refines_eq. iIntros (K) "HK Hown".
    iApply wp_fupd.
    wp_apply (wp_init_bounded_rng_gen with "[//]").
    iIntros (g) "Hbounded_gen".
    iMod (spec_init_rng_gen with "[$]") as (f) "(HK&Hhash_gen)"; first done.
    set (P := (∃ n, shash_rng_gen n f ∗ bounded_rng_gen n g)%I).
    iMod (na_inv_alloc prelogrelGS_nais _ rngN P with "[Hhash_gen Hbounded_gen]") as "#Hinv".
    { iNext. iExists O. iFrame. }
    iModIntro. iExists _. iFrame.
    iIntros (v1 v2) "!> (->&->)".
    clear K.
    rewrite /P.
    iApply (refines_na_inv with "[$Hinv]") ; auto ; iIntros "[HP Hclose]".
    rewrite refines_eq. iIntros (K) "HK Hown".
    iDestruct "HP" as (m) "(Hsf&>Hg)".
    iApply wp_fupd.
    destruct (decide (m <= MAX_RNGS)) as [Hl|]; last first.
    { wp_apply (wp_run_bounded_rng_gen_out_of_range with "[$]"); first lia.
      iIntros "Hg".
      iMod (spec_run_rng_gen_out_of_range with "[$] [$]") as "(HK&Hsf)"; auto; try lia.
      iMod ("Hclose" with "[Hg Hsf $Hown]").
      { iNext. iExists _; iFrame. }
      iModIntro. iExists _; iFrame.
      iExists _, _. iLeft.
      iSplit; first eauto.
      iSplit; first eauto.
      eauto. }

    wp_apply (wp_run_bounded_rng_gen with "[$]"); first done.
    iIntros (rng) "(Hg&Hrng)".
    iMod (spec_run_rng_gen with "Hsf HK") as (srng) "(HK&Hsf&Hsrng)"; auto.
    iMod ("Hclose" with "[Hg Hsf Hown]") as "Hown".
    { iFrame. iNext. iExists _; iFrame. }

    (* finally we show a refinement between the generated rngs *)
    set (Prng := (∃ n, shash_rng n srng ∗ bounded_rng MAX_SAMPLES n rng)%I).
    iMod (na_inv_alloc prelogrelGS_nais _ rngN Prng with "[Hrng Hsrng]") as "#Hinv_rng".
    { rewrite /Prng. iNext. iExists _. iFrame.  }
    iClear "Hinv".
    iModIntro. iExists _. iFrame.

    iExists _, _. iRight.
    iSplit; first eauto.
    iSplit; first eauto.

    iIntros (v1 v2) "!> (->&->)".
    clear Hl m K.
    iApply (refines_na_inv with "[$Hinv_rng]") ; auto ; iIntros "[HP Hclose]".
    rewrite refines_eq. iIntros (K) "HK Hown".
    iDestruct "HP" as (m) "(Hf&>Hsf)".
    iApply wp_fupd.
    iDestruct (na_own_acc (↑khashN) with "Hown") as "(Hown&Hclose')"; first solve_ndisj.
    wp_apply (wp_bounded_rng_flip_refine with "[$Hf $Hsf $HK $Hown]"); [done | done |].
    iIntros (b) "(Hhash&Hbounded&HK&Hown)".
    iDestruct ("Hclose'" with "[$]") as "Hown".
    iMod ("Hclose" with "[-HK]").
    { iFrame. iExists _. iFrame. }
    iExists _. iFrame. eauto.
  Qed.

End rng.


Set Implicit Arguments.

Require Export List.
Require Export Arith.

Section Carrier.

Variable N:Type.
Variable A:Type.
Variable zero : N.
Variable succ : N -> N.
Variable comp : N -> N -> comparison.

Fixpoint fromNat (x:nat) : N :=
  match x with
    | 0 => zero
    | S y => succ (fromNat y)
  end.

Variable size : forall t, list t -> N.
Variable sizeNat : forall t (x:list t), fromNat (length x) = size x.

(*
Definition Buffer t := list t.

Definition bufferSize t (b:list t) := @length _ b < 6.
*)

Inductive Buffer t :=
  Zero
| One : t -> Buffer t
| Two : t -> t -> Buffer t
| Three : t -> t -> t -> Buffer t
| Four : t -> t -> t -> t -> Buffer t
| Five : t -> t -> t -> t -> t -> Buffer t.

Set Maximal Implicit Insertion.
Implicit Arguments Zero [t].
Unset Maximal Implicit Insertion.

(*
Inductive SimpleDeque t :=
  Empty : SimpleDeque t
| Full : Buffer t ->
         SimpleDeque (prod t t) ->
         Buffer t ->
         SimpleDeque t.
*)

(*
Inductive LeafTree t :=
  One : t -> LeafTree t
| More : LeafTree (prod t t) -> LeafTree t.

Definition Elem := LeafTree A.
*)

Inductive SubStack s : Type -> Type :=
  Single : Buffer s -> Buffer s -> SubStack s s
| Multiple : forall t,
             Buffer s -> Buffer s ->
             SubStack (prod s s) t ->
             SubStack s t.

Inductive Deque s :=
  Empty : Deque s
| Full : forall t,
         SubStack s t ->
         Deque (prod t t) ->
         Deque s.

Set Maximal Implicit Insertion.
Implicit Arguments Empty [s].
Unset Maximal Implicit Insertion.

Definition toListBufferC t (x:Buffer t) r :=
  match x with
    | Zero => r
    | One a => a::r
    | Two a b => a::b::r
    | Three a b c => a::b::c::r
    | Four a b c d => a::b::c::d::r
    | Five a b c d e => a::b::c::d::e::r
  end.

(*
Definition toListPairBufferC t (x:Buffer (prod t t)) r :=
  match x with
    | Zero => r
    | One (a,b) => a::b::r
    | Two (a,b) (c,d) => a::b::c::d::r
    | Three (a,b) (c,d) (e,f) => a::b::c::d::e::f::r
    | Four (a,b) (c,d) (e,f) (g,h) => a::b::c::d::e::f::g::h::r
    | Five (a,b) (c,d) (e,f) (g,h) (i,j) => a::b::c::d::e::f::g::h::i::j::r
  end.
*)

Fixpoint unzipMix t (x:list (prod t t)) r :=
  match x with
    | nil => r
    | (a,b)::tyl => a::b::(unzipMix tyl r)
  end.

(*
Require Import Program.
Require Import Coq.Logic.JMeq.
*)
(* Error: Library Coq.Logic.JMeq has to be required first. *)
(*
Program Fixpoint toListSubStack t s (x:SubStack t s) (r:list s -> list s) : list t :=
  match x with
    | Single a b => toListBufferC a (r (toListBufferC b nil))
    | Multiple _ a b tyl =>
      toListBufferC a
      (unzipMix (toListSubStack tyl r)
        (toListBufferC b nil))
  end.
*)

Fixpoint toListSubStack t s (x:SubStack t s) :
  (list s -> list s) -> list t :=
  match x with
    | Single a b => fun r => toListBufferC a (r (toListBufferC b nil))
    | Multiple _ a b tyl => fun r =>
      toListBufferC a
      (unzipMix (toListSubStack tyl r)
        (toListBufferC b nil))
  end.

Fixpoint toListDeque t (x:Deque t) : list t :=
  match x with
    | Empty => nil
    | Full u hed tyl =>
      toListSubStack hed (unzipMix (toListDeque tyl))
  end.

Inductive Color :=
  Red
| Yellow
| Green.

Definition bufferColor t (b:Buffer t) :=
  match b with
    | Two _ _ => Green
    | Three _ _ _ => Green
    | One _ => Yellow
    | Four _ _ _ _ => Yellow
    | _ => Red
  end.
Hint Unfold bufferColor.
Hint Unfold length.

Definition minColor a b :=
  match a with
    | Red => Red
    | Yellow =>
      match b with
        | Red => Red
        | _ => Yellow
      end
    | _ => b
  end.

Definition bottomSubStackColor s t (x:SubStack s t) :=
  match x with
    | Single pre suf =>
      match pre with
        | Zero => bufferColor suf
        | _ =>
          match suf with
            | Zero => bufferColor pre
            | _ => minColor (bufferColor pre) (bufferColor suf)
          end
      end
    | Multiple _ pre suf _ => minColor (bufferColor pre) (bufferColor suf)
  end.

Definition topSubStackColor s t (x:SubStack s t) :=
  match x with
    | Single pre suf =>
        minColor (bufferColor pre) (bufferColor suf)
    | Multiple _ pre suf _ =>
        minColor (bufferColor pre) (bufferColor suf)
  end.

Definition dequeColor t (d:Deque t) :=
  match d with
    | Empty => None
    | Full _ hed tyl => Some (
      match tyl with
        | Empty => bottomSubStackColor hed
        | _ => topSubStackColor hed
      end)
  end.

Fixpoint allSubStackYellow (f:forall s t, SubStack s t -> Color)
  s t (x:SubStack s t) :=
  f _ _ x = Yellow /\
  match x with
    | Single _ _ => True
    | Multiple _ _ _ r => allSubStackYellow f r
  end.

Definition tailStackColor (f: forall s t, SubStack s t -> Color)
  s t (x:SubStack s t) :=
  match x with
    | Single _ _ => None
    | Multiple _ _ _ r => Some (f _ _ r)
  end.

Definition yellowOrNothing x :=
  match x with
    | None => True
    | Some c =>
      match c with
        | Yellow => True
        | _ => False
      end
  end.

Definition tailStackProp (f: forall s t, SubStack s t -> Prop)
  s t (x:SubStack s t) :=
  match x with
    | Single _ _ => True
    | Multiple _ _ _ r => f _ _ r
  end.

Fixpoint restWellStacked s (x:Deque s) :=
  match x with
    | Empty => True
    | Full _ hed tyl =>
      match tyl with
        | Empty =>
          bottomSubStackColor hed <> Yellow
          /\
          tailStackProp (allSubStackYellow bottomSubStackColor) hed
        | _ =>
          topSubStackColor hed <> Yellow
          /\
          tailStackProp (allSubStackYellow topSubStackColor) hed
          /\
          restWellStacked tyl
      end
  end.

Definition wellStacked s (x:Deque s) :=
  match x with
    | Empty => True
    | Full _ hed tyl =>
      match tyl with
        | Empty => tailStackProp (allSubStackYellow bottomSubStackColor) hed
        | _ =>
          tailStackProp (allSubStackYellow topSubStackColor) hed
          /\
          restWellStacked tyl
      end
  end.

Fixpoint topDequeColors s (x:Deque s) :=
  match x with
    | Empty => nil
    | Full _ hed tyl =>
      match tyl with
        | Empty => (bottomSubStackColor hed) :: nil
        | _ => (topSubStackColor hed) :: (topDequeColors tyl)
      end
  end.

Fixpoint semiRegularColorListGreenBeforeRed x :=
  match x with
    | nil => True
    | y::ys =>
      match y with
        | Red => False
        | Green => semiRegularColorList ys
        | Yellow => semiRegularColorListGreenBeforeRed ys
      end
  end
with semiRegularColorList x :=
  match x with
    | nil => True
    | y::ys =>
      match y with
        | Red => semiRegularColorListGreenBeforeRed ys
        | _ => semiRegularColorList ys
      end
  end.

Fixpoint nonEmptySubStack t s (x:SubStack t s) :=
  match x with
    | Single pre suf =>
      match pre, suf with
        | Zero,Zero => False
        | _,_ => True
      end
    | Multiple _ pre suf tyl =>
        (match pre, suf with
           | Zero,Zero => False
           | _,_ => True
         end)
        /\
        nonEmptySubStack tyl
  end.

(* Full deques are not empty *)
Fixpoint fullDequeIs t (d:Deque t) :=
  match d with
    | Empty => True
    | Full _ hed tyl =>
      match tyl with
        | Empty => nonEmptySubStack hed
        | _ =>
          nonEmptySubStack hed
          /\
          fullDequeIs tyl
      end
  end.

Fixpoint eachBufferSubStack (f: forall a, Buffer a -> Prop)
  s t (x:SubStack s t) :=
  match x with
    | Single pre suf => f _ pre /\ f _ suf
    | Multiple _ pre suf tyl => f _ pre /\ f _ suf /\ eachBufferSubStack f tyl
  end.

Fixpoint eachSubStackDeque (f:forall s t, SubStack s t -> Prop)
  s (x:Deque s) :=
  match x with
    | Empty => True
    | Full _ hed tyl =>
      f _ _ hed /\ eachSubStackDeque f tyl
  end.

Definition semiRegular s (x:Deque s) :=
  wellStacked x
  /\
  fullDequeIs x
  /\
(*  eachSubStackDeque (eachBufferSubStack bufferSize) x
  /\*)
  semiRegularColorList (topDequeColors x).
Hint Unfold semiRegular.

Fixpoint topNonYellowIsGreen x :=
  match x with
    | nil => True
    | y::ys =>
      match y with
        | Red => False
        | Yellow => topNonYellowIsGreen ys
        | Green => True
      end
  end.

(*
Fixpoint regularColorList x :=
  topNonYellowIsGreen x
  /\
  semiRegularColorList x.
*)

Definition regular s (x:Deque s) :=
  semiRegular x
  /\
  topNonYellowIsGreen (topDequeColors x).
Hint Unfold regular.

Definition restoreBottom t (pre suf:Buffer t) : Deque t :=
  match pre,suf with
    | Zero,Five a b c d e =>
      Full (Single (Two a b) (Three c d e)) Empty
    | One a,Five b c d e f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Two a b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Three a b c,Five d e f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Four a b c d,Five e f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty
    | Five a b c d e,Five f g h i j =>
      Full (Multiple (Three a b c) (Three h i j)
        (Single (One (d,e)) (One (f,g)))) Empty

    | Five a b c d e, Zero =>
      Full (Single (Two a b) (Three c d e)) Empty
    | Five a b c d e, One f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Five a b c d e, Two f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Five a b c d e, Three f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Five a b c d e, Four f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty

    | _,_ => Full (Single pre suf) Empty
  end.

Ltac cutThis x :=
  let xx := fresh
    in remember x as xx; destruct xx.

Ltac pisp t := try subst;
  unfold bufferColor in *; unfold not; intros;
    simpl in *; auto; t;
  match goal with
    | [H:Red=Yellow |- _] => inversion H;  pisp t
    | [H:Red=Green |- _] => inversion H;  pisp t
    | [H:Yellow=Green |- _] => inversion H;  pisp t
    | [H:Yellow=Red |- _] => inversion H;  pisp t
    | [H:Green=Red |- _] => inversion H;  pisp t
    | [H:Green=Yellow |- _] => inversion H;  pisp t
    | [ H : true = false |- _] => inversion H;  pisp t
    | [ H : None = Some ?a |- _] => inversion H;  pisp t
    | [ H : Some ?a = None |- _] => inversion H;  pisp t
    | [ H : False |- _] => inversion H;  pisp t

    | [ H : True |- _] => clear H; pisp t
    | [ H : ?a = ?a |- _] => clear H;  pisp t

    | [ H : Some ?a = Some ?b |- _] => inversion_clear H; subst;  pisp t
    | [ |- regular (Full _ _) ] => unfold regular;  pisp t
    | [ H : semiRegular (Full _ _) |- _] => unfold semiRegular in H;  pisp t
    | [ |- semiRegular (Full _ _) ] => unfold semiRegular;  pisp t

    | [H : ?A \/ ?B |- _] => destruct H;  pisp t
    | [ H : _ /\ _ |- _ ] => destruct H;  pisp t
    | [ |- _ /\ _ ] => split;  pisp t

    | [ |- context[
      match ?x with
         | Single _ _ => _
         | Multiple _ _ _ _ => _
       end]] => destruct x; pisp t
    | [ |- context
      [match ?x with
         | Zero => _
         | One _ => _
         | Two _ _ => _
         | Three _ _ _ => _
         | Four _ _ _ _ => _
         | Five _ _ _ _ _ => _
       end]] => destruct x; pisp t
    | [ H : prod _ _ |- _] => cutThis H; pisp t
(*    | [ |- context
      [let (_,_) := ?x in _]] => destruct x; pisp t *)
    | _ => auto
  end.

Ltac asp := progress pisp auto.

Lemma restoreBottomDoes :
  forall t (pre suf:Buffer t),
    semiRegular (Full (Single pre suf) Empty) ->
    regular (restoreBottom pre suf).
Proof.
  intros.
  destruct pre; asp.
Qed.
Hint Resolve restoreBottomDoes.

Lemma restoreBottomPreserves :
  forall t (pre suf:Buffer t),
    let x := (Full (Single pre suf) Empty) in
      semiRegular x ->
      toListDeque (restoreBottom pre suf) = toListDeque x.
Proof.
  intros.
  destruct pre; asp.
Qed.
Hint Resolve restoreBottomPreserves.

Definition restoreOneYellowBottom
  T (p1 s1:Buffer T) (p2 s2:Buffer (prod T T)) : option (Deque T) :=
  match p1,p2,s2,s1 with
    | Zero,Zero,One (a,b),Five c d e f g =>
      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
    | Zero,Zero,Four (a,b) cd ef gh,Five i j k l m =>
      Some (Full
      (Single (Two a b) (Three k l m))
        (Full (Single (Two cd ef) (Two gh (i,j))) Empty))

    | Zero,One (a,b),Zero,Five c d e f g =>
      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
    | Zero,One (a,b),One (c,d), Five e f g h i =>
      Some (
        Full (Multiple (Four a b c d) (Three g h i)
          (Single Zero (One (e,f)))) Empty)
    | Zero,One (a,b),Two (c,d) (e,f), Five g h i j k =>
      Some (
        Full (Multiple (Four a b c d) (Three i j k)
          (Single (One (e,f)) (One (g,h)))) Empty)
    | Zero,One (a,b),Three (c,d) (e,f) (g,h), Five i j k l m =>
      Some (
        Full (Multiple (Four a b c d) (Three k l m)
          (Single (One (e,f)) (Two (g,h) (i,j)))) Empty)
    | Zero,One (a,b),Four (c,d) (e,f) (g,h) (i,j), Five k l m n o=>
      Some (
        Full (Multiple (Four a b c d) (Three m n o)
          (Single (One (e,f)) (Three (g,h) (i,j) (k,l)))) Empty)

    | Zero,Two (a,b) (c,d), One (e,f), Five g h i j k =>
      Some (
        Full (Multiple (Four a b c d) (Three i j k)
          (Single (One (e,f)) (One (g,h)))) Empty)
    | Zero,Two (a,b) (c,d),Four (e,f) (g,h) (i,j) (k,l), Five m n o p q=>
      Some (
        Full (Multiple (Four a b c d) (Three o p q)
          (Single (One (e,f)) (Four (g,h) (i,j) (k,l) (m,n)))) Empty)

    | Zero,Three (a,b) (c,d) (e,f), One (g,h), Five i j k l m=>
      Some (
        Full (Multiple (Four a b c d) (Three k l m)
          (Single (One (e,f)) (Two (g,h) (i,j)))) Empty)
    | Zero,Three (a,b) (c,d) (e,f), Four (g,h) (i,j) (k,l) (m,n), Five o p q r s =>
      Some (
        Full (Multiple (Four a b c d) (Three q r s)
          (Single (Two (e,f) (g,h)) (Four (i,j) (k,l) (m,n) (o,p)))) Empty)

    |_,_,_,_ => None
  end.

Lemma restoreOneYellowBottomDoes :
  forall t (p1 s1:Buffer t) p2 s2,
    semiRegular (Full (Multiple p1 s1 (Single p2 s2)) Empty) ->
    match restoreOneYellowBottom p1 s1 p2 s2 with
      | None => True
      | Some v => regular v
    end.
Proof.
  intros.
  destruct p1; asp.
Qed.

Lemma restoreOneYellowBottomPreserves :
  forall t (p1 s1:Buffer t) p2 s2,
    let x := (Full (Multiple p1 s1 (Single p2 s2)) Empty) in
    semiRegular x ->
    match restoreOneYellowBottom p1 s1 p2 s2 with
      | None => True
      | Some v => toListDeque x = toListDeque v
    end.
Proof.
  intros.
  destruct p1; asp.
Qed.

Lemma restoreBottomPreserves :
  forall t (pre suf:Buffer t),
    let x := (Full (Single pre suf) Empty) in
      semiRegular x ->
      toListDeque (restoreBottom pre suf) = toListDeque x.
Proof.
  intros.
  destruct pre; asp.
Qed.
Hint Resolve restoreBottomPreserves.

(Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty
    | Zero,One a,Zero,Five b c d e f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Zero,One a,One b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Zero,One a,One b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty

    | One a,Five b c d e f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Two a b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Three a b c,Five d e f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Four a b c d,Five e f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty
    | Five a b c d e,Five f g h i j =>
      Full (Multiple (Three a b c) (Three h i j)
        (Single (One (d,e)) (One (f,g)))) Empty

    | Five a b c d e, Zero =>
      Full (Single (Two a b) (Three c d e)) Empty
    | Five a b c d e, One f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Five a b c d e, Two f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Five a b c d e, Three f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Five a b c d e, Four f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty

    | _,_ => Full (Single pre suf) Empty
end

Definition restore s (x:Deque s) : option (Deque s) :=
  match x with
    | Empty => Some Empty
    | Full _ y ys =>
      match ys with
        | Empty =>
          match y with
            | Single pre suf =>
              Some (restoreBottom pre suf)
            | Multiple _ pre suf tyl =>
              match tyl with
                | Single p2 s2 => None
                | Multiple _ p2 s2 _ => None
              end
          end
        | _ => None
      end
  end.

Lemma regEmpty : forall s, regular (@Empty s).
Proof.
  intros.
  unfold regular.
  unfold semiRegular; unfold topNonYellowIsGreen; unfold topDequeColors;
    asp.
Qed.
Hint Resolve regEmpty.

Lemma restoreDoes :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => regular v
    end.
Proof.
  intros.
  destruct x; simpl in *; auto.
  destruct x; simpl in *; auto.
  destruct s0; auto.
  destruct s0; auto.
Qed.
Lemma restorePreserves :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => toListDeque v = toListDeque x
    end.
Proof.
  intros.
  destruct x; simpl in *; auto.
  destruct x; simpl in *; auto.
  destruct s0; auto.
  apply restoreBottomPreserves; auto.
  destruct s0; auto.
Qed.

Definition restore s (x:Deque s) : option (Deque s) :=
  match x with
    | Empty => Some Empty
    | Full _ y ys =>
      match ys with
        | Empty =>
          match bottomSubStackColor y with
            | Green => Some x
            | Yellow => Some x
            | Red =>
              match y with
                | Single pre suf =>
                  match pre,suf with

                    | Zero,Five a b c d e =>
                      Some (Full (Single (Two a b) (Three c d e)) Empty)
                    | One a,Five b c d e f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Two a b,Five c d e f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Three a b c,Five d e f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Four a b c d,Five e f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)
                    | Five a b c d e,Five f g h i j =>
                      Some (Full (Multiple (Three a b c) (Three h i j)
                        (Single (One (d,e)) (One (f,g)))) Empty)

                    | Five a b c d e, Zero =>
                      Some (Full (Single (Two a b) (Three c d e)) Empty)
                    | Five a b c d e, One f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Five a b c d e, Two f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Five a b c d e, Three f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Five a b c d e, Four f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)

                    | _,_ => Some x
                  end
                | Multiple _ pre suf tyl =>
                  match pre,suf with
                    | Zero,Five a b c d e =>
                      match tyl with
                        | Single p2 s2 =>
                          match s2 with
                            | Zero =>
                              Some (Full (Multiple Zero (Three c d e) (Single p2 (One (a,b)))) Empty)
                            | _ => None
                          end
                        | _ => None
                      end
                    | _,_ => None
                  end
(*
                    | One a,Five b c d e f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Two a b,Five c d e f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Three a b c,Five d e f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Four a b c d,Five e f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)
                    | Five a b c d e,Five f g h i j =>
                      Some (Full (Multiple (Three a b c) (Three h i j)
                        (Single (One (d,e)) (One (f,g)))) Empty)

                    | Five a b c d e, Zero =>
                      Some (Full (Single (Two a b) (Three c d e)) Empty)
                    | Five a b c d e, One f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Five a b c d e, Two f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Five a b c d e, Three f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Five a b c d e, Four f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)

                    | _,_ => Some x

                  match tyl with
                    | Single pre1 suf1 =>
                      match pre1 with
                        | Zero =>
                          match suf1 with
                            | Zero => Some x
                            | _ => None
                          end
                        | _ => None
                      end
                    | _ => None
                  end*)
              end
          end
        | _ => None
      end
  end.

(*
      match topSubStackColor y with
        | Green => x
        | Yellow => restoreRest ys
        | Red =>
*)

Ltac cutThis x :=
  let xx := fresh
    in remember x as xx; destruct xx.

Ltac pisp t := try subst;
  unfold bufferColor in *; simpl in *; auto; t;
  match goal with
    | [H:Red=Yellow |- _] => inversion H;  pisp t
    | [H:Red=Green |- _] => inversion H;  pisp t
    | [H:Yellow=Green |- _] => inversion H;  pisp t
    | [H:Yellow=Red |- _] => inversion H;  pisp t
    | [H:Green=Red |- _] => inversion H;  pisp t
    | [H:Green=Yellow |- _] => inversion H;  pisp t
    | [ H : true = false |- _] => inversion H;  pisp t
    | [ H : None = Some ?a |- _] => inversion H;  pisp t
    | [ H : Some ?a = None |- _] => inversion H;  pisp t
    | [ H : False |- _] => inversion H;  pisp t

    | [ H : True |- _] => clear H; pisp t
    | [ H : ?a = ?a |- _] => clear H;  pisp t

    | [ H : Some ?a = Some ?b |- _] => inversion_clear H; subst;  pisp t
    | [ |- regular (Full _ _) ] => unfold regular;  pisp t
    | [ H : semiRegular (Full _ _) |- _] => unfold semiRegular in H;  pisp t
    | [ |- semiRegular (Full _ _) ] => unfold semiRegular;  pisp t
(*
    | [ _ : context[length ?a] |- _] => destruct a; pisp t
*)
    | [H : ?A \/ ?B |- _] => destruct H;  pisp t
    | [ H : _ /\ _ |- _ ] => destruct H;  pisp t
    | [ |- _ /\ _ ] => split;  pisp t

(*
    | [ _ : _ =
      match ?x with
         | Single _ _ => _
         | Multiple _ _ _ _ => _
       end |- _] => cutThis x; pisp t
*)
    | [ |- context[
      match ?x with
         | Single _ _ => _
         | Multiple _ _ _ _ => _
       end]] => destruct x; pisp t
    | [ |- context
      [match ?x with
         | Zero => _
         | One _ => _
         | Two _ _ => _
         | Three _ _ _ => _
         | Four _ _ _ _ => _
         | Five _ _ _ _ _ => _
       end]] => destruct x; pisp t

(*
    | [ _ : context[bufferColor (?a :: ?b :: ?c :: ?d :: ?e)] |- _]
      => destruct e; pisp t
    | [ _ : context[bufferColor (?a :: ?b :: ?c :: ?e)] |- _]
      => destruct e; pisp t
    | [ _ : context[bufferColor (?a :: ?b :: ?e)] |- _]
      => destruct e; pisp t
(*    | [ _ : context[bufferColor (?a :: ?e)] |- _]
      => destruct e; pisp t*)
*)
    | _ => auto
  end.

Ltac asp := progress pisp auto.

Lemma regEmpty : forall s, regular (@Empty s).
Proof.
  intros.
  unfold regular.
  unfold semiRegular; unfold topNonYellowIsGreen; unfold topDequeColors;
    asp.
Qed.
Hint Resolve regEmpty.

Lemma restoreDoes :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => regular v
    end.
Proof.
  intros.
  destruct x.
  Focus 2.
  simpl.
  destruct x; simpl.
  destruct s0; simpl.
  Focus 2.
  destruct s0.
  destruct b2.
  destruct b0.
  Focus 6.
  destruct b.
  simpl in *.
  unfold regular in *.
  unfold semiRegular in *.
  destruct H. destruct H0.
  split. split.
  simpl in *. asp.
  asp.
  simpl.
  asp.
  split.
  asp.
  destruct x; asp;
    destruct x; asp.
  Focus 2.
  destruct b1; asp.
Qed.

Lemma restorePreserves :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => toListDeque v = toListDeque x
    end.
Proof.
  intros.
  destruct x; asp;
    destruct x; asp.
Qed.

End Carrier.

Extraction Language Haskell.
Recursive Extraction dequeColor.

Lemma help :
  forall t (p q:t), proj1 (conj p q) = p.
Proof.
  Print proj1.
  unfold proj1.
  simpl.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Util.Tactics.CacheTerm.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Tactics.Not.
Require Import Crypto.Util.Tactics.BreakMatch.

Section lang.
  Context {base_type}
          {op : flat_type base_type -> flat_type base_type -> Type}
          {interp_base_type : base_type -> Type}
          {interp_op : forall s d, op s d
                                   -> interp_flat_type interp_base_type s
                                   -> interp_flat_type interp_base_type d}.
  Local Notation Expr := (@Expr base_type op).
  Local Notation Interp := (@Interp base_type interp_base_type op interp_op).

  Definition packaged_expr_functionP A :=
    (fun F : Expr A -> Expr A
     => forall e',
         Wf e'
         -> Wf (F e')
            /\ forall v, Interp (F e') v = Interp e' v).
  Local Notation packaged_expr_function A :=
    (sig (packaged_expr_functionP A)).

  Definition compose {A} (f g : packaged_expr_function A)
    : packaged_expr_function A.
  Proof.
    exists (fun x => proj1_sig f (proj1_sig g x)).
    clear.
    abstract (
        destruct f as [f Hf], g as [g Hg]; cbn [proj1_sig];
        intros e' Wfe; split; [ apply Hf, Hg, Wfe | ];
        intro x; etransitivity; [ apply Hf, Hg, Wfe | apply Hg, Wfe ]
      ).
  Defined.

  Definition id_package {A} : packaged_expr_function A
    := exist (packaged_expr_functionP A)
             id
             (fun e' Wfe' => conj Wfe' (fun v => eq_refl)).

  Inductive reified_transformation :=
  | base (idx : nat)
  | transform (idx : nat) (rest : reified_transformation)
  | cond (test : bool) (iftrue iffalse : reified_transformation).
  Fixpoint denote {A}
           (ls : list (packaged_expr_function A))
           (ls' : list { x : Expr A | Wf x })
           default
           (f : reified_transformation)
    := match f with
       | base idx => proj1_sig (List.nth_default default ls' idx)
       | transform idx rest
         => proj1_sig (List.nth_default id_package ls idx)
                      (denote ls ls' default rest)
       | cond test iftrue iffalse
         => if test
            then denote ls ls' default iftrue
            else denote ls ls' default iffalse
       end.
  Fixpoint reduce (f : reified_transformation) : reified_transformation
    := match f with
       | base idx => base idx
       | transform idx rest => reduce rest
       | cond test iftrue iffalse
         => match reduce iftrue, reduce iffalse with
            | base idx0 as t, base idx1 as f
              => if nat_beq idx0 idx1
                 then base idx0
                 else cond test t f
            | t, f => cond test t f
            end
       end.
  Lemma Wf_denote A ctx es d f : Wf (@denote A ctx es d f).
  Proof.
    induction f; simpl; unfold proj1_sig; break_innermost_match; split_and; auto.
    match goal with H : _ |- _ => apply H; assumption end.
  Qed.
  Lemma Wf_denote_iff_True A ctx es d f : Wf (@denote A ctx es d f) <-> True.
  Proof. split; auto using Wf_denote. Qed.
  Lemma Interp_denote_reduce A ctx es d f
    : forall v, Interp (@denote A ctx es d f) v = Interp (@denote A nil es d (reduce f)) v.
  Proof.
    induction f; simpl; unfold proj1_sig; break_innermost_match;
      nat_beq_to_eq; subst;
        try reflexivity; auto.
    intro; rewrite <- IHf.
    match goal with H : _ |- _ => apply H, Wf_denote end.
  Qed.
End lang.

Local Ltac find ctx f :=
  lazymatch ctx with
  | (exist _ f _ :: _)%list => constr:(0)
  | (_ :: ?ctx)%list
    => let v := find ctx f in
       constr:(S v)
  end.

Local Ltac reify_transformation interp_base_type interp_op ctx es T cont :=
  let reify_transformation := reify_transformation interp_base_type interp_op in
  let ExprA := type of T in
  let packageP := lazymatch type of T with
                 | @Expr ?base_type_code ?op ?A
                   => constr:(@packaged_expr_functionP base_type_code op interp_base_type interp_op A)
                 end in
  let es := lazymatch es with
            | tt => constr:(@nil { x : ExprA | Wf x })
            | _ => es
            end in
  let ctx := lazymatch ctx with
             | tt => constr:(@nil (sig packageP))
             | _ => ctx
             end in
  lazymatch T with
  | ?f ?e
    => let ctx := lazymatch ctx with
                  | context[exist _ f _] => ctx
                  | _ => let hf := head f in
                         let fId := fresh hf in
                         let rfPf :=
                             cache_proof_with_type_by
                               (packageP f)
                               ltac:(refine (fun e Hwf
                                             => (fun Hwf'
                                                 => conj Hwf' (fun v => _)) _);
                                     [ autorewrite with reflective_interp; reflexivity
                                     | auto with wf ])
                                      fId in
                         constr:(cons (exist packageP f rfPf)
                                      ctx)
                  end in
       reify_transformation
         ctx es e
         ltac:(fun ctx es re
               => let idx := find ctx f in
                  cont ctx es (transform idx re))
  | match ?b with true => ?t | false => ?f end
    => reify_transformation
         ctx es t
         ltac:(fun ctx es rt
               => reify_transformation
                    ctx es f
                    ltac:(fun ctx es rf
                          => reify_transformation
                               ctx es t
                               ltac:(fun ctx es rt
                                     => cont ctx es (cond b rt rf))))
  | _ => let es := lazymatch es with
                   | context[exist _ T _] => es
                   | _
                     => let Hwf := lazymatch goal with
                                   | [ Hwf : Wf T |- _ ] => Hwf

                                   | _
                                     => let Hwf := fresh "Hwf" in
                                        cache_proof_with_type_by
                                          (Wf T)
                                          ltac:(idtac; solve_wf_side_condition)
                                                 Hwf
                                   end in
                        constr:(cons (exist Wf T Hwf) es)
                   end in
         let idx := find es T in
         cont ctx es (base idx)
  end.
Ltac finish_rewrite_reflective_interp_cached :=
  rewrite ?Wf_denote_iff_True;
  cbv [reduce nat_beq];
  try (rewrite Interp_denote_reduce;
       cbv [reduce nat_beq];
       cbv [denote List.nth_default List.nth_error];
       cbn [proj1_sig]).
Ltac rewrite_reflective_interp_cached_then ctx es cont :=
  let e := match goal with
           | [ |- context[@Interp _ _ _ _ _ ?e] ]
             => let test := match goal with _ => not is_var e end in
                e
           end in
  lazymatch goal with
  | [ |- context[@Interp ?base_type ?interp_base_type ?op ?interp_op _ e] ]
    => reify_transformation
         interp_base_type interp_op ctx es e
         ltac:(fun ctx es r
               => lazymatch es with
                  | cons ?default _
                    => change e with (denote ctx es default r)
                  end;
                  finish_rewrite_reflective_interp_cached;
                  cont ctx es)
  end.
Ltac rewrite_reflective_interp_cached :=
  rewrite_reflective_interp_cached_then tt tt ltac:(fun _ _ => idtac).


Require Import Util LengthEq AllInRel Map Envs DecSolve.
Require Import IL Annotation AutoIndTac Exp SetOperations.
Require Export Liveness.Liveness Filter LabelsDefined OUnion.

Set Implicit Arguments.

(** * Specification of True Liveness *)

Local Hint Resolve incl_empty minus_incl incl_right incl_left.

Inductive argsLive (Caller Callee:set var) : args -> params -> Prop :=
| AL_nil : argsLive Caller Callee nil nil
| AL_cons y z Y Z
  : argsLive Caller Callee Y Z
    -> (z ∈ Callee -> live_op_sound y Caller)
    -> argsLive Caller Callee (y::Y) (z::Z).

Lemma argsLive_length lv bv Y Z
  : argsLive lv bv Y Z
    -> length Y = length Z.
Proof.
  intros. general induction H; simpl; eauto.
Qed.

Hint Resolve argsLive_length : len.

Lemma argsLive_liveSound lv blv Y Z
  : argsLive lv blv Y Z
    -> forall (n : nat) (y : op),
      get (filter_by (fun y : var => B[y ∈ blv]) Z Y) n y ->
      live_op_sound y lv.
Proof.
  intros. general induction H; simpl in * |- *.
  - isabsurd.
  - decide (z ∈ blv); eauto.
    inv H1; eauto.
Qed.

Lemma argsLive_live_exp_sound lv blv Y Z y z n
  : argsLive lv blv Y Z
    -> get Y n y
    -> get Z n z
    -> z ∈ blv
    -> live_op_sound y lv.
Proof.
  intros. general induction n; invt argsLive; isabsurd; eauto.
Qed.

Lemma live_exp_sound_argsLive lv blv Y Z
  : length Y = length Z
    -> (forall n y z, get Y n y -> get Z n z -> z ∈ blv -> live_op_sound y lv)
    -> argsLive lv blv Y Z.
Proof.
  intros. length_equify.
  general induction H; eauto 20 using argsLive, get.
Qed.

Lemma argsLive_agree_on' (V E E':onv val) lv blv Y Z v v'
  :  argsLive lv blv Y Z
     -> agree_on eq lv E E'
     -> omap (op_eval E) Y = Some v
     -> omap (op_eval E') Y = Some v'
     -> agree_on eq blv (V [Z <-- List.map Some v]) (V [Z <-- List.map Some v']).
Proof.
  intros. general induction H; simpl in * |- *; eauto.
  - monad_inv H2. monad_inv H3.
    decide (z ∈ blv).
    +erewrite <- op_eval_live in EQ0; eauto.
     *  assert (x1 = x) by congruence.
        subst. simpl.
        eauto using agree_on_update_same, agree_on_incl.
    + eapply agree_on_update_dead_both; eauto.
Qed.

Lemma argsLive_agree_on (V V' E E':onv val) lv blv Y Z v v'
  : agree_on eq (blv \ of_list Z) V V'
    -> argsLive lv blv Y Z
    -> agree_on eq lv E E'
    -> omap (op_eval E) Y = Some v
    -> omap (op_eval E') Y = Some v'
    -> agree_on eq blv (V [Z <-- List.map Some v]) (V' [Z <-- List.map Some v']).
Proof.
  intros. etransitivity; eauto using argsLive_agree_on'.
  eapply update_with_list_agree; eauto with len.
Qed.

Lemma filter_by_incl_argsLive lv blv Y Z
  : ❬Y❭ = ❬Z❭
    -> list_union (Ops.freeVars ⊝ filter_by (fun x => if [x \In blv] then true else false) Z Y) ⊆ lv
    -> argsLive lv blv Y Z.
Proof.
  intros LEN INCL. length_equify.
  general induction LEN; simpl in *; eauto using argsLive.
  - econstructor.
    + cases in INCL; try congruence; eauto.
      * eapply IHLEN. rewrite <- INCL.
        simpl List.map. rewrite list_union_cons. eauto with cset.
    + intros. cases in INCL.
      simpl List.map in INCL.
      rewrite list_union_cons in INCL.
      eapply live_op_sound_incl;[eapply Ops.live_freeVars|].
      rewrite <- INCL. eauto with cset.
Qed.

(** ** The inductive predicate *)

Inductive true_live_sound (i:overapproximation)
  : list params -> list (set var) -> stmt -> ann (set var) -> Prop :=
| TLOpr ZL Lv x b lv e al
  :  true_live_sound i ZL Lv b al
     -> (x ∈ getAnn al \/ isCall e ->live_exp_sound e lv)
     -> (getAnn al\ singleton x) ⊆ lv
     -> true_live_sound i ZL Lv (stmtLet x e b) (ann1 lv al)
| TLIf ZL Lv e b1 b2 lv al1 al2
  :  true_live_sound i ZL Lv b1 al1
     -> true_live_sound i ZL Lv b2 al2
     -> live_op_sound e lv
     -> getAnn al1 ⊆ lv
     -> getAnn al2 ⊆ lv
     -> true_live_sound i ZL Lv (stmtIf e b1 b2) (ann2 lv al1 al2)
| TLGoto ZL Lv l Y lv blv Z
  : get ZL (counted l) Z
    -> get Lv (counted l) blv
    -> (if isImperative i then  (blv \ of_list Z ⊆ lv) else True)
    -> argsLive lv blv Y Z
    -> length Y = length Z
    -> true_live_sound i ZL Lv (stmtApp l Y) (ann0 lv)
| TLReturn ZL Lv e lv
  : live_op_sound e lv
    -> true_live_sound i ZL Lv (stmtReturn e) (ann0 lv)
| TLLet ZL Lv F t lv als alt
  : true_live_sound i (fst ⊝ F ++ ZL) (getAnn ⊝ als ++ Lv) t alt
    -> length F = length als
    -> (forall n Zs a, get F n Zs ->
                 get als n a ->
                 true_live_sound i (fst ⊝ F ++ ZL) (getAnn ⊝ als ++ Lv) (snd Zs) a)
    -> (forall n Zs a, get F n Zs ->
                 get als n a ->
                 if isFunctional i then (getAnn a \ of_list (fst Zs)) ⊆ lv
                 else True)
    -> getAnn alt ⊆ lv
    -> true_live_sound i ZL Lv (stmtFun F t)(annF lv als alt).

(** *** Some properties of the predicate *)

Lemma true_live_sound_overapproximation_I ZL Lv s slv
  : true_live_sound FunctionalAndImperative ZL Lv s slv
    -> true_live_sound Imperative ZL Lv s slv.
Proof.
  intros. general induction H; simpl in * |- *; econstructor; simpl; eauto.
Qed.

Lemma true_live_sound_overapproximation_F ZL Lv s slv
  : true_live_sound FunctionalAndImperative ZL Lv s slv
    -> true_live_sound Functional ZL Lv s slv.
Proof.
  intros. general induction H; simpl in * |- *; econstructor; simpl; eauto.
Qed.

Lemma argsLive_monotone lv blv blv' Y Z
  : argsLive lv blv Y Z
    -> blv' ⊆ blv
    -> argsLive lv blv' Y Z.
Proof.
  intros Args LE.
  general induction Args; eauto using argsLive.
Qed.

Lemma true_live_sound_monotone i ZL LV LV' s lv
: true_live_sound i ZL LV s lv
  -> PIR2 Subset LV' LV
  -> true_live_sound i ZL LV' s lv.
Proof.
  intros LS LE.
  general induction LS; simpl; eauto 20 using true_live_sound, PIR2_app.
  - PIR2_inv.
    econstructor; eauto.
    cases; eauto with cset.
    eauto using argsLive_monotone.
Qed.

(*
Lemma true_live_sound_trueIsCalled i ZL Lv s slv l
  : true_live_sound i ZL Lv s slv
    -> trueIsCalled s l
    -> exists lv, get Lv (counted l) lv.
Proof.
  intros Live IC. destruct l; simpl in *.
  general induction IC; invt true_live_sound; eauto.
  - edestruct IHIC2 as [lv' [Z' ?]]; eauto; simpl in *.
    rewrite get_app_lt in H1; eauto with len. inv_get.
    edestruct IHIC1 as [lv'' [Z'' ?]]; eauto.
    rewrite get_app_ge in H1; eauto with len.
    rewrite zip_length2 in H1; eauto with len.
    rewrite map_length in H1.
    orewrite (❬F❭ + n - ❬als❭ = n) in H1. eauto.
  - edestruct IHIC as [lv' [Z' ?]]; eauto; try reflexivity.
    rewrite get_app_ge in H; eauto with len.
    rewrite zip_length2 in H; eauto with len.
    rewrite map_length in H.
    orewrite (❬F❭ + n - ❬als❭ = n) in H. eauto.
Qed.*)