Require Import Coq.Unicode.Utf8.
Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Loops.

Require Coq.Init.Byte Coq.Strings.String. Import Init.Byte(byte(..)) String.
Require Import coqutil.Datatypes.List. Import Lists.List List.ListNotations.
Require Import Coq.ZArith.BinInt. Import Zdiv. Local Open Scope Z_scope.
Require Import coqutil.Byte coqutil.Word.LittleEndianList.

(* TODO: move into core Bedrock *)
Require Import Crypto.Bedrock.Field.Common.Util.

Import Syntax.Coercions ProgramLogic.Coercions.
Import Datatypes.

Open Scope Z_scope.

(*TODO: move to Rupicola.Lib *)

(*TODO: this statement is specialized to its use below.
  Should it be generalized?
 *)
Lemma skipn_nth_0 {A} (i : nat) (l : list A) d
  : i < length l -> skipn i l = (nth 0 (skipn i l) d):: skipn (S i) l.
Proof using.
  change (S i) with (1+i)%nat.
  rewrite <- skipn_skipn.
  intros.
  assert (0 < length (skipn i l)) by (rewrite length_skipn;lia).
  revert H0; generalize (skipn i l).
  intros.
  destruct l0; simpl in *; [lia|].
  reflexivity.
Qed.

  Lemma length_fold_left_invariant {A B} (l : list A) (acc : list B) f
    : (forall a acc, length (f acc a) = length acc) ->
      length (fold_left f l acc) = length acc.
  Proof.
    revert acc; induction l; simpl; intros; auto.
    rewrite IHl; congruence.
  Qed.

  Lemma upd_firstn_skipn A (l old : list A) (start : nat) d
    : start < length l ->
      start < length old ->
      upd (firstn start l ++ skipn start old) start (nth start l d)
      = (firstn (S start) l ++ skipn (S start) old).
  Proof.
    intros.
    unfold upd, upds.
    repeat rewrite !firstn_app, !skipn_app,
      !app_length,
      !firstn_length,
      !skipn_length,
      !firstn_firstn,
      !length_cons,
      !length_nil,
      !Nat.min_id.
    rewrite !min_l by lia.
    rewrite app_assoc.
    f_equal.
    {
      erewrite <- firstn_nth by lia.
      f_equal.
      {
        replace (start - start)%nat with 0%nat by lia.
        simpl.
        rewrite app_nil_r.
        reflexivity.
      }
      {
        rewrite firstn_all2; eauto.
        simpl.
        lia.
      }
    }
    {
      rewrite skipn_all2.
      {
        rewrite skipn_skipn.
        replace (1 + start - start + start)%nat with (S start) by lia.
        reflexivity.
      }
      {
        rewrite firstn_length.
        rewrite min_l; lia.
      }
    }
  Qed.

  Lemma list_as_nd_ranged_for_all_helper {A} (l old : list A) d
        (measure len start : nat)
    : measure = (len - start)%nat ->
      length l = len ->
      length old = len ->
      fold_left (λ (old0 : list A) (i : Z), upd old0 (Z.to_nat i) (nth (Z.to_nat i) l d)) (z_range start (Z.of_nat len)) ((firstn start l) ++ (skipn start old))
      = l.
  Proof.
    revert start len l old.
    induction measure; simpl; intros.
    {
      assert (start >=len) by lia.
      rewrite z_range_nil by lia.
      rewrite firstn_all2 by lia.
      rewrite skipn_all2 by lia.
      rewrite app_nil_r.
      reflexivity.
    }
    {
      rewrite z_range_cons by lia.
      simpl.
      rewrite Nat2Z.id.
      rewrite upd_firstn_skipn by lia.
      replace (Z.of_nat start + 1) with (Z.of_nat (S start)) by lia.
      rewrite IHmeasure; eauto.
      lia.
    }
  Qed.

  Lemma list_as_nd_ranged_for_all {A} (l old : list A) d len
    : length l = len ->
      length old = len ->
      nd_ranged_for_all 0 len (fun old i => upd old (Z.to_nat i) (nth (Z.to_nat i) l d)) old = l.
  Proof.
    rewrite <- fold_left_as_nd_ranged_for_all.
    intros.
    change old with ((firstn 0 l) ++ (skipn 0 old)).
    replace 0 with (Z.of_nat 0%nat) by lia.
    eapply list_as_nd_ranged_for_all_helper; eauto.
  Qed.

Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

     (*TODO: should be in core bedrock*)
  Lemma expr_locals_put m l x v exp (P : word -> Prop)
    : map.get l x = None ->
      WeakestPrecondition.expr m l exp P ->
      WeakestPrecondition.expr m (map.put l x v) exp P.
  Proof using locals_ok word_ok.
    intros.
    eapply Util.expr_only_differ_undef; eauto.
    eapply Util.only_differ_sym; eauto.
    eapply Util.only_differ_put; eauto.
    unfold map.undef_on, PropSet.singleton_set.
    unfold map.agree_on.
    intros.
    cbv in H1; subst.
    rewrite map.get_empty; auto.
  Qed.

  Lemma dexpr_locals_put m l x v exp (w : word)
    : map.get l x = None ->
      DEXPR m l exp w ->
      DEXPR m (map.put l x v) exp w.
  Proof using locals_ok word_ok.
    intros.
    eapply expr_locals_put; eauto.
  Qed.

  Class FitsInLocal T : Type :=
    {
      predT : word -> T -> mem -> Prop;
      szT : access_size;
      word_of_T : T -> word;
    }.
  (*TODO: properties*)
  Class FitsInLocal_ok T `(FitsInLocal T) : Prop :=
    {
      truncate_of_T : forall t, truncate_word szT (word_of_T t) = word_of_T t;
      predT_to_truncated_word
      : forall ptr t,
        Lift1Prop.iff1 (predT ptr t) (truncated_word szT ptr (word_of_T t));
    }.

  Section WithAccessSize.
    Context (T : Type) {T_Fits: FitsInLocal T}
            {T_Fits_ok : @FitsInLocal_ok T T_Fits}
            `{HasDefault T}.
    Existing Instance T_Fits.

    Notation predT := (@predT T T_Fits).
    Notation szT := (@szT T T_Fits).
    Notation word_of_T := (@word_of_T T T_Fits).

    Declare Scope word_scope.
    Delimit Scope word_scope with word.
    Local Infix "+" := word.add : word_scope.
    Local Infix "*" := word.mul : word_scope.

    Definition sz_word : word := (word.of_Z (Z.of_nat (Memory.bytes_per (width:=width) szT))).

    Local Notation "xs $@ a" :=
      (array predT sz_word a%word xs%list) (at level 10, format "xs $@ a").

    (* Array broadcasting/pointwise expressions.
     Requires some care to make sure that the array being written to can also be read.
     allows more things to be written in a expr style rather than a statement style,
     avoiding dealing directly with a pile of loop invariant inference.
   *)

  (* TODO: could add knowledge about lstl, but it's not yet necessary *)
  (* TODO: m not mentioned? *)
  (* expr expect idx_var to hold the index
   *)
  (*
    TODO: generalize to things that don't fit in a word by allocating scratch space
   *)
  Definition broadcast_expr
             l idx_var
             old_data ptr R
             (expr : expr.expr) (lst : list T) :=
    forall (m : mem) (lstl : list T),
      length lstl < length old_data ->
      ((lstl ++ skipn (length lstl) old_data)$@ptr * R)%sep m ->
      DEXPR m (map.put l idx_var (word.of_Z (length lstl)))
            expr (word_of_T (nth (length lstl) lst default)).

  Lemma ranged_for'_length_helper (from' : nat) scratch lst
    :  length (snd (ranged_for' 0 from'
                      (λ (acc : list T) (tok : ExitToken.t) (idx : Z) (_ : 0 - 1 < idx < from'),
                        (tok, upd acc (Z.to_nat idx) (nth (Z.to_nat idx) lst default))) scratch :
                   ExitToken.t * list T)) = length scratch.
  Proof.
    revert scratch lst.
    induction from'.
    {
      simpl.
      lia.
    }
    {
      intros.
      replace (Z.of_nat (S from')) with ((Z.of_nat from') + 1) by lia.
      erewrite ranged_for'_unfold_r; try lia.
      simpl.
      set (fst _).
      destruct y; simpl; eauto.
      rewrite upd_length.
      eauto.
    }
  Qed.

  Lemma ranged_for'_invariant {A} n m (f : _ -> _ -> _ -> _) acc (P : A -> Prop)
    : (forall acc' tok idx, fst (f acc' tok idx) = tok) ->
      P acc ->
      (forall acc' tok idx, n - 1 < idx < m -> P acc' -> P (snd (f acc' tok idx))) ->
      P (snd (nd_ranged_for' n m f acc)).
  Proof.
    intro Htok.
    unfold nd_ranged_for'.
    unfold nd_ranged_for_break.
    intros H0 Hn.
    revert acc H0.
    pose proof (z_range_sound n m) as H'; revert H'.
    generalize ((z_range n m)).

    induction l; simpl; intros; eauto.
    specialize (IHl ltac:(eauto)).
    specialize (H' a ltac:(tauto)).
    rewrite (surjective_pairing (f acc ExitToken.new a)).
    rewrite Htok.
    eapply IHl.
    eapply Hn; eauto.
  Qed.

  Lemma skipn_ranged_for'_upd (from' : nat) scratch lst
    : skipn from'
        (snd
           (ranged_for' 0 from'
              (λ (acc0 : list T) (tok : ExitToken.t) (idx : Z) (_ : 0 - 1 < idx < from'),
                (tok, upd acc0 (Z.to_nat idx) (nth (Z.to_nat idx) lst default))) scratch))
      = skipn from' scratch.
  Proof.
    rewrite <- nd_as_ranged_for'.
    eapply ranged_for'_invariant; eauto.
    intros.
    simpl in *.
    eapply nth_error_ext.
    intro i.
    rewrite ListUtil.nth_error_skipn.
    rewrite nth_error_upd_diff.
    {
      rewrite <- !ListUtil.nth_error_skipn.
      congruence.
    }
    lia.
  Qed.

  Lemma map_predT_to_truncated_word ptr t
    : Lift1Prop.iff1 (t$@ptr) (array (truncated_word szT) sz_word ptr (map word_of_T t)).
  Proof.
    revert ptr; induction t;
      simpl.
    1: cbv; eauto.
    intros ptr m.
    split; intro H'.
    2:{
      seprewrite IHt.
      seprewrite predT_to_truncated_word.
      auto.
    }
    {
      symmetry in IHt.
      seprewrite IHt.
      pose proof predT_to_truncated_word as Hpred;
        symmetry in Hpred;
        seprewrite Hpred.
      auto.
    }
  Qed.

  Lemma map_upd A B (f : A -> B) i (a : A) l
    : map f (upd l i a) = upd (map f l) i (f a).
  Proof.
    eapply nth_error_ext;
      intros i0.
    destruct (Nat.compare_spec i0 (length l)); subst.
    1,3: rewrite !ListUtil.nth_error_length_error; eauto;
    repeat rewrite ?List.map_length, ?List.upd_length; lia.
    assert A as default.
    {
      destruct l; simpl in*; try lia; auto.
    }
    rewrite !nth_error_nth' with (d:= f default)
      by (repeat rewrite ?List.map_length, ?List.upd_length; lia).
    f_equal.
    destruct (Nat.eq_dec i i0); subst.
    {
      repeat rewrite ?nth_upd_same, ?map_nth
        by (repeat rewrite ?List.map_length, ?List.upd_length; lia).
      auto.
    }
    {
      repeat rewrite ?nth_upd_diff, ?map_nth
        by (repeat rewrite ?List.map_length, ?List.upd_length; lia).
      auto.
    }
  Qed.

  Lemma compile_broadcast_expr' {t m l e} (len : nat) (lst scratch : list T) :
    len = length scratch ->
    len = length lst ->
    len < 2^width ->
    let v := lst in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           (a_ptr : word) a_var lst_expr idx_var to_var R,

      DEXPR m l (expr.var a_var) a_ptr ->

      (scratch$@a_ptr * R)%sep m ->

      ~idx_var = to_var ->
      map.get l idx_var = None ->
      map.get l to_var = None ->

     broadcast_expr l idx_var scratch a_ptr R lst_expr v ->
     (let v := v in
      (*TODO: should this allow writing to the trace?*)
       forall idx to m,
         (v$@a_ptr* R)%sep m ->
         <{ Trace := t; Memory := m; Locals := map.put (map.put l idx_var idx) to_var to; Functions := e }>
           k_impl
         <{ pred (k v eq_refl) }>) ->
      <{ Trace := t; Memory := m; Locals := l; Functions := e }>
        cmd_loop_fresh false idx_var (expr.literal 0) to_var len
                       (cmd.store szT (expr.op bopname.add a_var
                                               (expr.op bopname.mul idx_var sz_word))
                                  lst_expr)
                       k_impl
      <{ pred (nlet_eq [a_var] v k) }>.
  Proof.
    intros len_scratch len_lst.
    rewrite <- (list_as_nd_ranged_for_all lst scratch default len ltac:(auto) ltac:(auto)).
    rewrite nd_as_ranged_for_all.
    rewrite ranged_for_all_as_ranged_for.
    repeat compile_step.

    assert (~ a_var = to_var).
    {
      intro; subst.
      revert H1.
      unfold DEXPR.
      simpl.
      unfold WeakestPrecondition.get.
      rewrite H5.
      intro H'; destruct H' as [? [? ?]]; congruence.
    }
    assert (~ a_var = idx_var).
    {
      intro; subst.
      revert H1.
      unfold DEXPR.
      simpl.
      unfold WeakestPrecondition.get.
      rewrite H4.
      intro H'; destruct H' as [? [? ?]]; congruence.
    }
    eapply (compile_ranged_for_fresh _ _ _ _ _ _ _ _ _ _ _ _ idx_var to_var).
    repeat compile_step.
    repeat compile_step.
    (*Issue: in loop invariant lp from -> lp from'*)
    let x := open_constr:(fun from' lst tr mem locals =>
                            (lst$@a_ptr ⋆ R) mem
                            /\ tr = t
                            /\ locals = map.put (map.put l idx_var (word.of_Z from'))
                                                to_var (word.of_Z (Z.of_nat (length scratch)))) in
    instantiate(1:= x).
    {
      cbn beta.
      repeat compile_step.
      rewrite map.get_put_diff; repeat compile_step.
      rewrite map.get_put_same; repeat compile_step.
      rewrite map.get_put_same; repeat compile_step.
    }
    {
      cbn beta.
      repeat compile_step.
      rewrite map.put_comm; try compile_step.
      f_equal.
      rewrite map.put_put_same.
      reflexivity.
    }
    {
      cbn beta.
      repeat compile_step.
    }
    {
      repeat compile_step; try lia.
    }
    {
      cbn beta.
      repeat compile_step.
      repeat straightline'.
      exists (word.add a_ptr (word.mul (word.of_Z from') sz_word)); repeat compile_step.
      {
        eapply Util.dexpr_put_diff; repeat compile_step.
        eapply Util.dexpr_put_diff; repeat compile_step.
      }
      {
        eapply Util.dexpr_put_diff; repeat compile_step.
        eapply Util.dexpr_put_same; repeat compile_step.
      }
      exists (word_of_T (nth (Z.to_nat from') lst default)); repeat compile_step.
      {
        unfold broadcast_expr in *.
        subst v.
        revert H6.
        rewrite <- ranged_for_all_as_ranged_for.
        rewrite <- nd_as_ranged_for_all.
        rewrite (list_as_nd_ranged_for_all lst scratch default (length scratch)
                                           ltac:(auto) ltac:(auto)).
        intro H'.
        eapply dexpr_locals_put.
        {
          rewrite map.get_put_diff; auto.
        }
        (*TODO: need to know about the ranged_for'*)
        specialize (H' mem0 (firstn (Z.to_nat from') acc)).
        rewrite firstn_length in H'.
        assert (from' <= length acc).
        {
          unfold acc.
          unfold a.
          replace (from') with (Z.of_nat (Z.to_nat from')) by lia.
          rewrite ranged_for'_length_helper.
          lia.
        }
        rewrite Nat.min_l in H' by lia.
        rewrite Z2Nat.id in H'.
        eapply H'.
        all:try lia.
        replace (firstn (Z.to_nat from') acc ++ skipn (Z.to_nat from') scratch) with acc; eauto.
        rewrite <- firstn_skipn with (n:=Z.to_nat from') (l:=acc) at 1.
        f_equal.
        unfold acc, a.
        replace (from') with (Z.of_nat (Z.to_nat from')) by lia.
        rewrite Nat2Z.id.
        apply skipn_ranged_for'_upd.
      }
      {

        seprewrite_in map_predT_to_truncated_word H12.
        eapply array_store_of_sep in H12.
        destruct H12 as [? [? ?]].

        eexists; split.
        { apply H11. }
        {
          unfold lp.
          simpl.
          split; eauto.
        }
        {
          instantiate (1:=Z.to_nat from').
          f_equal.
          rewrite Z2Nat.id by lia.
          rewrite Z.mul_comm.
          rewrite word.ring_morph_mul.
          rewrite word.of_Z_unsigned.
          reflexivity.
        }
        {
          rewrite List.map_length.
          unfold acc, a.
          replace (from') with (Z.of_nat (Z.to_nat from')) by lia.
          rewrite ranged_for'_length_helper.
          lia.
        }
        {
          intros.
          seprewrite map_predT_to_truncated_word.
          rewrite <- map_upd in H11.
          eauto.
        }
      }
    }
    {
      simpl.
      intros.
      destruct H10.
      eapply H7 in H10.
      change (-1) with (0-1).
      unfold v in H10.
      destruct H11;
        subst.
      exact H10.
    }
  Qed.

  Lemma compile_broadcast_expr {t m l e} (len : nat) (lst scratch : list T) :
    let v := lst in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           (a_ptr : word) a_var lst_expr idx_var to_var R,

      DEXPR m l (expr.var a_var) a_ptr ->

      (scratch$@a_ptr * R)%sep m ->

      len = length scratch ->
      len = length lst ->
      len < 2^width ->

      ~idx_var = to_var ->
      map.get l idx_var = None ->
      map.get l to_var = None ->

      broadcast_expr l idx_var scratch a_ptr R lst_expr v ->
      (let v := v in
       (*TODO: should we allow affecting the trace? *)
       forall idx to m,
         (v$@a_ptr* R)%sep m ->
         <{ Trace := t; Memory := m; Locals :=  map.put (map.put l idx_var idx) to_var to; Functions := e }>
           k_impl
         <{ pred (k v eq_refl) }>) ->
      <{ Trace := t; Memory := m; Locals := l; Functions := e }>
        cmd_loop_fresh false idx_var (expr.literal 0) to_var len
          (cmd.store szT (expr.op bopname.add a_var
                            (expr.op bopname.mul idx_var sz_word))
             lst_expr)
          k_impl
      <{ pred (nlet_eq [a_var] v k) }>.
  Proof using T_Fits_ok env_ok ext_spec_ok locals_ok mem_ok word_ok.
    eauto using compile_broadcast_expr'.
  Qed.

    Section Binops.

      Context (expr_op : expr -> expr -> expr)
              (word_op : word -> word -> word)
              (op : T -> T -> T).
      Context (word_morph : forall a b, word_of_T (op a b) = word_op (word_of_T a) (word_of_T b)).

      Context (expr_compile_word_op
                 : forall {m l} (w1 w2 : word.rep) (e1 e2 : expr),
                  DEXPR m l e1 w1 ->
                  DEXPR m l e2 w2 ->
                  DEXPR m l (expr_op e1 e2) (word_op w1 w2)).

    (*TODO: generalize to a DEXPR goal instead of bop?*)
      Lemma broadcast_binop l idx_var scratch a_ptr R l1_expr l2_expr (l1 l2 : list T)
        : (*TODO: not necessary, just makes proof using expr_compile_word_op word_morph easier*)
        op default default = default ->

        length l1 = length l2 ->
        broadcast_expr l idx_var scratch a_ptr R l1_expr l1 ->
        broadcast_expr l idx_var scratch a_ptr R l2_expr l2 ->
        broadcast_expr l idx_var scratch a_ptr R
                       (expr_op l1_expr l2_expr)
                       (List.map (fun '(w1, w2) => op w1 w2) (combine l1 l2)).
      Proof.
        unfold broadcast_expr; intuition idtac.
        set (op_uncurry:=fun '(w1,w2) => op w1 w2).
        replace default with (op_uncurry (default,default)).
        rewrite map_nth.
        rewrite combine_nth by auto.
        subst op_uncurry; cbn beta match.
        rewrite word_morph.
        eapply expr_compile_word_op; eauto.
      Qed.

    End Binops.

    (*TODO: this is awkward*)
    Local Definition predT_to_tw := @predT_to_truncated_word T T_Fits T_Fits_ok.

    Local Hint Resolve predT_to_tw : ecancel_impl.

  Lemma broadcast_id l idx_var scratch a_ptr R a_var
    : map.get l a_var = Some a_ptr ->
      ~a_var = idx_var ->
      broadcast_expr l idx_var scratch a_ptr R
                     (expr.load szT
                                (expr.op bopname.add a_var
                                                 (expr.op bopname.mul idx_var sz_word)))
                     scratch.
  Proof using T_Fits_ok locals_ok mem_ok word_ok.
    unfold broadcast_expr; intuition idtac.
    repeat straightline.
    exists a_ptr; intuition idtac.
    {
      rewrite map.get_put_diff by assumption.
      assumption.
    }
    exists (word.of_Z (Z.of_nat (length lstl))).
    intuition idtac.
    {
      rewrite map.get_put_same; eauto.
    }
    simpl.
    unfold WeakestPrecondition.literal.
    cbv [dlet].
    exists (word_of_T (nth (length lstl) scratch default)).
    split; auto.
    erewrite load_of_sep.
    {
      erewrite truncate_of_T.
      reflexivity.
    }
    seprewrite_in (array_append (T:=T) predT sz_word) H3.
    replace (nth (length lstl) scratch)
      with (nth ((length lstl)+0) scratch) by (f_equal;lia).
    rewrite <- nth_skipn.
    assert (0 < length (skipn (length lstl) scratch)).
    {
      rewrite length_skipn.
      lia.
    }
    erewrite skipn_nth_0 in H3 by lia.
    cbn [nth array] in *.
    lazymatch goal with
    | [H : context [predT ?ptr1] |- context [ truncated_word _ ?ptr2]] =>
        replace ptr2 with ptr1
    end.
    seprewrite_in predT_to_truncated_word H3.
    ecancel_assumption.
    f_equal.
    rewrite Z.mul_comm.
    rewrite word.ring_morph_mul.
    reflexivity.
  Qed.

  Lemma split_hd_tl {A} (a:A) (l:list A)
    : 0 < length l ->
      l = hd a l :: tl l.
  Proof.
    destruct l; simpl in *; [lia | auto].
  Qed.

  Lemma broadcast_var l idx_var scratch a_ptr b_ptr a_var a_data R' R
    : Lift1Prop.iff1 R' (a_data$@a_ptr * R)%sep ->
      map.get l a_var = Some a_ptr ->
      ~a_var = idx_var ->
      length scratch <= length a_data ->
      broadcast_expr l idx_var scratch b_ptr R'
        (expr.load szT
           (expr.op bopname.add a_var
              (expr.op bopname.mul idx_var sz_word)))
        a_data.
  Proof using T_Fits_ok locals_ok mem_ok word_ok.
    unfold broadcast_expr; intuition idtac.
    repeat straightline.
    exists a_ptr; intuition idtac.
    {
      rewrite map.get_put_diff by assumption.
      assumption.
    }
    exists (word.of_Z (Z.of_nat (length lstl))).
    intuition idtac.
    {
      rewrite map.get_put_same; eauto.
    }
    simpl.
    unfold WeakestPrecondition.literal.
    cbv [dlet].
    exists (word_of_T (nth (length lstl) a_data default)).
    split; auto.
    erewrite load_of_sep.
    {
      erewrite truncate_of_T.
      reflexivity.
    }
    seprewrite_in H0 H5.
    clear R' H0.
    assert (((lstl ++ skipn (length lstl) scratch)$@b_ptr ⋆  (a_data$@a_ptr) * R)%sep m)
     as H6 by ecancel_assumption.
    clear H5; rename H6 into H5.
    seprewrite_in (array_append (T:=T) predT sz_word) H5.
    replace (nth (length lstl) scratch)
      with (nth ((length lstl)+0) scratch) by (f_equal;lia).
    seprewrite_in map_predT_to_truncated_word H5.
    seprewrite_in map_predT_to_truncated_word H5.
    seprewrite_in map_predT_to_truncated_word H5.
    rewrite <- (firstn_skipn (length lstl) a_data) in H5.
    rewrite map_app in H5.
    seprewrite_in (array_append (T:=word)) H5.
    rewrite map_length in H5.
    rewrite firstn_length in H5.
    replace ((Init.Nat.min (length lstl) (length a_data))) with (length lstl) in H5 by lia.
    rewrite (split_hd_tl default (skipn (length lstl) a_data)) in H5 by (rewrite skipn_length; lia).
    simpl in H5.
    rewrite Z.mul_comm in H5.
    rewrite word.ring_morph_mul in H5.
    rewrite <- hd_skipn_nth_default in H5.
    rewrite nth_default_eq in H5.
    ecancel_assumption.
  Qed.

  End WithAccessSize.

  Instance byte_ac : FitsInLocal byte :=
    {|
      predT := ptsto;
      szT := access_size.one;
      word_of_T b := word_of_byte b;
    |}.

  Lemma byte_and_xff b : byte.and b xff = b.
  Proof using Type.
    destruct b; reflexivity.
  Qed.

  (*TODO: where to put?*)
  Axiom (width_at_least_byte : 8 <= width).

  Lemma byte_in_word_bounds t
    : 0 <= byte.unsigned t < 2 ^ width.
  Proof using Type.
    assert (256 <= 2^width).
    {
      assert (256 <= 2^8) by (compute; congruence).
      pose proof (Z.pow_le_mono_r 2 8 width).
      pose proof width_at_least_byte.
      lia.
    }
    destruct t; cbv [byte.unsigned Byte.to_N Z.of_N]; lia.
  Qed.

  Instance byte_ac_ok : FitsInLocal_ok byte byte_ac.
  Proof using BW mem_ok word_ok.
    constructor; unfold word_of_T, szT, predT, byte_ac.
    {
      intros; unfold truncate_word.
      cbn.
      unfold truncate_Z.
      simpl.
      rewrite word.morph_and.
      rewrite word.unsigned_of_Z_nowrap; [| apply byte_in_word_bounds].
      change (word.of_Z (Z.ones 8)) with (word_of_byte xff : word).
      rewrite <- byte_morph_and.
      rewrite byte_and_xff.
      reflexivity.
    }
    intros ptr t m.
    split.
    {
      intro H.
      unfold  truncated_word, truncated_scalar.
      cbn.
      rewrite word.unsigned_of_Z_nowrap.
      rewrite word.byte_of_Z_unsigned.
      ecancel_assumption.
      apply byte_in_word_bounds.
    }
    {
      intro H.
      unfold truncated_word, truncated_scalar in H.
      cbn in H.
      rewrite word.unsigned_of_Z_nowrap in H.
      rewrite word.byte_of_Z_unsigned in H.
      ecancel_assumption.
      apply byte_in_word_bounds.
    }
  Qed.

  Instance word_ac : FitsInLocal word :=
    {|
      predT := scalar;
      szT := access_size.word;
      word_of_T b := b;
    |}.

  (*TODO: where to get this fact from?*)
  Axiom width_mul_8 : exists x, width = x * 8.

  Instance word_ac_ok : FitsInLocal_ok word word_ac.
  Proof.
    constructor; unfold word_of_T, szT, predT, word_ac.
    {
      intros.
      intros; unfold truncate_word.
      cbn.
      unfold truncate_Z.
      simpl.
      rewrite word.morph_and.
      rewrite !word.of_Z_unsigned.
      rewrite Z2Nat.id.
      unfold Memory.bytes_per_word.
      replace ((width + 7) / 8 * 8) with width.
      {
        rewrite <- (word.of_Z_unsigned t).
        rewrite <- word.morph_and.
        rewrite word.of_Z_land_ones.
        auto.
      }
      {
        pose proof width_mul_8 as Hw; destruct Hw as [x Hw]; subst.
        lia.
      }
      {
        unfold Memory.bytes_per_word.
        pose proof (word.width_pos).
        pose proof width_mul_8 as Hw; destruct Hw as [x Hw]; subst.
        lia.
      }
    }
    {
      intros ptr t m;
        split;
        unfold scalar in *;
        auto.
    }
  Qed.

  (*TODO: define in general*)
  Lemma broadcast_byte_const l (idx_var : string) scratch a_ptr R (const_list : list byte)
    : length scratch <= length const_list ->
      length scratch <= 2^width ->
      broadcast_expr byte l idx_var scratch a_ptr R
                     (expr.inlinetable
                               access_size.one
                               const_list
                               idx_var)
                     const_list.
  Proof.
    unfold broadcast_expr.
    intros.
    repeat straightline.
    exists (word.of_Z (length lstl)); split; auto.
    {
      rewrite map.get_put_same; eauto.
    }
    unfold  WeakestPrecondition.load.
    exists (word_of_byte (nth (length lstl) const_list x00)).
    split; auto.
    eapply load_one_of_sep.
    instantiate (1:= fun _ => True).

    exists (map.put map.empty (word.of_Z (Z.of_nat (length lstl))) (nth (length lstl) const_list x00)).
    exists (map.remove (OfListWord.map.of_list_word const_list) (word.of_Z (Z.of_nat (length lstl)))).
    intuition idtac.
    {
      eapply map.split_comm.
      eapply map.split_remove_put.
      rewrite map.split_empty_r; auto.
      rewrite OfListWord.map.get_of_list_word.
      rewrite word.unsigned_of_Z.
      rewrite word.wrap_small.
      rewrite Nat2Z.id.
      eapply nth_error_nth'.
      lia.
      split; try lia.
    }
    {
      reflexivity.
    }
  Qed.

  Lemma broadcast_byte_and l idx_var scratch a_ptr R l1_expr l2_expr (l1 l2 : list byte)
    : length l1 = length l2 ->
      broadcast_expr byte l idx_var scratch a_ptr R l1_expr l1 ->
      broadcast_expr byte l idx_var scratch a_ptr R l2_expr l2 ->
      broadcast_expr byte l idx_var scratch a_ptr R
                     (expr.op bopname.and l1_expr l2_expr)
                     (List.map (fun '(w1, w2) => byte.and w1 w2) (combine l1 l2)).
  Proof using BW word_ok.
    eapply broadcast_binop.
    - exact byte_morph_and.
    - intros; eapply expr_compile_word_and; eauto.
    - reflexivity.
  Qed.

  Lemma broadcast_word_add l idx_var scratch a_ptr R l1_expr l2_expr (l1 l2 : list word)
    : length l1 = length l2 ->
      broadcast_expr word l idx_var scratch a_ptr R l1_expr l1 ->
      broadcast_expr word l idx_var scratch a_ptr R l2_expr l2 ->
      broadcast_expr word l idx_var scratch a_ptr R
                     (expr.op bopname.add l1_expr l2_expr)
                     (List.map (fun '(w1, w2) => word.add w1 w2) (combine l1 l2)).
  Proof using word_ok.
    eapply broadcast_binop.
    - intros; reflexivity.
    - intros; eapply expr_compile_word_add; eauto.
    - unfold default, HasDefault_word.
      rewrite <- word.ring_morph_add.
      reflexivity.
  Qed.

End with_parameters.

Ltac compile_broadcast_expr :=
  lazymatch goal with
  | [ |- WeakestPrecondition.cmd _ _ _ _ ?locals (_ (nlet_eq [?var] ?v _)) ] =>
      let idx_var_str := gensym locals constr:((var++"_idx")%string) in
      let to_var_str := gensym locals constr:((var++"_to")%string) in
      simple eapply compile_broadcast_expr
        with (idx_var:=idx_var_str) (to_var:=to_var_str);
      [ typeclasses eauto|..]
  end.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Floating-point format with gradual underflow *)
Require Import Raux Defs Round_pred Generic_fmt Float_prop.
Require Import FLX FIX Ulp Round_NE.
Require Import Psatz.

Section RND_FLT.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Inductive FLT_format (x : R) : Prop :=
  FLT_spec (f : float beta) :
    x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z ->
    (emin <= Fexp f)%Z -> FLT_format x.

Definition FLT_exp e := Z.max (e - prec) emin.

(** Properties of the FLT format *)
Global Instance FLT_exp_valid : Valid_exp FLT_exp.
Proof.
intros k.
unfold FLT_exp.
generalize (prec_gt_0 prec).
repeat split ;
  intros ; zify ; omega.
Qed.

Theorem generic_format_FLT :
  forall x, FLT_format x -> generic_format beta FLT_exp x.
Proof.
clear prec_gt_0_.
intros x [[mx ex] H1 H2 H3].
simpl in H2, H3.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold cexp, FLT_exp.
rewrite mag_F2R with (1 := Zmx).
apply Z.max_lub with (2 := H3).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply mag_le_Zpower.
Qed.

Theorem FLT_format_generic :
  forall x, generic_format beta FLT_exp x -> FLT_format x.
Proof.
intros x.
unfold generic_format.
set (ex := cexp beta FLT_exp x).
set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)).
intros Hx.
rewrite Hx.
eexists ; repeat split ; simpl.
apply lt_IZR.
rewrite IZR_Zpower. 2: now apply Zlt_le_weak.
apply Rmult_lt_reg_r with (bpow ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
change (F2R (Float beta (Z.abs mx) ex) < bpow (prec + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
unfold cexp in ex.
destruct (mag beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - prec <= ex)%Z. omega.
unfold ex, FLT_exp.
apply Z.le_max_l.
apply Z.le_max_r.
Qed.

Theorem FLT_format_bpow :
  forall e, (emin <= e)%Z -> generic_format beta FLT_exp (bpow e).
Proof.
intros e He.
apply generic_format_bpow; unfold FLT_exp.
apply Z.max_case; try assumption.
unfold Prec_gt_0 in prec_gt_0_; omega.
Qed.

Theorem FLT_format_satisfies_any :
  satisfies_any FLT_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLT_exp)).
intros x.
split.
apply FLT_format_generic.
apply generic_format_FLT.
Qed.

Theorem cexp_FLT_FLX :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  cexp beta FLT_exp x = cexp beta (FLX_exp prec) x.
Proof.
intros x Hx.
assert (Hx0: x <> 0%R).
intros H1; rewrite H1, Rabs_R0 in Hx.
contradict Hx; apply Rlt_not_le, bpow_gt_0.
unfold cexp.
apply Zmax_left.
destruct (mag beta x) as (ex, He).
unfold FLX_exp. simpl.
specialize (He Hx0).
cut (emin + prec - 1 < ex)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
Qed.

(** Links between FLT and FLX *)
Theorem generic_format_FLT_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  generic_format beta (FLX_exp prec) x ->
  generic_format beta FLT_exp x.
Proof.
intros x Hx H.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply generic_format_0.
unfold generic_format, scaled_mantissa.
now rewrite cexp_FLT_FLX.
Qed.

Theorem generic_format_FLX_FLT :
  forall x : R,
  generic_format beta FLT_exp x -> generic_format beta (FLX_exp prec) x.
Proof.
clear prec_gt_0_.
intros x Hx.
unfold generic_format in Hx; rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
unfold cexp, FLX_exp, FLT_exp.
apply Z.le_max_l.
Qed.

Theorem round_FLT_FLX : forall rnd x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x.
Proof.
intros rnd x Hx.
unfold round, scaled_mantissa.
rewrite cexp_FLT_FLX ; trivial.
Qed.

(** Links between FLT and FIX (underflow) *)
Theorem cexp_FLT_FIX :
  forall x, x <> 0%R ->
  (Rabs x < bpow (emin + prec))%R ->
  cexp beta FLT_exp x = cexp beta (FIX_exp emin) x.
Proof.
intros x Hx0 Hx.
unfold cexp.
apply Zmax_right.
unfold FIX_exp.
destruct (mag beta x) as (ex, Hex).
simpl.
cut (ex - 1 < emin + prec)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := Hx).
now apply Hex.
Qed.

Theorem generic_format_FIX_FLT :
  forall x : R,
  generic_format beta FLT_exp x ->
  generic_format beta (FIX_exp emin) x.
Proof.
clear prec_gt_0_.
intros x Hx.
rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
apply Z.le_max_r.
Qed.

Theorem generic_format_FLT_FIX :
  forall x : R,
  (Rabs x <= bpow (emin + prec))%R ->
  generic_format beta (FIX_exp emin) x ->
  generic_format beta FLT_exp x.
Proof with auto with typeclass_instances.
apply generic_inclusion_le...
intros e He.
unfold FIX_exp.
apply Z.max_lub.
omega.
apply Z.le_refl.
Qed.

Lemma negligible_exp_FLT :
  exists n, negligible_exp FLT_exp = Some n /\ (n <= emin)%Z.
Proof.
case (negligible_exp_spec FLT_exp).
{ intro H; exfalso; specialize (H emin); revert H.
  apply Zle_not_lt, Z.le_max_r. }
intros n Hn; exists n; split; [now simpl|].
destruct (Z.max_spec (n - prec) emin) as [(Hm, Hm')|(Hm, Hm')].
{ now revert Hn; unfold FLT_exp; rewrite Hm'. }
revert Hn prec_gt_0_; unfold FLT_exp, Prec_gt_0; rewrite Hm'; lia.
Qed.

Theorem generic_format_FLT_1 (Hemin : (emin <= 0)%Z) :
  generic_format beta FLT_exp 1.
Proof.
unfold generic_format, scaled_mantissa, cexp, F2R; simpl.
rewrite Rmult_1_l, (mag_unique beta 1 1).
{ unfold FLT_exp.
  destruct (Z.max_spec_le (1 - prec) emin) as [(H,Hm)|(H,Hm)]; rewrite Hm;
    (rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]);
    (rewrite Ztrunc_IZR, IZR_Zpower, <-bpow_plus;
     [|unfold Prec_gt_0 in prec_gt_0_; omega]);
    now replace (_ + _)%Z with Z0 by ring. }
rewrite Rabs_R1; simpl; split; [now right|].
rewrite IZR_Zpower_pos; simpl; rewrite Rmult_1_r; apply IZR_lt.
apply (Z.lt_le_trans _ 2); [omega|]; apply Zle_bool_imp_le, beta.
Qed.

Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R ->
    ulp beta FLT_exp x = bpow emin.
Proof with auto with typeclass_instances.
intros x Hx.
unfold ulp; case Req_bool_spec; intros Hx2.
(* x = 0 *)
case (negligible_exp_spec FLT_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
apply Zle_not_lt; unfold FLT_exp.
apply Z.le_trans with (2:=Z.le_max_r _ _); omega.
assert (V:FLT_exp emin = emin).
unfold FLT_exp; apply Z.max_r.
unfold Prec_gt_0 in prec_gt_0_; omega.
intros n H2; rewrite <-V.
apply f_equal, fexp_negligible_exp_eq...
omega.
(* x <> 0 *)
apply f_equal; unfold cexp, FLT_exp.
apply Z.max_r.
assert (mag beta x-1 < emin+prec)%Z;[idtac|omega].
destruct (mag beta x) as (e,He); simpl.
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=Hx).
now apply He.
Qed.

Theorem ulp_FLT_le :
  forall x, (bpow (emin + prec - 1) <= Rabs x)%R ->
  (ulp beta FLT_exp x <= Rabs x * bpow (1 - prec))%R.
Proof.
intros x Hx.
assert (Zx : (x <> 0)%R).
  intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt.
  rewrite Z, Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0 with (1 := Zx).
unfold cexp, FLT_exp.
destruct (mag beta x) as (e,He).
apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R.
rewrite <- bpow_plus.
right; apply f_equal.
replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring.
apply Z.max_l.
assert (emin+prec-1 < e)%Z; try omega.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=Hx).
now apply He.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply He.
Qed.

Theorem ulp_FLT_gt :
  forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0.
rewrite Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLT_exp.
apply Rlt_le_trans with (bpow (mag beta x)*bpow (-prec))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply bpow_mag_gt.
rewrite <- bpow_plus.
apply bpow_le.
apply Z.le_max_l.
Qed.

Lemma ulp_FLT_exact_shift :
  forall x e,
  (x <> 0)%R ->
  (emin + prec <= mag beta x)%Z ->
  (emin + prec - mag beta x <= e)%Z ->
  (ulp beta FLT_exp (x * bpow e) = ulp beta FLT_exp x * bpow e)%R.
Proof.
intros x e Nzx Hmx He.
unfold ulp; rewrite Req_bool_false;
  [|now intro H; apply Nzx, (Rmult_eq_reg_r (bpow e));
    [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]].
rewrite (Req_bool_false _ _ Nzx), <- bpow_plus; f_equal; unfold cexp, FLT_exp.
rewrite (mag_mult_bpow _ _ _ Nzx), !Z.max_l; omega.
Qed.

Lemma succ_FLT_exact_shift_pos :
  forall x e,
  (0 < x)%R ->
  (emin + prec <= mag beta x)%Z ->
  (emin + prec - mag beta x <= e)%Z ->
  (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R.
Proof.
intros x e Px Hmx He.
rewrite succ_eq_pos; [|now apply Rlt_le, Rmult_lt_0_compat, bpow_gt_0].
rewrite (succ_eq_pos _ _ _ (Rlt_le _ _ Px)).
now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLT_exact_shift; [lra| |].
Qed.

Lemma succ_FLT_exact_shift :
  forall x e,
  (x <> 0)%R ->
  (emin + prec + 1 <= mag beta x)%Z ->
  (emin + prec - mag beta x + 1 <= e)%Z ->
  (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R.
Proof.
intros x e Nzx Hmx He.
destruct (Rle_or_lt 0 x) as [Px|Nx].
{ now apply succ_FLT_exact_shift_pos; [lra|lia|lia]. }
unfold succ.
rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra].
rewrite Rle_bool_false; [|now simpl].
rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal.
unfold pred_pos.
rewrite mag_mult_bpow; [|lra].
replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus.
unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0].
fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool.
{ rewrite mag_opp; unfold FLT_exp; do 2 (rewrite Z.max_l; [|lia]).
  replace (_ - _)%Z with (mag beta x - 1 - prec + e)%Z; [|ring].
  rewrite bpow_plus; ring. }
rewrite ulp_FLT_exact_shift; [ring|lra| |]; rewrite mag_opp; lia.
Qed.

(** FLT is a nice format: it has a monotone exponent... *)
Global Instance FLT_exp_monotone : Monotone_exp FLT_exp.
Proof.
intros ex ey.
unfold FLT_exp.
zify ; omega.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLT : Exists_NE beta FLT_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
intros e.
unfold FLT_exp.
destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ;
  rewrite H2 ; clear H2.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (e - prec + 1 - prec) emin).
omega.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (emin + 1 - prec) emin).
omega.
Qed.

End RND_FLT.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A Aprime /\ (wd_ A B /\ (wd_ C B /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O Aprime Cprime /\ col_ O C Aprime))))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coqlib.
Require Import List. Import ListNotations.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import sha.functional_prog.
Require Import HMAC256_DRBG_functional_prog.
Require Import entropy.
Require Import DRBG_state_handle.
Require Import DRBG_generate_function.
Require Import DRBG_instantiate_function.
Require Import DRBG_reseed_function.

Require Import sha.ByteBitRelations.

Definition stream_dummy (result: string) (n: nat) : option bool :=
  let hex := bytesToBits (hexstring_to_Zlist result) in
  if nth_ok n hex false then Some (nth n hex false)
  else None.

Definition get_nonce_dummy (result: string) (_: unit) := hexstring_to_Zlist result.

Fixpoint DRBG_generate_check (state_handle: DRBG_state_handle) (internal_states: list (string * string * string * string)) (returned_bits: string) :=
  match internal_states with
    | [] => True
    | (key, v, additional_input, entropy_input_reseed)::[] =>
      let test_HMAC256_DRBG_reseed_function := HMAC256_DRBG_reseed_function 32 32 256 in
      let test_HMAC256_DRBG_generate_function := HMAC256_DRBG_generate_function test_HMAC256_DRBG_reseed_function 1024 128 128 in
      let key := hexstring_to_Zlist key in
      let value := hexstring_to_Zlist v in
      let additional_input := hexstring_to_Zlist additional_input in
      let returned_bits := hexstring_to_Zlist returned_bits in
      match test_HMAC256_DRBG_generate_function (stream_dummy entropy_input_reseed) state_handle 128 256 true additional_input with
        | ENTROPY.success (returned_bits', ((value', key', _), _, _)) _ => listZ_eq value value' = true /\ listZ_eq key key' = true /\ listZ_eq returned_bits returned_bits' = true
        | ENTROPY.error _ _ => False
      end
    | (key, v, additional_input, entropy_input_reseed)::tl =>
      let test_HMAC256_DRBG_reseed_function := HMAC256_DRBG_reseed_function 32 32 256 in
      let test_HMAC256_DRBG_generate_function := HMAC256_DRBG_generate_function test_HMAC256_DRBG_reseed_function 1024 128 128 in
      let key := hexstring_to_Zlist key in
      let value := hexstring_to_Zlist v in
      let additional_input := hexstring_to_Zlist additional_input in
      match test_HMAC256_DRBG_generate_function (stream_dummy entropy_input_reseed) state_handle 128 256 true additional_input with
        | ENTROPY.success (_, ((value', key', x), y, z)) _ => listZ_eq value value' = true /\ listZ_eq key key' = true /\ DRBG_generate_check ((value', key', x), y, z) tl returned_bits
        | ENTROPY.error _ _ => False
      end
  end.

Definition DRBG_check (entropy_input nonce key value personalization_string: string) (internal_states: list (string * string * string * string)) (returned_bits: string) :=
  let key := hexstring_to_Zlist key in
  let value := hexstring_to_Zlist value in
  let personalization_string := hexstring_to_Zlist personalization_string in
  match HMAC256_DRBG_instantiate_function 32 32 (get_nonce_dummy nonce) 256 256 true (stream_dummy entropy_input) 256 true personalization_string with
    | ENTROPY.success ((value', key', x), y, z) _ => listZ_eq value value' = true /\ listZ_eq key key' = true /\ DRBG_generate_check ((value', key', x), y, z) internal_states returned_bits
    | _ => False
  end.

Lemma test0:
  DRBG_check
    "9969e54b4703ff31785b879a7e5c0eae0d3e309559e9fe96b0676d49d591ea4d"
    "07d20d46d064757d3023cac2376127ab"
    "c2d1fd328b9789a72097325a5623f1b23eed73ed2fdcb477e9a2dd10a96f9d27"
    "cba657aa552473950ef85a02f228224514c648f01cdb2cd04aa773c25ca836f2"
    ""
    [
      ("d89d68107440e91a57a841b688ad0fd1fbeb440d26b199bad639280ba809da2e"%string, "df85d42ae075f3560d00a653ecf4dba120a90dc4510245aaf77c799f488df76e"%string, ""%string, "c60f2999100f738c10f74792676a3fc4a262d13721798046e29a295181569f54"%string);
      ("ee60a512e1383ffef37971a07a9754ceeb5b3d0aa640514e13e2a7359ec7157e"%string, "a964fd634f8f05a22719d37453ede555d6dd8fdf7beccf757e69c6fa782c5f16"%string, ""%string, "c11d4524c9071bd3096015fcf7bc24a607f22fa065c937658a2a77a8699089f4"%string)
    ]
    "abc015856094803a938dffd20da94843870ef935b82cfec17706b8f551b8385044235dd44b599f94b39be78dd476e0cf11309c995a7334e0a78b37bc9586235086fa3b637ba91cf8fb65efa22a589c137531aa7b2d4e2607aac27292b01c698e6e01ae679eb87c01a89c7422d4372d6d754ababb4bf896fcb1cd09d692d0283f"%string.
  vm_compute. repeat (split;auto). Qed.

Lemma test_with_personalization0:
  DRBG_check
    "f7b90c797a4a376cdd9f5c435f5985e77f36ec1df1145a12072cbb2a0da378fc"
    "d95202986d45896e9f4a65f2f353fa35"
    "628f0d947dca7e4171940799bfbc9b61c0ec7c2555a606c75940c37c9432bad0"
    "2fbafb7afd31927f8f5ee0c4fcdb27c15db4c5dda3d40bc091bfdb782561df85"
    "61535c5c045e784267fd0d85f2861778fa53c8e8586af67cf5c9f21a28ebb656"
    [
      ("b31f8c3d56139a901abc4dd953c43a3fc65cfcb7647061e4d9e2a7e31206a5f3"%string, "1ef1e9d5d8901b71c4f9cca6c68f320d5493f2fef1c71f5e58c5c83e144822f2"%string, ""%string, "130ab64f41a5d49d6a241e0260b4bb8a46a16c6ac9e234c84b5b26cdb518d459"%string);
      ("da8e4563d0180619c92b29c3b8dd8f3508df3e8fa844bf331cfb0b1f4205df75"%string, "4fe4168ff2aa97bdc0235b4df3eed8bd377aa3805ff6cd9445efb6e287a71e80"%string, ""%string, "f7670e817ac061ac60439be60982492000dc5da8bc6636bdac8b1cab03198dfd"%string)
    ]
    "8df4e349f9ea43cc509ecb2b1124358cda2de1f5cc9315edca63610a413478d68b8bb49c2814c82ce571f6e0a6780fa21c4b570610ee0c04d3edb92124f580f962d741330200c19885ca716502223247b728d66fbbeb7c6cc25cfe9866b1450b346227c7663074c8b15d189f1c6edba172a53c733d67c1c69bd7aca7e62013cd"%string.
  vm_compute. repeat (split;auto). Qed.

Lemma test_with_additional_input0:
  DRBG_check
    "2cad88b2b6a06e703de46185ccb2ddcf5e0ee030995ebdf95cc4fbc38441f17f"
    "32310770e04172c0cf91f6590cce44a4"
    "bef6a1ebb29164bc4d7ae6ca2d5a02d619b91dd0d88147e7e87454898ce99338"
    "6f78b5982fef43f09bd7096ecc3aa02a5c3a4dbf71e17341ff3814bbc5dcddd2"
    ""
    [
      ("bc4186dc24c4b64d8c094c79c7605ae9a3ce6a9e6cdb071a766897c8df302e4c"%string, "5f1aa99b991e37d7ffa7e6779d36b8295976a26ff13efaf72fe90f30a2d16aff"%string, "ef6da5e6530e0d621749ab192e06327e995c3ac0c3963ab8c8cd2df2839ab5df"%string, "448bfbc5ce9e3b9da3e9642daecd994dfe373e75253e8eb585141224eca7ad7b"%string);
      ("2afc9c4d27f850d0f982499199af67d0c20d324ebf9260fb021d377861ef257e"%string, "c5beeb04e4bfae254053c26d1ef0ff637da4873e7488fc08ab5660142a6311ae"%string, "44278b31ed853f0a510bd14650ac4b4971d8b426799a43511d016be68dedbb8d"%string, "afb57f69799c0b892b3015990e133698d543aa87829ace868e4a5e9525d62357"%string)
    ]
    "4c7dfbe509dc5a3ac26998723c6a44cad20b197fc86117c778d1568ab828923862885e97198f77a1cb45113f5d78726a0f120aec94afc45f57c8dcc1cb092b343480012858ef5bc559f57023442209326ec4a54d91ca3a77dfdf9e75f117cef50e6fd2dc9af6ddce8e6515b4a97357a97b6cd274f68a042fa41bbd7b7261b034"%string.
  vm_compute. repeat (split;auto). Qed.

Lemma test_with_additional_input_and_personalization0:
  DRBG_check
    "4294671d493dc085b5184607d7de2ff2b6aceb734a1b026f6cfee7c5a90f03da"
    "d071544e599235d5eb38b64b551d2a6e"
    "3ab4e27f331bf194cec5762baf84b7fb16e7cf81d69635c48b96febdfb809c18"
    "7a232bc40bdd9c92ddaffbe76aa322ba1a47234d227060d8ac187e680780c02a"
    "63bc769ae1d95a98bde870e4db7776297041d37c8a5c688d4e024b78d83f4d78"
    [
      ("6acd0c98e1f7340bd7ab4a594960b63357bd19b99471cc8ea34817af77259880"%string, "db7c92e4c55c43b370b81a6024f0e14675a86c9667412b10ce5d1ea76259c1e4"%string, "28848becd3f47696f124f4b14853a456156f69be583a7d4682cff8d44b39e1d3"%string, "db9b4790b62336fbb9a684b82947065393eeef8f57bd2477141ad17e776dac34"%string);
      ("2bcafedb81361b2cf44555d3739fdff9dcd6315dd861bb640e812ddcb26045a5"%string, "48e842ba5cb7784211bdc0c19eedec0e23cdfa6c81ad56a7e993eee15a604e2e"%string, "8bfce0b7132661c3cd78175d83926f643e36f7608eec2c5dac3ddcbacc8c2182"%string, "4a9abe80f6f522f29878bedf8245b27940a76471006fb4a4110beb4decb6c341"%string)
    ]
    "e580dc969194b2b18a97478aef9d1a72390aff14562747bf080d741527a6655ce7fc135325b457483a9f9c70f91165a811cf4524b50d51199a0df3bd60d12abac27d0bf6618e6b114e05420352e23f3603dfe8a225dc19b3d1fff1dc245dc6b1df24c741744bec3f9437dbbf222df84881a457a589e7815ef132f686b760f012"%string.
  vm_compute. repeat (split;auto). Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.Syntax.Util.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Z.Bounds.Interpretation.
Require Import Crypto.Compilers.Z.Bounds.InterpretationLemmas.Tactics.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Util.ZRange.CornersMonotoneBounds.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.ZUtil.Stabilization.
Require Import Crypto.Util.ZUtil.MulSplit.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.FixedWordSizesEquality.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.ZUtil.Tactics.SplitMinMax.

Local Open Scope Z_scope.

Local Arguments Bounds.is_bounded_by' !_ _ _ / .

Lemma is_bounded_by_truncation_bounds' Tout bs v
      (H : Bounds.is_bounded_by (T:=Tbase TZ) bs v)
  : Bounds.is_bounded_by (T:=Tbase Tout)
                         (Bounds.truncation_bounds' (Bounds.bit_width_of_base_type Tout) bs)
                         (ZToInterp v).
Proof.
  destruct bs as [l u]; cbv [Bounds.truncation_bounds' Bounds.is_bounded_by Bounds.is_bounded_by' Bounds.bit_width_of_base_type Bounds.log_bit_width_of_base_type option_map ZRange.is_bounded_by'] in *; simpl in *.
  repeat first [ break_t_step
               | fin_t
               | progress simpl in *
               | Zarith_t_step
               | rewriter_t
               | word_arith_t ].
Qed.

Lemma is_bounded_by_compose T1 T2 f_v bs v f_bs fv
      (H : Bounds.is_bounded_by (T:=Tbase T1) bs v)
      (Hf : forall bs v, Bounds.is_bounded_by (T:=Tbase T1) bs v -> Bounds.is_bounded_by (T:=Tbase T2) (f_bs bs) (f_v v))
      (Hfv : f_v v = fv)
  : Bounds.is_bounded_by (T:=Tbase T2) (f_bs bs) fv.
Proof.
  subst; eauto.
Qed.

Local Existing Instances Z.log2_up_le_Proper Z.add_le_Proper Z.sub_with_borrow_le_Proper.
Lemma land_upper_lor_land_bounds a b
  : Z.abs (Z.land a b) <= Bounds.upper_lor_and_bounds (Z.abs a) (Z.abs b).
Proof.
  unfold Bounds.upper_lor_and_bounds.
  apply stabilizes_bounded; auto with zarith.
  rewrite <- !Z.max_mono by exact _.
  apply land_stabilizes; apply stabilization_time_weaker.
Qed.

Lemma lor_upper_lor_land_bounds a b
  : Z.abs (Z.lor a b) <= Bounds.upper_lor_and_bounds (Z.abs a) (Z.abs b).
Proof.
  unfold Bounds.upper_lor_and_bounds.
  apply stabilizes_bounded; auto with zarith.
  rewrite <- !Z.max_mono by exact _.
  apply lor_stabilizes; apply stabilization_time_weaker.
Qed.

Lemma upper_lor_and_bounds_Proper
  : Proper (Z.le ==> Z.le ==> Z.le) Bounds.upper_lor_and_bounds.
Proof.
  intros ??? ???.
  unfold Bounds.upper_lor_and_bounds.
  auto with zarith.
Qed.

Local Arguments Z.pow !_ !_.
Local Arguments Z.log2_up !_.
Local Arguments Z.add !_ !_.
Lemma land_bounds_extreme xb yb x y
      (Hx : ZRange.is_bounded_by' None xb x)
      (Hy : ZRange.is_bounded_by' None yb y)
  : ZRange.is_bounded_by' None (Bounds.extreme_lor_land_bounds xb yb) (Z.land x y).
Proof.
  apply ZRange.monotonify2; auto;
    unfold Bounds.extreme_lor_land_bounds;
    [ apply land_upper_lor_land_bounds
    | apply upper_lor_and_bounds_Proper ].
Qed.
Lemma lor_bounds_extreme xb yb x y
      (Hx : ZRange.is_bounded_by' None xb x)
      (Hy : ZRange.is_bounded_by' None yb y)
  : ZRange.is_bounded_by' None (Bounds.extreme_lor_land_bounds xb yb) (Z.lor x y).
Proof.
  apply ZRange.monotonify2; auto;
    unfold Bounds.extreme_lor_land_bounds;
    [ apply lor_upper_lor_land_bounds
    | apply upper_lor_and_bounds_Proper ].
Qed.

Local Arguments N.ldiff : simpl never.
Local Arguments Z.pow : simpl never.
Local Arguments Z.add !_ !_.
Local Existing Instances Z.add_le_Proper Z.sub_le_flip_le_Proper Z.log2_up_le_Proper Z.pow_Zpos_le_Proper Z.sub_le_eq_Proper Z.add_with_carry_le_Proper.
Local Hint Extern 1 => progress cbv beta iota : typeclass_instances.
Local Ltac ibbio_prefin :=
  [ > | intros | simpl; reflexivity ].
Local Ltac apply_is_bounded_by_truncation_bounds :=
  cbv [id
         Bounds.interp_op interp_op Bounds.is_bounded_by Relations.interp_flat_type_rel_pointwise Relations.interp_flat_type_rel_pointwise_gen_Prop SmartVarfMap smart_interp_flat_map lift_op SmartFlatTypeMapUnInterp cast_const Zinterp_op SmartFlatTypeMapInterp2
         Z.add_with_get_carry Bounds.add_with_get_carry Bounds.sub_with_get_borrow Bounds.get_carry Bounds.get_borrow Z.get_carry Bounds.mul_split];
  cbn [interpToZ fst snd];
  repeat match goal with
         | [ |- _ /\ _ ] => split
         end;
  lazymatch goal with
  | [ |- Bounds.is_bounded_by' (Bounds.truncation_bounds _ _) (ZToInterp _) ]
    => apply is_bounded_by_truncation_bounds'
  end.
Local Ltac handle_mul :=
  apply ZRange.monotone_four_corners_genb; try (split; auto);
  unfold Basics.flip;
  let x := fresh "x" in
  intro x;
  exists (0 <=? x);
  break_match; Z.ltb_to_lt;
  intros ???; nia.
Lemma is_bounded_by_interp_op t tR (opc : op t tR)
      (bs : interp_flat_type Bounds.interp_base_type _)
      (v : interp_flat_type interp_base_type _)
      (H : Bounds.is_bounded_by bs v)
      (H_side : to_prop (interped_op_side_conditions opc v))
  : Bounds.is_bounded_by (Bounds.interp_op opc bs) (Syntax.interp_op _ _ opc v).
Proof.
  destruct opc; apply_is_bounded_by_truncation_bounds;
    [ ..
    | eapply is_bounded_by_compose with (T1:=TZ) (f_v := fun v => ZToInterp (v mod _)) (v:=ZToInterp _);
      [ .. | cbn -[Z.mul_split_at_bitwidth]; rewrite Z.mul_split_at_bitwidth_mod ];
      ibbio_prefin
    | eapply is_bounded_by_compose with (T1:=TZ) (f_v := fun v => ZToInterp (v / _))   (v:=ZToInterp _);
        [ .. | cbn -[Z.mul_split_at_bitwidth]; rewrite Z.mul_split_at_bitwidth_div ];
        ibbio_prefin
    |
    | eapply is_bounded_by_compose with (T1:=TZ) (f_v := fun v => ZToInterp (v mod _)) (v:=ZToInterp _);
        ibbio_prefin
    | eapply is_bounded_by_compose with (T1:=TZ) (f_v := fun v => ZToInterp (v / _))   (v:=ZToInterp _);
        ibbio_prefin
    |
    | eapply is_bounded_by_compose with (T1:=TZ) (f_v := fun v => ZToInterp (v mod _)) (v:=ZToInterp _);
        ibbio_prefin
    | eapply is_bounded_by_compose with (T1:=TZ) (f_v := fun v => ZToInterp (-(v / _)))   (v:=ZToInterp _);
      ibbio_prefin ];
    repeat first [ progress simpl in *
                 | progress cbv [Bounds.interp_base_type Bounds.is_bounded_by' ZRange.is_bounded_by'] in *
                 | progress destruct_head'_prod
                 | progress destruct_head'_and
                 | omega
                 | match goal with
                   | [ |- context[interpToZ ?x] ]
                     => generalize dependent (interpToZ x); clear x; intros
                   | [ |- _ /\ True ] => split; [ | tauto ]
                   end ].
  { apply (@ZRange.monotone_four_corners true true _ _); split; auto. }
  { apply (@ZRange.monotone_four_corners true false _ _); split; auto. }
  { handle_mul. }
  { apply ZRange.monotone_four_corners_genb; try (split; auto);
      [ eexists; apply Z.shiftl_le_Proper1
      | exists true; apply Z.shiftl_le_Proper2 ]. }
  { apply ZRange.monotone_four_corners_genb; try (split; auto);
      [ eexists; apply Z.shiftr_le_Proper1
      | exists true; apply Z.shiftr_le_Proper2 ]. }
  { cbv [Bounds.land Bounds.extremization_bounds]; break_innermost_match;
      [ apply land_bounds_extreme; split; auto | .. ];
      repeat first [ progress simpl in *
                   | Zarith_t_step
                   | rewriter_t
                   | progress saturate_land_lor_facts
                   | split_min_max; omega ]. }
  { cbv [Bounds.lor Bounds.extremization_bounds]; break_innermost_match;
      [ apply lor_bounds_extreme; split; auto | .. ];
      repeat first [ progress simpl in *
                   | Zarith_t_step
                   | rewriter_t
                   | progress Zarith_land_lor_t_step
                   | solve [ split_min_max; try omega; try Zarith_land_lor_t_step ] ]. }
  { repeat first [ progress destruct_head Bounds.t
                 | progress simpl in *
                 | progress split_min_max
                 | omega ]. }
  { cbv [Bounds.id_with_alt];
      break_innermost_match; simpl in *; Z.ltb_to_lt; subst;
        split; assumption. }
  { destruct_head Bounds.t; cbv [Bounds.zselect' Z.zselect].
    break_innermost_match; split_min_max; omega. }
  { handle_mul. }
  { apply Z.mod_bound_min_max; auto. }
  { handle_mul. }
  { auto with zarith. }
  { apply (@ZRange.monotone_eight_corners true true true _ _ _); split; auto. }
  { apply (@ZRange.monotone_eight_corners true true true _ _ _); split; auto. }
  { apply Z.mod_bound_min_max; auto. }
  { apply (@ZRange.monotone_eight_corners true true true _ _ _); split; auto. }
  { auto with zarith. }
  { apply (@ZRange.monotone_eight_corners false true false _ _ _); split; auto. }
  { apply (@ZRange.monotone_eight_corners false true false _ _ _); split; auto. }
  { apply Z.mod_bound_min_max; auto. }
  { apply (@ZRange.monotone_eight_corners false true false _ _ _); split; auto. }
  { auto with zarith. }
Qed.


Require Import ListAux.
Require Import Tactics.
Require Import TreeAux.
Lemma batchedq2consistent_ListIsEmpty0 (il_0:list nat) (b_0:bool) (u_0:nat) (u_1:nat) : (is_empty_spec  il_0 b_0) -> (((not (u_1 = u_0))/\(list_order  il_0 u_0 u_1)/\(list_member  il_0 u_1)) -> (list_member  il_0 u_0)).
Proof. solve_is_empty; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListIsEmpty1 (il_0:list nat) (b_0:bool) (u_0:nat) (u_1:nat) : (is_empty_spec  il_0 b_0) -> (((not (u_1 = u_0))/\(list_head  il_0 u_1)/\(list_order  il_0 u_0 u_1)/\(list_member  il_0 u_1)) -> (not (list_head  il_0 u_0))).
Proof. solve_is_empty; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListIsEmpty2 (il_0:list nat) (b_0:bool) (u_0:nat) (u_1:nat) : (is_empty_spec  il_0 b_0) -> (((not (list_order  il_0 u_0 u_1))/\(list_member  il_0 u_1)) -> (not (Bool.Is_true b_0))).
Proof.
intro nilspec;
  inversion nilspec as [a b Hhd Hmem Hord Honce]; subst; intros; intr_not;
  try destruct_pairs; auto with core. apply H.
      apply (Hmem u_1) in Z. apply Z in H0. inversion H0.
Qed.

Lemma batchedq2consistent_ListIsEmpty3 (il_0:list nat) (b_0:bool) (u_0:nat) (u_1:nat) : (is_empty_spec  il_0 b_0) -> (((list_head  il_0 u_0)/\(not (list_order  il_0 u_0 u_1))/\(list_member  il_0 u_1)) -> (u_1 = u_0)).
Proof. solve_is_empty; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListIsEmpty4 (il_0:list nat) (b_0:bool) (u_0:nat) (u_1:nat) : (is_empty_spec  il_0 b_0) -> (((not (list_member  il_0 u_1))) -> (not (list_head  il_0 u_1))).
Proof. solve_is_empty; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListIsEmpty5 (il_0:list nat) (b_0:bool) (u_0:nat) (u_1:nat) : (is_empty_spec  il_0 b_0) -> (((not (list_member  il_0 u_1))) -> (not (list_order  il_0 u_0 u_1))).
Proof. solve_is_empty; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma batchedq2consistent_ListIsEmpty6 (il_0:list nat) (b_0:bool) (u_0:nat) (u_1:nat) : (is_empty_spec  il_0 b_0) -> (((not (list_member  il_0 u_1))) -> (not (list_order  il_0 u_1 u_0))).
Proof. solve_is_empty; try (assert (u_0 = u_1); subst; eauto). Qed.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.

Require Import MSets.MSetPositive.
Import PositiveSet. Module PSet:= PositiveSet. (*For positive-indexed sets*)

Require Import VCC.Heap.

(* Variables are represented as positives *)
Definition ident := positive.

(** * Values *)

(* Real Values*)
Inductive val: Type :=
| Vundef: val                       (*Undefined*)
| Vint: int -> val                   (*Unsigned integers*)
| Vptr: (positive * Int.int) -> val. (*Pointers*)

(* Ghost Values *)
Inductive gval: Type :=
| GVptr: (positive * Int.int)  -> gval
| GVnat: nat -> gval
| GVbool: bool -> gval
| GVheap: @heap val -> gval.

(* Values*)
Inductive uval:= | RV: val -> uval | GV: gval -> uval.
Coercion RV : val >-> uval.
Coercion GV : gval >-> uval.
Notation heap:= (@heap val).

Notation val_zero:= (Vint Int.zero).

(** * Types *)

(*Real Types*)
Inductive type : Type :=
| Tvoid: type                        (* oid type *)
| Tint:  type                        (* Unsigned integer types *)
| Tpointer: type -> type.             (* Pointer type *)

(*Ghost Types*)
Inductive gtype : Type :=
| GTnat: gtype
| GTbool: gtype
| GTheap: gtype
| GTpointer: type -> gtype.

Definition sizeof (t:type): Z:=
  match t with
  | Tvoid => 1
  | Tint => 4 (*only 32 int for now*)
  | Tpointer _ => 4 (*hardcoded 32 for now*)
  end.

Inductive utype:= | RT: type -> utype | GT: gtype -> utype.
Coercion RT : type >-> utype.
Coercion GT : gtype >-> utype.