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 X Y T PX PY Bprime Cprime : Universe, ((wd_ A B /\ (wd_ A T /\ (wd_ PX A /\ (wd_ PY A /\ (wd_ T B /\ (wd_ B Y /\ (wd_ A Y /\ (wd_ B X /\ (wd_ A X /\ (wd_ PY Cprime /\ (wd_ B Bprime /\ (wd_ A Cprime /\ (wd_ A Bprime /\ (col_ PX A T /\ (col_ PY A T /\ (col_ A PX PY /\ (col_ PX A B /\ (col_ PY A Cprime /\ col_ B A Bprime)))))))))))))))))) -> col_ T A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export DEX_ElemLemmas.

Import DEX_BigStepWithTypes.DEX_BigStepWithTypes DEX_BigStep.DEX_Dom DEX_Prog.

Section p.
  Variable kobs : L.t.
  Variable p : DEX_ExtendedProgram.

Lemma some_eq: forall (A:Type) (x y:A), Some x = Some y -> x = y.
Proof. intros; inversion H; auto. Qed.

Lemma leql_join_eq: forall (k k1 k2: L.t) , k2 = L.join k k1 -> L.leql k k2.
Proof. intros. subst; apply leql_join2; apply L.leql_refl; auto. Qed.

Ltac indist2_intra_normal_aux Hindistreg rn:=
  specialize Hindistreg with rn;
  inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist];
  try (constructor 1 with (k:=lvl) (k':=lvl');
  try (rewrite MapList.get_update2; auto); auto);
  try (constructor 2; rewrite ?DEX_Registers.get_update_old; auto).

Lemma indist2_intra_normal :
 forall se reg m sgn pc pc2 pc2' i r1 rt1 h1 b1
      r1' rt1' h1' b1' r2 rt2 h2 b2 r2' rt2' h2' b2',
   instructionAt m pc = Some i ->

   NormalStep kobs p se reg m sgn i (pc,(h1,r1)) rt1 b1 (pc2,(h2,r2)) rt2 b2 ->
   NormalStep kobs p se reg m sgn i (pc,(h1',r1')) rt1' b1' (pc2',(h2',r2')) rt2' b2'->
   st_in kobs (DEX_ft p) b1 b1' rt1 rt1' (pc,h1,r1) (pc,h1',r1') ->

   st_in kobs (DEX_ft p) b2 b2' rt2 rt2' (pc2,h2,r2) (pc2',h2',r2').
Proof.
  intros se reg m sgn pc pc2 pc2' i r1 rt1 h1 b1
      r1' rt1' h1' b1' r2 rt2 h2 b2 r2' rt2' h2' b2'
    Hins Hstep Hstep' Hindist.
  inversion_clear Hindist.
  destruct i; simpl in Hstep, Hstep';
  inversion_clear Hstep in Hins Hstep' H H0;
  inversion_clear Hstep' in H H0;
  constructor; auto.
  (* DEX_Move *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k0 (se pc)) (k':=L.join k1 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H9; inversion H9; subst; apply not_leql_join1; auto.
    rewrite Hget' in H19; inversion H19; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H7 in Hvalueindist; rewrite <- H17 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Const *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    constructor 1. constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Ineg *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H7; inversion H7; subst; apply not_leql_join1; auto.
    rewrite Hget' in H16; inversion H16; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H6 in Hvalueindist; rewrite <- H15 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H17. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Inot *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H7; inversion H7; subst; apply not_leql_join1; auto.
    rewrite Hget' in H16; inversion H16; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H6 in Hvalueindist; rewrite <- H15 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H17. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX I2b *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H7; inversion H7; subst; apply not_leql_join1; auto.
    rewrite Hget' in H16; inversion H16; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H6 in Hvalueindist; rewrite <- H15 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H17. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_I2s *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H7; inversion H7; subst; apply not_leql_join1; auto.
    rewrite Hget' in H16; inversion H16; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H6 in Hvalueindist; rewrite <- H15 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H17. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_IBinop *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    assert (Hindistreg' := Hindistreg).
    specialize Hindistreg with (rn:=ra).
    specialize Hindistreg' with (rn:=rb).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k1 (L.join k2 (se pc))) (k':=L.join k0 (L.join k3 (se pc)));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H10; inversion H10; subst; apply not_leql_join1; auto.
    rewrite Hget' in H23; inversion H23; subst; apply not_leql_join1; auto.
    (* case of register b *)
    inversion Hindistreg' as [lvl2 lvl2' Hget2 Hget2' Hleq2 Hleq2' | Hvalueindist'].
    constructor 1 with (k:=L.join k1 (L.join k2 (se pc))) (k':=L.join k0 (L.join k3 (se pc)));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget2 in H11; inversion H11; subst.
    apply not_leql_join2; apply not_leql_join1; auto.
    rewrite Hget2' in H24; inversion H24; subst.
    apply not_leql_join2; apply not_leql_join1; auto.
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    rewrite <- H8 in Hvalueindist; rewrite <- H21 in Hvalueindist.
    rewrite <- H9 in Hvalueindist'; rewrite <- H22 in Hvalueindist'.
    inversion Hvalueindist as [v v' Hin | Hnone]; inversion Hvalueindist' as [v2 v2' Hin' | Hnone'];
    inversion Hin; inversion Hin'. repeat (constructor); auto.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_IBinopConst *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=r).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H7; inversion H7; subst; apply not_leql_join1; auto.
    rewrite Hget' in H16; inversion H16; subst; apply not_leql_join1; auto.
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    rewrite <- H6 in Hvalueindist; rewrite <- H15 in Hvalueindist.
    inversion Hvalueindist as [val val' Hin | Hnone]; inversion Hin;
    repeat (constructor); auto.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Iget *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=ro).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join ko (L.join (se pc) (DEX_ft p f)))
        (k':=L.join ko0 (L.join (se pc) (DEX_ft p f)));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H12; inversion H12; subst; apply not_leql_join1; auto.
    rewrite Hget' in H25; inversion H25; subst; apply not_leql_join1; auto.
    generalize (L.leql_dec (DEX_ft p f) (kobs)).
    intro Hft; inversion Hft.
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    constructor.
    rewrite <- H7 in Hvalueindist; rewrite <- H20 in Hvalueindist; inversion Hvalueindist.
    apply hp_in_getfield with (kobs:=kobs) (p:=p) (h2:=h2) (h2':=h2') (loc:=loc)
      (loc0:=loc0) (cn:=cn) (cn0:=cn0) (f:=f); auto.
    constructor 1 with (k:=L.join ko (L.join (se pc) (DEX_ft p f)))
        (k':=L.join ko0 (L.join (se pc) (DEX_ft p f)));
      try (rewrite MapList.get_update1; auto); auto;
    apply not_leql_join2; apply not_leql_join2; auto.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Iput *)
    (* heap indist *)
  rewrite H29; rewrite H12.
  generalize (L.leql_dec (DEX_ft p f) (kobs)).
    intro Hft; inversion_clear Hft.
  inversion H as [Heqset Hindistreg].
  apply hp_in_putfield_ffun with (cn:=cn) (cn':=cn0); auto.
  specialize Hindistreg with (rn:=rs).
  inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
  rewrite Hget in H14; inversion H14; subst.
  apply not_leql_trans with (k2:=(DEX_ft p f)) in Hleq; auto.
  contradiction.
  rewrite <- H25 in Hvalueindist; rewrite <- H8 in Hvalueindist; inversion Hvalueindist; auto.
  specialize Hindistreg with ro.
  inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
  rewrite Hget in H13; inversion H13; subst.
  apply not_leql_trans with (k2:=(DEX_ft p f)) in Hleq; auto.
  contradiction.
  rewrite <- H24 in Hvalueindist; rewrite <- H7 in Hvalueindist; inversion Hvalueindist; auto.
  apply hp_in_putfield_high with (cn:=cn) (cn':=cn0); auto.
  (* DEX_New *)
  subst.
  inversion H as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    unfold newb. destruct L.leql_dec.
    (* update Low *)
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    constructor 1.
    apply Value_in_extends with (kobs:=kobs) (p:=p) (h1:=h1) (h2:=h1'); auto.
    apply DEX_Heap.new_fresh_location with (p:=DEX_prog p) (h':=h2) (lt:=(DEX_Heap.DEX_LocationObject c)); auto.
    apply DEX_Heap.new_fresh_location with (p:=DEX_prog p) (h':=h2') (lt:=(DEX_Heap.DEX_LocationObject c)); auto.
    (* update High *)
    apply Reg_in_upd_high; auto.
    (* rn <> rt *)
    unfold newb. destruct L.leql_dec.
    indist2_intra_normal_aux Hindistreg rn.
      apply ffun_extends_val_in_opt; auto.
    indist2_intra_normal_aux Hindistreg rn.
    (* heap indist *)
  unfold newb. destruct (L.leql_dec (se pc) kobs); auto.
  apply ffun_extends_hp_in with (c:=c) (h:=h1) (h':=h1'); auto.
  apply ffun_extends_hp_in_simpl with (c:=c) (c':=c) (h:=h1) (h':=h1') (loc:=loc) (loc':=loc0); auto.
Qed.

End p.


From Hammer Require Import Hammer.

From compcert Require Import Raux.
From compcert Require Import Defs.
From compcert Require Import Round_pred.
From compcert Require Import Generic_fmt.
From compcert Require Import Float_prop.
From compcert Require Import Ulp.

Notation ZnearestE := (Znearest (fun x => negb (Z.even x))).

Section Fcore_rnd_NE.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.

Notation format := (generic_format beta fexp).
Notation canonical := (canonical beta fexp).

Definition NE_prop (_ : R) f :=
exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true.

Definition Rnd_NE_pt :=
Rnd_NG_pt format NE_prop.

Definition DN_UP_parity_pos_prop :=
forall x xd xu,
(0 < x)%R ->
~ format x ->
canonical xd ->
canonical xu ->
F2R xd = round beta fexp Zfloor x ->
F2R xu = round beta fexp Zceil x ->
Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Definition DN_UP_parity_prop :=
forall x xd xu,
~ format x ->
canonical xd ->
canonical xu ->
F2R xd = round beta fexp Zfloor x ->
F2R xu = round beta fexp Zceil x ->
Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Lemma DN_UP_parity_aux :
DN_UP_parity_pos_prop ->
DN_UP_parity_prop.
Proof. hammer_hook "Round_NE" "Round_NE.DN_UP_parity_aux".
intros Hpos x xd xu Hfx Hd Hu Hxd Hxu.
destruct (total_order_T 0 x) as [[Hx|Hx]|Hx].

exact (Hpos x xd xu Hx Hfx Hd Hu Hxd Hxu).
elim Hfx.
rewrite <- Hx.
apply generic_format_0.

assert (Hx': (0 < -x)%R).
apply Ropp_lt_cancel.
now rewrite Ropp_involutive, Ropp_0.
destruct xd as (md, ed).
destruct xu as (mu, eu).
simpl.
rewrite <- (Bool.negb_involutive (Z.even mu)).
apply f_equal.
apply sym_eq.
rewrite <- (Z.even_opp mu), <- (Z.even_opp md).
change (Z.even (Fnum (Float beta (-md) ed)) = negb (Z.even (Fnum (Float beta (-mu) eu)))).
apply (Hpos (-x)%R _ _ Hx').
intros H.
apply Hfx.
rewrite <- Ropp_involutive.
now apply generic_format_opp.
now apply canonical_opp.
now apply canonical_opp.
rewrite round_DN_opp, F2R_Zopp.
now apply f_equal.
rewrite round_UP_opp, F2R_Zopp.
now apply f_equal.
Qed.

Class Exists_NE :=
exists_NE : Z.even beta = false \/ forall e,
((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e).

Context { exists_NE_ : Exists_NE }.

Theorem DN_UP_parity_generic_pos :
DN_UP_parity_pos_prop.
Proof with auto with typeclass_instances. hammer_hook "Round_NE" "Round_NE.DN_UP_parity_generic_pos".
intros x xd xu H0x Hfx Hd Hu Hxd Hxu.
destruct (mag beta x) as (ex, Hexa).
specialize (Hexa (Rgt_not_eq _ _ H0x)).
generalize Hexa. intros Hex.
rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex.
destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe].

assert (Hd3 : Fnum xd = Z0).
apply eq_0_F2R with beta (Fexp xd).
change (F2R xd = R0).
rewrite Hxd.
apply round_DN_small_pos with (1 := Hex) (2 := Hxe).
assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- F2R_change_exp.
rewrite F2R_bpow.
apply sym_eq.
rewrite Hxu.
apply sym_eq.
apply round_UP_small_pos with (1 := Hex) (2 := Hxe).
now apply valid_exp.
rewrite Hd3, Hu3.
rewrite Zmult_1_l.
simpl.
destruct exists_NE_ as [H|H].
apply Zeven_Zpower_odd with (2 := H).
apply Zle_minus_le_0.
now apply valid_exp.
rewrite (proj2 (H ex)).
now rewrite Zminus_diag.
exact Hxe.

assert (Hd4: (bpow (ex - 1) <= Rabs (F2R xd) < bpow ex)%R).
rewrite Rabs_pos_eq.
rewrite Hxd.
split.
apply (round_DN_pt beta fexp x).
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
omega.
apply Hex.
apply Rle_lt_trans with (2 := proj2 Hex).
apply (round_DN_pt beta fexp x).
rewrite Hxd.
apply (round_DN_pt beta fexp x).
apply generic_format_0.
now apply Rlt_le.
assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp.
assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R).
rewrite Hxu, Hxd.
now apply round_UP_DN_ulp.
destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2].

elim (Rlt_not_le _ _ Hu2).
rewrite Hxu.
apply round_bounded_large_pos...

assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- Hu2.
apply sym_eq.
rewrite <- F2R_change_exp.
apply F2R_bpow.
exact Hxe2.
assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)).
assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))).
unfold F2R. simpl.
rewrite minus_IZR.
unfold Rminus.
rewrite Rmult_plus_distr_r.
rewrite IZR_Zpower, <- bpow_plus.
ring_simplify (ex - fexp ex + fexp ex)%Z.
rewrite Hu2, Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold cexp.
rewrite mag_unique with beta x ex.
unfold F2R.
simpl. ring.
rewrite Rabs_pos_eq.
exact Hex.
now apply Rlt_le.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
apply canonical_unique with (1 := Hd) (3 := H).
apply (f_equal fexp).
rewrite <- H.
apply sym_eq.
now apply mag_unique.
rewrite Hd3, Hu3.
unfold Fnum.
rewrite Z.even_mul. simpl.
unfold Zminus at 2.
rewrite Z.even_add.
rewrite eqb_sym. simpl.
fold (negb (Z.even (beta ^ (ex - fexp ex)))).
rewrite Bool.negb_involutive.
rewrite (Z.even_pow beta (ex - fexp ex)). 2: omega.
destruct exists_NE_.
rewrite H.
apply Zeven_Zpower_odd with (2 := H).
now apply Zle_minus_le_0.
apply Z.even_pow.
specialize (H ex).
omega.

revert Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold F2R.
rewrite Hd, Hu.
unfold cexp.
rewrite mag_unique with beta (F2R xu) ex.
rewrite mag_unique with (1 := Hd4).
rewrite mag_unique with (1 := Hexa).
intros H.
replace (Fnum xu) with (Fnum xd + 1)%Z.
rewrite Z.even_add.
now apply eqb_sym.
apply sym_eq.
apply eq_IZR.
rewrite plus_IZR.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
rewrite H.
simpl. ring.
apply Rgt_not_eq.
apply bpow_gt_0.
rewrite Rabs_pos_eq.
split.
apply Rle_trans with (1 := proj1 Hex).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
exact Hu2.
apply Rlt_le.
apply Rlt_le_trans with (1 := H0x).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
Qed.

Theorem DN_UP_parity_generic :
DN_UP_parity_prop.
Proof. hammer_hook "Round_NE" "Round_NE.DN_UP_parity_generic".
apply DN_UP_parity_aux.
apply DN_UP_parity_generic_pos.
Qed.

Theorem Rnd_NE_pt_total :
round_pred_total Rnd_NE_pt.
Proof. hammer_hook "Round_NE" "Round_NE.Rnd_NE_pt_total".
apply satisfies_any_imp_NG.
now apply generic_format_satisfies_any.
intros x d u Hf Hd Hu.
generalize (proj1 Hd).
unfold generic_format.
set (ed := cexp beta fexp d).
set (md := Ztrunc (scaled_mantissa beta fexp d)).
intros Hd1.
case_eq (Z.even md) ; [ intros He | intros Ho ].
right.
exists (Float beta md ed).
unfold Generic_fmt.canonical.
rewrite <- Hd1.
now repeat split.
left.
generalize (proj1 Hu).
unfold generic_format.
set (eu := cexp beta fexp u).
set (mu := Ztrunc (scaled_mantissa beta fexp u)).
intros Hu1.
rewrite Hu1.
eexists ; repeat split.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)).
simpl.
now rewrite Ho.
exact Hf.
unfold Generic_fmt.canonical.
now rewrite <- Hd1.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_monotone :
round_pred_monotone Rnd_NE_pt.
Proof. hammer_hook "Round_NE" "Round_NE.Rnd_NE_pt_monotone".
apply Rnd_NG_pt_monotone.
intros x d u Hd Hdn Hu Hun (cd, (Hd1, Hd2)) (cu, (Hu1, Hu2)).
destruct (Req_dec x d) as [Hx|Hx].
rewrite <- Hx.
apply sym_eq.
apply Rnd_UP_pt_idempotent with (1 := Hu).
rewrite Hx.
apply Hd.
rewrite (DN_UP_parity_aux DN_UP_parity_generic_pos x cd cu) in Hu2 ; try easy.
now rewrite (proj2 Hd2) in Hu2.
intros Hf.
apply Hx.
apply sym_eq.
now apply Rnd_DN_pt_idempotent with (1 := Hd).
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_round :
round_pred Rnd_NE_pt.
Proof. hammer_hook "Round_NE" "Round_NE.Rnd_NE_pt_round".
split.
apply Rnd_NE_pt_total.
apply Rnd_NE_pt_monotone.
Qed.

Lemma round_NE_pt_pos :
forall x,
(0 < x)%R ->
Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances. hammer_hook "Round_NE" "Round_NE.round_NE_pt_pos".
intros x Hx.
split.
now apply round_N_pt.
unfold NE_prop.
set (mx := scaled_mantissa beta fexp x).
set (xr := round beta fexp ZnearestE x).
destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm].

