(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Bool.
Require Import Reals.
Require Import trajectory_const.
Require Import rrho.
Require Import trajectory_def.
Require Import constants.
Require Import ycngftys.
Require Import ycngstys.
Require Import ails_def.
Require Import math_prop.
Section alpha_no_conflict.

Require Import tau.
Require Import ails.
Require Import trajectory.
Require Import measure2state.
Require Import ails_trajectory.
Require Import alarm.

Unset Standard Proposition Elimination Names.

Variable intr : Trajectory.
Variable evad : EvaderTrajectory.
Variable T : TimeT.

Definition Alpha (a : R) : bool :=
  let a1 :=
    ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) /
     (2 * ve evad * T))%R in
  let a2 := (l intr evad T * cos a)%R in
  match Rle_dec a1 a2 with
  | left _ => true
  | right _ => false
  end.

Lemma Alpha_d_AlertRange_0 :
 Alpha (beta intr evad T) = true -> (d intr evad <= AlertRange)%R.
Proof with trivial.
unfold Alpha in |- *;
 case
  (Rle_dec
     ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) /
      (2 * ve evad * T)) (l intr evad T * cos (beta intr evad T)));
 intros...
unfold Rdiv in r; cut (0 < 2 * ve evad * T)%R...
intro;
 generalize
  (Rmult_le_compat_r (2 * ve evad * T)
     ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) *
      / (2 * ve evad * T)) (l intr evad T * cos (beta intr evad T))
     (Rlt_le 0 (2 * ve evad * T) H0) r); repeat rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym...
rewrite Rmult_1_r; intro;
 generalize
  (Rplus_le_compat_l
     (Rsqr AlertRange -
      2 * l intr evad T * ve evad * T * cos (beta intr evad T))
     (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange)
     (l intr evad T * (cos (beta intr evad T) * (2 * (ve evad * T)))) H1);
 replace
  (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
   l intr evad T * (cos (beta intr evad T) * (2 * (ve evad * T))))%R with
  (Rsqr AlertRange)...
replace
 (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
  (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange))%R with
 (Rsqr (ve evad * T) + Rsqr (l intr evad T) -
  2 * ve evad * T * l intr evad T * cos (beta intr evad T))%R...
rewrite <- d_l_beta...
intro; apply Rsqr_incr_0_var...
left; apply AlertRange_pos...
ring...
ring...
repeat apply prod_neq_R0...
discrR...
red in |- *; intro; generalize (TypeSpeed_pos (h (tr evad))); intro;
 unfold ve in H1; rewrite H1 in H2; elim (Rlt_irrefl 0 H2)...
cut (0 < T)%R...
intro...
red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl 0 H1)...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
repeat apply Rmult_lt_0_compat...
prove_sup0...
unfold ve in |- *; apply (TypeSpeed_pos (h (tr evad)))...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
elim diff_false_true...
Qed.

Lemma Alpha_d_AlertRange_1 :
 (d intr evad <= AlertRange)%R -> Alpha (beta intr evad T) = true.
Proof with trivial.
intros; unfold Alpha in |- *;
 case
  (Rle_dec
     ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) /
      (2 * ve evad * T)) (l intr evad T * cos (beta intr evad T)));
 intro...
elim n; unfold Rdiv in |- *; cut (0 < 2 * ve evad * T)%R...
intro; apply Rmult_le_reg_l with (2 * ve evad * T)%R...
rewrite <-
 (Rmult_comm
    ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) *
     / (2 * ve evad * T))); repeat rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym...
rewrite Rmult_1_r;
 apply
  Rplus_le_reg_l
   with
     (Rsqr AlertRange -
      2 * l intr evad T * ve evad * T * cos (beta intr evad T))%R;
 replace
  (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
   (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange))%R with
  (Rsqr (ve evad * T) + Rsqr (l intr evad T) -
   2 * ve evad * T * l intr evad T * cos (beta intr evad T))%R...
rewrite <- d_l_beta;
 replace
  (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
   2 * (ve evad * (T * (l intr evad T * cos (beta intr evad T)))))%R with
  (Rsqr AlertRange)...
apply Rsqr_incr_1...
unfold d in |- *; unfold Die in |- *; apply sqrt_positivity;
 apply Rplus_le_le_0_compat; apply Rle_0_sqr...
left; apply AlertRange_pos...
ring...
ring...
repeat apply prod_neq_R0...
discrR...
red in |- *; intro; generalize (TypeSpeed_pos (h (tr evad))); intro;
 unfold ve in H1; rewrite H1 in H2; elim (Rlt_irrefl 0 H2)...
cut (0 < T)%R...
intro; red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl 0 H1)...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
repeat apply Rmult_lt_0_compat;
 [ prove_sup0
 | unfold ve in |- *; apply (TypeSpeed_pos (h (tr evad)))
 | apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ] ]...
Qed.

Lemma Alpha_d_AlertRange_2 :
 Alpha (beta intr evad T) = false -> (AlertRange < d intr evad)%R.
Proof with trivial.
unfold Alpha in |- *;
 case
  (Rle_dec
     ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) /
      (2 * ve evad * T)) (l intr evad T * cos (beta intr evad T)));
 intros...
elim diff_true_false...
unfold Rdiv in n; cut (0 < 2 * ve evad * T)%R...
intro...
cut
 (l intr evad T * cos (beta intr evad T) <
  (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) *
  / (2 * ve evad * T))%R...
intro;
 generalize
  (Rmult_lt_compat_r (2 * ve evad * T)
     (l intr evad T * cos (beta intr evad T))
     ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) *
      / (2 * ve evad * T)) H0 H1); repeat rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym...
rewrite Rmult_1_r; intro;
 generalize
  (Rplus_lt_compat_l
     (Rsqr AlertRange -
      2 * l intr evad T * ve evad * T * cos (beta intr evad T))
     (l intr evad T * (cos (beta intr evad T) * (2 * (ve evad * T))))
     (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) H2);
 replace
  (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
   l intr evad T * (cos (beta intr evad T) * (2 * (ve evad * T))))%R with
  (Rsqr AlertRange)...
replace
 (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
  (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange))%R with
 (Rsqr (ve evad * T) + Rsqr (l intr evad T) -
  2 * ve evad * T * l intr evad T * cos (beta intr evad T))%R...
rewrite <- d_l_beta...
intro; apply Rsqr_incrst_0...
left; apply AlertRange_pos...
unfold d in |- *; unfold Die in |- *; apply sqrt_positivity;
 apply Rplus_le_le_0_compat; apply Rle_0_sqr...
ring...
ring...
repeat apply prod_neq_R0...
discrR...
red in |- *; intro; generalize (TypeSpeed_pos (h (tr evad))); intro;
 unfold ve in H2; rewrite H2 in H3; elim (Rlt_irrefl 0 H3)...
cut (0 < T)%R...
intro...
red in |- *; intro; rewrite H3 in H2; elim (Rlt_irrefl 0 H2)...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
auto with real...
repeat apply Rmult_lt_0_compat...
prove_sup0...
unfold ve in |- *; apply (TypeSpeed_pos (h (tr evad)))...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
Qed.

Lemma Alpha_d_AlertRange_3 :
 (AlertRange < d intr evad)%R -> Alpha (beta intr evad T) = false.
Proof with trivial.
intros; unfold Alpha in |- *;
 case
  (Rle_dec
     ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) /
      (2 * ve evad * T)) (l intr evad T * cos (beta intr evad T)));
 intro...
unfold Rdiv in r; cut (0 < 2 * ve evad * T)%R...
intro;
 generalize
  (Rmult_le_compat_l (2 * ve evad * T)
     ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) *
      / (2 * ve evad * T)) (l intr evad T * cos (beta intr evad T))
     (Rlt_le 0 (2 * ve evad * T) H0) r)...
rewrite <-
 (Rmult_comm
    ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) *
     / (2 * ve evad * T))); repeat rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym...
rewrite Rmult_1_r; intro...
generalize
 (Rplus_le_compat_l
    (Rsqr AlertRange -
     2 * l intr evad T * ve evad * T * cos (beta intr evad T))
    (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange)
    (2 * (ve evad * (T * (l intr evad T * cos (beta intr evad T))))) H1)...
replace
 (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
  (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange))%R with
 (Rsqr (ve evad * T) + Rsqr (l intr evad T) -
  2 * ve evad * T * l intr evad T * cos (beta intr evad T))%R...
rewrite <- d_l_beta;
 replace
  (Rsqr AlertRange - 2 * l intr evad T * ve evad * T * cos (beta intr evad T) +
   2 * (ve evad * (T * (l intr evad T * cos (beta intr evad T)))))%R with
  (Rsqr AlertRange)...
intro...
generalize
 (Rsqr_incr_0_var (d intr evad) AlertRange H2
    (Rlt_le 0 AlertRange AlertRange_pos))...
intro...
elim (Rlt_irrefl (d intr evad) (Rle_lt_trans _ _ _ H3 H))...
ring...
ring...
repeat apply prod_neq_R0...
discrR...
red in |- *; intro; generalize (TypeSpeed_pos (h (tr evad))); intro;
 unfold ve in H1; rewrite H1 in H2; elim (Rlt_irrefl 0 H2)...
cut (0 < T)%R...
intro...
red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl 0 H1)...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
repeat apply Rmult_lt_0_compat;
 [ prove_sup0
 | unfold ve in |- *; apply (TypeSpeed_pos (h (tr evad)))
 | apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ] ]...
Qed.

(*** Verifiable in MuPAD ***)
Axiom
  cos_beta_NOT_Alpha :
    Alpha (beta intr evad T) = false ->
    h intr = V ->
    h (tr evad) = V ->
    (MinDistance T <= l intr evad T)%R ->
    (l intr evad T <= MaxDistance T)%R ->
    (cos (beta intr evad T) <= cos MinBeta)%R.

Lemma tau_le_0_diverg :
 (tau (measure2state intr 0) (measure2state (tr evad) 0) 0 <= 0)%R ->
 (d intr evad <= RR (measure2state intr 0) (measure2state (tr evad) 0) T)%R.
Proof with trivial.
intro; rewrite <- d_distance; rewrite distance_sym; rewrite <- R_distance...
cut (0 <= T)%R...
intro;
 generalize
  (asymptotic_increase_tau (measure2state intr 0) (measure2state (tr evad) 0)
     0 0 T H H0); intro...
repeat rewrite Rplus_0_l in H1...
left; apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
Qed.

Lemma R_T_d_diff_0 :
 h (tr evad) = V ->
 (0 < l intr evad T)%R ->
 (d intr evad <= RR (measure2state intr 0) (measure2state (tr evad) 0) T)%R ->
 (cos (beta intr evad T + thetat intr 0) <= cos (beta intr evad T))%R.
Proof with trivial.
intros hyp_evad H...
cut (0 <= d intr evad)%R...
cut (0 <= RR (measure2state intr 0) (measure2state (tr evad) 0) T)%R...
intros...
generalize
 (Rsqr_incr_1 _ (RR (measure2state intr 0) (measure2state (tr evad) 0) T) H2
    H1 H0); intro...
rewrite R_T in H3...
rewrite (d_l_beta intr evad T) in H3...
unfold ve in H3...
rewrite hyp_evad in H3...
rewrite Rsqr_minus in H3...
repeat rewrite Rsqr_mult in H3...
rewrite cos2 in H3...
generalize
 (Rplus_le_compat_l (- Rsqr (l intr evad T) - Rsqr V * Rsqr T)
    (Rsqr V * Rsqr T + Rsqr (l intr evad T) -
     2 * V * T * l intr evad T * cos (beta intr evad T))
    (Rsqr (l intr evad T) *
     (1 - Rsqr (sin (beta intr evad T + thetat intr 0))) +
     Rsqr V * Rsqr T -
     2 * (l intr evad T * cos (beta intr evad T + thetat intr 0)) * (V * T) +
     Rsqr (l intr evad T) * Rsqr (sin (beta intr evad T + thetat intr 0))) H3)...
replace
 (- Rsqr (l intr evad T) - Rsqr V * Rsqr T +
  (Rsqr V * Rsqr T + Rsqr (l intr evad T) -
   2 * V * T * l intr evad T * cos (beta intr evad T)))%R with
 (2 * V * T * l intr evad T * - cos (beta intr evad T))%R...
