Require Export Unicode.Utf8_core.
Require Import String List.
Require Export Showable PartialOrder TErrorMonad Connection HoTT Decidable.

Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation " ( x ; p ) " := (existT _ x p).
Notation "{ x : A & P }" := (sigT_HSet A (fun x => P)) : type_scope.

Local Open Scope string_scope.

Set Universe Polymorphism.

(** * Dependent equivalences *)

(**

A _simple_ type is an inhabitant of [Type], e.g. [A: Type], [A → B: Type].

A _rich_ type is a dependent pair, e.g. [{ a : A | B a}].

A _dependent_ type is a type family [A → Type] indexed by some type
[A], e.g. [C: nat → Type], [C (S n) → C n].

  We define the following family of cast operators:
  - [to_rich]: from [A] to [{a: A & P a}]
  - [to_dep]: from [A] to [B a]
  - [to_simp]: from [B a] to [A]

   We don't provide an explicit [rich_to_simpl], since this is just [projT1]
*)

(**

  A dependent equivalence between [B : A -> Type] and [C : Type] is
  witnessed by a (proof-irrelevant) predicate [P : A -> C -> Type]
  such that [B] and [{C & P}] are equivalent while [{C & P}] and [C]
  are partially equivalent. It also a partial index synthesis function
  [c_to_a], which tries to compute an index from a computational
  element [C].

*)

(* =DepEquiv= *)
Class DepAnticonnection (A:HSet) (B: A -> HSet) (C:HSet) :=
  {  a_P : A -> C -> HProp;
     a_total_equiv :> forall a, B a ≃ {c:C & a_P a c};
     a_partial_equiv :> forall a, {c:C & a_P a c} ≈K C;
     a_c_to_a : C ⇀ A;
     a_prop_c_to_a : forall a (b:B a), (a_c_to_a °° ((a_partial_equiv a).(apc_fun)))
                                  ((a_total_equiv a).(e_fun) b) = Some a;
  }.
Notation "B ≈K□ C" := (DepAnticonnection _ B C)
(* =end= *)
                      (at level 50).

Hint Extern 1 (IsEquiv ?f) => apply (e_isequiv (e := a_total_equiv _)) :
             typeclass_instances.

Hint Extern 1 (IsAnticonnectionK ?f) => apply (apc_isconn (a := a_partial_equiv _)) :
             typeclass_instances.

Definition c_to_b {A:HSet} {B: A -> HSet} {C:HSet}
           `{B ≈K□ C} {a:A}: {c:C & a_P a c} -> (B a) :=
  e_inv _.

Definition b_to_c {A:HSet} {B: A -> HSet} {C}
           `{B ≈K□ C} {a:A}: B a -> {c:C & a_P a c} :=
  (a_total_equiv a).(e_fun).

Definition to_rich {A:HSet} {B: A -> HSet} {C}
           `{B ≈K□ C} {a:A}: C ⇀ {c: C & a_P a c} :=
  apc_inv (apc_fun (@a_partial_equiv _ _ _ _ a)).

Program Definition to_dep {A:HSet} {B: A -> HSet} {C}
           `{B ≈K□ C}
           (a:A) : C ⇀ (B a) :=
  fun c => c' <- apc_inv (apc_fun (@a_partial_equiv _ _ _ _ a)) c; clift (e_inv _) c'.

Definition to_simpl {A:HSet} {B: A -> HSet} {C:HSet}
           `{B ≈K□ C}
           {a:A} : B a ⇀ C :=
  (a_partial_equiv a).(apc_fun) ° ((a_total_equiv a).(e_fun)).

(** ** Properties *)

Definition sub_eq_implies {A B B' : HSet} (x:TError A info_str) {f : A ⇀ B} {y : TError B info_str}
           {g : A ⇀ B'} {y' : TError B' info_str}
  (e : forall a, f a ≼ y -> g a ≼ y') : (a <- x; f a) ≼ y -> (a <- x; g a) ≼ y'.
Proof.
  destruct x. apply e. exact (fun x => x).
Defined.

Definition sub_eq_implies_simpl {A B : HSet} (x:TError A info_str) {y : TError A info_str}
           {g : A ⇀ B} {y' : TError B info_str}
  (e : forall a, creturn a ≼ y -> g a ≼ y') : x ≼ y -> (a <- x; g a) ≼ y'.
Proof.
  destruct x. apply e. intros H. exact H.
Defined.

Definition sub_eq_implies_complex  {A B B' C :HSet} (x:TError A info_str) {f : A ⇀ B}
           {y : TError B info_str} {g : A ⇀ B'} {y' : TError C info_str} {g' : B' ⇀ C}
           (e : forall a, f a ≼ y -> (b <- g a ; g' b) ≼ y') :
  (a <- x; f a) ≼ y ->  (b <- (a <- x; g a); g' b)  ≼ y'.
Proof.
  destruct x. apply e. intros X. simpl in *. exact X.
Defined.

Definition sub_eq_implies_op {A B B' : HSet} (x:TError A info_str) {f : A ⇀ B} {y : B}
           {g : A ⇀ B'} {y' : TError B' info_str}
  (e : forall a, creturn y ≼ f a -> y' ≼ g a) : creturn y ≼ (a <- x; f a) -> y' ≼ (a <- x; g a).
Proof.
  destruct x. apply e. intro H; inversion H.
Defined.

Definition sub_eq_implies_op_simpl {A B :HSet} (x:TError A info_str) {y : A}
           {g : A ⇀ B} {y' : TError B info_str}
  (e : forall a, creturn y ≼ creturn a -> y' ≼ g a) : creturn y ≼ x -> y' ≼ (a <- x; g a).
Proof.
  destruct x. apply e. intros H. inversion H.
Defined.

(* =DepEquiv_PartialEquivK= *)
Program Definition DepAnticonnection_ConnectionK  (A : HSet) (B : A -> HSet)
         (C : HSet) `{B ≈K□ C} (a:A) : B a ≈K C :=
  {| apc_fun := to_simpl;
     apc_isconn := {| apc_inv := to_dep a|} |}.
