(* This file are developed by Qinxiang Cao, Shengyi Wang and Aquinas Hobor in 2015 *)
(* summer in Yale-NUS.                                                             *)

Require Import VST.msl.base.
Require Import VST.msl.Extensionality.
Require Import VST.msl.simple_CCC.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.zlist.sublist.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Sorting.Permutation.
Require Export Coq.Classes.Morphisms.

Lemma In_Permutation_cons: forall {A : Type} (l : list A) (x : A),
  In x l ->
  exists l', Permutation l (x :: l').
Proof.
  intros.
  induction l.
  + inversion H.
  + destruct H.
    - exists l; subst; reflexivity.
    - destruct (IHl H) as [l' ?].
      exists (a :: l').
      rewrite H0.
      constructor.
Qed.

Lemma incl_Permutation {A: Type}: forall (l1 l2: list A), NoDup l2 -> incl l2 l1 -> exists l', Permutation l1 (l2 ++ l').
Proof.
  intros l1 l2. revert l1. induction l2; intros.
  - exists l1. simpl. auto.
  - rewrite NoDup_cons_iff in H. destruct H. hnf in H0. assert (In a l1) by (apply H0; simpl; auto). assert (incl l2 l1) by (hnf; intros; apply H0; simpl; auto).
    specialize (IHl2 l1 H1 H3). destruct IHl2 as [l3 ?]. assert (In a l3) by (rewrite H4 in H2; apply in_app_or in H2; destruct H2; [exfalso|]; auto).
    apply In_Permutation_cons in H5. destruct H5 as [l4 ?]. rewrite H5 in H4. exists l4. rewrite H4. rewrite <- app_comm_cons. symmetry. apply Permutation_middle.
Qed.

Local Open Scope logic.

Set Implicit Arguments.

Definition sepcon_unique1 {X A} `{SepLog A} (P: X -> A): Prop :=
  forall x, P x * P x |-- FF.

Definition sepcon_unique2 {X Y A} `{SepLog A} (P: X -> Y -> A): Prop :=
  forall x y1 y2, P x y1 * P x y2 |-- FF.

Section IterSepCon.

  Context {A : Type}.
  Context {B : Type}.
  Context {ND : NatDed A}.
  Context {SL : SepLog A}.
  Context {ClS: ClassicalSep A}.
  Context {CoSL: CorableSepLog A}.

Section SingleSepPred.

  Context (p : B -> A).

Fixpoint iter_sepcon (l : list B) : A :=
  match l with
    | nil => emp
    | x :: xl => p x * iter_sepcon xl
  end.

Lemma iter_sepcon_app:
  forall (l1 l2 : list B), iter_sepcon (l1 ++ l2) = iter_sepcon l1 * iter_sepcon l2.
Proof.
  induction l1; intros; simpl. rewrite emp_sepcon; auto. rewrite IHl1. rewrite sepcon_assoc. auto.
Qed.

Lemma iter_sepcon_app_comm: forall (l1 l2 : list B), iter_sepcon (l1 ++ l2) = iter_sepcon (l2 ++ l1).
Proof. intros. do 2 rewrite iter_sepcon_app. rewrite sepcon_comm. auto. Qed.

Lemma iter_sepcon_permutation: forall  (l1 l2 : list B), Permutation l1 l2 -> iter_sepcon l1 = iter_sepcon l2.
Proof.
  intros. induction H; simpl; auto.
  + rewrite IHPermutation. auto.
  + do 2 rewrite <- sepcon_assoc. rewrite (sepcon_comm (p y)). auto.
  + rewrite IHPermutation1. auto.
Qed.

Lemma iter_sepcon_in_true: forall (l : list B) x, In x l -> iter_sepcon l |-- p x * TT.
Proof.
  intros. apply in_split in H. destruct H as [l1 [l2 ?]]. subst.
  rewrite iter_sepcon_app_comm. rewrite <- app_comm_cons. simpl.
  apply sepcon_derives; auto. apply TT_right.
Qed.

Lemma iter_sepcon_incl_true: forall (l s: list B),
    NoDup s -> incl s l -> iter_sepcon l |-- iter_sepcon s * TT.
Proof.
  intros. destruct (incl_Permutation l s H H0) as [l' ?].
  apply iter_sepcon_permutation in H1. rewrite H1, iter_sepcon_app.
  apply sepcon_derives; auto. apply TT_right.
Qed.

Lemma iter_sepcon_unique_nodup: forall (l : list B), sepcon_unique1 p -> iter_sepcon l |-- !!(NoDup l).
Proof.
  intros. induction l.
  + apply prop_right. constructor.
  + simpl.
    assert (p a * iter_sepcon l |-- !!(~ In a l)). {
      apply not_prop_right.
      intros. apply iter_sepcon_in_true in H0.
      apply derives_trans with (p a * p a * TT).
      + rewrite sepcon_assoc. apply sepcon_derives. apply derives_refl. auto.
      + specialize (H a). apply derives_trans with (FF * TT).
        apply sepcon_derives; auto. rewrite sepcon_comm, sepcon_FF. apply derives_refl.
    }
  apply derives_trans with (!!(NoDup l) && !!(~ In a l)).
  - apply andp_right; auto. rewrite (add_andp _ _ IHl). normalize.
  - normalize. constructor; auto.
Qed.

Lemma iter_sepcon_emp': forall (l : list B), (forall x, In x l -> p x = emp) -> iter_sepcon l = emp.
Proof.
  induction l; intros; simpl; auto.
  rewrite H, IHl, sepcon_emp; simpl; auto.
  intros; apply H; simpl; auto.
Qed.

Lemma iter_sepcon_emp: forall (l l' : list B), (forall x, p x |-- emp) -> NoDup l' -> incl l' l -> iter_sepcon l |-- iter_sepcon l'.
Proof.
  intros.
  revert l H1; induction l'; intros.
  + simpl; clear H1.
    induction l; simpl; auto.
    rewrite <- (emp_sepcon emp).
    apply sepcon_derives; auto.
  + inversion H0; subst.
    spec IHl'; [auto |].
    assert (In a l) by (specialize (H1 a); simpl in H1; auto).
    apply in_split in H2.
    destruct H2 as [l1 [l2 ?]].
    specialize (IHl' (l1 ++ l2)).
    spec IHl'.
    {
      clear - H2 H1 H4.
      intros x ?H.
      specialize (H1 x).
      spec H1; [simpl; auto |].
      subst.
      rewrite in_app_iff in H1; simpl in H1.
      rewrite in_app_iff.
      assert (a = x -> False) by (intros; subst; tauto).
      tauto.
    }
    subst.
    rewrite iter_sepcon_app in *.
    simpl.
    rewrite (sepcon_comm (p a)), <- sepcon_assoc, (sepcon_comm _ (p a)).
    apply sepcon_derives; auto.
Qed.

Lemma iter_sepcon_nil: iter_sepcon nil = emp.
Proof. intros; reflexivity. Qed.

End SingleSepPred.

Lemma iter_sepcon_sepcon: forall (f g1 g2: B -> A) l,
     (forall b : B, f b = g1 b * g2 b) ->
  iter_sepcon f l = iter_sepcon g1 l * iter_sepcon g2 l.
Proof.
  intros; induction l; simpl.
  autorewrite with norm; auto.
  rewrite H, IHl.
  rewrite !sepcon_assoc.
  f_equal.
  rewrite sepcon_comm.
  rewrite !sepcon_assoc.
  f_equal.
  apply sepcon_comm.
Qed.

Lemma iter_sepcon_sepcon': forall g1 g2 (l : list B),
  iter_sepcon (fun x => g1 x * g2 x) l = iter_sepcon g1 l * iter_sepcon g2 l.
Proof.
  intros. apply iter_sepcon_sepcon. easy.
Qed.

Lemma iter_sepcon_derives :
   forall f g (l : list B), (forall x, In x l -> f x |-- g x) -> iter_sepcon f l |-- iter_sepcon g l.
Proof.
  induction l; simpl; auto; intros.
  apply sepcon_derives; auto.
Qed.

Lemma iter_sepcon_func: forall l P Q, (forall x, P x = Q x) -> iter_sepcon P l = iter_sepcon Q l.
Proof. intros. induction l; simpl; [|f_equal]; auto. Qed.

Lemma iter_sepcon_func_strong: forall l P Q, (forall x, In x l -> P x = Q x) -> iter_sepcon P l = iter_sepcon Q l.
Proof.
  intros. induction l.
  + reflexivity.
  + simpl.
    f_equal.
    - apply H.
      simpl; auto.
    - apply IHl.
      intros; apply H.
      simpl; auto.
Qed.

#[global] Instance iter_sepcon_permutation_proper : Proper ((pointwise_relation B eq) ==> (@Permutation B) ==> eq) iter_sepcon.
Proof.
  repeat intro. transitivity (iter_sepcon x y0).
  + apply iter_sepcon_permutation. auto.
  + apply iter_sepcon_func.
    exact H.
Qed.

Lemma iter_sepcon_Znth: forall {d : Inhabitant B} f (l : list B) (i: Z), (0 <= i < Zlength l)%Z ->
  iter_sepcon f l = f (Znth i l) * iter_sepcon f (remove_Znth i l).
Proof.
  intros; unfold remove_Znth.
  rewrite <- sublist_same at 1 by auto.
  rewrite sublist_split with (mid := i) by lia.
  rewrite (sublist_next i) by lia.
  rewrite !iter_sepcon_app; simpl.
  rewrite <- !sepcon_assoc. f_equal.
  apply sepcon_comm.
Qed.

#[global] Arguments iter_sepcon_Znth {d} f l i.

Lemma iter_sepcon_Znth_remove : forall {d : Inhabitant B} f (l: list B) i j,
  (0 <= i < Zlength l)%Z -> (0 <= j < Zlength l)%Z -> i <> j ->
  iter_sepcon f (remove_Znth j l) =
  f (Znth i l) * iter_sepcon f (remove_Znth (if Z_lt_dec i j then i else i - 1) (remove_Znth j l)).
Proof.
  intros ????? Hi Hj Hn.
  pose proof (Zlength_remove_Znth _ _ Hj) as Hlen.
  unfold remove_Znth at 1 2; rewrite Hlen.
  unfold remove_Znth in *.
  destruct (Z_lt_dec i j).
  - rewrite -> !sublist_app by (rewrite -> ?Zlength_app in *; lia).
    autorewrite with sublist.
    rewrite -> (sublist_split 0 i j) by lia.
    rewrite !iter_sepcon_app.
    rewrite -> (sublist_next i _) by lia; simpl.
    replace (Zlength l - _ - _ + _)%Z with (Zlength l) by lia.
    rewrite <- !sepcon_assoc. do 2 f_equal. apply sepcon_comm.
  - rewrite -> !sublist_app by (rewrite -> ?Zlength_app in *; lia).
    autorewrite with sublist.
    rewrite -> (sublist_split (j + 1) i (Zlength l)) by lia.
    rewrite !iter_sepcon_app.
    rewrite -> (sublist_next i _) by lia; simpl.
    replace (Zlength l - _ - _ + _)%Z with (Zlength l) by lia.
    replace (i - _ - _ + _)%Z with i by lia.
    replace (i - _ + _)%Z with (i + 1)%Z by lia.
    rewrite (sepcon_comm (f _) (_ * _ * _)).
    rewrite <- !sepcon_assoc. do 2 rewrite (sepcon_assoc (_ * _)).
    f_equal. apply sepcon_comm.
Qed.

Lemma iter_sepcon_Znth' : forall {d : Inhabitant B} f (l: list B) i,
  (0 <= i < Zlength l)%Z -> iter_sepcon f l = f (Znth i l) * (f (Znth i l) -* iter_sepcon f l).
Proof.
  intros; eapply wand_eq, iter_sepcon_Znth; auto.
Qed.

Lemma iter_sepcon_remove_wand : forall {d : Inhabitant B} f (l: list B) i,
  (0 <= i < Zlength l)%Z -> iter_sepcon f (remove_Znth i l) |-- f (Znth i l) -* iter_sepcon f l.
Proof.
  intros; rewrite <- wand_sepcon_adjoint.
  erewrite (iter_sepcon_Znth _ l) by eauto.
  rewrite sepcon_comm. auto.
Qed.

Lemma iter_sepcon_In : forall (x : B) f (l: list B), In x l -> iter_sepcon f l = f x * (f x -* iter_sepcon f l).
Proof.
  intros.
  apply (@In_Znth _ x) in H as (? & ? & Heq).
  rewrite <- Heq; apply iter_sepcon_Znth'; auto.
Qed.

End IterSepCon.

Lemma iter_sepcon_map: forall {A B C: Type} {ND : NatDed A} {SL : SepLog A} (l : list C) (f : B -> A) (g: C -> B),
                         iter_sepcon (fun x : C => f (g x)) l = iter_sepcon f (map g l).
Proof. intros. induction l; simpl; [|f_equal]; auto. Qed.

Global Existing Instance iter_sepcon_permutation_proper.

Definition uncurry {A B C} (f: A -> B -> C) (xy: A*B) : C :=
  f (fst xy) (snd xy).

Section IterSepCon2.

  Context {A : Type}.
  Context {B1 B2 : Type}.
  Context {ND : NatDed A}.
  Context {SL : SepLog A}.
  Context {ClS: ClassicalSep A}.
  Context {CoSL: CorableSepLog A}.
  Context (p : B1 -> B2 -> A).

Fixpoint iter_sepcon2 (l : list B1) : list B2 -> A :=
    match l with
    | nil => fun l2 =>
       match l2 with
       | nil => emp
       | _ => FF
       end
    | x :: xl => fun l' =>
       match l' with
       | nil => FF
       | y :: yl => p x y * iter_sepcon2 xl yl
       end
  end.

Lemma iter_sepcon2_spec: forall l1 l2,
  iter_sepcon2 l1 l2 = EX l: list (B1 * B2), !! (l1 = map fst l /\ l2 = map snd l) && iter_sepcon (uncurry p) l.
Proof.
  intros.
  apply pred_ext.
  + revert l2; induction l1; intros; destruct l2.
    - apply (exp_right nil); simpl.
      apply andp_right; auto.
      apply prop_right; auto.
    - simpl.
      apply FF_left.
    - simpl.
      apply FF_left.
    - simpl.
      specialize (IHl1 l2).
      eapply derives_trans; [apply sepcon_derives; [apply derives_refl | apply IHl1] | clear IHl1].
      normalize.
      destruct H.
      apply (exp_right ((a, b) :: l)).
      simpl.
      apply andp_right; [apply prop_right; subst; auto |].
      apply derives_refl.
  + apply exp_left; intros l.
    normalize.
    destruct H; subst.
    induction l.
    - simpl. auto.
    - simpl.
      eapply derives_trans; [apply sepcon_derives; [apply derives_refl | apply IHl] | clear IHl].
      apply derives_refl.
Qed.

Lemma iter_sepcon2_Znth: forall {d1 : Inhabitant B1} {d2 : Inhabitant B2}
  (l1 : list B1) (l2 : list B2) i, (0 <= i < Zlength l1)%Z -> Zlength l1 = Zlength l2 ->
  iter_sepcon2 l1 l2 =
  p (Znth i l1) (Znth i l2) * iter_sepcon2 (remove_Znth i l1) (remove_Znth i l2).
Proof.
  intros; rewrite !iter_sepcon2_spec.
  apply pred_ext.
  - apply exp_left. intros l. apply derives_extract_prop. intros [? ?].
    subst. rewrite Zlength_map in *.
    rewrite !remove_Znth_map, !Znth_map, (iter_sepcon_Znth (uncurry p) l i) by auto.
    unfold uncurry at 1. apply sepcon_derives; auto.
    apply exp_right with (remove_Znth i l). apply prop_and_same_derives.
    apply prop_right. auto.
  - rewrite exp_sepcon2. apply exp_left; intros l. apply exp_right with (combine l1 l2).
    rewrite sepcon_andp_prop. apply derives_extract_prop. intros [? ?].
    rewrite combine_fst, combine_snd
      by (rewrite <- !ZtoNat_Zlength; apply Nat2Z.inj; rewrite !Z2Nat.id; lia).
    rewrite (iter_sepcon_Znth _ (combine _ _) i)
      by (rewrite Zlength_combine, Z.min_l; lia).
    rewrite Znth_combine, remove_Znth_combine by auto.
    rewrite H1, H2, combine_eq; unfold uncurry. cbn [fst snd].
    apply prop_and_same_derives. apply prop_right. auto.
all:    apply derives_refl.  (*  We need this for Coq 8.14 and before. *)
Qed.

End IterSepCon2.

Section IterPredSepCon.

  Context {A : Type}.
  Context {B : Type}.
  Context {ND : NatDed A}.
  Context {SL : SepLog A}.
  Context {ClS: ClassicalSep A}.

Definition pred_sepcon (p: B -> A) (P: B -> Prop): A :=
  EX l: list B, !! (forall x, In x l <-> P x) && !! NoDup l && iter_sepcon p l.

Lemma pred_sepcon_eq: forall (P: B -> Prop) (p: B -> A),
    pred_sepcon p P =
    (EX l: list B, !! ((forall x, In x l <-> P x) /\ NoDup l) && iter_sepcon p l).
Proof.
  intros. unfold pred_sepcon. f_equal. extensionality l. rewrite prop_and. auto.
Qed.

Lemma pred_sepcon_strong_proper: forall P1 P2 p1 p2,
  (forall x, P1 x <-> P2 x) ->
  (forall x, P1 x -> P2 x -> p1 x = p2 x) ->
  pred_sepcon p1 P1 = pred_sepcon p2 P2.
Proof.
  assert (forall P1 P2 p1 p2,
    (forall x, P1 x <-> P2 x) ->
    (forall x, P1 x -> P2 x -> p1 x = p2 x) ->
    pred_sepcon p1 P1 |-- pred_sepcon p2 P2).
  2: intros; apply pred_ext; apply H; [auto | auto | symmetry; auto | symmetry; auto].
  intros.
  unfold pred_sepcon.
  apply exp_left; intro l; apply (exp_right l).
  normalize.
  assert (forall x : B, In x l <-> P2 x) by (intros; rewrite H1, H; reflexivity).
  normalize.
  erewrite iter_sepcon_func_strong; [apply derives_refl |].
  intros.
  specialize (H1 x); specialize (H3 x).
  apply H0; tauto.
Qed.

#[global] Instance pred_sepcon_proper: Proper (pointwise_relation B eq ==> pointwise_relation B iff ==> eq) pred_sepcon.
Proof.
  intros.
  do 2 (hnf; intros).
  apply pred_sepcon_strong_proper; intros; auto.
Defined.

Global Existing Instance pred_sepcon_proper.

Lemma pred_sepcon1: forall p x0,
  pred_sepcon p (fun x => x = x0) = p x0.
Proof.
  intros.
  unfold pred_sepcon.
  apply pred_ext.
  + apply exp_left; intro l.
    normalize.
    destruct l as [| ? [|]].
    - specialize (H x0); simpl in H.
      tauto.
    - specialize (H x0); simpl in H.
      assert (b = x0) by tauto; subst b.
      simpl.
      rewrite sepcon_emp; auto.
    - pose proof proj1 (H b) as HH; simpl in HH.
      spec HH; [auto |].
      subst b.
      pose proof proj1 (H b0) as HH; simpl in HH.
      spec HH; [auto |].
      subst b0.
      clear - H0.
      inversion H0; subst.
      simpl in H2; tauto.
  + apply (exp_right (x0 :: nil)).
    repeat apply andp_right.
    - apply prop_right.
      intros.
      simpl.
      split; [intros [? | ?]; [congruence | tauto] | left; congruence].
    - apply prop_right.
      constructor; [simpl; tauto | constructor].
    - simpl.
      rewrite sepcon_emp; auto.
Qed.

(*
Lemma pred_sepcon_sepcon: forall (P Q R: B -> Prop) p,
  Prop_join P Q R ->
  pred_sepcon P p * pred_sepcon Q p = pred_sepcon R p.
Proof.
  intros.
  destruct H.
  unfold pred_sepcon; apply pred_ext.
  + rewrite exp_sepcon1. apply exp_left; intro lP.
    rewrite exp_sepcon2. apply exp_left; intro lQ.
    normalize.
    apply (exp_right (lP ++ lQ)).
    apply andp_right; [apply andp_right |].
    - apply prop_right.
      intros.
      rewrite in_app_iff.
      firstorder.
    - apply prop_right.
      apply NoDup_app_inv; auto.
      firstorder.
    - rewrite <- iter_sepcon_app; auto.
  + apply exp_left; intro l.
    rewrite andp_assoc.
    do 2 (apply derives_extract_prop; intro).
    destruct (spec_list_split l P Q R H2 H1 (conj H H0)) as [lp [lq [? [? [? [? ?]]]]]].
    rewrite exp_sepcon1. apply (exp_right lp).
    rewrite exp_sepcon2. apply (exp_right lq).
    normalize.
    rewrite H7, iter_sepcon_app; auto.
Qed.

Lemma pred_sepcon_sepcon1: forall (P P': B -> Prop) p x0,
  (forall x, P' x <-> P x \/ x = x0) ->
  ~ P x0 ->
  pred_sepcon P' p = pred_sepcon P p * p x0.
Proof.
  intros.
  rewrite <- pred_sepcon_sepcon with (Q := fun x => x = x0) (P := P).
  + f_equal.
    apply pred_sepcon1.
  + split; intros.
    - specialize (H a).
      assert (a = x0 -> ~ P a) by (intro; subst; auto).
      tauto.
    - subst.
      specialize (H x0).
      tauto.
Qed.
*)

Lemma pred_sepcon_unique_sepcon1: forall (P: B -> Prop) p x0,
  sepcon_unique1 p ->
  pred_sepcon p P * p x0 |-- !! (~ P x0).
Proof.
  intros.
  apply not_prop_right; intro.
  unfold pred_sepcon; normalize.
  rewrite <- H1 in H0.
  eapply derives_trans; [apply sepcon_derives; [apply iter_sepcon_in_true; eauto| apply derives_refl] |].
  rewrite sepcon_comm, <- sepcon_assoc.
  eapply derives_trans; [apply sepcon_derives; [apply H | apply derives_refl] |].
  normalize.
Qed.

Lemma prop_forall_allp: forall (P: B -> Prop),
  !! (forall x, P x) = ALL x: B, !! P x.
Proof.
  intros.
  apply pred_ext.
  + apply allp_right; intros.
    apply prop_derives; intros.
    auto.
  + apply allp_prop_left.
Qed.

Lemma prop_impl_imp: forall (P Q: Prop),
  !! (P -> Q) = !! P --> !! Q.
Proof.
  intros.
  apply pred_ext.
  + apply imp_andp_adjoint.
    normalize.
  + apply prop_imp_prop_left.
Qed.

Lemma pred_sepcon_prop_true: forall (P: B -> Prop) p x,
  P x ->
  pred_sepcon p P |-- p x * TT.
Proof.
  intros.
  unfold pred_sepcon; normalize.
  intros.
  normalize.
  rename x0 into l.
  rewrite <- H0 in H.
  eapply iter_sepcon_in_true; auto.
Qed.

(*
Lemma pred_sepcon_prop_true_weak:
  forall (P Q: B -> Prop) (qdec: forall x, Decidable (Q x)) p,
    (forall x, Q x -> P x) -> pred_sepcon P p |-- pred_sepcon Q p * TT.
Proof.
  intros. unfold pred_sepcon. normalize.
  apply (exp_right (filter (fun x => if (qdec x) then true else false) l)).
  rewrite <- prop_and, sepcon_andp_prop'.
  remember (filter (fun x0 : B => if qdec x0 then true else false) l) as l'.
  assert (forall x : B, In x l' <-> Q x). {
    intros. subst l'. rewrite filter_In. destruct (qdec x); split; intros; auto.
    - split; auto. apply H in H2. rewrite H0. auto.
    - destruct H2; inversion H3.
    - exfalso; auto.
  } assert (NoDup l') by (subst l'; apply NoDup_filter; auto). apply andp_right.
  - apply prop_right. split; auto.
  - apply iter_sepcon_incl_true; auto. intro. rewrite H0, H2. apply H.
Qed.
*)
Lemma pred_sepcon_False: forall p,
  pred_sepcon p (fun _ => False) = emp.
Proof.
  intros.
  unfold pred_sepcon.
  apply pred_ext.
  + apply exp_left; intros.
    normalize.
    destruct x; [apply derives_refl |].
    specialize (H b); simpl in H; tauto.
  + apply (exp_right nil).
    normalize.
    apply andp_right.
    apply prop_right; constructor.
    apply derives_refl.
Qed.

Lemma pred_sepcon_False':
 forall (P: B -> Prop) (p : B -> A),
  (forall x, ~ P x) ->
  pred_sepcon p P = emp.
Proof.
intros.
replace P with (fun _:B  => False).
apply pred_sepcon_False.
extensionality i.
apply prop_ext; split; intros. contradiction.
apply (H i); auto.
Qed.

End IterPredSepCon.

Lemma pred_sepcon_isolate:
  forall {A B: Type}{NA: NatDed A}{SA: SepLog A}
  (x: B)
  (DECB: forall x y: B, {x=y}+{x<>y})
  (f: B -> A) (u: B -> Prop),
  (u x) ->
  pred_sepcon f u = pred_sepcon f (fun y => u y /\ y<>x) * f x.
Proof.
intros.
rewrite !pred_sepcon_eq.
pose (neqx y := if DECB x y then false else true).
apply pred_ext.
apply exp_left; intro l.
normalize.
destruct H0.
apply exp_right with (filter neqx l).
rewrite prop_true_andp.
apply derives_trans with (iter_sepcon f (x :: filter neqx l)).
apply derives_refl'.
apply iter_sepcon_permutation.
apply NoDup_Permutation; auto.
constructor.
intro. apply filter_In in H2. destruct H2.
unfold neqx in H3.
destruct (DECB x x). inversion H3. contradiction n; auto.
apply NoDup_filter; auto.
intro.
split; intro.
destruct (DECB x0 x).
subst. left; auto. right. apply filter_In. split; auto.
unfold neqx.
destruct (DECB x x0); auto.
destruct H2.
subst.
rewrite <- H0 in H. auto.
apply filter_In in H2. destruct H2; auto.
simpl. rewrite sepcon_comm; auto.
split.
intro. split; intro.
apply filter_In in H2. destruct H2.
rewrite H0 in H2.
split; auto.
intro; subst.
unfold neqx in H3.
destruct (DECB x x); auto. inv H3.
destruct H2.
apply filter_In. split; auto.
rewrite H0; auto.
unfold neqx.
destruct (DECB x x0); auto.
apply NoDup_filter. auto.
normalize.
destruct H0.
apply exp_right with (x::l).
rewrite prop_true_andp.
simpl.
rewrite sepcon_comm; auto.
split.
intro.
specialize (H0 x0).
simpl. rewrite H0.
split; intro.
destruct H2.
subst; auto.
destruct H2. auto.
destruct (DECB x0 x).
subst.
auto.
right; auto.
constructor; auto.
rewrite H0.
intros [? ?].
contradiction.
Qed.


Require Import Strings.String.
Scheme Equality for string.

          (*  types definitions + operations *)

  (* natural *)

Require Import Nat.

Inductive ERRnat  :=
| err_nat :       ERRnat
| natural :       nat    -> ERRnat.

Coercion natural:  nat >-> ERRnat.

Inductive AExp :=
| acon: ERRnat -> AExp
| avar: string -> AExp
| aplus: AExp  -> AExp -> AExp
| amin:  AExp  -> AExp -> AExp
| amul:  AExp  -> AExp -> AExp
| adiv:  AExp  -> AExp -> AExp
| amod:  AExp  -> AExp -> AExp.
Notation "A a+ B" := (aplus A B)(at level 71, left associativity).
Notation "A a- B" := (amin  A B)(at level 71, left associativity).
Notation "A a* B" := (amul  A B)(at level 69, left associativity).
Notation "A a/ B" := (adiv  A B)(at level 69, left associativity).
Notation "A a% B" := (amod  A B)(at level 68, left associativity).

Coercion acon: ERRnat >-> AExp.
Coercion avar: string >-> AExp.

  (* booleans *)

Inductive ERRbool :=
| err_bool :      ERRbool
| boolean :       bool  -> ERRbool.

Coercion boolean:  bool >-> ERRbool.

Inductive BExp :=
| bcon:   ERRbool-> BExp
| bvar:   string -> BExp
| bnot:   BExp   -> BExp
| blt:    AExp   -> AExp -> BExp
| ble:    AExp   -> AExp -> BExp
| beq:    AExp   -> AExp -> BExp
| band:   BExp   -> BExp -> BExp
| bor:    BExp   -> BExp -> BExp.
Notation "b!       A" := (bnot   A) (at level 77, left associativity).
Notation "A  b<  B" := (blt  A B) (at level 80).
Notation "A  b<= B" := (ble  A B) (at level 80).
Notation "A  b=  B" := (beq  A B) (at level 80).
Notation "A  b&& B" := (band A B) (at level 78, left associativity).
Notation "A  b|| B" := (bor  A B) (at level 79, left associativity).

Coercion bcon : ERRbool >->  BExp.
Coercion bvar : string >-> BExp.

  (* strings *)

Inductive ERRstring :=
| err_str :       ERRstring
| str  :          string -> ERRstring.

Coercion str: string >-> ERRstring.

Inductive SExp :=
| scon : ERRstring -> SExp
| svar :   string    -> SExp
| scat :   SExp    -> SExp -> SExp.
Notation "A s+ B" := (scat A B) (at level 71).

Coercion svar : string >-> SExp.

(* statements *)
Inductive Stmt :=
| declNat:        string -> AExp   -> Stmt
| declBool:       string -> BExp   -> Stmt
| declStr:        string -> SExp -> Stmt

| assignNat:      string -> AExp   -> Stmt
| assignBool:     string -> BExp   -> Stmt
| assignStr:      string -> SExp -> Stmt

| funDecl:        string -> Stmt   -> Stmt -> Stmt
| funCall:        string -> Stmt

| sequence:   Stmt   -> Stmt   -> Stmt

| whiledo:    BExp   -> Stmt   -> Stmt

| ifelse:     BExp   -> Stmt   -> Stmt -> Stmt
| ifthen:     BExp   -> Stmt   -> Stmt

| switch_:     AExp   -> Stmt   -> Stmt
| case_:       AExp   -> Stmt   -> Stmt

| break:      Stmt
| void:        Stmt.
Notation "'NATURAL' X :n= N"                := (declNat  X N)      (at level 90).
Notation "'BOOLEAN' X :b= B"                := (declBool X B)      (at level 90).
Notation "'STRING'  X :s= S"                := (declStr  X S)      (at level 90).
Notation "X <n-  N"                         := (assignNat X N)     (at level 90).
Notation "X <b-  N"                         := (assignBool X N)    (at level 90).
Notation "X <s-  N"                         := (assignStr X N)     (at level 90).
Notation "'function' N # P # '{' S '}'"     := (funDecl N P S)     (at level 91).
Notation "'CALL' N "                        := (funCall N)         (at level 90).
Notation "S1 ;; S2"                         := (sequence S1 S2)    (at level 92, right associativity).
Notation "'while' '[' B ']'  S "            := (whiledo B S)       (at level 89).
(*ifelse*)
(*ifthen*)
(* Notation "'switch' A  '[' S ']'"            := (switch A S)        (at level 90). *)
(* Notation "'case' '>' A '<' S "              := (case A S)          (at level 90). *)

Inductive Result :=
| code :            Stmt      -> Result
| undeclared :      Result
| naturalResult :   ERRnat    -> Result
| booleanResult :   ERRbool   -> Result
| stringResult :    ERRstring -> Result.

Definition check_eq_over_types (t1 : Result)(t2 : Result) : bool :=
  match t1 with
| code c => match t2 with
                   | code c => true
                   | _ => false
                   end
| undeclared => match t2 with
                   | undeclared => true
                   | _ => false
                   end
| naturalResult n=> match t2 with
                   | naturalResult n=> true
                   | _ => false
                   end
| booleanResult n=> match t2 with
                   | booleanResult n=> true
                   | _ => false
                   end
| stringResult n=> match t2 with
                   | stringResult n=> true
                   | _ => false
                   end
  end.

(*result for natural*)

Definition aplus_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural x' )) , (naturalResult ( natural y' )) => (naturalResult ( natural ( x' + y' ) ))
    | _ , _                                                           =>  naturalResult err_nat
  end.

Definition amin_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural x' )) , (naturalResult ( natural y' )) => if(Nat.ltb x' y') then (naturalResult err_nat)
                                                                                else (naturalResult (natural ( x' - y' )))
    | _ , _                                                           =>  naturalResult err_nat
  end.

Definition amul_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural x' )) , (naturalResult ( natural y' )) => (naturalResult ( natural ( x' * y' ) ))
    | _ , _                                                           =>  naturalResult err_nat
  end.