replace
 (- Rsqr (l intr evad T) - Rsqr V * Rsqr T +
  (Rsqr (l intr evad T) * (1 - Rsqr (sin (beta intr evad T + thetat intr 0))) +
   Rsqr V * Rsqr T -
   2 * (l intr evad T * cos (beta intr evad T + thetat intr 0)) * (V * T) +
   Rsqr (l intr evad T) * Rsqr (sin (beta intr evad T + thetat intr 0))))%R
 with
 (2 * V * T * l intr evad T * - cos (beta intr evad T + thetat intr 0))%R...
intro...
rewrite <- (Ropp_involutive (cos (beta intr evad T)))...
rewrite <- (Ropp_involutive (cos (beta intr evad T + thetat intr 0)))...
apply Ropp_ge_le_contravar...
apply Rle_ge...
apply Rmult_le_reg_l with (2 * V * T * l intr evad T)%R...
apply Rmult_lt_0_compat...
prove_sup0...
(*apply TypeSpeed_pos. useless since 8.4 thanks to beta/delta in apply*)
apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ]...
ring...
ring...
(*Rewrite hyp_evad.*)
apply RR_pos...
unfold d in |- *; unfold Die in |- *; apply sqrt_positivity...
apply Rplus_le_le_0_compat; apply Rle_0_sqr...
Qed.

Lemma R_T_d_diff_1 :
 h (tr evad) = V ->
 (cos (beta intr evad T + thetat intr 0) <= cos (beta intr evad T))%R ->
 (d intr evad <= RR (measure2state intr 0) (measure2state (tr evad) 0) T)%R.
Proof with trivial.
intros...
apply Rsqr_incr_0...
rewrite R_T...
rewrite (d_l_beta intr evad T)...
unfold ve in |- *...
rewrite H...
rewrite Rsqr_minus...
repeat rewrite Rsqr_mult...
rewrite cos2...
replace
 (Rsqr (l intr evad T) * (1 - Rsqr (sin (beta intr evad T + thetat intr 0))) +
  Rsqr V * Rsqr T -
  2 * (l intr evad T * cos (beta intr evad T + thetat intr 0)) * (V * T) +
  Rsqr (l intr evad T) * Rsqr (sin (beta intr evad T + thetat intr 0)))%R
 with
 (Rsqr V * Rsqr T + Rsqr (l intr evad T) -
  2 * (l intr evad T * cos (beta intr evad T + thetat intr 0)) * (V * T))%R...
unfold Rminus in |- *...
apply Rplus_le_compat_l...
apply Ropp_ge_le_contravar...
apply Rle_ge...
repeat rewrite Rmult_assoc...
apply Rmult_le_compat_l...
left; prove_sup0...
rewrite <- (Rmult_comm (V * T))...
rewrite (Rmult_comm (l intr evad T))...
repeat rewrite Rmult_assoc...
apply Rmult_le_compat_l...
left; apply TypeSpeed_pos...
apply Rmult_le_compat_l...
left; apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ]...
rewrite <- (Rmult_comm (l intr evad T))...
apply Rmult_le_compat_l...
apply l_is_pos...
unfold Rminus in |- *...
rewrite Rmult_plus_distr_l...
ring...
(*Rewrite H.*)
unfold d in |- *; unfold Die in |- *; apply sqrt_positivity;
 apply Rplus_le_le_0_compat; apply Rle_0_sqr...
apply RR_pos...
Qed.

Lemma cos_no_conflict :
 h intr = V ->
 h (tr evad) = V ->
 Alpha (beta intr evad T) = false ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 (cos (beta intr evad T + thetat intr 0) <= cos (beta intr evad T))%R ->
 Omega (thetat intr 0 + beta intr evad T) = false ->
 conflict intr evad T = false.
Proof with trivial.
intros hyp_intr hyp_evad; intros...
unfold conflict in |- *...
cut
 (l intr evad T * cos (beta intr evad T) <
  (Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) /
  (2 * ve evad * T))%R...
cut
 ((thetat intr 0 + beta intr evad T < PI / 2)%R \/
  (PI / 2 <= thetat intr 0 + beta intr evad T)%R /\
  (3 * (PI / 2) < thetat intr 0 + beta intr evad T)%R)...
intros...
case (Rle_dec (Die intr evad T T) ConflictRange); intro...
unfold Die in r...
generalize (isometric_evader intr evad T T)...
unfold Rsqr_evader_distance in |- *...
unfold xe, ye in |- *...
intro...
rewrite H6 in r...
cut (0 <= T)%R...
cut (rho_vi intr * T <= PI / 2)%R...
intros...
generalize (ypt_PI2 intr evad T T H8 H7); intro...
generalize
 (xpt_PI intr evad T T H8
    (Rle_trans (rho_vi intr * T) (PI / 2) PI H7
       (Rlt_le (PI / 2) PI PI2_Rlt_PI))); intro...
elim H4; intros...
rewrite Rplus_comm in H11...
cut (MinBeta <= beta intr evad T + thetat intr 0)%R...
intro...
elim H9; intros...
generalize
 (Math_prop_no_conflict_1 (beta intr evad T + thetat intr 0)
    (l intr evad T) (xp intr evad T T) (yp intr evad T T) T H0 H1 H12
    (Rlt_le (beta intr evad T + thetat intr 0) (PI / 2) H11))...
unfold r_V, rho_V in |- *...
unfold r_vi, rho_vi in H13...
unfold r_vi, rho_vi in H10...
unfold vi in H10...
rewrite hyp_intr in H10...
unfold vi in H13...
rewrite hyp_intr in H13...
intro...
generalize (H15 H13 H10)...
intro...
cut (0 <= sqrt (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T)))%R...
cut (0 <= ConflictRange)%R...
intros...
generalize
 (Rsqr_incr_1 (sqrt (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T)))
    ConflictRange r H18 H17); intro...
rewrite Rsqr_sqrt in H19...
elim
 (Rlt_irrefl (Rsqr ConflictRange)
    (Rlt_le_trans (Rsqr ConflictRange)
       (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T))
       (Rsqr ConflictRange) H16 H19))...
apply Rplus_le_le_0_compat; apply Rle_0_sqr...
unfold ConflictRange in |- *; left; prove_sup...
apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr...
apply cos_decr_0...
generalize (beta_def intr evad T); intro...
decompose [and] H12...
left; apply Rlt_trans with (PI / 2)%R...
apply PI2_Rlt_PI...
left; apply MinBeta_pos...
unfold MinBeta in |- *...
left; apply Rlt_trans with 1%R...
unfold Rdiv in |- *...
apply Rmult_lt_reg_l with 1000%R...
prove_sup...
rewrite Rmult_1_r; rewrite (Rmult_comm 1000); rewrite Rmult_assoc...
rewrite <- Rinv_l_sym; [ prove_sup | discrR ]...
apply Rlt_trans with (PI / 2)%R...
apply Rlt_1_PI2...
apply PI2_Rlt_PI...
apply Rle_trans with (cos (beta intr evad T))...
apply cos_beta_NOT_Alpha...
elim H11; intros...
rewrite (Rplus_comm (thetat intr 0)) in H13...
cut (beta intr evad T + thetat intr 0 <= 2 * PI - MinBeta)%R...
intro...
generalize
 (Math_prop_no_conflict_2 (beta intr evad T + thetat intr 0)
    (l intr evad T) (xp intr evad T T) (yp intr evad T T) T H0 H1
    (Rlt_le (3 * (PI / 2)) (beta intr evad T + thetat intr 0) H13) H14);
 intro...
unfold r_V, rho_V in H15...
unfold r_vi, rho_vi in H10...
elim H9; intros...
unfold r_vi, rho_vi in H17...
unfold vi in H17...
rewrite hyp_intr in H17...
unfold vi in H10...
rewrite hyp_intr in H10...
generalize (H15 H17 H10); intro...
cut (0 <= sqrt (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T)))%R...
cut (0 <= ConflictRange)%R...
intros...
generalize
 (Rsqr_incr_1 (sqrt (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T)))
    ConflictRange r H20 H19); intro...
rewrite Rsqr_sqrt in H21...
elim
 (Rlt_irrefl (Rsqr ConflictRange)
    (Rlt_le_trans (Rsqr ConflictRange)
       (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T))
       (Rsqr ConflictRange) H18 H21))...
apply Rplus_le_le_0_compat; apply Rle_0_sqr...
unfold ConflictRange in |- *; left; prove_sup...
apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr...
apply cos_incr_0...
left; apply Rlt_trans with (3 * (PI / 2))%R...
pattern PI at 1 in |- *; rewrite <- (Rplus_0_r PI)...
replace (3 * (PI / 2))%R with (PI + PI / 2)%R...
apply Rplus_lt_compat_l...
apply PI2_RGT_0...
pattern PI at 1 in |- *; rewrite double_var; ring...
generalize (beta_def intr evad T); intro...
decompose [and] H14...
left...
left...
apply Rplus_lt_reg_l with (MinBeta - PI)%R...
replace (MinBeta - PI + PI)%R with MinBeta...
replace (MinBeta - PI + (2 * PI - MinBeta))%R with PI...
unfold MinBeta in |- *...
apply Rlt_trans with 1%R...
unfold Rdiv in |- *...
apply Rmult_lt_reg_l with 1000%R...
prove_sup...
rewrite (Rmult_comm 1000); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
 [ repeat rewrite Rmult_1_r; prove_sup | discrR ]...
apply Rlt_trans with (PI / 2)%R...
apply Rlt_1_PI2...
apply PI2_Rlt_PI...
ring...
ring...
unfold Rminus in |- *...
pattern (2 * PI)%R at 2 in |- *; rewrite <- (Rplus_0_r (2 * PI))...
apply Rplus_le_compat_l...
left; rewrite <- Ropp_0...
apply Ropp_lt_gt_contravar...
apply MinBeta_pos...
unfold Rminus in |- *...
rewrite (Rplus_comm (2 * PI))...
generalize (cos_period (- MinBeta) 1)...
unfold INR in |- *...
rewrite Rmult_1_r...
intro...
rewrite H14...
rewrite cos_neg...
apply Rle_trans with (cos (beta intr evad T))...
apply cos_beta_NOT_Alpha...
left; replace (rho_vi intr) with rho_V...
apply rho_t_PI2...
unfold rho_vi, rho_V in |- *...
unfold vi in |- *; rewrite hyp_intr...
left; apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
cut (Omega (thetat intr 0 + beta intr evad T) = false)...
unfold Omega in |- *...
case (Rle_dec (PI / 2) (thetat intr 0 + beta intr evad T)); intro...
case (Rle_dec (thetat intr 0 + beta intr evad T) (3 * (PI / 2))); intros...
elim diff_true_false...
right...
split...
auto with real...
intro...
left; auto with real...
cut (Alpha (beta intr evad T) = false)...
unfold Alpha in |- *...
case
 (Rle_dec
    ((Rsqr (ve evad * T) + Rsqr (l intr evad T) - Rsqr AlertRange) /
     (2 * ve evad * T)) (l intr evad T * cos (beta intr evad T)));
 intros...
elim diff_true_false...
auto with real...
Qed.

(**************************************************************)
(*************************** THEOREME *************************)
(**************************************************************)

Theorem ails_no_conflict_tau_le0 :
 h intr = V ->
 h (tr evad) = V ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 (AlertRange < d intr evad)%R ->
 Omega (thetat intr 0 + beta intr evad T) = false ->
 (tau (measure2state intr 0) (measure2state (tr evad) 0) 0 <= 0)%R ->
 conflict intr evad T = false.
Proof with trivial.
intros; apply cos_no_conflict...
apply (Alpha_d_AlertRange_3 H3)...
apply R_T_d_diff_0...
apply Rlt_le_trans with (MinDistance T)...
apply MinDistance_pos...
apply tau_le_0_diverg...
Qed.

End alpha_no_conflict.


From mathcomp Require Import all_ssreflect.
From chip Require Import extra connect acyclic closure check.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Changed.

(* artifact *)
Variable A : eqType.

(* paths *)
Variable V' : finType.

Variable P : pred V'.

Local Notation V := (sig_finType P).

Variable f' : V' -> A.

Variable f : V -> A.

Variable g' : rel V'.

Local Notation g'rev := [rel x y | g' y x].

Variable g : rel V.

Local Notation grev := [rel x y | g y x].

Variable checkable' : pred V'.

Variable checkable : pred V.

Variable R : eqType.

Variable check' : V' -> R.

Variable check : V -> R.

Definition insub_g (x y : V') :=
match insub x, insub y with
| Some x', Some y' => g x' y'
| _, _ => false
end.

Local Notation gV' := [rel x y : V' | insub_g x y].

