(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* A Coq computable reduction from n-registers MM termination
    to 2-registers MMA termination. Beware that the semantics
    of MMA is a bit different than the semantics of MM:

       the DEC instruction jumps when not zero instead of when zero

    Compare mm_sss  (ILL/Mm/mm_defs.v)
    and     mma_sss (MM/mma_defs.v)

    The reduction goes via regular FRACTRAN termination *)

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.Shared.Libs.DLW Require Import Utils.utils Vec.pos Vec.vec.
From Undecidability.Shared.Libs.DLW.Code Require Import sss.

From Undecidability.MinskyMachines Require Import MM FRACTRAN_to_MMA2.
From Undecidability.FRACTRAN Require Import FRACTRAN MM_FRACTRAN.

Set Implicit Arguments.

Corollary MM_MMA2_HALTING : MM_HALTING ⪯ MMA2_HALTING.
Proof.
  eapply reduces_transitive. exact MM_FRACTRAN_REG_HALTING.
  exact FRACTRAN_REG_MMA2_HALTING.
Qed.

Check MM_MMA2_HALTING.

From Undecidability.MinskyMachines Require Import mm_defs mma_defs fractran_mma.
From Undecidability.FRACTRAN Require Import fractran_utils prime_seq mm_fractran.

(* This is somewhat for direct proof that does not involve
    testing for (0,_) in the intermediate Fractran program *)

Local Notation "P /MM/ s ↓" := (sss_terminates (@mm_sss _) P s) (at level 70, no associativity).
Local Notation "P /MMA/ s ↓" := (sss_terminates (@mma_sss 2) P s) (at level 70, no associativity).

Theorem mm_mma2 n (P : list (mm_instr (pos n))) :
               {   Q : list (mm_instr (pos 2))
               & { f : vec nat n -> vec nat 2
                 | forall v, (1,P) /MM/ (1,v) ↓ <-> (1,Q) /MMA/ (1,f v) ↓ } }.