(* =end= *)
Next Obligation.
  - rename a0 into b. change ((to_dep a) °° to_simpl b ≼ creturn b). unfold kleisliComp, compose.
    unfold to_dep, to_rich, to_simpl, compose in *.
    assert (f := apc_sect (IsAnticonnectionK := apc_isconn (a := a_partial_equiv a)) _ (b_to_c b)).
    unfold kleisliComp in f.
    revert f. unfold b_to_c, compose.
    apply sub_eq_implies. intro c.
    apply sub_eq_implies_simpl. intro x.
    intro e. pose (ap (e_inv _) (Some_inj e)). apply (ap (@Some _ _)).
    pose (e_sect (IsEquiv := e_isequiv (e := a_total_equiv a)) _ b).
    refine (e0 @ e1).
Defined.
Next Obligation.
    rename a0 into c. unfold kleisliComp.
    unfold to_dep, to_rich in *.
    unfold to_simpl, clift, compose.
    assert (f := apc_retr (IsAnticonnectionK := apc_isconn (a := a_partial_equiv a)) _ c).
    unfold kleisliComp in f.
    revert f. apply sub_eq_implies_complex. intros s e.
    pose (e_retr (IsEquiv := e_isequiv (e := a_total_equiv a)) _ s).
    unfold compose in e0. simpl in *.
    simpl.
    rewrite e0. exact e.
Defined.

(* =to_dep_dom= *)
Definition to_dep_dom {A D: HSet} {B: A -> HSet} {C: HSet}
    `{B ≈K□ C}(f: C ⇀ D) (a: A): B a ⇀ D := f °° to_simpl.
(* =end= *)

Definition to_dep_dom2 {A:HSet} {B: A -> HSet} {C} {D E}
           `{B ≈K□ C}
           (f: C -> D ⇀ E) : forall a, B a -> D ⇀ E :=
  fun a b x=>
    c <- to_simpl b;
    f c x.

(** ** Casts from dependent to simple *)

