(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************

          Buchberger : Division for Term

          Laurent Thery April 01

  ****************************************************************************)
Require Import Relation_Definitions.
Require Import CoefStructure.
Require Import moreCoefStructure.
Require Import OrderStructure.
Require Import Monomials.
Require Import Term.
Require Import List.
Section DivTerm.
Load "hCoefStructure".
Load "mCoefStructure".
Load "hOrderStructure".
Load "mOrderStructure".
Load "hTerm".
Set Implicit Arguments.
Unset Strict Implicit.

Definition divTerm :
  Term A n ->
  forall (b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b), Term A n.
intros H; case H; intros b2 c2 H'; case H'; intros b3 c3; simpl in |- *.
intros nZb3; exact (divA b2 b3 nZb3, div_mon n c2 c3).
Defined.
Set Strict Implicit.
Unset Implicit Arguments.

Theorem eqT_divTerm_plusTerm :
 forall (a b c : Term A n) (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c),
 eqT a b ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZc) c) ->
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZc) c) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (plusTerm (A:=A) plusA (n:=n) a b) nZc)
   (plusTerm (A:=A) plusA (n:=n) (divTerm a nZc) (divTerm b nZc)).
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1 nZc H' H'0 H'1; split; auto.
case H'1; intros H'3 H'4; clear H'1.
case H'0; intros H'2 H'5; clear H'0.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := divA
            (plusA (multA (divA a2 a0 nZc) a0) (multA (divA a1 a0 nZc) a0))
            a0 nZc); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := divA (multA (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)) a0) a0 nZc);
 auto.
apply divA_eqA_comp with (1 := cs); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := plusA (multA a0 (divA a2 a0 nZc)) (multA a0 (divA a1 a0 nZc)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA a0 (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := multA (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)) (divA a0 a0 nZc));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := divA (multA a0 (plusA (divA a2 a0 nZc) (divA a1 a0 nZc))) a0 nZc);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := multA (divA a0 a0 nZc) (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)));
 auto.
apply divA_multA_comp_r with (1 := cs); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)) A1);
 auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply multA_eqA_comp with (1 := cs); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply divA_A1 with (1 := cs); auto.
apply multA_A1_r with (1 := cs); auto.
Qed.

Theorem divTerm_invTerm_l :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (invTerm (A:=A) invA (n:=n) b) nZa)
   (invTerm (A:=A) invA (n:=n) (divTerm b nZa)).
intros a b; case a; case b; simpl in |- *; auto.
intros d c A0' c0 nZA2 H'0; split; auto.
case H'0; intros H'1 H'2; clear H'0.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := divA (invA (multA (divA d A0' nZA2) A0')) A0' nZA2);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := divA (multA (invA (divA d A0' nZA2)) A0') A0' nZA2);
 auto.
apply divA_eqA_comp with (1 := cs); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); apply multA_invA_com_l with (1 := cs);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA (invA (divA d A0' nZA2)) (divA A0' A0' nZA2));
 auto.
apply divA_multA_comp_l with (1 := cs).
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA (invA (divA d A0' nZA2)) A1); auto.
apply multA_eqA_comp with (1 := cs); auto.
apply divA_A1 with (1 := cs).
apply multA_A1_r with (1 := cs).
Qed.

Theorem divTerm_invTerm_r :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZia : ~ zeroP (A:=A) A0 eqA (n:=n) (invTerm (A:=A) invA (n:=n) a)),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm b nZia)
   (invTerm (A:=A) invA (n:=n) (divTerm b nZa)).
intros a b; case a; case b; simpl in |- *; auto.
split; auto.
apply divA_invA_r with (1 := cs); auto.
Qed.

Theorem eqT_divTerm :
 forall (a b c d : Term A n) (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c)
   (nZd : ~ zeroP (A:=A) A0 eqA (n:=n) d),
 eqT a b -> eqT c d -> eqT (divTerm a nZc) (divTerm b nZd).
intros a b c d; case a; case b; case c; case d; unfold eqT in |- *;
 simpl in |- *; auto.
intros A0' c0 d2 c2 H' c3 H'0 c4 H'1 H'2 H'3 H'4; rewrite H'3; rewrite H'4;
 auto.
Qed.

Theorem eqTerm_divTerm_comp :
 forall (a b c d : Term A n) (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c)
   (nZd : ~ zeroP (A:=A) A0 eqA (n:=n) d),
 eqTerm (A:=A) eqA (n:=n) a b ->
 eqTerm (A:=A) eqA (n:=n) c d ->
 eqTerm (A:=A) eqA (n:=n) (divTerm a nZc) (divTerm b nZd).
intros a b c d; case a; case b; case c; case d; simpl in |- *; auto.
intros A0' c0 d2 c2 d3 c3 d4 c4 nZd2 H'0 H'1 H'2.
case H'2; intros H'3 H'4; clear H'2.
case H'1; intros H'2 H'5; clear H'1.
split; auto.
rewrite H'5; rewrite H'4; auto.
Qed.
Hint Resolve eqTerm_divTerm_comp.

Theorem divTerm_multTerm_l :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (multTerm (A:=A) multA (n:=n) c b) nZa)
   (multTerm (A:=A) multA (n:=n) c (divTerm b nZa)).
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros d c0 A0' c2 d2 c3 nZd2 H'0; case H'0; intros H'1 H'2; auto.
split; auto.
apply divA_multA_comp_l with (1 := cs).
rewrite H'2.
repeat rewrite mult_div_com.
rewrite mult_mon_assoc.
repeat rewrite mult_div_com; auto.
Qed.

Theorem divTerm_multTerm_r :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (multTerm (A:=A) multA (n:=n) b c) nZa)
   (multTerm (A:=A) multA (n:=n) (divTerm b nZa) c).
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1 nZa H'; split; auto.
apply divA_multA_comp_r with (1 := cs).
elim H'; intros H'0 H'1; rewrite H'1; clear H'.
rewrite mult_div_com; auto.
rewrite <- mult_mon_assoc.
rewrite (mult_mon_com n m1 m).
rewrite mult_mon_assoc.
rewrite mult_div_com; auto.
Qed.
Hint Resolve divTerm_multTerm_l divTerm_multTerm_r.

Theorem div_is_T1 :
 forall (a : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) (divTerm a nZa) (T1 A1 n).
intros a; case a; simpl in |- *; auto.
intros a0 m nZa; split; auto.
apply divA_A1 with (1 := cs).
unfold M1 in |- *; apply mult_div_id; auto.
Qed.
Hint Resolve div_is_T1.

Theorem divTerm_nZ :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 ~ zeroP (A:=A) A0 eqA (n:=n) (divTerm a nZb).
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 H nZb; apply divA_nZ with (1 := cs); auto.
Qed.

Theorem divTerm_eqT :
 forall a b c : Term A n,
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 forall nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c,
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZc) c) ->
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZc) c).
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a1 m1 a2 m2 a3 m3 H1 H2 H3 H4 H5; case H5; intros H6 H7; split; auto.
apply divA_is_multA with (1 := cs); auto.
unfold eqT in H1; simpl in H1; rewrite <- H1; auto.
Qed.

Let gb : mon n * bool -> bool.
intros H'; case H'; auto.
Defined.

Let gm : mon n * bool -> mon n.
intros H'; case H'; auto.
Defined.

Definition mk_clean :
  forall a b : mon n, {c : mon n * bool | c = div_mon_clean n a b}.
intros a b; exists (div_mon_clean n a b); auto.
Qed.

Theorem divTerm_dec :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 {eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b)} +
 {~
  eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b)}.
intros a b; case a; case b; simpl in |- *; auto.
intros b2 c2 b3 c3.
intros Zp1 Zp2.
case (mk_clean c3 c2).
intros x; case x.
intros c b4; case b4.
intros H0; left; simpl in |- *; auto.
generalize (div_clean_dec1 n c3 c2); rewrite <- H0; simpl in |- *; auto.
intros H1; case H1; auto; intros H2 H3; split; auto.
apply divA_is_multA with (1 := cs); auto.
intros H0; right; red in |- *; intros dviP_H; inversion dviP_H.
generalize (div_clean_dec2 n c3 c2); simpl in |- *; auto.
intros H'; lapply H'; [ intros H'0; apply H'0; clear H' | clear H' ].
rewrite <- H1; auto.
rewrite <- H0; simpl in |- *; auto.
Qed.

Theorem zeroP_divTerm :
 forall a b : Term A n,
 zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 zeroP (A:=A) A0 eqA (n:=n) (divTerm a nZb).
intros a b; case a; case b; simpl in |- *; auto.
intros d H' A0' H'0 H'1 nZd; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := divA A0 d nZd); auto.
apply divA_A0_l with (1 := cs).
Qed.

Theorem divTerm_on_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqT a b ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b).
intros a b; case a; case b; unfold eqT in |- *; simpl in |- *; auto.
intros d c A0' c0 H' H'0 H'1; rewrite <- H'1.
split; auto.
apply divA_is_multA with (1 := cs); auto.
rewrite mult_div_id; auto.
rewrite mult_mon_zero_l; auto.
Qed.

Theorem divTerm_on_eqT_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqT a b -> eqT (divTerm a nZb) (T1 A1 n).
intros a b; case a; case b; unfold eqT in |- *; simpl in |- *; auto.
intros b2 c b3 c0 H' H'0 H'1; rewrite H'1; auto.
rewrite mult_div_id; auto.
Qed.

Theorem divTerm_on_plusM_minusM :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 T2M a = mult_mon n (div_mon n (T2M a) (T2M b)) (T2M b) ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b).
intros a b; case a; case b; simpl in |- *; auto.
split; auto.
apply divA_is_multA with (1 := cs); auto.
Qed.
Set Implicit Arguments.
Unset Strict Implicit.

Definition ppc : Term A n -> Term A n -> Term A n.
intros H; case H; intros b2 c2 H'; case H'; intros b3 c3; simpl in |- *;
 exact (A1, ppcm_mon n c2 c3).
Defined.
Set Strict Implicit.
Unset Implicit Arguments.

Theorem ppc_com :
 forall a b : Term A n, eqTerm (A:=A) eqA (n:=n) (ppc a b) (ppc b a).
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0; split; auto.
apply ppcm_com; auto.
Qed.

Theorem divTerm_ppc :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b)),
 eqTerm (A:=A) eqA (n:=n) c (multTerm (A:=A) multA (n:=n) (divTerm c nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) c (multTerm (A:=A) multA (n:=n) (divTerm c nZb) b) ->
 eqTerm (A:=A) eqA (n:=n) c
   (multTerm (A:=A) multA (n:=n) (divTerm c nZppab) (ppc a b)).
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1 nZa nZb nZppab H H0; split; auto.
apply divA_is_multA with (1 := cs); auto.
apply ppcm_mom_is_ppcm; intuition.
Qed.

Theorem divTerm_ppcl :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 eqTerm (A:=A) eqA (n:=n) (ppc a b)
   (multTerm (A:=A) multA (n:=n) (divTerm (ppc a b) nZa) a).
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 nZa H; split; auto.
apply divA_is_multA with (1 := cs); auto.
apply ppcm_prop_l.
Qed.

Theorem divTerm_ppcr :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqTerm (A:=A) eqA (n:=n) (ppc a b)
   (multTerm (A:=A) multA (n:=n) (divTerm (ppc a b) nZb) b).
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 H nZb; split; auto.
apply divA_is_multA with (1 := cs); auto.
apply ppcm_prop_r.
Qed.

Theorem ppc_nZ :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b).
intros a b; case a; case b; simpl in |- *; auto.
Qed.

Theorem divTerm_rew :
 forall (a b : Term A n) (nZ1 nZ2 : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 divTerm a nZ1 = divTerm a nZ2.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 nZ1 nZ2.
rewrite divA_rew with (1 := cs) (nZ2 := nZ2); auto.
Qed.

Inductive divP : Term A n -> Term A n -> Prop :=
    divTerm_def :
      forall a b : Term A n,
      ~ zeroP (A:=A) A0 eqA (n:=n) a ->
      forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
      eqTerm (A:=A) eqA (n:=n) a
        (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) ->
      divP a b.

Theorem divP_inv1 :
 forall a b : Term A n, divP a b -> ~ zeroP (A:=A) A0 eqA (n:=n) a.
intros a b H; inversion H; auto.
Qed.

Theorem divP_inv2 :
 forall a b : Term A n, divP a b -> ~ zeroP (A:=A) A0 eqA (n:=n) b.
intros a b H; inversion H; auto.
Qed.

Theorem divP_inv3 :
 forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 divP a b ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b).
intros a b nZb H; inversion H; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb0) b);
 auto.