left.
exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)).
split.
apply round_N_pt...
split.
unfold Generic_fmt.canonical. simpl.
apply f_equal.
apply round_N_pt...
simpl.
unfold xr, round, Znearest.
fold mx.
rewrite Hm.
rewrite Rcompare_Eq. 2: apply refl_equal.
case_eq (Z.even (Zfloor mx)) ; intros Hmx.

change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true).
destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr].
rewrite (Rle_antisym _ _ Hr).
unfold scaled_mantissa.
rewrite Rmult_0_l.
now rewrite Ztrunc_IZR.
rewrite <- (round_0 beta fexp Zfloor).
apply round_le...
now apply Rlt_le.
rewrite scaled_mantissa_DN...
now rewrite Ztrunc_IZR.

change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true).
destruct (mag beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex.
destruct (Z_lt_le_dec (fexp ex) ex) as [He|He].

assert (Hu := round_bounded_large_pos _ _ Zceil _ _ He Hex).
assert (Hfc: Zceil mx = (Zfloor mx + 1)%Z).
apply Zceil_floor_neq.
intros H.
rewrite H in Hm.
unfold Rminus in Hm.
rewrite Rplus_opp_r in Hm.
elim (Rlt_irrefl 0).
rewrite Hm at 2.
apply Rinv_0_lt_compat.
now apply IZR_lt.
destruct (proj2 Hu) as [Hu'|Hu'].

unfold scaled_mantissa.
rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu').
unfold round, F2R. simpl.
rewrite cexp_fexp_pos with (1 := Hex).
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
rewrite Ztrunc_IZR.
fold mx.
rewrite Hfc.
now rewrite Z.even_add, Hmx.

rewrite Hu'.
unfold scaled_mantissa, cexp.
rewrite mag_bpow.
rewrite <- bpow_plus, <- IZR_Zpower.
rewrite Ztrunc_IZR.
case_eq (Z.even beta) ; intros Hr.
destruct exists_NE_ as [Hs|Hs].
now rewrite Hs in Hr.
destruct (Hs ex) as (H,_).
rewrite Z.even_pow.
exact Hr.
omega.
assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
replace (Zfloor mx) with (Zceil mx + -1)%Z by omega.
rewrite Z.even_add.
apply eqb_true.
unfold mx.
replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)).
rewrite Zeven_Zpower_odd with (2 := Hr).
easy.
omega.
apply eq_IZR.
rewrite IZR_Zpower. 2: omega.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
unfold Zminus.
rewrite bpow_plus.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r.
pattern (fexp ex) ; rewrite <- cexp_fexp_pos with (1 := Hex).
now apply sym_eq.
apply Rgt_not_eq.
apply bpow_gt_0.
generalize (proj1 (valid_exp ex) He).
omega.

assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
unfold mx, scaled_mantissa.
rewrite cexp_fexp_pos with (1 := Hex).
now rewrite mantissa_DN_small_pos.

right.
intros g Hg.
destruct (Req_dec x g) as [Hxg|Hxg].
rewrite <- Hxg.
apply sym_eq.
apply round_generic...
rewrite Hxg.
apply Hg.
set (d := round beta fexp Zfloor x).
set (u := round beta fexp Zceil x).
apply Rnd_N_pt_unique with (d := d) (u := u) (4 := Hg).
now apply round_DN_pt.
now apply round_UP_pt.
2: now apply round_N_pt.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
unfold d, u, round, F2R. simpl. fold mx.
rewrite <- 2!Rmult_minus_distr_r.
intros H.
apply Rmult_eq_reg_r in H.
apply Hm.
apply Rcompare_Eq_inv.
rewrite Rcompare_floor_ceil_middle.
now apply Rcompare_Eq.
contradict Hxg.
apply sym_eq.
apply Rnd_N_pt_idempotent with (1 := Hg).
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
fold mx.
rewrite <- Hxg.
change (IZR (Zfloor mx) * bpow (cexp beta fexp x))%R with d.
now eapply round_DN_pt.
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.

