(* Implementation of positive (non zero) rationals using only nat *)

Require Import Utf8 Arith Morphisms Psatz.
Require Import Misc.

Set Nested Proofs Allowed.

Tactic Notation "flia" hyp_list(Hs) := clear - Hs; lia.
Reserved Notation "a // b" (at level 32).

Declare Scope PQ_scope.
Delimit Scope PQ_scope with PQ.

(* A PQ number {PQnum1:=a; PQden1:=b} represents the rational (a+1)/(b+1) *)

Record PQ := PQmake { PQnum1 : nat; PQden1 : nat }.
Arguments PQmake _%nat _%nat.
Arguments PQnum1 x%PQ : rename.
Arguments PQden1 x%PQ : rename.

Definition PQ_of_pair n d := PQmake (n - 1) (d - 1).
Definition nd x y := (PQnum1 x + 1) * (PQden1 y + 1).
Definition PQeq x y := nd x y = nd y x.

Theorem PQeq_dec : ∀ x y : PQ, {PQeq x y} + {¬ PQeq x y}.
Proof. intros; apply Nat.eq_dec. Qed.
Arguments PQeq_dec x%PQ y%PQ.

Definition if_PQeq {A} (P Q : A) x y := if PQeq_dec x y then P else Q.
Arguments if_PQeq _ _ _ x%PQ y%PQ.

Definition PQlt x y := nd x y < nd y x.
Definition PQle x y := nd x y ≤ nd y x.
Definition PQgt x y := PQlt y x.
Definition PQge x y := PQle y x.

(* addition, subtraction *)

Definition PQadd_num1 x y := nd x y + nd y x - 1.
Definition PQsub_num1 x y := nd x y - nd y x - 1.
Definition PQadd_den1 x y := (PQden1 x + 1) * (PQden1 y + 1) - 1.

Definition PQadd x y := PQmake (PQadd_num1 x y) (PQadd_den1 x y).
Definition PQsub x y := PQmake (PQsub_num1 x y) (PQadd_den1 x y).
Arguments PQadd x%PQ y%PQ.
Arguments PQsub x%PQ y%PQ.

(* multiplication, inversion, division *)

Definition PQmul_num1 x y := (PQnum1 x + 1) * (PQnum1 y + 1) - 1.
Definition PQmul_den1 x y := (PQden1 x + 1) * (PQden1 y + 1) - 1.

Definition PQmul x y := PQmake (PQmul_num1 x y) (PQmul_den1 x y).
Arguments PQmul x%PQ y%PQ.

Definition PQinv x := PQmake (PQden1 x) (PQnum1 x).

Module PQ_Notations.

(*
Notation "1" := (PQmake 0 0) : PQ_scope.
Notation "2" := (PQmake 1 0) : PQ_scope.
*)
Notation "a // b" := (PQ_of_pair a b) : PQ_scope.
Notation "x == y" := (PQeq x y) (at level 70) : PQ_scope.
Notation "x ≠≠ y" := (¬ PQeq x y) (at level 70) : PQ_scope.
Notation "'if_PQeq_dec' x y 'then' P 'else' Q" :=
  (if_PQeq P Q x y) (at level 200, x at level 9, y at level 9).
Notation "x < y" := (PQlt x y) : PQ_scope.
Notation "x ≤ y" := (PQle x y) : PQ_scope.
Notation "x > y" := (PQgt x y) : PQ_scope.
Notation "x ≥ y" := (PQge x y) : PQ_scope.
Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z)%PQ (at level 70, y at next level) :
  PQ_scope.
Notation "x + y" := (PQadd x y) : PQ_scope.
Notation "x - y" := (PQsub x y) : PQ_scope.
Notation "x * y" := (PQmul x y) : PQ_scope.
Notation "/ x" := (PQinv x) : PQ_scope.

Definition PQ_of_decimal_uint (n : Decimal.uint) : option PQ :=
  let a := Nat.of_uint n in
  if Nat.eq_dec a 0 then None
  else Some (PQ_of_pair a 1).

Definition PQ_of_decimal_int (n : Decimal.int) : option PQ :=
  match n with
  | Decimal.Pos ui => PQ_of_decimal_uint ui
  | Decimal.Neg ui => None
  end.

Definition PQ_to_decimal_uint (pq : PQ) : option Decimal.uint :=
  match PQden1 pq with
  | 0 => Some (Nat.to_uint (PQnum1 pq + 1))
  | _ => None
  end.

Definition PQ_to_decimal_int (pq : PQ) : option Decimal.int :=
  option_map Decimal.Pos (PQ_to_decimal_uint pq).

Numeral Notation PQ PQ_of_decimal_int PQ_to_decimal_int : PQ_scope.

