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 : Universe, ((wd_ B C /\ (wd_ B A /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ A C /\ (col_ O E A /\ (col_ O E B /\ col_ A B C)))))))) -> col_ O E C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Definitions and Properties of First-Order Terms *)
(*   with holes in [nat] for de Bruijn indices *)

From Coq Require Export PeanoNat List.
From OLlibs Require Import List_more.
From OLlibs Require Export dectype.
From Quantifiers Require Export term_tactics.

Set Implicit Arguments.

(* Extensional equality of functions *)
Definition ext_eq {A B} (f g : A -> B) := forall a, f a = g a.
Notation " f ~ g " := (ext_eq f g) (at level 60).

(** * First-Order Terms *)

Section Terms.

Context {vatom : DecType} {tatom : Type}.

(** terms with quantifiable variables

    arity not given meaning that we have a copy of each function name for each arity

 - [evar] for De Bruijn style eigen variables in proofs,
             type for these indices as parameter called the eigen type,
             but mostly used with [nat].
             Other values can be used (for terms without indices, use [Empty_set]).
 - [tvar] for quantified variables in formulas *)
Inductive term T :=
| evar : T -> term T
| tvar : vatom -> term T
| tconstr : tatom -> list (term T) -> term T.
Arguments evar {T}.

(** appropriate induction for [term] (with list inside): so called "nested fix" *)
Fixpoint term_ind_list_Forall T t :
  forall P : term T -> Prop,
  (forall n, P (evar n)) ->
  (forall x, P (tvar T x)) ->
  (forall f l, Forall P l -> P (tconstr f l)) -> P t :=
fun P Pevar Ptvar Pconstr =>
match t with
| evar n => Pevar n
| tvar _ x => Ptvar x
| tconstr c l => Pconstr c l
    ((fix l_ind l' : Forall P l' :=
      match l' with
      | nil => Forall_nil P
      | cons t1 l1 => Forall_cons _
                        (term_ind_list_Forall t1 Pevar Ptvar Pconstr)
                        (l_ind l1)
      end) l)
end.
Ltac term_induction t :=
  (try intros until t);
  let nn := fresh "n" in
  let xx := fresh "x" in
  let cc := fresh "c" in
  let ll := fresh "l" in
  let IHll := fresh "IHl" in
  let i := fresh "i" in
  let Hi := fresh "Hi" in
  apply (term_ind_list_Forall t);
  [ intros nn; try (now intuition); simpl
  | intros xx; try (now intuition); simpl
  | intros cc ll IHll; simpl; intros;
    try (apply (f_equal (tconstr _)));
    rewrite ? flat_map_concat_map, ? map_map;
    try (apply (f_equal (@concat _)));
    match goal with
    | |- map _ ?l = ?l => rewrite <- (map_id l) at 2
    | _ => idtac
    end;
    try (apply map_ext_in; intros i Hi; specialize_Forall_all i);
    try (apply Forall_forall; intros i Hi; specialize_Forall_all i);
    try (intuition; fail) ];
  try (now rcauto).

(** * Monad structure on [term] via substitution *)

(** substitutes the [term] [r n] for index [n] in [term] [t] *)
Fixpoint tesubs T1 T2 (r : T1 -> term T2) (t : term T1) :=
match t with
| tvar _ x => tvar T2 x
| evar k => r k
| tconstr f l => tconstr f (map (tesubs r) l)
end.
Notation "t ⟦ r ⟧" := (tesubs r t) (at level 8, left associativity, format "t ⟦ r ⟧").

(** monad structure induced on [term] *)
Lemma evar_tesubs T1 T2 (r : T1 -> term T2) x : (evar x)⟦r⟧ = r x.
Proof. reflexivity. Qed.
Hint Rewrite evar_tesubs : term_db.

Lemma tesubs_evar T (t : term T) : t⟦evar⟧ = t.
Proof. term_induction t. Qed.
Hint Rewrite tesubs_evar : term_db.

Definition fecomp T1 T2 T3 (r : T1 -> term T2) (s : T2 -> term T3) := fun x => (r x)⟦s⟧.
Notation "r ;; s" := (fecomp r s) (at level 20, format "r  ;;  s").

Lemma tesubs_comp T1 T2 T3 (r : T1 -> term T2) (s : T2 -> term T3) t : t⟦r⟧⟦s⟧ = t⟦r ;; s⟧.
Proof. term_induction t. Qed.
Hint Rewrite tesubs_comp : term_db.

(* the result of substitution depends extensionnaly on the substituting function *)
Lemma tesubs_ext T1 T2 (r1 r2 : T1 -> term T2) : r1 ~ r2 -> forall t, t⟦r1⟧ = t⟦r2⟧.
Proof. term_induction t. Qed.
Hint Resolve tesubs_ext : term_db.
(* TODO could be turned into a morphism *)

Section Fixed_Eigen_Type.

Variable T : Type.
Implicit Type t : term T.
Arguments tvar {T} _.

(** * Term substitution *)

(** substitutes [term] [u] for variable [x] in [term] [t] *)
Fixpoint tsubs x u t :=
match t with
| tvar y => if eq_dt_dec y x then u else tvar y
| evar k => evar k
| tconstr c l => tconstr c (map (tsubs x u) l)
end.
Notation "t [ u // x ]" := (tsubs x u t) (at level 8, format "t [ u // x ]").

