(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require  Import area_method.

Lemma essai : forall A B C,
let x := S A B C + 2 in
let y := S B C A + 2 in
x = y.
Proof.
intros.
unfold x,y.
uniformize_signed_areas.
auto.
Qed.

(* on_line *)

Lemma test_py_on_line_1 : forall I B C D E,
  on_line I B C -> Py I D E = Py E D I.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_2 : forall I B C D E,
  on_line I B C -> Py D E I = Py D E I.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_3 : forall I B C D,
  on_line I B C -> Py I D I = Py I D I.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_4 : forall I B C,
  on_line I B C -> Py B I C = Py B I C.
Proof.
intros.
prepare_half_free_construction.
eliminate I;auto.
Qed.

Lemma test_py_on_line_4_b : forall I B C,
  B<>C -> on_line I B C -> Py B I C = Py B I C.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_4_c : forall I B C,
  B=C -> on_line I B C -> Py B I C = Py B I C.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_5 : forall I P Q B,
  on_line I P Q -> Py B I B = Py B I B.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

(* on_line_d *)

Lemma test_py_on_line_d_1 : forall I B C r,
  on_line_d I B C r -> Py I C B = Py B C I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_d_2 : forall I B C r,
  on_line_d I B C r -> Py B C I = Py B C I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_d_3 : forall I B C r,
  on_line_d I B C r -> Py B I C = Py B I C.
Proof.
intros.
eliminate I;
auto.
Qed.

Lemma test_py_on_line_d_4 : forall I B C r,
  on_line_d I B C r -> Py B I B = Py B I B.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_line_d_5 : forall A B C D Q r,
  on_line_d Q B C r -> Py A Q D = Py A Q D.
Proof.
intros.
eliminate Q;auto.
Qed.

Lemma test_py_on_line_d_6 : forall A B C D Q r,
  on_line_d Q B C r ->
  Py A Q A + Py A Q D = Py Q A Q + Py A Q D.
Proof.
geoInit.
eliminate Q;auto.
Qed.

(* inter_ll *)

Lemma  test_inter_ll_1 : forall I A B C D X Y,
  inter_ll I A B C D -> Py I X Y = Py Y X I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma  test_inter_ll_2 : forall I A B C D X Y,
  inter_ll I A B C D -> Py Y X I = Py Y X I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma  test_inter_ll_3 : forall I A B C D X Y,
  inter_ll I A B C D -> Py Y I X = Py Y I X.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma  test_inter_ll_4 : forall I A B C D X,
  inter_ll I A B C D -> Py X I X = Py X I X.
Proof.
intros.
eliminate I.
auto.
Qed.

(* on_parallel_d *)

Lemma test_py_on_parallel_d_1  : forall I B C D X Y r,
 on_parallel_d I B C D r -> Py X Y I = Py X Y I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_parallel_d_2  : forall I B C D X Y r,
 on_parallel_d I B C D r -> Py I Y X = Py I Y X.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_parallel_d_3  : forall I B C D X Y r,
 on_parallel_d I B C D r -> Py X I Y = Py X I Y.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_parallel_d_4  : forall I B C D X r,
 on_parallel_d I B C D r -> Py X I X = Py X I X.
Proof.
intros.
eliminate I.
auto.
Qed.

(* on_perp *)

Lemma test_py_on_perp_1  : forall I A B X Y,
 on_perp I A B -> Py X Y I = Py X Y I.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_perp_2  : forall I A B X Y,
 on_perp I A B -> Py I Y X = Py X Y I.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_perp_3  : forall I A B X Y,
 on_perp I A B -> Py X I Y = Py X I Y.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

Lemma test_py_on_perp_4  : forall I A B X,
 on_perp I A B -> Py X I X = Py X I X.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
auto.
Qed.

(* on_perp_d *)

Lemma test_py_on_perp_d_1  : forall I A B r X Y,
 on_perp_d I A B r -> Py X Y I = Py X Y I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_perp_d_2  : forall I A B r X Y,
 on_perp_d I A B r -> Py I Y X = Py X Y I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_perp_d_3  : forall I A B r X Y,
 on_perp_d I A B r -> Py X I Y = Py X I Y.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_perp_d_4  : forall I A B r Y,
 on_perp_d I A B r -> Py Y I Y = Py Y I Y.
Proof.
intros.
eliminate I.
auto.
Qed.

(* on_foot *)

Lemma test_py_on_foot_1  : forall I A B C X Y,
 on_foot I A B C -> Py X Y I = Py X Y I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_foot_2  : forall I A B C X Y,
 on_foot I A B C -> Py I Y X = Py X Y I.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_foot_3  : forall I A B C X Y,
 on_foot I A B C -> Py X I Y = Py X I Y.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_foot_4  : forall I A B C X,
 on_foot I A B C -> Py X I X = Py X I X.
Proof.
intros.
eliminate I.
auto.
Qed.

Lemma test_py_on_foot_5 : forall A B C E,
on_foot E B A C ->
Py B E B + Py E A C = Py B E B + Py E A C.
Proof.
intros.
eliminate E.
auto.
Qed.


Require Import RamifyCoq.msl_application.Graph.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.alg_seplog_direct.
Require Import RamifyCoq.msl_ext.abs_addr.
Require Import RamifyCoq.msl_ext.seplog.
Require Import RamifyCoq.msl_ext.log_normalize.
Require Import RamifyCoq.msl_ext.precise_direct.
Require Import RamifyCoq.msl_ext.overlapping_direct.
Require Import RamifyCoq.msl_ext.alg_seplog_direct.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.heap_model_direct.SeparationAlgebra.
Require Import RamifyCoq.heap_model_direct.mapsto.
Require Import RamifyCoq.heap_model_direct.SeparationLogic.
Require Import VST.msl.msl_direct.
Require Import VST.msl.predicates_sa.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.ZArith.Znumtheory.

Local Open Scope nat.
Local Open Scope pred.

Instance SGS_HMD: PointwiseGraphSetting.
  apply (Build_PointwiseGraphSetting adr 0 eq_nat_dec).
Defined.

Definition trinode x (dlr: bool * nat * nat) :=
  match dlr with
  | (d, l, r) => !! Z.divide 3 (Z.of_nat x) && ((mapsto x (if d then 1 else 0)) * (mapsto (x+1) l) * (mapsto (x+2) r))
  end.

Lemma trinode_unfold: forall x, exp (trinode x) = !! Z.divide 3 (Z.of_nat x) && ((EX d: bool, (mapsto x (if d then 1 else 0))) * (exp (mapsto (x + 1))) * (exp (mapsto (x + 2)))).
Proof.
  intros.
  replace (exp (trinode x) =
   !! Z.divide 3 (Z.of_nat x) && ((EX d: bool, (mapsto x (if d then 1 else 0))) * exp (mapsto (x + 1)) * exp (mapsto (x + 2)))) with
    ((EX dlr : bool * adr * adr,
      !! Z.divide 3 (Z.of_nat x) &&
      (mapsto x (if (fst (fst dlr)) then 1 else 0) * mapsto (x + 1) (snd (fst dlr)) *
       mapsto (x + 2) (snd dlr))) =
   !! Z.divide 3 (Z.of_nat x) && ((EX d: bool, (mapsto x (if d then 1 else 0))) * seplog.exp (mapsto (x + 1)) * seplog.exp (mapsto (x + 2))))%logic.
  2: {
    f_equal.
    simpl.
    f_equal.
    extensionality dlr; destruct dlr as [[? ?] ?]. reflexivity.
  }
  rewrite <- log_normalize.exp_andp2.
  f_equal.
  repeat rewrite exp_curry; simpl fst; simpl snd.
  rewrite seplog.sepcon_assoc.
  rewrite log_normalize.exp_sepcon1.
  f_equal. extensionality s.
  rewrite log_normalize.exp_sepcon1.
  rewrite log_normalize.exp_sepcon2.
  f_equal; extensionality l.
  rewrite !log_normalize.exp_sepcon2.
  f_equal; extensionality r.
  rewrite seplog.sepcon_assoc.
  reflexivity.
Qed.

Lemma mapsto_derives_aux: forall x, EX  d : bool, mapsto x (if d then 1 else 0) |-- exp (mapsto x).
Proof.
  intros.
  apply exp_left; intro d.
  apply (exp_right (if d then 1 else 0)); auto.
Qed.

Lemma trinode__precise: forall x, precise (exp (trinode x)).
Proof.
  intros.
  rewrite trinode_unfold.
  pose proof (@precise_andp_right _ _ _ PSLdirect).
  simpl in H.
  apply H.
  repeat apply precise_sepcon; try apply mapsto__precise.
  apply derives_precise with (exp (mapsto x)); [| apply mapsto__precise].
  apply mapsto_derives_aux.
Qed.

Lemma trinode_conflict: forall p1 p2 v1 v2, p1 = p2 -> trinode p1 v1 * trinode p2 v2 |-- FF.
Proof.
  intros.
  destruct v1 as [[d1 l1] r1].
  destruct v2 as [[d2 l2] r2].
  change (trinode p1 (d1, l1, r1) * trinode p2 (d2, l2, r2) |-- FF) with
   (seplog.derives (!! Z.divide 3 (Z.of_nat p1) && (mapsto p1 (if d1 then 1 else 0) * mapsto (p1 + 1) l1 * mapsto (p1 + 2) r1) *
   (!! Z.divide 3 (Z.of_nat p2) && (mapsto p2 (if d2 then 1 else 0) * mapsto (p2 + 1) l2 * mapsto (p2 + 2) r2)))
    FF)%logic.
  eapply seplog.derives_trans.
  + apply seplog.sepcon_derives;
    (apply log_normalize.andp_derives;
    [| apply seplog.sepcon_derives; [apply seplog.sepcon_derives | apply seplog.derives_refl ]]);
    apply TT_right.
  + rewrite !TT_andp.
    simpl.
    rewrite !sepcon_assoc.
    rewrite (sepcon_comm (mapsto (p1 + 2) r1)).
    rewrite !sepcon_assoc.
    pose proof sepcon_left2_corable_right as HH; simpl in HH.
    do 4 (try apply HH); try apply corable_prop.
    apply mapsto_conflict.
    congruence.
Qed.

Lemma align_3_aux: forall x, Z.divide 3 (Z.of_nat x) <-> exists k, x = (k * 3) % nat.
Proof.
  intros.
  unfold Z.divide.
  split; intros [?k ?].
  + exists (Z.to_nat k).
    rewrite <- (Nat2Z.id x).
    rewrite H.
    assert (0 <= k)%Z.
    1: {
      destruct (Z_lt_le_dec k 0%Z); auto.
      assert (k * 3 < 0 * 3)%Z by (apply Z.mul_lt_mono_pos_r; omega).
      simpl in H0.
      omega.
    }
    apply Z2Nat.inj_mul; omega.
  + exists (Z.of_nat k).
    rewrite H.
    apply Nat2Z.inj_mul.
Qed.

Lemma align_3_aux1: forall p1 p2 k1 k2, (p1 = k1 * 3 -> p2 = k2 * 3 -> p1 = p2 + 1 -> False)%nat.
Proof.
  intros.
  subst.
  destruct (le_dec k1 k2).
  + pose proof mult_le_compat_r _ _ 3 l.
    omega.
  + assert (k2 * 3 < k1 * 3) by (apply Nat.mul_lt_mono_pos_r; omega).
    omega.
Qed.

Lemma align_3_aux2: forall p1 p2 k1 k2, (p1 = k1 * 3 -> p2 = k2 * 3 -> p1 = p2 + 2 -> False)%nat.
Proof.
  intros.
  subst.
  destruct (le_dec k1 k2).
  + pose proof mult_le_compat_r _ _ 3 l.
    omega.
  + assert (k2 * 3 < k1 * 3) by (apply Nat.mul_lt_mono_pos_r; omega).
    omega.
Qed.

Lemma disj_trinode_: forall p1 p2, p1 <> p2 -> disjointed (EX  v : bool * adr * adr, trinode p1 v)
  (EX  v : bool * adr * adr, trinode p2 v).
Proof.
  intros.
  change (EX  v : bool * adr * adr, trinode p1 v) with (exp (trinode p1)).
  change (EX  v : bool * adr * adr, trinode p2 v) with (exp (trinode p2)).
  rewrite !trinode_unfold.
  pose proof disj_prop_andp_left as HH; simpl in HH; apply HH; clear HH; [apply Zdivide_dec |].
  intros.
  apply align_3_aux in H0; destruct H0 as [k1 ?].
  pose proof disj_prop_andp_right as HH; simpl in HH; apply HH; clear HH; [apply Zdivide_dec |].
  intros.
  apply align_3_aux in H1; destruct H1 as [k2 ?].
  pose proof disj_sepcon_right as HH; simpl in HH.
  repeat apply HH; apply disj_comm; repeat apply HH;
  try (eapply disj_derives;
         [ first [apply mapsto_derives_aux | apply derives_refl]
         | first [apply mapsto_derives_aux | apply derives_refl]
         | apply disj_mapsto_]; omega).
Qed.

Lemma trinode_inj: forall p v1 v2, trinode p v1 && trinode p v2 |-- !! (v1 = v2).
Proof.
  intros.
  unfold trinode.
  destruct v1 as [[d1 l1] r1].
  destruct v2 as [[d2 l2] r2].
  eapply derives_trans.
  + apply andp_derives;
    (apply andp_derives;
    [apply (@TT_right _ Ndirect) | apply derives_refl]).
  + pose proof TT_andp.
    simpl in H; rewrite !H; clear H.
    rewrite !sepcon_assoc.
    eapply derives_trans.
    apply precise_left_sepcon_andp_distr with (exp (mapsto p)).
    1: apply mapsto__precise.
    1: apply (exp_right (if d1 then 1 else 0)); auto.
    1: apply (exp_right (if d2 then 1 else 0)); auto.

    eapply derives_trans; [apply sepcon_derives |].
    1: apply mapsto_inj.

    eapply derives_trans.
    apply precise_left_sepcon_andp_distr with (exp (mapsto (p + 1))).
    1: apply mapsto__precise.
    1: apply (exp_right l1); auto.
    1: apply (exp_right l2); auto.

    eapply derives_trans; [apply sepcon_derives |].
    1: apply mapsto_inj.
    1: apply mapsto_inj.
    1: apply derives_refl.

    pose proof sepcon_prop_prop.
    simpl in H; rewrite !H; clear H.

    intro; simpl in *; intros.
    unfold prop in *.

    destruct d1, d2; destruct H as [? [? ?]]; congruence.
Qed.

Instance MSLdirect : MapstoSepLog AV_SGraph trinode.
Proof.
  apply mkMapstoSepLog.
  apply trinode__precise.
Defined.

Instance sMSLdirect : StaticMapstoSepLog AV_SGraph trinode.
Proof.
  apply mkStaticMapstoSepLog; simpl; intros.
  + hnf in H. simpl in H. unfold addr_eqb in H. simpl in H.
    destruct eq_nat_dec.
    - inversion H.
    - exfalso; tauto.
  + apply trinode_conflict.
    unfold addr_eqb in H; simpl in H.
    destruct (eq_nat_dec p1 p2); congruence.
  + apply disj_trinode_.
    unfold addr_eqb in H; simpl in H.
    destruct (eq_nat_dec p1 p2); congruence.
Defined.

Instance nMSLdirect : NormalMapstoSepLog AV_SGraph trinode.
Proof.
  apply mkNormalMapstoSepLog.
  apply trinode_inj.
Defined.

Instance SGA_HMD: PointwiseGraphAssum.
  apply (Build_PointwiseGraphAssum (pred world) _ _ _ _ _ _ _ _ SGS_HMD trinode _ _ (* nMSLdirect *)).
Defined.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
Require Export CoRN.reals.Series.
Require Export CoRN.reals.PosSeq.

Section AlgebraBits.

Lemma algebraic_transform1 : forall (l : IR) (x : nat->IR) (y : nat->IR)
(H2 : seq_pos y) (m : nat),
(seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S m)[/]
       seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m) [=]