(* =to_simpl_dom= *)
Definition to_simpl_dom {A D: HSet} {B: A -> HSet} {C: HSet}
           `{B ≈K□ C} (f: forall a: A, B a ⇀ D): C ⇀ D := fun c =>
     a <- a_c_to_a c;
     b <- to_dep a c ;
     f a b.
(* =end= *)

Program Definition TotalEquiv (A:HSet) (B: A -> HSet) (C:HSet) (P: A -> C -> HProp)
   {DREquiv_prop : forall a c, IsHProp (P a c)}
   {HSet_C : IsHSet C}
   (b_to_c : forall a, B a -> {c : C & P a c})
   (c_to_b : forall a, {c : C & P a c} -> B a)
   (prop_b_to_b : forall a, (c_to_b a) ° (b_to_c a) == id )
   (prop_c_to_c : forall a, (b_to_c a) ° (c_to_b a) == id) a:
  Equiv (B a) {c : C & P a c} :=
    {| e_fun := b_to_c a ;
       e_isequiv :=
         {| e_inv := c_to_b a ;
            e_sect := prop_b_to_b a;
            e_retr := prop_c_to_c a;|} |}.
Next Obligation.
  apply (is_hprop (IsHProp := is_hset (IsHSet := trunc_sigma _ _) _ _)).
Defined.

(* =IsDepAntiEquiv= *)
Definition IsDepAnticonnection (A:HSet) (B: A -> HSet) (C:HSet) P (H:forall a c, Checkable (P a c))
  (b_to_c : forall a, B a -> {c : C & P a c}) (c_to_b : forall a, {c : C & P a c} -> B a) (c_to_a : C ⇀ A) :
  (forall a, (c_to_b a) ° (b_to_c a) == id ) -> (forall a, (b_to_c a) ° (c_to_b a) == id) ->
  (forall a (b:B a), c_to_a (b_to_c a b).1 = Some a) -> B ≈K□ C
(* =end= *)
  :=
    fun prop_b_to_b prop_c_to_c prop_c_to_a =>
      Build_DepAnticonnection A B C P
                        (TotalEquiv A B C P b_to_c c_to_b prop_b_to_b prop_c_to_c)
                        (fun a => Checkable_AnticonnectionK C (P a))
                        c_to_a prop_c_to_a.

(** Given a relation [R : TError A -> A -> Type], one can automatically
construct a partial type equivalence between [B: A → Type] and [C:
Type] as long as we can recompute the index from an inhabitant of
[C]. This is the role of the function [c_to_a_rel]. *)

Definition Anticonnection_rel {A:HSet} {B: A -> HSet} {C:HSet} (R : TError A info_str -> A -> HProp)
   (c_to_a_rel : C ⇀ A)
   (P := fun a c => R (c_to_a_rel c) a)
   (b_to_c_rel : forall a, B a -> {c : C & P a c})
   (c_to_b_rel : forall a, {c : C & P a c} -> B a)
   (prop_b_to_b_rel : forall a, (c_to_b_rel a) ° (b_to_c_rel a) == id)
   (prop_c_to_c_rel : forall a, (b_to_c_rel a) ° (c_to_b_rel a) == id)
   {DepEquiv_check_rel : forall a a', Checkable (R a a')}
   {HSet : IsHSet C}
   (prop_c_to_a_R : forall a (b:B a), c_to_a_rel (b_to_c_rel _ b).1 = Some a) :
  B ≈K□ C
  :=
  IsDepAnticonnection A B C P _ b_to_c_rel c_to_b_rel c_to_a_rel prop_b_to_b_rel prop_c_to_c_rel
            (fun _ _ => prop_c_to_a_R _ _).


From Hammer Require Import Hammer.

Require Import Ensembles.
From GroupTheory Require Import Laws.
From GroupTheory Require Import Group_definitions.
From GroupTheory Require Import gr.
From GroupTheory Require Import g1.

Theorem auxsub :
forall (H : Group U) (x : U), subgroup U H Gr -> In U (G_ U H) x -> In U G x.
Proof. hammer_hook "g2" "g2.auxsub".
intros H x H'; elim H'; auto with sets.
Qed.

Section Trois.

Variable H K : Group U.
Variable subH : subgroup U H Gr.
Variable subK : subgroup U K Gr.

Inductive Prod : Ensemble U :=
Definition_of_Prod :
forall x y z : U,
In U (G_ U H) x -> In U (G_ U K) y -> star x y = z -> In U Prod z.
End Trois.

Section Quatre.
Variable H K : Group U.
Variable subH : subgroup U H Gr.
Variable subK : subgroup U K Gr.

Theorem T4 : Same_set U (Prod H K) (Prod K H) -> Setsubgroup U (Prod H K) Gr.
Proof. hammer_hook "g2" "g2.T4".
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'.
apply T_1_6_3 with (witness := e); auto with sets.
rewrite <- (G2c' e); auto with sets.
apply Definition_of_Prod with (x := e) (y := e); auto with sets.
rewrite <- (eh_is_e H); auto with sets.
rewrite <- (eh_is_e K); auto with sets.
red in |- *.
intros x H'0; elim H'0.
intros x0 y z H'1 H'2 H'3; rewrite <- H'3; auto with sets.
intros a b H'0 H'1.
generalize H'1; clear H'1.
elim H'0.
intros x y z H'1 H'2 H'3; rewrite <- H'3.
intro H'4; elim H'4.
intros x0 y0 z0 H'5 H'6 H'7; rewrite <- H'7.
rewrite <- (inv_star' x0 y0); auto with sets.
rewrite <- (G1' x y (star (inv y0) (inv x0))); auto with sets.
red in H'.
elim H'; intros H'8 H'9; red in H'9; clear H'.
rewrite (G1' y (inv y0) (inv x0)); auto with sets.
lapply (H'9 (star (star y (inv y0)) (inv x0)));
[ intro H'10; elim H'10 | idtac ].
intros x1 y1 z1 H' H'11 H'12; rewrite <- H'12.
rewrite (G1' x x1 y1); auto with sets.
apply Definition_of_Prod with (x := star x x1) (y := y1); auto with sets.
rewrite <- (starH_is_star H); auto with sets.
apply Definition_of_Prod with (x := star y (inv y0)) (y := inv x0).
rewrite <- (starH_is_star K); auto with sets.
rewrite <- (invH_is_inv K); auto with sets.
rewrite <- (invH_is_inv H); auto with sets.
trivial with sets.
Qed.

Theorem T4R : Setsubgroup U (Prod H K) Gr -> Included U (Prod H K) (Prod K H).
Proof. hammer_hook "g2" "g2.T4R".
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'; elim H'.
intros x H'0; red in |- *.
intros x0 H'1.
elim H'0; intros L1 L2; clear H'0.
generalize (auxsub x); intro tx.
cut (exists t : U, In U (Prod H K) t /\ t = inv x0).
intro H'2; elim H'2.
intros x1 H'3; elim H'3; intros H'4 H'5; try exact H'4; clear H'3.
generalize H'5.
elim H'4.
intros x2 y z H'3 H'6 H'7; rewrite <- H'7.
intro H'8.
rewrite (inv_involution' x0); auto with sets.
rewrite <- H'8.
rewrite <- (inv_star' x2 y); auto with sets.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv K subK y); auto with sets.
rewrite <- (invH_is_inv H subH x2); auto with sets.
generalize H'1.
rewrite <- L2; auto with sets.
intro H'0.
apply ex_intro with (x := inv x0).
split; [ idtac | trivial with sets ].
rewrite <- (invH_is_inv x L1 x0); auto with sets.
Qed.

Theorem T4R1 :
Setsubgroup U (Prod H K) Gr -> Included U (Prod K H) (Prod H K).
Proof. hammer_hook "g2" "g2.T4R1".
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'; elim H'.
intros x H'0; red in |- *.
intros x0 H'1.
elim H'0; intros L1 L2; clear H'0.
generalize (auxsub x); intro tx.
cut (exists t : U, In U (Prod K H) t /\ t = inv (inv x0)).
intro H'0; elim H'0.
intros x1 H'2.
elim H'2; intros H'3 H'4; generalize H'4; clear H'2.
elim H'3.
intros x2 y z H'2 H'5 H'6; rewrite <- H'6.
intro H'7.
rewrite (inv_involution' x0).
rewrite <- H'7.
rewrite (inv_involution' (star x2 y)).
rewrite <- (inv_star' x2 y).
rewrite <- (invH_is_inv x L1 (star (inv y) (inv x2))).
rewrite <- L2; auto with sets.
elim L1; simpl in |- *; auto with sets.
intros H'15 H'16; apply (G3a_ U x); auto with sets.
rewrite L2.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv H subH y); auto with sets.
rewrite <- (invH_is_inv K subK x2); auto with sets.
rewrite L2.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv H subH y); auto with sets.
rewrite <- (invH_is_inv K subK x2); auto with sets.
elim H'1; intros x3 y0 z0 H'8 H'9 H'10; rewrite <- H'10.
apply ex_intro with (x := star x3 y0).
split; [ idtac | auto with sets ].
apply Definition_of_Prod with (x := x3) (y := y0); trivial with sets.
Qed.
Hint Resolve T4 T4R T4R1.

Theorem T_1_6_8 :
Same_set U (Prod H K) (Prod K H) <-> Setsubgroup U (Prod H K) Gr.
Proof. hammer_hook "g2" "g2.T_1_6_8".
red in |- *; auto with sets.
Qed.
End Quatre.


Require Import Basics Types HSet.
Require Import Truncations.Core Truncations.SeparatedTrunc.
Require Import Modalities.Modality Modalities.Separated Modalities.Identity.
Require Import Limits.Pullback.

(** * Projective types *)

(** To quantify over all truncation levels including infinity, we parametrize [IsOProjective] by a [Modality]. When specializing to [IsOProjective purely] we get an (oo,-1)-projectivity predicate, [IsProjective]. When specializing to [IsOProjective (Tr n)] we get an (n,-1)-projectivity predicate, [IsTrProjective]. *)

Definition IsOProjective (O : Modality) (X : Type) : Type
  := forall A, In O A -> forall B, In O B ->
     forall f : X -> B, forall p : A -> B,
     IsSurjection p -> merely (exists s : X -> A, p o s == f).

(** (oo,-1)-projectivity. *)

Notation IsProjective := (IsOProjective purely).

(** (n,-1)-projectivity. *)

Notation IsTrProjective n := (IsOProjective (Tr n)).

(** A type X is projective if and only if surjections into X merely split. *)
Proposition iff_isoprojective_surjections_split
  (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <->
    (forall (Y : Type), In O Y -> forall (p : Y -> X),
          IsSurjection p -> merely (exists s : X -> Y, p o s == idmap)).
Proof.
  split.
  - intros isprojX Y oY p S; unfold IsOProjective in isprojX.
    exact (isprojX Y _ X _ idmap p S).
  - intro splits. unfold IsOProjective.
    intros A oA B oB f p S.
    pose proof (splits (Pullback p f) _ pullback_pr2 _) as s'.
    strip_truncations.
    destruct s' as [s E].
    refine (tr (pullback_pr1 o s; _)).
    intro x.
    refine (pullback_commsq p f (s x) @ _).
    apply (ap f).
    apply E.
Defined.

Corollary equiv_isoprojective_surjections_split
  `{Funext} (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <~>
    (forall (Y : Type), In O Y -> forall (p : Y -> X),
          IsSurjection p -> merely (exists s : X -> Y, p o s == idmap)).
Proof.
  exact (equiv_iff_hprop_uncurried (iff_isoprojective_surjections_split O X)).
Defined.

(** ** Projectivity and the axiom of choice *)

(** In topos theory, an object X is said to be projective if the axiom of choice holds when making choices indexed by X. We will refer to this as [HasOChoice], to avoid confusion with [IsOProjective] above. In similarity with [IsOProjective], we parametrize it by a [Modality]. *)

Class HasOChoice (O : Modality) (A : Type) :=
  hasochoice :
    forall (B : A -> Type), (forall x, In O (B x)) ->
    (forall x, merely (B x)) -> merely (forall x, B x).

(** (oo,-1)-choice. *)

Notation HasChoice := (HasOChoice purely).

(** (n,-1)-choice. *)

Notation HasTrChoice n := (HasOChoice (Tr n)).

Global Instance hasochoice_sigma
  `{Funext} {A : Type} {B : A -> Type} (O : Modality)
  (chA : HasOChoice O A)
  (chB : forall a : A, HasOChoice O (B a))
  : HasOChoice O {a : A | B a}.
Proof.
  intros C sC f.
  set (f' := fun a => chB a (fun b => C (a; b)) _ (fun b => f (a; b))).
  specialize (chA (fun a => forall b, C (a; b)) _ f').
  strip_truncations.
  apply tr.
  intro.
  apply chA.
Defined.

Proposition isoprojective_ochoice (O : Modality) (X : Type)
  : HasOChoice O X -> IsOProjective O X.
Proof.
  intros chX A ? B ? f p S.
  assert (g : merely (forall x:X, hfiber p (f x))).
  - rapply chX.
    intro x.
    exact (center _).
  - strip_truncations; apply tr.
    exists (fun x:X => pr1 (g x)).
    intro x.
    exact (g x).2.
Defined.

Proposition hasochoice_oprojective (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X -> HasOChoice O X.
Proof.
  refine (_ o fst (iff_isoprojective_surjections_split O X)).
  intros splits P oP S.
  specialize splits with {x : X & P x} pr1.
  pose proof (splits _ (fst (iff_merely_issurjection P) S)) as M.
  clear S splits.
  strip_truncations; apply tr.
  destruct M as [s p].
  intro x.
  exact (transport _ (p x) (s x).2).
Defined.

Proposition iff_isoprojective_hasochoice (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <-> HasOChoice O X.
Proof.
  split.
  - apply hasochoice_oprojective. exact _.
  - apply isoprojective_ochoice.
Defined.

Proposition equiv_isoprojective_hasochoice
  `{Funext} (O : Modality) (X : Type) `{In O X}
  : IsOProjective O X <~> HasOChoice O X.
Proof.
  refine (equiv_iff_hprop_uncurried (iff_isoprojective_hasochoice O X)).
  apply istrunc_forall.
Defined.

Proposition isprojective_unit : IsProjective Unit.
Proof.
  apply (isoprojective_ochoice purely Unit).
  intros P trP S.
  specialize S with tt.
  strip_truncations; apply tr.
  apply Unit_ind.
  exact S.
Defined.

Section AC_oo_neg1.
  (** ** Projectivity and AC_(oo,-1) (defined in HoTT book, Exercise 7.8) *)
  (* TODO: Generalize to n, m. *)

  Context {AC : forall X : HSet, HasChoice X}.

  (** (Exercise 7.9) Assuming AC_(oo,-1) every type merely has a projective cover. *)
  Proposition projective_cover_AC `{Univalence} (A : Type)
    : merely (exists X:HSet, exists p : X -> A, IsSurjection p).
  Proof.
    pose (X := Build_HSet (Tr 0 A)).
    pose proof ((equiv_isoprojective_hasochoice _ X)^-1 (AC X)) as P.
    pose proof (P A _ X _ idmap tr _) as F; clear P.
    strip_truncations.
    destruct F as [f p].
    refine (tr (X; (f; BuildIsSurjection f _))).
    intro a; unfold hfiber.
    apply equiv_O_sigma_O.
    refine (tr (tr a; _)).
    rapply (equiv_path_Tr _ _)^-1%equiv.  (* Uses Univalence. *)
    apply p.
  Defined.

  (** Assuming AC_(oo,-1), projective types are exactly sets. *)
  Theorem equiv_isprojective_ishset_AC `{Univalence} (X : Type)
    : IsProjective X <~> IsHSet X.
  Proof.
    apply equiv_iff_hprop.
    - intro isprojX. unfold IsOProjective in isprojX.
      pose proof (projective_cover_AC X) as P; strip_truncations.
      destruct P as [P [p issurj_p]].
      pose proof (isprojX P _ X _ idmap p issurj_p) as S; strip_truncations.
      destruct S as [s h].
      rapply (istrunc_embedding_trunc s).
      apply isembedding_isinj_hset.
      exact (isinj_section h).
    - intro ishsetX.
      apply (equiv_isoprojective_hasochoice purely X)^-1.
      rapply AC.
  Defined.

End AC_oo_neg1.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Cat.Facts.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Functor.Representable.Hom_Func.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat
     Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat
     NatTrans.NatIso.

Local Open Scope nattrans_scope.

Section Y_emb.
  Context (C : Category).

  (** The dual of the Yoneda embedding for category C – the curry of hom
      functor of C. *)
  Definition CoYoneda : (C^op --> (Func_Cat C Type_Cat))%functor :=
    Exp_Cat_morph_ex (Hom_Func C).

  (** The Yoneda embedding for category C – the curry of hom functor of Cᵒᵖ. *)
  Definition Yoneda : (C --> (Func_Cat (C^op) Type_Cat))%functor :=
    Exp_Cat_morph_ex (Hom_Func (C^op)).

End Y_emb.

Section Y_Left_Right.
  Context (C : Category).

  (** The left hand side of the Yoneda lemma's isomorphism *)
  Definition Y_left :
    ((C^op × (Func_Cat (C^op) Type_Cat)) --> Type_Cat)%functor
    :=
      ((Hom_Func _)
         ∘ (Prod_Functor
              ((Yoneda C)^op) (Functor_id (Func_Cat (C^op) Type_Cat))))%functor.

  (** The right hand side of the Yoneda lemma's isomorphism *)
  Definition Y_right
    : ((C^op × (Func_Cat (C^op) Type_Cat)) --> Type_Cat)%functor :=
    ((Exp_Cat_Eval (C^op) Type_Cat) ∘ (Twist_Func _ _))%functor.

End Y_Left_Right.

Local Obligation Tactic := idtac.

(** The left to right natural transformation of Yoneda lemma. *)
Program Definition Y_left_to_right (C : Category) : (Y_left C) --> (Y_right C) :=
{|
  Trans := fun c_F => fun N => ((Trans N (fst c_F))) (id (fst c_F))
|}.

Next Obligation. (* Trnas_com *)
Proof.
  intros C [c F] [c' F'] [h1 h2].
  extensionality N; cbn.
  cbn in *.
  match goal with
    [|- _ = ?W] =>
    match W with
      (?F _a ?X (?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  match goal with
    [|- _ = Trans h2 c' ?W] =>
    match W with
      (?F _a ?X (?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  auto.
Qed.

Next Obligation.
Proof.
  symmetry; simpl.
  apply Y_left_to_right_obligation_1.
Qed.

(** The natural transformation needed to make the right to left natural
    transformation of Yoneda lemma. *)
Program Definition Y_right_to_left_NT (C : Category) (c : Obj)
        (F : (C^op --> Type_Cat)%functor) (h : (F _o c)%object)
  :
    ((Yoneda _) _o c)%object --> F :=
{|
  Trans := fun c' => fun g => (F _a g)%morphism h
|}.

Next Obligation. (* Trnas_com *)
Proof.
  intros C c F h c1 c2 h'.
  extensionality g; cbn.
  simpl_ids.
  match goal with
    [|- (?F _a (?X ∘ ?Y) ?Z)%morphism = _] =>
      transitivity (((F _a Y) ∘ (F _a X)) Z)%morphism; trivial
  end.
  auto.
Qed.

Next Obligation.
Proof.
  symmetry; simpl.
  apply Y_right_to_left_NT_obligation_1.
Qed.

(** The right to left natural transformation of Yoneda lemma. *)
Program Definition Y_right_to_left (C : Category) : (Y_right C) --> (Y_left C) :=
{|
  Trans := fun c_F => fun h => Y_right_to_left_NT C (fst c_F) (snd c_F) h
|}.

Next Obligation. (* Trans_com *)
Proof.
  intros C [c f] [c' f'] [h N].
  cbn in *.
  extensionality g; cbn.
  apply NatTrans_eq_simplify.
  extensionality d; extensionality g'; cbn.
  simpl_ids.
  match goal with
    [|- ?W = _] =>
    match W with
      (?F _a ?X (?F _a ?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ (F _a Y)) Z)%morphism
    end
  end.
  rewrite <- F_compose; cbn.
  match goal with
    [|- ?W = _] =>
    match W with
      ?X (?Y ?Z) =>
      change W with ((X ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn; trivial.
Qed.

Next Obligation.
Proof.
  symmetry; simpl.
  apply Y_right_to_left_obligation_1.
Qed.

(** The Yoneda Lemma*)
Program Definition Yoneda_Lemma (C : Category) :
  ((Y_left C) ≃ (Y_right C))%natiso :=
  NatIso _ _ (Y_left_to_right C) (Y_right_to_left C) _ _.

Next Obligation.
Proof.
  intros C [c F]; FunExt; cbn in *.
  rewrite (F_id F).
  trivial.
Qed.

Next Obligation.
  simpl; intros C [c F]; FunExt.
  apply NatTrans_eq_simplify.
  FunExt.
  cbn in *.
  match goal with
    [|- ?W = _] =>
    match W with
      ?X (?Y ?Z) =>
      change W with ((X ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  auto.
Qed.

(** Yoneda embedding is faithful. *)
Lemma Yoneda_Faithful (C : Category) : Faithful_Func (Yoneda C).
Proof.
  intros c c' f f' H.
  cbn in *.
  match type of H with
      ?X = ?Y =>
      assert(H' : Trans X c id= Trans Y c id)
  end.
  + rewrite H; trivial.
  + cbn in H'.
    simpl_ids in H'.
    trivial.
Qed.

(** Yoneda embedding is full. *)
Lemma Yoneda_Full (C : Category) : Full_Func (Yoneda C).
Proof.
  intros c c' N.
  exists (Trans (Y_left_to_right C) (c, (((Yoneda C) _o)%object c')) N).
  apply NatTrans_eq_simplify.
  extensionality x; extensionality h.
  transitivity ((((Yoneda C) _o c')%object _a h ∘ (Trans N c)) id)%morphism.
  + cbn; auto.
  + rewrite <- Trans_com.
    cbn; auto.
Qed.

(** Yoneda embedding is indeed an embedding. *)
Definition Yoneda_Emb (C : Category) : Embedding C (Func_Cat (C^op) Type_Cat) :=
{|
  Emb_Func := Yoneda C;
  Emb_Faithful := Yoneda_Faithful C;
  Emb_Full := Yoneda_Full C
|}.

(** Yoneda is conservative of isomorphisms. *)
Theorem Yoneda_Iso (C : Category) : forall (c c' : Obj),
    ((Yoneda C) _o c ≃ (Yoneda C) _o c')%isomorphism → (c ≃ c')%isomorphism.
Proof.
  intros.
  apply (Emb_Conservative _ _ (Yoneda_Emb C) _); trivial.
Qed.

Ltac Yoneda := apply Yoneda_Iso.

(** The dual of Yoneda is conservative of isomorphisms. *)
Theorem CoYoneda_Iso (C : Category) : forall (c c' : Obj),
    ((CoYoneda C) _o c ≃ (CoYoneda C) _o c')%isomorphism → (c ≃ c')%isomorphism.
Proof.
  intros; Yoneda; trivial.
Qed.

Ltac CoYoneda := apply CoYoneda_Iso.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import SSCHPreservation.
Require Import TraceCriterion.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section SSCHCriterion.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Set.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.
  Local Definition hprop__S := hprop trace__S.
  Local Definition hprop__T := hprop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition hsat__S := hsat Source_Semantics.
  Local Definition hsat__T := hsat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Lemma τ_mono : monotone τ'.
  Proof. move/Galois_equiv: rel_adjunction_law. by move => [H1 H2]. Qed.

  Definition rel_TC : Prop := rel_TC  compilation_chain
                                   Source_Semantics Target_Semantics
                                   rel.

  Local Definition sCl_σ : hprop__T -> hprop__S := sCl_σ σ'.
  Local Definition sCl_τ : hprop__S -> hprop__T := sCl_τ τ'.

  Local Definition sCl_τhP := sCl_τhP compilation_chain
                                      Source_Semantics Target_Semantics
                                      τ'.

  Local Definition sCl_σhP := sCl_σhP compilation_chain
                                      Source_Semantics Target_Semantics
                                      σ'.

  Lemma sCl_σhP_sCl_τhP : (forall (W : prg__S) (H__T : hprop__T), SSC H__T ->  sCl_σhP W H__T) <->
                          (forall (W : prg__S) (H__S : hprop__S), SSC H__S -> sCl_τhP W H__S).
  Proof.
    split.
    + move => Hσ P H__S ssc_H rsat_source.
      have rsat_sigma_tau : hsat__S P (sCl_σ (sCl_τ H__S)).
      { apply: hsat_upper_closed. exact rsat_source.
        apply: Galois_snd_lift. exact rel_adjunction_law. exact ssc_H. }
      have τ_ssc : SSC (sCl_τ H__S) by apply: sCl_SCH.
      exact (Hσ P (sCl_τ H__S) τ_ssc rsat_sigma_tau).
    + move => Hτ P H__T ssc_H rsat_source.
      have h_ssc: SSC (sCl_σ H__T) by apply: sCl_SCH.
      move: (Hτ P (sCl_σ H__T) h_ssc rsat_source).
      move => HHH. eapply hsat_upper_closed. exact HHH.
      apply: Galois_fst_lift; eauto. exact rel_adjunction_law.
  Qed.

  Theorem rel_TC_sClτSCHP : rel_TC <-> (forall (P : prg__S) (H__S : hprop__S), SSC H__S -> sCl_τhP P H__S).
  Proof.
    setoid_rewrite rel_TC'.
    split.
    - move => Htilde P H H_ssc Hsrc.
      exists (τ' (beh__S P)). split.
      + rewrite /lift. exists (beh__S P).
        split; auto. exact: (Htilde P).
    - move => Hτ W.
      have Hssc: SSC (fun b: prop__S => b ⊆ beh__S W) by firstorder.
      have Hfoo: hsat__S W (fun b: prop__S => b ⊆ beh__S W) by rewrite /hsat__S.
      move: (Hτ W _ Hssc Hfoo).
      move => [b__T [[b__S [H1 H2]] H3]]. subst.
      apply: subset_trans.
      exact H3. by apply: τ_mono.
  Qed.

  Theorem rel_TC_sCl_σRSCHP : rel_TC <-> (forall (W : prg__S) (H__T : hprop__T), SSC H__T ->  sCl_σhP W H__T).
  Proof. by rewrite sCl_σhP_sCl_τhP rel_TC_sClτSCHP. Qed.

End SSCHCriterion.


From Coq Require Import ssreflect.
From stdpp Require Import base gmap.
From iris.proofmode Require Import tactics.
From aneris.aneris_lang.lib Require Import list_proof.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.aneris_lang Require Import aneris_lifting proofmode.
From aneris.examples.crdt.spec Require Import crdt_base crdt_time crdt_events crdt_denot crdt_resources.
From aneris.examples.crdt.oplib Require Import oplib_code.
From aneris.examples.crdt.oplib.spec Require Import model spec.
From aneris.examples.crdt.oplib.examples.pncounter Require Import pncounter_code.

(** A positive-negative counter *)
Section PNCounterCrdt.

  Inductive CtrOp :=
  | Add (z : Z) : CtrOp. (* note we can add a negative number *)

  Definition ctr_payload (op : CtrOp) : Z :=
    match op with
    | Add z => z
    end.

  Global Instance ctr_op_eqdecision : EqDecision CtrOp.
  Proof. solve_decision. Qed.

  Global Instance ctr_op_countable : Countable CtrOp.
  Proof.
    refine {|
      encode op := match op with Add z => encode z end;
      decode n := Add <$> @decode Z _ _ n;
    |}.
    intros []. rewrite decode_encode /=. done.
  Qed.

  Definition CtrSt := Z.
  Context `{!Log_Time}.

  (* The value of a counter is just the sum of the operations' payloads. *)
  Fixpoint ctr_value (s : list (Event CtrOp)) : Z :=
    match s with
    | [] => 0%Z
    | ev :: xs => (ctr_payload ev.(EV_Op) + ctr_value xs)%Z
    end.

  Definition ctr_denot (s : gset (Event CtrOp)) (st : CtrSt) : Prop :=
    st = ctr_value (elements s).

  Global Instance ctr_denot_fun : Rel2__Fun ctr_denot.
  Proof.
    constructor; unfold ctr_denot; intros; subst; done.
  Qed.

  Global Instance ctr_denot_instance : CrdtDenot CtrOp CtrSt := {
    crdt_denot := ctr_denot;
  }.
End PNCounterCrdt.

Section OpPNCounter.

  Context `{!Log_Time}.

  Definition op_ctr_effect st (ev : Event CtrOp) st' :=
    st' = (st + ctr_payload ev.(EV_Op))%Z.

  Lemma op_ctr_effect_fun st : Rel2__Fun (op_ctr_effect st).
  Proof.
    constructor. unfold op_ctr_effect.
    intros a b b' Hb Hb'.
    destruct (EV_Op a) as [z]; simpl in *; subst; auto.
  Qed.

  Lemma ctr_value_singleton ev :
    ctr_value [ev] = ctr_payload (ev.(EV_Op)).
  Proof.
    unfold ctr_value. lia.
  Qed.

  Lemma ctr_value_cons ev l :
    ctr_value (ev :: l) = (ctr_payload ev.(EV_Op) + ctr_value l)%Z.
  Proof.
    simpl. auto.
  Qed.

  Lemma ctr_value_app (l l' : list (Event CtrOp)) :
    ctr_value (l ++ l') = (ctr_value l + ctr_value l')%Z.
  Proof.
    generalize dependent l'.
    induction l as [ | h t Ht]; intros l'; [done |].
    rewrite -app_comm_cons.
    do 2 rewrite ctr_value_cons.
    rewrite (Ht l'). lia.
  Qed.

  Lemma ctr_value_perm (l l' : list (Event CtrOp)) :
    Permutation l l' -> ctr_value l = ctr_value l'.
  Proof.
    generalize dependent l'.
    induction l as [ | h t Ht]; intros l' Hperm.
    - apply Permutation_nil in Hperm; subst; reflexivity.
    - rewrite ctr_value_cons.
      apply Permutation_sym in Hperm.
      pose proof Hperm as Hperm'.
      apply Permutation_vs_cons_inv in Hperm as [l1 [l2 ->]].
      apply Permutation_sym, Permutation_cons_app_inv, Ht in Hperm'.
      rewrite Hperm'.
      do 2 rewrite ctr_value_app.
      rewrite ctr_value_cons.
      lia.
  Qed.

  Lemma ctr_denot_union (s : gset (Event CtrOp)) (ev : Event CtrOp) (res : CtrSt) :
    ⟦ s ⟧ ⇝ res ->
    ev ∉ s ->
    ⟦ s ∪ {[ ev ]} ⟧ ⇝ (res + ctr_payload ev.(EV_Op))%Z.
  Proof.
    simpl. unfold ctr_denot.
    intros -> Hnotin.
    assert (s ## {[ ev ]}) as Hdisj by set_solver.
    pose proof (elements_disj_union s
                                    ({[ev]} : gset (Event CtrOp))
                                    Hdisj) as Hperm.
    apply ctr_value_perm in Hperm. rewrite Hperm.
    by rewrite elements_singleton ctr_value_app ctr_value_singleton.
  Qed.

  Instance op_ctr_effect_coh : OpCrdtEffectCoh op_ctr_effect.
  Proof.
    intros s e st st'.
    intros Hdenot Hnotin. split.
    - intros Heff.
      unfold op_ctr_effect in Heff; subst.
      by apply ctr_denot_union.
    - intros Hdenot'.
      unfold op_ctr_effect.
      pose proof (ctr_denot_union s e st Hdenot Hnotin) as Hunion.
      pose proof (rel2_fun Hdenot' Hunion) as Hequiv.
      apply leibniz_equiv in Hequiv; subst; done.
  Qed.

  Definition op_ctr_init_st := 0%Z.

  Lemma op_ctr_init_st_coh : ⟦ (∅ : gset (Event CtrOp)) ⟧ ⇝ op_ctr_init_st.
  Proof. done. Qed.

  Global Instance op_ctr_model_instance : OpCrdtModel CtrOp CtrSt := {
    op_crdtM_effect := op_ctr_effect;
    op_crdtM_effect_fun := op_ctr_effect_fun;
    op_crdtM_effect_coh := op_ctr_effect_coh;
    op_crdtM_init_st := op_ctr_init_st;
    op_crdtM_init_st_coh := op_ctr_init_st_coh
  }.

End OpPNCounter.

From aneris.examples.crdt.oplib.proof Require Import time.

Section PNCounter_proof.
  Context `{!anerisG M Σ}.

  Context `{!CRDT_Params, !OpLib_Res CtrOp}.

  Definition Ctr_OpLib_Op_Coh := λ (op : CtrOp) v, match op with Add z => v = #z end.

  Lemma Ctr_OpLib_Op_Coh_Inj (o1 o2 : CtrOp) (v : val) :
    Ctr_OpLib_Op_Coh o1 v → Ctr_OpLib_Op_Coh o2 v → o1 = o2.
  Proof. destruct o1; destruct o2; simpl; intros ? ?; simplify_eq; done. Qed.

  Lemma Ctr_OpLib_Coh_Ser (op : CtrOp) (v : val) :
    Ctr_OpLib_Op_Coh op v → Serializable int_serialization v.
  Proof.
    destruct op; rewrite /Ctr_OpLib_Op_Coh; intros ?; simplify_eq; apply _.
  Qed.

  Definition Ctr_OpLib_State_Coh := λ (st : CtrSt) v, v = #st.

  Global Instance Ctr_OpLib_Params : OpLib_Params CtrOp CtrSt :=
  {|
    OpLib_Serialization := int_serialization;
    OpLib_State_Coh := Ctr_OpLib_State_Coh;
    OpLib_Op_Coh := Ctr_OpLib_Op_Coh;
    OpLib_Op_Coh_Inj := Ctr_OpLib_Op_Coh_Inj;
    OpLib_Coh_Ser := Ctr_OpLib_Coh_Ser
  |}.

  Lemma Ctr_init_st_fn_spec : ⊢ init_st_fn_spec pncounter_init_st.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /pncounter_init_st.
    wp_pures.
    iApply "HΦ"; done.
  Qed.

  Lemma Ctr_effect_spec : ⊢ effect_spec pncounter_effect.
  Proof.
    iIntros (addr ev st s log_ev log_st).
    iIntros "!#" (Φ) "(%Hev & %Hst & %Hs & %Hevs) HΦ".
    rewrite /pncounter_effect.
    destruct log_ev as [[op] orig vc].
    destruct Hev as (evpl&evvc&evorig&?&Hevpl&?&?).
    rewrite /OpLib_State_Coh /=  /Ctr_OpLib_State_Coh in Hst.
    simplify_eq/=.
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

  Lemma Ctr_crdt_fun_spec : ⊢ crdt_fun_spec pncounter_crdt.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /pncounter_crdt.
    wp_pures.
    iApply "HΦ".
    iExists _, _; iSplit; first done.
    iSplit; [iApply Ctr_init_st_fn_spec|iApply Ctr_effect_spec].
  Qed.

  Lemma Ctr_init_spec :
    init_spec (oplib_init
               (s_ser (s_serializer OpLib_Serialization))
               (s_deser (s_serializer OpLib_Serialization))) -∗
    init_spec_for_specific_crdt pncounter_init.
  Proof.
    iIntros "#Hinit" (repId addr addrs_val).
    iIntros (Φ) "!# (%Haddrs & %Hrepid & Hprotos & Hskt & Hfr & Htoken) HΦ".
    rewrite /pncounter_init.
    wp_pures.
    wp_apply ("Hinit" with "[$Hprotos $Htoken $Hskt $Hfr]").
    { do 2 (iSplit; first done). iApply Ctr_crdt_fun_spec; done. }
    iIntros (get update) "(HLS & #Hget & #Hupdate)".
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

End PNCounter_proof.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj4 : forall  (lv0 : lst), (@eq natural (len lv0) (len (append lv0 Nil))).
Admitted.
QuickChick conj15eqsynthconj4.


(* 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.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural) (IHx:@eq natural (mult (plus x y) z) (plus (mult x z) (mult y z))):@eq natural (plus (mult x z) (plus (mult y z) z))
  (plus (plus (mult x z) z) (mult y z)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_distrib_94_plus_commut/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z.
QuickChick collect_data.
Success.