Require Import GHC.Base.
Require Import Fix.

Require Import Adverb.Composable.Purely.
Require Import Adverb.Composable.Streamingly.
Require Import Adverb.Composable.Statically.
Require Import Adverb.Composable.Dynamically.

Require Import ProofAlgebra.ProofAlgebra.
Require Import ProofAlgebra.Composable.
Require Import UP.Fix.

From Coq Require Import
     FunctionalExtensionality
.

Section UPs.

  Variable F : (Set -> Set) -> Set -> Set.
  Context `{Functor1 F} `{PurelyAdv -≪ F}.
  Context `{@WFFunctor1 PurelyAdv F Functor1__PurelyAdv _ _}.

  Lemma pure_UP : forall (A : Set) (a : A),
      UP1 F (@inF1 _ _ _ (inj1 (Pure a))).
  Proof.
    intros. constructor. intros.
    rewrite H2. unfold inF1. unfold foldFix1.
    rewrite !wf_functor. reflexivity.
  Qed.

  Global Instance ProofAlg_PurelyAdv_UP1 : ProofAlg1 PurelyAdv (@UP1 F _) :=
    Pure_ProofAlgebra _ _ pure_UP.

  Definition pure' {A : Set} (a : A) : {e : Fix1 F A | UP1 F e} :=
    inF'1 (HP:=ProofAlg_PurelyAdv_UP1) (Pure a).

  Section Functor.

    Context `{StreaminglyAdv -≪ F}.
    Context `{@WFFunctor1 StreaminglyAdv F Functor1__StreaminglyAdv _ _}.

    Lemma fmap_UP : forall (A B : Set) (g : A -> B) f,
        UP1 F f -> UP1 F (fmap g f).
    Proof.
      intros. constructor. intros.
      unfold fmap. cbn. unfold fmap_ff.
      specialize (H5 _ (inj1 (FMap g f))) as Hmap.
      rewrite H5. unfold inF1. rewrite !wf_functor. cbn.
      destruct H4. erewrite -> UP1_implies_fold. 2: { intros; apply H5. }
      reflexivity.
    Qed.

    Global Instance ProofAlg_StreaminglyAdv_UP1 : ProofAlg1 StreaminglyAdv (@UP1 F _) :=
      FunctorT_ProofAlgebra _ _ fmap_UP.

    Definition fmap' {A B : Set} (f : A -> B) (a : {e : Fix1 F A | UP1 F e})
      : {e : Fix1 F B | UP1 F e} :=
      inF'1 (HP:=ProofAlg_StreaminglyAdv_UP1) (FMap f a).

    Global Instance Functor_StreaminglyAdv' :
      Functor (fun A => {e : Fix1 F A | UP1 F e }) :=
      fun _ k => k {| fmap__      := fun {a} {b} => fmap' ;
                   op_zlzd____ := fun {a} {b} => fmap' ∘ const |}.
  End Functor.

  Section Applicative.

    Context `{StaticallyAdv -≪ F}.
    Context `{@WFFunctor1 StaticallyAdv F Functor1__StaticallyAdv _ _}.

    Lemma liftA2_UP : forall (A B C : Set) (f : A -> B -> C) a b,
        UP1 F a -> UP1 F b -> UP1 F (liftA2 f a b).
    Proof.
      intros. constructor. intros.
      unfold liftA2. cbn. unfold liftA2_fa.
      rewrite H6. unfold inF1. rewrite !wf_functor. cbn.
      destruct H4. erewrite -> UP1_implies_fold.
      2: { intros. apply H6. }
      destruct H5. erewrite -> UP1_implies_fold0.
      2: { intros. apply H6. }
      reflexivity.
    Qed.

    Global Instance ProofAlg_StaticallyAdv_UP1 : ProofAlg1 StaticallyAdv (@UP1 F _) :=
      ApT_ProofAlgebra _ _ liftA2_UP.

    Definition liftA2' {A B C : Set}
               (f : A -> B -> C)
               (a : {e : Fix1 F A | UP1 F e})
               (b : {e : Fix1 F B | UP1 F e})
      : {e : Fix1 F C | UP1 F e} :=
      inF'1 (HP:=ProofAlg_StaticallyAdv_UP1) (LiftA2 f a b).

    Definition fmap'A {A B : Set} (f : A -> B)
               (a : {e : Fix1 F A | UP1 F e}) : {e : Fix1 F B | UP1 F e} :=
      liftA2' id (pure' f) a.

    Global Instance Functor_StaticallyAdv' :
      Functor (fun A => {e : Fix1 F A | UP1 F e }) :=
      fun _ k => k {| fmap__      := fun {a} {b} => fmap'A ;
                   op_zlzd____ := fun {a} {b} => fmap'A ∘ const |}.

    Global Instance Applicative_StaticallyAdv' :
      Applicative (fun A => {e : Fix1 F A | UP1 F e }) :=
      fun _ k => k {| liftA2__ := fun {a b c} => liftA2' ;
               op_zlztzg____ := fun {a b} => liftA2' id ;
               op_ztzg____ := fun {a b} fa => liftA2' id (id <$ fa) ;
               pure__ := fun {a} => pure' |}.

  End Applicative.

  Section Monad.

    Context `{DynamicallyAdv -≪ F}.
    Context `{@WFFunctor1 DynamicallyAdv F Functor1__DynamicallyAdv _ _}.

    Lemma ret_UP : forall (A : Set) (a : A),
        UP1 F (return_ a).
    Proof.
      exact pure_UP.
    Qed.

    Lemma bind_UP : forall (A B : Set) (g : A -> Fix1 F B) m,
        UP1 F m -> (forall a, UP1 F (g a)) -> UP1 F (m >>= g).
    Proof.
      intros. constructor. intros.
      unfold ">>=". cbn. unfold bind_fm.
      rewrite H6. unfold inF1. rewrite !wf_functor. cbn.
      destruct H4. erewrite -> UP1_implies_fold.
      2: { intros. apply H6. }
      replace (fun x : A => h B (g x))
        with (fun x : A => foldFix1 alg (g x)).
      2: { apply functional_extensionality.
           intro a. specialize (H5 a).
           destruct H5. erewrite -> UP1_implies_fold0.
           reflexivity. intros. apply H6. }
      reflexivity.
    Qed.

    Global Instance ProofAlg_DynamicallyAdv_UP1 : ProofAlg1 DynamicallyAdv (@UP1 F _) :=
      MonadT_ProofAlgebra _ _ bind_UP.

    Definition return_' {A : Set} (a : A) : {e : Fix1 F A | UP1 F e} :=
      pure' a.

    Definition bind' {A B : Set}
               (m : {e : Fix1 F A | UP1 F e})
               (k : A -> {e : Fix1 F B | UP1 F e}) : {e : Fix1 F B | UP1 F e} :=
      inF'1 (HP:=ProofAlg_DynamicallyAdv_UP1) (Bind m k).

    Definition fmap'M {A B : Set} (f : A -> B)
               (a : {e : Fix1 F A | UP1 F e}) : {e : Fix1 F B | UP1 F e} :=
      bind' a (return_' ∘ f).

    Definition ap'M {A B : Set}
               (f : {e : Fix1 F (A -> B) | UP1 F e})
               (a : {e : Fix1 F A | UP1 F e}) : {e : Fix1 F B | UP1 F e} :=
      bind' f (fun f => bind' a (fun a => return_' (f a))).

    Global Instance Functor_DynamicallyAdv' :
      Functor (fun A => {e : Fix1 F A | UP1 F e }) :=
      fun _ k => k {| fmap__      := fun {a} {b} => fmap'M ;
                   op_zlzd____ := fun {a} {b} => fmap'M ∘ const |}.

    Global Instance Applicative_DynamicallyAdv' :
      Applicative (fun A => {e : Fix1 F A | UP1 F e }) :=
      fun _ k => k {| liftA2__ := fun {a b c} g fa fb => ap'M (fmap'M g fa) fb ;
               op_zlztzg____ := fun {a b} => ap'M ;
               op_ztzg____ := fun {a b} fa => ap'M (id <$ fa) ;
               pure__ := fun {a} => return_' |}.

    Global Instance Monad_FMonaT' :
      Monad (fun A => {e : Fix1 F A | UP1 F e }) :=
      fun _ k => k {| op_zgzg____ := fun {a} {b} m k => bind' m (fun _ => k) ;
                   op_zgzgze____ := fun {a} {b} => bind' ;
                   return___ := fun {a} => return_' |}.
  End Monad.

End UPs.


From stdpp Require Import namespaces finite.
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 hash.

Set Default Proof Using "Type*".

(* A wrapper around the tape hash that gives an interface where the hashing function now takes as input
   a key k and a value v to be hashed. Different keys yield different hashes, and the library
   splits up ownership along keys.

   This is implemented by actually just having a single hash function,
   and on input k and v, we convert the pair (k, v) to a single integer that is then
   hashed.

 *)

Section keyed_hash.

  (* we assume the key space / value space are integers in the range
  {0, ..., 2^n_k - 1} and {0, ..., 2^n_v} for some natural numbers n_k
  and n_v. *)

  Context (MAX_KEYS_POW : nat).
  Context (MAX_VALS_POW : nat).

  Definition MAX_KEYS : nat := (Nat.pow 2 MAX_KEYS_POW) - 1.
  Definition MAX_VALS : nat := (Nat.pow 2 MAX_VALS_POW) - 1.
  Definition MAX_KEYS_Z : Z := (Z.pow 2 MAX_KEYS_POW) - 1.
  Definition MAX_VALS_Z : Z := (Z.pow 2 MAX_VALS_POW) - 1.

  Definition MAX_HASH_DOM : nat := ((Nat.pow 2 (MAX_KEYS_POW + MAX_VALS_POW)) - 1).

  Definition enc : val :=
    λ: "k" "v", ("k" ≪ #MAX_VALS_POW) + "v".

  Definition enc_gallina (k : nat) (v: nat) : nat :=
    (Nat.shiftl k MAX_VALS_POW) + v.

  Definition val_of_enc_gallina (x: nat) : nat :=
    x `mod` (Nat.pow 2 MAX_VALS_POW).

  Definition key_of_enc_gallina (x: nat) : nat :=
    (Nat.shiftr (x - val_of_enc_gallina x) MAX_VALS_POW).

  Lemma pow2_nonzero: ∀ x, 0 < 2 ^ x.
  Proof.
    intros x. induction x => /=; try lia.
  Qed.

  Definition not_in_key x k : Prop := (¬ ∃ v, enc_gallina k v = x).

  Lemma val_of_enc_gallina_spec1 k v :
    v <= MAX_VALS →
    val_of_enc_gallina (enc_gallina k v) = v.
  Proof.
    rewrite /val_of_enc_gallina /enc_gallina/MAX_VALS.
    rewrite ?Nat.shiftr_div_pow2 ?Nat.shiftl_mul_pow2.
    intros Hv.
    specialize (pow2_nonzero MAX_VALS_POW) => ?.
    rewrite Nat.add_comm Nat.mod_add; last lia.
    rewrite Nat.mod_small; lia.
  Qed.

  Lemma val_of_enc_gallina_spec2 (x : nat) :
    val_of_enc_gallina x <= MAX_VALS.
  Proof.
    specialize (pow2_nonzero MAX_VALS_POW) => ?.
    cut (x `mod` (Nat.pow 2 MAX_VALS_POW) < Nat.pow 2 MAX_VALS_POW).
    { rewrite /val_of_enc_gallina/MAX_VALS. lia. }
    apply Nat.mod_upper_bound. lia.
  Qed.

  Lemma key_of_enc_gallina_spec1 (x : nat) k v :
    v <= MAX_VALS →
    key_of_enc_gallina (enc_gallina k v) = k.
  Proof.
    intros Hle.
    rewrite /key_of_enc_gallina val_of_enc_gallina_spec1 //.
    rewrite /enc_gallina/MAX_VALS.
    rewrite Nat.add_sub.
    rewrite Nat.shiftr_shiftl_r //.
    assert (MAX_VALS_POW - MAX_VALS_POW = 0) as -> by lia.
    rewrite Nat.shiftr_0_r //.
  Qed.

  Lemma Nat_div_sub_mod x k :
   0 < k ->
   x `div` k = (x - x `mod` k) `div` k.
  Proof.
    intros Hlt.
    rewrite Nat.mod_eq; last by lia.
    replace (x - (x - k * x `div` k)) with (k * x `div` k); last first.
    { remember (x `div` k) as y. cut (k * y <= x); try lia.
      rewrite Heqy. apply Nat.mul_div_le; lia. }
    rewrite Nat.mul_comm Nat.div_mul; lia.
  Qed.

  Lemma enc_gallina_inv x :
    enc_gallina (key_of_enc_gallina x) (val_of_enc_gallina x) = x.
  Proof.
    rewrite /enc_gallina/key_of_enc_gallina/val_of_enc_gallina.
    rewrite ?Nat.shiftr_div_pow2 ?Nat.shiftl_mul_pow2.
    symmetry.
    rewrite {1}(Nat.div_mod_eq x (Nat.pow 2 MAX_VALS_POW)).
    f_equal.
    rewrite Nat.mul_comm.
    rewrite Nat_div_sub_mod //. apply pow2_nonzero.
  Qed.

  Lemma enc_gallina_mono1 k1 k2 v1 v2:
    k1 < k2 -> v1 <= v2 -> enc_gallina k1 v1 < enc_gallina k2 v2.
  Proof.
    intros Hlt Hle.
    rewrite /enc_gallina.
    rewrite ?Nat.shiftr_div_pow2 ?Nat.shiftl_mul_pow2.
    specialize (pow2_nonzero MAX_VALS_POW) => Hnz.
    remember (2 ^ MAX_VALS_POW) as z.
    cut (k1 * z < k2 * z); first by lia.
    apply Mult.mult_lt_compat_r_stt; auto.
  Qed.

  Lemma enc_gallina_mono2 k1 k2 v1 v2:
    k1 < k2 -> v1 <= MAX_VALS -> v2 <= MAX_VALS -> enc_gallina k1 v1 < enc_gallina k2 v2.
  Proof.
    intros Hlt Hle1 Hle2.
    rewrite /enc_gallina.
    specialize (pow2_nonzero MAX_VALS_POW) => Hnz.
    rewrite ?Nat.shiftr_div_pow2 ?Nat.shiftl_mul_pow2.
    apply (Nat.lt_le_trans _ (k2 * 2 ^ MAX_VALS_POW)); last by lia.
    apply (Nat.lt_le_trans _ ((k1 + 1) * 2 ^ MAX_VALS_POW)); last first.
    { apply Nat.mul_le_mono_r; lia. }
    ring_simplify.
    rewrite /MAX_VALS in Hle1. lia.
  Qed.

  Lemma enc_gallina_mono2_inv k1 k2 v1 v2:
    enc_gallina k1 v1 <= enc_gallina k2 v2 ->
    v1 <= MAX_VALS ->
    v2 <= MAX_VALS ->
    k1 <= k2.
  Proof.
    intros Henc Hle1 Hle2.
    destruct (decide (k2 < k1)) as [Hlt|]; try lia.
    specialize (enc_gallina_mono2 _ _ _ _ Hlt Hle2 Hle1). lia.
  Qed.

  Lemma enc_gallina_inj k1 k2 v1 v2:
    enc_gallina k1 v1 = enc_gallina k2 v2 ->
    v1 <= MAX_VALS ->
    v2 <= MAX_VALS ->
    k1 = k2 /\ v1 = v2.
  Proof.
    intros Henc Hle1 Hle2.
    assert (k1 = k2) as ->.
    {
      apply Nat.le_antisymm.
      * eapply (enc_gallina_mono2_inv k1 k2 v1 v2); eauto; lia.
      * eapply (enc_gallina_mono2_inv k2 k1 v2 v1); eauto; lia.
    }
    split; auto.
    rewrite /enc_gallina in Henc. lia.
  Qed.

  Lemma enc_hits_max :
    enc_gallina MAX_KEYS MAX_VALS = MAX_HASH_DOM.
  Proof.
    rewrite /enc_gallina/MAX_HASH_DOM/MAX_KEYS/MAX_VALS.
    rewrite ?Nat.shiftr_div_pow2 ?Nat.shiftl_mul_pow2.
    rewrite Nat.pow_add_r.
    specialize (pow2_nonzero MAX_VALS_POW) => ?.
    specialize (pow2_nonzero MAX_KEYS_POW) => ?.
    assert (2 ^ MAX_KEYS_POW = (2 ^ MAX_KEYS_POW - 1) + 1) as Hsub1 by lia.
    lia.
  Qed.

  Lemma key_of_enc_gallina_spec2 (x : nat) :
    x <= MAX_HASH_DOM →
    key_of_enc_gallina x <= MAX_KEYS.
  Proof.
    intros.
    eapply (enc_gallina_mono2_inv _ _ (val_of_enc_gallina x) (MAX_VALS));
      auto using val_of_enc_gallina_spec2.
    rewrite enc_gallina_inv enc_hits_max //.
  Qed.

  Lemma enc_gallina_range k v :
    k < S MAX_KEYS →
    v < S MAX_VALS →
    enc_gallina k v < S MAX_HASH_DOM.
  Proof.
    rewrite /enc_gallina/MAX_KEYS/MAX_VALS/MAX_HASH_DOM.
    rewrite ?Nat.shiftl_mul_pow2.
    assert (Hsub_le: ∀ a b, 0 < b -> a < S (b - 1) → a <= b - 1).
    { intros. lia. }
    assert (Hsub: ∀ x, 0 < x -> S (x - 1) = x).
    { intros. lia. }
    intros Hlt1 Hlt2.
    specialize (pow2_nonzero MAX_VALS_POW) => ?.
    specialize (pow2_nonzero MAX_KEYS_POW) => ?.
    apply Hsub_le in Hlt1; auto.
    apply Hsub_le in Hlt2; auto.
    rewrite ?Hsub; try (apply pow2_nonzero).
    rewrite Nat.pow_add_r.
    apply (Nat.le_lt_trans _ ((2 ^ MAX_KEYS_POW - 1) * 2 ^ MAX_VALS_POW + (2 ^ MAX_VALS_POW - 1))).
    { assert (Hcompat: ∀ a b c d, a <= b → c <= d → a + c <= b + d) by lia.
      apply Hcompat; try lia.
      apply Nat.mul_le_mono_r; auto.
    }
    assert (2 ^ MAX_KEYS_POW = (2 ^ MAX_KEYS_POW - 1) + 1) as Hsub1 by lia.
    lia.
  Qed.

  Definition init_keyed_hash : val :=
    λ: "_",
      let: "f" := init_hash #MAX_HASH_DOM in
      (λ: "k" "v", "f" (enc "k" "v")).

  Context `{!prelogrelGS Σ}.

  Lemma wp_enc_spec (k v : nat) E :
    {{{ ⌜ k <= MAX_KEYS ∧ v ≤ MAX_VALS ⌝ }}}
      enc #k #v @ E
    {{{ (n: nat), RET #n; ⌜ n = enc_gallina k v ⌝ }}}.
  Proof.
    rewrite /enc. iIntros (Φ) "%Hdom HΦ". wp_pures.
    rewrite Z.shiftl_mul_pow2; last by lia.
    iSpecialize ("HΦ" $! (Z.to_nat (Z.of_nat (enc_gallina k v)))).
    rewrite /enc_gallina Nat.shiftl_mul_pow2.
    rewrite Nat2Z.id Nat2Z.inj_add Nat2Z.inj_mul Nat2Z.inj_pow.
    iApply "HΦ". auto.
  Qed.

  Definition fin_hash_dom_space : Type := fin (S (MAX_HASH_DOM)).
  Definition fin_key_space : Type := fin (S (MAX_KEYS)).
  Definition fin_val_space : Type := fin (S (MAX_VALS)).

  (*
  Instance finite_fin_val_space : Finite (fin_val_space).
  Proof. apply _. Qed.
  Instance finite_fin_key_space : Finite (fin_key_space).
  Proof. apply _. Qed.
  Instance finite_fin_hash_dom_space : Finite (fin_hash_dom_space).
  Proof. apply _. Qed.
   *)

  Context {GHOST_MAP: ghost_mapG Σ fin_hash_dom_space (option bool)}.

  Lemma fin_to_nat_S_le n (i: fin (S n)) : i <= n.
  Proof. specialize (fin_to_nat_lt i). lia. Qed.

  Definition enc_gallina_fin (k : fin_key_space) (v: fin_val_space) : fin_hash_dom_space.
    refine (@nat_to_fin (enc_gallina (fin_to_nat k) (fin_to_nat v)) _ _).
    abstract (apply (enc_gallina_range); apply fin_to_nat_lt).
  Defined.

  Definition key_of_enc_gallina_fin (x: fin_hash_dom_space) : fin_key_space.
  refine (@nat_to_fin (key_of_enc_gallina x) _ _).
  { abstract (cut (key_of_enc_gallina x <= MAX_KEYS); first lia;
              apply key_of_enc_gallina_spec2; specialize (fin_to_nat_lt x); lia; auto). }
  Defined.

  Definition val_of_enc_gallina_fin (x: fin_hash_dom_space) : fin_val_space.
  refine (@nat_to_fin (val_of_enc_gallina x) _ _).
  { abstract (cut (val_of_enc_gallina x <= MAX_VALS); first lia;
              apply val_of_enc_gallina_spec2; lia; auto). }
  Defined.

  Lemma enc_gallina_fin_inv x :
    enc_gallina_fin (key_of_enc_gallina_fin x) (val_of_enc_gallina_fin x) = x.
  Proof.
    rewrite /enc_gallina_fin/key_of_enc_gallina_fin/val_of_enc_gallina_fin/=.
    apply (inj fin_to_nat).
    rewrite ?fin_to_nat_to_fin enc_gallina_inv //.
  Qed.

  Lemma enc_gallina_fin_inj k1 k2 v1 v2 :
    enc_gallina_fin k1 v1 = enc_gallina_fin k2 v2 ->
    k1 = k2 /\ v1 = v2.
  Proof.
    rewrite /enc_gallina_fin.
    intros Hfeq%(f_equal fin_to_nat).
    rewrite ?fin_to_nat_to_fin in Hfeq.
    apply enc_gallina_inj in Hfeq; auto using fin_to_nat_S_le.
    split; apply (inj fin_to_nat); intuition auto.
  Qed.

  Definition khashN := nroot.@"khash".

  Definition ghost_phys_dom (mphys : gmap nat bool) (mghost : gmap fin_hash_dom_space (option bool)) :=
      (∀ x b, mphys !! (fin_to_nat x) = Some b → mghost !! x = Some (Some b)) ∧
      (∀ x, mphys !! (fin_to_nat x) = None → mghost !! x = Some (None)).

  Definition keyed_hash_auth_pure f f0 (mphys : gmap nat bool) (mghost : gmap fin_hash_dom_space (option bool))
    : iProp Σ :=
      ⌜ f = (λ: "k" "v", f0 (enc "k" "v"))%V ⌝ ∗
      ⌜ ghost_phys_dom mphys mghost ⌝.

  Definition keyed_hash_auth (γ : gname) (f : val) : iProp Σ :=
    ∃ (f0 : val) (mphys : gmap nat bool) (mghost : gmap fin_hash_dom_space (option bool)),
      keyed_hash_auth_pure f f0 mphys mghost ∗
      ghost_map_auth γ 1 mghost ∗
      hashfun MAX_HASH_DOM f0 mphys.

  Definition skeyed_hash_auth (γ : gname) (f : val) : iProp Σ :=
    ∃ (f0 : val) (mphys : gmap nat bool) (mghost : gmap fin_hash_dom_space (option bool)),
      keyed_hash_auth_pure f f0 mphys mghost ∗
      ghost_map_auth γ 1 mghost ∗
      shashfun MAX_HASH_DOM f0 mphys.

  Section timeless_spec.
    Existing Instance timeless_shashfun.
    Lemma timeless_skeyed_hash_auth γ f :
      Timeless (skeyed_hash_auth γ f).
    Proof. apply _. Qed.
  End timeless_spec.

  Existing Instance timeless_hashfun.
  #[global] Instance timeless_keyed_hash_auth γ f :
    Timeless (keyed_hash_auth γ f).
  Proof. apply _. Qed.

  (*
  Definition is_keyed_hash γ f :=
    inv khashN (keyed_hash_auth γ f).
   *)

  (* This encoding is annoying to work with because we don't have good lemmas for
     "set products" and big_sepS over such products. *)
  (*
  Definition khashfun_own γ k (m : gmap nat bool) : iProp Σ :=
    ⌜ ∀ x, x ∈ dom m → x <= MAX_VALS ⌝ ∗
    [∗ set] v ∈ fin_to_set (fin_val_space), (enc_gallina_fin k v) ↪[γ] (m !! (fin_to_nat v)).
   *)

  Definition not_in_key_fin x k : Prop := (¬ ∃ v, enc_gallina_fin k v = x).

  Lemma not_in_key_fin_spec x k :
    k ≠ key_of_enc_gallina_fin x →
    not_in_key_fin x k.
  Proof.
    intros Hneq (v&Henc). apply Hneq.
    rewrite -Henc.
    rewrite /enc_gallina_fin/key_of_enc_gallina_fin/val_of_enc_gallina_fin/=.
    apply (inj fin_to_nat).
    rewrite ?fin_to_nat_to_fin.
    rewrite key_of_enc_gallina_spec1 //.
    specialize (fin_to_nat_lt v); lia.
  Qed.

  (* This encoding is equivalent to the above in some sense but ends up being more workable
     in the absence of the above lemmas; I learned this trick from an encoding Upamanyu Sharma used
     used for representing "shards" of a key value store's key space, which is essentially equivalent
     to the problem here. *)
  Definition khashfun_own γ k (m : gmap nat bool) : iProp Σ :=
    ⌜ ∀ x, x ∈ dom m → x <= MAX_VALS ⌝ ∗
    [∗ set] kv ∈ fin_to_set (fin_hash_dom_space),
      (∃ v, ⌜ enc_gallina_fin k v = kv ⌝ ∗ kv ↪[γ] (m !! (fin_to_nat v))) ∨ ⌜ not_in_key_fin kv k ⌝.

  Lemma keyed_hash_ghost_init_split γ :
   ([∗ map] k↦v ∈ gset_to_gmap None (fin_to_set fin_hash_dom_space), k ↪[γ] v) -∗
   [∗ set] k ∈ fin_to_set fin_key_space, khashfun_own γ k ∅.
  Proof.
    rewrite /khashfun_own.
    iIntros "Hfrags".
    iApply big_sepS_sep.
    iSplit.
    { iPureIntro. rewrite /set_Forall. intros ???. rewrite dom_empty_L. set_solver. }
    iApply big_sepS_sepS.
    (* This proof is similar to one Ralf Jung developed for the above mentioned kv store's
       ghost state initialization *)
    iAssert ([∗ map] k↦v ∈ gset_to_gmap None (fin_to_set fin_hash_dom_space), k ↪[γ] None)%I with "[Hfrags]"
      as "H".
    { iApply (big_sepM_impl with "Hfrags"). iIntros "!>" (k x Hlookup).
      rewrite lookup_gset_to_gmap_Some in Hlookup.
      destruct Hlookup as (?&->). auto.
    }
    iDestruct (big_sepM_dom with "H") as "H".
    rewrite dom_gset_to_gmap.
    iApply (big_sepS_impl with "H").
    iIntros "!>" (x Hin) "Hx".
    rewrite (big_sepS_delete _ _ (key_of_enc_gallina_fin x)); last first.
    { apply elem_of_fin_to_set. }
    iSplitL "Hx".
    - iLeft. iExists (val_of_enc_gallina_fin x). rewrite lookup_empty //. iFrame.
      iPureIntro. rewrite enc_gallina_fin_inv //.
    - iApply big_sepS_intro.
      iIntros "!#" (k [Hk Hne]%elem_of_difference).
      iRight.
      iPureIntro.
      set_unfold.
      apply not_in_key_fin_spec; auto.
  Qed.

  Lemma ghost_phys_dom_init :
    ghost_phys_dom ∅ (gset_to_gmap None (fin_to_set fin_hash_dom_space)).
  Proof.
    split.
    - intros ??; rewrite lookup_empty; inversion 1.
    - intros ? _.
     rewrite lookup_gset_to_gmap_Some; split; auto.
     apply elem_of_fin_to_set.
  Qed.

  Lemma wp_init_keyed_hash E :
    {{{ True }}}
      init_keyed_hash #() @ E
    {{{ (f: val), RET f; ∃ γ, keyed_hash_auth γ f ∗
                              [∗ set] k ∈ fin_to_set (fin_key_space), khashfun_own γ k ∅ }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    rewrite /init_keyed_hash.
    wp_pures.
    wp_apply (wp_init_hash with "[//]").
    iIntros (f0) "Hf0".
    wp_pures. iApply "HΦ".
    set (m := gset_to_gmap None (fin_to_set (fin_hash_dom_space)) : gmap _ (option bool)).
    iMod (ghost_map_alloc m) as (γ) "(Hauth&Hfrags)".
    iExists γ.
    iSplitL "Hf0 Hauth".
    { iExists _, _, _. iFrame. iPureIntro; split_and!; eauto using ghost_phys_dom_init. }
    { iApply keyed_hash_ghost_init_split. auto. }
  Qed.

  Lemma spec_init_keyed_hash E K :
    ↑specN ⊆ E →
    refines_right K (init_keyed_hash #()) ={E}=∗
    ∃ f γ, refines_right K (of_val f) ∗ skeyed_hash_auth γ f ∗
           [∗ set] k ∈ fin_to_set (fin_key_space), khashfun_own γ k ∅.
  Proof.
    iIntros (?) "HK".
    rewrite /init_keyed_hash.
    tp_pures.
    tp_bind (init_hash _).
    rewrite refines_right_bind.
    iMod (spec_init_hash with "[$]") as (f0) "(HK&Hf0)"; first done.
    rewrite -refines_right_bind /=.
    tp_pures.
    set (m := gset_to_gmap None (fin_to_set (fin_hash_dom_space)) : gmap _ (option bool)).
    iMod (ghost_map_alloc m) as (γ) "(Hauth&Hfrags)".
    iExists _, γ. iFrame "HK".
    iSplitL "Hf0 Hauth".
    { iExists _, _, _. iFrame. iPureIntro; split_and!; eauto using ghost_phys_dom_init. }
    { iApply keyed_hash_ghost_init_split. auto. }
  Qed.

  Lemma khashfun_own_acc_assign_hash γ k v m :
    khashfun_own γ k m -∗
    (enc_gallina_fin k v) ↪[γ] (m !! (fin_to_nat v)) ∗
    (∀ b, (enc_gallina_fin k v) ↪[γ] (Some b) -∗ khashfun_own γ k (<[fin_to_nat v := b]>m)).
  Proof.
    iIntros "(%Hdom&Hk)".
    rewrite (big_sepS_delete _ _ (enc_gallina_fin k v)); last first.
    { apply elem_of_fin_to_set. }
    iDestruct "Hk" as "(Hkv&Hrest)".
    iSplitL "Hkv".
    { iDestruct "Hkv" as "[Hleft|%Hbad]".
      { iDestruct "Hleft" as (? Heq) "H". apply enc_gallina_fin_inj in Heq as (Heq1&Heq2). subst. auto. }
      iExFalso. iPureIntro. apply Hbad. eexists; eauto.
    }
    iIntros (b) "Hkv". iSplit.
    { iPureIntro. set_unfold. intros ? [?|?]; auto. subst.
      apply fin_to_nat_S_le. }
    iApply (big_sepS_delete _ _ (enc_gallina_fin k v)).
    { apply elem_of_fin_to_set. }
    iSplitL "Hkv".
    { iLeft. iExists _. iSplit; first eauto. rewrite lookup_insert //. }
    iApply (big_sepS_mono with "Hrest").
    { iIntros (x [Hx Hne]%elem_of_difference).
      set_unfold. iIntros "H".
      iDestruct "H" as "[Hleft|Hright]"; last by (iRight; eauto).
      iDestruct "Hleft" as (? Heq) "Hx". iLeft. iExists _; iSplit; first done.
      rewrite lookup_insert_ne //. subst. intros Heq.
      apply (inj fin_to_nat) in Heq. congruence.
    }
  Qed.

  Lemma khashfun_own_acc_lookup γ k v m :
    khashfun_own γ k m -∗
    (enc_gallina_fin k v) ↪[γ] (m !! (fin_to_nat v)) ∗
    ((enc_gallina_fin k v) ↪[γ] (m !! (fin_to_nat v)) -∗ khashfun_own γ k m).
  Proof.
    iIntros "(%Hdom&Hk)".
    rewrite (big_sepS_delete _ _ (enc_gallina_fin k v)); last first.
    { apply elem_of_fin_to_set. }
    iDestruct "Hk" as "(Hkv&Hrest)".
    iSplitL "Hkv".
    { iDestruct "Hkv" as "[Hleft|%Hbad]".
      { iDestruct "Hleft" as (? Heq) "H". apply enc_gallina_fin_inj in Heq as (Heq1&Heq2). subst. auto. }
      iExFalso. iPureIntro. apply Hbad. eexists; eauto.
    }
    iIntros "Hkv". iSplit; auto. iApply big_sepS_delete; first by apply elem_of_fin_to_set. iFrame.
    iLeft. eauto.
  Qed.

 (* TODO: move *)
  Lemma impl_couplable_wand (P Q: bool → iProp Σ) :
    impl_couplable P -∗
    (∀ b, P b -∗ Q b) -∗
    impl_couplable Q.
  Proof.
    rewrite /impl_couplable.
    iDestruct 1 as (α bs) "(Hα&HP)".
    iIntros "HPQ".
    iExists α, bs. iFrame. iIntros (?) "H". iApply "HPQ".
    iApply "HP". auto.
  Qed.

 (* TODO: move *)
  Lemma spec_couplable_wand (P Q: bool → iProp Σ) :
    spec_couplable P -∗
    (∀ b, P b -∗ Q b) -∗
    spec_couplable Q.
  Proof.
    iDestruct 1 as (α bs) "(Hα&HP)".
    iIntros "HPQ".
    iExists α, bs. iFrame. iIntros (?) "H". iApply "HPQ".
    iApply "HP". auto.
  Qed.

  Lemma ghost_phys_dom_insert x b mphys mghost :
    ghost_phys_dom mphys mghost →
    ghost_phys_dom (<[fin_to_nat x :=b]> mphys) (<[x :=Some b]> mghost).
  Proof.
    intros (?&?).
    split.
  - intros x' b'. destruct (decide (x = x')).
    { subst. rewrite ?lookup_insert // => -> //. }
    rewrite ?lookup_insert_ne //; eauto. intros ?%(inj fin_to_nat); congruence.
  - intros x'. destruct (decide (x = x')).
    { subst. rewrite ?lookup_insert // => -> //. }
    rewrite ?lookup_insert_ne //; eauto. intros ?%(inj fin_to_nat); congruence.
  Qed.

  Lemma ghost_phys_dom_rev mphys mghost x ob :
    ghost_phys_dom mphys mghost →
    mghost !! x = Some ob →
    mphys !! (fin_to_nat x) = ob.
  Proof.
    intros (Hdom1&Hdom2) Hlook_ghost.
    destruct ob as [b'|] eqn:Hob.
    - destruct (mphys !! (fin_to_nat x)) as [b|] eqn:Hlook_phys; last first.
      { exfalso. apply Hdom2 in Hlook_phys. rewrite Hlook_phys in Hlook_ghost. inversion Hlook_ghost. }
      { apply Hdom1 in Hlook_phys. congruence. }
    - destruct (mphys !! (fin_to_nat x)) as [b|] eqn:Hlook_phys.
      { exfalso. apply Hdom1 in Hlook_phys. rewrite Hlook_phys in Hlook_ghost. inversion Hlook_ghost. }
      { apply Hdom2 in Hlook_phys. congruence. }
  Qed.

  Lemma khashfun_own_couplable γ k f m v:
    v <= MAX_VALS →
    m !! v = None →
    keyed_hash_auth γ f -∗
    khashfun_own γ k m -∗ impl_couplable (λ b, |==> keyed_hash_auth γ f ∗ khashfun_own γ k (<[v:=b]>m)).
  Proof.
    iIntros (Hmax Hlookup) "Hhash Hk".
    assert (Hmax': v < S MAX_VALS) by lia.
    set (v' := nat_to_fin Hmax' : fin_val_space).
    iDestruct "Hhash" as (??? (Heq1&Hdom1&Hdom2)) "(Hauth&H)".
    set (x := enc_gallina_fin k v').
    iDestruct (khashfun_own_acc_assign_hash _ _ v' with "Hk") as "(Hpts&Hclo')".
    iDestruct (ghost_map_lookup with "[$] [$]") as %Hlook.
    assert (m !! fin_to_nat v' = None) as Hnone.
    { rewrite fin_to_nat_to_fin //. }
    rewrite Hnone in Hlook.
    iDestruct (hashfun_couplable (enc_gallina_fin k v') with "H") as "H".
    { apply fin_to_nat_S_le. }
    { eapply ghost_phys_dom_rev; eauto. split; auto. }
    iApply (impl_couplable_wand with "H").
    iIntros (b) "Hhash".
    iMod (ghost_map_update (Some b) with "[$] [$]") as "(Hauth&Hpts)".
    iDestruct ("Hclo'" with "[$]") as "Hk".
    iModIntro.
    iSplitL "Hhash Hauth".
    { iExists _, _, _.
      iFrame. iPureIntro; split_and!; eauto.
      apply ghost_phys_dom_insert. split; auto.
    }
    rewrite /v' fin_to_nat_to_fin //.
  Qed.

  Lemma khashfun_own_spec_couplable γ k f m v:
    v <= MAX_VALS →
    m !! v = None →
    skeyed_hash_auth γ f -∗
    khashfun_own γ k m -∗ spec_couplable (λ b, |==> skeyed_hash_auth γ f ∗ khashfun_own γ k (<[v:=b]>m)).
  Proof.
    iIntros (Hmax Hlookup) "Hhash Hk".
    assert (Hmax': v < S MAX_VALS) by lia.
    set (v' := nat_to_fin Hmax' : fin_val_space).
    iDestruct "Hhash" as (??? (Heq1&Hdom1&Hdom2)) "(Hauth&H)".
    set (x := enc_gallina_fin k v').
    iDestruct (khashfun_own_acc_assign_hash _ _ v' with "Hk") as "(Hpts&Hclo')".
    iDestruct (ghost_map_lookup with "[$] [$]") as %Hlook.
    assert (m !! fin_to_nat v' = None) as Hnone.
    { rewrite fin_to_nat_to_fin //. }
    rewrite Hnone in Hlook.
    iDestruct (shashfun_couplable (enc_gallina_fin k v') with "H") as "H".
    { apply fin_to_nat_S_le. }
    { eapply ghost_phys_dom_rev; eauto. split; auto. }
    iApply (spec_couplable_wand with "H").
    iIntros (b) "Hhash".
    iMod (ghost_map_update (Some b) with "[$] [$]") as "(Hauth&Hpts)".
    iDestruct ("Hclo'" with "[$]") as "Hk".
    iModIntro.
    iSplitL "Hhash Hauth".
    { iExists _, _, _.
      iFrame. iPureIntro; split_and!; eauto.
      apply ghost_phys_dom_insert. split; auto.
    }
    rewrite /v' fin_to_nat_to_fin //.
  Qed.

  Lemma wp_khashfun_prev E f m k (v : nat) γ (b : bool) :
    m !! v = Some b →
    {{{ keyed_hash_auth γ f ∗ khashfun_own γ k m }}}
      f #k #v @ E
    {{{ RET #b; keyed_hash_auth γ f ∗ khashfun_own γ k m }}}.
  Proof.
    iIntros (Hlookup Φ) "(H&Hown) HΦ".
    iDestruct "H" as (??? (Heq1&Hdom1&Hdom2)) "(Hauth&H)".
    rewrite Heq1. rewrite /enc. wp_pures.
    iAssert (⌜ v < S MAX_VALS ⌝)%I as "%Hmax'".
    { iDestruct "Hown" as "(%Hdom&_)". iPureIntro. apply elem_of_dom_2 in Hlookup.
      apply Hdom in Hlookup. lia. }
    set (v' := nat_to_fin Hmax' : fin_val_space).
    replace (#(k ≪ MAX_VALS_POW + v)) with #(fin_to_nat (enc_gallina_fin k v')); last first.
    { f_equal. rewrite /enc_gallina_fin ?fin_to_nat_to_fin /enc_gallina.
      rewrite /enc_gallina Nat.shiftl_mul_pow2 Z.shiftl_mul_pow2; last by lia.
      rewrite Nat2Z.inj_add Nat2Z.inj_mul Nat2Z.inj_pow //.
    }
    iDestruct (khashfun_own_acc_lookup _ _ v' with "Hown") as "(Hkv&Hclo)".
    iDestruct (ghost_map_lookup with "[$] [$]") as %Hlook.
    eapply ghost_phys_dom_rev in Hlook; last by (split; eauto).
    wp_apply (wp_hashfun_prev with "H").
    { rewrite Hlook. rewrite ?fin_to_nat_to_fin //. }
    iIntros "H".
    iApply "HΦ". iSplitL "Hauth H".
    { iExists _, _, _. iFrame. eauto. }
    iApply "Hclo". eauto.
  Qed.

  Lemma spec_khashfun_prev E K f m k (v : nat) γ (b : bool) :
    m !! v = Some b →
    ↑specN ⊆ E →
    skeyed_hash_auth γ f -∗
    khashfun_own γ k m -∗
    refines_right K (f #k #v) ={E}=∗
    refines_right K (of_val #b) ∗ skeyed_hash_auth γ f ∗ khashfun_own γ k m.
  Proof.
    iIntros (Hlookup ?) "Hauth Hown HK".
    iDestruct "Hauth" as (??? (Heq1&Hdom1&Hdom2)) "(Hauth&H)".
    rewrite Heq1. rewrite /enc. tp_pures.
    iAssert (⌜ v < S MAX_VALS ⌝)%I as "%Hmax'".
    { iDestruct "Hown" as "(%Hdom&_)". iPureIntro. apply elem_of_dom_2 in Hlookup.
      apply Hdom in Hlookup. lia. }
    set (v' := nat_to_fin Hmax' : fin_val_space).
    replace (#(k ≪ MAX_VALS_POW + v)) with #(fin_to_nat (enc_gallina_fin k v')); last first.
    { f_equal. rewrite /enc_gallina_fin ?fin_to_nat_to_fin /enc_gallina.
      rewrite /enc_gallina Nat.shiftl_mul_pow2 Z.shiftl_mul_pow2; last by lia.
      rewrite Nat2Z.inj_add Nat2Z.inj_mul Nat2Z.inj_pow //.
    }
    iDestruct (khashfun_own_acc_lookup _ _ v' with "Hown") as "(Hkv&Hclo)".
    iDestruct (ghost_map_lookup with "[$] [$]") as %Hlook.
    eapply ghost_phys_dom_rev in Hlook; last by (split; eauto).
    iMod (spec_hashfun_prev with "H HK") as "(HK&H)".
    { rewrite Hlook. rewrite ?fin_to_nat_to_fin //. }
    { done. }
    iFrame.
    iModIntro.
    iSplitL "Hauth H".
    { iExists _, _, _. iFrame. eauto. }
    iApply "Hclo". eauto.
  Qed.

  (* Actually this is not true: if v is out of range it can be as if
     you're hashing a differnt value with some other key! *)
  Lemma wp_khashfun_out_of_range E f k m (v : Z) γ :
    (v < 0 ∨ MAX_VALS < v)%Z →
    {{{ keyed_hash_auth γ f ∗ khashfun_own γ k m }}}
      f #k #v @ E
    {{{ RET #false; keyed_hash_auth γ f ∗ khashfun_own γ k m }}}.
  Proof.
  Abort.

End keyed_hash.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2004-09-06

This file provides an implementation of finite multisets using list
representation.
*)

Set Implicit Arguments.

Require Import LogicUtil RelExtras MultisetCore Permutation Multiset List
  ListExtras PermutSetoid Omega.

Module MultisetList (ES : Eqset_dec) <: MultisetCore with Module Sid := ES.

  Module Export Sid := ES.

Section Operations.

  Definition Multiset := list A.

  Definition empty : Multiset := nil.
  Definition singleton a : Multiset := a :: nil.
  Definition union := app (A:=A).
  Definition meq := permutation eqA eqA_dec.

  Definition mult := countIn eqA eqA_dec.
  Definition rem := removeElem eqA eqA_dec.
  Definition diff := removeAll eqA eqA_dec.

  Definition intersection := inter_as_diff diff.

  Definition fold_left := fun T : Type => List.fold_left (A := T) (B := A).

End Operations.

  Infix "=mul=" := meq (at level 70) : msets_scope.
  Notation "X <>mul Y" := (~meq X Y) (at level 50) : msets_scope.
  Notation "{{ x }}" := (singleton x) (at level 5) : msets_scope.
  Infix "+" := union : msets_scope.
  Infix "-" := diff : msets_scope.
  Infix "#" := intersection (at level 50, left associativity) : msets_scope.
  Infix "/" := mult : msets_scope.

  Delimit Scope msets_scope with msets.
  Open Scope msets_scope.
  Bind Scope msets_scope with Multiset.

Section ImplLemmas.

  Lemma empty_empty : forall M, (forall x, x / M = 0) -> M = empty.

  Proof.
    intros M mulM; destruct M.
    trivial.
    absurd (a / (a::M) = 0).
    simpl; case (eqA_dec a a); auto with sets.
    auto.
  Qed.

End ImplLemmas.

Section SpecConformation.

  Lemma mult_eqA_compat : forall M x y, x =A= y -> x / M = y / M.

  Proof.
     induction M.
     auto.
     intros; simpl.
     case (eqA_dec x a); case (eqA_dec y a); intros;
       solve [ absurd (y =A= a); eauto with sets
             | assert (x / M = y / M); auto ].
  Qed.

  Lemma mult_comp : forall l a,
    a / l = multiplicity (list_contents eqA eqA_dec l) a.

  Proof.
    induction l.
    auto.
    intro a0; simpl.
    case (eqA_dec a0 a); intro a0_a; case (eqA_dec a a0); intro a_a0;
      solve [ absurd (a0 =A= a); auto with sets
            | rewrite (IHl a0); trivial].
  Qed.

  Lemma multeq_meq : forall M N, (forall x, x / M = x / N) -> M =mul= N.

  Proof.
    unfold meq. intros M N mult_MN x. rewrite <- !mult_comp. exact (mult_MN x).
  Qed.

  Lemma meq_multeq : forall M N, M =mul= N -> forall x, x / M = x / N.

  Proof.
    unfold meq, permutation, Multiset.meq.
    intros M N eqMN x. rewrite !mult_comp. exact (eqMN x).
  Qed.

  Lemma empty_mult : forall x, mult x empty = 0.

  Proof. auto. Qed.

  Lemma union_mult : forall M N x, x / ((M + N))%msets = ((mult x  M)+ (mult x  N))%nat.

  Proof.
    induction M; auto.
    intros; simpl; case (eqA_dec x a); intro; auto.
    replace (x / (M + N)) with ((mult x M) + (mult x  N))%nat;
      solve [auto | apply IHM].
  Qed.

  Lemma diff_empty_l : forall M, empty - M = empty.

  Proof.
    induction M; auto.
  Qed.

  Lemma diff_empty_r : forall M, M - empty = M.

  Proof.
    induction M; auto.
  Qed.

  Lemma mult_remove_in : forall x a M,
    x =A= a -> x / (rem a M) = ((mult x M) - 1)%nat.

  Proof.
    induction M.
    auto.
    intro x_a.
    simpl; case (eqA_dec x a0); case (eqA_dec a a0);
      simpl; intros; try solve [absurd (x =A= a); eauto with sets].
    auto with arith.
    destruct (eqA_dec x a0).
    contr.
    auto.
  Qed.

  Lemma mult_remove_not_in : forall M a x,
    ~ x =A= a -> x / (rem a M) = x / M.

  Proof.
    induction M; intros.
    auto.
    simpl; case (eqA_dec a0 a); intro a0_a.
    case (eqA_dec x a); intro x_a;
      solve [absurd (x =A= a); eauto with sets | trivial].
    simpl; case (eqA_dec x a); intro x_a.
    rewrite (IHM a0 x); trivial.
    apply IHM; trivial.
  Qed.

  Lemma remove_perm_single : forall x a b M,
   x / (rem a (rem b M)) = x / (rem b (rem a M)).

  Proof.
    intros x a b M.
    case (eqA_dec x a); case (eqA_dec x b); intros x_b x_a.
     (* x=b,  x=a *)
    rewrite !mult_remove_in; trivial.
     (* x<>b, x=a *)
    rewrite mult_remove_in; trivial.
    do 2 (rewrite mult_remove_not_in; trivial).
    rewrite mult_remove_in; trivial.
     (* x=b,  x<>a *)
    rewrite mult_remove_not_in; trivial.
    do 2 (rewrite mult_remove_in; trivial).
    rewrite mult_remove_not_in; trivial.
     (* x<>b, x<>a *)
    rewrite !mult_remove_not_in; trivial.
  Qed.

  Lemma diff_mult_comp : forall x N M M',
    M =mul= M' -> x / (M - N) = x / (M' - N).

  Proof.
    induction N.
    intros; apply meq_multeq; trivial.
    intros M M' MM'.
    simpl.
    apply IHN.
    apply multeq_meq.
    intro x'.
    case (eqA_dec x' a).
    intro xa; rewrite !mult_remove_in; trivial.
    rewrite (meq_multeq MM'); trivial.
    intro xna; rewrite !mult_remove_not_in; trivial.
    apply meq_multeq; trivial.
  Qed.

  Lemma diff_perm_single : forall x a b M N,
    x / (M - (a::b::N)) = x / (M - (b::a::N)).

  Proof.
    intros x a b M N.
    simpl; apply diff_mult_comp.
    apply multeq_meq.
    intro x'; apply remove_perm_single.
  Qed.

  Lemma diff_perm : forall M N a x,
    x / ((rem a M) - N) = x / (rem a (M - N)).

  Proof.
    intros M N; gen M; clear M.
    induction N.
    auto.
    intros M b x.
    change (rem b M - (a::N)) with (M - (b::a::N)).
    rewrite diff_perm_single.
    simpl; apply IHN.
  Qed.

  Lemma diff_mult_step_eq : forall M N a x,
    x =A= a -> x / (rem a M - N) = (mult x  (M - N)%msets - 1)%nat.

  Proof.
    intros M N a x x_a.
    rewrite diff_perm.
    rewrite mult_remove_in; trivial.
  Qed.

  Lemma diff_mult_step_neq : forall M N a x,
    ~ x =A= a -> x / (rem a M - N) = x / (M - N).

  Proof.
    intros M N a x x_a.
    rewrite diff_perm.
    rewrite mult_remove_not_in; trivial.
  Qed.

  Lemma diff_mult : forall M N x, x / (M - N) = ((mult x  M) - (mult x N))%nat.

  Proof.
    induction N.
     (* induction base *)
    simpl; intros; omega.
     (* induction step *)
    intro x; simpl.
    case (eqA_dec x a); intro x_a; simpl.
     (* x = a *)
    fold rem.
    rewrite (diff_mult_step_eq M N x_a).
    rewrite (IHN x).
    omega.
     (* x <> a *)
    fold rem.
    rewrite (diff_mult_step_neq M N x_a).
    exact (IHN x).
  Qed.

  Definition intersection_mult := inter_as_diff_ok mult diff diff_mult.

  Lemma singleton_mult_in : forall x y, x =A= y -> x / {{y}} = 1.

  Proof.
    intros; compute.
    case (eqA_dec x y); [trivial | contr].
  Qed.

  Lemma singleton_mult_notin : forall x y, ~x =A= y -> x / {{y}} = 0.

  Proof.
    intros; compute.
    case (eqA_dec x y); [contr | trivial].
  Qed.

  Lemma rev_list_ind_type : forall P : Multiset -> Type,
    P nil -> (forall a l, P (rev l) -> P (rev (a :: l))) -> forall l, P (rev l).

  Proof.
    induction l; auto.
  Defined.

  Lemma rev_ind_type : forall P : Multiset -> Type,
    P nil -> (forall x l, P l -> P (l ++ x :: nil)) -> forall l, P l.

  Proof.
    intros.
    gen (rev_involutive l).
    intros E; rewrite <- E.
    apply (rev_list_ind_type P).
    auto.
    simpl in |- *.
    intros.
    apply (X0 a (rev l0)).
    auto.
  Defined.

  Lemma mset_ind_type : forall P : Multiset -> Type,
    P empty -> (forall M a, P M -> P (union M {{a}})) -> forall M, P M.

  Proof.
    induction M as [| x M] using rev_ind_type.
    exact X.
    exact (X0 M x IHM).
  Defined.

End SpecConformation.

  Hint Unfold meq
	      empty
              singleton
              mult
              union
              diff : multisets.

  Hint Resolve mult_eqA_compat
               meq_multeq
               multeq_meq
               empty_mult
               union_mult
               diff_mult
               intersection_mult
               singleton_mult_in
               singleton_mult_notin : multisets.

  Hint Rewrite empty_mult
               union_mult
	       diff_mult
	       intersection_mult using trivial : multisets.

End MultisetList.


Require Import VST.floyd.base.

Ltac make_ground_PTree a :=
 let a := eval hnf in a in
 match a with
 | PTree.Leaf => constr:(a)
 | PTree.Node ?l ?o ?r =>
    let l := make_ground_PTree l in
    let r := make_ground_PTree r in
    let o := eval hnf in o in
    constr:(PTree.Node l o r)
 end.

Ltac simpl_PTree_get_old :=
  repeat match goal with
         | |- context [PTree.get ?i' ?t] =>
           let i'' := eval hnf in i' in
               change (PTree.get i' t) with
               ((fix get (A : Type) (i : positive) (m : PTree.t A) {struct i} : option A :=
                 match m with
                 | PTree.Leaf => None
                 | PTree.Node l o r =>
                     match i with
                     | (ii~1)%positive => get A ii r
                     | (ii~0)%positive => get A ii l
                     | 1%positive => o
                     end
                 end) _ i'' t)
         end;
  cbv iota zeta beta.

Ltac simpl_PTree_get :=
  repeat match goal with
         | |- context [PTree.get ?i' ?t] =>
           let g := constr:(PTree.get i' t) in
           let g := eval hnf in g in
           change (PTree.get i' t) with g
         end;
  cbv iota zeta beta.

Ltac simpl_eqb_type :=
  repeat
  match goal with
  | |- context [eqb_type ?t1 ?t2] =>
    let b := eval hnf in (eqb_type t1 t2) in
    change (eqb_type t1 t2) with b;
    cbv beta iota zeta
  end.

Ltac simpl_temp_types_get :=
  repeat
  match goal with
  | |- context [(temp_types ?Delta) ! ?i] =>
          let ret := eval hnf in ((temp_types Delta) ! i) in
          change ((temp_types Delta) ! i) with ret
  end.

Ltac pos_eqb_tac :=
  let H := fresh "H" in
  match goal with
  | |- context [Pos.eqb ?i ?j] => destruct (Pos.eqb i j) eqn:H; [apply Pos.eqb_eq in H | apply Pos.eqb_neq in H]
  end.

Definition VST_floyd_map {A B : Type} (f: A -> B): list A -> list B :=
  fix map (l : list A) : list B := match l with
                                   | nil => nil
                                   | a :: t => f a :: map t
                                   end.

Definition VST_floyd_app {A: Type}: list A -> list A -> list A :=
  fix app (l m : list A) {struct l} : list A :=
  match l with
  | nil => m
  | a :: l1 => a :: app l1 m
  end.

Definition VST_floyd_concat {A: Type}: list (list A) -> list A :=
  fix concat (l : list (list A)) : list A :=
  match l with
  | nil => nil
  | x :: l0 => VST_floyd_app x (concat l0)
  end.


From Coq Require Import
     Program
     Setoid
     Morphisms
     Relations.

From ITree Require Import
     Basics.Basics
     Basics.Tacs
     Basics.HeterogeneousRelations
 .

From EnTree Require Import
     Basics.HeterogeneousRelations
     Core.EnTreeDefinition
     Eq.Eqit
.

From Paco Require Import paco.

Local Open Scope entree_scope.

Section padded.
Context {E : Type} `{EncodingType E} {R : Type}.

Variant paddedF (F : entree E R -> Prop) : entree' E R -> Prop :=
  | paddedF_Ret r : paddedF F (RetF r)
  | paddedF_Tau t : F t -> paddedF F (TauF t)
  | paddedF_Vis e (k : encodes e -> entree E R) :
    (forall a, F (k a)) -> paddedF F (VisF e (fun a => (Tau (k a))))
.
Hint Constructors paddedF : entree_spec.

Definition padded_ sim := fun t => paddedF sim (observe t).

Lemma padded_monotone_ : monotone1 padded_.
Proof with eauto with entree_spec.
  red. unfold padded_. intros.
  induction IN...
Qed.

Hint Resolve padded_monotone_ : entree_spec.

Definition padded := paco1 padded_ bot1.

Lemma padded_VisF_inv e k F : paddedF F (VisF e k) -> exists k', forall a, k a ≅ Tau (k' a).
Proof with eauto with entree_spec.
  intros. dependent destruction H0... eexists. reflexivity.
Qed.

CoFixpoint pad' (ot : entree' E R) : entree E R :=
  match ot with
  | RetF r => Ret r
  | TauF t => Tau (pad' (observe t))
  | VisF e k => Vis e (fun x => Tau (pad' (observe (k x))))
  end.

Definition pad t := pad' (observe t).

Lemma pad_ret r : pad (Ret r) ≅ Ret r.
Proof.
  pstep. constructor. auto.
Qed.

Lemma pad_tau t : pad (Tau t) ≅ Tau (pad t).
Proof.
  pstep. red. cbn. constructor. left. enough (pad t ≅ pad t). auto.
  reflexivity.
Qed.

Lemma pad_vis e k : pad (Vis e k) ≅ Vis e (fun x => Tau (pad (k x))).
Proof.
  pstep. red. cbn. constructor. left.  pstep. constructor.
  left. enough (pad (k a) ≅ pad (k a)). auto. reflexivity.
Qed.

End padded.

Theorem pad_is_padded {E : Type} `{EncodingType E} {R : Type} : forall t : entree E R, padded (pad t).
Proof with eauto with entree_spec.
  pcofix CIH. intros. pstep. unfold pad.
  destruct (observe t); eauto. constructor. constructor. right. eauto.
  econstructor. intros. eauto.
Qed.
#[global] Hint Resolve padded_monotone_ : paco.
#[global] Hint Resolve padded_monotone_ : entree_spec.
#[global] Hint Resolve pad_is_padded : entree_spec.

Theorem pad_eutt {E : Type} `{EncodingType E} {R : Type} : forall t : entree E R, t ≈ pad t.
Proof with eauto with entree_spec.
  ginit. gcofix CIH. intros.
  unfold pad.
  destruct (observe t) eqn : Ht; symmetry in Ht; apply simpobs in Ht.
  - rewrite <- Ht. gstep. constructor. auto.
  - rewrite <- Ht. gstep. red. cbn. constructor.
    gfinal. eauto.
  - rewrite <- Ht. gstep. red. cbn.
    constructor. intros. red.
    rewrite tau_euttge.
    gfinal. eauto.
Qed.

Global Instance pad_Proper {b1 b2 E R} `{EncodingType E} : Proper (eqit eq b1 b2 ==> eqit eq b1 b2) (@pad E _ R).
Proof.
  pcofix CIH.
  intros t1 t2 Ht12. pstep. red. unfold pad.
  punfold Ht12. red in Ht12. hinduction Ht12 before r;
    intros; cbn; eauto.
  - constructor. auto.
  - constructor. pclearbot. right. eapply CIH; eauto.
  - constructor. left. pstep. constructor. pclearbot. right.
    eapply CIH; eauto. apply REL.
  - constructor; auto.
  - constructor; auto.
Qed.

Theorem pad_bind {E : Type} `{EncodingType E} {R S: Type} : forall (t : entree E R) (k : R -> entree E S),
    pad (EnTree.bind t k) ≅ EnTree.bind (pad t) (fun x => pad (k x)).
Proof.
  ginit. gcofix CIH. intros t k.
  destruct (observe t) eqn : Heq; symmetry in Heq; apply simpobs in Heq.
  - rewrite <- Heq. rewrite pad_ret. repeat rewrite bind_ret_l.
    apply Reflexive_eqit_gen. auto.
  - repeat rewrite <- Heq. rewrite pad_tau. repeat rewrite bind_tau. gstep. constructor.
    gfinal. eauto.
  - repeat rewrite <- Heq. rewrite pad_vis. repeat rewrite bind_vis. rewrite pad_vis.
    gstep. constructor. intros. unfold id. gstep. constructor. gfinal. left. eapply CIH.
Qed.

Theorem pad_iter E `{EncodingType E} R S (body : R -> entree E (R + S)):
  forall r, pad (EnTree.iter body r) ≅ EnTree.iter (fun r => pad (body r)) r.
Proof.
  ginit. gcofix CIH.
  intros. setoid_rewrite unfold_iter. rewrite pad_bind.
  guclo eqit_clo_bind. econstructor.
  reflexivity. intros. subst. destruct u2.
  - rewrite pad_tau. gstep. constructor. gfinal. left. eauto.
  - rewrite pad_ret. gstep. constructor. auto.
Qed.


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

(** Whole-program behaviors *)

Require Import Classical.
Require Import ClassicalEpsilon.
Require Import Coqlib.
Require Import Events.
Require Import Globalenvs.
Require Import Integers.
Require Import Smallstep.

Set Implicit Arguments.

(** * Behaviors for program executions *)

(** The four possible outcomes for the execution of a program:
- Termination, with a finite trace of observable events
  and an integer value that stands for the process exit code
  (the return value of the main function).
- Divergence with a finite trace of observable events.
  (At some point, the program runs forever without doing any I/O.)
- Reactive divergence with an infinite trace of observable events.
  (The program performs infinitely many I/O operations separated
   by finite amounts of internal computations.)
- Going wrong, with a finite trace of observable events
  performed before the program gets stuck.
*)

(** [CompCertX:test-compcert-param-final] We parameterize the semantics
over the type of final return value. For whole programs, this shall be
[int]. *)

Inductive program_behavior (RETVAL: Type): Type :=
  | Terminates: trace -> RETVAL -> program_behavior RETVAL
  | Diverges: trace -> program_behavior RETVAL
  | Reacts: traceinf -> program_behavior RETVAL
  | Goes_wrong: trace -> program_behavior RETVAL.
Arguments Diverges [_] _.
Arguments Reacts [_] _.
Arguments Goes_wrong [_] _.

(** Operations and relations on behaviors *)

Definition not_wrong (RETVAL: Type) (beh: program_behavior RETVAL) : Prop :=
  match beh with
  | Terminates _ _ => True
  | Diverges _ => True
  | Reacts _ => True
  | Goes_wrong _ => False
  end.

Definition behavior_app (RETVAL: Type) (t: trace) (beh: program_behavior RETVAL): program_behavior RETVAL :=
  match beh with
  | Terminates t1 r => Terminates (t ** t1) r
  | Diverges t1 => Diverges (t ** t1)
  | Reacts T => Reacts (t *** T)
  | Goes_wrong t1 => Goes_wrong (t ** t1)
  end.

Lemma behavior_app_assoc:
  forall (RETVAL: Type) t1 t2 (beh: _ RETVAL),
  behavior_app (t1 ** t2) beh = behavior_app t1 (behavior_app t2 beh).
Proof.
  intros. destruct beh; simpl; f_equal; traceEq.
Qed.

Lemma behavior_app_E0:
  forall (RETVAL: Type) (beh: _ RETVAL), behavior_app E0 beh = beh.
Proof.
  destruct beh; auto.
Qed.

Definition behavior_prefix (RETVAL: Type) (t: trace) (beh: program_behavior RETVAL) : Prop :=
  exists beh', beh = behavior_app t beh'.

Definition behavior_improves (RETVAL: Type) (beh1 beh2: program_behavior RETVAL) : Prop :=
  beh1 = beh2 \/ exists t, beh1 = Goes_wrong t /\ behavior_prefix t beh2.

Lemma behavior_improves_refl:
  forall (RETVAL: Type) (beh: _ RETVAL), behavior_improves beh beh.
Proof.
  intros; red; auto.
Qed.

Lemma behavior_improves_trans:
  forall (RETVAL: Type) (beh1 beh2 beh3: _ RETVAL),
  behavior_improves beh1 beh2 -> behavior_improves beh2 beh3 ->
  behavior_improves beh1 beh3.
Proof.
  intros. red. destruct H; destruct H0; subst; auto.
  destruct H as [t1 [EQ1 [beh2' EQ1']]].
  destruct H0 as [t2 [EQ2 [beh3' EQ2']]].
  subst. destruct beh2'; simpl in EQ2; try discriminate. inv EQ2.
  right. exists t1; split; auto. exists (behavior_app t beh3'). apply behavior_app_assoc.
Qed.

Lemma behavior_improves_bot:
  forall (RETVAL: Type) (beh: _ RETVAL), behavior_improves (Goes_wrong E0) beh.
Proof.
  intros. right. exists E0; split; auto. exists beh. rewrite behavior_app_E0; auto.
Qed.

Lemma behavior_improves_app:
  forall (RETVAL: Type) t (beh1 beh2: _ RETVAL),
  behavior_improves beh1 beh2 ->
  behavior_improves (behavior_app t beh1) (behavior_app t beh2).
Proof.
  intros. red; destruct H. left; congruence.
  destruct H as [t' [A [beh' B]]]. subst.
  right; exists (t ** t'); split; auto. exists beh'. rewrite behavior_app_assoc; auto.
Qed.

(** Associating behaviors to programs. *)

Section PROGRAM_BEHAVIORS.

Variable RETVAL: Type.
Variable L: semantics RETVAL.

Inductive state_behaves (s: state L): program_behavior RETVAL -> Prop :=
  | state_terminates: forall t s' r,
      Star L s t s' ->
      final_state L s' r ->
      state_behaves s (Terminates t r)
  | state_diverges: forall t s',
      Star L s t s' -> Forever_silent L s' ->
      state_behaves s (Diverges t)
  | state_reacts: forall T,
      Forever_reactive L s T ->
      state_behaves s (Reacts T)
  | state_goes_wrong: forall t s',
      Star L s t s' ->
      Nostep L s' ->
      (forall r, ~final_state L s' r) ->
      state_behaves s (Goes_wrong t).

Inductive program_behaves: program_behavior RETVAL -> Prop :=
  | program_runs: forall s beh,
      initial_state L s -> state_behaves s beh ->
      program_behaves beh
  | program_goes_initially_wrong:
      (forall s, ~initial_state L s) ->
      program_behaves (Goes_wrong E0).

Lemma state_behaves_app:
  forall s1 t s2 beh,
  Star L s1 t s2 -> state_behaves s2 beh -> state_behaves s1 (behavior_app t beh).
Proof.
  intros. inv H0; simpl; econstructor; eauto; try (eapply star_trans; eauto).
  eapply star_forever_reactive; eauto.
Qed.

(** * Existence of behaviors *)

(** We now show that any program accepts at least one behavior.
  The proof requires classical logic: the axiom of excluded middle
  and an axiom of description. *)

(** The most difficult part of the proof is to show the existence
  of an infinite trace in the case of reactive divergence. *)

Section TRACEINF_REACTS.

Variable s0: state L.

Hypothesis reacts:
  forall s1 t1, Star L s0 t1 s1 ->
  exists s2, exists t2, Star L s1 t2 s2 /\ t2 <> E0.

Lemma reacts':
  forall s1 t1, Star L s0 t1 s1 ->
  { s2 : state L & { t2 : trace | Star L s1 t2 s2 /\ t2 <> E0 } }.
Proof.
  intros.
  destruct (constructive_indefinite_description _ (reacts H)) as [s2 A].
  destruct (constructive_indefinite_description _ A) as [t2 [B C]].
  exists s2; exists t2; auto.
Qed.

CoFixpoint build_traceinf' (s1: state L) (t1: trace) (ST: Star L s0 t1 s1) : traceinf' :=
  match reacts' ST with
  | existT s2 (exist t2 (conj A B)) =>
      Econsinf' t2
                (build_traceinf' (star_trans ST A (refl_equal _)))
                B
  end.

Lemma reacts_forever_reactive_rec:
  forall s1 t1 (ST: Star L s0 t1 s1),
  Forever_reactive L s1 (traceinf_of_traceinf' (build_traceinf' ST)).
Proof.
  cofix COINDHYP; intros.
  rewrite (unroll_traceinf' (build_traceinf' ST)). simpl.
  destruct (reacts' ST) as [s2 [t2 [A B]]].
  rewrite traceinf_traceinf'_app.
  econstructor. eexact A. auto. apply COINDHYP.
Qed.

Lemma reacts_forever_reactive:
  exists T, Forever_reactive L s0 T.
Proof.
  exists (traceinf_of_traceinf' (build_traceinf' (star_refl (step L) (globalenv L) s0))).
  apply reacts_forever_reactive_rec.
Qed.

End TRACEINF_REACTS.

Lemma diverges_forever_silent:
  forall s0,
  (forall s1 t1, Star L s0 t1 s1 -> exists s2, Step L s1 E0 s2) ->
  Forever_silent L s0.
Proof.
  cofix COINDHYP; intros.
  destruct (H s0 E0) as [s1 ST]. constructor.
  econstructor. eexact ST. apply COINDHYP.
  intros. eapply H. eapply star_left; eauto.
Qed.

Lemma state_behaves_exists:
  forall s, exists beh, state_behaves s beh.
Proof.
  intros s0.
  destruct (classic (forall s1 t1, Star L s0 t1 s1 -> exists s2, exists t2, Step L s1 t2 s2)).
(* 1 Divergence (silent or reactive) *)
  destruct (classic (exists s1, exists t1, Star L s0 t1 s1 /\
                       (forall s2 t2, Star L s1 t2 s2 ->
                        exists s3, Step L s2 E0 s3))).
(* 1.1 Silent divergence *)
  destruct H0 as [s1 [t1 [A B]]].
  exists (Diverges t1); econstructor; eauto.
  apply diverges_forever_silent; auto.
(* 1.2 Reactive divergence *)
  destruct (@reacts_forever_reactive s0) as [T FR].
  intros.
  generalize (not_ex_all_not _ _ H0 s1). intro A; clear H0.
  generalize (not_ex_all_not _ _ A t1). intro B; clear A.
  destruct (not_and_or _ _ B). contradiction.
  destruct (not_all_ex_not _ _ H0) as [s2 C]; clear H0.
  destruct (not_all_ex_not _ _ C) as [t2 D]; clear C.
  destruct (imply_to_and _ _ D) as [E F]; clear D.
  destruct (H s2 (t1 ** t2)) as [s3 [t3 G]]. eapply star_trans; eauto.
  exists s3; exists (t2 ** t3); split.
  eapply star_right; eauto.
  red; intros. destruct (app_eq_nil t2 t3 H0). subst. elim F. exists s3; auto.
  exists (Reacts T); econstructor; eauto.
(* 2 Termination (normal or by going wrong) *)
  destruct (not_all_ex_not _ _ H) as [s1 A]; clear H.
  destruct (not_all_ex_not _ _ A) as [t1 B]; clear A.
  destruct (imply_to_and _ _ B) as [C D]; clear B.
  destruct (classic (exists r, final_state L s1 r)) as [[r FINAL] | NOTFINAL].
(* 2.1 Normal termination *)
  exists (Terminates t1 r); econstructor; eauto.
(* 2.2 Going wrong *)
  exists (Goes_wrong t1); econstructor; eauto. red. intros.
  generalize (not_ex_all_not _ _ D s'); intros.
  generalize (not_ex_all_not _ _ H t); intros.
  auto.
Qed.

Theorem program_behaves_exists:
  exists beh, program_behaves beh.
Proof.
  destruct (classic (exists s, initial_state L s)) as [[s0 INIT] | NOTINIT].
(* 1. Initial state is defined. *)
  destruct (state_behaves_exists s0) as [beh SB].
  exists beh; econstructor; eauto.
(* 2. Initial state is undefined *)
  exists (Goes_wrong E0). apply program_goes_initially_wrong.
  intros. eapply not_ex_all_not; eauto.
Qed.

End PROGRAM_BEHAVIORS.

(** * Forward simulations and program behaviors *)

Section FORWARD_SIMULATIONS.

Variable RETVAL: Type.
Variable L1: semantics RETVAL.
Variable L2: semantics RETVAL.
Variable S: forward_simulation L1 L2.

Lemma forward_simulation_state_behaves:
  forall i s1 s2 beh1,
  S i s1 s2 -> state_behaves L1 s1 beh1 ->
  exists beh2, state_behaves L2 s2 beh2 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H0.
(* termination *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  exists (Terminates t r); split.
  econstructor; eauto. eapply fsim_match_final_states; eauto.
  apply behavior_improves_refl.
(* silent divergence *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  exists (Diverges t); split.
  econstructor; eauto. eapply simulation_forever_silent; eauto.
  apply behavior_improves_refl.
(* reactive divergence *)
  exists (Reacts T); split.
  econstructor. eapply simulation_forever_reactive; eauto.
  apply behavior_improves_refl.
(* going wrong *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  destruct (state_behaves_exists L2 s2') as [beh' SB].
  exists (behavior_app t beh'); split.
  eapply state_behaves_app; eauto.
  replace (Goes_wrong (RETVAL := RETVAL) t) with (behavior_app t (Goes_wrong (RETVAL := RETVAL) E0)).
  apply behavior_improves_app. apply behavior_improves_bot.
  simpl. decEq. traceEq.
Qed.

Theorem forward_simulation_behavior_improves:
  forall beh1, program_behaves L1 beh1 ->
  exists beh2, program_behaves L2 beh2 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H.
(* initial state defined *)
  exploit (fsim_match_initial_states S); eauto. intros [i [s' [INIT MATCH]]].
  exploit forward_simulation_state_behaves; eauto. intros [beh2 [A B]].
  exists beh2; split; auto. econstructor; eauto.
(* initial state undefined *)
  destruct (classic (exists s', initial_state L2 s')).
  destruct H as [s' INIT].
  destruct (state_behaves_exists L2 s') as [beh' SB].
  exists beh'; split. econstructor; eauto. apply behavior_improves_bot.
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros. elim H; exists s; auto.
  apply behavior_improves_refl.
Qed.

Corollary forward_simulation_same_safe_behavior:
  forall beh,
  program_behaves L1 beh -> not_wrong beh ->
  program_behaves L2 beh.
Proof.
  intros. exploit forward_simulation_behavior_improves; eauto.
  intros [beh' [A B]]. destruct B.
  congruence.
  destruct H1 as [t [C D]]. subst. contradiction.
Qed.

End FORWARD_SIMULATIONS.

(** * Backward simulations and program behaviors *)

Section BACKWARD_SIMULATIONS.

Variable RETVAL: Type.
Variable L1: semantics RETVAL.
Variable L2: semantics RETVAL.
Variable S: backward_simulation L1 L2.

Definition safe_along_behavior (s: state L1) (b: program_behavior RETVAL) : Prop :=
  forall t1 s' b2, Star L1 s t1 s' -> b = behavior_app t1 b2 ->
     (exists r, final_state L1 s' r)
  \/ (exists t2, exists s'', Step L1 s' t2 s'').

Remark safe_along_safe:
  forall s b, safe_along_behavior s b -> safe L1 s.
Proof.
  intros; red; intros. eapply H; eauto. symmetry; apply behavior_app_E0.
Qed.

Remark star_safe_along:
  forall s b t1 s' b2,
  safe_along_behavior s b ->
  Star L1 s t1 s' -> b = behavior_app t1 b2 ->
  safe_along_behavior s' b2.
Proof.
  intros; red; intros. eapply H. eapply star_trans; eauto.
  subst. rewrite behavior_app_assoc. eauto.
Qed.

Remark not_safe_along_behavior:
  forall s b,
  ~ safe_along_behavior s b ->
  exists t, exists s',
     behavior_prefix t b
  /\ Star L1 s t s'
  /\ Nostep L1 s'
  /\ (forall r, ~(final_state L1 s' r)).
Proof.
  intros.
  destruct (not_all_ex_not _ _ H) as [t1 A]; clear H.
  destruct (not_all_ex_not _ _ A) as [s' B]; clear A.
  destruct (not_all_ex_not _ _ B) as [b2 C]; clear B.
  destruct (imply_to_and _ _ C) as [D E]; clear C.
  destruct (imply_to_and _ _ E) as [F G]; clear E.
  destruct (not_or_and _ _ G) as [P Q]; clear G.
  exists t1; exists s'.
  split. exists b2; auto.
  split. auto.
  split. red; intros; red; intros. elim Q. exists t; exists s'0; auto.
  intros; red; intros. elim P. exists r; auto.
Qed.

Lemma backward_simulation_star:
  forall s2 t s2', Star L2 s2 t s2' ->
  forall i s1 b, S i s1 s2 -> safe_along_behavior s1 (behavior_app t b) ->
  exists i', exists s1', Star L1 s1 t s1' /\ S i' s1' s2'.
Proof.
  induction 1; intros.
  exists i; exists s1; split; auto. apply star_refl.
  exploit (bsim_simulation S); eauto. eapply safe_along_safe; eauto.
  intros [i' [s1' [A B]]].
  assert (Star L1 s0 t1 s1'). intuition. apply plus_star; auto.
  exploit IHstar; eauto. eapply star_safe_along; eauto.
  subst t; apply behavior_app_assoc.
  intros [i'' [s2'' [C D]]].
  exists i''; exists s2''; split; auto. eapply star_trans; eauto.
Qed.

Lemma backward_simulation_forever_silent:
  forall i s1 s2,
  Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 ->
  Forever_silent L1 s1.
Proof.
  assert (forall i s1 s2,
         Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 ->
         forever_silent_N (step L1) (bsim_order S) (globalenv L1) i s1).
    cofix COINDHYP; intros.
    inv H.  destruct (bsim_simulation S _ _ _ H2 _ H0 H1) as [i' [s2' [A B]]].
    destruct A as [C | [C D]].
    eapply forever_silent_N_plus; eauto. eapply COINDHYP; eauto.
      eapply star_safe; eauto. apply plus_star; auto.
    eapply forever_silent_N_star; eauto. eapply COINDHYP; eauto.
      eapply star_safe; eauto.
  intros. eapply forever_silent_N_forever; eauto. apply bsim_order_wf.
Qed.

Lemma backward_simulation_forever_reactive:
  forall i s1 s2 T,
  Forever_reactive L2 s2 T -> S i s1 s2 -> safe_along_behavior s1 (Reacts T) ->
  Forever_reactive L1 s1 T.
Proof.
  cofix COINDHYP; intros. inv H.
  destruct (backward_simulation_star H2 _ (Reacts T0) H0) as [i' [s1' [A B]]]; eauto.
  econstructor; eauto. eapply COINDHYP; eauto. eapply star_safe_along; eauto.
Qed.

Lemma backward_simulation_state_behaves:
  forall i s1 s2 beh2,
  S i s1 s2 -> state_behaves L2 s2 beh2 ->
  exists beh1, state_behaves L1 s1 beh1 /\ behavior_improves beh1 beh2.
Proof.
  intros. destruct (classic (safe_along_behavior s1 beh2)).
(* 1. Safe along *)
  exists beh2; split; [idtac|apply behavior_improves_refl].
  inv H0.
(* termination *)
  assert (Terminates t r = behavior_app t (Terminates E0 r)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  exploit (bsim_match_final_states S); eauto.
    eapply safe_along_safe. eapply star_safe_along; eauto.
  intros [s1'' [C D]].
  econstructor. eapply star_trans; eauto. traceEq. auto.
(* silent divergence *)
  assert (Diverges (RETVAL := RETVAL) t = behavior_app t (Diverges E0)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  econstructor. eauto. eapply backward_simulation_forever_silent; eauto.
  eapply safe_along_safe. eapply star_safe_along; eauto.
(* reactive divergence *)
  econstructor. eapply backward_simulation_forever_reactive; eauto.
(* goes wrong *)
  assert (Goes_wrong (RETVAL := RETVAL) t = behavior_app t (Goes_wrong E0)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  exploit (bsim_progress S); eauto. eapply safe_along_safe. eapply star_safe_along; eauto.
  intros [[r FIN] | [t' [s2' STEP2]]].
  elim (H4 _ FIN).
  elim (H3 _ _ STEP2).

(* 2. Not safe along *)
  exploit not_safe_along_behavior; eauto.
  intros [t [s1' [PREF [STEPS [NOSTEP NOFIN]]]]].
  exists (Goes_wrong t); split.
  econstructor; eauto.
  right. exists t; auto.
Qed.

Theorem backward_simulation_behavior_improves:
  forall beh2, program_behaves L2 beh2 ->
  exists beh1, program_behaves L1 beh1 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H.
(* L2's initial state is defined. *)
  destruct (classic (exists s1, initial_state L1 s1)) as [[s1 INIT] | NOINIT].
(* L1's initial state is defined too. *)
  exploit (bsim_match_initial_states S); eauto. intros [i [s1' [INIT1' MATCH]]].
  exploit backward_simulation_state_behaves; eauto. intros [beh1 [A B]].
  exists beh1; split; auto. econstructor; eauto.
(* L1 has no initial state *)
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros. elim NOINIT; exists s0; auto.
  apply behavior_improves_bot.
(* L2 has no initial state *)
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros.
  exploit (bsim_initial_states_exist S); eauto. intros [s2 INIT2].
  elim (H0 s2); auto.
  apply behavior_improves_refl.
Qed.

Corollary backward_simulation_same_safe_behavior:
  (forall beh, program_behaves L1 beh -> not_wrong beh) ->
  (forall beh, program_behaves L2 beh -> program_behaves L1 beh).
Proof.
  intros. exploit backward_simulation_behavior_improves; eauto.
  intros [beh' [A B]]. destruct B.
  congruence.
  destruct H1 as [t [C D]]. subst. elim (H (Goes_wrong t)). auto.
Qed.

End BACKWARD_SIMULATIONS.

(** * Program behaviors for the "atomic" construction *)

Section ATOMIC.

Variable RETVAL: Type.
Variable L: semantics RETVAL.
Hypothesis Lwb: well_behaved_traces L.

Remark atomic_finish: forall s t, output_trace t -> Star (atomic L) (t, s) t (E0, s).
Proof.
  induction t; intros.
  apply star_refl.
  simpl in H; destruct H. eapply star_left; eauto.
  simpl. apply atomic_step_continue; auto. simpl; auto. auto.
Qed.

Lemma step_atomic_plus:
  forall s1 t s2, Step L s1 t s2 -> Plus (atomic L) (E0,s1) t (E0,s2).
Proof.
  intros.  destruct t.
  apply plus_one. simpl; apply atomic_step_silent; auto.
  exploit Lwb; eauto. simpl; intros.
  eapply plus_left. eapply atomic_step_start; eauto. eapply atomic_finish; eauto. auto.
Qed.

Lemma star_atomic_star:
  forall s1 t s2, Star L s1 t s2 -> Star (atomic L) (E0,s1) t (E0,s2).
Proof.
  induction 1. apply star_refl. eapply star_trans with (s2 := (E0,s2)).
  apply plus_star. eapply step_atomic_plus; eauto. eauto. auto.
Qed.

Lemma atomic_forward_simulation: forward_simulation L (atomic L).
Proof.
  set (ms := fun (s: state L) (ts: state (atomic L)) => ts = (E0,s)).
  apply forward_simulation_plus with ms; intros.
  auto.
  exists (E0,s1); split. simpl; auto. red; auto.
  red in H. subst s2. simpl; auto.
  red in H0. subst s2. exists (E0,s1'); split.
  apply step_atomic_plus; auto. red; auto.
Qed.

Lemma atomic_star_star_gen:
  forall ts1 t ts2, Star (atomic L) ts1 t ts2 ->
  exists t', Star L (snd ts1) t' (snd ts2) /\ fst ts1 ** t' = t ** fst ts2.
Proof.
  induction 1.
  exists E0; split. apply star_refl. traceEq.
  destruct IHstar as [t' [A B]].
  simpl in H; inv H; simpl in *.
  exists t'; split. eapply star_left; eauto. auto.
  exists (ev :: t0 ** t'); split. eapply star_left; eauto. rewrite B; auto.
  exists t'; split. auto. rewrite B; auto.
Qed.

Lemma atomic_star_star:
  forall s1 t s2, Star (atomic L) (E0,s1) t (E0,s2) -> Star L s1 t s2.
Proof.
  intros. exploit atomic_star_star_gen; eauto. intros [t' [A B]].
  simpl in *. replace t with t'. auto. subst; traceEq.
Qed.

Lemma atomic_forever_silent_forever_silent:
  forall s, Forever_silent (atomic L) s -> Forever_silent L (snd s).
Proof.
  cofix COINDHYP; intros. inv H. inv H0.
  apply forever_silent_intro with (snd (E0, s')). auto. apply COINDHYP; auto.
Qed.

Remark star_atomic_output_trace:
  forall s t t' s',
  Star (atomic L) (E0, s) t (t', s') -> output_trace t'.
Proof.
  assert (forall ts1 t ts2, Star (atomic L) ts1 t ts2 ->
          output_trace (fst ts1) -> output_trace (fst ts2)).
  induction 1; intros. auto. inv H; simpl in *.
  apply IHstar. auto.
  apply IHstar. exploit Lwb; eauto.
  destruct H2. apply IHstar. auto.
  intros. change t' with (fst (t',s')). eapply H; eauto. simpl; auto.
Qed.

Lemma atomic_forever_reactive_forever_reactive:
  forall s T, Forever_reactive (atomic L) (E0,s) T -> Forever_reactive L s T.
Proof.
  assert (forall t s T, Forever_reactive (atomic L) (t,s) T ->
          exists T', Forever_reactive (atomic L) (E0,s) T' /\ T = t *** T').
  induction t; intros. exists T; auto.
  inv H. inv H0. congruence. simpl in H; inv H.
  destruct (IHt s (t2***T0)) as [T' [A B]]. eapply star_forever_reactive; eauto.
  exists T'; split; auto. simpl. congruence.

  cofix COINDHYP; intros. inv H0. destruct s2 as [t2 s2].
  destruct (H _ _ _ H3) as [T' [A B]].
  assert (Star (atomic L) (E0, s) (t**t2) (E0, s2)).
    eapply star_trans. eauto. apply atomic_finish. eapply star_atomic_output_trace; eauto. auto.
  replace (t *** T0) with ((t ** t2) *** T'). apply forever_reactive_intro with s2.
  apply atomic_star_star; auto. destruct t; simpl in *; unfold E0 in *; congruence.
  apply COINDHYP. auto.
  subst T0; traceEq.
Qed.

Theorem atomic_behaviors:
  forall beh, program_behaves L beh <-> program_behaves (atomic L) beh.
Proof.
  intros; split; intros.
  (* L -> atomic L *)
  exploit forward_simulation_behavior_improves. eapply atomic_forward_simulation. eauto.
  intros [beh2 [A B]]. red in B. destruct B as [EQ | [t [C D]]].
  congruence.
  subst beh. inv H. inv H1.
  apply program_runs with (E0,s). simpl; auto.
  apply state_goes_wrong with (E0,s'). apply star_atomic_star; auto.
  red; intros; red; intros. inv H. eelim H3; eauto. eelim H3; eauto.
  intros; red; intros. simpl in H. destruct H. eelim H4; eauto.
  apply program_goes_initially_wrong.
  intros; red; intros. simpl in H; destruct H. eelim H1; eauto.
  (* atomic L -> L *)
  inv H.
  (* initial state defined *)
  destruct s as [t s]. simpl in H0. destruct H0; subst t.
  apply program_runs with s; auto.
  inv H1.
  (* termination *)
  destruct s' as [t' s']. simpl in H2; destruct H2; subst t'.
  econstructor. eapply atomic_star_star; eauto. auto.
  (* silent divergence *)
  destruct s' as [t' s'].
  assert (t' = E0). inv H2. inv H1; auto. subst t'.
  econstructor. eapply atomic_star_star; eauto.
  change s' with (snd (E0,s')). apply atomic_forever_silent_forever_silent. auto.
  (* reactive divergence *)
  econstructor. apply atomic_forever_reactive_forever_reactive. auto.
  (* going wrong *)
  destruct s' as [t' s'].
  assert (t' = E0).
    destruct t'; auto. eelim H2. simpl. apply atomic_step_continue.
    eapply star_atomic_output_trace; eauto.
  subst t'. econstructor. apply atomic_star_star; eauto.
  red; intros; red; intros. destruct t0.
  elim (H2 E0 (E0,s'0)). constructor; auto.
  elim (H2 (e::nil) (t0,s'0)). constructor; auto.
  intros; red; intros. elim (H3 r). simpl; auto.
  (* initial state undefined *)
  apply program_goes_initially_wrong.
  intros; red; intros. elim (H0 (E0,s)); simpl; auto.
Qed.

End ATOMIC.

(** * Additional results about infinite reduction sequences *)

(** We now show that any infinite sequence of reductions is either of
  the "reactive" kind or of the "silent" kind (after a finite number
  of non-silent transitions).  The proof necessitates the axiom of
  excluded middle.  This result is used below to relate
  the coinductive big-step semantics for divergence with the
  small-step notions of divergence. *)

Unset Implicit Arguments.

Section INF_SEQ_DECOMP.

Variable genv: Type.
Variable state: Type.
Variable step: genv -> state -> trace -> state -> Prop.

Variable ge: genv.

Inductive tstate: Type :=
  ST: forall (s: state) (T: traceinf), forever step ge s T -> tstate.

Definition state_of_tstate (S: tstate): state :=
  match S with ST s T F => s end.
Definition traceinf_of_tstate (S: tstate) : traceinf :=
  match S with ST s T F => T end.

Inductive tstep: trace -> tstate -> tstate -> Prop :=
  | tstep_intro: forall s1 t T s2 S F,
      tstep t (ST s1 (t *** T) (@forever_intro genv state step ge s1 t s2 T S F))
              (ST s2 T F).

Inductive tsteps: tstate -> tstate -> Prop :=
  | tsteps_refl: forall S, tsteps S S
  | tsteps_left: forall t S1 S2 S3, tstep t S1 S2 -> tsteps S2 S3 -> tsteps S1 S3.

Remark tsteps_trans:
  forall S1 S2, tsteps S1 S2 -> forall S3, tsteps S2 S3 -> tsteps S1 S3.
Proof.
  induction 1; intros. auto. econstructor; eauto.
Qed.

Let treactive (S: tstate) : Prop :=
  forall S1,
  tsteps S S1 ->
  exists S2, exists S3, exists t, tsteps S1 S2 /\ tstep t S2 S3 /\ t <> E0.

Let tsilent (S: tstate) : Prop :=
  forall S1 t S2, tsteps S S1 -> tstep t S1 S2 -> t = E0.

Lemma treactive_or_tsilent:
  forall S, treactive S \/ (exists S', tsteps S S' /\ tsilent S').
Proof.
  intros. destruct (classic (exists S', tsteps S S' /\ tsilent S')).
  auto.
  left. red; intros.
  generalize (not_ex_all_not _ _ H S1). intros.
  destruct (not_and_or _ _ H1). contradiction.
  unfold tsilent in H2.
  generalize (not_all_ex_not _ _ H2). intros [S2 A].
  generalize (not_all_ex_not _ _ A). intros [t B].
  generalize (not_all_ex_not _ _ B). intros [S3 C].
  generalize (imply_to_and _ _ C). intros [D F].
  generalize (imply_to_and _ _ F). intros [G J].
  exists S2; exists S3; exists t. auto.
Qed.

Lemma tsteps_star:
  forall S1 S2, tsteps S1 S2 ->
  exists t, star step ge (state_of_tstate S1) t (state_of_tstate S2)
         /\ traceinf_of_tstate S1 = t *** traceinf_of_tstate S2.
Proof.
  induction 1.
  exists E0; split. apply star_refl. auto.
  inv H. destruct IHtsteps as [t' [A B]].
  exists (t ** t'); split.
  simpl; eapply star_left; eauto.
  simpl in *. subst T. traceEq.
Qed.

Lemma tsilent_forever_silent:
  forall S,
  tsilent S -> forever_silent step ge (state_of_tstate S).
Proof.
  cofix COINDHYP; intro S. case S. intros until f. simpl. case f. intros.
  assert (tstep t (ST s1 (t *** T0) (forever_intro s1 t s0 f0))
                  (ST s2 T0 f0)).
    constructor.
  assert (t = E0).
    red in H. eapply H; eauto. apply tsteps_refl.
  apply forever_silent_intro with (state_of_tstate (ST s2 T0 f0)).
  rewrite <- H1. assumption.
  apply COINDHYP.
  red; intros. eapply H. eapply tsteps_left; eauto. eauto.
Qed.

Lemma treactive_forever_reactive:
  forall S,
  treactive S -> forever_reactive step ge (state_of_tstate S) (traceinf_of_tstate S).
Proof.
  cofix COINDHYP; intros.
  destruct (H S) as [S1 [S2 [t [A [B C]]]]]. apply tsteps_refl.
  destruct (tsteps_star _ _ A) as [t' [P Q]].
  inv B. simpl in *. rewrite Q. rewrite <- Eappinf_assoc.
  apply forever_reactive_intro with s2.
  eapply star_right; eauto.
  red; intros. destruct (Eapp_E0_inv _ _ H0). contradiction.
  change (forever_reactive step ge (state_of_tstate (ST s2 T F)) (traceinf_of_tstate (ST s2 T F))).
  apply COINDHYP.
  red; intros. apply H.
  eapply tsteps_trans. eauto.
  eapply tsteps_left. constructor. eauto.
Qed.

Theorem forever_silent_or_reactive:
  forall s T,
  forever step ge s T ->
  forever_reactive step ge s T \/
  exists t, exists s', exists T',
  star step ge s t s' /\ forever_silent step ge s' /\ T = t *** T'.
Proof.
  intros.
  destruct (treactive_or_tsilent (ST s T H)).
  left.
  change (forever_reactive step ge (state_of_tstate (ST s T H)) (traceinf_of_tstate (ST s T H))).
  apply treactive_forever_reactive. auto.
  destruct H0 as [S' [A B]].
  exploit tsteps_star; eauto. intros [t [C D]]. simpl in *.
  right. exists t; exists (state_of_tstate S'); exists (traceinf_of_tstate S').
  split. auto.
  split. apply tsilent_forever_silent. auto.
  auto.
Qed.

End INF_SEQ_DECOMP.

Set Implicit Arguments.

(** * Big-step semantics and program behaviors *)

Section BIGSTEP_BEHAVIORS.

Variable RETVAL: Type.
Variable B: bigstep_semantics RETVAL.
Variable L: semantics RETVAL.
Hypothesis sound: bigstep_sound B L.

Lemma behavior_bigstep_terminates:
  forall t r,
  bigstep_terminates B t r -> program_behaves L (Terminates t r).
Proof.
  intros. exploit (bigstep_terminates_sound sound); eauto.
  intros [s1 [s2 [P [Q R]]]].
  econstructor; eauto. econstructor; eauto.
Qed.

Lemma behavior_bigstep_diverges:
  forall T,
  bigstep_diverges B T ->
  program_behaves L (Reacts T)
  \/ exists t, program_behaves L (Diverges t) /\ traceinf_prefix t T.
Proof.
  intros. exploit (bigstep_diverges_sound sound); eauto. intros [s1 [P Q]].
  exploit forever_silent_or_reactive; eauto. intros [X | [t [s' [T' [X [Y Z]]]]]].
  left. econstructor; eauto. constructor; auto.
  right. exists t; split. econstructor; eauto. econstructor; eauto. exists T'; auto.
Qed.

End BIGSTEP_BEHAVIORS.


(* Generated by Frama-C WP *)

Goal typed_cast_memset_loop_invariant_3_established.
Hint established,memset.
Proof.
  Require Import Lia.
  intros.
  unfold x_1.
  unfold land.
  simpl.
  unfold x.

  assert ((land 3 (to_uint32 (- int_of_addr a))) <= 3)%Z. {
    apply uint_land_range; lia.
  }

  assert (i - land 3 (to_uint32 (- int_of_addr a)) >= 0)%Z. {
    auto with zarith.
  }

  assert (i - land 3 (to_uint32 (- int_of_addr a)) <= i)%Z. {
    apply Z.le_sub_nonneg.
    apply uint_land_range.
    lia.
  }

  assert  (Zbits.land (i - land 3 (to_uint32 (- int_of_addr a))) 4294967292 <=
          (i - land 3 (to_uint32 (- int_of_addr a))))%Z. {
    apply Zbits.uint_land_range.
    auto with zarith.
  }

  assert (is_uint32 (i - land 3 (to_uint32 (- int_of_addr a)))). {
    unfold is_uint32 in *.
    lia.
  }

  split.
  + rewrite id_uint32. { rewrite land_commut; try lia. } auto.
  + rewrite id_uint32. { apply Zbits.uint_land_range; lia.  } auto.
(* auto with zarith. *)
Qed.

Goal typed_cast_memset_loop_invariant_established.
Hint established,memset.
Proof.
  Require Import Lia.
  intros.
  unfold x_1.
  unfold land.
  simpl.
  unfold x.

  assert ((land 3 (to_uint32 (- int_of_addr a))) <= 3)%Z. {
    apply uint_land_range; lia.
  }

  assert (i - land 3 (to_uint32 (- int_of_addr a)) >= 0)%Z. {
    auto with zarith.
  }

  assert (i - land 3 (to_uint32 (- int_of_addr a)) <= i)%Z. {
    apply Z.le_sub_nonneg.
    apply uint_land_range.
    lia.
  }

  assert  (Zbits.land (i - land 3 (to_uint32 (- int_of_addr a))) 4294967292 <=
          (i - land 3 (to_uint32 (- int_of_addr a))))%Z. {
    apply Zbits.uint_land_range.
    auto with zarith.
  }

  assert (is_uint32 (i - land 3 (to_uint32 (- int_of_addr a)))). {
    unfold is_uint32 in *.
    lia.
  }

  split.
  + rewrite id_uint32. { rewrite land_commut; try lia. } auto.
  + rewrite id_uint32. { apply Zbits.uint_land_range; lia.  } auto.
Qed.