(** * EqTh.v: decision procedures for determining program equivalence,
 e.g. dead code, code movement, semantic equivalence *)

Set Implicit Arguments.

Require Export While_loop.
Require Export NotModifyDec.

Module Make (Sem:SEM).

 Module NM_dec := NotModifyDec.Make Sem.
 Export NM_dec.

 Section EQOBS.

 Variable n : positive.
 Variable E : env.
 Variable pi : eq_refl_info E.

 (* [needed_args lv arg needed res] computes a set [I] such that [res [<=] I]
     and [EqObs_args lv arg arg needed I] *)

 Definition needed_args ltv1 (lv1:var_decl ltv1)
  lt1 (la1:E.args lt1) ltv2 (lv2:var_decl ltv2) lt2 (la2:E.args lt2)
  (needed:Vset.t) (res:Vset.t) :=
  Vset.fold (fun x r =>
   match r, get_arg x lv1 la1, get_arg x lv2 la2 with
   | Some r, Some a1, Some a2 =>
     if E.eqb a1 a2 then Some (fv_expr_extend a1 r)
     else None
   | _, _, _ => None
   end) needed (Some res).

 Definition needed_args_refl ltv (lv:var_decl ltv) lt (la:E.args lt)
  (needed:Vset.t) (res:Vset.t) :=
  Vset.fold (fun x r =>
   match r, get_arg x lv la with
   | Some r, Some a => Some (fv_expr_extend a r)
   | _, _ => None
   end) needed (Some res).

 Lemma needed_args_correct :
  forall needed ltv1 (lv1:var_decl ltv1) lt1 (la1:E.args lt1)
   ltv2 (lv2:var_decl ltv2) lt2 (la2:E.args lt2)
   res I,
   needed_args lv1 la1 lv2 la2 needed res = Some I ->
   EqObs_args lv1 la1 lv2 la2 needed I /\ res [<=] I.
 Proof.
  intros needed ltv1 lv1 lt1 la1 ltv2 lv2 lt2 la2 res I; unfold EqObs_args.
  assert (forall (L:list Var.t), fold_left (fun r (x:Var.t) =>
   match r, get_arg x lv1 la1, get_arg x lv2 la2 with
   | Some r, Some a1, Some a2 =>
     if E.eqb a1 a2 then Some (fv_expr_extend a1 r)
     else None
   | _, _, _ => None
   end) L None = None).
  induction L; simpl; intros; auto.
  assert (forall L R I,
   fold_left (fun r (x:Var.t) =>
    match r, get_arg x lv1 la1, get_arg x lv2 la2 with
    | Some r, Some a1, Some a2 =>
     if E.eqb a1 a2 then Some (fv_expr_extend a1 r)
      else None
    | _, _, _ => None
    end) L (Some R)  = Some I ->
   (forall x,
    InA (@eq _) x L ->
    match get_arg x lv1 la1 with
    | Some e1 =>
     match get_arg x lv2 la2 with
     | Some e2 => EqObs_e I e1 e2
     | None => False
     end
    | None => False
     end) /\ R[<=]I).
  rename H into ZZ. induction L; simpl; intros; auto.
  inversion_clear H; split; auto with set.
  intros x H; inversion H.
  case_eq (get_arg a lv1 la1); intros.
  case_eq (get_arg a lv2 la2); intros.
  rewrite H0 in H; rewrite H1 in H.
  assert (W:=E.eqb_spec e e0); destruct (E.eqb e e0); subst.
  destruct (IHL _ _ H); split; intros.
  inversion H4; clear H4; subst; auto.
  rewrite H0; rewrite H1.
  apply EqObs_e_strengthen with (fv_expr e0); trivial.
  apply VsetP.subset_trans with (2:= H3).
  rewrite union_fv_expr_spec; auto with set.
  apply H2; auto.
  apply VsetP.subset_trans with (2:= H3).
  rewrite union_fv_expr_spec; auto with set.
  rewrite ZZ in H; discriminate.
  rewrite H0 in H; rewrite H1 in H; rewrite ZZ in H; discriminate.
  rewrite H0 in H; rewrite ZZ in H; discriminate.

  unfold needed_args; rewrite Vset.fold_spec; intros V.
  destruct (H0 _ _ _ V); split; auto.
  intros; apply (H1 x); apply Vset.elements_correct; trivial.
 Qed.

 Lemma needed_args_refl_spec : forall needed
  ltv (lv:var_decl ltv) lt (la:E.args lt) res,
  needed_args_refl lv la needed res =
  needed_args lv la lv la needed res.
 Proof.
  unfold needed_args_refl, needed_args; intros; repeat rewrite Vset.fold_spec.
  generalize (Vset.elements needed) (Some res).
  induction l; simpl; intros; trivial.
  match goal with
   |- fold_left _ l ?o1 = fold_left _ l ?o2 =>
    assert (Heq : o1 = o2);[ | rewrite Heq; trivial] end.
  destruct o; trivial.
  destruct (get_arg a lv la); trivial.
  generalize (E.eqb_spec e e); destruct (E.eqb e e); trivial.
  intro Hd; elim Hd; trivial.
 Qed.

 Lemma needed_args_refl_correct : forall needed
  ltv (lv:var_decl ltv) lt (la:E.args lt) res I,
  needed_args_refl lv la needed res = Some I ->
  EqObs_args lv la lv la needed I /\ res [<=] I.
 Proof.
  intros needed ltv lv lt la res I; rewrite needed_args_refl_spec; apply
   needed_args_correct.
 Qed.

 (* [eqobs_in_I i O] computes a set [I] such that [EqObs_i I i i O] *)

 Definition eqobs_in_b (i:I.baseInstr) O :=
  match i with
  | I.Assign t x e =>
    if Vset.mem x O then fv_expr_extend e (Vset.remove x O)
    else O
  | I.Random t x e =>
    if Vset.mem x O then Vset.union (fv_distr e) (Vset.remove x O)
    else O
  | I.IAssert e => O
  end.

 Definition is_lossless_nm O c :=
  if is_lossless pi c then is_notmodify pi O c else false.

 Definition is_lossless_nm_i O i :=
  if is_lossless_i pi i then is_notmodify_i pi O i else false.

 Lemma is_lossless_nm_spec : forall O c,
  is_lossless_nm O c ->
  lossless E c /\ exists X, Modify E X c /\ Vset.disjoint O X.
 Proof.
  unfold is_lossless_nm; intros O c.
  generalize (is_lossless_correct pi c).
  destruct (is_lossless pi c).
  split; intros; auto.
  apply is_notmodify_correct with (1:= H0).
  intros; trivialb.
 Qed.

 Lemma is_lossless_nm_i_spec : forall O i,
  is_lossless_nm_i O i ->
  lossless E [i] /\
  exists X, Modify E X [i] /\ Vset.disjoint O X.
 Proof.
  unfold is_lossless_nm_i; intros O i.
  generalize (is_lossless_i_correct pi i);
   destruct (is_lossless_i pi i).
  split; intros; auto.
  apply is_notmodify_i_correct with (1:= H0).
  intros; trivialb.
 Qed.

 Fixpoint eqobs_in_i (i:I.instr) (O:Vset.t) {struct i} : option Vset.t :=
  match i with
  | I.Instr ib =>
    match ib with
    | I.Assign _ _ _ => Some (eqobs_in_b ib O)
    | I.Random _ _ _ => Some (eqobs_in_b ib O)
    | I.IAssert _ => None
    end
  | I.Cond e c1 c2 =>
    let oI1 := List.fold_right (fun i => opt_app (eqobs_in_i i)) (Some O) c1 in
    let oI2 := List.fold_right (fun i => opt_app (eqobs_in_i i)) (Some O) c2 in
     match oI1, oI2 with
     | Some I1, Some I2 =>
       let test :=
        if Vset.eqb I1 O then
         if Vset.eqb I2 O then
          if is_lossless_nm O c1 then is_lossless_nm O c2
           else false
          else false
         else false
        in if test then Some O else Some (fv_expr_extend e (Vset.union I1 I2))
     | _, _ => None
     end
  | I.While e c =>
    let loop O :=
    let oI := List.fold_right (fun i => opt_app (eqobs_in_i i)) (Some O) c in
     match oI with
     | Some II =>
       if II [<=?] O then Result Vset.t (Some O)
       else Continue (option Vset.t) (Vset.union II O)
     | None => Result Vset.t None
     end in
     let Oe := fv_expr_extend e O in
      match While_loop.while loop n Oe with
      | Continue _ => None
      | Result r => r
      end
  | I.Call t d f arg =>
    if is_lossless_nm_i O i then Some O else
     let lv := proc_params E f in
      match pi f with
      | Some pif =>
        let fout := Vset.add d (pi_output pif) in
        let other := Vset.diff O fout in
         if Vset.disjoint other  (pi_mod pif) then
          let gif := Vset.union (pi_input pif) other in
           match needed_args_refl lv arg (pi_params pif) gif with
           | None => None
           | Some Ifun => Some Ifun
           end
          else None
      | _ => None
      end
  end.

  (* [eqobsinv_in i O] compute the smallest [I] such that [Eqobsinv_i I i i O] *)
 Definition eqobs_in c O :=
  List.fold_right (fun i => opt_app (eqobs_in_i i)) (Some O) c.

 Lemma EqObs_lossless_Modify : forall X M1 M2 E1 c1 E2 c2,
  lossless E1 c1 ->
  lossless E2 c2 ->
  Modify E1 M1 c1 ->
  Modify E2 M2 c2 ->
  Vset.disjoint X M1 ->
  Vset.disjoint X M2 ->
  EqObs X E1 c1 E2 c2 X.
 Proof.
  unfold EqObs; intros.
  apply equiv_lossless_Modify with X X M1 M2; trivial.
 Qed.

 (* REMARK: decMR can be weakened, P has to be decidable only if m1 =={I} m2 *)
 Lemma equiv_union_Modify : forall E1 c1 E2 c2 I P X1 X2 O Q,
  Modify E1 X1 c1 /\ Modify E2 X2 c2 ->
  decMR P ->
  equiv (req_mem_rel I P) E1 c1 E2 c2
  (req_mem_rel (Vset.diff O (Vset.diff I (Vset.union X1 X2))) Q) ->
  equiv (req_mem_rel I P) E1 c1 E2 c2 (req_mem_rel O Q).
 Proof.
  intros; destruct H.
  apply equiv_union_Modify_pre2 with
   (P1:= fun _ _ => True) (P2:= fun _ _ => True)
   (X1:=X1) (X2:=X2)
   (Q:=req_mem_rel (Vset.diff O (Vset.diff I (Vset.union X1 X2))) Q); auto.
  unfold req_mem_rel, kreq_mem; intros k m1 m2 m1' m2' [W1 W2] [W3 W4]; split.
  intros t x Hx.
  destruct (VsetP.mem_dec x (Vset.diff I (Vset.union X1 X2))).
  rewrite VsetP.diff_spec, VsetP.union_spec in i; destruct i.
  rewrite <- H2; try tauto.
  rewrite <- H3; auto; try tauto.
  apply W3; auto with set.
  trivial.
  apply Modify_Modify_pre; auto.
  apply Modify_Modify_pre; auto.
 Qed.

 Lemma equiv_union_Modify_Meq : forall E1 c1 E2 c2 P X1 X2,
  Modify E1 X1 c1 /\ Modify E2 X2 c2 ->
  implMR P Meq ->
  equiv P E1 c1 E2 c2 (kreq_mem (Vset.union X1 X2)) ->
  equiv P E1 c1 E2 c2 Meq.
 Proof.
  intros; destruct H.
  apply equiv_union_Modify_pre with
   (P1:=fun _ _ => True) (P2:=fun _ _ => True)
   (X1:=Vset.union X1 X2) (X2:=Vset.union X1 X2)
   (Q:=kreq_mem (Vset.union X1 X2)); auto.
  intros.
  assert (W := H0 k m1 m2 H3).
  unfold Meq in *; subst.
  apply req_mem_eq; trivial.
  apply Modify_Modify_pre; apply Modify_weaken with (1:= H); auto with set.
  apply Modify_Modify_pre; apply Modify_weaken with (1:= H2); auto with set.
 Qed.

 Lemma equiv_union_Modify_Meq_and : forall E1 c1 E2 c2 P X1 X2 Q Y1 Y2,
  depend_only_rel Q Y1 Y2 ->
  Modify E1 X1 c1 /\ Modify E2 X2 c2 ->
  implMR P Meq ->
  equiv P E1 c1 E2 c2
  (req_mem_rel (Vset.union (Vset.union X1 X2) (Vset.union Y1 Y2)) Q) ->
  equiv P E1 c1 E2 c2 (Meq /-\ Q).
 Proof.
  intros; set (X:= Vset.union (Vset.union X1 X2) (Vset.union Y1 Y2)).
  destruct H0.
  intros; apply equiv_union_Modify_pre with
   (P1 := fun _ _ => True) (P2 := fun _ _ => True)
   (X1 := X) (X2 := X)
   (Q:= req_mem_rel X Q); auto.
  intros.
  assert (W := H1 k m1 m2 H4).
  destruct H5.
  unfold Meq, andR in *; subst; split.
  apply req_mem_eq; trivial.
  apply (H k m1' m2').
  apply req_mem_sym; apply req_mem_weaken with X;
  [ unfold X; auto with set | apply req_mem_update_mem_l].
  apply req_mem_sym; apply req_mem_weaken with X;
  [ unfold X; auto with set | apply req_mem_update_mem_l].
  trivial.
  apply Modify_Modify_pre; apply Modify_weaken with (1:= H0);
   unfold X; auto with set.
  apply Modify_Modify_pre; apply Modify_weaken with (1:= H3);
   unfold X; auto with set.
 Qed.

 Lemma EqObs_union_Modify : forall E1 c1 E2 c2 I X1 X2 O,
  Modify E1 X1 c1 /\ Modify E2 X2 c2 ->
  EqObs I E1 c1 E2 c2 (Vset.diff O (Vset.diff I (Vset.union X1 X2))) ->
  EqObs I E1 c1 E2 c2 O.
 Proof.
  unfold EqObs;intros.
  apply equiv_weaken with (req_mem_rel O trueR);
   [unfold req_mem_rel, andR;intuition |].
  apply equiv_strengthen with (req_mem_rel I trueR);
   [unfold req_mem_rel, andR, trueR;intuition|].
  eapply equiv_union_Modify; eauto.
  eapply equiv_weaken;[ | eapply equiv_strengthen;[ | apply H0] ];
  unfold req_mem_rel, andR, trueR;intuition.
 Qed.

 Lemma disjoint_singleton : forall v O,
  Vset.mem v O = false ->
  Vset.disjoint O (Vset.singleton v).
 Proof.
  unfold Vset.disjoint; intros.
  change (Vset.inter O (Vset.singleton v) [=] Vset.empty).
  rewrite VsetP.eq_spec; split; auto with set.
  apply Vset.subset_complete; intro.
  rewrite VsetP.inter_spec; intros (H1, H2).
  assert (v = x).
  apply (Vset.singleton_complete _ _ H2).
  subst; rewrite H in H1; trivialb.
 Qed.

 Lemma disjoint_union : forall I X1 X2,
  Vset.disjoint I X1 -> Vset.disjoint I X2 -> Vset.disjoint I (Vset.union X1 X2).
 Proof.
  unfold Vset.disjoint; intros.
  change  (Vset.inter I (Vset.union X1 X2) [=] Vset.empty).
  rewrite VsetP.inter_union_comm; rewrite (H :Vset.inter I X1 [=] Vset.empty).
  rewrite (H0 :Vset.inter I X2 [=] Vset.empty).
  auto with set.
 Qed.

 Lemma eqobs_in_b_assign : forall t (v:Var.var t) e O,
  EqObs (eqobs_in_b (I.Assign v e) O) E [v <- e] E [v <- e] O.
 Proof.
  unfold EqObs; intros; simpl.
  case_eq (Vset.mem v O); intros.
  eapply equiv_strengthen; [ | apply equiv_assign].
  unfold kreq_mem; intros; simpl.
  red; apply req_mem_weaken with (Vset.add v (Vset.remove v O)).
  rewrite VsetP.add_remove; auto with set.
  rewrite union_fv_expr_spec in H0.
  rewrite (@EqObs_e_fv_expr t e k m1 m2).
  apply req_mem_update.
  apply req_mem_weaken with (2:= H0); auto with set.
  apply req_mem_weaken with (2:= H0); auto with set.
  fold (EqObs O E [v<-e] E [v<-e] O).
  apply EqObs_lossless_Modify with (Vset.singleton v) (Vset.singleton v);
   auto using lossless_assign,Modify_assign,disjoint_singleton.
 Qed.

 Lemma eqobs_in_b_random : forall t (v:Var.var t) (d:DE.support t) O,
  EqObs (eqobs_in_b (I.Random v d) O) E [v <$- d] E [v <$- d] O.
 Proof.
  unfold EqObs; intros; simpl.
  case_eq (Vset.mem v O); intros.
  eapply equiv_strengthen;[ | apply equiv_random].
  unfold kreq_mem; intros; simpl.
  split; unfold eq_support.
  apply EqObs_d_fv_expr.
  apply req_mem_weaken with (2:= H0); auto with set.
  red; intros; apply req_mem_weaken with (Vset.add v (Vset.remove v O)).
  rewrite VsetP.add_remove; auto with set.
  apply req_mem_update.
  apply req_mem_weaken with (2:= H0); auto with set.
  fold (EqObs O E [v <$- d] E [v <$- d] O).
  apply EqObs_lossless_Modify with (Vset.singleton v) (Vset.singleton v);
   auto using lossless_random,Modify_random,disjoint_singleton.
 Qed.

 Section WHILE.

  Variable c : cmd.

  Hypothesis eqobs_in_correct :
   forall I O, eqobs_in c O = Some I -> EqObs I E c E c O.

  Lemma eqobs_in_while : forall b O I,
   eqobs_in_i (while b do c) O = Some I ->
   Vset.union O (fv_expr b) [<=]  I /\ EqObs I E c E c I.
  Proof.
   simpl; intros.
   set (P1 := fun X => (Vset.union O (fv_expr b) [<=] X)).
   set (P2 := fun res =>
    match res with
    | Continue X => P1 X
    | Result None => True
    | Result (Some X) => Vset.union O (fv_expr b) [<=] X /\  EqObs X E c E c X
    end).
   match type of H with
   | match ?t with
     | Result _ => _
     | Continue _ => _
     end = _ => cut (P2 t); [destruct t; try discriminate|]
   end.
   subst; trivial.
   apply while_P with P1; intros.
   unfold P1 in *; generalize (fun I => @eqobs_in_correct I a); clear P1; intros.
   unfold eqobs_in in H1.
   destruct (fold_right (fun i => opt_app (eqobs_in_i i)) (Some a) c).
   assert (U:=H1 t (refl_equal _)); clear H1.
   case_eq (t [<=?] a); intros; simpl.
   change (t [<=] a) in H1; split; auto.
   red; apply equiv_strengthen with (2:= U).
   unfold kreq_mem; intros; apply req_mem_weaken with (1:= H1); trivial.
   apply VsetP.subset_trans with a; auto with set.
   simpl; trivial.
   exact H0.
   unfold P1; rewrite union_fv_expr_spec; rewrite VsetP.union_sym; auto with set.
  Qed.

 End WHILE.

 Lemma eqobs_in_aux :
  (forall i I O, eqobs_in_i i O = Some I -> EqObs I E [i] E [i] O) /\
  (forall c I O, eqobs_in c O = Some I -> EqObs I E c E c O).
 Proof.
   unfold eqobs_in, EqObs; apply I.cmd_ind2; simpl; intros.

   (* baseInstr *)
   destruct i; inversion_clear H.
   apply eqobs_in_b_assign.
   apply eqobs_in_b_random.

   (* Cond *)
   generalize (fun I => H I O) (fun I => H0 I O); clear H H0;
    destruct (fold_right (fun i => opt_app (eqobs_in_i i)) (Some O) c1);
     try discriminate.
   destruct (fold_right (fun i => opt_app (eqobs_in_i i)) (Some O) c2);
     try (intros; discriminate).
   intros H H0;
   match type of H1 with (if ?test then _ else _) = _ =>
    generalize H1; clear H1; case_eq test;
     intros Heq H1; inversion H1; clear H1; subst
   end.
   destruct (Vset.eqb t I); try discriminate.
   destruct (Vset.eqb t0 I); try discriminate.
   case_eq (is_lossless_nm I c1);
   intros H1; rewrite H1 in Heq; try discriminate Heq.
   destruct (is_lossless_nm_spec I c1 H1) as (H2, (X1,(H3,H4))).
   destruct (is_lossless_nm_spec I c2 Heq) as (H5, (X2,(H6,H7))).
   assert (lossless E [If b then c1 else c2]) by (apply lossless_cond; trivial).
   assert (Modify E (Vset.union X1 X2) [If b then c1 else c2]).
     apply Modify_cond; trivial.
   change (EqObs I E [If b then c1 else c2] E [If b then c1 else c2] I).
   apply EqObs_lossless_Modify with (Vset.union X1 X2) (Vset.union X1 X2);
    auto using disjoint_union.
   clear Heq.
   apply equiv_cond.
   apply equiv_strengthen with (kreq_mem t); auto.
   unfold kreq_mem; intros k m1 m2 (H1, _); rewrite union_fv_expr_spec in H1;
   apply req_mem_weaken with (2:= H1); auto with set.
   apply equiv_strengthen with (kreq_mem t0); auto.
   unfold kreq_mem; intros k m1 m2 (H1, _); rewrite union_fv_expr_spec in H1;
   apply req_mem_weaken with (2:= H1); auto with set.
   unfold kreq_mem; intros; assert (EqObs_e (fv_expr b) b b).
   apply EqObs_e_fv_expr.
   apply H2.
   apply req_mem_weaken with (2:= H1); rewrite union_fv_expr_spec; auto with set.

   (* While *)
   destruct (eqobs_in_while H b O H0); clear H0.
   eapply equiv_weaken;[ | apply equiv_while]; trivial.
   unfold kreq_mem; intros k m1 m2 (H3, _); apply req_mem_weaken with I; trivial.
   apply VsetP.subset_trans with (Vset.union O (fv_expr b)); auto with set.
   unfold kreq_mem; intros; apply ((@EqObs_e_fv_expr _ b)).
   apply req_mem_weaken with I; trivial.
   apply VsetP.subset_trans with (Vset.union O (fv_expr b)); auto with set.
   apply equiv_strengthen with (2:= H2).
   intros k m1 m2 (H3,_); trivial.

   (* Call *)
   match type of H with
   | (if ?test then _ else _) = _ =>
     generalize H; clear H; case_eq test; intros Heq H;
      inversion H; clear H; subst
   end.
   destruct (is_lossless_nm_i_spec _ _ Heq) as (H1, (X, (H2,H3))).
   change (EqObs I E [x <c- f with a] E [x <c- f with a] I);
     apply EqObs_lossless_Modify with X X; trivial.
   clear Heq; destruct (pi f) as [pif | ]; try discriminate.
   set (other:= Vset.diff O (Vset.add x (pi_output pif))) in *.
   case_eq (Vset.disjoint other (pi_mod pif));
    intros H2; rewrite H2 in H1; try discriminate.
   generalize H1; clear H1.
   case_eq (needed_args_refl
    (proc_params E f) a (pi_params pif) (Vset.union (pi_input pif) other));
   intros; try discriminate.
   inversion H1; clear H1; subst.
   destruct (needed_args_refl_correct _ _ _ _ H).
   eapply equiv_weaken; [ | apply (pi_spec_call pif) ]; trivial.
   unfold kreq_mem; intros; red; intros.
   apply H3; destruct (VsetP.mem_dec x0 (Vset.add x (pi_output pif)));
     auto with set.
   rewrite VsetP.union_spec, VsetP.diff_spec; right.
   assert (Vset.mem x0 other).
     unfold other; rewrite VsetP.diff_spec; split; trivial.
   split;[ apply Vset.subset_correct with (1:= H1); auto with set | ].
   apply VsetP.disjoint_mem_not_mem with (1:= H2); trivial.
   apply VsetP.subset_trans with (2:= H1); auto with set.

   (* nil *)
   inversion H; apply equiv_nil.

   (* cons *)
   generalize (fun I => H0 I O); clear H0.
   destruct (fold_right (fun i0 => opt_app (eqobs_in_i i0)) (Some O) c);
    try discriminate.
   intros H0; assert (U:= H0 t (refl_equal _)); clear H0.
   assert (Ui := H _ _ H1).
   apply equiv_cons with (1:= Ui); auto.
  Qed.

  Lemma eqobs_in_i_correct : forall i I O,
   eqobs_in_i i O = Some I ->
    EqObs I E [i] E [i] O.
  Proof.
   destruct eqobs_in_aux; trivial.
  Qed.

  Lemma eqobs_in_correct : forall c I O,
   eqobs_in c O = Some I ->
    EqObs I E c E c O.
  Proof.
   destruct eqobs_in_aux; trivial.
  Qed.

  Definition eqobs_in_subset I c O :=
   match eqobs_in c O with
   | Some I' => I' [<=?] I
   | _ => false
   end.

  Lemma eqobs_in_subset_correct : forall I c O,
   eqobs_in_subset I c O = true ->
   EqObs I E c E c O.
  Proof.
   intros I c O; unfold eqobs_in_subset.
   generalize (fun I => @eqobs_in_correct c I O).
   destruct (eqobs_in c O); intros; try discriminate.
   unfold EqObs ; apply equiv_strengthen with (2:= H _ (refl_equal _)).
   unfold kreq_mem; intros; apply req_mem_weaken with I; auto.
  Qed.

 (** Dead Code **)

 Section DEADCODE_AUX.

   Variable dead_code_i : I.t -> Vset.t -> option (Vset.t * cmd).

   Fixpoint dead_code_aux (c:cmd) (O:Vset.t) {struct c} : option (Vset.t * cmd) :=
    match c with
    | nil => Some (O, nil)
    | i::c1 =>
      match dead_code_aux c1 O with
      | Some (I1, c2) =>
        match dead_code_i i I1 with
        | Some (II, ci) => Some (II, ci++c2)
        | _ => None
        end
      | _ => None
      end
    end.

  End DEADCODE_AUX.

  Fixpoint dead_code_i (i:I.t) (O:Vset.t) {struct i} : option (Vset.t * cmd) :=
   match i with
   | I.Instr ib =>
     match ib with
      | I.Assign _ _ _
      | I.Random _ _ _ =>
        if is_notmodify_i pi O i then Some (O, nil)
        else Some (eqobs_in_b ib O, [i])
      | I.IAssert _ => None
      end
   | I.Cond e c1 c2 =>
     if E.eqb e true then dead_code_aux dead_code_i c1 O
     else if E.eqb e false then dead_code_aux dead_code_i c2 O
     else
     match dead_code_aux dead_code_i c1 O, dead_code_aux dead_code_i c2 O with
     | Some (I1,c1'), Some (I2,c2') =>
        if I.ceqb c1' c2' then Some (Vset.union I1 I2, c1')
        else
         Some (Vset.union (fv_expr e) (Vset.union I1 I2),
               [If e then c1' else c2'])
     | _, _ => None
     end
   | I.While e c =>
     if E.eqb e false then Some (O,nil)
     else
      match eqobs_in_i i O with
      | Some II => Some (II, [i])
  (* Correct but hard to prove ....
     match dead_code_aux dead_code_i c II with
     | Some (_, c') => Some (II, [while e do c'])
     | _ => None
     end
   *)
      | None => None
      end
   | I.Call _ _ _ _ =>
     if is_lossless_nm_i O i then Some (O, nil)
     else
      match eqobs_in_i i O with
      | Some II => Some (II, [i])
      | None => None
      end
   end.

  Lemma dead_code_aux_correct :
   (forall i O I ci,
    dead_code_i i O = Some (I,ci) -> EqObs I E [i] E ci O) /\
   (forall c O I cc,
    dead_code_aux dead_code_i c O = Some (I, cc) -> EqObs I E c E cc O).
  Proof.
   unfold EqObs; apply I.cmd_ind2; simpl; intros.

   (* baseInstr *)
   case_eq (is_notmodify_i pi O (I.Instr i)); destruct i.
   intros Heq; rewrite Heq in H; inversion H; clear H; subst.
   destruct (is_notmodify_i_correct _ _ _ Heq) as (X, (H1,H2)).
   apply equiv_lossless_Modify with
    (1:= @depend_only_kreq_mem I) (M1:=X) (M2:=X); trivial.
   apply lossless_assign.
   apply lossless_nil.
   eapply Modify_weaken; [apply Modify_nil | auto with set].

   intros Heq; rewrite Heq in H; inversion H; clear H; subst.
   destruct (is_notmodify_i_correct _ _ _ Heq) as (X, (H1,H2)).
   apply equiv_lossless_Modify with
    (1:= @depend_only_kreq_mem I) (M1:=X) (M2:=X); trivial.
   apply lossless_random.
   apply lossless_nil.
   eapply Modify_weaken; [apply Modify_nil | auto with set].

   discriminate.

   intros Heq; rewrite Heq in H; inversion H; clear H; subst.
   apply eqobs_in_b_assign.

   intros Heq; rewrite Heq in H; inversion H; clear H; subst.
   apply eqobs_in_b_random.

   discriminate.

   (* Cond *)
   generalize H1; clear H1.
   assert (W:=E.eqb_spec b true); destruct (E.eqb b true); subst; intros.
   apply equiv_cond_l; simplMR; auto.
   clear W; assert (W:=E.eqb_spec b false); destruct (E.eqb b false); subst; intros.
   apply equiv_cond_l; simplMR; auto.
   generalize (H O) (H0 O); clear W H H0;
   destruct (dead_code_aux dead_code_i c1 O); try discriminate.
   destruct (dead_code_aux dead_code_i c2 O); try discriminate.
   intros.
   destruct p as (I1, c1'); destruct p0 as (I2, c2').
   assert (W:= I.ceqb_spec c1' c2'); destruct (I.ceqb c1' c2'); intros;
   inversion H1; clear H1; subst; subst.
   apply equiv_cond_l.
   rewrite proj1_MR, <- VsetP.subset_union_l; auto.
   rewrite proj1_MR, <- VsetP.subset_union_r; auto.
   apply equiv_cond.
   rewrite proj1_MR, <- VsetP.subset_union_r, <- VsetP.subset_union_l; auto.
   rewrite proj1_MR, <- VsetP.subset_union_r, <- VsetP.subset_union_r; auto.
   unfold kreq_mem; intros; apply ((@EqObs_e_fv_expr _ b)).
   apply req_mem_weaken with (2:= H1); auto with set.
   destruct p; discriminate.

   (* While *)
   change ((if E.eqb b false then Some (O, nil)
                 else match (eqobs_in_i (while b do c) O) with
                 | Some II => Some (II, [while b do c])
                 | None => None (A:=Vset.t * cmd)
                end) = Some (I, ci)) in H0.
   assert (W:=E.eqb_spec b false); destruct (E.eqb b false); subst; intros;
   inversion H0; clear H0; subst.
   apply equiv_lossless_Modify with (1:=@depend_only_kreq_mem I) (M1:=Vset.empty)
     (M2:=Vset.empty).
   unfold lossless; intros.
   rewrite (eq_distr_elim (deno_while E false c m)).
   rewrite deno_cond_elim.
   simpl. rewrite (@deno_nil_elim k); trivial.
   apply lossless_nil.
   unfold Modify,range; intros.
   rewrite (eq_distr_elim (deno_while E false c m)).
   rewrite deno_cond_elim.
   simpl; rewrite (@deno_nil_elim k).
   apply H0; red; trivial.
   apply Modify_nil.
   change (Vset.inter I Vset.empty [=] Vset.empty); auto with set.
   change (Vset.inter I Vset.empty [=] Vset.empty); auto with set.
   case_eq (eqobs_in_i (while b do c) O); intros.
   assert (W1:=eqobs_in_i_correct _ _ H0).
   simpl in H0; rewrite H0 in H2; clear H0; inversion H2; clear H2; subst; trivial.
   simpl in H0; rewrite H0 in H2; discriminate H2.
   (* Call *)
   match type of H with
   | (if ?test then _ else _) = _ =>
     case_eq test; intros Heq; rewrite Heq in H end.
   destruct (is_lossless_nm_i_spec _ _ Heq) as (H1, (X, (H2, H3))).
   inversion H; clear H; subst.
   apply equiv_lossless_Modify with
    (1:=@depend_only_kreq_mem I) (M1:=X) (M2:=Vset.empty); trivial.
   apply lossless_nil.
   apply Modify_nil.
   change (Vset.inter I Vset.empty [=] Vset.empty); auto with set.
   case_eq (eqobs_in_i (x <c- f with a) O); intros.
   assert (W:=eqobs_in_i_correct _ _ H0).
   simpl in H0; rewrite Heq in H0; rewrite H0 in H; clear Heq H0.
   inversion H; clear H; subst; trivial.
   simpl in H0; rewrite Heq in H0; rewrite H0 in H; discriminate.
   (* nil *)
   inversion H.
   apply equiv_nil.
   (* cons *)
   generalize (H0 O); clear H0.
   destruct (dead_code_aux dead_code_i c O); try discriminate.
   destruct p as (I1,c2); generalize (H I1); clear H;
    destruct (dead_code_i i I1); try discriminate.
   destruct p; inversion H1; clear H1; subst; intros.
   change (i::c) with ([i]++c); apply equiv_app with
    (1:= H _ _ (refl_equal _)); auto.
  Qed.

  Definition dead_code c O :=
   match dead_code_aux dead_code_i c O with
   | Some (_, c') => Some c'
   | _ => None
   end.

  Lemma dead_code_correct : forall c O c',
   dead_code c O = Some c' -> equiv Meq E c E c' (kreq_mem O).
  Proof.
   intros c O c'; destruct dead_code_aux_correct as (_, H); unfold dead_code.
   generalize (H c O); clear H.
   destruct (dead_code_aux dead_code_i c O) as [(I,c1) | ].
   intros H H0; inversion H0; clear H0; subst.
   apply equiv_strengthen with (2:= H _ _ (refl_equal _)).
   unfold Meq, kreq_mem; intros; subst; apply req_mem_refl.
   intros; discriminate.
  Qed.

  Lemma dead_code_equiv_l : forall c1 c1' E2 c2 P Q X1 X2,
   decMR P ->
   depend_only_rel Q X1 X2 ->
   dead_code c1 X1 = Some c1' ->
   equiv P E c1' E2 c2 Q ->
   equiv P E c1 E2 c2 Q.
  Proof.
   intros.
   assert (H2:= dead_code_correct _ _ H0).
   apply equiv_depend_only_l with (2:= H) (4:= H1); trivial.
  Qed.

  Lemma dead_code_equiv_r : forall c2 c2' E1 c1 P Q X1 X2,
   decMR P ->
   depend_only_rel Q X1 X2 ->
   dead_code c2 X2 = Some c2' ->
   equiv P E1 c1 E c2' Q ->
   equiv P E1 c1 E c2 Q.
  Proof.
   intros.
   assert (H2:= dead_code_correct _ _ H0).
   apply equiv_depend_only_r with (2:= H) (4:= H1); trivial.
  Qed.

 End EQOBS.

 Section DEAD_CODE.

  Variables n : positive.
  Variables E1 E2 : env.
  Variables (pi1:eq_refl_info E1) (pi2:eq_refl_info E2).

  Definition dead_code_para c1 c2 O1 O2 :=
   match dead_code n pi1 c1 O1, dead_code n pi2 c2 O2 with
   | Some c1', Some c2' => Some (c1', c2')
   | _, _ => None
   end.

  Lemma dead_code_para_equiv :  forall c1 c1' c2 c2' P Q X1 X2,
   decMR P ->
   depend_only_rel Q X1 X2 ->
   dead_code_para c1 c2 X1 X2 = Some (c1',c2') ->
   equiv P E1 c1' E2 c2' Q ->
   equiv P E1 c1 E2 c2 Q.
  Proof.
   intros c1 c1' c2 c2' P Q X1 X2 Hdec Hdep Heq Hequiv;
    generalize Heq; clear Heq; unfold dead_code_para.
   case_eq (dead_code n pi1 c1 X1);
    [intros C1' H | intros; discriminate].
   case_eq (dead_code n pi2 c2 X2);
    [intros C2' H' H1; inversion H1; clear H1; subst|intros; discriminate].
   apply (@dead_code_equiv_l n E1 pi1 c1 c1' E2 c2 P _ _ _ Hdec Hdep H); trivial.
   apply (@dead_code_equiv_r n E2 pi2 c2 c2' E1 c1' P _ _ _ Hdec Hdep H'); trivial.
  Qed.

 End DEAD_CODE.

 Section CODE_MOVEMENT.

  Fixpoint split_cmd_aux (i:I.t) (r c:cmd) {struct c} : option (cmd * cmd) :=
   match c with
   | nil => None
   | i'::c' =>
     if I.eqb i i' then Some (r, c')
     else split_cmd_aux i (i'::r) c'
   end.

  Definition split_cmd i c := split_cmd_aux i nil c.

  Lemma split_cmd_aux_correct : forall i c r r' t,
   split_cmd_aux i r c = Some (r',t) ->
   rev_append r c = rev_append r' (i::t).
  Proof.
   induction c; simpl; intros r r' t.
   intros; discriminate.
   generalize (I.eqb_spec i a); destruct (I.eqb i a); intros.
   inversion H0; clear IHc H0; subst; trivial.
   rewrite <- (IHc _ _ _ H0); trivial.
  Qed.

  Lemma split_cmd_correct : forall i c r t,
   split_cmd i c = Some (r,t) ->
   c = rev_append r (i::t).
  Proof.
   intros i c r t H; rewrite <- (split_cmd_aux_correct _ _ _  H); trivial.
  Qed.

  Lemma EqObs_swap_aux : forall E I1 I2 O1 O2 c1 c2,
   Modify E O1 c1 ->
   Modify E O2 c2 ->
   EqObs I2 E c2 E c2 O2 ->
   Vset.disjoint I2 O1 ->
   forall k (m1 m2 : Mem.t k),
    m1 =={Vset.union I1 I2} m2 ->
    forall f: Mem.t k -> U,
     mu ([[c1]] E m1) (fun m' => mu ([[c2]] E m') f) ==
     mu ([[c1]] E m1) (fun m' => mu ([[c2]] E m2)
      (fun m'' => f (m1{!O1 <<- m'!} {!O2 <<- m''!}))).
  Proof.
   intros.
   rewrite (Modify_deno_elim H).
   apply (mu_stable_eq (([[c1]]) E m1)).
   simpl; apply ford_eq_intro; intros m'.
   rewrite (Modify_deno_elim H0 (k:=k)).
   match goal with |- ?x == _ => set (F:= x) end.
   rewrite (Modify_deno_elim H0 (k:=k)); unfold F; clear F.
   assert (m1 {!O1 <<- m'!} =={I2} m2).
   apply req_mem_trans with m1.
   apply req_mem_update_disjoint; trivial.
   apply req_mem_weaken with (2:= H3); auto with set.
   apply (equiv_deno H1); trivial; unfold kreq_mem; intros.
   rewrite (@req_mem_eq k O2 (m1 {!O1 <<- m'!}) m0 (m2 {!O2 <<- m3!})); trivial.
   apply req_mem_trans with (1:= H5).
   apply req_mem_sym; apply req_mem_update_mem_l.
  Qed.

  Lemma swap_comm :  forall E I1 I2 O1 O2 c1 c2,
   Modify E O1 c1 ->
   Modify E O2 c2 ->
   EqObs I1 E c1 E c1 O1 ->
   EqObs I2 E c2 E c2 O2 ->
   Vset.disjoint I2 O1 ->
   Vset.disjoint I1 O2 ->
   Vset.disjoint O1 O2 ->
   forall k (m:Mem.t k) f,
    mu ([[c1++c2]] E m) f ==
    mu ([[c2++c1]] E m) f.
  Proof.
   intros; repeat rewrite deno_app_elim.
   assert (H6:= req_mem_refl (Vset.union I1 I2) m).
   rewrite (EqObs_swap_aux I1 H H0 H2 H3 H6).
   rewrite VsetP.union_sym in H6; apply req_mem_sym in H6.
   rewrite (EqObs_swap_aux I2 H0 H H1 H4 H6).
   rewrite deno_comm.
   apply mu_stable_eq.
   refine (@ford_eq_intro _ _ _ _ _); intros m'.
   apply mu_stable_eq.
   simpl; apply ford_eq_intro; intro m''.
   replace (m {!O1 <<- m''!} {!O2 <<- m'!}) with
    (m {!O2 <<- m'!} {!O1 <<- m''!}); trivial.
   apply Mem.eq_leibniz.
   intros (t, x); destruct (VsetP.mem_dec x O1).
   rewrite update_mem_in; trivial.
   rewrite update_mem_notin.
   rewrite update_mem_in; trivial.
   apply VsetP.disjoint_mem_not_mem with (1:= H5); trivial.
   rewrite update_mem_notin; trivial.
   destruct (VsetP.mem_dec x O2).
   repeat rewrite update_mem_in; trivial.
   repeat rewrite update_mem_notin; trivial.
  Qed.

  Lemma equiv_swap : forall E I1 I2 O1 O2 c1 c2,
   Modify E O1 c1 ->
   Modify E O2 c2 ->
   EqObs I1 E c1 E c1 O1 ->
   EqObs I2 E c2 E c2 O2 ->
   Vset.disjoint O1 O2 ->
   Vset.disjoint I1 O2 ->
   Vset.disjoint I2 O1 ->
   equiv Meq E (c1++c2) E (c2++c1) Meq.
  Proof.
   intros; intro k.
   exists (fun m1 m2 => Mlet ([[c1++c2]] E m1) (fun m => Munit (m,m))).
   unfold Meq; intros; subst; constructor; simpl; intros; trivial.
   apply (mu_stable_eq (([[c1 ++ c2]]) E m2)).
   simpl; apply ford_eq_intro; trivial.
   rewrite (swap_comm H H0 H1 H2 H5 H4 H3 m2).
   apply (mu_stable_eq (([[c2 ++ c1]]) E m2)).
   simpl; apply ford_eq_intro; trivial.
   red; unfold prodP; intros; simpl.
   transitivity (mu (([[c1 ++ c2]]) E m2) (fun x : Mem.t k=> 0)).
   symmetry; apply mu_0.
   apply (mu_stable_eq (([[c1 ++ c2]]) E m2)).
   simpl; apply ford_eq_intro; auto.
  Qed.

  Variable n : positive.

  Variable E1 E2 : env.

  Variable pi1 : eq_refl_info E1.

  Variable pi2 : eq_refl_info E2.

  Definition swapable (E:env) (pi:eq_refl_info E) (i:I.instr) (c:cmd) :=
   match modify_i pi Vset.empty i, modify pi Vset.empty c with
   | Some M1, Some M2 =>
     if Vset.disjoint M1 M2 then
     match eqobs_in_i n pi i M1, eqobs_in n pi c M2 with
     | Some I1, Some I2 =>
       if Vset.disjoint I1 M2 then Vset.disjoint I2 M1
       else false
     | _, _ => false
     end
     else false
   | _, _ => false
   end.

  Lemma swapable_correct : forall (E:env) (pi:eq_refl_info E) (i:I.instr) (c:cmd),
   swapable pi i c = true ->
   equiv Meq E (i::c) E (c++[i]) Meq.
  Proof.
   unfold swapable; intros E pi i c.
   generalize (modify_i_correct pi i Vset.empty);
    destruct (modify_i pi Vset.empty i) as [M1 | ];
     intro; try (intros; discriminate).
   generalize (modify_correct pi c Vset.empty);
    destruct (modify pi Vset.empty c) as [M2 | ];
     intro; try (intros; discriminate).
   case_eq (Vset.disjoint M1 M2); intro; try (intros; discriminate).
   generalize (fun I => @eqobs_in_i_correct n E pi i I M1);
    destruct (eqobs_in_i n pi i M1) as [I1 | ]; intro; try (intros; discriminate).
   generalize (fun I => @eqobs_in_correct n E pi c I M2);
    destruct (eqobs_in n pi c M2) as [I2 | ]; intro; try (intros; discriminate).
   case_eq (Vset.disjoint I1 M2); intros; try discriminate.
   apply equiv_swap with (3:=H2 _ (refl_equal _)) (4:=H3 _ (refl_equal _)); auto.
  Qed.

  Fixpoint swap_aux (rh1 t1 c2 t : cmd) {struct rh1} : (triple cmd cmd cmd) :=
   match rh1 with
   | nil => Triple t1 c2 t
   | i::rh1' =>
     if swapable pi1 i t1 then
      match split_cmd i c2 with
      | Some (r2,t2) =>
        if swapable pi2 i t2 then swap_aux rh1' t1 (rev_append r2 t2) (i::t)
        else swap_aux rh1' (i::t1) c2 t
      | None => swap_aux rh1' (i::t1) c2 t
      end
      else swap_aux rh1' (i::t1) c2 t
   end.

  Lemma swap_aux_correct : forall rh1 t1 c2 t h1 h2 t',
   swap_aux rh1 t1 c2 t = Triple h1 h2 t' ->
   equiv Meq E1 ((rev_append rh1 t1) ++ t) E1 (h1++t') Meq /\
   equiv Meq E2 (c2 ++ t) E2 (h2++t') Meq.
  Proof.
   induction rh1; simpl; intros t1 c2 t h1 h2 t'.
   intros Heq; inversion Heq; split; apply equiv_eq_mem.
   assert (forall h1 h2 t', swap_aux rh1 (a :: t1) c2 t = Triple h1 h2 t' ->
     equiv Meq E1 (rev_append rh1 (a :: t1) ++ t) E1 (h1 ++ t') Meq /\
     equiv Meq E2 (c2 ++ t) E2 (h2 ++ t') Meq).
     intros h3 h4 t'0 H1; refine (IHrh1 _ _ _ _ _ _ H1).
   generalize (swapable_correct pi1 a t1).
   destruct (swapable pi1 a t1); intro; auto.
   generalize (split_cmd_correct a c2).
   destruct (split_cmd a c2) as [(h3,t2) | ]; intro; auto.
   generalize (swapable_correct pi2 a t2).
   destruct (swapable pi2 a t2); intros; auto.
   destruct (IHrh1 _ _ _ _ _ _ H3).
   split.
   apply equiv_trans_eq_mem_l with
    (P1:=trueR) (2:= H4); trivial.
   simplMR; repeat rewrite rev_append_rev.
   change (a::t) with ([a]++t).
   rewrite ass_app; apply equiv_app with Meq; auto using equiv_eq_mem.
   rewrite app_ass; apply equiv_app with Meq; auto using equiv_eq_mem.
   red; red; trivial.
   rewrite (H1 _ _ (refl_equal _)).
   apply equiv_trans_eq_mem_l with (P1:=trueR) (2:= H5); trivial.
   simplMR; change (a::t) with ([a]++t).
   rewrite ass_app; apply equiv_app with Meq; auto using equiv_eq_mem.
   repeat rewrite rev_append_rev; rewrite rev_append_rev in H5.
   rewrite app_ass; apply equiv_app with Meq; auto using equiv_eq_mem.
   red; red; trivial.
  Qed.

  Definition swap c1 c2 := swap_aux (rev' c1) nil c2 nil.

  Lemma swap_correct : forall c1 c2 h1 h2 t,
   swap c1 c2 = Triple h1 h2 t ->
   forall P Q, equiv P E1 (h1++t) E2 (h2++t) Q ->
    equiv P E1 c1 E2 c2 Q.
  Proof.
   intros.
   destruct (swap_aux_correct _ _ _ _ H).
   rewrite <- app_nil_end in H1, H2.
   unfold rev' in H1; repeat rewrite rev_append_rev in H1.
   repeat rewrite <- app_nil_end in H1; rewrite rev_involutive in H1.
   apply equiv_trans_eq_mem_l with
    (P1:=trueR) (E1':= E1) (c1':= (h1 ++ t)); trivial.
   simplMR; trivial.
   apply equiv_trans_eq_mem_r with
    (P2:=trueR) (E2':= E2) (c2':= (h2 ++ t)); trivial.
   simplMR; trivial.
   red; red; trivial.
   red; red; trivial.
  Qed.

 End CODE_MOVEMENT.

End Make.


Require Import Arith List String.
Require Import ExtLib.Structures.Monad.
From CertiCoq.Plugin Require Import CertiCoq.

Import MonadNotation.
Import ListNotations.
Open Scope monad_scope.

Require Import Coq.Strings.Ascii.

Inductive rgx : Type :=
| empty   : rgx
| epsilon : rgx
| literal : string -> rgx
| or      : rgx -> rgx -> rgx
| and     : rgx -> rgx -> rgx
| star    : rgx -> rgx
| capture : rgx -> rgx.

Fixpoint simplify (r : rgx) : rgx :=
  match r with
  | star epsilon         => epsilon
  | star (star r')       => star (simplify r')
  | or epsilon (star r') => star (simplify r')
  | or empty r'          => simplify r'
  | and  r1 r2           => and (simplify r1) (simplify r2)
  | or   r1 r2           => or (simplify r1) (simplify r2)
  | star r'              => star (simplify r')
  | capture r'           => capture (simplify r')
  | _                    => r
  end.

Infix "⊕" := or (right associativity, at level 60).
Infix "·" := and (right associativity, at level 60).

Class RegexFFI : Type :=
  Build_RegexFFI
    { test : rgx -> string -> bool
    ; exec : rgx -> string -> option (list string)
    }.

Fixpoint literals (l : list string) : rgx :=
  match l with
  | nil => empty
  | x :: xs => literal x ⊕ literals xs
  end.

Definition numeric := literals ["0";"1";"2";"3";"4";"5";"6";"7";"8";"9"]%string.

Definition alpha :=
  or (literals ["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m"]%string)
     (literals ["n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"]%string).

Definition alphanumeric :=
  or alpha numeric.

Definition email :=
    capture (star alphanumeric)
  · literal "@"
  · capture (star alphanumeric)
  · literal "."
  · capture (literals ["com";"net";"org";"edu"]%string).

Definition prog `{RegexFFI} :=
  exec email "name@example.com".

CertiCoq Compile -args 5 prog.
CertiCoq FFI -prefix "rgx_" RegexFFI.


From Coq Require Import Arith Psatz Bool String List Nat Program.Equality.

Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.

Require Import DanTrick.StackLanguage DanTrick.StackLangEval DanTrick.LogicProp DanTrick.StackSubstitution DanTrick.StackPurest DanTrick.StackExprWellFormed.

From DanTrick Require Export StackLogicBase.

Scheme Equality for list.

Definition triple_stk (P: AbsState) (i: imp_stack) (Q: AbsState) (fenv: fun_env_stk): Prop :=
  forall (stk stk': stack),
    imp_stack_sem i fenv stk stk' ->
    (absstate_match_rel P fenv stk) ->
    (absstate_match_rel Q fenv stk').

Notation "{{{ P }}} i {{{ Q }}} @ f" := (triple_stk P i Q f) (at level 90, i at next level).

Definition atruestk (b: bexp_stack) (P: AbsState): AbsState :=
  (AbsAnd P (BaseState (AbsStkTrue)
                       (MetaBool (UnaryProp _ _
                                            (fun bval => bval = true)
                                            b)))).

Definition afalsestk (b: bexp_stack) (P: AbsState) : AbsState :=
  (AbsAnd P (BaseState (AbsStkTrue)
                       (MetaBool (UnaryProp _ _
                                            (fun bval => bval = false)
                                            b)))).

Definition aimpstk (P Q: AbsState) (fenv: fun_env_stk) : Prop :=
  forall stk,
    absstate_match_rel P fenv stk -> absstate_match_rel Q fenv stk.

Definition aandstk (P Q: assertion): assertion :=
  fun stk => P stk /\ Q stk.

Lemma self_implication :
  forall (s: AbsState) (fenv: fun_env_stk),
    (aimpstk s s fenv).
Proof.
  unfold aimpstk. intros. auto.
Qed.

Check (aandstk silly silly).

Lemma anding_silly :
  forall stk,
    ~ (aandstk silly silly stk).
Proof.
  intros. unfold aandstk, not. intros.
  destruct H.
  apply silly_theorem in H.
  assumption.
Qed.

Notation "P --->>> Q" := (aimpstk P Q) (at level 95, no associativity).

Inductive hl_stk : AbsState -> imp_stack -> AbsState -> fun_env_stk -> Type :=
| hl_stk_skip :
  forall P fenv,
    hl_stk P Skip_Stk P fenv
| hl_stk_assign :
  forall P fenv k a P',
    aexp_stack_pure_rel a fenv ->
    state_update_rel k a P P' ->
    hl_stk P' (Assign_Stk k a) P fenv
| hl_stk_push :
  forall P fenv P',
    state_stk_size_inc 1 P P' ->
    hl_stk P (Push_Stk) P' fenv
| hl_stk_pop :
  forall P fenv P' Q,
    state_stk_size_inc 1 P' P ->
    hl_stk (AbsAnd P Q) (Pop_Stk) P' fenv
| hl_stk_seq :
  forall P Q R i1 i2 fenv,
    hl_stk P i1 R fenv ->
    hl_stk R i2 Q fenv ->
    hl_stk P (Seq_Stk i1 i2) Q fenv
| hl_stk_if :
  forall P Q b i1 i2 fenv,
    bexp_stack_pure_rel b fenv ->
    hl_stk (atruestk b P) i1 Q fenv ->
    hl_stk (afalsestk b P) i2 Q fenv ->
    hl_stk P (If_Stk b i1 i2) Q fenv
| hl_stk_while :
  forall P b i fenv,
    bexp_stack_pure_rel b fenv ->
    hl_stk (atruestk b P) i P fenv ->
    hl_stk P (While_Stk b i) (afalsestk b P) fenv
| hl_stk_consequence :
  forall P Q P' Q' c fenv,
    hl_stk P c Q fenv ->
    (P' --->>> P) fenv ->
    (Q --->>> Q') fenv ->
    hl_stk P' c Q' fenv.

Check hl_stk_ind.

Lemma Hoare_Stk_consequence_pre :
  forall P P' Q i fenv,
    hl_stk P i Q fenv ->
    (P' --->>> P) fenv ->
    hl_stk P' i Q fenv.
Proof.
  intros.
  apply hl_stk_consequence with (P := P) (Q := Q); unfold aimpstk; auto.
Qed.

Lemma Hoare_Stk_consequence_post :
  forall P Q Q' i fenv,
    hl_stk P i Q fenv ->
    (Q --->>> Q') fenv ->
    hl_stk P i Q' fenv.
Proof.
  intros.
  apply hl_stk_consequence with (P := P) (Q := Q); unfold aimpstk; auto.
Qed.

Lemma Hoare_Stk_ifthen :
  forall b i P Q fenv,
    bexp_stack_pure_rel b fenv ->
    hl_stk (atruestk b P) i Q fenv ->
    ((afalsestk b P) --->>> Q) fenv ->
    hl_stk P (If_Stk b i Skip_Stk) Q fenv.
Proof.
  intros. apply (hl_stk_if P Q b i Skip_Stk fenv); auto.
  apply Hoare_Stk_consequence_pre with Q.
  - auto using hl_stk_skip.
  - assumption.
Qed.

Ltac invs H := inversion H; subst.

Lemma triple_stk_skip :
  forall P fenv,
    {{{P}}} Skip_Stk {{{P}}} @ fenv.
Proof.
  unfold triple_stk; intros. invs H. assumption.
Qed.

Lemma triple_stk_assign :
  forall P P' (k: stack_index) (a: aexp_stack) fenv,
    aexp_stack_pure_rel a fenv ->
    state_update_rel k a P P' ->
    {{{P'}}} Assign_Stk k a {{{P}}} @ fenv.
Proof.
  unfold triple_stk, stk_update. intros P P' k a fenv PURE STATE_UP.
  intros.
  invs H.

  pose proof (PURE' := PURE).
  eapply aexp_stack_pure_backwards in PURE.
  unfold aexp_stack_pure in PURE.
  specialize (PURE stk stk'0 c).

  pose proof (H10 := H5).
  apply PURE in H5.
  symmetry in H5.
  subst.
  invs STATE_UP.
  - assert (absstate_well_formed (BaseState s m)).
    econstructor.
    assumption.

    eapply state_update_same_as_eval_under_different_state with (k := k) (a := a) (aval := c) (stk := stk) (stk' := stk'); eassumption.
  - assert (absstate_well_formed (AbsAnd s1 s2)) by (econstructor; eassumption).
    eapply state_update_same_as_eval_under_different_state with (k := k) (a := a) (aval := c) (stk := stk) (stk' := stk'); eassumption.
  - assert (absstate_well_formed (AbsOr s1 s2)) by (econstructor; eassumption).
    eapply state_update_same_as_eval_under_different_state with (k := k) (a := a) (aval := c) (stk := stk) (stk' := stk'); eassumption.
Qed.

Ltac absstack_size :=
  match goal with
  | [ |- absstack_match_rel (AbsStkSize 1) (?v :: ?vs) ] =>
      econstructor; simpl; intuition
  end.

Ltac match_inversion :=
  match goal with
  | [ H: absstate_match_rel (BaseState ?s ?Meta) ?fenv ?stk |- _ ] =>
      invs H;
      match goal with
      | [ H': meta_match_rel Meta fenv stk |- _ ] =>
          invs H';
          match goal with
          | [ H'' : eval_prop_rel ?func ?LogProp |- _ ] =>
              invs H''
          end;
          match goal with
          | [ H''' : prop_rel ?func ?LogProp |- _ ] =>
              invs H'''
          end
      end
  end;
  match goal with
  | [ H : absstate_well_formed (BaseState ?s ?Meta) |- _ ] =>
      invs H;
      match goal with
      | [ H' : mv_well_formed Meta |- _ ] =>
          invs H'
      | [ |- _ ] =>
          idtac
      end
  | [ |- _ ] =>
      idtac
  end.

Ltac meta_match_elimination_helper p1 p2 p1' p2' :=
  match goal with
  | [ H': transformed_prop_exprs _ p1 p1' |- _ ] =>
      econstructor
  | [ H': transformed_prop_exprs _ p2 p2' |- _ ] =>
      eapply RelOrPropRight
  end.

Ltac meta_match_elimination :=
  match goal with
  | [  |- meta_match_rel (_ (OrProp ?ValType ?ExprType ?p1' ?p2')) ?fenv ?stk ] =>
      econstructor;
      match goal with
      | [ H: eval_prop_rel _ (OrProp ValType ExprType ?p1 ?p2)  |- _ ] =>
          match goal with
          | [ H': eval_prop_rel _ p1 |- _ ] =>
              econstructor
          | [ H': eval_prop_rel _ p2 |- _ ] =>
              eapply RelOrPropRight
          end
      | [ |- _ ] =>
          idtac
      end
  | [ |- meta_match_rel _ _ _ ] =>
      econstructor;
      econstructor
  end.

Ltac smart_pure_helper :=
  match goal with
  | [  H0 : transformed_prop_exprs (bexp_stk_size_inc_rel 1) ?p1 ?p1', H13 : prop_rel
          (fun boolexpr : bexp_stack => bexp_stack_pure_rel boolexpr ?fenv)
          ?p1
       |- prop_rel
           (fun boolexpr : bexp_stack => bexp_stack_pure_rel boolexpr ?fenv) ?p1' ] =>
      eapply bool_prop_rel_prop_stk_inc_preserves_purity; [ eapply H13 | eassumption]
  | [ H0: transformed_prop_exprs_args (bexp_stk_size_inc_rel 1) ?args ?args',
        H1: prop_args_rel (fun boolexpr : bexp_stack =>
                             bexp_stack_pure_rel boolexpr ?fenv)
                          ?args |-
        prop_args_rel (fun boolexpr : bexp_stack =>
                         bexp_stack_pure_rel boolexpr ?fenv)
                      ?args' ] =>
      eapply bool_prop_args_rel_prop_stk_inc_preserves_purity; eassumption
  | [ H0: bexp_stk_size_inc_rel 1 ?a ?a',
        H1: bexp_stack_pure_rel ?a ?fenv |-
        bexp_stack_pure_rel ?a' ?fenv ] =>
      eapply bexp_size_inc_preserves_purity; eassumption

  | [  H0 : transformed_prop_exprs (aexp_stk_size_inc_rel 1) ?p1 ?p1',
       H13 : prop_rel
               (fun natexpr : aexp_stack =>
                  aexp_stack_pure_rel natexpr ?fenv)
               ?p1
       |- prop_rel
           (fun natexpr : aexp_stack =>
              aexp_stack_pure_rel natexpr ?fenv)
           ?p1' ] =>
      eapply nat_prop_rel_prop_stk_inc_preserves_purity; [ eapply H13 | eassumption]
  | [ H0: aexp_stk_size_inc_rel 1 ?a ?a',
        H1: aexp_stack_pure_rel ?a ?fenv |-
        aexp_stack_pure_rel ?a' ?fenv ] =>
      eapply aexp_size_inc_preserves_purity; eassumption
  | [ H0: transformed_prop_exprs_args (aexp_stk_size_inc_rel 1) ?args ?args',
        H1: prop_args_rel (fun natexpr : aexp_stack =>
                             aexp_stack_pure_rel natexpr ?fenv)
                          ?args |-
        prop_args_rel (fun natexpr : aexp_stack =>
                         aexp_stack_pure_rel natexpr ?fenv)
                      ?args' ] =>
      eapply nat_prop_args_rel_prop_stk_inc_preserves_purity; eassumption

  end.

Lemma triple_stk_push :
  forall P Q fenv,
    state_stk_size_inc 1 P Q ->
    {{{P}}} Push_Stk {{{Q}}} @ fenv.
Proof.
  unfold triple_stk.
  induction P; intros Q fenv INC stk stk' IMP MATCH.
  - invs INC.
    invs H2; invs IMP.
    + econstructor; [absstack_size | ].
      invs H4.
      * invs H; match_inversion; meta_match_elimination; try smart_pure_helper.
        1,3,4,10-12: eapply bexp_stack_increase_preserves_eval; eassumption.
        3-6: eapply logic_stack_increase_preserves_eval; eassumption.
        4: eapply bool_args_stack_increase_preserves_eval; eassumption.
        all: try eassumption; try eapply bexp_size_inc_preserves_purity; try eassumption; try smart_pure_helper.
      * invs H; match_inversion; meta_match_elimination; try smart_pure_helper.
        1,3,4,10-12: eapply aexp_stack_increase_preserves_eval; eassumption.
        3-6: eapply nat_logic_stack_increase_preserves_eval; eassumption.
        4: eapply nat_args_stack_increase_preserves_eval; eassumption.
        all: try assumption.
    + econstructor.
      * invs MATCH.
        invs H1.
        econstructor.
        simpl.
        intuition.
      * invs H4.
        -- invs H; match_inversion; meta_match_elimination; try smart_pure_helper;
             try eapply bexp_stack_increase_preserves_eval; try eapply logic_stack_increase_preserves_eval; try eapply bool_args_stack_increase_preserves_eval; eassumption.
        -- invs H; match_inversion; meta_match_elimination; try smart_pure_helper; try eapply aexp_stack_increase_preserves_eval; try eapply nat_logic_stack_increase_preserves_eval; try eapply nat_args_stack_increase_preserves_eval; eassumption.
  - invs INC. invs MATCH.
    econstructor.
    + eapply IHP1; eassumption.
    + eapply IHP2; eassumption.
  - invs INC. invs MATCH.
    + econstructor. eapply IHP1.
      * eassumption.
      * eassumption.
      * assumption.
    + eapply RelAbsOrRight. eapply IHP2; eassumption.
Qed.

Ltac smart_pure_helper' :=
  match goal with
  | [  H0 : transformed_prop_exprs (bexp_stk_size_inc_rel 1) ?p1 ?p1', H13 : prop_rel
          (fun boolexpr : bexp_stack => bexp_stack_pure_rel boolexpr ?fenv)
          ?p1',
          H14: prop_rel bexp_well_formed ?p1
       |- prop_rel
           (fun boolexpr : bexp_stack => bexp_stack_pure_rel boolexpr ?fenv) ?p1 ] =>
      eapply bool_prop_rel_prop_stk_inc_preserves_purity';
      [eapply H13 | unfold bool_prop_wf; unfold_prop_helpers | eapply H0 ];
      eassumption
  | [ H0: transformed_prop_exprs_args (bexp_stk_size_inc_rel 1) ?args ?args',
        H1: prop_args_rel (fun boolexpr : bexp_stack =>
                             bexp_stack_pure_rel boolexpr ?fenv)
                          ?args',
          H2: prop_args_rel bexp_well_formed ?args |-

        prop_args_rel (fun boolexpr : bexp_stack =>
                         bexp_stack_pure_rel boolexpr ?fenv)
                      ?args ] =>
      eapply bool_prop_args_rel_prop_stk_inc_preserves_purity'; eassumption
  | [ H0: bexp_stk_size_inc_rel 1 ?a ?a',
        H1: bexp_stack_pure_rel ?a' ?fenv,
          H2: bexp_well_formed ?a
      |-
        bexp_stack_pure_rel ?a ?fenv ] =>
      eapply bexp_size_inc_preserves_purity'; eassumption

  | [  H0 : transformed_prop_exprs (aexp_stk_size_inc_rel 1) ?p1 ?p1',
       H13 : prop_rel
               (fun natexpr : aexp_stack =>
                  aexp_stack_pure_rel natexpr ?fenv)
               ?p1',
          H14 : prop_rel aexp_well_formed ?p1
       |- prop_rel
           (fun natexpr : aexp_stack =>
              aexp_stack_pure_rel natexpr ?fenv)
           ?p1 ] =>
      eapply nat_prop_rel_prop_stk_inc_preserves_purity';
      [ eapply H13 | unfold nat_prop_wf; unfold_prop_helpers | eapply H0];
      eassumption
  | [ H0: aexp_stk_size_inc_rel 1 ?a ?a',
        H1: aexp_stack_pure_rel ?a' ?fenv |-
        aexp_stack_pure_rel ?a ?fenv ] =>
      eapply aexp_size_inc_preserves_purity'; eassumption
  | [ H0: transformed_prop_exprs_args (aexp_stk_size_inc_rel 1) ?args ?args',
        H1: prop_args_rel (fun natexpr : aexp_stack =>
                             aexp_stack_pure_rel natexpr ?fenv)
                          ?args' |-
        prop_args_rel (fun natexpr : aexp_stack =>
                         aexp_stack_pure_rel natexpr ?fenv)
                      ?args ] =>
      eapply nat_prop_args_rel_prop_stk_inc_preserves_purity'; eassumption

  end.

Ltac match_inversion' :=
  match goal with
  | [ H: absstate_match_rel (AbsAnd (BaseState ?s ?Meta) ?Q) ?fenv ?stk |- _ ] =>
      invs H;
      match goal with
      | [ META: absstate_match_rel (BaseState s Meta) fenv stk |- _ ] =>
          invs META;
          match goal with
          | [ H': meta_match_rel Meta fenv stk |- _ ] =>
              invs H';
             match goal with
              | [ H'' : eval_prop_rel ?func ?LogProp |- _ ] =>
                  invs H''

              end;
              match goal with
              | [ H''' : prop_rel ?func ?LogProp |- _ ] =>
                  invs H''';
                  try (match goal with
                       | [ H''': prop_rel func LogProp,
                           H2 : prop_rel ?func2 ?LogProp2 |- _ ] =>
                      invs H2
                       end)

              end
          end
      end
  end;
  match goal with
  | [ H : absstate_well_formed (BaseState ?s ?Meta) |- _ ] =>
      invs H;
      match goal with
      | [ H' : mv_well_formed Meta |- _ ] =>
          invs H'
      | [ |- _ ] =>
          idtac
      end
  | [ |- _ ] =>
      idtac
  end;
  match goal with
  | [ H : meta_stk_size_inc ?inc (_ ?l1) (_ ?l2) |- _ ] =>
      invs H;
      match goal with
      | [ H' : transformed_prop_exprs (?func inc) l1 l2 |- _ ] =>
          invs H'
      end
  end.

Ltac smart_wf_helper :=
  match goal with
  | [ H : prop_rel bexp_well_formed ?p |- _ ] =>
      invs H
  | [ H: prop_rel aexp_well_formed ?p |- _ ] =>
      invs H
  end.

Ltac smart_expr_stack_increase_preserves_eval' inc_rel pure_rel wf_rel stack_sem :=
  match goal with
  | [ H1 : inc_rel 1 ?a ?a',
        H2 : pure_rel ?a' ?fenv,

          H3: wf_rel ?a,
      H4 : stack_sem ?a' ?fenv (?v :: ?stk) (?v :: ?stk, ?aval) |-
        stack_sem ?a ?fenv ?stk (?stk, ?val) ] =>
      let INC := fresh "INC" in
      pose proof (INC := H1);
      match inc_rel with
      | bexp_stk_size_inc_rel =>
          (eapply bexp_size_inc_preserves_purity' in INC ; [ | eassumption .. ]);
          eapply bexp_stack_increase_preserves_eval'; eassumption
      | aexp_stk_size_inc_rel =>
          (eapply aexp_size_inc_preserves_purity' in INC; [ | eassumption .. ]);
          eapply aexp_stack_increase_preserves_eval'; eassumption
      end
  end.

Ltac smart_bexp_stack_increase_preserves_eval' :=
  (smart_expr_stack_increase_preserves_eval'
     aexp_stk_size_inc_rel
     aexp_stack_pure_rel
     aexp_well_formed
     aexp_stack_sem)
  ||
  (smart_expr_stack_increase_preserves_eval'
     bexp_stk_size_inc_rel
     bexp_stack_pure_rel
     bexp_well_formed
     bexp_stack_sem).

Ltac match_logic_prop H p1 m tac :=
  match m with
  | AndProp _ _ p1 _ =>
      invs H;
      tac
  | OrProp _ _ p1 _ =>
      invs H; tac
  | AndProp _ _ _ p1 =>
      invs H; tac
  | OrProp _ _ _ p1 =>
      invs H; tac
  end.

Ltac smart_transformed_prop_exprs inc_rel p1 tac tac1 tac2 :=
  match goal with
  | [ H : transformed_prop_exprs (inc_rel 1) p1 ?p1' |- _ ] =>
      tac1 H
  | [ H : transformed_prop_exprs (inc_rel 1) ?p1' p1 |- _ ] =>
      tac2 H
  | [ H : transformed_prop_exprs (inc_rel 1) ?m ?n |- _ ] =>
      match_logic_prop H p1 m tac
  end.

Ltac smart_logic_stack_increase_preserves_eval'_bool_prop_wf prop_rel_prop p1 tac tac1 :=
   match goal with
   | [ H : prop_rel prop_rel_prop p1 |- _ ] =>
       tac1 H
   | [ H : prop_rel prop_rel_prop ?m |- _ ] =>
       match_logic_prop H p1 m tac
   end.

Ltac smart_logic_stack_increase_preserves_eval' :=
  match goal with
  | [ |- transformed_prop_exprs (?inc_rel 1) ?p1 ?[?p'] ] =>
      smart_transformed_prop_exprs inc_rel p1 ltac:(eassumption) ltac:(fun H => eapply H) ltac:(idtac)
  | [ |- bool_prop_wf ?p1 ] =>
      unfold bool_prop_wf;
      smart_logic_stack_increase_preserves_eval'_bool_prop_wf bexp_well_formed p1 ltac:(eassumption) ltac:(fun H => eapply H)
  | [ |- nat_prop_wf ?p1 ] =>
      unfold nat_prop_wf;
      smart_logic_stack_increase_preserves_eval'_bool_prop_wf aexp_well_formed p1 ltac:(eassumption) ltac:(fun H => eapply H)
  | [ |- prop_rel (fun boolexpr : ?expr_type => ?pure_rel boolexpr ?fenv) ?p1 ] =>
      match pure_rel with
      | bexp_stack_pure_rel =>
          smart_pure_helper'
      | aexp_stack_pure_rel =>
          smart_pure_helper'
      end
  | [ |- _ ] =>
      eassumption
  end.

Ltac small_smart_pure_helper inc_rel tac1 tac3 :=
  match inc_rel with
  | bexp_stk_size_inc_rel =>
      eapply bool_prop_rel_prop_stk_inc_preserves_purity';
      [
        tac1
      | smart_wf_helper
      | tac3 ]
  | aexp_stk_size_inc_rel =>
      eapply nat_prop_rel_prop_stk_inc_preserves_purity';
      [
        tac1
      | smart_wf_helper
      | tac3 ]
  end.

Lemma triple_stk_pop :
  forall P' P Q fenv,
    state_stk_size_inc 1 P' P ->
    {{{(AbsAnd P Q)}}} Pop_Stk {{{ P' }}} @ fenv.
Proof.
  unfold triple_stk.
  induction P'; intros P Q fenv INC stk stk' IMP MATCH.
  - invs IMP.
    invs INC.
    invs H2.
    + econstructor; [ econstructor | ].
      invs H4.
      * invs H; match_inversion'; meta_match_elimination; try smart_wf_helper; try smart_pure_helper'.
        all: try smart_bexp_stack_increase_preserves_eval'.
        all: try (eapply logic_stack_increase_preserves_eval'; smart_logic_stack_increase_preserves_eval').
        4: eapply bool_args_stack_increase_preserves_eval'; try eassumption; try smart_pure_helper'.
        all: eassumption.
      * invs H; match_inversion'; meta_match_elimination; try smart_wf_helper; try smart_pure_helper'.
        all: try (smart_bexp_stack_increase_preserves_eval').
        all: try (eapply nat_logic_stack_increase_preserves_eval'; smart_logic_stack_increase_preserves_eval').
        4: eapply nat_args_stack_increase_preserves_eval'; try eassumption; try smart_pure_helper'.
        all: assumption.
    + econstructor.
      * invs MATCH.
        invs H1.
        invs H3.
        constructor.
        simpl in H0.
        intuition.
      * invs H4.
        -- invs H; match_inversion'; meta_match_elimination; try smart_wf_helper; try smart_pure_helper'.
           all: try (smart_bexp_stack_increase_preserves_eval').
           all: try (eapply logic_stack_increase_preserves_eval'; smart_logic_stack_increase_preserves_eval').
           4: eapply bool_args_stack_increase_preserves_eval'; try eassumption; try smart_pure_helper'.
           all: assumption.
        -- invs H; match_inversion'; meta_match_elimination; try smart_wf_helper; try smart_pure_helper'.
           all: try smart_bexp_stack_increase_preserves_eval'.
           all: try (eapply nat_logic_stack_increase_preserves_eval'; smart_logic_stack_increase_preserves_eval').
           all: try (eapply aexp_stack_increase_preserves_eval'; [ | | eapply aexp_size_inc_preserves_purity' | ]; eassumption).
           4: eapply nat_args_stack_increase_preserves_eval'; try eassumption; try smart_pure_helper'.
           all: assumption.
  - invs MATCH. invs INC.
    econstructor.
    + eapply IHP'1; eassumption.
    + eapply IHP'2.
      eassumption.
      eassumption.
      invs MATCH.
      assert (absstate_match_rel (AbsAnd s2' Q) fenv stk).
      * invs H2.
        constructor; assumption.
      * eassumption.
  - invs MATCH. invs INC.
    invs H1.
    + econstructor. eapply IHP'1.
      eassumption.
      eassumption.
      assert (absstate_match_rel (AbsAnd s1' Q) fenv stk).
      * constructor; assumption.
      * eassumption.
    + eapply RelAbsOrRight. eapply IHP'2.
      eassumption.
      eassumption.
      assert (absstate_match_rel (AbsAnd s2' Q) fenv stk).
      * constructor; assumption.
      * eassumption.
Qed.

Local Open Scope stack_scope.

Lemma triple_stk_seq :
  forall P Q R i1 i2 fenv,
    {{{P}}} i1 {{{Q}}} @ fenv ->
    {{{Q}}} i2 {{{R}}} @ fenv ->
    {{{P}}} i1 ;;; i2 {{{R}}} @ fenv.
Proof.
  unfold triple_stk; intros.
  invs H1.
  apply H in H5.
  - apply H0 in H9.
    + assumption.
    + assumption.
  - assumption.
Qed.

Lemma triple_stk_ifthenelse :
  forall P Q b i1 i2 fenv,
    bexp_stack_pure_rel b fenv ->
    {{{(atruestk b P)}}} i1 {{{Q}}} @ fenv ->
    {{{(afalsestk b P)}}} i2 {{{Q}}} @ fenv ->
    {{{P}}} ifs b thens i1 elses i2 dones {{{Q}}} @ fenv.
Proof.
  unfold triple_stk, atruestk, afalsestk, bexp_stack_pure; intros.
  invs H2.
  - apply H0 in H11.
    + assumption.
    + pose proof (PURE := H).
      eapply (bexp_stack_pure_implication) in PURE.
      unfold bexp_stack_pure in PURE.
      pose proof (H12 := H10).
      apply PURE in H10.
      subst.
      econstructor.
      * assumption.
      * econstructor.
        -- econstructor.
        -- econstructor.
           econstructor.
           eassumption.
           reflexivity.
           econstructor.
           eassumption.
  - apply H1 in H11.
    + assumption.
    + pose proof (PURE := H).
      eapply (bexp_stack_pure_implication) in H.
      specialize (H stk stk'0 false).
      pose proof (H12 := H10).
      apply H in H10; subst.
      econstructor.
      * assumption.
      * econstructor.
        -- econstructor.
        -- econstructor.
           ++ econstructor.
              ** eassumption.
              ** reflexivity.
           ++ econstructor. assumption.
Qed.

Lemma triple_stk_while :
  forall P b l fenv,
    bexp_stack_pure_rel b fenv ->
    {{{atruestk b P}}} l {{{P}}} @ fenv ->
    {{{P}}} whiles b loops l dones {{{afalsestk b P}}} @ fenv.
Proof.
  unfold triple_stk, afalsestk, bexp_stack_pure; intros P b l fenv PURE TRUE_LOOP stk stk' SEM.
  dependent induction SEM; intros.
  - pose proof (PURE' := PURE).
    eapply bexp_stack_pure_implication in PURE.
    specialize (PURE stk stk' false).
    pose proof (H1 := H).
    apply PURE in H. subst.

    econstructor; [assumption | ].
    econstructor; [econstructor | ].
    econstructor; [ |  econstructor; eassumption].
    econstructor; [eassumption | reflexivity].
  - pose proof (PURE' := PURE).
    eapply bexp_stack_pure_implication in PURE'.
    specialize (PURE' stk stk1 true).

    pose proof (H1 := H).
    apply PURE' in H.
    subst.
    eapply IHSEM2; eauto.
    specialize (TRUE_LOOP stk1 stk2).
    apply TRUE_LOOP in SEM1.
    + assumption.
    + unfold atruestk. econstructor; [assumption |].
      econstructor; [econstructor|].
      econstructor. econstructor.
      * eassumption.
      * reflexivity.
      * econstructor; eassumption.
Qed.

Lemma triple_stk_consequence :
  forall P Q P' Q' i fenv,
    {{{P}}} i {{{Q}}} @ fenv ->
    (P' --->>> P) fenv ->
    (Q --->>> Q') fenv ->
    {{{P'}}} i {{{Q'}}} @ fenv.
Proof.
  unfold triple_stk, aimpstk; intros. eauto.
Qed.

Theorem Hoare_stk_sound :
  forall P i Q fenv,
    hl_stk P i Q fenv ->
    {{{P}}} i {{{Q}}} @ fenv.
Proof.
  induction 1;
    eauto using triple_stk_skip, triple_stk_assign, triple_stk_seq, triple_stk_ifthenelse, triple_stk_while, triple_stk_consequence, triple_stk_push, triple_stk_pop.
Qed.