((seq_part_sum (fun k : nat => x k[*]y k) (S m)[/]
       seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)[-]l).
Proof.
 intros.
 rstepr (((seq_part_sum (fun k : nat => x k[*]y k) (S m))[-] l[*](seq_part_sum y (S m)))[/]
   seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
 apply div_wd.
  2: apply eq_reflexive_unfolded.
 unfold seq_part_sum.
 unfold cg_minus.
 astepr (Sum0 (G:=IR) (S m) (fun k : nat => x k[*]y k)[+]
   Sum0 (G:=IR) (S m) (fun k : nat => [--]l[*]y k)).
  astepr (Sum0 (G:=IR) (S m) (fun k : nat => x k[*]y k[+][--]l[*]y k)).
   apply Sum0_wd. intros. rational.
   apply (Sum0_plus_Sum0 IR (fun k : nat => x k [*] y k) (fun k : nat => [--] l [*] y k) (S m)).
 apply plus_resp_eq.
 astepr ([--]l [*] (Sum0 (G:=IR) (S m) y)).
 apply mult_distr_sum0_lft.
Qed.

Lemma algebraic_transform2 : forall (l : IR) (x : nat->IR) (y : nat->IR)
(H2 : seq_pos y) (m N1: nat),
(( seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1)[+]
       Sum (S N1) m (fun k : nat => y k [*] (x k [-] l)) )[/]
       seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m) [=]
(seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S m)[/]
       seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
Proof.
 intros.
 unfold seq_part_sum.
 apply div_wd.
  2: apply eq_reflexive_unfolded.
 unfold Sum.
 unfold Sum1.
 rational.
Qed.

Lemma algebraic_transform3:  forall (eps: IR) (y : nat->IR)
(H2 : seq_pos y) (m N1: nat),
(eps[/]TwoNZ [*] (Sum (S N1) m (fun k: nat => y k)[/]
        seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)) [=]
