(******************************************************************************)
(*   Copyright (c) 2019--2022 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Require Import Lia.
Require Import Arith.
Require Import Equality.
Require Import Relations.
Require Import Local.Prelude.
Require Import Local.Syntax.
Require Import Local.Metatheory.
Require Import Local.AbstractRewriting.
Require Import Local.Context.
Require Import Local.Axiomatic.
Require Import Local.Reduction.
Require Import Local.Confluence.
Require Import Local.Factorization.

(** ** Observational theory *)

Inductive converges: pseudoterm -> nat -> Prop :=
  | converges_jump:
    forall k xs,
    converges (jump (bound k) xs) k
  | converges_bind:
    forall b ts c k,
    converges b (S k) -> converges (bind b ts c) k.

Global Hint Constructors converges: cps.

Definition weakly_converges a n: Prop :=
  comp star converges a n.

Global Hint Unfold weakly_converges: cps.

Lemma convergence_is_unique:
  forall e n,
  converges e n ->
  forall m,
  converges e m -> n = m.
Proof.
  induction 1; intros.
  (* Case: converges_jump. *)
  - inversion H; auto.
  (* Case: converges_bind. *)
  - dependent destruction H0.
    firstorder.
Qed.

Lemma converges_context_inversion:
  forall h,
  static h ->
  forall k xs n,
  converges (h (jump (bound k) xs)) n ->
  n = k - #h.
Proof.
  induction 1; simpl; intros.
  - dependent destruction H.
    lia.
  - dependent destruction H0.
    rename k0 into n.
    assert (S n = k - #h).
    + eapply IHstatic; eauto.
    + lia.
Qed.

Lemma converges_jump_inversion:
  forall (h: context) xs k,
  converges (h (jump #h xs)) k ->
  k > 0 ->
  nonstatic h.
Proof.
  unfold nonstatic, not; intros.
  assert (k = #h - #h).
  - eapply converges_context_inversion; eauto.
  - lia.
Qed.

Lemma converges_is_preserved_by_subst:
  forall c k p y,
  converges c (p + S k) ->
  converges (subst y p c) (p + k).
Proof.
  intros.
  dependent induction H.
  - rewrite subst_distributes_over_jump.
    rewrite subst_bound_gt; try lia.
    rewrite Nat.add_comm; simpl.
    rewrite Nat.add_comm; constructor.
  - rewrite subst_distributes_over_bind.
    constructor.
    replace (S (p + k)) with (S p + k); try lia.
    apply IHconverges; lia.
Qed.

Lemma converges_is_preserved_by_step:
  forall a b,
  [a => b] ->
  forall n,
  converges a n -> converges b n.
Proof.
  induction 1; intros.
  - dependent destruction H0.
    constructor.
    assert (nonstatic h).
    + eapply converges_jump_inversion; eauto.
      lia.
    + generalize dependent k.
      generalize #h.
      induction H1 using nonstatic_ind; simpl; intros.
      * dependent destruction H0.
        constructor; auto.
      * dependent destruction H0.
        constructor; auto.
  - dependent destruction H0.
    apply converges_is_preserved_by_subst with (p := 0).
    assumption.
  - dependent destruction H0.
    constructor; auto.
  - dependent destruction H0.
    constructor; auto.
Qed.

Global Hint Resolve converges_is_preserved_by_step: cps.

Lemma converges_is_preserved_by_star:
  forall a b,
  [a =>* b] ->
  forall n,
  converges a n -> converges b n.
Proof.
  induction 1; eauto with cps.
Qed.

Global Hint Resolve converges_is_preserved_by_star: cps.

Lemma weakly_converges_is_preserved_by_conv:
  forall a b,
  [a <=> b] ->
  forall n,
  weakly_converges a n -> weakly_converges b n.
Proof.
  destruct 2 as (c, ?, ?).
  assert [c <=> b].
  - eauto with cps.
  - destruct step_is_church_rosser with c b as (d, ?, ?); auto.
    exists d; auto.
    apply converges_is_preserved_by_star with c; auto.
Qed.

Lemma weakly_convergence_is_a_function:
  forall e n,
  weakly_converges e n ->
  forall m,
  weakly_converges e m -> n = m.
Proof.
  intros.
  destruct H as (a, ?, ?).
  destruct H0 as (b, ?, ?).
  destruct step_is_confluent with e a b as (c, ?, ?); auto.
  assert (converges c n); eauto with cps.
  assert (converges c m); eauto with cps.
  apply convergence_is_unique with c; auto.
Qed.

Lemma converges_lift:
  forall e n,
  converges e n ->
  forall i k (m: nat),
  lift i k n = m ->
  converges (lift i k e) m.
Proof.
  induction 1; intros.
  - rename k0 into p.
    rewrite lift_distributes_over_jump.
    rewrite H.
    constructor.
  - rename k0 into p.
    rewrite lift_distributes_over_bind.
    constructor.
    apply IHconverges.
    destruct (le_gt_dec p k).
    + rewrite lift_bound_ge in H0; auto.
      rewrite lift_bound_ge; try lia.
      dependent destruction H0.
      f_equal; lia.
    + rewrite lift_bound_lt in H0; auto.
      rewrite lift_bound_lt; try lia.
      dependent destruction H0.
      f_equal; lia.
Qed.

Lemma converges_subst:
  forall e n,
  converges e n ->
  forall y k (m: nat),
  subst y k n = m ->
  converges (subst y k e) m.
Proof.
  induction 1; intros.
  - rename k0 into p.
    rewrite subst_distributes_over_jump.
    rewrite H.
    constructor.
  - rename k0 into p.
    rewrite subst_distributes_over_bind.
    constructor.
    apply IHconverges.
    destruct (lt_eq_lt_dec p k) as [ [ ? | ? ] | ? ].
    + rewrite subst_bound_gt in H0; auto.
      rewrite subst_bound_gt; try lia.
      dependent destruction H0.
      f_equal; lia.
    + rewrite subst_bound_eq in H0; auto.
      rewrite subst_bound_eq; try lia.
      destruct y; try discriminate.
      rewrite lift_bound_ge in H0; try lia.
      rewrite lift_bound_ge; try lia.
      dependent destruction H0.
      f_equal; lia.
    + rewrite subst_bound_lt in H0; auto.
      rewrite subst_bound_lt; try lia.
      dependent destruction H0.
      f_equal; lia.
Qed.

Lemma converges_unlift:
  forall i k e n,
  converges (lift i k e) n ->
  exists2 m,
  converges e m & bound n = lift i k m.
Proof.
  intros.
  dependent induction H.
  - destruct e; try discriminate.
    + exfalso.
      destruct (le_gt_dec k n).
      * rewrite lift_bound_ge in x; auto.
        inversion x.
      * rewrite lift_bound_lt in x; auto.
        inversion x.
    + rewrite lift_distributes_over_jump in x.
      dependent destruction x.
      destruct e; try discriminate.
      exists n; auto with cps.
  - destruct e; try discriminate.
    + exfalso.
      destruct (le_gt_dec k n).
      * rewrite lift_bound_ge in x; auto.
        inversion x.
      * rewrite lift_bound_lt in x; auto.
        inversion x.
    + rewrite lift_distributes_over_bind in x.
      dependent destruction x.
      edestruct IHconverges; eauto.
      destruct x.
      * exfalso.
        rewrite lift_bound_lt in H1; try lia.
        discriminate.
      * exists x; auto with cps.
        (* TODO: fix this proof, please. *)
        destruct (le_gt_dec k x).
        rewrite lift_bound_ge in H1 |- *; try lia.
        dependent destruction H1; f_equal; lia.
        rewrite lift_bound_lt in H1 |- *; try lia.
        congruence.
Qed.

(** ** Observational relations *)

(* We'd like to show that defining weak convergence by using either head or full
   reduction coincide; this will allow us to further extend Merro's results:
   enabling full reduction won't change the observable behavior of terms, since
   the observational relations introduced by either of the reduction relations
   will also coincide. Of course, one of the sides is trivial.

   This proof seems way more trickier than I thought... it will probably require
   a notion of standard reduction sequences, in which we only allow jumps to be
   performed to unchanged commands (i.e., leftmost first, instead of rightmost
   first as it's done in the parallel reduction lemmas). If this is complete
   w.r.t. star, such that forall a =>* b there's a standard sequence from a to
   b, then it'll reach the correct head position using only head steps. *)

Local Lemma subst_backwards_preserves_convergence_gc:
  forall c y k p,
  not_free p c ->
  converges (subst y p c) (p + k) ->
  converges c (p + S k).
Proof.
  intros.
  dependent induction H0.
  - destruct c; try discriminate.
    + exfalso.
      dependent destruction H.
      destruct (le_gt_dec n0 n).
      * rewrite subst_bound_gt in x; try lia.
        discriminate.
      * rewrite subst_bound_lt in x; try lia.
        discriminate.
    + rewrite subst_distributes_over_jump in x.
      dependent destruction x.
      dependent destruction H.
      destruct c; try discriminate.
      dependent destruction H.
      destruct (le_gt_dec n n0).
      * rewrite subst_bound_gt in x; try lia.
        dependent destruction x.
        replace n0 with (n + S k); try lia.
        constructor.
      * exfalso.
        rewrite subst_bound_lt in x; try lia.
        dependent destruction x.
        lia.
  - destruct c; try discriminate.
    + exfalso.
      dependent destruction H.
      destruct (le_gt_dec n0 n).
      * rewrite subst_bound_gt in x; try lia.
        discriminate.
      * rewrite subst_bound_lt in x; try lia.
        discriminate.
    + rewrite subst_distributes_over_bind in x.
      dependent destruction x.
      dependent destruction H.
      constructor.
      rewrite <- plus_Sn_m.
      eapply IHconverges; eauto.
Qed.

(* Local Lemma subst_backwards_preserves_convergence_eta:
  forall h k xs y,
  static h ->
  forall c j p,
  k <> bound (p + #h) ->
  c = h (jump k xs) ->
  converges (subst y p c) (p + j) ->
  converges c (p + S j).
Proof.
  induction 1; intros.
  - rewrite Nat.add_comm in H.
    simpl in H, H0.
    dependent destruction H0.
    rewrite subst_distributes_over_jump in H1.
    dependent destruction H1.
    destruct k; try discriminate.
    (* H is an equality between terms! *)
    assert (n <> p); eauto.
    destruct (le_gt_dec p n).
    + rewrite subst_bound_gt in x; try lia.
      dependent destruction x.
      replace n with (p + S j); try lia.
      constructor.
    + exfalso.
      rewrite subst_bound_lt in x; try lia.
      dependent destruction x.
      lia.
  - simpl in H0, H1.
    destruct c0; try discriminate.
    dependent destruction H1.
    rewrite subst_distributes_over_bind in H2.
    dependent destruction H2.
    constructor.
    rewrite <- plus_Sn_m.
    apply IHstatic.
    + rewrite plus_Snm_nSm.
      assumption.
    + reflexivity.
    + assumption.
Qed. *)

Lemma inner_backwards_preserves_convergence:
  forall a b,
  inner a b ->
  forall k,
  converges b k -> converges a k.
Proof.
  induction 1.
  - clear H0; generalize #h; intros.
    dependent destruction H0; constructor.
    dependent induction H0.
    + exfalso.
      destruct h; try discriminate.
      apply H; auto with cps.
    + destruct h.
      * exfalso.
        apply H; auto with cps.
      * dependent destruction x; simpl.
        constructor.
        eapply IHconverges; eauto.
        intro; apply H.
        constructor; auto.
      * dependent destruction x; simpl.
        constructor; auto.
  - intros.
    constructor.
    eapply subst_backwards_preserves_convergence_gc with (p := 0).
    + assumption.
    + eassumption.
  - intros.
    dependent destruction H0.
    constructor; auto.
  - intros.
    dependent destruction H0.
    constructor; auto.
Qed.

Lemma rt_inner_backwards_preserves_convergence:
  forall a b,
  rt(inner) a b ->
  forall k,
  converges b k -> converges a k.
Proof.
  induction 1; intros.
  - eapply inner_backwards_preserves_convergence; eauto.
  - assumption.
  - firstorder.
Qed.

Theorem head_reduction_preserves_convergence:
  forall a k,
  weakly_converges a k -> comp rt(head) converges a k.
Proof.
  destruct 1 as (c, ?, ?).
  apply factorization in H.
  destruct H as (b, ?, ?).
  exists b; auto.
  apply rt_inner_backwards_preserves_convergence with c; auto.
Qed.

Corollary weak_convergence_characterization:
  forall a k,
  weakly_converges a k <-> comp rt(head) converges a k.
Proof.
  split; intros.
  - apply head_reduction_preserves_convergence; auto.
  - destruct H as (b, ?, ?).
    exists b; auto.
    clear H0.
    induction H; eauto with cps.
Qed.

(** ** Barbed relations *)

Notation barb := (barbed_congruence head converges apply_context).

Notation "[ a ~~ b ]" := (barb a b)
  (at level 0, a, b at level 200): type_scope.

Lemma barb_refl:
  forall e,
  [e ~~ e].
Proof.
  intros.
  apply barbed_congruence_refl.
Qed.

Global Hint Resolve barb_refl: cps.

Lemma barb_sym:
  forall a b,
  [a ~~ b] -> [b ~~ a].
Proof.
  intros.
  apply barbed_congruence_sym; auto.
Qed.

Global Hint Resolve barb_sym: cps.

Lemma barb_trans:
  forall a b c,
  [a ~~ b] -> [b ~~ c] -> [a ~~ c].
Proof.
  intros.
  eapply barbed_congruence_trans; eauto.
Qed.

Global Hint Resolve barb_trans: cps.

Lemma barb_bind_left:
  LEFT barb.
Proof.
  unfold LEFT; intros.
  set (r := context_left context_hole ts c).
  replace (bind b1 ts c) with (r b1); auto.
  replace (bind b2 ts c) with (r b2); auto.
  intro; do 2 rewrite <- compose_context_is_sound.
  apply H.
Qed.

Global Hint Resolve barb_bind_left: cps.

Lemma barb_bind_right:
  RIGHT barb.
Proof.
  unfold RIGHT; intros.
  set (r := context_right b ts context_hole).
  replace (bind b ts c1) with (r c1); auto.
  replace (bind b ts c2) with (r c2); auto.
  intro; do 2 rewrite <- compose_context_is_sound.
  apply H.
Qed.

Global Hint Resolve barb_bind_right: cps.

Lemma barb_lift:
  forall a b,
  [a ~~ b] ->
  forall i k,
  [lift i k a ~~ lift i k b].
Proof.
  (* There's no reason this shouldn't be true, and we even checked that this is
     true for sema. But this seems to be overly complex to prove, so I'll get
     back to this later on! *)
  admit.
Admitted.

Global Instance barb_is_a_congruence: Congruence barb.
Proof.
  split.
  - split.
    + exact barb_refl.
    + exact barb_sym.
    + exact barb_trans.
  - exact barb_bind_left.
  - exact barb_bind_right.
Defined.

(* If R and R-1 are barbed simulations, so is the equivalence closure of R.
   This might be useful in showing that sema is a barbed bisimulation by tracing
   its individual axioms. *)

Goal
  forall R,
  (* TODO: generalize this. *)
  barbed_simulation step converges R ->
  barbed_simulation step converges (transp R) ->
  barbed_simulation step converges rst(R).
Proof.
  split.
  - do 3 intro.
    assert ((forall c, [a =>* c] -> exists2 d, [b =>* d] & rst(R) c d)
         /\ (forall c, [b =>* c] -> exists2 d, [a =>* d] & rst(R) c d)).
    + induction H1; split; intros.
      * destruct H.
        eapply multistep_reduction_closed with (S := R) in H2 as (d, ?, ?);
          eauto.
        exists d; auto with cps.
      * destruct H0.
        eapply multistep_reduction_closed with (S := transp R) in H2
          as (d, ?, ?); eauto.
        exists d; auto with cps.
      * eauto with cps.
      * eauto with cps.
      * firstorder.
      * firstorder.
      * destruct IHclos_refl_sym_trans1.
        destruct IHclos_refl_sym_trans2.
        destruct H2 with c as (d, ?, ?); auto.
        destruct H4 with d as (e, ?, ?); auto.
        exists e; eauto with cps.
      * destruct IHclos_refl_sym_trans1.
        destruct IHclos_refl_sym_trans2.
        destruct H5 with c as (d, ?, ?); auto.
        destruct H3 with d as (e, ?, ?); auto.
        exists e; eauto with cps.
    + destruct H2.
      induction H1; intros.
      * eauto with cps.
      * eauto with cps.
      * eauto with cps.
      * eauto with cps.
  - do 4 intro.
    assert ((weakly_converges a n -> weakly_converges b n)
         /\ (weakly_converges b n -> weakly_converges a n)).
    + induction H1; split; intros.
      * destruct H.
        destruct H2 as (z, ?, ?).
        eapply multistep_reduction_closed in H1; eauto.
        destruct H1 as (w, ?, ?).
        apply H3 in H5.
        destruct H5 with n as (k, ?, ?); auto.
        exists k; eauto with cps.
      * destruct H0.
        destruct H2 as (z, ?, ?).
        assert (transp R y x); eauto.
        eapply multistep_reduction_closed in H5; eauto.
        destruct H5 as (w, ?, ?).
        apply H3 in H6.
        destruct H6 with n as (k, ?, ?); auto.
        exists k; eauto with cps.
      * assumption.
      * assumption.
      * firstorder.
      * firstorder.
      * firstorder.
      * firstorder.
    + destruct H2.
      induction H1; intros.
      * unfold weakly_converges in H2, H3.
        eauto with cps.
      * apply H2; eexists; eauto with cps.
      * apply H2; eexists; eauto with cps.
      * destruct H2 as (w, ?, ?); eexists; eauto with cps.
Qed.

Theorem barb_sema:
  forall a b,
  [a == b] -> [a ~~ b].
Proof.
  admit.
Admitted.

Corollary barb_conv:
  forall a b,
  [a <=> b] -> [a ~~ b].
Proof.
  intros.
  apply barb_sema.
  apply sema_conv.
  assumption.
Qed.


Require Import Coq.Reals.Reals.
Require Import Coquelicot.Coquelicot.
Require Import Coq.micromega.Psatz.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import ExtLib.Structures.Applicative.
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Logics.ILogicIso.
Require ChargeCore.Logics.ILInsts.

Section ODE.

  Variable state : NormedModule R_AbsRing.

  (* An ordinary differential inclusions is a predicate over
     derivatives and their variables. *)
  Definition ODI : Type := state -> state -> Prop.

  (* A trajectory of the system is a mapping from time to state.
     We could restrict time to be nonegreal, but this probably makes
     most things messier. *)
  Definition trajectory : Type := R -> state.

  Definition StateVal (T : Type) := state -> T.
  Definition FlowVal (T : Type) := state -> state -> T.
  Definition TrajectoryVal (T : Type) := trajectory -> T.
  Global Instance Applicative_StateVal : Applicative StateVal :=
    { pure := fun _ x => (fun _ => x)
      ; ap   := fun _ _ f x => (fun st => f st (x st)) }.
  Global Instance Applicative_FlowVal : Applicative FlowVal :=
    { pure := fun _ x => (fun _ _ => x)
      ; ap   := fun _ _ f x => (fun st st' => f st st' (x st st')) }.
  Global Instance Applicative_TrajectoryVal : Applicative TrajectoryVal :=
    { pure := fun _ x => (fun _ => x)
      ; ap   := fun _ _ f x => (fun tr => f tr (x tr)) }.

  (** Notation for applicative functors *)
  Notation "x <$> y" := (ap x y) (at level 30).

  Definition liftA1 {T U : Type} {F : Type -> Type}
             {Ap : Applicative.Applicative F}
             (f : T -> U) (x : F T) : F U := (pure f) <$> x.

  Definition liftA2 (T: Type -> Type) {app: Applicative T} (A B C: Type)
             (f: A -> B -> C) (a: T A) (b: T B): T C :=
    pure f <$> a <$> b.
  Arguments liftA2 [_ _ _ _ _] _ _ _.

  Notation "a [+] b" := (liftA2 Rplus a b) (at level 50, left associativity).
  Notation "a [-] b" := (liftA2 Rminus a b) (at level 50, left associativity).
  Notation "a [*] b" := (liftA2 Rmult a b) (at level 40, left associativity).
  Notation "a [^] n" := (liftA2 pow a n) (at level 40, left associativity).
  Notation "a [/] b" := (liftA2 Rdiv a b) (at level 40, left associativity).
  Notation "a [>=] b" := (liftA2 Rge a b) (at level 70, right associativity).
  Notation "a [<=] b" := (liftA2 Rle a b) (at level 70, right associativity).
  Notation "a [>] b" := (liftA2 Rgt a b) (at level 70, right associativity).
  Notation "a [<] b" := (liftA2 Rlt a b) (at level 70, right associativity).
  Notation "a [=] b" := (liftA2 (@eq R) a b) (at level 70, right associativity).
  Notation "a [<>] b" := (liftA1 not (liftA2 (@eq R) a b)) (at level 70, right associativity).
  Notation "[sqrt] e" := (liftA1 sqrt e) (at level 30, right associativity).
  Notation "# x" := (pure x) (at level 20, right associativity).
  Notation "c ?<= x [?] e1 [:] e2" :=
    (fun st => if Rle_dec (c st) x then e1 st else e2 st) (at level 80).

  Notation "a [[+]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rplus a b) (at level 50, left associativity).
  Notation "a [[-]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rminus a b) (at level 50, left associativity).
  Notation "a [[*]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rmult a b) (at level 40, left associativity).
  Notation "a [[^]] n" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ pow a n) (at level 40, left associativity).
  Notation "a [[/]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rdiv a b) (at level 40, left associativity).
  Notation "a [[>=]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rge a b) (at level 70, right associativity).
  Notation "a [[<=]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rle a b) (at level 70, right associativity).
  Notation "a [[>]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rgt a b) (at level 70, right associativity).
  Notation "a [[<]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ Rlt a b) (at level 70, right associativity).
  Notation "a [[=]] b" :=
    (@liftA2 _ (Applicative_FlowVal _) _ _ _ (@eq R) a b) (at level 70, right associativity).
  Notation "a [[<>]] b" :=
    (@liftA1 _ _ _ (Applicative_FlowVal _) not (@liftA2 _ (Applicative_FlowVal _) _ _ _ (@eq R) a b))
      (at level 70, right associativity).
  Notation "[[sqrt]] e" :=
    (@liftA1 _ _ _ (Applicative_FlowVal _) sqrt e) (at level 30, right associativity).
  Notation "## x" := (@pure _ (Applicative_FlowVal _) _ x) (at level 20, right associativity).
  Notation "c ??<= x [?] e1 [:] e2" :=
    (fun st' st => if Rle_dec (c st' st) x then e1 st' st else e2 st' st) (at level 80).
  Notation "'d[' x ']'" := (fun st' st => x st') (at level 20).
  Notation "'$[' e ']'" := (fun _ st => e st) (at level 20).

  Export ExtLib.Structures.Applicative.

  (* A barrier function maps states to scalars. *)
  Definition barrier : Type := StateVal R.
  Definition dbarrier : Type := FlowVal R.

  Definition StateProp := StateVal Prop.
  Definition FlowProp := FlowVal Prop.
  Definition TrajectoryProp := TrajectoryVal Prop.

  Definition always (P : StateProp) : TrajectoryProp :=
    fun F =>
      forall t : R, 0 <= t -> P (F t).

  Local Transparent ILInsts.ILFun_Ops.
  Lemma always_ltrue :
    |-- always ltrue.
  Proof.
    unfold always. simpl. auto.
  Qed.

  Definition start (P : StateProp) : TrajectoryProp :=
    fun F => P (F 0).

  Notation "[] P" := (always P) (at level 70).
  Notation "! P" := (start P) (at level 70).

  Definition derive_barrier_dom
             (dom : StateProp) (B : barrier) (dB : dbarrier) : Prop :=
    forall (F : trajectory) (D : R -> state),
      (forall t, continuous F t) ->
      (forall t, is_derive F t (D t)) ->
      (forall t, dom (F t) -> is_derive (fun t => B (F t)) t (dB (D t) (F t))).

  (* StateProp is an ILogic *)
  Global Instance ILogic_StateProp : ILogic StateProp := _.
  Global Instance ILogic_FlowProp : ILogic FlowProp := _.
  Global Instance ILogic_TrajectoryProp : ILogic TrajectoryProp := _.

  Definition derive_barrier := derive_barrier_dom (fun _ => True).

  (* States that F is a solution to the ODI f with initial value x0. *)
  Definition solution (f : ODI) : TrajectoryProp :=
    fun F =>
      exists (D : R -> state),
        (forall x, continuous D x) /\
        forall (t : R),
          is_derive F t (D t) /\
          (0 <= t -> f (D t) (F t)).

  Definition solution_bounded (f : ODI) (T : R) : TrajectoryProp :=
    fun F =>
      exists (D : R -> state),
        (forall x, continuous D x) /\
        forall (t : R),
          is_derive F t (D t) /\
          (0 <= t -> t <= T -> f (D t) (F t)).

  (* If a system of ODEs has a solution, then that solution is continuous. *)
  Lemma solution_continuous :
    forall f F,
      solution f F ->
      forall t, continuous F t.
  Proof.
    intros. apply ex_derive_continuous. unfold solution in *.
    unfold ex_derive. destruct H. destruct H. specialize (H0 t).
    exists (x t). tauto.
  Qed.

(*
  (* The least upper bound of a closed set is contained in the set. *)
  Lemma lub_closed_in_set :
    forall (S : R -> Prop) (m : R),
      closed S -> is_lub S m -> S m.
  Proof.
    unfold closed, open, is_lub, locally, ball. simpl.
    unfold AbsRing_ball. intros. apply NNPP. intro. specialize (H _ H1).
    destruct H.
    assert (is_upper_bound S (m - x)).
    { unfold is_upper_bound in *. intros. apply Rnot_gt_le. intro.
      destruct (Rle_dec x0 m).
      { assert (~ S x0).
        { apply H. unfold abs, minus, plus, opp. simpl.
          rewrite Rabs_left; [ psatzl R | ]. destruct r.
          { psatzl R. }
          { intuition congruence. } }
        auto. }
      { assert (x0 <= m) by (apply H0; auto). psatzl R. } }
    assert (m <= m - x).
    { apply H0; auto. }
    destruct x. simpl in *. psatzl R.
  Qed.
*)

  Definition evolve (dF : FlowProp) (I : StateProp)
      : state -> state -> Prop :=
    fun st st' =>
      exists (r : R) (F : R -> state),
        0 <= r /\ F 0 = st /\ F r = st' /\
        (forall t, 0 <= t <= r -> I (F t)) /\
        (exists (D : R -> state),
            (forall t : R, is_derive F t (D t)) /\
            forall t, 0 <= t <= r ->
                      dF (D t) (F t)).

  Definition box (a : state -> state -> Prop) (s : StateProp) : StateProp :=
    fun st => forall st', a st st' -> s st'.

  Theorem differential_induction_leq :
    forall (dF : FlowProp) (I : StateProp)
           (e1 e2 : StateVal R) (e1' e2' : FlowVal R),
      (derive_barrier e1 e1') ->
      (derive_barrier e2 e2') ->
      dF //\\ $[I] |-- (fun st' st => e1' st' st <= e2' st' st) ->
      I -->> (e1 [<=] e2)
                     |-- box (evolve dF I) (e1 [<=] e2).
  Proof.
    unfold derive_barrier, box. simpl. intros.
    destruct H3 as [ r [f [Hr [Hf0 [Hfr [HI [D [HFD1 HFD2] ] ] ] ] ] ] ].
    apply Rminus_le. assert (I (f 0)).
    { apply HI; psatzl R. }
    assert (e2 (f 0) - e1 (f 0) <= e2 (f r) - e1 (f r)).
    { destruct Hr.
      { specialize (H f D). specialize (H0 f D).
        assert (forall t : R_UniformSpace, continuous f t) as Hcont.
        { intros; apply ex_derive_continuous; eexists; eauto. }
        eapply derive_increasing_interv_var
        with (f:=fun t => e2 (f t) - e1 (f t)) (a:=0) (b:=r);
          try psatzl R. intros. assert (0 <= t0 <= r) by psatzl R.
        Unshelve.
        2: (unfold derivable; intros; apply ex_derive_Reals_0;
            eapply ex_derive_minus
            with (f0:=fun t => e2 (f t)) (g:=fun t => e1 (f t));
            eexists; [ apply H0 | apply H ]; intros; auto).
        rewrite Derive_Reals. rewrite Derive_minus; [ | eexists; eauto | eexists; eauto ].
        assert (is_derive f t0 (D t0)) as Hderivf by (apply HFD1; assumption).
        specialize (H Hcont HFD1 t0). specialize (H0 Hcont HFD1 t0).
        apply is_derive_unique in H; auto. apply is_derive_unique in H0; auto.
        simpl in *. rewrite H. rewrite H0. specialize (H1 (D t0) (f t0)).
        assert (dF (D t0) (f t0) /\ I (f t0)).
        { split; [ apply HFD2 | apply HI ]; psatzl R. }
        intuition psatzl R. }
      { subst r. psatzl R. } }
    { rewrite <- Hfr. rewrite <- Hf0 in *. intuition psatzl R. }
  Qed.

  Lemma exp_integral :
    forall (f df : R -> R) (a : R),
      (forall x, 0 <= x -> continuous df x) ->
      (forall x, is_derive f x (df x)) ->
      (forall x, 0 <= x -> df x <= a * f x) ->
      forall x, 0 <= x -> f x <= f 0 * exp (a * x).
  Proof.
    intros.
    assert (Derive (fun x : R => f x * exp (- a * x)) =
            fun x => df x*exp (-a*x) - (a*f x) * exp (-a*x))
      as HDerive.
    { apply functional_extensionality. intros.
      apply is_derive_unique. auto_derive.
      { unfold ex_derive. eauto. }
      { erewrite is_derive_unique; eauto. field. } }
    assert (forall x0,
               0 <= x0 ->
               continuous
                 (fun x1 : R =>
                    df x1*exp (-a*x1) - a*f x1 * exp (-a*x1)) x0)
      as Hcont.
    { intros. assert (continuous (fun x => exp (-a * x)) x0).
      { unfold continuous.
        rewrite <- (continuity_pt_filterlim
                      (fun x => exp (-a*x))).
        apply derivable_continuous. apply derivable_comp.
        { apply derivable_mult.
          { apply derivable_const. }
          { apply derivable_id. } }
        { apply derivable_exp. } }
      apply (continuous_minus
               (fun x => df x * exp (- a * x))
               (fun x => a * f x * exp (- a * x))).
      { apply (continuous_mult
                 (fun x => df x) (fun x => exp (-a * x))).
        { apply H. auto. }
        { auto. } }
      { apply (continuous_mult
                 (fun x => a * f x) (fun x => exp (-a * x))).
        { apply (continuous_mult (fun _ => a) f).
          { apply continuous_const. }
          { unfold continuous. apply (ex_derive_continuous f).
            unfold ex_derive. eauto. } }
        { auto. } } }
    assert (f x * exp (-a * x) - f 0 <= 0).
    { replace (f 0) with (f 0 * exp (-a * 0)).
      { rewrite <- (RInt_Derive (fun x => f x * exp (- a * x))).
        { replace 0 with (RInt (fun _ => 0) 0 x) at 2.
          { apply RInt_le; auto.
            { eexists. apply is_RInt_derive.
              { intros. apply Derive_correct. auto_derive.
                unfold ex_derive. eauto. }
              { intros. rewrite HDerive. apply Hcont.
                rewrite Rmin_left in *; psatzl R. } }
            { apply ex_RInt_const. }
            { intros. rewrite HDerive.
              apply Rle_minus. apply Rmult_le_compat_r.
              { left. apply exp_pos. }
              { apply H1. psatzl R. } } }
          { rewrite RInt_const. field. } }
        { intros. auto_derive. unfold ex_derive. eauto. }
        { intros. intros. rewrite HDerive. apply Hcont.
          rewrite Rmin_left in *; psatzl R. } }
      { rewrite Rmult_0_r. rewrite exp_0. field. } }
    { rewrite <- Ropp_mult_distr_l in H3. rewrite exp_Ropp in H3.
      apply Rminus_le in H3. apply Rle_div_l in H3.
      { assumption. }
      { apply exp_pos. } }
  Qed.

  Definition exp_inductive (f : FlowProp) (B : barrier) (dB : dbarrier) (a : R) :
    FlowProp :=
    fun (x' x : state) =>
        f x' x -> dB x' x <= a * B x.

  Theorem barrier_exp_condition :
    forall (B : barrier) (dB : dbarrier),
      derive_barrier B dB ->
      (forall t x' x,
          continuous (fun t : R => dB (x' t) (x t)) t) ->
      forall (f : ODI) (a : R) (G : TrajectoryProp) (P : StateProp),
        $[P] |-- exp_inductive f B dB a ->
        G |-- solution f ->
        G |-- !(B [<=] #0) ->
        G |-- []P ->
        G |-- [](B [<=] #0).
  Proof.
    unfold always, start. simpl. intros. rename t into F.
    specialize (H2 _ H5). specialize (H3 _ H5). specialize (H4 _ H5).
    destruct H2.
    assert (B (F t0) <= B (F 0) * exp (a * t0)).
    { apply exp_integral
      with (f:=fun t => B (F t))
             (df:=fun t => dB (x t) (F t)); auto.
      { intros. apply H; auto.
        { eapply solution_continuous. unfold solution.
          eexists. apply H2. }
        { apply H2. } }
      { intros. eapply H1; [ apply H4; auto | apply H2; assumption]. } }
    pose proof (exp_pos (a * t0)). psatz R.
  Qed.

  Definition solution_sampled_data
             (f : state -> state -> state -> Prop)
             (F : trajectory) (sample : R -> R) : Prop :=
    exists (D : R -> state),
      (forall x, continuous D x) /\
      (forall (t : R),
          is_derive F t (D t)) /\
      (forall t, 0 <= t - sample t) /\
      forall t : R, f (D t) (F t) (F (sample t)).

  (* If a sampled data system of ODEs has a solution,
     then that solution is continuous. *)
  Lemma sampled_solution_continuous :
    forall f F sample,
      solution_sampled_data f F sample ->
      forall t, continuous F t.
  Proof.
    intros. apply ex_derive_continuous.
    unfold solution_sampled_data in *.
    unfold ex_derive. destruct H. exists (x t). apply H.
  Qed.

  Definition intersample_relation_valid
             (rel : state -> state -> Prop)
             (sample : R -> R) (F : trajectory) :=
    forall t, rel (F (sample t)) (F t).

  Definition exp_condition (B : barrier) (dB : dbarrier)
             (rel : state -> state -> Prop)
             (f : state -> state -> state -> Prop)
             (lambda : R) :=
    forall (x' x xb : state),
      rel xb x -> f x' x xb -> dB x' x <= lambda * B x.

  Definition continuous_dB (G : FlowProp) (dB : dbarrier) :=
    forall (p : state * state),
      G (fst p) (snd p) ->
      continuous (fun p => dB (fst p) (snd p)) p.

(*
  Theorem barrier_exp_condition_sampled :
    forall (B : barrier) (dB : dbarrier),
      derive_barrier B dB ->
      continuous_dB ltrue dB ->
      forall (f : state -> state -> state -> Prop) (F : trajectory)
             (lambda : R) (sample : R -> R)
             (rel : state -> state -> Prop),
        solution_sampled_data f F sample ->
        intersample_relation_valid rel sample F ->
        exp_condition B dB rel f lambda ->
        trajectory_invariant F (fun st => B st <= 0).
  Proof.
    unfold trajectory_invariant, intersample_relation_valid.
    intros. pose proof H1 as Hsol.
    unfold solution_sampled_data in *. destruct H1 as [D [? ?]].
    assert (B (F t) <= B (F 0) * exp (lambda * t)).
    { apply exp_integral
      with (f:=fun t => B (F t)) (df:=fun t => dB (D t) (F t));
      auto.
      { intros. eapply continuous_comp_2 in H0.
        { apply H0. }
        { auto. }
        { eapply sampled_solution_continuous; eauto. }
        { exact I. } }
      { intros. apply H; auto. intros.
        { eapply sampled_solution_continuous; eauto. }
        { apply H6. } }
      { intros. eapply H3. 2: apply H6. apply H2. } }
    pose proof (exp_pos (lambda * t)). psatz R.
  Qed.
*)

  Definition exp_condition2 (B : barrier) (dB : dbarrier)
             (f : state -> state -> state -> Prop)
             (lambda : R) : FlowProp :=
     (fun x' x => f x' x x) -->> dB [<=] $[#lambda [*] B].

  Definition sampled_data
             (f : state -> state -> state -> Prop)
             (sample : nat -> R) : TrajectoryProp :=
    fun F =>
      exists (D : R -> state),
        (forall x, continuous D x) /\
        (forall (t : R),
            is_derive F t (D t)) /\
        forall n : nat,
          let a := sample n in
          let b := sample (S n) in
          forall t : R, a <= t < b -> f (D t) (F t) (F a).

  (* If a sampled data system of ODEs has a solution,
     then that solution is continuous. *)
  Lemma sampled_solution_continuous2 :
    forall f F sample,
      sampled_data f sample F ->
      forall t, continuous F t.
  Proof.
    intros. apply ex_derive_continuous.
    unfold solution_sampled_data in *.
    unfold ex_derive. destruct H. exists (x t). apply H.
  Qed.

  Definition well_formed_samples (sample : nat -> R) :=
    sample 0%nat = 0 /\
    (forall n : nat, sample n < sample (S n)) /\
    (forall t : R, exists n : nat, sample n <= t < sample (S n)).

  Lemma well_formed_sample_ge_0 :
    forall (sample : nat -> R),
      well_formed_samples sample ->
      forall n : nat, 0 <= sample n.
  Proof.
    unfold well_formed_samples. intros. induction n.
    { psatzl R. }
    { destruct H. destruct H0. specialize (H0 n). psatzl R. }
  Qed.

  Theorem barrier_exp_condition_sampled_weak :
    forall (B : barrier) (dB : dbarrier),
      derive_barrier B dB ->
      continuous_dB ltrue dB ->
      forall (f : state -> state -> state -> Prop)
             (sample : nat -> R) (G : TrajectoryProp) (P : StateProp)
             (lambda : R),
        G |-- sampled_data f sample ->
        (forall stk, $[P] |-- exp_inductive (fun st' st => f st' st stk) B dB lambda) ->
        well_formed_samples sample ->
        G |-- []P ->
        G |-- !(B [<=] #0) ->
        G |-- [](B [<=] #0).
  Proof.
    unfold always, start. simpl. intros. rename t into F.
    specialize (H1 _ H6). specialize (H4 _ H6). specialize (H5 _ H6).
    remember H1 as Hsol.
    assert (B (F t0) <= B (F 0) * exp (lambda * t0)).
    { destruct H1.
      apply exp_integral
      with (f:=fun t => B (F t))
             (df:=fun t => dB (x t) (F t)); auto.
      { intros. eapply continuous_comp_2; eauto.
        { apply a. }
        { eapply sampled_solution_continuous2; eauto. } }
      { intros. apply H; auto.
        { eapply sampled_solution_continuous2; eauto. }
        { apply a. } }
      { intros. unfold well_formed_samples in H3. destruct H3. destruct H8.
        specialize (H9 x0). destruct H9. eapply H2; [ apply H4; auto | apply a; eauto ]. } }
    pose proof (exp_pos (lambda * t0)). psatz R.
  Qed.

  Definition bounded_samples (sample : nat -> R) (T : R) :=
    forall n : nat, sample (S n) - sample n <= T.

  Definition intersample_relation_valid2
             (rel : state -> state -> Prop)
             (sample : nat -> R) : TrajectoryProp :=
    fun F =>
      forall n : nat,
        let a := sample n in
        let b := sample (S n) in
        forall t : R, a <= t < b -> rel (F a) (F t).

  Require Import Control.Arithmetic.
  Theorem barrier_exp_condition_sampled2 :
    forall (B : barrier) (dB : dbarrier),
      derive_barrier B dB ->
      continuous_dB ltrue dB ->
      forall (f : state -> state -> state -> Prop)
             (sample : nat -> R) (rel : state -> state -> Prop)
             (C : R) (T : R) (G : TrajectoryProp) (P : StateProp),
        G |-- sampled_data f sample ->
        G |-- intersample_relation_valid2 rel sample ->
        $[P] |-- exp_condition2 B dB f (-1/T) ->
        (forall (x' xk' x xk : state),
            rel xk x -> f x' x xk -> f xk' xk xk -> dB x' x <= dB xk' xk + C) ->
        well_formed_samples sample ->
        bounded_samples sample T ->
        forall (HC : C > 0) (HT : T > 0),
        G |-- []P ->
        G |-- !(B [<=] #(C * T)) ->
        G |-- [](B [<=] #(C * T)).
  Proof.
    unfold start, always. simpl. intros. rename t into F.
    specialize (H1 _ H9). specialize (H2 _ H9).
    specialize (H7 _ H9). specialize (H8 _ H9).
    pose proof H1 as Hsol. destruct H1 as [D [? ?]].
    assert (Derive (fun t => B (F t)) = fun t : R => dB (D t) (F t))
           as HDerive.
    { apply functional_extensionality. intros. apply is_derive_unique.
      apply H; auto.
      { eapply sampled_solution_continuous2; eauto. }
      { tauto. } }
    assert (forall x, continuous (fun t0 : R => dB (D t0) (F t0)) x).
    { intros. eapply continuous_comp_2 in H0.
      { apply H0. }
      { auto. }
      { eapply sampled_solution_continuous2; eauto. }
      { exact I. } }
    assert (forall n t,
               B (F t) = B (F (sample n)) +
                         RInt (fun t => dB (D t) (F t)) (sample n) t)
      as HRInt1.
    { intros. rewrite <- HDerive. rewrite RInt_Derive.
      { field. }
      { intros. unfold ex_derive. eexists; apply H; auto.
        { intros. eapply sampled_solution_continuous2; eauto. }
        { intros. apply H11. } }
      { intros. rewrite HDerive. auto. } }
    assert (forall n t,
               is_RInt (fun _ => (-1/T) * B (F (sample n)) + C) (sample n) t
                       ((t - sample n) * ((-1/T) * B (F (sample n)) + C))) as HRInt_val.
    { intros. apply (is_RInt_const (sample n) t ((-1/T) * B (F (sample n)) + C)). }
    assert (forall n t,
               sample n <= t < sample (S n) ->
               B (F t) <= B (F (sample n)) +
                          RInt (fun _ => (-1/T)*(B (F (sample n))) + C) (sample n) t)
      as RInt2.
    { intros. erewrite HRInt1. apply Rplus_le_compat_l.
      apply RInt_le.
      { tauto. }
      { eexists. apply is_RInt_derive.
        { intros. apply H; auto.
          { intros. eapply sampled_solution_continuous2; eauto. }
          { intros. apply H11. } }
        { auto. } }
      { unfold ex_RInt. eexists; eauto. }
      { intros. rewrite H4.
        { apply Rplus_le_compat_r. eapply H3.
          { apply H7. apply well_formed_sample_ge_0; auto. }
          { apply H11. psatzl R. } }
        { apply H2. psatzl R. }
        { apply H11. psatzl R. }
        { apply H11. psatzl R. } } }
    assert (forall n,
               B (F (sample n)) <= C*T ->
               forall t,
                 sample n <= t < sample (S n) ->
                 B (F t) <= C*T) as HCT.
    { intros ? ? ? Hsmpl. specialize (RInt2 _ _ Hsmpl).
      erewrite is_RInt_unique in RInt2; eauto.
      assert (0 <= t - sample n) by psatzl R.
      assert (t - sample n <= T).
      { unfold bounded_samples in *. specialize (H6 n).
        psatzl R. }
      rewrite RInt2.
      destruct (Rle_dec ((-1/T) * B (F (sample n)) + C) 0).
      { rewrite H13 at 1. psatz R. }
      { etransitivity.
        { apply Rplus_le_compat_l. apply Rmult_le_compat; try psatzl R; eauto.
          reflexivity. }
        { field_simplify; psatzl R. } } }
    destruct H5. destruct H13. specialize (H14 t0). destruct H14 as [n Hn].
    eapply HCT; eauto. clear Hn. induction n.
    { congruence. }
    { specialize (HCT n IHn). eapply closed_continuous with (f0:=fun t => B (F t)).
      { unfold closed. eapply open_ext. 2: apply open_gt. intros.
        simpl. instantiate (1:=C * T). psatzl R. }
      { instantiate (1:=sample n). auto. }
      { auto. }
      { apply ex_derive_continuous with (f0:=fun t => B (F t)).
        eexists. apply H; auto.
        { eapply sampled_solution_continuous2; eauto. }
        { intros. apply H11. } } }
  Qed.

  Definition exp_condition3 (B : barrier) (dB : dbarrier)
             (f : state -> state -> state -> Prop)
             (lambda : R) : FlowProp :=
     (fun x' x => f x' x x) -->> dB [<=]
                            @liftA2  _ (Applicative_FlowVal) _ _ _ Rmax ($[#lambda [*] B]) (#0).

  Require Import Control.Arithmetic.
  Theorem barrier_exp_condition_sampled3 :
    forall (B : barrier) (dB : dbarrier),
      derive_barrier B dB ->
      continuous_dB ltrue dB ->
      forall (f : state -> state -> state -> Prop)
             (sample : nat -> R) (rel : state -> state -> Prop)
             (C : R) (T : R) (G : TrajectoryProp) (P : StateProp),
        G |-- sampled_data f sample ->
        G |-- intersample_relation_valid2 rel sample ->
        $[P] |-- exp_condition2 B dB f (-1/T) ->
        (forall (x' xk' x xk : state),
            rel xk x -> f x' x xk -> f xk' xk xk -> dB x' x <= Rmax (dB xk' xk + C) 0) ->
        well_formed_samples sample ->
        bounded_samples sample T ->
        forall (HC : C > 0) (HT : T > 0),
        G |-- []P ->
        G |-- !(B [<=] #(C * T)) ->
        G |-- [](B [<=] #(C * T)).
  Proof.
    unfold start, always. simpl. intros. rename t into F.
    specialize (H1 _ H9). specialize (H2 _ H9).
    specialize (H7 _ H9). specialize (H8 _ H9).
    pose proof H1 as Hsol. destruct H1 as [D [? ?]].
    assert (Derive (fun t => B (F t)) = fun t : R => dB (D t) (F t))
           as HDerive.
    { apply functional_extensionality. intros. apply is_derive_unique.
      apply H; auto.
      { eapply sampled_solution_continuous2; eauto. }
      { tauto. } }
    assert (forall x, continuous (fun t0 : R => dB (D t0) (F t0)) x).
    { intros. eapply continuous_comp_2 in H0.
      { apply H0. }
      { auto. }
      { eapply sampled_solution_continuous2; eauto. }
      { exact I. } }
    assert (forall n t,
               B (F t) = B (F (sample n)) +
                         RInt (fun t => dB (D t) (F t)) (sample n) t)
      as HRInt1.
    { intros. rewrite <- HDerive. rewrite RInt_Derive.
      { field. }
      { intros. unfold ex_derive. eexists; apply H; auto.
        { intros. eapply sampled_solution_continuous2; eauto. }
        { intros. apply H11. } }
      { intros. rewrite HDerive. auto. } }
    assert (forall n t,
               is_RInt (fun _ => Rmax ((-1/T)*(B (F (sample n))) + C) 0) (sample n) t
                       ((t - sample n) * Rmax ((-1/T)*(B (F (sample n))) + C) 0)) as HRInt_val.
    { intros. apply (is_RInt_const (sample n) t (Rmax ((-1/T)*(B (F (sample n))) + C) 0)). }
    assert (forall n t,
               sample n <= t < sample (S n) ->
               B (F t) <= B (F (sample n)) +
                          RInt (fun _ => Rmax ((-1/T)*(B (F (sample n))) + C) 0) (sample n) t)
      as RInt2.
    { intros. erewrite HRInt1. apply Rplus_le_compat_l.
      apply RInt_le.
      { tauto. }
      { eexists. apply is_RInt_derive.
        { intros. apply H; auto.
          { intros. eapply sampled_solution_continuous2; eauto. }
          { intros. apply H11. } }
        { auto. } }
      { unfold ex_RInt. eexists; eauto. }
      { intros. rewrite H4.
        { apply Rle_max_compat_r. apply Rplus_le_compat_r. eapply H3.
          { apply H7. apply well_formed_sample_ge_0; auto. }
          { apply H11. psatzl R. } }
        { apply H2. psatzl R. }
        { apply H11. psatzl R. }
        { apply H11. psatzl R. } } }
    assert (forall n,
               B (F (sample n)) <= C*T ->
               forall t,
                 sample n <= t < sample (S n) ->
                 B (F t) <= C*T) as HCT.
    { intros ? ? ? Hsmpl. specialize (RInt2 _ _ Hsmpl).
      erewrite is_RInt_unique in RInt2; eauto.
      assert (0 <= t - sample n) by psatzl R.
      assert (t - sample n <= T).
      { unfold bounded_samples in *. specialize (H6 n).
        psatzl R. }
      rewrite RInt2. unfold Rmax. destruct (Rle_dec (-1 / T * B (F (sample n)) + C) 0).
      { psatzl R. }
      { destruct (Rle_dec ((-1/T) * B (F (sample n)) + C) 0).
        { rewrite H13 at 1. psatz R. }
        { etransitivity.
          { apply Rplus_le_compat_l. apply Rmult_le_compat; try psatzl R; eauto.
            reflexivity. }
          { field_simplify; psatzl R. } } } }
    destruct H5. destruct H13. specialize (H14 t0). destruct H14 as [n Hn].
    eapply HCT; eauto. clear Hn. induction n.
    { congruence. }
    { specialize (HCT n IHn). eapply closed_continuous with (f0:=fun t => B (F t)).
      { unfold closed. eapply open_ext. 2: apply open_gt. intros.
        simpl. instantiate (1:=C * T). psatzl R. }
      { instantiate (1:=sample n). auto. }
      { auto. }
      { apply ex_derive_continuous with (f0:=fun t => B (F t)).
        eexists. apply H; auto.
        { eapply sampled_solution_continuous2; eauto. }
        { intros. apply H11. } } }
  Qed.

End ODE.

Arguments derive_barrier [_] _ _.
Arguments derive_barrier_dom [_] _ _ _.
Arguments solution_sampled_data [_] _ _ _.
Arguments intersample_relation_valid [_] _ _ _.
Arguments exp_condition [_] _ _ _ _ _.
Arguments continuous_dB [_] _ _.
Arguments sampled_data [_] _ _ _.
Arguments intersample_relation_valid2 [_] _ _ _.
Arguments start [_] _ _.
Arguments always [_] _ _.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   T. Balabonski, P. Courtieu, L. Rieg, X. Urbain                       *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms
     T. Balabonski, P. Courtieu, L. Rieg, X. Urbain
     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence
                                                                          *)
(**************************************************************************)

Require Import Relations.
Require Import RelationPairs.
Require Import Morphisms.
Set Implicit Arguments.

Section WfLexicographic_Product.
  Variable A : Type.
  Variable B : Type.
  Variable leA : A -> A -> Prop.
  Variable leB : B -> B -> Prop.

  Inductive lexprod : A*B -> A*B -> Prop :=
  | left_lex :
      forall (x x':A) (y y':B), leA x x' -> lexprod (x, y) (x', y')
  | right_lex :
      forall (x:A) (y y':B), leB y y' -> lexprod (x, y) (x, y').

  Notation LexProd := (lexprod leA leB).

  Lemma acc_A_B_lexprod :
    forall x:A,
      Acc leA x ->
      (forall x0:A, clos_trans A leA x0 x -> well_founded leB) ->
      forall y:B, Acc leB y -> @Acc (A*B) lexprod (x, y).
  Proof.
  induction 1 as [x _ IHAcc]; intros H2 y.
  induction 1 as [x0 H IHAcc0]; intros.
  apply Acc_intro.
  destruct y as [x2 y1]; intro H6.
  simple inversion H6; intro;
  [ cut (leA x2 x); intros;
    [ apply IHAcc; auto with sets |] |].
  - intros.
    eapply H2.
    apply t_trans with x2; auto with sets.
    eassumption.
  - red in H2. eapply H2. eauto with sets.
  - injection H1. destruct 2. injection H3.
    destruct 2; auto with sets.
  - rewrite <- H1.
    injection H3; intros _ Hx1.
    subst x1.
    apply IHAcc0.
    inversion H1.
    inversion H3.
    now subst.
  Defined.

  Theorem wf_lexprod :
    well_founded leA ->
    well_founded leB -> well_founded lexprod.
  Proof.
  intros wfA wfB; unfold well_founded.
  destruct a.
  apply acc_A_B_lexprod; auto with sets; intros.
  Defined.
End WfLexicographic_Product.

Global Arguments lexprod  [A] [B] leA leB _ _.

Instance lexprod_compat: Proper (eq * eq ==> eq * eq ==> iff) (lexprod lt lt).
Proof using .
intros (a, b) (a', b') (heqa, heqb) (c, d) (c', d') (heqc, heqd).
hnf in *|-. simpl in *|-. now subst.
Qed.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)

From mathcomp Require Import all_ssreflect.
Require Import Relations.
From CompDecModal.libs Require Import edone bcase.

Set Default Proof Using "Type".

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Generic Lemmas not in Ssreflect

This file contains a number of generic lemmas that might by added to the
Ssreflect libraries *)

Lemma forall_inPn (T : finType) (p q : pred T) :
  reflect (exists2 x, p x & ~~ q x) (~~ [forall (x | p x), q x]).
Proof.
  rewrite negb_forall (eq_existsb (P2 := fun x => p x && ~~ q x)) => [|x].
  exact: exists_inP. exact: negb_imply.
Qed.

(** Boolean Logic *)

Definition curry aT1 aT2 rT (f : aT1 * aT2 -> rT) a b := f (a,b).
Lemma curryE aT1 aT2 rT (f : aT1 * aT2 -> rT) a b : f (a,b) = curry f a b. done. Qed.

Lemma eqF (T : eqType) (a b : T) : a <> b -> (a == b) = false.
Proof. move => H. apply/negbTE. apply/negP => /eqP. done. Qed.

Lemma classic_orb a b : a || b = a || ~~ a && b.
Proof. bcase. Qed.

Lemma contraN (b : bool) (P : Prop) : b -> ~~ b -> P.
Proof. by case b. Qed.

Lemma contraP (b : bool) (P : Prop) : ~~ b -> b -> P.
Proof. by case b. Qed.

(** Strong eliminations for [orb] and [has] *)

Lemma orS b1 b2 : ( b1 || b2 ) -> {b1} + {b2}.
Proof. case: b1 b2 => [|] [|] //= _; first [by left| by right]. Qed.

Lemma hasS (T : eqType) (p : pred T) s : has p s -> {a : T | a \in s & p a}.
Proof.
  case: s => // b s H. pose a := (nth b (b :: s) (find p (b :: s))).
  exists a ; by rewrite ?mem_nth -?has_find ?nth_find.
Qed.

(** Sequences *)

Lemma forall_nil (T : eqType) (P : T -> Prop) :
  (forall x, x \in nil -> P x) <-> True.
Proof. intuition. by rewrite in_nil in H0. Qed.

Lemma forall_cons (T : eqType) (P : T -> Prop) a s :
  (forall x, x \in a :: s -> P x) <-> P a /\ (forall x, x \in s -> P x).
Proof.
  firstorder using mem_head. by apply H; rewrite in_cons H0.
  rewrite in_cons in H0. case/predU1P : H0 => [->//|]. exact: H1.
Qed.

Lemma sub_behead (T : eqType) x (xs ys : seq T) :
  {subset x :: xs <= ys} -> {subset xs <= ys}.
Proof. move => sub a H. apply: sub. by rewrite inE H orbT. Qed.

Lemma sumn_bound n (s : seq nat) :
  (forall x, x \in s -> x <= n) -> sumn s <= n * size s.
Proof.
  elim: s => //= m s IHs H. rewrite mulnS leq_add ?H ?IHs ? mem_head //.
  move => x Hx. by rewrite H //= in_cons Hx.
Qed.

Lemma nilp_map aT rT (f : aT -> rT) s : nilp (map f s) = nilp s.
Proof. by case: s. Qed.

Lemma in_sub_has (T:eqType) (a1 a2 : pred T) s :
  {in s, subpred a1 a2} -> has a1 s -> has a2 s.
Proof. move => H /hasP [x ins Ha]. apply/hasP. exists x => //. exact: H. Qed.

Lemma in_sub_all (T : eqType) (a1 a2 : pred T) (s : seq T) :
   {in s, subpred a1 a2} -> all a1 s -> all a2 s.
Proof. move => sub /allP H. apply/allP => x in_s. by firstorder. Qed.

Lemma sub_all_dom (T : eqType) (s1 s2 : seq T) (p : pred T) :
  {subset s1 <= s2} -> all p s2 -> all p s1.
Proof. move => sub /allP H. apply/allP => x /sub. exact: H. Qed.

Lemma sub_has_dom (T : eqType) (s1 s2 : seq T) (p : pred T) :
  {subset s2 <= s1} -> has p s2 -> has p s1.
Proof. move => H /hasP [x /H Hx] ?. by apply/hasP; exists x. Qed.

Lemma all_inP (T : eqType) (s : seq T) p q :
  reflect {in s, subpred p q} (all (fun x => p x ==> q x) s).
Proof. by apply: (iffP allP) => H x /H /implyP. Qed.

Lemma filter_subset (T: eqType) p (s : seq T) : {subset filter p s <= s}.
Proof. apply: mem_subseq. exact: filter_subseq. Qed.

Definition del (T: eqType) (x:T) := filter [pred a | a != x].

Lemma size_del (T: eqType) (x:T) s : x \in s -> size (del x s) < size s.
Proof.
  move => in_s. rewrite size_filter -(count_predC [pred a | a != x]).
  rewrite -{1}[count _ s]addn0 ltn_add2l -has_count.
  apply/hasP. exists x => //. by rewrite inE /= eqxx.
Qed.

Lemma flattenP (T : eqType) (ss : (seq (seq T))) a :
  reflect (exists2 s, s \in ss & a \in s) (a \in flatten ss).
Proof.
  elim: ss => //= [|s0 ss IHss]. rewrite in_nil. constructor => [[s]]. by rewrite in_nil.
  rewrite mem_cat. apply: (iffP orP) => [[H|/IHss [s in_ss in_s]]|[s]].
  - exists s0; by rewrite ?mem_head.
  - exists s => //. by rewrite in_cons in_ss.
  - rewrite in_cons. case/orP => [/eqP->|*]; auto. right. apply/IHss. by eexists.
Qed.

(**  Injectivity of bitmasking. Required for the size of the powerset. *)
Lemma mask_inj (T : eqType) (m1 m2 : bitseq) (s : seq T) :
  uniq s -> size m1 == size s -> size m2 == size s -> mask m1 s =i mask m2 s -> m1 == m2.
Proof.
  elim: s m1 m2 => [m1 m2|a s IHs [|b1 m1] [|b2 m2] // U S1 S2 E].
  - by rewrite /= !size_eq0 => _ /eqP-> /eqP->.
  - rewrite /= in U. move: U => /andP[U1 U2].
    have mask_s : a \in mask _ s = false.
      move => b. apply: contraNF U1. exact: mem_mask.
    move: (E a). rewrite !mem_mask_cons !eqxx !andbT !mask_s !orbF => b12.
    rewrite eqseq_cons b12 eqxx IHs // => b.
    move: (E b). rewrite !mem_mask_cons.
    case: (boolP (b == a)) => [/eqP->|_]; by rewrite ?mask_s // ?andbF.
Qed.

Arguments SeqSub [T s].

(** ** A least- and greatest fixpoints for finite types *)

Lemma iter_fix T (F : T -> T) x k n :
  iter k F x = iter k.+1 F x -> k <= n -> iter n F x = iter n.+1 F x.
Proof.
  move => e. elim: n. rewrite leqn0. by move/eqP<-.
  move => n IH. rewrite leq_eqVlt; case/orP; first by move/eqP<-.
  move/IH => /= IHe. by rewrite -!IHe.
Qed.

Section LeastFixPoint.
  Variable T : finType.
  Definition set_op := {set T} -> {set T}.
  Definition mono (F : set_op)  := forall p q : {set T} , p \subset q -> F p \subset F q.

  Variable F : {set T} -> {set T}.
  Hypothesis monoF : mono F.

  Definition lfp := iter #|T| F set0.

  Lemma lfp_ind (P : {set T} -> Type) : P set0 -> (forall s , P s -> P (F s)) -> P lfp.
  Proof.
    move => P0 Pn. rewrite /lfp. set n := #|T|. elim: n => //= n. exact: Pn.
  Qed.

  Lemma iterFsub n : iter n F set0 \subset iter n.+1 F set0.
  Proof using monoF.
    elim: n => //=; first by rewrite sub0set.
    move => n IH /=. by apply: monoF.
  Qed.

  Lemma iterFsubn m n : m <= n -> iter m F set0 \subset iter n F set0.
  Proof using monoF.
    elim : n; first by rewrite leqn0 ; move/eqP->.
    move => n IH. rewrite leq_eqVlt; case/orP; first by move/eqP<-.
    move/IH => /= IHe. apply: subset_trans IHe _. exact:iterFsub.
  Qed.

  Lemma lfpE : lfp = F lfp.
  Proof using monoF.
    suff: exists k : 'I_#|T|.+1 , iter k F set0 == iter k.+1 F set0.
      case => k /eqP E. apply: iter_fix E _. exact: leq_ord.
    apply/existsP. rewrite -[[exists _,_]]negbK negb_exists.
    apply/negP => /forallP => H.
    have/(_ #|T|.+1 (leqnn _)): forall k , k <= #|T|.+1 -> k <= #|iter k F set0|.
      elim => // n IHn Hn.
      apply: leq_ltn_trans (IHn (ltnW Hn)) _. apply: proper_card.
      rewrite properEneq iterFsub andbT. exact: (H (Ordinal Hn)).
    apply/negP. rewrite leqNgt negbK. by rewrite ltnS max_card.
  Qed.

End LeastFixPoint.

Section GreatestFixPoint.
  Variable (T : finType) (F : {set T} -> {set T}).
  Hypothesis F_mono : mono F.

  Let F' A := ~: F (~: A).

  Lemma mono_F' : mono F'.
  Proof using F_mono.
    move =>  A B.
    rewrite /F' -setCS [~: F _ \subset _]setCS. exact: F_mono.
  Qed.

  Definition gfp := ~: lfp F'.

  Lemma gfpE : gfp = F gfp.
  Proof using F_mono. by rewrite /gfp {1}(lfpE mono_F') setCK. Qed.

  Lemma gfp_ind (P : {set T} -> Type) :
    P setT -> (forall s , P s -> P (F s)) -> P gfp.
  Proof.
    move => H1 H2. rewrite /gfp /F'.
    apply lfp_ind => [|A]; rewrite ?setC0 ?setCK //. exact: H2.
  Qed.

  Lemma gfp_ind2 (P : T -> Type) :
    (forall x (X : {set T}), (forall y, P y -> y \in X) -> P x -> x \in F X) ->
    forall x, P x -> x \in gfp.
  Proof. move => H. apply gfp_ind => [x|*]; first by rewrite inE. exact: H. Qed.

End GreatestFixPoint.

(** ** Cyclic directed distance *)

Lemma ex_dist i j n : (0 < n) -> exists d, (d < n) && (j == i + d %[mod n]).
Proof.
  move => n0. case: (leqP i j) => H.
  - exists ((j - i) %% n). by rewrite ltn_mod n0 /= modnDmr  (subnKC H).
  - exists ((n - i %% n + j %% n) %% n). rewrite ltn_mod n0 /= modnDmr.
    rewrite -(eqn_modDr (i %% n)). set i' := i %% n. set j' := j %% n.
    rewrite -!addnA [j' + _]addnC. rewrite [n - _ +_]addnA subnK.
    by rewrite addnC modnDml eqn_modDl modnDmr modnDl.
    by rewrite ltnW // ltn_mod n0.
Qed.

Lemma unique_dist i j n d d' :
  d < n -> d' < n -> (j = i + d %[mod n]) -> (j = i + d' %[mod n]) -> d = d'.
Proof. move => Hd Hd' -> /eqP. by rewrite eqn_modDl !modn_small // => /eqP. Qed.

Section Dist.
  Variables (T : finType) (Tgt0 : 0 < #|{:T}|).

  Definition dist (s t : T) := xchoose (ex_dist (enum_rank s) (enum_rank t) Tgt0).

  Lemma distP s t : enum_rank t = enum_rank s + dist s t %[mod #|{:T}|].
  Proof.
    apply/eqP.
    by case/andP: (xchooseP (ex_dist (enum_rank s) (enum_rank t) Tgt0)).
  Qed.

  Lemma dist_ltn s t : dist s t < #|{:T}|.
  Proof. by case/andP: (xchooseP (ex_dist (enum_rank s) (enum_rank t) Tgt0)). Qed.

  Lemma dist0 (s t : T) : dist s t = 0 -> s = t.
  Proof.
    move => D0. move : (distP s t). rewrite D0 addn0.
    rewrite !modn_small ?ltn_ord //. move/ord_inj. move/enum_rank_inj.
    by symmetry.
  Qed.

  Lemma next_subproof (s : T) : (enum_rank s).+1 %% #|{: T}| < #|{: T}|.
  Proof. rewrite ltn_mod. apply/card_gt0P. by exists s. Qed.

  Definition next (s : T) := enum_val (Ordinal (next_subproof s)).

  Lemma distS (s t : T) n : dist s t = n.+1 -> dist (next s) t = n.
  Proof.
    move => Dn. move: (distP s t) => H.
    rewrite Dn -addn1 [_ + 1]addnC addnA addn1 -modnDml in H.
    move: (distP (next s) t) => Dn'. rewrite {1}/next enum_valK /= in Dn'.
    apply: unique_dist Dn' H; last rewrite -Dn ltnW //; exact: dist_ltn.
  Qed.
End Dist.

(** Finite Choice Principles *)

Lemma fin_choice_aux (T : choiceType) T' (d : T') (R : T -> T' -> Prop) (xs : seq T) :
  (forall x, x \in xs -> exists y, R x y) -> exists f , forall x, x \in xs -> R x (f x).
Proof.
  elim: xs. move => _. exists (fun _ => d) => ?. by rewrite in_nil.
  move => x s IH step.
  have/IH: forall x : T, x \in s -> exists y, R x y.
    move => z ins. apply: step. by rewrite in_cons ins orbT.
  case => f Hf. (case: (step x); first by rewrite mem_head) => y Rxy.
  exists (fun z => if z == x then y else f z) => z.
  rewrite in_cons; case/orP. move/eqP=>e. by rewrite -e ?eq_refl in Rxy *.
  case e: (z == x); first by rewrite (eqP e). exact: Hf.
Qed.

Lemma cardSmC (X : finType) m : (#|X|= m.+1) -> X.
Proof. rewrite cardE. case e: (enum X) => [|x s] //=. Qed.

Lemma fin_choice (X : finType) Y (R : X -> Y -> Prop) :
  (forall x : X , exists y , R x y) -> exists f, forall x , R x (f x).
Proof.
  case n : (#|X|) => [|m].
  - have F : X -> False. move => x. move : (max_card (pred1 x)). by rewrite card1 n.
    exists (fun x => match F x with end) => x. done.
  - move => step.
    have H : forall x, x \in enum X -> exists y, R x y. by move => *.
    case (step (cardSmC n)) => d.
    move/(fin_choice_aux d) : H => [f Hf].
    exists f => x. apply: Hf. by rewrite mem_enum.
Qed.

Lemma fin_choices (T : finType) (P : T -> Prop) (Pdec : forall x, P x \/ ~ P x) :
  exists A : {set T}, forall x, x \in A <-> P x.
Proof.
  pose R x (b :bool) := b <-> P x.
  have/fin_choice [f Hf]: forall x, exists b, R x b.
    move => x. case (Pdec x); [by exists true|by exists false].
  exists (finset f) => x. rewrite inE. exact: Hf.
Qed.

(** Some tactic notations for boolean logical connectives *)
Ltac rightb := apply/orP; right.
Ltac leftb := apply/orP; left.
Ltac existsb s := apply/hasP; exists s.

(** Types of some Axioms *)
Definition XM := forall P : Prop, P \/ ~ P.


Require Import Coq.Numbers.NatInt.NZAddOrder.
Set Default Proof Using "All".
Require Export flows ccm multiset_flows keyset_ra.

(** Flow interface cameras and auxiliary lemmas for inset flows
  (used in the give-up template proof). *)

Section inset_flows.

Context `{Countable K}.

Definition KS := @KS K _ _.

(** Keysets of flow interfaces *)

Definition keyset (I : multiset_flowint_ur K) n := dom_ms (inf I n) ∖ dom_ms (out I n).

Lemma keyset_def : ∀ k I_n n, k ∈ inset K I_n n → ¬ in_outsets K k I_n
  → k ∈ keyset I_n n.
Proof.
  intros ? ? ? k_in_inset k_not_in_outsets.
  unfold keyset.
  unfold inset in k_in_inset.
  unfold in_outsets in k_not_in_outsets.
  rewrite elem_of_difference.
  naive_solver.
Qed.

(* The global invariant ϕ. *)
Definition globalinv root I :=
  ✓I
  ∧ (root ∈ domm I)
  ∧ closed K I
  ∧ (∀ k, k ∈ KS → k ∈ inset K I root).

(** Assorted lemmas about inset flows used in the template proofs *)

Lemma globalinv_root_fp: ∀ I root, globalinv root I → root ∈ domm I.
Proof.
  intros I root Hglob. unfold globalinv in Hglob.
  destruct Hglob as [H1 [H2 H3]]. done.
Qed.

Lemma contextualLeq_impl_globalinv : ∀ I I' root,
    globalinv root I →
    contextualLeq K_multiset I I' →
    (∀ n, n ∈ domm I' ∖ domm I → inset K I' n = ∅) →
    globalinv root I'.
Proof.
  intros ? ? ? GI CLeq InfI'.
  unfold contextualLeq in CLeq.
  unfold globalinv in GI.
  destruct GI as (_ & DomR & OutI & InfI).
  destruct CLeq as (VI & VI' & DS & InfR & OutR).
  unfold closed in OutI.
  unfold globalinv, closed.
  repeat split.
  - trivial.
  - set_solver.
  - intros.
    destruct (decide (n ∈ domm I')).
    * apply flowint_valid_unfold in VI'.
      destruct VI' as [Ir' (I'_def & I'_disj & _)].
      rewrite (@map_disjoint_dom Node (gmap Node) (gset Node)) in I'_disj *.
      intros.
      assert (out_map I' ! n = 0%CCM).
      { unfold out_map. rewrite I'_def.
        assert (¬ (n ∈ dom (gset Node) (out_map I'))).
        { unfold domm, dom, flowint_dom in e.
          set_solver.
        }
        rewrite I'_def in H1.
        rewrite nzmap_elem_of_dom_total in H1 *.
        intros.
        apply dec_stable in H1.
        unfold out_map in H1.
        by rewrite H1.
      }
      unfold outset, multiset_flows.dom_ms, nzmap_dom, out.
      rewrite H1. simpl.
      rewrite dom_empty.
      apply not_elem_of_empty.
    * assert (n ∉ domm I) by set_solver.
      pose proof (OutR n n0).
      unfold outset, multiset_flows.K_multiset, multiset_flows.K_multiset_ccm.
      unfold K_multiset, K_multiset_ccm in H1. rewrite <- H1.
      pose proof (OutI k n).
      unfold outset in H2.
      trivial.
  - intros.
    (*destruct H2 as (H2 & _).*)
    specialize (InfI k).
    (*rewrite <- H0 in DomR.*)
    specialize (InfR root DomR).
    unfold inset.
    unfold inset in InfR.
    rewrite <- InfR.
    apply InfI in H0.
    trivial.
Qed.

Lemma globalinv_root_ins : ∀ I Ir root k,
    globalinv root I ∧ Ir ≼ I ∧ domm Ir = {[root]} ∧ k ∈ KS
    → k ∈ inset K Ir root.
Proof.
  intros I Ir root k ((Hv & _ & _ & Hl) & [I2 Hincl] & Hdom & kKS).
  specialize (Hl k kKS).
  apply (inset_monotone I Ir I2 k root); try done.
  set_solver.
Qed.

End inset_flows.

Arguments keyset _ {_ _} _ _ : assert.
Arguments globalinv _ {_ _} _ _ : assert.


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

Require Import ZArith Znumtheory.

Open Scope Z_scope.

(** * ZSig *)

(** Interface of a rich structure about integers.
    Specifications are written via translation to Z.
*)

Module Type ZType.

 Parameter t : Type.

 Parameter to_Z : t -> Z.
 Local Notation "[ x ]" := (to_Z x).

 Definition eq x y := [x] = [y].
 Definition lt x y := [x] < [y].
 Definition le x y := [x] <= [y].

 Parameter of_Z : Z -> t.
 Parameter spec_of_Z: forall x, to_Z (of_Z x) = x.

 Parameter compare : t -> t -> comparison.
 Parameter eq_bool : t -> t -> bool.
 Parameter min : t -> t -> t.
 Parameter max : t -> t -> t.
 Parameter zero : t.
 Parameter one : t.
 Parameter two : t.
 Parameter minus_one : t.
 Parameter succ : t -> t.
 Parameter add  : t -> t -> t.
 Parameter pred : t -> t.
 Parameter sub : t -> t -> t.
 Parameter opp : t -> t.
 Parameter mul : t -> t -> t.
 Parameter square : t -> t.
 Parameter pow_pos : t -> positive -> t.
 Parameter pow_N : t -> N -> t.
 Parameter pow : t -> t -> t.
 Parameter sqrt : t -> t.
 Parameter log2 : t -> t.
 Parameter div_eucl : t -> t -> t * t.
 Parameter div : t -> t -> t.
 Parameter modulo : t -> t -> t.
 Parameter quot : t -> t -> t.
 Parameter rem : t -> t -> t.
 Parameter gcd : t -> t -> t.
 Parameter sgn : t -> t.
 Parameter abs : t -> t.
 Parameter even : t -> bool.
 Parameter odd : t -> bool.
 Parameter testbit : t -> t -> bool.
 Parameter shiftr : t -> t -> t.
 Parameter shiftl : t -> t -> t.
 Parameter land : t -> t -> t.
 Parameter lor : t -> t -> t.
 Parameter ldiff : t -> t -> t.
 Parameter lxor : t -> t -> t.
 Parameter div2 : t -> t.

 Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y].
 Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y].
 Parameter spec_min : forall x y, [min x y] = Zmin [x] [y].
 Parameter spec_max : forall x y, [max x y] = Zmax [x] [y].
 Parameter spec_0: [zero] = 0.
 Parameter spec_1: [one] = 1.
 Parameter spec_2: [two] = 2.
 Parameter spec_m1: [minus_one] = -1.
 Parameter spec_succ: forall n, [succ n] = [n] + 1.
 Parameter spec_add: forall x y, [add x y] = [x] + [y].
 Parameter spec_pred: forall x, [pred x] = [x] - 1.
 Parameter spec_sub: forall x y, [sub x y] = [x] - [y].
 Parameter spec_opp: forall x, [opp x] = - [x].
 Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
 Parameter spec_square: forall x, [square x] = [x] *  [x].
 Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n.
 Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z_of_N n.
 Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n].
 Parameter spec_sqrt: forall x, [sqrt x] = Zsqrt [x].
 Parameter spec_log2: forall x, [log2 x] = Zlog2 [x].
 Parameter spec_div_eucl: forall x y,
   let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
 Parameter spec_div: forall x y, [div x y] = [x] / [y].
 Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y].
 Parameter spec_quot: forall x y, [quot x y] = [x] ÷ [y].
 Parameter spec_rem: forall x y, [rem x y] = Zrem [x] [y].
 Parameter spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].
 Parameter spec_sgn : forall x, [sgn x] = Zsgn [x].
 Parameter spec_abs : forall x, [abs x] = Zabs [x].
 Parameter spec_even : forall x, even x = Zeven_bool [x].
 Parameter spec_odd : forall x, odd x = Zodd_bool [x].
 Parameter spec_testbit: forall x p, testbit x p = Ztestbit [x] [p].
 Parameter spec_shiftr: forall x p, [shiftr x p] = Zshiftr [x] [p].
 Parameter spec_shiftl: forall x p, [shiftl x p] = Zshiftl [x] [p].
 Parameter spec_land: forall x y, [land x y] = Zand [x] [y].
 Parameter spec_lor: forall x y, [lor x y] = Zor [x] [y].
 Parameter spec_ldiff: forall x y, [ldiff x y] = Zdiff [x] [y].
 Parameter spec_lxor: forall x y, [lxor x y] = Zxor [x] [y].
 Parameter spec_div2: forall x, [div2 x] = Zdiv2 [x].

End ZType.

Module Type ZType_Notation (Import Z:ZType).
 Notation "[ x ]" := (to_Z x).
 Infix "=="  := eq (at level 70).
 Notation "0" := zero.
 Notation "1" := one.
 Notation "2" := two.
 Infix "+" := add.
 Infix "-" := sub.
 Infix "*" := mul.
 Infix "^" := pow.
 Notation "- x" := (opp x).
 Infix "<=" := le.
 Infix "<" := lt.
End ZType_Notation.

Module Type ZType' := ZType <+ ZType_Notation.