From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Import Low.Z.
From Tweetnacl Require Import Low.Reduce_by_P_compose_step.
From Tweetnacl Require Import Low.Reduce_by_P_compose_1.
From Tweetnacl Require Import Low.Reduce_by_P_compose_2.
From Tweetnacl Require Import Low.Reduce_by_P_compose.
From stdpp Require Import list.
Require Import Recdef.
Require Import ssreflect.
Open Scope Z.

Lemma bound_a_subst_step_2 : forall a m,
  0 < a < 15 ->
  Zlength m = 16 ->
  Forall (fun x => -2^16 < x <= 0) (take (Z.to_nat (a + 1)) m) ->
  - 2 ^ 16 ≤ nth (Z.to_nat a) (sub_fn_rev_s 1 sub_step_2 (a + 1) m) 0 ∧ nth (Z.to_nat a) (sub_fn_rev_s 1 sub_step_2 (a + 1) m) 0 ≤ 0.
Proof.
intros.
  rewrite sub_fn_rev_s_n.
  2: omega.
  remember (sub_fn_rev_s 1 sub_step_2 (a + 1 - 1) m) as m'.
  replace (a + 1 - 1) with a by omega.
  rewrite /sub_step_2.
  rewrite upd_nth_diff_Zlength.
  4: intro Ha; apply (f_equal Z.of_nat) in Ha ; repeat rewrite Z2Nat.id in Ha ; omega.
  rewrite upd_nth_same_Zlength.
  2,3,4: subst m' ; rewrite ?upd_nth_Zlength ?Z2Nat.id ?sub_fn_rev_s_sub_step_2_Zlength ; omega.
  rewrite /subst_c.
  assert(Handb:= and_0_or_1 (nth (Z.to_nat (a - 1)) m' 0 ≫ 16)).
  assert(Handbb: Z.land (nth (Z.to_nat (a - 1)) m' 0 ≫ 16) 1 = 0 \/ Z.land (nth (Z.to_nat (a - 1)) m' 0 ≫ 16) 1 = 1) by omega.
  clear Handb.
  assert(- 2 ^ 16 < nth (Z.to_nat a) m' 0 ∧ nth (Z.to_nat a) m' 0 ≤ 0).
  replace (a + 1 - 1) with a in Heqm' by omega.
  {
  rewrite nth_drop_2.
  subst m'.
  rewrite sub_fn_rev_f_skip.
  2: rewrite Zlength_correct in H0.
  2: omega.
  2: omega.
  2: {
  replace (length m')%nat with (Z.to_nat (Z.of_nat (length m')))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_le ; subst.
  all: rewrite -?Zlength_correct.
  all: rewrite ?sub_fn_rev_s_sub_step_2_Zlength ; omega.
  }
  rewrite -nth_drop_2.
  2: {
  replace (length m)%nat with (Z.to_nat (Z.of_nat (length m)))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_le -?Zlength_correct ; omega.
  }
  rewrite -(nth_take_full _ (Z.to_nat (a + 1))).
  2: rewrite -Z2Nat.inj_lt ; omega.
  apply Forall_nth_d.
  compute ; split ; [reflexivity | intros; discriminate].
  change_Z_to_nat.
  assumption.
  }
  destruct Handbb as [Handbb|Handbb] ; rewrite Handbb ;  try omega.
Qed.

Lemma bound_a_subst_step_2_lss : forall a m,
  0 < a < 15 ->
  Zlength m = 16 ->
  Forall (fun x => -2^16 < x < 2^16) (take (Z.to_nat (a + 1)) m) ->
  - 2 ^ 16 ≤ nth (Z.to_nat a) (sub_fn_rev_s 1 sub_step_2 (a + 1) m) 0 ∧ nth (Z.to_nat a) (sub_fn_rev_s 1 sub_step_2 (a + 1) m) 0 < 2^16.
Proof.
intros.
  rewrite sub_fn_rev_s_n.
  2: omega.
  remember (sub_fn_rev_s 1 sub_step_2 (a + 1 - 1) m) as m'.
  replace (a + 1 - 1) with a by omega.
  rewrite /sub_step_2.
  rewrite upd_nth_diff_Zlength.
  4: intro Ha; apply (f_equal Z.of_nat) in Ha ; repeat rewrite Z2Nat.id in Ha ; omega.
  rewrite upd_nth_same_Zlength.
  2,3,4: subst m' ; rewrite ?upd_nth_Zlength ?Z2Nat.id ?sub_fn_rev_s_sub_step_2_Zlength ; omega.
  rewrite /subst_c.
  assert(Handb:= and_0_or_1 (nth (Z.to_nat (a - 1)) m' 0 ≫ 16)).
  assert(Handbb: Z.land (nth (Z.to_nat (a - 1)) m' 0 ≫ 16) 1 = 0 \/ Z.land (nth (Z.to_nat (a - 1)) m' 0 ≫ 16) 1 = 1) by omega.
  clear Handb.
  assert(- 2 ^ 16 < nth (Z.to_nat a) m' 0 ∧ nth (Z.to_nat a) m' 0 < 2^16).
  replace (a + 1 - 1) with a in Heqm' by omega.
  {
  rewrite nth_drop_2.
  subst m'.
  rewrite sub_fn_rev_f_skip.
  2: rewrite Zlength_correct in H0.
  2: omega.
  2: omega.
  2: {
  replace (length m')%nat with (Z.to_nat (Z.of_nat (length m')))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_le ; subst.
  all: rewrite -?Zlength_correct.
  all: rewrite ?sub_fn_rev_s_sub_step_2_Zlength ; omega.
  }
  rewrite -nth_drop_2.
  2: {
  replace (length m)%nat with (Z.to_nat (Z.of_nat (length m)))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_le -?Zlength_correct ; omega.
  }
  rewrite -(nth_take_full _ (Z.to_nat (a + 1))).
  2: rewrite -Z2Nat.inj_lt ; omega.
  apply Forall_nth_d.
  compute ; split ; reflexivity.
  change_Z_to_nat.
  assumption.
  }
  destruct Handbb as [Handbb|Handbb] ; rewrite Handbb ;  try omega.
Qed.

Local Ltac solve_this_assert :=
  rewrite sub_fn_rev_s_n; try omega;
  rewrite sub_step_2_Z_inv_lss; Grind_add_Z; try assumption;
  rewrite ?sub_fn_rev_s_sub_step_2_Zlength ; try omega;
  apply bound_a_subst_step_2_lss ; auto ; try omega;
  eapply Forall_take_n_m ; [| eauto];
  Grind_add_Z ; change_Z_to_nat ; omega.

Local Ltac gen_goals P j n := match n with
  | 0 => idtac
  | n =>
    let n'' := (eval compute in (j - n)) in
    assert(P n'');
    [simpl ; solve_this_assert|];
   let n' := (eval compute in (n - 1)) in
   gen_goals P j n'
  end.

Lemma sub_fn_rev_s_sub_step_2_inv : forall a m,
  0 < a < 16 ->
  Zlength m = 16 ->
  Forall (fun x => - 2^16 < x < 2^16) (take 15 m) ->
  ZofList 16 (sub_fn_rev_s 1 sub_step_2 a m) = ZofList 16 m.
Proof.
intros a m Ha Hm Hb.
assert(Hbound: forall a, 0 < a /\ a < 16 -> - 2^16 < nth (Z.to_nat (a - 1)) m 0 < 2^16).
{
  intros x Hx.
  replace(nth (Z.to_nat (x - 1)) m 0) with (nth (Z.to_nat (x - 1)) (take 15 m) 0).
  apply Forall_nth_d.
  compute ; split ; reflexivity.
  assumption.
  apply nth_take_full.
  change 15%nat with (Z.to_nat 15).
  apply Z2Nat.inj_lt ; omega.
}
assert(H1: ℤ16.lst sub_fn_rev_s 1 sub_step_2 1 m = ℤ16.lst m).
  rewrite sub_fn_rev_s_1 ; reflexivity.
assert(H2: ℤ16.lst sub_fn_rev_s 1 sub_step_2 2 m = ℤ16.lst m).
  rewrite sub_fn_rev_s_n ; try apply sub_step_2_Z_inv_lss; [omega | | omega].
  assert(Haspe: 0 < 2 - 1 /\ 2 - 1 < 16) by omega.
  apply Hbound in Haspe; omega.