Theorem round_NE_opp :
forall x,
round beta fexp ZnearestE (-x) = (- round beta fexp ZnearestE x)%R.
Proof. hammer_hook "Round_NE" "Round_NE.round_NE_opp".
intros x.
unfold round. simpl.
rewrite scaled_mantissa_opp, cexp_opp.
rewrite Znearest_opp.
rewrite <- F2R_Zopp.
apply (f_equal (fun v => F2R (Float beta (-v) _))).
set (m := scaled_mantissa beta fexp x).
unfold Znearest.
case Rcompare ; trivial.
apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)).
rewrite Bool.negb_involutive.
rewrite Z.even_opp.
rewrite Z.even_add.
now rewrite eqb_sym.
Qed.

Lemma round_NE_abs:
forall x : R,
round beta fexp ZnearestE (Rabs x) = Rabs (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances. hammer_hook "Round_NE" "Round_NE.round_NE_abs".
intros x.
apply sym_eq.
unfold Rabs at 2.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite round_NE_opp.
apply Rabs_left1.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rlt_le.
apply Rabs_pos_eq.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rge_le.
Qed.

Theorem round_NE_pt :
forall x,
Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances. hammer_hook "Round_NE" "Round_NE.round_NE_pt".
intros x.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
apply Rnd_NG_pt_opp_inv.
apply generic_format_opp.
unfold NE_prop.
intros _ f ((mg,eg),(H1,(H2,H3))).
exists (Float beta (- mg) eg).
repeat split.
rewrite H1.
now rewrite F2R_Zopp.
now apply canonical_opp.
simpl.
now rewrite Z.even_opp.
rewrite <- round_NE_opp.
apply round_NE_pt_pos.
now apply Ropp_0_gt_lt_contravar.
rewrite Hx, round_0...
apply Rnd_NG_pt_refl.
apply generic_format_0.
now apply round_NE_pt_pos.
Qed.

End Fcore_rnd_NE.

Notation rndNE := ZnearestE (only parsing).


(* En este archivo se demuestra la corrección de la acción revoke *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import EqTheorems.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.

Section Revoke.

Lemma postRevokeCorrect : forall (s:System) (a:idApp) (p:Perm), (pre (revoke p a) s) -> validstate s -> post_revoke p a s (revoke_post p a s).
Proof.
    intros.
    unfold post_revoke.
    split. simpl; auto.
    simpl in H.
    unfold pre_revoke in H;simpl in H.
    destruct H.
    destruct H as [lPerm H2].
    destruct H2.

    split.
    unfold revokePerm.
    unfold revoke_post;unfold revokePermission;simpl.
    rewrite H.
    split;intros.
    elim (classic (a=a'));intros.
    exists lPerm.

    split.
    rewrite <- H4.
    auto.
    intros.
    rewrite <- H4 in H3.
    rewrite <-(addAndApply idApp_eq a (remove Perm_eq p lPerm) (perms (state s))) in H3.
    inversion H3.
    rewrite <- H7 in H5.
    apply removeSthElse in H5.
    destruct H5;auto.

    exists lPerm'.
    split.
    rewrite overrideNotEq in H3; auto.
    intros;auto.

    split;intros.
    elim (classic (a=a'));intros.
    exists (remove Perm_eq p lPerm).
    split.
    rewrite H4.
    symmetry.
    apply addAndApply.
    intros.
    split;auto.
    symmetry.
    apply (notInRemove Perm lPerm p' p Perm_eq ).
    rewrite H4 in H.
    rewrite H in H3.
    inversion H3.
    auto.
    auto.

    exists lPerm0.
    split.
    rewrite overrideNotEq.
    auto.
    auto.
    intros.
    contradiction.
    split.
    exists (remove Perm_eq p lPerm).
    split.
    symmetry.
    apply addAndApply.
    rewrite <-removeSthElse.
    unfold not;intros.
    destruct H3.
    apply H3;auto.
    apply addPreservesCorrectness.
    apply permsCorrect;auto.
    repeat (split;auto).
Qed.

Lemma notPreRevokeThenError : forall (s:System) (a:idApp) (p:Perm), ~(pre (revoke p a) s) -> validstate s -> exists ec : ErrorCode, response (step s (revoke p a)) = error ec /\ ErrorMsg s (revoke p a) ec /\ s = system (step s (revoke p a)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold revoke_safe, revoke_pre.
    case_eq (negb (InBool Perm Perm_eq p (grantedPermsForApp a s))); intros.
    simpl. exists perm_wasnt_granted. auto.
    case_eq (isSomethingBool idGrp (maybeGrp p)); intros.
    simpl. exists perm_is_grouped. split; auto. split; auto.
    unfold isSomethingBool in H2.
    destruct (maybeGrp p).
    exists i; auto. inversion H2.

    destruct H.
    unfold pre_revoke.
    split.
    rewrite negb_false_iff in H1.
    unfold InBool in H1.
    rewrite existsb_exists in H1.
    destruct H1 as [p' [H1 H3]].
    unfold grantedPermsForApp in H1.
    case_eq (map_apply idApp_eq (perms (state s)) a); intros.
    rewrite H in H1. exists l.
    destruct (Perm_eq p p'). rewrite e. auto.
    inversion H3.
    rewrite H in H1. inversion H1.
    unfold isSomethingBool in H2.
    destruct (maybeGrp p).
    inversion H2. auto.
Qed.

Lemma revokeIsSound : forall (s:System) (a:idApp) (p:Perm),
        validstate s -> exec s (revoke p a) (system (step s (revoke p a))) (response (step s (revoke p a))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (revoke p a) s));intro.
    left.
    assert(revoke_pre p a s = None).
    unfold revoke_pre.
    destruct H0.
    destruct H0.

    assert (InBool Perm Perm_eq p (grantedPermsForApp a s) = true).
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    split.
    destruct H0.
    unfold grantedPermsForApp.
    rewrite H0.
    auto.
    destruct Perm_eq; auto.
    rewrite H1.
    rewrite H2. simpl.
    auto.

    unfold step;simpl.
    unfold revoke_safe;simpl.
    rewrite H1;simpl.
    split;auto.
    split;auto.
    apply postRevokeCorrect;auto.
    right.
    apply notPreRevokeThenError;auto.

Qed.
End Revoke.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Axioms.

Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.

Require Import VST.sepcomp.mem_lemmas.

Notation val_inject:=Val.inject.

(*A value that is (if its a pointer) not dangling wrt m - a condition
 like this will probably be need to imposed on after-external return
 values (and thus also on the values returned by halted)*)
Definition val_valid (v:val) (m:mem):Prop :=
     match v with Vptr b ofs => Mem.valid_block m b | _ => True
     end.

(*In fact val_valid is a slight relaxtion of valid_pointer*)
Lemma valid_ptr_val_valid: forall b ofs m,
    Mem.valid_pointer m b ofs = true -> val_valid (Vptr b (Ptrofs.repr ofs)) m.
Proof. intros.
  apply Mem.valid_pointer_nonempty_perm in H. eapply Mem.perm_valid_block. apply H.
Qed.

Lemma extends_valvalid: forall m1 m2 (Ext: Mem.extends m1 m2) v,
        val_valid v m1 <-> val_valid v m2.
Proof. intros.
  split; intros. destruct v; simpl in *; try econstructor.
     eapply (Mem.valid_block_extends _ _ _ Ext). apply H.
  destruct v; simpl in *; try econstructor.
     eapply (Mem.valid_block_extends _ _ _ Ext). apply H.
Qed.

Lemma inject_valvalid: forall j m1 m2 (Inj: Mem.inject j m1 m2) v2 (V:val_valid v2 m2) v1,
             val_inject j v1 v2 -> val_valid v1 m1.
Proof. intros.
  inv H; repeat constructor.
     simpl in *. eapply Mem.valid_block_inject_1; eassumption.
Qed.

(*Preservation of val_valid along an injection only holds
  if the LHS value is defined*)
Lemma inject_valvalid_1:
  forall (j : meminj) (m1 m2 : mem),
  Mem.inject j m1 m2 ->
  forall v1 : val,
  val_valid v1 m1 -> forall v2 : val, val_inject j v1 v2 ->
  match v1 with Vundef => True
      | _ => val_valid v2 m2
  end.
Proof. intros.
  destruct v1; auto; inv H1; auto.
  simpl in *.
  eapply Mem.valid_block_inject_2; eassumption.
Qed.

(*memories that do not contain "dangling pointers"*)
Definition mem_wd m := Mem.inject_neutral (Mem.nextblock m) m.

Lemma align_chunk_0: forall chunk, (align_chunk chunk | 0).
Proof.
  intros chunk. destruct chunk; simpl; apply Z.divide_0_r.
Qed.

Lemma mem_wdI: forall m,
  (forall (b:block) ofs  (R:Mem.perm m b ofs Cur Readable),
    memval_inject  (Mem.flat_inj (Mem.nextblock m))
    (ZMap.get ofs (PMap.get b (Mem.mem_contents m)))
    (ZMap.get ofs (PMap.get b (Mem.mem_contents m)))) -> mem_wd m.
Proof. intros.
  split; intros.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. rewrite Zplus_0_r. trivial.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. apply align_chunk_0.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. rewrite Zplus_0_r.
        apply H. apply H1.
Qed.

Lemma mem_wd_E: forall m, mem_wd m ->  Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m.
Proof. intros. apply Mem.neutral_inject. apply H. Qed.

Lemma meminj_split_flatinjR: forall j m m' (J:Mem.inject j m' m), mem_wd m ->
     j = compose_meminj j (Mem.flat_inj (Mem.nextblock m)).
Proof. intros. apply mem_wd_E in H.
   unfold  compose_meminj.
   apply extensionality. intro b.
   remember (j b).
   destruct o; trivial. destruct p. unfold Mem.flat_inj in *.
   destruct (plt b0 (Mem.nextblock m)).
     rewrite Zplus_0_r. trivial.
   inv J. apply eq_sym in Heqo. specialize (mi_mappedblocks _ _ _ Heqo).
               exfalso. unfold Mem.valid_block in mi_mappedblocks. contradiction.
Qed.

Lemma meminj_split_flatinjL: forall j m m' (J:Mem.inject j m m'), mem_wd m ->
     j = compose_meminj (Mem.flat_inj (Mem.nextblock m)) j.
Proof. intros. apply mem_wd_E in H.
   unfold  compose_meminj.
   apply extensionality. intro b.
   unfold Mem.flat_inj in *.
   destruct (plt b (Mem.nextblock m)).
     remember (j b). destruct o. destruct p0.  rewrite Zplus_0_l. trivial. trivial.
  inv J. apply mi_freeblocks. assumption.
Qed.

Lemma mem_wd_inject_splitL: forall j m1 m2
              (J:Mem.inject j m1 m2)  (WD: mem_wd m1),
     Mem.inject (Mem.flat_inj (Mem.nextblock m1)) m1 m1
     /\ j = compose_meminj (Mem.flat_inj (Mem.nextblock m1)) j.
Proof. intros.
    split. apply mem_wd_E. apply WD.
    eapply (meminj_split_flatinjL _ _ _ J WD).
Qed.

Lemma mem_wd_inject_splitR: forall j m1 m2
              (J:Mem.inject j m1 m2)  (WD: mem_wd m2),
     Mem.inject (Mem.flat_inj (Mem.nextblock m2)) m2 m2
     /\ j = compose_meminj j (Mem.flat_inj (Mem.nextblock m2)).
Proof. intros.
    split. apply mem_wd_E. apply WD.
    eapply (meminj_split_flatinjR _ _ _ J WD).
Qed.

(*Preservation of mem_wd by memory operations*)
Lemma mem_wd_empty: mem_wd Mem.empty.
Proof.  apply Mem.empty_inject_neutral. Qed.

Lemma  mem_wd_alloc: forall m b lo hi m' (ALL: Mem.alloc m lo hi = (m',b))
     (WDm: mem_wd m), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  rewrite (Mem.nextblock_alloc _ _ _ _ _ ALL).
  eapply (Mem.alloc_inject_neutral _ _ _ _ _ _ ALL); try lia.
  inv WDm.
         split; intros.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r. assumption.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. apply align_chunk_0.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r.
                 assert (X: Mem.flat_inj (Mem.nextblock m) b1 = Some (b1, 0)).
                     apply flatinj_I. apply (Mem.perm_valid_block _ _ _ _ _ H0).
                  specialize (mi_memval _ _ _ _ X H0). rewrite Zplus_0_r in mi_memval.
                  eapply memval_inject_incr; try eassumption.
                       intros bb; intros.
                        eapply flatinj_mono; try eassumption. apply Plt_succ.
     apply Plt_succ.
Qed.

Lemma  mem_wd_drop: forall m b lo hi p m' (DROP: Mem.drop_perm m b lo hi p = Some m')
     (WDm: mem_wd m), Mem.valid_block m b -> mem_wd m'.
Proof. intros. unfold mem_wd in *.
  rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP).
  eapply (Mem.drop_inject_neutral _ _ _ _ _ _ _ DROP); trivial.
Qed.

Lemma free_neutral: forall (thr : block) (m : mem) (lo hi : Z) (b : block) (m' : Mem.mem')
  (FREE: Mem.free m b lo hi = Some m'),
  Mem.inject_neutral thr m -> Mem.inject_neutral thr m'.
Proof. intros. inv H.
  split; intros.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r. assumption.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. apply align_chunk_0.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r.
        assert (X: Mem.flat_inj thr b1 = Some (b1,0)). apply flatinj_I. assumption.
        assert (Y:= Mem.perm_free_3 _ _ _ _ _ FREE _ _ _ _ H0).
         specialize (mi_memval _ _ _ _ X Y). rewrite Zplus_0_r in *.
         rewrite (Mem.free_result _ _ _ _ _ FREE) in *. simpl in *. apply mi_memval.
Qed.

Lemma mem_wd_free: forall m b lo hi m' (WDm: mem_wd m)
  (FREE: Mem.free m b lo hi = Some m'), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  eapply free_neutral. apply FREE.
   rewrite (Mem.nextblock_free _ _ _ _ _ FREE). assumption.
Qed.

Lemma mem_wd_store: forall m b ofs v m' chunk (WDm: mem_wd m)
  (ST: Mem.store chunk m b ofs v = Some m')
  (V: val_valid v m), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  eapply Mem.store_inject_neutral. apply ST.
      rewrite (Mem.nextblock_store _ _ _ _ _ _ ST). assumption.
      assert (X:= Mem.store_valid_access_3 _ _ _ _ _ _ ST).
          rewrite (Mem.nextblock_store _ _ _ _ _ _ ST).
           apply (Mem.valid_access_implies _ _ _ _ _  Nonempty) in X.
                apply Mem.valid_access_valid_block in X. apply X.
            constructor.
      rewrite (Mem.nextblock_store _ _ _ _ _ _ ST).
          destruct v; try solve [constructor].
            econstructor. eapply flatinj_I. apply V.
                          rewrite Ptrofs.add_zero. trivial.
Qed.

Lemma extends_memwd:
forall m1 m2 (Ext: Mem.extends m1 m2), mem_wd m2 -> mem_wd m1.
Proof.
  intros. eapply mem_wdI. intros.
  assert (Mem.perm m2 b ofs Cur Readable).
    eapply (Mem.perm_extends _ _ _ _ _ _ Ext R).
  assert (Mem.valid_block m2 b).
     apply (Mem.perm_valid_block _ _ _ _ _ H0).
  destruct Ext. rewrite mext_next.
  assert (Mem.flat_inj (Mem.nextblock m2) b = Some (b,0)).
    apply flatinj_I. apply H1.
  destruct mext_inj. specialize (mi_memval b ofs b 0 (eq_refl _) R).
  rewrite Zplus_0_r in mi_memval.
  destruct H. specialize (mi_memval0 b ofs b 0 H2 H0).
  rewrite Zplus_0_r in mi_memval0.
  remember (ZMap.get ofs (PMap.get b (Mem.mem_contents m1))) as v.
  destruct v. repeat econstructor.
  econstructor.
  econstructor.
  destruct v; try constructor.
  econstructor.
    eapply flatinj_I. inv mi_memval.
    inv H3. inv H5. rewrite Ptrofs.add_zero in H6.
      rewrite <- H6 in mi_memval0. simpl in mi_memval0.
     inv mi_memval0. inversion H3.
      apply flatinj_E in H7. apply H7.
   rewrite Ptrofs.add_zero. reflexivity.
Qed.

Inductive valid_genv {F V:Type} (ge:Genv.t F V) (m:mem) : Type :=
  mk_valid_genv :
    (forall b, isGlobalBlock ge b=true -> val_valid (Vptr b Ptrofs.zero) m) ->
    (forall b f, Genv.find_funct_ptr ge b = Some f -> val_valid (Vptr b Ptrofs.zero) m) ->
    valid_genv ge m.

Lemma valid_genv_alloc: forall {F V:Type} (ge:Genv.t F V) (m m1:mem) lo hi b
    (ALLOC: Mem.alloc m lo hi = (m1,b)) (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.valid_block_alloc _ _ _ _ _ ALLOC).
  apply (v _ H).
  apply (Mem.valid_block_alloc _ _ _ _ _ ALLOC).
  apply (v0 _ _ H).
Qed.

Lemma valid_genv_store: forall {F V:Type} (ge:Genv.t F V) m m1 b ofs v chunk
    (STORE: Mem.store chunk m b ofs v = Some m1)
     (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.store_valid_block_1 _ _ _ _ _ _ STORE).
  apply (v0 _ H).
  apply (Mem.store_valid_block_1 _ _ _ _ _ _ STORE).
  apply (v1 _ _ H).
Qed.

Lemma valid_genv_store_zeros: forall {F V:Type} (ge:Genv.t F V) m m1 b y z
    (STORE_ZERO: store_zeros m b y z = Some m1)
    (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply Genv.store_zeros_nextblock in STORE_ZERO.
  specialize (v _ H); simpl in *.
  unfold Mem.valid_block in *.
  rewrite STORE_ZERO. apply G; auto.
  specialize (v0 _ _ H); simpl in *.
  apply Genv.store_zeros_nextblock in STORE_ZERO.
  unfold Mem.valid_block in *.
  rewrite STORE_ZERO. auto.
Qed.

Require Import FunInd.

Lemma mem_wd_store_zeros: forall m b p n m1
    (STORE_ZERO: store_zeros m b p n = Some m1) (WD: mem_wd m), mem_wd m1.
Proof. intros until n. functional induction (store_zeros m b p n); intros.
  inv STORE_ZERO; tauto.
  apply (IHo _ STORE_ZERO); clear IHo.
      eapply (mem_wd_store m). apply WD. apply e0. simpl; trivial.
  inv STORE_ZERO.
Qed.

Lemma valid_genv_drop: forall {F V:Type} (ge:Genv.t F V) (m m1:mem) b lo hi p
    (DROP: Mem.drop_perm m b lo hi p = Some m1) (G: valid_genv ge m),
    valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.drop_perm_valid_block_1 _ _ _ _ _ _ DROP).
  apply (v _ H); auto.
  apply (Mem.drop_perm_valid_block_1 _ _ _ _ _ _ DROP).
  apply (v0 _ _ H); auto.
Qed.

Lemma mem_wd_store_init_data: forall {F V} (ge: Genv.t F V) a (b:block) (z:Z)
  m1 m2 (SID:Genv.store_init_data ge m1 b z a = Some m2),
  valid_genv ge m1 -> mem_wd m1 -> mem_wd m2.
Proof. intros F V ge a.
  destruct a; simpl; intros;
      try apply (mem_wd_store _ _ _ _ _ _ H0 SID); simpl; trivial.
   inv SID; trivial.
   remember (Genv.find_symbol ge i) as d.
     destruct d; inv SID.
     eapply (mem_wd_store _ _ _ _ _ _ H0 H2).
    apply eq_sym in Heqd.
    destruct H.
    apply v.
    unfold isGlobalBlock.
    rewrite orb_true_iff.
    unfold genv2blocksBool; simpl.
    apply Genv.find_invert_symbol in Heqd.
    rewrite Heqd; left; auto.
Qed.

Lemma valid_genv_store_init_data:
  forall {F V}  (ge: Genv.t F V) a (b:block) (z:Z) m1 m2
  (SID: Genv.store_init_data ge m1 b z a = Some m2),
  valid_genv ge m1 -> valid_genv ge m2.
Proof. intros F V ge a.
  destruct a; simpl; intros; inv H; constructor;
    try (intros b0 X; eapply Mem.store_valid_block_1 with (b':=b0); eauto;
          apply H0; auto);
    try (intros b0 ? X; eapply Mem.store_valid_block_1 with (b':=b0); eauto;
          eapply H1; eauto);
    try (inv SID; auto).
  intros.
  remember (Genv.find_symbol ge i) as d.
  destruct d; inv H2.
  eapply Mem.store_valid_block_1; eauto.
  apply eq_sym in Heqd.
  eapply H0; eauto.
  revert H2. destruct (Genv.find_symbol ge i); intros; try congruence.
  eapply Mem.store_valid_block_1; eauto.
  eapply H1; eauto.
Qed.

Lemma mem_wd_store_init_datalist: forall {F V} (ge: Genv.t F V) l (b:block)
  (z:Z) m1 m2 (SID: Genv.store_init_data_list ge m1 b z l = Some m2),
  valid_genv ge m1 -> mem_wd m1 -> mem_wd m2.
Proof. intros F V ge l.
  induction l; simpl; intros.
    inv SID. trivial.
  remember (Genv.store_init_data ge m1 b z a) as d.
  destruct d; inv SID; apply eq_sym in Heqd.
  apply (IHl _ _ _ _ H2); clear IHl H2.
     eapply valid_genv_store_init_data. apply Heqd. apply H.
  eapply mem_wd_store_init_data. apply Heqd. apply H. apply H0.
Qed.

Lemma valid_genv_store_init_datalist: forall {F V} (ge: Genv.t F V) l (b:block)
  (z:Z) m1 m2 (SID: Genv.store_init_data_list ge m1 b z l = Some m2),
   valid_genv ge m1 -> valid_genv ge m2.
Proof. intros F V ge l.
  induction l; simpl; intros.
    inv SID. trivial.
  remember (Genv.store_init_data ge m1 b z a) as d.
  destruct d; inv SID; apply eq_sym in Heqd.
  apply (IHl _ _ _ _ H1); clear IHl H1.
     eapply valid_genv_store_init_data. apply Heqd. apply H.
Qed.

Lemma mem_wd_alloc_global: forall  {F V} (ge: Genv.t F V) a m0 m1
   (GA: Genv.alloc_global ge m0 a = Some m1),
   mem_wd m0 -> valid_genv ge m0 -> mem_wd m1.
Proof. intros F V ge a.
destruct a; simpl. intros.
destruct g.
  remember (Mem.alloc m0 0 1) as mm. destruct mm.
    apply eq_sym in Heqmm.
    specialize (mem_wd_alloc _ _ _ _ _ Heqmm). intros.
     eapply (mem_wd_drop _ _ _ _ _  _ GA).
    apply (H1 H).
    apply (Mem.valid_new_block _ _ _ _ _ Heqmm).
remember (Mem.alloc m0 0 (init_data_list_size (AST.gvar_init v)) ) as mm.
  destruct mm. apply eq_sym in Heqmm.
  remember (store_zeros m b 0 (init_data_list_size (AST.gvar_init v)))
           as d.
  destruct d; inv GA; apply eq_sym in Heqd.
  remember (Genv.store_init_data_list ge m2 b 0 (AST.gvar_init v)) as dd.
  destruct dd; inv H2; apply eq_sym in Heqdd.
  eapply (mem_wd_drop _ _ _ _ _ _ H3); clear H3.
    eapply (mem_wd_store_init_datalist _ _ _ _ _ _ Heqdd).
    apply (valid_genv_store_zeros _ _ _ _ _ _ Heqd).
    apply (valid_genv_alloc ge _ _ _ _ _ Heqmm H0).
  apply (mem_wd_store_zeros _ _ _ _ _ Heqd).
    apply (mem_wd_alloc _ _ _ _ _ Heqmm H).
  unfold Mem.valid_block.
     apply Genv.store_init_data_list_nextblock in Heqdd.
           rewrite Heqdd. clear Heqdd.
      apply Genv.store_zeros_nextblock in Heqd. rewrite Heqd; clear Heqd.
      apply (Mem.valid_new_block _ _ _ _ _  Heqmm).
Qed.

Lemma valid_genv_alloc_global: forall  {F V} (ge: Genv.t F V) a m0 m1
   (GA: Genv.alloc_global ge m0 a = Some m1),
   valid_genv ge m0 -> valid_genv ge m1.
Proof. intros F V ge a.
destruct a; simpl. intros.
destruct g.
  remember (Mem.alloc m0 0 1) as d. destruct d.
    apply eq_sym in Heqd.
    apply (valid_genv_drop _ _ _ _ _ _ _ GA).
    apply (valid_genv_alloc _ _ _ _ _ _ Heqd H).
remember (Mem.alloc m0 0 (init_data_list_size (AST.gvar_init v)) )
         as Alloc.
  destruct Alloc. apply eq_sym in HeqAlloc.
  remember (store_zeros m b 0
           (init_data_list_size (AST.gvar_init v))) as SZ.
  destruct SZ; inv GA; apply eq_sym in HeqSZ.
  remember (Genv.store_init_data_list ge m2 b 0 (AST.gvar_init v)) as Drop.
  destruct Drop; inv H1; apply eq_sym in HeqDrop.
  eapply (valid_genv_drop _ _ _ _ _ _ _ H2); clear H2.
  eapply (valid_genv_store_init_datalist _ _ _ _ _ _ HeqDrop). clear HeqDrop.
  apply (valid_genv_store_zeros _ _ _ _ _ _ HeqSZ).
    apply (valid_genv_alloc _ _ _ _ _ _ HeqAlloc H).
Qed.

Lemma valid_genv_alloc_globals:
   forall F V (ge: Genv.t F V) init_list m0 m
   (GA: Genv.alloc_globals ge m0 init_list = Some m),
   valid_genv ge m0 -> valid_genv ge m.
Proof. intros F V ge l.
induction l; intros; simpl in *.
  inv GA. assumption.
remember (Genv.alloc_global ge m0 a) as d.
  destruct d; inv GA. apply eq_sym in Heqd.
  eapply (IHl  _ _  H1). clear H1.
    apply (valid_genv_alloc_global _ _ _ _ Heqd H).
Qed.

Lemma mem_wd_alloc_globals:
   forall F V (ge: Genv.t F V) init_list m0 m
   (GA: Genv.alloc_globals ge m0 init_list = Some m),
   mem_wd m0 -> valid_genv ge m0 -> mem_wd m.
Proof. intros F V ge l.
induction l; intros; simpl in *.
  inv GA. assumption.
remember (Genv.alloc_global ge m0 a) as d.
  destruct d; inv GA. apply eq_sym in Heqd.
eapply (IHl  _ _  H2).
    apply (mem_wd_alloc_global ge _ _ _ Heqd H H0).
    apply (valid_genv_alloc_global _ _ _ _ Heqd H0).
Qed.

(*POPL-compcomp used the following lemma to prove mem_wd_load:
Lemma decode_val_pointer_inv:
  forall chunk mvl b ofs,
  decode_val chunk mvl = Vptr b ofs ->
  chunk = Mint32 /\ mvl = inj_value Q32 (Vptr b ofs).
 A version of this lemma is in
  CompCert 2.3, Memdata.v,
 but missing from CompCert 2.4.  I'm not even sure
 it's true in CompCert 2.4.  -A.W.A.

In CompCert2.5, the proof of mem_wd_load uses the new load_ptr_is_fragment, recently added to mem_lemmas*)
Lemma mem_wd_load: forall m ch b ofs v
  (LD: Mem.load ch m b ofs = Some v)
  (WD : mem_wd m), val_valid v m.
Proof. intros.
  destruct v; simpl; trivial.
  destruct (load_ptr_is_fragment _ _ _ _ _ _ LD) as [q [n FRAG]].
  destruct (Mem.load_valid_access _ _ _ _ _ LD) as [Perms Align].
  apply Mem.load_result in LD.
  destruct WD.
  assert (Arith: ofs <= ofs < ofs + (size_chunk ch)). specialize (size_chunk_pos ch); lia.
  specialize (Perms _ Arith).
  assert (VB:= Mem.perm_valid_block _ _ _ _ _ Perms).
  assert (Z:= flatinj_I (Mem.nextblock m) b VB).
  specialize (mi_memval _ _ _ _ Z Perms).
  rewrite Zplus_0_r in mi_memval. rewrite FRAG in mi_memval.
  inversion mi_memval. subst.
  inversion H0.
  apply flatinj_E in H3. apply H3.
Qed.

Lemma mem_wd_storebytes: forall m b ofs bytes m' (WDm: mem_wd m)
  (ST: Mem.storebytes m b ofs bytes = Some m')
  (BytesValid: forall v, In v bytes ->
               memval_inject (Mem.flat_inj (Mem.nextblock m)) v v),
   mem_wd m'.
Proof. intros. apply mem_wdI. intros.
  assert (F: Mem.flat_inj (Mem.nextblock m) b0 = Some (b0, 0)).
        apply flatinj_I.
        apply (Mem.storebytes_valid_block_2 _ _ _ _ _ ST).
        eapply Mem.perm_valid_block; eassumption.
  apply mem_wd_E in WDm.
  assert (P:= Mem.perm_storebytes_2 _ _ _ _ _ ST _ _ _ _ R).
  specialize (Mem.mi_memval _ _ _ (Mem.mi_inj _ _ _ WDm) _ _ _ _ F P).
  rewrite Zplus_0_r.
  intros MVI.
  rewrite (Mem.nextblock_storebytes _ _ _ _ _ ST).
  rewrite (Mem.storebytes_mem_contents _ _ _ _ _ ST).
  remember (eq_block b0 b).
  destruct s; subst; clear Heqs.
  (*case b0=b*)
    rewrite PMap.gss.
    remember (zlt ofs0 ofs) as d.
    destruct d; clear Heqd.
    (*case ofs0 < ofs*)
      rewrite Mem.setN_outside; try (left; assumption).
      assumption.
    (*case ofs0 >= ofs*)
      remember (zlt ofs0 (ofs + (Z.of_nat (length bytes)))) as d.
      destruct d; clear Heqd.
      (*case <*)
        apply BytesValid; clear BytesValid.
        apply Mem.setN_in. lia.
      (*case >= *)
         rewrite Mem.setN_outside; try (right; assumption).
      assumption.
  (*case b0 <> b*)
    rewrite PMap.gso; trivial.
Qed.

Lemma getN_aux: forall n p c B1 v B2, Mem.getN n p c = B1 ++ v::B2 ->
    v = ZMap.get (p + Z.of_nat (length B1)) c.
Proof. intros n.
  induction n; simpl; intros.
    destruct B1; simpl in *. inv H. inv H.
    destruct B1; simpl in *.
      inv H. rewrite Zplus_0_r. trivial.
      inv H. specialize (IHn _ _ _ _ _ H2). subst.
        rewrite Zpos_P_of_succ_nat.
        remember (Z.of_nat (length B1)) as m. clear Heqm H2. rewrite <- Z.add_1_l.
         rewrite Zplus_assoc. trivial.
Qed.

Lemma getN_range: forall n ofs M bytes1 v bytes2,
  Mem.getN n ofs M = bytes1 ++ v::bytes2 ->
  (length bytes1 < n)%nat.
Proof. intros n.
  induction n; simpl; intros.
    destruct bytes1; inv H.
    destruct bytes1; simpl in *; inv H.
      lia.
    specialize (IHn _ _ _ _ _ H2). lia.
Qed.

Lemma loadbytes_D: forall m b ofs n bytes
      (LD: Mem.loadbytes m b ofs n = Some bytes),
      Mem.range_perm m b ofs (ofs + n) Cur Readable /\
      bytes = Mem.getN (Z.to_nat n) ofs (PMap.get b (Mem.mem_contents m)).
Proof. intros.
  Transparent Mem.loadbytes.
  unfold Mem.loadbytes in LD.
  Opaque Mem.loadbytes.
  remember (Mem.range_perm_dec m b ofs (ofs + n) Cur Readable) as d.
  destruct d; inv LD. auto.
Qed.

Lemma loadbytes_valid: forall m (WD: mem_wd m) b ofs' n bytes
      (LD: Mem.loadbytes m b (Int.unsigned ofs') n = Some bytes)
      v (B: In v bytes),
      memval_inject (Mem.flat_inj (Mem.nextblock m)) v v.
Proof. intros.
  destruct (loadbytes_D _ _ _ _ _ LD) as [Range BB]; subst.
  assert (L:= Mem.loadbytes_length _ _ _ _ _ LD).
  apply In_split in B. destruct B as [bytes1 [bytes2 B]]. subst.
  assert (I: Int.unsigned ofs' <= (Int.unsigned ofs') + Z.of_nat (length bytes1) <
                  Int.unsigned ofs' + n).
    assert (II:= getN_range _ _ _ _ _ _ B).
    clear Range LD B L.
    split. lia.
    assert (Z.of_nat (length bytes1) < Z.of_nat (Z.to_nat n)).
        lia.
    rewrite Z2Nat.id in H. lia. clear H.
        destruct n. lia. specialize (Pos2Z.is_pos p); lia.
        rewrite Z2Nat.inj_neg in II. destruct bytes1; simpl in II; inv II.
  specialize (Range _ I).
  assert (F: Mem.flat_inj (Mem.nextblock m) b = Some (b, 0)).
    apply flatinj_I. apply Mem.perm_valid_block in Range. apply Range.
    specialize (Mem.mi_memval _ _ _ WD _ _ _ _ F Range).
    intros. rewrite Zplus_0_r in H.
   apply getN_aux in B. subst. apply H.
Qed.

Lemma freelist_mem_wd: forall l m m'
      (M: Mem.free_list m l = Some m')
      (WD: mem_wd m), mem_wd m'.
Proof. intros l.
  induction l; simpl; intros.
    inv M; trivial.
  destruct a. destruct p.
  remember (Mem.free m b z0 z) as d.
  destruct d; inv M; apply eq_sym in Heqd.
  apply (IHl _ _ H0).
  eapply mem_wd_free; eassumption.
Qed.


(** Definition of Wasm datatypes
    See https://webassembly.github.io/spec/core/syntax/index.html
    and https://webassembly.github.io/spec/core/exec/index.html **)
(* (C) J. Pichon, M. Bodin - see LICENSE.txt *)

(* TODO: use better representations than "nat", which is expensive;
   maybe N? maybe a 32-bit word type? *)

Require Import BinNat.
From Wasm Require array.
From Wasm Require Import common memory memory_list.
From Wasm Require Export numerics bytes.
From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq.
From compcert Require common.Memdata.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Basic Datatypes **)

(* TODO: Documentation. *)

(* TODO: make these have structure; this will require monad-ifying the whole thing *)
Definition host := unit.
Definition host_state := unit.

Definition depth := nat.

Definition immediate (* i *) :=
  (* TODO: this is not a great representation *)
  nat.

Definition static_offset := (* off *) N. (* TODO: should be u32 *)

Definition alignment_exponent := (* a *) N. (* TODO: should be u32 *)

Definition serialise_i32 (i : i32) : bytes :=
  common.Memdata.encode_int 4%nat (numerics.Wasm_int.Int32.unsigned i).

Definition serialise_i64 (i : i64) : bytes :=
  common.Memdata.encode_int 8%nat (numerics.Wasm_int.Int64.unsigned i).

Definition serialise_f32 (f : f32) : bytes :=
  common.Memdata.encode_int 4%nat (Integers.Int.unsigned (numerics.Wasm_float.FloatSize32.to_bits f)).

Definition serialise_f64 (f : f64) : bytes :=
  common.Memdata.encode_int 8%nat (Integers.Int64.unsigned (numerics.Wasm_float.FloatSize64.to_bits f)).

(** std-doc:
Limits classify the size range of resizeable storage associated with memory types and table types.
If no maximum is given, the respective storage can grow to any size.
[https://webassembly.github.io/spec/core/syntax/types.html#limits]
 *)
Record limits : Type := {
  lim_min : N; (* TODO: should be u32 *)
  lim_max : option N; (* TODO: should be u32 *)
}.

(* TODO: factor this out, following the `memory` branch *)
Module Byte_Index <: array.Index_Sig.
Definition Index := N.
Definition Value := byte.
Definition index_eqb := N.eqb.
End Byte_Index.

Module Byte_array := array.Make Byte_Index.

Record data_vec : Type := {
  dv_length : N;
  dv_array : Byte_array.array;
}.

Record memory : Type := {
  mem_data : memory_list;
  mem_max_opt: option N; (* TODO: should be u32 *)
}.

(** std-doc:
Memory types classify linear memories and their size range.
The limits constrain the minimum and optionally the maximum size of a memory. The limits are given in units of page size.
[https://webassembly.github.io/spec/core/syntax/types.html#memory-types]
*)
Definition memory_type := limits.

(** std-doc:
Value types classify the individual values that WebAssembly code can compute with and the values that a variable accepts.
The types i32 and i64 classify 32 and 64 bit integers, respectively. Integers are not inherently signed or unsigned, their interpretation is determined by individual operations.

The types f32 and f64 classify 32 and 64 bit floating-point data, respectively. They correspond to the respective binary floating-point representations, also known as single and double precision, as defined by the IEEE 754-2019 standard (Section 3.3).
[https://webassembly.github.io/spec/core/syntax/types.html#value-types]
*)
Inductive value_type : Type := (* t *)
  | T_i32
  | T_i64
  | T_f32
  | T_f64
  .

Inductive packed_type : Type := (* tp *)
  | Tp_i8
  | Tp_i16
  | Tp_i32
  .

(* TODO: the standard calls those const and var *)
(** std-doc:
[https://webassembly.github.io/spec/core/syntax/types.html#global-types]
*)
Inductive mutability : Type := (* mut *)
  | MUT_immut
  | MUT_mut
  .

(** std-doc:
Global types classify global variables, which hold a value and can either be mutable or immutable.
[https://webassembly.github.io/spec/core/syntax/types.html#global-types]
*)
Record global_type : Type := (* tg *) {
  tg_mut : mutability;
  tg_t : value_type
}.

(** std-doc:
Result types classify the result of executing instructions or functions, which is a sequence of values written with brackets.
[https://webassembly.github.io/spec/core/syntax/types.html#result-types]
*)
Definition result_type : Type :=
  list value_type.
(** Note from the specification:
  In the current version of WebAssembly, at most one value is allowed as a result.
  However, this may be generalized to sequences of values in future versions. **)
(* FIXME: Do we want to enforce it? *)

(** std-doc:
Function types classify the signature of functions, mapping a vector of
parameters to a vector of results. They are also used to classify the inputs
and outputs of instructions.
[https://webassembly.github.io/spec/core/syntax/types.html#function-types]
*)
Inductive function_type := (* tf *)
  | Tf : result_type -> result_type -> function_type
  (** Note from the specification:
    In the current version of Wasm, the result list has an arity of at most [1]. **)
  (* FIXME: Shouldn’t we enforce it? *)
  .

(** std-doc:
The element type funcref is the infinite union of all function types. A table
of that type thus contains references to functions of heterogeneous type.
*)
Inductive elem_type : Type :=
| ELT_funcref : elem_type.

(** std-doc:
Table types classify tables over elements of element types within a size range.

Like memories, tables are constrained by limits for their minimum and
optionally maximum size. The limits are given in numbers of entries.
[https://webassembly.github.io/spec/core/syntax/types.html#table-types]
*)
Record table_type : Type := {
  tt_limits : limits;
  tt_elem_type : elem_type;
}.

(** Typing context. **)
(** std-doc:
Validity of an individual definition is specified relative to a context, which
collects relevant information about the surrounding module and the definitions
in scope:
- Types: the list of types defined in the current module.
- Functions: the list of functions declared in the current module, represented
  by their function type.
- Tables: the list of tables declared in the current module, represented by
  their table type.
- Memories: the list of memories declared in the current module, represented by
  their memory type.
- Globals: the list of globals declared in the current module, represented by
  their global type.
- Locals: the list of locals declared in the current function (including
  parameters), represented by their value type.
- Labels: the stack of labels accessible from the current position, represented
  by their result type.
- Return: the return type of the current function, represented as an optional
  result type that is absent when no return is allowed, as in free-standing
  expressions.
In other words, a context contains a sequence of suitable types for each index
space, describing each defined entry in that space. Locals, labels and return
type are only used for validating instructions in function bodies, and are left
empty elsewhere. The label stack is the only part of the context that changes
as validation of an instruction sequence proceeds.
*)
Record t_context : Type := {
  tc_types_t : list function_type;
  tc_func_t : list function_type;
  tc_global : list global_type;
  tc_table : list table_type;
  tc_memory : list memory_type;
  tc_local : list value_type;
  tc_label : list (list value_type);
  tc_return : option (list value_type);
}.

(** std-doc:
WebAssembly computations manipulate values of the four basic value types:
integers and floating-point data of 32 or 64 bit width each, respectively.
*)
Inductive value : Type := (* v *)
  | VAL_int32 : i32 -> value
  | VAL_int64 : i64 -> value
  | VAL_float32 : f32 -> value
  | VAL_float64 : f64 -> value
  .

Inductive result : Type :=
  | result_values : list value -> result
  (** Note from the specification:
    In the current version of WebAssembly, a result can consist of at most one value. **)
  | result_trap : result
  .

(** * Basic Instructions **)

Inductive sx : Type :=
  | SX_S
  | SX_U
  .

Inductive unop_i : Type :=
  | UOI_clz
  | UOI_ctz
  | UOI_popcnt
  .

Inductive unop_f : Type :=
  | UOF_neg
  | UOF_abs
  | UOF_ceil
  | UOF_floor
  | UOF_trunc
  | UOF_nearest
  | UOF_sqrt
  .

Inductive unop : Type :=
  | Unop_i : unop_i -> unop
  | Unop_f : unop_f -> unop
  .

Inductive binop_i : Type :=
  | BOI_add
  | BOI_sub
  | BOI_mul
  | BOI_div : sx -> binop_i
  | BOI_rem : sx -> binop_i
  | BOI_and
  | BOI_or
  | BOI_xor
  | BOI_shl
  | BOI_shr : sx -> binop_i
  | BOI_rotl
  | BOI_rotr
  .

Inductive binop_f : Type :=
  | BOF_add
  | BOF_sub
  | BOF_mul
  | BOF_div
  | BOF_min
  | BOF_max
  | BOF_copysign
  .

Inductive binop : Type :=
  | Binop_i : binop_i -> binop
  | Binop_f : binop_f -> binop
  .

Inductive testop : Type :=
  | TO_eqz
  .

Inductive relop_i : Type :=
  | ROI_eq
  | ROI_ne
  | ROI_lt : sx -> relop_i
  | ROI_gt : sx -> relop_i
  | ROI_le : sx -> relop_i
  | ROI_ge : sx -> relop_i
  .

Inductive relop_f : Type :=
  | ROF_eq
  | ROF_ne
  | ROF_lt
  | ROF_gt
  | ROF_le
  | ROF_ge
  .

Inductive relop : Type :=
  | Relop_i : relop_i -> relop
  | Relop_f : relop_f -> relop
  .

Inductive cvtop : Type :=
  | CVO_convert
  | CVO_reinterpret
  .

Inductive basic_instruction : Type := (* be *)
  | BI_unreachable
  | BI_nop
  | BI_drop
  | BI_select
  | BI_block : function_type -> list basic_instruction -> basic_instruction
  | BI_loop : function_type -> list basic_instruction -> basic_instruction
  | BI_if : function_type -> list basic_instruction -> list basic_instruction -> basic_instruction
  | BI_br : immediate -> basic_instruction
  | BI_br_if : immediate -> basic_instruction
  | BI_br_table : list immediate -> immediate -> basic_instruction
  | BI_return
  | BI_call : immediate -> basic_instruction
  | BI_call_indirect : immediate -> basic_instruction
  | BI_get_local : immediate -> basic_instruction
  | BI_set_local : immediate -> basic_instruction
  | BI_tee_local : immediate -> basic_instruction
  | BI_get_global : immediate -> basic_instruction
  | BI_set_global : immediate -> basic_instruction
  | BI_load : value_type -> option (packed_type * sx) -> alignment_exponent -> static_offset -> basic_instruction
  | BI_store : value_type -> option packed_type -> alignment_exponent -> static_offset -> basic_instruction
  | BI_current_memory
  | BI_grow_memory
  | BI_const : value -> basic_instruction
  | BI_unop : value_type -> unop -> basic_instruction
  | BI_binop : value_type -> binop -> basic_instruction
  | BI_testop : value_type -> testop -> basic_instruction
  | BI_relop : value_type -> relop -> basic_instruction
  | BI_cvtop : value_type -> cvtop -> value_type -> option sx -> basic_instruction
  .

(** * Functions and Store **)

Section Host.

(** We assume a family of host functions. **)
Variable host_function : Type.

Definition funcaddr := immediate (* TODO: should be funcidx *).
Definition tableaddr := immediate (* TODO: should be tableidx *).
Definition memaddr := immediate. (* TODO: should be memidx *)
Definition globaladdr := immediate. (* TODO: should be globalidx *)

(** std-doc:
A module instance is the runtime representation of a module. It is created by
instantiating a module, and collects runtime representations of all entities
that are imported, defined, or exported by the module.

Each component references runtime instances corresponding to respective
declarations from the original module – whether imported or defined – in the
order of their static indices. Function instances, table instances, memory
instances, and global instances are referenced with an indirection through
their respective addresses in the store.

It is an invariant of the semantics that all export instances in a given module
instance have different names.
*)
Record instance : Type := (* inst *) {
  inst_types : list function_type;
  inst_funcs : list funcaddr;
  inst_tab : list tableaddr;
  inst_memory : list memaddr;
  inst_globs : list globaladdr;
  (* TODO: exports field? *)
}.
(** std-doc:
A function instance is the runtime representation of a function. It effectively
is a closure of the original function over the runtime module instance of its
originating module. The module instance is used to resolve references to other
definitions during execution of the function.
*)
Inductive function_closure : Type := (* cl *)
  | FC_func_native : instance -> function_type -> list value_type -> list basic_instruction -> function_closure
  | FC_func_host : function_type -> host_function -> function_closure
.

(** std-doc:
Each function element is either empty, representing an uninitialized table
entry, or a function address. Function elements can be mutated through the
execution of an element segment or by external means provided by the embedder.
*)
Definition funcelem := option nat.

(** std-doc:
A table instance is the runtime representation of a table. It holds a vector of
function elements and an optional maximum size, if one was specified in the
table type at the table’s definition site.

It is an invariant of the semantics that the length of the element vector never
exceeds the maximum size, if present.
*)
Record tableinst : Type := {
  table_data: list funcelem;
  table_max_opt: option N; (* TODO: should be u32 *)
}.

(** std-doc:
https://webassembly.github.io/spec/core/syntax/types.html#global-types
*)
Record global : Type := {
  g_mut : mutability;
  g_val : value;
}.

(** std-doc:
The store represents all global state that can be manipulated by WebAssembly
programs. It consists of the runtime representation of all instances of
functions, tables, memories, and globals that have been allocated during the
life time of the abstract machine
*)
Record store_record : Type := (* s *) {
  s_funcs : list function_closure;
  s_tables : list tableinst;
  s_mems : list memory;
  s_globals : list global;
}.

(** std-doc:

[https://webassembly.github.io/spec/core/exec/runtime.html#syntax-frame]
*)
Record frame : Type := (* f *) {
  f_locs: list value;
  f_inst: instance
}.

(** * Administrative Instructions **)

(** std-doc:
WebAssembly code consists of sequences of instructions. Its computational model is based on a stack machine in that instructions manipulate values on an implicit operand stack, consuming (popping) argument values and producing or returning (pushing) result values.

In addition to dynamic operands from the stack, some instructions also have static immediate arguments, typically indices or type annotations, which are part of the instruction itself.

Some instructions are structured in that they bracket nested sequences of instructions.
[https://webassembly.github.io/spec/core/syntax/instructions.html]

In order to express the reduction of traps, calls, and control instructions,
the syntax of instructions is extended to include the following administrative
instructions:
*)
Inductive administrative_instruction : Type := (* e *)
| AI_basic : basic_instruction -> administrative_instruction
| AI_trap
| AI_invoke : funcaddr -> administrative_instruction
| AI_label : nat -> seq administrative_instruction -> seq administrative_instruction -> administrative_instruction
| AI_local : nat -> frame -> seq administrative_instruction -> administrative_instruction
.

Inductive lholed : Type :=
| LH_base : list administrative_instruction -> list administrative_instruction -> lholed
| LH_rec : list administrative_instruction -> nat -> list administrative_instruction -> lholed -> list administrative_instruction -> lholed
.

(** std-doc:
Function bodies, initialization values for globals, and offsets of element or data segments are given as expressions, which are sequences of instructions terminated by an 𝖾𝗇𝖽 marker.
In some places, validation restricts expressions to be constant, which limits the set of allowable instructions.
[https://webassembly.github.io/spec/core/syntax/instructions.html#expressions]
*)
Definition expr := list basic_instruction.

Inductive labelidx : Type :=
| Mk_labelidx : nat -> labelidx.

Inductive funcidx : Type :=
| Mk_funcidx : nat -> funcidx.

Inductive tableidx : Type :=
| Mk_tableidx : nat -> tableidx.

Inductive memidx : Type :=
| Mk_memidx : nat -> memidx.

Inductive typeidx : Type :=
| Mk_typeidx : nat -> typeidx.

Inductive localidx : Type :=
| Mk_localidx : nat -> localidx.

Inductive globalidx : Type :=
| Mk_globalidx : nat -> globalidx.

Inductive import_desc : Type :=
| ID_func : nat -> import_desc
| ID_table : table_type -> import_desc
| ID_mem : memory_type -> import_desc
| ID_global : global_type -> import_desc.

Definition name := list Byte.byte.

Record module_import : Type := {
  imp_module : name;
  imp_name : name;
  imp_desc : import_desc;
}.

Record module_table : Type := {
  modtab_type : table_type;
}.

Record module_glob : Type := {
  modglob_type : global_type;
  modglob_init : expr;
}.

Record module_start : Type := {
  modstart_func : funcidx;
}.

Record module_element : Type := {
  modelem_table : tableidx;
  modelem_offset : expr;
  modelem_init : list funcidx;
}.

Record code_func : Type := {
  fc_locals : list value_type;
  fc_expr : expr;
}.

Record module_data : Type := {
  moddata_data : memidx;
  moddata_offset : expr;
  moddata_init : list Byte.byte;
}.

Inductive module_export_desc : Type :=
| MED_func : funcidx -> module_export_desc
| MED_table : tableidx -> module_export_desc
| MED_mem : memidx -> module_export_desc
| MED_global : globalidx -> module_export_desc.

Record module_export : Type := {
  modexp_name : name;
  modexp_desc : module_export_desc;
}.

Record module_func : Type := {
  modfunc_type : typeidx;
  modfunc_locals : list value_type;
  modfunc_body : expr;
}.

(** std-doc:
WebAssembly programs are organized into modules, which are the unit of deployment, loading, and compilation. A module collects definitions for types, functions, tables, memories, and globals. In addition, it can declare imports and exports and provide initialization logic in the form of data and element segments or a start function.
[https://webassembly.github.io/spec/core/syntax/modules.html]
*)
Record module : Type := {
  mod_types : list function_type;
  mod_funcs : list module_func;
  mod_tables : list module_table;
  mod_mems : list memory_type;
  mod_globals : list module_glob;
  mod_elem : list module_element;
  mod_data : list module_data;
  mod_start : option module_start;
  mod_imports : list module_import;
  mod_exports : list module_export;
}.

Inductive extern_t : Type :=
| ET_func : function_type -> extern_t
| ET_tab : table_type -> extern_t
| ET_mem : memory_type -> extern_t
| ET_glob : global_type -> extern_t
.

(** Some types used in the interpreter. **)

Definition config_tuple : Type := store_record * frame * seq administrative_instruction.

Definition config_one_tuple_without_e : Type := store_record * frame * seq value.

Inductive res_crash : Type :=
  | C_error : res_crash
  .

Inductive res_step : Type :=
  | RS_crash : res_crash -> res_step
  | RS_break : nat -> seq value -> res_step
  | RS_return : seq value -> res_step
  | RS_normal : seq administrative_instruction -> res_step
  .

Definition res_tuple : Type := store_record * frame * res_step.

End Host.
Arguments FC_func_native [host_function].


Require Import CoqlibC.
Require Import Memory.
Require Import Values.
Require Import Maps.
Require Import Events.
Require Import Globalenvs.
Require Import sflib.
Require Import RelationClasses.
Require Import FSets.
Require Import Ordered.
Require Import AST.
Require Import Integers.

Require Import ModSem.
Require Export SimMem.
(* Include SimMem. *)

Set Implicit Arguments.

(* A special instance of private transition, for backward compatibility *)

Module SimMemLift.

  (* Context `{SM: SimMem.class}. *)

  Class class (SM: SimMem.class) :=
  { lepriv_Trans :> Transitive SimMem.lepriv;

    lift: SimMem.t -> SimMem.t;
    unlift: SimMem.t -> SimMem.t -> SimMem.t;

    lift_wf: forall mrel, SimMem.wf mrel -> SimMem.wf (lift mrel);
    lift_src: forall mrel, (lift mrel).(SimMem.src) = mrel.(SimMem.src);
    lift_tgt: forall mrel, (lift mrel).(SimMem.tgt) = mrel.(SimMem.tgt);
    unlift_src: forall mrel0 mrel1, (unlift mrel0 mrel1).(SimMem.src) = mrel1.(SimMem.src);
    unlift_tgt: forall mrel0 mrel1, (unlift mrel0 mrel1).(SimMem.tgt) = mrel1.(SimMem.tgt);
    lift_spec: forall mrel0 mrel1, SimMem.le (lift mrel0) mrel1 -> SimMem.wf mrel0 -> SimMem.le mrel0 (unlift mrel0 mrel1);
    unlift_wf: forall mrel0 mrel1,
        SimMem.wf mrel0 -> SimMem.wf mrel1 -> SimMem.le (lift mrel0) mrel1 -> SimMem.wf (unlift mrel0 mrel1);

    lift_sim_val: forall mrel, SimMem.sim_val mrel <2= SimMem.sim_val (lift mrel);

    (* Required for "forward" compatibility *)

    lift_priv: forall sm0 (MWF: SimMem.wf sm0), SimMem.lepriv sm0 (lift sm0);
    (* unlift_priv: forall sm0 sm1 (MWF: SimMem.wf sm0), SimMem.lepriv sm1 (unlift sm0 sm1); *)
    unlift_priv: forall
        sm_at sm_arg sm_ret
        (MWF: SimMem.wf sm_at)
        (MLIFT: SimMem.lepriv sm_at sm_arg)
        (MLE: SimMem.le sm_arg sm_ret)
        (MWF: SimMem.wf sm_ret),
        SimMem.lepriv sm_ret (unlift sm_at sm_ret);
  }.

  Section PROPS.

  Context {SM: SimMem.class}.
  Context {SML: SimMemLift.class SM}.

  Lemma lift_sim_regset: forall sm0, SimMem.sim_regset sm0 <2= SimMem.sim_regset (SimMemLift.lift sm0).
  Proof. ii. eapply SimMemLift.lift_sim_val; et. Qed.

  Lemma le_lift_lepriv
        sm0 sm1 sm_lift
        (MWF0: SimMem.wf sm0)
        (MWF1: SimMem.wf sm1)
        (MLE: SimMem.le sm0 sm1)
        (MLIFT: SimMemLift.lift sm1 = sm_lift):
      <<MLE: SimMem.lepriv sm0 sm_lift>>.
  Proof.
    subst. hexploit (SimMemLift.lift_priv sm1); eauto. intro T. r. etrans; et.
  Qed.

  Lemma lift_args
        args_src args_tgt sm_arg0
        (ARGS: SimMem.sim_args args_src args_tgt sm_arg0):
      <<ARGS: SimMem.sim_args args_src args_tgt (SimMemLift.lift sm_arg0)>>.
  Proof.
    inv ARGS.
    - econs; eauto.
      + eapply SimMemLift.lift_sim_val; et.
      + erewrite <- SimMem.sim_val_list_spec in *.
        eapply Forall2_impl.
        { eapply SimMemLift.lift_sim_val; et. }
        ss.
      + rewrite SimMemLift.lift_src. ss.
      + rewrite SimMemLift.lift_tgt. ss.
    - econs 2; eauto.
      + eapply lift_sim_regset; et.
      + rewrite SimMemLift.lift_src. ss.
      + rewrite SimMemLift.lift_tgt. ss.
  Qed.

  (* Lemma unlift_le_lepriv *)
  (*       sm_arg sm_ret sm1 *)
  (*       (MWF0: SimMem.wf sm_arg) *)
  (*       (MWF1: SimMem.wf (SimMemLift.unlift sm_arg sm_ret)) *)
  (*       (MLE: SimMem.le (SimMemLift.unlift sm_arg sm_ret) sm1) *)
  (*   : *)
  (*     <<MLE: SimMem.lepriv sm_ret sm1>> *)
  (* . *)
  (* Proof. *)
  (*   hexploit (SimMemLift.unlift_priv sm_arg sm_ret); eauto. intro T. *)
  (*   r. etrans; et. *)
  (* Qed. *)

  End PROPS.

End SimMemLift.


(** * Properties about Context Free Grammars *)
Require Import Fiat.Parsers.StringLike.Core Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties Fiat.Parsers.ContextFreeGrammar.Transfer.

Set Implicit Arguments.

Local Open Scope list_scope.

Section cfg.
  Context {Char} {HSLM1 HSLM2 : StringLikeMin Char}
          {HSL1 : @StringLike Char HSLM1}
          {HSL2 : @StringLike Char HSLM2}
          {G : grammar Char}
          {R : @String Char HSLM1 -> @String Char HSLM2 -> Prop}
          {TR : transfer_respectful R}.
  Context {P : String.string -> Type}.

  Definition transfer_forall_parse_of_item'
        (transfer_forall_parse_of
         : forall str1 str2 it (HR : R str1 str2) p,
             @Forall_parse_of Char _ _ G (fun _ => P) str1 it p
             -> @Forall_parse_of Char _ _ G (fun _ => P) str2 it (transfer_parse_of HR p))
        {str1 str2 it}
        (HR : R str1 str2)
        {p}
  : @Forall_parse_of_item' Char _ HSL1 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str1 it p
    -> @Forall_parse_of_item' Char _ HSL2 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str2 it (transfer_parse_of_item HR p)
    := match
        p in (parse_of_item _ _ it)
        return
        (@Forall_parse_of_item' Char _ HSL1 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str1 it p
         -> @Forall_parse_of_item' Char _ HSL2 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str2 it (transfer_parse_of_item HR p))
      with
        | ParseTerminal _ _ _ _ => fun x => x
        | ParseNonTerminal _ H' p' => fun xy => (fst xy, transfer_forall_parse_of _ _ _ _ p' (snd xy))
      end.

  Fixpoint transfer_forall_parse_of
           str1 str2 pats
           (HR : R str1 str2)
           {p}
           {struct p}
  : @Forall_parse_of Char _ HSL1 G (fun _ => P) str1 pats p
    -> @Forall_parse_of Char _ HSL2 G (fun _ => P) str2 pats (transfer_parse_of HR p)
    := match
        p in (parse_of _ _ pats)
        return
        (@Forall_parse_of Char _ HSL1 G (fun _ => P) str1 pats p
         -> @Forall_parse_of Char _ HSL2 G (fun _ => P) str2 pats (transfer_parse_of HR p))
      with
        | ParseHead _ _ p' => @transfer_forall_parse_of_production _ _ _ _ p'
        | ParseTail _ _ p' => @transfer_forall_parse_of _ _ _ _ p'
      end
  with transfer_forall_parse_of_production
         str1 str2 pat
         (HR : R str1 str2)
         {p}
         {struct p}
       : @Forall_parse_of_production Char _ HSL1 G (fun _ => P) str1 pat p
         -> @Forall_parse_of_production Char _ HSL2 G (fun _ => P) str2 pat (transfer_parse_of_production HR p)
       := match
           p in (parse_of_production _ _ pat)
           return
           (@Forall_parse_of_production Char _ HSL1 G (fun _ => P) str1 pat p
            -> @Forall_parse_of_production Char _ HSL2 G (fun _ => P) str2 pat (transfer_parse_of_production HR p))
         with
           | ParseProductionNil _ => fun x => x
           | ParseProductionCons _ _ _ p0 p1
             => fun xy
                => (@transfer_forall_parse_of_item' (@transfer_forall_parse_of) _ _ _ _ p0 (fst xy),
                    @transfer_forall_parse_of_production _ _ _ _ p1 (snd xy))
         end.

  Global Arguments transfer_forall_parse_of {_ _ _} HR {_} _.
  Global Arguments transfer_forall_parse_of_production {_ _ _} HR {_} _.

  Definition transfer_forall_parse_of_item
             {str1 str2 it}
             (HR : R str1 str2)
             {p}
  : @Forall_parse_of_item Char _ HSL1 G (fun _ => P) str1 it p
    -> @Forall_parse_of_item Char _ HSL2 G (fun _ => P) str2 it (transfer_parse_of_item HR p)
    := @transfer_forall_parse_of_item' (@transfer_forall_parse_of) str1 str2 it HR p.
End cfg.


Require Import list_examples.
Require Import step_ok.

Definition oddDef :=
  FunDef "odd" ["x"]
         (SIf (BEq "x" 0) (SReturn (ECon 0))
              (SReturn (ECall "even" [EMinus (EVar "x") (ECon 1)]))).
Definition evenDef :=
  FunDef "even" ["x"]
         (SIf (BEq "x" 0) (SReturn (ECon 1))
              (SReturn (ECall "odd" [EMinus (EVar "x") (ECon 1)]))).

(* spec claims that calling def computes the same result as f
   as long as deps and def are included in the funs *)
Definition z_spec (f:Z -> bool) spec deps def :=
  forall y, heap_fun spec deps def [Int y] emptyP (fun r => constraint (r = if f y then 1 else 0)).

Lemma heap_fun_mono (spec1 : Spec kcfg) (spec2 : Spec kcfg):
  forall deps d args init_heap ret,
    heap_fun spec1 deps d args init_heap ret ->
    (forall x P, spec1 x P -> spec2 x P) ->
    heap_fun spec2 deps d args init_heap ret.
Proof.
  intros. unfold heap_fun. destruct d. intros. apply H0. eapply H; eauto.
Qed.

Lemma z_spec_mono (spec1 : Spec kcfg) (spec2 : Spec kcfg):
  forall f deps def,
     z_spec f spec1 deps def ->
     (forall x P, spec1 x P -> spec2 x P) ->
     z_spec f spec2 deps def.
Proof.
  unfold z_spec, heap_fun. firstorder. eapply heap_fun_mono with spec1.
  unfold heap_fun. firstorder. assumption.
Qed.

Inductive ho_spec (A : Spec kcfg): Spec kcfg :=
| even_claim :
    forall OddDef,
      name OddDef = "odd" ->
      (z_spec Z.odd A [evenDef] OddDef) ->
      z_spec Z.even (ho_spec A) [OddDef] evenDef
| odd_claim :
    forall EvenDef,
      name EvenDef = "even" ->
      (z_spec Z.even A [oddDef] EvenDef) ->
      z_spec Z.odd (ho_spec A) [EvenDef] oddDef.

Inductive nonho_spec : Spec kcfg :=
| even_final :
    z_spec Z.even nonho_spec [oddDef] evenDef
| odd_final :
    z_spec Z.odd nonho_spec [evenDef] oddDef.

Inductive make_mono (F : Spec kcfg -> Spec kcfg) X: Spec kcfg :=
  mono_claim :
    forall A : Spec kcfg,
      (forall x P, A x P -> X x P) ->
      forall x P, F A x P -> make_mono F X x P.

Definition make_increasing : forall (F : Spec kcfg -> Spec kcfg) A x P,
    F A x P -> make_mono F A x P :=
  fun F A x P => mono_claim _ _ _ (fun _ _ H => H) x P.

Lemma made_mono : forall (F : Spec kcfg -> Spec kcfg),
   forall A B, (forall x P, A x P -> B x P) ->
               (forall x P, make_mono F A x P -> make_mono F B x P).
Proof. intros. destruct H. econstructor;eauto. Qed.

Lemma my_ho_spec_mono : forall (A : Spec kcfg) x P, make_mono ho_spec A x P -> ho_spec A x P.
Proof.
  destruct 1. destruct H0;econstructor(solve[eauto using z_spec_mono]).
Qed.

(*Lemma ho_spec_mono :*)

Lemma ho_gfp : subspec (nonho_spec) (ho_spec nonho_spec).
Proof.
  destruct 1.
  eapply even_claim with (OddDef := oddDef); try eauto. apply odd_final.
  eapply odd_claim with (EvenDef := evenDef); try eauto. apply even_final.
Qed.

Lemma ho_spec_mono : mono ho_spec.
Proof.
  destruct 2; econstructor; try(eapply z_spec_mono; eassumption; apply H); eassumption.
Qed.

Lemma ho_ok : sound kstep nonho_spec.
Proof.
  unfold sound. apply ok with ho_spec. apply ho_spec_mono.
  intros.
  destruct 1. destruct OddDef. simpl in H, H1.
  eapply sstep. step_solver.
  do 6 (eapply tstep; try apply ho_spec_mono; try step_solver).
  simpl.
  split_bool (y =? 0);use_assumptions.
  do 2 (eapply tstep; try apply ho_spec_mono; try step_solver).
  eapply tdone; try apply ho_spec_mono; done_solver.
  do 8 (eapply tstep; try apply ho_spec_mono; try step_solver).
  simpl.
  eapply ttrans; try apply ho_spec_mono.

  eapply z_spec_mono with (spec2 := T (step kstep) ho_spec A) in H0. eapply H0.
  simpl;equate_maps. assumption. pat_solver.
  intros. eapply Tf_id. trivial.
  trans_use_result.
  do 2 (eapply tstep; try apply ho_spec_mono; try step_solver).
  eapply tdone. apply ho_spec_mono. done_solver.
  rewrite Z.sub_1_r, Z.odd_pred. trivial.

  (* Now odd *)

  destruct EvenDef. simpl in H, H1.
  eapply sstep. step_solver.
  do 6 (eapply tstep; try apply ho_spec_mono; try step_solver).
  simpl.
  split_bool (y =? 0);use_assumptions.
  do 2 (eapply tstep; try apply ho_spec_mono; try step_solver).
  eapply tdone; try apply ho_spec_mono; done_solver.
  do 8 (eapply tstep; try apply ho_spec_mono; try step_solver).
  simpl.
  eapply ttrans; try apply ho_spec_mono.

  eapply z_spec_mono in H0.
  eapply H0.
  simpl;equate_maps. assumption. pat_solver.
  intros. eapply Tf_id. trivial.
  trans_use_result.
  do 2 (eapply tstep; try apply ho_spec_mono; try step_solver).
  eapply tdone. apply ho_spec_mono. done_solver.
  rewrite Z.sub_1_r, Z.even_pred. trivial.

  apply ho_gfp.
Qed.

(* Print Assumptions ho_ok. *)