(** * NotModifyDec.v : Decision procedure for determining the
   variables that a progam (not) modifies *)

Set Implicit Arguments.

Require Export SemTheory.

Module Make (Sem:SEM).

 Module SemTh := SemTheory.Make Sem.
 Export SemTh.

 Definition modify_base X (i:I.baseInstr) :=
   match i with
   | I.Assign t x e =>
      if E.eqb e x then X else Vset.add x X
   | I.Random t x _ => Vset.add x X
   | I.IAssert e => X
   end.

 Section MODIFY.

  Variable E: env.

  Variable mod_info :  forall t (f:Proc.proc t), option Vset.t.

  Hypothesis mod_info_correct : forall t (f:Proc.proc t) GM,
   mod_info f = Some GM ->
   (forall x, Vset.mem x GM -> Var.is_global x) /\
   (exists L, (forall x, Vset.mem x L -> Var.is_local x) /\
    Modify E (Vset.union L GM) (proc_body E f)).

  Fixpoint modify_i_1 (X:Vset.t) (i:I.instr) {struct i} : option Vset.t :=
   match i with
   | I.Instr i  => Some (modify_base X i)
   | I.Cond _ c1 c2 =>
     opt_app (fold_left_opt modify_i_1 c1) (fold_left_opt modify_i_1 c2 X)
   | I.While _ c => fold_left_opt modify_i_1 c X
   | I.Call t d f _ =>
     match mod_info f with
     | Some GM => Some (Vset.add d (Vset.union GM X))
     | None => None
     end
    end.

  Definition modify_1 X (c:cmd) := fold_left_opt modify_i_1 c X.

  Lemma modify_1_correct_aux :
   (forall i X, spec_opt (fun R => Modify E R [i] /\ X [<=] R)
    (modify_i_1 X i)) /\
   (forall c X, spec_opt (fun R => Modify E R c /\ X [<=] R)
    (modify_1 X c)).
  Proof.
   unfold modify_1; intros; apply I.cmd_ind2; simpl; intros.
   (* baseInstr *)
   destruct i; simpl.
   generalize (E.eqb_spec e v); destruct (E.eqb e v);
    intros; split; auto with set.
   rewrite H; apply Modify_weaken with Vset.empty; auto with set.
   apply Modify_assign_same.
   apply Modify_weaken with (Vset.singleton v).
   apply Modify_assign.
   apply Vset.subset_complete; intro; rewrite VsetP.add_spec.
   intros H1; left; apply (Vset.singleton_complete _ _ H1).
   split; auto with set.
   apply Modify_weaken with (Vset.singleton v).
   apply Modify_random.
   apply Vset.subset_complete; intro; rewrite VsetP.add_spec.
   intros H1; left; apply (Vset.singleton_complete _ _ H1).

   split; [ | auto with set].
   apply Modify_weaken with Vset.empty.
   apply Modify_assert.
   auto with set.

   (* Cond *)
   assert (H0' := H0 X); clear H0.
   destruct (fold_left_opt modify_i_1 c2 X) as [R2|]; try exact I.
   assert (H' := H R2); clear H.
   unfold opt_app; destruct (fold_left_opt modify_i_1 c1 R2) as [R1|];
    try exact I.
   destruct H0'; destruct H'; split.
   apply Modify_weaken with (Vset.union R1 R2).
   apply Modify_cond; auto.
   rewrite VsetP.union_sym; rewrite VsetP.subset_union; auto with set.
   apply VsetP.subset_trans with R2; auto.

   (* While *)
   assert (H' := H X); destruct (fold_left_opt modify_i_1 c X); destruct H';
    split; auto.
   apply Modify_while; auto.

   (* Call *)
   generalize (@mod_info_correct _ f).
   destruct (mod_info f) as [GM | ]; simpl; trivial; split;auto with set.
   destruct (H _ (eq_refl _)) as (H2,(L,(H0,H1))).
   apply Modify_weaken with  (Vset.add x GM).
   eapply Modify_weaken;[ apply Modify_call with (1:=H1) | ].
   apply VsetP.subset_add_ctxt.
   apply Vset.subset_complete; intros.
   assert (W:=get_globals_spec _ _ H3).
   assert (Vset.mem x0 (Vset.union L GM)).
   apply Vset.subset_correct with
    (1:= get_globals_subset(Vset.union L GM)); trivial.
   rewrite VsetP.union_spec in H4; destruct H4; trivial.
   apply H0 in H4; unfold Var.is_local in H4; rewrite W in H4; discriminate.
   apply VsetP.subset_add_ctxt;auto with set.

   (* nil *)
   split; auto with set.
   apply Modify_weaken with Vset.empty; auto with set.
   apply Modify_nil.

   (* cons *)
   assert (H':= H X); clear H; destruct (modify_i_1 X i) as [Ri|]; try exact I; simpl.
   assert (H0' := H0 Ri); clear H0; unfold opt_app;
     destruct (fold_left_opt modify_i_1 c Ri) as [Rc|]; try exact I; simpl in *.
   destruct H'; destruct H0'; split.
   apply Modify_weaken with (Vset.union Ri Rc); auto with set.
   apply Modify_cons; auto.
   rewrite VsetP.subset_union; auto with set.
   apply VsetP.subset_trans with Ri; auto.
  Qed.

  Definition modify_2 := modify_1 Vset.empty.

  Lemma modify_2_correct :
    forall c M, modify_2 c = Some M -> Modify E M c.
  Proof.
    destruct modify_1_correct_aux;unfold modify_2;intros.
    assert (W:=H0 c Vset.empty);rewrite H1 in W;destruct W;trivial.
  Qed.

 End MODIFY.

 Section LOSSLESS.

  Variable E: env.

  Variable lossless_info :  forall t, Proc.proc t ->  bool.

  Hypothesis lossless_info_correct : forall t (f:Proc.proc t),
   lossless_info f -> lossless E (proc_body E f).

  Definition list_forall := Eval cbv beta delta [forallb andb ifb] in forallb.

  Fixpoint is_lossless_i_1 (i:I.t) : bool :=
   match i with
   | I.Instr (I.Assign _ _ _) => true
   | I.Instr (I.Random _ _ _) => true
   | I.Cond _ c1 c2 =>
     if list_forall is_lossless_i_1 c1 then list_forall is_lossless_i_1 c2
     else false
   | I.Call t d f arg => lossless_info f
   | _ => false
  end.

  Definition is_lossless_1 : cmd -> bool := list_forall is_lossless_i_1.

  Lemma is_lossless_1_correct_aux :
   (forall i, is_lossless_i_1 i -> lossless E [i]) /\
   (forall c, is_lossless_1 c -> lossless E c).
  Proof.
   apply I.cmd_ind2; simpl; intros; trivialb.
   destruct i; auto using lossless_assign, lossless_random; discriminate.
   unfold is_lossless_1 in *.
   destruct (list_forall is_lossless_i_1 c1); trivialb.
   destruct (list_forall is_lossless_i_1 c2); trivialb.
   apply lossless_cond; trivial.
   apply lossless_call; auto.
   apply lossless_nil.
   destruct (is_lossless_i_1 i); trivialb.
   apply lossless_cons; trivial.
  Qed.

  Lemma is_lossless_1_correct : forall c, is_lossless_1 c -> lossless E c.
  Proof.
   destruct is_lossless_1_correct_aux; trivial.
  Qed.

 End LOSSLESS.

 Section NOTMODIFY.

  Variable E : env.

  Variable pi : eq_refl_info E.

  Definition pi_to_mod_info := fun t f =>
    match @pi t f with
    | Some i => Some (pi_mod i)
    | _ => None
    end.

  Definition modify_i := modify_i_1 pi_to_mod_info.

  Definition modify X (c:cmd) := fold_left_opt modify_i c X.

  Lemma modify_correct_aux :
   (forall i X, spec_opt (fun R => Modify E R [i] /\ X [<=] R)
    (modify_i X i)) /\
   (forall c X, spec_opt (fun R => Modify E R c /\ X [<=] R)
    (modify X c)).
  Proof.
   apply modify_1_correct_aux.
   unfold pi_to_mod_info;intros t f GM.
   destruct (pi f);[ | discriminate].
   intros Heq;injection Heq;intros;subst;split.
   apply mod_global. apply mod_spec.
  Qed.

  Lemma modify_i_correct_subset : forall i X R,
   modify_i X i = Some R ->
   Modify E R [i] /\ X [<=] R.
  Proof.
   destruct modify_correct_aux as (H1,H2); intros i Y R Heq.
   assert (H3 := H1 i Y); rewrite Heq in H3; trivial.
  Qed.

  Lemma modify_i_correct : forall i X R,
   modify_i X i = Some R ->
   Modify E R [i].
  Proof.
   intros i X R H; destruct (modify_i_correct_subset _ _ H); trivial.
  Qed.

  Lemma modify_correct_subset : forall c X R,
   modify X c = Some R ->
   Modify E R c /\ X [<=] R.
  Proof.
   destruct modify_correct_aux as (H1,H2); intros c Y R Heq.
   assert (H3 := H2 c Y); rewrite Heq in H3; trivial.
  Qed.

  Lemma modify_correct : forall c X R,
   modify X c = Some R ->
   Modify E R c.
  Proof.
   intros c Y R H; destruct (modify_correct_subset _ _ H); trivial.
  Qed.

  Definition is_notmodify X c :=
   match modify Vset.empty c with
   | Some X' => Vset.disjoint X X'
   | _ => false
   end.

  Definition is_notmodify_i X i :=
   match modify_i Vset.empty i with
   | Some X' => Vset.disjoint X X'
   | _ => false
   end.

  Lemma is_notmodify_correct : forall X c,
   is_notmodify X c -> exists M, Modify E M c /\ Vset.disjoint X M.
  Proof.
   unfold is_notmodify; intros X c.
   case_eq (modify Vset.empty c); intros; trivialb.
   exists t; split; trivial.
   eapply modify_correct; eauto.
  Qed.

  Lemma is_notmodify_i_correct : forall X i,
   is_notmodify_i X i -> exists M, Modify E M [i] /\ Vset.disjoint X M.
  Proof.
   unfold is_notmodify_i; intros X i.
   case_eq (modify_i Vset.empty i); intros; trivialb.
   exists t; split; trivial.
   eapply modify_i_correct; eauto.
  Qed.

  (** Deciding lossless *)

  Definition pi_to_lossless_info := fun t f =>
    match @pi t f with
    | Some i =>  pi_lossless i
    | _ => false
    end.

  Lemma pi_to_lossless_info_correct : forall t (f:Proc.proc t),
   pi_to_lossless_info f -> lossless E (proc_body E f).
  Proof.
   unfold pi_to_lossless_info;intros.
   destruct (pi f);[ | discriminate].
   apply pi_lossless_spec with p;trivial.
  Qed.

  Definition is_lossless_i := is_lossless_i_1 pi_to_lossless_info.

  Definition is_lossless : cmd -> bool := is_lossless_1 pi_to_lossless_info.

  Lemma is_lossless_correct_aux :
   (forall i, is_lossless_i i -> lossless E [i]) /\
   (forall c, is_lossless c -> lossless E c).
  Proof.
   apply is_lossless_1_correct_aux;apply pi_to_lossless_info_correct.
  Qed.

  Lemma is_lossless_i_correct : forall i, is_lossless_i i -> lossless E [i].
  Proof.
   destruct is_lossless_correct_aux; trivial.
  Qed.

  Lemma is_lossless_correct : forall c, is_lossless c -> lossless E c.
  Proof.
   destruct is_lossless_correct_aux; trivial.
  Qed.

 End NOTMODIFY.

End Make.


(* This file is a monster. Working with type classes is great, but the mechanisms for
   creating an instance are currently very fragile. One major piece of work will be to
   make this easier. Ideally, this file should not be larger than a few tens of lines
   at most. *)

Require Import ILogic ILInsts SepAlg BILogic BILInsts IBILogic SepAlgMap Maps String Rel.
Require Import RelationClasses Setoid Morphisms Program.
Require Import MapInterface MapFacts.
Require Import Charge.Open.Open.
Require Import Charge.Open.Stack Lang OpenILogic Pure ILEmbed PureInsts.
Require Import UUSepAlg SepAlgInsts HeapArr.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.String.

Local Existing Instance ILPre_Ops.
Local Existing Instance ILPre_ILogic.

Local Existing Instance ILFun_Ops.
Local Existing Instance ILFun_ILogic.
Local Existing Instance SAIBIOps.
Local Existing Instance SAIBILogic.
Local Existing Instance BILPre_Ops.
Local Existing Instance IBILPreLogic.
Local Existing Instance BILFun_Ops.
Local Existing Instance IBILFunLogic.

Local Existing Instance MapSepAlgOps.
Local Existing Instance MapSepAlg.
Local Existing Instance MapEquiv.
Local Existing Instance EquivPreorder.
Local Existing Instance UUMapSepAlg.
Local Existing Instance SepAlgOps_prod.
Local Existing Instance SepAlg_prod.
Local Existing Instance UUSepAlg_prod.

Definition heap_ptr := Map [ptr * field, val].

Definition heap := (heap_ptr * heap_arr)%type.

Definition heap_ptr_unit : heap_ptr := @map_unit _ _ _ val.
Definition heap_unit : heap := (heap_ptr_unit, heap_arr_unit).

Definition heap_add_ptr (h : heap) (p : ptr) (f : field) (v : val) : heap :=
  (add (p, f) v (fst h), snd h).
Definition heap_add_arr (h : heap) (n m : nat) (v : val) : heap :=
  (fst h, add (n, m) v (snd h)).

Instance RelHeapPtr : Rel heap_ptr := _.
Instance PreorderHeapPtr : PreOrder (@rel heap_ptr RelHeapPtr) := _.
Instance HeapPtrSepAlgOps : SepAlgOps heap_ptr := _.
Instance SepAlgHeapPtr : SepAlg heap_ptr := _.
Instance UUSepAlgHeapPtr : UUSepAlg heap_ptr := _.

(*
Instance SepAlgArrPtr : SepAlg heap_arr := _.

Instance RelHeap : Rel heap := _.
Instance PreorderHeap : PreOrder (@rel heap RelHeap) := _.
Instance HeapSepAlgOps : SepAlgOps heap := _.
Instance SepAlgHeap : SepAlg heap := _.
Instance UUSepAlgHeap : UUSepAlg heap := _.
*)

Instance HeapSepAlgOps : SepAlgOps heap := _.
Instance UUSepAlgHeap : UUSepAlg heap := _.

Definition asn := ILPreFrm Prog_sub (ILPreFrm ge (ILPreFrm (@rel heap subheap) Prop)).

Instance ILogicOpsAsn : ILogicOps asn := _.
Instance BILogicOpsAsn : BILOperators asn. Admitted.
Instance BILogicAsn : IBILogic asn. Admitted.

Local Existing Instance EmbedILPreDropOp.
Local Existing Instance EmbedILPreDrop.
Local Existing Instance EmbedOpPropProp.
Local Existing Instance EmbedPropProp.

Instance EmbedAsnPropOp : EmbedOp Prop asn := _.
Instance EmbedAsnProp : Embed Prop asn := _.

Instance RelDec_var : RelDec (@eq var) := _.

Definition sasn := (Stack.stack var val) -> asn.

Instance ILogicOpsSAsn : ILogicOps sasn := _.
Instance BILogicOpsSAsn : BILOperators sasn := _.
Instance BILogicSAsn : IBILogic sasn := _.

Local Existing Instance EmbedILFunDropOp.
Local Existing Instance EmbedILFunDrop.
Local Existing Instance EmbedILFunOp.
Local Existing Instance EmbedILFun.
Local Existing Instance EmbedILPreOp.
Local Existing Instance EmbedILPre.

Local Existing Instance SABIOps.
Local Existing Instance SABILogic.
Local Existing Instance pureop_bi_sepalg.

Instance EmbedSasnPureOp : EmbedOp vlogic sasn := _.
Instance EmbedSasnPure : Embed vlogic sasn := _.

Require Import SpecLogic.

Instance EmbedAsnSpecOp  : EmbedOp spec asn := _.
Instance EmbedAsnSpec    : Embed spec asn := _.
Instance EmbedSAsnSpecOp : EmbedOp spec sasn := _.
Instance EmbedSAsnSpec   : Embed spec sasn := _.

Local Existing Instance pure_embed_pre_drop.
Local Existing Instance pure_embed_pre.
Local Existing Instance pure_embed_fun_drop.
Local Existing Instance pure_embed_fun.
Local Existing Instance pure_ibi_sepalg.
Local Existing Instance pureop_pure_ibi_sepalg.
Local Existing Instance pure_ibi_embed_drop.
Local Existing Instance PureBILPre.
Local Existing Instance PureBILPreOp.
Local Existing Instance PureBILFun.
Local Existing Instance PureBILFunOp.

Print pureop_bi_sepalg.
(*
Local Instance PureOpAsn1 : @PureOp asn1 := _.
Local Instance PureAsn1 : Pure PureOpAsn1 := _.
Local Instance PureOpAsn2 : @PureOp asn2 := _.
Local Instance PureAsn2 : Pure PureOpAsn2 := _.
Local Instance PureOpAsn : @PureOp asn := _.
Local Instance PureAsn : Pure PureOpAsn := _.
Local Instance PureOpSasn : @PureOp sasn := _.
Local Instance PureSAsn : Pure PureOpSasn := _.
*)

(*
Instance pure_prop (p : Prop) : pure (@embed Prop sasn _ p) := _.
Instance pure_vlogic (p : vlogic) : pure (@embed vlogic sasn _ p) := _.
Instance pure_spec_asn (p : spec) : pure (@embed spec asn _ p) := _.
Instance pure_spec (p : spec) : pure (@embed spec sasn _ p) := _.
*)

Local Transparent ILPre_Ops.

Definition mk_asn (f: Program -> nat -> heap -> Prop)
  (Hnat: forall P k h, f P (S k) h -> f P k h)
  (HProg: forall P P' k h, Prog_sub P P' -> f P k h -> f P' k h)
  (Hheap: forall P k h h', subheap h h' -> f P k h -> f P k h') : asn.
  refine (mkILPreFrm (fun P => mkILPreFrm (fun k => mkILPreFrm (fun h => f P k h) _) _) _).
Proof.
  intros P P' HP Hn h H; simpl.
  eapply HProg; eassumption.
Grab Existential Variables.
  assert (forall k' k P h, k' >= k -> f P k' h -> f P k h) as Hnat'.
  intros k k' P' h Hkk' S.
  induction Hkk'. assumption.
  apply IHHkk'. apply Hnat. assumption.
  intros n n' Hn'' p S; simpl in *. eapply Hnat'; eassumption.
  intros h h' Hh H. eapply Hheap; eassumption.
Defined.

Program Definition pointsto_aux (x : ptr) (f : field) (v : val) : asn :=
  mk_asn (fun P k h => subheap (add (x, f) v (empty val)) (fst h)) _ _ _.
Next Obligation.
  destruct h, h'; simpl in *.
  apply subheap_prod in H as [H _].
  setoid_rewrite H in H0. assumption.
Qed.

Definition pointsto (p : val) (f : field) (v : val) : asn :=
  (p <> null) /\\ pointsto_aux (val_to_ptr p) f v.

Program Definition pointsto_arr_element_aux (x : val) (path : list val) (v : val) : asn :=
  mk_asn (fun P k h => exists (h' : heap) ,
                         subheap h' h /\
                         find_heap_arr (val_to_nat x)
                                       (List.map val_to_nat path) (snd h') =
                         Some v) _ _ _.
Next Obligation.
  exists H; split; [assumption | reflexivity].
Qed.
Next Obligation.
  exists H0; split; [assumption | reflexivity].
Qed.
Next Obligation.
  exists H0; split; [etransitivity; eassumption | reflexivity].
Qed.

Definition pointsto_arr_element (x i : val) (v : val) : asn :=
  pointsto_arr_element_aux x (i::nil) v.

Require Import ZArith.

Fixpoint pointsto_arr_aux (x : val) (n : nat) (vs : list val) : asn :=
  match vs with
    | nil   => empSP
    | v::vs => pointsto_arr_element x (vint (Z_of_nat n)) v **
                                    pointsto_arr_aux x (S n) vs
  end.

Lemma firstn_nil {A : Type} (n : nat) : firstn n (@nil A) = nil.
Proof.
  destruct n; simpl; reflexivity.
Qed.

Lemma skipn_nil {A : Type} (n : nat) : skipn n (@nil A) = nil.
Proof.
  destruct n; simpl; reflexivity.
Qed.

Lemma firstn_cons {A : Type} (n : nat) (x : A) (xs : list A) (H : n > 0) :
  firstn n (x :: xs) = x :: (firstn (n - 1) xs).
Proof.
  destruct n; simpl.
  + omega.
  + replace (n - 0) with n by omega; reflexivity.
Qed.

Lemma firstn_app1 {A : Type} (n : nat) (xs ys : list A) (H : n <= List.length xs) :
  firstn n (xs ++ ys) = firstn n xs.
Proof.
  generalize dependent n; induction xs; simpl in *; intros.
  + assert (n = 0) by omega; clear H; subst; simpl; reflexivity.
  + destruct n; simpl in *; [reflexivity|].
    f_equal. apply IHxs. omega.
Qed.

Lemma firstn_app2 {A : Type} (n : nat) (xs ys : list A) (H : n >= List.length xs) :
  firstn n (xs ++ ys) = xs++(firstn (n - List.length xs) ys).
Proof.
  generalize dependent n; induction xs; simpl in *; intros.
  + replace (n - 0) with n by omega; reflexivity.
  + destruct n; simpl in *; [omega|].
    f_equal. apply IHxs. omega.
Qed.

Lemma skipn_cons {A : Type} (n : nat) (x : A) (xs : list A) (H : n > 0) :
  skipn n (x :: xs) = skipn (n - 1) xs.
Proof.
  destruct n; simpl.
  + omega.
  + replace (n - 0) with n by omega; reflexivity.
Qed.

Lemma skipn_drop {A : Type} (n : nat) (xs : list A) (H : n >= List.length xs) :
  skipn n xs = nil.
Proof.
  generalize dependent xs; induction n; simpl; intros.
  + destruct xs; simpl in *; [reflexivity | omega].
  + destruct xs; [reflexivity|].
    apply IHn; simpl in *; omega.
Qed.

Lemma skipn_length {A : Type} (n : nat) (vs : list A) :
  List.length (skipn n vs) = (List.length vs - n).
Proof.
  generalize dependent n; induction vs; simpl.
  + destruct n; simpl; reflexivity.
  + destruct n; simpl; [reflexivity|].
    rewrite IHvs. reflexivity.
Qed.

(*
Lemma pointsto_arr_aux_app (x : val) (n : nat) (xs ys : list val) :
  pointsto_arr_aux x n (xs++ys) -|- pointsto_arr_aux x n xs ** pointsto_arr_aux x (n + List.length xs) ys.
Proof.
  generalize dependent n; induction xs; simpl in *; intros.
  + rewrite sepSPC, empSPR. replace (n + 0) with n by omega. reflexivity.
  + rewrite IHxs.
    replace (n + S (Datatypes.length xs)) with (S n + Datatypes.length xs) by omega.
    rewrite sepSPA. reflexivity.
Qed.

Lemma pointsto_arr_aux_split (x : val) (n m : nat) (vs : list val) (H : n < m) :
  pointsto_arr_aux x n vs -|- pointsto_arr_aux x n (firstn (m - n) vs) **
                              pointsto_arr_aux x m (skipn (m - n) vs).
Proof.
  rewrite <- (firstn_skipn (m - n) vs) at 1.
  rewrite pointsto_arr_aux_app.
  rewrite firstn_length.
  destruct (Min.min_dec (m - n) (Datatypes.length vs)) as [H1 | H1]; rewrite H1.
  + replace (n + (m - n)) with m by omega; reflexivity.
  + rewrite skipn_drop; simpl; [reflexivity|].
    setoid_rewrite <- H1.
    assert (min (m - n) (Datatypes.length vs) <= m - n); [|omega].
    apply Min.le_min_l.
Qed.

Definition pointsto_arr (x n m : val) (vs : list val) : asn :=
  let n' := val_to_nat n in
  let m' := val_to_nat m in
  (n' <= m' /\ List.length vs = S (m' - n')) /\\ pointsto_arr_aux x n' vs.

(* Gregory should be able to pull this off with his cancellation magic. *)

Lemma embed_and_admit (p q : asn) (P Q : Prop) :
  (P /\\ p) ** (Q /\\ q) -|- P /\\ Q /\\ p ** q.
Proof.
  admit.
Qed.

Lemma pointsto_arr_split (x i j k : val) (vs : list val)
      (Hij : val_to_nat i <= val_to_nat j)
      (Hjk : val_to_nat j < val_to_nat k) :
  pointsto_arr x i k vs -|- pointsto_arr x i j (firstn (S ((val_to_nat j) -
                                                           (val_to_nat i))) vs) **
                            pointsto_arr x (vint (Z_of_nat (S (val_to_nat j)))) k
                                         (skipn (S ((val_to_nat j) - (val_to_nat i))) vs).
Proof.
  unfold pointsto_arr.
   replace (val_to_nat (Z.of_nat (S (val_to_nat j)))) with (S (val_to_nat j)) by
    (destruct j; unfold val_to_nat; simpl in *; try reflexivity;
     rewrite SuccNat2Pos.id_succ; reflexivity).
   split.
  + apply lpropandL; intros [H1 H2].
    rewrite embed_and_admit.
    apply lpropandR. {
      split; [assumption|].
      rewrite firstn_length.
      simpl. setoid_rewrite H2.
      f_equal; apply Min.min_l; omega.
    }
    apply lpropandR. {
      split; [omega|].
      rewrite skipn_length; omega.
    }
    rewrite (pointsto_arr_aux_split x (val_to_nat i) (S(val_to_nat j))); [|omega].
    replace (S (val_to_nat j) - val_to_nat i) with (S (val_to_nat j - val_to_nat i)) by omega.
    reflexivity.

  + rewrite embed_and_admit.
    apply lpropandL; intros [H1 H2].
    apply lpropandL; intros [H3 H4].
    apply lpropandR. split; [omega|].
    rewrite <- (firstn_skipn (S (val_to_nat j - val_to_nat i)) vs), app_length; omega.
    etransitivity; [|rewrite (pointsto_arr_aux_split x (val_to_nat i) (S(val_to_nat j))); [|omega]]; [|reflexivity].
    replace (S (val_to_nat j) - val_to_nat i) with (S (val_to_nat j - val_to_nat i)) by omega.
    reflexivity.
Qed.

Transparent ILogicOpsAsn.
Transparent BILOperatorsAsn.
Transparent BILPre_Ops.
Transparent EmbedAsnPropOp.
Transparent EmbedILPreDropOp.
Opaque MapSepAlgOps.
Opaque SepAlgOps_prod.

Lemma pointsto_arr_pointsto_element_lst (x i : val) (vs : list val) :
  pointsto_arr x i i vs |-- Exists v, vs = v::nil /\\ pointsto_arr_element x i v.
Proof.
  unfold pointsto_arr, pointsto_arr_element.
  apply lpropandL; intros [H1 H2].
  destruct vs; simpl in H2; [omega|].
  destruct vs; simpl in H2; [|omega].
  cbv [pointsto_arr_aux].
  rewrite empSPR.
  intros P n h H.
  simpl in *.
  destruct H as [h' [Hh H]].
  exists v; split; simpl; [reflexivity|].
  exists h'; split; [assumption|].
  destruct h'; simpl in *.
  assert (val_to_nat (Z.of_nat (val_to_nat i)) = val_to_nat i). {
      clear H.
      induction i; simpl in *; unfold val_to_nat in *; simpl in *; try reflexivity.
      rewrite Nat2Z.id; reflexivity.
    }
  rewrite <- H0. apply H.
Qed.

Lemma pointsto_arr_pointsto_element (x i : val) (v : val) :
  pointsto_arr x i i (v::nil) -|- pointsto_arr_element x i v.
Proof.
  split.
  + rewrite pointsto_arr_pointsto_element_lst.
    apply lexistsL; intro v'.
    apply lpropandL; intros H; inversion H; subst; clear H.
    reflexivity.
  + unfold pointsto_arr_element, pointsto_arr.
    apply lpropandR; [split; [reflexivity | simpl; omega]|].
    cbv [pointsto_arr_aux]. rewrite empSPR.
    intros P n h H; simpl in *.
    destruct H as [h' [Hh H]].
    exists h'; split; [apply Hh|].
    assert (val_to_nat (Z.of_nat (val_to_nat i)) = val_to_nat i). {
      clear H.
      induction i; simpl in *; unfold val_to_nat in *; simpl in *; try reflexivity.
      rewrite Nat2Z.id; reflexivity.
    }
    rewrite H0. apply H.
Qed.

Definition update {A : Type} (lst : list A) (n : nat) (p : A) :=
  firstn n lst ++ (p::(skipn (n+1) lst)).

Lemma pointsto_arr_update (x i j k : val) (vs : list val) (v : val)
      (Hij : val_to_nat i <= val_to_nat j)
      (Hjk : val_to_nat j < val_to_nat k) :
  pointsto_arr x i k (update vs (val_to_nat j - val_to_nat i) v) -|-
  pointsto_arr x i j (firstn ((val_to_nat j) -
                              (val_to_nat i)) vs) **
  pointsto_arr_element k j v **
  pointsto_arr x (vint (Z_of_nat (S (val_to_nat j)))) k
  (skipn (S ((val_to_nat j) - (val_to_nat i))) vs).
Proof.
  rewrite pointsto_arr_split with (j := S (val_to_nat j)). try eassumption.
  unfold update.
  replace (firstn (val_to_nat j - val_to_nat i) vs ++
                  v :: skipn (val_to_nat j - val_to_nat i + 1) vs) with
  ((firstn (val_to_nat j - val_to_nat i) vs ++
         (v::nil)) ++ (skipn (val_to_nat j - val_to_nat i + 1) vs))
    by (rewrite <- app_assoc; reflexivity).
  rewrite firstn_app1.
  rewrite firstn_app2.
  replace (S (val_to_nat j - val_to_nat i) -
         Datatypes.length (firstn (val_to_nat j - val_to_nat i) vs)) with 1.
  replace (firstn 1 (v :: nil)) with (v :: nil) by reflexivity.
  cbv delta [firstn].
SearchAbout firstn.
  simpl.
Qed.
*)
(*

Lemma pointsto_arr_get_element x i j k vs
      (Hij : val_to_nat i <= val_to_nat j)
      (Hjk : val_to_nat j <= val_to_nat k) :
      pointsto_arr x i k vs |-- pointsto_arr_element x j
                                (List.nth (val_to_nat j - val_to_nat i) vs null).
Proof.
  unfold pointsto_arr.
  apply lpropandL; intros [H1 H2].
  unfold pointsto_arr_element.
  intros p n h; simpl; intros.
  generalize dependent (val_to_nat i).
  generalize dependent (val_to_nat j).
  generalize dependent (val_to_nat k).
  clear i j k.
  intros k j Hjk i Hij Hik Hlength H.
  destruct h as [hp ha].
  exists (hp, heap_arr_unit [(val_to_nat x, j) <- nth (j - i) vs null]).
  split; simpl; [|rewrite add_eq_o; reflexivity].
  apply subheap_prod; split; [reflexivity|].
  generalize dependent k; induction vs; simpl in *; intros. omega.
  inversion Hlength; clear Hlength.
  unfold sepSP in H. unfold BILOperatorsAsn in H.
  simpl in H.
  destruct H as [h1 [h2 [Hh [[h3 [H2 H3]] H4]]]].
  destruct h1, h2, h3.
  apply subheap_prod in H2 as [H2 H5].
  simpl in *.
  remember (j - i) as l; destruct l; simpl in *.
  assert (i = j) by omega; subst.
  admit.
  admit.
Qed.

Fixpoint arr_heap (h : heap_arr) (x : nat) (path indexes : list nat) (v : val) : heap_arr :=
	match path, indexes with
		| nil, i::indexes     => h [(x, i) <- v]
		| n::path, i::indexes => (arr_heap h n path indexes v) [(x, i) <- (varr n)]
		| _, _                => empty val
	end.

Program Definition in_arr_aux (p : val) (path : list nat) (indexes : list val) (v : val) : asn :=
	mk_asn (fun P k h => subheap (arr_heap (empty val) (val_to_arr p) path
                                               (List.map val_to_arr indexes) v) (snd h)) _ _ _.
Next Obligation.
	destruct h as [_h h]; destruct h' as [_h' h']; simpl in *.
	apply subheap_prod in H as [_ H]; clear _h _h'.
	rewrite H in H0. assumption.
Qed.

Definition in_arr (p : val) (indexes : list val) (v : val) : asn :=
	Exists path : list nat, in_arr_aux p path indexes v.

Fixpoint alloc_arr_val (h : heap_arr) (x size : nat) (f : nat -> val) : heap_arr :=
	match size with
		| 0   => h [(x, 0) <- (f x)]
		| S n => (alloc_arr_val h x n f) [(x, S n) <- null]
	end.

Fixpoint alloc_arr_aux (h : heap_arr) (x : nat) (size : list nat)
         (paths : list (list nat)) : heap_arr :=
	match size, paths with
		| s::nil, nil            => alloc_arr_val h x s (fun x => null)
		| s :: size, ps :: paths => List.fold_right (fun n h => h [(x, s) <- (varr n)]) h ps
		| _, _                   => empty val
	end.

Definition alloc_arr (x : nat) (size : list nat) (paths : list (list nat)) : heap_arr :=
	alloc_arr_aux (empty val) x size paths.
*)


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

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

Require Import sepcomp.mem_lemmas.
Require Import sepcomp.semantics.
Require Import sepcomp.semantics_lemmas.
Require Import sepcomp.wholeprog_simulations.
Require Import sepcomp.closed_safety.
Require Import sepcomp.effect_semantics.

Import Wholeprog_sim.

Arguments match_state : default implicits.
Arguments core_halted : default implicits.
Arguments core_data : default implicits.
Arguments core_ord : default implicits.
Arguments core_ord_wf : default implicits.
Arguments core_diagram : default implicits.

(** * Safety and semantics preservation *)

Section safety_preservation_lemmas.
Context  {G TG C D M TM Z data : Type}
         {source : @CoreSemantics G C M}
         {target : @CoreSemantics TG D TM}
         {geS : G}
         {geT : TG}
         {ge_inv : G -> TG -> Prop}
         {init_inv : meminj -> G -> list val -> M -> TG -> list val -> TM -> Prop}
         {halt_inv : meminj (*structured_injections.SM_Injection*) ->
                     G -> val -> M -> TG -> val -> TM -> Prop}
         (main : val)

  (sim : Wholeprog_sim source target geS geT main ge_inv init_inv halt_inv)
  (c : C)
  (d : D)
  (m : M)
  (tm: TM)

  (TGT_DET : corestep_fun target)

  (source_safe : forall n, safeN source geS n c m).

Definition my_P := fun (x: core_data sim) =>
   forall j (c : C) (d : D) (m : M) (tm : TM),
   (forall n : nat, safeN source geS n c m) ->
   match_state sim x j c m d tm ->
   (exists rv : val, halted source c = Some rv) \/
   (exists (cd' : core_data sim) j' (c' : C) (m' : M),
      corestep_plus source geS c m c' m' /\
      ((exists (d' : D) (tm' : TM),
          corestep_plus target geT d tm d' tm' /\
          match_state sim cd' j' c' m' d' tm') \/
       (exists rv : val,
        halted source c' = Some rv
        /\ match_state sim cd' j' c' m' d tm))).

Lemma corestep_ord:
  forall cd j,
  match_state sim cd j c m d tm ->
  (exists rv, halted source c = Some rv) \/
  (exists cd' j' c' m',
      corestep_plus source geS c m c' m'
   /\ ((exists d' tm', corestep_plus target geT d tm d' tm'
                   /\ match_state sim cd' j' c' m' d' tm')
    \/ (exists rv, halted source c' = Some rv
                   /\ match_state sim cd' j' c' m' d tm))).
Proof.
intros.
revert j c d m tm source_safe H.
assert (my_well_founded_induction
     : (forall x, (forall y, core_ord sim y x -> my_P y) -> my_P x) ->
       forall a, my_P a).
{ apply well_founded_induction; auto. apply (core_ord_wf sim). }
unfold my_P in my_well_founded_induction.
apply my_well_founded_induction; auto.
intros.
case_eq (halted source c).
intros.
solve[left; exists v; auto].
intros HALTED_NONE.
right.
generalize H0 as SAFE; intro.
specialize (H0 (S O)); simpl in H0.
rewrite HALTED_NONE in H0.
destruct H0 as [H0 HALL].
destruct H0 as [c2 [m2 STEP]].
generalize STEP as STEP'; intro.
eapply core_diagram in STEP; eauto.
destruct STEP as [d2 [tm2 [cd2 [j2 [? H2]]]]].
destruct H2 as [H2|H2]. exists cd2, j2, c2, m2. split; auto.
exists O; simpl; exists c2, m2; split; auto.
solve[left; exists d2, tm2; split; auto].
destruct H2 as [H2 ORD].
specialize (H _ ORD j2 c2 d2 m2 tm2).
assert (SAFE': forall n, safeN source geS n c2 m2).
  solve[intros n; eapply safe_corestep_forward; eauto].
specialize (H SAFE' H0).
destruct H2 as [n H2].
destruct n. inv H2.
destruct H.
destruct H as [rv HALTED].
exists cd2, j2, c2, m2.
split; auto.
solve[exists O; simpl; exists c2, m2; split; auto].
solve[right; exists rv; split; auto].
destruct H as [cd' [j' [c' [m' [STEPN H]]]]].
destruct H as [H|H].
destruct H as [d' [tm' [TSTEP' MATCH']]].
exists cd', j', c', m'.
split; auto.
destruct STEPN as [n STEPN].
exists (S n).
simpl.
exists c2, m2.
split; auto.
solve[left; exists d', tm'; split; auto].
destruct H as [rv [HALT MATCH']].
exists cd', j', c', m'.
split; auto.
destruct STEPN as [n STEPN].
exists (S n).
simpl.
exists c2, m2.
split; auto.
solve[right; exists rv; split; auto].
exists cd2, j2, c2, m2.
split; auto.
solve[exists O; simpl; exists c2, m2; split; auto].
left.
exists d2, tm2.
split; auto.
exists n; auto.
Qed.

Definition halt_match c d :=
  exists rv trv,
    halted source c = Some rv
    /\ halted target d = Some trv.

Lemma corestep_ord':
  forall cd j,
  match_state sim cd j c m d tm ->
  halt_match c d
  \/ (exists cd' j' c' m',
         corestep_plus source geS c m c' m'
         /\ ((match_state sim cd' j' c' m' d tm /\ halt_match c' d)
            \/ (exists d' tm',
                  corestep_plus target geT d tm d' tm'
                  /\ match_state sim cd' j' c' m' d' tm'))).
Proof.
intros.
generalize H as MATCH; intro.
apply corestep_ord in H.
destruct H.
{
destruct H as [rv HALT].
left.
unfold halt_match.
generalize HALT as HALT'; intro.
apply (core_halted sim cd j c m d tm) in HALT; auto.
destruct HALT as [j' [rv' [INJ HALT]]].
exists rv, rv'.
split; auto.
}
{
destruct H as [cd' [j' [c' [m' [STEPN ?]]]]].
destruct H as [H|H].
destruct H as [d' [tm' [TSTEPN MATCH']]].
right.
exists cd', j', c', m'.
split; auto.
right.
exists d', tm'.
solve[split; auto].
destruct H as [rv [HALT MATCH']].
right.
exists cd', j', c', m'.
split; auto.
left.
split; auto.
unfold halt_match.
generalize HALT as HALT'; intro.
apply (core_halted sim cd' j' c' m' d tm) in HALT; auto.
destruct HALT as [j'' [rv' [INJ HALT]]].
exists rv, rv'.
split; auto.
}
Qed.

End safety_preservation_lemmas.

Lemma corestepN_splits_lt
       {G C M} (csem : CoreSemantics G C M) (ge : G)
       c m c' m' c'' m'' n1 n2 :
  corestep_fun csem ->
  corestepN csem ge (S n1) c m c' m' ->
  corestepN csem ge n2 c m c'' m'' ->
  (n1 < n2)%nat ->
  exists a b,
    (a > O)%nat
    /\ (b=0 -> S n1=n2)%nat
    /\ n2 = plus a b
    /\ corestepN csem ge a c m c' m'
    /\ corestepN csem ge b c' m' c'' m''.
Proof.
intros FN H1 H2 LT.
revert c m n1 H1 H2 LT.
induction n2; intros.
destruct n1; try inv LT.
destruct n1.
destruct H1 as [c2' [m2' [STEP STEPN]]].
inv STEPN.
exists (S O), n2.
split; try omega.
split; try omega.
destruct H2 as [c2'' [m2'' [STEP' STEPN']]].
destruct (FN _ _ _ _ _ _ _ STEP STEP').
subst c2'' m2''.
split; auto.
split; auto.
exists c',m'.
split; simpl; auto.
assert (n1 < n2)%nat by omega.
destruct H1 as [c2 [m2 [STEP STEPN]]].
destruct H2 as [c2' [m2' [STEP' STEPN']]].
assert (c2'=c2 /\ m2=m2') as [? ?].
  { destruct (FN _ _ _ _ _ _ _ STEP STEP').
    subst c2 m2; split; auto. }
subst c2' m2; auto.
destruct (IHn2 c2 m2' n1); auto.
destruct H0 as [n1' [H0 [H1 [H2 [H3 H4]]]]].
exists (S x), n1'.
split; auto.
split. omega.
split; auto. omega.
split; auto.
exists c2,m2'.
split; auto.
Qed.

(** ** Equitermination *)

Definition terminates {G C M} (csem : CoreSemantics G C M)
    (ge : G) (c : C) (m : M) :=
  exists c' m', corestep_star csem ge c m c' m'
  /\ exists v, halted csem c' = Some v.

Section termination_preservation.
Context  {G TG C D M TM Z data : Type}
         {source : @CoreSemantics G C M}
         {target : @CoreSemantics TG D TM}
         {geS : G}
         {geT : TG}
         {ge_inv : G -> TG -> Prop}
         {init_inv : meminj -> G -> list val -> M -> TG -> list val -> TM -> Prop}
         {halt_inv : meminj (*structured_injections.SM_Injection *)->
                     G -> val -> M -> TG -> val -> TM -> Prop}
         (main : val)

  (sim : Wholeprog_sim source target geS geT main ge_inv init_inv halt_inv).

Lemma termination_preservation:
  forall cd c m d tm j c' m' rv1,
  match_state sim cd j c m d tm ->
  corestep_star source geS c m c' m' ->
  halted source c' = Some rv1 ->
  terminates target geT d tm.
Proof.
intros.
destruct H0 as [n H0].
revert cd j c m d tm H H0.
induction n; intros.
simpl in H0. symmetry in H0; inv H0.
cut (@halt_match G _ C D _ _ source target c d). intro.
unfold halt_match in H0.
destruct H0 as [rv [trv [? ?]]].
exists d, tm; split; auto.
solve[exists O; simpl; auto].
solve[exists trv; auto].
generalize H1 as H1'; intro.
eapply core_halted in H1; eauto.
destruct H1 as [? [rv2 [? ?]]].
exists rv1, rv2; split; auto.
simpl in H0.
destruct H0 as [c2 [m2 [STEP STEPN]]].
generalize STEP as STEP'; intro.
apply corestep_not_halted in STEP.
eapply core_diagram in STEP'; eauto.
destruct STEP' as [? [? [cd' [j' [MATCH ?]]]]].
clear H.
destruct H0 as [X|[X Y]].
eapply IHn in MATCH; eauto.
unfold terminates in MATCH|-*.
destruct MATCH as [x' [tm' [Y [v W]]]].
exists x', tm'; split; eauto.
eapply corestep_star_trans; eauto.
solve[eapply corestep_plus_star; eauto].
eapply IHn in MATCH; eauto.
unfold terminates in MATCH|-*.
destruct MATCH as [x' [tm' [U [v W]]]].
exists x', tm'; split; eauto.
solve[eapply corestep_star_trans; eauto].
Qed.

End termination_preservation.

Section equitermination.
Context  {G TG C D M TM Z data : Type}
         {source : @CoreSemantics G C M}
         {target : @CoreSemantics TG D TM}
         {geS : G}
         {geT : TG}
         {ge_inv : G -> TG -> Prop}
         {init_inv : meminj -> G -> list val -> M -> TG -> list val -> TM -> Prop}
         {halt_inv : meminj (*structured_injections.SM_Injection*) ->
                     G -> val -> M -> TG -> val -> TM -> Prop}
         (main : val)

  (sim : Wholeprog_sim source target geS geT main ge_inv init_inv halt_inv)
  (TGT_DET : corestep_fun target).

Lemma termination_reflection:
  forall n c m d tm cd j d' tm' hv'
    (source_safe : forall n, safeN source geS n c m),
    match_state sim cd j c m d tm ->
    corestepN target geT n d tm d' tm' ->
    halted target d' = Some hv' ->
    terminates source geS c m.
Proof.
set (my_P := fun (n : nat) =>
   forall (c : C) (m : M) (d : D) (tm : TM)
     (cd : core_data sim) (j : meminj (*structured_injections.SM_Injection*))
     (d' : D) (tm' : TM) (hv' : val),
   (forall n0 : nat, safeN source geS n0 c m) ->
   match_state sim cd j c m d tm ->
   corestepN target geT n d tm d' tm' ->
   halted target d' = Some hv' -> terminates source geS c m).
apply (@well_founded_induction _ _ lt_wf my_P); auto.
unfold my_P; clear my_P; intros n IH.

intros c m d tm cd j d' tm' hv' safe MATCH TSTEPN HLT2.
apply (corestep_ord' main sim c d m tm) in MATCH; auto.
destruct MATCH as [HLT|H].
destruct HLT as [rv [_ [HLT _]]]; exists c,m. split.
exists O; simpl; auto. solve[exists rv; auto].
destruct H as [cd' [j' [c2 [m2 [STEPN H]]]]]. destruct H as [[H H2]|H].
destruct H2 as [rv [_ [HLT _]]].
destruct STEPN as [n2 STEPN].
exists c2,m2. split; auto. exists (S n2); simpl; auto. solve[exists rv; auto].

destruct H as [d2 [tm2 [[n2 TSTEPN2] MTCH2]]].
destruct (lt_dec n2 n) as [pf|pf].
{ assert (TSTEPN': exists n2', (n2' < n)%nat
    /\ corestepN target geT n2' d2 tm2 d' tm').
  { destruct (corestepN_splits_lt target geT d tm d2 tm2 d' tm' n2 n TGT_DET
              TSTEPN2 TSTEPN pf)
      as [a [b [alt [neq [X [Y U]]]]]].
    exists b; split; auto. omega. }
  destruct TSTEPN' as [n2' [ltpf TSTEPN']].
  assert (safe': forall n, safeN source geS n c2 m2).
  { destruct STEPN as [q STEPN].
    intros n0; eapply safe_corestepN_forward; eauto. }
  destruct (IH n2' ltpf c2 m2 d2 tm2 cd' j' d' tm' hv' safe' MTCH2 TSTEPN' HLT2)
    as [c0 [m0 [[q STEPN1] [hv0 HLT1]]]].
  destruct STEPN as [q' STEPN]. exists c0,m0; split; auto.
  eapply corestep_star_trans. exists (S q'); eauto. exists q; auto.
  exists hv0; auto. }
{ assert (lt: (n < S n2)%nat) by omega. clear pf.
  destruct n. inv TSTEPN. simpl in TSTEPN2.
  destruct TSTEPN2 as [? [? [X _]]]; apply corestep_not_halted in X.
  rewrite X in HLT2; congruence.
  destruct (corestepN_splits_lt target geT d tm d' tm' d2 tm2 n (S n2) TGT_DET
              TSTEPN TSTEPN2)
      as [a [b [alt [neq [X [Y W]]]]]]. omega.
  destruct b. rewrite neq in lt; auto. omega.
  simpl in W. destruct W as [? [? [W _]]].
  apply corestep_not_halted in W; rewrite W in HLT2; congruence. }
Qed.

Lemma equitermination:
  forall cd c m d tm j
  (source_safe : forall n, safeN source geS n c m),
  match_state sim cd j c m d tm ->
  (terminates source geS c m <-> terminates target geT d tm).
Proof.
intros; split; intros [? [? [A [? B]]]].
eapply termination_preservation; eauto.
destruct A as [n A]; eapply termination_reflection; eauto.
Qed.

End equitermination.