Qed.
Hint Resolve divP_inv1 divP_inv2 divP_inv3.

Theorem divP_plusTerm :
 forall a b c : Term A n,
 divP a c ->
 divP b c ->
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 divP (plusTerm (A:=A) plusA (n:=n) a b) c.
intros a b c H' H'0; inversion H'0; inversion H'.
intros H'1 H'2; apply divTerm_def with (nZb := nZb0); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb0) c)
            (multTerm (A:=A) multA (n:=n) (divTerm b nZb0) c));
 auto.
apply eqTerm_plusTerm_comp with (1 := cs); auto.
apply multTerm_eqT; auto.
apply eqT_divTerm; auto.
apply (eqT_refl A n).
apply (eqT_refl A n).
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (plusTerm (A:=A) plusA (n:=n) (divTerm a nZb0) (divTerm b nZb0))
            c); auto.
apply multTerm_plusTerm_dist_l with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqT_divTerm_plusTerm; auto.
Qed.
Hint Resolve divP_plusTerm.

Theorem divP_invTerm_l :
 forall a b : Term A n, divP a b -> divP (invTerm (A:=A) invA (n:=n) a) b.
intros a b H'; inversion H'; auto.
apply divTerm_def with (nZb := nZb); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (invTerm (A:=A) invA (n:=n) (divTerm a nZb)) b);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_invTerm_l; auto.
Qed.
Hint Resolve divP_invTerm_l.

Theorem divP_invTerm_r :
 forall a b : Term A n, divP a b -> divP a (invTerm (A:=A) invA (n:=n) b).
intros a b H'; inversion H'.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (invTerm (A:=A) invA (n:=n) b));
 [ intros nZib | auto ].
apply divTerm_def with (nZb := nZib); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (invTerm (A:=A) invA (n:=n) (divTerm a nZb))
            (invTerm (A:=A) invA (n:=n) b)); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb)
               (invTerm (A:=A) invA (n:=n) b))); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (invTerm (A:=A) invA (n:=n)
               (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b)));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb) b);
 auto.
apply eqTerm_invTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com_r with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_invTerm_r; auto.
Qed.
Hint Resolve divTerm_nZ.
Hint Resolve divP_invTerm_r.

Theorem divTerm_multTerml :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (multTerm (A:=A) multA (n:=n) a b) a.
intros a b nZa nZb.
apply divTerm_def with (nZb := nZa); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZa) b) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n) b) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) b a); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply div_is_T1; auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_multTerm_r; auto.
Qed.

Theorem divTerm_multTermr :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (multTerm (A:=A) multA (n:=n) a b) b.
intros a b nZa nZb.
apply divTerm_def with (nZb := nZb); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) a (divTerm b nZb)) b);
 auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_multTerm_l; auto.
Qed.
Hint Resolve divTerm_multTermr divTerm_multTerml.

Theorem divP_trans : transitive (Term A n) divP.
red in |- *; intros a b c H' H'0.
cut (~ zeroP (A:=A) A0 eqA (n:=n) c); [ intros nZc | auto ].
apply divTerm_def with (nZb := nZc); auto.
apply divP_inv1 with (b := b); auto.
2: apply divP_inv2 with (a := b); auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) b); [ intros nZb | auto ].
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb) (divTerm b nZc)) c);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb)
            (multTerm (A:=A) multA (n:=n) (divTerm b nZc) c));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb) b);
 auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
inversion H'0; inversion H'.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) nZc);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_multTerm_l; auto.
apply eqTerm_divTerm_comp; auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (1 := H4);
 auto.
apply divP_inv2 with (a := a); auto.
Qed.
Hint Resolve divP_trans.

Theorem divP_nZero :
 forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 divP a b -> ~ zeroP (A:=A) A0 eqA (n:=n) (divTerm a nZb).
intros a b nZb H'; inversion H'; auto.
Qed.
Hint Resolve divP_nZero.

Theorem divP_eqTerm_comp :
 forall a b c : Term A n,
 divP a c -> eqTerm (A:=A) eqA (n:=n) a b -> divP b c.
intros a b c H' H'0.
cut (~ zeroP (A:=A) A0 eqA (n:=n) c); [ intros nZc | auto ].
apply divTerm_def with (nZb := nZc); auto.
apply nzeroP_comp_eqTerm with (1 := cs) (a := a); auto.
apply divP_inv1 with (b := c); auto.
2: apply divP_inv2 with (a := a); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZc) c);
 auto.
apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (y := a); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem divP_on_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> eqT a b -> divP a b.
intros a b H' nZb H'1; apply divTerm_def with (nZb := nZb); auto.
apply divTerm_on_eqT; auto.
Qed.

Theorem divP_on_eqT_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqT a b -> eqT (divTerm a nZb) (T1 A1 n).
intros a b H nZb H0; apply divTerm_on_eqT_eqT; auto.
Qed.
Hint Resolve divP_on_eqT divP_on_eqT_eqT.

Inductive ppcm (p q : Term A n) : Term A n -> Prop :=
    ppcm0 :
      forall s : Term A n,
      (forall r : Term A n, divP r p -> divP r q -> divP r s) ->
      divP s p -> divP s q -> ppcm p q s.
Hint Resolve ppcm0.

Theorem ppc_is_ppcm :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> ppcm a b (ppc a b).
intros a b nZa nZb; apply ppcm0; auto.
intros r H'1 H'2; inversion H'1; inversion H'2.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b)); [ intros nZppab | auto ].
apply divTerm_def with (nZb := nZppab); auto.
apply divTerm_ppc with (nZa := nZa) (nZb := nZb); auto.
apply ppc_nZ; auto.
apply divTerm_def with (nZb := nZa); auto.
apply ppc_nZ; auto.
apply divTerm_ppcl; auto.
apply divTerm_def with (nZb := nZb); auto.
apply ppc_nZ; auto.
apply divTerm_ppcr; auto.
Qed.

Theorem ppc_multTerm_divP :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 divP (multTerm (A:=A) multA (n:=n) a b) (ppc a b).
intros a b H' H'0.
elim ppc_is_ppcm; auto.
Qed.
Hint Resolve ppc_multTerm_divP.

Theorem divP_comp :
 forall a b c d : Term A n,
 divP a c ->
 eqTerm (A:=A) eqA (n:=n) a b -> eqTerm (A:=A) eqA (n:=n) c d -> divP b d.
intros a b c d H'; generalize b d; elim H'.
intros a0 b0 nZa0 nZb0 H'2 b1 d0 H'3 H'4; auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) d0); [ intros nZd0 | auto ].
apply divTerm_def with (nZb := nZd0); auto.
red in |- *; intros nz1; absurd (zeroP (A:=A) A0 eqA (n:=n) a0); auto.
apply zeroP_comp_eqTerm with (1 := cs) (a := b1); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (y := a0); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a0 nZb0) b0);
 auto.
red in |- *; intros nz1; absurd (zeroP (A:=A) A0 eqA (n:=n) b0); auto.
apply zeroP_comp_eqTerm with (1 := cs) (a := d0); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem divP_multTerm_l :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) a b) c -> divP c a.
intros a b c H' H'0 H'1.
apply divP_comp with (a := multTerm (A:=A) multA (n:=n) a b) (c := a); auto.
Qed.

Theorem divP_multTerm_r :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) a b) c -> divP c b.
intros a b c H' H'0 H'1.
apply divP_comp with (a := multTerm (A:=A) multA (n:=n) a b) (c := b); auto.
Qed.
Hint Resolve divP_multTerm_r divP_multTerm_l.

Theorem divP_ppcl :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (ppc a b) a.
intros a b H' H'0; try assumption.
lapply (ppc_is_ppcm a b);
 [ intros H'3; lapply H'3; clear H'3; [ intros H'4 | idtac ] | idtac ];
 auto; auto.
inversion H'4; auto.
Qed.

Theorem divP_ppcr :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (ppc a b) b.
intros a b H' H'0; try assumption.
lapply (ppc_is_ppcm a b);
 [ intros H'3; lapply H'3; clear H'3; [ intros H'4 | idtac ] | idtac ];
 auto; auto.
inversion H'4; auto.
Qed.
Hint Resolve divP_ppcl divP_ppcr.

Theorem divTerm_compo :
 forall (a b c : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c),
 divP a b ->
 divP b c ->
 eqTerm (A:=A) eqA (n:=n) (divTerm a nZc)
   (multTerm (A:=A) multA (n:=n) (divTerm a nZb) (divTerm b nZc)).
intros a b c nZb nZc H'; inversion H'.
intros H'0; inversion H'0.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) nZc);
 auto.
Qed.
Hint Resolve divTerm_compo.

Theorem divP_comp_ppc0 :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b))
   (p : list (Term A n)),
 eqTerm (A:=A) eqA (n:=n) b
   (multTerm (A:=A) multA (n:=n)
      (divTerm (multTerm (A:=A) multA (n:=n) a b) nZppab)
      (divTerm (ppc a b) nZa)).
intros a b nZa nZb nZppab p.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZa) b);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a b) nZa);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem divP_comp_ppc1 :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b))
   (p : list (Term A n)),
 eqTerm (A:=A) eqA (n:=n) a
   (multTerm (A:=A) multA (n:=n)
      (divTerm (multTerm (A:=A) multA (n:=n) a b) nZppab)
      (divTerm (ppc a b) nZb)).
intros a b nZa nZb nZppab H'0.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) a (divTerm b nZb));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a b) nZb);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem divP_dec :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> {divP a b} + {~ divP a b}.
intros a b nZa nZb.
elim divTerm_dec with (a := a) (nZb := nZb); auto.
intros H'1; left; apply divTerm_def with (nZb := nZb); auto.
Qed.

Theorem divP_eqT :
 forall a b c : Term A n,
 eqT a b -> ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP a c -> divP b c.
intros a b c H' nZb H'1; inversion H'1.
apply divTerm_def with (nZb := nZb0); auto.
apply divTerm_eqT with (a := a); auto.
Qed.

Theorem eqTerm_multTerm_imp_eqTerm :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) c ->
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) c a)
   (multTerm (A:=A) multA (n:=n) c b) -> eqTerm (A:=A) eqA (n:=n) a b.
intros a b c nZc H'0.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) c a) nZc);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZc) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply
  (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
   with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZc) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) c b) nZc);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZc) b);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) b);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem multTerm_eqTerm_inv :
 forall a b c : Term A n,
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) a b)
   (multTerm (A:=A) multA (n:=n) a c) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> eqTerm (A:=A) eqA (n:=n) b c.
intros a b c H' H'1.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) b (divTerm a H'1));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) b a) H'1);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a b) H'1);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) c (divTerm a H'1));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) c a) H'1);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a c) H'1);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) c (T1 A1 n));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem eqT_nzero_divP :
 forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 eqT a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> divP a b.
intros a b nZb H'0 H'1; auto.
apply divP_eqT with (a := multTerm (A:=A) multA (n:=n) (divTerm a nZb) b);
 auto.
apply (eqT_sym A n); auto.
Qed.
Hint Resolve eqT_nzero_divP.

Theorem eqT_nzero_eqT_divP :
 forall (a b c : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 eqT c (multTerm (A:=A) multA (n:=n) (divTerm c nZb) b) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> eqT a c -> divP a b.
intros a b c nZb H'0 H'1 H'2.
apply eqT_nzero_divP with (nZb := nZb); auto.
apply (eqT_trans A n) with (y := c); auto.
apply
 (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZb) b);
 auto.
apply (eqT_sym A n); auto.
apply multTerm_eqT; auto.
apply eqT_divTerm; auto; apply (eqT_refl A n); auto.
apply (eqT_refl A n); auto.
Qed.
Hint Resolve eqT_nzero_eqT_divP.
End DivTerm.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import hypermap.
Require Import geometry.
Require Import coloring.
Require Import znat.
Require Import grid.
Require Import matte.
Require Import real.
Require Import realmap.
Require Import realsyntax.
Require Import Setoid.
Require Import realprop.

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

Section ApproxMap.