Definition adiv_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural x' )) , (naturalResult ( natural y' )) => match x', y' with
                                                                         |  x'', 0  => naturalResult (err_nat)
                                                                         |  x'', y''=> naturalResult ( natural ( x'' / y'' ) )
                                                                         end
    | _ , _                                                           =>  naturalResult err_nat
  end.

Definition amod_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural x' )) , (naturalResult ( natural y' )) => match x', y' with
                                                                         |  x'', 0  => naturalResult (err_nat)
                                                                         |  x'', y''=> naturalResult ( natural ( x'' mod y'' ) )
                                                                         end
    | _ , _                                                           =>  naturalResult err_nat
  end.

(*result for booleans*)

Definition bnot_result (x : Result) : Result :=
  match x with
    | booleanResult ( boolean true  ) => booleanResult ( boolean false )
    | booleanResult ( boolean false ) => booleanResult ( boolean true  )
    | _                               => booleanResult   err_bool
  end.

Definition blt_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural n1 )) , (naturalResult ( natural n2 )) => if ( n1 <? n2 ) then booleanResult ( boolean true )
                                                                                else booleanResult ( boolean false)
    | _ , _                                                           =>  booleanResult err_bool
  end.

Definition ble_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural n1 )) , (naturalResult ( natural n2 )) => if ( n1 <=? n2 ) then booleanResult ( boolean true )
                                                                                else booleanResult ( boolean false)
    | _ , _                                                           =>  booleanResult err_bool
  end.

