(* --------------------------   Description ---------------------------------------------------

      In this file we formally define the  relation between graphs G and G', where the graph G'
      is obtained by repeating vertex a of G  to a'.

      Following definition captures this relationship:

      Definition Rep_in (G:UG) (a a':A) (G': UG):=
       In a G /\ ~ In a' G /\ (nodes G') = (add a' G) /\ edg G' a a' /\
       (forall x y, In x G -> In y G-> edg G x y = edg G' x y) /\
       (forall x, x<>a-> edg G x a = edg G' x a').

       Definition Rep G G':= exists a a', Rep_in G a a' G'.

      For a the given graphs G and G' related to each other by above relation we prove
      many useful properties relating their edges.

      We also establish an isomorphism between the graph G and G'_a using the following
      function f:

       Let f:= ( fun x:A => match (x == a), (x == a') with
                            | true, true => x
                            | true, false => a'
                            | false, true => a
                            | false, false => x
                     end).

      Lemma G_iso_G'_a : iso_usg f G (ind_at N'_a G').

   ------------------------------------------------------------------------------------------*)

Require Export MoreUG GenIso.

Set Implicit Arguments.

Section Repeat_node.

  Context { A: ordType }.

  (*------ Definition and properties of the relation (Repeat G G' a a') and (Rep G G' -------*)

  Definition Rep_in (G:UG) (a a':A) (G': UG):=
    In a G /\ ~ In a' G /\ (nodes G') = (add a' G) /\ edg G' a a' /\
    (forall x y, In x G -> In y G-> edg G x y = edg G' x y) /\ (forall x, x<>a-> edg G x a = edg G' x a').

  Definition Rep G G':= exists a a', Rep_in G a a' G'.

  Variable G G': @UG A.
  Variable a a': A.

  Hypothesis Hrep: Rep_in G a a' G'.

  Lemma a_in_G: In a G.
  Proof. apply Hrep. Qed.

  Lemma a'_not_in_G: ~ In a' G.
  Proof. apply Hrep. Qed.

  Lemma a'_in_G': In a' G'.
  Proof. replace (nodes G') with (add a' G). auto. symmetry;apply Hrep. Qed.

  Lemma nodes_GG': (nodes G') = (add a' G).
  Proof. apply Hrep. Qed.

  Lemma a_not_a': a <> a'.
  Proof. intro h1; subst a; unfold Rep_in in Hrep; absurd (In a' G); apply Hrep.  Qed.

  Hint Resolve a_in_G a'_not_in_G a'_in_G'  nodes_GG' a_not_a': core.

  Lemma E'_aa': (edg G') a a'.
  Proof.  { unfold Rep_in in Hrep.
            destruct Hrep as [hr1 hr]; destruct hr as [hr2 hr]; destruct hr as [hr3 hr].
            destruct hr as [hr4 hr];destruct hr as [hr5 hr]. auto. } Qed.

  Lemma Exa_E'xa' (x: A):(edg G) x a-> (edg G') x a'.
  Proof. { unfold Rep_in in Hrep.
           destruct (x==a) eqn: Hxa.
           move /eqP in Hxa. subst x;intros;apply Hrep. move /eqP in Hxa.
           replace (edg G' x a') with (edg G x a). auto. apply Hrep. auto. } Qed.

  Lemma Eay_E'a'y (y: A): (edg G) a y -> (edg G') a' y.
  Proof. { intros h. apply sym_edg. apply sym_edg in h.  apply Exa_E'xa'; auto. } Qed.

  Hint Resolve E'_aa' Exa_E'xa' Eay_E'a'y : core.

  (* --- following three results true only for x y both in G  --- *)

  Lemma In_Exy_eq_E'xy (x y:A): In x G-> In y G-> edg G x y=edg G' x y.
  Proof. { unfold Rep_in in Hrep. apply Hrep. } Qed.

  Lemma In_E'xy_Exy (x y:A): In x G -> In y G -> ~ edg G x y  -> ~ edg G' x y.
  Proof.  { intros h1 h2. replace (edg G' x y) with (edg G x y). auto.
            apply In_Exy_eq_E'xy;auto. } Qed.

  Lemma In_E'xy_Exy1 (x y:A): In x G -> In y G  -> edg G' x y -> edg G x y.
  Proof.  { intros h1 h2. replace (edg G' x y) with (edg G x y). auto.
            apply In_Exy_eq_E'xy;auto. } Qed.

Hint Immediate In_E'xy_Exy In_E'xy_Exy1 In_Exy_eq_E'xy: core.

  Lemma Exy_E'xy (x y:A): edg G x y -> edg G' x y.
  Proof. { intro h1.
           assert (h2: In x G). eauto.
           assert (h3: In y G). eauto.
           replace (edg G' x y) with (edg G x y); auto. } Qed.

  Hint Immediate Exy_E'xy: core.

  (* ---- if niether x nor y is a' then E' x y = E x y --------*)

  Lemma Exy_eq_E'xy (x y:A): x <> a'-> y<> a'->  edg G x y = edg G' x y.
  Proof. { intros H1 H2.
           assert (hx: In x G \/ ~ In x G). eauto.
           assert (hy: In y G \/ ~ In y G). eauto.
           destruct hx as [hx | hx].
           { (*--  In x G  -*)
             destruct hy as [hy | hy].
             { (*-- In y G---*)
               auto. }
             { (*---  ~ In y G --*)
               assert (hyG': ~ In y G' ).
               { intros h1. replace (nodes G') with (add a' G) in h1.
                 cut (y = a' \/ In y G). intro h2.
                 destruct h2; contradiction. auto. symmetry; apply Hrep.  }
               replace (edg G x y) with false.
               replace (edg G' x y) with false.
               auto. all: symmetry; switch; intros h3.
               absurd (In y G');eauto. absurd (In y G);eauto. } }
           { (*--  ~ In x G  -*)
             assert (hyG': ~ In x G' ).
              { intros h1. replace (nodes G') with (add a' G) in h1.
                cut (x = a' \/ In x G). intro h2.
                destruct h2; contradiction. auto. symmetry; apply Hrep.  }
             replace (edg G x y) with false.
             replace (edg G' x y) with false.
             auto. all: symmetry; switch; intros h3.
             absurd (In x G');eauto. absurd (In x G);eauto. }  } Qed.

    Hint Immediate Exy_eq_E'xy: core.

    Lemma E'xy_Exy (x y:A): x<>a'-> y<>a'-> edg G' x y -> edg G x y.
    Proof. intros h1 h2; replace (edg G' x y) with (edg G x y); auto. Qed.

    Lemma Exy_E'xy1 (x y:A): x<>a'-> y<>a'-> edg G x y -> edg G' x y.
    Proof. intros h1 h2; replace (edg G' x y) with (edg G x y); auto. Qed.

    Hint Immediate E'xy_Exy Exy_E'xy1: core.

   (*------------- other special cases of interest------------*)

    Lemma E'xa_Exa (x:A):  x<> a'->  edg G' x a -> edg G x a.
    Proof. intros. apply E'xy_Exy; auto.  Qed.

   Lemma Exa_eq_E'xa'(x:A): x <> a ->  edg G x a = edg G' x a'.
   Proof. apply Hrep. Qed.

  Lemma Eay_eq_E'a'y (y:A): y<>a  -> edg G a y = edg G' a' y.
  Proof. { replace (edg G a y) with (edg G y a);
           replace (edg G' a' y) with (edg G' y a');
           (eapply Exa_eq_E'xa' || eapply edg_sym); auto. } Qed.

    Lemma E'xa'_Exa (x:A): x <> a->  edg G' x a' -> edg G x a.
    Proof. { intro h1. replace (edg G' x a') with (edg G x a). auto.
              auto using Exa_eq_E'xa'. } Qed.

  Hint Immediate E'xa_Exa E'xa'_Exa Exa_eq_E'xa' Eay_eq_E'a'y: core.

  (*------------------------- edge properties only in G'--------------*)
  Lemma E'xa_E'xa' (x:A):  x <> a' -> edg G' x a -> edg G' x a'.
    Proof.  auto.  Qed.

  Lemma E'xa'_E'xa (x:A): x <> a->  edg G' x a' -> edg G' x a.
  Proof. intros H1 H2.  specialize ( E'xa'_Exa H1 H2) as H3;  auto. Qed.

  Hint Immediate E'xa_E'xa' E'xa'_E'xa: core.

  Lemma E'xa_eq_E'xa' (x:A): x <> a-> x<> a'->  edg G' x a = edg G' x a'.
   Proof. auto. Qed.

   Lemma E'ay_eq_E'a'y (y:A): y<>a -> y<> a'-> edg G' a y = edg G' a' y.
   Proof. { intros H1 H2.
           replace (edg G' a y) with (edg G' y a);
             replace (edg G' a' y) with (edg G' y a').
           auto using E'xa_eq_E'xa'. all: apply edg_sym. } Qed.

   Hint Immediate E'xa_eq_E'xa' E'ay_eq_E'a'y: core.

   (*------------------- G is Induced subgraph of G'-----------------------*)

   Lemma Ind_sub_GG': Ind_subgraph G G'.
   Proof.  { split. replace (nodes G') with (add a' G). intros x h1; auto.
             symmetry. auto.  apply Hrep. } Qed.

   Hint Resolve Ind_sub_GG': core.

   (* The term G'_a is used to represent the induced subgraph of G' at G' \ {a} *)

   (*-------------------- G'_a is isomorphic to G  -----------------------*)

   Let N'_a:= (rmv a G').
   Let G'_a:= (ind_at (rmv a G') G').

   Lemma NG'_a: N'_a = nodes (ind_at N'_a G').
   Proof.  apply set_equal;auto. unfold N'_a. auto.
          cut ((rmv a G') [<=] G'). simpl. auto. auto.  Qed.

   Lemma G'_a_is_ind_subgraph: Ind_subgraph (ind_at N'_a G') G'.
   Proof. split.
          { simpl. auto. }
          { intros x y H1 H2. simpl. symmetry;auto. } Qed.

   (*---- Following function is used to establish isomorphism between G and G'_a----*)

   Let f:= ( fun x:A => match (x == a), (x == a') with
                            | true, true => x
                            | true, false => a'
                            | false, true => a
                            | false, false => x
                     end).

   (* -----------  some properties of f to become an isomorphism-------------- *)
   Lemma fa_is_a':  (f a) = a'.
   Proof. { unfold f. replace (a==a) with true. replace (a==a') with false.
            auto. all: symmetry; apply /eqP; auto. } Qed.

   Lemma fa'_is_a :  (f a') = a.
   Proof. { unfold f. replace (a'==a') with true. replace (a'==a) with false.
            auto. all: symmetry; apply /eqP; auto.  } Qed.

   Lemma fx_is_x (x:A): In x G-> x<>a-> (f x) = x.
   Proof.  { intros H H1. unfold f. replace (x==a) with false. replace (x==a') with false.
             auto. all: symmetry; apply /eqP; auto. intro. subst x.
             absurd (In a' G). apply Hrep. auto.  } Qed.

   Lemma fx_is_x2 (x:A): x<>a'-> x<>a-> (f x) = x.
   Proof.  { intros H H1. unfold f. replace (x==a) with false. replace (x==a') with false.
             auto. all: symmetry; apply /eqP; auto.  } Qed.

   (* -----   fact: f (f x) = x     ------------ *)
   Lemma f_is_invertible: forall x : A, f (f x) = x.
   Proof. { assert (H0: a <> a'). auto.
            intro x. unfold f.  destruct (x==a) eqn: Hxa;destruct (x==a') eqn: Hxa'.
            {  absurd (a=a'). auto. move /eqP in Hxa; move /eqP in Hxa'.
               rewrite <- Hxa; auto.  }
            { replace (a'== a) with false.
              { replace (a'==a') with true. symmetry;auto. symmetry;auto. }
              { symmetry. switch.  move /eqP. intro H1;apply H0;auto. } }
            { replace (a==a) with true. replace (a==a') with false. all: symmetry;auto.  }
            { rewrite Hxa. rewrite Hxa'. auto. } } Qed.

   (* -----   fact:   G'_a = (img f G) -------- *)
   Lemma G'_a_is_imgG: nodes (ind_at N'_a G') = (img f G).
   Proof. { assert (H0: a <> a'). auto.
            assert (HGG': nodes G' = add a' G). apply Hrep.
          assert (H1: Equal (ind_at N'_a G') (img f G)).
          { split; unfold Subset.
            { (* -- x in G_a' implies x in img f G --*)
              intros x H1.
              assert (H1a: x <> a). rewrite <- NG'_a in H1.
              { eapply set_rmv_elim2 with (l:= (add a' G)). auto.
                unfold N'_a in H1. rewrite <- HGG'. auto.  }
              assert (case_xa': x=a' \/ x<>a'). eauto.
              destruct case_xa'.
              { subst x. replace a' with (f a).  auto. auto using fa_is_a'. }
              { assert (H2: In x G).
                { simpl in H1.  cut (In x (add a' G)). eauto.
                  unfold N'_a in H1. rewrite <- HGG'. eauto. }
                replace x with (f x). auto. auto using fx_is_x.  } }
            { (*--- x in img f G implie x in G_a' ---*)
              intros y H1.
              assert (H1a: exists x, In x G /\ y= f x ). auto.
              destruct H1a as [x H1a]. destruct H1a as [H1a H1b].
              assert (Hxa: x=a \/ x<>a). eauto.
              destruct Hxa.
              { subst y. replace (f x) with a'. simpl.
                cut (In a' (add a' G)). cut (In a' N'_a).
                auto. unfold N'_a. cut(a'<>a). cut (In a' G').  auto.
                simpl. all: auto.  subst x; symmetry. auto using fa_is_a'. }
              { subst y. replace (f x) with x. rewrite <- NG'_a.
                unfold N'_a. cut (In x G').  auto. rewrite HGG'. auto.
                symmetry; auto using fx_is_x. } } }
              auto. } Qed.

   (* -----   fact: f preserves edg relation ----- *)
   Lemma f_preserves_edg(x y:A):In x G -> In y G -> edg G x y = edg (ind_at N'_a G') (f x) (f y).
   Proof. { intros hx hy.  assert (H0: a <> a'). auto.
          assert (H0a: a == a' = false). switch. move /eqP. auto.
          assert (H0b: (rmv a G') [<=] G'). auto.

          assert (H0d: In a' G'). simpl;  auto.

          destruct (x==y) eqn: Hxy.
          { (* when x =y : easy case*)
            assert (H1: x=y). auto. subst y.
            replace (edg G x x) with false.  all: symmetry; switch; auto. }
          { (* when x <> y : involved case*)
            assert (H1: x <> y).
            { move /eqP. switch_in Hxy. auto. }
            unfold f.
            destruct (x==a) eqn: Hxa.
            { (* when x=a*)
              assert (x=a); auto. subst x. rewrite H0a.
              assert (y == a =false).
              { switch. move /eqP. intro H2. subst y. auto. }
              rewrite H.
              destruct (y == a') eqn: Hya'.
              { (*when y=a'*)
                assert (y=a'). auto. subst y. absurd (In a' G).
                apply Hrep. auto.  }
              { (*when y <> a'*)
                assert (y<>a'). move /eqP. switch. auto.
                replace (edg G a y) with (edg G' a' y).
                Focus 2. symmetry. apply Eay_eq_E'a'y;auto.
                assert (H3: In a' (rmv a G')).  auto.
                assert (H3a: memb a' G' = memb a' (rmv a G')). symmetry; auto.
                assert (H4: memb y G' = memb y (rmv a G')). auto. auto. } }
            { (*when x<>a*)
              assert (x<> a). move /eqP. switch; auto.
              destruct (x==a') eqn: Hxa'.
              { (* when x =a'*)
                assert (x=a'). auto. subst x. absurd (In a' G).
                apply Hrep. auto. }
              { (* when x <> a'*)
                assert (x<> a'). switch_in Hxa'. intro H2; apply Hxa'; auto.
                destruct (y==a) eqn: Hya; destruct (y== a') eqn: Hya'.
                { move /eqP in Hya. move /eqP in Hya'. subst y. contradiction. }
                { move /eqP in Hya. subst y.
                  replace (edg G x a) with (edg G' x a').
                  Focus 2. auto.
                  assert (memb x G' = memb x (rmv a G')). auto.
                  assert (memb a' G' = memb a' (rmv a G')). auto.
                  auto. }
                { move /eqP in Hya'. subst y.  absurd (In a' G).
                  apply Hrep. auto.  }
                { assert (y<>a). move /eqP; switch; auto.
                  assert (y<>a'). move /eqP; switch; auto.
                  replace (edg G x y) with (edg G' x y).
                  Focus 2. auto.
                  assert (memb x G' = memb x (rmv a G')). auto.
                  assert (memb y G' = memb y (rmv a G')). auto.
                  auto. } } } }  } Qed.

   Lemma G_iso_G'_a : iso_usg f G (ind_at N'_a G').
   Proof. { assert (H0: a <> a'). auto.
          split.
          { (* ------------------ Proof of the fact that f (f x) = x -----------------*)
             intros x hx. apply f_is_invertible;auto. }
          split.
          { (*----------------- Proof of the fact that G'_a = img f G -------------- *)
            apply G'_a_is_imgG;auto. }
          { (*---------------  Proof that isomorphism preserves the edg relation-------*)
            intros x y. intros hx hy. apply f_preserves_edg;auto.  } } Qed.

   Lemma G_isomorphic_G'_a: exists f, iso_usg f G (ind_at N'_a G').
     Proof.  exists f. apply G_iso_G'_a;auto. Qed.

End Repeat_node.

Hint Resolve a_in_G a'_not_in_G a'_in_G' nodes_GG' a_not_a': core.
Hint Resolve E'_aa' Exa_E'xa' Eay_E'a'y : core.

 Hint Immediate In_E'xy_Exy In_E'xy_Exy1 In_Exy_eq_E'xy: core.
 Hint Immediate Exy_E'xy Exy_E'xy1 Exy_eq_E'xy: core.

 Hint Immediate E'xy_Exy : core.

 Hint Immediate E'xa_Exa E'xa'_Exa Exa_eq_E'xa' Eay_eq_E'a'y: core.

 Hint Immediate E'xa_E'xa' E'xa'_E'xa: core.
 Hint Immediate E'xa_eq_E'xa' E'ay_eq_E'a'y: core.

 Hint Resolve Ind_sub_GG': core.

 Hint Resolve G_isomorphic_G'_a: core.

 Hint Resolve no_edg1 no_edg2: core.
 Hint Resolve G_iso_G'_a: core.


From Hammer Require Import Hammer.

Require Export ZArith_base.
Require Export Rdefinitions.
Local Open Scope R_scope.

Axiom Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1.
Hint Resolve Rplus_comm: real.

Axiom Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3).
Hint Resolve Rplus_assoc: real.

Axiom Rplus_opp_r : forall r:R, r + - r = 0.
Hint Resolve Rplus_opp_r: real.

Axiom Rplus_0_l : forall r:R, 0 + r = r.
Hint Resolve Rplus_0_l: real.

Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1.
Hint Resolve Rmult_comm: real.

Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3).
Hint Resolve Rmult_assoc: real.

Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1.
Hint Resolve Rinv_l: real.

Axiom Rmult_1_l : forall r:R, 1 * r = r.
Hint Resolve Rmult_1_l: real.

Axiom R1_neq_R0 : 1 <> 0.
Hint Resolve R1_neq_R0: real.

Axiom
Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3.
Hint Resolve Rmult_plus_distr_l: real.

Axiom total_order_T : forall r1 r2:R, {r1 < r2} + {r1 = r2} + {r1 > r2}.

Axiom Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1.

Axiom Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3.

Axiom Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2.

Axiom
Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2.

Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real.

Fixpoint INR (n:nat) : R :=
match n with
| O => 0
| S O => 1
| S n => INR n + 1
end.
Arguments INR n%nat.

Axiom archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1.

Definition is_upper_bound (E:R -> Prop) (m:R) := forall x:R, E x -> x <= m.

Definition bound (E:R -> Prop) :=  exists m : R, is_upper_bound E m.

Definition is_lub (E:R -> Prop) (m:R) :=
is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b).

Axiom
completeness :
forall E:R -> Prop,
bound E -> (exists x : R, E x) -> { m:R | is_lub E m }.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import ZArith_base.
Require Import ZArithRing.
Require Import Zcomplements.
Require Import Zdiv.
Require Import Wf_nat.

(** For compatibility reasons, this Open Scope isn't local as it should *)

Open Scope Z_scope.

(** This file contains some notions of number theory upon Z numbers:
     - a divisibility predicate [Z.divide]
     - a gcd predicate [gcd]
     - Euclid algorithm [euclid]
     - a relatively prime predicate [rel_prime]
     - a prime predicate [prime]
     - properties of the efficient [Z.gcd] function
*)

Notation Zgcd := Z.gcd (compat "8.6").
Notation Zggcd := Z.ggcd (compat "8.6").
Notation Zggcd_gcd := Z.ggcd_gcd (compat "8.6").
Notation Zggcd_correct_divisors := Z.ggcd_correct_divisors (compat "8.6").
Notation Zgcd_divide_l := Z.gcd_divide_l (compat "8.6").
Notation Zgcd_divide_r := Z.gcd_divide_r (compat "8.6").
Notation Zgcd_greatest := Z.gcd_greatest (compat "8.6").
Notation Zgcd_nonneg := Z.gcd_nonneg (compat "8.6").
Notation Zggcd_opp := Z.ggcd_opp (compat "8.6").

(** The former specialized inductive predicate [Z.divide] is now
    a generic existential predicate. *)

Notation Zdivide := Z.divide (compat "8.6").

(** Its former constructor is now a pseudo-constructor. *)

Definition Zdivide_intro a b q (H:b=q*a) : Z.divide a b := ex_intro _ q H.

(** Results concerning divisibility*)

Notation Zdivide_refl := Z.divide_refl (compat "8.6").
Notation Zone_divide := Z.divide_1_l (only parsing).
Notation Zdivide_0 := Z.divide_0_r (only parsing).
Notation Zmult_divide_compat_l := Z.mul_divide_mono_l (only parsing).
Notation Zmult_divide_compat_r := Z.mul_divide_mono_r (only parsing).
Notation Zdivide_plus_r := Z.divide_add_r (only parsing).
Notation Zdivide_minus_l := Z.divide_sub_r (only parsing).
Notation Zdivide_mult_l := Z.divide_mul_l (only parsing).
Notation Zdivide_mult_r := Z.divide_mul_r (only parsing).
Notation Zdivide_factor_r := Z.divide_factor_l (only parsing).
Notation Zdivide_factor_l := Z.divide_factor_r (only parsing).

Lemma Zdivide_opp_r a b : (a | b) -> (a | - b).
Proof. apply Z.divide_opp_r. Qed.

Lemma Zdivide_opp_r_rev a b : (a | - b) -> (a | b).
Proof. apply Z.divide_opp_r. Qed.

Lemma Zdivide_opp_l a b : (a | b) -> (- a | b).
Proof. apply Z.divide_opp_l. Qed.

Lemma Zdivide_opp_l_rev a b : (- a | b) -> (a | b).
Proof. apply Z.divide_opp_l. Qed.

Theorem Zdivide_Zabs_l a b : (Z.abs a | b) -> (a | b).
Proof. apply Z.divide_abs_l. Qed.

Theorem Zdivide_Zabs_inv_l a b : (a | b) -> (Z.abs a | b).
Proof. apply Z.divide_abs_l. Qed.

Hint Resolve Z.divide_refl Z.divide_1_l Z.divide_0_r: zarith.
Hint Resolve Z.mul_divide_mono_l Z.mul_divide_mono_r: zarith.
Hint Resolve Z.divide_add_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
  Zdivide_opp_l_rev Z.divide_sub_r Z.divide_mul_l Z.divide_mul_r
  Z.divide_factor_l Z.divide_factor_r: zarith.

(** Auxiliary result. *)

Lemma Zmult_one x y : x >= 0 -> x * y = 1 -> x = 1.
Proof.
 Z.swap_greater. apply Z.eq_mul_1_nonneg.
Qed.

(** Only [1] and [-1] divide [1]. *)

Notation Zdivide_1 := Z.divide_1_r (only parsing).

(** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *)

Notation Zdivide_antisym := Z.divide_antisym (compat "8.6").
Notation Zdivide_trans := Z.divide_trans (compat "8.6").

(** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *)

Lemma Zdivide_bounds a b : (a | b) -> b <> 0 -> Z.abs a <= Z.abs b.
Proof.
 intros H Hb.
 rewrite <- Z.divide_abs_l, <- Z.divide_abs_r in H.
 apply Z.abs_pos in Hb.
 now apply Z.divide_pos_le.
Qed.

(** [Z.divide] can be expressed using [Z.modulo]. *)

Lemma Zmod_divide : forall a b, b<>0 -> a mod b = 0 -> (b | a).
Proof.
 apply Z.mod_divide.
Qed.

Lemma Zdivide_mod : forall a b, (b | a) -> a mod b = 0.
Proof.
 intros a b (c,->); apply Z_mod_mult.
Qed.

(** [Z.divide] is hence decidable *)

Lemma Zdivide_dec a b : {(a | b)} + {~ (a | b)}.
Proof.
 destruct (Z.eq_dec a 0) as [Ha|Ha].
  destruct (Z.eq_dec b 0) as [Hb|Hb].
   left; subst; apply Z.divide_0_r.
   right. subst. contradict Hb. now apply Z.divide_0_l.
  destruct (Z.eq_dec (b mod a) 0).
   left. now apply Z.mod_divide.
   right. now rewrite <- Z.mod_divide.
Defined.

Theorem Zdivide_Zdiv_eq a b : 0 < a -> (a | b) ->  b = a * (b / a).
Proof.
 intros Ha H.
 rewrite (Z.div_mod b a) at 1; auto with zarith.
 rewrite Zdivide_mod; auto with zarith.
Qed.

Theorem Zdivide_Zdiv_eq_2 a b c :
 0 < a -> (a | b) -> (c * b) / a = c * (b / a).
Proof.
 intros. apply Z.divide_div_mul_exact; auto with zarith.
Qed.

Theorem Zdivide_le: forall a b : Z,
 0 <= a -> 0 < b -> (a | b) ->  a <= b.
Proof.
 intros. now apply Z.divide_pos_le.
Qed.

Theorem Zdivide_Zdiv_lt_pos a b :
 1 < a -> 0 < b -> (a | b) ->  0 < b / a < b .
Proof.
  intros H1 H2 H3; split.
  apply Z.mul_pos_cancel_l with a; auto with zarith.
  rewrite <- Zdivide_Zdiv_eq; auto with zarith.
  now apply Z.div_lt.
Qed.

Lemma Zmod_div_mod n m a:
 0 < n -> 0 < m -> (n | m) -> a mod n = (a mod m) mod n.
Proof.
  intros H1 H2 (p,Hp).
  rewrite (Z.div_mod a m) at 1; auto with zarith.
  rewrite Hp at 1.
  rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add; auto with zarith.
Qed.

Lemma Zmod_divide_minus a b c:
 0 < b -> a mod b = c -> (b | a - c).
Proof.
  intros H H1. apply Z.mod_divide; auto with zarith.
  rewrite Zminus_mod; auto with zarith.
  rewrite H1. rewrite <- (Z.mod_small c b) at 1.
  rewrite Z.sub_diag, Z.mod_0_l; auto with zarith.
  subst. now apply Z.mod_pos_bound.
Qed.

Lemma Zdivide_mod_minus a b c:
 0 <= c < b -> (b | a - c) -> a mod b = c.
Proof.
  intros (H1, H2) H3.
  assert (0 < b) by Z.order.
  replace a with ((a - c) + c); auto with zarith.
  rewrite Z.add_mod; auto with zarith.
  rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto with zarith.
  rewrite Z.mod_mod; try apply Zmod_small; auto with zarith.
Qed.

(** * Greatest common divisor (gcd). *)

(** There is no unicity of the gcd; hence we define the predicate
    [Zis_gcd a b g] expressing that [g] is a gcd of [a] and [b].
    (We show later that the [gcd] is actually unique if we discard its sign.) *)

Inductive Zis_gcd (a b g:Z) : Prop :=
 Zis_gcd_intro :
  (g | a) ->
  (g | b) ->
  (forall x, (x | a) -> (x | b) -> (x | g)) ->
  Zis_gcd a b g.

(** Trivial properties of [gcd] *)

Lemma Zis_gcd_sym : forall a b d, Zis_gcd a b d -> Zis_gcd b a d.
Proof.
  induction 1; constructor; intuition.
Qed.

Lemma Zis_gcd_0 : forall a, Zis_gcd a 0 a.
Proof.
  constructor; auto with zarith.
Qed.

Lemma Zis_gcd_1 : forall a, Zis_gcd a 1 1.
Proof.
  constructor; auto with zarith.
Qed.

Lemma Zis_gcd_refl : forall a, Zis_gcd a a a.
Proof.
  constructor; auto with zarith.
Qed.

Lemma Zis_gcd_minus : forall a b d, Zis_gcd a (- b) d -> Zis_gcd b a d.
Proof.
  induction 1; constructor; intuition.
Qed.

Lemma Zis_gcd_opp : forall a b d, Zis_gcd a b d -> Zis_gcd b a (- d).
Proof.
  induction 1; constructor; intuition.
Qed.

Lemma Zis_gcd_0_abs a : Zis_gcd 0 a (Z.abs a).
Proof.
  apply Zabs_ind.
  intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
  intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
Qed.

Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.

Theorem Zis_gcd_unique: forall a b c d : Z,
 Zis_gcd a b c -> Zis_gcd a b d ->  c = d \/ c = (- d).
Proof.
intros a b c d [Hc1 Hc2 Hc3] [Hd1 Hd2 Hd3].
assert (c|d) by auto.
assert (d|c) by auto.
apply Z.divide_antisym; auto.
Qed.

(** * Extended Euclid algorithm. *)

(** Euclid's algorithm to compute the [gcd] mainly relies on
    the following property. *)

Lemma Zis_gcd_for_euclid :
  forall a b d q:Z, Zis_gcd b (a - q * b) d -> Zis_gcd a b d.
Proof.
  simple induction 1; constructor; intuition.
  replace a with (a - q * b + q * b). auto with zarith. ring.
Qed.

Lemma Zis_gcd_for_euclid2 :
  forall b d q r:Z, Zis_gcd r b d -> Zis_gcd b (b * q + r) d.
Proof.
  simple induction 1; constructor; intuition.
  apply H2; auto.
  replace r with (b * q + r - b * q). auto with zarith. ring.
Qed.

(** We implement the extended version of Euclid's algorithm,
    i.e. the one computing Bezout's coefficients as it computes
    the [gcd]. We follow the algorithm given in Knuth's
    "Art of Computer Programming", vol 2, page 325. *)

Section extended_euclid_algorithm.

  Variables a b : Z.

  (** The specification of Euclid's algorithm is the existence of
      [u], [v] and [d] such that [ua+vb=d] and [(gcd a b d)]. *)

  Inductive Euclid : Set :=
    Euclid_intro :
    forall u v d:Z, u * a + v * b = d -> Zis_gcd a b d -> Euclid.

  (** The recursive part of Euclid's algorithm uses well-founded
      recursion of non-negative integers. It maintains 6 integers
      [u1,u2,u3,v1,v2,v3] such that the following invariant holds:
      [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u3,v3)=gcd(a,b)].
      *)

  Lemma euclid_rec :
    forall v3:Z,
      0 <= v3 ->
      forall u1 u2 u3 v1 v2:Z,
	u1 * a + u2 * b = u3 ->
	v1 * a + v2 * b = v3 ->
	(forall d:Z, Zis_gcd u3 v3 d -> Zis_gcd a b d) -> Euclid.
  Proof.
    intros v3 Hv3; generalize Hv3; pattern v3.
    apply Zlt_0_rec.
    clear v3 Hv3; intros.
    destruct (Z_zerop x) as [Heq|Hneq].
    apply Euclid_intro with (u := u1) (v := u2) (d := u3).
    assumption.
    apply H3.
    rewrite Heq; auto with zarith.
    set (q := u3 / x) in *.
    assert (Hq : 0 <= u3 - q * x < x).
    replace (u3 - q * x) with (u3 mod x).
    apply Z_mod_lt; omega.
    assert (xpos : x > 0). omega.
    generalize (Z_div_mod_eq u3 x xpos).
    unfold q.
    intro eq; pattern u3 at 2; rewrite eq; ring.
    apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)).
    tauto.
    replace ((u1 - q * v1) * a + (u2 - q * v2) * b) with
      (u1 * a + u2 * b - q * (v1 * a + v2 * b)).
    rewrite H1; rewrite H2; trivial.
    ring.
    intros; apply H3.
    apply Zis_gcd_for_euclid with q; assumption.
    assumption.
  Qed.

  (** We get Euclid's algorithm by applying [euclid_rec] on
      [1,0,a,0,1,b] when [b>=0] and [1,0,a,0,-1,-b] when [b<0]. *)

  Lemma euclid : Euclid.
  Proof.
    case (Z_le_gt_dec 0 b); intro.
    intros;
      apply euclid_rec with
	(u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b);
	auto with zarith; ring.
    intros;
      apply euclid_rec with
	(u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b);
	auto with zarith; try ring.
  Qed.

End extended_euclid_algorithm.

Theorem Zis_gcd_uniqueness_apart_sign :
  forall a b d d':Z, Zis_gcd a b d -> Zis_gcd a b d' -> d = d' \/ d = - d'.
Proof.
  simple induction 1.
  intros H1 H2 H3; simple induction 1; intros.
  generalize (H3 d' H4 H5); intro Hd'd.
  generalize (H6 d H1 H2); intro Hdd'.
  exact (Z.divide_antisym d d' Hdd' Hd'd).
Qed.

(** * Bezout's coefficients *)

Inductive Bezout (a b d:Z) : Prop :=
  Bezout_intro : forall u v:Z, u * a + v * b = d -> Bezout a b d.

(** Existence of Bezout's coefficients for the [gcd] of [a] and [b] *)

Lemma Zis_gcd_bezout : forall a b d:Z, Zis_gcd a b d -> Bezout a b d.
Proof.
  intros a b d Hgcd.
  elim (euclid a b); intros u v d0 e g.
  generalize (Zis_gcd_uniqueness_apart_sign a b d d0 Hgcd g).
  intro H; elim H; clear H; intros.
  apply Bezout_intro with u v.
  rewrite H; assumption.
  apply Bezout_intro with (- u) (- v).
  rewrite H; rewrite <- e; ring.
Qed.

(** gcd of [ca] and [cb] is [c gcd(a,b)]. *)

Lemma Zis_gcd_mult :
  forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d).
Proof.
  intros a b c d; simple induction 1. constructor; auto with zarith.
  intros x Ha Hb.
  elim (Zis_gcd_bezout a b d H). intros u v Huv.
  elim Ha; intros a' Ha'.
  elim Hb; intros b' Hb'.
  apply Zdivide_intro with (u * a' + v * b').
  rewrite <- Huv.
  replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)).
  rewrite Ha'; rewrite Hb'; ring.
  ring.
Qed.

(** * Relative primality *)

Definition rel_prime (a b:Z) : Prop := Zis_gcd a b 1.

(** Bezout's theorem: [a] and [b] are relatively prime if and
    only if there exist [u] and [v] such that [ua+vb = 1]. *)

Lemma rel_prime_bezout : forall a b:Z, rel_prime a b -> Bezout a b 1.
Proof.
  intros a b; exact (Zis_gcd_bezout a b 1).
Qed.

Lemma bezout_rel_prime : forall a b:Z, Bezout a b 1 -> rel_prime a b.
Proof.
  simple induction 1; constructor; auto with zarith.
  intros. rewrite <- H0; auto with zarith.
Qed.

(** Gauss's theorem: if [a] divides [bc] and if [a] and [b] are
    relatively prime, then [a] divides [c]. *)

Theorem Gauss : forall a b c:Z, (a | b * c) -> rel_prime a b -> (a | c).
Proof.
  intros. elim (rel_prime_bezout a b H0); intros.
  replace c with (c * 1); [ idtac | ring ].
  rewrite <- H1.
  replace (c * (u * a + v * b)) with (c * u * a + v * (b * c));
    [ eauto with zarith | ring ].
Qed.

(** If [a] is relatively prime to [b] and [c], then it is to [bc] *)

Lemma rel_prime_mult :
  forall a b c:Z, rel_prime a b -> rel_prime a c -> rel_prime a (b * c).
Proof.
  intros a b c Hb Hc.
  elim (rel_prime_bezout a b Hb); intros.
  elim (rel_prime_bezout a c Hc); intros.
  apply bezout_rel_prime.
  apply Bezout_intro with
    (u := u * u0 * a + v0 * c * u + u0 * v * b) (v := v * v0).
  rewrite <- H.
  replace (u * a + v * b) with ((u * a + v * b) * 1); [ idtac | ring ].
  rewrite <- H0.
  ring.
Qed.

Lemma rel_prime_cross_prod :
  forall a b c d:Z,
    rel_prime a b ->
    rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d.
Proof.
  intros a b c d; intros.
  elim (Z.divide_antisym b d).
  split; auto with zarith.
  rewrite H4 in H3.
  rewrite Z.mul_comm in H3.
  apply Z.mul_reg_l with d; auto with zarith.
  intros; omega.
  apply Gauss with a.
  rewrite H3.
  auto with zarith.
  red; auto with zarith.
  apply Gauss with c.
  rewrite Z.mul_comm.
  rewrite <- H3.
  auto with zarith.
  red; auto with zarith.
Qed.

(** After factorization by a gcd, the original numbers are relatively prime. *)

Lemma Zis_gcd_rel_prime :
  forall a b g:Z,
    b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g).
Proof.
  intros a b g; intros.
  assert (g <> 0).
  intro.
  elim H1; intros.
  elim H4; intros.
  rewrite H2 in H6; subst b; omega.
  unfold rel_prime.
  destruct H1.
  destruct H1 as (a',H1).
  destruct H3 as (b',H3).
  replace (a/g) with a';
    [|rewrite H1; rewrite Z_div_mult; auto with zarith].
  replace (b/g) with b';
    [|rewrite H3; rewrite Z_div_mult; auto with zarith].
  constructor.
  exists a'; auto with zarith.
  exists b'; auto with zarith.
  intros x (xa,H5) (xb,H6).
  destruct (H4 (x*g)) as (x',Hx').
  exists xa; rewrite Z.mul_assoc; rewrite <- H5; auto.
  exists xb; rewrite Z.mul_assoc; rewrite <- H6; auto.
  replace g with (1*g) in Hx'; auto with zarith.
  do 2 rewrite Z.mul_assoc in Hx'.
  apply Z.mul_reg_r in Hx'; trivial.
  rewrite Z.mul_1_r in Hx'.
  exists x'; auto with zarith.
Qed.

Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a.
Proof.
  intros a b H; auto with zarith.
  red; apply Zis_gcd_sym; auto with zarith.
Qed.

Theorem rel_prime_div: forall p q r,
 rel_prime p q -> (r | p) -> rel_prime r q.
Proof.
  intros p q r H (u, H1); subst.
  inversion_clear H as [H1 H2 H3].
  red; apply Zis_gcd_intro; try apply Z.divide_1_l.
  intros x H4 H5; apply H3; auto.
  apply Z.divide_mul_r; auto.
Qed.

Theorem rel_prime_1: forall n, rel_prime 1 n.
Proof.
  intros n; red; apply Zis_gcd_intro; auto.
  exists 1; auto with zarith.
  exists n; auto with zarith.
Qed.

Theorem not_rel_prime_0: forall n, 1 < n -> ~ rel_prime 0 n.
Proof.
  intros n H H1; absurd (n = 1 \/ n = -1).
  intros [H2 | H2]; subst; contradict H; auto with zarith.
  case (Zis_gcd_unique  0 n n 1); auto.
  apply Zis_gcd_intro; auto.
  exists 0; auto with zarith.
  exists 1; auto with zarith.
Qed.

Theorem rel_prime_mod: forall p q, 0 < q ->
 rel_prime p q -> rel_prime (p mod q) q.
Proof.
  intros p q H H0.
  assert (H1: Bezout p q 1).
  apply rel_prime_bezout; auto.
  inversion_clear H1 as [q1 r1 H2].
  apply bezout_rel_prime.
  apply Bezout_intro with q1  (r1 + q1 * (p / q)).
  rewrite <- H2.
  pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith.
Qed.

Theorem rel_prime_mod_rev: forall p q, 0 < q ->
 rel_prime (p mod q) q -> rel_prime p q.
Proof.
  intros p q H H0.
  rewrite (Z_div_mod_eq p q); auto with zarith; red.
  apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto with zarith.
Qed.

Theorem Zrel_prime_neq_mod_0: forall a b, 1 < b -> rel_prime a b -> a mod b <> 0.
Proof.
  intros a b H H1 H2.
  case (not_rel_prime_0 _ H).
  rewrite <- H2.
  apply rel_prime_mod; auto with zarith.
Qed.

(** * Primality *)

Inductive prime (p:Z) : Prop :=
  prime_intro :
    1 < p -> (forall n:Z, 1 <= n < p -> rel_prime n p) -> prime p.

(** The sole divisors of a prime number [p] are [-1], [1], [p] and [-p]. *)

Lemma prime_divisors :
  forall p:Z,
    prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p.
Proof.
  destruct 1; intros.
  assert
    (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
  { assert (Z.abs a <= Z.abs p) as H2.
      apply Zdivide_bounds; [ assumption | omega ].
    revert H2.
    pattern (Z.abs a); apply Zabs_ind; pattern (Z.abs p); apply Zabs_ind;
    intros; omega. }
  intuition idtac.
  (* -p < a < -1 *)
  - absurd (rel_prime (- a) p); intuition.
    inversion H2.
    assert (- a | - a) by auto with zarith.
    assert (- a | p) by auto with zarith.
    apply H7, Z.divide_1_r in H8; intuition.
  (* a = 0 *)
  - inversion H1. subst a; omega.
  (* 1 < a < p *)
  - absurd (rel_prime a p); intuition.
    inversion H2.
    assert (a | a) by auto with zarith.
    assert (a | p) by auto with zarith.
    apply H7, Z.divide_1_r in H8; intuition.
Qed.

(** A prime number is relatively prime with any number it does not divide *)

Lemma prime_rel_prime :
  forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a.
Proof.
  intros; constructor; intros; auto with zarith.
  apply prime_divisors in H1; intuition; subst; auto with zarith.
  - absurd (p | a); auto with zarith.
  - absurd (p | a); intuition.
Qed.

Hint Resolve prime_rel_prime: zarith.

(** As a consequence, a prime number is relatively prime with smaller numbers *)

Theorem rel_prime_le_prime:
 forall a p, prime p -> 1 <=  a < p -> rel_prime a p.
Proof.
  intros a p Hp [H1 H2].
  apply rel_prime_sym; apply prime_rel_prime; auto.
  intros [q Hq]; subst a.
  case (Z.le_gt_cases q 0); intros Hl.
  absurd (q * p <= 0 * p); auto with zarith.
  absurd (1 * p <= q * p); auto with zarith.
Qed.

(** If a prime [p] divides [ab] then it divides either [a] or [b] *)

Lemma prime_mult :
  forall p:Z, prime p -> forall a b:Z, (p | a * b) -> (p | a) \/ (p | b).
Proof.
  intro p; simple induction 1; intros.
  case (Zdivide_dec p a); intuition.
  right; apply Gauss with a; auto with zarith.
Qed.

Lemma not_prime_0: ~ prime 0.
Proof.
  intros H1; case (prime_divisors _ H1 2); auto with zarith.
Qed.

Lemma not_prime_1: ~ prime 1.
Proof.
  intros H1; absurd (1 < 1); auto with zarith.
  inversion H1; auto.
Qed.

Lemma prime_2: prime 2.
Proof.
  apply prime_intro; auto with zarith.
  intros n (H,H'); Z.le_elim H; auto with zarith.
  - contradict H'; auto with zarith.
  - subst n. constructor; auto with zarith.
Qed.

Theorem prime_3: prime 3.
Proof.
  apply prime_intro; auto with zarith.
  intros n (H,H'); Z.le_elim H; auto with zarith.
  - replace n with 2 by omega.
    constructor; auto with zarith.
    intros x (q,Hq) (q',Hq').
    exists (q' - q). ring_simplify. now rewrite <- Hq, <- Hq'.
  - replace n with 1 by trivial.
    constructor; auto with zarith.
Qed.

Theorem prime_ge_2 p : prime p ->  2 <= p.
Proof.
  intros (Hp,_); auto with zarith.
Qed.

Definition prime' p := 1<p /\ (forall n, 1<n<p -> ~ (n|p)).

Lemma Z_0_1_more x : 0<=x -> x=0 \/ x=1 \/ 1<x.
Proof.
 intros H. Z.le_elim H; auto.
 apply Z.le_succ_l in H. change (1 <= x) in H. Z.le_elim H; auto.
Qed.

Theorem prime_alt p : prime' p <-> prime p.
Proof.
  split; intros (Hp,H).
  - (* prime -> prime' *)
    constructor; trivial; intros n Hn.
    constructor; auto with zarith; intros x Hxn Hxp.
    rewrite <- Z.divide_abs_l in Hxn, Hxp |- *.
    assert (Hx := Z.abs_nonneg x).
    set (y:=Z.abs x) in *; clearbody y; clear x; rename y into x.
    destruct (Z_0_1_more x Hx) as [->|[->|Hx']].
    + exfalso. apply Z.divide_0_l in Hxn. omega.
    + now exists 1.
    + elim (H x); auto.
      split; trivial.
      apply Z.le_lt_trans with n; auto with zarith.
      apply Z.divide_pos_le; auto with zarith.
  - (* prime' -> prime *)
    constructor; trivial. intros n Hn Hnp.
    case (Zis_gcd_unique n p n 1); auto with zarith.
    constructor; auto with zarith.
    apply H; auto with zarith.
Qed.

Theorem square_not_prime: forall a, ~ prime (a * a).
Proof.
  intros a Ha.
  rewrite <- (Z.abs_square a) in Ha.
  assert (H:=Z.abs_nonneg a).
  set (b:=Z.abs a) in *; clearbody b; clear a; rename b into a.
  rewrite <- prime_alt in Ha; destruct Ha as (Ha,Ha').
  assert (H' : 1 < a) by now apply (Z.square_lt_simpl_nonneg 1).
  apply (Ha' a).
  + split; trivial.
    rewrite <- (Z.mul_1_l a) at 1. apply Z.mul_lt_mono_pos_r; omega.
  + exists a; auto.
Qed.

Theorem prime_div_prime: forall p q,
 prime p -> prime q -> (p | q) -> p = q.
Proof.
  intros p q H H1 H2;
  assert (Hp: 0 < p); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith.
  assert (Hq: 0 < q); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith.
  case prime_divisors with (2 := H2); auto.
  intros H4; contradict Hp; subst; auto with zarith.
  intros [H4| [H4 | H4]]; subst; auto.
  contradict H; auto; apply not_prime_1.
  contradict Hp; auto with zarith.
Qed.

(** we now prove that [Z.gcd] is indeed a gcd in
   the sense of [Zis_gcd]. *)

Notation Zgcd_is_pos := Z.gcd_nonneg (only parsing).

Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Z.gcd a b).
Proof.
 constructor.
 apply Z.gcd_divide_l.
 apply Z.gcd_divide_r.
 apply Z.gcd_greatest.
Qed.

Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}.
Proof.
  intros x y; exists (Z.gcd x y).
  split; [apply Zgcd_is_gcd  | apply Z.gcd_nonneg].
Qed.

Theorem Zdivide_Zgcd: forall p q r : Z,
 (p | q) -> (p | r) -> (p | Z.gcd q r).
Proof.
 intros. now apply Z.gcd_greatest.
Qed.

Theorem Zis_gcd_gcd: forall a b c : Z,
 0 <= c ->  Zis_gcd a b c -> Z.gcd a b = c.
Proof.
  intros a b c H1 H2.
  case (Zis_gcd_uniqueness_apart_sign a b c (Z.gcd a b)); auto.
  apply Zgcd_is_gcd; auto.
  Z.le_elim H1.
  - generalize (Z.gcd_nonneg a b); auto with zarith.
  - subst. now case (Z.gcd a b).
Qed.

Notation Zgcd_inv_0_l := Z.gcd_eq_0_l (only parsing).
Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (only parsing).

Theorem Zgcd_div_swap0 : forall a b : Z,
 0 < Z.gcd a b ->
 0 < b ->
 (a / Z.gcd a b) * b = a * (b/Z.gcd a b).
Proof.
  intros a b Hg Hb.
  assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3].
  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto.
  repeat rewrite Z.mul_assoc; f_equal.
  rewrite Z.mul_comm.
  rewrite <- Zdivide_Zdiv_eq; auto.
Qed.

Theorem Zgcd_div_swap : forall a b c : Z,
 0 < Z.gcd a b ->
 0 < b ->
 (c * a) / Z.gcd a b * b = c * a * (b/Z.gcd a b).
Proof.
  intros a b c Hg Hb.
  assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3].
  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto.
  repeat rewrite Z.mul_assoc; f_equal.
  rewrite Zdivide_Zdiv_eq_2; auto.
  repeat rewrite <- Z.mul_assoc; f_equal.
  rewrite Z.mul_comm.
  rewrite <- Zdivide_Zdiv_eq; auto.
Qed.

Notation Zgcd_comm := Z.gcd_comm (compat "8.6").

Lemma Zgcd_ass a b c : Z.gcd (Z.gcd a b) c = Z.gcd a (Z.gcd b c).
Proof.
 symmetry. apply Z.gcd_assoc.
Qed.

Notation Zgcd_Zabs := Z.gcd_abs_l (only parsing).
Notation Zgcd_0 := Z.gcd_0_r (only parsing).
Notation Zgcd_1 := Z.gcd_1_r (only parsing).

Hint Resolve Z.gcd_0_r Z.gcd_1_r : zarith.

Theorem Zgcd_1_rel_prime : forall a b,
 Z.gcd a b = 1 <-> rel_prime a b.
Proof.
  unfold rel_prime; split; intro H.
  rewrite <- H; apply Zgcd_is_gcd.
  case (Zis_gcd_unique a b (Z.gcd a b) 1); auto.
  apply Zgcd_is_gcd.
  intros H2; absurd (0 <= Z.gcd a b); auto with zarith.
  generalize (Z.gcd_nonneg a b); auto with zarith.
Qed.

Definition rel_prime_dec: forall a b,
 { rel_prime a b }+{ ~ rel_prime a b }.
Proof.
  intros a b; case (Z.eq_dec (Z.gcd a b) 1); intros H1.
  left; apply -> Zgcd_1_rel_prime; auto.
  right; contradict H1; apply <- Zgcd_1_rel_prime; auto.
Defined.

Definition prime_dec_aux:
 forall p m,
  { forall n, 1 < n < m -> rel_prime n p } +
  { exists n, 1 < n < m  /\ ~ rel_prime n p }.
Proof.
  intros p m.
  case (Z_lt_dec 1 m); intros H1;
   [ | left; intros; exfalso; omega ].
  pattern m; apply natlike_rec; auto with zarith.
  left; intros; exfalso; omega.
  intros x Hx IH; destruct IH as [F|E].
  destruct (rel_prime_dec x p) as [Y|N].
  left; intros n [HH1 HH2].
  rewrite Z.lt_succ_r in HH2.
  Z.le_elim HH2; subst; auto with zarith.
  - case (Z_lt_dec 1 x); intros HH1.
    * right; exists x; split; auto with zarith.
    * left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith.
  - right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith.
Defined.

Definition prime_dec: forall p, { prime p }+{ ~ prime p }.
Proof.
  intros p; case (Z_lt_dec 1 p); intros H1.
  + case (prime_dec_aux p p); intros H2.
    * left; apply prime_intro; auto.
      intros n (Hn1,Hn2). Z.le_elim Hn1; auto; subst n.
      constructor; auto with zarith.
    * right; intros H3; inversion_clear H3 as [Hp1 Hp2].
      case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith.
  + right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto.
Defined.

Theorem not_prime_divide:
 forall p, 1 < p -> ~ prime p -> exists n, 1 < n < p  /\ (n | p).
Proof.
  intros p Hp Hp1.
  case (prime_dec_aux p p); intros H1.
  - elim Hp1; constructor; auto.
    intros n (Hn1,Hn2).
    Z.le_elim Hn1; auto with zarith.
    subst n; constructor; auto with zarith.
  - case H1; intros n (Hn1,Hn2).
    destruct (Z_0_1_more _ (Z.gcd_nonneg n p)) as [H|[H|H]].
    + exfalso. apply Z.gcd_eq_0_l in H. omega.
    + elim Hn2. red. rewrite <- H. apply Zgcd_is_gcd.
    + exists (Z.gcd n p); split; [ split; auto | apply Z.gcd_divide_r ].
      apply Z.le_lt_trans with n; auto with zarith.
      apply Z.divide_pos_le; auto with zarith.
      apply Z.gcd_divide_l.
Qed.


Require Import Category4.
Require Import Category2.

(* given a Category4, we define the data necessary to create a Category2 *)

Definition dom_ (c:Category4) (f:Mor4 c) : Obj4 c := dom4 c f.
Definition cod_ (c:Category4) (f:Mor4 c) : Obj4 c := cod4 c f.
Definition compose2_ (c:Category4) (f g:Mor4 c) : option (Mor4 c) := compose4 c f g.
Definition id_ (c:Category4) (a:Obj4 c) : Mor4 c := id4 c a.

Definition proof_sid_ (c:Category4) : forall (a:Obj4 c), dom_ c (id_ c a) = a.
Proof. apply (proof_sid4 c). Qed.

Definition proof_tid_ (c:Category4) : forall (a:Obj4 c), cod_ c (id_ c a) = a.
Proof. apply (proof_tid4 c). Qed.

Definition proof_dom2_ (c:Category4) : forall (f g:Mor4 c),
    cod_ c f = dom_ c g <-> compose2_ c f g <> None.
Proof. apply (proof_dom4 c). Qed.

Definition proof_src2_ (c:Category4) : forall (f g h:Mor4 c),
    compose2_ c f g = Some h -> dom_ c h = dom_ c f.
Proof. apply (proof_src4 c). Qed.

Definition proof_tgt2_ (c:Category4) : forall (f g h:Mor4 c),
    compose2_ c f g = Some h -> cod_ c h = cod_ c g.
Proof. apply (proof_tgt4 c). Qed.

Definition proof_idl2_ (c:Category4) : forall (a:Obj4 c) (f:Mor4 c),
    a = dom_ c f -> compose2_ c (id_ c a) f = Some f.
Proof. apply (proof_idl4 c). Qed.

Definition proof_idr2_ (c:Category4) : forall (a:Obj4 c) (f:Mor4 c),
    a = cod_ c f -> compose2_ c f (id_ c a) = Some f.
Proof. apply (proof_idr4 c). Qed.

Definition proof_asc2_ (c:Category4) : forall (f g h fg gh:Mor4 c),
    compose2_ c f g  = Some fg ->
    compose2_ c g h  = Some gh ->
    compose2_ c f gh = compose2_ c fg h.
Proof. apply (proof_asc4 c). Qed.

Definition toCategory2 (c:Category4):Category2 (Obj4 c) (Mor4 c) := category2
    (dom_               c)
    (cod_               c)
    (compose2_          c)
    (id_                c)
    (proof_sid_         c)
    (proof_tid_         c)
    (proof_dom2_        c)
    (proof_src2_        c)
    (proof_tgt2_        c)
    (proof_idl2_        c)
    (proof_idr2_        c)
    (proof_asc2_        c) .


(** * Iterators

    Throughout this discussion we'll work with an [Iterator] interface
    and various concrete classes which implement [Iterator].

    ** Iterator Interface

    We'll start with a Java code example that consumes the [Iterator]
    interface:

[[
Iterator<int> it = getIteratorSomehow();
it.forth();

while (!it.after()) {

  doSomethingWithAnInt(it.item());
  it.forth();
}
]]

    N.B. This is not Java's standard [Iterator<E>] interface [[1]].

    An [Iterator] has three states:

    - _Start_: [Iterator] has not retrieved the first item.
    - _Intermediate_: [Iterator] has retrieved an item and is ready to
      retrieve the next item.
    - _Stop_: [Iterator] ran out of items.

    These three states are encoded by two boolean functions:

    - [off]: [false] if [Iterator] has a current item.
    - [after]: [true] if [Iterator] ran out of items.

    The states are encoded by [off] and [after] as follows:

    - _Start_: [off = true /\ after = false].
    - _Intermediate_: [off = false /\ after = false].
    - _Stop_: [off = true /\ after = true].

    N.B. [off = false /\ after = true] represents an invalid state.

    The [Iterator] moves to the next state or the next item when we call
    [forth]. If we consider the [Iterator] as a transition system [[2]]
    the set of state transition labelled by [forth] is:

    - (_Start_, _Intermediate_).
    - (_Start_, _Stop_).
    - (_Intermediate_, _Intermediate_).
    - (_Intermediate_, _Stop_).

    We call [item] to retrieve the [Iterator]'s current item.

    In summary, the [Iterator] interface contains the following
    functions:

    - [off]: [false] if [Iterator] has a current item.
    - [after]: [true] if [Iterator] ran out of items.
    - [forth]: move to next state or next item.
    - [item]: retrieve current item.

    ** NatRangeIterator Class

    A [NatRangeIterator] is an [Iterator] whose items are a range of
    [nat]'s. It is defined by two [nat]'s:

    - [first]: the first [nat] returned.
    - [count]: the number of [nat]'s returned before entering _Stop_
    state.

    ** NatMultiplierIterator Class

    A [NatMultiplierIterator] is an [Iterator] whose items are the items
    of another [Iterator] multiplied by a [nat]. It is defined by a
    [nat] [Iterator] and a [nat] multiplier:

    - [inner_iterator]: the source [nat] [Iterator].
    - [multiplier]: the [nat] which multiplies each item of the
      [inner_iterator].

    * Outcomes

    The outcomes of this discussion are:

    - An [Iterator] specification (in the form of a Coq function) which
      tests if an implementation specification (either a concrete class or
      a sub-interface) conforms to [Iterator].
    - A [NatRangeIterator] specification describing the behavior with
      respect to [first] and [count].
    - Proof that the [NatRangeIterator] specification conforms to the
      [Iterator] specifiation.
    - A [NatMultiplierIterator] specification describing the behavior
      with respect to [inner_iterator] and [multiplier].
    - Proof that the [NatMultiplierIterator] specification conforms to
      the [Iterator] specification.
    - A [Main] function which is a closed term that composes a
      [NatRangeIterator] with a [NatMultiplierIterator] to produce some
      output.
    - Proof that [Main] produces the expected output.

    * Naming Conventions

    This project uses function names from Eiffel's base library wherever
    possible. For example [off], [after], [forth], and [item] were
    inspired by Eiffel's [LINEAR] class [[3]].

    * References

    - [[1]]: https://docs.oracle.com/javase/8/docs/api/java/util/Iterator.html
    - [[2]]: https://en.wikipedia.org/wiki/Transition_system
    - [[3]]: https://www.eiffel.org/files/doc/static/trunk/libraries/base/linear_chart.html *)


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.CCC.
Require Import Coq_Cats.Type_Cat.Type_Cat.

Program Instance unit_Type_term : (𝟙_ Type_Cat)%object :=
{
  terminal := unit;
  t_morph := fun _ _=> tt
}.

Next Obligation. (* t_morph_unique *)
Proof.
  extensionality x.
  destruct (f x); destruct (g x); reflexivity.
Qed.

Local Notation "A × B" := (@Product Type_Cat A B) : object_scope.

(** The cartesian product of types is the categorical notion of products in
    category of types. *)
Program Definition prod_Product (A B : Type) : (A × B)%object :=
{|
  product := (A * B)%type;
  Pi_1 := fst;
  Pi_2 := snd;
  Prod_morph_ex := fun p x y z => (x z, y z)
|}.

Next Obligation. (* Prod_morph_unique *)
Proof.
  extensionality x.
  repeat
    match goal with
      [H : _ = _ |- _] =>
      apply (fun p => equal_f p x) in H
    end.
  basic_simpl.
  destruct (f x); destruct (g x); cbn in *; subst; trivial.
Qed.

Program Instance Type_Cat_Has_Products : Has_Products Type_Cat := prod_Product.

(** The function type in coq is the categorical exponential in the category of
    types. *)
Program Definition fun_exp (A B : Type_Cat) : (A ⇑ B)%object :=
{|
  exponential := A -> B;
  eval := fun x => (fst x) (snd x);
  Exp_morph_ex := fun h z u v=>  z (u, v)
|}.

Next Obligation. (* Exp_morph_unique *)
Proof.
  extensionality a; extensionality x.
  repeat
    match goal with
      [H : _ = _ |- _] =>
      apply (fun p => equal_f p (a, x)) in H
    end.
  transitivity (f (a, x)); auto.
Qed.

(* fun_exp defined *)

Program Instance Type_Cat_Has_Exponentials : Has_Exponentials Type_Cat := fun_exp.

(* Category of Types is cartesian closed *)

Program Instance Type_Cat_CCC : CCC Type_Cat.


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

Require Import List Arith NArith NPeano Ascii String.

Set Implicit Arguments.

Local Open Scope string_scope.

Local Definition natToDigit (n : nat) : string :=
  match n with
    | 0 => "0"
    | 1 => "1"
    | 2 => "2"
    | 3 => "3"
    | 4 => "4"
    | 5 => "5"
    | 6 => "6"
    | 7 => "7"
    | 8 => "8"
    | _ => "9"
  end.

Local Definition NToDigit (n : N) := natToDigit (N.to_nat n).

Local Fixpoint writeNatAux (time n : nat) (acc : string) : string :=
  let acc' := natToDigit (n mod 10) ++ acc in
  match time with
    | 0 => acc'
    | S time' =>
      match n / 10 with
        | 0 => acc'
        | n' => writeNatAux time' n' acc'
      end
  end.

Local Fixpoint writeNAux (time : nat) (n : N) (acc : string) : string :=
  let acc' := NToDigit (n mod 10)%N ++ acc in
  match time with
    | 0 => acc'
    | S time' =>
      match (n / 10)%N with
        | N0 => acc'
        | n' => writeNAux time' n' acc'
      end
  end.

Section N_to_string.

  Let loop := fix loop l n s :=
    let (d,r) := N.div_eucl n 10 in
    let s'    := String (ascii_of_N (48+r)) s
    in match d, l with
         | N0, _   => s'
         | _ , 0   => s'
         | _ , S l => loop l d s'
    end.

  (* We limit the display of N to 10^12 *)

  Definition string_of_N n :=
    match n with
      | N0 => "0"
      | _  => loop 12 n EmptyString
    end.

End N_to_string.

Definition string_of_nat n := writeNatAux n n "".

(*
Eval compute in string_of_N 123456789012309271072.
*)


From mathcomp Require Export fintype ssrbool seq choice ssreflect finset.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Notation "∅" := set0.
Notation "x ∈ X" := (x \in X)(at level 60).
Notation "A ∩ B" := (setI A B)(at level 40).
Notation "A ∪ B" := (setU A B)(at level 40).
Notation "A ⊂ B" := (A \subset B)(at level 30).
Notation "A // B" := (setD A B)(at level 40).
Notation "¬ A" := (setC A)(at level 40).
Notation "pow[ A ]" := (powerset A).
Notation "∅" := set0.

Lemma extension {T : finType} (A B : {set T}) :
    A ⊂ B -> B ⊂ A -> A = B.
Proof.
    move => AB BA; apply /setP /subset_eqP /andP => //.
Qed.

Lemma set_enum {T : finType} (A : {set T}) :
    [set x | x \in enum A] = A.
Proof.
    by apply/setP => x; rewrite inE mem_enum .
Qed.

Axiom bigcup : forall {T : finType}, {set {set T}} -> {set T}.
Axiom bigcupP : forall {T : finType} (XX : {set {set T}}) (X : T),
    reflect (exists (Y : {set T}), X ∈ Y /\ Y ∈ XX) (X ∈ bigcup XX).

Axiom bigcap : forall {T : finType}, {set {set T}} -> {set T}.
Axiom bigcapP : forall {T : finType} (XX : {set {set T}}) (X : T),
    reflect (forall (Y : {set T}), Y ∈ XX -> X ∈ Y) (X ∈ bigcup XX).


(** * Abstract theory of coinduction

  See
  Coinduction All the Way Up. Damien Pous. In Proc. LICS, 2016.
  http://dx.doi.org/10.1145/2933575.2934564
  https://hal.archives-ouvertes.fr/hal-01259622/document

*)

Require Export lattice.
Require Classical.              (* only for distributivity of the companion *)
Set Implicit Arguments.

(** * Knaster-Tarski and compatibility  *)

Section s1.
 Context {X} {L: CompleteLattice X}.

 Variable b: mon X.

 (** ** compatible functions *)
 Notation compat f := (f ° b <= b ° f) (only parsing).

 (** compositionality properties of compatibility *)
 Lemma compat_id: compat id.
 Proof. reflexivity. Qed.

 Lemma compat_comp f g: compat f -> compat g -> compat (f ° g).
 Proof.
   intros Hf Hg.
   rewrite <-compA, Hg.
   rewrite compA, Hf.
   now rewrite compA.
 Qed.

 Lemma compat_b: compat b.
 Proof. reflexivity. Qed.

 Lemma compat_const y: y <= b y -> compat (const y).
 Proof. now intros ??. Qed.

 Lemma compat_sup (P: mon X -> Prop):
   (forall f, P f -> compat f) -> compat (sup P).
 Proof.
   intros H x. simpl. apply sup_spec. intros f Pf.
   rewrite (H _ Pf x). apply b. eapply eleq_xsup; eauto.
 Qed.

 (** ** companion *)

 (** the companion is the largest compatible function *)
 Definition t := sup (fun f => compat f).

 Lemma compat_t: compat t.
 Proof. now apply compat_sup. Qed.

 (** ** Knaster Tarski *)

 (** we will show that [t bot] is the greatest fixpoint of [b] (Theorem 3.3),
     whence the following definition *)
 Definition gfp := t bot.

 (** [gfp] is a post-fixpoint *)
 Proposition gfp_pfp: gfp <= b gfp.
 Proof.
   transitivity (t (b bot)).
   now apply t.
   apply compat_t.
 Qed.
 (** and actually the greatest one *)
 Proposition leq_gfp y: y <= b y -> y <= gfp.
 Proof.
   intro H.
   assert (H': const y <= t) by now apply leq_xsup, compat_const.
   apply (H' bot).
 Qed.

 (** thus a fixpoint, as in Knaster-Tarski's proof *)
 Theorem gfp_fp: gfp == b gfp.
 Proof.
   apply antisym. apply gfp_pfp.
   apply leq_gfp. apply b, gfp_pfp.
 Qed.

 (** more properties about [t] (Lemma 3.2) *)
 Lemma leq_t f: compat f -> f <= t.
 Proof. intro; now apply leq_xsup. Qed.

 Lemma id_t: id <= t.
 Proof. apply leq_t, compat_id. Qed.

 Lemma b_t: b <= t.
 Proof. apply leq_t, compat_b. Qed.

 Lemma tt_t: t ° t <= t.
 Proof. apply leq_t, compat_comp; apply compat_t. Qed.

 Lemma ft_t f: f <= t -> f ° t <= t.
 Proof. intro H. rewrite H. apply tt_t. Qed.

 Lemma t_idem: t ° t == t.
 Proof. apply antisym. apply tt_t. now rewrite <-id_t at 2. Qed.

 (** 'guarded companion', convenient later for expressing the [coinduction] and [accumulate] rules *)
 Definition bt := b ° t.

 Lemma bt_t: bt <= t.
 Proof. apply ft_t, b_t. Qed.

 Lemma fbt_bt {f}: f <= t -> f°bt <= bt.
 Proof. intro H. unfold bt. rewrite H. now rewrite compA, compat_t, <-compA, tt_t. Qed.

 (** to sum up: [gfp = t bot = t gfp <= t x] *)
 (** Corollary 3.4 *)
 Corollary t_gfp: t gfp == gfp.
 Proof. apply t_idem. Qed.

 Corollary gfp_t x: gfp <= t x.
 Proof. now apply t. Qed.

 Corollary gfp_bt x: gfp <= bt x.
 Proof. now rewrite gfp_pfp, (gfp_t x) . Qed.

 Lemma leq_f_ft f: f <= f ° t.
 Proof. now rewrite <-id_t. Qed.
 Lemma leq_f_tf f: f <= t ° f.
 Proof. now rewrite <-id_t. Qed.

End s1.
Notation compat b f := (f ° b <= b ° f) (only parsing).
#[export] Typeclasses Opaque t.
Global Opaque t.

Section s2.
 Context {X} {L: CompleteLattice X}.

 (** [gfp] is monotone, as a function from [mon X] to [X]
     (be careful: [t] is not monotone from [mon X] to [mon X]) *)
 Instance gfp_leq: Proper (leq ==> leq) gfp.
 Proof. intros b b' Hb. apply leq_gfp. rewrite gfp_fp at 1. apply Hb. Qed.
 Instance gfp_weq: Proper (weq ==> weq) gfp := op_leq_weq_1.

 Variable b: mon X.

 (** [t] is intended to be used as an up-to technique, to play with
     [b' = b ° t] rather than just [b].
    The following proposition (Equation 11) shows that we would not get
    anything new by iterating this idea. *)
 Notation bt := (bt b).
 Notation t' := (t bt).
 Notation t := (t b).
 Proposition stagnate_t: t == t'.
 Proof.
   unfold bt.
   apply antisym'. apply leq_t. now rewrite compA, compat_t.
   intro E. apply leq_t.
   rewrite (leq_f_ft b b) at 3.
   rewrite compat_t.
   rewrite <-compA. rewrite E at 1.
   now rewrite tt_t.
 Qed.

 (** as a corollary, [b'] is a valid enhancement of [b] (Theorem 3.6) *)
 Corollary enhanced_gfp: gfp b == gfp bt.
 Proof. apply stagnate_t. Qed.

 (** and we get a unique enhanced coinduction principle *)
 Corollary coinduction x: x <= bt x -> x <= gfp b.
 Proof. intro. rewrite enhanced_gfp. now apply leq_gfp. Qed.

End s2.

(** * Compatibility up-to: second order reasoning *)

Section s3.
 Context {X} {L: CompleteLattice X}.
 Variable b: mon X.

 (** a function whose post-fixpoints are the compatible functions (Definition 6.1) *)
 Program Definition B: mon (mon X) :=
   {| body g := sup (fun f => f ° b <= b ° g) |}.
 Next Obligation.
   intros g g' Hg x. apply sup_leq; trivial.
   intros f Hf z. now rewrite <-(Hg z).
 Qed.

 (** Lemma 6.2 *)
 Lemma B_spec f g: f <= B g <-> f ° b <= b ° g.
 Proof.
   split; intro H. rewrite H. intro. apply sup_spec.
   intros h Hh. apply Hh.
   now apply leq_xsup.
 Qed.
 Lemma Bfb f: B f ° b <= b ° f.
 Proof. now apply B_spec. Qed.

 (** the companion of [b] is the greatest fixpoint of [B] *)
 Theorem companion_gfp: t b == gfp B.
 Proof.
  apply antisym.
   apply leq_gfp. rewrite B_spec. apply compat_t.
   apply leq_t. rewrite <-B_spec. apply gfp_pfp.
 Qed.

 (** [T] is the companion of [B] *)
 Definition T := t B.
 Definition bT f := comp b (T f).
 Notation t := (t b).
 Notation bt := (bt b).

 (** corresponding second-order coinduction principle *)
 Corollary Coinduction f: f ° b <= bT f -> f <= t.
 Proof. unfold bT. rewrite <-B_spec, companion_gfp. apply coinduction. Qed.

 (** ** properties of the second order companion (Proposition 6.4) *)

 (** the squaring function is compatible for [B] (Lemma 6.3) *)
 Program Definition csquare: mon (mon X) := {| body f := f ° f |}.
 Next Obligation. intros ? ? ?. now apply comp_leq. Qed.
 Lemma compat_csquare: compat B csquare.
 Proof.
   intro f. apply B_spec. change (B f ° B f ° b <= b ° f ° f).
   rewrite <-compA, Bfb.
   now rewrite compA, Bfb.
 Qed.

 (** so is the constant-to-identity function *)
 Lemma compat_constid: const id ° B <= B ° const id.
 Proof. intro f. now apply B_spec. Qed.

 (** thus [T f] is always an idempotent function  *)
 Proposition TT_T f: T f ° T f <= T f.
 Proof. apply (ft_t (leq_t compat_csquare)). Qed.
 Proposition id_T f: id <= T f.
 Proof. apply (ft_t (leq_t compat_constid)). Qed.
 Corollary T_idem f: T f ° T f == T f.
 Proof. apply antisym. apply TT_T. now rewrite <-id_T at 2. Qed.

 (** [T f] always contains [f], [t], [b], and [gfp b] *)
 Lemma f_Tf f: f <= T f.
 Proof. apply id_t. Qed.
 Lemma t_T f: t <= T f.
 Proof. rewrite companion_gfp. apply gfp_t. Qed.
 Lemma bt_bT f: bt <= bT f.
 Proof. unfold bt, bT. now rewrite t_T. Qed.
 Lemma b_T f: b <= T f.
 Proof. rewrite b_t. apply t_T. Qed.
 Lemma bT_T f: bT f <= T f.
 Proof. unfold bT. rewrite (b_T f). apply TT_T. Qed.
 Lemma bt_T f: bt <= T f.
 Proof. rewrite bt_t. apply t_T. Qed.

 Lemma gfp_bT f x: gfp b <= bT f x.
 Proof. rewrite <-bt_bT. apply gfp_bt. Qed.
 Lemma gfp_T f x: gfp b <= T f x.
 Proof. rewrite <-t_T. apply gfp_t. Qed.

 (** helpers, to extract components out of [T]  *)
 Lemma fT_T_ f g: f <= T g -> f ° T g <= T g.
 Proof. intro H. rewrite H. apply TT_T. Qed.
 Lemma fTf_Tf f: f ° T f <= T f.
 Proof. apply fT_T_, f_Tf. Qed.
 Lemma fT_T f: f <= t -> forall g, f ° T g <= T g.
 Proof. intros H g. apply fT_T_. rewrite H. apply t_T. Qed.
 Lemma Tf_T f g: f <= T g -> T g ° f <= T g.
 Proof. intro H. rewrite H. apply TT_T. Qed.
 Lemma Cancel f g x y: f <= T g -> x <= T g y -> f x <= T g y.
 Proof. intros Hf Hx. rewrite Hx. now apply fT_T_. Qed.

 Lemma fbT_bT {f}: f <= t -> forall g, f°bT g <= bT g.
 Proof. intros H g. unfold bT. rewrite H. now rewrite compA, compat_t, <-compA, fT_T. Qed.

 (** [T f R] is always of the shape [t _] *)
 Lemma T_tT f: T f == t ° T f.
 Proof.
   apply antisym.
   - intro. apply id_t.
   - rewrite t_T. apply TT_T.
 Qed.
 (** [bt R] is always of the shape [t _] *)
 Lemma bt_tbt: bt == t ° bt.
 Proof.
   apply antisym.
   - intro. apply id_t.
   - now apply fbt_bt.
 Qed.

 (** we can thus transfer universal properties of [t] to [bt], [T], and [bT]
     (not used yet)
  *)
 Lemma Pt_PTf (P: X -> Prop) (H: forall R, P (t R)) (H': Proper (weq ==> leq) P): forall f R, P (T f R).
 Proof. intros f R. rewrite T_tT. apply H. Qed.
 Lemma Pt_Pbt (P: X -> Prop) (H: forall R, P (t R)) (H': Proper (weq ==> leq) P): forall R, P (bt R).
 Proof. intros R. rewrite bt_tbt. apply H. Qed.
 Lemma Pt_PbTf (P: X -> Prop) (H: forall R, P (t R)) (H': Proper (weq ==> leq) P): forall f R, P (bT f R).
 Proof. intros f R. unfold bT. rewrite T_tT. apply (Pt_Pbt H H' _). Qed.
 (* TOTHINK:
    in fact, universal properties of [t] are universal properties of elements of [chain.S] below
  *)

 (** * Parametric coinduction: the accumulation rule  *)

 Program Definition xaccumulate y x: mon X :=
   {| body z := sup' (fun _:unit => x <= z) (fun _:unit => y) |}.
 Next Obligation.
   intros z z' Hz. apply sup_leq; trivial.
   intros _ H. now rewrite H.
 Qed.

 (** Theorem 10.2 *)
 Theorem accumulate y x: y <= bt (cup x y) -> y <= t x.
 Proof.
   intro H. set (f:=xaccumulate y x).
   assert (E: y <= f x) by now eapply eleq_xsup; eauto.
   cut (f <= t). intro F. now rewrite E.
   apply Coinduction. intro z. apply sup_spec. intros _ Hxz.
   rewrite H. apply b. apply Cancel. apply t_T.
   apply cup_spec. split.
   rewrite Hxz. apply b_T.
   rewrite E, Hxz. apply Cancel. apply f_Tf. apply b_T.
 Qed.

End s3.
#[export] Typeclasses Opaque B T.
Global Opaque B.

(** * Symmetry arguments *)

Section symmetry.
 (** we use a class to record the involution: this makes it possible to
     find the appropriate involution automativally in concrete examples  *)
 Context {X} {L: CompleteLattice X} {i: mon X}.
 Class Involution := invol: i ° i == id.
 Context {I: Involution}.

 Lemma invol' x: i (i x) == x.
 Proof. apply invol. Qed.

 Lemma switch x y: i x <= y <-> x <= i y.
 Proof. split; (intro H; apply i in H; now rewrite invol' in H). Qed.

 Lemma Switch f g: i ° f <= g <-> f <= i ° g.
 Proof. split; (intros H x; apply switch, H). Qed.

 Lemma compat_if_fi f: compat i f -> compat f i.
 Proof. intro H; apply Switch. now rewrite compA, <-H, <-compA, invol. Qed.

 (** [b] is assumed to be of the shape [s /\ i s i]
     we use a class to record such a fact, so that the end-user may use syntactically different definitions and yet be able to declare a function as being of this shape.
  *)

 Context {b s: mon X}.
 Class Sym_from := sym_from: b == (cap s (i ° s ° i)).
 Context {H: Sym_from}.
 Notation B := (B b).
 Notation T := (T b).
 Notation t := (t b).
 Notation bt := (bt b).
 Notation bT := (bT b).

 (** [i] is compatible  *)
 Lemma compat_invol: compat b i.
 Proof.
   rewrite sym_from.
   rewrite o_mcap, 2compA, invol.
   rewrite mcap_o, <-2compA, invol.
   now rewrite capC.
 Qed.

 (** thus below [t]  *)
 Lemma invol_t: i <= t.
 Proof. apply leq_t, compat_invol. Qed.

 (** reasoning by symmetry on plain post-fixpoints *)
 Proposition symmetric_pfp x: i x <= x -> x <= s x -> x <= b x.
 Proof.
   intros ix sx. rewrite sym_from. apply cap_spec. split. assumption.
   apply switch. rewrite ix at 1. apply switch in ix. now rewrite <-ix.
 Qed.

 (** reasoning by symmetry at the first level *)
 Proposition by_symmetry x y: i x <= x -> x <= s (t y) -> x <= bt y.
 Proof.
   assert(it: i ° t == t). apply antisym'. apply ft_t, invol_t. apply Switch.
   intros Hx Hxy. rewrite (sym_from (t y)). apply cap_spec. split. assumption.
   apply switch. rewrite Hx, Hxy. now rewrite (it y).
 Qed.

 (** reasoning by symmetry at the second level *)
 Proposition by_Symmetry f g: compat i f -> f ° b <= s ° (T g) -> f ° b <= bT g.
 Proof.
   intros Hf Hfg. apply compat_if_fi in Hf.
   unfold bT. rewrite sym_from at 2.
   rewrite mcap_o. apply cap_spec. split. assumption.
   change (f ° b <= i ° (s ° i ° T g)). apply Switch.
   rewrite compA, Hf.
   rewrite <-compA, compat_invol.
   rewrite compA, Hfg, <-2(compA s).
   apply comp_leq. reflexivity.
   assert (iT: i <= T g). rewrite invol_t at 1. apply t_T.
   rewrite iT at 1. setoid_rewrite TT_T.
   apply Switch. apply fT_T_, iT.
 Qed.

End symmetry.
Arguments Involution {_ _} _.
Arguments Sym_from {_ _} _ _ _.

(** obvious instance of [Sym_from] (default) *)
#[export] Instance sym_from_def {X} {L: CompleteLattice X} {i s: mon X}: Sym_from i (cap s (i ° s ° i)) s.
Proof. now cbn. Qed.

(** * Proof system *)

Section proof_system.
 Context {X} {L: CompleteLattice X}.

 Variable b: mon X.
 Notation B := (B b).
 Notation T := (T b).
 Notation t := (t b).
 Notation bt := (bt b).

 Lemma rule_init y: y <= t bot -> y <= gfp b.
 Proof. now intro. Qed.

 Lemma rule_done y x: y <= x -> y <= t x.
 Proof. now rewrite <-id_t. Qed.

 Lemma rule_upto f y x: f <= t -> y <= f (t x) -> y <= t x.
 Proof. intros Hf Hy. now rewrite <- (ft_t Hf). Qed.

 Lemma rule_coind y x: y <= bt (cup x y) -> y <= t x.
 Proof. apply accumulate. Qed.

End proof_system.

(** * Coincidence of the greatest respectful and the greatest compatible *)

Module respectful.
Section s.
 Context {X} {L: CompleteLattice X}.

 Variable b: mon X.
 Notation b' := (cap b id).
 Notation t' := (t b').
 Notation B' := (B b').
 Notation T' := (T b').
 Notation B := (B b).
 Notation T := (T b).
 Notation t := (t b).

 Lemma b_b't: b <= b' ° t.
 Proof.
   rewrite mcap_o. apply cap_spec. split.
    now rewrite <-id_t.
    apply b_t.
 Qed.

 (** Proposition 9.1  *)
 Proposition t_t': t == t'.
 Proof.
   apply antisym'.
    apply leq_t. rewrite cap_l at 1.
    rewrite compat_t. rewrite b_b't at 1. now rewrite <-compA, tt_t.
   intro E. apply leq_t. rewrite b_b't at 2.
   rewrite compA, compat_t.
   rewrite E. rewrite <-compA, tt_t.
   now rewrite cap_l at 1.
 Qed.

 Proposition bt_b't: b ° t == b' ° t.
 Proof.
   apply antisym.
    rewrite b_b't at 1. now rewrite <-compA, tt_t.
    now rewrite cap_l.
 Qed.

 Lemma B'S_BS: forall S, S=T \/ S=T' -> B' ° S == B ° S.
 Proof.
   intros S HS g.
   assert (tS: t ° S g <= S g). destruct HS as [->| ->].
    now apply fT_T.
    rewrite t_t'. now apply fT_T.
   assert (St: S g ° t <= S g). destruct HS as [->| ->].
    apply Tf_T, t_T.
    rewrite t_t'. apply Tf_T, t_T.
   apply from_below. intro f.
   change (f <= B' (S g) <-> f <= B (S g)). rewrite 2B_spec.
   split; intro H.
   rewrite b_b't at 1. rewrite compA, H. rewrite <-compA, St.
   now rewrite cap_l.
   rewrite cap_l at 1. rewrite H. rewrite b_b't at 1.
   now rewrite <-tS at 2.
 Qed.

 (** Proposition 9.2  *)
 Proposition T'_T: T' == T.
 Proof.
   apply antisym; apply leq_t.
   transitivity (T' ° B ° T'). now setoid_rewrite <-id_t at 3.
   rewrite <-compA. rewrite <-B'S_BS by tauto.
   rewrite compA. setoid_rewrite compat_t.
   now rewrite <-compA, tt_t.
   transitivity (T ° B' ° T). now setoid_rewrite <-id_t at 3.
   rewrite <-compA. rewrite B'S_BS by tauto.
   rewrite compA. setoid_rewrite compat_t.
   now rewrite <-compA, tt_t.
 Qed.

 Proposition B'T'_BT: B' ° T' == B ° T.
 Proof. rewrite T'_T. apply B'S_BS. tauto. Qed.

 (* note that B≠B' in general *)

End s.
End respectful.

Global Opaque T.

(** * Characterisation of Hur et al.' function G using the companion *)

Module paco.
Section s.

 Context {X} {L: CompleteLattice X}.

 Program Definition g (b: mon X) x: mon X := {| body y := b (cup x y) |}.
 Next Obligation. intros y z H. now rewrite H. Qed.

 Program Definition G b: mon X := {| body x := gfp (g b x) |}.
 Next Obligation.
   intros ? ? ?. apply gfp_leq.
   intro. simpl. now rewrite H.
 Qed.

 Variable b: mon X.
 Notation t := (t b).
 Notation bt := (bt b).
 Notation G' := (G bt).

 (** Theorem 10.1 *)
 Theorem G_bt: G' == bt.
 Proof.
   apply antisym.
    assert (E: G' <= t).
     intro x. apply rule_coind. simpl. now rewrite gfp_fp at 1.
    intro x. simpl. rewrite gfp_fp. simpl. apply b.
    rewrite (E x). rewrite <-(tt_t b x) at 2. apply t. apply cup_spec. split.
    apply id_t. reflexivity.
   intro. simpl. apply leq_gfp. simpl. apply b, t, cup_l.
 Qed.

 Proposition G_upto: G' == t ° G'. (* i.e., bt = tbt *)
 Proof.
   rewrite G_bt. apply antisym. intro. apply id_t.
   unfold bt. now rewrite compA, compat_t, <-compA, tt_t.
 Qed.

 (* note: tb < bt = tbt < t *)
End s.
End paco.

(** * alternative definition of the companion, using Kleene iteration *)
Module chain.
Section s.
 Context {X} {L: CompleteLattice X}.
 Variable b: mon X.
 Notation t := (t b).
 Inductive S: X -> Prop :=
 | Sb: forall x, S x -> S (b x)
 | Sinf: forall T, T <= S -> S (inf T).
 Lemma gfpS: gfp b == inf S.
 Proof.
   apply antisym. apply inf_spec. simpl. intros u U. induction U.
   rewrite gfp_pfp. now apply b. now apply inf_spec.
   apply leq_gfp. apply leq_infx. now apply Sb, Sinf.
 Qed.
 Lemma tS: forall s, S s -> t s == s.
 Proof.
   intros s H. apply antisym. 2: apply id_t.
   induction H as [s Hs IH|T HT IH].
   rewrite (compat_t b s). now apply b.
   apply inf_spec. intros s Hs. rewrite <-(IH _ Hs). apply t. now apply leq_infx.
 Qed.
 Definition S_ x s := S s /\ x <= s.
 Definition t'_ x := inf (S_ x).
 Lemma t'_mon: Proper (leq ==> leq) t'_.
 Proof.
   intros x y H. apply inf_spec; intros s [Ss E]. apply leq_infx.
   split. assumption. now rewrite H.
 Qed.
 Definition t' := Build_mon t'_mon.
 Lemma id_t' x: x <= t' x.
 Proof. apply inf_spec. now intros s [_ ?]. Qed.
 Lemma St' x: S (t' x).
 Proof. apply Sinf. now intros ? [? ?]. Qed.
 Lemma compat_t': t' ° b <= b ° t'.
 Proof.
   intro x. simpl. apply leq_infx. split.
   apply Sb. apply St'. apply b. apply id_t'.
 Qed.

 Theorem tt': t == t'.
 Proof.
   apply antisym.
   intro x. rewrite (id_t' x) at 1. now rewrite tS by apply St'.
   apply leq_t, compat_t'.
 Qed.

 Corollary leq_t' f: f <= t <-> forall s, S s -> f s <= s.
 Proof.
   split.
   intros E s H. now rewrite (E s), tS.
   intros H. apply Coinduction. intro x. simpl.
   rewrite (id_t' x) at 1. rewrite H by apply Sb, St'.
   apply b. rewrite <-tt'. apply t_T.
 Qed.

 Lemma St x: S (t x).
 Abort.
 Lemma St x: exists tx, S tx /\ tx == t x.
 Proof. exists (t' x). split. apply St'. now rewrite tt'. Qed.

 Lemma Sflat s: S s -> exists T, T<=S /\ s == inf' T b.
 Proof.
   induction 1 as [s Hs IH|T HT IH].
   exists (eq s). split. now intros ? <-.
   apply antisym. apply inf_spec. now intros ? <-.
   eapply eleq_infx; eauto.
   (* exists (fun t => exists a (A: T a), match IH a A return Prop with ex_intro _ U _ => U t end). *)
 Abort.

 Lemma Sflat s: S s -> s == inf' (fun t => S t /\ s <= b t) b.
 Proof.
   intro E. apply antisym. now apply inf_spec; intros t [_ T].
   induction E as [s Hs IH|T HT IH].
   eapply eleq_infx; eauto.
   apply inf_spec. intros s Hs.
   rewrite <- (IH s Hs). apply inf_leq; trivial.
   intros t [St sbt]. split. assumption.
   rewrite <-sbt. now apply leq_infx.
 Qed.

 (** * additivity of the companion (assuming classical logic) *)

 Import Classical.
 Lemma choose (P A B: X -> Prop): (forall x, P x -> A x \/ B x) -> (exists x, P x /\ B x) \/ (forall x, P x -> A x).
 Proof.
   intro H. classical_right. intros x Px.
   destruct (H _ Px). assumption. exfalso; eauto.
 Qed.

 Lemma S_linear x y: S x -> S y -> x <= y \/ y <= x.
 Proof.
   intro Sx. revert y. induction Sx as [x Hx IH|T HT IH]; intros y Sy.
   - pose proof (Sflat Sy) as E.
     set (T t := S t /\ y <= b t) in E.
     assert (IH': forall y, T y -> x <= y \/ y <= x). intros t Tt. apply IH, Tt.
     destruct (choose _ _ _ IH') as [[s [Ss sx]]|F].
     right. rewrite E, <-sx. eapply eleq_infx; eauto.
     left. rewrite E. apply inf_spec; intros s Ts. now apply b, F.
   - assert (IH': forall a, T a -> y <= a \/ a <= y). intros a A. specialize (IH _ A _ Sy). tauto.
     destruct (choose _ _ _ IH') as [[s [Ss sx]]|F].
     left. rewrite <-sx. now apply leq_infx.
     right. apply inf_spec; intros t Tt. now apply F.
 Qed.

 Lemma tcup x y: t (cup x y) == cup (t x) (t y).
 Proof.
   apply antisym.
   transitivity (t (cup (t' x) (t' y))).
   apply t. apply cup_leq; apply id_t'.
   destruct (S_linear (St' x) (St' y)) as [xy|yx].
   transitivity (t (t' y)). apply t. apply cup_spec. now split.
   rewrite <-tt', (tt_t b y). apply cup_r.
   transitivity (t (t' x)). apply t. apply cup_spec. now split.
   rewrite <-tt', (tt_t b x). apply cup_l.
   apply cup_spec. split; apply t. apply cup_l. apply cup_r.
 Qed.

End s.
End chain.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.uni.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module ResponseTime.

  Import UniprocessorSchedule SporadicTaskset TaskArrival.

  (* In this section, we define the notion of response-time bound. *)
  Section ResponseTimeBound.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* For simplicity, let's define some local names. *)
    Let job_has_completed_by := completed_by job_cost sched.

    Section Job.

      (* Given any job j, ... *)
      Variable j: Job.

      (* ...we say that R is a response-time bound of j in this schedule ... *)
      Variable R: time.

      (* ... iff j completes by (job_arrival j + R). *)
      Definition is_response_time_bound_of_job := job_has_completed_by j (job_arrival j + R).

    End Job.

    Section Task.

      (* Let tsk be any task that is to be analyzed. *)
      Variable tsk: sporadic_task.

      (* Then, we say that R is a response-time bound of tsk in this schedule ... *)
      Variable R: time.

      (* ... iff any job j of tsk in this arrival sequence has
         completed by (job_arrival j + R). *)
      Definition is_response_time_bound_of_task :=
        forall j,
          arrives_in arr_seq j ->
          job_task j = tsk ->
          is_response_time_bound_of_job j R.

      End Task.

  End ResponseTimeBound.

  (* In this section, we prove some basic lemmas about response-time bounds. *)
  Section BasicLemmas.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* Assume that jobs don't execute after completion. *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* For simplicity, let's define some local names. *)
    Let response_time_bounded_by := is_response_time_bound_of_job job_arrival job_cost sched.

    (* We begin by proving lemmas about job response-time bounds. *)
    Section SpecificJob.

      (* Let j be any job... *)
      Variable j: Job.

      (* ...with response-time bound R. *)
      Variable R: time.
      Hypothesis response_time_bound: response_time_bounded_by j R.

      (* Then, the service received by j at any time t' after its response time is 0. *)
      Lemma service_after_job_rt_zero :
        forall t',
          t' >= job_arrival j + R ->
          service_at sched j t' = 0.
      Proof.
        rename response_time_bound into RT,
               H_completed_jobs_dont_execute into EXEC; ins.
        unfold is_response_time_bound_of_task, completed_by,
               completed_jobs_dont_execute in *.
        apply/eqP; rewrite eqb0; apply/negP; intros CONTR.
        unfold response_time_bounded_by,is_response_time_bound_of_job in *.
        eapply completion_monotonic in RT; eauto 2.
        apply completed_implies_not_scheduled in RT; eauto 2.
          by move: RT => /negP RT; apply:RT.
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_job_rt_zero :
        forall t' t'',
          t' >= job_arrival j + R ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        ins; apply/eqP; rewrite -leqn0.
        rewrite big_nat_cond; rewrite -> eq_bigr with (F2 := fun i => 0);
          first by rewrite big_const_seq iter_addn mul0n addn0 leqnn.
        intro i; rewrite andbT; move => /andP [LE _].
        by rewrite service_after_job_rt_zero;
          [by ins | by apply leq_trans with (n := t')].
      Qed.

    End SpecificJob.

    (* Next, we prove properties about task response-time bounds. *)
    Section AllJobs.

      (* Consider any task tsk ...*)
      Variable tsk: sporadic_task.

      (* ... for which a response-time bound R is known. *)
      Variable R: time.
      Hypothesis response_time_bound:
        is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched tsk R.

      (* Then, for any job j of this task, ...*)
      Variable j: Job.
      Hypothesis H_from_arrival_sequence: arrives_in arr_seq j.
      Hypothesis H_job_of_task: job_task j = tsk.

      (* ...the service received by job j at any time t' after the response time is 0. *)
      Lemma service_after_task_rt_zero :
        forall t',
          t' >= job_arrival j + R ->
          service_at sched j t' = 0.
      Proof.
        intros t' LE.
        apply service_after_job_rt_zero with (R := R); last by done.
        by apply response_time_bound.
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_task_rt_zero :
        forall t' t'',
          t' >= job_arrival j + R ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        by ins; apply cumulative_service_after_job_rt_zero with (R := R);
          first by apply response_time_bound.
      Qed.

    End AllJobs.

  End BasicLemmas.

End ResponseTime.


Require Import A1_Plan.

Section CLOCKWISE.

(* Il existe une relation sur les triplets de points d'orientation dans le sens des aiguilles d'une montre. *)

Parameter Clockwise : Point -> Point -> Point -> Prop.

Definition HalfPlane (A B : Point) : Figure := Clockwise A B.

Definition EquiOriented (A B C D: Point) : Prop  :=
	forall M : Point, Clockwise A B M -> Clockwise C D M.

Definition EquiDirected := fun A B C D : Point =>
	EquiOriented A B C D \/ EquiOriented A B D C \/
	EquiOriented B A C D \/ EquiOriented B A D C \/
	EquiOriented C D A B \/ EquiOriented C D B A \/
	EquiOriented D C A B \/ EquiOriented D C B A.

Definition OpenRay (A B : Point) : Figure  := EquiOriented A B A.

Definition ClosedRay (A B : Point) : Figure  :=
	fun M : Point => EquiOriented A M A B.

Definition Collinear (A B C : Point) := ~Clockwise A B C /\ ~Clockwise B A C.

Definition Between (A B C : Point) :=
	A <> B /\ EquiOriented A B B C.

Definition Segment (A B : Point) :=
	fun M : Point => ClosedRay A B M /\ ClosedRay B A M.

(* Trois points ne peuvent avoir deux orientations a la fois. *)

Axiom ClockwiseAntisym : forall A B C, ~Clockwise A B C \/ ~Clockwise B A C.

(* La relation d'orientation est stable par permutation circulaire. *)

Axiom ClockwisePerm : forall A B C, Clockwise A B C -> Clockwise B C A.

(* Trois points sont necessairement orientes ou alignes. *)

Axiom FourCases : forall A B C,
	Clockwise A B C \/ Clockwise B A C \/ OpenRay A B C \/ OpenRay B A C.

(* Etant donne un triangle non degenere, tout point est dans le meme demi plan qu'un sommet par rapport au cote oppose. *)

Axiom FourthPoint : forall A B C D,
	Clockwise A B C ->
	Clockwise A B D \/ Clockwise A D C \/ Clockwise D B C.

(* Trois points colineaires partagent le plan en 2. *)

Axiom ChangeSense : forall A B C D,
	EquiOriented A B C D ->
	Collinear A B C ->
	EquiOriented B A D C.

(* Deux droites paralleles partagent le plan en 3. *)

Axiom ChangeSide : forall A B C D,
	EquiOriented A B C D ->
	A <> B ->
	EquiOriented D C B A.

End CLOCKWISE.


Require Export TopologicalSpaces.
Require Export Continuity.
Require Export SubspaceTopology.

Section continuous_factorization.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.
Variable S:Ensemble (point_set Y).
Hypothesis f_cont: continuous f.
Hypothesis f_img: forall x:point_set X, In S (f x).

Definition continuous_factorization :
  point_set X -> point_set (SubspaceTopology S) :=
  fun x:point_set X => exist _ (f x) (f_img x).

Lemma factorization_is_continuous:
  continuous continuous_factorization.
Proof.
red; intros.
destruct (subspace_topology_topology _ _ V H) as [V' []].
rewrite H1.
rewrite <- inverse_image_composition.
simpl.
assert (inverse_image (fun x:point_set X => f x) V' =
        inverse_image f V').
apply Extensionality_Ensembles; split; red; intros.
destruct H2; constructor; trivial.
destruct H2; constructor; trivial.
rewrite H2.
apply f_cont; trivial.
Qed.

End continuous_factorization.

Implicit Arguments continuous_factorization [[X] [Y]].

Section continuous_surj_factorization.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.
Hypothesis f_cont: continuous f.

Definition continuous_surj_factorization :
  point_set X -> point_set (SubspaceTopology (Im Full_set f)).
apply continuous_factorization with f.
intros.
exists x.
constructor.
trivial.
Defined.

Lemma continuous_surj_factorization_is_surjective:
  surjective continuous_surj_factorization.
Proof.
red; intros.
destruct y.
destruct i.
exists x.
unfold continuous_surj_factorization.
unfold continuous_factorization.
pose proof (e).
symmetry in H.
destruct H.
f_equal.
f_equal.
apply proof_irrelevance.
apply proof_irrelevance.
Qed.

Lemma continuous_surj_factorization_is_continuous:
  continuous continuous_surj_factorization.
Proof.
apply factorization_is_continuous.
exact f_cont.
Qed.

End continuous_surj_factorization.

Implicit Arguments continuous_surj_factorization [[X] [Y]].