Local Notation gV'rev := [rel x y | gV' y x].

Lemma ginsubexP (x y : V') :
  reflect (exists x' y' : V, val x' = x /\ val y' = y /\ g x' y') (gV' x y).
Proof.
apply: (iffP idP).
- rewrite /gV' /=.
  rewrite /insub_g.
  have H_sp := (insubP [subType of V] x).
  destruct H_sp.
  * rewrite insubT //.
    have H_sp := (insubP [subType of V] y).
    destruct H_sp.
    + rewrite insubT.
      by exists (Sub x i), (Sub y i0).
    + by rewrite insubN.
  * by rewrite insubN.
- case => x'; case => y'.
  move => [Hx [Hy Hg]].
  rewrite /gV' /=.
  rewrite /insub_g.
  case: x' Hx Hg => /= x0 Px0 -<-.
  case: y' Hy => /= y0 Py0 -<-.
  by rewrite (insubT _ Px0) (insubT _ Py0).
Qed.

Lemma grevinsubexP (x y : V') :
  reflect (exists x' y' : V, val x' = x /\ val y' = y /\ grev x' y') (gV'rev x y).
Proof.
apply: (iffP idP).
- rewrite /= => Hs.
  move/ginsubexP: Hs.
  move=> [y' [x' [Hx [Hy Hxy]]]].
  by exists x', y'.
- rewrite /=.
  move => [y' [x' [Hy [Hx Hxy]]]].
  apply/ginsubexP.
  by exists x', y'.
Qed.

Lemma ginsubP x y :
  reflect (g x y) (gV' (val x) (val y)).
Proof.
apply: (iffP idP).
- move/ginsubexP.
  move => [x' [y' [Hx [Hy Hxy]]]].
  move/val_inj: Hx =>-<-.
  by move/val_inj: Hy =>-<-.
- move => Hg.
  apply/ginsubexP.
  by exists x, y.
Qed.

Lemma ginsub_eq x y :
  g x y = gV' (val x) (val y).
Proof.
by apply/idP/ginsubP.
Qed.

(* Assumption: dependencies are the same if artifact is the same *)
Hypothesis f_equal_g :
  forall v, f v = f' (val v) -> forall v', gV' (val v) v' = g' (val v) v'.

(* Assumption: checknability is the same if artifact is the same *)
Hypothesis checkable_V_V' :
  forall v, f v = f' (val v) -> checkable v = checkable' (val v).

(*
Assumption:
if the dependency (sub)graph rooted in a checkable vertex
is well-founded and unchanged, then the outcome of checkning
the vertex (in the new graph) is the same as the old outcome
 *)
Hypothesis check_V_V' :
  forall v, checkable v -> checkable' (val v) ->
  (forall v', connect gV' (val v) v' = connect g' (val v) v') ->
  (forall v', connect gV' (val v) (val v') -> f v' = f' (val v')) ->
  check v = check' (val v).

Variable V_result_cert : seq (V * R).

Hypothesis V_result_certP :
  forall v r, reflect (checkable v /\ check v = r) ((v,r) \in V_result_cert).

Hypothesis V_result_cert_uniq : uniq [seq vr.1 | vr <- V_result_cert].

Lemma V_result_cert_complete :
  forall v r, checkable v -> check v == r -> (v,r) \in V_result_cert.
Proof.
move => v r Hc.
move/eqP => Hr.
by apply/V_result_certP.
Qed.

Lemma V_result_cert_sound :
  forall v r, (v,r) \in V_result_cert -> checkable v /\ check v == r.
Proof.
move => v r.
move/V_result_certP => [Hc Hr].
by move/eqP: Hr => Hr.
Qed.

Definition V'_result_filter_cert :=
 [seq (val vr.1, vr.2) | vr <- V_result_cert & val vr.1 \notin impactedVV' g (modifiedV f' f)].

Lemma V_result_filter_cert_checkable' :
  forall (v : V') (r : R), (v,r) \in V'_result_filter_cert -> checkable' v.
Proof.
move => v r.
move/mapP.
move => [[v' r'] Hv'].
case.
move =>->.
move => Hb; move: Hv'.
rewrite -Hb {Hb}.
rewrite mem_filter /=.
move/andP => [Hr Hin].
have Hi': (val v' \notin impactedVV' g (modifiedV f' f)).
  apply/negP.
  move => Hv.
  move/negP: Hr.
  by case.
move/imsetP: Hi'.
move => Hvb.
have Hv': v' \notin impacted g^-1 (modifiedV f' f).
  apply/negP.
  move => Hv'.
  case: Hvb.
  by exists v'.
move/impactedVP: Hv'.
move => Hm.
move/V_result_certP: Hin.
move => [Hvc Hc].
case Hf: (f v' == f' (val v')).
  move/eqP: Hf.
  by move/checkable_V_V'=>-<-.
move/negP/negP: Hf => Hf.
case: Hm.
exists v'; first by rewrite in_set.
apply/connectP.
by exists [::].
Qed.

Definition check_all_cert :=
  check_impactedV'_cert f' f g checkable' check' ++ V'_result_filter_cert.

Lemma check_all_cert_cases :
  forall v r, (v, r) \in check_all_cert ->
 ((v, r) \in check_impactedV'_cert f' f g checkable' check' /\ (v, r) \notin V'_result_filter_cert) \/
 ((v, r) \in V'_result_filter_cert /\ (v,r) \notin check_impactedV'_cert f' f g checkable' check').
Proof.
move => v b.
rewrite mem_cat.
move/orP.
case => Hi.
- left; split => //.
  move/check_impactedV'_certP: Hi.
  move => [Hc [Hv Hi]].
  apply/negP => Hp.
  move: Hp.
  move/mapP.
  case => [[v' b'] Hb].
  rewrite /=.
  case.
  move => Hv' Hb'.
  subst.
  move: Hb.
  rewrite mem_filter /=.
  move/andP => [Hp Hp'].
  move/negP: Hp.
  case.
  move/impactedV'P: Hi.
  case; move => [Hi Hi'] //.
  move/freshV'P: Hi => Hi.
  have Hv' := Hi v'.
  move/negP: Hv'.
  case.
  by apply/eqP.
- right; split => //.
  apply/negP.
  move => Hm.
  move/check_impactedV'_certP: Hm.
  move/mapP: Hi.
  move => [[v' b'] Hb] /=.
  case.
  move => Hv' Hb'.
  subst.
  move: Hb.
  rewrite mem_filter /=.
  move/andP => [Hb Hc].
  move => [Hc1 [Hc2 Hi2]].
  move/negP: Hb.
  case.
  move/impactedV'P: Hi2.
  case; move => [Hi Hi'] //.
  move/freshV'P: Hi => Hi.
  have Hv' := Hi v'.
  move/negP: Hv'.
  case.
  by apply/eqP.
Qed.

Definition check_all_cert_V' :=
 [seq vr.1 | vr <- check_all_cert].

Lemma check_all_cert_V'_uniq : uniq check_all_cert_V'.
Proof.
rewrite map_inj_in_uniq.
- rewrite cat_uniq.
  apply/andP.
  split; last (apply/andP; split).
  * have Hu := check_impactedV'_cert_uniq f' f g checkable' check'.
    move: Hu.
    exact: map_uniq.
  * apply/negP.
    move/hasP => [vr Hvr].
    move/mapP: Hvr => [vr' Hvr'].
    case: vr' Hvr' => v' r'.
    rewrite mem_filter.
    case: vr => /= v r.
    move/andP => [Hv Hvr].
    case => Hv'; move =>-> {r}.
    move/mapP => [v0 Hv0].
    case => Hvv0 Hr'.
    rewrite mem_enum -Hvv0 in Hv0.
    move/negP: Hv.
    case.
    rewrite in_set in Hv0.
    move/andP: Hv0 => [Hvi Hvc].
    rewrite in_set in Hvi.
    move/orP: Hvi.
    case; first by rewrite Hv'.
    move/freshV'P => Hvv.
    have Hvv' := Hvv v'.
    move/negP: Hvv'.
    case.
    by rewrite Hv'.
  * have Hm := map_uniq V_result_cert_uniq.
    rewrite map_inj_in_uniq; first by rewrite filter_uniq.
    case => v1 r1.
    case => v2 r2.
    rewrite /= => Hv1 Hv2.
    case.
    by move/val_inj =><-<-.
- case => v1 r1.
  case => v2 r2.
  rewrite /= 2!mem_cat.
  move/orP.
  case => Hv1; move/orP.
  * case => Hv2 Hv.
    + move: Hv Hv1 Hv2 =><-.
      move/mapP => [v1' Hv1' Hc1].
      rewrite mem_enum in Hv1'.
      case: Hc1 =><- Hr1.
      move/mapP => [v2' Hv2' Hc2].
      rewrite mem_enum in Hv2'.
      case: Hc2 =><- Hr2.
      by rewrite Hr1 Hr2.
    + move: Hv Hv1 Hv2 =><-.
      move/mapP => [v1' Hv1' Hc1].
      case: Hc1 Hv1' =><-.
      rewrite mem_enum => Hc.
      rewrite in_set.
      move/andP => [Hi H'c].
      move/mapP => [v' Hv' Heq].
      case: v' Hv' Heq => v2' r2'.
      rewrite mem_filter.
      move/andP => [Hv2' HV].
      case => Hv1 Hr2.
      rewrite /= in Hv2'.
      move/negP: Hv2'.
      case.
      rewrite -Hv1.
      rewrite in_set in Hi.
      move/orP: Hi.
      case => //.
      move/freshV'P => Hv.
      have Hv' := Hv v2'.
      move/negP: Hv'.
      case.
      apply/eqP.
      by rewrite Hv1.
  * case => Hv2 Hv.
    + move: Hv Hv1 Hv2.
      move =><-.
      move/mapP => [v1' Hv1' Hc1].
      case: v1' Hc1 Hv1' => v1' r1'.
      case =>->->.
      rewrite mem_filter.
      move/andP => [Hi H'c].
      move/mapP => [v' Hv' Heq].
      case: Heq Hv'.
      rewrite mem_enum.
      move =><-->.
      move => Hc.
      move/negP: Hi.
      case.
      rewrite in_set in Hc.
      move/andP: Hc => [Hi Hc].
      rewrite in_set in Hi.
      move/orP: Hi.
      case => //.
      move/freshV'P => Hv'.
      have Hv'' := Hv' v1'.
      move/negP: Hv''.
      by case.
    + move: Hv1 Hv2.
      move/mapP.
      case; case => v1' r1'.
      rewrite mem_filter.
      move/andP => [Hi Hv'].
      case.
      move => H_eq_v H_eq_r.
      move/mapP.
      case; case => v2' r2'.
      rewrite mem_filter.
      move/andP => [Hi' Hv''].
      case => H_eq_v' H_eq_r'.
      rewrite Hv in H_eq_v, H_eq_v'.
      rewrite H_eq_v in H_eq_v'.
      apply val_inj in H_eq_v'.
      rewrite -H_eq_v' in Hv''.
      rewrite Hv H_eq_r H_eq_r'.
      have Hu := uniq_prod_eq V_result_cert_uniq Hv' Hv''.
      by rewrite -Hu.
Qed.

Lemma check_all_cert_complete :
  forall (v : V'), checkable' v -> v \in check_all_cert_V'.
Proof.
move => v Hc.
have H_sp := (insubP [subType of V] v).
destruct H_sp.
- (* 1. V'_result_filter_cert 2. impactedVV' *)
  have Hv: v \notin freshV' P.
    apply/negP.
    move => Hv.
    move/freshV'P: Hv => Hv.
    move/negP: (Hv u) => Hv'.
    case: Hv'.
    by apply/eqP.
  apply/mapP.
  (* outline:
     - either in filtered or impacted
     - if in filtered, take check u
     - if in impacted, take check' v
  *)
  case Hv': (v \in impactedV' f' f g).
  - have Hv'': v \in impactedV' f' f g by [].
    move {Hv'}.
    exists (v, check' v); last by [].
    rewrite mem_cat.
    apply/orP.
    left.
    apply/check_impactedV'_certP.
    by split.
  - have Hv'': v \notin impactedV' f' f g by apply/negP; rewrite Hv'.
    move {Hv'}.
    exists (v, check u); last by [].
    rewrite mem_cat.
    apply/orP.
    right.
    apply/mapP.
    exists (u, check u); last by rewrite /= e.
    rewrite mem_filter.
    apply/andP.
    rewrite /= in e.
    rewrite /=.
    split.
    * move/impactedV'P: Hv'' => Hv''.
      apply/negP.
      move => Hu.
      case: Hv''.
      left.
      split => //.
      by rewrite -e.
    * apply/V_result_certP.
      split => //.
      suff H_suff: f u = f' (val u) by rewrite checkable_V_V' //= e.
      apply/eqP.
      apply/not_modifiedP.
      apply/negP.
      move => Hu.
      move/negP: Hv'' => Hv''.
      case: Hv''.
      apply/impactedV'P.
      left.
      split => //.
      apply/imsetP.
      exists u; last by [].
      apply/impactedVP.
      by exists u.
- (*3. fresh *)
  have Hv: v \in freshV' P.
    rewrite -sub_freshV'.
    move/negP: i => Hp.
    apply/negP => Hs.
    case: Hp.
    have H_sp := (insubP [subType of V] v).
    move: Hs.
    by destruct H_sp.
  apply/mapP.
  exists (v, check' v) => //.
  rewrite mem_cat.
  apply/orP.
  left.
  apply/check_impactedV'_certP.
  split => //.
  split => //.
  apply/impactedV'P.
  right.
  split => //.
  apply/negP.
  by move/impactedVV'_freshV'/negP.
Qed.

Lemma connect_gV'_rev u :
  (forall v : V, connect grev v u -> forall v', gV' (val v) v' = g' (val v) v') ->
  (forall v : V, connect grev v u -> f v == f' (val v)) ->
  forall v', connect gV' (val u) v' = connect g' (val u) v'.
Proof.
move => Hv.
have Hv': forall v : V, connect g u v -> forall v', gV' (val v) v' = g' (val v) v'.
  move => v' Hc.
  apply: Hv.
  exact: connect_rev.
move {Hv}.
move => Hvf.
have Hvf': forall v' : V, connect g u v' -> f v' == f' (val v').
  move => v' Hc.
  apply: Hvf.
  exact: connect_rev.
move {Hvf}.
move => v'.
have H_eq: f u = f' (val u).
  apply/eqP.
  apply: Hvf'.
  apply/connectP.
  by exists [::].
apply/connectP.
case: ifP.
- case/connectP => p Hp Hl.
  have H_eq' := f_equal_g H_eq.
  exists p; last by [].
  clear Hl H_eq.
  elim: p u Hp Hv' Hvf' H_eq' => //=.
  move => v0 p IH u.
  move/andP => [Hg Hp] Hc Hc' Hg'.
  apply/andP.
  rewrite -Hg' in Hg.
  split.
  * move/ginsubexP: Hg => [x [y [Hx [Hy Hxy]]]].
    rewrite -Hy.
    rewrite ginsub_eq in Hxy.
    by rewrite /gV' /= Hx in Hxy.
  * move/ginsubexP: Hg => [x [y [Hx [Hy Hxy]]]].
    rewrite -Hy.
    apply: IH => //; first by rewrite Hy.
    + apply val_inj in Hx.
      rewrite Hx in Hxy.
      move => v1 Hc1.
      apply: Hc.
      move/connectP: Hc1 => [p' Hp'] Hl.
      apply/connectP.
      exists (y :: p'); last by [].
      exact/andP.
    + apply val_inj in Hx.
      rewrite Hx in Hxy.
      move => v1 Hc1.
      apply: Hc'.
      move/connectP: Hc1 => [p' Hp'] Hl.
      apply/connectP.
      exists (y :: p'); last by [].
      exact/andP.
    + apply val_inj in Hx.
      rewrite Hx in Hxy.
      apply f_equal_g.
      apply/eqP.
      apply: Hc'.
      apply/connectP.
      exists [:: y]; last by [].
      exact/andP.
- move/connectP.
  move => Hex Hex'.
  case: Hex.
  case: Hex' => p Hp Hl.
  have H_eq' := f_equal_g H_eq.
  exists p; last by [].
  clear Hl H_eq.
  elim: p u Hp Hv' Hvf' H_eq' => //=.
  move => v0 p IH u.
  move/andP => [Hg Hp] Hc Hc' Hg'.
  apply/andP.
  move/ginsubexP: Hg => [x [y [Hx [Hy Hxy]]]].
  split.
  - rewrite -Hg' -Hy.
    apply/ginsubP.
    by move/val_inj: Hx =><-.
  - rewrite -Hy.
    rewrite -Hy in Hp.
    apply: IH => //.
    * move => v1 Hc1.
      apply: Hc.
      move/val_inj: Hx =><-.
      move/connectP: Hc1 => [p' Hp'] Hl.
      apply/connectP.
      exists (y :: p'); last by [].
      exact/andP.
    * move => v1 Hc1.
      apply: Hc'.
      move/val_inj: Hx =><-.
      move/connectP: Hc1 => [p' Hp'] Hl.
      apply/connectP.
      exists (y :: p'); last by [].
      exact/andP.
    * apply: Hc.
      move/val_inj: Hx =><-.
      apply/connectP.
      exists [:: y]; last by [].
      exact/andP.
Qed.

Lemma connect_f_f'_eq u v0 :
  (forall v' : V, connect grev v' u -> f v' == f' (val v')) ->
  connect gV' (val u) (val v0) ->
  f v0 = f' (val v0).
Proof.
move => Hgc Hc.
apply/eqP.
apply: Hgc.
apply/connect_rev.
move: Hc.
move/connectP => [p Hp] Hl.
apply/connectP.
exists (foldr (fun x (p' : seq V) => if insub x is Some x' then x' :: p' else p') [::] p).
- rewrite /=.
  elim: p u v0 Hp Hl => //=.
  move => v p IH u v0.
  move/andP => [Hi Hp] Hl.
  move: Hi.
  rewrite /insub_g.
  have H_sp := (insubP [subType of V] (sval u)).
  move: H_sp.
  case => //.
  move => u0 HPu.
  move/val_inj =>-> {u0}.
  have H_sp := (insubP [subType of V] v).
  move: H_sp.
  case => //.
  move => u0 HPv Heq Hg.
  rewrite /=.
  apply/andP.
  split => //.
  rewrite -Heq in Hp, Hl.
  by apply: IH; eauto.
- rewrite /=.
  elim: p u v0 Hp Hl => //=; first by move => u v0 Hl; apply val_inj.
  move => v p IH u v0.
  move/andP => [Hi Hp] Hl.
  move: Hi.
  rewrite /insub_g.
  have H_sp := (insubP [subType of V] (sval u)).
  move: H_sp.
  case => //.
  move => u0 HPu.
  move/val_inj =>-> {u0}.
  have H_sp := (insubP [subType of V] v).
  move: H_sp.
  case => //.
  move => u0 HPv Heq Hg.
  rewrite /=.
  by apply IH; rewrite Heq.
Qed.

Lemma check_all_cert_sound :
  forall (v : V') (r : R), (v,r) \in check_all_cert ->
  checkable' v /\ check' v = r.
Proof.
move => v r.
move/check_all_cert_cases.
case.
- (* impacted case *)
  move => [Hi Hr].
  move/check_impactedV'_cert_check: Hi => [Hi [Hi' Hi'']].
  by move/eqP: Hi'.
- (* unimpacted case *)
  move => [Hi Hr].
  have Hc: checkable' v.
    move: Hi.
    exact: V_result_filter_cert_checkable'.
  split => //.
  move/mapP: Hi.
  case; case => u b'.
  move => Hu.
  case => Hu'.
  move => Hb.
  move: Hb Hu=><- {b'}.
  rewrite mem_filter.
  move/andP.
  rewrite /=.
  move => [Hi Hu].
  have Hv: v \notin freshV' P.
    apply/negP.
    move => Hv.
    move/freshV'P: Hv => Hv.
    move/negP: (Hv u) => Hv'.
    case: Hv'.
    by apply/eqP.
  move/V_result_certP: Hu.
  move => [Hca Hch].
  have Him' := Hi.
  move: Him'.
  move/imsetP.
  move => Hx.
  have Him': u \notin impacted g^-1 (modifiedV f' f).
    apply/negP => Him'.
    case: Hx.
    by exists u.
  have Him'' := Him'.
  move/impactedVP: Him''.
  move => Hx'.
  have Hum: u \notin modifiedV f' f.
    apply/negP.
    move => Hu.
    case: Hx'.
    exists u; first by [].
    apply/connectP.
    by exists [::].
  have Hall: forall v', connect grev v' u -> v' \notin modifiedV f' f.
    move => v' Hc'.
    apply/negP => Hv'.
    case: Hx'.
    by exists v'.
  move: Hall {Hx' Hi Hx} => Hall.
  have Hu'': f u == f' (val u) by apply/not_modifiedP.
  have Hall': forall v', connect grev v' u -> f v' == f' (val v').
    move => v' Hc'.
    apply/not_modifiedP.
    by apply Hall.
  have Hallg': forall v, connect grev v u -> forall v', gV' (val v) v' = g' (val v) v'.
    move => v' Hc'.
    apply f_equal_g.
    apply/eqP.
    exact: Hall'.
  rewrite -Hch.
  rewrite Hu'.
  apply sym_eq.
  apply check_V_V' => //.
  * rewrite -checkable_V_V' //.
    apply/eqP.
    by apply: Hall'.
  * exact: connect_gV'_rev.
  * move => v0.
    exact: connect_f_f'_eq.
Qed.

End Changed.

Section Other.

Variable A : eqType.
Variable V' : finType.
Variable P : pred V'.
Local Notation V := (sig_finType P).
Variable f' : V' -> A.
Variable f : V -> A.
Variable checkable' : pred V'.
Variable checkable : pred V.
Variable R : eqType.
Variable check : V -> R.
Variable check' : V' -> R.
Variables (g1 : rel V) (g2 : rel V).
Variable g' : rel V'.

Local Notation g1V' := [rel x y : V' | insub_g g1 x y].

Hypothesis g1_g2_connect : connect g1 =2 connect g2.

Hypothesis f_equal_g1 :
  forall v, f v = f' (val v) -> forall v', g1V' (val v) v' = g' (val v) v'.

Hypothesis checkable_V_V' :
  forall v, f v = f' (val v) -> checkable v = checkable' (val v).

Hypothesis check_V_V' :
  forall v, checkable v -> checkable' (val v) ->
  (forall v', connect g1V' (val v) v' = connect g' (val v) v') ->
  (forall v', connect g1V' (val v) (val v') -> f v' = f' (val v')) ->
  check v = check' (val v).

Variable V_result_cert : seq (V * R).
Hypothesis V_result_certP :
  forall (v : V) (r : R), reflect (checkable v /\ check v = r) ((v,r) \in V_result_cert).
Hypothesis V_result_cert_uniq : uniq [seq vr.1 | vr <- V_result_cert].

Lemma check_all_cert_V'_uniq_g2 : uniq (check_all_cert_V' f' f g2 checkable' check' V_result_cert).
Proof.
rewrite /check_all_cert_V' /check_all_cert /check_impactedV'_cert /checkable_impacted_fresh.
erewrite <- connect_checkable_impactedV'; eauto.
rewrite /V'_result_filter_cert /impactedVV'.
erewrite <- connect_impactedV_eq; eauto.
exact: check_all_cert_V'_uniq.
Qed.

Lemma check_all_cert_complete_g2 :
  forall v, checkable' v -> v \in check_all_cert_V' f' f g2 checkable' check' V_result_cert.
Proof.
move => v Hc.
rewrite /check_all_cert_V' /check_all_cert /check_impactedV'_cert /checkable_impacted_fresh.
erewrite <- connect_checkable_impactedV'; eauto.
rewrite /V'_result_filter_cert /impactedVV'.
erewrite <- connect_impactedV_eq; eauto.
by apply: check_all_cert_complete; eauto.
Qed.

Lemma check_all_cert_sound_g2 :
  forall (v : V') (r : R), (v,r) \in check_all_cert f' f g2 checkable' check' V_result_cert ->
  checkable' v /\ check' v = r.
Proof.
move => v r.
rewrite /check_all_cert /check_impactedV'_cert /checkable_impacted_fresh.
erewrite <- connect_checkable_impactedV'; eauto.
rewrite /V'_result_filter_cert /impactedVV'.
erewrite <- connect_impactedV_eq; eauto.
by apply: check_all_cert_sound; eauto.
Qed.

End Other.


Require Export Syntax.
Require Import Types.

(*
--------
Program
--------
*)

Inductive wfMethodSig (P : program) : methodSig -> Prop :=
  WF_Msig :
    forall m x t t',
      wfType P t ->
      wfType P t' ->
      wfMethodSig P (MethodSig m (x, t) t').

Inductive wfInterface (P : program) : interfaceDecl -> Prop :=
  | WF_Interface :
      forall i msigs,
        Forall (wfMethodSig P) msigs ->
        wfInterface P (Interface i msigs)
  | WF_ExtInterface :
      forall i i1 i2 msigs1 msigs2,
        methodSigs P (TInterface i1) msigs1 ->
        methodSigs P (TInterface i2) msigs2 ->
        (forall m msig, methodSigLookup msigs1 m = Some msig -> methodSigLookup msigs2 m = None) ->
        (forall m msig, methodSigLookup msigs2 m = Some msig -> methodSigLookup msigs1 m = None) ->
        wfInterface P (ExtInterface i i1 i2).

Inductive wfFieldDecl (P : program) : fieldDecl -> Prop :=
  | WF_Field :
      forall f t r,
        wfType P t ->
        wfFieldDecl P (Field f t r).

Inductive wfMethodDecl (P : program) (c : class_id) : methodDecl -> Prop :=
  | WF_Method :
      forall m x t t' e,
      wfType P t ->
      (* This should be derivable, but this makes things simpler *)
      wfType P t' ->
      x <> this ->
      (* This should also be derivable *)
      remove id_eq_dec x
             (remove id_eq_dec this (freeVars e)) = nil ->
      exprStatic e ->
        (let Gamma := extend
                        (extend empty
                                (env_var (SV x)) t)
                        (env_var (SV this)) (TClass c) in
         P ; Gamma |- e \in t') ->
        wfMethodDecl P c (Method m (x, t) t' e).

Inductive wfClassDecl (P : program) : classDecl -> Prop :=
  | WF_Class :
      forall c i fs ms msigs,
        methodSigs P (TInterface i) msigs ->
        extractSigs ms = msigs ->
        Forall (wfFieldDecl P) fs ->
        Forall (wfMethodDecl P c) ms ->
        wfClassDecl P (Cls c i fs ms).

Inductive wfProgram : program -> ty -> Prop :=
  | WF_Program :
      forall cds ids e t,
        Forall (wfClassDecl (cds, ids, e)) cds ->
        Forall (wfInterface (cds, ids, e)) ids ->
        (cds, ids, e); empty |- e \in t ->
        wfProgram (cds, ids, e) t.

(*
-------
Heap
-------
*)

Inductive wfFields (P : program) (Gamma : env) (c : class_id) (F : dyn_fields) : Prop :=
  WF_Fields :
    forall fs,
      fields P (TClass c) = Some fs ->
      (forall f t r, fieldLookup fs f = Some (Field f t r) ->
                   exists v, F f = Some v /\ P; Gamma |- EVal v \in t) ->
      wfFields P Gamma c F.

Inductive wfRegionLocks (P : program) (c : class_id) (RL : region_locks) : Prop :=
  | WF_RegionLocks :
      forall fs,
        fields P (TClass c) = Some fs ->
        (forall f t r, fieldLookup fs f = Some (Field f t r) ->
                       exists status, RL r = Some status) ->
        wfRegionLocks P c RL.

Inductive wfHeap (P : program) (Gamma : env) : heap -> Prop :=
  WF_Heap :
    forall H,
      wfEnv P Gamma ->
      (forall l c, Gamma (env_loc l) = Some (TClass c) ->
                   exists F RL, heapLookup H l = Some (c, F, RL) /\
                                wfFields P Gamma c F /\
                                wfRegionLocks P c RL) ->
      (forall l, heapLookup H l <> None -> exists c, Gamma (env_loc l) = Some (TClass c)) ->
      wfHeap P Gamma H.

(*
------
Vars
------
*)

Definition freshVars (n : nat) (V : dvar_map) :=
  (forall n', n <= n' -> fresh V (DVar n')).

Inductive wfVars (P : program) (Gamma : env) (n : nat) (V : dvar_map) : Prop :=
  WF_Vars :
      wfEnv P Gamma ->
      (forall x t, Gamma (env_var (DV x)) = Some t -> exists v, V x = Some v /\ P; Gamma |- (EVal v) \in t) ->
      (forall x, V x <> None -> Gamma (env_var (DV x)) <> None) ->
      freshVars n V ->
      wfVars P Gamma n V.

(*
------
Locks
------
*)

Inductive wfLock (H : heap) : lock -> Prop :=
  | WF_Lock :
      forall l r c F RL,
        heapLookup H l = Some (c, F, RL) ->
        RL r = Some (LLocked) ->
        wfLock H (l, r).

Inductive wfHeldLocks (H : heap) (Ls : list lock) : Prop :=
  | WF_HeldLocks :
      Forall (wfLock H) Ls ->
      wfHeldLocks H Ls.

Inductive wfLocks (Ls : list lock) (e : expr) : Prop :=
  | WF_Locks :
      (forall l, In l (locks e) -> In l Ls) ->
      NoDup (locks e) ->
      wfLocks Ls e.

Inductive disjointLocks (T1 T2 : threads) : Prop :=
  | DisjointLocks :
      (forall L, In L (heldLocks T1) -> ~ In L (heldLocks T2)) ->
      (forall L, In L (heldLocks T2) -> ~ In L (heldLocks T1)) ->
      disjointLocks T1 T2.

Inductive wfLocking (H : heap) : threads -> Prop :=
  | WF_Locking_Thread :
      forall Ls e,
        wfHeldLocks H Ls ->
        NoDup Ls ->
        wfLocks Ls e ->
        wfLocking H (T_Thread Ls e)
  | WF_Locking_Async :
      forall T1 T2 e,
        wfLocks (leftmost_locks T1) e ->
        (forall L, In L (locks e) -> ~In L (t_locks T1)) ->
        disjointLocks T1 T2 ->
        wfLocking H T1 ->
        wfLocking H T2 ->
        wfLocking H (T_Async T1 T2 e)
  | WF_Locking_EXN :
      forall Ls,
        wfHeldLocks H Ls ->
        wfLocking H (T_EXN Ls).

(*
--------
Threads
--------
*)

Inductive wfThreads (P : program) (Gamma : env) : threads -> ty -> Prop :=
  | WF_Thread :
      forall Ls e t,
        freeVars e = nil ->
        P; Gamma |- e \in t ->
        wfThreads P Gamma (T_Thread Ls e) t
  | WF_Async :
      forall T1 T2 e t t1 t2,
        freeVars e = nil ->
        P; Gamma |- e \in t ->
        wfThreads P Gamma T1 t1 ->
        wfThreads P Gamma T2 t2 ->
        wfThreads P Gamma (T_Async T1 T2 e) t
  | WF_EXN :
      forall t Ls,
        wfType P t ->
        wfEnv P Gamma ->
        wfThreads P Gamma (T_EXN Ls) t.

(*
--------------
Configuration
--------------
*)

Inductive wfConfiguration (P : program) (Gamma : env) : configuration -> ty -> Prop :=
  | WF_Cfg :
      forall H V n T t,
        0 < n ->
        wfHeap P Gamma H ->
        wfVars P Gamma n V ->
        wfThreads P Gamma T t ->
        wfLocking H T ->
        wfConfiguration P Gamma (H, V, n, T) t.


Require Import Bool List Arith Nat.
Import ListNotations.
Require Import Mmx.ast_instructions Mmx.binary Mmx.association_list Mmx.encodeProof Mmx.decodeProof Mmx.encode.

(* Proof about encode_decode_flux *)

Lemma encode_decode_decoup_flux_decoup : forall (lb : list binary_instruction) (l : list instruction),
    encode_flux l = Some lb -> decode_flux_decoup lb = Some l.
Proof.
  induction lb.
  -intros.
   unfold encode_flux in H.
   assert (traverse (encode_flux_opt l) = Some [] -> l = []).
   {
     destruct l.
     -reflexivity.
     -simpl.
      destruct (encode i).
      +destruct (traverse (encode_flux_opt l)).
       discriminate.
       discriminate.
      +discriminate.
   }
   apply H0 in H.
   rewrite H.
   auto.
  -destruct l.
   +unfold encode_flux.
    simpl.
    discriminate.
   +intros.
    assert (keep : encode_flux (i :: l) = Some (a :: lb)) by auto.
    assert (encode_flux (i :: l) = Some (a :: lb) -> encode i = Some a).
    {
      unfold encode_flux.
      simpl.
      intros.
      destruct (encode i).
      assert (encode_flux (i :: l) = Some (a :: lb) -> encode_flux l = Some lb).
      {
        unfold encode_flux.
        simpl.
        intros.
        destruct (encode i).
        -destruct (traverse (encode_flux_opt l)).
         +inversion H1.
          reflexivity.
         +discriminate.
        -discriminate.
      }
      apply H1 in H.
      assert (traverse (encode_flux_opt l) = encode_flux l).
      {
        unfold encode_flux.
        reflexivity.
      }
      rewrite H2 in H0.
      rewrite H in H0.
      -inversion H0.
       reflexivity.
      -discriminate.
    }
    apply H0 in H.
    unfold decode_flux_decoup.
    simpl.
    apply encode_decode in H.
    rewrite H.
    fold decode_flux_decoup.
    assert (traverse (decode_flux_opt lb) = decode_flux_decoup lb).
    {
      unfold decode_flux_decoup.
      reflexivity.
    }
    rewrite H1.
    assert (decode_flux_decoup lb = Some l).
    {
      apply IHlb.
      assert (encode_flux (i :: l) = Some (a :: lb) -> encode_flux l = Some lb).
      {
        unfold encode_flux.
        simpl.
        intros.
        destruct (encode i).
        -destruct (traverse (encode_flux_opt l)).
         +inversion H2.
          reflexivity.
         +discriminate.
        -discriminate.
      }
      apply H2 in keep.
      auto.
    }
    rewrite H2.
    reflexivity.
Qed.

Lemma decode_decoup_encode_flux : forall (l : list instruction) (lb : list binary_instruction),
    decode_flux_decoup lb = Some l -> encode_flux l = Some lb.
Proof.
  induction l.
  -unfold decode_flux_decoup.
   unfold encode_flux.
   intros.
   assert (traverse (decode_flux_opt lb) = Some [] -> lb = []).
   {
     destruct lb.
     -reflexivity.
     -simpl.
      destruct (decode b).
      +destruct (traverse (decode_flux_opt lb)).
       discriminate.
       discriminate.
      +discriminate.
   }
   apply H0 in H.
   rewrite H.
   reflexivity.
  -intros.
   destruct lb.
   +unfold decode_flux_decoup in H.
    simpl in H.
    discriminate.
   +assert (keep : decode_flux_decoup (b :: lb) = Some (a :: l)) by auto.
    assert (keep2 : decode_flux_decoup (b :: lb) = Some (a :: l)) by auto.
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> decode_flux_decoup lb = Some l).
    {
      unfold decode_flux_decoup.
      intros.
      simpl in H0.
      destruct (decode b).
      -destruct (traverse (decode_flux_opt lb)).
       +inversion H0.
        reflexivity.
       +discriminate.
      -discriminate.
    }
    apply H0 in H.
    unfold encode_flux.
    simpl.
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> decode b = Some a).
    {
      intros.
      unfold decode_flux_decoup in H1.
      simpl in H1.
      destruct (decode b).
      -destruct (traverse (decode_flux_opt lb)).
       +inversion H1.
       reflexivity.
       +discriminate.
      -discriminate.
    }
    apply H1 in keep.
    Search decode.
    apply decode_encode in keep.
    {
      rewrite keep.
      assert (traverse (encode_flux_opt l) = encode_flux l).
      {
        unfold encode_flux.
        reflexivity.
      }
      rewrite H2.
      assert (encode_flux l = Some lb).
      {
        apply IHl.
        auto.
      }
      rewrite H3.
      reflexivity.
    }
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> length b = 32).
    {
      unfold decode_flux_decoup.
      simpl.
      intros.
      Search decode.
      Check decode_size.
      apply decode_size in keep.
      auto.
    }
    apply H2 in keep2.
    auto.
Qed.

(* Some proofs about cut32 and concatlistes *)

(* good proofs *)
Lemma app_cut32 : forall (l1 l2 : list bool) (ll : list (list bool)), length l1 = 32 -> cut32 l2 = Some ll
                                                                      -> cut32 (l1 ++ l2) = Some (l1 :: ll).
Proof.
  intros.
  unfold cut32.
  assert (length (l1 ++ l2) mod 32 =? 0 = true).
  {
    rewrite app_length.
    rewrite H.
    Search ((_ + _) mod _).
    rewrite Nat.add_mod.
    -{
        Search (_ mod _ = 0).
        rewrite Nat.mod_same.
        -Search (0 + _).
         rewrite plus_O_n.
         unfold cut32 in H0.
         destruct (length l2 mod 32).
         +reflexivity.
         +discriminate.
        -auto.
     }
    -auto.
  }
  rewrite H1.
  assert(length (l1 ++ l2) / 32 = S (length l2 / 32)).
  {
    rewrite app_length.
    rewrite H.
    Check Nat.div_add_l.
    specialize (Nat.div_add_l 1 32 (length l2)).
    intros.
    Search (1 * _).
    rewrite Nat.mul_1_l in H2.
    apply H2.
    auto.
  }
  rewrite H2.
  unfold cut32_n.
  assert (firstn 32 (l1 ++ l2) = l1).
  {
    Search (_ = _ -> _ <= _).
    Search firstn.
    Check firstn_app_2.
    rewrite <- H.
    Search (_ + 0).
    specialize (plus_n_O (length l1)).
    intros.
    rewrite H3.
    Check firstn_app_2.
    specialize (firstn_app_2 0 l1 l2).
    intros.
    rewrite H4.
    simpl.
    Search (_ ++ []).
    apply app_nil_r.
  }
  rewrite H3.
  fold cut32_n.
  Search (_ :: _ = _ :: _).
  assert (forall (l1 l2: list (list bool)), l1 = l2 -> Some l1 = Some l2).
  {
    intros.
    rewrite H4.
    reflexivity.
  }
  apply H4.
  Check delete_concat.
  assert (forall (lb : list bool) (ll1 ll2 : list (list bool)), ll1 = ll2 -> lb :: ll1 = lb :: ll2).
  {
    intros.
    rewrite H5.
    reflexivity.
  }
  apply H5.
  unfold cut32 in H0.
  assert (length l2 mod 32 =? 0 = true).
  {
    destruct (length l2 mod 32).
    -reflexivity.
    -simpl in H0.
     discriminate.
  }
  rewrite H6 in H0.
  assert (skipn 32 (l1 ++ l2) = l2).
  {
    SearchAbout skipn.
    assert (firstn 32 (l1 ++ l2) ++ skipn 32 (l1 ++ l2) = (l1 ++ l2)).
    {
      apply firstn_skipn.
    }
    rewrite H3 in H7.
    Search (_ ++ _ = _ ++ _).
    apply app_inv_head in H7.
    auto.
  }
  rewrite H7.
  inversion H0.
  assert (forall (n : nat), n / 32 = fst (Nat.divmod n 31 0 31)).
  {
    destruct n.
    -reflexivity.
    -reflexivity.
  }
  rewrite H8.
  reflexivity.
Qed.

Lemma concat_listes_cut32 : forall (ll : list (list bool)) (l : list bool) ,
    concat_listes_32 ll = Some l -> cut32 l = Some ll.
Proof.
  assert (I : forall (ll : list (list bool)) (l : list bool), concat_listes_32 ll = Some l -> cut32 l = Some ll).
  {
    induction ll.
    -assert (I_1 : forall l : list bool, concat_listes_32 [] = Some l -> cut32 l = Some []).
     {
       intros.
       simpl in H.
       inversion H.
       reflexivity.
     }
     auto.
    -assert(forall l : list bool, concat_listes_32 (a :: ll) = Some l -> cut32 l = Some (a :: ll)).
     {
       intros.
       unfold concat_listes_32 in H.
       apply bind_rewrite in H.
       destruct H.
       destruct H.
       fold concat_listes_32 in H0.
       destruct (length a =? 32) eqn:H1.
       -{
           inversion H.
           specialize (IHll x).
           apply commut_equal in H0.
           apply IHll in H0.
           Check app_cut32.
           apply app_cut32.
           -apply beq_nat_true in H1.
            auto.
           -auto.
         }
       -discriminate.
     }
     auto.
  }
  auto.
Qed.

(* i made separatly the two case proof *)
Lemma cut32_concat_nil : forall (l : list bool),
    cut32 l = Some [] -> concat_listes_32 [] = Some l.
Proof.
  intros.
  assert (cut32 l = Some [] -> length l = 0).
  {
    destruct (length l) eqn:H1.
    -reflexivity.
    -intros.
     unfold cut32 in H0.
     destruct (length l mod 32 =? 0) eqn:H2.
     +destruct (length l / 32) eqn:H3.
      {
        Search (_ / _ = 0).
        specialize (Nat.div_small_iff (length l) 32).
        intros.
        assert (32 <> 0) by auto.
        apply H4 in H5.
        apply beq_nat_true in H2.
        apply H5 in H3.
        assert (forall (n' m': nat), n' = S m' -> n' < 32 -> n' mod 32 = n').
        {
          intros.
          apply Nat.mod_small.
          auto.
        }
        apply Nat.mod_small in H3.
        rewrite H3 in H2.
        rewrite H1 in H2.
        discriminate.
      }
      {
        unfold cut32_n in H0.
        fold cut32_n in H0.
        inversion H0.
      }
     +discriminate.
  }
  apply H0 in H.
  Search (length _ = 0).
  apply length_zero_iff_nil in H.
  rewrite H.
  reflexivity.
Qed.

Lemma cut32_length : forall (l l': list bool) (ll : list (list bool)),
    cut32 l = Some (l' :: ll) -> length l' = 32.
Proof.
  assert (div_S_n : forall (n m q : nat), n / m = S q -> m <= n).
  {
    intros.
    apply Nat.div_str_pos_iff.
    -destruct m.
     +discriminate.
     +auto.
    -rewrite H.
     apply Nat.lt_0_succ.
  }
  intros.
  unfold cut32 in H.
  destruct (length l mod 32 =? 0) eqn:H1.
  -destruct (length l / 32) eqn:H2.
   +simpl in H.
    discriminate.
   +unfold cut32_n in H.
    fold cut32_n in H.
    assert (32 <= length l) by (specialize (div_S_n (length l) 32 n);auto).
    assert (forall (l1 l2: list bool) (tl1 tl2 : list (list bool)), Some (l1 :: tl1) = Some (l2 :: tl2) -> l1 = l2).
    { intros. inversion H3. reflexivity. }
    apply H3 in H.
    rewrite <- H.
    Search firstn.
    apply firstn_length_le.
    auto.
  -discriminate.
Qed.

Lemma cut32_firstn : forall (l l': list bool) (ll : list (list bool)),
    cut32 l = Some (l' :: ll) -> firstn 32 l = l'.
Proof.
  intros.
  unfold cut32 in H.
  destruct (length l mod 32 =? 0) eqn:H0.
  -unfold cut32_n in H.
   destruct ((length l / 32)) eqn:H1.
   +discriminate.
   +fold cut32_n in H.
    inversion H.
    reflexivity.
  -discriminate.
Qed.

Lemma skipn_length : forall (l : list bool), 32 <= length l -> length (skipn 32 l) = length l - 32.
Proof.
  Search skipn.
  intros.
  specialize (firstn_skipn 32 l).
  intros.
  rewrite <- H0.
  rewrite app_length.
  Search firstn.
  rewrite firstn_length_le.
  -rewrite minus_plus.
   rewrite H0.
   reflexivity.
  -auto.
Qed.
Search (_ mod _ = 0).

(* Lemma mod_zero : forall (n m : nat), n mod m = 0 -> n = 0 \/ exists (a : nat),  a * n = m. *)
(* Proof. *)
(*   intros. *)
(*   Search (_ mod _ = 0). *)
(*   apply Nat.div_exact in H. *)
(*   -right. *)
(*    rewrite H. *)
(*    Search (_ * (_ / _)). *)
(*    admit. *)
(*   - *)

Lemma mod_sub : forall (n : nat), n mod 32 = 0 -> (n - 32) mod 32 = 0.
Proof.
  intros.
  specialize (Nat.mod_divides n 32).
  intros.
  assert (32 <> 0) by auto.
  apply H0 in H1.
  apply H1 in H.
  destruct H.
  rewrite H.
  Search (_ * _ - _).
  rewrite <- Nat.mul_pred_r.
  induction x.
  -reflexivity.
  -Search (Nat.pred (S _)).
   rewrite <- pred_Sn.
   Search (_ * _ mod _ = 0).
   Search (_ * _ = _ * _).
   rewrite Nat.mul_comm.
   apply Nat.mod_mul.
   auto.
Qed.

Lemma equal_succ_diff_0 : forall (n' m' : nat), n' = S m' -> 0 < n'.
Proof.
  intros.
  rewrite H.
  Search (0 < S _).
  apply Nat.lt_0_succ.
Qed.

Lemma div_sub : forall (n m k : nat), n <> 0 -> n / m = S k -> (n - m) / m = k.
Proof.
Admitted.

Lemma diff_zero : forall (n : nat), 32 <= n -> n <> 0.
Proof.
  destruct n.
  -Search (_ <= 0).
   intros.
   apply Nat.nle_succ_0 in H.
   inversion H.
  -auto.
Qed.

Lemma cut32_concat_listes : forall (ll : list (list bool)) (l : list bool),
    cut32 l = Some ll -> concat_listes_32 ll = Some l.
Proof.
  induction ll.
  -apply cut32_concat_nil.
  -intros.
   assert (cut32 (skipn 32 l) = Some ll).
   {
     unfold cut32 in H.
     destruct (length l mod 32 =? 0) eqn:H0.
     -destruct (length l / 32) eqn:H1.
      +simpl in H.
       discriminate.
      +unfold cut32_n in H.
       fold cut32_n in H.
       assert (forall (a b : list bool) (l1 l2 : list (list bool)), Some (a :: l1) = Some (b :: l2) -> Some l1 = Some l2).
       {
         intros.
         inversion H2.
         reflexivity.
       }
       apply H2 in H.
       assert (forall (ll1 ll2 : list (list bool)), Some ll1 = Some ll2 -> ll1 = ll2).
       {
         intros. inversion H3. reflexivity.
       }
       apply H3 in H.
       unfold cut32.
       assert (32 <= length l).
       {
         Search (_ / _).
         Check Nat.div_str_pos_iff.
         specialize (Nat.div_str_pos_iff (length l) 32).
         intros.
         assert (32 <> 0) by auto.
         apply H4 in H5.
         apply equal_succ_diff_0 in H1.
         apply H5 in H1.
         auto.
       }
       assert (length (skipn 32 l) mod 32 =? 0 = true).
       {
         assert (length (skipn 32 l) = length l - 32).
         {
           Check skipn_length.
           apply skipn_length.
           auto.
         }
         rewrite H5.
         auto.
         Check mod_sub.
         specialize (mod_sub (length l)).
         intros.
         apply beq_nat_true in H0.
         apply mod_sub in H0.
         rewrite H0.
         reflexivity.
       }
       rewrite H5.
       assert ((length (skipn 32 l) / 32) = n).
       {
         Check skipn_length.
         rewrite skipn_length.
         -apply div_sub in H1.
          auto.
          assert (length l <> 0).
          {
            apply diff_zero in H4.
            auto.
          }
          auto.
         -auto.
       }
       rewrite H6.
       rewrite H.
       reflexivity.
     -discriminate.
   }
   simpl.
   specialize (IHll (skipn 32 l)).
   rewrite IHll.
   +assert (length a =? 32 = true).
    {
      Check cut32_length.
      apply cut32_length in H.
      rewrite H.
      reflexivity.
    }
    rewrite H1.
    assert (l = firstn 32 l ++ skipn 32 l).
    {
      rewrite firstn_skipn.
      reflexivity.
    }
    assert (a = firstn 32 l).
    {
      apply cut32_firstn in H.
      apply commut_equal.
      auto.
    }
    rewrite H3.
    unfold bind.
    rewrite <- H2.
    reflexivity.
   +auto.
Qed.

(* Finals goal of this file, proofs about encode_flux_b and decode_flux_b *)

Lemma encode_decode_flux_decoup : forall (lb : list bool) (l : list instruction),
    encode_flux_b l = Some lb -> decode_flux lb = Some l.
Proof.
  intros.
  unfold encode_flux_b in H.
  destruct encode_flux eqn:H1.
  -Search (encode_flux).
   apply encode_decode_decoup_flux_decoup in H1.
   unfold decode_flux.
   Search concat_listes_32.
   apply concat_listes_cut32 in H.
   rewrite H.
   auto.
  -discriminate.
Qed.

Lemma decode_flux_decoup_encode : forall (lb : list bool) (l : list instruction),
    decode_flux lb = Some l -> encode_flux_b l = Some lb.
Proof.
  intros.
  unfold decode_flux in H.
  unfold encode_flux_b.
  destruct (cut32 lb) eqn:H1.
  -simpl in H. Search (decode_flux_decoup).
   apply decode_decoup_encode_flux in H.
   rewrite H.
   Search cut32.
   apply cut32_concat_listes in H1.
   rewrite H1.
   reflexivity.
  -simpl in H.
   discriminate.
Qed.


Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Trivial.
Require Import Logic.MinimumLogic.Sound.Sound_Classical_Trivial.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Sound.Sound_Classical_Trivial.

(* TODO: split part of this file into MinimumLogic folder. *)

Instance Pred_minL (A: Type): MinimumLanguage (Pred_L A) := Build_MinimumLanguage (Pred_L A) Semantics.impp.

Instance Pred_andpL (A: Type): AndLanguage (Pred_L A) := Build_AndLanguage (Pred_L A) Semantics.andp.

Instance Pred_orpL (A: Type): OrLanguage (Pred_L A) := Build_OrLanguage (Pred_L A) Semantics.orp.

Instance Pred_falsepL (A: Type): FalseLanguage (Pred_L A) := Build_FalseLanguage (Pred_L A) Semantics.falsep.

Instance Pred_tminSM (A: Type): TrivialMinimumSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  intros; apply Same_set_refl.
Qed.

Instance Pred_andpSM (A: Type): AndSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_orpSM (A: Type): OrSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_falsepSM (A: Type): FalseSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  + apply Same_set_refl.
Qed.

Instance Pred_Gamma (A: Type): Provable (Pred_L A) :=
  Build_Provable (Pred_L A) (fun x: expr => forall a: A, x a).

Instance Pred_minAX (A: Type): MinimumAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y ? ? m.
    pose proof @sound_modus_ponens (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y.
    exact (H1 m (H m) (H0 m)).
  + intros x y.
    exact (@sound_axiom1 (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y).
  + intros x y z.
    exact (@sound_axiom2 (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y z).
Qed.

Instance Pred_andpAX (A: Type): AndAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y.
    exact (@sound_andp_intros (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_andpSM A) x y).
  + intros x y.
    exact (@sound_andp_elim1 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_andpSM A) x y).
  + intros x y.
    exact (@sound_andp_elim2 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_andpSM A) x y).
Qed.

Instance Pred_orpAX (A: Type): OrAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y.
    exact (@sound_orp_intros1 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_orpSM A) x y).
  + intros x y.
    exact (@sound_orp_intros2 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_orpSM A) x y).
  + intros x y z.
    exact (@sound_orp_elim (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_orpSM A) x y z).
Qed.

Instance Pred_falsepAX (A: Type): FalseAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x.
    exact (@sound_falsep_elim (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_falsepSM A) x).
Qed.
(*TODO: need to adjust(about classical)
Instance Pred_cpGamma (A: Type): ClassicalPropositionalLogic (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  intros x.
  exact (@sound_excluded_middle (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x).
Qed.
*)
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Semantics.SemanticEquiv.
Require Import Logic.PropositionalLogic.Semantics.Kripke.

Instance Pred_kiSM (A: Type): @KripkeIntuitionisticSemantics (Pred_L A) (Build_Model A) (unit_kMD _) tt eq (Pred_SM A) :=
  @eqR_KripkeIntuitionistic _ _ _.

Instance Pred_kminSM (A: Type): @KripkeMinimumSemantics (Pred_L A) (Pred_minL A) (Build_Model A) (unit_kMD _) tt eq (Pred_SM A) :=
  @Trivial2Kripke _ _ _ _ (Pred_tminSM A).

Instance Pred_kandpSM (A: Type): @KripkeAndSemantics (Pred_L A) (Pred_andpL A) (Build_Model A) (unit_kMD _) tt (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_korpSM (A: Type): @KripkeOrSemantics (Pred_L A) (Pred_orpL A) (Build_Model A) (unit_kMD _) tt (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_kfalsepSM (A: Type): @KripkeFalseSemantics (Pred_L A) (Pred_falsepL A) (Build_Model A) (unit_kMD _) tt (Pred_SM A).
Proof.
  constructor.
  + apply Same_set_refl.
Qed.


Require Import Coq.Relations.Relation_Operators.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OSAExamples.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.

Local Open Scope kripke_model.
Import KripkeModelNotation_Intuitionistic.

Class Action: Type := {
  action: Type;
  trace := list action;
  traces := trace -> Prop
}.

Definition singleton_trace {Ac: Action} (a: action): trace := cons a nil.

Definition singleton_traces {Ac: Action} (tr: trace): traces := eq tr.

Definition trace_app {Ac: Action}: trace -> trace -> trace := @app _.

Inductive traces_app {Ac: Action}: traces -> traces -> traces :=
  traces_app_intro: forall tr1 tr2 (Tr1 Tr2: traces), Tr1 tr1 -> Tr2 tr2 -> traces_app Tr1 Tr2 (trace_app tr1 tr2).

Class Command2Traces (P: ProgrammingLanguage) (Ac: Action): Type := {
  cmd_denote: cmd -> traces
}.

Class ActionInterpret (state: Type) (Ac: Action): Type := {
  state_enable: action -> state -> MetaState state -> Prop (*;
  state_enable_pf: forall a s ms1 ms2, state_enable a s ms1 -> state_enable a s ms2 -> ms1 = ms2*)
}.

Class TraceSemantics (P: ProgrammingLanguage) (state: Type) (Ac: Action): Type := {
  c2t :> Command2Traces P Ac;
  ac_sem :> ActionInterpret state Ac
}.

Class Action_resource (Ac: Action) (Res: Resource) : Type := {
  Aacquire_res: resource -> action;
  Arelease_res: resource -> action;
}.

Class NormalAction_resource (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res}: Type := {
  Aacquire_res_inv: forall r1 r2, Aacquire_res r1 = Aacquire_res r2 -> r1 = r2;
  Arelease_res_inv: forall r1 r2, Arelease_res r1 = Arelease_res r2 -> r1 = r2;
  Aacquire_Arelease_res: forall r1 r2, Aacquire_res r1 <> Arelease_res r2;
}.

Definition is_resource_action {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} (r: resource) (a: action) := Aacquire_res r = a \/ Arelease_res r = a.

Definition is_resources_action {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} (a: action) := exists r, is_resource_action r a.

Ltac solve_resource_action :=
  repeat
  match goal with
  | H: Aacquire_res ?r1 = Aacquire_res ?r2 |- _ => apply Aacquire_res_inv in H; subst
  | H: Arelease_res ?r1 = Arelease_res ?r2 |- _ => apply Arelease_res_inv in H; subst
  | H: Aacquire_res ?r1 = Arelease_res ?r2 |- _ => exfalso; apply Aacquire_Arelease_res in H; apply H
  | H: Arelease_res ?r1 = Aacquire_res ?r2 |- _ => exfalso; symmetry in H; apply Aacquire_Arelease_res in H; apply H
  | H: ~ is_resource_action ?r (Aacquire_res ?r) |- _ => exfalso; apply H; left; auto
  | H: ~ is_resource_action ?r (Arelease_res ?r) |- _ => exfalso; apply H; right; auto
  | H: ~ is_resources_action (Aacquire_res ?r) |- _ => exfalso; apply H; exists r; left; auto
  | H: ~ is_resources_action (Arelease_res ?r) |- _ => exfalso; apply H; exists r; right; auto
  end;
  repeat
  let HH := fresh "H" in
  match goal with
  | H: ~ is_resource_action ?r1 (Aacquire_res ?r2) |- _ =>
         specialize (fun (HH: r2 = r1) => H (or_introl (f_equal Aacquire_res (eq_sym HH))))
  | H: ~ is_resource_action ?r1 (Arelease_res ?r2) |- _ =>
         specialize (fun (HH: r2 = r1) => H (or_intror (f_equal Arelease_res (eq_sym HH))))
  end.

Instance Res_Join (Res: Resource): Join resources := Pred_Join resource.

Instance Res_SA (Res: Resource): SeparationAlgebra resources := Pred_SA resource.

(* res_enable A1 A1' A2 := A1 ==> A1' while A2 is the environ *)
Inductive res_enable {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res}: action -> resources -> resources -> resources -> Prop :=
| res_enable_acq: forall r A1 A1' A2, join A1 (eq r) A1' -> ~ A2 r -> res_enable (Aacquire_res r) A1 A1' A2
| res_enable_rel: forall r A1 A1' A2, join A1' (eq r) A1 -> res_enable (Arelease_res r) A1 A1' A2
| res_enable_other: forall a A1 A2, ~ is_resources_action a -> res_enable a A1 A1 A2.

Lemma res_enable_acq_inv {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}:
  forall r A1 A1' A2, res_enable (Aacquire_res r) A1 A1' A2 -> join A1 (eq r) A1' /\ ~ A2 r.
Proof.
  intros.
  inversion H; subst; solve_resource_action.
  auto.
Qed.

Lemma res_enable_rel_inv {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}:
  forall r A1 A1' A2, res_enable (Arelease_res r) A1 A1' A2 -> join A1' (eq r) A1.
Proof.
  intros.
  inversion H; subst; solve_resource_action.
  auto.
Qed.

Lemma res_enable_not_res_inv {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}:
  forall a A1 A1' A2, ~ is_resources_action a -> res_enable a A1 A1' A2 -> A1 = A1'.
Proof.
  intros.
  inversion H0; subst; solve_resource_action.
  auto.
Qed.

Inductive start_by_Aacq {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res}: resource -> trace -> Prop :=
| start_by_Aacq_nil: forall r, start_by_Aacq r nil
| start_by_Aacq_acq: forall r tr, start_by_Arel r tr -> start_by_Aacq r (cons (Aacquire_res r) tr)
| start_by_Aacq_irr: forall r a tr, ~ is_resource_action r a -> start_by_Aacq r tr -> start_by_Aacq r (cons a tr)
with start_by_Arel {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res}: resource -> trace -> Prop :=
| start_by_Arel_rel: forall r tr, start_by_Aacq r tr -> start_by_Arel r (cons (Arelease_res r) tr)
| start_by_Arel_irr: forall r a tr, ~ is_resource_action r a -> start_by_Arel r tr -> start_by_Arel r (cons a tr).

Class Action_Parallel (Ac: Action): Type := {
  race: action;
  race_actions: action -> action -> Prop;
}.

Class NormalAction_Parallel_resource (Ac: Action) (Res: Resource) {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res}: Type := {
  res_actions_no_race: forall a1 a2, race_actions a1 a2 -> ~ is_resources_action a1 /\ ~ is_resources_action a2;
  race_not_resource: ~ is_resources_action race
}.

Inductive trace_interleave {Ac: Action} {Res: Resource} {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res}: resources -> resources -> trace -> trace -> trace -> Prop :=
| trace_interleave_nil_nil: forall (A1 A2: resources), trace_interleave A1 A2 nil nil nil
| trace_interleave_race: forall (A1 A2: resources) a1 tr1 a2 tr2, race_actions a1 a2 -> trace_interleave A1 A2 (cons a1 tr1) (cons a2 tr2) (cons race nil)
| trace_interleave_left: forall (A1 A1' A2: resources) a1 tr1 tr2 tr, res_enable a1 A1 A1' A2 -> trace_interleave A1' A2 tr1 tr2 tr -> trace_interleave A1 A2 (cons a1 tr1) tr2 (cons a1 tr)
| trace_interleave_right: forall (A1 A2 A2': resources) tr1 a2 tr2 tr, res_enable a2 A2 A2' A1 -> trace_interleave A1 A2' tr1 tr2 tr -> trace_interleave A1 A2 tr1 (cons a2 tr2) (cons a2 tr).

Inductive traces_interleave {Ac: Action} {Res: Resource} {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res}: traces -> traces -> traces :=
| traces_interleave_intro: forall (Tr1 Tr2: traces) tr1 tr2 tr, Tr1 tr1 -> Tr2 tr2 -> trace_interleave (fun _ => False) (fun _ => False) tr1 tr2 tr -> traces_interleave Tr1 Tr2 tr.

Class ActionInterpret_resource (state: Type) (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res} (ac_sem: ActionInterpret (resources * state) Ac): Type := {
  state_enable_Aacquire_res: forall r (A1 A2: resources) (s: state),
    join A1 (eq r) A2 -> state_enable (Aacquire_res r) (A1, s) (Terminating (A2, s));
  state_enable_Arelease_res: forall r (A1 A2: resources) (s: state),
    join A2 (eq r) A1 -> state_enable (Arelease_res r) (A1, s) (Terminating (A2, s));
  state_enable_non_resource_action1: forall a (A1 A2: resources) (s1 s2: state),
    ~ is_resources_action a -> state_enable a (A1, s1) (Terminating (A2, s2)) -> A1 = A2;
  state_enable_non_resource_action2: forall a (A A': resources) (s: state) (ms: MetaState state),
    ~ is_resources_action a -> state_enable a (A, s) (lift_function (pair A) ms) -> state_enable a (A', s) (lift_function (pair A') ms)
}.

Class ActionInterpret_Parallel_resource (state: Type) {J: Join state} (Ac: Action) {AcP: Action_Parallel Ac} (Res: Resource) {Acr: Action_resource Ac Res} (ac_sem: ActionInterpret (resources * state) Ac): Type := {
  state_enable_race: forall A s ms, state_enable race (A, s) ms <-> ms = Error; (* TODO: is this line necessary? *)
  state_enable_race_actions_spec: forall a1 a2 (A1 A2: resources) (s1 s2 s: state),
      race_actions a1 a2 -> ~ state_enable a1 (A1, s1) Error -> ~ state_enable a2 (A2, s2) Error -> join s1 s2 s -> False
  (* This formalization is critical. Even if there is no ms s.t. stable_enable a1 (s1, A1) ms, it still means (s1, A1) has a domain to perform a1. It's just the result does not match, i.e. the read action. *)
}.

Class Command2Traces_Sresource (P: ProgrammingLanguage) (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res} {CPR: ConcurrentProgrammingLanguage_Sresource P Res} (c2t: Command2Traces P Ac): Type := {
  Sresource_denote: forall r c, cmd_denote (Sresource r c) = traces_app (singleton_traces (singleton_trace (Aacquire_res r))) (traces_app (cmd_denote c) (singleton_traces (singleton_trace (Arelease_res r))))
}.

Class Command2Traces_Sparallel_resource (P: ProgrammingLanguage) (state: Type) (Ac: Action) (Res: Resource) {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res} {CPP: ConcurrentProgrammingLanguage_Sparallel P} (c2t: Command2Traces P Ac): Type := {
  Sparallel_denote: forall c1 c2, cmd_denote (Sparallel c1 c2) = traces_interleave (cmd_denote c1) (cmd_denote c2)
}.

Class StructuralResourceAccess (P: ProgrammingLanguage) (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res} (c2t: Command2Traces P Ac): Type := {
  resource_sequential: forall c r tr, cmd_denote c tr -> start_by_Aacq r tr
}.

Definition resource_no_occur {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} (r: resource) (Tr: traces): Prop :=
  forall tr, Tr tr -> ~ List.In (Aacquire_res r) tr /\ ~ List.In (Arelease_res r) tr.

Class SAActionInterpret_resource (state: Type) (Ac: Action) (ac_sem: ActionInterpret state Ac) {J: Join state} (G: action -> Prop) : Prop := {
  frame_property: forall (a: action) (m1 f n1: state) (n2: MetaState state),
    G a ->
    join m1 f n1 ->
    state_enable a n1 n2 ->
    exists m2, lift_join m2 (Terminating f) n2 /\ state_enable a m1 m2
}.

Class KActionInterpret_resource (state: Type) (Ac: Action) (ac_sem: ActionInterpret state Ac) {state_R: Relation state}: Prop := {
  ordered_action_interpret: forall (a: action) (m1 n1: state) (n2: MetaState state),
    m1 <= n1 ->
    state_enable a n1 n2 ->
    exists m2, Partial.forward m2 n2 /\ state_enable a m1 m2
}.

Class KSAActionInterpret_resource (state: Type) (Ac: Action) (ac_sem: ActionInterpret state Ac) {J: Join state} {state_R: Relation state} (G: action -> Prop): Prop := {
  ordered_frame_property: forall (a: action) (m1 f n1' n1: state) (n2: MetaState state),
    G a ->
    join m1 f n1' ->
    n1' <= n1 ->
    state_enable a n1 n2  ->
    exists m2 n2', lift_join m2 (Terminating f) n2' /\ Partial.forward n2' n2 /\ state_enable a m1 m2
}.

Lemma ordered_and_frame_AIr {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac} {J: Join state} {state_R: Relation state} (G: action -> Prop):
  SAActionInterpret_resource state Ac ac_sem G ->
  KActionInterpret_resource state Ac ac_sem ->
  KSAActionInterpret_resource state Ac ac_sem G.
Proof.
  intros.
  constructor.
  intros.
  pose proof ordered_action_interpret _ _ _ _ H3 H4 as [n2' [? ?]].
  pose proof frame_property _ _ _ _ _ H1 H2 H6 as [m2 [? ?]].
  exists m2, n2'; auto.
Qed.

Inductive trace_access {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac}: trace -> state -> MetaState state -> Prop :=
| trace_access_nil: forall s, trace_access nil s (Terminating s)
| trace_access_NonTerminating: forall a tr s, state_enable a s NonTerminating -> trace_access (cons a tr) s NonTerminating
| trace_access_Error: forall a tr s, state_enable a s Error -> trace_access (cons a tr) s Error
| trace_access_Terminating: forall a tr s s' ms, state_enable a s (Terminating s') -> trace_access tr s' ms -> trace_access (cons a tr) s ms.

Inductive traces_access {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac}: traces -> state -> MetaState state -> Prop :=
| traces_access_intro: forall tr (Tr: traces) s ms, Tr tr -> trace_access tr s ms -> traces_access Tr s ms.

(* TODO: maybe not necessary *)
Lemma trace_access_Terminating_inv {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac}:
  forall P a tr s ms,
    trace_access (cons a tr) s ms ->
    (forall ms', state_enable a s ms' -> exists s', P s' /\ ms' = Terminating s') ->
    (exists s', P s' /\ trace_access tr s' ms).
Proof.
  intros.
  inversion H; subst.
  + apply H0 in H5.
    destruct H5 as [? [? ?]].
    inversion H2.
  + apply H0 in H5.
    destruct H5 as [? [? ?]].
    inversion H2.
  + apply H0 in H3.
    destruct H3 as [? [? ?]].
    inversion H2; subst.
    exists x; auto.
Qed.

Definition TS2BSS {P: ProgrammingLanguage} {state: Type} {Ac: Action} {Res: Resource} (TS: TraceSemantics P (resources * state) Ac): BigStepSemantics P state :=
  Build_BigStepSemantics _ _ (fun s c ms => traces_access (cmd_denote c) (fun _ => False, s) (lift_function (pair ( fun _ => False)) ms)).

Definition is_upper_bound {A: Type} {R: Relation A} (s: A -> Prop) (a: A): Prop :=
  forall a0, s a0 -> a0 <= a.

Definition greatest {A: Type} {R: Relation A} (s: A -> Prop) (a: A): Prop :=
  s a /\ is_upper_bound s a.

Inductive thread_local_state_enable {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac} (Inv: resource * (state -> Prop) -> Prop) : action -> resources * state -> MetaState (resources * state) -> Prop :=
| thread_local_state_enable_acq: forall r A1 A2 I m f n,
    join A1 (eq r) A2 ->
    Inv (r, I) -> I f ->
    join m f n ->
    thread_local_state_enable Inv (Aacquire_res r) (A1, m) (Terminating (A2, n))
| thread_local_state_enable_rel_succ: forall r A1 A2 I m n,
    join A2 (eq r) A1 ->
    Inv (r, I) ->
    greatest (fun n => exists f, I f /\ join n f m) n ->
    thread_local_state_enable Inv (Arelease_res r) (A1, m) (Terminating (A2, n))
| thread_local_state_enable_rel_fail: forall r A1 A2 I m,
    join A2 (eq r) A1 ->
    Inv (r, I) ->
    (forall n, ~ exists f, I f /\ join n f m) ->
    thread_local_state_enable Inv (Arelease_res r) (A1, m) Error
| thread_local_state_enable_non_resource: forall a s s',
    ~ is_resources_action a ->
    state_enable a s s' ->
    thread_local_state_enable Inv a s s'.

Lemma thread_local_state_enable_non_resource_action {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac}:
  forall Inv a s s',
    ~ is_resources_action a ->
    (state_enable a s s' <-> thread_local_state_enable Inv a s s').
Proof.
  intros.
  split; intros.
  + constructor; auto.
  + inversion H0; subst; solve_resource_action.
    auto.
Qed.

Definition ThreadLocal_ActionInterpret_resource {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} (ac_sem: ActionInterpret (resources * state) Ac) (Inv: resource * (state -> Prop) -> Prop): ActionInterpret (resources * state) Ac :=
  Build_ActionInterpret _ _ (thread_local_state_enable Inv).

Definition ThreadLocal_BSS {P: ProgrammingLanguage} {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} (TS: TraceSemantics P (resources * state) Ac) (Inv: resource * (state -> Prop) -> Prop): BigStepSemantics P state :=
  TS2BSS (Build_TraceSemantics _ _ _ c2t (ThreadLocal_ActionInterpret_resource ac_sem Inv)).

Definition ThreadLocal_AIPr {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res} {nAcPr: NormalAction_Parallel_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac} {AIPr: ActionInterpret_Parallel_resource state Ac Res ac_sem}: forall (Inv: resource * (state -> Prop) -> Prop), ActionInterpret_Parallel_resource state Ac Res (ThreadLocal_ActionInterpret_resource ac_sem Inv).
  intros.
  constructor.
  + intros.
    simpl.
    rewrite <- (state_enable_race A s ms).
    rewrite (thread_local_state_enable_non_resource_action Inv) by (apply race_not_resource).
    tauto.
  + intros.
    simpl in H0, H1.
    destruct (res_actions_no_race _ _ H).
    rewrite <- (thread_local_state_enable_non_resource_action Inv) in H0, H1 by auto.
    revert H H0 H1 H2.
    apply state_enable_race_actions_spec.
Qed.


Require Import FP.Core.

Inductive v_step S A :=
  | v_Done : v_step S A
  | v_Yield : A -> S -> v_step S A.

Inductive v_stream A := v_Stream
  { v_streamS : Type
  ; v_streamSeed : v_streamS
  ; v_streamStep : v_step v_streamS A
  }.

Definition stream (A:qtype) := lib (v_stream (dom A)).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export Raxioms.
Require Export LegacyField.
Import LegacyRing_theory.

Section LegacyRfield.

Open Scope R_scope.

Lemma RLegacyTheory : Ring_Theory Rplus Rmult 1 0 Ropp (fun x y:R => false).
  split.
  exact Rplus_comm.
  symmetry  in |- *; apply Rplus_assoc.
  exact Rmult_comm.
  symmetry  in |- *; apply Rmult_assoc.
  intro; apply Rplus_0_l.
  intro; apply Rmult_1_l.
  exact Rplus_opp_r.
  intros.
  rewrite Rmult_comm.
  rewrite (Rmult_comm n p).
  rewrite (Rmult_comm m p).
  apply Rmult_plus_distr_l.
  intros; contradiction.
Defined.

End LegacyRfield.

Add Legacy Field
R Rplus Rmult 1%R 0%R Ropp (fun x y:R => false) Rinv RLegacyTheory Rinv_l
  with minus := Rminus div := Rdiv.


From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.prelude Require Import options.

Definition nondet_bool : val :=
  λ: <>, let: "l" := ref #true in Fork ("l" <- #false);; !"l".

Section proof.
  Context `{!heapG Σ}.

  Lemma nondet_bool_spec : {{{ True }}} nondet_bool #() {{{ (b : bool), RET #b; True }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam. wp_alloc l as "Hl". wp_let.
    pose proof (nroot .@ "rnd") as rndN.
    iMod (inv_alloc rndN _ (∃ (b : bool), l ↦ #b)%I with "[Hl]") as "#Hinv";
      first by eauto.
    wp_apply wp_fork.
    - iInv rndN as (?) "?". wp_store; eauto.
    - wp_seq. iInv rndN as (?) "?". wp_load.
      iSplitR "HΦ"; first by eauto.
      by iApply "HΦ".
  Qed.

End proof.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C Bprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ col_ O Eprime A)))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.