(*   Approximations of real scalar, points, regions and rectangles, used for *)
(* casting the continuous four color problem into a combinatorial form.      *)
(*   Because the grid decomposition is based on dichotomy, we choose to      *)
(* approximate the real coordinates with binary decimals (i.e., floating     *)
(* nubers, rather than arbitrary rationals.                                  *)

Variable R : real_model.

Notation point := (point R).
Notation region := (region R).
Notation map := (map R).
Notation rect := (rect R).
Notation interval := (interval R).

(* Because of the limitations of Coq v8.0 Setoid tactics, we need to repeat *)
(* some of the boilerplate from file realprop.v. here.                      *)

Let RR : Type := R.
Let isR (x : RR) : RR := x.
Let leqR : RR -> RR -> Prop := locked (@leqr _).
Let eqR : RR -> RR -> Prop := @eqr _.
Let addR : RR -> RR -> RR := locked (@addr _).
Let oppR : RR -> RR := locked (@oppr _).
Let mulR : RR -> RR -> RR := locked (@mulr _).
Let selR : Prop -> RR -> RR -> RR := locked (@selr _).
Let minR : RR -> RR -> RR := locked (@minr _).
Let maxR : RR -> RR -> RR := locked (@maxr _).
Let range1R : RR -> RR -> Prop := @range1r _.
Coercion Local natR := natr R.
Coercion Local znatR := znatr R.

Open Scope real_scope.

Remark rwR : forall x1 x2 : R, x1 == x2 -> eqR (isR x1) (isR x2).
Proof. done. Qed.

Remark leqRI : forall x1 x2 : R, (x1 <= x2) = leqR (isR x1) (isR x2).
Proof. by unlock leqR. Qed.

Remark eqRI : forall x1 x2 : R, (x1 == x2) = eqR (isR x1) (isR x2).
Proof. by unlock eqR. Qed.

Remark addRI : forall x1 x2 : R, x1 + x2 = addR (isR x1) (isR x2).
Proof. by unlock addR. Qed.

Remark oppRI : forall x : R, - x = oppR (isR x).
Proof. by unlock oppR. Qed.

Remark mulRI : forall x1 x2 : R, x1 * x2 = mulR (isR x1) (isR x2).
Proof. by unlock mulR. Qed.

Remark selRI : forall P (x1 x2 : R),
  select {x1 if P, else x2} = selR P (isR x1) (isR x2).
Proof. by unlock selR. Qed.

Remark minRI : forall x1 x2 : R, min x1 x2 = minR (isR x1) (isR x2).
Proof. by unlock minR. Qed.

Remark maxRI : forall x1 x2 : R, max x1 x2 = maxR (isR x1) (isR x2).
Proof. by unlock maxR. Qed.

Lemma range1RI : forall x1 x2 : R, range1r x1 x2 = range1R (isR x1) (isR x2).
Proof. done. Qed.

Add Setoid RR eqR (eqr_theory R).

Hint Unfold eqR.

Let eqR_refl : forall x, eqR x x := @eqr_refl R.
Hint Resolve eqr_refl leqrr ltrW ltr01 ltr02.

Let ltr01 := (ltr01 R).
Let ltr02 := (ltr02 R).
Notation znatr_leqP := (znatr_leqPx R _ _).
Notation znatr_ltP := (znatr_ltPx R _ _).

Add Morphism isR : discrmap_isr_morphism. Proof. done. Qed.

Add Morphism leqR : discrmap_leqr_morphism. Proof. exact: leqR_morphism. Qed.

Add Morphism addR : discrmap_addr_morphism. Proof. exact: addR_morphism. Qed.

Add Morphism oppR : discrmap_oppr_morphism. Proof. exact: oppR_morphism. Qed.

Add Morphism mulR : discrmap_mulr_morphism. Proof. exact: mulR_morphism. Qed.

Add Morphism minR : discrmap_minr_morphism.
Proof. unlock minR; exact: minr_morphism. Qed.

Add Morphism maxR : discrmap_maxr_morphism.
Proof. unlock maxR; exact: maxr_morphism. Qed.

Add Morphism selR : discrmap_selR_morphism.
Proof. unlock selR; exact: selr_morphism. Qed.

Add Morphism range1R : discrmap_range1r_morphism.
Proof. exact: range1r_morphism. Qed.

(* Real powers of 2, for scaling approximations.                          *)

Fixpoint exp2 (s : nat) : R := if s is S s' then 2 * exp2 s' else 1.

Lemma leqr1exp2 : forall s, 1 <= exp2 s.
Proof.
elim=> [|s]; [ exact: leqrr | rewrite -(leqr_pmul2l 1 (exp2 s) ltr02) /= ].
apply: leqr_trans; rewrite leqRI (rwR (mulr1 2)) -leqRI.
exact: (znatr_leqPx _ 1%nat 2%nat).
Qed.

Lemma ltr0exp2 : forall s, 0 < exp2 s.
Proof. move=> s; apply: (ltr_leq_trans ltr01); exact: leqr1exp2. Qed.
Implicit Arguments ltr0exp2 [].

Lemma exp2_add : forall s1 s2, exp2 (s1 + s2) == exp2 s1 * exp2 s2.
Proof.
move=> s1 s2; elim: s1 => [|s1 Hrec] /=.
  by rewrite eqRI (rwR (mul1r (exp2 s2))).
rewrite eqRI mulRI addnI (rwR Hrec) -mulRI; apply: mulrA.
Qed.

Lemma leq_exp2 : forall s1 s2, (s1 <= s2)%dnat -> exp2 s1 <= exp2 s2.
Proof.
move=> s1 s2 Hs12; rewrite -(leq_add_sub Hs12).
move: {s2 Hs12}(s2 - s1)%dnat => s2.
rewrite leqRI -(rwR (mulr1 (exp2 s1))) (rwR (exp2_add s1 s2)) -leqRI.
rewrite (leqr_pmul2l 1 (exp2 s2) (ltr0exp2 s1)); exact: leqr1exp2.
Qed.

Lemma ltr1exp2S : forall s, 1 < exp2 (S s).
Proof.
move=> s; apply: ltr_leq_trans (leq_exp2 (ltn0Sn s)).
rewrite /= leqRI (rwR (mulr1 2)) -leqRI; exact: ltrSr.
Qed.
Implicit Arguments ltr1exp2S [].

(* Scalar decimal approximation.                                       *)

Definition approx s (x : RR) (m : znat) := range1r m (exp2 s * x).

Add Morphism approx : approx_morphism.
Proof. by move=> s x y m Dx; rewrite /approx range1RI !mulRI Dx. Qed.

Lemma approxI : forall s (x : R), approx s x = approx s (isR x).
Proof. done. Qed.

Lemma approx_inj : forall s (x : R) m1 m2,
  approx s x m1 -> approx s x m2 -> m1 = m2.
Proof. move=> s x; apply: range1z_inj. Qed.

Lemma approx_exists : forall s (x : R), exists m, approx s x m.
Proof. by move=> s x; apply: find_range1z. Qed.

Definition scale s (m : znat) : R := m / exp2 s.

Lemma approx_scale : forall s m, approx s (scale s m) m.
Proof.
move=> s m; rewrite /approx /scale range1RI.
rewrite (rwR (mulrCA (exp2 s) m (invr (exp2 s)))).
rewrite mulRI (rwR (divrr (gtr_neq (ltr0exp2 s)))) -mulRI.
rewrite (rwR (mulr1 m)); exact: range1zz.
Qed.

Lemma approx_halfz : forall s (x : R) m, approx (S s) x m -> approx s x (halfz m).
Proof.
rewrite /approx /=; move/exp2=> y x m; rewrite range1RI -(rwR (mulrA 2 y x)).
move: {y x}(y * x) => x; rewrite /range1R /range1r /isR !leqRI !addRI /znatR.
rewrite (rwR (znatr_addbit _ m)) -/znatR -/natR -!addRI -!leqRI.
move/halfz: m (oddz m) => m b [Hxm Hmx].
rewrite -(leqr_pmul2l m x ltr02) -(leqr_pmul2l (m + 1) x ltr02); split.
  apply: leqr_trans Hxm; rewrite leqRI -(rwR (add0r (2 * m))) -leqRI.
  rewrite (leqr_add2r (2 * m) 0 b); exact: leqr0n.
apply: (ltr_leq_trans Hmx); rewrite leqRI (rwR (mulr_addr 2 m 1)).
rewrite (addRI (2 * m)) (rwR (mulr1 2)) -addRI (rwR (addrCA (2 * m) 1 1)).
rewrite -(rwR (addrA b (2 * m) 1)) -leqRI (leqr_add2r (2 * m + 1) b 1).
by case: (b) => /=; auto.
Qed.

Lemma scale_exists : forall x : R, x > 0 -> exists s, exp2 s * x > 1.
Proof.
move=> x Hx; case: (find_range1z (/ x)) => [[s|s'] [_]].
  rewrite /= -/natR -(leqr_pmul2l (s + 1) (/ x) Hx) leqRI.
  rewrite (rwR (divrr (gtr_neq Hx))) /natR mulRI -(rwR (natr_S _ s)) -/natR.
  rewrite -mulRI -leqRI => Hs.
  exists s; elim: s x Hx Hs => [|s Hrec] x Hx Hs /=.
    by rewrite leqRI (rwR (mulrC 1 x)) -leqRI.
  rewrite leqRI -(rwR (mulrA 2 (exp2 s) x)).
  rewrite (rwR (mulrCA 2 (exp2 s) x)) -leqRI; apply Hrec.
    by rewrite leqRI -(rwR (mulr0 2)) -leqRI (leqr_pmul2l x 0 ltr02).
  apply: (ltr_leq_trans Hs); rewrite leqRI -(rwR (mulrA 2 x (S s))).
  rewrite (rwR (mulrCA 2 x (S s))) -leqRI.
  rewrite (leqr_pmul2l (S (S s)) (2 * S s) Hx).
  rewrite leqRI (rwR (mulr_addl (S s) 1 1)) addRI (rwR (mul1r (S s))) -addRI.
  rewrite /natR (rwR (natr_S _ (S s))) -/natR -leqRI (leqr_add2l (S s) 1 (S s)).
  by apply: (znatr_leqPx R 1%nat (S s)) => /=; rewrite leqz_nat.
case; apply ltrW; apply: leqr_lt_trans (posr_inv Hx).
rewrite leqRI -/znatR (rwR (addrC (Zneg s') 1)).
rewrite addRI /znatR /znatr oppRI (rwR (natr_S _ s')) -/natR -oppRI.
rewrite (rwR (oppr_add s' 1)) -addRI (rwR (addrCA 1 (- s') (- 1))).
rewrite addRI (rwR (subrr 1)) -addRI (rwR (addr0 (- s'))) -(rwR (oppr0 _)).
rewrite -leqRI (leqr_opp2 s' 0); exact: leqr0n.
Qed.

Lemma approx_between : forall s (x1 x2 : R) m1 m2,
   approx (S s) x1 m1 -> approx (S s) x2 m2 -> 1 < exp2 s * (x2 - x1) ->
  exists2 m, (incz m1 <= m)%Z & (incz m <= m2)%Z.
Proof.
move=> s x1 x2 m1 m2; set s2 := exp2 s; set z := s2 * (x2 - x1).
case: (approx_exists s (x1 + x2)) => m; rewrite /approx /= -/s2.
set y := s2 * (x1 + x2).
have Dx1: 2 * s2 * x1 == y - z.
  rewrite eqRI -(rwR (mulrA 2 s2 x1)) (rwR (mulrCA 2 s2 x1)).
  rewrite mulRI (rwR (mulr_addl x1 1 1)) addRI (rwR (mul1r x1)).
  rewrite /y /z addRI -(rwR (mulr_oppr s2 (x2 - x1))) !mulRI.
  rewrite (rwR (oppr_sub x2 x1)) -!mulRI -!addRI.
  rewrite -(rwR (mulr_addr s2 (x1 + x2) (x1 - x2))) !mulRI.
  rewrite (rwR (addrCA (x1 + x2) x1 (- x2))) 2!addRI.
  rewrite -(rwR (addrA x1 x2 (- x2))) addRI (rwR (subrr x2)) -!addRI 2!addRI.
  by rewrite (rwR (addr0 x1)).
have Dx2: 2 * s2 * x2 == y + z.
  rewrite eqRI -(rwR (mulrA 2 s2 x2)) (rwR (mulrCA 2 s2 x2)).
  rewrite mulRI (rwR (mulr_addl x2 1 1)) addRI (rwR (mul1r x2)).
  rewrite /y /z -(rwR (mulr_addr s2 (x1 + x2) (x2 - x1))) !mulRI.
  rewrite (rwR (addrCA (x1 + x2) x2 (- x1))) addRI.
  rewrite -(rwR (addrA x1 x2 (- x1))) (rwR (addrCA x1 x2 (- x1))) addRI.
  by rewrite (rwR (subrr x1)) -!addRI 2!addRI (rwR (addr0 x2)).
move=> [Hmy Hym]; rewrite range1RI (rwR Dx1) /isR {Dx1} => [[Hm1 _]].
case=> _; rewrite leqRI -/znatR {Dx2}(rwR Dx2) -leqRI => Hm2 Hz.
exists m; apply/znatr_ltP; rewrite -/znatR.
  apply: (leqr_lt_trans Hm1); rewrite -(leqr_add2l z m (y - z)) leqRI.
  rewrite (rwR (addrCA z y (- z))) 2!addRI (rwR (subrr z)) -!addRI.
  rewrite (rwR (addr0 y)) (rwR (addrC z m)) -leqRI; apply: (ltr_leq_trans Hym).
  by apply ltrW; rewrite -/znatR (leqr_add2l m z 1).
apply: (leqr_lt_trans Hmy); rewrite -(leqr_add2r z m2 y).
by apply: (ltr_leq_trans Hm2); apply ltrW; rewrite (leqr_add2l m2 z 1).
Qed.

(* Geometrical binary approximation.                                   *)

Definition approx_point s (z : point) p :=
  let: Point x y := z in let: Gpoint mx my := p in approx s x mx /\ approx s y my.

Lemma approx_point_inj : forall s z p1 p2,
  approx_point s z p1 -> approx_point s z p2 -> p1 = p2.
Proof.
move=> s [x y] [mx1 my1] [mx2 my2] [Hx1 Hy1] [Hx2 Hy2].
congr Gpoint; eapply approx_inj; eauto.
Qed.

Lemma approx_point_exists : forall s z, exists p, approx_point s z p.
Proof.
move=> s [x y]; case: (approx_exists s x) (approx_exists s y) => [mx Hmx] [my Hmy].
by exists (Gpoint mx my); split.
Qed.

Definition scale_point s p : point :=
  let: Gpoint mx my := p in Point (scale s mx) (scale s my).

Lemma approx_scale_point : forall s p, approx_point s (scale_point s p) p.
Proof. move=> s [mx my]; split; apply approx_scale. Qed.

Lemma approx_halfg : forall s z p,
   approx_point (S s) z p -> approx_point s z (halfg p).
Proof. by move=> s [x y] [mx my] [Hx Hy]; split; apply approx_halfz. Qed.

Notation gpset := (set gpointData).

Definition mem_approx s (gr : gpset) : region :=
   fun z => exists2 p, approx_point s z p & gr p.

Lemma sub_mem_approx : forall s (gr1 gr2 : gpointset),
  sub_set gr1 gr2 -> subregion (mem_approx s gr1) (mem_approx s gr2).
Proof. move=> s gr1 gr2 Hgr12 z [p Dp Hp]; exists p; auto. Qed.

Lemma mem_approx_scale : forall s gr p,
  reflect (mem_approx s gr (scale_point s p)) (gr p).
Proof.
move=> s gr p; apply: (iffP idP) => [Hp|[p' Dp' Hp']].
  by exists p; first by apply approx_scale_point.
by rewrite (approx_point_inj (approx_scale_point _ _) Dp').
Qed.

Lemma mem_approx_refine1_rect : forall s b z,
  mem_approx (S s) (refine_rect b) z <-> mem_approx s b z.
Proof.
move=> s b z; split; move=> [p Dp Hp].
  by exists (halfg p); [ apply approx_halfg | rewrite -mem_refine_rect ].
  case: (approx_point_exists (S s) z) => [p' Dp']; exists p'; first done.
by rewrite mem_refine_rect (approx_point_inj (approx_halfg Dp') Dp).
Qed.

Lemma mem_approx_refine_rect : forall s s' b z,
  mem_approx (s + s') (iter s refine_rect b) z <-> mem_approx s' b z.
Proof.
move=> s s' b z; elim: s => //= [|s Hrec]; first by split.
rewrite -Hrec addSn; apply mem_approx_refine1_rect.
Qed.

Lemma mem_approx_refine1_matte : forall s mm z,
  mem_approx (S s) (refine_matte mm) z <-> mem_approx s mm z.
Proof.
move=> s mm z; split; move=> [p Dp Hp].
  by exists (halfg p); [ apply approx_halfg | rewrite -mem_refine_matte ].
  case: (approx_point_exists (S s) z) => [p' Dp']; exists p'; first done.
by rewrite mem_refine_matte (approx_point_inj (approx_halfg Dp') Dp).
Qed.

Lemma mem_approx_refine_matte : forall s s' mm z,
  mem_approx (s + s') (iter s refine_matte mm) z <-> mem_approx s' mm z.
Proof.
move=> s s' b z; elim: s => //= [|s Hrec]; first by split.
rewrite -Hrec addSn; apply: mem_approx_refine1_matte.
Qed.

Lemma mem_approx_inset2 : forall s b,
  subregion (mem_approx s (inset b)) (mem_approx (S s) (inset2 (refine_rect b))).
Proof.
move=> s b z [p Dp Hp].
case: (approx_point_exists (S s) z) => [p' Dp']; exists p'; first done.
by apply inset2_refine; rewrite (approx_point_inj (approx_halfg Dp') Dp).
Qed.

Lemma mem_approx_inset1 : forall s b,
  subregion (mem_approx s (inset b)) (mem_approx (S s) (inset (refine_rect b))).
Proof.
by move=> s r z; case/mem_approx_inset2=> [p Dp Hp]; case/andP: Hp; exists p.
Qed.

Lemma mem_approx_inset : forall s s' b,
 subregion (mem_approx s' (inset b))
           (mem_approx (s + s') (inset (iter s refine_rect b))).
Proof.
move=> s s' b z; elim: s => [|s Hrec] //= Hz; rewrite addSn.
apply: mem_approx_inset1; auto.
Qed.

Lemma approx_rect : forall z (r : rect), r z ->
 exists s, exists2 b, mem_approx s (inset b) z & subregion (mem_approx s b) r.
Proof.
move=> [x y] [[xx zx] [xy zy]] [Hrx Hry].
have [s [Hsxx Hszx] [Hsxy Hszy]]:
     exists2 s, 1 < exp2 s * (x - xx) /\ 1 < exp2 s * (zx - x)
              & 1 < exp2 s * (y - xy) /\ 1 < exp2 s * (zy - y).
  case Hrx; rewrite (leqr_sub0 x xx) (leqr_sub0 zx x).
  move/scale_exists=> [s1 Hs1]; move/scale_exists=> [s2 Hs2].
  case Hry; rewrite (leqr_sub0 y xy) (leqr_sub0 zy y).
  move/scale_exists=> [s3 Hs3]; move/scale_exists=> [s4 Hs4].
  have Hleql: forall n1 n2 n3, (n1 <= n2)%dnat -> (n1 <= n2 + n3)%dnat.
    move=> n1 n2 n3 Hn12; apply: (leq_trans Hn12); apply leq_addr.
  have Hleqr: forall n1 n2 n3, (n1 <= n3)%dnat -> (n1 <= n2 + n3)%dnat.
    move=> n1 n2 n3 Hn13; apply: (leq_trans Hn13); apply leq_addl.
  have Hleqs: forall n1 n2 u,
      1 < exp2 n1 * u -> (n1 <= n2)%dnat -> 1 < exp2 n2 * u.
    move=> n1 n2 u Hu1 Hn12.
    have Hu: u > 0.
      rewrite -(leqr_pmul2l u 0 (ltr0exp2 n1)) leqRI (rwR (mulr0 (exp2 n1))).
      by rewrite -leqRI; exact: ltr_trans Hu1.
    apply: (ltr_leq_trans Hu1).
    rewrite leqRI (rwR (mulrC (exp2 n1) u)) (rwR (mulrC (exp2 n2) u)) -leqRI.
    by move/leq_exp2: Hn12; rewrite (leqr_pmul2l (exp2 n1) (exp2 n2) Hu).
  move: leqnn; exists (addn (addn s1 s2) (addn s3 s4)); split; eapply Hleqs; eauto.
case: (approx_exists (S s) x) (approx_exists (S s) y) => [mx Dmx] [my Dmy].
case: (approx_exists (S s) xx) (approx_exists (S s) xy) => [mxx Dmxx] [mxy Dmxy].
case: (approx_exists (S s) zx) (approx_exists (S s) zy) => [mzx Dmzx] [mzy Dmzy].
case: (approx_between Dmxx Dmx) => // [nxx Hnxx Hnxxx].
case: (approx_between Dmx Dmzx) => // [nzx Hxnzx Hnzx].
case: (approx_between Dmxy Dmy) => // [nxy Hnxy Hnxyy].
case: (approx_between Dmy Dmzy) => // [nzy Hynzy Hnzy].
rewrite leqz_inc_dec in Hnxxx; rewrite leqz_inc_dec in Hnxyy.
exists (S s); exists (Grect nxx nzx nxy nzy).
  by exists (Gpoint mx my); try apply/and4P; split.
have Hap: forall u v nu nv,
    approx (S s) u nu -> approx (S s) v nv -> (incz nu <=nv)%Z -> u < v.
  rewrite /approx; move=> u v nu nv [_ Hnu] [Hnv _] Huv.
  rewrite -(leqr_pmul2l v u (ltr0exp2 (S s))).
  apply: (ltr_leq_trans Hnu); apply: leqr_trans Hnv.
  by rewrite leqRI /znatR -(rwR (znatr_inc _ nu)) -leqRI; exact: znatr_leqP.
move=> [x' y'] [[mx' my'] [Dmx' Dmy']]; move/and4P=> [Hmxxx' Hx'mzx Hmxyy' Hy'mzy].
by split; split; eapply Hap; eauto; eapply leqz_trans; eauto; rewrite leqz_inc2.
Qed.

Lemma rect_approx : forall s z p, approx_point s z p ->
  exists2 r : rect, r z & subregion r (mem_approx s (ltouch p)).
Proof.
move=> s [x y] [mx my] [H H']; case: H'; case: H; set s1 := exp2 s.
have Hs1: s1 > 0 by exact: ltr0exp2.
have Es1: forall u, s1 * (u / s1) == u.
  move=> u; rewrite eqRI (rwR (mulrCA s1 u (/ s1))) mulRI.
  by rewrite (rwR (divrr (gtr_neq Hs1))) -mulRI (rwR (mulr1 u)).
move=> Hmxx Hxmx Hmyy Hymy.
pose int_pm1 (m : znat) := Interval ((m - 1) / s1) ((m + 1) / s1).
exists (Rect (int_pm1 mx) (int_pm1 my)).
  split; split.
  - rewrite -(leqr_pmul2l x ((mx - 1) / s1) Hs1) leqRI (rwR (Es1 (mx - 1))).
    rewrite /znatR -(rwR (znatr_dec _ mx)) -/znatR -leqRI.
    by apply: ltr_leq_trans Hmxx; apply: znatr_ltP; rewrite incz_dec leqzz.
  - rewrite -(leqr_pmul2l ((mx + 1) / s1) x Hs1) leqRI (rwR (Es1 (mx + 1))).
    by rewrite -leqRI.
  - rewrite -(leqr_pmul2l y ((my - 1) / s1) Hs1) leqRI (rwR (Es1 (my - 1))).
    rewrite /znatR -(rwR (znatr_dec _ my)) -/znatR -leqRI.
    by apply: ltr_leq_trans Hmyy; apply: znatr_ltPx; rewrite incz_dec leqzz.
  rewrite -(leqr_pmul2l ((my + 1) / s1) y Hs1) leqRI (rwR (Es1 (my + 1))).
  by rewrite -leqRI.
move=> [x' y'] [H H']; case: H'; case: H.
rewrite -(leqr_pmul2l x' ((mx - 1) / s1) Hs1) leqRI (rwR (Es1 (mx - 1))).
rewrite /znatR -(rwR (znatr_dec _ mx)) -/znatR -leqRI => Hmxx'.
rewrite -(leqr_pmul2l ((mx + 1) / s1) x' Hs1) leqRI (rwR (Es1 (mx + 1))).
rewrite -leqRI => Hx'mx.
rewrite -(leqr_pmul2l y' ((my - 1) / s1) Hs1) leqRI (rwR (Es1 (my - 1))).
rewrite /znatR -(rwR (znatr_dec _ my)) -/znatR -leqRI => Hmyy'.
rewrite -(leqr_pmul2l ((my + 1) / s1) y' Hs1) leqRI (rwR (Es1 (my + 1))).
rewrite -leqRI => Hy'my.
case: (approx_point_exists s (Point x' y')) => [p' Hp']; exists p'; auto.
case: p' Hp' => [mx' my'] [H H']; case: H'; case: H; rewrite -/s1.
move=> Hmx'x Hxmx' Hmy'y Hymy'; apply/and4P; split; rewrite -leqz_inc2;
 apply/znatr_ltP; rewrite leqRI /znatR;
 rewrite ?(rwR (znatr_inc _ mx')) ?(rwR (znatr_inc _ mx));
 rewrite ?(rwR (znatr_inc _ my')) ?(rwR (znatr_inc _ my)) -/znatR -leqRI;
 eapply leqr_lt_trans; eauto; eapply ltr_trans; eauto.
Qed.

(* Some rectangle operations.                                                   *)

Definition cap_interval (xz1 xz2 : interval) :=
  let: Interval x1 z1 := xz1 in let: Interval x2 z2 := xz2 in
  Interval (max x1 x2) (min z1 z2).

Lemma mem_cap_interval : forall (xz1 xz2 : interval) y,
  xz1 y /\ xz2 y <-> cap_interval xz1 xz2 y.
Proof.
move=> [x1 z1] [x2 z2] y /=; rewrite (ltr_max x1 x2 y) (ltr_min z1 z2 y); tauto.
Qed.

Definition cap_rect (r1 r2 : rect) :=
  let: Rect xint1 yint1 := r1 in let: Rect xint2 yint2 := r2 in
  Rect (cap_interval xint1 xint2) (cap_interval yint1 yint2).

Lemma mem_cap_rect : forall (r1 r2 : rect) p, r1 p /\ r2 p <-> cap_rect r1 r2 p.
Proof.
move=> [xint1 yint1] [xint2 yint2] [px py] /=.
rewrite -(mem_cap_interval xint1 xint2 px) -(mem_cap_interval yint1 yint2 py).
tauto.
Qed.

Definition sep_interval (x z : R) :=
  let y := (x + z) / 2 in
  Interval (select {z - 1 if z <= y, else y}) (select {z + 1 if z >= y, else y}).

Lemma mem_sep_interval : forall x y : R, sep_interval x y y.
Proof.
move=> x z; rewrite /sep_interval; move: {x}((x + z) / 2) => y; split.
  case: (selr_cases (z <= y) (z - 1) y) => t.
  case; case=> Ht Dt; rewrite leqRI (rwR Dt) -leqRI //; exact: ltPrr.
case: (selr_cases (z >= y) (z + 1) y) => t.
case; case=> Ht Dt; rewrite leqRI (rwR Dt) -leqRI //; exact: ltrSr.
Qed.

Lemma meet_sep_interval : forall x y t,
  sep_interval x y t -> sep_interval y x t -> x == y.
Proof.
suffice Hle: forall t x y, sep_interval x y t -> sep_interval y x t -> x <= y.
  by move=> x y t *; split; apply: (Hle t).
move=> t x y Hxyt Hyxt; case: (reals_classic R (x <= y)) => // Hyx.
case: Hyxt; case: Hxyt.
rewrite !selRI !mulRI !leqRI (rwR (addrC y x)) -!mulRI -!leqRI -!selRI.
set z := (x + y) / 2; have Ez2: 2 * z == x + y.
rewrite /z eqRI (rwR (mulrCA 2 (x + y) (/ 2))) mulRI.
  rewrite (rwR (divrr (gtr_neq ltr02))) -mulRI; exact: mulr1.
have [Hyz Hzx]: y < z < x.
  rewrite -(leqr_pmul2l z y ltr02) -(leqr_pmul2l x z ltr02) !leqRI (rwR Ez2).
  rewrite (rwR (mul2r x)) (rwR (mul2r y)) -!leqRI.
  by rewrite (leqr_add2l x x y) (leqr_add2r y x y); split.
clear; case: (selr_cases (z <= y) (y + 1) z) => z'.
case=> [[Hz _]|[_ Dz']]; first by case Hyz.
rewrite leqRI {z' Dz'}(rwR Dz') -leqRI => Hzt.
case: (selr_cases (x <= z) (x - 1) z) => z'.
case=> [[Hz _]|[_ Dz']]; first by case Hzx.
by rewrite leqRI {z' Dz'}(rwR Dz') -leqRI; case; exact: ltrW.
Qed.

Definition sep_rect z1 z2 :=
  let: Point x1 y1 := z1 in let: Point x2 y2 := z2 in
  Rect (sep_interval x1 x2) (sep_interval y1 y2).

Lemma mem_sep_rect : forall z1 z2, sep_rect z1 z2 z2.
Proof. by move=> [x1 y1] [x2 y2] /=; split; apply mem_sep_interval. Qed.

Lemma meet_sep_rect : forall z1 z2, meet (sep_rect z1 z2) (sep_rect z2 z1) ->
  forall rr : rect, rr z1 -> rr z2.
Proof.
move=> [x1 y1] [x2 y2] [[x y] [[Hx12 Hy12] [Hx21 Hy21]]] [[t1 t2] [t3 t4]] Hrz1.
rewrite /= !leqRI -(rwR (meet_sep_interval Hx12 Hx21)).
by rewrite -(rwR (meet_sep_interval Hy12 Hy21)) -!leqRI.
Qed.

End ApproxMap.

Set Strict Implicit.
Unset Implicit Arguments.


From Coq Require Import PArith.
From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.IsVariable.
From Velus Require Import NLustre.IsDefined.
From Velus Require Import NLustre.Memories.

(** * No duplication of variables *)

(**

  The [NoDup_def] predicate states that variables are only defined
  once. This is asking for some sort of SSA.

  Remark: [Ordered_nodes] is implied by [Welldef_global].

 *)

Module Type NODUP
       (Ids          : IDS)
       (Op           : OPERATORS)
       (Import CESyn : CESYNTAX       Op)
       (Import Syn   : NLSYNTAX   Ids Op CESyn)
       (Import Mem   : MEMORIES   Ids Op CESyn Syn)
       (Import IsD   : ISDEFINED  Ids Op CESyn Syn Mem)
       (Import IsV   : ISVARIABLE Ids Op CESyn Syn Mem IsD).

  Inductive NoDup_defs : list equation -> Prop :=
  | NDDNil: NoDup_defs nil
  | NDDEqDef:
      forall x ck e eqs,
        NoDup_defs eqs ->
        ~Is_defined_in x eqs ->
        NoDup_defs (EqDef x ck e :: eqs)
  | NDDEqApp:
      forall xs ck f e r eqs,
        NoDup_defs eqs ->
        (forall x, In x xs -> ~Is_defined_in x eqs) ->
        NoDup_defs (EqApp xs ck f e r :: eqs)
  | NDDEqFby:
      forall x ck v e eqs,
        NoDup_defs eqs ->
        ~Is_defined_in x eqs ->
        NoDup_defs (EqFby x ck v e :: eqs).

  (** ** Properties *)

  Lemma NoDup_defs_cons:
    forall eq eqs,
      NoDup_defs (eq :: eqs) -> NoDup_defs eqs.
  Proof.
    intros eq eqs Hndd.
    destruct eq; inversion_clear Hndd; assumption.
  Qed.

  Lemma not_Is_variable_in_memories:
    forall x eqs,
      PS.In x (memories eqs)
      -> NoDup_defs eqs
      -> ~Is_variable_in x eqs.
  Proof.
    intros x eqs Hinm Hndd Hvar.

    induction eqs as [ | eq eqs IHeqs ].
    - inv Hvar.
    - assert (NoDup_defs eqs)
        by now eapply NoDup_defs_cons; eauto.

      unfold memories in *; simpl in *.
      destruct eq; simpl in *;
      match goal with
      | _ : context[ EqFby _ _ _ _ ] |- _ =>
        idtac
      | _ =>
        (* Case: eq ~ EqApp or eq ~ EqDef *)
        (assert (Is_defined_in x eqs)
          by now apply Is_defined_in_memories);
        (assert (Is_variable_in x eqs)
          by now inv Hvar; auto; exfalso; inv Hndd;
            match goal with
            | H: Is_variable_in_eq ?x (EqDef ?i _ _) |- _ => inv H
            | H: Is_variable_in_eq ?x (EqApp ?i _ _ _ _) |- _ => inv H
            end; firstorder);
        now apply IHeqs
      end.
      (* Case: eq ~ EqFby *)
      rewrite In_fold_left_memory_eq in Hinm.
      destruct Hinm.
      * assert (Is_defined_in x eqs)
          by now apply Is_defined_in_memories.
        assert (Is_variable_in x eqs)
          by now inv Hvar; auto; exfalso; inv Hndd;
            match goal with
            | H: Is_variable_in_eq ?x (EqFby ?i _ _ _) |- _ => inv H
            end.
        now apply IHeqs.
      * assert (x = i) as ->.
        {
          rewrite PSF.add_iff in H0.
          destruct H0; auto.
          exfalso; eapply not_In_empty; eauto.
        }

        assert (~ Is_variable_in i eqs)
          by now apply not_Is_defined_in_not_Is_variable_in;
          inv Hndd.

        assert (~ Is_variable_in_eq i (EqFby i c c0 e))
          by now intro His_var; inv His_var.

        now inv Hvar.
  Qed.

  Lemma NoDup_defs_NoDup_vars_defined:
    forall eqs,
      NoDup (vars_defined eqs) ->
      NoDup_defs eqs.
  Proof.
    unfold vars_defined.
    induction eqs as [|eq eqs].
    - auto using NoDup_defs.
    - simpl. intro Hnodup.
      apply NoDup_app'_iff in Hnodup.
      destruct Hnodup as (Hnd1 & Hnd2 & Hni).
      apply IHeqs in Hnd2.
      destruct eq.
      + constructor; auto.
        simpl in *.
        intro Hdef.
        inv Hni. apply H1.
        now apply Is_defined_in_vars_defined.
      + constructor; auto.
        intros x Hin Hdef.
        simpl in *.
        eapply Forall_forall in Hin; eauto.
        apply Hin.
        now apply Is_defined_in_vars_defined.
      + constructor; auto.
        simpl in *.
        intro Hdef.
        inv Hni. apply H1.
        now apply Is_defined_in_vars_defined.
  Qed.

  Lemma NoDup_defs_node:
    forall n,
      NoDup_defs n.(n_eqs).
  Proof.
    intro; apply NoDup_defs_NoDup_vars_defined, NoDup_var_defined_n_eqs.
  Qed.

End NODUP.

Module NoDupFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (CESyn : CESYNTAX       Op)
       (Syn   : NLSYNTAX   Ids Op CESyn)
       (Mem   : MEMORIES   Ids Op CESyn Syn)
       (IsD   : ISDEFINED  Ids Op CESyn Syn Mem)
       (IsV   : ISVARIABLE Ids Op CESyn Syn Mem IsD)
       <: NODUP Ids Op CESyn Syn Mem IsD IsV.

  Include NODUP Ids Op CESyn Syn Mem IsD IsV.

End NoDupFun.


(** * Group Presentations *)
(******************************************************************************)
(*      Copyright (C) 2021      Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype choice fintype.
From mathcomp Require Import ssrnat seq finfun finset tuple.
From mathcomp Require Import bigop fingroup perm morphism alt gproduct.
From mathcomp Require Import ssralg zmodp div.

Require Import ssrcompl.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.

Import GroupScope.

Definition biggseq := (big_cons, big_nil, mulg1, mulgA).

Reserved Notation "gr \present G" (at level 10).

Section DefPresentation.

Implicit Types (gT hT : finGroupType) (I J : finType).

Section Satisfy.

Variable (gT : finGroupType) (I : finType).
Implicit Type (gens : I -> gT) (rels : seq (seq I * seq I)).

Definition satisfy rels gens :=
  all (fun r => \prod_(i <- r.1) gens i == \prod_(i <- r.2) gens i) rels.

Lemma satisfyP rels gens :
  reflect (forall r, r \in rels ->
                           \prod_(i <- r.1) gens i = \prod_(i <- r.2) gens i)
          (satisfy rels gens).
Proof. by apply: (iffP allP) => /= [H r /H /eqP| H r /H ->]. Qed.

Lemma satisfy_eq gens1 gens2 rels :
  gens1 =1 gens2 -> satisfy rels gens1 = satisfy rels gens2.
Proof.
suff impl g1 g2 : g1 =1 g2 -> satisfy rels g1 -> satisfy rels g2.
  by move=> Hgen; apply/idP/idP; apply: impl.
move=> Heq /satisfyP Hsat; apply/satisfyP => /= r rin.
transitivity (\prod_(i <- r.1) g1 i).
  by apply eq_bigr => i _; rewrite Heq.
by rewrite Hsat //; apply eq_bigr => i.
Qed.

Lemma perm_satisfy rels1 rels2 gens :
  perm_eq rels1 rels2 -> satisfy rels1 gens = satisfy rels2 gens.
Proof. by rewrite/satisfy => /perm_all ->. Qed.

Lemma satisfy_cat rels1 rels2 gens :
  satisfy (rels1 ++ rels2) gens = satisfy rels1 gens && satisfy rels2 gens.
Proof. exact: all_cat. Qed.

End Satisfy.

Lemma satisfy_map gT I J (f : I -> J) (gens : J -> gT) rels :
  satisfy rels (gens \o f) =
  satisfy [seq (map f r.1, map f r.2) | r <- rels] gens.
Proof. by rewrite /satisfy all_map; apply eq_all => r; rewrite /= !big_map. Qed.

Lemma satisfy_can gT I J (f : I -> J) f_inv :
    cancel f f_inv ->
  forall (gens : I -> gT) rels,
  satisfy [seq (map f r.1, map f r.2) | r <- rels] (gens \o f_inv) =
  satisfy rels gens.
Proof.
move=> fK gens rels; rewrite -satisfy_map; apply satisfy_eq => x.
by rewrite /= fK.
Qed.

Lemma satisfy_perm gT I J (p : {perm I}) rels (gens : I -> gT) :
  satisfy [seq (map p r.1, map p r.2) | r <- rels] (gens \o p^-1) =
  satisfy rels gens.
Proof. exact/satisfy_can/permK. Qed.

Lemma morph_satisfy gT (G : {group gT}) hT (H : {group hT}) I
      (f : {morphism G >-> hT}) (gens : I -> gT) rels :
  (forall i, gens i \in G) -> satisfy rels gens -> satisfy rels (f \o gens).
Proof.
move=> memgens /satisfyP /= sat; apply/satisfyP => s {}/sat /(congr1 f).
by rewrite !morph_prod.
Qed.

Definition presentation_of gT I (gr : (I -> gT) * (seq (seq I * seq I)))
       (G : {group gT}) (ph : phantom {set gT} G) : Prop :=
  [/\ G = <<[set gr.1 i | i : I]>> :> {set gT},
   satisfy gr.2 gr.1
   & forall (hT : finGroupType) (gensH : I -> hT),
       satisfy gr.2 gensH ->
       exists presm : {morphism G >-> hT}, forall i, presm (gr.1 i) = gensH i].

End DefPresentation.

Notation "gr \present G" := (presentation_of gr (Phantom {set _} G)).

Section Presentation.

Variables (gT : finGroupType) (G : {group gT})
          (I : finType) (gens  : I -> gT) (rels  : seq (seq I * seq I)).
Hypothesis prG : (gens, rels) \present G.

Lemma present_gen : G = <<[set gens i | i : I]>> :> {set gT}.
Proof. by case: prG. Qed.
Lemma present_sat : satisfy rels gens.
Proof. by case: prG. Qed.
Lemma present_mem  i : gens i \in G.
Proof. by rewrite present_gen mem_gen // imset_f. Qed.
Hint Resolve present_mem : core.

Lemma present_eq (gens' : I -> gT) :
  gens =1 gens' -> (gens', rels) \present G.
Proof.
have [/= eqG satG morphG] := prG.
move=> eqgens; apply And3 => //=.
- by rewrite eqG; congr <<_>>; exact: eq_imset.
- by rewrite -(satisfy_eq _ eqgens).
- move=> hT gensH /morphG => [][phi eqphi].
  by exists phi => i; rewrite -eqgens eqphi.
Qed.

Lemma presentP x :
  reflect (exists l (c : 'I_l -> I), \prod_i gens (c i) = x) (x \in G).
Proof.
apply (iffP idP) => [| [l [dec <-{x}]]]; last exact: group_prod.
rewrite present_gen => /gen_prodgP[l [gen Hgen ->{x}]].
have {}get_gen i : {j : I | gen i == gens j}.
  by apply sigW => /=; move: Hgen => /(_ i) /imsetP[/= j _ ->]; exists j.
have dec_in i : gen i \in G by case: (get_gen i) => j /eqP ->.
have decE i : gen i = gens (val (get_gen i)).
  by case: (get_gen i) => j /= /eqP.
by exists l, (fun i => val (get_gen i)); apply eq_bigr.
Qed.

Lemma present_seq_minP x :
  x \in G ->
  {s : seq I | \prod_(i <- s) gens i = x &
                forall s', \prod_(i <- s') gens i = x -> size s <= size s'}.
Proof.
move=> xin.
suff : exists l, [exists t : l.-tuple I, \prod_(i <- t) gens i == x].
  move=> exP; case: (ex_minnP exP) => l /existsP/sigW [/= t /eqP eqt tmin].
  exists t => [//|s' eqs'].
  rewrite size_tuple; apply: tmin; apply/existsP.
  by exists (in_tuple s'); rewrite eqs'.
move/presentP : xin => [l [f eqx]]; exists l; apply/existsP.
exists [tuple f i | i < l]; rewrite -eqx big_tuple.
by apply/eqP/eq_bigr => /= i _; rewrite tnth_mktuple.
Qed.

Lemma present_seqP x :
  x \in G -> {s : seq I | \prod_(i <- s) gens i = x}.
Proof. by move=> /present_seq_minP [s Hs _]; exists s. Qed.

Section Morphism.

Variable (hT : finGroupType) (gensH : I -> hT).
Hypothesis (sat : satisfy rels gensH).

Lemma presm_spec :
  {presm : {morphism G >-> hT} | forall i, presm (gens i) = gensH i}.
Proof.
suff : {m : {ffun gT -> hT} | morphic G m && [forall i, m (gens i) == gensH i]}.
  move=> [m /andP [morm /forallP /= Heq]].
  by exists (morphm_morphism morm) => /= i; rewrite morphmE; apply/eqP.
apply sigW; case: prG => [_ _ /(_ _ _ sat)] [phi eq_phi] /=.
exists (finfun phi); apply/andP; split.
  by apply/morphicP => x y xG yG /=; rewrite !ffunE morphM.
by apply/forallP => /= i; rewrite ffunE eq_phi.
Qed.
Definition presm := let: exist m _ := presm_spec in m.
Lemma presmP : forall i, presm (gens i) = gensH i.
Proof. by rewrite /presm; case: presm_spec. Qed.

Lemma presmE (phi : {morphism G >-> hT}) :
  (forall i, phi (gens i) = gensH i) -> {in G, phi =1 presm}.
Proof.
move=> Heq x /presentP [l [decc <-{x}]].
rewrite !morph_prod //.
by apply: eq_bigr => /= i _; rewrite Heq presmP.
Qed.

Lemma morphim_presm : presm @* G = <<[set gensH i | i : I]>>.
Proof.
have gsub : [set gens i | i : I] \subset G by rewrite present_gen subset_gen.
rewrite [X in presm @* X]present_gen (morphim_gen _ gsub).
rewrite /morphim (setIidPr gsub) -imset_comp; congr <<_>>.
by apply: eq_imset => i /=; rewrite presmP.
Qed.

End Morphism.

Section InjMorphism.

Variables (hT: finGroupType) (phi : {morphism G >-> hT}).
Hypothesis (inj_phi : 'injm phi).

Lemma morph_present : (phi \o gens, rels) \present (phi @* G).
Proof.
have gsub : [set gens i | i : I] \subset G by rewrite present_gen subset_gen.
have gin i : gens i \in G by rewrite present_gen mem_gen // imset_f.
apply And3 => /=.
- rewrite [X in phi @* X]present_gen (morphim_gen _ gsub) /morphim.
  by rewrite (setIidPr gsub) -imset_comp /=.
- apply/satisfyP => /= [][lft rgt] /= /(satisfyP _ _ present_sat) /=.
  by rewrite -!morph_prod // => ->.
- move=> Ht gensH satH.
  have psi_morph : {in phi @* G & ,
                       {morph (presm satH) \o invm inj_phi : x y / x * y}}.
    by rewrite -morphpre_invm => x y xin yin; rewrite !morphM.
  by exists (Morphism psi_morph) => i /=; rewrite invmE ?presmP.
Qed.

End InjMorphism.

End Presentation.
#[export] Hint Resolve present_mem : core.

Section PresentationMap.

Variables (gT : finGroupType) (G : {group gT}).
Variables (I J : finType) (f : I -> J) (f_inv : J -> I).
Hypothesis (f_invK : cancel f_inv f).
Variables (gens : J -> gT) (rels : seq (seq I * seq I)).

Lemma present_map :
  (gens \o f, rels) \present G ->
  (gens, [seq (map f r.1, map f r.2) | r <- rels]) \present G.
Proof.
move=> prG; apply And3 => /=.
- rewrite (present_gen prG); congr <<_>>.
  apply/setP => x; apply/imsetP/imsetP => [] [/= y _ ->{x}].
  + by exists (f y).
  + by exists (f_inv y) => //; rewrite f_invK.
- by rewrite -satisfy_map // (present_sat prG).
- move=> ht gensH; rewrite -satisfy_map => satH.
  exists (presm prG satH) => j.
  by rewrite -(f_invK j) presmP.
Qed.

End PresentationMap.

Section PresentationBij.

Variables (gT : finGroupType) (G : {group gT}).
Variables (I J : finType) (f : I -> J) (f_inv : J -> I).
Hypothesis (fK : cancel f f_inv) (f_invK : cancel f_inv f).
Variables (gens : I -> gT) (rels : seq (seq I * seq I)).

Lemma present_bij :
  (gens \o f_inv, [seq (map f r.1, map f r.2) | r <- rels]) \present G <->
  (gens, rels) \present G.
Proof.
split.
- move/(present_map fK).
  rewrite -map_comp (eq_map (f2 := id)) ?map_id // => [[r1 r2]] /=.
  rewrite -!map_comp -[in RHS](map_id r1) -[in RHS](map_id r2).
  by congr (_, _); apply eq_map => i /=; rewrite fK.
- have /present_eq : gens =1 (gens \o f_inv) \o f by move=> i; rewrite /= fK.
  by move=> /[apply]/present_map; apply.
Qed.

End PresentationBij.

Section Permute.

Variables (gT : finGroupType) (G : {group gT})
          (I : finType) (gens : I -> gT) (rels : seq (seq I * seq I)).

Lemma present_perm (p : {perm I}) :
  (gens \o p, [seq (map p^-1 r.1, map p^-1 r.2) | r <- rels]) \present G <->
  (gens, rels) \present G.
Proof. by apply: present_bij; [apply: permKV | apply permK]. Qed.

End Permute.

Section Isomorphism.

Variable gT hT : finGroupType.
Variables (G : {group gT}) (H : {group hT}).
Variables (I : finType) (gens  : I -> gT) (rels  : seq (seq I * seq I)).
Hypothesis (prG : (gens, rels) \present G).

Lemma presm_id (sat : satisfy rels gens) : {in G, presm prG sat =1 id}.
Proof.
have : forall i, idm G (gens i) = (gens i) by [].
by move/(presmE prG sat) => Heq x /Heq.
Qed.

Lemma present_isog (gh : I -> hT) : (gh, rels) \present H -> G \isog H.
Proof.
move=> prH; apply/isogP.
have satG := present_sat prG; have satH := present_sat prH.
have:= morphim_presm prG satH; rewrite -(present_gen prH) => impH.
have phi_morph : morphic G (presm prH satG \o presm prG satH).
  apply/morphicP => x y xinG yinG.
  by rewrite /= !morphM // -impH mem_morphim.
have : forall i, morphm phi_morph (gens i) = gens i.
  by move=> i; rewrite morphmE /= !presmP.
move=> /(presmE prG satG) presmP.
have {presmP} presmK : {in G, cancel (presm prG satH) (presm prH satG)}.
  by move => x Hx; move: presmP => /(_ x Hx) /=; rewrite presm_id.
exists (presm prG satH) => //.
exact/injmP/(can_in_inj presmK).
Qed.

Lemma isog_present :
  G \isog H -> {gensh: I -> hT | (gensh, rels) \present H}.
Proof.
move=> /isog_isom [f /isomP [injf imf]].
have [/=]:= morph_present prG injf; rewrite imf => genH sat morph.
by exists (f \o gens).
Qed.

End Isomorphism.

Section PresentTriv.

Variable (gT : finGroupType).

Lemma present_trivG : (fun _ : 'I_0 => 1, [::]) \present [1 gT].
Proof.
apply And3 => //=.
- rewrite -gen0; congr << _ >>; apply/setP => x; rewrite inE.
  by apply/esym/negP => /imsetP[[]].
- by move=> hT gensH _; exists [morphism of trivm 1%G] => [[]].
Qed.

End PresentTriv.

Section PresentBool.

Lemma boolV (x : bool) : x^-1 = x.
Proof. by case: x. Qed.

Lemma present_bool :
  (fun _ : 'I_1 => true, [:: ([:: ord0; ord0], [::])]) \present [set: bool].
Proof.
have trin : true \in [set true | _ : 'I_1] by apply/imsetP; exists ord0.
apply And3 => /=.
- apply/esym/eqP; rewrite -subTset.
  apply/subsetP => [[|]] _; apply/generatedP=> G /subsetP/(_ true trin) //.
  by move=> trinG; exact: (groupM trinG trinG).
- by rewrite andbT !biggseq.
- move=> gT genH; rewrite andbT !biggseq => /eqP Heq.
  pose phi b := if b then genH ord0 else 1.
  have phi_morph : {in [set: bool] & , {morph phi : x y / x * y}}.
    by case=> /= [] [] _ _ /=; rewrite ?Heq ?mulg1 ?mul1g.
  by exists (Morphism phi_morph) => i /=; rewrite fintype.ord1.
Qed.

End PresentBool.

Section PresentZp.

Variable (n0 : nat).
Local Notation n := n0.+2.

Implicit Type (x y z : 'I_n) (i j k : nat).

Lemma expZp x k : x ^+ k = (x *+ k)%R.
Proof.
elim: k => [|k IHk]; first by rewrite expg0 mulr0n.
by rewrite expgS mulrS IHk.
Qed.
Lemma Zp_expn x : x ^+ n = 1 :> 'I_n.
Proof. by rewrite expZp Zp_mulrn; apply val_inj; rewrite /= modnMl. Qed.
Lemma Zp1_expn k : Zp1 ^+ k = (k%:R)%R :> 'I_n.
Proof. by rewrite expZp. Qed.
Lemma Zp1_ord k (ltkn : k < n) : Ordinal ltkn = Zp1 ^+ k.
Proof.
by rewrite expZp Zp_mulrn mul1n; apply val_inj; rewrite /= modn_small.
Qed.

Lemma present_Zp :
  (fun _ : 'I_1 => Zp1, [:: (nseq n ord0, [::])]) \present [set: 'I_n].
Proof.
move: (nseq n ord0) (size_nseq n (ord0 : 'I_1)) => s sizes.
apply And3.
- apply/esym/eqP; rewrite -subTset /=.
  apply/subsetP => [[i ltin]] _; apply/generatedP=> G /subsetP/(_ Zp1) H.
  have {}H : Zp1 \in G by apply/H/imsetP; exists ord0.
  by rewrite (Zp1_ord ltin) groupX.
- by rewrite /= andbT big_nil big_const_seq count_predT sizes iter_mulg Zp_expn.
- move=> gT genH; rewrite /= andbT big_nil => /eqP H.
  have {}H : genH ord0 ^+ n = 1.
    rewrite -[RHS]H -iter_mulg -sizes -count_predT -[LHS]big_const_seq /=.
    by apply eq_bigr => i _; rewrite fintype.ord1.
  pose phi (i : 'I_n) := genH ord0 ^+ i.
  have phi_morph : {in [set: 'I_n] & , {morph phi : x y / x * y}}.
    case=> /= [i ltin] [j ltjn] _ _.
    rewrite /phi -expgD /= [in RHS](divn_eq (i + j) n) expgD.
    by rewrite mulnC expgM H expg1n mul1g.
  by exists (Morphism phi_morph) => i /=; rewrite ord1.
Qed.

End PresentZp.

Section PresentDProd.

Variables (gT : finGroupType) (A B G : {group gT}).
Hypothesis (eqG : A \x B = G).
Variables (IA : finType) (gensA : IA -> gT) (relsA : seq (seq IA * seq IA)).
Variables (IB : finType) (gensB : IB -> gT) (relsB : seq (seq IB * seq IB)).

Definition dprod_gens (k : IA + IB) :=
  match k with | inl i => gensA i | inr i => gensB i end.

Definition dprod_rels :=
  [seq (map inl r.1, map inl r.2) | r <- relsA] ++
  [seq (map inr r.1, map inr r.2) | r <- relsB] ++
  [seq ([:: inl i; inr j], [:: inr j; inl i]) | i <- enum IA, j <- enum IB].

Theorem present_dprod :
  (gensA, relsA) \present A -> (gensB, relsB) \present B ->
  (dprod_gens, dprod_rels) \present G.
Proof.
move: eqG => /dprodP [_ eqGAB ABC _] prA prB.
apply And3 => /=.
- apply/eqP; rewrite eqEsubset; apply/andP; split.
  + rewrite -eqGAB mulG_subG (present_gen prA) (present_gen prB); apply/andP.
    by split; apply/genS/subsetP=> x /imsetP[i _ ->{x}];
      apply/imsetP; [exists (inl i)| exists (inr i)].
  + rewrite gen_subG; apply/subsetP => i /imsetP[x _ ->{i} /=].
    rewrite /dprod_gens; case: x => [a|b]; rewrite -eqGAB.
    * by rewrite -(mulg1 (gensA a)) mem_mulg // (present_mem prA).
    * by rewrite -(mul1g (gensB b)) mem_mulg // (present_mem prB).
- rewrite !satisfy_cat.
  apply/and3P; split; apply/satisfyP => /= [][lft rgt] /=.
  + move/mapP => /= [[r1 r2] rin /= [->{lft} ->{rgt}]]; rewrite !big_map.
    exact: (satisfyP _ _ (present_sat prA) _ rin).
  + move/mapP => /= [[r1 r2] rin /= [->{lft} ->{rgt}]]; rewrite !big_map.
    exact: (satisfyP _ _ (present_sat prB) _ rin).
  + move/allpairsP => [[iA iB] [_ _] [->{lft} ->{rgt}]].
    rewrite !big_cons big_nil !mulg1 /=.
    move/subsetP/(_ _ (present_mem prB iB))/centP : ABC => -> //.
    exact: (present_mem prA iA).
- move=> Ht gensH /satisfyP /= Hsat.
  have satA : satisfy relsA (fun i => gensH (inl i)).
    apply/satisfyP=> /= rel Hin.
    rewrite -!(big_map inl xpredT gensH); apply: (Hsat (_, _)).
    by rewrite !mem_cat map_f.
  move: (presm _ _) (presmP prA satA) => {satA} fA eq_fA.
  have satB : satisfy relsB (fun i => gensH (inr i)).
    apply/satisfyP=> /= rel Hin.
    rewrite -!(big_map inr xpredT gensH); apply: (Hsat (_, _)).
    by rewrite !mem_cat map_f //= orbT.
  move: (presm _ _) (presmP prB satB) => {satB} fB eq_fB.
  suff cAB : fB @* B \subset 'C(fA @* A).
    exists [morphism of dprodm eqG cAB] => [[a|b]] /=.
    + by rewrite dprodmEl // (present_mem prA).
    + by rewrite dprodmEr // (present_mem prB).
  rewrite [X in fA @* X](present_gen prA) [X in fB @* X](present_gen prB).
  rewrite !morphim_gen; first last.
    + by apply/subsetP => x /imsetP[b _ ->{x}]; apply (present_mem prB).
    + by apply/subsetP => x /imsetP[a _ ->{x}]; apply (present_mem prA).
  rewrite gen_subG /= cent_gen; apply/subsetP => /= x /imsetP[y].
  rewrite inE => /andP[_ /imsetP[b _ ->{y} ->{x}]].
  apply/centP => x /imsetP[y].
  rewrite inE => /andP[_ /imsetP[a _ ->{y} ->{x}]].
  rewrite /commute.
  have /Hsat/= : ([:: inl a; inr b], [:: inr b; inl a]) \in dprod_rels.
    by rewrite !mem_cat allpairs_f ?orbT // mem_enum.
  by rewrite !big_cons big_nil !mulg1 eq_fA eq_fB => ->.
Qed.

End PresentDProd.


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

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Require Import Omega.
Local Open Scope R_scope.

(**********)
Lemma formule :
  forall (x h l1 l2:R) (f1 f2:R -> R),
    h <> 0 ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
    (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
    / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
    l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
    f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
    l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
Proof.
  intros; unfold Rdiv, Rminus, Rsqr.
  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
    repeat rewrite Rinv_mult_distr; try assumption.
  replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
  [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
  (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
  (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
  (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x)));
  [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try assumption || ring.
  apply prod_neq_R0; assumption.
Qed.

(* begin hide *)
Notation Rmin_pos := Rmin_pos (only parsing). (* compat *)
(* end hide *)

Lemma maj_term1 :
  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f1d ->
      Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f1d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4.
Proof.
  intros.
  assert (H7 := H3 h H6).
  assert (H8 := H2 h H4 H5).
  apply Rle_lt_trans with
    (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
  rewrite Rabs_mult.
  apply Rmult_le_compat_r.
  apply Rabs_pos.
  rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
  apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
  apply Rmult_lt_compat_l.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
  exact H8.
  right; unfold Rdiv.
  repeat rewrite Rabs_mult.
  rewrite Rabs_Rinv; discrR.
  rewrite (Rabs_pos_eq 8) by now apply IZR_le.
  rewrite (Rabs_pos_eq eps).
  field.
  now apply Rabs_no_R0.
  now apply Rlt_le.
Qed.

Lemma maj_term2 :
  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal)
    (f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2t2 ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4.
Proof.
  intros.
  assert (H8 := H3 h H6).
  assert (H9 := H2 h H5).
  apply Rle_lt_trans with
    (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  rewrite Rabs_mult; apply Rmult_le_compat_l.
  apply Rabs_pos.
  rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
    try assumption || discrR.
  red; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
  unfold Rdiv.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; try assumption.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H8; exact H8.
  symmetry ; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with
  (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
  ring.
  symmetry ; apply Rabs_right; left; prove_sup0.
  symmetry ; apply Rabs_right; left; prove_sup.
  symmetry ; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term3 :
  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f2d ->
      Rabs ((f2 (x + h) - f2 x) / h - l2) <
      Rabs (Rsqr (f2 x) * eps / (8 * f1 x))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
    eps / 4.
Proof.
  intros.
  assert (H8 := H2 h H4 H5).
  assert (H9 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H8.
  apply Rlt_le_trans with
    (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
    try assumption.
  red; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
  unfold Rdiv.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; assumption || idtac.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H9; exact H9.
  symmetry ; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with
  (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry ; apply Rabs_right; left; prove_sup0.
  symmetry ; apply Rabs_right; left; prove_sup.
  symmetry ; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term4 :
  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2c ->
      Rabs (f2 (x + a) - f2 x) <
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2c ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    l2 <> 0 ->
    Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
    eps / 4.
Proof.
  intros.
  assert (H9 := H2 h H5).
  assert (H10 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
    assumption || idtac.
  red; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0.
  apply prod_neq_R0.
  discrR.
  assumption.
  assumption.
  unfold Rdiv.
  repeat rewrite Rinv_mult_distr;
    try assumption || (unfold Rsqr; apply prod_neq_R0; assumption).
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  replace
  (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2))));
  [ idtac | ring ].
  replace
  (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr;
    apply prod_neq_R0; assumption.
  repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H10; exact H10.
  symmetry ; apply Rabs_right; left; prove_sup0.
  right; unfold Rsqr, Rdiv.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * Rabs l2 *
    (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
      (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with
  (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry ; apply Rabs_right; left; prove_sup0.
  symmetry ; apply Rabs_right; left; prove_sup.
  symmetry ; apply Rabs_right; left; assumption.
  apply prod_neq_R0; assumption || discrR.
  apply prod_neq_R0; assumption.
Qed.

Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a).
Proof.
  intros.
  unfold D_x, no_cond.
  split.
  trivial.
  apply Rminus_not_eq.
  unfold Rminus.
  rewrite Ropp_plus_distr.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  apply Ropp_neq_0_compat; assumption.
Qed.

Lemma Rabs_4 :
  forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
Proof.
  intros.
  apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
  replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ].
  apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
  apply Rplus_le_compat_r.
  apply Rabs_triang.
  repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
  apply Rabs_triang.
Qed.

Lemma Rlt_4 :
  forall a b c d e f g h:R,
    a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
Proof.
  intros; apply Rlt_trans with (b + c + e + g).
  repeat apply Rplus_lt_compat_r; assumption.
  repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
  apply Rlt_trans with (d + e + g).
  rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
  rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
  apply Rplus_lt_compat_r; assumption.
  apply Rplus_lt_compat_l; assumption.
Qed.

(* begin hide *)
Notation Rmin_2 := Rmin_glb_lt (only parsing).
(* end hide *)

Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
Proof.
  intro; ring.
Qed.

Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4.
Proof.
  intro; rewrite <- quadruple.
  unfold Rdiv; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
  reflexivity.
Qed.

(**********)
Lemma continuous_neq_0 :
  forall (f:R -> R) (x0:R),
    continuity_pt f x0 ->
    f x0 <> 0 ->
    exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> 0).
Proof.
  intros; unfold continuity_pt in H; unfold continue_in in H;
    unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))).
  intros; elim H1; intros.
  exists (mkposreal x H2).
  intros; assert (H5 := H3 (x0 + h)).
  cut
    (dist R_met (x0 + h) x0 < x ->
      dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
  unfold dist; simpl; unfold R_dist;
    replace (x0 + h - x0) with h.
  intros; assert (H7 := H6 H4).
  red; intro.
  rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
    rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
      pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
  cut (0 < Rabs (f x0)).
  intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
  cut (Rabs (/ 2) = / 2).
  assert (Hyp : 0 < 2).
  prove_sup0.
  intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12;
      [ idtac | discrR ].
  now apply lt_IZR in H12.
  unfold Rabs; case (Rcase_abs (/ 2)) as [Hlt|Hge].
  assert (Hyp : 0 < 2).
  prove_sup0.
  assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp Hlt); rewrite Rmult_0_r in H11;
    rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
  elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
  reflexivity.
  apply (Rabs_pos_lt _ H0).
  ring.
  assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
  intro; rewrite <- H7. unfold R_met, dist; unfold R_dist;
    unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
      apply Rabs_pos_lt.
  unfold Rdiv; apply prod_neq_R0;
    [ assumption | apply Rinv_neq_0_compat; discrR ].
  intro; apply H5.
  split.
  unfold D_x, no_cond.
  split; trivial || assumption.
  assumption.
  change (0 < Rabs (f x0 / 2)).
  apply Rabs_pos_lt; unfold Rdiv; apply prod_neq_R0.
  assumption.
  apply Rinv_neq_0_compat; discrR.
Qed.


CoInductive Comp (a:Type) : Type :=
| Ret : a -> Comp a
| Bnd : forall (a':Type), Comp a' -> (a' -> Comp a) -> Comp a
.

Arguments Ret {a}.
Arguments Bnd {a} {a'}.

Lemma comp_dest_ret : forall (a:Type) (x y:a),
    Ret x = Ret y -> x = y.
Proof.
    intros a x y H. inversion H. reflexivity.
Qed.

(* Usual trick for coinductive type                                             *)
Definition frob (a:Type) (c:Comp a) : Comp a :=
    match c with
    | Ret x     => Ret x
    | Bnd c f   => Bnd c f
    end.

Arguments frob {a}.

Lemma frob_same : forall (a:Type) (c:Comp a), c = frob c.
Proof. intros a [x|a' c f]; reflexivity. Qed.

(* Need to pick some good notion of equality with coinductive proofs            *)
CoInductive comp_eq (a:Type) : Comp a -> Comp a -> Prop :=
| Ret_eq : forall (x:a), comp_eq a (Ret x) (Ret x)
| Bnd_eq : forall (a':Type) (c1 c2:Comp a') (f1 f2:a' -> Comp a),
    comp_eq a' c1 c2                        ->
    (forall (z:a'), comp_eq a (f1 z) (f2 z))  ->
    comp_eq a (Bnd c1 f1) (Bnd c2 f2)
.

Arguments comp_eq {a}.

Lemma comp_eq_ret : forall (a:Type) (x y:a), comp_eq (Ret x) (Ret y) -> x = y.
Proof.
    intros a x y H. inversion H. reflexivity.
Qed.

Lemma comp_eq_refl : forall (a:Type) (c:Comp a), comp_eq c c.
Proof.
    cofix coIH. intros a [x|a' c f].
    - constructor.
    - constructor.
        + apply coIH.
        + intros z. apply coIH.
Qed.

Lemma comp_eq_sym : forall (a:Type) (c1 c2:Comp a),
    comp_eq c1 c2 -> comp_eq c2 c1.
Proof.
    cofix coIH. intros a c1 c2 H.
    destruct H as [|a' c1 c2 f1 f2 H1 H2].
    - constructor.
    - constructor.
        + apply coIH. assumption.
        + intros z. apply coIH. apply H2.
Qed.

(*
Lemma comp_eq_trans : forall (a:Type) (c1 c2 c3:Comp a),
    comp_eq c1 c2 -> comp_eq c2 c3 -> comp_eq c1 c3.
Proof.
    cofix coIH. intros a c1 c2 c3 H. revert c3.
    destruct H as [|a' c1 c2 f1 f2 H1 H2].
    - intros c3 H. assumption.
    - intros c3 H3.
      remember (Bnd c2 f2) as c2' eqn:E. revert E.
      destruct H3 as [|a'' c2' c3 f2' f3 H4 H5].
        + intros H3. inversion H3.
        +
        + intros H3. inversion H3. subst. constructor. inversion H3.

Show.
*)

(*
Inductive Exec (a:Type) : Comp a -> a -> Prop :=
| ExecRet : forall (x:a), Exec a (Ret x) x
| ExecBnd : forall (a':Type) (c:Comp a')(f:a' -> Comp a) (x:a') (y:a),
    Exec a' c x -> Exec a (f x) y -> Exec a (Bnd c f) y
.

Arguments Exec {a}.

Definition comp_eq (a:Type) (c1 c2:Comp a) : Prop :=
    forall (x:a), Exec c1 x <-> Exec c2 x.

Arguments comp_eq {a}.

Lemma comp_eq_refl : forall (a:Type) (c:Comp a) , comp_eq c c.
Proof. unfold comp_eq. intros a c x. split; intros H; assumption. Qed.

Lemma comp_eq_sym : forall (a:Type) (c1 c2:Comp a),
    comp_eq c1 c2 -> comp_eq c2 c1.
Proof.
    unfold comp_eq. intros a c1 c2 H x. split; intros H'; apply H; assumption.
Qed.

Lemma comp_eq_trans : forall (a:Type) (c1 c2 c3:Comp a),
    comp_eq c1 c2 -> comp_eq c2 c3 -> comp_eq c1 c3.
Proof.
    unfold comp_eq. intros a c1 c2 c3 H1 H2 x. split; intros H.
    - apply H2, H1. assumption.
    - apply H1, H2. assumption.
Qed.

Definition pure (a:Type) (x:a) : Comp a := Ret x.

Arguments pure {a}.

Definition bind (a b:Type) (k:Comp a) (f:a -> Comp b) : Comp b := Bnd k f.

Arguments bind {a} {b}.

Notation "k >>= f" := (bind k f) (at level 50, left associativity).

Notation "c1 == c2" := (comp_eq c1 c2) (at level 90).
*)

(*
Lemma left_identity : forall (a b:Type) (x:a) (f:a -> Comp b),
    (pure x) >>= f == f x.
Proof.
    intros a b x f y. split.
    - intros H. remember (pure x >>= f) as k eqn:E. revert E.
      destruct H as [x'|a' c g x' y' H1 H2]; intros H.
        + inversion H.
        + unfold bind in H. revert H1 H2. remember (pure x) as k eqn:E. revert E.

Show.
*)


(** * The product list
      This file contains defintions and lemmas about [product_list], which computes
      a substitution from a list of id and a list of types of the same length.
      This function is used in the lemmas
      [inst_subst_to_subst_aux] and [more_general_ctx_disjoint_prefix_apply_inst]
      in the Moregeneral file. *)

Set Implicit Arguments.

Require Import List.
Require Import Sublist.
Require Import ListIds.
Require Import Context.
Require Import Typing.
Require Import Gen.
Require Import SimpleTypes.
Require Import Schemes.
Require Import Subst.
Require Import SubstSchm.
Require Import MyLtacs.
Require Import NthErrorTools.
Require Import LibTactics.

(** This creates a substitution from a list of id and a list of types of the same length. *)
Fixpoint product_list (l1 : list id) (l2 : list ty) : option substitution :=
  match l1 with
  | nil =>  Some nil
  | st :: l'1 => match l2 with
                | nil => None
                | t :: l'2 => match product_list l'1 l'2 with
                             | None => None
                             | Some s => Some ((st, t) :: s)
                             end
                end
  end.

Lemma domain_product : forall (l : list id) (is_s : inst_subst) (phi : substitution),
    product_list l is_s = Some phi -> dom phi = l.
Proof.
  induction l. crush.
  destruct is_s. crush.
  intros.
  simpl in *.
  cases (product_list l is_s).
  inverts* H.
  simpl.
  erewrite IHl; eauto.
  inverts* H.
Qed.

Lemma image_by_product2 : forall (l : list id) (is_s : inst_subst) (st : id)
                            (n0 : id) (phi : substitution) (tau : ty),
    index_list_id st l = Some n0 ->
    product_list l is_s = Some phi ->
    nth_error is_s n0 = Some tau -> apply_subst phi (var st) = tau.
Proof.
  induction l; unfold index_list_id. crush.
  intros.
  simpl in *.
  destruct (eq_id_dec a st).
  inverts* H.
  destruct is_s.
  inversion H0.
  subst.
  simpl in H1. inverts* H1.
  cases (product_list l is_s).
  inverts* H0.
  crush.
  inversion H0.
  destruct is_s.
  inversion H0.
  cases (product_list l is_s).
  inverts* H0.
  crush.
  eapply IHl.
  apply index_aux1 in H.
  unfold index_list_id. apply H.
  apply Eq.
  destruct n0. simpl in *.
  inverts* H1. destruct is_s.
  assert (False). { eapply index_aux_false with (n := 1) (m := 0); eauto. } contradiction.
  assert (False). { eapply index_aux_false with (n := 1) (m := 0); eauto. } contradiction.
  simpl. eauto.
  inversion H0.
Qed.

Hint Resolve image_by_product2:core.

Lemma product_for_le_length : forall (l1 : list id) (l2 : list ty),
    length l1 <= length l2 -> exists s, product_list l1 l2 = Some s.
Proof.
  induction l1; crush.
  destruct l2; crush.
  edestruct IHl1; eauto.
  apply le_S_n in H.
  apply H.
  rewrite H0.
  exists ((a, t)::x).
  reflexivity.
Qed.

Hint Resolve product_for_le_length:core.

(** *)
Lemma product_list_exists : forall (tau : ty) (G : ctx) (is_s : inst_subst),
    max_gen_vars (gen_ty tau G) <= length is_s ->
    exists s, product_list (snd (gen_ty_aux tau G nil)) is_s = Some s.
Proof.
  intros.
  apply product_for_le_length.
  rewrite length_snd_gen_aux.
  crush.
Qed.


Require Export ProductCategory Functor NaturalTransformation.
Require Import Common Notations.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Ltac t :=
  intros; simpl; repeat (rewrite <- FCompositionOf || rewrite <- FIdentityOf);
  apply f_equal; expand; autorewrite with morphism;
  reflexivity.

Section ProductInducedFunctors.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(E : @SpecializedCategory objE).

  Variable F : SpecializedFunctor (C * D) E.

  Definition InducedProductFstFunctor (d : D) : SpecializedFunctor C E.
    refine {| ObjectOf := (fun c => F (c, d));
      MorphismOf := (fun _ _ m => MorphismOf F (s := (_, d)) (d := (_, d)) (m, Identity d))
    |};
    abstract t.
  Defined.

  Definition InducedProductSndFunctor (c : C) : SpecializedFunctor D E.
    refine {| ObjectOf := (fun d => F (c, d));
      MorphismOf := (fun _ _ m => MorphismOf F (s := (c, _)) (d := (c, _)) (Identity c, m))
    |};
    abstract t.
  Defined.
End ProductInducedFunctors.

Notation "F ⟨ c , - ⟩" := (InducedProductSndFunctor F c) : functor_scope.
Notation "F ⟨ - , d ⟩" := (InducedProductFstFunctor F d) : functor_scope.

Section ProductInducedNaturalTransformations.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(E : @SpecializedCategory objE).

  Variable F : SpecializedFunctor (C * D) E.

  Definition InducedProductFstNaturalTransformation {s d} (m : Morphism C s d) : SpecializedNaturalTransformation (F ⟨ s, - ⟩) (F ⟨ d, - ⟩).
    match goal with
      | [ |- SpecializedNaturalTransformation ?F0 ?G0 ] =>
        refine (Build_SpecializedNaturalTransformation F0 G0
          (fun d => MorphismOf F (s := (_, d)) (d := (_, d)) (m, Identity (C := D) d))
          _
        )
    end;
    abstract t.
  Defined.

  Definition InducedProductSndNaturalTransformation {s d} (m : Morphism D s d) : SpecializedNaturalTransformation (F ⟨ -, s ⟩) (F ⟨ - , d ⟩).
    match goal with
      | [ |- SpecializedNaturalTransformation ?F0 ?G0 ] =>
        refine (Build_SpecializedNaturalTransformation F0 G0
          (fun c => MorphismOf F (s := (c, _)) (d := (c, _)) (Identity (C := C) c, m))
          _
        )
    end;
    abstract t.
  Defined.
End ProductInducedNaturalTransformations.

Notation "F ⟨ f , - ⟩" := (InducedProductSndNaturalTransformation F f) : natural_transformation_scope.
Notation "F ⟨ - , f ⟩" := (InducedProductFstNaturalTransformation F f) : natural_transformation_scope.