(Sum (G:=IR) (S N1) m (fun k : nat => y k[*]eps [/]TwoNZ)[/]
  seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
Proof.
 intros.
 astepl ((eps[/]TwoNZ [*] (Sum (S N1) m (fun k: nat => y k)))[/]
   seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
 astepr (Sum (G:=IR) (S N1) m (fun k : nat => eps[/]TwoNZ[*]y k)[/]
   seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
 apply div_wd.
  2: apply eq_reflexive_unfolded.
 apply eq_symmetric_unfolded.
 astepr (eps[/]TwoNZ[*]Sum (G:=IR) (S N1) m y).
 apply mult_distr_sum_lft.
Qed.

Lemma algebraic_estimate1 :
forall (e l: IR) (H1 : [0] [<] e) (x : nat -> IR) (y : nat->IR)
(H2 : seq_pos y) (m N1: nat) (H3 : S N1 <= m)
(H4 : forall i, S N1 <= i -> i <= m -> AbsSmall e (x i[-]l)),
AbsSmall
   (Sum (G:=IR) (S N1) m (fun k : nat => y k[*]e)[/]
    seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)
 (Sum (G:=IR) (S N1) m (fun k : nat => y k[*](x k[-]l))[/]
   seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
Proof.
 intros.
 apply AbsSmall_cancel_mult with (seq_part_sum y (S m)).
  apply seq_pos_imp_sum_pos; auto.
 astepl (Sum (G:=IR) (S N1) m (fun k : nat => y k[*]e)).
 astepr (Sum (G:=IR) (S N1) m (fun k : nat => y k[*](x k[-]l))).
 apply sum_resp_AbsSmall; auto.
 intros.
 apply mult_resp_AbsSmall.
  apply less_leEq.
  apply H2.
 apply H4; auto.
Qed.

End AlgebraBits.

Section Cesaro.

Theorem cesaro_transform :
forall (l : IR) (x : nat -> IR) (y : nat -> IR)
(H1 : Cauchy_Lim_prop2 x l)
(H2 : seq_pos y) (H3 : seq_inf_sum y),
Cauchy_Lim_prop2 (fun n : nat => seq_part_sum (fun k : nat => x k [*] y k) (S n)
      [/](seq_part_sum y (S n)) [//] (seq_pos_imp_ap_zero y H2 n)) l.
Proof.
 unfold Cauchy_Lim_prop2.
 intros.
 (* Find N such that forall m > N |x - l| < eps / 2*)
 assert (H4 : [0] [<] eps[/]TwoNZ). apply pos_div_two. auto.
  assert ({N : nat | forall m, N <= m -> AbsSmall (eps[/]TwoNZ) ((x m) [-] l) }).
  apply (H1 (eps[/]TwoNZ) H4).
 destruct X0 as [N1 H5].
 (* find N1 such that a the following will be less that eps/2 also *)
 set (C := seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1)); assert (H7 : { N : nat |
   forall m : nat, N <= m -> AbsSmall (eps[/]TwoNZ) (C [/](seq_part_sum y (S m)) [//] (seq_pos_imp_ap_zero y H2 m))}).
  apply (seq_inf_sum_imp_div_small y H3 H2 C (eps[/]TwoNZ) H4).
 destruct H7 as [N2 H7].
 (* Now we can choose N as max of N1 and N2 *)
 exists (S (max (S N1) N2)).
 intros.
 astepr (seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S m)[/]
   seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
  2: apply (algebraic_transform1 l x y H2 m).
 astepr ((seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1)[+]
   Sum (S N1) m (fun k : nat => y k [*] (x k [-] l)) )[/]
     seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
  2: apply (algebraic_transform2 l x y H2 m).
 astepr (((seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1))
   [/]seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m) [+]
     ((Sum (S N1) m (fun k : nat => y k [*] (x k [-] l)))[/]
       seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)).
 apply AbsSmall_eps_div_two.
  (* We are ready for estimates *)
  apply H7.
  eauto with arith.
 apply AbsSmall_leEq_trans with ((Sum (S N1) m (fun k : nat => y k [*] eps [/]TwoNZ))[/]
   seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
  astepl (eps[/]TwoNZ [*] (Sum (S N1) m (fun k: nat => y k)[/]
    seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)).
   2: apply algebraic_transform3.
  astepr (eps[/]TwoNZ[*][1]).
  apply mult_resp_leEq_lft.
   cut (AbsSmall [1] (Sum (G:=IR) (S N1) m (fun k : nat => y k)[/]
     seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)).
    unfold AbsSmall. tauto.
    apply seq_inf_sum_ratio_bound.
   eauto with arith.
  apply less_leEq; auto.
 apply algebraic_estimate1; auto.
  eauto with arith.
 intros.
 apply H5.
 auto with arith.
Qed.

Theorem cesaro_sum :
forall (l : IR) (x : nat -> IR) (H1 : Cauchy_Lim_prop2 x l),
Cauchy_Lim_prop2 (fun n : nat => seq_part_sum x (S n)
      [/]nring (S n)[//](nringS_ap_zero _ n)) l.
Proof.
 intros.
 set (y := (fun k : nat => [1] : IR)).
 assert (H2 : seq_pos y).
  apply One_seq_is_pos.
 assert (H3 : seq_inf_sum y).
  apply One_seq_is_inf_sum.
 apply Cauchy_Lim_prop2_wd' with (fun n : nat => seq_part_sum (fun k : nat => x k[*] y k) (S n)
   [/]seq_part_sum y (S n)[//]seq_pos_imp_ap_zero y H2 n).
  apply cesaro_transform; auto.
 exists 0.
 intros.
 apply div_wd.
  unfold seq_part_sum.
  apply Sum0_wd.
  intros. unfold y. algebra.
  apply One_part_sum.
Qed.

End Cesaro.


From Typonomikon Require Import F2.

CoInductive StreamTree (A : Type) : Type :=
{
  root : A;
  trees : Stream (StreamTree A);
}.

Arguments root  {A} _.
Arguments trees {A} _.

(* Unset Guard Checking. *)
Fail CoFixpoint stmap {A B : Type} (f : A -> B) (t : StreamTree A) : StreamTree B :=
{|
  root := f (root t);
  trees := map (stmap f) (trees t);
|}.
Set Guard Checking.

Fail CoFixpoint stmap {A B : Type} (f : A -> B) (t : StreamTree A) : StreamTree B :=
{|
  root  := f (root t);
  trees :=
  {|
    hd := stmap f (hd (trees t));
    tl := trees (stmap f {| root := root t; trees := tl (trees t); |})
  |};
|}.

Fail CoFixpoint stmap {A B : Type} (f : A -> B) (t : StreamTree A) : StreamTree B :=
{|
  root  := f (root t);
  trees := smap f (trees t);
|}

with smap {A B : Type} (f : A -> B) (s : Stream (StreamTree A)) : Stream (StreamTree B) :=
{|
  hd := stmap f (hd s);
  tl := smap  f (tl s);
|}.


(** This file provides an "unbounded" version of the fractional camera whose
elements are in the interval (0,..) instead of (0,1]. *)
From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes.
From iris.prelude Require Import options.

(** Since the standard (0,1] fractional camera [frac] is used more often, we
define [ufrac] through a [Definition] instead of a [Notation]. That way, Coq
infers the [frac] camera by default when using the [Qp] type. *)
Definition ufrac := Qp.

Section ufrac.
  Implicit Types p q : ufrac.

  Canonical Structure ufracO := leibnizO ufrac.

  Local Instance ufrac_valid_instance : Valid ufrac := λ x, True.
  Local Instance ufrac_pcore_instance : PCore ufrac := λ _, None.
  Local Instance ufrac_op_instance : Op ufrac := λ x y, (x + y)%Qp.

  Lemma ufrac_op p q : p ⋅ q = (p + q)%Qp.
  Proof. done. Qed.
  Lemma ufrac_included p q : p ≼ q ↔ (p < q)%Qp.
  Proof. by rewrite Qp.lt_sum. Qed.

  Corollary ufrac_included_weak p q : p ≼ q → (p ≤ q)%Qp.
  Proof. rewrite ufrac_included. apply Qp.lt_le_incl. Qed.

  Definition ufrac_ra_mixin : RAMixin ufrac.
  Proof. split; try apply _; try done. Qed.
  Canonical Structure ufracR := discreteR ufrac ufrac_ra_mixin.

  Global Instance ufrac_cmra_discrete : CmraDiscrete ufracR.
  Proof. apply discrete_cmra_discrete. Qed.

  Global Instance ufrac_cancelable q : Cancelable q.
  Proof. intros n p1 p2 _. apply (inj (Qp.add q)). Qed.
  Global Instance ufrac_id_free q : IdFree q.
  Proof. intros p _. apply Qp.add_id_free. Qed.

  Global Instance is_op_ufrac q : IsOp' q (q/2)%Qp (q/2)%Qp.
  Proof. by rewrite /IsOp' /IsOp ufrac_op Qp.div_2. Qed.
End ufrac.


Require Import VST.floyd.proofauto.
Require Import vcfloat.VCFloat.
Require Import vcfloat.FPCompCert.
Require Import VSTlib.spec_math.
Require Import Iterative.floatlib.

Set Bullet Behavior "Strict Subproofs".

Open Scope logic.

Inductive crs_row_rep {t: type}: forall (cols: Z) (vals: list (ftype t)) (col_ind: list Z) (v: list  (ftype t)), Prop :=
 | crs_row_rep_nil: crs_row_rep 0%Z nil nil nil
 | crs_row_rep_zero: forall cols vals col_ind v,
          crs_row_rep (cols-1) vals (map Z.pred col_ind) v ->
          crs_row_rep cols vals col_ind (Zconst t 0 :: v)
 | crs_row_rep_val: forall cols x vals col_ind v,
          crs_row_rep (cols-1) vals (map Z.pred col_ind) v ->
          crs_row_rep cols (x::vals) (0::col_ind) (x::v).

Definition crs_rep_aux {t} (mval: matrix t) (cols: Z) (vals: list (ftype t)) (col_ind: list Z) (row_ptr: list Z) : Prop :=
  Zlength row_ptr = 1 + Zlength mval /\
  Zlength vals = Znth (Zlength mval) row_ptr /\
  Zlength col_ind = Znth (Zlength mval) row_ptr /\
  sorted Z.le (0::row_ptr ++ [Int.max_unsigned]) /\
  forall j, 0 <= j < Zlength mval ->
        crs_row_rep cols
             (sublist (Znth j row_ptr) (Znth (j+1) row_ptr) vals)
             (sublist (Znth j row_ptr) (Znth (j+1) row_ptr) col_ind)
             (Znth j mval).

Lemma sorted_app_e1:
 forall {A} {HA: Inhabitant A} (le: A -> A -> Prop) al bl,
  sorted le (al++bl) -> sorted le al.
Proof.
intros.
intros i j [??]. specialize (H i j).
rewrite !Znth_app1 in H by lia.
apply H; list_solve.
Qed.

Lemma crs_rep_matrix_cols {t: type}:
   forall (mval: matrix t) cols vals col_ind row_ptr,
   crs_rep_aux mval cols vals col_ind row_ptr -> matrix_cols mval cols.
Proof.
unfold crs_rep_aux.
intros mval cols.
induction mval; intros; [constructor | ].
destruct H as [L [L0 [L1 (*[COL*) [SORT ?]]]](*]*).
constructor.
-
specialize (H 0 ltac:(list_solve)).
clear - H.
rewrite Znth_0_cons in H.
simpl in H.
forget (Znth 0 row_ptr) as x.
forget (Znth 1 row_ptr) as x'.
forget (sublist x x' vals) as v.
forget (sublist x x' col_ind) as c.
clear - H.
induction H.
reflexivity.
list_solve.
list_solve.
-
destruct row_ptr as [| r row_ptr]. list_solve.
apply (IHmval (sublist r (Zlength vals) vals)
                 (sublist r (Zlength col_ind) col_ind)
                 (map (fun i => i-r) row_ptr)); clear IHmval.
rewrite !Zlength_cons in *.
unfold Z.succ in *.
rewrite Znth_pos_cons in * by list_solve.
rewrite Z.add_simpl_r in *.
rewrite !Zlength_map.
rewrite !Znth_map by list_solve.
pose proof (SORT 0 1 ltac:(list_solve)).
change (0 <= r) in H0.
split3; [ | | split3].
 + list_solve.
 + rewrite L0. clear - H0 L L0  SORT. abstract list_solve.
 + rewrite L1. clear - H0 L L1 SORT. abstract list_solve.
 + intros i j [? ?].
     autorewrite with sublist in H2.
     clear - H0 H1 H2 SORT. change (Z.succ 0) with 1 in H2.
     abstract (list_simplify;
     (* BUG! in list_solve / list_simplify: one of the tactics is leaving
         this trivial subgoal.  Please report. *) rep_lia).
  + intros.
      specialize (H (j+1) ltac:(lia)).
       rewrite !Znth_pos_cons in H by lia.
       rewrite !Z.add_simpl_r in H.
       rewrite !Znth_map by lia.
       assert (0 <= Znth j row_ptr - r <= Znth (j + 1) row_ptr - r)
                    by (clear - H0 H1 SORT L; abstract list_solve).
       assert (Znth (j + 1) row_ptr - r <= Zlength col_ind - r)
                    by (clear - H0 H1 SORT L L1; abstract list_solve).
       rewrite !sublist_sublist by lia.
       rewrite !Z.sub_add. auto.
Qed.

Lemma crs_row_rep_cols_nonneg:
 forall {t} cols (vals: list (ftype t)) col_ind vval,
  crs_row_rep cols vals col_ind vval ->
  0 <= cols.
Proof.
induction 1; intros.
- list_solve.
- lia.
- lia.
Qed.

Lemma crs_row_rep_col_range:
 forall {t} cols (vals: list (ftype t)) col_ind vval,
  crs_row_rep cols vals col_ind vval ->
   forall j, 0 <= j < Zlength col_ind -> 0 <= Znth j col_ind < cols.
Proof.
induction 1; intros.
- list_solve.
- specialize (IHcrs_row_rep j ltac:(list_solve)). rewrite Znth_map in * by list_solve. lia.
- destruct (zeq j 0).
  + subst. rewrite Znth_0_cons. apply crs_row_rep_cols_nonneg in H. lia.
  + rewrite Znth_pos_cons by lia.
     specialize (IHcrs_row_rep (j-1) ltac:(list_solve)).
     rewrite Znth_map in IHcrs_row_rep by list_solve.
     lia.
Qed.

Lemma crs_row_rep_property:
 forall {t} (P: ftype t -> Prop) cols (vals: list (ftype t)) col_ind vval,
  crs_row_rep cols vals col_ind vval ->
  Forall P vval -> Forall P vals.
Proof.
intros.
induction H; auto.
inversion H0; auto.
inversion H0; constructor; auto.
Qed.

Fixpoint rowmult {t} (s: ftype t)
            (vals: list (ftype t)) (col_ind: list Z) (vval: list (ftype t)) :=
 match vals, col_ind with
  | v1::vals', c1::col_ind' => rowmult (BFMA v1 (Znth c1 vval) s) vals' col_ind' vval
  | _, _ => s
 end.

Add Parametric Morphism {t: type}  : rowmult
  with signature (@feq t) ==> Forall2 feq ==> @eq (list Z) ==> Forall2 feq ==> feq
  as rowmult_mor.
Proof.
intros s s' Hs vals vals' Hvals ci vval vval' Hvval.
revert s s' Hs ci vval vval' Hvval.
induction Hvals; intros.
-
simpl. auto.
-
destruct ci; simpl.
auto.
apply IHHvals; auto.
apply BFMA_mor; auto.
pose proof (Forall2_Zlength Hvval).
destruct (zlt z 0).
rewrite !Znth_underflow by auto. apply I.
destruct (zle (Zlength vval) z).
rewrite !Znth_overflow by lia. apply I.
apply Forall2_Znth with (i:=z) in Hvval; auto.
lia.
Qed.

Add Parametric Morphism {t: type}  : rowmult
  with signature (@feq t) ==> Forall2 strict_feq ==> @eq (list Z) ==> Forall2 strict_feq ==> feq
  as rowmult_stricter_mor.
Proof.
intros s s' Hs vals vals' Hvals ci vval vval' Hvval.
revert s s' Hs ci vval vval' Hvval.
induction Hvals; intros.
-
simpl. auto.
-
destruct ci; simpl.
auto.
apply IHHvals; auto.
apply BFMA_mor; auto; apply subrelation_strict_feq; auto.
pose proof (Forall2_Zlength Hvval).
destruct (zlt z 0).
rewrite !Znth_underflow by auto. apply I.
destruct (zle (Zlength vval) z).
rewrite !Znth_overflow by lia. apply I.
apply Forall2_Znth with (i:=z) in Hvval; auto.
lia.
Qed.

Definition partial_row {t} (i: Z) (h: Z) (vals: list (ftype t)) (col_ind: list Z) (row_ptr: list Z)
                (vval: vector t) : ftype t :=
 let vals' := sublist (Znth i row_ptr) h vals in
 let col_ind' := sublist (Znth i row_ptr) h col_ind in
   rowmult (Zconst t 0) vals' col_ind' vval.

Lemma partial_row_start:
 forall {t} i (mval: matrix t) cols vals col_ind row_ptr vval,
  crs_rep_aux mval cols vals col_ind row_ptr ->
  partial_row i (Znth i row_ptr) vals col_ind row_ptr vval = Zconst t 0.
Proof.
intros.
unfold partial_row.
autorewrite with sublist.
reflexivity.
Qed.

Lemma strict_feq_i:
 forall {t} (x: ftype t), finite x -> strict_feq x x.
Proof. auto. Qed.

Lemma strict_floatlist_eqv_i:
  forall {t} (vec: list (ftype t)), Forall finite vec -> Forall2 strict_feq vec vec.
Proof.
intros.
induction H; constructor; auto.
Qed.
#[export] Hint Resolve strict_feq_i strict_floatlist_eqv_i : core.

Lemma partial_row_end:
 forall {t} i (mval: matrix t) cols vals col_ind row_ptr vval
  (FINvval: Forall finite vval)
  (FINmval: Forall (Forall finite) mval)
  (LEN: Zlength vval = cols),
  0 <= i < matrix_rows mval ->
  crs_rep_aux mval cols vals col_ind row_ptr ->
  feq (partial_row i (Znth (i+1) row_ptr) vals col_ind row_ptr vval)
      (Znth i (matrix_vector_mult mval vval)).
Proof.
intros.
unfold partial_row.
unfold matrix_vector_mult.
assert (COL := crs_rep_matrix_cols _ _ _ _ _ H0).
red in COL.
destruct H0 as [? [? [? [? ?]]]].
specialize (H4 _ H).
set (vals' := sublist _ _ vals) in *. clearbody vals'.
set (col_ind' := sublist _ _ col_ind)  in *. clearbody col_ind'.
unfold matrix_rows in *.
rewrite Znth_map by list_solve.
assert (FINrow := sublist.Forall_Znth _ _ _ H FINmval).
set (row := Znth i mval) in *. clearbody row.
assert (FINvals': Forall finite vals'). {
 clear - FINrow H4.
 eapply crs_row_rep_property; eauto.
}
clear - H4 FINvval FINvals' FINrow LEN.
unfold dotprod.
forget (Zconst t 0) as s.
revert s vval FINvval LEN; induction H4; intros.
-
reflexivity.
-
 inv FINrow. clear H1. rename H2 into FINrow.
destruct vval as [ | v0 vval'].
 +
  simpl.
  pose proof (feq_refl s).
  clear - FINvals' FINvval FINrow H.
  revert s col_ind H; induction vals; intros; destruct col_ind; simpl; auto.
  rewrite Znth_nil. unfold default, zerof.
  inv FINvals'.
  specialize (IHvals H3 s col_ind H).
   etransitivity; [ | apply IHvals].
   apply rowmult_mor; auto.
   apply BFMA_zero2; auto.
 +
   simpl.
   transitivity  (fold_left
     (fun (s0 : ftype t) (x12 : ftype t * ftype t) =>
      BFMA (fst x12) (snd x12) s0) (combine v vval') s).
  *
   inv FINvval.
   rewrite <- IHcrs_row_rep; clear IHcrs_row_rep; auto.
   pose proof (crs_row_rep_col_range _ _ _ _ H4). clear H4.
   rewrite Zlength_map in H by list_solve.
   rewrite Zlength_cons in H.
   assert (Forall (fun j => 1 <= j <= (Zlength vval')) col_ind).
   apply Forall_Znth. intros.
   specialize (H _ H0).
   rewrite Znth_map in H by list_solve. lia. clear H.
   revert s col_ind H0; induction vals; destruct col_ind; simpl; intros; auto.
   inv FINvals'.
   rewrite IHvals; auto. f_equal. f_equal.
   inv H0.
   list_solve.
   inv H0; auto. clear; list_solve.
 * clear - FINvval FINrow.
    inv FINvval.
    assert (feq s (BFMA (Zconst t 0) v0 s)). symmetry; apply BFMA_zero1; auto.
    forget (BFMA (Zconst t 0) v0 s) as s'. clear v0 H1.
    revert s s' H vval' H2; induction v; simpl; intros; auto.
    destruct vval'; simpl; auto.
    inv H2. inv FINrow.
    apply IHv; auto.
    apply BFMA_mor; auto.
-
  inv FINrow. rename H1 into FINx. rename H2 into FINrow.
  inv FINvals'. clear H1. rename H2 into FINvals.
  specialize (IHcrs_row_rep FINrow FINvals).
  destruct vval as [ | v0 vval'].
 + simpl. rewrite Znth_nil. unfold default, zerof.
   transitivity  (rowmult s vals col_ind []).
   apply rowmult_mor; auto. apply BFMA_zero2; auto.
   clear - FINvals. revert s col_ind; induction vals; destruct col_ind; simpl; auto.
   rewrite Znth_nil. unfold default, zerof. inv FINvals.
   rewrite IHvals; auto.
   rewrite BFMA_zero2; auto.
 +
   simpl. rewrite Znth_0_cons.
   forget (BFMA x v0 s) as s1. clear s x FINx.
   inv FINvval. rename H1 into FINv0. rename H2 into FINvval.
   rewrite <- IHcrs_row_rep; auto; clear IHcrs_row_rep.
   pose proof (crs_row_rep_col_range _ _ _ _ H4). clear H4.
   rewrite Zlength_map in H by list_solve.
   assert (Forall (fun j => 1 <= j <= Zlength vval') col_ind). {
     apply Forall_Znth. intros.
     specialize (H _ H0).
     rewrite Znth_map in H by list_solve. rewrite Zlength_cons in H; lia.
   } clear H.
   revert s1 col_ind H0; induction vals; destruct col_ind; simpl; intros; auto.
   inv FINvals.
   inv H0.
   rewrite IHvals; auto.
   apply rowmult_mor; auto. apply BFMA_mor; auto.
   rewrite Znth_pos_cons by list_solve.
   replace (Z.pred z) with (z-1) by lia. reflexivity.
   list_solve.
Qed.

Lemma rowmult_app:
 forall {t} (s: ftype t) vals1 col_ind1 vals2 col_ind2 vvals,
   Zlength vals1 = Zlength col_ind1 ->
   rowmult s (vals1++vals2) (col_ind1++col_ind2) vvals =
   rowmult (rowmult s vals1 col_ind1 vvals) vals2 col_ind2 vvals.
Proof.
intros.
rewrite !Zlength_correct in H. apply Nat2Z.inj in H.
revert s col_ind1 H.
induction vals1; destruct col_ind1; simpl; intros; inv H; auto.
Qed.

Lemma partial_row_next:
 forall {t} i h (mval: matrix t) cols vals col_ind row_ptr vval,
  0 <= Znth i row_ptr ->
  Znth i row_ptr <= h < Zlength vals ->
  Zlength vals = Zlength col_ind ->
  crs_rep_aux mval cols vals col_ind row_ptr ->
partial_row i (h + 1) vals col_ind row_ptr vval =
BFMA (Znth h vals) (Znth (Znth h col_ind) vval)
  (partial_row i h vals col_ind row_ptr vval).
Proof.
intros.
unfold partial_row.
rewrite !(sublist_split (Znth i row_ptr) h (h+1)) by lia.
rewrite rowmult_app by list_solve.
set (s1 := rowmult (Zconst t 0) _ _ _). clearbody s1.
rewrite !sublist_len_1 by lia.
reflexivity.
Qed.


From SSL_Iris Require Import core.
From iris.heap_lang Require Import lang notation proofmode.
From iris_string_ident Require Import ltac2_string_ident.
Section common.
Context `{!heapG Σ}.
Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: loc) (len: Z) (lo: Z) (hi: Z) (self_card: sll_card) { struct self_card } : iProp Σ := match self_card with
    | sll_card_0  => ⌜(x = null_loc) ∧ (hi = 0) ∧ (len = 0) ∧ (lo = 7)⌝
    | sll_card_1 _alpha_513 => ∃ (len1 : Z) (v : Z) (hi1 : Z) (lo1 : Z) (nxt : loc), ⌜~ (x = null_loc) ∧ (0 ≤ len1)%Z ∧ (0 ≤ v)%Z ∧ (hi = if (Z.leb hi1 v) then v else hi1) ∧ (len = (1 + len1)%Z) ∧ (lo = if (Z.leb v lo1) then v else lo1) ∧ (v ≤ 7)%Z⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #nxt ∗ (sll nxt len1 lo1 hi1 _alpha_513)
end.

Global Opaque sll.

Lemma sll_card_0_learn (x: loc) (len: Z) (lo: Z) (hi: Z) self_card:
sll x len lo hi self_card  ⊢ sll x len lo hi self_card ∗ ⌜(x = null_loc) -> self_card = sll_card_0⌝.
Proof.
Transparent sll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & % & % & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (len1 v hi1 lo1 nxt) "((% & % & % & % & % & % & %) & (? & ? & ? & ?))".
   iSplitL.
   iExists len1, v, hi1, lo1, nxt. iFrame. eauto.
   eauto.
Global Opaque sll.
Qed.

Lemma sll_card_1_learn (x: loc) (len: Z) (lo: Z) (hi: Z) self_card:
sll x len lo hi self_card  ⊢ sll x len lo hi self_card ∗ ⌜~ (x = null_loc) -> ∃ _alpha_513, self_card = (sll_card_1 _alpha_513)⌝.
Proof.
Transparent sll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & % & % & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (len1 v hi1 lo1 nxt) "((% & % & % & % & % & % & %) & (? & ? & ? & ?))".
   iSplitL.
   iExists len1, v, hi1, lo1, nxt. iFrame. eauto.
   eauto.
Global Opaque sll.
Qed.

Lemma sll_card_0_open  (x: loc) (len: Z) (lo: Z) (hi: Z) :
sll x len lo hi (sll_card_0 ) = (⌜(x = null_loc) ∧ (hi = 0) ∧ (len = 0) ∧ (lo = 7)⌝)%I.
Proof. auto. Qed.

Lemma sll_card_1_open (_alpha_513 : sll_card) (x: loc) (len: Z) (lo: Z) (hi: Z) :
sll x len lo hi (sll_card_1 _alpha_513) = (∃ (len1 : Z) (v : Z) (hi1 : Z) (lo1 : Z) (nxt : loc), ⌜~ (x = null_loc) ∧ (0 ≤ len1)%Z ∧ (0 ≤ v)%Z ∧ (hi = if (Z.leb hi1 v) then v else hi1) ∧ (len = (1 + len1)%Z) ∧ (lo = if (Z.leb v lo1) then v else lo1) ∧ (v ≤ 7)%Z⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #nxt ∗ (sll nxt len1 lo1 hi1 _alpha_513))%I.
Proof. auto. Qed.

End common.


Require Import msl.msl_standard.
Require Import share_dec_base.
Require Import base_properties.
Require Import share_equation_system.
Require Import share_dec_interface.
Require Import NPeano.

 Import Share.

Module Round_Average (sv : SV)
                     (Import es : EQUATION_SYSTEM sv with Module dom := Share_Domain)
                     (Import esf : SYSTEM_FEATURES sv es).

 Definition avg_ctx (ctxL ctxR : context) (h : nat) (l : list var) : context :=
  fun v => if in_dec eq_dec v l then
            match avg h (ctxL v) (ctxR v) with
            | None => emptyshare
            | Some s => s
            end
           else recompose (ctxL v ,ctxR v).

 Definition rL_ctx (ctx : context) (h : nat) (l : list var) : context :=
  fun v => if in_dec eq_dec v l then
            match roundL h (ctx v) with
            | None => emptyshare
            | Some s => s
            end
           else let (sL,sR) := decompose (ctx v) in sL.

 Definition rR_ctx (ctx : context) (h : nat) (l : list var) : context :=
  fun v => if in_dec eq_dec v l then
            match roundR h (ctx v) with
            | None => emptyshare
            | Some s => s
            end
           else let (sL,sR) := decompose (ctx v) in sR.

 Lemma avg_override: forall l l' n ctxL ctxL' ctxR ctxR',
  avg_ctx ([l => ctxL']ctxL) ([l => ctxR']ctxR) n l' =
  [l => avg_ctx ctxL' ctxR' n l'] (avg_ctx ctxL ctxR n l').
 Proof with try tauto.
  intros.
  extensionality v.
  destruct (in_dec eq_dec v l).
  rewrite override_in...
  unfold avg_ctx.
  destruct (in_dec eq_dec v l').
  repeat rewrite override_in...
  repeat rewrite override_in...
  rewrite override_not_in...
  unfold avg_ctx.
  destruct (in_dec eq_dec v l').
  repeat rewrite override_not_in...
  repeat rewrite override_not_in...
 Qed.

 Lemma avg_ctx_in_var: forall l v h (ctxL ctxR : context),
  |ctxL v| < h ->
  |ctxR v| < h ->
  In v l ->
  avg h (ctxL v) (ctxR v) = Some (avg_ctx ctxL ctxR h l v).
  Proof with auto.
   intros.
   unfold avg_ctx.
   icase (in_dec eq_dec v l).
   destruct (tree_avg_ex _ _ _ H H0).
   unfold s,share in *. unfold dom.e,share in *. rewrite H2...
  Qed.

 Lemma avg_ctx_not_in_var: forall (ctxL ctxR : context) n l v,
  ~In v l ->
  avg_ctx ctxL ctxR n l v = recompose (ctxL v, ctxR v).
 Proof.
  intros. unfold avg_ctx. icase (in_dec eq_dec v l).
 Qed.

 Lemma rL_ctx_override: forall ctx ctx' l' n l,
  rL_ctx ([l'=>ctx']ctx) n l = [l'=>(rL_ctx ctx' n l)](rL_ctx ctx n l).
 Proof with try tauto.
  intros.
  extensionality v.
  destruct (in_dec eq_dec v l').
  rewrite override_in...
  unfold rL_ctx.
  destruct (in_dec eq_dec v l);
  rewrite override_in...
  rewrite override_not_in...
  unfold rL_ctx.
  destruct (in_dec eq_dec v l);
  rewrite override_not_in...
 Qed.

 Lemma rR_ctx_override: forall ctx ctx' l' n l,
  rR_ctx ([l'=>ctx']ctx) n l = [l'=>(rR_ctx ctx' n l)](rR_ctx ctx n l).
  Proof with try tauto.
  intros.
  extensionality v.
  destruct (in_dec eq_dec v l').
  rewrite override_in...
  unfold rR_ctx.
  destruct (in_dec eq_dec v l);
  rewrite override_in...
  rewrite override_not_in...
  unfold rR_ctx.
  destruct (in_dec eq_dec v l);
  rewrite override_not_in...
 Qed.

 Lemma rL_ctx_in_var: forall (ctx : context) h l v,
  (|ctx v| <= S h)%nat ->
  In v l ->
  roundL (S h) (ctx v) = Some (rL_ctx ctx (S h) l v).
 Proof with try tauto.
  intros.
  unfold rL_ctx.
  icase (in_dec eq_dec v l).
  apply tree_round_left_Some in H.
  destruct H. unfold s,share in *.  unfold dom.e,share in *. rewrite H...
 Qed.

 Lemma rR_ctx_in_var: forall (ctx : context) h l v,
  (|ctx v| <= S h)%nat ->
  In v l ->
  roundR (S h) (ctx v) = Some (rR_ctx ctx (S h) l v).
 Proof with try tauto.
  intros.
  unfold rR_ctx.
  icase (in_dec eq_dec v l).
  apply tree_round_right_Some in H.
  destruct H. unfold s,share in *. unfold dom.e,share in *. rewrite H...
 Qed.

 Lemma rL_ctx_not_in_var: forall (ctx : context) n l v,
  ~In v l ->
  rL_ctx ctx n l v = fst (decompose (ctx v)).
 Proof.
  intros. unfold rL_ctx. icase (in_dec eq_dec v l).
 Qed.

 Lemma rR_ctx_not_in_var: forall (ctx : context) n l v,
  ~In v l ->
  rR_ctx ctx n l v = snd (decompose (ctx v)).
 Proof.
  intros. unfold rR_ctx. icase (in_dec eq_dec v l).
 Qed.

 Lemma rL_ctx_lt: forall v h ctx l,
  (|ctx v| <= S h)%nat ->
  In v l ->
  |rL_ctx ctx (S h) l v| < S h.
 Proof with try tauto.
  intros.
  unfold rL_ctx. icase (in_dec eq_dec v l).
  apply tree_round_left_Some in H.
  destruct H. unfold s,share in *. unfold dom.e,share in *. rewrite H.
  apply tree_round_left_height_compare in H...
 Qed.

 Lemma rR_ctx_lt: forall v h ctx l,
  (|ctx v| <= S h)%nat ->
  In v l ->
  |rR_ctx ctx (S h) l v| < S h.
 Proof with try tauto.
  intros.
  unfold rR_ctx. icase (in_dec eq_dec v l).
  apply tree_round_right_Some in H.
  destruct H. unfold s,share in *. unfold dom.e,share in *. rewrite H.
  apply tree_round_right_height_compare in H...
 Qed.

 Lemma avg_ctx_leq: forall v h ctxL ctxR l,
  |ctxL v| < S h -> |ctxR v| < S h -> In v l ->
  (|avg_ctx ctxL ctxR (S h) l v| <= S h)%nat.
 Proof with try tauto.
  intros.
  unfold avg_ctx. icase (in_dec eq_dec v l).
  destruct (tree_avg_ex _ _ _ H H0).
  unfold s,share in *. unfold dom.e,share in *. rewrite H2.
  apply tree_avg_bound in H2...
 Qed.

 Lemma round_avg_ctx: forall ctx ctxL ctxR h l,
  (cheight ctx l <= S h)%nat ->
   rL_ctx ctx (S h) l = ctxL -> rR_ctx ctx (S h) l = ctxR ->
  avg_ctx ctxL ctxR (S h) l = ctx.
 Proof with try tauto.
  intros.
  rewrite cheight_leq_rewrite in H.
  extensionality v.
  destruct (in_dec eq_dec v l).
  spec H v i.
  assert (|rL_ctx ctx (S h) l v| < S h) by (apply rL_ctx_lt;tauto).
  assert (|rR_ctx ctx (S h) l v| < S h) by (apply rR_ctx_lt;tauto).
  generalize (avg_ctx_in_var _ _ _ _ _ H2 H3 i);intro.
  generalize (rL_ctx_in_var _ _ _ _ H i);intro.
  generalize (rR_ctx_in_var _ _ _ _ H i);intro.
  generalize (tree_avg_round2avg _ _ _ _ H5 H6);intro.
  rewrite H0 in *. rewrite H1 in *.
  unfold s,share in *. unfold dom.e,share in *. rewrite H7 in H4. inv H4...
  generalize (avg_ctx_not_in_var ctxL ctxR (S h) _ _ n);intro.
  generalize (rL_ctx_not_in_var ctx (S h) _ _ n);intro.
  generalize (rR_ctx_not_in_var ctx (S h) _ _ n);intro.
  rewrite H2.
  rewrite H0 in H3. rewrite H1 in H4.
  rewrite H3,H4.
  rewrite<- recompose_decompose. unfold s,dom.e,share,t in *.
  destruct (@decompose canonTree _ (ctx v))...
 Qed.

 Lemma avg_round_ctx: forall ctx ctxL ctxR h l,
  cheight ctxL l < S h->
  cheight ctxR l < S h->
  avg_ctx ctxL ctxR (S h) l = ctx ->
  rL_ctx ctx (S h) l = ctxL /\ rR_ctx ctx (S h) l = ctxR.
 Proof with try tauto.
  intros.
  split;extensionality v.
  destruct (in_dec eq_dec v l).
  rewrite cheight_lt_rewrite in H.
  rewrite cheight_lt_rewrite in H0.
  spec H v i. spec H0 v i.
  generalize (avg_ctx_in_var _ _ _ _ _ H H0 i);intro.
  generalize (avg_ctx_leq _ _ _ _ l H H0 i);intro.
  generalize (rL_ctx_in_var _ _ _ _ H3 i);intro.
  destruct (tree_avg_avg2round _ _ _ _ H2) as [? _].
  unfold s,share in *. unfold dom.e,share in *. rewrite H4 in H5. inv H5...
  generalize (avg_ctx_not_in_var ctxL ctxR (S h) _ _ n);intro.
  generalize (rL_ctx_not_in_var ctx (S h) _ _ n);intro.
  rewrite H1 in H2. rewrite H3. rewrite H2.
  rewrite decompose_recompose...
  destruct (in_dec eq_dec v l).
  rewrite cheight_lt_rewrite in H.
  rewrite cheight_lt_rewrite in H0.
  spec H v i. spec H0 v i.
  generalize (avg_ctx_in_var _ _ _ _ _ H H0 i);intro.
  generalize (avg_ctx_leq _ _ _ _ l H H0 i);intro.
  generalize (rR_ctx_in_var _ _ _ _ H3 i);intro.
  destruct (tree_avg_avg2round _ _ _ _ H2) as [_ ?].
  unfold s,share in *. unfold dom.e,share in *. rewrite H4 in H5. inv H5...
  generalize (avg_ctx_not_in_var ctxL ctxR (S h) _ _ n);intro.
  generalize (rR_ctx_not_in_var ctx (S h) _ _ n);intro.
  rewrite H1 in H2. rewrite H3. rewrite H2.
  rewrite decompose_recompose...
 Qed.

 Lemma rL_ctx_iden: forall ctx l n v,
  In v l ->
  |ctx v| < n ->
  rL_ctx ctx n l v =  ctx v.
 Proof with try tauto.
  intros.
  unfold rL_ctx.
  destruct (in_dec eq_dec v l)...
  generalize (tree_round_left_identity _ _ H0);intro.
  unfold s,share in *.
  unfold dom.e,share in *. rewrite H1...
 Qed.

 Lemma rR_ctx_iden: forall ctx l n v,
  In v l ->
  |ctx v| < n ->
  rR_ctx ctx n l v =  ctx v.
 Proof with try tauto.
  intros.
  unfold rR_ctx.
  destruct (in_dec eq_dec v l)...
  generalize (tree_round_right_identity _ _ H0);intro.
  unfold s,share in *.
  unfold dom.e,share in *. rewrite H1...
 Qed.

 Lemma avg_ctx_iden: forall ctx n v l,
  In v l ->
  |ctx v| < n ->
  avg_ctx ctx ctx n l v = ctx v.
 Proof with try tauto.
  intros.
  unfold avg_ctx.
  destruct (in_dec eq_dec v l)...
  apply tree_avg_identity in H0.
  unfold s,share in *.
  unfold dom.e,share in *. rewrite H0...
 Qed.

 Lemma rLR_avg_ctx: forall ctxL ctxR v l n,
  |ctxL v| < n ->
  |ctxR v| < n ->
  rL_ctx (avg_ctx ctxL ctxR n l) n l v = ctxL v /\
  rR_ctx (avg_ctx ctxL ctxR n l) n l v = ctxR v.
 Proof.
  intros.
  unfold avg_ctx,rL_ctx,rR_ctx.
  destruct (in_dec eq_dec v l).
  destruct (tree_avg_ex _ _ _ H H0).
  unfold s,share in *.
  unfold dom.e,share in *. rewrite H1.
  apply tree_avg_avg2round in H1.
  destruct H1.
  rewrite H1,H2. split;trivial.
  repeat rewrite decompose_recompose.
  split;trivial.
 Qed.

 Lemma avg_ctx_in_obj_eval: forall l obj h ctxL ctxR,
  sublist (vars obj) l ->
  |obj| < h ->
  cheight ctxL l < h ->
  cheight ctxR l < h ->
  avg h (get ctxL obj) (get ctxR obj) = Some (get (avg_ctx ctxL ctxR h l) obj).
 Proof with auto.
  intros. icase h. omega.
  destruct obj.
  assert (In v l). apply H. left...
  apply avg_ctx_in_var with (l:=l)...
  rewrite cheight_lt_rewrite in H1. apply H1...
  rewrite cheight_lt_rewrite in H2. apply H2...
  apply tree_avg_identity. simpl in *...
 Qed.

End Round_Average.

Module SAT_Base (sv : SV)
                (Import es : EQUATION_SYSTEM sv with Module dom := Share_Domain)
                (Import esf : SYSTEM_FEATURES sv es).

 Module RA := Round_Average sv es esf.
 Import RA.

 Definition SAT_avg_ctx_eval_spec
  (A : Type) `{heightable A} `{evalable context A}
  `{varsable A var} `{cheightable context A}:=
  forall ctxL ctxR l n (a : A),
  sublist (vars a) l -> |a| < n ->
  cheight ctxL l < n -> cheight ctxR l < n ->
  ctxL |= a -> ctxR |= a ->
  avg_ctx ctxL ctxR n l |= a.

 Class avg_ctx_SAT_prop (A : Type)
  `{heightable A} `{evalable context A}
  `{varsable A var} `{cheightable context A} := Avg_ctx_SAT_prop {
   SAT_avg_eval: SAT_avg_ctx_eval_spec A
 }.

 Instance SAT_avg_ctx_eql: avg_ctx_SAT_prop equality.
 Proof with try tauto.
  constructor.
  repeat intro.
  destruct a as [o1 o2].
  simpl in H,H0,H1,H2.
  rewrite sublist_app_iff in H.
  rewrite Nat.max_lub_lt_iff in H0.
  destruct H. destruct H0.
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H H0 H1 H2);intro.
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H5 H6 H1 H2);intro.
  simpl in *.
  rewrite H3,H4 in H7.
  rewrite H7 in H8. inv H8...
 Qed.

 Instance SAT_avg_ctx_eqn: avg_ctx_SAT_prop equation.
 Proof with try tauto.
  constructor.
  repeat intro.
  destruct a as [[o1 o2] o3].
  simpl in H,H0.
  repeat rewrite sublist_app_iff in H.
  repeat rewrite Nat.max_lub_lt_iff in H0.
  destruct H as [? [? ?]].
  destruct H0 as [[? ?] ?].
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H H0 H1 H2);intro.
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H5 H7 H1 H2);intro.
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H6 H8 H1 H2);intro.
  simpl in *...
  eapply tree_avg_join.
  apply H9. apply H10. apply H11. apply H3. apply H4.
 Qed.

 Instance SAT_avg_ctx_var : avg_ctx_SAT_prop var.
 Proof with try tauto.
  constructor.
  repeat intro.
  unfold avg_ctx in H5.
  assert (In a l). apply H. left...
  icase (in_dec eq_dec a l).
  icase n. omega.
  rewrite cheight_lt_rewrite in H1.
  rewrite cheight_lt_rewrite in H2.
  spec H1 a i. spec H2 a i.
  destruct (tree_avg_ex _ _ _ H1 H2).
  unfold s,share in *. unfold dom.e,share in *. rewrite H7 in H5.
  generalize (tree_avg_nonzero _ _ _ _ H7);intro.
  apply H8...
 Qed.

 Instance SAT_avg_ctx_list {A} `{avg_ctx_SAT_prop A} : avg_ctx_SAT_prop (list A).
 Proof with try tauto.
  constructor.
  induction a;intros...
  simpl in H4. rewrite sublist_app_iff in H4.
  destruct H4.
  destruct H8. destruct H9.
  rewrite height_rewrite in H5.
  rewrite Nat.max_lub_lt_iff in H5.
  destruct H5.
  generalize (IHa H10 H13 H6 H7 H8 H9);intro.
  split...
  apply H3...
 Qed.

 Instance SAT_avg_ctx_ses: avg_ctx_SAT_prop sat_equation_system.
 Proof with try tauto.
  constructor.
  repeat intro.
  destruct a as [l1 l2 l3].
  simpl in *.
  repeat rewrite sublist_app_iff in H. destruct H as [? [? ?]].
  unfold ses_h in H0. simpl in H0.
  rewrite Nat.max_lub_lt_iff in H0.
  destruct H0.
  unfold eval_sat_equation_system in *. simpl in *.
  destruct H3 as [? [? ?]].
  destruct H4 as [? [? ?]].
  split.
  generalize (SAT_avg_eval ctxL ctxR l n l2 H5 H0 H1 H2 H3 H4);intro.
  apply H12.
  split.
  generalize (SAT_avg_eval ctxL ctxR l n l3 H6 H7 H1 H2 H8 H10);intro.
  apply H12.
  assert (|l1| = 0). clear. induction l1...
  assert (|l1| < n) by omega.
  assert (l1 = vars l1).
   clear. induction l1... simpl. f_equal...
  rewrite H14 in H.
  generalize (SAT_avg_eval ctxL ctxR l n l1 H H13 H1 H2 H9 H11);intro.
  apply H15.
 Qed.

 Lemma SAT_nzvars_correct1: forall l ses,
  l <> nil ->
  (forall v, In v l -> sSAT ses v) ->
  SAT (replace_snzvars ses l).
 Proof with try tauto.
  induction l;intros...
  destruct (list_eq_dec eq_dec l nil). subst.
  apply H0. left...
  spec IHl ses n.
  destruct IHl.
  intros. apply H0. right...
  spec H0 a. destruct H0. left...
  remember (replace_snzvars ses (a::l)) as ses'.
  remember (S (max (max (cheight x0 (vars ses'))(cheight x (vars ses'))) (|replace_snzvars ses' nil|))) as h.
  exists (avg_ctx x x0 h (vars ses')).
  rewrite replace_snzvars_nil_eval.
  rewrite replace_snzvars_nil_eval in H0,H1.
  destruct H0. destruct H1.
  rewrite replace_snzvars_reduce in H0.
  rewrite replace_snzvars_reduce in H1.
  rewrite Heqses'.
  rewrite replace_snzvars_reduce. rewrite<- Heqses'.
  assert (max (max (cheight x0 (vars ses')) (cheight x (vars ses'))) (|replace_snzvars ses' nil|) < h) by omega.
  repeat rewrite Nat.max_lub_lt_iff in H4.
  destruct H4 as [[? ?] ?].
  assert (sublist (vars (replace_snzvars ses' nil)) (vars ses')).
   clear. repeat intro...
   destruct ses' as [l1 l2 l3]. simpl in *.
   rewrite in_app_iff in H.
   repeat rewrite in_app_iff...
  assert (replace_snzvars ses nil = replace_snzvars ses' nil).
   rewrite Heqses'. rewrite replace_snzvars_reduce...
  rewrite H8 in H1,H0.
  split.
  generalize (SAT_avg_eval _ _ _ _ _ H7 H6 H5 H4 H1 H0);intro.
  rewrite H8. apply H9.
  assert (sat_nzvars ses' = a::l).
   rewrite Heqses'. rewrite replace_snzvars_correct...
  rewrite H9.
  rewrite replace_snzvars_correct in H2.
  rewrite replace_snzvars_correct in H3.
  assert (sublist (a::l) (vars ses')).
   clear -H9. destruct ses' as [l1 l2 l3].
   simpl in *. subst.
   repeat intro. repeat rewrite in_app_iff.
   left...
  assert (x0 |= a). destruct  H2...
  clear -H3 H4 H5 H10 H11.
  rewrite list_eval_rewrite in H3.
  rewrite list_eval_rewrite. intros.
  assert (In e (vars ses')) by (apply H10;tauto).
  unfold eval,eval_nzvars.
  icase h. omega.
  rewrite cheight_lt_rewrite in H4.
  rewrite cheight_lt_rewrite in H5.
  spec H4 e H0. spec H5 e H0.
  generalize (avg_ctx_in_var _ _ _ _ _ H5 H4 H0);intro.
  apply tree_avg_nonzero in H1.
  apply H1. destruct H. subst.
  right. apply H11. left. apply H3...
 Qed.

End SAT_Base.

Module IMPL_Base (sv : SV)
                 (Import es : EQUATION_SYSTEM sv with Module dom := Share_Domain)
                 (Import esf : SYSTEM_FEATURES sv es).

 Require Import Classical.
 Import ClassicalProps.
 Module SB := SAT_Base sv es esf.
 Import SB.
 Module RA := Round_Average sv es esf.
 Import RA.

 Definition equiv_ctx:= fun (l : list var) (ctx ctx' : context) =>
  forall v, In v l -> ctx v = ctx' v.

 Definition eval_equiv_spec (A : Type) `{varsable A var} `{evalable context A}:=
  forall (a : A) ctx ctx',
  equiv_ctx (vars a) ctx ctx' ->
  (ctx |= a <-> ctx' |= a).

 Class eval_equiv_prop (A : Type) `{varsable A var} `{evalable context A} :=
  Eval_equiv_prop {
   eval_equiv: eval_equiv_spec A
 }.

 Lemma equiv_ctx_app_iff : forall ctx ctx' l l',
  equiv_ctx (l++l') ctx ctx' <-> equiv_ctx l ctx ctx' /\ equiv_ctx l' ctx ctx'.
 Proof with try tauto.
  intros.
  unfold equiv_ctx.
  split;intros.
  split;intros; apply H;rewrite in_app_iff...
  rewrite in_app_iff in H0.
  destruct H. destruct H0.
  apply H... apply H1...
 Qed.

 Lemma eval_equiv_prop_obj: forall (obj:object) ctx ctx',
  equiv_ctx (vars obj) ctx ctx' ->
  get_obj_val ctx obj = get_obj_val ctx' obj.
 Proof.
  intros. icase obj. simpl.
  apply H. left. trivial.
 Qed.

 Instance eval_equiv_prop_var: eval_equiv_prop var.
 Proof.
 constructor. repeat intro.
 spec H a. detach H. simpl. rewrite H. tauto.
 left. trivial.
 Qed.

 Instance eval_equiv_prop_eql: eval_equiv_prop equality.
 Proof.
 constructor. repeat intro.
 destruct a as [o1 o2].
 simpl in *.
 rewrite equiv_ctx_app_iff in H.
 destruct H.
 generalize (eval_equiv_prop_obj _ _ _ H);intro.
 generalize (eval_equiv_prop_obj _ _ _ H0);intro.
 unfold s in *.
 rewrite H1. rewrite H2. tauto.
 Qed.

 Instance eval_equiv_prop_eqn: eval_equiv_prop equation.
 Proof.
 constructor. repeat intro.
 destruct a as [[o1 o2] o3].
 simpl in H. repeat rewrite equiv_ctx_app_iff in H.
 destruct H as [? [? ?]].
 generalize (eval_equiv_prop_obj _ _ _ H);intro.
 generalize (eval_equiv_prop_obj _ _ _ H0);intro.
 generalize (eval_equiv_prop_obj _ _ _ H1);intro.
 simpl. unfold s in *.
 rewrite H2,H3,H4. tauto.
 Qed.

 Instance eval_equiv_prop_list {A} `{eval_equiv_prop A} : eval_equiv_prop (list A).
 Proof with try tauto.
 constructor. induction a;intros.
 simpl...
 simpl in H2. rewrite equiv_ctx_app_iff in H2.
 destruct H2.
 generalize (IHa _ _ H3);intro.
 generalize (eval_equiv _ _ _ H2);intro.
 simpl in *. tauto.
 Qed.

 Instance eval_equiv_prop_ses : eval_equiv_prop sat_equation_system.
 Proof with try tauto.
 constructor. repeat intro.
 destruct a as [l1 l2 l3].
 simpl in H. repeat rewrite equiv_ctx_app_iff in H.
 destruct H as [? [? ?]].
 assert (l1 = vars l1).
  clear.
  induction l1. simpl...
  simpl in *. rewrite<- IHl1...
 rewrite H2 in H.
 generalize (eval_equiv l1 _ _ H);intro.
 generalize (eval_equiv l2 _ _ H0);intro.
 generalize (eval_equiv l3 _ _ H1);intro.
 simpl in *. unfold eval_sat_equation_system;simpl...
 Qed.

 Definition neg_IMPL (is : impl_system) :=
  exists ctx, ctx |= fst is /\ ~ ctx |= snd is.
 Definition neg_sIMPL (is : impl_system) (x y : var) :=
  neg_IMPL (replace_isnzvars is (x::nil) (y::nil)).
 Definition neg_zIMPL (is : impl_system) (y : var) : Prop :=
  neg_IMPL (replace_isnzvars is nil (y::nil)).

 Definition sIMPL_Cond (is : impl_system): Prop :=
  forall y, In y (impl_nzvars (snd is)) ->
  exists x, In x (impl_nzvars (fst is)) /\ sIMPL is x y.
 Definition zIMPL_Cond (is : impl_system) : Prop :=
  forall y, In y (impl_nzvars (snd is)) -> zIMPL is y.
 Definition F (is : impl_system): Prop :=
  forall y, In y (impl_nzvars (snd is)) ->
  IMPL (replace_isnzvars is (impl_nzvars (fst is)) (y::nil)).
 Definition neg_sIMPL_Cond (is : impl_system): Prop :=
  exists y, In y (impl_nzvars (snd is)) /\
  (forall x, In x (impl_nzvars (fst is)) -> ~sIMPL is x y).

 Lemma neg_sIMPL_Cond_correct: forall is,
  ~sIMPL_Cond is <-> neg_sIMPL_Cond is.
 Proof with try tauto.
  intro is. unfold sIMPL_Cond,neg_sIMPL_Cond.
  split;repeat intro.
  rewrite neg_forall in H.
  destruct H as [y H]. exists y.
  rewrite neg_impl in H.
  split... destruct H.
  rewrite neg_ex in H0...
  repeat intro. spec H0 x. apply H0...
  destruct H as [y [H H1]].
  destruct (H0 y H) as [x [H2 H3]].
  spec H1 x H2...
 Qed.

 Lemma neg_IMPL_correct: forall is,
  ~IMPL is <-> neg_IMPL is.
 Proof.
  intros.
  unfold IMPL,neg_IMPL.
  split;repeat intro.
  rewrite neg_forall in H.
  destruct H as [ctx H]. exists ctx.
  rewrite<- neg_impl. apply H.
  destruct H as [ctx [H1 H2]].
  spec H0 ctx. apply H0 in H1. tauto.
 Qed.

 Lemma neg_sIMPL_correct: forall is x y,
 (~sIMPL is x y) <-> neg_sIMPL is x y.
 Proof.
  intros.
  unfold sIMPL,neg_sIMPL.
  apply neg_IMPL_correct.
 Qed.

 Lemma neg_zIMPL_correct: forall is y,
  ~zIMPL is y <-> neg_zIMPL is y.
 Proof.
  intros.
  unfold zIMPL,neg_zIMPL,IMPL,neg_IMPL.
  split;repeat intro.
  rewrite neg_forall in H.
  destruct H as [ctx H]. exists ctx.
  rewrite<- neg_impl. apply H.
  destruct H as [ctx [H1 H2]].
  spec H0 ctx. apply H0 in H1. tauto.
 Qed.

 Definition IMPL_avg_ctx_eval_spec
  (A : Type) `{heightable A} `{evalable context A}
  `{varsable A var} `{cheightable context A}:=
  forall ctxL ctxR l n (a : A),
  sublist (vars a) l -> |a| < n ->
  cheight ctxL l < n -> cheight ctxR l < n ->
  avg_ctx ctxL ctxR n l |= a ->
  ctxL |= a /\ ctxR |= a.

 Class avg_ctx_IMPL_prop (A : Type)
  `{heightable A} `{evalable context A}
  `{varsable A var} `{cheightable context A} := Avg_ctx_IMPL_prop {
   IMPL_avg_eval: IMPL_avg_ctx_eval_spec A
 }.

 Instance IMPL_avg_ctx_eql: avg_ctx_IMPL_prop equality.
 Proof with try tauto.
 constructor.
 repeat intro.
 destruct a as [o1 o2].
 simpl in H,H0,H1,H2.
 rewrite sublist_app_iff in H.
 rewrite Nat.max_lub_lt_iff in H0.
 destruct H. destruct H0.
 generalize (avg_ctx_in_obj_eval _ _ _ _ _ H H0 H1 H2);intro.
 generalize (avg_ctx_in_obj_eval _ _ _ _ _ H4 H5 H1 H2);intro.
 simpl in *.
 rewrite H3 in H6.
 apply tree_avg_avg2round in H6.
 apply tree_avg_avg2round in H7.
 simpl in *. destruct H6. destruct H7.
 rewrite H6 in H7. rewrite H8 in H9.
 inv H7. inv H9...
 Qed.

 Instance IMPL_avg_ctx_eqn: avg_ctx_IMPL_prop equation.
 Proof with try tauto.
  constructor.
  repeat intro.
  destruct a as [[o1 o2] o3].
  simpl in H,H0.
  repeat rewrite sublist_app_iff in H.
  repeat rewrite Nat.max_lub_lt_iff in H0.
  destruct H as [? [? ?]].
  destruct H0 as [[? ?] ?].
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H H0 H1 H2);intro.
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H4 H6 H1 H2);intro.
  generalize (avg_ctx_in_obj_eval _ _ _ _ _ H5 H7 H1 H2);intro.
  apply tree_avg_avg2round in H8.
  apply tree_avg_avg2round in H9.
  apply tree_avg_avg2round in H10.
  destruct H8. destruct H9. destruct H10.
  generalize (tree_round_left_join _ _ _ _ _ _ _ H3 H8 H9 H10);intro.
  generalize (tree_round_right_join _ _ _ _ _ _ _ H3 H11 H12 H13);intro...
 Qed.

 Instance IMPL_avg_ctx_list {A} `{avg_ctx_IMPL_prop A} : avg_ctx_IMPL_prop (list A).
 Proof with try tauto.
  constructor.
  induction a;intros...
  simpl in H4. rewrite sublist_app_iff in H4.
  destruct H4. destruct H8.
  rewrite height_rewrite in H5.
  rewrite Nat.max_lub_lt_iff in H5.
  destruct H5.
  generalize (IHa H9 H11 H6 H7 H8);intro.
  split; split;
  try apply H3 with (ctxL:=ctxL)(ctxR:=ctxR)(l:=l)(n:=n)...
 Qed.

 Lemma IMPL_avg_ctx_list_var: forall L l l' ctxL ctxR n,
  ctxL |= l -> ctxR |= l' ->
  sublist l L -> sublist l' L ->
  cheight ctxL L < n -> cheight ctxR L < n ->
  avg_ctx ctxL ctxR n L |= (l++l').
 Proof with try tauto.
  intros.
  rewrite list_eval_rewrite. intros.
  rewrite list_eval_rewrite in H.
  rewrite list_eval_rewrite in H0.
  icase n. omega.
  rewrite cheight_lt_rewrite in H3.
  rewrite cheight_lt_rewrite in H4.
  rewrite in_app_iff in H5.
  assert (In e L). destruct H5. apply H1... apply H2...
  spec H3 e H6. spec H4 e H6.
  simpl.
  rewrite tree_avg_nonzero with (sL:=ctxL e) (sR:=ctxR e) (n:=S n)...
  destruct H5. left. apply H... right. apply H0...
  apply avg_ctx_in_var...
 Qed.

 Lemma IMPL_avg_ctx_ses: forall ctxL ctxR l n (ses : sat_equation_system),
  sublist (vars (replace_snzvars ses nil)) l ->
  |(replace_snzvars ses nil)| < n ->
  cheight ctxL l < n -> cheight ctxR l < n ->
  avg_ctx ctxL ctxR n l |= (replace_snzvars ses nil) ->
  ctxL |= (replace_snzvars ses nil) /\ ctxR |= (replace_snzvars ses nil).
 Proof with try tauto.
  intros.
  destruct ses as [l1 l2 l3].
  simpl in *. unfold ses_h in H0. simpl in *.
  rewrite sublist_app_iff in H.
  rewrite Nat.max_lub_lt_iff in H0.
  destruct H3 as [? [? ?]]. simpl in *.
  destruct H. destruct H0.
  generalize (IMPL_avg_eval ctxL ctxR l n l2 H H0 H1 H2 H3);intro.
  generalize (IMPL_avg_eval ctxL ctxR l n l3 H6 H7 H1 H2 H4);intro.
  split; split...
 Qed.

 Lemma ses_single_nzvar: forall (ses : sat_equation_system) n ctx v l,
  sat_nzvars ses = v ::nil ->
  |ses| < n ->
  sublist (vars ses) l ->
  le (cheight ctx l) n ->
  ctx |= ses ->
  rL_ctx ctx n l |= ses \/ rR_ctx ctx n l |= ses.
 Proof with try tauto.
  intros.
  rewrite replace_snzvars_nil_eval in H3.
  rewrite H in H3.
  destruct H3.
  assert (ctx v <> emptyshare).
   destruct H4. apply H5. clear H4.
  remember (rL_ctx ctx n l) as ctxL.
  remember (rR_ctx ctx n l) as ctxR.
  symmetry in HeqctxL,HeqctxR.
  icase n. omega.
  generalize (round_avg_ctx _ _ _ _ _ H2 HeqctxL HeqctxR);intro.
  assert (In v l).
   apply H1. destruct ses as [l1 l2 l3]. simpl.
   simpl in H. rewrite H. rewrite in_app_iff.
   left. left. tauto.
  assert (ctxL v <> emptyshare \/ ctxR v <> emptyshare).
    rewrite<- tree_avg_nonzero. apply H5.
    rewrite cheight_leq_rewrite in H2. spec H2 v H6.
    generalize (rL_ctx_in_var _ _ _ _ H2 H6);intro.
    generalize (rR_ctx_in_var _ _ _ _ H2 H6);intro.
    generalize (rL_ctx_lt _ _ _ _ H2 H6);intro.
    generalize (rR_ctx_lt _ _ _ _ H2 H6);intro.
    rewrite HeqctxL in H7,H9.
    rewrite HeqctxR in H8,H10.
    generalize (avg_ctx_in_var _ _ _ _ _ H9 H10 H6);intro.
    rewrite H4 in H11.
    apply H11.
  rewrite <- H4 in H3.
  apply IMPL_avg_ctx_ses in H3... destruct H3.
  destruct H7.
  left. rewrite replace_snzvars_nil_eval.
  split... rewrite H. split... simpl...
  right. rewrite replace_snzvars_nil_eval.
  split... rewrite H. split... simpl...
  repeat intro. apply H1.
  destruct ses as [l1 l2 l3]. simpl;simpl in H8.
  rewrite in_app_iff. right...
  rewrite cheight_lt_rewrite.
  rewrite cheight_leq_rewrite in H2.
  intros. spec H2 v0 H8.
  rewrite <-HeqctxL. apply rL_ctx_lt...
  rewrite cheight_lt_rewrite.
  rewrite cheight_leq_rewrite in H2.
  intros. spec H2 v0 H8.
  rewrite <-HeqctxR. apply rR_ctx_lt...
 Qed.

 Lemma override_eval_height: forall (ses:sat_equation_system) ctx ctx' l l' v,
  sat_nzvars ses = v::nil ->
  [l => ctx']ctx |= ses ->
  sublist l l' ->
  exists ctx'', (cheight ctx'' l' <= max (cheight ctx ((vars ses)++l')) (|ses|))%nat /\
  [l => ctx'']ctx |= ses.
 Proof with try tauto.
  do 6 intro.
  assert (exists m, le (cheight ctx' l') m). apply exists_le.
  destruct H as [m H].
  revert H. revert ctx'. induction m;intros.
  exists ctx'. split... omega.
  destruct (le_dec (cheight ctx' l') (max (cheight ctx ((vars ses)++l')) (|ses |))).
  exists ctx'. split...
  assert (max (cheight ctx ((vars ses)++l')) (|ses|) < cheight ctx' l') by omega.
  clear n. rewrite Nat.max_lub_lt_iff in H3. destruct H3.
  generalize (ses_single_nzvar _ _ ([l => ctx']ctx) _ ((vars ses)++l') H0 H4);intro.
  repeat detach H5... destruct H5.

  apply IHm with (rL_ctx ctx' (cheight ctx' l') (vars ses ++ l'))...
  rewrite cheight_leq_rewrite. intros.
  assert (le (|ctx' v0|) (cheight ctx' l')).
  eapply cheight_leq_rewrite. apply le_refl. tauto.
  icase (cheight ctx' l'). omega.
  generalize (rL_ctx_lt _ _ _ _ H7 H6);intro.
  generalize (rL_ctx_in_var _ _ _ _ H7 H6);intro.
  assert (In v0 (vars ses ++ l')).
   rewrite in_app_iff. right...
  generalize (rL_ctx_in_var _ _ _ _ H7 H10);intro.
  rewrite H9 in H11. inv H11.
  simpl. rewrite <-H13. simpl in *;omega.
  rewrite rL_ctx_override in H5.
  eapply eval_equiv. Focus 2. apply H5.
  repeat intro.
  destruct (in_dec eq_dec v0 l).
  repeat rewrite override_in...
  repeat rewrite override_not_in...
  rewrite rL_ctx_iden...
  rewrite in_app_iff...
  icase (cheight ctx' l'). omega.
  rewrite cheight_lt_rewrite in H3. apply H3.
  rewrite in_app_iff...

  apply IHm with (rR_ctx ctx' (cheight ctx' l') (vars ses ++ l'))...
  rewrite cheight_leq_rewrite. intros.
  assert (le (|ctx' v0|) (cheight ctx' l')).
  eapply cheight_leq_rewrite. apply le_refl. tauto.
  icase (cheight ctx' l'). omega.
  generalize (rR_ctx_lt _ _ _ _ H7 H6);intro.
  generalize (rR_ctx_in_var _ _ _ _ H7 H6);intro.
  assert (In v0 (vars ses ++ l')).
   rewrite in_app_iff. right...
  generalize (rR_ctx_in_var _ _ _ _ H7 H10);intro.
  rewrite H9 in H11. inv H11.
  simpl. rewrite <-H13. simpl in *;omega.
  rewrite rR_ctx_override in H5.
  eapply eval_equiv. Focus 2. apply H5.
  repeat intro.
  destruct (in_dec eq_dec v0 l).
  repeat rewrite override_in...
  repeat rewrite override_not_in...
  rewrite rR_ctx_iden...
  rewrite in_app_iff...
  icase (cheight ctx' l'). omega.
  rewrite cheight_lt_rewrite in H3. apply H3.
  rewrite in_app_iff...

  rewrite cheight_leq_rewrite. intros.
  rewrite in_app_iff in H5. destruct H5.
  destruct (in_dec eq_dec v0 l).
  rewrite override_in...
  assert ((cheight ctx' l' <= cheight ctx' l')%nat) by omega.
  rewrite cheight_leq_rewrite in H6. apply H6.
  apply H2...
  rewrite override_not_in...
  icase (cheight ctx' l'). omega.
  rewrite cheight_lt_rewrite in H3.
  spec H3 v0. detach H3. omega.
  rewrite in_app_iff. left...
  destruct (in_dec eq_dec v0 l).
  rewrite override_in...
  eapply cheight_leq_rewrite...
  apply le_refl. tauto.
  rewrite override_not_in...
  icase (cheight ctx' l'). omega.
  rewrite cheight_lt_rewrite in H3.
  spec H3 v0. detach H3. omega.
  rewrite in_app_iff. right...
  repeat intro. rewrite in_app_iff. left...
 Qed.

 Lemma rLR_ctx_eval: forall (n : nat) ctx l (ses : sat_equation_system),
  sat_nzvars ses = nil ->
  ctx |= ses ->
  |ses| < n ->
  le (cheight ctx l) n ->
  sublist (vars ses) l ->
  rL_ctx ctx n l |= ses /\ rR_ctx ctx n l |= ses.
 Proof with try tauto.
  intros.
  assert (replace_snzvars ses nil = ses).
   rewrite<-H. rewrite replace_snzvars_id...
  rewrite<-H4 in *.
  icase n;try omega.
  remember (rL_ctx ctx (S n) l) as ctxL.
  remember (rR_ctx ctx (S n) l) as ctxR.
  symmetry in HeqctxL,HeqctxR.
  generalize (round_avg_ctx _ _ _ _ _ H2 HeqctxL HeqctxR);intro.
  rewrite <-H5 in H0.
  rewrite cheight_leq_rewrite in H2.
  apply IMPL_avg_ctx_ses with (l:=l)(n:=S n)...
  rewrite cheight_lt_rewrite. intros.
  subst ctxL. apply rL_ctx_lt... apply H2...
  rewrite cheight_lt_rewrite. intros.
  subst ctxR. apply rR_ctx_lt... apply H2...
 Qed.

 Lemma override_eval_height_2: forall (ses:sat_equation_system) ctx ctx' l l',
  sat_nzvars ses = nil ->
  [l => ctx']ctx |= ses ->
  sublist l l' ->
  exists ctx'', (cheight ctx'' l' <= max (cheight ctx ((vars ses)++l')) (|ses|))%nat /\
  [l => ctx'']ctx |= ses.
 Proof with try tauto.
  do 6 intro.
  assert (exists m, le (cheight ctx' l') m). apply exists_le.
  destruct H0 as [m H0].
  revert H0. revert ctx'. induction m;intros.
  exists ctx'. split... omega.
  destruct (le_dec (cheight ctx' l') (max (cheight ctx ((vars ses)++l')) (|ses |))).
  exists ctx'. split...
  assert (max (cheight ctx ((vars ses)++l')) (|ses|) < cheight ctx' l') by omega.
  clear n. rewrite Nat.max_lub_lt_iff in H3. destruct H3.
  assert (le (cheight ([l => ctx']ctx) (vars ses ++ l'))  (cheight ctx' l') ).
   rewrite cheight_leq_rewrite;intros.
   destruct (in_dec eq_dec v l).
   rewrite override_in...
   eapply cheight_leq_rewrite. apply le_refl. apply H2...
   rewrite override_not_in...
   icase (cheight ctx' l'). omega.
   rewrite cheight_lt_rewrite in H3.
   spec H3 v. detach H3... omega.
  assert (sublist (vars ses) (vars ses ++ l')).
   repeat intro. rewrite in_app_iff...
  destruct (rLR_ctx_eval _ _ _ _ H H1 H4 H5 H6) as [H7 _].
  apply IHm with (ctx':=rL_ctx ctx' (cheight ctx' l') (vars ses++l'))...
  rewrite cheight_leq_rewrite;intros.
  assert (le (|ctx' v|) (cheight ctx' l')).
  eapply cheight_leq_rewrite. apply le_refl. apply H8.
  icase (cheight ctx' l'). omega.
  apply rL_ctx_lt with (l:=vars ses ++l')in H9... omega.
  rewrite in_app_iff...
  rewrite rL_ctx_override in H7.
  eapply eval_equiv. Focus 2. apply H7.
  repeat intro.
  destruct (in_dec eq_dec v l).
  repeat rewrite override_in...
  repeat rewrite override_not_in...
  symmetry. apply rL_ctx_iden...
  rewrite in_app_iff...
  icase (cheight ctx' l'). omega.
  rewrite cheight_lt_rewrite in H3.
  spec H3 v. detach H3. omega.
  rewrite in_app_iff...
 Qed.

 Lemma IMPL_F_equiv: forall is,
 (impl_nzvars (snd is) <> nil) ->
 (IMPL is <-> F is).
 Proof with try tauto.
  intros.
  split. repeat intro.
  destruct is as [ies1 ies2].
  rewrite fst_replace_isnzvars in H2.
  rewrite snd_replace_isnzvars.
  spec H0 rho. apply H0 in H2.
  rewrite replace_inzvars_nil_eval in H2.
  rewrite replace_inzvars_nil_eval.
  destruct H2 as [ctx [H2 H3]].
  exists ctx. simpl in *.
  split... split...
  eapply list_eval_rewrite in H1. apply H1. apply H3.

  remember (impl_nzvars (snd is)) as l.
  revert Heql. revert is.
  induction l;intros. tauto.
  generalize (H0 a);intro.
  assert (In a (impl_nzvars (snd is))).
   rewrite<- Heql. left...
  spec H1 H2.
  destruct (list_eq_dec eq_dec l nil). subst. intros ctx H3.
  spec H0 a. detach H0.
  Focus 2. rewrite <-Heql. left...
  spec H0 ctx.
  rewrite replace_isnzvars_eval in H0.
  rewrite replace_inzvars_id in H0.
  spec H0 H3.
  rewrite Heql in H0.
  rewrite replace_inzvars_id in H0...
  spec IHl n (replace_isnzvars is (impl_nzvars (fst is)) l).
  detach IHl. detach IHl.
  intros ctx H3.
  spec H1 ctx. spec IHl ctx.
  rewrite replace_isnzvars_eval in H1,IHl.
  rewrite replace_inzvars_id in H1,IHl.
  spec H1 H3. spec IHl H3.
  destruct H1 as [ctx1 H1].
  destruct IHl as [ctx2 IHl].
  rewrite replace_inzvars_exvars in *.
  rewrite replace_inzvars_ies2ses in *.
  assert (exists n, max (|(snd is)|)
  (max (cheight ([impl_exvars (snd is) => ctx1]ctx) (vars (snd is)))
       (cheight ([impl_exvars (snd is) => ctx2]ctx) (vars (snd is)))) < n) by apply exist_lt.
  destruct H4 as [m H4].
  repeat rewrite Nat.max_lub_lt_iff in H4.
  destruct H4 as [? [? ?]].
  rewrite replace_snzvars_nil_eval in H1,IHl.
  rewrite replace_snzvars_reduce in *.
  rewrite replace_snzvars_correct in *.
  destruct H1 as [H7 H8].
  destruct IHl as [H9 H10].
  assert (sublist (vars (replace_snzvars (ies2ses (snd is)) nil)) (vars (snd is))).
   repeat intro.
   destruct (snd is) as [l1 l2 l3 l4]. simpl in *.
   rewrite in_app_iff. right. rewrite in_app_iff...
  generalize (SAT_avg_eval _ _ _ _ _ H1 H4 H5 H6 H7 H9);intro H11.
  rewrite avg_override in H11.
  exists (avg_ctx ctx1 ctx2 m (vars (snd is))).
  rewrite replace_snzvars_nil_eval.
  split.
  eapply eval_equiv. Focus 2. apply H11.
  repeat intro.
  destruct (in_dec eq_dec v (impl_exvars (snd is))).
  repeat rewrite override_in...
  repeat rewrite override_not_in...
  symmetry. apply avg_ctx_iden.
  apply H1...
  icase m. omega.
  rewrite cheight_lt_rewrite in H5.
  spec H5 v. rewrite override_not_in in H5...
  apply H5. apply H1...

  (*Eval list*)
  assert (sat_nzvars (ies2ses (snd is)) = a ::l).
   clear - Heql. destruct (snd is) as [l1 l2 l3 l4].
   simpl in *. rewrite Heql...
  rewrite H12.
  assert (sublist (a::l) (vars (snd is))).
   clear - Heql. destruct (snd is) as [l1 l2 l3 l4].
  simpl in *. subst.
  repeat intro.
  rewrite in_app_iff. right. rewrite in_app_iff. left...
  generalize (IMPL_avg_ctx_list_var (vars (snd is)) _ _ _ _ m H8 H10);intro H14.
  repeat detach H14...
  rewrite avg_override in H14.
  eapply eval_equiv in H14. apply H14.
  repeat intro.
  destruct (in_dec eq_dec v (impl_exvars (snd is))).
  repeat rewrite override_in...
  repeat rewrite override_not_in...
  symmetry. apply avg_ctx_iden...
  apply H13.
  simpl in H15. destruct H15. left...
  right. rewrite<- vars_var_list. simpl...
  icase m. omega.
  rewrite cheight_lt_rewrite in H5.
  spec H5 v. detach H5. rewrite override_not_in in H5...
  apply H13.
  simpl in H15. destruct H15. left...
  right. rewrite<- vars_var_list. simpl...
  repeat intro. apply H13. right...
  repeat intro. apply H13. left. destruct H14...

  repeat intro.
  repeat rewrite fst_replace_isnzvars in *.
  repeat rewrite snd_replace_isnzvars in *.
  repeat rewrite replace_inzvars_reduce in *.
  rewrite replace_inzvars_correct in *.
  rewrite replace_inzvars_id in *.
  spec H0 y. detach H0. spec H0 rho.
  rewrite replace_isnzvars_eval in H0.
  rewrite replace_inzvars_id in *.
  apply H0...
  rewrite<-Heql. right...
  destruct is as [ies1 ies2]. simpl...
 Qed.

 Lemma neg_sIMPL_combine: forall l is y,
  l <> nil ->
  (forall x, In x l -> neg_sIMPL is x y) ->
  neg_IMPL (replace_isnzvars is l (y::nil)).
 Proof with try tauto.
  induction l;intros...
  generalize (H0 a);intro.
  destruct H1 as [ctx H1]. left...
  destruct (list_eq_dec eq_dec l nil). subst.
  exists ctx...

  (*Pre-processing, very tedious...*)
  spec IHl is y n.
  destruct IHl as [ctx' H2].
  intros. apply H0. right...
  rewrite fst_replace_isnzvars in H1,H2.
  rewrite snd_replace_isnzvars in H1,H2.
  destruct H1 as [H1L H1R]. destruct H2 as [H2L H2R].
  destruct H1L as [ctx1 H1L].
  destruct H2L as [ctx2 H2L].
  rewrite replace_inzvars_ies2ses in H1L,H2L.
  rewrite replace_inzvars_exvars in H1L,H2L.
  remember (impl_exvars (fst is)) as lex1.
  remember (replace_isnzvars is (a::l) (y::nil)) as is'.
  assert (exists m, cheight ctx1 lex1 < m /\ cheight ctx2 lex1 < m /\
                    cheight ctx  (vars is') < m /\ cheight ctx' (vars is') < m /\
                    |replace_isnzvars is (a::l) (y::nil)| < m).
   exists (1 + (cheight ctx1 lex1) + (cheight ctx2 lex1) + ( cheight ctx  (vars is')) +
           (cheight ctx' (vars is')) + (|replace_isnzvars is (a::l) (y::nil)|)). omega.
  destruct H1 as [m [? [? [? [? ?]]]]].
  destruct is as [ies1 ies2]. unfold fst,snd in *.
  unfold replace_isnzvars in H5.
  simpl in H5. unfold is_h in H5.
  rewrite Nat.max_lub_lt_iff in H5. unfold fst,snd in H5.
  destruct H5 as [H5 H6].
  exists (avg_ctx ctx ctx' m (vars is')).

  (*First goal*)
  split. exists (avg_ctx ctx1 ctx2 m (vars is')).
  rewrite<- avg_override.
  assert (impl_exvars (fst is') = impl_exvars ies1 /\
          ies2ses (fst is') = replace_snzvars (ies2ses ies1) (a::l)).
   clear - Heqis'.
   destruct is' as [ies1' ies2']. inv Heqis'.
   simpl. split...
  destruct H7 as [H7 H8]. rewrite H7,H8. clear H7 H8.
  rewrite<- Heqlex1.
  rewrite replace_snzvars_nil_eval in *.
  rewrite replace_snzvars_reduce in *.
  rewrite replace_snzvars_correct in *.
  destruct H1L as [H1L H1L'].
  destruct H2L as [H2L H2L'].
  assert (H7 : cheight ([lex1 => ctx1]ctx) (vars is') < m).
   icase m. omega. rewrite cheight_lt_rewrite.
   repeat intro. destruct (in_dec eq_dec v lex1).
   rewrite override_in...
   rewrite cheight_lt_rewrite in H1. apply H1...
   rewrite override_not_in...
   rewrite cheight_lt_rewrite in H3. apply H3...
  assert (H8 : cheight ([lex1 => ctx2]ctx') (vars is') < m).
   icase m. omega. rewrite cheight_lt_rewrite.
   repeat intro. destruct (in_dec eq_dec v lex1).
   rewrite override_in...
   rewrite cheight_lt_rewrite in H2. apply H2...
   rewrite override_not_in...
   rewrite cheight_lt_rewrite in H4. apply H4...
  split. apply SAT_avg_ctx_ses...
  subst. destruct ies1 as [l1 l2 l3 l4].
  simpl. repeat intro.
  replace (a :: l ++ vars_list l3 ++ vars_list l4) with
  ((a::l)++(vars_list l3)++(vars_list l4)) by tauto.
  repeat rewrite in_app_iff.
  rewrite in_app_iff in H9...
  replace (a::l) with ((a::nil)++l) by tauto.
  apply IMPL_avg_ctx_list_var...
  subst. simpl.
  repeat intro. rewrite in_app_iff. left.
  rewrite in_app_iff. right. left. inv H9...
  subst. simpl.
  repeat intro. rewrite in_app_iff. left.
  rewrite in_app_iff. right. right.
  rewrite in_app_iff. left...

  (*Second goal*)
  intro.
  destruct H7 as [ctx_r H7].
  assert (impl_exvars (snd is') = impl_exvars ies2 /\
          ies2ses (snd is') = replace_snzvars (ies2ses ies2) (y::nil)).
   clear - Heqis'.
   destruct is' as [ies1' ies2']. inv Heqis'.
   simpl. split...
  destruct H8. rewrite H8,H9 in H7. clear H8 H9.
  apply override_eval_height with (v:=y) (l':= vars is') in H7.
  destruct H7 as [ctx'' [H7 H8]].
  icase m. omega.
  assert (H9 : (cheight ctx'' (vars is') <= S m)%nat).
   rewrite Nat.max_le_iff in H7. destruct H7.
   assert ((cheight (avg_ctx ctx ctx' (S m) (vars is')) (vars is') <= S m)%nat).
    rewrite cheight_leq_rewrite.
    intros.
    rewrite avg_ctx_leq... omega.
    rewrite cheight_lt_rewrite in H3. apply H3...
    rewrite cheight_lt_rewrite in H4. apply H4...
    eapply le_trans. apply H7.
    eapply le_trans. Focus 2. apply H9.
    apply cheight_sublist.
    repeat intro. subst is'.
    destruct ies2 as [l1 l2 l3 l4].
    clear - H10.
    simpl in *. rewrite in_app_iff.
    destruct H10. subst. right.
    rewrite in_app_iff. right. left...
    rewrite in_app_iff in H. destruct H.
    right. rewrite in_app_iff. right. right...
    destruct ies1 as [l5 l6 l7 l8]. simpl in *.
    rewrite in_app_iff in H. destruct H. left... right...
   assert (|replace_snzvars (ies2ses ies2) (y :: nil) | = |replace_inzvars ies2 (y :: nil) |) by tauto.
   omega.
  remember (rL_ctx ctx'' (S m) (vars is')) as ctxL.
  remember (rR_ctx ctx'' (S m) (vars is')) as ctxR.
  symmetry in HeqctxL,HeqctxR.
  generalize (round_avg_ctx _ _ _ _ _ H9 HeqctxL HeqctxR);intro.
  rewrite <-H10 in H8.
  rewrite<- avg_override in H8.
  rewrite replace_snzvars_nil_eval in H8.
  rewrite replace_snzvars_reduce,replace_snzvars_correct in H8.
  destruct H8 as [H8L H8R].
  assert (Hy : In y (vars is')).
   subst is'.
   simpl. rewrite in_app_iff. right.
   rewrite in_app_iff. right. left...
  apply IMPL_avg_ctx_ses in H8L...
  assert ([impl_exvars ies2 => ctxL]ctx y <> emptyshare \/
          [impl_exvars ies2 => ctxR]ctx' y <> emptyshare).
   assert (avg_ctx ([impl_exvars ies2 => ctxL]ctx)
        ([impl_exvars ies2 => ctxR]ctx') (S m) (vars is') y <> emptyshare).
    destruct H8R...
   rewrite<- tree_avg_nonzero.
   apply H8.
   apply avg_ctx_in_var...
   destruct (in_dec eq_dec y (impl_exvars ies2)).
   rewrite override_in...
   subst ctxL. apply rL_ctx_lt...
   rewrite cheight_leq_rewrite in H9.
   apply H9...
   rewrite override_not_in...
   rewrite cheight_lt_rewrite in H3.
   apply H3...
   destruct (in_dec eq_dec y (impl_exvars ies2)).
   rewrite override_in...
   subst ctxR. apply rR_ctx_lt...
   rewrite cheight_leq_rewrite in H9.
   apply H9...
   rewrite override_not_in...
   rewrite cheight_lt_rewrite in H4.
   apply H4...
  destruct H8.
  apply H1R.
  exists ctxL.
  rewrite replace_inzvars_exvars.
  rewrite replace_inzvars_ies2ses.
  rewrite replace_snzvars_nil_eval.
  rewrite replace_snzvars_reduce,replace_snzvars_correct.
  split... split... simpl...
  apply H2R.
  exists ctxR.
  rewrite replace_inzvars_exvars.
  rewrite replace_inzvars_ies2ses.
  rewrite replace_snzvars_nil_eval.
  rewrite replace_snzvars_reduce,replace_snzvars_correct.
  split... split... simpl...
  subst is'.
  destruct ies2 as [l1 l2 l3 l4]. simpl.
  repeat intro. rewrite in_app_iff. right.
  rewrite in_app_iff. right. right...
  rewrite cheight_lt_rewrite. intros.
  destruct (in_dec eq_dec v (impl_exvars ies2)).
  rewrite override_in...
  subst ctxL. apply rL_ctx_lt...
  rewrite cheight_leq_rewrite in H9.
  apply H9...
  rewrite override_not_in...
  rewrite cheight_lt_rewrite in H3.
  apply H3...
  rewrite cheight_lt_rewrite. intros.
  destruct (in_dec eq_dec v (impl_exvars ies2)).
  rewrite override_in...
  subst ctxR. apply rR_ctx_lt...
  rewrite cheight_leq_rewrite in H9.
  apply H9...
  rewrite override_not_in...
  rewrite cheight_lt_rewrite in H4.
  apply H4...
  rewrite replace_snzvars_correct...
  subst. repeat intro.
  destruct ies1 as [l1 l2 l3 l4];
  destruct ies2 as [l5 l6 l7 l8].
  simpl in *. repeat rewrite in_app_iff...
 Qed.

 Lemma F_sIMPL_Cond_equiv: forall is,
 (impl_nzvars (fst is) <> nil) ->
 (F is <-> sIMPL_Cond is).
 Proof with try tauto.
  intros. split;intros.
  icase (classic (sIMPL_Cond is)).
  rewrite neg_sIMPL_Cond_correct in H1.
  destruct H1 as [y [H2 H3]].
  spec H0 y H2.
  assert (forall x, In x (impl_nzvars (fst is)) -> neg_sIMPL is x y).
   intros. apply neg_sIMPL_correct. apply H3...
  assert (exists ctx, ctx |= (fst is) /\ ~ctx |= replace_inzvars (snd is) (y::nil)).
   apply neg_sIMPL_combine in H1...
   destruct H1 as [ ctx [H4 H5]].
   rewrite fst_replace_isnzvars in H4.
   rewrite replace_inzvars_id in H4.
   rewrite snd_replace_isnzvars in H5.
   exists ctx...
  destruct H4 as [ctx [H4 H5]].
  spec H0 ctx. destruct H0.
  rewrite fst_replace_isnzvars.
  rewrite replace_inzvars_id...
  elimtype False. apply H5.
  rewrite snd_replace_isnzvars in H0.
  exists x...
  intros y H1 ctx.
  destruct (H0 y H1) as [x [H2 H3]].
  repeat intro.
  rewrite fst_replace_isnzvars in H4.
  rewrite snd_replace_isnzvars.
  assert (ctx |= replace_inzvars (fst is) (x::nil)).
   rewrite replace_inzvars_nil_eval.
   rewrite replace_inzvars_nil_eval in H4.
   destruct H4 as [ctx' [H4 H5]].
   exists ctx'. split...
   rewrite replace_inzvars_id in H5.
   rewrite list_eval_rewrite in H5.
   rewrite replace_inzvars_correct.
   spec H5 x H2. rewrite replace_inzvars_exvars.
   split... simpl...
  spec H3 ctx. destruct H3.
  rewrite fst_replace_isnzvars...
  rewrite snd_replace_isnzvars in H3...
  exists x0...
 Qed.

 Lemma rLR_ctx_eval_ses: forall ses ctx n l,
  sat_nzvars ses = nil ->
  |ses| < n ->
  le (cheight ctx l) n ->
  sublist (vars ses) l ->
  ctx |= ses ->
  (rL_ctx ctx n l |= ses /\ rR_ctx ctx n l |= ses).
 Proof with try tauto.
  intros.
  remember (rL_ctx ctx n l) as ctxL.
  remember (rR_ctx ctx n l) as ctxR.
  icase n. omega.
  symmetry in HeqctxL,HeqctxR.
  generalize (round_avg_ctx _ _ _ _ _ H1 HeqctxL HeqctxR);intro.
  assert (ses = replace_snzvars ses nil).
   rewrite <-H. rewrite replace_snzvars_id...
  rewrite H5. rewrite H5 in H2,H3,H0.
  rewrite<-H4 in H3.
  rewrite cheight_leq_rewrite in H1.
  apply IMPL_avg_ctx_ses with (l:=l)(n:=S n)...
  rewrite<-HeqctxL. rewrite cheight_lt_rewrite. intros.
  apply rL_ctx_lt... apply H1...
  rewrite<-HeqctxR. rewrite cheight_lt_rewrite. intros.
  apply rR_ctx_lt... apply H1...
 Qed.

End IMPL_Base.


Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import ClassicalExtras.
Require Import XPrefix.

(** This file defines the robust preservation of several
    classes of properties *)

(*********************************************************)
(* PROPERTIES                                            *)
(*********************************************************)

Definition RP (P : par src i) (π : prop) :=
  rsat P π -> rsat (P↓) π.

(** *Robust Preservation of Trace Properties *)
Definition RTP := forall (P : par src i) (π : prop), RP P π.

Lemma contra_RP : forall P π,
     RP P π <->
     ((exists C' t', sem tgt (C' [ P ↓ ]) t'  /\ ~ π t') ->
      (exists C t ,  sem src (C [ P ]) t /\ ~ π t)).
Proof.
  intros P π. unfold RP. split; intros H.
  - rewrite contra in H.
    repeat rewrite neg_rsat in H. auto.
  - rewrite contra. repeat rewrite neg_rsat. auto.
Qed.

(** *RObust Preservation of a class of properties*)
Definition RclassP (class : prop -> Prop) (P : par src i) (π : prop) : Prop :=
  class π -> RP P π.

(* RP can be regarded as a monotonic function *)
Lemma RP_monotonic : forall (X Y : prop -> Prop),
    (forall π, Y π -> X π) -> ((forall P π, RclassP X P π) -> (forall P π, RclassP Y P π)).
Proof. unfold RclassP. intros X Y H H0 π P H1. now auto. Qed.

(* big enough classes for RTP *)
Lemma RclassP_sufficient_to_RTP :
  forall (X : prop -> Prop),
    (forall t, X (fun b => b <> t)) -> ((forall P π, RclassP X P π) -> forall P π, RP P π).
Proof.
  intros X Hx Hrxp P π. rewrite contra_RP.
  intros [C' [t [H0 H1]]]. specialize (Hrxp P (fun b => b <> t)).
  unfold RclassP in Hrxp. specialize (Hrxp (Hx t)).
  rewrite contra_RP in Hrxp.
  destruct Hrxp as [C [t' [K0 K1]]]; try now exists C', t.
  exists C, t'. split; try now auto. apply NNPP in K1. now subst.
Qed.

(* RTP is not strictly monotonic *)
Lemma RclassP_not_strict : exists (X Y : prop -> Prop),
    (forall π, Y π -> X π) /\ (exists π, X π /\ ~ Y π) /\
    ((forall P π, RclassP Y P π) -> (forall P π, RclassP X P π)).
Proof.
    exists (fun π => True), (fun π => exists t, (forall b, π b <-> b <> t)).
    split; try now auto.
    split.
    + exists (fun t => False).  split; auto.
      intros [t Heq].  destruct t.
      ++ now apply (Heq (tsilent l)).
      ++ now apply (Heq (tstop l an_endstate)).
      ++ now apply (Heq (tstop nil an_endstate)).
    + unfold RclassP. intros P π H tt.
      eapply (RclassP_sufficient_to_RTP (fun π => exists t, (forall b, π b <-> b <> t)));
        try now auto.
      ++ intros t. now exists t.
Qed.

(** *Robust Preservation of Safety Properties *)

Definition RSP := forall P π, Safety π -> RP P π.

(** *Robust Preservation of Liveness Properties *)

Definition RDP := forall P π, Dense π -> RP P π.

(*********************************************************)
(*   HYPERPROPERTIES                                     *)
(*********************************************************)

(** *Robust Preservation of H: hprop *)

Definition RhP (P : par src i) (H : hprop) :=
  rhsat P H -> rhsat (P ↓) H.

Definition RHP := forall P H, RhP P H.

Lemma contra_RHP (P : par src i) (H : hprop) :
      RhP P H <->
      ((exists C' : ctx tgt (cint i), ~ H (beh (C' [ P ↓ ]))) ->
       (exists C  : ctx src i, ~ H (beh (C [ P ])))).
Proof.
  unfold RhP, rhsat, hsat. split.
  + intros Hr [C' Hc']. rewrite contra in Hr.
    repeat rewrite not_forall_ex_not in Hr.
    destruct Hr as [C Hc]; try now exists C'. now exists C.
  + intros Himp. rewrite contra. repeat rewrite not_forall_ex_not.
    now auto.
Qed.

(** *Robust Preservation of a class of HyperProperties*)
Definition RHclassP (class : hprop -> Prop) (P : par src i) (H : hprop) : Prop :=
  class H -> RhP P H.

Lemma RHP_monotonic : forall (X Y : hprop -> Prop),
    (forall H, Y H -> X H) -> ((forall P H, RHclassP X P H) -> (forall P H, RHclassP Y P H)).
Proof. unfold RclassP. intros X Y H H0 P h H1.
       specialize (H0 P h). unfold RHclassP in *.
       apply H0. firstorder.
Qed.

Lemma RHclassP_sufficient_to_RHP :
  forall (X : hprop -> Prop),
    (forall π, X (fun π' => π' <> π)) -> ((forall P H, RHclassP X P H) -> (forall P H, RhP P H)).
Proof.
  intros X Hx Hrxp P H. rewrite contra_RHP.
  intros [C' Hc']. specialize (Hrxp P (fun μ => μ <> (beh (C' [ P ↓] )))).
  unfold RHclassP in Hrxp. specialize (Hrxp (Hx (beh (C' [ P ↓] )))).
  rewrite contra_RHP in Hrxp.
  destruct Hrxp as [C Hdif]; try now exists C'.
  apply NNPP in Hdif. exists C. now rewrite Hdif.
Qed.

(* RXP <=> R[X]P *)
Lemma robust_lift_lemma : forall (prop_class : prop -> Prop),
    (forall P π, prop_class π -> RP P π) <->
    (forall P h, (class_lift prop_class) h -> RhP P h).
Proof.
  intros class. unfold RP, rhsat, rsat, hsat, sat. split.
  + intros Hrp P h [π [Hclass Heq]] Hpremise Ct.
    specialize (Hrp P π Hclass). unfold lifting, "⊆" in *.
    rewrite Heq in *.
    now firstorder.
  + intros Hrp P π Hclass premise.
    assert (class_lift class (lifting π)) by now exists π.
    specialize (Hrp P (lifting π) H).
    unfold RhP, rhsat, hsat, lifting, "⊆" in *.
    now firstorder.
Qed.

(** *Robust Preservation of Subset Closed HyperProperties *)

Definition RSCHP := forall P H, SSC H -> RhP P H.

(* Robust Preservation of SSC => RPP *)
Lemma RSSCP_RPP : RSCHP -> RTP.
Proof.
  assert ((forall P π, RP P π) <-> (forall P π, (fun _ => True) π -> RP P π)) by firstorder.
  rewrite H. rewrite robust_lift_lemma. intros Hssc P h [π [foo Heq]].
  assert (SSC h).
  { apply SSC_iff. exists (fun μ => (forall t, μ t <-> π t)).
    intros μ. rewrite Heq. unfold lifting, "⊆" in *.
    now firstorder. }
  now apply Hssc.
Qed.

(** *Robust Preservation of 2-Subset Closed HyperProperties *)

Definition R2SCHP := forall P H, twoSC H -> RhP P H.

(** *Robust Preservation of HyperSafety  *)

Definition RHSP := forall P H, HSafe H -> RhP P H.

(** *Robust Preservation of 2-HyperSafety *)

Definition R2HSP := forall P H, H2Safe H -> RhP P H.

(** *Robust Preservation of HyperLiveness  *)

Definition RHLP := forall P H, HLiv H -> RhP P H.

(*********************************************************)
(*   RELATIONS                                           *)
(*********************************************************)

(** *Robust Preservation of 2-Relational Properties *)

Definition R2rTP : Prop :=  forall (P1 P2 : par src i) (r : rel_prop),
    rsat2 P1 P2 r -> rsat2 (P1 ↓) (P2 ↓) r .

Lemma R2rTP' :
  R2rTP <->
  (forall (P1 P2 : par src i) r,
  forall Ct t1 t2, sem tgt ( Ct [P1 ↓] )  t1 ->
              sem tgt ( Ct [P2 ↓] )  t2 ->
               ~ (r t1 t2) ->
  exists Cs t1' t2', sem src (Cs [ P1 ]) t1' /\
                sem src (Cs [ P2 ]) t2' /\ ~ (r t1' t2')).
Proof.
  unfold R2rTP, rsat2, sat2. split.
  - intros H P1 P2 r Ct t1 t2 H0 H1 H2. specialize (H P1 P2 r).
    rewrite imp_equiv in H. destruct H as [H | H].
    + rewrite not_forall_ex_not in H. destruct H as [Cs H].
      rewrite not_forall_ex_not in H. destruct H as [tt1 H].
      rewrite not_forall_ex_not in H. destruct H as [tt2 H].
      rewrite not_imp in H. destruct H as [k1 k2].
      rewrite not_imp in k2. destruct k2 as [k2 k3].
      now exists Cs, tt1, tt2.
   + exfalso. now apply (H2 (H Ct t1 t2 H0 H1)).
  - intros H P1 P2 r H0 C t1 t2 H1 H2. apply NNPP. intros ff.
    specialize (H P1 P2 r C t1 t2 H1 H2 ff); destruct H as [Cs [tt1 [tt2 [h0 [h1 h2]]]]].
    now apply (h2 (H0 Cs tt1 tt2 h0 h1)).
Qed.

(* Robust Preservation of relations over properties =>
   Robust Property Preservation
*)
Lemma R2rTP_RPP : R2rTP -> RTP.
Proof.
  unfold R2rTP, RTP, RP, rsat, rsat2, sat, sat2.
  intros H P π Hpi Ct t H'. specialize (H P P (fun t1 _ => π t1)).
  simpl in H.
  assert(Hpi1 : forall C t1 t2 ,
                 sem src (C [P]) t1 -> sem src (C [P]) t2 -> π t1) by eauto.
  specialize (H Hpi1 Ct t t). tauto.
Qed.

(** *Robust Preservation of arbitrary-Relational Properties *)

Definition RrTP' : Prop :=
  forall R : (par src i  ->  trace) -> Prop,
    (forall Cs f,  (forall P, sem src (Cs [P]) (f P)) -> R f) ->
    (forall Ct f,  (forall P, sem tgt (Ct [P↓]) (f P)) -> R f).

(** *Robust Preservation of 2-Relational Safety Properties *)

Definition R2rSP := forall (P1 P2 : par src i) r,
    safety2 r ->
    rsat2 P1 P2 r ->
    rsat2 (P1 ↓) (P2 ↓) r.

Lemma R2rSP' : R2rSP <-> (forall (P1 P2 : par src i) r,
                           safety2 r ->
                           forall Ct t1 t2, sem _ (plug _ (P1 ↓) Ct) t1 ->
                                       sem _ (plug _ (P2 ↓) Ct) t2 -> ~(r t1 t2) ->
                                       exists Cs t1' t2', sem _ (plug _ P1 Cs) t1' /\
                                                     sem _ (plug _ P2 Cs) t2' /\ ~(r t1' t2')).
Proof.
  unfold R2rSP, rsat2, sat2. split.
  - intros H P1 P2 r Hsafety Ct t1 t2 H0 H1 H2. specialize (H P1 P2 r Hsafety).
    rewrite imp_equiv in H. destruct H as [H | H].
    + rewrite not_forall_ex_not in H. destruct H as [Cs H].
      rewrite not_forall_ex_not in H. destruct H as [tt1 H].
      rewrite not_forall_ex_not in H. destruct H as [tt2 H].
      rewrite not_imp in H. destruct H as [k1 k2].
      rewrite not_imp in k2. destruct k2 as [k2 k3].
      now exists Cs, tt1, tt2.
    + exfalso. now apply (H2 (H Ct t1 t2 H0 H1)).
  - intros H P1 P2 r Hsafety H0 C t1 t2 H1 H2. apply NNPP. intros ff.
    specialize (H P1 P2 r Hsafety C t1 t2 H1 H2 ff); destruct H as [Cs [tt1 [tt2 [h0 [h1 h2]]]]].
    now apply (h2 (H0 Cs tt1 tt2 h0 h1)).
Qed.

(** *Robust Preservation of arbitrary Relational Safety Properties*)

Definition RrSP' : Prop :=
  forall R : (par src i -> (finpref -> Prop)) -> Prop,
     (forall Cs f, (forall P, spref (f P) (sem src (Cs [P]))) -> R f) ->
     (forall Ct f, (forall P, spref (f P) (sem tgt (Ct [P↓]))) -> R f).

(** *Robust Preservation of 2-Relational Xafety Properties*)

Definition R2rXP := forall (P1 P2 : par src i) r,
    xafety2 r ->
    rsat2 P1 P2 r ->
    rsat2 (P1 ↓) (P2 ↓) r.

Lemma R2rXP' : R2rXP <-> (forall (P1 P2 : par src i) r,
                           xafety2 r ->
                           forall Ct t1 t2, sem _ (plug _ (P1 ↓) Ct) t1 ->
                                       sem _ (plug _ (P2 ↓) Ct) t2 -> ~(r t1 t2) ->
                                       exists Cs t1' t2', sem _ (plug _ P1 Cs) t1' /\
                                                     sem _ (plug _ P2 Cs) t2' /\ ~(r t1' t2')).
Proof.
  unfold R2rXP, rsat2, sat2. split.
  - intros H P1 P2 r Hsafety Ct t1 t2 H0 H1 H2. specialize (H P1 P2 r Hsafety).
    rewrite imp_equiv in H. destruct H as [H | H].
    + rewrite not_forall_ex_not in H. destruct H as [Cs H].
      rewrite not_forall_ex_not in H. destruct H as [tt1 H].
      rewrite not_forall_ex_not in H. destruct H as [tt2 H].
      rewrite not_imp in H. destruct H as [k1 k2].
      rewrite not_imp in k2. destruct k2 as [k2 k3].
      now exists Cs, tt1, tt2.
    + exfalso. now apply (H2 (H Ct t1 t2 H0 H1)).
  - intros H P1 P2 r Hsafety H0 C t1 t2 H1 H2. apply NNPP. intros ff.
    specialize (H P1 P2 r Hsafety C t1 t2 H1 H2 ff); destruct H as [Cs [tt1 [tt2 [h0 [h1 h2]]]]].
    now apply (h2 (H0 Cs tt1 tt2 h0 h1)).
Qed.

(** *Robust Preservation of arbitrary Relational XSafety Properties*)

Definition RrXP' : Prop :=
  forall R : (par src i -> (xpref -> Prop)) -> Prop,
     (forall Cs f, (forall P, spref_x (f P) (sem src (Cs [P]))) -> R f) ->
     (forall Ct f, (forall P, spref_x (f P) (sem tgt (Ct [P↓]))) -> R f).

(** *Robust Preservation of 2-Relational  HyperProperties *)

Definition R2rHP : Prop :=
  forall (P1 P2 : par src i) r, (hrsat2 P1 P2 r) -> (hrsat2 (P1 ↓) (P2 ↓) r).

(** *Robust Preservation of arbitrary Relational HyperProperties*)

Definition RrHP' : Prop :=
  forall R : (par src i  ->  prop) -> Prop,
    (forall Cs, R (fun P  => sem src (Cs [ P] ) )) ->
    (forall Ct, R (fun P  => sem tgt (Ct [ (P ↓)]) )).

(** *Robust Preservation of 2-subsetclosed Relational HyperProperties*)

Definition R2rSCHP := forall (P1 P2 : par src i) r,
    ssc2 r ->
    (hrsat2 P1 P2 r) -> (hrsat2 (P1↓) (P2↓) r).

Lemma R2rSCHP' :
  R2rSCHP <->
  (forall (P1 P2 : par src i) r, ssc2 r ->
                            ((exists Ct, ~ r (beh (Ct [P1↓])) (beh (Ct [P2↓]))) ->
                            (exists Cs, ~ r (beh (Cs [P1])) (beh (Cs [P2]))))).
Proof.
  split.
  + intros r2p P1 P2 r Hr [Ct nr].
    rewrite <- not_forall_ex_not.
    intros H. specialize (r2p P1 P2 r Hr H). now apply nr.
  + intros r2pc P1 P2 r Hr H. unfold hrsat2.
    intros Ct. rewrite dne. intros Hf.
    destruct (r2pc P1 P2 r Hr) as [Cs Hc].
    now exists Ct. now apply Hc.
Qed.

(** *Robust Trace Equivalence Preservation *)
Definition RTEP : Prop :=
  forall (P1 P2: par src i),
           (forall Cs t, sem src (Cs [P1]) t <-> sem src (Cs [P2]) t) ->
           (forall Ct t, sem tgt (Ct [P1 ↓]) t <-> sem tgt (Ct [P2 ↓]) t).

Lemma RTEP' : RTEP <-> (forall (P1 P2:par src i),
 (exists Ct t, ~ (sem tgt (Ct [P1 ↓]) t  <-> sem tgt (Ct [P2 ↓]) t)) ->
 (exists Cs t', ~ (sem src (Cs [P1]) t'  <-> sem src (Cs [P2]) t'))).
Proof.
  unfold RTEP. split.
  - intros He P1 P2. specialize (He P1 P2). rewrite imp_equiv in He.
    destruct He as [He | He]; intros [Ct [t Hdiff]].
    + rewrite not_forall_ex_not in He. destruct He as [Cs Hd].
      rewrite not_forall_ex_not in Hd. destruct Hd as [t' Hd].
      now exists Cs,t'.
    + exfalso. apply Hdiff. now apply He.
  - intros H P1 P2 Hsrc Ct t. apply NNPP. intros Hf.
    destruct (H P1 P2) as [Cs [t' Hc]].
    now exists Ct, t. apply Hc. now apply Hsrc.
Qed.

Lemma R2rHP_RTEP : R2rHP -> RTEP.
Proof.
  unfold R2rHP, hrsat2, hsat2, RTEP. intros Hr P1 P2 Hsrc Ct t.
  specialize (Hr P1 P2 (fun π1 π2 => forall t,  π1 t <-> π2 t)).
  simpl in Hr. specialize (Hr Hsrc). now apply (Hr Ct t).
Qed.

(** *Robust Trace Inclusion Preservation *)
Definition RTIP : Prop :=
  forall (P1 P2:par src i),
           (forall Cs t, sem src (Cs [P1]) t -> sem src (Cs [P2]) t) ->
           (forall Ct t, sem tgt (Ct [P1 ↓]) t -> sem tgt (Ct [P2 ↓]) t).

Lemma RTIP_RTEP : RTIP -> RTEP.
Proof.
  unfold RTIP, RTEP.
  intros rtip P1 P2 Hsrc Ct t.
  split; [apply (rtip P1 P2) | apply (rtip P2 P1)]; firstorder.
Qed.