Lemma tsubs_tsubs_eq : forall x u v t, t[v//x][u//x] = t[v[u//x]//x].
Proof. term_induction t. Qed.
Hint Rewrite tsubs_tsubs_eq : term_db.

(** * Variables *)

Fixpoint tvars t :=
match t with
| tvar x => x :: nil
| evar _ => nil
| tconstr _ l => flat_map tvars l
end.
Notation "x ∈ t" := (In x (tvars t)) (at level 30).
Notation "x ∉ t" := (~ In x (tvars t)) (at level 30).
Notation closed t := (tvars t = nil).

Lemma closed_notvars t x : closed t -> x ∉ t.
Proof. intros -> []. Qed.
Hint Resolve closed_notvars : term_db.

Lemma tvars_tsubs_closed x u (Hc : closed u) t : tvars t[u//x] = remove eq_dt_dec x (tvars t).
Proof. term_induction t.
rewrite remove_concat, flat_map_concat_map, map_map. f_equal.
apply map_ext_in. intros v Hv. specialize_Forall IHl with v. exact IHl.
Qed.
Hint Rewrite tvars_tsubs_closed using intuition; fail : term_db.

Lemma notin_tsubs : forall x u t, x ∉ t -> t[u//x] = t.
Proof. term_induction t; try rcauto.
apply IHl. intros Hx. apply H, in_flat_map. exists i. split; assumption.
Qed.
Hint Rewrite notin_tsubs using try (intuition; fail); try apply closed_notvars; intuition; fail : term_db.

Lemma tsubs_tsubs x v y u : x <> y -> x ∉ u -> forall t,
  t[v//x][u//y] = t[u//y][v[u//y]//x].
Proof. term_induction t. Qed.
Hint Rewrite tsubs_tsubs using try (intuition; fail); try apply closed_notvars; intuition; fail : term_db.

Lemma notin_tsubs_bivar x y t : x ∉ t -> t[tvar x//y][tvar y//x] = t.
Proof. term_induction t.
apply IHl. intros Hx. apply H, in_flat_map. exists i. split; assumption.
Qed.
Hint Rewrite notin_tsubs_bivar using try (intuition; fail); try apply closed_notvars; (intuition; fail) : term_db.

End Fixed_Eigen_Type.

Section Two_Eigen_Types.

Variable T1 T2 : Type.
Variable r : T1 -> term T2.

Notation closed t := (tvars t = nil).
Notation rclosed := (forall n, closed (r n)).
Notation "t [ u // x ]" := (tsubs x u t) (at level 8, format "t [ u // x ]").

Hint Rewrite notin_tsubs using try (intuition; fail); try apply closed_notvars; intuition; fail : term_db.

(** * Additional results with variable eigen type *)

Lemma tvars_tesubs_closed t : rclosed -> tvars t⟦r⟧ = tvars t.
Proof. term_induction t. Qed.
Hint Rewrite tvars_tesubs_closed using intuition; fail : term_db.

Lemma tsubs_tesubs x u t : rclosed -> t[u//x]⟦r⟧ = t⟦r⟧[u⟦r⟧//x].
Proof. term_induction t. Qed.
Hint Rewrite tsubs_tesubs using intuition; fail : term_db.

End Two_Eigen_Types.

(* We restrict to [term nat] *)
Section Eigen_nat.

Hint Rewrite tvars_tesubs_closed using intuition; fail : term_db.

Notation term := (term nat).
Notation tvar := (tvar nat).
Notation "t [ u // x ]" := (tsubs x u t) (at level 8, format "t [ u // x ]").
Notation "x ∈ t" := (In x (tvars t)) (at level 30).
Notation "x ∉ t" := (~ In x (tvars t)) (at level 30).
Notation closed t := (tvars t = nil).
Notation rclosed r := (forall n, closed (r n)).

Definition fup := fun n => evar (S n).
Notation "⇑" := fup.
Notation "t ↑" := (t⟦⇑⟧) (at level 8, format "t ↑").

Lemma closed_fup : rclosed ⇑.
Proof. reflexivity. Qed.
Hint Rewrite closed_fup : term_db.

Lemma tvars_fup t : tvars t↑ = tvars t.
Proof. rcauto. Qed.
Hint Rewrite tvars_fup : term_db.

(* general shape, unused, generated through ↑
Definition fesubs k v := fun n =>
  match n ?= k with
  | Lt => evar n
  | Eq => v
  | Gt => evar (pred n)
  end.
Notation "v // ↓ k" := (fesubs k v) (at level 18, format "v // ↓ k").

Lemma closed_fesubs : forall k v, closed v -> rclosed (v//↓k).
Proof. e_case_intuition unfolding fesubs. Qed.
Hint Resolve closed_fesubs : term_db.

Lemma fesubs_fup k v : ⇑ ;; v↑//↓(S k) == v//↓k ;; ⇑.
Proof. intros ?; unfold fesubs, fup, fecomp; e_case_intuition. Qed.
*)
Definition fesubs v := fun n =>
  match n with
  | 0 => v
  | S n => evar n
  end.
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").

Lemma closed_fesubs v : closed v -> rclosed (v⇓).
Proof. now intros Hc [|]. Qed.
Hint Resolve closed_fesubs : term_db.

Lemma fesubs_fup v : ⇑ ;; v⇓ ~ evar.
Proof. intro. reflexivity. Qed.

Lemma tesubs_fup v t : t↑⟦v⇓⟧ = t.
Proof. rcauto. Qed.
Hint Rewrite tesubs_fup : term_db.

(* In practive only the case [u = evar 0] will be used *)
Definition felift u r := fun n =>
  match n with
  | 0 => u
  | S k => (r k)↑
  end.
Notation "⇑[ u ] r" := (felift u r) (at level 25, format "⇑[ u ] r").

Lemma closed_felift u r : closed u -> rclosed r -> rclosed (⇑[u]r).
Proof. rnow intros ? ? [|]. Qed.
Hint Resolve closed_felift : term_db.

Lemma felift_comp u r : r ;; ⇑ ~ ⇑ ;; ⇑[u]r.
Proof. intro. reflexivity. Qed.
Hint Rewrite felift_comp : term_db.

Lemma felift_tesubs u r t : t⟦r⟧↑ = t↑⟦⇑[u]r⟧.
Proof. rcauto. Qed.
Hint Rewrite felift_tesubs : term_db.

End Eigen_nat.

End Terms.

Ltac term_induction t :=
  (try intros until t);
  let nn := fresh "n" in
  let xx := fresh "x" in
  let cc := fresh "c" in
  let ll := fresh "l" in
  let IHll := fresh "IHl" in
  let i := fresh "i" in
  let Hi := fresh "Hi" in
  apply (term_ind_list_Forall t);
  [ intros nn; try (now intuition); simpl
  | intros xx; try (now intuition); simpl
  | intros cc ll IHll; simpl; intros;
    try (apply (f_equal (tconstr _)));
    rewrite ? flat_map_concat_map, ? map_map;
    try (apply (f_equal (@concat _)));
    match goal with
    | |- map _ ?l = ?l => rewrite <- (map_id l) at 2
    | _ => idtac
    end;
    try (apply map_ext_in; intros i Hi; specialize_Forall_all i);
    try (apply Forall_forall; intros i Hi; specialize_Forall_all i);
    try (now intuition) ];
  try (now (rnow idtac)); try (now rcauto).


Require Export prosa.model.task.concept.

(** In this module, we give a precise definition of the common notion of
    "sequential tasks", which is commonly understood to mean that the jobs of a
    sequential task execute in sequence and in a non-overlapping fashion. *)

Section PropertyOfSequentiality.

  (** Consider any type of jobs stemming from any type of tasks ... *)
  Context {Job : JobType}.
  Context {Task : TaskType}.
  Context `{JobTask Job Task}.

  (** ... with arrival times and costs ... *)
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** ... and any kind of processor model. *)
  Context {PState: Type}.
  Context `{ProcessorState Job PState}.

  (** Given a schedule of such jobs ... *)
  Variable sched: schedule PState.

  (** ... we say that the tasks execute sequentially if each task's jobs are
     executed in arrival order and in a non-overlapping fashion. *)
  Definition sequential_tasks :=
    forall (j1 j2: Job) (t: instant),
      same_task j1 j2 ->
      job_arrival j1 < job_arrival j2 ->
      scheduled_at sched j2 t ->
      completed_by sched j1 t.

End PropertyOfSequentiality.


(** * IEEE754 binary64 format satisfies hypothesis in [Float_infnan_spec] *)

(** Uses the Flocq library (http://flocq.gforge.inria.fr) to build a
    record [Float_infnan_spec] corresponding to IEEE754 binary64 format with
    a rounding to nearest with overflows and NaN. *)

Require Import Reals mathcomp.analysis.Rstruct Psatz.
Require Import Floats.
From mathcomp Require Import ssreflect ssrbool eqtype.

Require Import float_spec binary64 float_infnan_spec.

Require Import Flocq.Core.Zaux.
Require Import Flocq.Core.Raux.
Require Import Flocq.Core.Defs.
Require Import Flocq.Core.Generic_fmt.
Require Import Flocq.Core.FLT.
Require Import Flocq.Core.Float_prop.

Require Import Flocq.IEEE754.BinarySingleNaN.

Require Import float_spec binary64 float_infnan_spec.

#[global] Obligation Tactic := idtac.  (* no automatic intro *)

Open Scope R_scope.

Section Binary64_infnan.

Let prec := 53%Z.
Let emax := 1024%Z.

Let emin := (3 - emax - prec)%Z.
Let fexp := FLT_exp emin prec.

Local Instance Hprec : FLX.Prec_gt_0 prec := refl_equal _.

Local Instance Hprec_emax : Prec_lt_emax prec emax := refl_equal _.

Let Hemax : (3 <= emax)%Z.
Proof.
intros H.
discriminate H.
Qed.

(** Binary64 defined in [Fappli_IEEE_bits]. *)
Definition FI := BinarySingleNaN.binary_float prec emax.

Definition FI0 : FI := B754_zero false.

Lemma FI1_proof : SpecFloat.bounded prec emax 4503599627370496 (-52) = true.
Proof. now simpl. Qed.

Definition FI1 := B754_finite false 4503599627370496 (-52) FI1_proof.

Definition finite (x : FI) := is_finite x = true.

Lemma finite0 : finite FI0.
Proof. now simpl. Qed.

Lemma finite1 : finite FI1.
Proof. now simpl. Qed.

Definition fis := binary64.binary64 (fun m => negb (Z.even m)).

Definition m := bpow radix2 emax.

Lemma m_ge_2 : 2 <= m.
Proof. now change 2 with (bpow radix2 1); apply bpow_le. Qed.

Program Definition FI2FS (x : FI) : FS fis := @Build_FS_of _ (B2R x) _.
Next Obligation.
move=> x; apply/eqP; apply (generic_format_B2R prec emax x).
Qed.

Lemma FI2FS_spec x : (FI2FS x <> 0 :> R) -> finite x.
Proof. case x; unfold finite; auto. Qed.

Lemma FI2FS0 : FI2FS (FI0) = F0 fis :> R.
Proof. by []. Qed.

Lemma FI2FS1 : FI2FS (FI1) = F1 fis :> R.
Proof.
apply /Rinv_r; change 0 with (IZR 0).
now change 4503599627370496 with (Z2R 4503599627370496); apply IZR_neq.
Qed.

Definition firnd (x : R) : FI :=
  binary_normalize
    prec emax (@refl_equal comparison Lt) (@refl_equal comparison Lt)
    mode_NE
    (round_mode mode_NE (scaled_mantissa binary64.radix2 fexp x))
    (cexp binary64.radix2 fexp x)
    false.

Lemma firnd_spec x : finite (firnd x) -> FI2FS (firnd x) = frnd fis x :> R.
Proof.
intro Frx.
unfold FI2FS, firnd; simpl.
set (mx := round_mode mode_NE (scaled_mantissa binary64.radix2 fexp x)).
set (ex := cexp binary64.radix2 fexp x).
assert (H := binary_normalize_correct
               prec emax (@refl_equal comparison Lt) (@refl_equal comparison Lt)
               mode_NE mx ex false).
revert H; simpl; case (Rlt_bool (Rabs _) _).
{ unfold mx, round_mode; intro H; destruct H as (H, _); rewrite H.
  rewrite round_generic; [now unfold round|].
  now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
unfold binary_overflow, overflow_to_inf.
change (binary_normalize _ _ _ _ _ _ _ _) with (firnd x).
revert Frx; unfold finite, is_finite, B2SF; case (firnd x); try discriminate.
Qed.

Lemma firnd_spec_f x : Rabs (frnd fis x) < m -> finite (firnd x).
Proof.
intro Hm.
set (mx := round_mode mode_NE (scaled_mantissa binary64.radix2 fexp x)).
set (ex := cexp binary64.radix2 fexp x).
assert (H := binary_normalize_correct
               prec emax (@refl_equal comparison Lt) (@refl_equal comparison Lt)
               mode_NE mx ex false).
revert H; simpl.
replace (round _ _ _ _) with (frnd fis x : R).
{ now fold emax m; rewrite (Rlt_bool_true _ _ Hm); intro. }
rewrite round_generic; [now unfold round|].
now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N].
Qed.

Definition fiopp : FI -> FI := Bopp.

Lemma fiopp_spec x : finite (fiopp x) -> FI2FS (fiopp x) = fopp (FI2FS x) :> R.
Proof. now intro Hox; rewrite /= B2R_Bopp. Qed.

Lemma fiopp_spec_f1 x : finite (fiopp x) -> finite x.
Proof. case x; unfold finite; auto. Qed.

Lemma fiopp_spec_f x : finite x -> finite (fiopp x).
Proof. case x; unfold finite; auto. Qed.

Definition fiplus (x y : FI) : FI := Bplus mode_NE x y.

Lemma fiplus_spec_fl x y : finite (fiplus x y) -> finite x.
Proof.
case x; case y; unfold finite, fiplus; simpl; try auto.
now intros b b'; case (Bool.eqb b' b).
Qed.

Lemma fiplus_spec_fr x y : finite (fiplus x y) -> finite y.
Proof.
case x; case y; unfold finite, fiplus; simpl; try auto.
now intros b b'; case (Bool.eqb b' b).
Qed.

Lemma fiplus_spec x y : finite (fiplus x y) ->
  FI2FS (fiplus x y) = fplus (FI2FS x) (FI2FS y) :> R.
Proof.
intro Fxy.
assert (Fx := fiplus_spec_fl _ _ Fxy); assert (Fy := fiplus_spec_fr _ _ Fxy).
unfold FI2FS, fiplus, prec, emax.
change ((53 ?= 1024)%Z) with Lt; simpl.
assert (H := Bplus_correct _ _ Hprec Hprec_emax mode_NE _ _ Fx Fy).
revert H; case (Rlt_bool _ _); intro H; destruct H as (H, _); [now rewrite H|].
casetype False; revert Fxy H.
fold (fiplus x y).
now case (fiplus x y).
Qed.

Lemma fiplus_spec_f x y : finite x -> finite y ->
  Rabs (fplus (FI2FS x) (FI2FS y)) < m -> finite (fiplus x y).
Proof.
intros Fx Fy Hm.
assert (H := Bplus_correct _ _ Hprec Hprec_emax mode_NE _ _ Fx Fy).
revert H.
replace (round _ _ _ _) with (fplus (FI2FS x) (FI2FS y) : R); [|now simpl].
now fold emax m; rewrite (Rlt_bool_true _ _ Hm); intro.
Qed.

Definition fimult (x y : FI) : FI := Bmult mode_NE x y.

Lemma fimult_spec_fl x y : finite (fimult x y) -> finite x.
Proof.
case x; case y; unfold finite, fimult; auto.
Qed.

Lemma fimult_spec_fr x y : finite (fimult x y) -> finite y.
Proof.
case x; case y; unfold finite, fimult; auto.
Qed.

Lemma fimult_spec x y : finite (fimult x y) ->
  FI2FS (fimult x y) = fmult (FI2FS x) (FI2FS y) :> R.
Proof.
intro Fxy.
unfold FI2FS, fimult, prec, emax.
change (53 ?= 1024)%Z with Lt; simpl.
assert (H := Bmult_correct _ _ Hprec Hprec_emax mode_NE x y).
revert H; case (Rlt_bool _ _); intro H; [now rewrite (proj1 H)|].
casetype False; revert Fxy H.
fold (fimult x y).
now case (fimult x y).
Qed.

Lemma fimult_spec_f x y : finite x -> finite y ->
  Rabs (fmult (FI2FS x) (FI2FS y)) < m -> finite (fimult x y).
Proof.
intros Fx Fy Hm.
assert (H := Bmult_correct _ _ Hprec Hprec_emax mode_NE x y).
revert H.
replace (round _ _ _ _) with (fmult (FI2FS x) (FI2FS y) : R); [|now simpl].
fold emax m; rewrite (Rlt_bool_true _ _ Hm).
now fold prec; rewrite Fx Fy; intro H.
Qed.

Definition fidiv (x y : FI) : FI := Bdiv mode_NE x y.

Lemma fidiv_spec_fl x y : finite (fidiv x y) -> finite y -> finite x.
Proof.
case x; case y; unfold finite, fidiv; auto.
Qed.

Lemma F2R_cond_pos_not_0 (b : bool) (m : positive) (e : Z) :
  F2R (Float radix2 (cond_Zopp b (Z.pos m)) e) <> 0.
Proof.
cut (0 < F2R (Float radix2 (Z.pos m) e)).
{ now rewrite F2R_cond_Zopp; case b; simpl; lra. }
now apply F2R_gt_0.
Qed.

Lemma fidiv_spec x y : finite (fidiv x y) -> finite y ->
  FI2FS (fidiv x y) = fdiv (FI2FS x) (FI2FS y) :> R.
Proof.
unfold FI2FS, fidiv, prec, emax.
change (53 ?= 1024)%Z with Lt; simpl.
intros Fxy Fy => /=.
assert (Nzy : B2R y <> 0).
{ revert Fxy Fy; case x; case y; unfold finite, Bdiv, B2R; auto;
  intros; apply F2R_cond_pos_not_0. }
assert (H := Bdiv_correct _ _ Hprec Hprec_emax mode_NE x _ Nzy).
revert H; case (Rlt_bool _ _); intro H.
{ now rewrite (proj1 H). }
casetype False; revert Fxy H.
fold prec; fold emax; fold (fidiv x y).
now case (fidiv x y).
Qed.

Lemma fidiv_spec_f x y : finite x -> (FI2FS y <> 0 :> R) ->
  Rabs (fdiv (FI2FS x) (FI2FS y)) < m -> finite (fidiv x y).
Proof.
intros Fx Nzy Hm.
assert (H := Bdiv_correct _ _ Hprec Hprec_emax mode_NE x _ Nzy).
revert H.
replace (round _ _ _ _) with (fdiv (FI2FS x) (FI2FS y) : R); [|now simpl].
fold emax m; rewrite (Rlt_bool_true _ _ Hm).
now fold prec; rewrite Fx; intro H.
Qed.

Definition fisqrt (x : FI) : FI := Bsqrt mode_NE x.

Lemma fisqrt_spec_f1 x : finite (fisqrt x) -> finite x.
Proof.
case x; unfold finite, fisqrt; simpl; try auto.
now intros b; case b.
Qed.

Lemma fisqrt_spec x : finite (fisqrt x) -> FI2FS (fisqrt x) = fsqrt (FI2FS x) :> R.
Proof.
unfold FI2FS, fisqrt, prec, emax.
change (53 ?= 1024)%Z with Lt; simpl.
intros Fx => /=.
assert (H := Bsqrt_correct _ _ Hprec Hprec_emax mode_NE x).
now rewrite (proj1 H).
Qed.

Lemma fisqrt_spec_f x : finite x -> FI2FS x >= 0 -> finite (fisqrt x).
Proof.
assert (H := Bsqrt_correct _ _ Hprec Hprec_emax mode_NE x).
destruct H as (_, (H, _)); revert H; fold prec emax.
replace (Bsqrt _ _ : binary_float prec emax) with (fisqrt x).
{ intro H; unfold finite; rewrite H; unfold is_finite, FI2FS, B2R; simpl.
  case x; try auto; intros b m e _ _; case b; [|now auto].
  unfold F2R, IZR; simpl; intro H'; casetype False; revert H'.
  change R0 with 0%Re.
  apply Rgt_not_ge; rewrite <- Ropp_0, Ropp_mult_distr_l_reverse.
  apply Ropp_lt_gt_contravar, Rmult_lt_0_compat; [|now apply bpow_gt_0].
  rewrite <-INR_IPR; apply pos_INR_nat_of_P. }
now simpl.
Qed.

Definition ficompare (x y : FI) : float_comparison :=
  flatten_cmp_opt (Bcompare x y).

Lemma ficompare_spec x y : finite x -> finite y ->
  ficompare x y = flatten_cmp_opt (Some (Rcompare (FI2FS x) (FI2FS y))).
Proof. now intros Fx Fy; unfold ficompare; rewrite Bcompare_correct. Qed.

Lemma ficompare_spec_eq x y : ficompare x y = FEq -> FI2FS x = FI2FS y :> R.
Proof.
unfold ficompare => H /=; move: H.
case x; case y; try now simpl.
{ now intro b; case b. }
{ now intros b m e e' b'; case b'. }
{ now intros b b'; case b'. }
{ now intros b b'; case b'; case b. }
intros s m e Hb s' m' e' Hb'; case s', s; simpl;
  (destruct (Z.compare_spec e' e) as [He|He|He]; try discriminate;
   rewrite He Pos.compare_cont_spec; unfold Pos.switch_Eq;
   destruct (Pos.compare_spec m' m) as [Hm|Hm|Hm]; try discriminate;
   now rewrite Hm).
Qed.

Lemma ficompare_spec_eq_f x y : ficompare x y = FEq ->
  (finite x <-> finite y).
Proof.
unfold ficompare.
case x; case y; try now simpl;
  try (now intros b pl Hpl b'; case b').
{ now intro b; case b. }
{ now intros b b'; simpl; case b'. }
{ now intros b m e He b'; simpl; case b'. }
now intros b b'; case b'; case b.
Qed.

Definition binary64_infnan : Float_infnan_spec :=
  @Build_Float_infnan_spec
    FI
    FI0
    FI1
    is_finite
    finite0
    finite1
    fis
    m
    m_ge_2
    FI2FS
    FI2FS_spec
    FI2FS0
    FI2FS1
    firnd
    firnd_spec
    firnd_spec_f
    fiopp
    fiopp_spec
    fiopp_spec_f1
    fiopp_spec_f
    fiplus
    fiplus_spec
    fiplus_spec_fl
    fiplus_spec_fr
    fiplus_spec_f
    fimult
    fimult_spec
    fimult_spec_fl
    fimult_spec_fr
    fimult_spec_f
    fidiv
    fidiv_spec
    fidiv_spec_fl
    fidiv_spec_f
    fisqrt
    fisqrt_spec
    fisqrt_spec_f1
    fisqrt_spec_f
    ficompare
    ficompare_spec
    ficompare_spec_eq
    ficompare_spec_eq_f.

End Binary64_infnan.


                                      (* Jacques Garrigue, 2018 年 10 月 3 日 *)

(*** Coqで関数型プログラミング ***)

(**
 * 1 Coq とは
 *
 *   通常のプログラミング言語でプログラムを書くと，しばしばバグに悩まされる．Coq の開発に
 * 使われる OCaml という型付き関数型プログラミング言語では，型システムが多くのバグを見つ
 * けてくれることが知られている．しかし，OCaml の型推論で全てのバグを取るのが不可能である．
 * プログラムの正しさは，満たすべき性質を定義し，それを証明しなければならない．しかし，通
 * 常の型システムではそういう性質を書くことができない．
 *   Coq は型理論に基づいた定理証明支援系である．具体的には，論理式の形で定理を述べること
 * ができ，コンピュータとの対話で証明を作ることもできる．しかも，Coq の中で OCaml とよく
 * 似た形でプログラムが書けるので，そのプログラムを対象とした性質や証明もできる．最終的に
 * 作ったプログラムを OCaml などに自動的に翻訳する機能も付いているので，証明付きのプログ
 * ラムが作れる訳である．ちなみに，Coq 自身も OCaml で書かれている．そもそも，1980 年代に
 * Caml を開発したのは Coq を作るためであった．
 * 残念ながら，日本語の資料が非常に少ないので，以下の URL は英語で書かれている．
 *
 * http://coq.inria.fr/
 *   Coq の開発元．英語での資料と処理系が置いてある．
 *
 * http://www.proofcafe.org/
 *   Proof Caf´e. 名古屋における Coq のコミュニティで，様々な日本語資料もある．
 **)

(**
 * 2 プログラミング言語としての Coq
 *
 * Coq では，関数型言語のようにプログラムが書ける．
 * 注意：Coq では各命令が ”.” で終わる．
 **)

(*
 * 定義と関数
 *)

Definition one : nat := 1.                                            (* 定義 *)
(* one is defined *)
(* Definition one := 1. *)                                (* 再定義はできない *)
(* Error: one already exists. *)

Definition one' := 1.                                  (* 型を書かなくてもいい *)

Print one'.                                                    (* 定義の確認 *)
(*
  one’ = 1
       : nat                                             (* nat は自然数の型 *)
 *)

Definition double x := x + x.                                 (* 関数の定義 *)
Print double.
(*
double = fun x : nat => x + x                                   (* 関数も値 *)
     : nat -> nat                                               (* 関数の型 *)
*)

Eval compute in double 2.                                    (* 式を計算する *)
(*
  = 4
  : nat
 *)

Definition double' := fun x => x + x.                          (* 関数式で定義 *)
Print double'.
(*
  double’ = fun x : nat => x + x
       : nat -> nat
 *)

Definition quad x := let y := double x in 2 * y.            (* 局所的な定義 *)
Eval compute in quad 2.
(*
  = 8
  : nat
 *)

Definition quad' x := double (double x).                (* 関数適用の入れ子 *)
Eval compute in quad' 2.
(*
  = 8
  : nat
 *)

Definition triple x :=
  let double x := x + x in                (* 局所的な関数定義。上書きもできる *)
  double x + x.
Eval compute in triple 3.
(*
  = 9
  : nat
 *)

(**
 * 整数とモジュール
 **)

Eval compute in 1 - 2.                        (* 自然数の引き算は整数と違う *)
(*
  = 0
  : nat
 *)

Require Import ZArith.                              (* 整数を使ってみよう *)
Module Z.                         (* 定義の範囲を区切るために Module を使う *)
Open Scope Z_scope.                     (* 数値や演算子を整数として解釈する *)
Eval compute in 1 - 2.
(*
  = -1
  : Z (* Z は整数の型 *)
 *)

Eval compute in (2 + 3) / 2.                           (* 割り算も使える *)
(*
  = 2
  : Z
 *)

Definition p (x y : Z) := 2 * x - y * y.                (* 多引数の関数 *)
Print p.
(*
  p = fun x y : Z => 2 * x - y * y
    : Z -> Z -> Z                                   (* 多引数の関数の型 *)
*)

Eval compute in p 3 4.
(*
  = -10
  : Z
 *)

Definition p' := fun x => fun y => 2 * x - y * y.               (* 関数式で *)
Print p'.
(*
  p’ = fun x y : Z => 2 * x - y * y
     : Z -> Z -> Z
 *)

Definition q := p 3.                                     (* 部分適用 *)
Eval compute [p q] in q.                 (* p と q の定義だけを展開する *)
(*
  = fun y : Z => 2 * 3 - y * y
  : Z -> Z
 *)

Eval compute in q 4.
(*
  = -10
  : Z
 *)

Eval compute in let x := 0 in q x.       (* q の中の x の値は変わらない *)
(*
  = 6
  : Z
 *)
End Z.
(* Module Z is defined *)

(* coq1.pdf では Print Z.p. だが Print の結果は Z.q *)
Print Z.p.
(*
  Z.p = fun x y => (2 * x - y * y)%Z
      : Z -> Z -> Z
 *)

Print Z.q.                               (* Module の中味へのアクセス *)
(*
  Z.q = Z.p 3
      : Z -> Z
 *)

Eval compute in 1 - 2.                          (* Scope は元に戻る *)
(*
  = 0
  : nat
 *)

(**
 * 練習問題 2.1 Z の中で二つの整数値の平均を計算する関数 heikin : Z -> Z -> Z を定義せよ．
 **)

(*
 * データ型の定義
 *)
Inductive janken : Set :=                          (* じゃんけんの手 *)
  | gu
  | choki
  | pa.

Definition weakness t :=                              (* 弱点を返す *)
  match t with                                     (* 簡単な場合分け *)
  | gu => pa
  | choki => gu
  | pa => choki
  end.

Eval compute in weakness pa.
(*
  = choki
  : janken
 *)
Print bool.
(*
 Inductive bool : Set := true : bool | false : bool
 *)

Print janken.
(*
 Inductive janken : Set := gu : janken | choki : janken | pa : janken
 *)

Definition wins t1 t2 :=               (* 「t1 は t2 に勝つ」という関係 *)
  match t1, t2 with                              (* 二つの値で場合分け *)
  | gu, choki => true
  | choki, pa => true
  | pa, gu => true
  | _, _ => false                                 (* 残りは全部勝たない *)
  end.

Check wins.
(* wins : janken -> janken -> bool    (* 関係は bool への多引数関数 *) *)
Eval compute in wins gu pa.
(*
  = false
  : bool
 *)

Module Play2.                                   (* 二人でゲームしよう *)

Inductive winner : Set :=
  | first
  | second
  | aiko.

Definition play t1 t2 :=
  if wins t1 t2 then first else
  if wins t2 t1 then second else
  aiko.

Eval compute in play gu pa.
(*
  = second
  : winner
 *)
Eval compute in play choki choki.
(*
  = aiko
  : winner
 *)

End Play2.

Print andb.
Print orb.

Module Play3.

Inductive winner : Set :=
  | first
  | second
  | third
  | aiko.

(* 練習問題 2.2 *)
Definition play (t1 t2 t3 : janken) : winner := aiko.

End Play3.

(**
 * 練習問題 2.2 Play3.play を正しく定義せよ．
 **)

(**
 * 再帰データ型と再帰関数
 **)

Module MyNat.                                    (* nat を新しく定義する *)

Inductive nat : Set :=
  | O : nat
  | S : nat -> nat.
(*
  nat is defined
  nat_rect is defined
  nat_ind is defined
  nat_rec is defined
*)

(* *Error*
Fixpoint plus (m n : nat) { struct m } : nat := (* 帰納法の対象を明示する *)
  match m with                                  (* 減らないとエラーになる *)
  | O => n
  | S m' => S (plus m n)
  end.
 *)
(*
  Error: Recursive definition of plus is ill-formed.
  In environment ...
  Recursive call to plus has principal argument equal to m instead of m’.
 *)

Fixpoint plus (m n : nat) { struct m } : nat :=     (* 同じ型の引数をまとめる *)
  match m with
  | O => n
  | S m' => S (plus m' n)                                  (* 正しい定義 *)
  end.
(*
  plus is recursively defined (decreasing on 1st argument)
 *)
Print plus.
(*
  plus =
  fix plus (m n : nat) : nat := match m with
                                | O => n
                                | S m’ => S (m’ + n)
                                end
       : nat -> nat -> nat
 *)

Check plus (S (S O)) (S O).                          (* 式の型を調べる *)
(*
  plus (S (S O)) (S O)
       : nat
 *)

Eval compute in plus (S (S O)) (S O).                 (* 式を評価する *)
(*
  = S (S (S O))
  : nat
 *)

(* 練習問題 2.3 mult *)
Fixpoint mult (m n : nat) {struct m} : nat := O.

Eval compute in mult (S (S O)) (S O).
(*
  = S (S O)                                         (* 期待している値 *)
  : nat
 *)
End MyNat.

(**
 * 練習問題 2.3 mult を正しく定義せよ．
 **)

(**
 * 文字列の扱い
 *)
Require Import Ascii String.             (* 必要なライブラリーを読み込む *)
Open Scope string_scope.              (* 文字列リテラルを使えるようにする *)
Definition s := "hello".
Print s.
(*
  s = "hello"
    : string
 *)
Print string.

(*
Inductive string : Set :=
  EmptyString : string | String : ascii -> string -> string
 *)

Print ascii.
(*
Inductive ascii : Set :=
  Ascii : bool -> bool
       -> bool -> bool
       -> bool -> bool
       -> bool -> bool
       -> ascii
*)

Definition s2 := s ++ " " ++ "everybody".             (* 文字列の結合 *)
Eval compute in s2.
(*
  = "hello everybody"
  : string
 *)
Eval compute in (" ")%char.                          (* 文字リテラル *)
(*
  = " "%char
  : ascii
 *)
Definition remove_head_space s :=             (* 先頭の空白を一個取る *)
  match s with
    | String " " s' => s'
    | _ => s
  end.

Eval compute in remove_head_space " hello".
(*
  = "hello"
  : string
 *)

(* 練習問題 2.4 remove_head_spaces *)
Fixpoint remove_head_spaces (s : string) : string := "". (* 先頭の空白を全て取る *)

(**
 * 練習問題 2.4 remove head spaces を正しく定義せよ．
 **)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Definitions and theorems about semi-open integer intervals *)

Require Import Coqlib.
Require Import Zwf.
Require Coq.Program.Wf.
Require Recdef.

Definition interv : Type := (Z * Z)%type.

(** * Membership *)

Definition In (x: Z) (i: interv) : Prop := fst i <= x < snd i.

Lemma In_dec:
  forall x i, {In x i} + {~In x i}.
Proof.
  unfold In; intros.
  case (zle (fst i) x); intros.
  case (zlt x (snd i)); intros.
  left; auto.
  right; intuition.
  right; intuition.
Qed.

Lemma notin_range:
  forall x i,
  x < fst i \/ x >= snd i -> ~In x i.
Proof.
  unfold In; intros; omega.
Qed.

Lemma range_notin:
  forall x i,
  ~In x i -> fst i < snd i -> x < fst i \/ x >= snd i.
Proof.
  unfold In; intros; omega.
Qed.

(** * Emptyness *)

Definition empty (i: interv) : Prop := fst i >= snd i.

Lemma empty_dec:
  forall i, {empty i} + {~empty i}.
Proof.
  unfold empty; intros.
  case (zle (snd i) (fst i)); intros.
  left; omega.
  right; omega.
Qed.

Lemma is_notempty:
  forall i, fst i < snd i -> ~empty i.
Proof.
  unfold empty; intros; omega.
Qed.

Lemma empty_notin:
  forall x i, empty i -> ~In x i.
Proof.
  unfold empty, In; intros. omega.
Qed.

Lemma in_notempty:
  forall x i, In x i -> ~empty i.
Proof.
  unfold empty, In; intros. omega.
Qed.

(** * Disjointness *)

Definition disjoint (i j: interv) : Prop :=
  forall x, In x i -> ~In x j.

Lemma disjoint_sym:
  forall i j, disjoint i j -> disjoint j i.
Proof.
  unfold disjoint; intros; red; intros. elim (H x); auto.
Qed.

Lemma empty_disjoint_r:
  forall i j, empty j -> disjoint i j.
Proof.
  unfold disjoint; intros. apply empty_notin; auto.
Qed.

Lemma empty_disjoint_l:
  forall i j, empty i -> disjoint i j.
Proof.
  intros. apply disjoint_sym. apply empty_disjoint_r; auto.
Qed.

Lemma disjoint_range:
  forall i j,
  snd i <= fst j \/ snd j <= fst i -> disjoint i j.
Proof.
  unfold disjoint, In; intros. omega.
Qed.

Lemma range_disjoint:
  forall i j,
  disjoint i j ->
  empty i \/ empty j \/ snd i <= fst j \/ snd j <= fst i.
Proof.
  unfold disjoint, empty; intros.
  destruct (zlt (fst i) (snd i)); auto.
  destruct (zlt (fst j) (snd j)); auto.
  right; right.
  destruct (zlt (fst i) (fst j)).
(* Case 1: i starts to the left of j. *)
  destruct (zle (snd i) (fst j)).
(* Case 1.1: i ends to the left of j, OK *)
  auto.
(* Case 1.2: i ends to the right of j's start, not disjoint. *)
  elim (H (fst j)). red; omega. red; omega.
(* Case 2: j starts to the left of i *)
  destruct (zle (snd j) (fst i)).
(* Case 2.1: j ends to the left of i, OK *)
  auto.
(* Case 2.2: j ends to the right of i's start, not disjoint. *)
  elim (H (fst i)). red; omega. red; omega.
Qed.

Lemma range_disjoint':
  forall i j,
  disjoint i j -> fst i < snd i -> fst j < snd j ->
  snd i <= fst j \/ snd j <= fst i.
Proof.
  intros. exploit range_disjoint; eauto. unfold empty; intuition omega.
Qed.

Lemma disjoint_dec:
  forall i j, {disjoint i j} + {~disjoint i j}.
Proof.
  intros.
  destruct (empty_dec i). left; apply empty_disjoint_l; auto.
  destruct (empty_dec j). left; apply empty_disjoint_r; auto.
  destruct (zle (snd i) (fst j)). left; apply disjoint_range; auto.
  destruct (zle (snd j) (fst i)). left; apply disjoint_range; auto.
  right; red; intro. exploit range_disjoint; eauto. intuition.
Qed.

(** * Shifting an interval by some amount *)

Definition shift (i: interv) (delta: Z) : interv := (fst i + delta, snd i + delta).

Lemma in_shift:
  forall x i delta,
  In x i -> In (x + delta) (shift i delta).
Proof.
  unfold shift, In; intros. simpl. omega.
Qed.

Lemma in_shift_inv:
  forall x i delta,
  In x (shift i delta) -> In (x - delta) i.
Proof.
  unfold shift, In; simpl; intros. omega.
Qed.

(** * Enumerating the elements of an interval *)

Section ELEMENTS.

Variable lo: Z.

Function elements_rec (hi: Z) {wf (Zwf lo) hi} : list Z :=
  if zlt lo hi then (hi-1) :: elements_rec (hi-1) else nil.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
Qed.

Lemma In_elements_rec:
  forall hi x,
  List.In x (elements_rec hi) <-> lo <= x < hi.
Proof.
  intros. functional induction (elements_rec hi).
  simpl; split; intros.
  destruct H. clear IHl. omega. rewrite IHl in H. clear IHl. omega.
  destruct (zeq (hi - 1) x); auto. right. rewrite IHl. clear IHl. omega.
  simpl; intuition.
Qed.

End ELEMENTS.

Definition elements (i: interv) : list Z :=
  elements_rec (fst i) (snd i).

Lemma in_elements:
  forall x i,
  In x i -> List.In x (elements i).
Proof.
  intros. unfold elements. rewrite In_elements_rec. auto.
Qed.

Lemma elements_in:
  forall x i,
  List.In x (elements i) -> In x i.
Proof.
  unfold elements; intros.
  rewrite In_elements_rec in H. auto.
Qed.

(** * Checking properties on all elements of an interval *)

Section FORALL.

Variables P Q: Z -> Prop.
Variable f: forall (x: Z), {P x} + {Q x}.
Variable lo: Z.

Program Fixpoint forall_rec (hi: Z) {wf (Zwf lo) hi}:
                 {forall x, lo <= x < hi -> P x}
                 + {exists x, lo <= x < hi /\ Q x} :=
  if zlt lo hi then
    match f (hi - 1) with
    | left _ =>
        match forall_rec (hi - 1) with
        | left _ => left _ _
        | right _ => right _ _
        end
    | right _ => right _ _
    end
  else
    left _ _
.
Next Obligation.
  red. omega.
Qed.
Next Obligation.
  assert (x = hi - 1 \/ x < hi - 1) by omega.
  destruct H2. congruence. auto.
Qed.
Next Obligation.
  exists wildcard'0; split; auto. omega.
Qed.
Next Obligation.
  exists (hi - 1); split; auto. omega.
Qed.
Next Obligation.
  omegaContradiction.
Defined.

End FORALL.

Definition forall_dec
       (P Q: Z -> Prop) (f: forall (x: Z), {P x} + {Q x}) (i: interv) :
       {forall x, In x i -> P x} + {exists x, In x i /\ Q x} :=
 forall_rec P Q f (fst i) (snd i).

(** * Folding a function over all elements of an interval *)

Section FOLD.

Variable A: Type.
Variable f: Z -> A -> A.
Variable lo: Z.
Variable a: A.

Function fold_rec (hi: Z) {wf (Zwf lo) hi} : A :=
  if zlt lo hi then f (hi - 1) (fold_rec (hi - 1)) else a.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
Qed.

Lemma fold_rec_elements:
  forall hi, fold_rec hi = List.fold_right f a (elements_rec lo hi).
Proof.
  intros. functional induction (fold_rec hi).
  rewrite elements_rec_equation. rewrite zlt_true; auto.
  simpl. congruence.
  rewrite elements_rec_equation. rewrite zlt_false; auto.
Qed.

End FOLD.

Definition fold {A: Type} (f: Z -> A -> A) (a: A) (i: interv) : A :=
  fold_rec A f (fst i) a (snd i).

Lemma fold_elements:
  forall (A: Type) (f: Z -> A -> A) a i,
  fold f a i = List.fold_right f a (elements i).
Proof.
  intros. unfold fold, elements. apply fold_rec_elements.
Qed.

(** Hints *)

Hint Resolve
  notin_range range_notin
  is_notempty empty_notin in_notempty
  disjoint_sym empty_disjoint_r empty_disjoint_l
  disjoint_range
  in_shift in_shift_inv
  in_elements elements_in : intv.


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 A B C I : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ C I /\ (wd_ B I /\ (wd_ A I /\ (col_ B A I /\ col_ B C I))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 C U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (col_ O E A /\ (col_ O E O /\ (col_ O E C /\ (col_ O E O /\ col_ O E U))))))))) -> col_ O U C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 A B C D X Y : Universe, ((wd_ A B /\ (wd_ C D /\ (wd_ C Y /\ (col_ A B X /\ (col_ C D X /\ (col_ A B Y /\ (col_ C D Y /\ col_ A B C))))))) -> col_ B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Logic.Syntax.
Require Import Logic.Semantics.
Require Import Logic.Automation.
Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.R_sqrt.
Require Import Coq.Reals.Ratan.
Require Import Coq.Lists.List.

(* Various proof rules for our logic in general *)

Local Open Scope HP_scope.

Ltac morphism_intro :=
  repeat (intros; match goal with
                  | |- Proper (_ ==> _)%signature _ => red
                  | |- (_ ==> _)%signature _ _ => red
                  end; intros).

(* TODO: All of these should be available in ExtLib *)
Lemma exists_iff : forall {T} (P Q: T -> Prop),
    (forall x, P x <-> Q x) ->
    ((exists x, P x) <-> (exists x, Q x)).
Proof.
  split; destruct 1; eexists; apply H; eauto.
Qed.
Lemma forall_iff : forall {T} (P Q: T -> Prop),
    (forall x, P x <-> Q x) ->
    ((forall x, P x) <-> (forall x, Q x)).
Proof. split; intuition; firstorder. Qed.
Lemma impl_iff : forall (P Q R S : Prop),
    (P <-> Q) ->
    (P -> (R <-> S)) ->
    ((P -> R) <-> (Q -> S)).
Proof.
  intros. tauto.
Qed.
Lemma and_iff : forall (P Q R S : Prop),
    (P <-> Q) ->
    (P -> (R <-> S)) ->
    ((P /\ R) <-> (Q /\ S)).
Proof.
  intros. tauto.
Qed.
Lemma or_iff : Proper (iff ==> iff ==> iff) or.
Proof.
  morphism_intro. tauto.
Qed.

Lemma lequiv_to_iff
: forall (P Q : Formula),
    (P -|- Q) <-> (forall st, eval_formula P st <-> eval_formula Q st).
Proof.
  split.
  { intros. destruct H; split; auto. }
  { intro. split; intro; apply H. }
Qed.

Global Instance Proper_eval_formula
: Proper (lequiv ==> Stream.stream_eq eq ==> iff) eval_formula.
Proof.
  red. red.
  induction x;
    morphism_intro;
    try match goal with
        | H : _ -|- _ |- _ => rewrite lequiv_to_iff in H ; rewrite <- H ; clear H
        end; simpl; try tauto.
  { destruct H0. destruct H0.
    rewrite H. rewrite H0. reflexivity. }
  { eapply and_iff; intros; first [ eapply IHx1 | eapply IHx2 ]; eauto. }
  { eapply or_iff; intros; first [ eapply IHx1 | eapply IHx2 ]; eauto. }
  { eapply impl_iff; intros; first [ eapply IHx1 | eapply IHx2 ]; eauto. }
  { eapply exists_iff; intros.
    eapply H; eauto. }
  { eapply forall_iff; intros.
    eapply H; eauto. }
  { eapply exists_iff; intros.
    destruct H0. rewrite H.
    reflexivity. }
  { eapply forall_iff; intros.
    eapply IHx. reflexivity.
    eapply Stream.Proper_nth_suf_stream_eq; eauto. }
  { eapply exists_iff; intros.
    eapply IHx. reflexivity.
    eapply Stream.Proper_nth_suf_stream_eq; eauto. }
  { destruct H0. destruct H0.
    rewrite H. rewrite H0. reflexivity. }
  { eapply IHx. reflexivity.
    eapply Stream.Proper_stream_map; eauto.
    reflexivity. }
Qed.

(* First, a few functions for expressing
   the proof rules *)

(* Puts ! on all variables in a Term *)
Fixpoint next_term (t:Term) :=
  match t with
  | NatT n => NatT n
  | RealT r => RealT r
  | VarNowT x => VarNextT x
  | VarNextT x => VarNextT x
  | PlusT t1 t2 => PlusT (next_term t1)
                         (next_term t2)
  | MinusT t1 t2 => MinusT (next_term t1)
                           (next_term t2)
  | MultT t1 t2 => MultT (next_term t1)
                         (next_term t2)
  | InvT t => InvT (next_term t)
  | CosT t => CosT (next_term t)
  | SinT t => SinT (next_term t)
  | SqrtT t => SqrtT (next_term t)
  | ArctanT t => ArctanT (next_term t)
  | ExpT t => ExpT (next_term t)
  | MaxT t1 t2 => MaxT (next_term t1) (next_term t2)
  | Unop f t => Unop f (next_term t)
  | Binop f t1 t2 => Binop f (next_term t1)
                           (next_term t2)
  end.

(* Puts ! on all variables in a Formula *)
Fixpoint next (F:Formula) :=
  match F with
  | TRUE => ltrue
  | FALSE => lfalse
  | Comp t1 t2 op => Comp (next_term t1) (next_term t2) op
  | And F1 F2 => next F1 //\\ next F2
  | Or F1 F2 => next F1 \\// next F2
  | Imp F1 F2 => next F1 -->> next F2
  | Syntax.Exists _ f => Exists x, next (f x)
  | Syntax.Forall _ f => Forall x, next (f x)
  | PropF P => PropF P
  | Enabled F => Enabled (next F)
  | Always F => Always (next F)
  | Eventually F => Eventually (next F)
  | Embed P => Embed (fun _ en => P en en)
  | Rename s P => Rename s (next P)
  end.

(* Returns true iff the Term has no ! *)
Fixpoint is_st_term (t:Term) : bool :=
  match t with
  | NatT _ => true
  | RealT _ => true
  | VarNowT _ => true
  | VarNextT x => false
  | PlusT t1 t2 => andb (is_st_term t1)
                        (is_st_term t2)
  | MinusT t1 t2 => andb (is_st_term t1)
                         (is_st_term t2)
  | MultT t1 t2 => andb (is_st_term t1)
                        (is_st_term t2)
  | InvT t => is_st_term t
  | CosT t => is_st_term t
  | SinT t => is_st_term t
  | SqrtT t => is_st_term t
  | ArctanT t => is_st_term t
  | ExpT t => is_st_term t
  | MaxT t1 t2 => andb (is_st_term t1)
                       (is_st_term t2)
  | Unop _ t => is_st_term t
  | Binop _ t1 t2 => andb (is_st_term t1)
                          (is_st_term t2)
  end.

(* Prop expressing that the Formula has no
   !. This cannot be a bool because of
   Forall and Exists. *)
Fixpoint is_st_formula (F:Formula) : Prop :=
  match F with
  | TRUE => True
  | FALSE => True
  | Comp t1 t2 _ =>
    and (is_st_term t1 = true) (is_st_term t2 = true)
  | And F1 F2 =>
    and (is_st_formula F1) (is_st_formula F2)
  | Or F1 F2 =>
    and (is_st_formula F1) (is_st_formula F2)
  | Imp F1 F2 =>
    and (is_st_formula F1) (is_st_formula F2)
  | Syntax.Exists _ f =>
    forall x, is_st_formula (f x)
  | Syntax.Forall _ f =>
    forall x, is_st_formula (f x)
  | PropF _ => True
  | Rename _ x => is_st_formula x
  | _ => False
  end.

Existing Class is_st_formula.

Hint Extern 1 (is_st_formula _) => solve [ compute ; tauto ] : typeclass_instances.

(* The bool version of is_st_formula. This
   one is incomplete. If it returns true,
   the Formula does not have any !, but if
   it returns false, the Formula may or may
   not have a !. This incompleteness is because
   of Forall and Exists. *)
Fixpoint is_st_formula_b (F:Formula) : bool :=
  match F with
  | TRUE => true
  | FALSE => true
  | Comp t1 t2 _ => andb (is_st_term t1)
                         (is_st_term t2)
  | And F1 F2 => andb (is_st_formula_b F1)
                      (is_st_formula_b F2)
  | Or F1 F2 => andb (is_st_formula_b F1)
                     (is_st_formula_b F2)
  | Imp F1 F2 => andb (is_st_formula_b F1)
                      (is_st_formula_b F2)
  | Rename _ x => is_st_formula_b x
  | _ => false
  end.

Theorem is_st_formula_b_ok
: forall F, is_st_formula_b F = true -> is_st_formula F.
Proof.
  induction F; simpl; intros; try congruence; auto;
  try apply Bool.andb_true_iff in H; tauto.
Qed.

Hint Extern 0 (is_st_formula ?X) => solve [ eapply (is_st_formula_b_ok X) ; reflexivity ] : typeclass_instances.

Lemma st_term_hd : forall t s1 s2 s3,
  is_st_term t = true ->
  eval_term t s1 s2 =
  eval_term t s1 s3.
Proof.
  induction t; intros s1 s2 s3 Hst;
  simpl in *; auto; try discriminate;
  try (try apply andb_prop in Hst; simpl;
       try erewrite IHt1; intuition).
Qed.

Lemma st_formula_hd : forall F tr1 tr2,
  is_st_formula F ->
  eval_formula F tr1 ->
  Stream.hd tr1 = Stream.hd tr2 ->
  eval_formula F tr2.
Proof.
  induction F; intros; simpl in *; auto;
  try tauto; try discriminate.
  - unfold eval_comp in *. simpl in *.
    rewrite st_term_hd
    with (t:=t) (s3:=Stream.hd (Stream.tl tr1));
      intuition.
    rewrite st_term_hd
    with (t:=t0) (s3:=Stream.hd (Stream.tl tr1));
      intuition.
    rewrite <- H1; auto.
  - split; try eapply IHF1; try eapply IHF2;
    intuition; eauto.
  - destruct H0;
    [ left; eapply IHF1 |
      right; eapply IHF2 ];
    intuition; eauto.
  - intros. eapply IHF2; eauto; intuition.
    apply H0. eapply IHF1; eauto.
  - destruct H1. exists x. eapply H; eauto.
  - intros. eapply H; eauto.
  - eapply IHF; eauto.
    destruct tr1; destruct tr2. simpl in H1.
    simpl. destruct H1. reflexivity.
Qed.

(* Now a few helper lemmas *)
Lemma next_term_tl : forall t s1 s2 s3,
  is_st_term t = true ->
  eval_term (next_term t) s1 s2 =
  eval_term t s2 s3.
Proof.
  intros t s1 s2 s3 Hst.
  induction t; auto; simpl in *;
  try discriminate;
  try (try apply andb_prop in Hst; intuition;
       rewrite H1; rewrite H2; auto).
Qed.

Lemma next_formula_tl : forall F tr,
  is_st_formula F ->
  (eval_formula (next F) tr <->
   eval_formula F (Stream.tl tr)).
Proof.
  induction F; simpl in *; intros ;
  try tauto.
  - unfold eval_comp in *. simpl in *.
    rewrite <- next_term_tl with (s1:=Stream.hd tr) (t:=t).
    rewrite <- next_term_tl with (s1:=Stream.hd tr) (t:=t0).
    intuition. intuition. intuition.
  - rewrite IHF1; try rewrite IHF2; tauto.
  - rewrite IHF1; try rewrite IHF2; tauto.
  - rewrite IHF1; try rewrite IHF2; tauto.
  - eapply exists_iff.
    intros; eapply H; eauto.
  - eapply forall_iff; eauto.
  - rewrite IHF; eauto.
    eapply Proper_eval_formula. reflexivity.
    eapply Stream.stream_map_tl. apply eq_equivalence.
Qed.

Lemma next_st_formula_entails :
  forall A B,
    is_st_formula A ->
    is_st_formula B ->
    A |-- B ->
    next A |-- next B.
Proof.
  breakAbstraction. intros.
  apply next_formula_tl; auto.
  apply H1. apply next_formula_tl; auto.
Qed.

(* And finally the proof rules *)

(* A discrete induction rule *)
Lemma inv_discr_ind : forall I N,
  is_st_formula I ->
  (|-- (I //\\ N) -->> (next I)) ->
  (|-- (I //\\ []N) -->> []I).
Proof.
  intros I N Hst Hind. simpl in *.
  intros tr _ [HI HAN] n. fold eval_formula in *.
  induction n; auto.
  simpl. rewrite Stream.nth_suf_tl.
  apply next_formula_tl; intuition.
  eapply Hind; fold eval_formula.
  simpl. trivial.
  unfold tlaEntails in Hind. simpl in *.
  auto.
Qed.

Lemma discr_ind : forall P A I N,
    is_st_formula I ->
    (P |-- [] A) ->
    (A |-- I //\\ N -->> next I) ->
    (P |-- (I //\\ []N) -->> []I).
Proof.
  intros. rewrite H0; clear H0.
  intro. simpl; intros.
  induction n.
  { simpl. tauto. }
  { simpl. rewrite Stream.nth_suf_tl.
    apply next_formula_tl; auto.
    apply H1; auto.
    split; auto. destruct H2. apply H3. }
Qed.

Lemma discr_indX : forall P A IndInv,
    is_st_formula IndInv ->
    P |-- [] A ->
    P |-- IndInv ->
    A //\\ IndInv |-- next IndInv ->
    P |-- []IndInv.
Proof.
  intros.
  intro. simpl; intros.
  specialize (H0 _ H3).
  induction n.
  { simpl. intros; eapply H1. auto. }
  { simpl. rewrite Stream.nth_suf_tl.
    apply next_formula_tl; auto.
    apply H2; auto.
    split; auto. }
Qed.

Section in_context.
  Variable C : Formula.

(* A variety of basic propositional
   and temporal logic proof rules *)
Lemma imp_trans : forall F1 F2 F3,
  (C |-- F1 -->> F2) ->
  (C |-- F2 -->> F3) ->
  (C |-- F1 -->> F3).
Proof. intros; charge_tauto. Qed.

Lemma eventually_imp : forall F1 F2,
  (|-- F1 -->> F2) ->
  (C |-- <>F1 -->> <>F2).
Proof.
  tlaIntuition. destruct H1. exists x. auto.
Qed.

Lemma always_and_left : forall F1 F2 F3,
  (C |-- [](F1 //\\ F2) -->> F3) ->
  (C |-- ([]F1 //\\ []F2) -->> F3).
Proof. tlaIntuition. Qed.

Lemma and_right : forall F1 F2 F3,
  (C |-- F1 -->> F2) ->
  (C |-- F1 -->> F3) ->
  (C |-- F1 -->> (F2 //\\ F3)).
Proof. intros; charge_tauto. Qed.

Lemma and_left1 : forall F1 F2 F3,
  (C |-- F1 -->> F3) ->
  (C |-- (F1 //\\ F2) -->> F3).
Proof. intros; charge_tauto. Qed.

Lemma and_left2 : forall F1 F2 F3,
  (C |-- F2 -->> F3) ->
  (C |-- (F1 //\\ F2) -->> F3).
Proof. intros; charge_tauto. Qed.

Lemma imp_id : forall F,
  |-- F -->> F.
Proof. intros; charge_tauto. Qed.

Lemma or_next : forall F1 F2 N1 N2,
  (C |-- (F1 //\\ N1) -->> F2) ->
  (C |-- (F1 //\\ N2) -->> F2) ->
  (C |-- (F1 //\\ (N1 \\// N2)) -->> F2).
Proof. tlaIntuition. Qed.

Lemma or_left : forall F1 F2 F3,
  (C |-- F1 -->> F3) ->
  (C |-- F2 -->> F3) ->
  (C |-- (F1 \\// F2) -->> F3).
Proof. tlaIntuition. Qed.

Lemma or_right1 : forall F1 F2 F3,
  (C |-- F1 -->> F2) ->
  (C |-- F1 -->> (F2 \\// F3)).
Proof. tlaIntuition. Qed.

Lemma or_right2 : forall F1 F2 F3,
  (C |-- F1 -->> F3) ->
  (C |-- F1 -->> (F2 \\// F3)).
Proof. tlaIntuition. Qed.

Lemma imp_right : forall F1 F2 F3,
  (C |-- (F1 //\\ F2) -->> F3) ->
  (C |-- F1 -->> (F2 -->> F3)).
Proof. intros; charge_tauto. Qed.

Lemma imp_strengthen : forall F1 F2 F3,
  (C |-- F1 -->> F2) ->
  (C |-- (F1 //\\ F2) -->> F3) ->
  (C |-- F1 -->> F3).
Proof. intros; charge_tauto. Qed.

Lemma and_assoc_left : forall F1 F2 F3 F4,
  (C |-- (F1 //\\ (F2 //\\ F3)) -->> F4) ->
  (C |-- ((F1 //\\ F2) //\\ F3) -->> F4).
Proof. intros; charge_tauto. Qed.

Lemma and_comm_left : forall F1 F2 F3,
  (C |-- (F2 //\\ F1) -->> F3) ->
  (C |-- (F1 //\\ F2) -->> F3).
Proof. intros; charge_tauto. Qed.

Lemma forall_right : forall T F G,
  (forall x, |-- F -->> G x) ->
  (C |-- F -->> @lforall Formula _ T G).
Proof. tlaIntuition. Qed.

Lemma lor_right2 : forall {P Q : Formula},
    Q |-- P \\// Q.
Proof. intros. charge_tauto. Qed.

Lemma trans_it : forall A B C D,
    C |-- A ->
    B |-- D ->
    A -->> B |-- C -->> D.
Proof.
  intros. rewrite H. rewrite H0. reflexivity.
Qed.

Lemma land_distr :
  forall A B C,
    (A //\\ B) //\\ (C //\\ B) -|- (A //\\ C) //\\ B.
Proof. split; charge_tauto. Qed.

Lemma lor_intro1 :
  forall A B,
    A |-- A \\// B.
Proof. intros; charge_tauto. Qed.

Lemma lor_intro2 :
  forall A B,
    B |-- A \\// B.
Proof. intros; charge_tauto. Qed.

Close Scope HP_scope.

End in_context.

Lemma next_And :
  forall A B,
    next (A //\\ B) -|- next A //\\ next B.
Proof. reflexivity. Qed.

Lemma next_Rename :
  forall A sigma,
    next (Rename sigma A) -|- Rename sigma (next A).
Proof. reflexivity. Qed.

Lemma land_limpl :
  forall P Q R,
    P -->> (Q //\\ R) -|- (P -->> Q) //\\ (P -->> R).
Proof.
  split.
  { charge_split; charge_intros.
    { eapply Lemmas.lcut.
      { charge_use; charge_assumption. }
      { charge_tauto. } }
    { eapply Lemmas.lcut.
      { charge_use; charge_assumption. }
      { charge_tauto. } } }
  { charge_tauto. }
Qed.

Lemma always_tauto : forall G P, |-- P -> G |-- [] P.
Proof. tlaIntuition. Qed.

Lemma always_tauto_inv :
  forall P,
    |--[]P ->
    |-- P.
Proof.
  breakAbstraction. intros.
  specialize (H tr I 0). auto.
Qed.

Lemma next_inv : forall N I,
  is_st_formula I ->
  (|-- [](N //\\ I) -->> [](N //\\ I //\\ next I)).
Proof.
  intros. breakAbstraction. intuition.
  - apply H1.
  - apply H1.
  - apply next_formula_tl; auto.
    rewrite <- Stream.nth_suf_Sn.
    apply H1.
Qed.

Lemma next_inv' : forall G P Q Z,
  is_st_formula Q ->
  (|-- P -->> Q) ->
  (|-- P //\\ next Q -->> Z) ->
  (G |-- []P -->> []Z).
Proof.
  tlaIntuition.
  - apply H1; auto.
    split; auto.
    apply next_formula_tl; auto.
    rewrite <- Stream.nth_suf_Sn. auto.
Qed.

(** Always **)
Lemma Always_and : forall P Q,
    []P //\\ []Q -|- [](P //\\ Q).
Proof.
  intros. split.
  { breakAbstraction. intros. intuition. }
  { breakAbstraction; split; intros; edestruct H; eauto. }
Qed.

Lemma Always_or : forall P Q,
    []P \\// []Q |-- [](P \\// Q).
Proof. tlaIntuition. Qed.

Lemma Always_imp : forall C F1 F2,
  (|-- F1 -->> F2) ->
  (C |-- []F1 -->> []F2).
Proof. tlaIntuition. Qed.

Lemma always_st : forall Q,
    is_st_formula Q ->
    [] Q -|- [] (Q //\\ next Q).
Proof.
  intros. split.
  { rewrite <- Always_and. charge_split; try charge_tauto.
    breakAbstraction. intros.
    rewrite next_formula_tl; auto.
    rewrite <- Stream.nth_suf_Sn. eauto. }
  { rewrite <- Always_and. charge_tauto. }
Qed.

Lemma Always_now : forall P I,
  P |-- []I ->
  P |-- I.
Proof.
  breakAbstraction.
  intros P I H tr HP.
  apply (H tr HP 0).
Qed.

(** Existential quantification **)
Lemma exists_entails : forall T F1 F2,
  (forall x, F1 x |-- F2 x) ->
  Exists x : T, F1 x |-- Exists x : T, F2 x.
Proof.
  tlaIntuition.  destruct H0.
  exists x. intuition.
Qed.

Lemma Exists_with_st : forall G P (t : Term),
    (forall x : R, G |-- t = x -->> P x) ->
    G |-- Exists x : R, P x.
Proof.
  breakAbstraction.
  intros.
  specialize (H _ tr H0 eq_refl).
  eexists. eauto.
Qed.

(* Enabled *)
Lemma Enabled_action : forall P,
    (forall st, exists st',
          eval_formula P (Stream.Cons st (Stream.forever st'))) ->
    |-- Enabled P.
Proof.
  breakAbstraction; intros.
  specialize (H (Stream.hd tr)). destruct H.
  exists (Stream.forever x). auto.
Qed.

Lemma Enabled_action' : forall P Q,
    is_st_formula Q ->
    (forall st,
        eval_formula Q (Stream.forever st) ->
        exists st',
          eval_formula P (Stream.Cons st (Stream.forever st'))) ->
    Q |-- Enabled P.
Proof.
  breakAbstraction; intros.
  specialize (H0 (Stream.hd tr)).
  eapply st_formula_hd in H1;
    [ apply H0 in H1 | assumption | reflexivity ].
  destruct H1. exists (Stream.forever x). auto.
Qed.

Lemma ex_state_flow_any : forall (P : (state * flow) -> Prop),
  (forall f, exists st, P (st, f)) ->
  exists stf, P stf.
Proof.
  intros. specialize (H (fun _ _ => R0)).
  destruct H. eauto.
Qed.

Lemma ex_state : forall (v : Var) (P : state -> Prop),
    (exists st,
        (exists val, P
          (fun v' => if String.string_dec v v'
                     then val else st v'))) ->
      exists st, P st.
Proof.
  intros. destruct H. destruct H. eauto.
Qed.

Lemma ex_state_any : forall (P : state -> Prop),
    (forall st, P st) ->
    exists st, P st.
Proof.
  intros. exists (fun _ => 0%R). eauto.
Qed.

Global Instance Proper_Enabled :
  Proper (lequiv ==> lequiv) Enabled.
Proof.
  red. red. unfold lequiv, lentails. simpl.
  unfold tlaEntails. simpl. intros. split.
  { intros. destruct H0. exists x0. intuition. }
  { intros. destruct H0. exists x0. intuition. }
Qed.

Global Instance Proper_Always_lequiv
: Proper (lequiv ==> lequiv) Always.
Proof.
  red. red. unfold lequiv, lentails. simpl.
  intuition. restoreAbstraction. tlaRevert. apply Always_imp.
  charge_tauto.
  restoreAbstraction. tlaRevert.
  apply Always_imp. charge_tauto.
Qed.

Global Instance Proper_Always_entails
: Proper (lentails ==> lentails) Always.
Proof.
 red. red. intros.
 tlaRevert.
 eapply Always_imp. charge_tauto.
Qed.

Global Instance Proper_Enabled_lentails
: Proper (lentails ==> lentails) Enabled.
Proof.
  morphism_intro.
  breakAbstraction.
  intros.
  destruct H0. exists x0. eauto.
Qed.

Global Instance Proper_PropF_lequiv
: Proper (iff ==> lequiv) PropF.
Proof.
  morphism_intro. compute. tauto.
Qed.

Global Instance Proper_PropF_lentails
: Proper (Basics.impl ==> lentails) PropF.
Proof.
  morphism_intro. compute. tauto.
Qed.

Lemma PropF_and : forall P Q, PropF (P /\ Q) -|- PropF P //\\ PropF Q.
Proof. compute. tauto. Qed.


(* Extension for [mgraph] of the library GraphTheory
   About Trees
 *)

From Coq Require Import Bool.
Set Warnings "-notation-overridden". (* to ignore warnings due to the import of ssreflect *)
From mathcomp Require Import all_ssreflect zify.
Set Warnings "notation-overridden".
From GraphTheory Require Import preliminaries mgraph structures bij setoid_bigop.
From Yalla Require Import mll_prelim graph_more.

Import EqNotations.

Set Mangle Names.
Set Mangle Names Light.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Section Tree.
Context {Lv Le : Type} {G : graph Lv Le}.

(* Tree = acyclic and connected graph *)
Definition utree {I : eqType} (f : edge G -> option I) :=
  uacyclic f /\ uconnected f.

(* In an acyclic graph (where we removed only edges), there is at most one path between two vertices *)
Lemma uacyclic_unique_path {I : finType} (f : edge G -> option I) :
  {in ~: f @^-1 None &, injective f} -> uacyclic f -> forall (s t : G) (p q : Supath f s t), p = q.
Proof.
  intros F A s t [p P] [q Q]. cbnb.
  destruct (eq_comparable p q) as [ | Neq]; trivial.
  exfalso.
  revert s P q Q Neq. induction p as [ | [ep bp] p IHp] => s P q Q Neq; destruct q as [ | [eq bq] q]; try by [].
  - revert P. rewrite /supath /= !andb_true_r => /eqP-?. subst t.
    by specialize (A _ {| upval := _ ; upvalK := Q |}).
  - revert Q. rewrite /supath /= !andb_true_r => /eqP-?. subst t.
    by specialize (A _ {| upval := _ ; upvalK := P |}).
  - assert (Pe : supath f s t ((ep, bp) :: p)) by assumption.
    assert (Qe : supath f s t ((eq, bq) :: q)) by assumption.
    revert P. rewrite /supath /= in_cons => /andP[/andP[/andP[/eqP-SP WP] /andP[uP UP]] /norP[/eqP-nP NP]].
    revert Q. rewrite /supath /= in_cons => /andP[/andP[/andP[/eqP-SQ WQ] /andP[uQ UQ]] /norP[/eqP-nQ NQ]].
    destruct (eq_comparable ep eq) as [ | Hneq]; [subst eq | ].
    + assert (bp = bq).
      { destruct (eq_comparable bp bq) as [ | Hneq]; trivial.
        contradict SQ. rewrite -SP.
        destruct bp, bq; try by [].
        - by apply nesym, (uacyclic_loop A), nesym.
        - by apply (uacyclic_loop A), nesym. }
      subst bq.
      revert Neq => /eqP. cbn. move => /nandP[/nandP[/eqP // | /eqP //] | /eqP-Neq].
      eapply (IHp (endpoint bp ep) _ q _ Neq). Unshelve. splitb. splitb.
    + clear Neq IHp.
      set pq : upath := p ++ upath_rev q.
      assert (WPQ : uwalk (endpoint bp ep) (endpoint bq eq) pq).
      { apply (uwalk_cat WP). by rewrite uwalk_rev. }
      assert (NPQ : None \notin [seq f e.1 | e <- pq]).
      { rewrite /pq map_cat mem_cat. splitb.
        by rewrite map_comp upath_rev_fst map_rev in_rev -map_comp. }
      destruct (uconnected_simpl F WPQ NPQ) as [PQ' HPQ'].
      assert (Eq : supath f (endpoint bq eq) (endpoint (~~bq) eq) [:: (eq, ~~bq)]).
      { rewrite /supath !in_cons /= orb_false_r negb_involutive. splitb. by apply /eqP. }
      set EQ := {| upval := _ ; upvalK := Eq |}.
      assert (Ep : supath f (endpoint (~~bp) ep) (endpoint bp ep) [:: (ep, bp)]).
      { rewrite /supath !in_cons /= orb_false_r. splitb. by apply /eqP. }
      set EP := {| upval := _ ; upvalK := Ep |}.
      assert (Qep : ep \notin [seq e.1 | e <- q]).
      { remember (ep \in [seq e.1 | e <- q]) as b eqn:In. symmetry in In.
        destruct b; trivial.
        assert (exists b, (ep, b) \in q) as [b In'] by by apply in_map_fst.
        clear In.
        apply in_elt_sub in In'.
        assert (In'' : exists (n : nat), q == take n q ++ (ep, b) :: drop n.+1 q).
        { destruct In' as [n ?]. exists n. by apply /eqP. }
        revert In'' => {In'} /sigW[n /eqP-Qeq].
        rewrite Qeq in Qe.
        destruct (eq_comparable b bp).
        - subst b.
          assert (Hr : (eq, bq) :: take n q ++ (ep, bp) :: drop n.+1 q =
            ((eq, bq) :: take n q) ++ [:: (ep, bp)] ++ drop n.+1 q).
          { by rewrite -(cat1s (ep, bp) (drop n.+1 q))
                       -(cat1s (eq, bq) ((take n q) ++ ([:: (ep, bp)] ++ (drop n.+1 q))))
                       -(cat1s (eq, bq) (take n q)) -!catA. }
          rewrite Hr {Hr} in Qe.
          destruct (supath_subKK Qe) as [L _].
          assert (Hr : (upath_target s ((eq, bq) :: (take n q))) = s).
          { transitivity (upath_source t ([:: (ep, bp)] ++ (drop n.+1 q))); last by rewrite /= SP.
            apply uwalk_sub_middle.
            by revert Qe => /andP[/andP[-> _] _]. }
          rewrite Hr {Hr} in L.
          specialize (A s {| upval := _ ; upvalK := L |}).
          contradict A. cbnb.
        - assert (b = ~~bp) by by destruct b, bp.
          subst b.
          assert (Hr : (eq, bq) :: take n q ++ (ep, ~~ bp) :: drop n.+1 q =
            (((eq, bq) :: take n q) ++ [:: (ep, ~~ bp)]) ++ drop n.+1 q).
          { by rewrite -(cat1s (ep, ~~ bp) (drop n.+1 q))
                       -(cat1s (eq, bq) ((take n q) ++ ([:: (ep, ~~ bp)] ++ (drop n.+1 q))))
                       -(cat1s (eq, bq) (take n q)) -!catA. }
          rewrite Hr {Hr} in Qe.
          destruct (supath_subKK Qe) as [L _].
          rewrite /= map_cat /= last_cat /= SP in L.
          specialize (A s {| upval := _ ; upvalK := L |}).
          contradict A. cbnb. }
      assert (Peq : eq \notin [seq e.1 | e <- p]).
      (* TODO same as Qep above: possible to do the 2 in 1 with a wlog/forall? *)
      { remember (eq \in [seq e.1 | e <- p]) as b eqn:In. symmetry in In.
        destruct b; trivial.
        assert (exists b, (eq, b) \in p) as [b In'] by by apply in_map_fst.
        clear In.
        apply in_elt_sub in In'.
        assert (In'' : exists (n : nat), p == take n p ++ (eq, b) :: drop n.+1 p).
        { destruct In' as [n ?]. exists n. by apply /eqP. }
        revert In'' => {In'} /sigW[n /eqP-Peq].
        rewrite Peq in Pe.
        destruct (eq_comparable b bq).
        - subst b.
          assert (Hr : (ep, bp) :: take n p ++ (eq, bq) :: drop n.+1 p =
            ((ep, bp) :: take n p) ++ [:: (eq, bq)] ++ drop n.+1 p).
          { by rewrite -(cat1s (eq, bq) (drop n.+1 p))
                       -(cat1s (ep, bp) ((take n p) ++ ([:: (eq, bq)] ++ (drop n.+1 p))))
                       -(cat1s (ep, bp) (take n p)) -!catA. }
          rewrite Hr {Hr} in Pe.
          destruct (supath_subKK Pe) as [L _].
          assert (Hr : (upath_target s ((ep, bp) :: (take n p))) = s).
          { transitivity (upath_source t ([:: (eq, bq)] ++ (drop n.+1 p))); last by rewrite /= SQ.
            apply uwalk_sub_middle.
            by revert Pe => /andP[/andP[-> _] _]. }
          rewrite Hr {Hr} in L.
          specialize (A s {| upval := _ ; upvalK := L |}).
          contradict A. cbnb.
        - assert (b = ~~bq) by by destruct b, bq.
          subst b.
          assert (Hr : (ep, bp) :: take n p ++ (eq, ~~ bq) :: drop n.+1 p =
            (((ep, bp) :: take n p) ++ [:: (eq, ~~ bq)]) ++ drop n.+1 p).
          { by rewrite -(cat1s (eq, ~~ bq) (drop n.+1 p))
                       -(cat1s (ep, bp) ((take n p) ++ ([:: (eq, ~~ bq)] ++ (drop n.+1 p))))
                       -(cat1s (ep, bp) (take n p)) -!catA. }
          rewrite Hr {Hr} in Pe.
          destruct (supath_subKK Pe) as [L _].
          rewrite /= map_cat /= last_cat /= SQ in L.
          specialize (A s {| upval := _ ; upvalK := L |}).
          contradict A. cbnb. }
      assert (DQ : upath_disjoint f PQ' EQ).
      { rewrite /upath_disjoint disjoint_sym disjoint_has /= orb_false_r.
        apply /mapP. move => [[k b] K /= KEQ].
        specialize (HPQ' _ K). clear K.
        assert (eq = k).
        { apply F; trivial.
          - rewrite !in_set. apply /eqP. by apply nesym.
          - rewrite !in_set. apply /eqP => FK.
            contradict NPQ. apply /negP/negPn.
            rewrite -FK.
            replace k with ((k, b).1) by trivial.
            by apply (map_f (fun e => f e.1)). }
        subst k. clear KEQ.
        revert HPQ'. rewrite /pq mem_cat upath_rev_in => /orP[In | In].
        - contradict Peq. apply /negP/negPn.
          replace eq with ((eq, b).1) by trivial.
          by apply map_f.
        - contradict uQ. apply /negP/negPn.
          replace eq with ((eq, ~~b).1) by trivial.
          by apply (map_f (fun e => f e.1)). }
      set PQ'Q := supath_cat DQ.
      assert (DP : upath_disjoint f EP PQ'Q).
      { rewrite /upath_disjoint disjoint_has /= map_cat mem_cat /= in_cons in_nil !orb_false_r.
        assert ((f ep) == (f eq) = false) as ->.
        { apply /eqP => FPQ.
          contradict Hneq.
          apply F; trivial.
          all: by rewrite !in_set; apply /eqP; apply nesym. }
        rewrite orb_false_r.
        apply /mapP. move => [[k b] K /= KEQ].
        specialize (HPQ' _ K). clear K.
        assert (ep = k).
        { apply F; trivial.
          - rewrite !in_set. apply /eqP. by apply nesym.
          - rewrite !in_set. apply /eqP => FK.
            contradict NPQ. apply /negP/negPn.
            rewrite -FK.
            replace k with ((k, b).1) by trivial.
            by apply (map_f (fun e => f e.1)). }
        subst k. clear KEQ.
        revert HPQ'. rewrite /pq mem_cat upath_rev_in => /orP[In | In].
        - contradict uP. apply /negP/negPn.
          replace ep with ((ep, b).1) by trivial.
          by apply (map_f (fun e => f e.1)).
        - contradict Qep. apply /negP/negPn.
          replace ep with ((ep, ~~b).1) by trivial.
          by apply map_f. }
      set PPQ'Q := supath_cat DP.
      assert (Nnil : upval PPQ'Q <> [::]) by by [].
      clearbody PPQ'Q. revert PPQ'Q Nnil. rewrite SP SQ => PPQ'Q Nnil.
      contradict Nnil.
      by rewrite (A _ PPQ'Q).
Qed.
(* Proof:
  By induction, we can assume P and Q differ on their first edges, respectively ep and eq.
  We denote by p and q the rest of P and Q respectively.
  With p and q, we get a path pq from the target of ep to the target of eq (this is the part where we need
  the infectivity of f).
  Remark that q does not contain ep. Otherwise, (eq ++ q) would go back to s, by following q until
  reaching ep (ep being in q or not according to signs). This would yield a non-trivial cycle,
  contradicting acyclicity.
  Similarly, p does not contain eq.
  Thus, the path pq does not contain ep nor eq, as it is contain in the walk p ++ q.
  But then, ep ++ pq ++ eq give us a non-trivial cycle, a contradiction
*)

Lemma utree_unique_path {I : finType} (f : edge G -> option I) :
  {in ~: f @^-1 None &, injective f} -> utree f -> forall (s t : G),
  { p : Supath f s t & forall (q : Supath f s t), p = q}.
Proof.
  intros F [A C] s t.
  revert C => /(_ s t)/sigW[P _].
  exists P.
  by apply uacyclic_unique_path.
Qed.

(* Function to define a partition of the vertices of a tree: given a vertex v,
   we partitione the tree into v itself, and a class for each edge of v,
   containing vertices accessible from this edge *)
Definition utree_part {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) (x : G) : option (edge G) :=
  match utree_unique_path F T v x with
  | existT {| upval := [::] ; upvalK := _ |} _        => None   (* class of v *)
  | existT {| upval := (e, _) :: _ ; upvalK := _ |} _ => Some e (* a class for each edge of v *)
  end.

(* In a tree, for any vertex v, we can partition the graph according to the edges of v *)
Lemma tree_partition {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  partition (preim_partition (utree_part F T v) setT) setT.
Proof. exact (preim_partitionP (utree_part F T v) setT). Qed. (* TODO notation? *)

Lemma inside_utree_part (S : {set G}) {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  S \in (preim_partition (utree_part F T v) [set: G]) ->
  forall a p (x : G) (X : x \in S),
  supath f v x (a :: p) ->
  forall e, e \in p -> e.1 \in edge_set S.
Proof.
  intros Sin a p.
  induction p as [ | p ep IH] using last_ind; first by by [].
  intros x X P e E.
  rewrite -rcons_cons in P.
  assert (P' := P).
  rewrite supath_rcons in P. revert P => /andP[/andP[/andP[P /eqP-?] ?] ?]. subst x.
  enough (TepS : usource ep \in S).
  { specialize (IH _ TepS P).
    revert E. rewrite in_rcons => /orP[/eqP-? | ]; last by apply IH.
    subst e. rewrite /= in_set.
    destruct ep as [? []]; splitb. }
  clear IH E e.
  apply (preim_partition_im_eq Sin X); trivial.
  clear Sin X S.
  unfold utree_part.
  destruct (utree_unique_path F T v (usource ep)) as [[ps Ps] Us].
  assert (ps = a :: p).
  { specialize (Us {| upvalK := P |}). by inversion Us. }
  subst ps. clear Us Ps .
  destruct (utree_unique_path F T v (utarget ep)) as [[pt Pt] Ut].
  assert (pt = rcons (a :: p) ep).
  { specialize (Ut {| upvalK := P' |}). by inversion Ut. }
  subst pt. clear Ut Pt P'.
  reflexivity.
Qed.

Lemma uconnected_utree_part_in (S : {set G})
  {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  S \in (preim_partition (utree_part F T v) [set: G]) ->
  forall x y, x \in S -> y \in S ->
  forall e, e \in upval (projT1 (utree_unique_path F T x y)) -> e.1 \in edge_set S.
(* Sketch of the proof :
   We have a path from v to x and one from v to y.
   Their concatenation, after reversing the first path and simplification,
   yields the unique path from x to y.
   This is a subpath of the previous two paths, without their
   first edges (the one involving v).
   These subpaths are included in S by Lemma inside_utree_part. *)
Proof.
  intros Sin x y X Y.
  destruct (utree_unique_path F T x y) as [P Pu]. simpl.
  assert (XY := preim_partition_in_eq Sin X Y).
  unfold utree_part in XY.
  destruct (utree_unique_path F T v x) as [[px Px] _].
  destruct (utree_unique_path F T v y) as [[py Py] _].
  destruct px as [ | (ex, box) px], py as [ | (ey, boy) py]; try by [].
  { revert Px Py => /supath_of_nilP-? /supath_of_nilP-?. subst x y.
    specialize (Pu (supath_nil _ v)). by subst P. }
  inversion XY. subst ey. clear XY.
  assert (PxS := inside_utree_part Sin X Px).
  assert (PyS := inside_utree_part Sin Y Py).
  rewrite !supath_cons in Px, Py.
  revert Px => /andP[/andP[/andP[Px /eqP-Usex] _] /eqP-FexN]. simpl in FexN.
  revert Py => /andP[/andP[/andP[Py /eqP-Usey] _] _].
  assert (box = boy).
  { clear P Pu px Px PxS py Py PyS x X y Y Sin F.
    destruct T as [A _].
    destruct (eq_comparable box boy) as [ | B]; trivial.
    apply nesym in FexN. assert (F := uacyclic_loop A FexN). contradict F.
    subst v. by destruct box, boy. }
  subst boy. clear Usey Usex FexN.
  apply supath_revK in Px. revert Px => /andP[/andP[Wx _] Nx].
  revert Py => /andP[/andP[Wy _] Ny].
  assert (Nxy : None \notin [seq f _e.1 | _e <- upath_rev px ++ py]).
  { by rewrite map_cat mem_cat negb_orb Nx Ny. }
  destruct (uconnected_simpl F (uwalk_cat Wx Wy) Nxy) as [Pxy Exy].
  specialize (Pu Pxy). subst Pxy.
  clear Nx Ny Nxy Wx Wy ex box X Y Sin T F.
  intros (e, b) E.
  revert Exy => /(_ _ E) {E}. rewrite mem_cat upath_rev_in => /orP[E | E].
  - exact (PxS _ E).
  - exact (PyS _ E).
Qed.

(* The partition of a tree yields connected components *)
Lemma uconnected_utree_part (S : {set G})
  {I J : finType} (f : edge G -> option I) (f' : edge (induced S) -> option J)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  (forall e (E : e \in edge_set S), None <> f e -> None <> f' (Sub e E : edge (induced S))) ->
  (forall e a (E : e \in edge_set S) (A : a \in edge_set S),
    f' (Sub e E) = f' (Sub a A) -> f e = f a) ->
  S \in (preim_partition (utree_part F T v) [set: G]) -> uconnected f'.
Proof.
  intros F0 F1 Sin [x X] [y Y].
  destruct (supath_to_induced F0 F1 (uconnected_utree_part_in Sin X Y) X Y) as [Q _].
  by exists Q.
Qed. (* TODO voir ce qui tient avec cette définition de f', plus générale *)

(* Furthermore these connected components are maximal ones *)
Lemma uconnected_max_utree_part (S : {set G}) {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  S \in (preim_partition (utree_part F T v) [set: G]) ->
  forall e, usource e \in S -> e.1 \notin edges_at v -> f e.1 <> None -> utarget e \in S.
Proof.
  intros Sin e Se Te Fe.
  enough (E : utree_part F T v (utarget e) = utree_part F T v (usource e)).
  { refine (preim_partition_im_eq Sin Se _ E). by rewrite in_set. }
  rewrite /utree_part.
  destruct (utree_unique_path F T v (usource e)) as [[[ | (a, b) ps] Ps] _].
  { revert Ps => /supath_of_nilP-?. subst v.
    contradict Te. apply /negP/negPn.
    rewrite edges_at_eq. destruct e as [? []]; caseb. }
  assert (E : supath f (usource e) (utarget e) [:: e]).
  { rewrite /supath /= !eq_refl /= in_cons in_nil orb_false_r. apply /eqP. by apply nesym. }
  destruct (utree_unique_path F T v (utarget e)) as [[pt Pt] Pteq].
  destruct e as [e eb]. simpl in *.
  destruct (upath_disjoint f {| upvalK := Ps |} {| upvalK := E |}) eqn:D.
  - specialize (Pteq (supath_cat D)).
    unfold supath_cat in Pteq. inversion Pteq. clear Pteq. by subst pt.
  - revert D. rewrite /upath_disjoint /= disjoint_sym disjoint_cons disjoint_nil andb_true_r in_cons
      => /negPn/orP[/eqP-D | D].
    { exfalso.
      assert (e = a).
      { apply F; rewrite // !in_set -?D; by apply /eqP. }
      subst e.
      contradict Te. apply /negP/negPn. rewrite edges_at_eq.
      destruct (supath_endpoint {| upvalK := Ps |}) as [Sa _]. simpl in Sa.
      destruct b; rewrite Sa; caseb. }
    revert D => /mapP[[e' eb'] /= Ein EE'].
    assert (e = e').
    { apply F; rewrite // !in_set -?EE'; by apply /eqP. }
    subst e'. clear EE'.
    apply in_elt_sub in Ein. destruct Ein as [n Pseq].
    enough (P' : supath f v (endpoint eb e)
      ((a, b) :: if eb' == eb then rcons (take n ps) (e, eb') else take n ps)).
    { specialize (Pteq {| upvalK := P' |}). inversion Pteq. by subst pt. }
    rewrite Pseq in Ps. case: ifP.
    + move => /eqP-?. subst eb'.
      replace ((a, b) :: take n ps ++ _) with (((a, b) :: rcons (take n ps) (e, eb)) ++ drop n.+1 ps)
        in Ps by by rewrite cat_cons cat_rcons.
      destruct (supath_subKK Ps) as [Ps' _].
      by rewrite /= map_rcons last_rcons in Ps'.
    + move => /eqP-?.
      replace (endpoint eb e) with (usource (e, eb')) by by destruct eb, eb'.
      assert (Hr : ((a, b) :: take n ps ++ (e, eb') :: drop n.+1 ps)
        = ([::] ++ ((a, b) :: take n ps) ++ (e, eb') :: drop n.+1 ps))
        by by rewrite cat_cons.
      rewrite {}Hr in Ps.
      exact (supath_subK Ps).
Qed.

(* An edge between two disjoint components, except the component [set v], is
an edge labelled None *)
Lemma utree_part_outside (S R : {set G}) {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  S \in (preim_partition (utree_part F T v) [set: G]) ->
  R \in (preim_partition (utree_part F T v) [set: G]) ->
  [disjoint S & R] -> [disjoint [set v] & S] -> [disjoint [set v] & R] ->
  forall e, usource e \in S -> utarget e \in R -> f e.1 = None.
Proof.
  intros Sin Rin SR VS VR e Se Re.
  apply /eqP/negPn/negP => /eqP-E.
  enough (Se' : utarget e \in S) by exact (disjointE SR Se' Re).
  refine (@uconnected_max_utree_part S I f F T v Sin e Se _ E).
  rewrite edges_at_eq negb_orb.
  destruct e as [e b]. simpl in *.
  destruct (eq_comparable (source e) v) as [Ve | Ve].
  - exfalso. destruct b; simpl in *.
    + rewrite Ve in Se. refine (disjointE VS _ Se). by rewrite in_set.
    + rewrite Ve in Re. refine (disjointE VR _ Re). by rewrite in_set.
  - splitb; apply /eqP => // Te.
    destruct b; simpl in *.
    + rewrite Te in Re. refine (disjointE VR _ Re). by rewrite in_set.
    + rewrite Te in Se. refine (disjointE VS _ Se). by rewrite in_set.
Qed.

Lemma utree_part_None {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v x : G) :
  utree_part F T v x = None -> x = v.
Proof.
  unfold utree_part.
  destruct (utree_unique_path F T v x) as [[[ | (e, b) p] P] _]; last by [].
  revert P. rewrite /supath /=. introb.
Qed.

Lemma utree_part_v_v {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  utree_part F T v v = None.
Proof.
  unfold utree_part. destruct (utree_unique_path F T v v) as [P Pu].
  specialize (Pu (supath_nil _ v)). by subst P.
Qed.

Lemma utree_part_v {I : finType} (f : edge G -> option I)
  (F : {in ~: f @^-1 None &, injective f}) (T : utree f) (v : G) :
  pblock (preim_partition (utree_part F T v) [set: G]) v = [set v].
Proof.
  assert (Spart := preim_partitionP (utree_part F T v) [set: G]).
  revert Spart => /andP[/eqP-Cov /andP[Triv _]].
  apply /setP => y.
  rewrite in_set -eq_pblock // ?Cov // preim_partition_pblock_eq //.
  destruct (eq_comparable y v) as [? | Y].
  { subst y. by rewrite !eq_refl. }
  transitivity false; last by (symmetry; apply /eqP).
  rewrite utree_part_v_v.
  destruct (utree_part F T v y) eqn:H; first by [].
  contradict Y. by apply (utree_part_None H).
Qed.

End Tree.


Require Import FP.Structures.EqvEnv.
Require Import FP.Structures.Proxy.
Require Import FP.Structures.Eqv.
Require Import FP.Relations.Setoid.

Import ProperNotation.

Class FUnit (t:Type->Type) :=
  { funit : forall {A}, A -> t A }.

Section FUnitWF.
  Context {t:Type -> Type}.
  Context {FUnit_:FUnit t}.
  Context {EqvEnv_:EqvEnv}.
  Context {EqvEnvLogical_:EqvEnvLogical}.
  Context {E_R_t:forall {A} {aPE:Px (env_PER A)}, Px (env_PER (t A))}.
  Context {E_R_WF_t :
    forall {A} {aPE:Px (env_PER A)} {aPEWF:Px (env_PER_WF A)},
    Px (env_PER_WF (t A))}.

  Class FUnitWF :=
    { funit_respect :>
        forall {A} {aER:Px (env_PER A)} {aER':Px (env_PER_WF A)},
        Proper env_eqv (funit (A:=A))
    }.
End FUnitWF.
Arguments FUnitWF t {_ _ _ _}.
Hint Extern 9 (Proper env_eqv funit) => apply funit_respect : typeclass_instances.

Section EqvEnv_eqv.
  Local Instance EqvEnv_ : EqvEnv := eqv_EqvEnv.
  Local Instance EqvEnvLogical_ : EqvEnvLogical := eqv_EqvEnvLogical.
  Context {t:Type -> Type}.
  Context {FUnit_:FUnit t}.
  Context {E_R_t:forall {A} {aPE:Eqv A}, Eqv (t A)}.
  Context {E_R_WF_t :
    forall {A} {aPE:Eqv A} {aPEWF:Eqv_PE_WF A},
    Eqv_PE_WF (t A)}.
  Context {FUnitWF_:FUnitWF t}.

  Global Instance funit_respect_eqv :
    forall {A} {aER:Eqv A} {aER':Eqv_PE_WF A},
    Proper eqv (funit (A:=A)).
  Proof.
    intros.
    pose (@funit_respect _ _ _ _ _).
    eauto.
  Qed.
End EqvEnv_eqv.


(* Written by Sosuke Moriguchi (chiguri), Kwansei Gakuin University *)

(** * Functor from Network Topology to specifications/proofs about extracting all Events and Packets about the specific Content_Name.

      This guarantees that each event does not use shared resource in this settings.
      (Be careful that if we add limits of ContentStores, this is not valid since other contents change the state of ContentStores.)
 *)

Require Import List.
Import ListNotations.

Require Import MiscSpec.

Require CCNTopology.
Require CCNProtocol.

Module CCN_Protocol_Content (N : CCNTopology.CCN_Network).
Import N.

Module Protocol := CCNProtocol.CCN_Protocol N.
Import Protocol.

Definition packet_content_name (p : Packet) : Content_Name :=
match p with
| Interest _ _ c => c
| Data _ _ c _ => c
end.

Definition event_content_name (e : Event) : Content_Name :=
match e with
| Request _ c => c
| ForwardInterest _ c => c
| AddPIT _ _ c => c
| ReplyData _ c => c
| ForwardData _ c => c
| StoreData _ c _ => c
end.

Fixpoint content_list {A : Type} (cname : A -> Content_Name) (c : Content_Name) (al : list A) : list A :=
match al with
| [] => []
| a :: al' =>
  if Content_Name_eq_dec c (cname a)
     then a :: content_list cname c al'
     else content_list cname c al'
end.

Definition content_packets := content_list packet_content_name.
Definition content_events := content_list event_content_name.

Arguments content_packets /.
Arguments content_events /.

Lemma content_list_app :
 forall {A : Type} (cname : A -> Content_Name) (c : Content_Name) (al1 al2 : list A),
  content_list cname c (al1 ++ al2) = content_list cname c al1 ++ content_list cname c al2.
Proof.
intros A cname c al1; induction al1; intros; simpl in *.
 now auto.
 destruct Content_Name_eq_dec with c (cname a).
  simpl; f_equal; now auto.
  now auto.
Qed.

Lemma Broadcast_Interest_content :
 forall (v : Node) (c : Content_Name),
  content_packets c (Broadcast_Interest v c) = Broadcast_Interest v c.
unfold Broadcast_Interest.
intro v.
generalize (Connected_list v).
induction l; intros; simpl.
+now auto.
+destruct Content_Name_eq_dec.
 -f_equal; now auto.
 -elim n; now auto.
Qed.

Lemma Broadcast_Interest_not_content :
 forall (v : Node) (c c' : Content_Name),
  c <> c' ->
   content_packets c (Broadcast_Interest v c') = [].
unfold Broadcast_Interest.
intro v.
generalize (Connected_list v).
induction l; intros; simpl.
+now auto.
+destruct Content_Name_eq_dec.
 -elim H; now auto.
 -now auto.
Qed.

Lemma FIB_Interest_content :
 forall (v : Node) (c : Content_Name),
  content_packets c (FIB_Interest v c) = FIB_Interest v c.
unfold FIB_Interest.
intros v c.
generalize (FIB_list v c).
induction l; intros; simpl.
+now auto.
+destruct Content_Name_eq_dec.
 -f_equal; now auto.
 -elim n; now auto.
Qed.

Lemma FIB_Interest_not_content :
 forall (v : Node) (c c' : Content_Name),
  c <> c' ->
   content_packets c (FIB_Interest v c') = [].
unfold FIB_Interest.
intros v c c'.
generalize (FIB_list v c').
induction l; intros; simpl.
+now auto.
+destruct Content_Name_eq_dec.
 -elim H; now auto.
 -now auto.
Qed.

Lemma PIT_Data_content :
 forall (v : Node) (c : Content_Name) (C : Content c) (es : list Event),
  content_packets c (PIT_Data v c C es) = PIT_Data v c C es.
unfold PIT_Data.
intros v c C es.
generalize (PIT_list v c es).
induction l; intros; simpl.
+now auto.
+destruct Content_Name_eq_dec.
 -f_equal; now auto.
 -elim n; now auto.
Qed.

Lemma PIT_Data_not_content :
 forall (v : Node) (c c' : Content_Name) (C : Content c') (es : list Event),
  c <> c' ->
   content_packets c (PIT_Data v c' C es) = [].
unfold PIT_Data.
intros v c c' C es.
generalize (PIT_list v c' es).
induction l; intros; simpl.
+now auto.
+destruct Content_Name_eq_dec.
 -elim H; now auto.
 -now auto.
Qed.

Lemma content_list_cons :
 forall {A : Type} (cname : A -> Content_Name) (c : Content_Name) (a : A) (al : list A),
  c = cname a ->
   content_list cname c (a :: al) = a :: (content_list cname c al).
intros; simpl.
destruct Content_Name_eq_dec.
 now auto.
 elim n; now auto.
Qed.

Lemma content_list_cons_not :
 forall {A : Type} (cname : A -> Content_Name) (c : Content_Name) (a : A) (al : list A),
  c <> cname a ->
   content_list cname c (a :: al) = content_list cname c al.
intros; simpl.
destruct Content_Name_eq_dec.
 elim H; now auto.
 now auto.
Qed.

Lemma Content_get_events :
 forall (v : Node) (c : Content_Name) (es : list Event),
  Content_get v c es = Content_get v c (content_events c es).
induction es.
 simpl; now auto.
 simpl.
 destruct Content_Name_eq_dec.
 +simpl.
  destruct a; auto.
  destruct Node_eq_dec; auto.
  destruct Content_Name_eq_dec; now auto.
 +destruct a; auto.
  simpl in n.
  destruct Node_eq_dec; auto.
  destruct Content_Name_eq_dec.
   elim n; now auto.
   now auto.
Qed.

Lemma content_PIT_list :
 forall (v : Node) (c : Content_Name) (es : list Event),
  PIT_list v c (content_list event_content_name c es) = PIT_list v c es.
induction es; simpl.
 now auto.
 destruct Content_Name_eq_dec.
 +destruct a; auto.
  -simpl.
   destruct Node_eq_dec; auto.
   destruct Content_Name_eq_dec.
    f_equal; now auto.
    now auto.
  -simpl.
   destruct Node_eq_dec; auto.
   destruct Content_Name_eq_dec; now auto.
 +destruct a; auto.
  -destruct Node_eq_dec; auto.
   destruct Content_Name_eq_dec.
    elim n; simpl; now auto.
    now auto.
  -destruct Node_eq_dec; auto.
   destruct Content_Name_eq_dec.
    elim n; simpl; now auto.
    now auto.
Qed.

Lemma content_PIT_Data :
 forall (v : Node) (c : Content_Name) (C : Content c) (es : list Event),
  PIT_Data v c C es = PIT_Data v c C (content_list event_content_name c es).
unfold PIT_Data.
intros; rewrite content_PIT_list; now auto.
Qed.

Lemma content_In :
 forall {A : Type} (cname : A -> Content_Name) (c : Content_Name) (a : A) (al : list A),
  c = cname a ->
   (In a (content_list cname c al) <-> In a al).
intros; induction al; simpl.
split; now auto.
destruct IHal.
split.
+destruct Content_Name_eq_dec; simpl; intro.
 -destruct H2; now auto.
 -now auto.
+intro; destruct Content_Name_eq_dec; simpl.
 -destruct H2; now auto.
 -destruct H2.
   subst.
    elim n; now auto.
   now auto.
Qed.

Theorem CCNProtocol_single_content :
 forall (c : Content_Name) (es : list Event) (ps : list Packet),
  CCNprotocol es ps -> CCNprotocol (content_events c es) (content_packets c ps).
Proof.
intros c es ps H; induction H; simpl in *; subst.
+now constructor.
+rewrite content_list_app.
 destruct Content_Name_eq_dec.
 -subst.
  rewrite Broadcast_Interest_content.
  apply ccn_request with (content_list packet_content_name c0 ps); auto.
  rewrite <- Content_get_events; now auto.
 -rewrite Broadcast_Interest_not_content.
  simpl; now auto.
  now auto.
+repeat rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol.
 simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  rewrite FIB_Interest_content.
  apply ccn_forward_interest with (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *rewrite content_PIT_list; now auto.
  *now auto.
  *now auto.
 -rewrite FIB_Interest_not_content; simpl; now auto.
+rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  apply ccn_add_pit with (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *rewrite content_PIT_list; now auto.
  *rewrite content_PIT_list; now auto.
  *now auto.
  *now auto.
 -now auto.
+rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  apply ccn_drop_interest_fib with v v' c0 (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *now auto.
  *now auto.
 -now auto.
+rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  apply ccn_drop_interest_pit with v v' c0 (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *rewrite content_PIT_list; now auto.
  *now auto.
 -now auto.
+simpl.
 rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  apply ccn_reply_data with v C (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *now auto.
 -now auto.
+rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  apply ccn_store_data with v (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *apply content_In; now auto.
  *rewrite content_PIT_list; now auto.
  *now auto.
 -now auto.
+simpl; repeat rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  rewrite PIT_Data_content.
  apply ccn_forward_data with v (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *intro.
   apply content_In in H3; now auto.
  *rewrite content_PIT_list; now auto.
  *rewrite content_PIT_Data; now auto.
 -rewrite PIT_Data_not_content; simpl; now auto.
+repeat rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  rewrite PIT_Data_content.
  apply ccn_store_forward with v (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *apply content_In; now auto.
  *rewrite content_PIT_list; now auto.
  *rewrite content_PIT_Data; now auto.
 -rewrite PIT_Data_not_content; simpl; now auto.
+rewrite content_list_app.
 rewrite content_list_app in IHCCNprotocol; simpl in IHCCNprotocol.
 destruct Content_Name_eq_dec.
 -subst.
  apply ccn_drop_data with v v' c0 C (content_packets c0 ps1) (content_packets c0 ps2).
  *now auto.
  *rewrite <- Content_get_events; now auto.
  *now auto.
 -now auto.
Qed.

End CCN_Protocol_Content.