Definition beq_result (x y : Result) : Result :=
  match x, y with
    | (naturalResult ( natural n1 )) , (naturalResult ( natural n2 )) => if ( n1 =? n2 ) then booleanResult ( boolean true )
                                                                                else booleanResult ( boolean false)
    | _ , _                                                           =>  booleanResult err_bool
  end.

Definition band_result (x y : Result) : Result :=
  match x, y with
    | (booleanResult ( boolean true  )) , (booleanResult ( boolean true  )) => booleanResult ( boolean true  )
    | (booleanResult ( boolean true  )) , (booleanResult ( boolean false )) => booleanResult ( boolean false )
    | (booleanResult ( boolean false )) , (booleanResult ( boolean true  )) => booleanResult ( boolean false )
    | (booleanResult ( boolean false )) , (booleanResult ( boolean false )) => booleanResult ( boolean false )
    | _ , _                                                                 => booleanResult   err_bool
  end.

Definition bor_result (x y : Result) : Result :=
  match x, y with
    | (booleanResult ( boolean true  )) , (booleanResult ( boolean true  )) => booleanResult ( boolean true  )
    | (booleanResult ( boolean true  )) , (booleanResult ( boolean false )) => booleanResult ( boolean true  )
    | (booleanResult ( boolean false )) , (booleanResult ( boolean true  )) => booleanResult ( boolean true  )
    | (booleanResult ( boolean false )) , (booleanResult ( boolean false )) => booleanResult ( boolean false )
    | _ , _                                                                 => booleanResult   err_bool
  end.