gen_goals (fun x => (ℤ16.lst sub_fn_rev_s 1 sub_step_2 x m = ℤ16.lst m)) 16 13.
assert_gen_hyp_ Hadec a 15 14 ; try omega.
repeat match goal with
  | _ => assumption
  | _ => progress subst
  | [ H : _ \/ _ |- _ ] => destruct H
end.
Qed.

Close Scope Z.


Require Import Framework.
Require Import String.
Require Import Common.

Require Import Src.
Require Import Trg.
Require Import ASrc.
Require Import ATrg.

Require Import TrgAnalysis.

Module CFFramework := Framework CFObs.

Module CaseStudy.
  Definition src :=
    CFFramework.Build_language
      Src.configuration (* Whole__S *)
      Src.partial (* Partial__S *)
      Src.ctx (* Context__S *)
      (fun C P => Src.initial_cfg (Src.link C P)) (* Linking *)
      Src.step. (* SOS semantics with observables *)

  Definition trg :=
    CFFramework.Build_language
      Trg.configuration
      Trg.partial
      Trg.ctx
      (fun C P => Trg.initial_cfg (Trg.link C P))
      Trg.step.

  (* The abstract source language is just src with a "testing" semantics *)
  Axiom k : nat. (* The maximum number of steps allowed by testing *)
  Axiom TestList : list Src.buf_contents. (* This is the set of inputs *)

  Definition asrc :=
    CFFramework.Build_language
      ASrc.configuration (* Whole__S *)
      Src.partial (* Partial__S *)
      Src.ctx (* Context__S *)
      (fun C P => ASrc.initial_cfg k (Src.initial_cfg (Src.link C P))) (* Linking *)
      (ASrc.step TestList). (* SOS semantics with observables *)

  (* The source analysis is trivial *)
  Definition α__src :=
    (CFFramework.Build_analysis src asrc)
      (fun P => P)
      (fun C => C)
      (fun W => ASrc.initial_cfg k W).

  (* This proof is done pencil and paper in the attached README.org file *)
  Theorem completeness_α__src : CFFramework.complete α__src.
  Proof. Admitted.

  (* The abstract target language is that of history expressions *)
  Definition atrg :=
    CFFramework.Build_language
      ATrg.configuration
      ATrg.partial
      ATrg.ctx
      (fun C P => ATrg.initial_cfg (ATrg.link C P))
      ATrg.step.

  (* The source analysis is a simple type and effect system *)

  Definition trgwhole_of_config (cfg : Trg.configuration) :=
    match cfg with
    | (b, W, T, M, u, f, ς, m, R, pc) => W
    end.

  Definition α__trg :=
    (CFFramework.Build_analysis trg atrg)
      TrgAnalysis.α__partial
      TrgAnalysis.α__ctx
      (fun trgcfg => ATrg.initial_cfg (TrgAnalysis.α__whole (trgwhole_of_config trgcfg))).

  (* This proof is done pencil and paper in the attached README.org file *)
  Theorem linearity_α__trg : CFFramework.llinear α__trg.
  Proof. Admitted.

  Theorem soundness_α__trg : CFFramework.sound α__trg.
  Proof. Admitted.
End CaseStudy.


Require Import VST.msl.seplog.
Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import VST.msl.sepalg.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.predicates_sl.
Require Import VST.msl.subtypes.
Require Import VST.msl.subtypes_sl.
Require Import VST.msl.predicates_rec.
Require Import VST.msl.contractive.
Require VST.msl.normalize.

Local Open Scope logic.

Instance algNatDed (T: Type){agT: ageable T} : NatDed (pred T).
  apply (mkNatDed _
                    predicates_hered.andp
                    predicates_hered.orp
                    (@predicates_hered.exp _ _)
                    (@predicates_hered.allp _ _)
                    predicates_hered.imp predicates_hered.prop
                    (@predicates_hered.derives _ _)).
 apply pred_ext.
 apply derives_refl.
 apply derives_trans.
 apply andp_right.
 apply andp_left1.
 apply andp_left2.
 apply orp_left.
 apply orp_right1.
 apply orp_right2.
 intros ? ?; apply @exp_right.
 intros ? ?; apply @exp_left.
 intros ? ?; apply @allp_left.
 intros ? ?; apply @allp_right.
 apply imp_andp_adjoint.
 repeat intro. eapply H; eauto. hnf; auto.
 repeat intro. hnf; auto.
 repeat intro. specialize (H a (necR_refl _)). simpl in H. auto.
 repeat intro. specialize (H b). simpl in H. auto.
Defined.

Instance algSepLog (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
      @SepLog (pred T) (algNatDed T).
 apply (mkSepLog _ (algNatDed T) predicates_sl.emp predicates_sl.sepcon
            predicates_sl.wand predicates_sl.ewand).
 apply sepcon_assoc.
 apply sepcon_comm.
 intros. pose proof (wand_sepcon_adjoint P Q R). simpl. rewrite H; split; auto.
 intros; simpl. apply predicates_hered.pred_ext; simpl.
          intros ? [w1 [w2 [? [? [? ?]]]]];  split; auto. exists w1; exists w2; repeat split; auto.
          intros ? [? [w1 [w2 [? [? ?]]]]];  exists w1; exists w2; repeat split; auto.
 intros; intro; apply sepcon_derives; auto.
 intros; simpl; apply ewand_sepcon; auto.
 intros; simpl. apply ewand_TT_sepcon; auto.
 intros; simpl. intros w [w1 [w2 [? [? ?]]]]. exists w1,w2; repeat split; auto. exists w2; exists w; repeat split; auto.
  intros; simpl. apply ewand_conflict; auto.
Defined.

Instance algClassicalSep (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T}:
     @ClassicalSep (pred T) (algNatDed T)(algSepLog T).
 constructor; intros. simpl. apply predicates_sl.sepcon_emp.
Qed.

Definition Triv := predicates_hered.pred nat.
Instance TrivNatDed: NatDed Triv := algNatDed nat.
Instance TrivSeplog: SepLog Triv := @algSepLog nat _ _ _ _ (asa_nat).
Instance TrivClassical: ClassicalSep Triv := @algClassicalSep _ _ _ _ _ asa_nat.
Instance TrivIntuitionistic: IntuitionisticSep Triv.
 constructor. intros. hnf. intros. destruct H as [w1 [w2 [? [? _]]]].
 destruct H; subst; auto.
Qed.

Instance algIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}
                {AgeT: Age_alg T}:
         @Indir (pred T) (algNatDed T).
 apply (mkIndir _ _ (box laterM)); intros; simpl in *.
 apply @predicates_hered.now_later.
 apply @predicates_hered.axiomK.
 apply @predicates_hered.later_allp.
 simpl. intros; apply @box_ex.
 simpl. intros; apply @later_ex; auto.
 simpl. intros; apply @later_ex''.
 apply @predicates_hered.later_imp.
 apply @predicates_hered.later_prop.
 apply @predicates_hered.loeb; auto.
Defined.

Instance TrivIndir: Indir Triv := @algIndir nat _ _ _ _ asa_nat.

Section SL2. Import VST.msl.seplog.

Class RecIndir (A: Type) {NA: NatDed A}{IA: Indir A} := mkRecIndir {
  fash : A -> Triv;
  unfash : Triv -> A;
  HORec : forall {X} (f: (X -> A) -> (X -> A)), X -> A;
  unfash_fash:  forall P: A, unfash (fash P) |-- P;
  fash_K: forall P Q, fash (P --> Q) |-- fash P --> fash Q;
  fash_derives: forall P Q, P |-- Q -> fash P |-- fash Q;
  unfash_derives:  forall P Q,  P |-- Q -> unfash P |-- unfash Q;
  later_fash:  forall P, later (fash P) = fash (later P);
  later_unfash:  forall P, later (unfash P) = unfash (later P);
  fash_andp: forall P Q, fash (P && Q) = fash P && fash Q;
  unfash_allp:  forall {B} (P: B -> Triv), unfash (allp P) = ALL x:B, unfash (P x);  subp_allp: forall G B (X Y:B -> A),  (forall x:B, G |-- fash (imp (X x) (Y x))) ->  G |-- fash (imp (allp X) (allp Y));
  subp_exp: forall G B (X Y:B -> A),  (forall x:B, G |-- fash (imp (X x) (Y x))) ->  G |-- fash (imp (exp X) (exp Y));
  subp_e: forall (P Q : A), TT |-- fash (P --> Q) -> P |-- Q;
  subp_i1: forall P (Q R: A), unfash P && Q |-- R -> P |-- fash (Q --> R);
 fash_TT: forall G, G |-- fash TT;
  HOcontractive: forall {X: Type} (f: (X -> A) -> (X -> A)), Prop :=
         fun {X} f => forall P Q,  (ALL x:X, later (fash (P x <--> Q x))) |-- (ALL x:X, fash (f P x <--> f Q x));
  HORec_fold_unfold : forall X (f: (X -> A) -> (X -> A)) (H: HOcontractive f), HORec f = f (HORec f)
}.