Proof.
  destruct (mm_fractran_not_zero P) as (l & H1 & H2).
  exists (fractran_mma l), (fun v => ps 1 * exp 1 v ## 0 ## vec_nil).
  intros v; rewrite H2.
  apply fractran_mma_reduction; trivial.
  revert H1; apply Forall_impl; tauto.
Qed.


Require Import init.

(*Require Import tensor_algebra_traditional_universal.*)
Require Import tensor_algebra_direct_universal.

Require Export algebra_category.
Require Import category_initterm.

Section TensorAlgebraBase.

Context {F : CRingObj} (V : ModuleObj F).
Let U := cring_U F.

Definition to_tensor_algebra := ex_val (tensor_algebra_ex V).
Definition tensor_algebra := (to_algebra_algebra V) to_tensor_algebra.
Definition tensor_algebra_ex := ex_proof (tensor_algebra_ex V).
Definition vector_to_tensor_homo := (to_algebra_homo V) to_tensor_algebra.
Definition vector_to_tensor := module_homo_f vector_to_tensor_homo.

Theorem tensor_algebra_universal : @initial (TO_ALGEBRA V) to_tensor_algebra.
Proof.
    apply tensor_algebra_ex.
Qed.

Theorem vector_to_tensor_plus : ∀ u v : module_V V, vector_to_tensor (u + v) =
    vector_to_tensor u + vector_to_tensor v.
Proof.
    apply module_homo_plus.
Qed.
Theorem vector_to_tensor_scalar : ∀ a (v : module_V V), vector_to_tensor (a · v)
    = a · vector_to_tensor v.
Proof.
    apply module_homo_scalar.
Qed.
Theorem vector_to_tensor_zero : vector_to_tensor (zero (U := module_V V)) = 0.
Proof.
    apply module_homo_zero.
Qed.

Definition scalar_to_tensor (a : U) : algebra_V tensor_algebra := a · 1.

Theorem scalar_to_tensor_plus : ∀ a b,
    scalar_to_tensor (a + b) = scalar_to_tensor a + scalar_to_tensor b.
Proof.
    intros a b.
    unfold scalar_to_tensor.
    apply scalar_rdist.
Qed.

Theorem scalar_to_tensor_zero : scalar_to_tensor 0 = 0.
Proof.
    unfold scalar_to_tensor.
    apply scalar_lanni.
Qed.

Theorem scalar_to_tensor_mult : ∀ a b,
    scalar_to_tensor (a * b) = scalar_to_tensor a * scalar_to_tensor b.
Proof.
    intros a b.
    unfold scalar_to_tensor.
    rewrite scalar_lmult, scalar_rmult.
    rewrite scalar_comp, mult_lid.
    reflexivity.
Qed.

Theorem scalar_to_tensor_scalar : ∀ a A, scalar_to_tensor a * A = a · A.
Proof.
    intros a A.
    unfold scalar_to_tensor.
    rewrite scalar_lmult.
    rewrite mult_lid.
    reflexivity.
Qed.

Theorem scalar_to_tensor_one : scalar_to_tensor 1 = 1.
Proof.
    unfold scalar_to_tensor.
    apply scalar_id.
Qed.

Theorem scalar_to_tensor_comm : ∀ a A,
    scalar_to_tensor a * A = A * scalar_to_tensor a.
Proof.
    intros a A.
    unfold scalar_to_tensor.
    rewrite scalar_lmult, scalar_rmult.
    rewrite mult_lid, mult_rid.
    reflexivity.
Qed.

End TensorAlgebraBase.

Arguments vector_to_tensor {F V}.


(* Model of the compare-and-swap concurrent approximate counter using
the "lazy" synchronization scheme *)

From discprob.basic Require Import base sval order monad bigop_ext nify.
Require Import Reals Psatz Omega.

Require ClassicalEpsilon.
Global Set Bullet Behavior "Strict Subproofs".
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype finset finfun bigop.

Local Open Scope R_scope.
From discprob.prob Require Import prob countable finite stochastic_order.
Import List.
From discprob.idxval Require Import pival_dist.

Module counter.

  Require discprob.monad.counter.

  (*
  Definition flipn (n: nat) : pidist bool :=
    pidist_plus (1/2^n) (counter.range_half_pow n) (mret true) (mret false).
   *)

  Definition incr_flipn (n: nat) : pidist nat :=
    pidist_plus (1/2^n) (counter.range_half_pow n) (mret (S O)) (mret O).

  Fixpoint upto (n: nat) : pidist nat :=
    match n with
    | O => mret O
    | S n' => pidist_union (mret (S n')) (upto n')
    end.

  Fixpoint rep_upto_while {A B: Type} (f: A → B → A) (P: A → bool) (n: nat)
           (comp: pidist B) (init: A) :=
    match n with
    | 0 => mret init
    | S n' =>
      if P init then
        pidist_union (mret init)
                     (b ← comp;
                      rep_upto_while f P n' comp (f init b))
      else
        mret init
    end.

  Definition rep_upto {A B: Type} (f: A → B → A) (n: nat) (comp: pidist B) (init: A) :=
    rep_upto_while f (λ x, true) n comp init.

  Definition rep_upto_count {A B: Type} (f: A → B → A) (n: nat) (comp: pidist B) (init: A) :=
    rep_upto (λ an b, (f (fst an) b, S (snd an))) n comp (init, O).

  Definition rep_upto_while_count {A B: Type} (f: A → B → A) P (n: nat) (comp: pidist B) (init: A) :=
    rep_upto_while (λ an b, (f (fst an) b, S (snd an))) (λ x, P (fst x)) n comp (init, O).

  Fixpoint rep_while {A B: Type} (f: A → B → A) (P: A → bool) (n: nat)
           (comp: pidist B) (init: A) :=
    match n with
    | 0 => mret init
    | S n' =>
      if P init then
                     (b ← comp;
                      rep_while f P n' comp (f init b))
      else
        mret init
    end.

  Definition rep {A B: Type} (f: A → B → A) (n: nat) (comp: pidist B) (init: A) :=
    rep_while f (λ x, true) n comp init.

  Definition rep_count {A B: Type} (f: A → B → A) (n: nat) (comp: pidist B) (init: A) :=
    rep (λ an b, (f (fst an) b, S (snd an))) n comp (init, O).

  Definition rep_while_count {A B: Type} (f: A → B → A) P (n: nat) (comp: pidist B) (init: A) :=
    rep_while (λ an b, (f (fst an) b, S (snd an))) (λ x, P (fst x)) n comp (init, O).

  Definition approx_estimate (n: nat) : R :=
    2^n - 1.

  Fixpoint approx (pt: nat) (n: nat) (k: nat) {struct n} : pidist R :=
    match n with
    | 0 => mret (approx_estimate k)
    | S n => i0 ← incr_flipn k;
             '(itotal, c) ← rep_upto_while_count (λ isum i, isum + i)%nat
                                                 (λ isum, (isum <= pt)%nat)
                                                 n
                                                 (incr_flipn k)
                                                 i0;
               approx pt (n - c) (k + min 1 itotal)
    end.

  Fixpoint approx_worst (pt: nat) (n: nat) (k: nat) {struct n} : pidist R :=
    match n with
    | 0 => mret (approx_estimate k)
    | S n => i0 ← incr_flipn k;
             '(itotal, c) ← rep_while_count (λ isum i, isum + i)%nat
                                                 (λ isum, (isum <= pt)%nat)
                                                 n
                                                 (incr_flipn k)
                                                 i0;
               approx_worst pt (n - c) (k + min 1 itotal)
    end.

  Lemma rep_upto_while_impl {A B} (f: A → B → A) g1 g2 k m a:
    (∀ a, g1 a ==> g2 a) →
    le_pidist (rep_upto_while f g1 k m a) (rep_upto_while f g2 k m a).
  Proof.
    intros Himpl.
    revert a.
    induction k => //= a.
    - reflexivity.
    - specialize (Himpl a). destruct (g1 a).
      * rewrite //= in Himpl. rewrite Himpl.
        apply pidist_union_mono; first reflexivity.
        apply pidist_bind_congr_le; first reflexivity.
        eauto.
      * destruct (g2 a); last by reflexivity.
        apply pidist_union_le; reflexivity.
  Qed.

  Lemma approx_pt_S_le_pidist pt n k:
    le_pidist (approx pt n k) (approx pt.+1 n k).
  Proof.
    revert pt k.
    induction n as [n IH] using lt_wf_ind => pt k.
    destruct n as [| n].
    - rewrite //=. reflexivity.
    - rewrite //=. apply pidist_bind_congr_le; first reflexivity.
      intros i0.
      destruct n.
      * rewrite //=. reflexivity.
      * rewrite /rep_upto_while_count. rewrite //=.
        destruct (le_dec i0 (pt)).
        ** assert (i0 <= pt)%nat as ->.
           { auto with *. nify. done. }
           assert (i0 <= (S pt))%nat as ->.
           { auto with *. nify. omega. }
           eapply pidist_bind_congr_le.
           { apply pidist_union_mono; first reflexivity.
             apply pidist_bind_congr_le; first reflexivity.
             intros.
             apply rep_upto_while_impl. intros => //=.
             apply /implyP. intros. nify. omega.
           }
           intros (itotal&c). eapply IH. nify. omega.
        ** assert (i0 <= pt = false)%nat as ->.
           { apply /negP. intros Hn. nify.  omega. }
           case: ifP.
           *** intros.
               assert (i0 = (S pt))%nat.
               { nify.  omega. }
               subst.
               apply pidist_bind_congr_le.
               ****  apply pidist_union_le.
               **** intros (?&?). eapply IH.
                    nify. omega.
           *** intros. setoid_rewrite pidist_left_id.
               eapply IH. nify. omega.
  Qed.

  Lemma approx_pt_S_Ex pt n k:
    Ex_min (approx (S pt) n k) ≤ Ex_min (approx pt n k).
  Proof.
    apply Ex_min_le_pidist.
    apply approx_pt_S_le_pidist.
  Qed.

  Local Open Scope nat_scope.

  Lemma approx_worst_aux pt n k1 k2 c1 c2 m1 m2 i1 i2:
    (k1 <= k2)%coq_nat →
    (k1 + Init.Nat.min 1 i1 <= k2 + Init.Nat.min 1 i2)%coq_nat →
    (i1 > i2 → k1 + Init.Nat.min 1 i1 <= k2)%coq_nat →
    (m1 = n + c1)%coq_nat →
    (m2 = n + c2)%coq_nat →
    Ex_min
      (' (itotal, c)
         ← rep_while (λ (an : nat * nat) (b : nat), ((an.1 + b)%N, an.2.+1))
         (λ x : nat * nat, (x.1 <= pt)%N) n (incr_flipn k1) (i1, c1)%nat;
         approx_worst pt (m1 - c) (k1 + Init.Nat.min 1 itotal))
      ≤ Ex_min
      (' (itotal, c)
         ← rep_upto_while (λ (an : nat * nat) (b : nat), ((an.1 + b)%N, an.2.+1))
         (λ x : nat * nat, (x.1 <= pt)%N) n (incr_flipn k2) (i2, c2);
         approx pt (m2 - c) (k2 + Init.Nat.min 1 itotal)).
  Proof.
    revert pt k1 k2 c1 c2 m1 m2 i1 i2.
    induction n as [n IH] using lt_wf_ind => pt k1 k2 c1 c2 m1 m2 i1 i2 Hlek Hle Hlei
                                               Hm1 Hm2.
    destruct n as [| n].
    - rewrite /rep_while/rep_upto_while.
      setoid_rewrite pidist_left_id => //=.
      intros. subst. rewrite ?subnn //=. rewrite ?Ex_min_mret //= /approx_estimate //=.
      rewrite ?addn0. rewrite /Rminus. apply Rplus_le_compat_r.
      apply Rle_pow; try nra. rewrite //= in Hle.
    - rewrite {1}/rep_while -{1}/rep_while.
      rewrite {1}/rep_upto_while -{1}/rep_upto_while.
      case: ifP => Hle_pt1;
      rewrite //= in Hle_pt1;
      case: ifP => Hle_pt2;
      rewrite //= in Hle_pt2.
      * apply Ex_min_bind_union.
        ** setoid_rewrite pidist_left_id.
           simpl fst. simpl snd.
           subst.
           replace ((S n + c2)%coq_nat - c2)%nat with (S n); last by (nify; omega).
           rewrite /approx -/approx.
           assert (k1 <= k2 + Init.Nat.min 1 i2)%coq_nat as Hle' by (nify; omega).
           setoid_rewrite pidist_assoc.
           destruct Hle' as [| k2' Hle']. (* Might want inversion instead of destruct here *)
           *** eapply Ex_min_bind_congr; first by reflexivity.
               intros i.
               rewrite /rep_upto_while_count.
               eapply IH; nify; try omega.
               destruct i1; simpl in *; omega.
               destruct i1.
               **** rewrite //=.  omega.
               **** rewrite //= in Hle. omega.
           *** eapply Ex_min_pidist_plus_bind_le_l;
               eapply Ex_min_pidist_plus_bind_le_r;
               setoid_rewrite pidist_left_id;
               abstract (eapply IH; destruct i1; simpl in *; nify; omega).
        ** setoid_rewrite pidist_assoc.
           destruct Hlek as [| k2' Hlek].
           *** eapply Ex_min_bind_congr; first by reflexivity.
               intros i.
               rewrite /rep_upto_while_count.
               abstract (eapply IH; nify; try omega;
                         destruct i1; destruct i2; destruct i; simpl in *; try omega).
           *** eapply Ex_min_pidist_plus_bind_le_l;
               eapply Ex_min_pidist_plus_bind_le_r;
               setoid_rewrite pidist_left_id;
               eapply IH; try omega;
               destruct i1; destruct i2; simpl in *; nify; try omega.
      * setoid_rewrite pidist_left_id.
        rewrite Hm2.
        replace ((S n + c2)%coq_nat - c2) with (S ((n + c2)%coq_nat - c2)); last by (nify; omega).
        rewrite /approx -/approx.
        rewrite /rep_upto_while_count.
        setoid_rewrite pidist_assoc.
        replace ((n + c2)%coq_nat - c2) with n; last by (nify; omega).
        eapply Ex_min_pidist_plus_bind_le_l;
        setoid_rewrite pidist_left_id;
        eapply Ex_min_pidist_plus_bind_le_r;
        setoid_rewrite pidist_left_id;
        by (eapply IH; try omega;
          destruct i1; destruct i2; simpl in *; nify; try omega).
      * move /negP in Hle_pt1.
        apply Ex_min_bind_union.
        ** setoid_rewrite pidist_left_id.
           rewrite Hm1 Hm2.
           replace ((S n + c1)%coq_nat - c1) with (S ((n + c1)%coq_nat - c1)); last by (nify; omega).
           replace ((S n + c2)%coq_nat - c2) with (S ((n + c2)%coq_nat - c2)); last by (nify; omega).
        rewrite /approx_worst -/approx_worst.
        rewrite /rep_while_count.
        rewrite /approx -/approx.
        rewrite /rep_upto_while_count.
        replace ((n + c1)%coq_nat - c1) with n; last by (nify; omega).
        replace ((n + c2)%coq_nat - c2) with n; last by (nify; omega).
        assert (k1 + min 1 i1 = k2 + Init.Nat.min 1 i2 ∨
                k1 + min 1 i1 < k2 + Init.Nat.min 1 i2) as [Heq|Hlt].
        { rewrite //=.
          destruct i1; destruct i2; rewrite //= in Hle; inversion Hle; nify; try omega; auto;
          try (left; nify; omega);
          try (right; nify; omega). }
           *** rewrite Heq. subst. eapply Ex_min_bind_congr; first by reflexivity.
               intros i.
               eapply IH; nify; try omega.
           *** eapply Ex_min_pidist_plus_bind_le_l;
               eapply Ex_min_pidist_plus_bind_le_r;
               setoid_rewrite pidist_left_id;
               abstract (eapply IH; destruct i1; simpl in *; nify; omega).
        ** setoid_rewrite pidist_assoc.
           setoid_rewrite pidist_left_id.
           rewrite Hm1.
           replace ((S n + c1)%coq_nat - c1) with (S ((n + c1)%coq_nat - c1)); last by (nify; omega).
           rewrite /approx_worst -/approx_worst.
           rewrite /rep_while_count.
           replace ((n + c1)%coq_nat - c1) with n; last by (nify; omega).
           destruct Hlei.
           { nify; omega. }
           *** eapply Ex_min_bind_congr; first by reflexivity.
               intros i.
               eapply IH;
                 destruct i1; destruct i2; destruct i; rewrite //=; nify; try omega; auto.
           *** eapply Ex_min_pidist_plus_bind_le_l;
               eapply Ex_min_pidist_plus_bind_le_r;
               setoid_rewrite pidist_left_id;
               abstract (eapply IH; destruct i1; simpl in *; nify; omega).
      * setoid_rewrite pidist_left_id.
        rewrite Hm1 Hm2.
           replace ((S n + c1)%coq_nat - c1) with (S ((n + c1)%coq_nat - c1)); last by (nify; omega).
           replace ((S n + c2)%coq_nat - c2) with (S ((n + c2)%coq_nat - c2)); last by (nify; omega).
        rewrite /approx_worst -/approx_worst.
        rewrite /rep_while_count.
        rewrite /approx -/approx.
        rewrite /rep_upto_while_count.
        replace ((n + c1)%coq_nat - c1) with n; last by (nify; omega).
        replace ((n + c2)%coq_nat - c2) with n; last by (nify; omega).
        assert (k1 + min 1 i1 = k2 + Init.Nat.min 1 i2 ∨
                k1 + min 1 i1 < k2 + Init.Nat.min 1 i2) as [Heq|Hlt].
        { rewrite //=.
          destruct i1; destruct i2; rewrite //= in Hle; inversion Hle; nify; try omega; auto;
          try (left; nify; omega);
          try (right; nify; omega). }
           *** rewrite Heq. subst. eapply Ex_min_bind_congr; first by reflexivity.
               intros i.
               eapply IH; nify; try omega.
           *** eapply Ex_min_pidist_plus_bind_le_l;
               eapply Ex_min_pidist_plus_bind_le_r;
               setoid_rewrite pidist_left_id;
               abstract (eapply IH; destruct i1; simpl in *; nify; omega).
  Qed.

  Lemma approx_worst_spec pt n k:
    Ex_min (approx_worst pt n k) ≤ Ex_min (approx pt n k).
  Proof.
    destruct n.
    - rewrite //=.  reflexivity.
    - rewrite /approx_worst -/approx_worst.
      rewrite /rep_while_count.
      rewrite /approx -/approx.
      rewrite /rep_upto_while_count.
      eapply Ex_min_bind_congr; first by reflexivity. intros i.
      eapply approx_worst_aux; omega.
  Qed.

  Local Open Scope R.

  Fixpoint Ex_approx_worst c n k curr :=
    match n with
    | 0 => match curr with
          | 0 => approx_estimate k
          | _ => approx_estimate (S k)
          end
    | S n =>
      let (curr', k') :=
          match (c - S curr)%nat with
          | 0 => (0, S k)%nat
          | _ => (S curr, k)%nat
          end
      in
      (1 / 2^k) * Ex_approx_worst c n k' curr' +
      (1 - 1 / 2^k) * Ex_approx_worst c n k curr
    end.

  Lemma Ex_approx_worst_spec_aux pt n k:
    (1 <= pt)%coq_nat →
    (∀ i1 c1 m1,
    (i1 <= pt)%coq_nat →
    (m1 = n + c1)%coq_nat →
    ( Ex_min (' (itotal, c)
         ← rep_while (λ (an : nat * nat) (b : nat), ((an.1 + b)%N, an.2.+1))
         (λ x : nat * nat, (x.1 <= pt)%N) n (incr_flipn k) (i1, c1)%nat;
               approx_worst pt (m1 - c) (k + Init.Nat.min 1 itotal)) =
      Ex_approx_worst (S pt) n k (min i1 pt))) ∧
    ( Ex_min (approx_worst pt n k) = Ex_approx_worst (S pt) n k 0).
  Proof.
    intros Hpt.
    revert k.
    induction n as [n IH] using lt_wf_ind => k.
    destruct n as [| n].
    - split.
      * intros i1 c1 m1 Hlt Heq.
        rewrite //=.  setoid_rewrite pidist_left_id. rewrite Heq.
        replace ((0 + c1)%coq_nat - c1)%nat with O by (nify; omega).
        rewrite //=. rewrite Ex_min_mret.
        rewrite /approx_estimate; destruct i1 => //=; rewrite ?addn0 ?addn1 //=.
        destruct pt; rewrite ?addn0 ?addn1 //=. omega.
      * rewrite //=. apply Ex_min_mret.
    - split.
      * intros i1 c1 m1 Hlt Heq.
      rewrite /rep_while -/rep_while. rewrite /Ex_approx_worst -/Ex_approx_worst.
      rewrite /fst.
      assert (i1 <= pt)%N as -> by (nify; omega).
      case_eq (S pt - S i1)%nat.
      { intros.
        assert (pt = i1) as -> by (nify; omega).
        destruct n.
        * rewrite //=.  setoid_rewrite pidist_assoc. setoid_rewrite pidist_left_id.
          rewrite Ex_min_pidist_plus_bind. setoid_rewrite pidist_left_id.
          replace (m1 - S c1)%nat with O by (nify; omega).
          rewrite //=. rewrite ?Ex_min_mret ?addn1 ?addn0 => //=.
          rewrite Min.min_idempotent.
          destruct i1; rewrite ?addn0 ?addn1; auto.
          rewrite subnn. done.
        * setoid_rewrite pidist_assoc.
          rewrite Ex_min_pidist_plus_bind. setoid_rewrite pidist_left_id.
          destruct (IH (S n)) with (k := k) as (IHl&_); first by auto.
          rewrite [a in _ + (_ * a) = _]IHl; try (rewrite //=; nify; omega).
          rewrite addn0.
          f_equal. f_equal.
          rewrite /rep_while -/rep_while. rewrite addn1.
          assert (S i1 <= i1 = false)%nat as ->.
          { apply /negP. nify. omega. }
          setoid_rewrite pidist_left_id.
          rewrite /snd.
          replace (m1 - S c1)%nat with (S n) by (nify; omega).
          specialize (IH (S n)).
          assert (Hltn: (S n < S (S n))%coq_nat) by auto.
          destruct (IH Hltn (k + min 1 (S i1))%nat) as (_&IHr);
            last (rewrite (IHr); clear IHr); eauto;
            try (rewrite //=; nify; omega).
          rewrite ?Min.min_idempotent ?subnn.
          destruct i1.
          ** rewrite Min.min_idempotent. rewrite ?Min.min_r; last by omega.
          ** rewrite ?Min.min_l; last by omega. rewrite ?addn0; f_equal.
             f_equal. f_equal.
             *** rewrite //=. nify. omega.
      }
      intros diff Hdiff.
      setoid_rewrite pidist_assoc.
      rewrite Ex_min_pidist_plus_bind.
      setoid_rewrite pidist_left_id.
      rewrite Heq. replace (S n + c1)%coq_nat with (n + S c1)%coq_nat; last by (nify; omega).
      specialize (IH n).
      assert (n < S n)%coq_nat as Hltn.
      { auto.  }
      destruct (IH Hltn k) as (IHl&_); last (rewrite [a in _ + (_ * a) = _](IHl _ (S c1)); clear IHl);
        try (rewrite //=; nify; omega);
      destruct (IH Hltn k) as (IHl&_); last (rewrite (IHl _ (S c1)); clear IHl);
        try (rewrite //=; nify; omega).
      rewrite addn1 addn0 //=.
      destruct pt as [| pt].
      { exfalso. nify. omega. }
      assert (i1 <= pt)%coq_nat.
      { nify.  omega. }
      rewrite ?(Min.min_l i1 (S pt)); last by auto.
      rewrite ?(Min.min_l i1 pt); last by auto.
      rewrite Hdiff; f_equal.
      * rewrite /approx_worst -/approx_worst.
        rewrite Ex_min_pidist_plus_bind.
        setoid_rewrite pidist_left_id.
        specialize (IH n).
        assert (n < S n)%coq_nat as Hltn by auto.
      destruct (IH Hltn k) as (IHl&_); last (rewrite [a in _ + (_ * a) = _](IHl _ O); clear IHl);
        try (rewrite //=; nify; omega).
      destruct (IH Hltn k) as (IHl&_); last (rewrite (IHl _ O); clear IHl);
        try (rewrite //=; nify; omega).
      rewrite //=.
      rewrite subn1 //=. destruct pt; first by omega.
      done.
  Qed.

  Lemma Ex_approx_worst_spec_aux2 n k:
    (∀ i1 c1 m1,
    (i1 = 0 ∨ i1 = 1)%nat →
    (m1 = n + c1)%coq_nat →
    ( Ex_min (' (itotal, c)
         ← rep_while (λ (an : nat * nat) (b : nat), ((an.1 + b)%N, an.2.+1))
         (λ x : nat * nat, (x.1 <= 0)%N) n (incr_flipn k) (i1, c1)%nat;
               approx_worst 0 (m1 - c) (k + Init.Nat.min 1 itotal)) =
      Ex_approx_worst 1 n (k + min 1 i1) 0)) ∧
    ( Ex_min (approx_worst 0 n k) = Ex_approx_worst 1 n k 0).
  Proof.
    revert k.
    induction n as [n IH] using lt_wf_ind => k.
    destruct n as [| n].
    - split.
      * intros i1 c1 m2 Hcase Heq.
        rewrite Heq. rewrite //=. setoid_rewrite pidist_left_id.
        rewrite subnn. rewrite //=. rewrite Ex_min_mret. destruct i1; auto.
      * rewrite //=. rewrite Ex_min_mret; done.
    - split.
      * intros ic1 c1 m2 Hcase Heq.
        rewrite Heq. rewrite //=. destruct Hcase as [?|?]; subst.
        ** rewrite //=. setoid_rewrite pidist_assoc.
           rewrite Ex_min_pidist_plus_bind. setoid_rewrite pidist_left_id.
           assert (n < S n)%coq_nat as Hltnn.
           { auto. }

           destruct (IH n Hltnn k) as (IHl&_).
           rewrite [a in _ + (_ * a) = _]IHl; try (rewrite //=; nify; omega); [].
           rewrite ?addn0.
           f_equal. f_equal.
           destruct (IH _ Hltnn k%nat) as (IHl'&IHr).
           replace ((S (n + c1)%coq_nat)) with (n + (S c1))%coq_nat; last by auto.
           rewrite IHl'  //=; auto. rewrite addn1. done.
        ** rewrite //=. setoid_rewrite pidist_left_id.
           replace (S (n + c1)%coq_nat - c1)%nat with (S n); last by (nify; omega).
           rewrite //=. rewrite Ex_min_pidist_plus_bind.
           setoid_rewrite pidist_left_id.
           assert (n < S n)%coq_nat as Hltnn.
           { auto. }
           destruct (IH n Hltnn (k + 1)%nat) as (IHl&_); rewrite IHl; try (rewrite //=; nify; omega).
           f_equal.
           {rewrite //= ?addn1. f_equal. }
           destruct (IH n Hltnn (k + 1))%nat as (IHl'&_); rewrite IHl'; try (rewrite //=; nify; omega).
           rewrite //= ?addn1 ?addn0. f_equal.
      * rewrite //=.
        assert (n < S n)%coq_nat as Hltnn.
        { auto. }
        rewrite Ex_min_pidist_plus_bind.
        setoid_rewrite pidist_left_id.
        destruct (IH n Hltnn k)%nat as (IHl'&_).
        rewrite ?IHl'; try (rewrite //=; nify; omega).
        rewrite //= ?addn1 ?addn0. done.
  Qed.

  Lemma Ex_approx_worst_spec pt n k:
    Ex_min (approx_worst pt n k) = Ex_approx_worst (S pt) n k 0.
  Proof.
    destruct pt as [| pt].
    - edestruct Ex_approx_worst_spec_aux2; eauto.
    - edestruct (Ex_approx_worst_spec_aux (S pt) n k); eauto.
      nify. omega.
  Qed.

  Remark simple_calculation: Ex_min (approx_worst 1 5 0) = 3.
  Proof.
    rewrite Ex_approx_worst_spec //= /approx_estimate.
    nra.
  Qed.

  Remark simple_calculation2: Ex_min (approx_worst 1 6 0) >= 3.
  Proof.
    rewrite Ex_approx_worst_spec //= /approx_estimate.
    field_simplify.
    nra.
  Qed.

  (*
  Remark simple_calculation3: 7 - Ex_min (approx_worst 1 7 0) <= (33/10).
  Proof.
    rewrite Ex_approx_worst_spec //= /approx_estimate.
    field_simplify.
    nra.
  Qed.

  Remark simple_calculation4: 10 - Ex_min (approx_worst 1 10 0) <= (409/100).
  Proof.
    rewrite Ex_approx_worst_spec //= /approx_estimate.
    Time field_simplify.
    nra.
  Qed.
   *)

 End counter.


Require Export prosa.analysis.transform.prefix.
Require Export prosa.analysis.transform.swap.
Require Export prosa.analysis.facts.model.ideal_schedule.

(** In this file we define the EDF transformation of a schedule, which turns a
    (finite prefix of a) schedule into an EDF schedule. This operation is at
    the core of the EDF optimality proof. *)

Section EDFTransformation.
  (** Consider any given type of jobs... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ... and ideal uni-processor schedules. *)
  Let PState := ideal.processor_state Job.
  Let SchedType := schedule (PState).

  (** We say that a state [s1] "has an earlier or equal deadline" than a state
      [s2] if the job scheduled in state [s1] has has an earlier or equal
      deadline than the job scheduled in state [s2]. This function is never
      used on idle states, so the default values are irrelevant. *)
  Definition earlier_deadline (s1 s2: PState) :=
    (oapp job_deadline 0 s1) <= (oapp job_deadline 0 s2).

  (** We say that a state is relevant (for the purpose of the transformation)
      if it is not idle and if the job scheduled in it has arrived prior to
      some given reference time. *)
  Definition relevant_pstate (reference_time: instant) (s: PState) :=
    match s with
    | None => false
    | Some j' => job_arrival j' <= reference_time
    end.

  (** Next, we define a central element of the EDF transformation procedure:
      given a job scheduled at a time [t1], find a later time [t2] before the
      job's deadline at which a job with an earlier-or-equal deadline is
      scheduled. In other words, find a job that causes the [EDF_at] property
      to be violated at time [t1]. *)
  Definition find_swap_candidate (sched: SchedType) (t1: instant) (j: Job) :=
    if search_arg sched (relevant_pstate t1) earlier_deadline t1 (job_deadline j) is Some t
    then t
    else 0.

  (** The point-wise EDF transformation procedure: given a schedule and a time
      [t1], ensure that the schedule satisfies [EDF_at] at time [t1]. *)
  Definition make_edf_at (sched: SchedType) (t1: instant): SchedType :=
    match sched t1 with
    | None => sched (* leave idle instants alone *)
    | Some j =>
      let
        t2 := find_swap_candidate sched t1 j
      in swapped sched t1 t2
    end.

  (** To transform a finite prefix of a given reference schedule, apply
      [make_edf_at] to every point up to the given finite horizon. *)
  Definition edf_transform_prefix (sched: SchedType) (horizon: instant): SchedType :=
    prefix_map sched make_edf_at horizon.

  (** Finally, a full EDF schedule (i.e., one that satisfies [EDF_at] at any
      time) is obtained by first computing an EDF prefix up to and including
      the requested time [t], and by then looking at the last point of the
      prefix. *)
  Definition edf_transform (sched: SchedType) (t: instant): ideal.processor_state Job :=
    let
      edf_prefix := edf_transform_prefix sched t.+1
    in edf_prefix t.

End EDFTransformation.


Require Export ZArith.
Require Export Bool.
Require Import zorder.
Require Import setOrder.
Require Import genSets.
Require Import Mapping.
Require Import List.

Module myOrder : CmpOrderTheory with Definition A := Zorder.A := cmpOrder
  Zorder.
Module ZSet := geneSets myOrder.

Definition NodeSet := ZSet.set.
Definition emptyNS := ZSet.empty.
Definition s_in := ZSet.s_in.
Definition single := ZSet.single.
Definition card := ZSet.card.

(*
Module M1:=(SetOrder ZSet).
Module M2:=(cmpOrder M1).
Module ZZSet:=(geneSets M2).
*)

Module M3 := SetDecidableEq ZSet.
Module M_Arcs := genMapping myOrder M3.
Module M_Order := genMapping myOrder Zequal.

Definition Arcs := M_Arcs.Mapping.
Definition NodeId := ZSet.A.
Definition Order := M_Order.Mapping.

(*
Definition Dpath :Set := (list NodeId).
*)

(*==============================================================================*)
(* 		a generic model of Directed Graphs, unlabeled arcs 		*)
(* 		(possibly cyclic)                           			*)
(*==============================================================================*)
Module Type graphSig.

Declare Module M_NNodes : MappingInt with Definition A := Z.

Definition Nodes := M_NNodes.Mapping.

(* Definition Node:=M_NNodes.B . *)
(*
Parameter Nodes:Set.
*)
Parameter Node : Set.

(* type for Directed graphs *)
Parameter DGraph : Set.

(* DGraph constructor *)
Parameter graph : Z -> Nodes -> Arcs -> Arcs -> Order -> DGraph.

(* Could be nice to abstract over "internal state", but I can't figure out *)
(* how to achieve this in a simple way *)
(*Parameter InternalState:Type.*)
(*Parameter graph: InternalState -> DGraph.*)

Definition empty : DGraph :=
  graph 0 M_NNodes.empty M_Arcs.empty M_Arcs.empty M_Order.empty.

(* hidden stuctures : see in implementation below
Parameter alloc:Z
Parameter nodes:Nodes.
Parameter FwdArcs:Arcs.
Parameter BwdArcs:Arcs.
Parameter order:Order.
*)

Parameter g_in : DGraph -> NodeId -> bool.

Parameter get_node : DGraph -> NodeId -> option Node.

Parameter roots : DGraph -> NodeId -> NodeSet.
Parameter leaves : DGraph -> NodeId -> NodeSet.

Parameter children : DGraph -> NodeId -> NodeSet.
Parameter descendants : DGraph -> NodeId -> NodeSet.

Parameter parents : DGraph -> NodeId -> NodeSet.
Parameter ancestors : DGraph -> NodeId -> NodeSet.

Parameter add_node : DGraph -> Node -> NodeId * DGraph.
Parameter sub_node : DGraph -> NodeId -> DGraph.

Parameter add_arc : DGraph -> NodeId -> NodeId -> DGraph.
Parameter sub_arc : DGraph -> NodeId -> NodeId -> DGraph.

Parameter set_order : DGraph -> NodeId -> Z -> DGraph.
Parameter get_order : DGraph -> NodeId -> option Z.

Parameter project : DGraph -> NodeSet -> DGraph.

(*-------------------------------------------------------------------------------*)
Axiom
  g_in_sem :
    forall (g g' : DGraph) (id : NodeId) (N : Node),
    add_node g N = (id, g') -> g_in g' id = true.

Axiom
  g_in_sem2 :
    forall (g g' : DGraph) (id id' : NodeId) (N : Node),
    id <> id' -> add_node g N = (id', g') -> g_in g' id = g_in g id.

Axiom g_in_empty : forall id : NodeId, g_in empty id = false.

(*-------------------------------------------------------------------------------*)
Axiom
  get_node_sem1 :
    forall (g : DGraph) (id : NodeId),
    g_in g id = true -> exists N : Node, get_node g id = Some N.

Axiom
  get_node_sem2 :
    forall (g : DGraph) (id : NodeId),
    g_in g id = false -> get_node g id = None.

Axiom get_node_empty : forall id : NodeId, get_node empty id = None.

(*-------------------------------------------------------------------------------*)
Axiom
  roots_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (roots g id') = true ->
    parents g id = emptyNS /\
    (s_in id' (descendants g id) = true \/ id = id').
Axiom
  leaves_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (leaves g id') = true ->
    children g id = emptyNS /\ (s_in id' (ancestors g id) = true \/ id = id').

(*-------------------------------------------------------------------------------*)
Axiom
  add_sub_node :
    forall (g g' : DGraph) (N : Node) (id : NodeId),
    add_node g N = (id, g') -> sub_node g' id = g.
Axiom
  add_node_sem :
    forall (g g' : DGraph) (N : Node) (id : NodeId),
    add_node g N = (id, g') -> get_node g' id = Some N.

Axiom
  add_node_sem2 :
    forall (g g' : DGraph) (N : Node) (id id' : NodeId),
    id <> id' -> add_node g N = (id', g') -> get_node g' id = get_node g id.

Axiom
  sub_node_sem :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> get_node g' id = None.

Axiom
  sub_node_sem1 :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> get_order g' id = None.

Axiom
  sub_node_sem2 :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> descendants g' id = emptyNS.

Axiom
  sub_node_sem3 :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> ancestors g' id = emptyNS.

(*-------------------------------------------------------------------------------*)
Axiom
  add_sub_arc :
    forall (g g' : DGraph) (id id' : NodeId),
    add_arc g id id' = g' -> sub_arc g' id id' = g.
Axiom
  add_arc_sem1 :
    forall (g g' : DGraph) (id id' : NodeId),
    add_arc g id id = g' -> s_in id' (children g' id) = true.

(*-------------------------------------------------------------------------------*)
Axiom
  children_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (children g id') = true -> g_in g id = true.
Axiom
  descendants_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (descendants g id') = true -> g_in g id = true.

Axiom descendants_sem2 :
        forall (g : DGraph) (x z: NodeId),
	s_in z (descendants g x) = true ->
        (s_in z (children g x)=true) \/
         (exists y:NodeId,
         s_in y (children g x)=true  /\ s_in z (descendants g y)=true)
	.

Axiom
  children_descendants :
    forall (g : DGraph) (id id' : NodeId),
    s_in id' (children g id) = true -> s_in id' (descendants g id) = true.

Axiom
  descendants_closure :
    forall (g : DGraph) (id id' id'' : NodeId),
    s_in id' (descendants g id) = true ->
    s_in id'' (descendants g id') = true ->
    s_in id'' (descendants g id) = true.

(*-------------------------------------------------------------------------------*)
Axiom
  parents_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (parents g id') = true -> g_in g id = true.
Axiom
  ancestors_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (ancestors g id') = true -> g_in g id = true.

Axiom
  parents_ancestors :
    forall (g : DGraph) (id id' : NodeId),
    s_in id' (parents g id) = true -> s_in id' (ancestors g id) = true.

Axiom
  ancestors_closure :
    forall (g : DGraph) (id id' id'' : NodeId),
    s_in id' (ancestors g id) = true ->
    s_in id'' (ancestors g id') = true -> s_in id'' (ancestors g id) = true.

Axiom
  children_parents :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (children g id') = true -> s_in id' (parents g id) = true.

Axiom
  parents_children :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (parents g id') = true -> s_in id' (children g id) = true.

Axiom
  descendants_ancestors :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (descendants g id') = true -> s_in id' (ancestors g id) = true.

Axiom
  ancestors_descendants :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (ancestors g id') = true -> s_in id' (descendants g id) = true.

(*-------------------------------------------------------------------------------*)
Axiom
  order_sem :
    forall (g : DGraph) (id : NodeId) (z : Z),
    g_in g id = true -> get_order (set_order g id z) id = Some z.

(*-------------------------------------------------------------------------------*)
Axiom
  project_sem :
    forall (g : DGraph) (ns : NodeSet) (e : NodeId),
    s_in e ns = true ->
    g_in g e = true ->
    g_in (project g ns) e = true /\
    (forall e' : NodeId,
     s_in e' (descendants g e) = true -> g_in (project g ns) e' = true).

End graphSig.


Require Export preservation.

Definition normal_form {X:Type} (R:relation X) (t:X) : Prop :=
  ~ (exists t', R t t').

Notation reduction_normal_form := (normal_form reduction).

Definition stuck (t:term) : Prop :=
  reduction_normal_form t /\ ~ bool_value t.

Hint Unfold stuck.

Check refl_step_closure.
Check relation.
Check reduction.

Definition reductionmany := (refl_step_closure reduction).
Notation "t1 '==>*' t2" := (reductionmany t1 t2) (at level 40).

Corollary soundness_type_system : forall t t' Ty,
                                    has_Type t Ty ->
                                    t ==>* t' ->
                                    ~ (stuck t').

Proof.
intros t t' T HT P.
induction P; intros [R S].
destruct (progress x T HT); auto.
apply IHP.
apply (preservation x y T HT H).
unfold stuck.
split.
auto.
auto.
Qed.


Require Export CFGloopcutting.
Require Import Lia.

Section cfg.
  Context `(C : redCFG).
  (** ** p p ex head **)

  Lemma loop_contains_all_ex_pre p q π ϕ
        (Hpath : CPath p q ϕ)
        (Hpre : Prefix ϕ π)
        (Hae : forall x, x ∈ π -> exists h, h ∈ π /\ loop_contains h x)
    : exists h, h ∈ π /\ forall x, x ∈ ϕ -> loop_contains h x.
  Proof.
    induction Hpath.
    - specialize (Hae a). exploit Hae. 1:eapply prefix_incl;eauto.
      destructH. exists h. split;eauto. intros. destruct H;[subst|contradiction]. eauto.
    - exploit IHHpath.
      + eapply prefix_cons;eauto.
      + destructH.
        specialize (IHHpath1 b) as Hb. exploit Hb. 1: eapply path_contains_front;eauto.
        destruct (edge_Edge H).
        * exists h. split;eauto. intros. destruct H0;eauto. subst.
          eapply basic_edge_eq_loop in b0. rewrite <-b0. eauto.
        * exists h. split;eauto. intros. destruct H0;eauto. subst.
          eapply back_edge_eq_loop in b0. rewrite <-b0. eauto.
        * exists h. split;eauto. intros. destruct H0;eauto. subst.
          eapply deq_loop_entry;eauto.
        * destruct e. eapply deq_loop_exited in H0.
          specialize (Hae c). exploit Hae.
          -- eapply prefix_incl;eauto.
          -- destructH. eapply loop_contains_either in Hb. 2: eapply H0;eauto.
             destruct Hb.
             ++ exists h0. split;eauto. intros.
                destruct H2;eauto.
                ** subst. eauto.
                ** eapply loop_contains_trans;eauto.
             ++ exists h. split;eauto. intros. destruct H2.
                ** subst. eapply loop_contains_trans;eauto.
                ** eauto.
  Qed.

  Lemma loop_contains_all_ex p q π
        (Hpath : CPath p q π)
        (Hae : forall x, x ∈ π -> exists h, h ∈ π /\ loop_contains h x)
    : exists h, h ∈ π /\ forall x, x ∈ π -> loop_contains h x.
  Proof.
    eapply loop_contains_all_ex_pre;eauto.
    econstructor.
  Qed.

  Lemma p_p_ex_head (p : Lab) π
        (Hpath : CPath p p π)
        (Hlen : | π | >= 2)
    : exists h, h ∈ π /\ forall x, x ∈ π -> loop_contains h x.
  Proof.
    eapply loop_contains_all_ex;eauto.
    decide (exists x, x ∈ π /\ forall h, h ∈ π -> ~ loop_contains h x).
    - exfalso.
      destructH.
      eapply rotate_find in Hpath;eauto. destructH.
      inv_path Hpath0.
      + cbn in Hpath3. lia.
      + destruct Hpath2.
        eapply loop_cutting in H;eauto.
        * destructH.
          eapply a_edge_acyclic;eauto.
          destruct (edge_Edge H0).
          -- destruct b. eauto.
          -- exfalso. eapply e1;eauto. eapply loop_contains_self. eexists;eauto.
          -- eapply entry_edge_acyclic;eauto.
          -- eapply exit_edge_acyclic;eauto.
        * intros. intro N. eapply e1. 2:eapply H3. eapply H2. right. eauto.
    - do 3 simpl_dec' n. intros.
      specialize (n x).
      destruct n;[contradiction|].
      destructH.
      exists x0.
      eapply dec_DM_impl in H0;eauto.
      destructH. split;eauto. eapply dec_DN;eauto.
  Qed.

End cfg.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Tactics for integers arithmetic                                         *
**************************************************************************)

(** --IMPORTANT: requires the CSDP package to be installed on the system
    [sudo apt get install ubuntu package coinor-csdp]
*)

(** For documentation, see the Micromega chapter from Coq reference manual:
    "Micromega: tactics for solving arithmetic goals over ordered rings" *)

(** --DISCLAIMER: WORK IN PROGRESS *)

Set Implicit Arguments.
Require Import Coq.micromega.Psatz.
From TLC Require Import LibTactics.
From TLC Require Export LibInt.

(* ********************************************************************** *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(** ** [math_lia] tactic *)

(** [math_lia] supports linear arithmetic; it roughly provides the
    combined power of [ring_simplify] and [omega]. *)

Ltac math_lia_core tt :=
  math_setup; lia.

Tactic Notation "math_lia" :=
  math_lia_core tt.

(** Binding for [nat] --TODO: is it useful? *)

Ltac nat_math_lia :=
  nat_math_setup; lia.

(* ---------------------------------------------------------------------- *)
(** ** [math_nia] tactic *)

(** [math_nia] supports non-linear integer arithmetic.
    It performs a limited amount of non-linear reasoning
    before running [lia]. *)

Ltac math_nia_core tt :=
  math_setup; nia.

Tactic Notation "math_nia" :=
  math_nia_core tt.

(** Binding for [nat] --TODO: is it useful? *)

Ltac nat_math_nia :=
  nat_math_setup; nia.

(* ---------------------------------------------------------------------- *)
(** ** [math_dia] *)

(** [math_dia] extends [math_nia] with support for divisions.
    Division are encoded using multiplications, via Euclidian
    division and remainder. *)

Definition Zdiv_hyp (P:Prop) := P.

Lemma Z_div_mod' : forall a b : int,
  Zdiv_hyp ((b > 0)%Z) ->
  let (q, r) := Z.div_eucl a b in
  a = (b * q)%I + r /\ (0 <= r < b)%Z.
Proof using. applys Z_div_mod. Qed.

Ltac Zdiv_eliminate_step tt :=
  match goal with |- context[ Z.div_eucl ?X ?Y ] =>
     generalize (@Z_div_mod' X Y);
     destruct (Z.div_eucl X Y)
  end.

Ltac math_dia_generalize_all_prop tt :=
  repeat match goal with H: ?T |- _ =>
    match type of T with Prop => gen H end end.

Ltac Zdiv_eliminate tt :=
  math_dia_generalize_all_prop tt;
  unfold Z.div;
  repeat (Zdiv_eliminate_step tt).

(* --TODO: deal differently with iterated divisions,
   in order to avoid blow up *)

Ltac Zdiv_instantiate_hyp_steps tt :=
  match goal with H: Zdiv_hyp ?P -> _ |- _ =>
    specializes H __;
    [ idtac
    | try Zdiv_instantiate_hyp_steps tt ]
  end.

Ltac Zdiv_instantiate_hyp tt :=
  Zdiv_instantiate_hyp_steps tt.

Ltac math_dia_setup :=
  math_0; math_1; math_2; math_3; Zdiv_eliminate tt;
  intros; try Zdiv_instantiate_hyp_steps tt; unfolds Zdiv_hyp.

Ltac math_dia_core tt :=
  math_dia_setup; math_nia.

Tactic Notation "math_dia" :=
  math_dia_core tt.

(* ********************************************************************** *)
(** * Demos *)

(** --Commented out so that the compilation does not fail in the absence
      of the CSDP package...

Lemma math_nia_demo_1 : forall (a b N : int),
  N > 0 ->
  a * N <= b * N ->
  a <= b.
Proof using. math_nia. Qed.

Lemma math_dia_demo_1 : forall (a b t : int),
  t > 0 ->
  a <= b ->
  a / t <= b / t.
Proof using. math_dia. Qed.

Lemma math_dia_demo_2 : forall (a t : int),
  t > 1 ->
  a > 0 ->
  a / t <= a.
Proof using. math_dia. Qed.

Lemma math_dia_demo_3 : forall (a b t : int),
  t > 0 ->
  0 <= a <= b ->
  a / t <= b / t.
Proof using. math_dia. Qed.

Lemma math_dia_demo_4 : forall (a b N : int),
  N > 0 ->
  a > 0 ->
  b > 0 ->
  a * N <= b * N ->
  a <= b.
Proof using. math_dia. Qed.

Lemma math_dia_demo_5 : forall (a b N t : int),
  N > 0 ->
  t > 1 ->
  a > 0 ->
  b > 0 ->
  a * N <= b * N ->
  a / t <= b.
Proof using. (* showing that a little help might be needed *)
  intros.
  (* math_dia_setup. math_dia. skip. *)
  try math_dia.
  assert (a / t <= a). math_dia.
  assert (a <= b). math_dia.
  math_dia.
Qed.

*)

(*--- FUTURE WORK
Lemma math_dia_demo_span_1 : forall (a b t n N : int),
  N > 0 ->
  n > 0 ->
  t > 0 ->
  a >= 0 ->
  b >= 0 ->
  a <= b * (1 + N/t) + n * t/N ->
  (   a <= b * (1 + N/t) + (n+1) * t/N
  /\ (a+1) <= (b+1) * (1 + N/t) + (n+1) * t/N
  /\ b * (1 + N/t) + N * t/N = b * (1 + t/N) + t
  /\ (b + t) * (1 + N/t) + n * t/N = b * (1 + N/t) + t + N + n * t/N).
Proof using.
  intros. splits.
  math_dia.
  try math_dia. skip.
  try math_dia. skip.
  try math_dia. skip.
Qed.

Lemma math_dia_demo : forall a b t n N,
  a * N <= b * N + (b + n) * t  ->
  a <= b * (1 + t / N) + n * t / N.
Proof using. intros. math_dia. Qed.

--*)