(*result for strings*)

Definition scat_result (x y : Result) : Result :=
  match x, y with
    | (stringResult ( str s1 )) , (stringResult ( str s2 )) => stringResult ( str ( s1 ++ s2   ) )
    | _ , _                                                 => stringResult ( err_str )
  end.

(* environment + semantics*)

Definition Env := string -> Result.

Definition env0 : Env := fun x => undeclared.

Definition update (env : Env) (x : string) (v : Result) : Env :=
fun y=>
  if ( string_eq_dec y x )  then v
                            else (env y)
.

Reserved Notation "A =[ S ]=> N" (at level 60).
Inductive aeval : AExp -> Env -> Result -> Prop :=
| a_const :   forall n sigma,
                acon n =[ sigma ]=> (naturalResult n)
| a_var :     forall v sigma,
                avar v =[ sigma ]=> (sigma v)
| a_add :     forall a1 a2 i1 i2 sigma n,
                a1 =[ sigma ]=> i1 ->
                a2 =[ sigma ]=> i2 ->
                n = aplus_result i1 i2 ->
                (a1 a+ a2) =[ sigma ]=> n
| a_minus :   forall a1 a2 i1 i2 sigma n,
                a1 =[ sigma ]=> i1 ->
                a2 =[ sigma ]=> i2 ->
                n = amin_result i1 i2 ->
                (a1 a- a2) =[ sigma ]=> n