(*
Check 25%PQ.
Check (22 // 7)%PQ.
*)
(*
Check 0%PQ.
*)

End PQ_Notations.

Import PQ_Notations.

Definition PQone x := PQmake (PQden1 x) (PQden1 x).
Definition PQ_of_nat n := PQmake (n - 1) 0.

(* equality *)

Theorem PQeq_refl : ∀ x : PQ, (x == x)%PQ.
Proof. easy. Qed.

Theorem PQeq_symm : ∀ x y : PQ, (x == y)%PQ → (y == x)%PQ.
Proof. easy. Qed.

Theorem PQeq_trans : ∀ x y z : PQ, (x == y)%PQ → (y == z)%PQ → (x == z)%PQ.
Proof.
unfold "==".
intros * Hxy Hyz.
unfold nd in *.
apply (Nat.mul_cancel_l _ _ (PQnum1 y + 1)); [ flia | ].
rewrite Nat.mul_assoc, Nat.mul_shuffle0, Hyz.
rewrite Nat.mul_shuffle0, <- Nat.mul_assoc, Hxy.
rewrite Nat.mul_comm, Nat.mul_shuffle0.
symmetry; apply Nat.mul_assoc.
Qed.

Add Parametric Relation : _ PQeq
 reflexivity proved by PQeq_refl
 symmetry proved by PQeq_symm
 transitivity proved by PQeq_trans
 as PQeq_equiv_rel.

Theorem PQeq_if : ∀ A {P Q : A} x y,
  (if PQeq_dec x y then P else Q) = if_PQeq P Q x y.
Proof. easy. Qed.

(* allows to use rewrite inside a if_PQeq_dec ...
   through PQeq_if, e.g.
      H : (x = y)%PQ
      ====================
      ... if_PQeq_dec x z then P else Q ...
   > rewrite H.
      ====================
      ... if_PQeq_dec y z then P else Q ...
 *)
Instance PQif_PQeq_morph {P Q : Prop} :
  Proper (PQeq ==> PQeq ==> iff) (λ x y, if PQeq_dec x y then P else Q).
Proof.
intros x1 x2 Hx y1 y2 Hy.
move y1 before x2; move y2 before y1.
destruct (PQeq_dec x1 y1) as [H1| H1]; rewrite Hx, Hy in H1.
-now destruct (PQeq_dec x2 y2).
-now destruct (PQeq_dec x2 y2).
Qed.

(* inequality *)

Definition PQcompare x y := Nat.compare (nd x y) (nd y x).
Arguments PQcompare x%PQ y%PQ.

Theorem PQcompare_eq_iff : ∀ x y, PQcompare x y = Eq ↔ (x == y)%PQ.
Proof. intros; apply Nat.compare_eq_iff. Qed.

Theorem PQcompare_lt_iff : ∀ x y, PQcompare x y = Lt ↔ (x < y)%PQ.
Proof. intros; apply Nat.compare_lt_iff. Qed.

Theorem PQcompare_gt_iff : ∀ x y, PQcompare x y = Gt ↔ (x > y)%PQ.
Proof. intros; apply Nat.compare_gt_iff. Qed.

Theorem PQle_refl : ∀ x, (x ≤ x)%PQ.
Proof. now unfold "≤"%PQ. Qed.

Theorem PQnlt_ge : ∀ x y, ¬ (x < y)%PQ ↔ (y ≤ x)%PQ.
Proof.
intros.
split; intros H; [ now apply Nat.nlt_ge in H | ].
now apply Nat.nlt_ge.
Qed.

Theorem PQnle_gt : ∀ x y, ¬ (x ≤ y)%PQ ↔ (y < x)%PQ.
Proof.
intros.
split; intros H; [ now apply Nat.nle_gt in H | ].
now apply Nat.nle_gt.
Qed.

Theorem PQlt_le_dec : ∀ x y : PQ, {(x < y)%PQ} + {(y ≤ x)%PQ}.
Proof.
intros (xn, xd) (yn, yd).
unfold PQlt, PQle, nd; simpl.
destruct (lt_dec ((xn + 1) * (yd + 1)) ((yn + 1) * (xd + 1))) as [H1| H1].
-now left.
-now right; apply Nat.nlt_ge.
Qed.
Arguments PQlt_le_dec x%PQ y%PQ.

Theorem PQle_lt_dec : ∀ x y : PQ, {(x ≤ y)%PQ} + {(y < x)%PQ}.
Proof.
intros (xn, xd) (yn, yd).
unfold PQlt, PQle, nd; simpl.
destruct (le_dec ((xn + 1) * (yd + 1)) ((yn + 1) * (xd + 1))) as [H1| H1].
-now left.
-now right; apply Nat.nle_gt.
Qed.
Arguments PQle_lt_dec x%PQ y%PQ.

Ltac split_var x :=
  let xn := fresh x in
  let xd := fresh x in
  let Hpn := fresh x in
  let Hpd := fresh x in
  remember (PQnum1 x + 1) as xn eqn:Hxn;
  remember (PQden1 x + 1) as xd eqn:Hxd;
  assert (Hpn : 0 < xn) by flia Hxn;
  assert (Hpd : 0 < xd) by flia Hxd;
  clear Hxn Hxd.

(* allows to use rewrite inside a less than
   e.g.
      H : x = y
      ====================
      (x < z)%PQ
   rewrite H.
 *)
Instance PQlt_morph : Proper (PQeq ==> PQeq ==> iff) PQlt.
Proof.
assert (H : ∀ x1 x2 y1 y2,
  (x1 == x2)%PQ → (y1 == y2)%PQ → (x1 < y1)%PQ → (x2 < y2)%PQ). {
  intros x1q x2q y1q y2q Hx Hy Hxy.
  unfold "<"%PQ, nd in Hxy |-*.
  unfold "=="%PQ, nd in Hx, Hy.
  split_var x1q; split_var x2q; split_var y1q; split_var y2q.
  move Hx before Hy.
  apply (Nat.mul_lt_mono_pos_l y1q0); [ easy | ].
  rewrite Nat.mul_assoc, Nat.mul_shuffle0, Hy; clear Hy.
  remember (y2q0 * y1q1 * x2q0) as u; rewrite Nat.mul_comm; subst u.
  do 2 rewrite <- Nat.mul_assoc.
  apply Nat.mul_lt_mono_pos_l; [ easy | ].
  apply (Nat.mul_lt_mono_pos_r x1q1); [ easy | ].
  rewrite <- Nat.mul_assoc, <- Hx; clear Hx.
  rewrite Nat.mul_assoc, Nat.mul_comm.
  rewrite <- Nat.mul_assoc.
  apply Nat.mul_lt_mono_pos_l; [ easy | ].
  now rewrite Nat.mul_comm.
}
intros x1 x2 Hx y1 y2 Hy.
move y1 before x2; move y2 before y1.
split; intros Hxy.
-now apply (H x1 x2 y1 y2).
-symmetry in Hx, Hy.
 now apply (H x2 x1 y2 y1).
Qed.

Instance PQgt_morph : Proper (PQeq ==> PQeq ==> iff) PQgt.
Proof.
intros x1 x2 Hx y1 y2 Hy.
now apply PQlt_morph.
Qed.

(* allows to use rewrite inside a less equal
   e.g.
      H : x = y
      ====================
      (x ≤ z)%PQ
   rewrite H.
 *)
Instance PQle_morph : Proper (PQeq ==> PQeq ==> iff) PQle.
Proof.
assert (H : ∀ x1 x2 y1 y2,
  (x1 == x2)%PQ → (y1 == y2)%PQ → (x1 ≤ y1)%PQ → (x2 ≤ y2)%PQ). {
  intros x1q x2q y1q y2q Hx Hy Hxy.
  unfold "≤"%PQ, nd in Hxy |-*.
  unfold "=="%PQ, nd in Hx, Hy.
  split_var x1q; split_var x2q; split_var y1q; split_var y2q.
  move Hx before Hy.
  apply (Nat.mul_le_mono_pos_l _ _ y1q0); [ easy | ].
  rewrite Nat.mul_assoc, Nat.mul_shuffle0, Hy; clear Hy.
  remember (y2q0 * y1q1 * x2q0) as u; rewrite Nat.mul_comm; subst u.
  do 2 rewrite <- Nat.mul_assoc.
  apply Nat.mul_le_mono_pos_l; [ easy | ].
  apply (Nat.mul_le_mono_pos_r _ _ x1q1); [ easy | ].
  rewrite <- Nat.mul_assoc, <- Hx; clear Hx.
  rewrite Nat.mul_assoc, Nat.mul_comm.
  rewrite <- Nat.mul_assoc.
  apply Nat.mul_le_mono_pos_l; [ easy | ].
  now rewrite Nat.mul_comm.
}
intros x1 x2 Hx y1 y2 Hy.
move y1 before x2; move y2 before y1.
split; intros Hxy.
-now apply (H x1 x2 y1 y2).
-symmetry in Hx, Hy.
 now apply (H x2 x1 y2 y1).
Qed.

Instance PQge_morph : Proper (PQeq ==> PQeq ==> iff) PQge.
Proof.
intros x1 x2 Hx y1 y2 Hy.
now apply PQle_morph.
Qed.

(* allows to use rewrite inside an addition
   e.g.
      H : x = y
      ====================
      ..... (x + z)%PQ ....
   rewrite H.
 *)
Instance PQadd_morph : Proper (PQeq ==> PQeq ==> PQeq) PQadd.
Proof.
intros x1q x2q Hx y1q y2q Hy.
move Hx before Hy.
unfold "+"%PQ.
unfold "==", nd in Hx, Hy |-*.
unfold PQadd_num1, PQadd_den1, nd; simpl.
rewrite Nat.sub_add; [ | do 4 rewrite Nat.add_1_r; simpl; flia ].
rewrite Nat.sub_add; [ | do 2 rewrite Nat.add_1_r; simpl; flia ].
rewrite Nat.sub_add; [ | do 2 rewrite Nat.add_1_r; simpl; flia ].
rewrite Nat.sub_add; [ | do 2 rewrite Nat.add_1_r; simpl; flia ].
split_var x1q; split_var x2q; split_var y1q; split_var y2q.
move Hx before Hy.
ring_simplify.
rewrite Nat.add_comm; f_equal.
-replace (y1q0 * x1q1 * x2q1 * y2q1) with (y1q0 * y2q1 * x1q1 * x2q1) by flia.
 rewrite Hy; flia.
-replace (x1q0 * y1q1 * x2q1) with (x1q0 * x2q1 * y1q1) by flia.
 rewrite Hx; flia.
Qed.

Theorem PQsub_morph : ∀ x1 x2 y1 y2,
  (x1 < y1)%PQ
  → (x1 == x2)%PQ
  → (y1 == y2)%PQ
  → (y1 - x1 == y2 - x2)%PQ.
Proof.
intros * H1 Hx Hy.
generalize H1; intros H2; move H2 before H1.
rewrite Hx, Hy in H2.
unfold "-"%PQ.
unfold "==", nd in Hx, Hy |-*.
unfold "<"%PQ, nd in H1, H2.
unfold PQsub_num1, PQadd_den1, nd; simpl.
do 4 rewrite Nat.add_1_r in H1, H2, Hx, Hy.
do 12 rewrite Nat.add_1_r.
do 2 (rewrite <- Nat.sub_succ_l; [ | flia H1 ]).
rewrite Nat_sub_sub_swap, Nat.sub_succ, Nat.sub_0_r.
rewrite <- Nat.sub_succ_l; [ | simpl; flia ].
rewrite Nat.sub_succ, Nat.sub_0_r.
do 2 (rewrite <- Nat.sub_succ_l; [ | flia H2 ]).
rewrite Nat_sub_sub_swap, Nat.sub_succ, Nat.sub_0_r.
rewrite <- Nat.sub_succ_l; [ | simpl; flia ].
rewrite Nat.sub_succ, Nat.sub_0_r.
do 2 rewrite Nat.mul_sub_distr_r.
remember (S (PQnum1 x1)) as x1n eqn:Hx1n.
remember (S (PQden1 x1)) as x1d eqn:Hx1d.
remember (S (PQnum1 x2)) as x2n eqn:Hx2n.
remember (S (PQden1 x2)) as x2d eqn:Hx2d.
remember (S (PQnum1 y1)) as y1n eqn:Hy1n.
remember (S (PQden1 y1)) as y1d eqn:Hy1d.
remember (S (PQnum1 y2)) as y2n eqn:Hy2n.
remember (S (PQden1 y2)) as y2d eqn:Hy2d.
move H1 before H2.
f_equal.
-replace (y1n * x1d * (y2d * x2d)) with (y1n * y2d * x1d * x2d) by flia.
 rewrite Hy; flia.
-replace (x1n * y1d * (y2d * x2d)) with (x1n * x2d * y1d * y2d) by flia.
 rewrite Hx; flia.
Qed.
Arguments PQsub_morph x1%PQ x2%PQ y1%PQ y2%PQ.

(* allows to use rewrite inside a multiplication
   e.g.
      H : x = y
      ====================
      ..... (x * z)%PQ ....
   rewrite H.
 *)
Instance PQmul_morph : Proper (PQeq ==> PQeq ==> PQeq) PQmul.
Proof.
unfold "*"%PQ.
unfold "==", nd; simpl.
unfold PQmul_num1, PQmul_den1; simpl.
intros x1 x2 Hx y1 y2 Hy; simpl.
move Hx before Hy.
do 4 rewrite Nat.add_1_r in Hx, Hy.
do 12 rewrite Nat.add_1_r.
do 4 (rewrite <- Nat.sub_succ_l; [ | simpl; flia ]).
do 4 rewrite Nat.sub_succ, Nat.sub_0_r.
setoid_rewrite Nat.mul_shuffle0.
do 2 rewrite Nat.mul_assoc; rewrite Hx.
setoid_rewrite <- Nat.mul_assoc; f_equal.
rewrite Nat.mul_comm, Hy.
apply Nat.mul_comm.
Qed.

Ltac split_var2 x xn xd Hpn Hpd :=
  remember (S (PQnum1 x)) as xn eqn:Heqxn;
  remember (S (PQden1 x)) as xd eqn:Heqxd;
  move xn at top; move xd at top;
  assert (Hpn : 0 < xn) by flia Heqxn;
  assert (Hpd : 0 < xd) by flia Heqxd;
  clear Heqxn Heqxd.

Ltac PQtac1 :=
  unfold "+"%PQ, "-"%PQ, "<"%PQ, "=="%PQ, "≤"%PQ;
  unfold PQadd_num1, PQsub_num1, PQadd_den1, nd; simpl;
  repeat rewrite Nat.add_1_r.

Ltac PQtac2 :=
  rewrite <- Nat.sub_succ_l;
  try (rewrite Nat.sub_succ, Nat.sub_0_r);
  match goal with
  | [ |- 1 ≤ S _ * _ ] => try (simpl; flia)
  | [ |- 1 ≤ S _ * _ * _ ] => try (simpl; flia)
  | _ => idtac
  end.

Ltac PQtac3 :=
  repeat rewrite Nat.mul_sub_distr_l;
  repeat rewrite Nat.mul_add_distr_l;
  repeat rewrite Nat.mul_sub_distr_r;
  repeat rewrite Nat.mul_add_distr_r;
  repeat rewrite Nat.mul_assoc.

Theorem PQmul_one_r : ∀ x y, (x * PQone y == x)%PQ.
Proof.
intros.
unfold "*"%PQ, "==", PQone, nd; simpl.
unfold PQmul_num1, PQmul_den1; simpl.
PQtac1; repeat PQtac2; PQtac3.
apply Nat.mul_shuffle0.
Qed.

Theorem PQle_antisymm_eq : ∀ x y,
  (x ≤ y)%PQ → (y ≤ x)%PQ → (x * PQone y = y * PQone x)%PQ.
Proof.
intros x y Hxy Hyx.
unfold PQone, "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1; simpl.
specialize (Nat.le_antisymm _ _ Hxy Hyx) as H.
unfold nd in H; rewrite H.
f_equal.
now rewrite Nat.mul_comm.
Qed.

Theorem PQle_antisymm : ∀ x y, (x ≤ y)%PQ → (y ≤ x)%PQ → (x == y)%PQ.
Proof.
intros * Hxy Hyx.
apply (Nat.le_antisymm _ _ Hxy Hyx).
Qed.

Theorem PQadd_comm : ∀ x y, (x + y)%PQ = (y + x)%PQ.
Proof.
intros.
unfold "+"%PQ; f_equal.
-now unfold PQadd_num1, nd; rewrite Nat.add_comm.
-now unfold PQadd_den1, nd; rewrite Nat.mul_comm.
Qed.

Theorem PQadd_add_swap : ∀ x y z, (x + y + z)%PQ = (x + z + y)%PQ.
Proof.
intros; PQtac1.
repeat PQtac2; [ | simpl; flia | simpl; flia ].
PQtac3; f_equal; [ | f_equal; apply Nat.mul_shuffle0 ].
f_equal.
rewrite Nat.add_shuffle0.
f_equal; f_equal.
apply Nat.mul_shuffle0.
Qed.

Theorem PQadd_assoc : ∀ x y z, (x + (y + z))%PQ = ((x + y) + z)%PQ.
Proof.
intros.
rewrite PQadd_comm.
remember (x + y)%PQ as t eqn:Ht.
rewrite PQadd_comm in Ht; subst t.
apply PQadd_add_swap.
Qed.

(* *)

Theorem PQlt_irrefl : ∀ x, (¬ x < x)%PQ.
Proof. intros x; apply Nat.lt_irrefl. Qed.

Theorem PQlt_le_incl : ∀ x y, (x < y)%PQ → (x ≤ y)%PQ.
Proof. intros * Hxy; now apply Nat.lt_le_incl. Qed.

Theorem PQle_trans : ∀ x y z, (x ≤ y)%PQ → (y ≤ z)%PQ → (x ≤ z)%PQ.
Proof.
intros * Hxy Hyz.
unfold "≤"%PQ, nd in Hxy, Hyz |-*.
apply (Nat.mul_le_mono_pos_r _ _ (PQden1 y + 1)); [ flia | ].
rewrite Nat.mul_shuffle0.
apply (Nat.le_trans _ ((PQnum1 y + 1) * (PQden1 x + 1) * (PQden1 z + 1))).
-apply Nat.mul_le_mono_pos_r; [ flia | easy ].
-setoid_rewrite Nat.mul_shuffle0.
 apply Nat.mul_le_mono_pos_r; [ flia | easy ].
Qed.
Arguments PQle_trans x%PQ y%PQ z%PQ.

Theorem PQlt_trans : ∀ x y z, (x < y)%PQ → (y < z)%PQ → (x < z)%PQ.
Proof.
intros * Hxy Hyz.
unfold "<"%PQ, nd in Hxy, Hyz |-*.
apply (Nat.mul_lt_mono_pos_r (PQden1 y + 1)); [ flia | ].
rewrite Nat.mul_shuffle0.
apply (Nat.lt_trans _ ((PQnum1 y + 1) * (PQden1 x + 1) * (PQden1 z + 1))).
-apply Nat.mul_lt_mono_pos_r; [ flia | easy ].
-setoid_rewrite Nat.mul_shuffle0.
 apply Nat.mul_lt_mono_pos_r; [ flia | easy ].
Qed.
Arguments PQlt_trans x%PQ y%PQ z%PQ.

Theorem PQle_lt_trans : ∀ x y z, (x ≤ y)%PQ → (y < z)%PQ → (x < z)%PQ.
Proof.
intros * Hxy Hyz.
unfold "<"%PQ, nd in Hyz |-*.
unfold "≤"%PQ, nd in Hxy.
apply (Nat.mul_lt_mono_pos_r (PQden1 y + 1)); [ flia | ].
rewrite Nat.mul_shuffle0.
apply (Nat.le_lt_trans _ ((PQnum1 y + 1) * (PQden1 x + 1) * (PQden1 z + 1))).
-apply Nat.mul_le_mono_pos_r; [ flia | easy ].
-setoid_rewrite Nat.mul_shuffle0.
 apply Nat.mul_lt_mono_pos_r; [ flia | easy ].
Qed.

Theorem PQlt_le_trans : ∀ x y z, (x < y)%PQ → (y ≤ z)%PQ → (x < z)%PQ.
Proof.
intros * Hxy Hyz.
unfold "<"%PQ, nd in Hxy |-*.
unfold "≤"%PQ, nd in Hyz.
apply (Nat.mul_lt_mono_pos_r (PQden1 y + 1)); [ flia | ].
rewrite Nat.mul_shuffle0.
apply (Nat.lt_le_trans _ ((PQnum1 y + 1) * (PQden1 x + 1) * (PQden1 z + 1))).
-apply Nat.mul_lt_mono_pos_r; [ flia | easy ].
-setoid_rewrite Nat.mul_shuffle0.
 apply Nat.mul_le_mono_pos_r; [ flia | easy ].
Qed.

Instance PQcompare_morph : Proper (PQeq ==> PQeq ==> eq) PQcompare.
Proof.
intros x1 x2 Hx y1 y2 Hy.
move Hx before Hy.
remember (PQcompare x1 y1) as c1 eqn:Hc1; symmetry in Hc1.
remember (PQcompare x2 y2) as c2 eqn:Hc2; symmetry in Hc2.
move c2 before c1.
destruct c1.
-apply PQcompare_eq_iff in Hc1.
 destruct c2; [ easy | | ].
 +apply PQcompare_lt_iff in Hc2.
  rewrite <- Hy, <- Hc1, Hx in Hc2.
  now apply PQlt_irrefl in Hc2.
 +apply PQcompare_gt_iff in Hc2.
  rewrite <- Hy, <- Hc1, Hx in Hc2.
  now apply PQlt_irrefl in Hc2.
-apply PQcompare_lt_iff in Hc1.
 destruct c2; [ | easy | ].
 +apply PQcompare_eq_iff in Hc2.
  rewrite Hx, Hc2, Hy in Hc1.
  now apply PQlt_irrefl in Hc1.
 +apply PQcompare_gt_iff in Hc2.
  rewrite Hx, Hy in Hc1.
  apply PQnle_gt in Hc2.
  now exfalso; apply Hc2, PQlt_le_incl.
-apply PQcompare_gt_iff in Hc1.
 destruct c2; [ | | easy ].
 +apply PQcompare_eq_iff in Hc2.
  rewrite Hx, Hc2, <- Hy in Hc1.
  now apply PQlt_irrefl in Hc1.
 +apply PQcompare_lt_iff in Hc2.
  rewrite Hx, Hy in Hc1.
  apply PQnle_gt in Hc2.
  now exfalso; apply Hc2, PQlt_le_incl.
Qed.
Arguments PQcompare_morph x1%PQ x2%PQ Hx%PQ y1%PQ y2%PQ Hy%PQ : rename.

Theorem PQadd_lt_mono_r : ∀ x y z, (x < y)%PQ ↔ (x + z < y + z)%PQ.
Proof.
unfold "<"%PQ, "+"%PQ, PQadd_num1, PQadd_den1, nd; simpl.
intros *.
do 10 rewrite Nat.add_1_r.
do 4 (rewrite <- Nat.sub_succ_l; [ | simpl; flia ]).
do 4 rewrite Nat.sub_succ, Nat.sub_0_r.
do 2 rewrite Nat.mul_add_distr_r.
remember (S (PQnum1 x)) as xn eqn:Hxn.
remember (S (PQden1 x)) as xd eqn:Hxd.
remember (S (PQnum1 y)) as yn eqn:Hyn.
remember (S (PQden1 y)) as yd eqn:Hyd.
remember (S (PQnum1 z)) as zn eqn:Hzn.
remember (S (PQden1 z)) as zd eqn:Hzd.
replace (zn * yd * (xd * zd)) with (zn * xd * (yd * zd)) by flia.
replace (xn * zd * (yd * zd)) with (xn * yd * (zd * zd)) by flia.
replace (yn * zd * (xd * zd)) with (yn * xd * (zd * zd)) by flia.
split; intros H.
-apply Nat.add_lt_mono_r.
 apply Nat.mul_lt_mono_pos_r; [ | easy ].
 subst zd; simpl; flia.
-apply Nat.add_lt_mono_r in H.
 apply Nat.mul_lt_mono_pos_r in H; [ easy | ].
 subst zd; simpl; flia.
Qed.

Theorem PQadd_lt_mono_l : ∀ x y z, (y < z)%PQ ↔ (x + y < x + z)%PQ.
Proof.
intros.
setoid_rewrite PQadd_comm.
apply PQadd_lt_mono_r.
Qed.

Theorem PQadd_le_mono_r : ∀ x y z, (x ≤ y ↔ x + z ≤ y + z)%PQ.
Proof.
unfold "≤"%PQ, "+"%PQ, PQadd_num1, PQadd_den1, nd; simpl.
intros *.
do 10 rewrite Nat.add_1_r.
do 4 (rewrite <- Nat.sub_succ_l; [ | simpl; flia ]).
do 4 rewrite Nat.sub_succ, Nat.sub_0_r.
do 2 rewrite Nat.mul_add_distr_r.
remember (S (PQnum1 x)) as xn eqn:Hxn.
remember (S (PQden1 x)) as xd eqn:Hxd.
remember (S (PQnum1 y)) as yn eqn:Hyn.
remember (S (PQden1 y)) as yd eqn:Hyd.
remember (S (PQnum1 z)) as zn eqn:Hzn.
remember (S (PQden1 z)) as zd eqn:Hzd.
replace (zn * yd * (xd * zd)) with (zn * xd * (yd * zd)) by flia.
replace (xn * zd * (yd * zd)) with (xn * yd * (zd * zd)) by flia.
replace (yn * zd * (xd * zd)) with (yn * xd * (zd * zd)) by flia.
split; intros H.
-apply Nat.add_le_mono_r.
 now apply Nat.mul_le_mono_r.
-apply Nat.add_le_mono_r in H.
 apply Nat.mul_le_mono_pos_r in H; [ easy | ].
 subst zd; simpl; flia.
Qed.

Theorem PQadd_le_mono_l : ∀ x y z, (x ≤ y ↔ z + x ≤ z + y)%PQ.
Proof.
setoid_rewrite PQadd_comm.
apply PQadd_le_mono_r.
Qed.

Theorem PQadd_le_mono : ∀ x y z t,
  (x ≤ y)%PQ → (z ≤ t)%PQ → (x + z ≤ y + t)%PQ.
Proof.
intros * Hxy Hzt.
apply (PQle_trans _ (y + z)%PQ).
-now apply PQadd_le_mono_r.
-now apply PQadd_le_mono_l.
Qed.

Theorem PQsub_add_eq : ∀ x y,
  (y < x)%PQ → (x - y + y = x * PQone y * PQone y)%PQ.
Proof.
intros x y Hxy.
unfold "<"%PQ, nd in Hxy.
unfold "+"%PQ, "-"%PQ, "==", nd; simpl.
unfold PQsub_num1, PQadd_num1, PQadd_den1, nd; simpl.
unfold "*"%PQ, PQone, PQmul_num1, PQmul_den1; simpl.
do 4 rewrite Nat.add_1_r in Hxy.
f_equal.
PQtac1; repeat PQtac2; [ | flia Hxy ].
PQtac3; rewrite Nat.sub_add; [ easy | ].
setoid_rewrite Nat.mul_shuffle0.
rewrite Nat.mul_shuffle0.
now apply Nat.mul_le_mono_r, Nat.lt_le_incl.
Qed.

Theorem PQsub_add : ∀ x y, (y < x)%PQ → (x - y + y == x)%PQ.
Proof.
intros x y Hxy.
rewrite PQsub_add_eq; [ | easy ].
now do 2 rewrite PQmul_one_r.
Qed.

Theorem PQsub_le_mono_r : ∀ x y z,
  (z < x)%PQ → (z < y)%PQ → (x ≤ y ↔ x - z ≤ y - z)%PQ.
Proof.
intros * Hzx Hzy.
split.
-intros Hxy.
 revert Hzx Hxy Hzy.
 unfold "≤"%PQ, "<"%PQ, "-"%PQ, PQsub_num1, PQadd_den1, nd; simpl.
 do 10 rewrite Nat.add_1_r.
 intros.
 rewrite <- Nat.sub_succ_l; [ | flia Hzx ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 rewrite <- Nat.sub_succ_l; [ | simpl; flia ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 rewrite <- Nat.sub_succ_l; [ | flia Hzy ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 rewrite <- Nat.sub_succ_l; [ | simpl; flia ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 remember (S (PQnum1 x)) as xn eqn:Hxn.
 remember (S (PQden1 x)) as xd eqn:Hxd.
 remember (S (PQnum1 y)) as yn eqn:Hyn.
 remember (S (PQden1 y)) as yd eqn:Hyd.
 remember (S (PQnum1 z)) as zn eqn:Hzn.
 remember (S (PQden1 z)) as zd eqn:Hzd.
 do 2 rewrite Nat.mul_sub_distr_r.
 replace (zn * yd * (xd * zd)) with (zn * xd * (yd * zd)) by flia.
 replace (xn * zd * (yd * zd)) with (xn * yd * (zd * zd)) by flia.
 replace (yn * zd * (xd * zd)) with (yn * xd * (zd * zd)) by flia.
 apply Nat.sub_le_mono_r.
 now apply Nat.mul_le_mono_r.
-intros Hxyz.
 apply (PQadd_le_mono_r _ _ z) in Hxyz.
 rewrite PQsub_add in Hxyz; [ | easy ].
 now rewrite PQsub_add in Hxyz.
Qed.

Theorem PQsub_le_mono_l : ∀ x y z,
  (x < z)%PQ → (y < z)%PQ → (y ≤ x)%PQ ↔ (z - x ≤ z - y)%PQ.
Proof.
intros * Hzx Hzy.
split.
-intros Hxy.
 revert Hzx Hxy Hzy.
 unfold "≤"%PQ, "<"%PQ, "-"%PQ, PQsub_num1, PQadd_den1, nd; simpl.
 do 10 rewrite Nat.add_1_r.
 intros.
 rewrite <- Nat.sub_succ_l; [ | flia Hzx ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 rewrite <- Nat.sub_succ_l; [ | simpl; flia ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 rewrite <- Nat.sub_succ_l; [ | flia Hzy ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 rewrite <- Nat.sub_succ_l; [ | simpl; flia ].
 rewrite Nat.sub_succ, Nat.sub_0_r.
 remember (S (PQnum1 x)) as xn eqn:Hxn.
 remember (S (PQden1 x)) as xd eqn:Hxd.
 remember (S (PQnum1 y)) as yn eqn:Hyn.
 remember (S (PQden1 y)) as yd eqn:Hyd.
 remember (S (PQnum1 z)) as zn eqn:Hzn.
 remember (S (PQden1 z)) as zd eqn:Hzd.
 do 2 rewrite Nat.mul_sub_distr_r.
 replace (zn * yd * (zd * xd)) with (zn * xd * (zd * yd)) by flia.
 replace (xn * zd * (zd * yd)) with (xn * yd * (zd * zd)) by flia.
 replace (yn * zd * (zd * xd)) with (yn * xd * (zd * zd)) by flia.
 apply Nat.sub_le_mono_l.
 now apply Nat.mul_le_mono_r.
-intros Hxyz.
 apply (PQadd_le_mono_r _ _ (x + y)%PQ) in Hxyz.
 do 2 rewrite PQadd_assoc in Hxyz.
 rewrite PQsub_add in Hxyz; [ | easy ].
 rewrite PQadd_add_swap in Hxyz.
 rewrite PQsub_add in Hxyz; [ | easy ].
 now apply PQadd_le_mono_l in Hxyz.
Qed.

Theorem PQsub_le_mono : ∀ x y z t,
  (y < x)%PQ → (t < z)%PQ → (x ≤ z)%PQ → (t ≤ y)%PQ → (x - y ≤ z - t)%PQ.
Proof.
intros * Hyx Htz Hxz Hty.
eapply (PQle_trans _ (z - y)).
-apply PQsub_le_mono_r; [ easy | | easy ].
 eapply PQlt_le_trans; [ apply Hyx | apply Hxz ].
-apply PQsub_le_mono_l; [ | easy | easy ].
 eapply PQlt_le_trans; [ apply Hyx | apply Hxz ].
Qed.

Theorem PQadd_no_neutral : ∀ x y, (y + x ≠≠ x)%PQ.
Proof.
intros x y Hxy.
unfold "+"%PQ, "=="%PQ, nd in Hxy; simpl in Hxy.
unfold PQadd_num1, PQadd_den1, nd in Hxy.
do 6 rewrite Nat.add_1_r in Hxy.
do 2 (rewrite <- Nat.sub_succ_l in Hxy; [ | simpl; flia ]).
do 2 rewrite Nat.sub_succ, Nat.sub_0_r in Hxy.
rewrite Nat.mul_add_distr_r in Hxy.
rewrite Nat.mul_assoc in Hxy.
apply Nat.add_sub_eq_r in Hxy.
now rewrite Nat.sub_diag in Hxy.
Qed.

Theorem PQsub_no_neutral : ∀ x y, (y < x)%PQ → (x - y ≠≠ x)%PQ.
Proof.
intros *; PQtac1; intros Hyz.
PQtac2; [ | flia Hyz ].
PQtac3.
rewrite <- Nat.sub_succ_l; [ | simpl; flia ].
rewrite Nat.sub_succ, Nat.sub_0_r, Nat.mul_assoc.
intros H.
apply Nat.add_sub_eq_nz in H; [ | simpl; flia ].
rewrite Nat.add_comm, Nat.mul_shuffle0 in H.
rewrite <- Nat.add_0_r in H.
now apply Nat.add_cancel_l in H.
Qed.

Theorem PQadd_sub_same_eq : ∀ px py pz,
  (py == pz)%PQ
  → (px + py - pz = px * PQone py * PQone pz)%PQ.
Proof.
intros * Hyz.
unfold "*"%PQ, PQmul_num1, PQmul_den1.
revert Hyz.
PQtac1; intros; PQtac2; [ | simpl; flia ].
PQtac3; do 2 PQtac2; PQtac3; f_equal.
remember (S (PQnum1 px) * S (PQden1 py)) as t.
now rewrite Nat.mul_shuffle0, Hyz, Nat.mul_shuffle0, Nat.add_sub.
Qed.

Theorem PQadd_sub_eq : ∀ x y, (x + y - y = x * PQone y * PQone y)%PQ.
Proof. now intros; rewrite PQadd_sub_same_eq. Qed.

Theorem PQadd_sub : ∀ x y, (x + y - y == x)%PQ.
Proof.
intros x y.
rewrite PQadd_sub_eq.
now do 2 rewrite PQmul_one_r.
Qed.

Theorem PQlt_add_r : ∀ x y, (x < x + y)%PQ.
Proof.
intros.
unfold "<"%PQ, "+"%PQ; simpl.
unfold PQadd_num1, PQadd_den1, nd; simpl.
do 6 rewrite Nat.add_1_r.
do 2 (rewrite <- Nat.sub_succ_l; [ | simpl; flia ]).
do 2 (rewrite Nat.sub_succ, Nat.sub_0_r).
rewrite Nat.mul_add_distr_r.
rewrite Nat.mul_assoc, Nat.mul_shuffle0.
rewrite <- Nat.add_0_r at 1.
apply Nat.add_le_lt_mono; [ easy | simpl; flia ].
Qed.

Theorem PQlt_add_l : ∀ x y, (x < y + x)%PQ.
Proof.
intros.
rewrite PQadd_comm.
apply PQlt_add_r.
Qed.

Theorem PQle_add_r : ∀ x y, (x ≤ x + y)%PQ.
Proof.
intros.
unfold "≤"%PQ, "+"%PQ; simpl.
unfold PQadd_num1, PQadd_den1, nd; simpl.
do 6 rewrite Nat.add_1_r.
do 2 (rewrite <- Nat.sub_succ_l; [ | simpl; flia ]).
do 2 (rewrite Nat.sub_succ, Nat.sub_0_r).
rewrite Nat.mul_add_distr_r.
rewrite Nat.mul_assoc, Nat.mul_shuffle0.
rewrite <- Nat.add_0_r at 1.
apply Nat.add_le_mono; [ easy | simpl; flia ].
Qed.

Theorem PQle_add_l : ∀ x y, (x ≤ y + x)%PQ.
Proof.
intros.
rewrite PQadd_comm.
apply PQle_add_r.
Qed.

Theorem PQsub_lt : ∀ x y, (y < x)%PQ → (x - y < x)%PQ.
Proof.
intros * Hyx.
revert Hyx; PQtac1; intros.
repeat PQtac2.
-rewrite Nat.mul_assoc, Nat.mul_shuffle0.
 apply Nat.mul_lt_mono_pos_r; [ apply Nat.lt_0_succ | ].
 apply Nat.sub_lt; [ | simpl; apply Nat.lt_0_succ ].
 now apply Nat.lt_le_incl.
-flia Hyx.
Qed.

Theorem PQsub_add_distr : ∀ x y z,
  (y < x)%PQ → (x - (y + z))%PQ = (x - y - z)%PQ.
Proof.
intros * Hyx.
revert Hyx; PQtac1; intros.
repeat PQtac2; PQtac3; [ f_equal; flia | flia Hyx | simpl; flia ].
Qed.

Theorem PQsub_sub_swap : ∀ x y z,
  (y < x)%PQ → (z < x)%PQ → (x - y - z)%PQ = (x - z - y)%PQ.
Proof.
intros * Hyx Hzx.
rewrite <- PQsub_add_distr; [ | easy ].
rewrite <- PQsub_add_distr; [ now rewrite PQadd_comm | easy ].
Qed.

Theorem PQsub_sub_distr : ∀ x y z,
  (z < y)%PQ → (y - z < x)%PQ → (x - (y - z))%PQ = (x + z - y)%PQ.
Proof.
intros * Hzy Hyzx.
revert Hzy Hyzx; PQtac1; intros.
rewrite Nat_sub_sub_swap in Hyzx.
do 2 (rewrite <- Nat.sub_succ_l in Hyzx; [ | flia Hzy ]).
rewrite <- Nat.sub_succ_l in Hyzx; [ | simpl; flia ].
do 2 rewrite Nat.sub_succ, Nat.sub_0_r in Hyzx.
rewrite Nat.mul_sub_distr_r, Nat.mul_assoc in Hyzx.
repeat PQtac2; PQtac3; [ | simpl; flia | ].
-f_equal; [ f_equal | now rewrite Nat.mul_shuffle0 ].
 rewrite Nat_sub_sub_assoc.
 +f_equal; [ | now rewrite Nat.mul_shuffle0 ].
  now f_equal; rewrite Nat.mul_shuffle0.
 +split; [ | flia Hyzx ].
  now apply Nat.mul_le_mono_r, Nat.lt_le_incl.
-flia Hzy.
Qed.

Theorem PQadd_sub_assoc : ∀ x y z,
  (z < y)%PQ → (x + (y - z))%PQ = (x + y - z)%PQ.
Proof.
intros * Hzy.
revert Hzy; PQtac1; intros.
repeat PQtac2; [ | simpl; flia | flia Hzy ].
PQtac3.
f_equal; f_equal.
rewrite Nat.add_sub_assoc.
-f_equal; [ f_equal; apply Nat.mul_shuffle0 | apply Nat.mul_shuffle0 ].
-now apply Nat.mul_le_mono_r, Nat.lt_le_incl.
Qed.

Theorem PQadd_sub_swap : ∀ x y z, (z < x)%PQ → (x + y - z = x - z + y)%PQ.
Proof.
intros * Hzx.
revert Hzx; PQtac1; intros.
repeat PQtac2; [ | flia Hzx | simpl; flia ].
PQtac3.
f_equal; [ f_equal | now rewrite Nat.mul_shuffle0 ].
rewrite Nat.add_sub_swap.
-f_equal; f_equal; apply Nat.mul_shuffle0.
-setoid_rewrite Nat.mul_shuffle0.
 rewrite Nat.mul_shuffle0.
 apply Nat.mul_le_mono_pos_r; [ apply Nat.lt_0_succ | ].
 now apply Nat.lt_le_incl.
Qed.

Theorem PQadd_cancel_l_eq : ∀ x y z,
  (z + x == z + y)%PQ → (x * PQone y = y * PQone x)%PQ.
Proof.
intros * H.
revert H; PQtac1; intros.
do 4 (rewrite <- Nat.sub_succ_l in H; [ | simpl; flia ]).
do 4 rewrite Nat.sub_succ, Nat.sub_0_r in H.
setoid_rewrite Nat.mul_comm in H.
do 2 rewrite <- Nat.mul_assoc in H.
apply Nat.mul_cancel_l in H; [ | easy ].
setoid_rewrite Nat.mul_comm in H.
do 2 rewrite Nat.mul_add_distr_r in H.
rewrite Nat.mul_shuffle0 in H.
apply Nat.add_cancel_l in H.
setoid_rewrite Nat.mul_shuffle0 in H.
apply Nat.mul_cancel_r in H; [ | easy ].
unfold "*"%PQ, PQone, PQmul_num1, PQmul_den1; simpl.
PQtac1; rewrite H; f_equal.
now rewrite Nat.mul_comm.
Qed.

Theorem PQadd_cancel_l : ∀ x y z, (z + x == z + y)%PQ ↔ (x == y)%PQ.
Proof.
intros.
split; intros H; [ | now rewrite H ].
specialize (PQadd_cancel_l_eq _ _ _ H) as H1.
unfold "*"%PQ, PQone, PQmul_num1, PQmul_den1 in H1; simpl in H1.
injection H1; clear H1; intros H1 H2.
revert H2; PQtac1; intros.
simpl in H2; simpl; do 2 rewrite Nat.sub_0_r in H2.
now rewrite H2.
Qed.

(* mouais, chais pas si PQadd_cancel_l ci-dessus est très convainquant ;
   est-ce une bonne idée de passer par PQadd_cancel_l_eq ?
   du coup, chais pas, mais je ne le fais pas pour PQadd_cancel_r
   ci-dessous *)

Theorem PQadd_cancel_r : ∀ x y z, (x + z == y + z ↔ x == y)%PQ.
Proof.
intros.
setoid_rewrite PQadd_comm.
apply PQadd_cancel_l.
Qed.
Arguments PQadd_cancel_r x%PQ y%PQ z%PQ.

Theorem PQsub_cancel_l : ∀ x y z,
  (y < x)%PQ → (z < x)%PQ → (x - y == x - z)%PQ ↔ (y == z)%PQ.
Proof.
intros * Hyx Hzx.
split; intros H.
-apply (PQadd_cancel_r _ _ z) in H.
 rewrite PQsub_add in H; [ | easy ].
 apply (PQadd_cancel_r _ _ (x - y)).
 setoid_rewrite PQadd_comm.
 rewrite PQsub_add; [ | easy ].
 now symmetry.
-apply (PQadd_cancel_r _ _ z).
 rewrite PQsub_add; [ | easy ].
 apply (PQadd_cancel_r _ _ (x - y)) in H.
 setoid_rewrite PQadd_comm in H.
 rewrite PQsub_add in H; [ | easy ].
 now symmetry.
Qed.

Theorem PQsub_cancel_r : ∀ x y z,
  (z < x)%PQ → (z < y)%PQ → (x - z == y - z)%PQ ↔ (x == y)%PQ.
Proof.
intros * Hzx Hzy.
split; intros H.
-apply (PQadd_cancel_l _ _ z) in H.
 setoid_rewrite PQadd_comm in H.
 rewrite PQsub_add in H; [ | easy ].
 now rewrite PQsub_add in H.
-apply (PQadd_cancel_r _ _ z).
 rewrite PQsub_add; [ | easy ].
 now rewrite PQsub_add.
Qed.

Theorem PQmul_comm : ∀ x y, (x * y = y * x)%PQ.
Proof.
intros.
unfold "*"%PQ; f_equal.
-now unfold PQmul_num1; simpl; rewrite Nat.mul_comm.
-now unfold PQmul_den1; simpl; rewrite Nat.mul_comm.
Qed.

Theorem PQmul_1_l : ∀ a, (1 * a)%PQ = a.
Proof.
intros.
unfold "*"%PQ.
unfold PQmul_num1, PQmul_den1; simpl.
do 2 rewrite Nat.add_0_r, Nat.add_sub.
now destruct a.
Qed.

Theorem PQmul_assoc : ∀ x y z, (x * (y * z) = (x * y) * z)%PQ.
intros.
unfold "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1; simpl; PQtac1; repeat PQtac2; f_equal.
-now rewrite Nat.mul_assoc.
-now rewrite Nat.mul_assoc.
Qed.

Theorem PQmul_mul_swap : ∀ x y z, (x * y * z = x * z * y)%PQ.
intros.
unfold "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1; simpl; PQtac1; repeat PQtac2; f_equal.
-now rewrite Nat.mul_shuffle0.
-now rewrite Nat.mul_shuffle0.
Qed.

Theorem PQmul_le_mono : ∀ x y z t,
  (x ≤ y)%PQ → (z ≤ t)%PQ → (x * z ≤ y * t)%PQ.
Proof.
intros *.
unfold "≤"%PQ, nd; cbn.
unfold PQmul_num1, PQmul_den1.
do 12 rewrite Nat.add_1_r.
do 4 (rewrite <- Nat.sub_succ_l; [ | cbn; flia ]).
do 4 rewrite Nat.sub_succ, Nat.sub_0_r.
intros Hxy Hzt.
setoid_rewrite Nat.mul_shuffle0.
do 2 rewrite Nat.mul_assoc.
setoid_rewrite <- Nat.mul_assoc.
apply Nat.mul_le_mono; [ easy | ].
now setoid_rewrite Nat.mul_comm.
Qed.

Theorem PQmul_le_mono_l : ∀ x y z, (x ≤ y ↔ z * x ≤ z * y)%PQ.
Proof.
intros *.
unfold "≤"%PQ, nd; simpl.
unfold PQmul_num1, PQmul_den1.
do 10 rewrite Nat.add_1_r.
do 4 (rewrite <- Nat.sub_succ_l; [ | simpl; flia ]).
do 4 rewrite Nat.sub_succ, Nat.sub_0_r.
do 2 rewrite Nat.mul_assoc.
setoid_rewrite Nat.mul_shuffle0.
split; intros Hxy.
-apply Nat.mul_le_mono_r.
 do 2 rewrite <- Nat.mul_assoc.
 now apply Nat.mul_le_mono_l.
-apply Nat.mul_le_mono_pos_r in Hxy; [ | flia ].
 do 2 rewrite <- Nat.mul_assoc in Hxy.
 apply Nat.mul_le_mono_pos_l in Hxy; [ | flia ].
 easy.
Qed.

Theorem PQmul_le_mono_r : ∀ x y z, (x ≤ y ↔ x * z ≤ y * z)%PQ.
Proof.
intros *.
setoid_rewrite PQmul_comm.
now apply PQmul_le_mono_l.
Qed.

Theorem PQmul_add_distr_l_eq : ∀ x y z,
  (x * (y + z) * PQone x = x * y + x * z)%PQ.
Proof.
intros.
unfold "==", "*"%PQ, "+"%PQ, nd; simpl.
unfold PQmul_num1, PQadd_den1, PQadd_num1, PQmul_den1, nd; simpl.
PQtac1; do 2 PQtac2; [ | simpl; flia ].
PQtac3; do 6 PQtac2.
PQtac3; f_equal; [ | now rewrite Nat.mul_shuffle0 ].
now f_equal; f_equal; rewrite Nat.mul_shuffle0.
Qed.

Theorem PQmul_add_distr_l : ∀ x y z, (x * (y + z) == x * y + x * z)%PQ.
Proof. now intros; rewrite <- PQmul_add_distr_l_eq, PQmul_one_r. Qed.

Theorem PQmul_sub_distr_l_eq : ∀ x y z,
  (z < y → x * (y - z) * PQone x = x * y - x * z)%PQ.
Proof.
intros *.
unfold "==", "*"%PQ, "+"%PQ, "<"%PQ, nd; simpl.
unfold PQmul_num1, PQadd_den1, PQadd_num1, PQmul_den1, nd; simpl.
PQtac1; intros Hzy.
repeat PQtac2.
-repeat rewrite Nat.mul_assoc; f_equal.
 +f_equal; PQtac3; f_equal; apply Nat.mul_shuffle0.
 +f_equal; apply Nat.mul_shuffle0.
-flia Hzy.
Qed.

Theorem PQmul_sub_distr_l : ∀ x y z,
  (z < y → x * (y - z) == x * y - x * z)%PQ.
Proof.
intros * Hzy.
rewrite <- PQmul_sub_distr_l_eq; [ | easy ].
now rewrite PQmul_one_r.
Qed.

Theorem PQmul_cancel_l_eq : ∀ x y z,
  (z * x == z * y)%PQ → (x * PQone y = y * PQone x)%PQ.
Proof.
intros * H.
revert H; unfold "*"%PQ, PQmul_num1, PQmul_den1.
destruct x as (xn, xd).
destruct y as (yn, yd).
destruct z as (zn, zd); simpl.
PQtac1; do 4 PQtac2.
intros.
do 2 rewrite <- Nat.mul_assoc in H.
apply Nat.mul_cancel_l in H; [ | easy ].
setoid_rewrite Nat.mul_comm in H.
do 2 rewrite <- Nat.mul_assoc in H.
apply Nat.mul_cancel_l in H; [ | easy ].
f_equal; rewrite Nat.mul_comm; [ now rewrite H, Nat.mul_comm | easy ].
Qed.

Theorem PQmul_cancel_l : ∀ x y z, (z * x == z * y ↔ x == y)%PQ.
Proof.
Proof.
intros.
split; intros H; [ | now rewrite H ].
specialize (PQmul_cancel_l_eq _ _ _ H) as H1.
unfold "*"%PQ, PQone, PQmul_num1, PQmul_den1 in H1; simpl in H1.
injection H1; clear H1; intros H1 H2.
revert H2; PQtac1; intros.
simpl in H2; simpl; do 2 rewrite Nat.sub_0_r in H2.
now rewrite H2.
Qed.

Theorem PQinv_involutive : ∀ x, (/ / x = x)%PQ.
Proof. intros. unfold "/"%PQ; now destruct x. Qed.

(* *)

Ltac PQcompare_iff :=
  match goal with
  | [ H : PQcompare _ _ = Eq |- _ ] => apply PQcompare_eq_iff in H
  | [ H : PQcompare _ _ = Lt |- _ ] => apply PQcompare_lt_iff in H
  | [ H : PQcompare _ _ = Gt |- _ ] => apply PQcompare_gt_iff in H
  end.

Theorem PQcompare_refl : ∀ x, PQcompare x x = Eq.
Proof.
intros.
remember (PQcompare x x) as c eqn:Hc; symmetry in Hc.
now destruct c; [ easy | | ]; PQcompare_iff; apply PQlt_irrefl in Hc.
Qed.

Theorem PQmul_lt_cancel_l : ∀ x y z, (x * y < x * z)%PQ ↔ (y < z)%PQ.
Proof.
intros.
unfold "<"%PQ, nd.
unfold "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1.
rewrite Nat.sub_add; [ | destruct (PQnum1 x); simpl; flia ].
rewrite Nat.sub_add; [ | destruct (PQden1 x); simpl; flia ].
rewrite Nat.sub_add; [ | destruct (PQnum1 x); simpl; flia ].
rewrite Nat.sub_add; [ | destruct (PQden1 x); simpl; flia ].
setoid_rewrite Nat.mul_shuffle1.
split; intros H.
-apply Nat.mul_lt_mono_pos_l in H; [ easy | ].
 do 2 rewrite Nat.add_1_r; simpl; apply Nat.lt_0_succ.
-apply Nat.mul_lt_mono_pos_l; [ | easy ].
 do 2 rewrite Nat.add_1_r; simpl; apply Nat.lt_0_succ.
Qed.

Theorem PQcompare_mul_cancel_l : ∀ x y z,
  PQcompare (x * y) (x * z) = PQcompare y z.
Proof.
intros.
remember (PQcompare (x * y) (x * z)) as b1 eqn:Hb1.
symmetry in Hb1; symmetry.
destruct b1; PQcompare_iff.
-apply PQcompare_eq_iff.
 now apply PQmul_cancel_l in Hb1.
-apply PQcompare_lt_iff.
 now apply PQmul_lt_cancel_l in Hb1.
-apply PQcompare_gt_iff.
 now apply PQmul_lt_cancel_l in Hb1.
Qed.

Require Import Nat_ggcd.

Definition PQred x :=
  let '(_, (aa, bb)) := ggcd (PQnum1 x + 1) (PQden1 x + 1) in
  PQmake (aa - 1) (bb - 1).
Arguments PQred x%PQ.

Instance PQred_morph : Proper (PQeq ==> PQeq) PQred.
Proof.
intros (xn, xd) (yn, yd) Hxy.
unfold "=="%PQ, nd in Hxy |-*; simpl in *.
unfold PQred; simpl.
remember (ggcd (xn + 1) (xd + 1)) as g1 eqn:Hg1; symmetry in Hg1.
remember (ggcd (yn + 1) (yd + 1)) as g2 eqn:Hg2; symmetry in Hg2.
move g2 before g1.
destruct g1 as (g1 & aa1 & bb1).
destruct g2 as (g2 & aa2 & bb2); simpl.
specialize (ggcd_correct_divisors (xn + 1) (xd + 1)) as H1.
rewrite Hg1 in H1; destruct H1 as (Hxn, Hxd).
specialize (ggcd_correct_divisors (yn + 1) (yd + 1)) as H1.
rewrite Hg2 in H1; destruct H1 as (Hyn, Hyd).
rewrite Nat.mul_comm, Nat.add_1_r in Hxn, Hxd, Hyn, Hyd.
rewrite Nat.sub_add; [ | destruct aa1; flia Hxn ].
rewrite Nat.sub_add; [ | destruct bb2; flia Hyd ].
rewrite Nat.sub_add; [ | destruct aa2; flia Hyn ].
rewrite Nat.sub_add; [ | destruct bb1; flia Hxd ].
rewrite Nat.mul_comm in Hxn, Hxd, Hyn, Hyd.
do 4 rewrite Nat.add_1_r in Hxy.
apply (Nat.mul_cancel_l _ _ g1); [ now destruct g1 | ].
rewrite Nat.mul_assoc, <- Hxn, Nat.mul_comm.
apply (Nat.mul_cancel_l _ _ g2); [ now destruct g2 | ].
rewrite Nat.mul_assoc, <- Hyd, Nat.mul_comm.
rewrite Hxy, Hyn, Hxd.
flia.
Qed.

(*
Definition PQH x := PQmake (PQnum1 x + 1) (PQden1 x + 1).
Definition PQF a b := PQmake (a - 1) (b - 1).

Compute (PQH (PQred (PQF 16 24))).
Compute (PQH (PQred (PQF 2 3))).
*)

Theorem PQred_idemp : ∀ x, PQred (PQred x) = PQred x.
Proof.
intros (xn, xd).
unfold PQred; simpl.
remember (ggcd (xn + 1) (xd + 1)) as g eqn:Hg1.
destruct g as (g1, (aa1, bb1)); simpl.
assert (Haa1 : aa1 ≠ 0). {
  intros H; subst aa1.
  specialize (ggcd_succ_l_neq_0 xn (xd + 1)) as H.
  now rewrite <- Nat.add_1_r, <- Hg1 in H.
}
assert (Hbb1 : bb1 ≠ 0). {
  intros H; subst bb1.
  symmetry in Hg1.
  apply ggcd_swap in Hg1.
  specialize (ggcd_succ_l_neq_0 xd (xn + 1)) as H.
  now rewrite <- Nat.add_1_r, Hg1 in H.
}
rewrite Nat.sub_add; [ | flia Haa1 ].
rewrite Nat.sub_add; [ | flia Hbb1 ].
specialize (ggcd_correct_divisors (xn + 1) (xd + 1)) as H1.
rewrite <- Hg1 in H1.
destruct H1 as (H1, H2).
remember (ggcd aa1 bb1) as g eqn:Hg2.
destruct g as (g2, (aa2, bb2)); simpl.
specialize (ggcd_correct_divisors aa1 bb1) as H3.
rewrite <- Hg2 in H3.
destruct H3 as (H3, H4).
move H1 before H3; move H2 before H3.
rewrite H3, Nat.mul_assoc in H1.
rewrite H4, Nat.mul_assoc in H2.
rewrite H1, H2 in Hg1.
remember (g1 * g2) as g eqn:Hg.
specialize (ggcd_gcd (g * aa2) (g * bb2)) as H.
rewrite <- Hg1 in H; simpl in H.
rewrite Nat.gcd_mul_mono_l in H.
rewrite Hg in H; symmetry in H.
rewrite <- Nat.mul_1_r, <- Nat.mul_assoc in H.
apply Nat.mul_cancel_l in H.
-apply Nat.eq_mul_1 in H.
 destruct H as (HH, H); subst g2.
 now rewrite Nat.mul_1_l in H3, H4; subst bb1 aa1.
-intros H5; subst g1; simpl in Hg; subst g.
 now rewrite Nat.add_1_r in H1.
Qed.

Theorem PQred_add_mul_one_l : ∀ x y a, PQred (x + y) = PQred (PQmake a a * x + y).
Proof.
intros (xn, xd) (yn, yd) a.
unfold PQred; simpl.
unfold "*"%PQ, PQ_of_nat.
unfold PQmul_num1, PQmul_den1; simpl.
unfold PQadd_num1, PQadd_den1, nd; simpl.
PQtac1.
PQtac2; [ PQtac2 | simpl; flia ].
PQtac2; [ | simpl; flia ].
do 3 PQtac2.
replace (S yn * (S a * S xd)) with (S a * (S yn * S xd)) by flia.
rewrite <- Nat.mul_assoc, <- Nat.mul_add_distr_l.
rewrite <- Nat.mul_assoc.
rewrite ggcd_mul_mono_l; [ | easy ].
now destruct (ggcd (S xn * S yd + S yn * S xd) (S xd * S yd)).
Qed.

Theorem PQred_sub_mul_one_l : ∀ x y a,
  (y < x)%PQ -> PQred (x - y) = PQred (PQmake a a * x - y).
Proof.
intros (xn, xd) (yn, yd) a Hyx.
unfold PQred; simpl.
unfold "*"%PQ, PQ_of_nat.
unfold PQmul_num1, PQmul_den1; simpl.
unfold PQsub_num1, PQadd_den1, nd; simpl.
revert Hyx; PQtac1; intros.
PQtac2; [ PQtac2 | flia Hyx ].
PQtac2.
-do 3 PQtac2.
 replace (S yn * (S a * S xd)) with (S a * (S yn * S xd)) by flia.
 rewrite <- Nat.mul_assoc, <- Nat.mul_sub_distr_l.
 rewrite <- Nat.mul_assoc.
 rewrite ggcd_mul_mono_l; [ | easy ].
 now destruct (ggcd (S xn * S yd - S yn * S xd) (S xd * S yd)).
-do 2 PQtac2.
 replace (S yn * (S a * S xd)) with (S a * (S yn * S xd)) by flia.
 rewrite <- Nat.mul_assoc, <- Nat.mul_sub_distr_l.
 simpl; flia Hyx.
Qed.

Theorem PQred_sub_mul_one_r : ∀ x y a,
  (y < x)%PQ -> PQred (x - y) = PQred (x - PQmake a a * y).
Proof.
intros (xn, xd) (yn, yd) a Hyx.
unfold PQred; simpl.
unfold "*"%PQ, PQ_of_nat.
unfold PQmul_num1, PQmul_den1; simpl.
unfold PQsub_num1, PQadd_den1, nd; simpl.
revert Hyx; PQtac1; intros.
PQtac2; [ PQtac2 | flia Hyx ].
PQtac2.
-do 3 PQtac2.
 replace (S xn * (S a * S yd)) with (S a * (S xn * S yd)) by flia.
 rewrite <- Nat.mul_assoc, <- Nat.mul_sub_distr_l.
 replace (S xd * (S a * S yd)) with (S a * (S xd * S yd)) by flia.
 rewrite ggcd_mul_mono_l; [ | easy ].
 now destruct (ggcd (S xn * S yd - S yn * S xd) (S xd * S yd)).
-do 2 PQtac2.
 replace (S xn * (S a * S yd)) with (S a * (S xn * S yd)) by flia.
 rewrite <- Nat.mul_assoc, <- Nat.mul_sub_distr_l.
 simpl; flia Hyx.
Qed.

Theorem PQred_mul_mul_one_l : ∀ x y a, PQred (x * y) = PQred (PQmake a a * x * y).
Proof.
intros (xn, xd) (yn, yd) a.
unfold PQred; simpl.
unfold "*"%PQ, PQ_of_nat.
unfold PQmul_num1, PQmul_den1; simpl.
PQtac1.
do 6 PQtac2.
do 2 rewrite <- Nat.mul_assoc.
rewrite ggcd_mul_mono_l; [ | easy ].
now destruct (ggcd (S xn * S yn) (S xd * S yd)).
Qed.

Theorem PQred_eq : ∀ x, (PQred x == x)%PQ.
Proof.
intros (xn, xd).
unfold PQred; simpl.
(**)
remember (ggcd (xn + 1) (xd + 1)) as g eqn:Hg; symmetry in Hg.
destruct g as (g, (aa, bb)).
unfold "=="%PQ, nd; simpl.
specialize (ggcd_correct_divisors (xn + 1) (xd + 1)) as H.
rewrite Hg in H.
destruct H as (Hxn, Hxd).
rewrite Nat.sub_add; cycle 1. {
  destruct aa; [ | flia ].
  now rewrite Nat.add_1_r, Nat.mul_0_r in Hxn.
}
rewrite Nat.sub_add; cycle 1. {
  destruct bb; [ | flia ].
  now rewrite Nat.add_1_r, Nat.mul_0_r in Hxd.
}
rewrite Hxn, Hxd.
now rewrite Nat.mul_comm, Nat.mul_shuffle0.
Qed.

Theorem PQred_lt_l : ∀ x y, (x < y)%PQ ↔ (PQred x < y)%PQ.
Proof. intros; now rewrite PQred_eq. Qed.

Theorem PQred_lt_r : ∀ x y, (x < y ↔ x < PQred y)%PQ.
Proof. intros; now rewrite PQred_eq. Qed.

Theorem PQred_lt : ∀ x y, (x < y)%PQ ↔ (PQred x < PQred y)%PQ.
Proof. intros; now do 2 rewrite PQred_eq. Qed.

Theorem PQred_le_l : ∀ x y, (x ≤ y)%PQ ↔ (PQred x ≤ y)%PQ.
Proof. intros; now rewrite PQred_eq. Qed.

Theorem PQred_le_r : ∀ x y, (x ≤ y)%PQ → (x ≤ PQred y)%PQ.
Proof. intros; now rewrite PQred_eq. Qed.

Theorem PQred_le : ∀ x y, (x ≤ y)%PQ ↔ (PQred x ≤ PQred y)%PQ.
Proof. intros; now do 2 rewrite PQred_eq. Qed.

Theorem PQred_add_l : ∀ x y, PQred (x + y) = PQred (PQred x + y).
Proof.
intros.
remember (Nat.gcd (PQnum1 x + 1) (PQden1 x + 1)) as a eqn:Ha.
rewrite (PQred_add_mul_one_l (PQred x) y (a - 1)).
f_equal; f_equal.
destruct x as (xn, xd).
simpl in Ha.
unfold "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1; simpl.
unfold PQred; simpl.
specialize (ggcd_split (xn + 1) (xd + 1) a Ha) as H.
rewrite H; simpl.
destruct a.
-symmetry in Ha.
 apply Nat.gcd_eq_0_l in Ha; flia Ha.
-replace (S a - 1 + 1) with (S a) by flia.
 assert (H2 : (xn + 1) / S a ≠ 0). {
   intros H1.
   apply Nat.div_small_iff in H1; [ | easy ].
   specialize (Nat_gcd_le_l (xn + 1) (xd +  1)) as H2.
   assert (H3 : xn + 1 ≠ 0) by flia.
   specialize (H2 H3).
   flia Ha H1 H2.
 }
 assert (H3 : (xd + 1) / S a ≠ 0). {
   intros H1.
   apply Nat.div_small_iff in H1; [ | easy ].
   specialize (Nat_gcd_le_r (xn + 1) (xd +  1)) as H3.
   assert (H4 : xd + 1 ≠ 0) by flia.
   specialize (H3 H4).
   flia Ha H1 H3.
 }
 rewrite Nat.sub_add; [ | flia H2 ].
 rewrite Nat.sub_add; [ | flia H3 ].
 specialize (Nat.gcd_divide_l (xn + 1) (xd + 1)) as (c1, Hc1).
 rewrite <- Ha in Hc1; rewrite Hc1.
 rewrite Nat.div_mul; [ | easy ].
 rewrite Nat.mul_comm, <- Hc1, Nat.add_sub.
 specialize (Nat.gcd_divide_r (xn + 1) (xd + 1)) as (c2, Hc2).
 rewrite <- Ha in Hc2; rewrite Hc2.
 rewrite Nat.div_mul; [ | easy ].
 rewrite Nat.mul_comm, <- Hc2, Nat.add_sub.
 easy.
Qed.

Theorem PQred_sub_l : ∀ x y, (y < x)%PQ → PQred (x - y) = PQred (PQred x - y).
Proof.
intros * Hyx.
remember (Nat.gcd (PQnum1 x + 1) (PQden1 x + 1)) as a eqn:Ha.
rewrite (PQred_sub_mul_one_l (PQred x) y (a - 1)); cycle 1. {
  now apply -> PQred_lt_r.
}
destruct x as (xn, xd).
simpl in Ha.
unfold "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1; simpl.
unfold PQred; simpl.
specialize (ggcd_split (xn + 1) (xd + 1) a Ha) as H.
rewrite H; simpl.
destruct a.
-symmetry in Ha.
 apply Nat.gcd_eq_0_l in Ha; flia Ha.
-replace (S a - 1 + 1) with (S a) by flia.
 assert (H2 : (xn + 1) / S a ≠ 0). {
   intros H1.
   apply Nat.div_small_iff in H1; [ | easy ].
   specialize (Nat_gcd_le_l (xn + 1) (xd +  1)) as H2.
   assert (H3 : xn + 1 ≠ 0) by flia.
   specialize (H2 H3).
   flia Ha H1 H2.
 }
 assert (H3 : (xd + 1) / S a ≠ 0). {
   intros H1.
   apply Nat.div_small_iff in H1; [ | easy ].
   specialize (Nat_gcd_le_r (xn + 1) (xd +  1)) as H3.
   assert (H4 : xd + 1 ≠ 0) by flia.
   specialize (H3 H4).
   flia Ha H1 H3.
 }
 rewrite Nat.sub_add; [ | flia H2 ].
 rewrite Nat.sub_add; [ | flia H3 ].
 specialize (Nat.gcd_divide_l (xn + 1) (xd + 1)) as (c1, Hc1).
 rewrite <- Ha in Hc1; rewrite Hc1.
 rewrite Nat.div_mul; [ | easy ].
 rewrite Nat.mul_comm, <- Hc1, Nat.add_sub.
 specialize (Nat.gcd_divide_r (xn + 1) (xd + 1)) as (c2, Hc2).
 rewrite <- Ha in Hc2; rewrite Hc2.
 rewrite Nat.div_mul; [ | easy ].
 rewrite Nat.mul_comm, <- Hc2, Nat.add_sub.
 easy.
Qed.

Theorem PQred_sub_r : ∀ x y, (y < x)%PQ → PQred (x - y) = PQred (x - PQred y).
Proof.
intros * Hyx.
remember (Nat.gcd (PQnum1 y + 1) (PQden1 y + 1)) as a eqn:Ha.
rewrite (PQred_sub_mul_one_r x (PQred y) (a - 1)); cycle 1. {
  now apply -> PQred_lt_l.
}
destruct y as (yn, yd).
simpl in Ha.
unfold "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1; simpl.
unfold PQred; simpl.
specialize (ggcd_split (yn + 1) (yd + 1) a Ha) as H.
rewrite H; simpl.
destruct a.
-symmetry in Ha.
 apply Nat.gcd_eq_0_l in Ha; flia Ha.
-replace (S a - 1 + 1) with (S a) by flia.
 assert (H2 : (yn + 1) / S a ≠ 0). {
   intros H1.
   apply Nat.div_small_iff in H1; [ | easy ].
   specialize (Nat_gcd_le_l (yn + 1) (yd +  1)) as H2.
   assert (H3 : yn + 1 ≠ 0) by flia.
   specialize (H2 H3).
   flia Ha H1 H2.
 }
 assert (H3 : (yd + 1) / S a ≠ 0). {
   intros H1.
   apply Nat.div_small_iff in H1; [ | easy ].
   specialize (Nat_gcd_le_r (yn + 1) (yd +  1)) as H3.
   assert (H4 : yd + 1 ≠ 0) by flia.
   specialize (H3 H4).
   flia Ha H1 H3.
 }
 rewrite Nat.sub_add; [ | flia H2 ].
 rewrite Nat.sub_add; [ | flia H3 ].
 specialize (Nat.gcd_divide_l (yn + 1) (yd + 1)) as (c1, Hc1).
 rewrite <- Ha in Hc1; rewrite Hc1.
 rewrite Nat.div_mul; [ | easy ].
 rewrite Nat.mul_comm, <- Hc1, Nat.add_sub.
 specialize (Nat.gcd_divide_r (yn + 1) (yd + 1)) as (c2, Hc2).
 rewrite <- Ha in Hc2; rewrite Hc2.
 rewrite Nat.div_mul; [ | easy ].
 rewrite Nat.mul_comm, <- Hc2, Nat.add_sub.
 easy.
Qed.

Theorem PQred_add : ∀ x y, PQred (x + y) = PQred (PQred x + PQred y).
Proof.
intros.
rewrite PQred_add_l, PQadd_comm.
rewrite PQred_add_l, PQadd_comm.
easy.
Qed.
(* merci Bérénice ! *)

Theorem PQred_sub : ∀ x y,
  (y < x)%PQ → PQred (x - y) = PQred (PQred x - PQred y).
Proof.
intros.
rewrite PQred_sub_l; [ | easy ].
rewrite PQred_sub_r; [ easy | ].
now apply -> PQred_lt_r.
Qed.

Theorem PQred_mul_l : ∀ x y, PQred (x * y) = PQred (PQred x * y).
Proof.
intros.
remember (Nat.gcd (PQnum1 x + 1) (PQden1 x + 1)) as a eqn:Ha.
rewrite (PQred_mul_mul_one_l (PQred x) y (a - 1)).
destruct x as (xn, xd).
simpl in Ha.
unfold "*"%PQ; simpl.
unfold PQmul_num1, PQmul_den1; simpl.
unfold PQred; simpl.
specialize (ggcd_split (xn + 1) (xd + 1) a Ha) as H.
rewrite H; simpl.
destruct a.
-symmetry in Ha.
 apply Nat.gcd_eq_0_l in Ha; flia Ha.
-replace (S a - 1 + 1) with (S a) by flia.
 assert (H2 : 1 ≤ (xn + 1) / S a). {
   apply Nat.div_str_pos.
   split; [ apply Nat.lt_0_succ | ].
   rewrite Ha; apply Nat_gcd_le_l.
   now rewrite Nat.add_1_r.
 }
 assert (H3 : 1 ≤ (xd + 1) / S a). {
   apply Nat.div_str_pos.
   split; [ apply Nat.lt_0_succ | ].
   rewrite Ha; apply Nat_gcd_le_r.
   now rewrite Nat.add_1_r.
 }
 do 4 (rewrite Nat.sub_add; [ | do 2 rewrite Nat.add_1_r; simpl; flia ]).
 rewrite Nat.sub_add; [ | easy ].
 rewrite Nat.sub_add.
 +rewrite Nat.sub_add.
  *rewrite Nat.sub_add; [ | easy ].
   rewrite <- Nat.divide_div_mul_exact; [ | easy | ].
  --rewrite <- Nat.divide_div_mul_exact; [ | easy | ].
   ++replace (S a * (xn + 1)) with ((xn + 1) * S a) by apply Nat.mul_comm.
     replace (S a * (xd + 1)) with ((xd + 1) * S a) by apply Nat.mul_comm.
     rewrite Nat.div_mul; [ | easy ].
     now rewrite Nat.div_mul.
   ++rewrite Ha; apply Nat.gcd_divide_r.
  --rewrite Ha; apply Nat.gcd_divide_l.
  *rewrite Nat.sub_add; [ | easy ].
   rewrite <- Nat.divide_div_mul_exact; [ | easy | ].
  --rewrite Nat.mul_comm, Nat.div_mul; [ flia | easy ].
  --rewrite Ha; apply Nat.gcd_divide_r.
 +rewrite Nat.sub_add.
  *rewrite Nat.sub_add; [ | easy ].
   do 2 rewrite Nat.add_1_r.
   eapply Nat.le_trans; [ | apply Nat_mul_le_pos_r; flia ].
   do 2 rewrite Nat.add_1_r in Ha.
   rewrite <- Nat.divide_div_mul_exact; [ | easy | ].
  --rewrite Nat.mul_comm, Nat.div_mul; [ flia | easy ].
  --rewrite Ha; apply Nat.gcd_divide_r.
  *rewrite Nat.sub_add; [ | easy ].
   rewrite <- Nat.divide_div_mul_exact; [ | easy | ].
  --rewrite Nat.mul_comm, Nat.div_mul; [ flia | easy ].
  --rewrite Ha; apply Nat.gcd_divide_r.
Qed.

Theorem PQred_mul_r : ∀ x y, PQred (x * y) = PQred (x * PQred y).
Proof.
intros.
setoid_rewrite PQmul_comm.
apply PQred_mul_l.
Qed.

Theorem PQred_mul : ∀ x y, PQred (x * y) = PQred (PQred x * PQred y).
Proof.
intros.
now rewrite PQred_mul_l, PQred_mul_r.
Qed.

Theorem PQred_gcd : ∀ x,
  Nat.gcd (PQnum1 (PQred x) + 1) (PQden1 (PQred x) + 1) = 1.
Proof.
intros.
unfold PQred.
remember (ggcd (PQnum1 x + 1) (PQden1 x + 1)) as g eqn:Hg1.
destruct g as (g1, (aa1, bb1)); simpl.
remember (Nat.gcd (PQnum1 x + 1) (PQden1 x + 1)) as g eqn:Hg.
specialize (ggcd_split _ _ _ Hg) as H.
rewrite <- Hg1 in H.
do 2 rewrite Nat.add_1_r in Hg1; symmetry in Hg1.
rewrite Nat.sub_add.
-rewrite Nat.sub_add.
 +injection H; clear H; intros; subst g1 aa1 bb1.
  apply ggcd_succ_l in Hg1.
  now apply Nat.gcd_div_gcd.
 +apply ggcd_succ_r in Hg1; flia Hg1.
-apply ggcd_succ_l in Hg1; flia Hg1.
Qed.

Theorem gcd_1_PQred : ∀ x,
  Nat.gcd (PQnum1 x + 1) (PQden1 x + 1) = 1
  → x = PQred x.
Proof.
intros x Hx.
destruct x as (xn, xd).
rewrite <- ggcd_gcd in Hx.
unfold PQred.
remember ggcd as f; cbn in Hx; cbn; subst f.
remember (ggcd (xn + 1) (xd + 1)) as g eqn:Hg.
destruct g as (g, (aa, bb)); cbn in Hx; subst g.
specialize (ggcd_correct_divisors (xn + 1) (xd + 1)) as H.
rewrite <- Hg in H; do 2 rewrite Nat.mul_1_l in H.
destruct H as (Hxn, Hxd).
subst aa bb.
now do 2 rewrite Nat.add_sub.
Qed.

Theorem PQeq_red_l : ∀ x y,
  x = PQred x → (x == y)%PQ → ∃ a, y = (a // a * x)%PQ.
Proof.
intros * Hx Hxy.
unfold "=="%PQ, nd in Hxy.
specialize (PQred_gcd x) as Hg.
rewrite <- Hx in Hg.
destruct x as (xn, xd), y as (yn, yd).
cbn in Hxy, Hg.
assert (Hd : Nat.divide (xn + 1) ((xd + 1) * (yn + 1))). {
  rewrite Nat.mul_comm, <- Hxy.
  exists (yd + 1).
  apply Nat.mul_comm.
}
specialize (Nat.gauss _ _ _ Hd Hg) as H1.
destruct H1 as (c, Hc).
exists c.
unfold "*"%PQ; cbn.
rewrite Nat.sub_add; cycle 1. {
  destruct c; [ now rewrite Nat.add_1_r in Hc | flia ].
}
rewrite <- Hc.
rewrite Nat.add_sub; f_equal.
symmetry in Hxy.
rewrite Hc, Nat.mul_shuffle0, Nat.mul_comm in Hxy.
apply Nat.mul_cancel_l in Hxy; [ | flia ].
now rewrite Hxy, Nat.add_sub.
Qed.

Theorem PQeq_red : ∀ x y,
  x = PQred x → y = PQred y → (x == y)%PQ ↔ x = y.
Proof.
intros * Hx Hy.
split; [ | now intros; subst y ].
intros Hxy.
specialize (PQeq_red_l x y Hx Hxy) as H1.
symmetry in Hxy.
specialize (PQeq_red_l y x Hy Hxy) as H2.
destruct H1 as (c, Hc).
destruct H2 as (d, Hd).
move d before c.
destruct x as (xn, xd), y as (yn, yd).
unfold "*"%PQ in Hc, Hd.
cbn in Hc, Hd.
injection Hc; clear Hc; intros H1 H2.
injection Hd; clear Hd; intros H3 H4.
destruct d.
-cbn in H3, H4.
 rewrite Nat.add_0_r, Nat.add_sub in H3, H4.
 now subst xd xn.
-rewrite Nat.sub_add in H3, H4; [ | flia | flia ].
 destruct c.
 +cbn in H1, H2.
  rewrite Nat.add_0_r, Nat.add_sub in H1, H2.
  now subst xd xn.
 +rewrite Nat.sub_add in H1, H2; [ | flia | flia ].
  cbn in H1, H2, H3, H4.
  rewrite Nat.add_shuffle0, Nat.add_sub in H1, H2, H3, H4.
  rewrite H1 in H3 at 1.
  assert (H : c * (xd + 1) + d * (yd + 1) = 0) by flia H3.
  apply Nat.eq_add_0 in H.
  destruct H as (H5, H6).
  apply Nat.eq_mul_0 in H5.
  apply Nat.eq_mul_0 in H6.
  destruct H5 as [H5| H5]; [ | flia H5].
  destruct H6 as [H6| H6]; [ | flia H6].
  subst c d.
  rewrite Nat.mul_0_l, Nat.add_0_r in H1, H2.
  now subst yn yd.
Qed.

Theorem PQred_diag : ∀ x, x ≠ 0 → PQred (x // x) = 1%PQ.
Proof.
intros * Hx.
unfold PQred.
remember ggcd as f; cbn; subst f.
rewrite Nat.sub_add; [ | flia Hx ].
now rewrite ggcd_diag.
Qed.

Theorem PQle_decidable : ∀ x y, Decidable.decidable (x ≤ y)%PQ.
Proof.
intros.
unfold Decidable.decidable.
apply Nat.le_decidable.
Qed.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence.
Require Import rt.model.schedule.uni.schedule.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop seq path finfun.

Module ScheduleConstruction.

  Import Job ArrivalSequence UniprocessorSchedule.

 (* In this section, we construct a schedule recursively by augmenting prefixes. *)
  Section ConstructionFromPrefixes.

    Context {Job: eqType}.

    (* Let arr_seq be any arrival sequence.*)
    Variable arr_seq: arrival_sequence Job.

    (* Assume we are given a function that takes an existing schedule prefix
       up to interval [0, t) and returns what should be scheduled at time t. *)
    Variable build_schedule:
      schedule Job -> time -> option Job.

    (* Then, starting from a base schedule, ... *)
    Variable base_sched: schedule Job.

    (* ...we can update individual times using the build_schedule function, ... *)
    Definition update_schedule (prev_sched: schedule Job)
                               (t_next: time) : schedule Job :=
      fun t =>
        if t == t_next then
          build_schedule prev_sched t
        else prev_sched t.

    (* ...which recursively generates schedule prefixes up to time t_max. *)
    Fixpoint schedule_prefix (t_max: time) : schedule Job :=
      if t_max is t_prev.+1 then
        update_schedule (schedule_prefix t_prev) t_prev.+1
      else
        update_schedule base_sched 0.

    (* Based on the schedule prefixes, we construct a complete schedule. *)
    Definition build_schedule_from_prefixes := fun t => schedule_prefix t t.

    (* In this section, we prove some lemmas about the construction. *)
    Section Lemmas.

      (* Let sched be the generated schedule. *)
      Let sched := build_schedule_from_prefixes.

      (* First, we show that the scheduler preserves its prefixes. *)
      Lemma prefix_construction_same_prefix:
        forall t t_max,
          t <= t_max ->
          schedule_prefix t_max t = sched t.
      Proof.
        intros t t_max LEt.
        induction t_max;
          first by rewrite leqn0 in LEt; move: LEt => /eqP EQ; subst.
        rewrite leq_eqVlt in LEt.
        move: LEt => /orP [/eqP EQ | LESS]; first by subst.
        {
          feed IHt_max; first by done.
          unfold schedule_prefix, update_schedule at 1.
          assert (FALSE: t == t_max.+1 = false).
          {
            by apply negbTE; rewrite neq_ltn LESS orTb.
          } rewrite FALSE.
          by rewrite -IHt_max.
        }
      Qed.

      Section ServiceDependent.

        (* If the generation function only depends on the service
         received by jobs during the schedule prefix, ...*)
        Hypothesis H_depends_only_on_service:
          forall sched1 sched2 t,
            (forall j, service sched1 j t = service sched2 j t) ->
            build_schedule sched1 t = build_schedule sched2 t.

        (* ...then we can prove that the final schedule, at any time t,
         is exactly the result of the construction function. *)
        Lemma service_dependent_schedule_construction:
          forall t,
            sched t = build_schedule sched t.
        Proof.
          intros t.
          feed (prefix_construction_same_prefix t t); [by done | intros EQ].
          rewrite -{}EQ.
          induction t as [t IH] using strong_ind.
          destruct t.
          {
            rewrite /= /update_schedule eq_refl.
            apply H_depends_only_on_service.
              by intros j; rewrite /service /service_during big_geq // big_geq //.
          }
          {
            rewrite /= /update_schedule eq_refl.
            apply H_depends_only_on_service.
            intros j; rewrite /service /service_during.
            rewrite big_nat_recr //= big_nat_recr //=; f_equal.
            apply eq_big_nat; move => i /= LT.
            rewrite /service_at /scheduled_at.
              by rewrite prefix_construction_same_prefix; last by apply ltnW.
          }
        Qed.

      End ServiceDependent.

      Section PrefixDependent.

        (* If the generation function only depends on the schedule prefix, ... *)
        Hypothesis H_depends_only_on_prefix:
          forall (sched1 sched2: schedule Job) t,
            (forall t0, t0 < t -> sched1 t0 = sched2 t0) ->
            build_schedule sched1 t = build_schedule sched2 t.

        (* ...then we can prove that the final schedule, at any time t,
         is exactly the result of the construction function. *)
        Lemma prefix_dependent_schedule_construction:
          forall t, sched t = build_schedule sched t.
        Proof.
          intros t.
          feed (prefix_construction_same_prefix t t); [by done | intros EQ].
          rewrite -{}EQ.
          induction t using strong_ind.
          destruct t.
          {
            rewrite /= /update_schedule eq_refl.
            apply H_depends_only_on_prefix.
            by intros t; rewrite ltn0.
          }
          {
            rewrite /= /update_schedule eq_refl.
            apply H_depends_only_on_prefix.
            intros t0 LT.
            by rewrite prefix_construction_same_prefix.
          }
        Qed.

      End PrefixDependent.

      Section ImmediateProperty.

        Variable P: option Job -> Prop.

        Hypothesis H_immediate_property:
          forall sched_prefix t, P (build_schedule sched_prefix t).

        Lemma immediate_property_of_schedule_construction:
          forall t, P (sched t).
        Proof.
          destruct t.
          {
            rewrite /sched /build_schedule_from_prefixes /schedule_prefix /update_schedule eq_refl.
            by apply H_immediate_property.
          }
          {
            rewrite /sched /build_schedule_from_prefixes /schedule_prefix /update_schedule eq_refl.
            by apply H_immediate_property.
          }
        Qed.

      End ImmediateProperty.

    End Lemmas.

  End ConstructionFromPrefixes.

End ScheduleConstruction.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : lst) (x : lst) : lst := append x (append x Nil).


(**************************)
(**************************)
(****                  ****)
(****   Typing rules   ****)
(****                  ****)
(**************************)
(**************************)

Require Import Main.STLC.Name.
Require Import Main.STLC.Syntax.

Inductive context :=
| cEmpty : context
| cExtend : context -> name -> type -> context.

Fixpoint lookup c1 x1 :=
  match c1 with
  | cEmpty => None
  | cExtend c2 x2 t => if nameEq x1 x2 then Some t else lookup c2 x1
  end.

Inductive hasType : context -> term -> type -> Prop :=
| htTrue :
  forall c,
  hasType c eTrue tBool
| htFalse :
  forall c,
  hasType c eFalse tBool
| htIf :
  forall c e1 e2 e3 t,
  hasType c e1 tBool ->
  hasType c e2 t ->
  hasType c e3 t ->
  hasType c (eIf e1 e2 e3) t
| htVar :
  forall c t x,
  lookup c x = Some t ->
  hasType c (eVar x) t
| htAbs :
  forall c e t1 t2 x,
  hasType (cExtend c x t2) e t1 ->
  hasType c (eAbs x t2 e) (tArrow t2 t1)
| htApp :
  forall c e1 e2 t1 t2,
  hasType c e1 (tArrow t2 t1) ->
  hasType c e2 t2 ->
  hasType c (eApp e1 e2) t1.

#[export] Hint Constructors hasType : main.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : natural) (lf2 : lst) : natural := len lf2.


Require Import List.
Import ListNotations.

Require Import Cryptol.Coqlib.
Require Import Program.
Require Import Omega.

Program Fixpoint repeat_z {A} (x : A) (z : Z) {measure (Z.to_nat z)} : list A :=
  if Z_le_dec z 0 then nil else
    x :: (repeat_z x (z - 1)).
Next Obligation.
eapply Z2Nat.inj_lt; omega.
Defined.

(* generate a list of Zs including lo up to hi-1 *)
Program Fixpoint zrange (lo hi : Z) {measure (Z.to_nat (hi - lo))} : list Z :=
  if Z_lt_dec lo hi then
    lo :: zrange (lo + 1) hi
  else nil.
Next Obligation.
eapply Z2Nat.inj_lt; omega.
Defined.

Lemma zrange_eq :
  forall lo hi,
    zrange lo hi = if Z_lt_dec lo hi then
                     lo :: zrange (lo + 1) hi
                   else nil.
Proof.
  intros.
  unfold zrange at 1.
  unfold zrange_func.
  rewrite fix_sub_eq.
  reflexivity.
  intros.
  destruct (Z_lt_dec (projT1 x) (projT2 x)); auto.
  f_equal. f_equal.
Qed.

Lemma Forall2_modus_ponens :
  forall {A B : Type} (P Q : A -> B -> Prop) (l : list A) (l' : list B),
    Forall2 P l l' ->
    Forall2 (fun x y => P x y -> Q x y) l l' ->
    Forall2 Q l l'.
Proof.
  induction 1; intros. econstructor; eauto.
  inversion H1. subst.
  econstructor; eauto.
Qed.

Lemma Forall2_implies_1 :
  forall {A B C : Type} (l1 : list A) (l2 : list B) (P : C -> Prop) (Q : C -> A -> B -> Prop),
    Forall2 (fun a b => forall x, P x -> Q x a b) l1 l2 ->
    forall x,
      P x ->
      Forall2 (Q x) l1 l2.
Proof.
  induction 1; intros; econstructor; eauto.
Qed.

Lemma Forall2_implies_2 :
  forall {A B C D : Type} (l1 : list A) (l2 : list B) (P : C -> D -> Prop) (Q : C -> D -> A -> B -> Prop),
    Forall2 (fun a b => forall x y, P x y -> Q x y a b) l1 l2 ->
    forall x y,
      P x y ->
      Forall2 (Q x y) l1 l2.
Proof.
  induction 1; intros; econstructor; eauto.
Qed.

Lemma Forall2_implies_3 :
  forall {A B C D E : Type} (l1 : list A) (l2 : list B) (P : C -> D -> E -> Prop) (Q : C -> D -> E -> A -> B -> Prop),
    Forall2 (fun a b => forall x y z, P x y z -> Q x y z a b) l1 l2 ->
    forall x y z,
      P x y z ->
      Forall2 (Q x y z) l1 l2.
Proof.
  induction 1; intros; econstructor; eauto.
Qed.

Lemma Forall_Forall2_implies :
  forall {A B} (P : A -> Prop) (Q R : A -> B -> Prop) (l : list A),
    Forall P l ->
    (forall a, P a -> forall b, Q a b -> R a b) ->
    forall (vs : list B),
      Forall2 Q l vs ->
      Forall2 R l vs.
Proof.
  induction 1; intros.
  inversion H0. subst.
  econstructor.
  inversion H2. subst.
  econstructor; eauto.
Qed.

Lemma Forall_Forall2_implies_in :
  forall {A B} (P : A -> Prop) (Q R : A -> B -> Prop) (l : list A),
    Forall P l ->
    (forall a, In a l -> P a -> forall b, Q a b -> R a b) ->
    forall (vs : list B),
      Forall2 Q l vs ->
      Forall2 R l vs.
Proof.
  induction 1; intros.
  inversion H0. subst.
  econstructor.
  inversion H2. subst.

  econstructor; eauto.

  eapply H1; eauto. simpl. left. reflexivity.
  eapply IHForall; eauto.
  intros. eapply H1; eauto.
  simpl. right. auto.
Qed.

(* Just like Forall2, but with 3 lists *)
(* Good for modeling evaluation of binary operators *)
Inductive Forall3 {A B C : Type} (TR : A -> B -> C -> Prop) : list A -> list B -> list C -> Prop :=
| Forall3_nil :
    Forall3 TR [] [] []
| Forall3_cons :
    forall x y z lx ly lz,
      TR x y z ->
      Forall3 TR lx ly lz ->
      Forall3 TR (x :: lx) (y :: ly) (z :: lz).

Lemma length_cons :
  forall {A} (e : A) l,
    Datatypes.length (e :: l) = S (Datatypes.length l).
Proof.
  reflexivity.
Qed.

Lemma map_cons :
  forall {A B} (f : A -> B) (e : A) l,
    map f (e :: l) = (f e) :: (map f l).
Proof.
  reflexivity.
Qed.

Lemma succ_nat_pred :
  forall n,
    (Z.of_nat (S n)) - 1 = Z.of_nat n.
Proof.
  intros.
  repeat rewrite Nat2Z.inj_succ.
  omega.
Qed.

Lemma Forall_app :
  forall {A} (l1 l2 : list A) P,
    Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2.
Proof.
  induction l1; intros; split; intros; simpl; auto.
  destruct H. auto.
  simpl in H. inversion H. subst.
  rewrite IHl1 in H3.
  destruct H3. split.
  econstructor; eauto.
  eauto.
  destruct H. inversion H. econstructor; eauto.
  rewrite IHl1. split; eauto.
Qed.

Lemma Forall_map :
  forall {A} (l : list A) P f,
    Forall P l ->
    (forall x, P x -> P (f x)) ->
    Forall P (map f l).
Proof.
  induction 1; intros; simpl; auto.
Qed.

Lemma firstn_map :
  forall {A B: Type} (f : A -> B)  n l,
    firstn n (map f l) = map f (firstn n l).
Proof.
  induction n; intros.
  simpl. reflexivity.
  simpl. destruct l; simpl. reflexivity.
  f_equal. eapply IHn.
Qed.

Lemma map_repeat_nil :
  forall {A B} k (f : A -> B),
    repeat [] k = map (map f) (repeat [] k).
Proof.
  induction k; intros; simpl; auto.
  f_equal. auto.
Qed.

Lemma length_list_drop :
  forall {A} (l : list A) n,
    (n > O)%nat ->
    l <> nil ->
    (Datatypes.length (list_drop n l) < Datatypes.length l)%nat.
Proof.
  induction l; intros.
  destruct n; simpl; try omega; congruence.
  simpl.
  destruct n; try omega.
  simpl.
  destruct n; try solve [simpl; auto].
  specialize (IHl (S n)).
  assert (l = nil \/ l <> []) by (destruct l; try solve [left; congruence]; right; congruence).
  destruct H1. subst l; simpl; auto.
  assert (S n > O)%nat by omega.
  eapply IHl in H2; try eapply H1. omega.
Qed.

Lemma map_injective_function :
  forall {A B} (f : A -> B) (l : list A),
    Forall (fun a => (forall b, f a = f b -> a = b)) l ->
    forall l',
      map f l = map f l' ->
      l = l'.
Proof.
  induction l; intros; simpl in *.
  destruct l'; simpl in *; try congruence; auto.
  destruct l'; simpl in *; try congruence.
  inversion H0.
  inversion H. subst. eapply H5 in H2. subst.
  f_equal.
  eapply IHl; eauto.
Qed.

Lemma combine_injective :
  forall {A B : Type} (l1 : list A) (l2 : list B),
  forall l3 l4,
    combine l1 l2 = combine l3 l4 ->
    (Datatypes.length l1 = Datatypes.length l2) ->
    (Datatypes.length l3 = Datatypes.length l4) ->
    l1 = l3 /\ l2 = l4.
Proof.
  induction l1; intros; simpl in *.
  destruct l2; destruct l3; destruct l4; simpl in *; try congruence.
  split; auto.
  destruct l2; destruct l3; destruct l4; simpl in *; try congruence.
  inversion H0. inversion H1. inversion H. subst. clear H H0 H1.
  eapply IHl1 in H7; eauto. destruct H7. subst. split; auto.
Qed.

Lemma list_pair_parts_eq :
  forall {A B : Type} (l1 l2 : list (A * B)),
    map fst l1 = map fst l2 ->
    map snd l1 = map snd l2 ->
    l1 = l2.
Proof.
  induction l1; intros;
    destruct l2; simpl in *; try congruence.
  inversion H. inversion H0.
  f_equal.
  destruct a; destruct p; simpl in *.
  congruence.
  subst.
  eapply IHl1; eauto.
Qed.

Lemma firstn_app :
  forall {A} (l : list A) l',
    firstn (length l) (l ++ l') = l.
Proof.
  induction l; intros; simpl; auto.
  f_equal. eapply IHl.
Qed.

Lemma list_drop_app :
  forall {A} (l : list A) l',
    list_drop (length l) (l ++ l') = l'.
Proof.
  induction l; intros; simpl; auto.
Qed.

Lemma list_drop_length :
  forall {A} (l : list A) n,
    (length (list_drop n l) <= length l)%nat.
Proof.
  induction l; intros.
  simpl. destruct n; simpl; omega.
  simpl. destruct n; simpl. omega.
  specialize (IHl n). omega.
Qed.

Lemma list_drop_all :
  forall {A} (l : list A),
    list_drop (length l) l = nil.
Proof.
  induction l; simpl; auto.
Qed.

Lemma map_repeat :
  forall {A B} (f : A -> B) n x,
    map f (repeat x n) = repeat (f x) n.
Proof.
  induction n; intros; eauto.
  simpl. f_equal. eauto.
Qed.

Lemma list_drop_Forall :
  forall {A} P (l : list A),
    Forall P l ->
    forall n,
      Forall P (list_drop n l).
Proof.
  induction l; intros.
  destruct n; simpl; econstructor.
  inversion H. subst.
  eapply IHl with (n := n) in H3.
  inversion H.
  destruct n; simpl; try econstructor; eauto.
Qed.

Lemma firstn_Forall :
  forall {A} P (l : list A),
    Forall P l ->
    forall n,
      Forall P (firstn n l).
Proof.
  induction l; intros.
  destruct n; simpl; econstructor.
  inversion H. subst.
  eapply IHl with (n := n) in H3.
  inversion H. subst.
  destruct n; simpl; try econstructor; eauto.
Qed.

Lemma list_drop_length_eq :
  forall {A} (l : list A) n,
    (n <= length l)%nat ->
    length (list_drop n l) = (length l - n)%nat.
Proof.
  induction l; intros.
  destruct n; simpl; auto.
  destruct n; simpl; auto.
  simpl in H.
  eapply IHl; eauto; omega.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Epsilon operator                                                        *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Definition and specification of Hilbert's epsilon operator *)

(* ---------------------------------------------------------------------- *)
(** ** Construction of epsilon *)

(* TODO: inline the lemma? *)
Lemma Inhab_witness : forall `{Inhab A}, { x : A | True }.
Proof using. intros. destruct H as [H]. apply~ indefinite_description. Qed.

Lemma epsilon_def : forall `{Inhab A} (P : A->Prop),
  { x : A | (exists y, P y) -> P x }.
Proof using.
  intros A I P. destruct (classicT (exists y, P y)) as [H|H].
    apply indefinite_description. destruct H. exists~ x.
    destruct (@Inhab_witness _ I) as [x _].
     exists x. auto_false~.
Qed.

Definition epsilon `{Inhab A} (P : A -> Prop) : A
  := proj1_sig (epsilon_def P).

(* ---------------------------------------------------------------------- *)
(** ** Specification of epsilon *)

Lemma epsilon_spec_exists : forall `{Inhab A} (P : A->Prop),
  (exists x, P x) -> P (epsilon P).
Proof using. intros. apply~ (proj2_sig (epsilon_def P)). Qed.

Lemma epsilon_elim_exists : forall `{Inhab A} (P Q : A->Prop),
  (exists x, P x) -> (forall x, P x -> Q x) -> Q (epsilon P).
Proof using. introv E M. apply M. apply~ epsilon_spec_exists. Qed.

Lemma epsilon_spec : forall `{Inhab A} (P : A->Prop) x,
  P x -> P (epsilon P).
Proof using. intros. apply* (epsilon_spec_exists). Qed.

Lemma epsilon_elim : forall `{Inhab A} (P Q : A->Prop) x,
  P x -> (forall x, P x -> Q x) -> Q (epsilon P).
Proof using. introv Px W. apply W. apply* epsilon_spec_exists. Qed.

Lemma epsilon_eq : forall A {I:Inhab A} (P P':A->Prop),
  (forall x, P x <-> P' x) ->
  epsilon P = epsilon P'.
Proof using. introv H. fequals. apply~ prop_ext_1. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to work with [epsilon] *)

(* TODO: comment and demos *)

Lemma epsilon_spec' : forall A (P:A->Prop) (x:A),
  forall (H:P x) {IA:Inhab A}, P (epsilon P).
Proof using. intros. applys* epsilon_spec. Qed.

Lemma epsilon_spec_exists' : forall A (P : A->Prop) {IA:Inhab A},
  (exists x, P x) -> P (epsilon P).
Proof using. intros. applys* epsilon_spec_exists. Qed.

Ltac find_epsilon cont :=
  match goal with
  | |- context [epsilon ?E] => cont E
  | H: context [epsilon ?E] |- _ => cont E
  end.

Ltac find_epsilon_in H cont :=
  match type of H with context [epsilon ?E] => cont E end.

Ltac spec_epsilon_post E X W I :=
   first [ lets I: (>> (@epsilon_spec' _ E W) __ __)
         | lets I: (>> (@epsilon_spec' _ E _ W) __)  ];
   [ | sets X: (epsilon E) ].

Ltac spec_epsilon_exists_post E X I :=
   lets I: (>> (@epsilon_spec_exists' _ E) __ __); [ | sets X: (epsilon E) ].

Tactic Notation "sets_epsilon" "as" ident(X) :=
  find_epsilon ltac:(fun E => sets X: (epsilon E)).

Tactic Notation "sets_epsilon" "in" hyp(H) "as" ident(X) :=
  find_epsilon_in H ltac:(fun E => sets X: (epsilon E)).

Tactic Notation "spec_epsilon" constr(W) "as" ident(X) simple_intropattern(I) :=
  find_epsilon ltac:(fun E => spec_epsilon_post E X W I).

Tactic Notation "spec_epsilon" constr(W) "in" hyp(H) "as" ident(X) simple_intropattern(I) :=
  find_epsilon_in H ltac:(fun E => spec_epsilon_post E X W I).

Tactic Notation "spec_epsilon" "as" ident(X) simple_intropattern(I) :=
  find_epsilon ltac:(fun E => spec_epsilon_exists_post E X I).
Tactic Notation "spec_epsilon" "as" ident(X) :=
  let H := fresh "H" X in spec_epsilon as X H.

Tactic Notation "spec_epsilon" "in" hyp(H) "as" ident(X) simple_intropattern(I) :=
  find_epsilon_in H ltac:(fun E => spec_epsilon_exists_post E X I).
Tactic Notation "spec_epsilon" "in" hyp(H) "as" ident(X) :=
  let H := fresh "H" X in spec_epsilon in H as X H.

Tactic Notation "spec_epsilon" "~" constr(W) "as" ident(X) simple_intropattern(I) :=
  spec_epsilon W as X I; auto_tilde.
Tactic Notation "spec_epsilon" "~" constr(W) "in" hyp(H) "as" ident(X) simple_intropattern(I) :=
  spec_epsilon W in H as X I; auto_tilde.
Tactic Notation "spec_epsilon" "~" "as" ident(X) simple_intropattern(I) :=
  spec_epsilon as X I; auto_tilde.
Tactic Notation "spec_epsilon" "~" "as" ident(X) :=
  spec_epsilon as X; auto_tilde.
Tactic Notation "spec_epsilon" "~" "in" hyp(H) "as" ident(X) simple_intropattern(I) :=
  spec_epsilon in H as X I; auto_tilde.
Tactic Notation "spec_epsilon" "~" "in" hyp(H) "as" ident(X) :=
  spec_epsilon in H as X; auto_tilde.

Tactic Notation "spec_epsilon" "*" constr(W) "as" ident(X) simple_intropattern(I) :=
  spec_epsilon W as X I; auto_star.
Tactic Notation "spec_epsilon" "*" constr(W) "in" hyp(H) "as" ident(X) simple_intropattern(I) :=
  spec_epsilon W in H as X I; auto_star.
Tactic Notation "spec_epsilon" "*" "as" ident(X) simple_intropattern(I) :=
  spec_epsilon as X I; auto_star.
Tactic Notation "spec_epsilon" "*" "as" ident(X) :=
  spec_epsilon as X; auto_star.
Tactic Notation "spec_epsilon" "*" "in" hyp(H) "as" ident(X) simple_intropattern(I) :=
  spec_epsilon in H as X I; auto_star.
Tactic Notation "spec_epsilon" "*" "in" hyp(H) "as" ident(X) :=
  spec_epsilon in H as X; auto_star.

(* ********************************************************************** *)
(** * Conversion from relations to functions *)

Section Choose.

(* Let [R] be an arbitrary binary relation at type [A -> B -> Prop]. *)

Variable A B : Type.
Variable R : A -> B -> Prop.
Context `{IB:Inhab B}.

(* We turn it into a function, which ostensibly is a total function of type
   [A -> B], but in reality is well-defined only in the domain of [R]. *)

Definition choose (a : A) : B :=
  epsilon (fun b => R a b).

(* TODO choose_spec and choose_unique could be reformulated using
   incl_fr and incl_rf *)

(* Every [a] in the domain of [R] is related by [R] with [choose a]. *)

Lemma choose_spec:
  forall a,
  ~ (forall b, ~ R a b) ->
  R a (choose a).
Proof using IB.
  intros.
  (* Since [a] is not a root, it has a parent [b]. *)
  forwards [ b ? ]: exists_from_not. eauto.
  (* By definition of [choose], there follows that [choose a] is
     well-defined, hence there is an edge from [a] to [choose a]. *)
  unfold choose. eapply epsilon_spec. eauto.
Qed.

(* If the relation [R] is functional, then [choose a] is unique.
   The existence of an edge from [a] to [b] implies that [b] is
   [choose a]. *)

Variable functional_R:
  forall a b1 b2, R a b1 -> R a b2 -> b1 = b2.
  (* TODO: use a definition of functional, and inline in the lemma below *)

Lemma choose_unique:
  forall a b,
  R a b ->
  choose a = b.
Proof using IB functional_R.
  intros.
  (* [R a b] implies that [a] is in the domain of [R].
     Hence there is an edge from [a] to [choose a]. *)
  forwards: choose_spec. rewrite not_forall_not. eauto.
  (* The result follows from the hypothesis that [R] is functional. *)
  eauto.
Qed.

End Choose.

(* In the special case where [B] is [A], the inhabitation witness
   can be constructed out of [a]. *)

Definition choose_ A (R : A -> A -> Prop) (a : A) : A :=
  @choose A A R (prove_Inhab a) a.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.global.workload.
Require Import prosa.classic.model.schedule.global.jitter.schedule prosa.classic.model.schedule.global.jitter.interference.
Require Import prosa.classic.analysis.global.jitter.workload_bound prosa.classic.analysis.global.jitter.interference_bound.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module InterferenceBoundFP.

  Import ScheduleWithJitter WorkloadBoundJitter Priority Interference.
  Export InterferenceBoundJitter.

    Section Definitions.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.
    Variable task_jitter: sporadic_task -> time.

    (* Let tsk be the task to be analyzed. *)
    Variable tsk: sporadic_task.

    Let task_with_response_time := (sporadic_task * time)%type.

    (* Assume a known response-time bound for each interfering task ... *)
    Variable R_prev: seq task_with_response_time.

    (* ... and an interval length delta. *)
    Variable delta: time.

    (* Assume an FP policy. *)
    Variable higher_eq_priority: FP_policy sporadic_task.

    (* Recall the interference bound. *)
    Let total_interference_bound := interference_bound_generic task_cost task_period task_jitter tsk delta.

    (* The total interference incurred by tsk is bounded by the sum
       of individual task interferences. *)
    Definition total_interference_bound_fp :=
      \sum_((tsk_other, R_other) <- R_prev)
         total_interference_bound (tsk_other, R_other).

  End Definitions.

End InterferenceBoundFP.


(* week-02_the-intro-tactic.v *)
(* FPP 2019 - YSC3236 2019-2020, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 25 Aug 2019 *)
(* was: *)
(* Version of 22 Aug 2019 *)

(* ********** *)

Lemma a_proposition_implies_itself :
  forall A : Prop,
    A -> A.
Proof.
  intro A.
  intro H_A.
  exact H_A.

  Restart.

  intro rose.
  intro H_rose.
  exact H_rose.
Qed.

(* ********** *)

Lemma the_following_example :
  forall A B C : Prop,
    A ->
    B ->
    C ->
    forall i j : nat,
      A /\ B /\ C /\ i = i /\ j = j.
Proof.
  intros A B C.
  intros H_A H_B H_C.
  intros i j.
  split.
    exact H_A.
  split.
    exact H_B.
  split.
    exact H_C.
  split.
    reflexivity.
  reflexivity.
Qed.

(* ********** *)

Lemma a_pair_of_propositions_implies_the_left_one :
  forall A B : Prop,
    A /\ B -> A.
Proof.
  intros A B.
  intro H_A_and_B.
  destruct H_A_and_B.
  exact H.

  Restart.

  intros A B.
  intro H_A_and_B.
  destruct H_A_and_B as [H_A H_B].
  exact H_A.

  Restart.

  intros A B.
  intros [H_A H_B].
  exact H_A.
Qed.

(* ********** *)

Lemma disjunction_is_commutative :
  forall A B : Prop,
    A \/ B -> B \/ A.
Proof.
  intros A B.
  intros [H_A | H_B].

  - right.
    exact H_A.

  - left.
    exact H_B.
Qed.

(* ********** *)

Lemma about_nested_conjunctions :
  forall A B C D : Prop,
    (A /\ B) /\ (C /\ D) -> (D /\ A) /\ (B /\ C).
Proof.
  intros A B C D.
  intros [[H_A H_B] [H_C H_D]].
  Check (conj (conj H_D H_A) (conj H_B H_C)).
  exact (conj (conj H_D H_A) (conj H_B H_C)).
Qed.

Lemma about_nested_conjunctions_and_disjunctions :
  forall A B C D E F : Prop,
    (A \/ B) /\ (C \/ (D /\ E)) -> F.
Proof.
  intros A B C D E F.
  intros [[H_A | H_B] [H_C | [H_D H_E]]].
Abort.

(* ********** *)

(* end of week-02_the-intro-tactic.v *)


(* Ancien bug signale par Laurent Thery sur la condition de garde *)

Require Import Bool.
Require Import ZArith.

Definition rNat := positive.

Inductive rBoolOp : Set :=
  | rAnd : rBoolOp
  | rEq : rBoolOp.

Definition rlt (a b : rNat) : Prop := Pos.compare_cont Eq a b = Lt.

Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}.
Proof.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont Eq n m).
intros H' H'0 H'1; right; right; auto.
intros H' H'0 H'1; left; unfold rlt.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
intros H' H'0 H'1; right; left; unfold rlt.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
apply H'0; auto.
Defined.

Definition rmax : rNat -> rNat -> rNat.
Proof.
intros n m; case (rltDec n m); intros Rlt0.
exact m.
exact n.
Defined.

Inductive rExpr : Set :=
  | rV : rNat -> rExpr
  | rN : rExpr -> rExpr
  | rNode : rBoolOp -> rExpr -> rExpr -> rExpr.

Fixpoint maxVar (e : rExpr) : rNat :=
  match e with
  | rV n => n
  | rN p => maxVar p
  | rNode n p q => rmax (maxVar p) (maxVar q)
  end.

(* Check bug #1491 *)

Require Import Streams.

Definition decomp (s:Stream nat) : Stream nat :=
  match s with Cons _ s => s end.

CoFixpoint bx0 : Stream nat := Cons 0 bx1
with bx1 : Stream nat := Cons 1 bx0.

Lemma bx0bx : decomp bx0 = bx1.
simpl. (* used to return bx0 in V8.1 and before instead of bx1 *)
reflexivity.
Qed.

(* Check mutually inductive statements *)

Require Import ZArith_base Omega.
Open Scope Z_scope.

Inductive even: Z -> Prop :=
| even_base: even 0
| even_succ: forall n, odd (n - 1) -> even n
with odd: Z -> Prop :=
| odd_succ: forall n, even (n - 1) -> odd n.

Lemma even_pos_odd_pos: forall n, even n -> n >= 0
with odd_pos_even_pos : forall n, odd n -> n >= 1.
Proof.
 intros.
 destruct H.
   omega.
   apply odd_pos_even_pos in H.
   omega.
 intros.
 destruct H.
  apply even_pos_odd_pos in H.
  omega.
Qed.

CoInductive a : Prop := acons : b -> a
with b : Prop := bcons : a -> b.

Lemma a1 : a
with b1 : b.
Proof.
apply acons.
assumption.

apply bcons.
assumption.
Qed.


Require Import hybrid.hypergeometry.
Require Import hybrid.util.
Require Import hybrid.c_util.
Require Import hybrid.hlist_aux.
Require Import hybrid.square_abstraction.
Require Import hybrid.vector_setoid.
Require Import hybrid.monotonic_flow.
Require Import hybrid.stability.

Require Import CoLoR.Util.Vector.VecUtil.

Set Implicit Arguments.

Open Scope CR_scope.

Section contents.

  (* Let's fix a dimension *)

  Variable n : nat.

  Definition forallDim (F : forall i, (i < n)%nat -> Type) :=
    forall i (ip : (i < n)%nat), F i ip.

  (* If one has a concrete hybrid system.. *)

  Variable chs : concrete.System.

  (* .. and points in that system basically correspond to points in the plane.. *)

  Notation proj_morpher :=
    (morpher (@st_eq (concrete.Point chs) ==> @st_eq CRasCSetoid)%signature).

  Variable proj : vector proj_morpher n.

  Hypothesis xyp : HyperPoint n -> concrete.Point chs.

  Definition pxy (p : concrete.Point chs) : HyperPoint n :=
    Vmap (fun pi : proj_morpher => pi p) proj.

  Hypotheses
    (xyp_pxy: forall p, xyp (pxy p) = p)
      (* TODO: should we split this condition into separate dimensions, like in square_abstraction? *)
    (pxy_xyp: forall p, pxy (xyp p) = p).

  (* .. and flow in that system is separable over the two axes.. *)

  Variables
    (flows : concrete.Location chs -> vector (Flow CRasCSetoid) n)
    (flow_inv : concrete.Location chs ->
      forall i (ip : (i < n)%nat), OpenRange -> OpenRange -> OpenRange)
    (flow_inv_correct : forall l,
      forallDim (fun i ip => range_flow_inv_spec (Vnth (flows l) ip) (flow_inv l ip)))
    (flow_separable : forall l p t,
      concrete.flow chs l p t = xyp (vector_flow (flows l) (pxy p) t)).

  (* .. and on both axes, abstraction parameters can be formed based on
   OpenRange regions.. *)

  Context (A : Set) (B : A -> Set).

  Context
    (intervals : vector A n)
    (intervals_eq_dec : forall x, EquivDec.EqDec (B x) eq)
    (intervals_enum : forall x, ExhaustiveList (B x))
    (intervals_NoDup : forall x, NoDup (intervals_enum x))
    (intervals_range : forallDim (fun i ip => B (Vnth intervals ip) -> OpenQRange))
    (absInterval : forall (l : concrete.Location chs) (p : concrete.Point chs), concrete.invariant (l, p) ->
      forallDim (fun i ip =>
        DN { int : B (Vnth intervals ip) | in_orange (intervals_range i ip int) (Vnth (pxy p) ip)}
    )).

  Definition ap_inv_DN :
    forall (i : nat) (ip : (i < n)%nat) (l : concrete.Location chs) (p : concrete.Point chs),
      concrete.invariant (l, p) ->
      DN {i : B (Vnth intervals ip) | in_orange (intervals_range ip i) (Vnth proj ip p)}.
  Proof.
    intros. set (w := absInterval l p H (ip:=ip)). simpl in w.
    unfold pxy in w. rewrite Vnth_map in w. exact w.
  Qed.

  Definition ap : abstract.Space chs :=
    abstract.hyper_space
      (list_of_vec (Vbuild (fun i (ip : (i < n)%nat) =>
         interval_abstraction.space chs (Vnth proj ip) (intervals_NoDup _) (intervals_range _) (@ap_inv_DN i ip)
      ))).

  Definition region2range :
    forall (i : nat) (ip : (i < n)%nat),
      abstract.Region
        (Vnth (Vbuild (fun i (ip : (i < n)%nat) =>
          interval_abstraction.space chs (Vnth proj ip) (intervals_NoDup _) (intervals_range _) (@ap_inv_DN i ip)
        )) ip) -> OpenQRange.
  Proof.
    intros.
    rewrite Vbuild_nth in X.
    exact (intervals_range ip X).
  Defined.

  Definition square : abstract.Region ap -> OpenQHCube n :=
    hlist_map _ region2range.

  (*  .. then we can define useful things.

  For instance, we can easily make an invariant overestimator
  (if one's invariant can be overestimated by a list of open squares): *)

  Section invariant_overestimator.

    Variable invariant_squares :
      forall l : concrete.Location chs,
        { s : OpenHCube n | forall p, concrete.invariant (l, p) -> in_ohypercube (pxy p) s }.

    Program Definition make_invariant_overestimator : overestimator (@abstract.invariant _ ap) := _.
    Admit Obligations.
(*      fun li => overestimate_osquares_overlap eps (invariant_squares (fst li)) (square (snd li)).*)

  End invariant_overestimator.

  (* Similarly, if one's initial condition can be overestimated by
   an open square, we can make an initial_dec thingy. *)

  Section make_initial_overestimator.

    Variables
      (initial_location : concrete.Location chs)
      (initial_square : OpenHCube n)
      (initial_representative : forall s, concrete.initial s ->
        fst s = initial_location /\ in_ohypercube (pxy (snd s)) initial_square).

    Program Definition make_initial_overestimator (eps : Qpos) : overestimator (@abstract.Initial _ ap) :=
      fun s => _.
    Admit Obligations.
(*
        (overestimate_conj (overestimate_osquares_overlap eps (initial_square) (square (snd s)))
          (decision_overestimation (concrete.Location_eq_dec chs (fst s) initial_location))).
*)

  End make_initial_overestimator.

  (* And similarly, if one's guard conditions can be overestimated by
  open squares, we can make a guard_dec thingy. *)

  Section make_guard_overestimator.

    Definition GuardSquare l l' :=
      { s : option (OpenHCube n) | forall p, concrete.guard chs (l, p) l' ->
          match s with
          | None => False
          | Some v => in_ohypercube (pxy p) v
          end
      }.

    Program Definition guard_dec (guard_square : forall l l', GuardSquare l l') (eps : Qpos) :
      overestimator (@abstract.guard _ ap) :=
      _.
    Admit Obligations.
(*
      fun l r l' =>
      match guard_square l l' with
      | Some s => overestimate_osquares_overlap eps s (square r)
      | None => false
      end.
*)

  End make_guard_overestimator.

  (* If the safety condition can be overestimated by a list of unsafe
   osquares, then we can select the unsafe abstract states automatically: *)

  Section square_safety.

    Variables
      (unsafe_concrete : concrete.State chs -> Prop)
      (unsafe_squares : concrete.Location chs -> list (OpenHCube n))
      (unsafe_squares_correct: forall s, unsafe_concrete s -> exists q,
        In q (unsafe_squares (fst s)) /\ in_ohypercube (pxy (snd s)) q)
      (eps: Qpos).

      Program Definition unsafe_abstract : abstract.CompleteCoverList ap unsafe_concrete :=
        _.
(*
      := flat_map (fun l => map (pair l) (flat_map (fun q =>
        filter (fun s => overestimate_osquares_overlap eps q (square s)) exhaustive_list
        ) (unsafe_squares l))) (concrete.locations chs).
*)
      Admit Obligations.

  End square_safety.

  (* Everything above is pretty simplistic. We now prepare for more complex
   transition overestimators, for which we will require some more stuff: *)

  Let reset_function := concrete.Location chs -> concrete.Location chs -> Reset.

  Variables
    (invariant_overestimator : overestimator (@abstract.invariant _ ap))
    (guard_decider : overestimator (@abstract.guard _ ap))
    (reset : vector reset_function n)
    (reset_components : forall p l l',
      pxy (concrete.reset chs l l' p) =
      Vmap2 (fun resetF => apply_Reset (resetF l l')) reset (pxy p)).

(*
  Section disc_trans_regions.

    Variables (eps: Qpos) (l l': concrete.Location chs) (r: abstract.Region ap).

    Definition map_orange' (f: sigT increasing): OpenRange -> OpenRange
      := let (_, y) := f in map_orange y.

    Definition x_regions :=
      match reset_x l l' with
      | Reset_const c => filter (fun r' => overestimate_oranges_overlap eps
        (* (map_orange' (increasing_const' c) (Xinterval_range (fst r))) (Xinterval_range r')) Xintervals *)
        (unit_range c: OpenRange) (Xinterval_range r')) Xintervals
      | Reset_map f => filter (fun r' => overestimate_oranges_overlap eps
        (map_orange' f (Xinterval_range (fst r))) (Xinterval_range r')) Xintervals
      | Reset_id => [fst r] (* x reset is id, so we can only remain in this x range *)
      end.

    Definition y_regions :=
      match reset_y l l' with
      | Reset_const c => filter (fun r' => overestimate_oranges_overlap eps
        (unit_range c: OpenRange) (Yinterval_range r')) Yintervals
      | Reset_map f => filter (fun r' => overestimate_oranges_overlap eps
        (map_orange' f (Yinterval_range (snd r))) (Yinterval_range r')) Yintervals
      | Reset_id => [snd r] (* x reset is id, so we can only remain in this x range *)
      end.

    Definition disc_trans_regions: list (abstract.Region ap)
      :=
      if overestimation_bool (guard_decider l r l') &&
          overestimation_bool (invariant_overestimator (l, r)) then
       filter (fun s => overestimation_bool (invariant_overestimator (l', s))) (cart x_regions y_regions)
     else [].

  End disc_trans_regions.

  Definition raw_disc_trans (eps: Qpos) (s: abstract.State ap): list (abstract.State ap) :=
    let (l, r) := s in
    flat_map (fun l' => map (pair l') (disc_trans_regions eps l l' r)) (concrete.locations chs).

  Lemma NoDup_disc_trans eps s: NoDup (raw_disc_trans eps s).

  Hint Resolve in_map_orange.

  Definition is_id_reset (r: Reset): bool :=
    match r with
    | Reset_id => true
    | _ => false
    end.

  Hint Unfold abstract.invariant abstract.guard.

  Lemma respects_disc (eps: Qpos) (s1 s2 : concrete.State chs):
    concrete.disc_trans s1 s2 -> forall i1, abstract.in_region ap (snd s1) i1 ->
    DN (exists i2, abstract.in_region ap (snd s2) i2 /\
    In (fst s2, i2) (raw_disc_trans eps (fst s1, i1))).

  Program Definition disc_trans: Qpos ->
    abstract.sharing_transition_overestimator ap (@concrete.disc_trans chs) := raw_disc_trans.

  Program Definition cont_trans_cond_dec eps l r r':
    overestimation (abstract.cont_trans ap l r r') :=
      square_flow_conditions.decide_practical
        (xflow_invr l) (yflow_invr l) (square r) (square r') eps &&
      invariant_overestimator (l, r) &&
      invariant_overestimator (l, r').
*)

End contents.


Require Export Completeness.

Lemma completion_exists: forall (X:Type) (d:X->X->R) (d_metric:metric d),
  exists Y:Type, exists i:X->Y, exists d':Y->Y->R,
  exists d'_metric:metric d',
  injective i /\ dense (Im Full_set i) (X:=MetricTopology d' d'_metric) /\
  (forall x1 x2:X, d' (i x1) (i x2) = d x1 x2) /\
  complete d' d'_metric.
Proof.
intros.
(* first of all, it suffices to construct a (Y, d') without the
   density condition; then the restriction of d' to the closure of X
   is again complete, and X is dense in it *)
cut (exists Y:Type, exists i:X->Y, exists d':Y->Y->R,
  exists d'_metric:metric d', injective i /\
  (forall x1 x2:X, d' (i x1) (i x2) = d x1 x2) /\
  complete d' d'_metric).
intros.
destruct H as [Y [i [d' [d'_metric [? []]]]]].
pose (F := closure (Im Full_set i) (X:=MetricTopology d' d'_metric)).
exists {y:Y | In F y}.
assert (forall x:X, In F (i x)).
intros.
apply closure_inflationary.
exists x; trivial.
constructor.
exists (fun x:X => exist _ (i x) (H2 x)).
exists (fun y1 y2 => d' (proj1_sig y1) (proj1_sig y2)).
assert (d'_metric0 : metric (fun (y1 y2:{y:Y | In F y}) =>
                       d' (proj1_sig y1) (proj1_sig y2))).
constructor; try destruct x; try destruct y; try destruct z; simpl;
  try apply d'_metric.
intros.
Require Import Proj1SigInjective.
apply subset_eq_compatT.
apply d'_metric; trivial.
exists d'_metric0.
repeat split.
red; intros.
injection H3; intros.
apply H; trivial.
red.
apply Extensionality_Ensembles; split; red; intros.
constructor.
simpl in x.
destruct x.
clear H3.
generalize i0.
apply first_countable_sequence_closure in i0.
destruct i0.
destruct H3.
assert (forall n:nat, { x:X | x0 n = i x }).
intros.
Require Import Description.
apply constructive_definite_description.
apply -> unique_existence.
split.
destruct (H3 n).
exists x1; trivial.
red; intros.
apply H.
rewrite H5 in H6; trivial.
assert (forall n:nat, In F (i (proj1_sig (X0 n)))).
intros; apply H2.
intros.
apply (@net_limit_in_closure nat_DS
  (MetricTopology _ d'_metric0)
  _ (fun n:nat => exist _ (i (proj1_sig (X0 n))) (H5 n))).
red; intros.
exists i1.
split.
simpl; auto with arith.
exists (proj1_sig (X0 i1)).
constructor.
apply subset_eq_compatT.
reflexivity.
pose proof (metric_space_net_limit_converse (MetricTopology d' d'_metric) d'
  (MetricTopology_metrizable _ d' d'_metric) nat_DS x0 x H4).
apply metric_space_net_limit with (1:=MetricTopology_metrizable _ _ d'_metric0).
(*
destruct (metric_space_net_limit (MetricTopology d' d'_metric)
  d' (MetricTopology_metrizable _ d' d'_metric) nat_DS x0 x).
pose proof (H6 H4); clear H6 H7.
apply <- (metric_space_net_limit (MetricTopology _ d'_metric0)
  _ (MetricTopology_metrizable _ _ d'_metric0) nat_DS). *)
intros.
destruct (H6 eps H7).
exists x1.
intros.
simpl.
destruct (X0 j).
simpl.
rewrite <- e.
apply H8; trivial.
apply metrizable_impl_first_countable.
exists d'; trivial.
apply MetricTopology_metrizable.

intros.
simpl.
apply H0.
apply (closed_subset_of_complete_is_complete Y d' d'_metric F);
  trivial.
apply closure_closed.

destruct (classic (inhabited X)).
destruct H as [x0].

(* we now construct Y as the uniform space of functions X->R,
   with base point "distance from x0"; the embedding of X into this
   space is to send x to "distance from x" *)
Require Import UniformTopology.
Require Import RTopology.
assert (forall x y z:X, R_metric (d x z) (d y z) <= d x y).
unfold R_metric.
assert (forall a b:R, -b <= a -> a <= b -> Rabs a <= b).
intros.
unfold Rabs.
Require Import Fourier.
destruct Rcase_abs; fourier.
intros.
apply H.
assert (d x z <= d x y + d y z) by apply d_metric.
fourier.
rewrite (metric_sym _ _ d_metric x y).
assert (d y z <= d y x + d x z) by apply d_metric.
fourier.

exists (uniform_space R_metric (d x0)).
refine (let H:=_ in ex_intro _ (fun x:X => exist _ (d x) (H x)) _).
intros.
exists (d x0 x).
red; intros.
destruct H0.
rewrite H1; trivial.
exists (uniform_metric R_metric (d x0) R_metric_is_metric
  (inhabits x0)).
exists (uniform_metric_is_metric _ _ _ _ _ _).
repeat split.
red; intros.
injection H1; intros.
apply d_metric.
rewrite H2; apply d_metric.

intros.
unfold uniform_metric; destruct sup; simpl.
apply Rle_antisym.
apply i.
red; intros.
destruct H1.
rewrite H2; apply H.
apply i.
exists x1.
constructor.
rewrite metric_zero; trivial.
unfold R_metric.
rewrite (metric_sym _ _ d_metric x2 x1).
rewrite Rminus_0_r.
symmetry; apply Rabs_right; apply d_metric.

apply uniform_metric_complete.
exact R_metric_complete.

exists False.
exists (fun x:X => H (inhabits x)).
exists (False_rect _).
assert (metric (False_rect (False->R))).
constructor; intros; destruct x.
exists H0.
repeat split.
red; intros.
contradiction (H (inhabits x1)).
intros.
contradiction (H (inhabits x1)).
red; intros.
contradiction (x O).
Qed.


(* -*- mode: coq; mode: visual-line -*- *)

(** * Theorems about the homotopical interval. *)

Require Import HoTT.Basics.
Require Import HIT.Interval.
Require Import Metatheory.Core Metatheory.FunextVarieties.

(** ** From an interval type, we can prove function extensionality. *)

Definition funext_type_from_interval : Funext_type
  := WeakFunext_implies_Funext (NaiveFunext_implies_WeakFunext
    (fun A P f g p =>
      let h := fun (x:interval) (a:A) =>
        interval_rec _ (f a) (g a) (p a) x
        in ap h seg)).