Definition HOnonexpansive {A}{NA: NatDed A}{IA: Indir A}{RA: RecIndir A}
        {X: Type} (f: (X -> A) -> (X -> A)) :=
         forall P Q: X -> A,  (ALL x:X, fash (P x <--> Q x)) |-- (ALL x:X, fash (f P x <--> f Q x)).
End SL2.

Notation "'#' e" := (fash e) (at level 30, right associativity): logic.
Notation "'!' e" := (unfash e) (at level 30, right associativity): logic.
Notation "P '>=>' Q" := (# (P --> Q)) (at level 55, right associativity) : logic.
Notation "P '<=>' Q" := (# (P <--> Q)) (at level 57, no associativity) : logic.

Definition algRecIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @RecIndir (pred T) (algNatDed T) (algIndir T).
 apply (mkRecIndir _ _ _ subtypes.fash subtypes.unfash HoRec.HORec); intros; simpl.
 repeat intro. do 3 red in H. apply H; auto.
 apply @subtypes.fash_K.
 apply @subtypes.fash_derives; auto.
 intros ? ?. do 3 red in H0. apply H in H0. apply H0.
 apply @subtypes.later_fash; auto.
 apply @subtypes.later_unfash.
 apply @subtypes.fash_and.
 apply pred_ext; repeat intro; do 3 red in H; apply (H b); auto.
 apply @subtypes.subp_allp; auto.
 eapply @subtypes.subp_exp; auto.
 eapply @subtypes.subp_e; eauto.
 eapply @subtypes.subp_i1; eauto.
 repeat intro; hnf; auto.
 intros. apply HoRec.HORec_fold_unfold; auto.
Defined.

Instance TrivRecIndir: RecIndir Triv := algRecIndir nat.

Section SL3. Import VST.msl.seplog.

Lemma fash_triv: forall P: Triv, fash P = P.
Proof.
 intros.
 apply pred_ext; intros ? ?.
 eapply H. unfold level; simpl.  unfold natLevel; auto.
 hnf; intros. eapply pred_nec_hereditary; try eapply H.
 apply nec_nat. auto.
Qed.

Class SepRec  (A: Type) {NA: NatDed A}{SA: SepLog A}{IA: Indir A}{RA: RecIndir A} := mkSepRec {
  unfash_sepcon_distrib: forall (P: Triv) (Q R: A),
                 andp (unfash P) (sepcon Q R) = sepcon (andp (unfash P) Q) (andp (unfash P) R)
}.

End SL3.

Instance algSepIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @SepIndir (pred T) (algNatDed T) (algSepLog T) (algIndir T).
 apply mkSepIndir; simpl.
 apply @predicates_sl.later_sepcon; auto.
 apply @predicates_sl.later_wand; auto.
 apply @predicates_sl.later_ewand; auto.
Qed.

Instance algSepRec (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @SepRec (pred T) (algNatDed T) (algSepLog T) (algIndir T)(algRecIndir T).
constructor.
 intros; simpl. apply subtypes_sl.unfash_sepcon_distrib.
Qed.

Instance algCorableSepLog (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @CorableSepLog (pred T) (algNatDed T) (algSepLog T).
  apply mkCorableSepLog with (corable := corable.corable).
  + apply corable.corable_prop.
  + apply corable.corable_andp.
  + apply corable.corable_orp.
  + apply corable.corable_imp.
  + intros; apply corable.corable_allp; auto.
  + intros; apply corable.corable_exp; auto.
  + apply corable.corable_sepcon.
  + apply corable.corable_wand.
  + intros; simpl.
    apply corable.corable_andp_sepcon1; auto.
Defined.

Instance algCorableIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @CorableIndir (pred T) (algNatDed T) (algSepLog T) (algCorableSepLog T) (algIndir T).
  unfold CorableIndir; simpl.
  apply corable.corable_later.
Defined.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*           Layers of PM: Assembly Verification for Lemmas            *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MPTInit layer and MPTBit layer*)
Require Import Coqlib.
Require Import Asm.
Require Import Values.
Require Import Integers.
Require Import CommonTactic.
Require Import AST.
Require Import Smallstep.
Require Import liblayers.compat.CompatLayers.
Require Import LAsm.
(*Require Import LoadStoreSem.*)
Require Import FunctionalExtensionality.
Require Import AsmImplLemma.
Require Import LRegSet.
Require Import Conventions.
Require Import AuxLemma.

Local Open Scope string_scope.
Local Open Scope error_monad_scope.

(*
 Definition n_instr (n: int) (rs: regset) := rs # PC <- (Val.add (rs PC) (Vint n)).

 Definition n_instr_nf (n: int) (rs: regset) :=
   (undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs) # PC <- (Val.add (rs PC) (Vint n)).

 Lemma nextinstr_n_instr:
   forall rs,
     nextinstr rs = n_instr Int.one rs.
 Proof.
   unfold nextinstr, n_instr.
   reflexivity.
 Qed.

 Lemma nextinstr_nf_n_instr_nf:
   forall rs,
     nextinstr_nf rs = n_instr_nf Int.one rs.
 Proof.
   unfold nextinstr_nf, n_instr_nf.
   reflexivity.
 Qed.

 Lemma regset_equal:
   forall (rs1 rs2: regset),
     (forall r, Pregmap.get r rs1 = Pregmap.get r rs2) ->
     rs1 = rs2.
 Proof.
   unfold Pregmap.get.
   intros.
   apply functional_extensionality.
   trivial.
 Qed.

 Lemma n_instr_nf_n_instr:
   forall rs n1 n2,
     n_instr_nf n1 (n_instr n2 rs) = n_instr_nf (Int.add n2 n1) rs.
 Proof.
   unfold n_instr, n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
   destruct (rs PC); simpl; try reflexivity;
   Int_Add_Simpl.
 Qed.

 Lemma n_instr_n_instr_nf:
   forall rs n1 n2,
     n_instr n1 (n_instr_nf n2 rs) = n_instr_nf (Int.add n2 n1) rs.
 Proof.
   unfold n_instr, n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
   destruct (rs PC); simpl; try reflexivity;
   Int_Add_Simpl.
 Qed.

 Lemma n_instr_n_instr:
   forall rs n1 n2,
     n_instr n1 (n_instr n2 rs) = n_instr (Int.add n2 n1) rs.
 Proof.
   unfold n_instr. intros.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
   destruct (rs PC); simpl; try reflexivity;
   Int_Add_Simpl.
 Qed.

 Lemma n_instr_nf_n_instr_nf:
   forall rs n1 n2,
     n_instr_nf n1 (n_instr_nf n2 rs) = n_instr_nf (Int.add n2 n1) rs.
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
   destruct (rs PC); simpl; try reflexivity;
   Int_Add_Simpl.
 Qed.

 Lemma n_instr_ireg_set:
   forall rs n i v,
     (n_instr n rs) # (IR i) <- v = n_instr n (rs # (IR i) <- v).
 Proof.
   unfold n_instr. intros.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_nf_ireg_set:
   forall rs n i v,
     (n_instr_nf n rs) # (IR i) <- v = n_instr_nf n (rs # (IR i) <- v).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_RA_set:
   forall rs n v,
     (n_instr n rs) # RA <- v = n_instr n (rs # RA <- v).
 Proof.
   unfold n_instr. intros.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_nf_RA_set:
   forall rs n v,
     (n_instr_nf n rs) # RA <- v = n_instr_nf n (rs # RA <- v).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_PC_set:
   forall rs n v,
     (n_instr n rs) # PC <- v = rs # PC <- v.
 Proof.
   unfold n_instr. intros.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_nf_PC_set:
   forall rs n b ofs,
     (n_instr_nf n rs) # PC <- (Vptr b ofs) = (n_instr_nf Int.zero rs # PC <- (Vptr b ofs)).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
   rewrite Int.add_zero.
   reflexivity.
 Qed.

 Lemma n_instr_ireg:
   forall rs n i,
     (n_instr n rs) (IR i) = rs # (IR i).
 Proof.
   unfold n_instr. intros.
   repeat simpl_Pregmap. trivial.
 Qed.

 Lemma n_instr_nf_ireg:
   forall rs n i,
     (n_instr_nf n rs) (IR i) = rs # (IR i).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   repeat simpl_Pregmap.
   trivial.
 Qed.

 Lemma n_instr_RA:
   forall rs n,
     (n_instr n rs) RA = rs # RA.
 Proof.
   unfold n_instr. intros.
   repeat simpl_Pregmap. trivial.
 Qed.

 Lemma n_instr_nf_RA:
   forall rs n,
     (n_instr_nf n rs) RA = rs # RA.
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   repeat simpl_Pregmap.
   trivial.
 Qed.

 Lemma n_instr_PC:
   forall rs n b ofs,
     rs PC = Vptr b ofs ->
     (n_instr n rs) PC = Vptr b (Int.add ofs n).
 Proof.
   unfold n_instr. intros.
   rewrite H.
   repeat simpl_Pregmap. trivial.
 Qed.

 Lemma n_instr_nf_PC:
   forall rs n b ofs,
     rs PC = Vptr b ofs ->
     (n_instr_nf n rs) PC = Vptr b (Int.add ofs n).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   repeat simpl_Pregmap.
   rewrite H. trivial.
 Qed.

 Lemma n_instr_freg_set:
   forall rs n i v,
     (n_instr n rs) # (FR i) <- v = n_instr n (rs # (FR i) <- v).
 Proof.
   unfold n_instr. intros.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_nf_freg_set:
   forall rs n i v,
     (n_instr_nf n rs) # (FR i) <- v = n_instr_nf n (rs # (FR i) <- v).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_ST0_set:
   forall rs n v,
     (n_instr n rs) # ST0 <- v = n_instr n (rs # ST0 <- v).
 Proof.
   unfold n_instr. intros.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_nf_ST0_set:
   forall rs n v,
     (n_instr_nf n rs) # ST0 <- v = n_instr_nf n (rs # ST0 <- v).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   apply regset_equal.
   intros reg.
   repeat simpl_Pregmap.
   repeat (rewrite Pregmap.gsspec).
   simpl_destruct_reg; trivial.
 Qed.

 Lemma n_instr_freg:
   forall rs n i,
     (n_instr n rs) (FR i) = rs # (FR i).
 Proof.
   unfold n_instr. intros.
   repeat simpl_Pregmap. trivial.
 Qed.

 Lemma n_instr_nf_freg:
   forall rs n i,
     (n_instr_nf n rs) (FR i) = rs # (FR i).
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   repeat simpl_Pregmap.
   trivial.
 Qed.

 Lemma n_instr_ST0:
   forall rs n,
     (n_instr n rs) ST0 = rs # ST0.
 Proof.
   unfold n_instr. intros.
   repeat simpl_Pregmap. trivial.
 Qed.

 Lemma n_instr_nf_ST0:
   forall rs n,
     (n_instr_nf n rs) ST0 = rs # ST0.
 Proof.
   unfold n_instr_nf. intros.
   unfold undef_regs.
   repeat simpl_Pregmap.
   trivial.
 Qed.

 Ltac regset_simpl_tac :=
   match goal with
     | |- context[(n_instr_nf _ _) # _ <- _] =>
       match goal with
         | |- context[(n_instr_nf _ _) # (_:ireg) <- _] => rewrite n_instr_nf_ireg_set
         | |- context[(n_instr_nf _ _) # RA <- _] => rewrite n_instr_nf_RA_set
         | |- context[(n_instr_nf _ _) # PC <- (Vptr _ _)] => rewrite n_instr_nf_PC_set
         | |- context[(n_instr_nf _ _) # (_:freg) <- _] => rewrite n_instr_nf_freg_set
         | |- context[(n_instr_nf _ _) # ST0 <- _] => rewrite n_instr_nf_ST0_set
       end
     | |- context[(n_instr _ _) # _ <- _] =>
       match goal with
         | |- context[(n_instr _ _) # (_:ireg) <- _] => rewrite n_instr_ireg_set
         | |- context[(n_instr _ _) # RA <- _] => rewrite n_instr_RA_set
         | |- context[(n_instr _ _) # PC <- _] => rewrite n_instr_PC_set
         | |- context[(n_instr _ _) # (_:freg) <- _] => rewrite n_instr_freg_set
         | |- context[(n_instr _ _) # ST0 <- _] => rewrite n_instr_ST0_set
       end
     | |- context[(n_instr_nf _ _) _] =>
       match goal with
         | |- context[(n_instr_nf _ _) (_:ireg)] => rewrite n_instr_nf_ireg
         | |- context[(n_instr_nf _ _) RA] => rewrite n_instr_nf_RA
         | |- context[(n_instr_nf _ _) PC] => erewrite n_instr_nf_PC
         | |- context[(n_instr_nf _ _) (_:freg)] => rewrite n_instr_nf_freg
         | |- context[(n_instr_nf _ _) ST0] => rewrite n_instr_nf_ST0
       end
     | |- context[(n_instr _ _) _] =>
       match goal with
         | |- context[(n_instr _ _) (_:ireg)] => rewrite n_instr_ireg
         | |- context[(n_instr _ _) RA] => rewrite n_instr_RA
         | |- context[(n_instr _ _) PC] => erewrite n_instr_PC
         | |- context[(n_instr _ _) (_:freg)] => rewrite n_instr_freg
         | |- context[(n_instr _ _) ST0] => rewrite n_instr_ST0
       end
     | |- context[n_instr_nf _ (n_instr_nf _ _)] => rewrite n_instr_nf_n_instr_nf
     | |- context[n_instr_nf _ (n_instr _ _)] => rewrite n_instr_nf_n_instr
     | |- context[n_instr _ (n_instr_nf _ _)] => rewrite n_instr_n_instr_nf
     | |- context[n_instr _ (n_instr _ _)] => rewrite n_instr_n_instr

     | |- context[?m # ?i <- ?x ?i] => rewrite Pregmap.gss
     | |- context[?m # ?i <- ?x ?j] => rewrite Pregmap.gso; [|discriminate]
     | |- context[nextinstr] => rewrite nextinstr_n_instr
     | |- context[nextinstr_nf] => rewrite nextinstr_nf_n_instr_nf
   end; simpl.

(* Ltac regset_simpl_tac :=
   match goal with
     | |- context[?m # ?i <- ?x ?i] => rewrite Pregmap.gss
     | |- context[?m # ?i <- ?x ?j] => rewrite Pregmap.gso; [|discriminate]
     | |- context[nextinstr] => rewrite nextinstr_n_instr
     | |- context[nextinstr_nf] => rewrite nextinstr_nf_n_instr_nf
     | |- context[n_instr_nf _ (n_instr _ _)] => rewrite n_instr_nf_n_instr
     | |- context[n_instr _ (n_instr_nf _ _)] => rewrite n_instr_n_instr_nf
     | |- context[n_instr _ (n_instr _ _)] => rewrite n_instr_n_instr
     | |- context[n_instr_nf _ (n_instr_nf _ _)] => rewrite n_instr_nf_n_instr_nf
     | |- context[(n_instr_nf _ _) # (_:ireg) <- _] => rewrite n_instr_nf_ireg_set
     | |- context[(n_instr _ _) # (_:ireg) <- _] => rewrite n_instr_ireg_set
     | |- context[(n_instr_nf _ _) # RA <- _] => rewrite n_instr_nf_RA_set
     | |- context[(n_instr _ _) # RA <- _] => rewrite n_instr_RA_set
     | |- context[(n_instr_nf _ _) # PC <- (Vptr _ _)] => rewrite n_instr_nf_PC_set
     | |- context[(n_instr _ _) # PC <- _] => rewrite n_instr_PC_set
     | |- context[(n_instr_nf _ _) (_:ireg)] => rewrite n_instr_nf_ireg
     | |- context[(n_instr _ _) (_:ireg)] => rewrite n_instr_ireg
     | |- context[(n_instr_nf _ _) RA] => rewrite n_instr_nf_RA
     | |- context[(n_instr _ _) RA] => rewrite n_instr_RA
     | |- context[(n_instr_nf _ _) PC] => erewrite n_instr_nf_PC
     | |- context[(n_instr _ _) PC] => erewrite n_instr_PC
   end; simpl.*)

 Ltac one_step_forward n:=
   match goal with
     | |- star _ _ _ _ _ =>
       eapply star_left; try reflexivity
     | |- plus _ _ _ _ _ =>
       econstructor
   end;
   match goal with
     | |- step _ _ _ _ =>
       econstructor; try eassumption;
       match goal with
         | H: _ PC = Vptr ?b _ |- _ = Vptr ?b _ =>
           repeat regset_simpl_tac; try reflexivity; eassumption
         | |- find_instr ?num _ = _ =>
           replace num with n;
             [pc_add_simpl; simpl| try reflexivity]
         | _ => simpl
       end
     | _ => idtac
   end.*)

(*Ltac lens_norm_ortho_trivial :=
  repeat progress
    match goal with
      | |- context [set ?β ?v (set ?α ?u ?s)] =>
        rewrite (lens_ortho_setr_setl u v s)
      | |- context [?α (set ?β ?v ?s)] =>
        rewrite (lens_ortho_getl_setr α β s v)
      | |- context [?β (set ?α ?u ?s)] =>
        rewrite (lens_ortho_getr_setl α β s u)
    end.

Ltac lens_norm_trivial :=
  repeat progress (simpl; lens_norm_ortho_trivial;
                   autorewrite with lens).

Ltac lens_simpl_trivial :=
  repeat progress (lens_norm_trivial; autorewrite with lens_simpl_trivial).

Ltac lens_unfold_trivial :=
  repeat progress (lens_simpl_trivial; unfold set).

Ltac lift_trivial :=
  unfold lift; lens_unfold_trivial; simpl.*)

(* Ltac regset_simpl_tac_n n:=
   repeat regset_simpl_tac;
   match goal with
     | |- context [n_instr ?a _] =>
       replace a with (Int.repr n); [| try reflexivity]
     | |- context [n_instr_nf ?a _] =>
       replace a with (Int.repr n); [| try reflexivity]
   end.*)

 Ltac store_split:=
   repeat match goal with
            | H: _ /\ _ = _ |- _ => destruct H as [H ?]; subst
          end.

 Ltac one_step_forward':=
   match goal with
     | |- star _ _ _ _ _ =>
       eapply star_left; try reflexivity
     | |- plus _ _ _ _ _ =>
       econstructor
   end;
   match goal with
     | |- step _ _ _ _ =>
       econstructor; try eassumption;
       try reflexivity
     | _ => idtac
   end; simpl; [auto; discriminate|..].

 Ltac one_step_forward n:=
   match goal with
     | |- star _ _ _ _ _ =>
       eapply star_left; try reflexivity
     | |- plus _ _ _ _ _ =>
       econstructor
   end;
   match goal with
     | |- step _ _ _ _ =>
       econstructor; try eassumption;
       match goal with
         | H: _ PC = Vptr ?b _ |- _ = Vptr ?b _ =>
           try reflexivity
         | |- find_instr ?num _ = _ =>
           replace num with n;
             [pc_add_simpl; simpl| try reflexivity]
         | _ => simpl
       end
     | _ => idtac
   end; [auto; discriminate|..].

 Lemma val_add_vptr:
   forall n b ofs,
     Int.repr n = Int.add ofs Int.one ->
     Val.add (Vptr b ofs) Vone = Vptr b (Int.repr n).
 Proof.
   simpl. intros.
   congruence.
 Qed.

 Ltac Lregset_simpl_tac:=
   repeat match goal with
            | |- context [undef_regs (map _ destroyed_at_call) (Lregset_fold _)] =>
              rewrite Lregset_fold_destroyed
            | |- context[(Lregset_fold _) _] =>
              rewrite Lregset_fold_get; simpl
            | |- context [nextinstr (Lregset_fold _)] =>
              rewrite Lregset_fold_nextinstr
            | |- context [nextinstr_nf (Lregset_fold _)] =>
              rewrite Lregset_fold_nextinstr_nf
            | |- context[(Lregset_fold _) # RA <- _ ] =>
              rewrite Lregset_fold_ra
            | |- context[(Lregset_fold _) # PC <- _ ] =>
              rewrite Lregset_fold_pc
            | |- context[(Lregset_fold _) # ST0 <- _ ] =>
              rewrite Lregset_fold_st0
            | |- context[(Lregset_fold _) # (IR ?i) <- _ ] =>
              match i with
                | EAX => rewrite Lregset_fold_eax
                | EDX => rewrite Lregset_fold_edx
                | ESP => rewrite Lregset_fold_esp
                | ECX => rewrite Lregset_fold_ecx
                | EDI => rewrite Lregset_fold_edi
                | ESI => rewrite Lregset_fold_esi
                | EBX => rewrite Lregset_fold_ebx
                | EBP => rewrite Lregset_fold_ebp
              end
            | |- context[(Lregset_fold _) # (CR ?i) <- _ ] =>
              match i with
                | ZF => rewrite Lregset_fold_zf
                | CF => rewrite Lregset_fold_cf
                | PF => rewrite Lregset_fold_pf
                | SF => rewrite Lregset_fold_sf
                | OF => rewrite Lregset_fold_of
              end
            | |- context[(Lregset_fold _) # (FR ?i) <- _ ] =>
              match i with
                | XMM0 => rewrite Lregset_fold_xmm0
                | XMM1 => rewrite Lregset_fold_xmm1
                | XMM2 => rewrite Lregset_fold_xmm2
                | XMM3 => rewrite Lregset_fold_xmm3
                | XMM4 => rewrite Lregset_fold_xmm4
                | XMM5 => rewrite Lregset_fold_xmm5
                | XMM6 => rewrite Lregset_fold_xmm6
                | XMM7 => rewrite Lregset_fold_xmm7
              end
          end.

 Ltac Lregset_simpl_tac' n :=
   Lregset_simpl_tac;
   match goal with
     | |- context [Val.add (Vptr ?b ?ofs) Vone] =>
       rewrite (val_add_vptr n b ofs); [| try reflexivity]
   end.

 Lemma reg_false:
   forall reg: preg,
     reg <> PC ->
     reg <> EBP ->
     reg <> EBX ->
     reg <> ESI ->
     reg <> EDI ->
     reg <> ESP ->
     reg <> RA ->
     reg <> EAX ->
     reg <> ECX ->
     reg <> EDX ->
     reg <> OF ->
     reg <> SF ->
     reg <> PF ->
     reg <> CF ->
     reg <> ZF ->
     reg <> XMM7 ->
     reg <> XMM6 ->
     reg <> XMM5 ->
     reg <> XMM4 ->
     reg <> XMM3 ->
     reg <> XMM2 ->
     reg <> XMM1 ->
     reg <> XMM0 ->
     reg <> ST0 ->
     False.
 Proof.
   intros.
   destruct reg; try congruence.
   destruct i; try congruence.
   destruct f; try congruence.
   destruct c; try congruence.
 Qed.

 Ltac link_nextblock_asm :=
   repeat match goal with
            | Hstore: Mem.store _ _ _ _ _ = Some ?fm |- context[Mem.nextblock ?fm] =>
              rewrite (Mem.nextblock_store _ _ _ _ _ _ Hstore)
          end; try reflexivity.

 Ltac link_inject_neutral_asm :=
   repeat match goal with
            | Hstore: Mem.store _ _ _ _ _ = Some ?fm |- Mem.inject_neutral _ ?fm =>
              eapply Mem.store_inject_neutral; eauto 1
          end.

 Lemma inv_reg_le:
   forall (rs: regset) a b,
     (forall r,
        val_inject (Mem.flat_inj a)
                   (rs r) (rs r)) ->
     (a <= b)%positive ->
     (forall r,
        val_inject (Mem.flat_inj b)
                   (rs r) (rs r)).
 Proof.
   intros. eapply val_inject_incr; [|eauto].
   eapply flat_inj_inject_incr; assumption.
 Qed.


From iris.algebra Require Import monoid.
From iris.bi Require Export interface.
From iris.prelude Require Import options.

Definition bi_iff {PROP : bi} (P Q : PROP) : PROP := ((P → Q) ∧ (Q → P))%I.
Global Arguments bi_iff {_} _%I _%I : simpl never.
Global Instance: Params (@bi_iff) 1 := {}.
Infix "↔" := bi_iff : bi_scope.

Definition bi_wand_iff {PROP : bi} (P Q : PROP) : PROP :=
  ((P -∗ Q) ∧ (Q -∗ P))%I.
Global Arguments bi_wand_iff {_} _%I _%I : simpl never.
Global Instance: Params (@bi_wand_iff) 1 := {}.
Infix "∗-∗" := bi_wand_iff : bi_scope.

Class Persistent {PROP : bi} (P : PROP) := persistent : P ⊢ <pers> P.
Global Arguments Persistent {_} _%I : simpl never.
Global Arguments persistent {_} _%I {_}.
Global Hint Mode Persistent + ! : typeclass_instances.
Global Instance: Params (@Persistent) 1 := {}.

Definition bi_affinely {PROP : bi} (P : PROP) : PROP := (emp ∧ P)%I.
Global Arguments bi_affinely {_} _%I : simpl never.
Global Instance: Params (@bi_affinely) 1 := {}.
Typeclasses Opaque bi_affinely.
Notation "'<affine>' P" := (bi_affinely P) : bi_scope.

Class Affine {PROP : bi} (Q : PROP) := affine : Q ⊢ emp.
Global Arguments Affine {_} _%I : simpl never.
Global Arguments affine {_} _%I {_}.
Global Hint Mode Affine + ! : typeclass_instances.

Class BiAffine (PROP : bi) := absorbing_bi (Q : PROP) : Affine Q.
Global Hint Mode BiAffine ! : typeclass_instances.
Existing Instance absorbing_bi | 0.

Class BiPositive (PROP : bi) :=
  bi_positive (P Q : PROP) : <affine> (P ∗ Q) ⊢ <affine> P ∗ Q.
Global Hint Mode BiPositive ! : typeclass_instances.

Definition bi_absorbingly {PROP : bi} (P : PROP) : PROP := (True ∗ P)%I.
Global Arguments bi_absorbingly {_} _%I : simpl never.
Global Instance: Params (@bi_absorbingly) 1 := {}.
Typeclasses Opaque bi_absorbingly.
Notation "'<absorb>' P" := (bi_absorbingly P) : bi_scope.

Class Absorbing {PROP : bi} (P : PROP) := absorbing : <absorb> P ⊢ P.
Global Arguments Absorbing {_} _%I : simpl never.
Global Arguments absorbing {_} _%I.
Global Hint Mode Absorbing + ! : typeclass_instances.

Definition bi_persistently_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
  (if p then <pers> P else P)%I.
Global Arguments bi_persistently_if {_} !_ _%I /.
Global Instance: Params (@bi_persistently_if) 2 := {}.
Typeclasses Opaque bi_persistently_if.
Notation "'<pers>?' p P" := (bi_persistently_if p P) : bi_scope.

Definition bi_affinely_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
  (if p then <affine> P else P)%I.
Global Arguments bi_affinely_if {_} !_ _%I /.
Global Instance: Params (@bi_affinely_if) 2 := {}.
Typeclasses Opaque bi_affinely_if.
Notation "'<affine>?' p P" := (bi_affinely_if p P) : bi_scope.

Definition bi_absorbingly_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
  (if p then <absorb> P else P)%I.
Global Arguments bi_absorbingly_if {_} !_ _%I /.
Global Instance: Params (@bi_absorbingly_if) 2 := {}.
Typeclasses Opaque bi_absorbingly_if.
Notation "'<absorb>?' p P" := (bi_absorbingly_if p P) : bi_scope.

Definition bi_intuitionistically {PROP : bi} (P : PROP) : PROP :=
  (<affine> <pers> P)%I.
Global Arguments bi_intuitionistically {_} _%I : simpl never.
Global Instance: Params (@bi_intuitionistically) 1 := {}.
Typeclasses Opaque bi_intuitionistically.
Notation "□ P" := (bi_intuitionistically P) : bi_scope.

Definition bi_intuitionistically_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
  (if p then □ P else P)%I.
Global Arguments bi_intuitionistically_if {_} !_ _%I /.
Global Instance: Params (@bi_intuitionistically_if) 2 := {}.
Typeclasses Opaque bi_intuitionistically_if.
Notation "'□?' p P" := (bi_intuitionistically_if p P) : bi_scope.

Fixpoint bi_laterN {PROP : bi} (n : nat) (P : PROP) : PROP :=
  match n with
  | O => P
  | S n' => ▷ ▷^n' P
  end%I
where "▷^ n P" := (bi_laterN n P) : bi_scope.
Global Arguments bi_laterN {_} !_%nat_scope _%I.
Global Instance: Params (@bi_laterN) 2 := {}.
Notation "▷? p P" := (bi_laterN (Nat.b2n p) P) : bi_scope.

Definition bi_except_0 {PROP : bi} (P : PROP) : PROP := (▷ False ∨ P)%I.
Global Arguments bi_except_0 {_} _%I : simpl never.
Notation "◇ P" := (bi_except_0 P) : bi_scope.
Global Instance: Params (@bi_except_0) 1 := {}.
Typeclasses Opaque bi_except_0.

Class Timeless {PROP : bi} (P : PROP) := timeless : ▷ P ⊢ ◇ P.
Global Arguments Timeless {_} _%I : simpl never.
Global Arguments timeless {_} _%I {_}.
Global Hint Mode Timeless + ! : typeclass_instances.
Global Instance: Params (@Timeless) 1 := {}.

(** An optional precondition [mP] to [Q].
    TODO: We may actually consider generalizing this to a list of preconditions,
    and e.g. also using it for texan triples. *)
Definition bi_wandM {PROP : bi} (mP : option PROP) (Q : PROP) : PROP :=
  match mP with
  | None => Q
  | Some P => (P -∗ Q)%I
  end.
Global Arguments bi_wandM {_} !_%I _%I /.
Notation "mP -∗? Q" := (bi_wandM mP Q)
  (at level 99, Q at level 200, right associativity) : bi_scope.

(** The class [BiLöb] is required for the [iLöb] tactic. However, for most BI
logics [BiLaterContractive] should be used, which gives an instance of [BiLöb]
automatically (see [derived_laws_later]). A direct instance of [BiLöb] is useful
when considering a BI logic with a discrete OFE, instead of an OFE that takes
step-indexing of the logic in account.

The internal/"strong" version of Löb [(▷ P → P) ⊢ P] is derivable from [BiLöb].
It is provided by the lemma [löb] in [derived_laws_later]. *)
Class BiLöb (PROP : bi) :=
  löb_weak (P : PROP) : (▷ P ⊢ P) → (True ⊢ P).
Global Hint Mode BiLöb ! : typeclass_instances.
Global Arguments löb_weak {_ _} _ _.

Notation BiLaterContractive PROP :=
  (Contractive (bi_later (PROP:=PROP))) (only parsing).

(** The class [BiPureForall] states that universal quantification commutes with
the embedding of pure propositions. The reverse direction of the entailment
described by this type class is derivable, so it is not included.

An instance of [BiPureForall] itself is derivable if we assume excluded middle
in Coq, see the lemma [bi_pure_forall_em] in [derived_laws]. *)
Class BiPureForall (PROP : bi) :=
  pure_forall_2 : ∀ {A} (φ : A → Prop), (∀ a, ⌜ φ a ⌝) ⊢@{PROP} ⌜ ∀ a, φ a ⌝.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.

Require Import Label Language.

Inductive funTy : Type :=
  | ArrowTy : ty -> ty -> funTy.

Definition typing_context := id -> (option ty).
Definition empty_context : typing_context := fun _ => None.

Definition update_typing (gamma : typing_context) (x:id) (T : ty) : typing_context :=
      fun x' => if beq_id x x' then (Some T) else gamma x.

Definition empty_heap : heap := nil.

Inductive tm_has_type : Class_table -> typing_context -> heap -> tm -> ty -> Prop :=
(*variable *)
  | T_Var : forall Gamma x T CT h ,
      Gamma x = Some T ->
      tm_has_type CT Gamma h (Tvar x) T
  | T_EqCmp : forall Gamma e1 e2 clsT h CT,
      tm_has_type CT Gamma h e1 (classTy clsT) ->
      tm_has_type CT Gamma h e2 (classTy clsT) ->
      (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_has_type CT Gamma h (EqCmp e1 e2) boolTy
(* null *)
  | T_null : forall Gamma h cls CT,
      tm_has_type CT Gamma h null (classTy cls)
(* Field read *)
  | T_FieldAccess : forall Gamma e f cls_def CT clsT cls' h fields_def,
      tm_has_type CT Gamma h e (classTy clsT) ->
      Some cls_def = CT(clsT) ->
      fields_def = (find_fields cls_def) ->
      type_of_field fields_def f = Some cls' ->
      tm_has_type CT Gamma h (FieldAccess e f) (classTy cls')
(* method call *)
  | T_MethodCall : forall Gamma  e meth argu CT h T returnT cls_def body arg_id arguT,
      tm_has_type CT Gamma h e (classTy T) ->
      tm_has_type CT Gamma h argu arguT ->
      Some cls_def = CT(T) ->
      find_method cls_def meth = Some (m_def returnT meth arguT arg_id  body)  ->
      surface_syntax body = true ->
      tm_has_type CT Gamma h (MethodCall e meth argu) returnT
(* new exp *)
  | T_NewExp : forall h Gamma cls_name CT,
      (exists cls_def field_defs method_defs, CT cls_name = Some cls_def /\
              cls_def = class_def cls_name field_defs method_defs) ->
      tm_has_type CT Gamma h (NewExp cls_name) (classTy cls_name)

(* booleans  *)
  | T_true : forall h Gamma CT,
      tm_has_type CT Gamma h B_true boolTy
  | T_false : forall h Gamma CT,
      tm_has_type CT Gamma h B_false boolTy
(* label *)
  | T_label : forall h Gamma lb CT,
      tm_has_type CT Gamma h (l lb) LabelTy
(* label data *)
  | T_labelData : forall h Gamma  CT e1 e2 T,
      tm_has_type CT Gamma h e2 LabelTy ->
      tm_has_type CT Gamma h e1 T ->
      tm_has_type CT Gamma h (labelData e1 e2) (LabelelTy T)
(* unlabel *)
  | T_unlabel : forall h Gamma CT e T,
      tm_has_type CT Gamma h e (LabelelTy T) ->
      tm_has_type CT Gamma h (unlabel e) T
(* labelOf *)
  | T_labelOf : forall h Gamma CT e T,
      tm_has_type CT Gamma h e (LabelelTy T) ->
      tm_has_type CT Gamma h (labelOf e) LabelTy

(* objectLabelOf *)
  | T_objectLabelOf : forall h Gamma CT e clsT,
      tm_has_type CT Gamma h e  (classTy clsT)  ->
      (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_has_type CT Gamma h (objectLabelOf e) LabelTy

(* raise label *)
  | T_raiseLabel : forall h Gamma CT e1 e2 clsT,
      tm_has_type CT Gamma h e2 LabelTy ->
      tm_has_type CT Gamma h e1 (classTy clsT) ->
      (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_has_type CT Gamma h (raiseLabel e1 e2) (classTy clsT)
(* toLabeled *)
  | T_toLabeled : forall h Gamma v CT e T,
      tm_has_type CT Gamma h v LabelTy ->
      tm_has_type CT Gamma h e T ->
      tm_has_type CT Gamma h (toLabeled e v) (LabelelTy T)
(* getCurrentLevel *)
  | T_getCurrentLevel : forall h Gamma CT,
      tm_has_type CT Gamma h (getCurrentLevel) LabelTy
(* assignment *)
  | T_assignment : forall h Gamma CT e T x,
      Gamma x = Some T ->
      tm_has_type CT Gamma h e T ->
      tm_has_type CT Gamma h (Assignment x e) T
(* Field Write *)
  | T_FieldWrite : forall h Gamma x f cls_def CT clsT cls' e,
      tm_has_type CT Gamma h x (classTy clsT) ->
      tm_has_type CT Gamma h e (classTy cls') ->
      Some cls_def = CT(clsT) ->
      type_of_field (find_fields cls_def) f = Some cls' ->
      tm_has_type CT Gamma h (FieldWrite x f e)  (classTy cls')
(* if *)
  | T_if : forall Gamma h CT guard s1 s2 T' ,
      tm_has_type CT Gamma h guard boolTy ->
      tm_has_type CT Gamma h s1 T' ->
      tm_has_type CT Gamma h s2 T' ->
      tm_has_type CT Gamma h (If guard s1 s2) T'
(* sequence *)
  | T_sequence : forall h Gamma CT e1 e2 T T',
      tm_has_type CT Gamma h e1 T ->
      tm_has_type CT Gamma h e2 T' ->
      tm_has_type CT Gamma h (Sequence e1 e2) T'

(* ObjId *)
  | T_ObjId : forall h Gamma CT o cls_name cls_def,
      Some cls_def = CT(cls_name) ->
      (exists field_defs method_defs, cls_def = (class_def cls_name field_defs method_defs)) ->
      (exists F lo ll, lookup_heap_obj h o = Some (Heap_OBJ cls_def F lo ll)) ->
      tm_has_type CT Gamma h (ObjId o) (classTy cls_name)
(* runtime labeled data *)
  | T_v_l : forall h Gamma lb CT v T,
      tm_has_type CT Gamma h (l lb)  LabelTy ->
      tm_has_type CT Gamma h v  T ->
      value v ->
      tm_has_type CT Gamma h (v_l v lb) (LabelelTy T)
(* runtime labeled data *)
  | T_v_opa_l : forall h Gamma lb CT v T,
      tm_has_type CT Gamma h (l lb)  LabelTy ->
      tm_has_type CT Gamma h v  T ->
      value  v  ->
      (forall v0 lb0, v <> v_opa_l v0 lb0 ) ->
      tm_has_type CT Gamma h (v_opa_l v lb)  T.
(* hole *)
(*  | T_hole : forall h Gamma CT T,
      tm_has_type CT Gamma h hole T.
 *)
Hint Constructors tm_has_type.

Inductive tm_hole_has_type : Class_table -> typing_context -> heap -> tm -> funTy -> Prop :=

  | T_EqCmp1 : forall e1 e2 Gamma clsT CT h,
      tm_has_type CT Gamma h e1 (classTy clsT) ->
      tm_has_type CT Gamma h e2 (classTy clsT) ->
      (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_has_type CT Gamma h (EqCmp e1 e2) boolTy ->
      tm_hole_has_type CT Gamma h (EqCmp hole e2) (ArrowTy (classTy clsT) boolTy)
  | T_EqCmp2 : forall e1 e2 Gamma clsT CT h,
      tm_has_type CT Gamma h e1 (classTy clsT) ->
      tm_has_type CT Gamma h e2 (classTy clsT) ->
      (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_has_type CT Gamma h (EqCmp e1 e2) boolTy ->
      tm_hole_has_type CT Gamma h (EqCmp e1 hole) (ArrowTy (classTy clsT) boolTy)

  | T_hole_FieldAccess : forall  Gamma f cls_def CT clsT cls' h fields_def,
      (*
      tm_has_type CT Gamma h (FieldAccess e f) (classTy cls') ->
      tm_has_type CT Gamma h e (classTy clsT) ->
       *)
      Some cls_def = CT(clsT) ->
      fields_def = (find_fields cls_def) ->
      type_of_field fields_def f = Some cls' ->
      tm_hole_has_type CT Gamma h (FieldAccess hole f) (ArrowTy (classTy clsT) (classTy cls'))

  | T_hole_MethodCall1 : forall Gamma  meth argu CT h T returnT cls_def body arg_id arguT,
      (* tm_has_type CT Gamma h (MethodCall e meth argu) (OpaqueLabeledTy (classTy returnT)) ->
      tm_has_type CT Gamma h e (classTy T) ->  *)
      tm_has_type CT Gamma h argu arguT ->
      Some cls_def = CT(T) ->
      find_method cls_def meth = Some (m_def returnT meth arguT arg_id  body)  ->
      surface_syntax body = true ->
      tm_hole_has_type CT Gamma h (MethodCall hole meth argu) (ArrowTy (classTy T)
                                                                       returnT)

  | T_hole_MethodCall2 : forall Gamma  e meth CT h T returnT cls_def body arg_id arguT,
      (* tm_has_type CT Gamma h (MethodCall e meth argu) (OpaqueLabeledTy (classTy returnT)) ->
      tm_has_type CT Gamma h argu (classTy arguT) -> *)
      tm_has_type CT Gamma h e (classTy T) ->
      Some cls_def = CT(T) ->
      find_method cls_def meth = Some (m_def returnT meth arguT arg_id  body)  ->
      surface_syntax body = true ->
      tm_hole_has_type CT Gamma h (MethodCall e meth hole) (ArrowTy (arguT)
                                                                    ( returnT))

  | T_hole_labelData1 : forall h Gamma CT T e2 ,
      (* tm_has_type CT Gamma h (labelData e lb) (LabelelTy T) -> *)
      tm_has_type CT Gamma h e2 LabelTy ->
      tm_hole_has_type CT Gamma h (labelData hole e2) (ArrowTy T (LabelelTy T))

  | T_hole_labelData2 : forall h Gamma CT T v,
      value v ->
      tm_has_type CT Gamma h v T ->
      tm_hole_has_type CT Gamma h (labelData v hole) (ArrowTy LabelTy (LabelelTy T))

  (*unlabel data*)
  | T_hole_unlabel : forall h Gamma CT T,
      (* tm_has_type CT Gamma h (unlabel e) T -> *)
      tm_hole_has_type CT Gamma h (unlabel hole) (ArrowTy (LabelelTy T) T)
  (*labelOf data*)
  | T_hole_labelOf : forall h Gamma CT  T,
      (* tm_has_type CT Gamma h (labelOf e) LabelTy -> *)
      tm_hole_has_type CT Gamma h (labelOf hole) (ArrowTy ( (LabelelTy T)) LabelTy)

  (* objectLabelOf *)
  | T_hole_objectLabelOf : forall h Gamma CT  clsT,
      (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_hole_has_type CT Gamma h (objectLabelOf hole) (ArrowTy (classTy clsT) LabelTy)

  | T_hole_raiseLabel1 : forall  Gamma e2  CT clsT h,
      tm_has_type CT Gamma h e2 LabelTy ->
      (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_hole_has_type CT Gamma h (raiseLabel hole e2) (ArrowTy (classTy clsT) (classTy clsT))

  | T_hole_raiseLabel2 : forall  Gamma e1  CT clsT h,
      tm_has_type CT Gamma h e1 (classTy clsT) ->
       (exists cls_def field_defs method_defs, CT clsT = Some cls_def /\
              cls_def = class_def clsT field_defs method_defs) ->
      tm_hole_has_type CT Gamma h (raiseLabel e1 hole) (ArrowTy LabelTy (classTy clsT))

  | T_hole_toLabeled : forall h Gamma CT T e ,
      tm_has_type CT Gamma h e T ->
      tm_hole_has_type CT Gamma h (toLabeled e hole) (ArrowTy LabelTy (LabelelTy T))

(* assignment *)
  | T_hole_assignment : forall h Gamma CT  T x ,
      (* tm_has_type CT Gamma h (Assignment x e) voidTy -> *)
      Gamma x = Some T ->
      tm_hole_has_type CT Gamma h (Assignment x hole) (ArrowTy T T)

  (* sequence *)
  | T_hole_sequence : forall h Gamma CT  T T' s2,
      tm_has_type CT Gamma h s2 T ->
      tm_hole_has_type CT Gamma h (Sequence hole s2) (ArrowTy T' T)

(* if *)
  | T_hole_if : forall h Gamma CT s1 s2 T,
      tm_has_type CT Gamma h s1 T ->
      tm_has_type CT Gamma h s2 T ->
      tm_hole_has_type CT Gamma h (If hole s1 s2) (ArrowTy boolTy T)

(* Field Write *)
  | T_hole_FieldWrite1 : forall  h Gamma f cls_def CT clsT cls' e,
      (*tm_has_type CT Gamma h (FieldWrite x f e) voidTy ->
       tm_has_type CT Gamma h x (classTy clsT) -> *)
      tm_has_type CT Gamma h e (classTy cls') ->
      Some cls_def = CT(clsT) ->
      type_of_field (find_fields cls_def) f = Some cls' ->
      tm_hole_has_type CT Gamma h (FieldWrite hole f e) (ArrowTy (classTy clsT) (classTy cls'))
  | T_hole_FieldWrite2 : forall  h Gamma x f cls_def CT clsT cls',
      tm_has_type CT Gamma h x (classTy clsT) ->
      Some cls_def = CT(clsT) ->
      type_of_field (find_fields cls_def) f = Some cls' ->
      tm_hole_has_type CT Gamma h (FieldWrite x f hole) (ArrowTy (classTy cls') (classTy cls') ).
Hint Constructors tm_hole_has_type.

Inductive fs_has_type : Class_table -> typing_context -> heap -> list tm -> funTy -> Prop :=
  | T_fs_nil : forall h Gamma CT T,
      fs_has_type CT Gamma h nil (ArrowTy T T)
  | T_fs_hole : forall h Gamma CT T T' top fs T1,
      hole_free top  = false ->
      tm_hole_has_type CT Gamma h top ((ArrowTy T T')) ->
      fs_has_type CT Gamma h (fs) (ArrowTy T' T1) ->
      fs_has_type CT Gamma h (top :: fs) (ArrowTy T T1).

  (*
  | T_fs_one : forall h Gamma CT T top,
      hole_free top = true ->
      tm_has_type CT Gamma h top T ->
      fs_has_type CT Gamma h (top :: nil) (ArrowTy T T)

  | T_fs_hole : forall h Gamma CT T T' top fs p,
      hole_free top = true ->
      hole_free p  = false ->
      tm_has_type CT Gamma h top T ->
      fs_has_type CT Gamma h (p :: fs) (ArrowTy T T') ->
      fs_has_type CT Gamma h (top :: p :: fs) (ArrowTy T T')
  | T_fs_no_hole : forall h Gamma CT T T' T0 top fs p,
      hole_free p  = true ->
      hole_free top = true ->
      tm_has_type CT Gamma h top T ->
      fs_has_type CT Gamma h (p :: fs) (ArrowTy T0 T') ->
      fs_has_type CT Gamma h (top :: p :: fs) (ArrowTy T T')
*)
Hint Constructors fs_has_type.

Inductive well_typed_stack_frame : Class_table -> typing_context ->
                           stack_frame -> heap -> Prop :=
| well_typed_sf : forall ct gamma sf  h,
    (forall x T, gamma x = Some T ->
    exists v, sf x = Some v /\
    tm_has_type ct gamma h v T) ->
    well_typed_stack_frame ct gamma sf h.
Hint Constructors well_typed_stack_frame.

Inductive ctn_has_type : Class_table -> typing_context -> heap -> container -> funTy -> Prop :=
    | T_ctn_type : forall h Gamma CT T lb fs open_t sf T',
        tm_has_type CT Gamma h open_t T ->
        well_typed_stack_frame CT Gamma sf h ->
        fs_has_type CT Gamma h fs (ArrowTy T T')  ->
        ctn_has_type CT Gamma h (Container open_t fs lb sf) (ArrowTy T T').
Hint Constructors ctn_has_type.

Inductive ctn_list_has_type : Class_table -> typing_context -> heap -> list container -> funTy -> Prop :=
  | T_ctn_nil : forall h Gamma CT T ,
      ctn_list_has_type CT Gamma h nil (ArrowTy T T)
  | T_ctn_list : forall h Gamma CT T0 T1 T' Gamma' ctn ctns',
      ctn_has_type CT Gamma' h ctn (ArrowTy T0 T1) ->
      ctn_list_has_type CT Gamma h ctns' (ArrowTy  T1 T') ->
      ctn_list_has_type CT Gamma h (ctn :: ctns')  (ArrowTy T0 T').
Hint Constructors ctn_list_has_type.

  Inductive well_typed_class_table : Class_table -> Prop :=
  | well_typed_CT : forall CT,
      (forall clsT cls_def field_defs method_defs,
      CT clsT = Some cls_def ->
      cls_def = class_def clsT field_defs method_defs ->
      (forall gamma h returnT meth arguT arg_id  body ,
          Some (m_def returnT meth arguT arg_id body) = find_method cls_def meth ->
          (gamma = update_typing empty_context arg_id arguT) ->
          (tm_has_type CT gamma h body returnT)
      )) ->
      well_typed_class_table CT.
  Hint Constructors well_typed_class_table.

Inductive config_has_type : Class_table -> typing_context -> config -> ty -> Prop :=
  | T_config_ctns : forall h Gamma CT T T' T0 ctn ctns Gamma',
      ctn_has_type CT Gamma' h ctn (ArrowTy T0 T) ->
      ctn_list_has_type CT Gamma h ctns (ArrowTy T T') ->
      well_typed_class_table CT ->
      config_has_type CT Gamma (Config CT ctn ctns h) T'.
Hint Constructors config_has_type.

Hint Constructors ctn_list_has_type.
Hint Constructors ctn_has_type.
Hint Constructors fs_has_type.


 Inductive month : Set :=
   | January : month
   | February : month
   | March : month
   | April : month
   | May : month
   | June : month
   | July : month
   | August : month
   | September : month
   | October : month
   | November : month
   | December : month
  .