| a_times :   forall a1 a2 i1 i2 sigma n,
                a1 =[ sigma ]=> i1 ->
                a2 =[ sigma ]=> i2 ->
                n = amul_result i1 i2 ->
                (a1 a* a2) =[ sigma ]=> n
| a_divide :  forall a1 a2 i1 i2 sigma n,
                a1 =[ sigma ]=> i1 ->
                a2 =[ sigma ]=> i2 ->
                n = adiv_result i1 i2 ->
                (a1 a/ a2) =[ sigma ]=> n
| a_modullo : forall a1 a2 i1 i2 sigma n,
                a1 =[ sigma ]=> i1 ->
                a2 =[ sigma ]=> i2 ->
                n = amod_result i1 i2 ->
                (a1 a% a2) =[ sigma ]=> n
where "a =[ sigma ]=> n" := (aeval a sigma n).

Reserved Notation "B ={ E }=> B'" (at level 60).
Inductive beval : BExp -> Env -> Result -> Prop :=
| b_const :   forall b env,
                bcon b ={ env }=> booleanResult b
| b_var :     forall v env,
                bvar v ={ env }=> (env v)
| b_not :     forall b i env n,
                b ={ env }=> i ->
                n = bnot_result i ->
                (b! b) ={ env }=> n
| b_ltb :   forall a1 a2 i1 i2 env n,
                a1 =[ env ]=> i1 ->
                a2 =[ env ]=> i2 ->
                n = blt_result i1 i2 ->
                (a1 b< a2) ={ env }=> n
| b_lte :   forall a1 a2 i1 i2 env n,
                a1 =[ env ]=> i1 ->
                a2 =[ env ]=> i2 ->
                n = ble_result i1 i2 ->
                (a1 b<= a2) ={ env }=> n
| b_eqb :  forall a1 a2 i1 i2 env n,
                a1 =[ env ]=> i1 ->
                a2 =[ env ]=> i2 ->
                n = beq_result i1 i2 ->
                (a1 b= a2) ={ env }=> n
| b_and : forall b1 b2 i1 i2 env n,
                b1 ={ env }=> i1 ->
                b2 ={ env }=> i2 ->
                n = band_result i1 i2 ->
                (b1 b&& b2) ={ env }=> n
| b_or : forall b1 b2 i1 i2 env n,
                b1 ={ env }=> i1 ->
                b2 ={ env }=> i2 ->
                n = bor_result i1 i2 ->
                (b1 b|| b2) ={ env }=> n
where "B ={ env }=> B'" := (beval B env B').

Reserved Notation "S =# V #=> S'" (at level 60).
Inductive seval : SExp -> Env -> Result -> Prop :=
| s_const :   forall s env,
                scon s =# env #=> stringResult s
| s_var :     forall v env,
                svar v =# env #=> (env v)
| s_cat :     forall s1 s2 i1 i2 env n,
                s1 =# env #=> i1 ->
                s2 =# env #=> i2 ->
                n = scat_result i1 i2 ->
                (s1 s+ s2) =# env #=> n
where "M =# S #=> N'" := (seval M S N').

Scheme Equality for Result.

Reserved Notation "S1 -! E !-> S2" (at level 70).
Inductive eval : Stmt -> Env -> Env -> Prop :=
| e_declNat :   forall x i n sigma sigma',
                  ( Result_beq undeclared (sigma x) ) = true ->
                  n =[ sigma ]=> (naturalResult i)             ->
                  sigma' = (update sigma x (naturalResult i))  ->
                  ( NATURAL x :n= n ) -! sigma !-> sigma'
| e_declBool :  forall x i n sigma sigma',
                  ( Result_beq undeclared (sigma x) ) = true ->
                  n ={ sigma }=> (booleanResult i)             ->
                  sigma' = (update sigma x (booleanResult i))  ->
                  ( BOOLEAN x :b= n ) -! sigma !-> sigma'
| e_declStr :   forall x i n sigma sigma',
                  ( Result_beq undeclared (sigma x) ) = true ->
                  n =# sigma #=> (stringResult i)              ->
                  sigma' = (update sigma x (stringResult i))  ->
                  ( STRING x :s= n ) -! sigma !-> sigma'

| e_assignNat : forall x i a sigma sigma',
                  ( Result_beq undeclared (sigma x) ) = false->
                  a =[ sigma ]=> (naturalResult i)             ->
                  sigma' = (update sigma x (naturalResult i))  ->
                  ( x <n- a ) -! sigma !-> sigma'
| e_assignBool :forall x i a sigma sigma',
                  ( Result_beq undeclared (sigma x) ) = false->
                  a =[ sigma ]=> (booleanResult i)             ->
                  sigma' = (update sigma x (booleanResult i))  ->
                  ( x <n- a ) -! sigma !-> sigma'
| e_assignStr : forall x i a sigma sigma',
                  ( Result_beq undeclared (sigma x) ) = false->
                  a =[ sigma ]=> (stringResult i)             ->
                  sigma' = (update sigma x (stringResult i))   ->
                  ( x <n- a ) -! sigma !-> sigma'

| e_funDecl :   forall s P stmt sigma sigma',
                  P = void ->
                  (Result_beq undeclared (sigma s)) = true     ->
                  sigma' = (update sigma s (code stmt))        ->
                  funDecl s P stmt -! sigma !-> sigma'
| e_funCall :   forall save s sigma sigma',
                  (Result_beq undeclared (sigma save)) = false ->
                  sigma save = (code s)                        ->
                  s -! sigma !-> sigma'                        ->
                  funCall save -! sigma !-> sigma'

| e_sequence :  forall s1 s2 sigma sigma1 sigma2,
                  s1 -! sigma  !-> sigma1                      ->
                  s2 -! sigma1 !-> sigma2                      ->
                  (s1 ;; s2) -! sigma !-> sigma2

| e_whilefalse: forall b s sigma,
                  b ={ sigma }=> booleanResult false           ->
                  (whiledo b s)-! sigma !-> sigma
| e_whiletrue:  forall b s sigma sigma',
                  b ={ sigma }=> booleanResult true            ->
                  ( s ;; whiledo b s)-! sigma !-> sigma'       ->
                  (whiledo b s)-! sigma !-> sigma'
| e_whilebreak: forall b s s1 s2 sigma sigma',
                  b  ={ sigma }=> booleanResult true           ->
                  s  = (s1 ;; break ;; s2)                     ->
                  s1 -! sigma !-> sigma'                       ->
                  whiledo b s -! sigma !-> sigma'

|e_switch_seq_false : forall a i a1 i1 sigma sigma' s s1 s2,
                  a =[ sigma ]=> i                             ->
                  s = ((case_ (a1) (s1)) ;; s2)                 ->
                  a1 =[ sigma ]=> i1                           ->
                  false = Result_beq i i1                      ->
                  (switch_ a s2)  -! sigma !-> sigma'           ->
                  (switch_ a s )  -! sigma !-> sigma'
| e_switch_seq_true : forall a i a1 i1 sigma sigma' sigma'' s s1 s2,
                  a =[ sigma ]=> i                             ->
                  s = ((case_ a1 s1) ;; s2)                     ->
                  a1 =[ sigma ]=> i1                           ->
                  i = i1                                       ->
                  s1 -! sigma !-> sigma'                       ->
                  switch_ a s2 -! sigma' !-> sigma''            ->
                  switch_ a s  -! sigma  !-> sigma''
| e_switch_case_true : forall a i a1 i1 sigma sigma' s s1,
                  a =[ sigma ]=> i                             ->
                  s = (case_ a1 s1)                             ->
                  a1 =[ sigma ]=> i1                           ->
                  i = i1                                       ->
                  s1 -! sigma !-> sigma'                       ->
                  switch_ a s -! sigma !-> sigma'
| e_switch_case_false : forall a i a1 i1 sigma s s1,
                  a =[ sigma ]=> i ->
                  s = (case_ a1 s1) ->
                  a1 =[ sigma ]=> i1 ->
                  false = Result_beq i i1 ->
                  switch_ a s -! sigma !-> sigma
where "M' -! S' !-> N'" := (eval M' S' N').

Definition function_ex  :=
function "fun" # void #
{
  NATURAL "var" :n= 5
} ;;
CALL "fun";;
NATURAL "x" :n= 1.

Example ex1 : exists ENV, function_ex -! env0 !-> ENV.
Proof.
    eexists.
    unfold function_ex.
    eapply e_sequence.
        -eapply e_funDecl.
            + reflexivity.
            + simpl. reflexivity.
            + split.
        -eapply e_sequence.
            +eapply e_funCall.
                -- simpl. reflexivity.
                -- split.
                -- eapply e_declNat.
                        ++ simpl. reflexivity.
                        ++ eapply a_const.
                        ++ split.
            + eapply e_declNat.
                -- simpl. reflexivity.
                -- eapply a_const.
                -- split.
Qed.

Definition switch_ex :=
NATURAL "x" :n= 5 ;;
switch_ ( 5 )
(
  case_ 5   ( "x" <n- 0 ) ;;
  case_ 6   ( "x" <n- 1 )
).

Example ex2 : exists ENV, switch_ex -! env0 !-> ENV.
Proof.
    eexists.
    unfold switch_ex.
    eapply e_sequence.
          -eapply e_declNat.
                + simpl. reflexivity.
                + eapply a_const.
                + split.
          -eapply e_switch_seq_true.
                +eapply a_const.
                +intuition.
                +eapply a_const.
                +reflexivity.
                +eapply e_assignNat.
                    --simpl. reflexivity.
                    --eapply a_const.
                    --split.
                +eapply e_switch_case_false.
                    --eapply a_const.
                    --intuition.
                    --eapply a_const.
                    --simpl. reflexivity.
Qed.

Definition break_ex :=
whiledo (1 b< 10)
(
  NATURAL "a" :n= 3 ;;
  NATURAL "x" :n= 5 ;;
  break
).

Inductive BExp1 :=
| b_True:  BExp1
| b_False: BExp1
| b_Var:   string -> BExp1
| b_Not:   BExp1  -> BExp1
| b_And:   BExp1  -> BExp1 -> BExp1
| b_Or:    BExp1  -> BExp1 -> BExp1.

Notation " a &&' b" := (b_And a b ) (at level 50).
Notation " a ||' b" := (b_Or a b ) (at level 50).
Notation " !!' b" := (b_Not b ) (at level 50).

Definition EnvB := string ->bool.
Definition envB := fun x => if string_dec x "var" then false else true.

Require Import Bool.

Fixpoint interpret (e : BExp1) (env : EnvB) : bool :=
  match e with
  | b_True      => true
  | b_False     => false
  | b_Var x     => (env x)
  | b_Not b     => negb (interpret b env)
  | b_And b1 b2 => andb (interpret b1 env) (interpret b2 env)
  | b_Or  b1 b2 => orb  (interpret b1 env) (interpret b2 env)
  end.

(* Define a stack machine *)
Inductive Instruction :=
| push_const :  bool   -> Instruction
| push_var :    string -> Instruction
| not_exp :     Instruction
| and_exp :     Instruction
| or_exp :      Instruction.

Require Import List.
Import ListNotations.

Definition Stack := list bool.
Definition run_instruction (i : Instruction)
         (env : EnvB) (stack : Stack) : Stack :=
  match i with
  | push_const c => (c :: stack)
  | push_var x   => ((env x) :: stack)
  | not_exp      => match stack with
                 | n1 :: stack' => ( negb n1) :: stack'
                 | _ => stack
                  end
  | and_exp      => match stack with
                 | n1 :: n2 :: stack' => ( andb n1 n2) :: stack'
                 | _ => stack
                 end
  | or_exp       => match stack with
                 | n1 :: n2 :: stack' => ( orb n1 n2) :: stack'
                 | _ => stack
                 end
  end.

Fixpoint run_instructions (is' : list Instruction)
         (env : EnvB) (stack : Stack) : Stack :=
  match is' with
  | [] => stack
  | i :: is'' => run_instructions is'' env (run_instruction i env stack)
  end.

Fixpoint compile (e : BExp1) : list Instruction :=
  match e with
  | b_True  => [push_const true]
  | b_False => [push_const false]
  | b_Var x => [push_var x]
  | b_Not x => (compile x ) ++ [not_exp]
  | b_And e1 e2 => (compile e1) ++ (compile e2) ++ [and_exp]
  | b_Or e1 e2 => (compile e1) ++ (compile e2) ++ [or_exp]
  end.

Lemma soundness_helper :
  forall e env stack is',
    run_instructions (compile e ++ is') env stack =
    run_instructions is' env ((interpret e env) :: stack).
Proof.
  induction e; intros; simpl; trivial.
  - rewrite <- app_assoc.
    rewrite IHe. simpl. reflexivity.
  - rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite IHe1.
    rewrite IHe2.
    simpl.
    rewrite andb_comm.
    reflexivity.
  - rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite IHe1.
    rewrite IHe2.
    simpl.
    rewrite orb_comm.
    reflexivity.
Qed.

Theorem soundness :
  forall e env,
    run_instructions (compile e) env [] =
    [interpret e env].
Proof.
  intros.
  rewrite <- app_nil_r with (l := (compile e)).
  rewrite soundness_helper.
  simpl. trivial.
Qed.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Add Rec LoadPath "../src" as SMTCoq.

Require Import SMTCoq.
Require Import Bool PArray Int63 List ZArith.

Local Open Scope int63_scope.

(* First a tactic, to test the universe computation in an empty
   environment. *)

Lemma check_univ (x1: bool):
  (x1 && (negb x1)) = false.
Proof using.
  zchaff.
Qed.

(* zChaff tactic *)

Goal forall a, a || negb a.
Proof using.
  zchaff.
Qed.

Goal forall a, negb (a || negb a) = false.
Proof using.
  zchaff.
Qed.

Goal forall a, negb (negb (a || negb a)).
Proof using.
  zchaff.
Qed.

Goal forall a, (a && negb a) = false.
Proof using.
  zchaff.
Qed.

Goal forall a, negb (a && negb a).
Proof using.
  zchaff.
Qed.

Goal forall a, implb a a.
Proof using.
  zchaff.
Qed.

Goal forall a, negb (implb a a) = false.
Proof using.
  zchaff.
Qed.

Goal forall a , (xorb a a) || negb (xorb a a).
Proof using.
  zchaff.
Qed.

Goal forall a, (a||negb a) || negb (a||negb a).
Proof using.
  zchaff.
Qed.

Goal true.
Proof using.
  zchaff.
Qed.

Goal negb false.
Proof using.
  zchaff.
Qed.

Goal forall a, Bool.eqb a a.
Proof using.
  zchaff.
Qed.

Goal forall (a:bool), a = a.
Proof using.
  zchaff.
Qed.

(* sat2.smt *)
(* ((a ∧ b) ∨ (b ∧ c)) ∧ ¬b = ⊥ *)

Goal forall a b c, (((a && b) || (b && c)) && (negb b)) = false.
Proof using.
  zchaff.
Qed.

(* sat3.smt *)
(* (a ∨ a) ∧ ¬a = ⊥ *)

Goal forall a, ((a || a) && (negb a)) = false.
Proof using.
  zchaff.
Qed.

(* sat4.smt *)
(* ¬(a ∨ ¬a) = ⊥ *)

Goal forall a, (negb (a || (negb a))) = false.
Proof using.
  zchaff.
Qed.

(* sat5.smt *)
(* (a ∨ b ∨ c) ∧ (¬a ∨ ¬b ∨ ¬c) ∧ (¬a ∨ b) ∧ (¬b ∨ c) ∧ (¬c ∨ a) = ⊥ *)

Goal forall a b c,
  (a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a) = false.
Proof using.
  zchaff.
Qed.

(* The same, but with a, b and c being concrete terms *)

Goal forall i j k,
  ((i == j) || (j == k) || (k == i)) && ((negb (i == j)) || (negb (j == k)) || (negb (k == i))) && ((negb (i == j)) || (j == k)) && ((negb (j == k)) || (k == i)) && ((negb (k == i)) || (i == j)) = false.
Proof using.
  zchaff.
Qed.

Goal forall i j k,
  let a := i == j in
  let b := j == k in
  let c := k == i in
  (a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a) = false.
Proof using.
  zchaff.
Qed.

(* sat6.smt *)
(* (a ∧ b) ∧ (c ∨ d) ∧ ¬(c ∨ (a ∧ b ∧ d)) = ⊥ *)

Goal forall a b c d, ((a && b) && (c || d) && (negb (c || (a && b && d)))) = false.
Proof using.
  zchaff.
Qed.

(* sat7.smt *)
(* a ∧ b ∧ c ∧ (¬a ∨ ¬b ∨ d) ∧ (¬d ∨ ¬c) = ⊥ *)

Goal forall a b c d, (a && b && c && ((negb a) || (negb b) || d) && ((negb d) || (negb c))) = false.
Proof using.
  zchaff.
Qed.

(* Other connectives *)

Goal (false || true) && false = false.
Proof using.
  zchaff.
Qed.

Goal negb true = false.
Proof using.
  zchaff.
Qed.

Goal false = false.
Proof using.
  zchaff.
Qed.

Goal forall x y, Bool.eqb (xorb x y) ((x && (negb y)) || ((negb x) && y)).
Proof using.
  zchaff.
Qed.

Goal forall x y, Bool.eqb (implb x y) ((x && y) || (negb x)).
Proof using.
  zchaff.
Qed.

Goal forall x y z, Bool.eqb (ifb x y z) ((x && y) || ((negb x) && z)).
Proof using.
  zchaff.
Qed.

(* Multiple negations *)

Goal forall a, orb a (negb (negb (negb a))) = true.
Proof using.
  zchaff.
Qed.

(* Polarities *)

Goal forall a b, andb (orb a b) (negb (orb a b)) = false.
Proof using.
  zchaff.
Qed.

Goal forall a b, andb (orb a b) (andb (negb a) (negb b)) = false.
Proof using.
  zchaff.
Qed.

(* Pigeon hole: 4 holes, 5 pigeons. xij stands for "pidgeon i goes to
   hole j". *)

Goal forall x11 x12 x13 x14 x15 x21 x22 x23 x24 x25 x31 x32 x33 x34 x35 x41 x42 x43 x44 x45, (
  (orb (negb x11) (negb x21)) &&
  (orb (negb x11) (negb x31)) &&
  (orb (negb x11) (negb x41)) &&
  (orb (negb x21) (negb x31)) &&
  (orb (negb x21) (negb x41)) &&
  (orb (negb x31) (negb x41)) &&

  (orb (negb x12) (negb x22)) &&
  (orb (negb x12) (negb x32)) &&
  (orb (negb x12) (negb x42)) &&
  (orb (negb x22) (negb x32)) &&
  (orb (negb x22) (negb x42)) &&
  (orb (negb x32) (negb x42)) &&

  (orb (negb x13) (negb x23)) &&
  (orb (negb x13) (negb x33)) &&
  (orb (negb x13) (negb x43)) &&
  (orb (negb x23) (negb x33)) &&
  (orb (negb x23) (negb x43)) &&
  (orb (negb x33) (negb x43)) &&

  (orb (negb x14) (negb x24)) &&
  (orb (negb x14) (negb x34)) &&
  (orb (negb x14) (negb x44)) &&
  (orb (negb x24) (negb x34)) &&
  (orb (negb x24) (negb x44)) &&
  (orb (negb x34) (negb x44)) &&

  (orb (negb x15) (negb x25)) &&
  (orb (negb x15) (negb x35)) &&
  (orb (negb x15) (negb x45)) &&
  (orb (negb x25) (negb x35)) &&
  (orb (negb x25) (negb x45)) &&
  (orb (negb x35) (negb x45)) &&

  (orb (negb x11) (negb x12)) &&
  (orb (negb x11) (negb x13)) &&
  (orb (negb x11) (negb x14)) &&
  (orb (negb x11) (negb x15)) &&
  (orb (negb x12) (negb x13)) &&
  (orb (negb x12) (negb x14)) &&
  (orb (negb x12) (negb x15)) &&
  (orb (negb x13) (negb x14)) &&
  (orb (negb x13) (negb x15)) &&
  (orb (negb x14) (negb x15)) &&

  (orb (negb x21) (negb x22)) &&
  (orb (negb x21) (negb x23)) &&
  (orb (negb x21) (negb x24)) &&
  (orb (negb x21) (negb x25)) &&
  (orb (negb x22) (negb x23)) &&
  (orb (negb x22) (negb x24)) &&
  (orb (negb x22) (negb x25)) &&
  (orb (negb x23) (negb x24)) &&
  (orb (negb x23) (negb x25)) &&
  (orb (negb x24) (negb x25)) &&

  (orb (negb x31) (negb x32)) &&
  (orb (negb x31) (negb x33)) &&
  (orb (negb x31) (negb x34)) &&
  (orb (negb x31) (negb x35)) &&
  (orb (negb x32) (negb x33)) &&
  (orb (negb x32) (negb x34)) &&
  (orb (negb x32) (negb x35)) &&
  (orb (negb x33) (negb x34)) &&
  (orb (negb x33) (negb x35)) &&
  (orb (negb x34) (negb x35)) &&

  (orb (negb x41) (negb x42)) &&
  (orb (negb x41) (negb x43)) &&
  (orb (negb x41) (negb x44)) &&
  (orb (negb x41) (negb x45)) &&
  (orb (negb x42) (negb x43)) &&
  (orb (negb x42) (negb x44)) &&
  (orb (negb x42) (negb x45)) &&
  (orb (negb x43) (negb x44)) &&
  (orb (negb x43) (negb x45)) &&
  (orb (negb x44) (negb x45)) &&

  (orb (orb (orb x11 x21) x31) x41) &&
  (orb (orb (orb x12 x22) x32) x42) &&
  (orb (orb (orb x13 x23) x33) x43) &&
  (orb (orb (orb x14 x24) x34) x44) &&
  (orb (orb (orb x15 x25) x35) x45)) = false.
Proof using.
  zchaff.
Qed.

(* Counter examples *)

(*
Goal forall x, x && (negb x).
Proof using.
  zchaff.
Abort.

Goal forall x y, (implb (implb x y) (implb y x)).
Proof using.
  zchaff.
Abort.

(* Pigeon hole: 4 holes, 4 pigeons. xij stands for "pidgeon i goes to
   hole j". *)

Goal forall x11 x12 x13 x14 x21 x22 x23 x24 x31 x32 x33 x34 x41 x42 x43 x44, (
  (orb (negb x11) (negb x21)) &&
  (orb (negb x11) (negb x31)) &&
  (orb (negb x11) (negb x41)) &&
  (orb (negb x21) (negb x31)) &&
  (orb (negb x21) (negb x41)) &&
  (orb (negb x31) (negb x41)) &&

  (orb (negb x12) (negb x22)) &&
  (orb (negb x12) (negb x32)) &&
  (orb (negb x12) (negb x42)) &&
  (orb (negb x22) (negb x32)) &&
  (orb (negb x22) (negb x42)) &&
  (orb (negb x32) (negb x42)) &&

  (orb (negb x13) (negb x23)) &&
  (orb (negb x13) (negb x33)) &&
  (orb (negb x13) (negb x43)) &&
  (orb (negb x23) (negb x33)) &&
  (orb (negb x23) (negb x43)) &&
  (orb (negb x33) (negb x43)) &&

  (orb (negb x14) (negb x24)) &&
  (orb (negb x14) (negb x34)) &&
  (orb (negb x14) (negb x44)) &&
  (orb (negb x24) (negb x34)) &&
  (orb (negb x24) (negb x44)) &&
  (orb (negb x34) (negb x44)) &&

  (orb (negb x11) (negb x12)) &&
  (orb (negb x11) (negb x13)) &&
  (orb (negb x11) (negb x14)) &&
  (orb (negb x12) (negb x13)) &&
  (orb (negb x12) (negb x14)) &&
  (orb (negb x13) (negb x14)) &&

  (orb (negb x21) (negb x22)) &&
  (orb (negb x21) (negb x23)) &&
  (orb (negb x21) (negb x24)) &&
  (orb (negb x22) (negb x23)) &&
  (orb (negb x22) (negb x24)) &&
  (orb (negb x23) (negb x24)) &&

  (orb (negb x31) (negb x32)) &&
  (orb (negb x31) (negb x33)) &&
  (orb (negb x31) (negb x34)) &&
  (orb (negb x32) (negb x33)) &&
  (orb (negb x32) (negb x34)) &&
  (orb (negb x33) (negb x34)) &&

  (orb (negb x41) (negb x42)) &&
  (orb (negb x41) (negb x43)) &&
  (orb (negb x41) (negb x44)) &&
  (orb (negb x42) (negb x43)) &&
  (orb (negb x42) (negb x44)) &&
  (orb (negb x43) (negb x44)) &&

  (orb (orb (orb x11 x21) x31) x41) &&
  (orb (orb (orb x12 x22) x32) x42) &&
  (orb (orb (orb x13 x23) x33) x43) &&
  (orb (orb (orb x14 x24) x34) x44)) = false.
Proof using.
  zchaff.
Abort.
*)


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.

(* Hack so that Why3 does not override the notation below.

(* Why3 assumption *)
Definition divides (d:Z) (n:Z): Prop := exists q:Z, (n = (q * d)%Z).

*)

Require Import Znumtheory.
Notation divides := Zdivide (only parsing).

(* Why3 goal *)
Lemma divides_refl : forall (n:Z), (divides n n).
Proof.
exact Zdivide_refl.
Qed.

(* Why3 goal *)
Lemma divides_1_n : forall (n:Z), (divides 1%Z n).
Proof.
exact Zone_divide.
Qed.

(* Why3 goal *)
Lemma divides_0 : forall (n:Z), (divides n 0%Z).
Proof.
exact Zdivide_0.
Qed.

(* Why3 goal *)
Lemma divides_left : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides
  (c * a)%Z (c * b)%Z).
Proof.
exact Zmult_divide_compat_l.
Qed.

(* Why3 goal *)
Lemma divides_right : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides
  (a * c)%Z (b * c)%Z).
Proof.
exact Zmult_divide_compat_r.
Qed.

(* Why3 goal *)
Lemma divides_oppr : forall (a:Z) (b:Z), (divides a b) -> (divides a (-b)%Z).
Proof.
exact Zdivide_opp_r.
Qed.

(* Why3 goal *)
Lemma divides_oppl : forall (a:Z) (b:Z), (divides a b) -> (divides (-a)%Z b).
Proof.
exact Zdivide_opp_l.
Qed.

(* Why3 goal *)
Lemma divides_oppr_rev : forall (a:Z) (b:Z), (divides (-a)%Z b) -> (divides a
  b).
Proof.
exact Zdivide_opp_l_rev.
Qed.

(* Why3 goal *)
Lemma divides_oppl_rev : forall (a:Z) (b:Z), (divides a (-b)%Z) -> (divides a
  b).
Proof.
exact Zdivide_opp_r_rev.
Qed.

(* Why3 goal *)
Lemma divides_plusr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides a
  c) -> (divides a (b + c)%Z)).
Proof.
exact Zdivide_plus_r.
Qed.

(* Why3 goal *)
Lemma divides_minusr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides a
  c) -> (divides a (b - c)%Z)).
Proof.
exact Zdivide_minus_l.
Qed.

(* Why3 goal *)
Lemma divides_multl : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a
  (c * b)%Z).
Proof.
intros a b c.
apply Zdivide_mult_r.
Qed.

(* Why3 goal *)
Lemma divides_multr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a
  (b * c)%Z).
Proof.
exact Zdivide_mult_l.
Qed.

(* Why3 goal *)
Lemma divides_factorl : forall (a:Z) (b:Z), (divides a (b * a)%Z).
Proof.
exact Zdivide_factor_l.
Qed.

(* Why3 goal *)
Lemma divides_factorr : forall (a:Z) (b:Z), (divides a (a * b)%Z).
Proof.
exact Zdivide_factor_r.
Qed.

(* Why3 goal *)
Lemma divides_n_1 : forall (n:Z), (divides n 1%Z) -> ((n = 1%Z) \/
  (n = (-1%Z)%Z)).
Proof.
exact Zdivide_1.
Qed.

(* Why3 goal *)
Lemma divides_antisym : forall (a:Z) (b:Z), (divides a b) -> ((divides b
  a) -> ((a = b) \/ (a = (-b)%Z))).
Proof.
exact Zdivide_antisym.
Qed.

(* Why3 goal *)
Lemma divides_trans : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides b
  c) -> (divides a c)).
Proof.
exact Zdivide_trans.
Qed.

(* Why3 goal *)
Lemma divides_bounds : forall (a:Z) (b:Z), (divides a b) -> ((~ (b = 0%Z)) ->
  ((ZArith.BinInt.Z.abs a) <= (ZArith.BinInt.Z.abs b))%Z).
Proof.
exact Zdivide_bounds.
Qed.

Import EuclideanDivision.

(* Why3 goal *)
Lemma mod_divides_euclidean : forall (a:Z) (b:Z), (~ (b = 0%Z)) ->
  (((int.EuclideanDivision.mod1 a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (div a b).
rewrite (Div_mod a b Zb) at 1.
rewrite H.
ring.
Qed.

(* Why3 goal *)
Lemma divides_mod_euclidean : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((divides
  b a) -> ((int.EuclideanDivision.mod1 a b) = 0%Z)).
Proof.
intros a b Zb H.
assert (Zmod a b = Z0).
now apply Zdivide_mod.
unfold mod1, div.
rewrite H0.
case Z_le_dec ; intros H1.
rewrite (Z_div_exact_full_2 a b Zb H0) at 1.
apply Zminus_diag.
now elim H1.
Qed.

(* Why3 goal *)
Lemma mod_divides_computer : forall (a:Z) (b:Z), (~ (b = 0%Z)) ->
  (((ZArith.BinInt.Z.rem a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (Z.quot a b).
rewrite Zmult_comm.
now apply Zquot.Z_quot_exact_full.
Qed.

(* Why3 goal *)
Lemma divides_mod_computer : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((divides b
  a) -> ((ZArith.BinInt.Z.rem a b) = 0%Z)).
Proof.
intros a b Zb (q,H).
rewrite H.
apply Zquot.Z_rem_mult.
Qed.

(* Why3 goal *)
Lemma even_divides : forall (a:Z), (number.Parity.even a) <-> (divides 2%Z
  a).
Proof.
split ;
  intros (q,H) ; exists q ; now rewrite Zmult_comm.
Qed.

(* Why3 goal *)
Lemma odd_divides : forall (a:Z), (number.Parity.odd a) <-> ~ (divides 2%Z
  a).
Proof.
split.
intros H.
contradict H.
apply Parity.even_not_odd.
now apply <- even_divides.
intros H.
destruct (Parity.even_or_odd a).
elim H.
now apply -> even_divides.
exact H0.
Qed.