From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint.
Open Scope R.
Import GRing.Theory.
Import Num.Theory.

Definition Qnneg := [qualify a x : rat | 0 <= x].
Lemma Qnneg_def x : (x \is a Qnneg) = (0 <= x).
  done.
Qed.

Fact Qnneg_key : pred_key Qnneg. done. Qed.
Canonical Qnneg_keyed := KeyedQualifier Qnneg_key.

Section PosRatDef.
  Record posrat :=
    Posrat {
        mprat :> rat;
        _ : mprat \is a Qnneg}.

  Canonical Structure posratSub := [subType for mprat].
    Definition pEqmix := [eqMixin of posrat by <:].
    Canonical Structure pEqtype := EqType posrat pEqmix.
    Definition pChoicemix := [choiceMixin of posrat by <: ].
    Canonical pChoisetype := ChoiceType posrat pChoicemix.
    Canonical pCountmix := [countMixin of posrat by <: ].
    Canonical PCount := CountType posrat pCountmix.
End PosRatDef.

Definition padd_ (a b : posrat) : posrat.
  destruct a,b.
  econstructor.
  instantiate (1 := mprat0 + mprat1).
  apply Num.Theory.addr_ge0; done.
Defined.

Definition padd a b := locked (padd_ a b).

Definition pmul_ (a b : posrat) : posrat.
  destruct a,b.
  econstructor.
  instantiate (1 := mprat0 * mprat1).
  apply Num.Theory.mulr_ge0; done.
Defined.

Definition pmul a b := locked (pmul_ a b).

Lemma pmulrA : @associative posrat pmul.
  unlock pmul.
move=> x y z; apply/eqP; rewrite /pmul /eq_op //=; destruct x,y,z; rewrite //=; rewrite mulrA.
done.
Qed.

Lemma paddrA : @associative posrat padd.
  unlock padd.
move=> x y z; apply/eqP; rewrite /padd /eq_op //=; destruct x,y,z; rewrite //=; rewrite addrA.
done.
Qed.

Lemma pmul1r : @left_id posrat posrat (Posrat 1 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mul1r; done.
Qed.

Lemma pmulr1 : @right_id posrat posrat (Posrat 1 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mulr1; done.
Qed.

Lemma pmul0r : @left_zero posrat posrat (Posrat 0 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mul0r; done.
Qed.

Lemma pmulr0 : @right_zero posrat posrat (Posrat 0 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mulr0; done.
Qed.

Lemma padd0r : @left_id posrat posrat (Posrat 0 is_true_true) padd.
  unlock padd pmul;
move=>x; destruct x; apply/eqP; rewrite /padd /eq_op //=; rewrite add0r; done.
Qed.

Lemma paddr0 : @right_id posrat posrat (Posrat 0 is_true_true) padd.
  unlock padd pmul;
move=>x; destruct x; apply/eqP; rewrite /padd /eq_op //=; rewrite addr0; done.
Qed.

Lemma pmulrDl : @left_distributive posrat posrat pmul padd.
  unlock padd pmul;
move=> x y z; destruct x,y,z; apply/eqP; rewrite /pmul /padd /eq_op //=; rewrite mulrDl; done.
Qed.

Lemma pmulrDr : @right_distributive posrat posrat pmul padd.
  unlock padd pmul;
move=> x y z; destruct x,y,z; apply/eqP; rewrite /pmul /padd /eq_op //=; rewrite mulrDr; done.
Qed.

Lemma pmulrC : @commutative posrat posrat pmul.
  unlock padd pmul;
move=> x y; destruct x,y; apply/eqP; rewrite /pmul /eq_op //=; rewrite mulrC; done.
Qed.

Lemma paddrC : @commutative posrat posrat padd.
  unlock padd pmul;
move=> x y; destruct x,y; apply/eqP; rewrite /padd /eq_op //=; rewrite addrC; done.
Qed.

Canonical padd_monoid := Monoid.Law paddrA padd0r paddr0.
Canonical padd_comid := Monoid.ComLaw paddrC.
Canonical pmul_monoid := Monoid.Law pmulrA pmul1r pmulr1.
Canonical pmul_muloid := Monoid.MulLaw pmul0r pmulr0.
Canonical pmul_addoid := Monoid.AddLaw pmulrDl pmulrDr.
Canonical pmul_comid := Monoid.ComLaw pmulrC.

Notation "x + y" := (padd x y) : posrat_scope.
Notation "x * y" := (pmul x y) : posrat_scope.
Notation "0" := (Posrat 0 is_true_true) : posrat_scope.
Notation "1" := (Posrat 1 is_true_true) : posrat_scope.

Delimit Scope posrat_scope with PR.

Open Scope PR.
Import Monoid.Theory.

Lemma pmul0 (x y : posrat) : (x == 0) || (y == 0) = (x * y == 0).
  destruct x,y.
  apply /eqP; rewrite /eq_op //=.
  destruct (eqVneq mprat0 0).
  subst.
  apply/eqP.
  unlock pmul.
  simpl.
  rewrite mul0r; done.

  destruct (eqVneq mprat1 0).
  subst.
  unlock pmul.
  simpl; rewrite eq_refl orbT mulr0 eq_refl; done.
  Check GRing.mulf_eq0.
  have H := (GRing.mulf_eq0 mprat0 mprat1).
  rewrite (negbTE i1) in H.
  rewrite (negbTE i2) in H.
  simpl in H.
  unlock pmul.
  rewrite H.
  rewrite (negbTE i1).
  rewrite (negbTE i2).
  simpl.
  done.
Qed.

Lemma padd0 (x y : posrat) : (x == 0) && (y == 0) = (x + y == 0).
  destruct x,y.
  apply /eqP; rewrite /eq_op //=.
  destruct (eqVneq mprat0 0).
  subst.
  destruct (eqVneq mprat1 0).

  subst.
  simpl.
  unlock padd; simpl.
  rewrite add0r.
  done.
  unlock padd; simpl. rewrite (negbTE i1) add0r.
  done.

  destruct (eqVneq mprat1 0).
  subst.
  rewrite (negbTE i1).
  simpl.
  unlock padd; simpl; rewrite addr0.
  done.

  rewrite (negbTE i1) (negbTE i2).
  simpl.
  unlock padd; simpl; rewrite Qnneg_def in i.
  rewrite Qnneg_def in i0.
  have: (0 < mprat0 + mprat1)%R .

  apply addr_gt0.
  rewrite ltr_def i i1; done.
  rewrite ltr_def i0 i2; done.
  intros.
  rewrite ltr_def in x.
  move/andP: x => [x0 x1].
  rewrite (negbTE x0).
  done.
Qed.

Definition pinv_ (a : posrat) : posrat.
  destruct a.
  econstructor.
  instantiate (1 := mprat0^-1).
  rewrite Qnneg_def.
  rewrite invr_ge0.
  rewrite -Qnneg_def; done.
Defined.

Definition pinv a := locked (pinv_ a).

Definition pexp_ (a : posrat) (n : nat) : posrat.
  destruct a.
  econstructor.
  instantiate (1 := mprat0 ^+ n).
  rewrite Qnneg_def.
  apply exprn_ge0.
  done.
Defined.

Definition pexp a n := locked (pexp_ a n).

Notation "x / y" := (x * (pinv y)) : posrat_scope.

Notation "x ^+ n" := (pexp x n) : posrat_scope.

Lemma pexp_S (a : posrat) (n : nat) :
  a ^+ (S n) =
  a * (a ^+ n).
  unlock pexp.
  destruct a; simpl.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  unlock pmul.
  unlock pexp.
  rewrite exprS.
  simpl.
  done.
Qed.

Lemma pexp1 (x  :posrat) : x ^+ 1 = x.
destruct x.
unlock pexp.
apply/eqP; rewrite /eq_op //=.
Qed.

Definition posrat_of_nat_ (x : nat) : posrat.
  econstructor.
  instantiate (1 := x%:Q).
  rewrite Qnneg_def.
  apply ler0n.
Defined.

Definition posrat_of_nat x := locked (posrat_of_nat_ x).

Definition ple (a b : posrat) : bool.
  destruct a,b.
  exact (mprat0 <= mprat1).
Defined.

Definition plt (a b : posrat) : bool.
  destruct a,b.
  exact (mprat0 < mprat1).
Defined.

Notation "x <= y" := (ple x y) : posrat_scope.
Notation "x < y" := (plt x y) : posrat_scope.

Definition plt_def (a b : posrat) : (a < b) = ((a != b) && (a <= b)).
  destruct a,b.
  rewrite /plt.
  rewrite /ple.
  rewrite /eq_op //=.
  rewrite ltr_def //=.
  rewrite eq_sym.
  done.
Qed.

Lemma plt_trans (a b c : posrat) : a < b -> b < c -> a < c.
  destruct a,b,c; rewrite /plt.
  apply ltr_trans.
Qed.

Lemma plt_add (a b c d : posrat) : a < b -> c < d -> a + c < b + d.
  destruct a,b,c,d; rewrite /plt.
  unlock padd.
  apply ltr_add.
Qed.

Lemma plt_mulr (a  c d : posrat) : a != 0 -> c < d -> a * c < a * d.
  destruct a,c,d; rewrite /plt.
  simpl.
  intros.

  unlock pmul; simpl.
  rewrite (mulrC mprat0).
  rewrite (mulrC mprat0).
  rewrite ltr_pmul2r.
  done.
  rewrite ltr_def.
  rewrite H.
  rewrite -Qnneg_def; done.
Qed.

Lemma ple_le0 a : (a <= 0) = (a == 0).
  have: (a <= 0) <-> (a == 0).
  split.
  destruct a; simpl; intros; apply/eqP.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  apply/eqP; rewrite eqr_le.
  apply/andP; split; done.

  intro H; rewrite (eqP H); done.

  intros.
  apply/iffP.
  apply idP.
  apply x.
  apply x.
  destruct (a == 0); done.
Qed.

Lemma ple_refl a : a <= a.
  destruct a; simpl; done.
Qed.

Lemma ple_antisymm a b : a <= b -> b <= a -> a = b.
  destruct a,b; simpl.
  intros.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  apply/eqP;
  rewrite eqr_le.
  apply/andP; split; done.
Qed.

Lemma ple_trans a b c : a <= b -> b <= c -> a <= c.
  destruct a,b,c; simpl.
  apply ler_trans.
Qed.

Lemma ple_total a b : (a <= b) || (b <= a).
  destruct a,b;simpl.
  apply ger_leVge.
  rewrite Qnneg_def in i; done.
  rewrite Qnneg_def in i0; done.
Qed.

Lemma ple_add_is_le a b c : a + b <= c -> (a <= c) && (b <= c).
  destruct a,b,c.
  unfold ple.
  simpl.
  unlock padd; simpl.
  intro; apply/andP; split.
  apply/contraT.
  rewrite -real_ltrNge.
  unlock padd in H; simpl in H.
  rewrite real_lerNgt in H.
  intro.

  have: (mprat2 < mprat0 + mprat1)%R.
  remember (mprat1 == 0) as b; symmetry in Heqb; destruct b.
  rewrite (eqP Heqb) addr0; done.
  rewrite -(addr0 mprat2).
  apply ltr_add.
  done.
  rewrite ltr_def.
  rewrite Heqb.
  rewrite Qnneg_def in i0.
  rewrite i0.
  done.
  rewrite (negbTE H); done.
  rewrite realE; apply/orP; left.
  apply addr_ge0.
  rewrite Qnneg_def in i; done.
  rewrite Qnneg_def in i0; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i; done.

  apply/contraT.
  rewrite -real_ltrNge.
  rewrite real_lerNgt in H.
  intro.

  have: (mprat2 < mprat0 + mprat1)%R.
  remember (mprat0 == 0) as b; symmetry in Heqb; destruct b.
  rewrite (eqP Heqb) add0r; done.
  rewrite -(addr0 mprat2) -(addrC 0%R mprat2).
  apply ltr_add.
  rewrite ltr_def Heqb.
  rewrite Qnneg_def in i; rewrite i; done.
  done.
  rewrite (negbTE H); done.

  rewrite realE; apply/orP; left.
  apply addr_ge0.
  rewrite Qnneg_def in i; done.
  rewrite Qnneg_def in i0; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i; done.
Qed.

Lemma ple_add_r a b c : a <= b -> a + c <= b + c.
  destruct a,b,c; simpl.
  unlock padd.
  intros.
  apply ler_add.
  done.
  done.
Qed.

Lemma ple_add_l a b c : a <= b -> c + a <= c + b.
 rewrite (paddrC c a).
 rewrite (paddrC c b).
 apply ple_add_r.
Qed.

Lemma ple_add_lr a b c d : a <= b -> c <= d -> a + c <= b + d.
 intros.
 eapply ple_trans.
 instantiate (1 := b + c).
 apply ple_add_r; done.
 apply ple_add_l; done.
Qed.

Lemma ple_mul_r a b c : a <= b -> a * c <= b * c.
  destruct a,b,c; simpl.
  intros.
  unlock pmul; simpl.
  eapply ler_pmul.
  done.
  done.
  done.
  done.
Qed.

Lemma ple_mul_l a b c : a <= b -> c * a <= c * b.
 rewrite (pmulrC c a).
 rewrite (pmulrC c b).
 apply ple_mul_r.
Qed.

Lemma ple_mul_lr a b c d : a <= b -> c <= d -> a * c <= b * d.
  destruct a,b,c,d ;simpl; intros.
  unlock pmul; simpl.
  apply ler_pmul; done.
Qed.

Definition pdist_ (a b : posrat) : posrat.
  destruct a,b.
  econstructor.
  instantiate (1 := `|mprat0 - mprat1|).
  rewrite Qnneg_def.
  apply normr_ge0.
Defined.

Definition pdist a b := locked (pdist_ a b).

Lemma pdist_eq0 a b : (pdist a b == 0) = (a == b).
  unlock pdist.
  apply/(iffP idP).
  instantiate (1 := (a == b)).
  rewrite /pdist.
  destruct a,b.
  intro.
  rewrite /eq_op //=; apply/eqP.
  rewrite /eq_op //= in H.
  rewrite normr_eq0 in H.
  rewrite subr_eq0 in H.
  apply/eqP; done.
  intro H; rewrite (eqP H).
  rewrite /pdist.
  destruct b; simpl.
  rewrite /eq_op //=; apply/eqP.
  apply/eqP; rewrite normr_eq0.
  rewrite subr_eq0.
  done.
  destruct (a == b); done.
Qed.

Lemma pdist_le0 a b : (pdist a b <= 0) = (a == b).
  apply/(iffP idP).
  instantiate (1 := a == b).
  intro.
  rewrite ple_le0 in H.
  rewrite pdist_eq0 in H.
  done.
  intro.
  rewrite ple_le0.
  rewrite pdist_eq0.
  done.
  destruct (a == b); done.
Qed.

Lemma pdist_symm a b : pdist a b = pdist b a.
  unlock pdist.
  rewrite /pdist_; destruct a,b.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  rewrite distrC; done.
Qed.

Lemma pdist_triangle a b c : pdist a c <= pdist a b + pdist b c.
  unlock pdist;
  rewrite /pdist_; destruct a,b, c.
  simpl.
  unlock padd.
  simpl.
  apply ler_dist_add.
Qed.

Lemma pdist_add_r a b c : pdist a b = pdist (a + c) (b + c).
  unlock pdist;
  rewrite/pdist_; destruct a,b,c; simpl.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  unlock padd; simpl.
  rewrite (addrC mprat1 mprat2).
  rewrite GRing.addrKA.
  done.
Qed.

Lemma pdist_add_l a b c : pdist a b = pdist (c + a) (c + b).
  rewrite (paddrC c a).
  rewrite (paddrC c b).
  apply pdist_add_r.
Qed.

Lemma pdist_add_lr a b c d : pdist (a + c) (b + d) <= pdist a b + pdist c d.

  unlock pdist;
  rewrite/pdist_; destruct a,b,c,d; simpl.
  have: (mprat0 + mprat2 - (mprat1 + mprat3))%R =
        ((mprat0 - mprat1) + (mprat2 - mprat3))%R.
  rewrite -mulN1r.
  rewrite mulrDr.
  rewrite !mulN1r.
  rewrite addrA.
  rewrite addrA.
  congr (_ + _)%R.
  rewrite -addrA.
  rewrite (addrC mprat2 (-mprat1)).
  rewrite addrA.
  done.
  intro.
  unlock padd; simpl.
  rewrite x.
  apply ler_norm_add.
Qed.

Lemma pdist_mul_l a b c : pdist (c * a) (c * b) = c * (pdist a b).
  unlock pdist;
  rewrite/pdist_;destruct a,b,c; simpl.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  have: (mprat2 * mprat0 - mprat2 * mprat1)%R =
        (mprat2 * (mprat0 - mprat1))%R.
  rewrite -mulN1r.
  rewrite mulrA.
  rewrite (mulrC (-1) mprat2).
  rewrite -mulrA.
  rewrite -mulrDr.
  rewrite mulN1r.
  done.
  intro.
  unlock pmul; simpl.
  rewrite x.
  rewrite normrM.
  have: `|mprat2| == mprat2.
  rewrite -ger0_def.
  done.
  intro H; rewrite (eqP H).
  done.
Qed.

Lemma pdist_mul_r a b c : pdist (a * c) (b * c) = c * (pdist a b).
  rewrite (pmulrC a c).
  rewrite (pmulrC b c).
  apply pdist_mul_l.
Qed.

Lemma ple_sum {A} (c : seq A) (F1 F2 : A -> posrat) (f : A -> bool) :
  (forall x, f x -> F1 x <= F2 x) ->
  (\big[padd/0]_(p <- c | f p) F1 p) <= (\big[padd/0]_(p <- c | f p) F2 p).
  intros.
  induction c.
  rewrite !big_nil; done.
  rewrite !big_cons.
  remember (f a) as b; destruct b.
  apply ple_add_lr.
  apply H; rewrite -Heqb //=.
  done.
  done.
Qed.

Lemma padd2 (a : posrat) :
  a + a = (Posrat 2%:Q is_true_true) * a.
  destruct a; apply/eqP; rewrite /eq_op //=; apply/eqP.
  have: intr 2 = (intr 1 + intr 1)%R.
  done.
  intro.
  unlock padd pmul; simpl.
  rewrite x.
  rewrite mulrDl.
  rewrite (mulrC (intr 1)).
  rewrite !mulr1z.
  rewrite mulr1.
  done.
Qed.

Lemma pinv_0 : pinv 0 = 0.
  simpl.
  apply/eqP; rewrite /eq_op //=.
  unlock pinv; simpl.
  rewrite invr0.
  done.
Qed.

Lemma pinv_neq0 a :
  a != 0 -> pinv a != 0.
  unlock pinv;
  destruct a; rewrite /pinv_; intro; rewrite /eq_op //=.
  apply invr_neq0.
  done.
Qed.

Definition pdiv_neq0 a b :
  a != 0 -> b != 0 -> a / b != 0.
  intros; rewrite -pmul0.
  rewrite negb_or.
  apply/andP; split.
  done.
  apply pinv_neq0; done.
Qed.

Definition pexp_neq0 a c :
  a != 0 -> (a ^+ c != 0).
  unlock pexp;
  destruct a; rewrite /pexp_; simpl.
  intro; rewrite /eq_op //=.
  apply expf_neq0.
  done.
Qed.

Definition pdiv_lt1 a b :
  b != 0 -> a < b -> a / b < 1.
  destruct a,b.
  unfold plt; simpl.
  intros.
  unlock pmul pinv; simpl.

  rewrite ltr_pdivr_mulr.
  rewrite mul1r. done.
  rewrite ltr_def.
  rewrite -Qnneg_def i0.
  rewrite /eq_op //= in H.
  rewrite H; done.
Qed.

Lemma pmul_div a b c d:
  (a / b) * (c / d) = (a * c) / (b * d).
  unlock pmul pinv; simpl.
  destruct a,b,c,d; apply/eqP; rewrite /eq_op //=; apply/eqP.
  apply mulf_div.
Qed.

Lemma pinv_1 :
  pinv 1 = 1.
  unlock pinv.
  rewrite /pinv.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
Qed.

Lemma pdiv_pmul_num a b c :
  (a * b) / c = a * (b / c).
  rewrite -(pmul1r c).
  rewrite -pmul_div.
  rewrite pinv_1.
  rewrite pmulr1.
  rewrite pmul1r.
  done.
Qed.

Lemma pdiv_pmul_denom a b c:
  a / (b * c) = a / b * (1 / c).
  rewrite pmul_div.
  rewrite pmulr1.
  done.
Qed.

  Lemma psum_neq0 {A : eqType} (xs : seq A) f :
    (\big[padd/0]_(x <- xs) f x != 0) = (has (fun x => f x != 0) xs).
    induction xs.
    rewrite big_nil //=.
    rewrite big_cons //=.
    rewrite -IHxs.
    apply Bool.eq_true_iff_eq; split.
    rewrite -padd0 negb_and; move/orP; elim => H; rewrite H //= ?orbT //=.

    move/orP; elim => H.
    rewrite -padd0 negb_and H //=.
    rewrite -padd0 negb_and H //= orbT //=.
  Qed.

  Lemma psum_eq0 {A : eqType} (xs : seq A) f :
    (\big[padd/0]_(x <- xs) f x == 0) = (all (fun x => f x == 0) xs).
    induction xs.
    rewrite big_nil //=.
    rewrite big_cons //=.
    rewrite -IHxs.
    rewrite padd0; done.
  Qed.

Lemma pdivK (p : posrat) :
  p != 0 -> p / p = 1.
  move => H.
  destruct p; simpl in *; unlock pmul pinv; simpl.
  apply/eqP; rewrite /eq_op //=.
  rewrite GRing.Theory.divff.
  done.
  done.
Qed.

Lemma posrat_of_nat_0 :
  posrat_of_nat 0 = 0.
  unlock posrat_of_nat; simpl.
  apply/eqP; rewrite /eq_op //=.
Qed.

Lemma posrat_of_nat_neq0 n :
  posrat_of_nat (S n) != 0.
  unlock posrat_of_nat; simpl.
  rewrite /posrat_of_nat_; rewrite /eq_op //=.
  rewrite /intr //=.
  have: (0%R < n.+1%:R)%R.
  intro.
  apply ltr0Sn.
  intros.
  rewrite gtr_eqF.
  done.
  apply x.
Qed.

Lemma posrat_of_nat_S n :
  posrat_of_nat (S n) = 1 + posrat_of_nat n.
  unlock posrat_of_nat; simpl.
  rewrite /posrat_of_nat_.
  unlock padd; simpl.
  apply/eqP; rewrite /eq_op //=.
  rewrite /intr //=.
  have -> : (n.+1) = (1 + n)%N.
  done.
  rewrite natrD.
  apply/eqP; congr (_ + _)%R.
Qed.

Lemma iter_padd (n : nat) (p1 p2 : posrat) :
  iter n (padd p1) p2 =
  p2 + (posrat_of_nat n * p1).
  induction n.
  simpl.
  rewrite posrat_of_nat_0 pmul0r paddr0 //=.
  simpl.
  rewrite IHn.
  rewrite posrat_of_nat_S.
  rewrite pmulrDl pmul1r !paddrA.
  congr (_ + _).
  rewrite paddrC //=.
Qed.


Require Import Coq.Arith.Arith .
Require Import Coq.Bool.Bool .
Require Export Coq.Strings.String .
Require Import Coq.Logic.FunctionalExtensionality .
Require Import Coq.Lists.List .
Import ListNotations.
Require Import Coq.Logic.ProofIrrelevance.
Require Import ZArith.
Require Import Coq.Logic.FinFun.
Open Scope string.

(* Prepare Hints *)
Create HintDb DomainArrowDb discriminated.
Ltac auto ::= auto with DomainArrowDb.
Ltac myauto := simpl; auto with DomainArrowDb.
Ltac myrewrite := autorewrite with DomainArrowDb.
Ltac myunfold := autounfold with DomainArrowDb.

Ltac solvefieldlist l := induction l; [reflexivity | simpl; f_equal; assumption].

(* uniqness of a column *)
Definition UniqueField {A B:Type} (f: A->B) (l: list A)  :=
NoDup (map f l).

(**---Original----**)

Record Domain:= mkDomain{
  d_name: string;
}.

Record Arrow:= mkArrow{
  ar_name: string;
  startsAt: Domain;
  endsAt: Domain;
}.

Record class_diagram := mkCD{
  dl: list Domain;
  al: list Arrow;
  uniqueDomainName: UniqueField d_name dl;
  uniqueArrowName: UniqueField ar_name al;
}.

(**---Refacotred----**)

Record Domain':= mkDomain'{
  d_name': string;
}.

Record Arrow':= mkArrow'{
  ar_name': string;
  domain': string;
  codomain': string;
  connects': Domain' * Domain';
  samestart: domain' = d_name' (fst connects');
  sameend: codomain' = d_name' (snd connects');
}.

Record class_diagram' := mkCD'{
  dl': list Domain';
  al': list Arrow';
  uniqueDomainName': UniqueField d_name' dl';
  uniqueArrowName': UniqueField ar_name' al';
}.

(**------Mappings-------**)
Definition toDomain'(d:Domain) : Domain' :=
mkDomain' (d_name d).

Lemma samestartL: forall ar,
 d_name (startsAt ar) =
 d_name'(fst (toDomain' (startsAt ar), toDomain' (endsAt ar))).
Proof. intros; reflexivity. Qed.

Lemma sameendL: forall ar,
 d_name (endsAt ar) =
 d_name'(snd (toDomain' (startsAt ar), toDomain' (endsAt ar))).
Proof. intros; reflexivity. Qed.

Definition toArrow'(ar:Arrow) : Arrow' :=
mkArrow' (ar_name ar) (d_name (startsAt ar)) (d_name (endsAt ar))
         ((toDomain'(startsAt ar)), (toDomain'(endsAt ar)))
         (samestartL ar) (sameendL ar).

Lemma FieldMap: forall {A A' B: Type} {f: A -> B} {l:list A}
{f': A' -> B} {t':A -> A'} ,
(map f l) = (map f' (map t' l)) ->
UniqueField f l = UniqueField f' (map t' l).
Proof.
intros.
unfold UniqueField.
rewrite <- H.
reflexivity.
Qed.

Lemma domainNameMap: forall dl,
(map d_name dl) = (map d_name' (map toDomain' dl)).
Proof. intros dl; solvefieldlist dl. Qed.

Lemma uniqueDomainNameL: forall cd,
 UniqueField d_name'(map toDomain' (dl cd)).
Proof.
intros.
destruct cd as [dl ? ? ?]. simpl.
rewrite <- (FieldMap (domainNameMap dl)).
assumption.
Qed.

Lemma arrowNameMap: forall al,
(map ar_name al) = (map ar_name' (map toArrow' al)).
Proof. intros al; solvefieldlist al. Qed.

Lemma uniqueArrowNameL: forall cd,
UniqueField ar_name' (map toArrow' (al cd)).
Proof.
intros.
destruct cd as [? al ? ?]. simpl.
rewrite <- (FieldMap (arrowNameMap al)).
assumption.
Qed.

Definition toCD'(cd: class_diagram) : class_diagram':=
mkCD' (map toDomain' (dl cd)) (map toArrow' (al cd))
      (uniqueDomainNameL cd) (uniqueArrowNameL cd).

(** S Mappings **)

Definition toDomain(d':Domain') : Domain :=
mkDomain (d_name' d').

Definition toArrow(ar':Arrow') : Arrow :=
mkArrow (ar_name' ar') (toDomain (fst (connects' ar')))
                       (toDomain (snd (connects' ar'))).

Lemma domainNameMap': forall dl',
(map d_name' dl') = (map d_name (map toDomain dl')).
Proof. intros dl; solvefieldlist dl. Qed.

Lemma uniqueDomainNameL': forall cd',
 UniqueField d_name (map toDomain (dl' cd')).
Proof.
intros cd.
destruct cd as [dl ? ? ?]. simpl.
rewrite <- (FieldMap (domainNameMap' dl)).
assumption.
Qed.

Lemma arrowNameMap': forall al',
(map ar_name' al') = (map ar_name (map toArrow al')).
Proof. intros al; solvefieldlist al. Qed.

Lemma uniqueArrowNameL': forall cd',
UniqueField ar_name (map toArrow (al' cd')).
Proof.
intros cd.
destruct cd as [? al ? ?]. simpl.
rewrite <- (FieldMap (arrowNameMap' al)).
assumption.
Qed.

Definition toCD(cd': class_diagram') : class_diagram:=
mkCD (map toDomain (dl' cd'))(map toArrow (al' cd'))
      (uniqueDomainNameL' cd') (uniqueArrowNameL' cd').

Hint Unfold toArrow toArrow' toCD toCD' toDomain toDomain'.

(**------Theorems-------**)

Ltac destruct_record :=
 match goal with
   | [d : Domain |- _] => destruct d
   | [d' : Domain' |- _] => destruct d'
   | [a : Arrow |- _] => destruct a
   | [a' : Arrow' |- _] => destruct a'
   | [p : _*_ |- _] => destruct p
 end.

Ltac destruct_all := repeat destruct_record.

Ltac destruct_list :=
  match goal with
  | [l : list _ |- _ ] => destruct l as [ | destruct_all]
  end.

Ltac destruct_lists := repeat destruct_list.

Ltac solve_simple_reconstruct := intros [?]; destruct_all;  auto.

Ltac solve_list_reconstruct := intros l; induction l; [auto | simpl; f_equal;
                                     [destruct_all; myauto | auto] ].

Lemma reconstructDomain: forall d,
  d = toDomain (toDomain' d).
Proof. solve_simple_reconstruct. Qed.

Lemma reconstructDomain': forall d,
  d = toDomain' (toDomain d).
Proof. solve_simple_reconstruct. Qed.

Lemma reconstructArrow: forall a,
  a = toArrow (toArrow' a).
Proof. solve_simple_reconstruct. Qed.

Lemma reconstructArrowList: forall al,
 al = map toArrow (map toArrow' al).
Proof. solve_list_reconstruct. Qed.

Lemma reconstructDomainList: forall dl,
 dl = map toDomain (map toDomain' dl).
Proof. solve_list_reconstruct. Qed.

Hint Resolve reconstructDomain reconstructDomain': DomainArrowDb.

Definition castSameStart (domain': string) (conn:Domain'*Domain'):=
domain' = d_name' (fst conn).

Definition castSameEnd (codomain': string) (conn:Domain'*Domain'):=
codomain' = d_name' (snd conn).

Definition transport (fn : string -> Domain'*Domain' -> Type)
{s1 s2: string} {d1 d2: Domain'*Domain'}:
s1 = s2 -> d1 = d2 -> fn s1 d1 -> fn s2 d2.
Proof.
  repeat (intros []).
  firstorder.
Qed.

Print mkArrow'.

Lemma eqConst (a1 a2: Arrow')
      (n: ar_name' a1 = ar_name' a2)
      (p: domain' a1 = domain' a2)
      (q : codomain' a1 = codomain' a2)
      (r: connects' a1 = connects' a2):
  transport castSameStart p r (samestart a1) = samestart a2 ->
  transport castSameEnd   q r (sameend a1)   = sameend a2   ->
  a1 = a2.
Proof.
  destruct a1; destruct a2.
  simpl in * |- *.
  destruct n, p, q, r.
  repeat (intros []).
  f_equal; apply proof_irrelevance.
Qed.

Lemma n (a': Arrow'):
ar_name' a' = ar_name' (toArrow' (toArrow a')).
Proof. myauto. Qed.

Lemma p (a': Arrow'):
domain' a' = domain' (toArrow' (toArrow a')).
Proof. destruct a'; myauto. Qed.

Lemma q (a': Arrow'):
codomain' a' = codomain' (toArrow' (toArrow a')).
Proof. destruct a'; myauto. Qed.

Lemma r (a': Arrow'):
connects' a' = connects' (toArrow' (toArrow a')).
Proof. destruct_all. myauto. Qed.

Lemma reconstructArrow': forall a',
  a' = toArrow' (toArrow a').
Proof. intros a.
apply (eqConst a (toArrow' (toArrow a)) (n a) (p a) (q a) (r a));
apply proof_irrelevance. Qed.

Lemma reconstructArrowList': forall al',
 al' = map toArrow' (map toArrow al').
Proof.
solve_list_reconstruct.
apply reconstructArrow'.
Qed.

Lemma reconstructDomainList': forall dl',
 dl' = map toDomain' (map toDomain dl').
Proof. solve_list_reconstruct. Qed.

Hint Resolve reconstructArrow reconstructArrow'
             reconstructArrowList reconstructArrowList'
             reconstructDomainList reconstructDomainList' : DomainArrowDb.

Lemma eqDomainList: forall cd,
dl cd = dl (toCD (toCD' cd)).
Proof.
intros [?]; myauto.
Qed.

Lemma eqArrowList: forall cd,
 al cd = al (toCD (toCD' cd)).
Proof. intros [?]; myauto. Qed.

Lemma eqDomainList': forall cd',
dl' cd' = dl' (toCD' (toCD cd')).
Proof. intros [?]; myauto. Qed.

Lemma eqArrowList': forall cd',
al' cd' = al' (toCD' (toCD cd')).
Proof. intros [?]; myauto. Qed.

Definition castDN (dl: list Domain):=
UniqueField d_name dl.

Definition castAN (al: list Arrow):=
UniqueField ar_name al.

Definition transportDN (fn : list Domain -> Type)
  {d1 d2: list Domain} :
    d1 = d2 -> fn d1-> fn d2.
Proof. intros [] ?. assumption. Defined.

Definition transportAN (fn : list Arrow -> Type)
  {a1 a2: list Arrow} :
    a1 = a2 -> fn a1-> fn a2.
Proof. intros[] ?. assumption. Defined.

Lemma eqCD (cd1 cd2 : class_diagram)
      (p: dl cd1 = dl cd2)
      (q : al cd1 = al cd2):
  transportDN castDN p (uniqueDomainName cd1) = uniqueDomainName cd2 ->
  transportAN castAN q (uniqueArrowName cd1) = uniqueArrowName cd2 ->
  cd1 = cd2.
Proof.
  destruct cd1, cd2.
  simpl in * |- *.
  destruct p, q.
  repeat (intros []).
  reflexivity.
Qed.

Theorem th1: forall cd:class_diagram,
  cd = toCD (toCD' cd).
Proof.
intros.
pose proof eqCD cd (toCD (toCD' cd)).
apply (H (eqDomainList cd) (eqArrowList cd));
apply proof_irrelevance.
Qed.

Print mkCD'.

Definition castDN' (dl':list Domain'):=
UniqueField d_name' dl'.

Definition transportDN' (fn : list Domain' -> Type)
  {d1 d2: list Domain'} :
    d1 = d2 -> fn d1-> fn d2.
Proof.
  intros [] ?. assumption.
Defined.

Definition castAN' (al':list Arrow'):=
UniqueField ar_name' al'.

Definition transportAN' (fn : list Arrow' -> Type)
  {a1 a2: list Arrow'} :
    a1 = a2 -> fn a1-> fn a2.
Proof.
  intros[] ?. assumption.
Defined.

Lemma eqCD' (cd1 cd2 : class_diagram')
      (p: dl' cd1 = dl' cd2)
      (q : al' cd1 = al' cd2):
  transportDN' castDN' p (uniqueDomainName' cd1) = uniqueDomainName' cd2 ->
  transportAN' castAN' q (uniqueArrowName' cd1) = uniqueArrowName' cd2 ->
  cd1 = cd2.
Proof.
  destruct cd1, cd2.
  simpl in * |- *.
  destruct p, q.
  repeat (intros []).
  reflexivity.
Qed.

Theorem th2: forall cd':class_diagram',
  cd' = toCD' (toCD cd').
Proof.
intros.
pose proof eqCD' cd' (toCD' (toCD cd')).
apply (H (eqDomainList' cd') (eqArrowList' cd'));
apply proof_irrelevance.
Qed.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype.
Require Import tuple finfun bigop finset binomial fingroup.

(******************************************************************************)
(* This file contains the definition and properties associated to the group   *)
(* of permutations of an arbitrary finite type.                               *)
(*     {perm T} == the type of permutations of a finite type T, i.e.,         *)
(*                 injective (finite) functions from T to T. Permutations     *)
(*                 coerce to CiC functions.                                   *)
(*         'S_n == the set of all permutations of 'I_n, i.e., of {0,.., n-1}  *)
(*  perm_on A u == u is a permutation with support A, i.e., u only displaces  *)
(*                 elements of A (u x != x implies x \in A).                  *)
(*    tperm x y == the transposition of x, y                                  *)
(*    aperm x s == the image of x under the action of the permutation s       *)
(*              := s x                                                        *)
(*   pcycle s x == the set of all elements that are in the same cycle of the  *)
(*                 permutation s as x, i.e., {x, s x, (s ^+ 2) x, ...}        *)
(*    pcycles s == the set of all the cycles of the permutation s             *)
(*   (s : bool) == s is an odd permutation (the coercion is called odd_perm)  *)
(*      dpair u == u is a pair (x, y) of distinct objects (i.e., x != y)      *)
(* lift_perm i j s == the permutation obtained by lifting s : 'S_n.-1 over    *)
(*                 (i |-> j), that maps i to j and lift i k to lift j (s k).  *)
(* Canonical structures are defined allowing permutations to be an eqType,    *)
(* choiceType, countType, finType, subType, finGroupType; permutations with   *)
(* composition form a group, therefore inherit all generic group notations:   *)
(* 1 == identity permutation, * == composition, ^-1 == inverse permutation.   *)
(******************************************************************************)

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

Import GroupScope.

Section PermDefSection.

Variable T : finType.

Inductive perm_type : predArgType :=
  Perm (pval : {ffun T -> T}) & injectiveb pval.
Definition pval p := let: Perm f _ := p in f.
Definition perm_of of phant T := perm_type.
Identity Coercion type_of_perm : perm_of >-> perm_type.

Notation pT := (perm_of (Phant T)).

Canonical perm_subType := Eval hnf in [subType for pval].
Definition perm_eqMixin := Eval hnf in [eqMixin of perm_type by <:].
Canonical perm_eqType := Eval hnf in EqType perm_type perm_eqMixin.
Definition perm_choiceMixin := [choiceMixin of perm_type by <:].
Canonical perm_choiceType := Eval hnf in ChoiceType perm_type perm_choiceMixin.
Definition perm_countMixin := [countMixin of perm_type by <:].
Canonical perm_countType := Eval hnf in CountType perm_type perm_countMixin.
Canonical perm_subCountType := Eval hnf in [subCountType of perm_type].
Definition perm_finMixin := [finMixin of perm_type by <:].
Canonical perm_finType := Eval hnf in FinType perm_type perm_finMixin.
Canonical perm_subFinType := Eval hnf in [subFinType of perm_type].

Canonical perm_for_subType := Eval hnf in [subType of pT].
Canonical perm_for_eqType := Eval hnf in [eqType of pT].
Canonical perm_for_choiceType := Eval hnf in [choiceType of pT].
Canonical perm_for_countType := Eval hnf in [countType of pT].
Canonical perm_for_subCountType := Eval hnf in [subCountType of pT].
Canonical perm_for_finType := Eval hnf in [finType of pT].
Canonical perm_for_subFinType := Eval hnf in [subFinType of pT].

Lemma perm_proof (f : T -> T) : injective f -> injectiveb (finfun f).
Proof.
by move=> f_inj; apply/injectiveP; apply: eq_inj f_inj _ => x; rewrite ffunE.
Qed.

End PermDefSection.

Notation "{ 'perm' T }" := (perm_of (Phant T))
  (at level 0, format "{ 'perm'  T }") : type_scope.

Arguments Scope pval [_ group_scope].

Bind Scope group_scope with perm_type.
Bind Scope group_scope with perm_of.

Notation "''S_' n" := {perm 'I_n}
  (at level 8, n at level 2, format "''S_' n").

Notation Local fun_of_perm_def := (fun T (u : perm_type T) => val u : T -> T).
Notation Local perm_def := (fun T f injf => Perm (@perm_proof T f injf)).

Module Type PermDefSig.
Parameter fun_of_perm : forall T, perm_type T -> T -> T.
Parameter perm : forall (T : finType) (f : T -> T), injective f -> {perm T}.
Axiom fun_of_permE : fun_of_perm = fun_of_perm_def.
Axiom permE : perm = perm_def.
End PermDefSig.

Module PermDef : PermDefSig.
Definition fun_of_perm := fun_of_perm_def.
Definition perm := perm_def.
Lemma fun_of_permE : fun_of_perm = fun_of_perm_def. Proof. by []. Qed.
Lemma permE : perm = perm_def. Proof. by []. Qed.
End PermDef.

Notation fun_of_perm := PermDef.fun_of_perm.
Notation "@ 'perm'" := (@PermDef.perm) (at level 10, format "@ 'perm'").
Notation perm := (@PermDef.perm _ _).
Canonical fun_of_perm_unlock := Unlockable PermDef.fun_of_permE.
Canonical perm_unlock := Unlockable PermDef.permE.
Coercion fun_of_perm : perm_type >-> Funclass.

Section Theory.

Variable T : finType.
Implicit Types (x y : T) (s t : {perm T}) (S : {set T}).

Lemma permP s t : s =1 t <-> s = t.
Proof. by split=> [| -> //]; rewrite unlock => eq_sv; exact/val_inj/ffunP. Qed.

Lemma pvalE s : pval s = s :> (T -> T).
Proof. by rewrite [@fun_of_perm]unlock. Qed.

Lemma permE f f_inj : @perm T f f_inj =1 f.
Proof. by move=> x; rewrite -pvalE [@perm]unlock ffunE. Qed.

Lemma perm_inj s : injective s.
Proof. by rewrite -!pvalE; exact: (injectiveP _ (valP s)). Qed.

Implicit Arguments perm_inj [].
Hint Resolve perm_inj.

Lemma perm_onto s : codom s =i predT.
Proof. by apply/subset_cardP; rewrite ?card_codom ?subset_predT. Qed.

Definition perm_one := perm (@inj_id T).

Lemma perm_invK s : cancel (fun x => iinv (perm_onto s x)) s.
Proof. by move=> x /=; rewrite f_iinv. Qed.

Definition perm_inv s := perm (can_inj (perm_invK s)).

Definition perm_mul s t := perm (inj_comp (perm_inj t) (perm_inj s)).

Lemma perm_oneP : left_id perm_one perm_mul.
Proof. by move=> s; apply/permP => x; rewrite permE /= permE. Qed.

Lemma perm_invP : left_inverse perm_one perm_inv perm_mul.
Proof. by move=> s; apply/permP=> x; rewrite !permE /= permE f_iinv. Qed.

Lemma perm_mulP : associative perm_mul.
Proof. by move=> s t u; apply/permP=> x; do !rewrite permE /=. Qed.

Definition perm_of_baseFinGroupMixin : FinGroup.mixin_of (perm_type T) :=
  FinGroup.Mixin perm_mulP perm_oneP perm_invP.
Canonical perm_baseFinGroupType :=
  Eval hnf in BaseFinGroupType (perm_type T) perm_of_baseFinGroupMixin.
Canonical perm_finGroupType := @FinGroupType perm_baseFinGroupType perm_invP.

Canonical perm_of_baseFinGroupType :=
  Eval hnf in [baseFinGroupType of {perm T}].
Canonical perm_of_finGroupType := Eval hnf in [finGroupType of {perm T} ].

Lemma perm1 x : (1 : {perm T}) x = x.
Proof. by rewrite permE. Qed.

Lemma permM s t x : (s * t) x = t (s x).
Proof. by rewrite permE. Qed.

Lemma permK s : cancel s s^-1.
Proof. by move=> x; rewrite -permM mulgV perm1. Qed.

Lemma permKV s : cancel s^-1 s.
Proof. by have:= permK s^-1; rewrite invgK. Qed.

Lemma permJ s t x : (s ^ t) (t x) = t (s x).
Proof. by rewrite !permM permK. Qed.

Lemma permX s x n : (s ^+ n) x = iter n s x.
Proof. by elim: n => [|n /= <-]; rewrite ?perm1 // -permM expgSr. Qed.

Lemma im_permV s S : s^-1 @: S = s @^-1: S.
Proof. exact: can2_imset_pre (permKV s) (permK s). Qed.

Lemma preim_permV s S : s^-1 @^-1: S = s @: S.
Proof. by rewrite -im_permV invgK. Qed.

Definition perm_on S : pred {perm T} := fun s => [pred x | s x != x] \subset S.

Lemma perm_closed S s x : perm_on S s -> (s x \in S) = (x \in S).
Proof.
move/subsetP=> s_on_S; have [-> // | nfix_s_x] := eqVneq (s x) x.
by rewrite !s_on_S // inE /= ?(inj_eq (perm_inj s)).
Qed.

Lemma perm_on1 H : perm_on H 1.
Proof. by apply/subsetP=> x; rewrite inE /= perm1 eqxx. Qed.

Lemma perm_onM H s t : perm_on H s -> perm_on H t -> perm_on H (s * t).
Proof.
move/subsetP=> sH /subsetP tH; apply/subsetP => x; rewrite inE /= permM.
by have [-> /tH | /sH] := eqVneq (s x) x.
Qed.

Lemma out_perm S u x : perm_on S u -> x \notin S -> u x = x.
Proof. by move=> uS; exact: contraNeq (subsetP uS x). Qed.

Lemma im_perm_on u S : perm_on S u -> u @: S = S.
Proof.
move=> Su; rewrite -preim_permV; apply/setP=> x.
by rewrite !inE -(perm_closed _ Su) permKV.
Qed.

Lemma tperm_proof x y : involutive [fun z => z with x |-> y, y |-> x].
Proof.
move=> z /=; case: (z =P x) => [-> | ne_zx]; first by rewrite eqxx; case: eqP.
by case: (z =P y) => [->| ne_zy]; [rewrite eqxx | do 2?case: eqP].
Qed.

Definition tperm x y := perm (can_inj (tperm_proof x y)).

CoInductive tperm_spec x y z : T -> Type :=
  | TpermFirst of z = x          : tperm_spec x y z y
  | TpermSecond of z = y         : tperm_spec x y z x
  | TpermNone of z <> x & z <> y : tperm_spec x y z z.

Lemma tpermP x y z : tperm_spec x y z (tperm x y z).
Proof. by rewrite permE /=; do 2?[case: eqP => /=]; constructor; auto. Qed.

Lemma tpermL x y : tperm x y x = y.
Proof. by case: tpermP. Qed.

Lemma tpermR x y : tperm x y y = x.
Proof. by case: tpermP. Qed.

Lemma tpermD x y z : x != z -> y != z -> tperm x y z = z.
Proof. by case: tpermP => // ->; rewrite eqxx. Qed.

Lemma tpermC x y : tperm x y = tperm y x.
Proof. by apply/permP => z; do 2![case: tpermP => //] => ->. Qed.

Lemma tperm1 x : tperm x x = 1.
Proof. by apply/permP => z; rewrite perm1; case: tpermP. Qed.

Lemma tpermK x y : involutive (tperm x y).
Proof. by move=> z; rewrite !permE tperm_proof. Qed.

Lemma tpermKg x y : involutive (mulg (tperm x y)).
Proof. by move=> s; apply/permP=> z; rewrite !permM tpermK. Qed.

Lemma tpermV x y : (tperm x y)^-1 = tperm x y.
Proof. by set t := tperm x y; rewrite -{2}(mulgK t t) -mulgA tpermKg. Qed.

Lemma tperm2 x y : tperm x y * tperm x y = 1.
Proof. by rewrite -{1}tpermV mulVg. Qed.

Lemma card_perm A : #|perm_on A| = (#|A|)`!.
Proof.
pose ffA := {ffun {x | x \in A} -> T}.
rewrite -ffactnn -{2}(card_sig (mem A)) /= -card_inj_ffuns_on.
pose fT (f : ffA) := [ffun x => oapp f x (insub x)].
pose pfT f := insubd (1 : {perm T}) (fT f).
pose fA s : ffA := [ffun u => s (val u)].
rewrite -!sum1dep_card -sum1_card (reindex_onto fA pfT) => [|f].
  apply: eq_bigl => p; rewrite andbC; apply/idP/and3P=> [onA | []]; first split.
  - apply/eqP; suffices fTAp: fT (fA p) = pval p.
      by apply/permP=> x; rewrite -!pvalE insubdK fTAp //; exact: (valP p).
    apply/ffunP=> x; rewrite ffunE pvalE.
    by case: insubP => [u _ <- | /out_perm->] //=; rewrite ffunE.
  - by apply/forallP=> [[x Ax]]; rewrite ffunE /= perm_closed.
  - by apply/injectiveP=> u v; rewrite !ffunE => /perm_inj; exact: val_inj.
  move/eqP=> <- _ _; apply/subsetP=> x; rewrite !inE -pvalE val_insubd fun_if.
  by rewrite if_arg ffunE; case: insubP; rewrite // pvalE perm1 if_same eqxx.
case/andP=> /forallP onA /injectiveP f_inj.
apply/ffunP=> u; rewrite ffunE -pvalE insubdK; first by rewrite ffunE valK.
apply/injectiveP=> {u} x y; rewrite !ffunE.
case: insubP => [u _ <-|]; case: insubP => [v _ <-|] //=; first by move/f_inj->.
  by move=> Ay' def_y; rewrite -def_y [_ \in A]onA in Ay'.
by move=> Ax' def_x; rewrite def_x [_ \in A]onA in Ax'.
Qed.

End Theory.

Prenex Implicits tperm.

Lemma inj_tperm (T T' : finType) (f : T -> T') x y z :
  injective f -> f (tperm x y z) = tperm (f x) (f y) (f z).
Proof. by move=> injf; rewrite !permE /= !(inj_eq injf) !(fun_if f). Qed.

Lemma tpermJ (T : finType) x y (s : {perm T}) :
  (tperm x y) ^ s = tperm (s x) (s y).
Proof.
apply/permP => z; rewrite -(permKV s z) permJ; apply: inj_tperm.
exact: perm_inj.
Qed.

Lemma tuple_perm_eqP {T : eqType} {n} {s : seq T} {t : n.-tuple T} :
  reflect (exists p : 'S_n, s = [tuple tnth t (p i) | i < n]) (perm_eq s t).
Proof.
apply: (iffP idP) => [|[p ->]]; last first.
  rewrite /= (map_comp (tnth t)) -{1}(map_tnth_enum t) perm_map //.
  apply: uniq_perm_eq => [||i]; rewrite ?enum_uniq //.
    by apply/injectiveP; apply: perm_inj.
  by rewrite mem_enum -[i](permKV p) image_f.
case: n => [|n] in t *; last have x0 := tnth t ord0.
  rewrite tuple0 => /perm_eq_small-> //.
  by exists 1; rewrite [mktuple _]tuple0.
case/(perm_eq_iotaP x0); rewrite size_tuple => Is eqIst ->{s}.
have uniqIs: uniq Is by rewrite (perm_eq_uniq eqIst) iota_uniq.
have szIs: size Is == n.+1 by rewrite (perm_eq_size eqIst) !size_tuple.
have pP i : tnth (Tuple szIs) i < n.+1.
  by rewrite -[_ < _](mem_iota 0) -(perm_eq_mem eqIst) mem_tnth.
have inj_p: injective (fun i => Ordinal (pP i)).
  by apply/injectiveP/(@map_uniq _ _ val); rewrite -map_comp map_tnth_enum.
exists (perm inj_p); rewrite -[Is]/(tval (Tuple szIs)); congr (tval _).
by apply: eq_from_tnth => i; rewrite tnth_map tnth_mktuple permE (tnth_nth x0).
Qed.

Section PermutationParity.

Variable T : finType.

Implicit Types (s t u v : {perm T}) (x y z a b : T).

(* Note that pcycle s x is the orbit of x by <[s]> under the action aperm. *)
(* Hence, the pcycle lemmas below are special cases of more general lemmas *)
(* on orbits that will be stated in action.v.                              *)
(*   Defining pcycle directly here avoids a dependency of matrix.v on      *)
(* action.v and hence morphism.v.                                          *)

Definition aperm x s := s x.
Definition pcycle s x := aperm x @: <[s]>.
Definition pcycles s := pcycle s @: T.
Definition odd_perm (s : perm_type T) := odd #|T| (+) odd #|pcycles s|.

Lemma apermE x s : aperm x s = s x. Proof. by []. Qed.

Lemma mem_pcycle s i x : (s ^+ i) x \in pcycle s x.
Proof. by rewrite (mem_imset (aperm x)) ?mem_cycle. Qed.

Lemma pcycle_id s x : x \in pcycle s x.
Proof. by rewrite -{1}[x]perm1 (mem_pcycle s 0). Qed.

Lemma uniq_traject_pcycle s x : uniq (traject s x #|pcycle s x|).
Proof.
case def_n: #|_| => // [n]; rewrite looping_uniq.
apply: contraL (card_size (traject s x n)) => /loopingP t_sx.
rewrite -ltnNge size_traject -def_n ?subset_leq_card //.
by apply/subsetP=> _ /imsetP[_ /cycleP[i ->] ->]; rewrite /aperm permX t_sx.
Qed.

Lemma pcycle_traject s x : pcycle s x =i traject s x #|pcycle s x|.
Proof.
apply: fsym; apply/subset_cardP.
  by rewrite (card_uniqP _) ?size_traject ?uniq_traject_pcycle.
by apply/subsetP=> _ /trajectP[i _ ->]; rewrite -permX mem_pcycle.
Qed.

Lemma iter_pcycle s x : iter #|pcycle s x| s x = x.
Proof.
case def_n: #|_| (uniq_traject_pcycle s x) => [//|n] Ut.
have: looping s x n.+1.
  by rewrite -def_n -[looping _ _ _]pcycle_traject -permX mem_pcycle.
rewrite /looping => /trajectP[[|i] //= lt_i_n /perm_inj eq_i_n_sx].
move: lt_i_n; rewrite ltnS ltn_neqAle andbC => /andP[le_i_n /negP[]].
by rewrite -(nth_uniq x _ _ Ut) ?size_traject ?nth_traject // eq_i_n_sx.
Qed.

Lemma eq_pcycle_mem s x y : (pcycle s x == pcycle s y) = (x \in pcycle s y).
Proof.
apply/eqP/idP=> [<- | /imsetP[si s_si ->]]; first exact: pcycle_id.
apply/setP => z; apply/imsetP/imsetP=> [] [sj s_sj ->].
  by exists (si * sj); rewrite ?groupM /aperm ?permM.
exists (si^-1 * sj); first by rewrite groupM ?groupV.
by rewrite /aperm permM permK.
Qed.

Lemma pcycle_sym s x y : (x \in pcycle s y) = (y \in pcycle s x).
Proof. by rewrite -!eq_pcycle_mem eq_sym. Qed.

Lemma pcycle_perm s i x : pcycle s ((s ^+ i) x) = pcycle s x.
Proof. by apply/eqP; rewrite eq_pcycle_mem mem_pcycle. Qed.

Lemma ncycles_mul_tperm s x y : let t := tperm x y in
  #|pcycles (t * s)| + (x \notin pcycle s y).*2 = #|pcycles s| + (x != y).
Proof.
pose xf a b u := find (pred2 a b) (traject u (u a) #|pcycle u a|).
have xf_size a b u: xf a b u <= #|pcycle u a|.
  by rewrite (leq_trans (find_size _ _)) ?size_traject.
have lt_xf a b u n : n < xf a b u -> ~~ pred2 a b ((u ^+ n.+1) a).
  move=> lt_n; apply: contraFN (before_find (u a) lt_n).
  by rewrite permX iterSr nth_traject // (leq_trans lt_n).
pose t a b u := tperm a b * u.
have tC a b u : t a b u = t b a u by rewrite /t tpermC.
have tK a b: involutive (t a b) by move=> u; exact: tpermKg.
have tXC a b u n: n <= xf a b u -> (t a b u ^+ n.+1) b = (u ^+ n.+1) a.
  elim: n => [|n IHn] lt_n_f; first by rewrite permM tpermR.
  rewrite !(expgSr _ n.+1) !permM {}IHn 1?ltnW //; congr (u _).
  by case/lt_xf/norP: lt_n_f => ne_a ne_b; rewrite tpermD // eq_sym.
have eq_xf a b u: pred2 a b ((u ^+ (xf a b u).+1) a).
  have ua_a: a \in pcycle u (u a) by rewrite pcycle_sym (mem_pcycle _ 1).
  have has_f: has (pred2 a b) (traject u (u a) #|pcycle u (u a)|).
    by apply/hasP; exists a; rewrite /= ?eqxx -?pcycle_traject.
  have:= nth_find (u a) has_f; rewrite has_find size_traject in has_f.
  rewrite -eq_pcycle_mem in ua_a.
  by rewrite nth_traject // -iterSr -permX -(eqP ua_a).
have xfC a b u: xf b a (t a b u) = xf a b u.
  without loss lt_a: a b u / xf b a (t a b u) < xf a b u.
    move=> IHab; set m := xf b a _; set n := xf a b u.
    by case: (ltngtP m n) => // ltx; [exact: IHab | rewrite -[m]IHab tC tK].
  by move/lt_xf: (lt_a); rewrite -(tXC a b) 1?ltnW //= orbC [_ || _]eq_xf.
pose ts := t x y s; rewrite /= -[_ * s]/ts.
pose dp u := #|pcycles u :\ pcycle u y :\ pcycle u x|.
rewrite !(addnC #|_|) (cardsD1 (pcycle ts y)) mem_imset ?inE //.
rewrite (cardsD1 (pcycle ts x)) inE mem_imset ?inE //= -/(dp ts) {}/ts.
rewrite (cardsD1 (pcycle s y)) (cardsD1 (pcycle s x)) !(mem_imset, inE) //.
rewrite -/(dp s) !addnA !eq_pcycle_mem andbT; congr (_ + _); last first.
  wlog suffices: s / dp s <= dp (t x y s).
    by move=> IHs; apply/eqP; rewrite eqn_leq -{2}(tK x y s) !IHs.
  apply/subset_leq_card/subsetP=> {dp} C.
  rewrite !inE andbA andbC !(eq_sym C) => /and3P[/imsetP[z _ ->{C}]].
  rewrite 2!eq_pcycle_mem => sxz syz.
  suffices ts_z: pcycle (t x y s) z = pcycle s z.
    by rewrite -ts_z !eq_pcycle_mem {1 2}ts_z sxz syz mem_imset ?inE.
  suffices exp_id n: ((t x y s) ^+ n) z = (s ^+ n) z.
    apply/setP=> u; apply/idP/idP=> /imsetP[_ /cycleP[i ->] ->].
      by rewrite /aperm exp_id mem_pcycle.
    by rewrite /aperm -exp_id mem_pcycle.
  elim: n => // n IHn; rewrite !expgSr !permM {}IHn tpermD //.
    apply: contraNneq sxz => ->; exact: mem_pcycle.
  apply: contraNneq syz => ->; exact: mem_pcycle.
case: eqP {dp} => [<- | ne_xy]; first by rewrite /t tperm1 mul1g pcycle_id.
suff ->: (x \in pcycle (t x y s) y) = (x \notin pcycle s y) by case: (x \in _).
without loss xf_x: s x y ne_xy / (s ^+ (xf x y s).+1) x = x.
  move=> IHs; have ne_yx := nesym ne_xy; have:= eq_xf x y s; set n := xf x y s.
  case/pred2P=> [|snx]; first exact: IHs.
  by rewrite -[x \in _]negbK ![x \in _]pcycle_sym -{}IHs ?xfC ?tXC // tC tK.
rewrite -{1}xf_x -(tXC _ _ _ _ (leqnn _)) mem_pcycle; symmetry.
rewrite -eq_pcycle_mem eq_sym eq_pcycle_mem pcycle_traject.
apply/trajectP=> [[n _ snx]].
have: looping s x (xf x y s).+1 by rewrite /looping -permX xf_x inE eqxx.
move/loopingP/(_ n); rewrite -{n}snx.
case/trajectP=> [[_|i]]; first exact: nesym; rewrite ltnS -permX => lt_i def_y.
by move/lt_xf: lt_i; rewrite def_y /= eqxx orbT.
Qed.

Lemma odd_perm1 : odd_perm 1 = false.
Proof.
rewrite /odd_perm card_imset ?addbb // => x y; move/eqP.
by rewrite eq_pcycle_mem /pcycle cycle1 imset_set1 /aperm perm1; move/set1P.
Qed.

Lemma odd_mul_tperm x y s : odd_perm (tperm x y * s) = (x != y) (+) odd_perm s.
Proof.
rewrite addbC -addbA -[~~ _]oddb -odd_add -ncycles_mul_tperm.
by rewrite odd_add odd_double addbF.
Qed.

Lemma odd_tperm x y : odd_perm (tperm x y) = (x != y).
Proof. by rewrite -[_ y]mulg1 odd_mul_tperm odd_perm1 addbF. Qed.

Definition dpair (eT : eqType) := [pred t | t.1 != t.2 :> eT].
Implicit Arguments dpair [eT].

Lemma prod_tpermP s :
  {ts : seq (T * T) | s = \prod_(t <- ts) tperm t.1 t.2 & all dpair ts}.
Proof.
elim: {s}_.+1 {-2}s (ltnSn #|[pred x | s x != x]|) => // n IHn s.
rewrite ltnS => le_s_n; case: (pickP (fun x => s x != x)) => [x s_x | s_id].
  have [|ts def_s ne_ts] := IHn (tperm x (s^-1 x) * s).
    rewrite (cardD1 x) !inE s_x in le_s_n; apply: leq_ltn_trans le_s_n.
    apply: subset_leq_card; apply/subsetP=> y.
    rewrite !inE permM permE /= -(canF_eq (permK _)).
    have [-> | ne_yx] := altP (y =P x); first by rewrite permKV eqxx.
    by case: (s y =P x) => // -> _; rewrite eq_sym.
  exists ((x, s^-1 x) :: ts); last by rewrite /= -(canF_eq (permK _)) s_x.
  by rewrite big_cons -def_s mulgA tperm2 mul1g.
exists nil; rewrite // big_nil; apply/permP=> x.
by apply/eqP/idPn; rewrite perm1 s_id.
Qed.

Lemma odd_perm_prod ts :
  all dpair ts -> odd_perm (\prod_(t <- ts) tperm t.1 t.2) = odd (size ts).
Proof.
elim: ts => [_|t ts IHts] /=; first by rewrite big_nil odd_perm1.
by case/andP=> dt12 dts; rewrite big_cons odd_mul_tperm dt12 IHts.
Qed.

Lemma odd_permM : {morph odd_perm : s1 s2 / s1 * s2 >-> s1 (+) s2}.
Proof.
move=> s1 s2; case: (prod_tpermP s1) => ts1 ->{s1} dts1.
case: (prod_tpermP s2) => ts2 ->{s2} dts2.
by rewrite -big_cat !odd_perm_prod ?all_cat ?dts1 // size_cat odd_add.
Qed.

Lemma odd_permV s : odd_perm s^-1 = odd_perm s.
Proof. by rewrite -{2}(mulgK s s) !odd_permM -addbA addKb. Qed.

Lemma odd_permJ s1 s2 : odd_perm (s1 ^ s2) = odd_perm s1.
Proof. by rewrite !odd_permM odd_permV addbC addbK. Qed.

End PermutationParity.

Coercion odd_perm : perm_type >-> bool.
Implicit Arguments dpair [eT].
Prenex Implicits pcycle dpair pcycles aperm.

Section LiftPerm.
(* Somewhat more specialised constructs for permutations on ordinals. *)

Variable n : nat.
Implicit Types i j : 'I_n.+1.
Implicit Types s t : 'S_n.

Definition lift_perm_fun i j s k :=
  if unlift i k is Some k' then lift j (s k') else j.

Lemma lift_permK i j s :
  cancel (lift_perm_fun i j s) (lift_perm_fun j i s^-1).
Proof.
rewrite /lift_perm_fun => k.
by case: (unliftP i k) => [j'|] ->; rewrite (liftK, unlift_none) ?permK.
Qed.

Definition lift_perm i j s := perm (can_inj (lift_permK i j s)).

Lemma lift_perm_id i j s : lift_perm i j s i = j.
Proof. by rewrite permE /lift_perm_fun unlift_none. Qed.

Lemma lift_perm_lift i j s k' :
  lift_perm i j s (lift i k') = lift j (s k') :> 'I_n.+1.
Proof. by rewrite permE /lift_perm_fun liftK. Qed.

Lemma lift_permM i j k s t :
  lift_perm i j s * lift_perm j k t = lift_perm i k (s * t).
Proof.
apply/permP=> i1; case: (unliftP i i1) => [i2|] ->{i1}.
  by rewrite !(permM, lift_perm_lift).
by rewrite permM !lift_perm_id.
Qed.

Lemma lift_perm1 i : lift_perm i i 1 = 1.
Proof. by apply: (mulgI (lift_perm i i 1)); rewrite lift_permM !mulg1. Qed.

Lemma lift_permV i j s : (lift_perm i j s)^-1 = lift_perm j i s^-1.
Proof. by apply/eqP; rewrite eq_invg_mul lift_permM mulgV lift_perm1. Qed.

Lemma odd_lift_perm i j s : lift_perm i j s = odd i (+) odd j (+) s :> bool.
Proof.
rewrite -{1}(mul1g s) -(lift_permM _ j) odd_permM.
congr (_ (+) _); last first.
  case: (prod_tpermP s) => ts ->{s} _.
  elim: ts => [|t ts IHts] /=; first by rewrite big_nil lift_perm1 !odd_perm1.
  rewrite big_cons odd_mul_tperm -(lift_permM _ j) odd_permM {}IHts //.
  congr (_ (+) _); rewrite (_ : _ j _ = tperm (lift j t.1) (lift j t.2)).
    by rewrite odd_tperm (inj_eq (@lift_inj _ _)).
  apply/permP=> k; case: (unliftP j k) => [k'|] ->.
    rewrite lift_perm_lift inj_tperm //; exact: lift_inj.
  by rewrite lift_perm_id tpermD // eq_sym neq_lift.
suff{i j s} odd_lift0 (k : 'I_n.+1): lift_perm ord0 k 1 = odd k :> bool.
  rewrite -!odd_lift0 -{2}invg1 -lift_permV odd_permV -odd_permM.
  by rewrite lift_permM mulg1.
elim: {k}(k : nat) {1 3}k (erefl (k : nat)) => [|m IHm] k def_k.
  rewrite (_ : k = ord0) ?lift_perm1 ?odd_perm1 //; exact: val_inj.
have le_mn: m < n.+1 by [rewrite -def_k ltnW]; pose j := Ordinal le_mn.
rewrite -(mulg1 1)%g -(lift_permM _ j) odd_permM {}IHm // addbC.
rewrite (_ : _ k _ = tperm j k); first by rewrite odd_tperm neq_ltn def_k leqnn.
apply/permP=> i; case: (unliftP j i) => [i'|] ->; last first.
  by rewrite lift_perm_id tpermL.
apply: ord_inj; rewrite lift_perm_lift !permE /= eq_sym -if_neg neq_lift.
rewrite fun_if -val_eqE /= def_k /bump ltn_neqAle andbC.
case: leqP => [_ | lt_i'm] /=; last by rewrite -if_neg neq_ltn leqW.
by rewrite add1n eqSS eq_sym; case: eqP.
Qed.

End LiftPerm.


Set Implicit Arguments.
Set Asymmetric Patterns.

Require Import CoqStock.comparable.
Require Import CoqStock.List.

Require Import Reexamined.compare_regex.
Require Import Reexamined.derive.
Require Import Reexamined.nullable.
Require Import Reexamined.regex.
Require Import Reexamined.smart.

(*Using only or_comm, or_assoc and or_idemp
  Brzozowski proved that a notion of RE similarity including only
  r + r = r
  r + s = s + r
  (r + s) + t = r + (s + t)
  is enough to ensure that every RE has only a finite number of dissimilar derivatives.
  Hence, DFA construction is guaranteed to terminate if we use similarity as an approximation for equivalence
  see https://www.ccs.neu.edu/home/turon/re-deriv.pdf
  Regular-expression derivatives reexamined - Scott Owens, John Reppy, Aaron Turon
*)

(* Definition 4.2
   Two input characters are equivalent if for the same regex r
   they produce the same derivative.
*)
Definition eqv_char {A: Type} {cmp: comparable A} (a b: A) (r: regex A) : Prop :=
  derive r a = derive r b.

(* Lemma 4.1 proves that given the equivalent_character property
   it also holds for the combinators.
   If characters a and b are equivalent for regular expressions r and s.
   Then they are also equivalent for the:
   - concat
   - or
   - and
   - star
   - not
   or those regular expressions.
*)
Lemma eqv_concat : forall {A: Type} {cmp: comparable A} (a b: A) (r s: regex A)
  (eqvr: eqv_char a b r) (eqvs: eqv_char a b s),
eqv_char a b (concat r s).
Proof.
(* TODO: Good First Issue *)
Abort.

Lemma eqv_or : forall {A: Type} {cmp: comparable A} (a b: A) (r s: regex A)
  (eqvr: eqv_char a b r) (eqvs: eqv_char a b s),
eqv_char a b (or r s).
Proof.
unfold eqv_char.
intros.
simpl.
rewrite eqvr.
rewrite eqvs.
reflexivity.
Qed.

Lemma eqv_and : forall {A: Type} {cmp: comparable A} (a b: A) (r s: regex A)
  (eqvr: eqv_char a b r) (eqvs: eqv_char a b s),
eqv_char a b (and r s).
Proof.
(* TODO: Good First Issue *)
Abort.

Lemma eqv_star : forall {A: Type} {cmp: comparable A} (a b: A) (r: regex A)
  (eqvr: eqv_char a b r),
eqv_char a b (star r).
Proof.
(* TODO: Good First Issue *)
Abort.

Lemma eqv_not : forall {A: Type} {cmp: comparable A} (a b: A) (r: regex A)
  (eqvr: eqv_char a b r),
eqv_char a b (not r).
Proof.
(* TODO: Good First Issue *)
Abort.


(** This file defines the extended non-negative real type [ennr] representing
a number in the interval #[0, ∞]#. We will define integrals to be over [ennr]
as we are only interested in integrating measures and markov kernels.

This file lifts several useful definitions and theorems from [R], and proves
that [ennr] forms a semiring so that the [ring] tactic will apply.

Some lemmas are left admitted, but they should be straightforward to prove.
*)

Require Import Coq.Unicode.Utf8.
Require Import Coq.Program.Basics.
Require Import Coq.Reals.Reals.
Require Import Coq.micromega.Lra.
Require Import Coq.setoid_ring.Ring_theory.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Minus.

Require Import RRR.Util.Option.

Declare Scope ennr_scope.
Delimit Scope ennr_scope with ennr.
Local Open Scope R.
Local Open Scope ennr_scope.

Export RingSyntax.

Require Export Coq.Reals.Reals.

Infix "≤" := Rle : R_scope.
Infix "≥" := Rge : R_scope.
Notation "r1 ≤ r2 ≤ r3" := (r1 ≤ r2 ∧ r2 ≤ r3) (at level 70, r2 at next level) : R_scope.

Inductive ennr :=
| finite (r : R) (r_pos : 0 ≤ r)
| infinite.
Notation "R⁺" := ennr : ennr_scope.
Notation "∞" := infinite : ennr_scope.

(** * Equality *)

(** Equality between finite [ennr]s is shown to be exactly equality on [R]
through the genererous help of [proof_irrelevance]. It would probably be
possible to prove the important results without relying on proof
irrelevance, but it simplifies things greatly here. *)
Lemma finite_inj r0 r0_pos r1 r1_pos :
r0 = r1 →
finite r0 r0_pos = finite r1 r1_pos.
Proof.
intros.
subst.
f_equal.
apply proof_irrelevance.
Qed.
Hint Immediate finite_inj : core.
Ltac Finite := apply finite_inj; try solve [cbn; ring].

(** * [ennr] is a semiring *)
Program Definition ennr_0 := finite 0 (Rle_refl _).
Program Definition ennr_1 := finite 1 (Rlt_le 0 1 Rlt_0_1).
Notation "0" := ennr_0 : ennr_scope.
Notation "1" := ennr_1 : ennr_scope.

Definition option0 : option R⁺ → R⁺ := fromOption 0.

Definition ennr_plus (a b : R⁺) : R⁺ :=
match a, b with
| finite ra ra_pos, finite rb rb_pos
  => finite (ra + rb) (Rplus_le_le_0_compat _ _ ra_pos rb_pos)
| _, _ => ∞
end.
Infix "+" := ennr_plus : ennr_scope.

Parameter ennr_minus : ∀ (a b : R⁺), R⁺.
Infix "-" := ennr_minus : ennr_scope.

Definition ennr_mult (a b : R⁺) : R⁺ :=
match a, b with
| finite ra ra_pos, finite rb rb_pos
  => finite (ra * rb) (Rmult_le_pos _ _ ra_pos rb_pos)
| finite ra ra_pos, ∞
  => if Req_EM_T 0 ra then 0 else ∞
| ∞, finite rb rb_pos
  => if Req_EM_T 0 rb then 0 else ∞
| ∞, ∞
  => ∞
end.
Infix "*" := ennr_mult : ennr_scope.

Lemma ennr_add_0_l : ∀ n, 0 + n = n.
Proof.
destruct n; auto; Finite.
Qed.

Axiom ennr_minus_0 : ∀ r, r - 0 = r.
Axiom ennr_minus_self : ∀ r, r - r = 0.

Lemma ennr_add_comm : ∀ n m, n + m = m + n.
Proof.
destruct n, m; auto; Finite.
Qed.

Lemma ennr_add_assoc : ∀ n m p, n + (m + p) = (n + m) + p.
Proof.
destruct n, m, p; auto; Finite.
Qed.

Lemma ennr_mul_1_l : ∀ n, 1 * n = n.
Proof.
destruct n; simpl; auto.
- Finite.
- destruct Req_EM_T; simpl; auto.
  lra.
Qed.

Local Hint Extern 1 => match goal with
| [ H : ?r ≠ ?r |- _ ] => contradict H ; reflexivity
end : core.

Lemma ennr_mul_0_l : ∀ n, 0 * n = 0.
Proof.
destruct n; simpl; auto.
- Finite.
- destruct Req_EM_T; simpl; auto.
Qed.

Lemma ennr_mul_comm : ∀ n m, n * m = m * n.
Proof.
destruct n, m; auto; Finite.
Qed.

Lemma ennr_mul_assoc : ∀ n m p, n * (m * p) = (n * m) * p.
Proof.
assert (∀ r0 r1, 0 = r0 * r1 → 0 ≠ r0 → 0 ≠ r1 → False)%R.
+ intros.
  contradict H0.
  replace r0 with ((r0 * r1) * / r1)%R. {
    rewrite <- H.
    ring.
  } {
    rewrite Rmult_assoc.
    rewrite Rinv_r; auto.
    ring.
  }
+ destruct n, m, p;
  repeat (try destruct Req_EM_T; simpl);
  subst;
  auto;
  solve
    [ Finite
    | contradict n; ring
    | contradict n0; ring
    | contradict H; eauto
    ].
Qed.

Lemma ennr_distr_l : ∀ n m p, (n + m) * p = n * p + m * p.
Proof.
destruct n, m, p;
  repeat (try destruct Req_EM_T; simpl);
  subst;
  auto;
  try Finite.
+ contradict n.
  rewrite e.
  ring.
+ contradict n.
  apply Rle_antisym; auto.
  rewrite e.
  replace r with (r + 0)%R at 1 by ring.
  apply Rplus_le_compat; auto.
  apply Rle_refl.
+ contradict n; ring.
Qed.

Lemma ennr_distr_r : ∀ n m p, p * (n + m) = p * n + p * m.
Proof.
  intros.
  rewrite ennr_mul_comm.
  rewrite ennr_distr_l.
  repeat rewrite ennr_mul_comm with (m := p).
  reflexivity.
Qed.

Arguments ennr_plus _ _ : simpl never.
Arguments ennr_mult _ _ : simpl never.

Definition ennr_semiring :=
mk_srt ennr_0 ennr_1 ennr_plus ennr_mult eq
  ennr_add_0_l
  ennr_add_comm
  ennr_add_assoc
  ennr_mul_1_l
  ennr_mul_0_l
  ennr_mul_comm
  ennr_mul_assoc
  ennr_distr_l
.
Add Ring ennr_semiring : ennr_semiring.

Definition ennr_inv (a : R⁺) : R⁺.
Proof.
refine (match a with
| finite ra ra_pos =>
  if Req_EM_T ra 0
  then ∞
  else finite (/ ra) _
| ∞ => finite 0 (Rle_refl 0)
end).
destruct (Rle_lt_or_eq_dec _ _ ra_pos) as [ H | H ].
+ apply Rlt_le.
  apply Rinv_0_lt_compat.
  exact H.
+ lra.
Defined.
Notation "/ x" := (ennr_inv x) : ennr_scope.

Definition ennr_div a b := a * / b.

Lemma ennr_inv_0 : / 0 = ∞.
Proof.
cbn.
destruct (Req_EM_T 0 0) as [ H | H ] ; auto.
Qed.

Lemma ennr_inv_infinity : / ∞ = 0.
Proof.
auto.
Qed.

Lemma ennr_inv_is_zero r : 0 = / r → r = ∞.
Proof.
Admitted.

Lemma ennr_inv_1 : / 1 = 1.
Proof.
simpl.
destruct (Req_EM_T 1 0) as [ H | H ] ; auto.
+ lra.
+ apply finite_inj.
  lra.
Qed.

Lemma ennr_1_neq_0 : ~ 1 = 0.
Proof. intro C. inversion C. lra. Qed.

Lemma ennr_div_def : ∀ p q, ennr_div p q = p * / q.
Proof. reflexivity. Qed.

(** * Misc definitions and facts about [ennr]. *)

Definition ennr_lt (a b : R⁺) : Prop :=
match a, b with
| finite ra _, finite rb _ => ra < rb
| finite _ _, ∞ => True
| ∞, _ => False
end.
Definition ennr_gt a b := ennr_lt b a.
Definition ennr_le a b := ennr_lt a b ∨ a = b.
Definition ennr_ge a b := ennr_gt a b ∨ a = b.
Infix "<" := ennr_lt : ennr_scope.
Infix "≤" := ennr_le : ennr_scope.
Infix ">" := ennr_gt : ennr_scope.
Infix "≥" := ennr_ge : ennr_scope.
Notation "r1 < r2 < r3" := (r1 < r2 ∧ r2 < r3) (at level 70, r2 at next level) : ennr_scope.
Notation "r1 ≤ r2 ≤ r3" := (r1 ≤ r2 ∧ r2 ≤ r3) (at level 70, r2 at next level) : ennr_scope.
Notation "r1 < r2 ≤ r3" := (r1 < r2 ∧ r2 ≤ r3) (at level 70, r2 at next level) : ennr_scope.

Lemma ennr_0_lt_dec (r : R⁺) : {0 < r} + {0 = r}.
Proof.
destruct r; simpl.
+ destruct (Rlt_dec 0 r).
  - left. assumption.
  - right. assert (0 = r)%R.
    1:{ apply Rle_antisym; [ assumption | ]. apply Rnot_lt_le. assumption. }
    subst r. apply finite_inj. reflexivity.
+ left; auto.
Qed.

Lemma ennr_add_0_r : ∀ r, r + 0 = r.
Proof.
intro. ring.
Qed.

Lemma ennr_mul_1_r : ∀ r, r * 1 = r.
Proof.
intro. ring.
Qed.

Axiom ennr_minus_distr_l : ∀ n m p, m ≤ n → (n - m) * p = n * p - m * p.
Axiom ennr_minus_distr_r : ∀ n m p, m ≤ n → p * (n - m) = p * n - p * m.

Lemma ennr_lt_dec (a b : R⁺) : {a < b} + {¬ a < b}.
Proof.
destruct a, b; simpl; auto.
apply Rgt_dec.
Qed.

Lemma ennr_gt_dec (a b : R⁺) : {a > b} + {¬ a > b}.
Proof.
destruct a, b; simpl; auto.
apply Rgt_dec.
Qed.

Lemma ennr_le_0 (r : R⁺) : 0 ≤ r.
Proof.
Admitted.

Lemma ennr_le_0_is_0 (r : R⁺) : r ≤ 0 → 0 = r.
Proof.
Admitted.

Lemma ennr_le_refl (r : R⁺) : r ≤ r.
Proof.
right ; reflexivity.
Qed.

Lemma ennr_lt_trans (r1 r2 r3 : R⁺) :
r1 < r2 → r2 < r3 → r1 < r3.
Proof.
Admitted.

Lemma ennr_le_trans (r1 r2 r3 : R⁺) :
r1 ≤ r2 → r2 ≤ r3 → r1 ≤ r3.
Proof.
Admitted.

Lemma ennr_le_lt_trans (r1 r2 r3 : R⁺) :
r1 ≤ r2 → r2 < r3 → r1 < r3.
Proof.
Admitted.

Lemma ennr_lt_le_trans (r1 r2 r3 : R⁺) :
r1 < r2 → r2 ≤ r3 → r1 < r3.
Proof.
Admitted.

Lemma ennr_lt_irrefl r : ¬ r < r.
Admitted.

Lemma ennr_le_not_le (r1 r2 : R⁺) : r1 ≤ r2 ↔ (¬ r2 < r1).
Proof.
Admitted.

Lemma ennr_lt_not_eq r1 r2 : r1 < r2 → r1 ≠ r2.
Proof.
Admitted.

Lemma ennr_mul_0_r r : r * 0 = 0.
Proof.
Admitted.

Lemma ennr_add_le_compat_1 r1 r2 : r1 ≤ r1 + r2.
Proof.
Admitted.

Lemma ennr_add_le_compat_2 r1 r2 : r2 ≤ r1 + r2.
Proof.
Admitted.

Lemma ennr_add_le_compat_l r r1 r2 : r1 ≤ r2 → r + r1 ≤ r + r2.
Proof.
Admitted.

Lemma ennr_add_le_compat_r r r1 r2 : r1 ≤ r2 → r1 + r ≤ r2 + r.
Proof.
Admitted.

Lemma ennr_add_le_compat r1 r2 r3 r4 : r1 ≤ r2 → r3 ≤ r4 → r1 + r3 ≤ r2 + r4.
Proof.
Admitted.

Axiom ennr_plus_minus :
∀ r1 r2 r3, r2 ≤ r1 → r1 = r2 + r3 <-> r1 - r2 = r3.

Lemma ennr_minus_le_compat_r r r1 r2 :
r1 ≤ r → r2 ≤ r → r2 ≤ r1 → r - r1 ≤ r - r2.
Proof.
Admitted.

Lemma ennr_minus_le_compat r1 r1' r2 r2' :
r1 ≤ r1' → r2 ≤ r2' → r2 ≤ r1 → r1' ≤ r2' → r1' - r1 ≤ r2' - r2.
Proof.
Admitted.

Lemma ennr_inv_involutive r : / / r = r.
Proof.
Admitted.

Lemma ennr_inv_0_lt_compat r : 0 < r → / r < ∞.
Proof.
Admitted.

Lemma ennr_inv_finite_compat r : r < ∞ → 0 < / r.
Proof.
Admitted.

Lemma ennr_inv_0_lt_finite_compat r : 0 < r → r < ∞ → 0 < / r < ∞.
Proof.
Admitted.

Lemma ennr_mult_0_lt_compat r1 r2 : 0 < r1 * r2 ↔ 0 < r1 ∧ 0 < r2.
Proof.
Admitted.

Lemma ennr_mult_le_compat_l r r1 r2 : r1 ≤ r2 → r * r1 ≤ r * r2.
Proof.
Admitted.

Lemma ennr_mult_le_compat_r r r1 r2 : r1 ≤ r2 → r1 * r ≤ r2 * r.
Proof.
Admitted.

Lemma ennr_mult_le_compat r1 r2 r3 r4 : r1 ≤ r2 → r3 ≤ r4 → r1 * r3 ≤ r2 * r4.
Proof.
Admitted.

Lemma ennr_mult_le_1_compat r1 r2 : r1 ≤ 1 → r2 ≤ 1 → r1 * r2 ≤ 1.
Proof.
Admitted.

Lemma ennr_add_eq_compat_r r r1 r2 : r1 = r2 <-> r1 + r = r2 + r.
Proof.
Admitted.

Lemma ennr_mult_eq_compat_l r r1 r2 : r1 = r2 → r * r1 = r * r2.
Proof.
Admitted.

Lemma ennr_mult_integral r1 r2 : r1 * r2 = 0 → r1 = 0 ∨ r2 = 0.
Proof.
Admitted.

Lemma ennr_le_antisym r1 r2 : r1 ≤ r2 → r2 ≤ r1 → r1 = r2.
Proof.
Admitted.

Lemma ennr_le_infinity r : r ≤ ∞.
Proof.
Admitted.

Lemma ennr_mult_r_pos_lt_infinity_inv r1 r2 : r1 * r2 < ∞ → 0 < r2 → r1 < ∞.
Proof.
Admitted.

Lemma ennr_mul_infinity_l r : 0 < r → ∞ * r = ∞.
Proof.
Admitted.

Lemma ennr_mul_infinity_r r : 0 < r → r * ∞ = ∞.
Proof.
rewrite ennr_mul_comm.
apply ennr_mul_infinity_l.
Qed.

Lemma ennr_mult_inv_r_finite r : 0 < r → r < ∞ → r * / r = 1.
Proof.
Admitted.

Lemma ennr_mult_inv_l_finite r : 0 < r → r < ∞ → (/ r) * r = 1.
Proof.
Admitted.

Lemma ennr_mult_inv_r_le_1 r : r * / r ≤ 1.
Proof.
Admitted.

Lemma ennr_mult_inv_le_compat r1 r2 : r2 ≤ r1 → / r1 ≤ / r2.
Proof.
Admitted.

Lemma ennr_mult_inv_le_1_compat r1 r2 : r1 ≤ r2 → r1 * / r2 ≤ 1.
Proof.
Admitted.

Lemma ennr_mult_0_lt r1 r2 : 0 < r1 → 0 < r2 → 0 < r1 * r2.
Proof.
destruct r1 as [r1 r1_pos|], r2 as [r2 r2_pos|]; simpl; intros Hr1 Hr2.
+ prove_sup; lra.
+ rewrite ennr_mul_infinity_r; auto.
+ rewrite ennr_mul_infinity_l; auto.
+ trivial.
Qed.

Lemma ennr_mult_finite r1 r2 : r1 < ∞ → r2 < ∞ → r1 * r2 < ∞.
Proof.
destruct r1 as [r1 r1_pos|], r2 as [r2 r2_pos|]; simpl; intros Hr1 Hr2.
+ trivial.
+ exfalso; trivial.
+ exfalso; trivial.
+ trivial.
Qed.

Lemma ennr_mult_0_lt_and_finite r1 r2 :
0 < r1 < ∞ → 0 < r2 < ∞ → 0 < r1 * r2 < ∞.
Proof.
intros Hr1 Hr2.
destruct Hr1, Hr2.
split.
+ apply ennr_mult_0_lt; assumption.
+ apply ennr_mult_finite; assumption.
Qed.

Lemma ennr_0_lt_compat_mult_infinity r1 r2 :
(0 < r1 → 0 < r2) → r1 ≤ ∞ * r2.
Proof.
Admitted.

Lemma ennr_mult_infinity_compat_0_lt r1 r2 :
r1 ≤ ∞ * r2 → 0 < r1 → 0 < r2.
Proof.
intros H H1.
destruct (ennr_0_lt_dec r1) as [|Q].
+ destruct (ennr_0_lt_dec r2) as [H2|H2].
  - trivial.
  - exfalso.
    rewrite <- H2, ennr_mul_comm, ennr_mul_0_l in H.
    assert (0 = r1) as P.
    1:{ eapply ennr_le_antisym ; [ apply ennr_le_0 | apply H ]. }
    rewrite <- P in H1.
    apply ennr_lt_irrefl in H1 ; trivial.
+ exfalso.
  rewrite <- Q in H1.
  apply ennr_lt_irrefl in H1 ; trivial.
Qed.

Lemma ennr_0_eq_compat_mult_infinity r1 r2 :
(0 = r2 → 0 = r1) → r1 ≤ ∞ * r2.
Proof.
Admitted.

Lemma ennr_mult_infinity_compat_0_eq r1 r2 :
r1 ≤ ∞ * r2 → 0 = r2 → 0 = r1.
Proof.
Admitted.

Lemma ennr_inv_lt_infinity r :
0 < r → / r < ∞.
Proof.
Admitted.

Lemma ennr_inv_mult_distr_finite r1 r2 :
r1 < ∞ → r2 < ∞ → / (r1 * r2) = / r1 * / r2.
Proof.
Admitted.

Fact ennr_inv_useful_fact (A B A' B' c c' : R⁺) :
A' ≤ B' → A ≤ B →
B - A ≤ B' - A' →
B' + c' ≤ B + c →
B + c < ∞ →
(A' + c') * / (B' + c') ≤ (A + c) * / (B + c).
Proof.
Admitted.

Lemma Rinterval_dec r1 r2 r : ({r1 ≤ r ≤ r2} + {¬ r1 ≤ r ≤ r2})%R.
Proof.
Admitted.

Lemma Rinterval_dec' r1 r2 r: ({r1 < r ≤ r2} + {¬ r1 < r ≤ r2})%R.
Proof.
Admitted.

Definition is_upper_bound (E: R⁺ → Prop) r' := ∀ r, E r → r ≤ r'.
Definition is_lub (E: R⁺ → Prop) r' :=
is_upper_bound E r' ∧ (∀ r, is_upper_bound E r → r' ≤ r).
Definition is_lower_bound (E: R⁺ → Prop) r' := ∀ r, E r → r' ≤ r.
Definition is_glb (E: R⁺ → Prop) r' :=
is_lower_bound E r' ∧ (∀ r, is_lower_bound E r → r ≤ r').

Parameter sup : ∀ f : nat → R⁺, R⁺.
Axiom sup_is_lub : ∀ f, is_lub (λ r, ∃ n, r = f n) (sup f).
Parameter inf : ∀ f : nat → R⁺, R⁺.
Axiom inf_is_glb : ∀ f, is_glb (λ r, ∃ n, r = f n) (inf f).

Parameter has_lim : ∀ f : nat → R⁺, Prop.
Parameter lim : ∀ f : nat → R⁺, has_lim f → R⁺.

Definition monotone (f : nat → R⁺) : Prop :=
∀ N' N, (N' <= N)%nat → f N' ≤ f N.
Definition antitone (f : nat → R⁺) : Prop :=
∀ N' N, (N' <= N)%nat → f N ≤ f N'.

Lemma antitone_add_compat : ∀ f g,
antitone f → antitone g →
antitone (λ n : nat, f n + g n).
Proof.
  unfold antitone. intros.
  eapply ennr_add_le_compat; auto.
Qed.

Lemma antitone_mult_l : ∀ c f,
antitone f → antitone (λ n : nat, c * f n).
Proof.
  unfold antitone. intros.
  eapply ennr_mult_le_compat_l.
  auto.
Qed.

Lemma monotone_add_compat : ∀ f g,
monotone f → monotone g →
monotone (λ n : nat, f n + g n).
Proof.
  unfold monotone. intros.
  eapply ennr_add_le_compat; auto.
Qed.

Lemma monotone_mult_l : ∀ c f,
monotone f → monotone (λ n : nat, c * f n).
Proof.
  unfold monotone. intros.
  eapply ennr_mult_le_compat_l.
  auto.
Qed.

Ltac monotone :=
  match goal with
  | [|- antitone (λ n : nat, _ + _)] => apply antitone_add_compat
  | [|- antitone (λ n : nat, _ * _)] => apply antitone_mult_l
  | [|- monotone (λ n : nat, _ + _)] => apply monotone_add_compat
  | [|- monotone (λ n : nat, _ * _)] => apply monotone_mult_l
  | [|- _] => idtac
  end.

Axiom sup_S :
∀ (f : nat → R⁺), f O ≤ f (S O) → sup f = sup (λ n, f (S n)).
Axiom inf_S :
∀ (f : nat → R⁺), f (S O) ≤ f O → inf f = inf (λ n, f (S n)).

Axiom sup_monotone :
∀ (f : nat → R⁺), monotone f → ∀ k, sup f = sup (λ n, f (n + k)%nat).
Axiom inf_antitone :
∀ (f : nat → R⁺), antitone f → ∀ k, inf f = inf (λ n, f (n + k)%nat).

Axiom sup_extensionality :
∀ (f g : nat → R⁺), (∀ n, f n = g n) → sup f = sup g.
Axiom inf_extensionality :
∀ (f g : nat → R⁺), (∀ n, f n = g n) → inf f = inf g.

Axiom sup_of_constant :
∀ (f : nat → R⁺) (r : R⁺), (∀ n, f n = r) →
sup f = r.

Axiom inf_of_constant :
∀ (f : nat → R⁺) (r : R⁺), (∀ n, f n = r) →
inf f = r.

Axiom sup_of_constant_minus :
∀ (f : nat → R⁺) (r : R⁺),
sup (λ n, r - f n) = r - inf f.

Axiom sup_of_constant_plus :
∀ (f : nat → R⁺) (r : R⁺),
sup (λ n, r + f n) = r + sup f.

Axiom sup_linear_mult_r :
∀ (f : nat → R⁺) (r : R⁺), (r = ∞ → 0 < sup f) →
sup (λ n, f n * r) = sup f * r.

Axiom sup_linear_mult_l :
∀ (f : nat → R⁺) (r : R⁺), (r = ∞ → 0 < sup f) →
sup (λ n, r * f n) = r * sup f.

Axiom inf_linear_mult_r :
∀ (f : nat → R⁺) (r : R⁺), (0 = r → inf f < ∞) →
inf (λ n, f n * r) = inf f * r.

Axiom inf_linear_mult_l :
∀ (f : nat → R⁺) (r : R⁺), (r = ∞ → 0 < inf f) →
inf (λ n, r * f n) = r * inf f.

Axiom monotone_has_lim :
∀ (f : nat → R⁺), monotone f → has_lim f.

Axiom antitone_has_lim :
∀ (f : nat → R⁺), antitone f → has_lim f.

Axiom diff_has_lim :
∀ (f g : nat → R⁺), (∀ n, g n ≤ f n) →
has_lim f → has_lim g → has_lim (λ n, f n - g n).

Axiom sum_has_lim :
∀ (f g : nat → R⁺),
has_lim f → has_lim g → has_lim (λ n, f n + g n).

Axiom prod_has_lim :
∀ (f g : nat → R⁺),
has_lim f → has_lim g → has_lim (λ n, f n * g n).

Axiom inv_has_lim :
∀ (f : nat → R⁺), has_lim f → has_lim (λ n, / f n).

Axiom sup_is_lim :
∀ (f : nat → R⁺) (P : monotone f),
sup f = lim f (monotone_has_lim f P).

Axiom sup_is_lim' :
∀ (f : nat → R⁺) (P : monotone f) (H : has_lim f),
sup f = lim f H.

Axiom inf_is_lim :
∀ (f : nat → R⁺) (P : antitone f),
inf f = lim f (antitone_has_lim f P).

Axiom inf_is_lim' :
∀ (f : nat → R⁺) (P : antitone f) (H : has_lim f),
inf f = lim f H.

Axiom lim_of_sum :
∀ (f g : nat → R⁺) (Hf : has_lim f) (Hg : has_lim g)
  (Hsum : has_lim (λ n, f n + g n)),
lim (λ n, f n + g n) Hsum = lim f Hf + lim g Hg.

Axiom lim_of_difference :
∀ (f g : nat → R⁺) (_ : ∀ n, g n ≤ f n) (Hf : has_lim f) (Hg : has_lim g)
  (Hdiff : has_lim (λ n, f n - g n)),
lim (λ n, f n - g n) Hdiff = lim f Hf - lim g Hg.

Axiom lim_of_product :
∀ (f g : nat → R⁺) (Hf : has_lim f) (Hg : has_lim g)
  (Hprod : has_lim (λ n, f n * g n)),
(0 = lim f Hf → lim g Hg < ∞) → (0 = lim g Hg → lim f Hf < ∞) →
lim (λ n, f n * g n) Hprod = lim f Hf * lim g Hg.

Axiom lim_of_inv :
∀ (f : nat → R⁺) (H : has_lim f),
lim (λ n, / f n) (inv_has_lim f H) = / lim f H.

Axiom lim_of_inv' :
∀ (f : nat → R⁺) (H : has_lim f) (Hinv : has_lim (λ n, / f n)),
lim (λ n, / f n) Hinv = / lim f H.

Axiom lim_extensionality :
∀ (f g : nat → R⁺) (Hf : has_lim f) (Hg : has_lim g), (∀ n, f n = g n) →
lim f Hf = lim g Hg.

Axiom lim_extensionality_le :
∀ (f g : nat → R⁺) (Hf : has_lim f) (Hg : has_lim g), (∀ n, f n ≤ g n) →
lim f Hf ≤ lim g Hg.

Lemma sup_le_inf :
∀ (f g : nat → R⁺), monotone f → antitone g →
(∀ n, f n ≤ g n) → sup f ≤ inf g.
Proof.
intros f g Hf Hg Hfg.
specialize (sup_is_lub f) as P.
destruct P as [_ P]. apply P.
unfold is_upper_bound. intros p [m Hp]. subst p.
specialize (inf_is_glb g) as Q.
destruct Q as [_ Q]. apply Q.
unfold is_lower_bound. intros q [n Hq]. subst q.
destruct (le_dec m n).
+ apply ennr_le_trans with (r2 := f n). 1:{ apply Hf. omega. } apply Hfg.
+ apply ennr_le_trans with (r2 := g m). 2:{ apply Hg. omega. } apply Hfg.
Qed.


(* Software Foundations *)
(* Exercice 2 stars, total_relation *)

Inductive total_relation: nat -> nat -> Prop :=
|tr: forall n m, total_relation n m.


Set Printing Universes.
Set Universe Polymorphism.

(* Polymorhpic equality *)

Inductive heq {A : Type} (x : A) : A -> Type :=
  heq_refl : heq x x.

Notation "A = B" := (heq A B) (at level 70).

(* Fun Ext *)

Axiom fun_ext : forall {A B} {f g : A -> B}, (forall x, heq (f x) (g x)) -> heq f g.
Axiom dep_fun_ext : forall {A B} {f g : forall a : A, B a}, (forall a, heq (f a) (g a)) -> heq f g.

(* transitivity of heq *)
Lemma heq_trans {A} : forall a b c : A, heq a b -> heq b c -> heq a c.
Proof.
  intros a b c eqab eqbc.
  destruct eqab.
  exact eqbc.
Defined.

Lemma heq_sym {A} : forall a b : A, heq a b -> heq b a.
Proof.
  intros a b eq.
  now destruct eq.
Defined.

Lemma hf_equal : forall {A B : Type} (f : A -> B) {x y : A}, heq x y -> heq (f x) (f y).
Proof.
  intros A B f x y h.
  now destruct h.
Defined.

(* Sigma *)

Notation idmap := (fun x => x).

Notation compose := (fun g f x => g (f x)).
Notation " g 'o' f " := (compose g f) (at level 40, left associativity)
: core_scope.

Set Primitive Projections.
Record sig {A} (P : A -> Type) := exist { π1 : A ; π2 : P π1 }.
Arguments exist {_} _ _ _.
Scheme sig_rect := Induction for sig Sort Type.

Notation "{ x | P }" := (sig (fun x => P)) (only parsing) : type_scope.
Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) (only parsing) :
type_scope.
Notation "'exists' x .. y , P"
 := (sig (fun x => .. (sig (fun y => P)) ..))
      (at level 200, x binder, y binder, right associativity) : type_scope.
Notation "∃ x .. y , P"
 := (sig (fun x => .. (sig (fun y => P)) ..))
      (at level 200, x binder, y binder, right associativity) : type_scope.
Notation "( x ; y )" := (exist _ x y) : core_scope.
Notation "( x ; y ; z )" := (x ; (y ; z)) : core_scope.
(* Notation "( x ; y ; .. ; z )" := (exist _ .. (exist _ x y) .. z) :
core_scope. *)
Notation pr1 := (π1 _).
Notation pr2 := (π2 _).
Notation "x .1" := (π1 _ x) (at level 3, format "x '.1'") : core_scope.
Notation "x .2" := (π2 _ x) (at level 3, format "x '.2'") : core_scope.

Definition prod A B := sig (fun _ : A => B).
Notation "A * B" := (prod A B) (at level 40, left associativity) :
type_scope.
Notation "A × B" := (prod A B) (at level 60, right associativity) :
type_scope.
Definition pair {A B} : A -> B -> A × B := fun x y => (x; y).
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
Definition fst {A B} : A × B -> A := pr1.
Definition snd {A B} : A × B -> B := pr2.

Definition iff (A B : Type) := (A -> B) × (B -> A).
Notation "A <-> B" := (iff A B)%type : type_scope.

Definition transitive_iff {A B C}
 : A <-> B -> B <-> C -> A <-> C.
Proof.
 intros H1 H2. split; firstorder.
Defined.


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

Require Import Decidable.
Require Eqdep_dec.
Require Import Le Lt.
Open Local Scope nat_scope.

Implicit Types m n x y : nat.

Theorem O_or_S : forall n, {m : nat | S m = n} + {0 = n}.
Proof.
  induction n.
  auto.
  left; exists n; auto.
Defined.

Theorem eq_nat_dec : forall n m, {n = m} + {n <> m}.
Proof.
  induction n; destruct m; auto.
  elim (IHn m); auto.
Defined.

Hint Resolve O_or_S eq_nat_dec: arith.

Theorem dec_eq_nat : forall n m, decidable (n = m).
  intros x y; unfold decidable in |- *; elim (eq_nat_dec x y); auto with arith.
Defined.

Definition UIP_nat:= Eqdep_dec.UIP_dec eq_nat_dec.

Lemma le_unique: forall m n (h1 h2: m <= n), h1 = h2.
Proof.
fix 3.
refine (fun m _ h1 => match h1 as h' in _ <= k return forall hh: m <= k, h' = hh
  with le_n => _ |le_S i H => _ end).
refine (fun hh => match hh as h' in _ <= k return forall eq: m = k,
  le_n m = match eq in _ = p return m <= p -> m <= m with |eq_refl => fun bli => bli end h' with
    |le_n => fun eq => _ |le_S j H' => fun eq => _ end eq_refl).
rewrite (UIP_nat _ _ eq eq_refl). reflexivity.
subst m. destruct (Lt.lt_irrefl j H').
refine (fun hh => match hh as h' in _ <= k return match k as k' return m <= k' -> Prop
  with |0 => fun _ => True |S i' => fun h'' => forall H':m <= i', le_S m i' H' = h'' end h'
    with |le_n => _ |le_S j H2 => fun H' => _ end H).
destruct m. exact I. intros; destruct (Lt.lt_irrefl m H').
f_equal. apply le_unique.
Qed.


Require Import KindProperties.
Require Import LanguageUtil.
Require Import Properties.
Require Import BoxReasoning.

Theorem gen_head_kind_uniqueness : forall Γ e A k,
    Γ ⊢ e : A -> forall n B, head_kind A k n -> Γ ⊢ e : B -> head_kind B k n.
Proof.
  intros Γ e A k Hsub.
  dependent induction Hsub; intros n' B' Hk Hsubr.
  - eapply head_kind_var_consistent; eauto.
  - inversion Hk.
  - apply star_type_inversion in Hsubr. subst. assumption.
  - apply int_of_star in Hsubr. subst. assumption.
  - dependent induction Hsubr.
    + inversion Hk. subst. constructor. pick fresh x.
      eapply head_kind_invert_subst_var.
        eapply H2 with x; eauto.
    + eauto 3 using head_kind_sub_r.
  - dependent induction Hsubr.
    + pick fresh x. apply H2 with x; auto 2.
    + eauto 3 using head_kind_sub_r.
  - dependent induction Hsubr.
    + apply head_kind_invert_subst in Hk as [|].
      * destruct k.
        ++ eapply head_kind_star_of_box in Hsubr1; eauto 2. subst.
           now apply pi_box_impossible in Hsubr2.
        ++ now apply head_kind_box_never_welltype with (n := n') in Hsubr1.
      * assert (head_kind (e_pi A0 B0) k (S n')) by eauto 3.
        inversion H2. subst.
        now apply head_kind_subst.
    + eauto 3 using head_kind_sub_r.
  - dependent induction Hsubr.
    + inversion Hk; constructor.
    + eauto 3 using head_kind_sub_r.
  - dependent induction Hsubr.
    + assumption.
    + eauto 3 using head_kind_sub_r.
  - dependent induction Hsubr. assumption. eauto 3 using head_kind_sub_r.
  - destruct k.
    + conclude_type_refl Hsub2. inversion H.
      box_reasoning. assert False by eauto using expr_of_box_never_be_reduced'.
      contradiction.
    + conclude_type_refl Hsub2. inversion H.
      assert False by eauto using box_never_be_reduced.
      contradiction.
  - dependent induction Hsubr; eauto 3 using head_kind_sub_r.
  - dependent induction Hsubr; eauto 3 using head_kind_sub_r.
  - dependent induction Hsubr; eauto 3 using head_kind_sub_r.
  - eauto 3 using head_kind_sub_l.
Qed.

Corollary gen_kind_uniqueness : forall Γ e A k,
    Γ ⊢ e : e_kind k -> Γ ⊢ e : A -> A = e_kind k.
Proof.
  intros.  assert (head_kind A k 0).
  apply gen_head_kind_uniqueness with Γ e (e_kind k); eauto.
  now inversion H1.
Qed.

Corollary kind_uniqueness : forall Γ e k1 k2,
    Γ ⊢ e : e_kind k1 -> Γ ⊢ e : e_kind k2 -> k1 = k2.
Proof.
  intros.
  assert (e_kind k1 = e_kind k2) by
    (eapply gen_kind_uniqueness; eauto).
  now inversion H1.
Qed.


Require Import FSetInterface.
Require Import OrderedType.

Module makeEqual_fun (E:OrderedType) (SF:Sfun E).

  Theorem eq_Equal: forall ag ag',
    SF.eq ag ag' <-> SF.Equal ag ag'.
  Proof.
    intros; split;intros; eapply H.
  Qed.
  Hint Resolve eq_Equal.

End makeEqual_fun.

Module makeEqual (S:S).

  Include (makeEqual_fun S.E S).

End makeEqual.


Require Import ssreflect.
Require Import Coq.Classes.EquivDec.
Require Import Metalib.Metatheory.

Require Import Coq.Structures.Orders.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Program.Equality.

Require Import Qtt.tactics.
Require Import Qtt.usage.
Require Import Qtt.dctx.

(* ----------------------------------------------------------------------- *)
(** **    Lemmas about the context, reflecting the usage structure         *)

(* ----------------------------------------------------------------- *)
(** *** ctx_sub properties *)

Lemma ctx_sub_refl : forall {A} {D:list (atom * A)} {G}, ctx D G -> ctx_sub D G G.
Proof. induction D;
       move => G1 h; inversion h; subst. auto.
       econstructor; auto. reflexivity.
Qed.

Lemma ctx_sub_trans : forall {A} {G2} {D:list(atom * A)} {G1 G3}, ctx_sub D G1 G2 -> ctx_sub D G2 G3 ->
  ctx_sub D G1 G3.
Proof.
  move=> A G2 D. move: G2.
  induction D; intros; inversion H0; inversion H; subst; auto.
  invert_equality.
  econstructor; auto.
  transitivity q1; auto.
  eapply IHD; eauto.
Qed.

Instance cst : forall {A}{D:list (atom * A)}, Transitive (ctx_sub D).
intros. eauto using ctx_sub_trans.
Qed.

(* Interactions with association lists *)

Lemma dom_ctx_sub : forall {A} {D:list(atom*A)} {G1 G2}, ctx_sub D G1 G2 -> dom G1 = dom G2.
Proof. move => A D G1 G2 h. induction h; simpl; auto.
       all: rewrite IHh.
       all: auto.
Qed.

Lemma uniq_ctx_sub : forall {A} {D:list(atom*A)}{ G1 G2}, ctx_sub D G1 G2 -> uniq G1 <-> uniq G2.
Proof.
  move=> A D G1 G2 h. induction h; split; auto;
  move => h1; inversion h1; subst.
  + erewrite dom_ctx_sub in H5; eauto.
  econstructor; eauto.
  tauto.
  + erewrite <- dom_ctx_sub in H5; eauto.
  econstructor; eauto.
  tauto.
Qed.

Lemma ctx_sub_app {A} {D1 D2 : list (atom *A)}{G1 G2 G3 G4} :
  ctx_sub D1 G1 G2 -> ctx_sub D2 G3 G4 ->   uniq (D1 ++ D2) ->
  ctx_sub (D1 ++ D2) (G1 ++ G3) (G2 ++ G4).
Proof.
  induction 1. simpl. auto.
  all: intros h U; simpl_env; inversion U; subst.
  all: econstructor; eauto.
Qed.

(* decomposition *)

Lemma split_ctx_sub {A}{D1:list (atom*A)} : forall {G G1 D2 G4 G2},
  ctx D1 G -> ctx D1 G1
  -> ctx_sub (D1 ++ D2) (G ++ G4) (G1 ++ G2)
  -> ctx_sub D1 G G1 /\ ctx_sub D2 G4 G2.
Proof.
  induction D1; intros.
  inversion H; inversion H0.
  subst. simpl in *. split; auto.
  inversion H; inversion H0; inversion H1. subst.
  simpl_env in *.
  repeat invert_equality.
  edestruct IHD1. 3: { eauto. } eclarify_ctx. eclarify_ctx.
  econstructor; eauto.
Qed.

Lemma ctx_sub_app_split_r {A} {D:list (atom*A)} : forall {G G0 G3},
  ctx_sub D G (G0 ++ G3) ->
  exists D1 D2 G1 G2, G = G1 ++ G2 /\ D = D1 ++ D2 /\ ctx_sub D1 G1 G0 /\ ctx_sub D2 G2 G3.
Proof.
  induction D.
  + intros G G0 G3 h. inversion h. exists nil. exists nil.
    exists nil. exists nil.
    repeat split; auto.
    destruct G0; destruct G3; simpl_env in *; inversion h.
    eauto.
    destruct G0; destruct G3; simpl_env in *; inversion h.
    eauto.
  + intros G G0 G3 h.
    destruct G0; simpl_env in *; inversion h; subst.
    - clear h.
      specialize (IHD G1 nil G2 ltac:(eauto)).
      move: IHD => [D1 [D2 [G1' [G2' [h1 [h2 [h3 h4]]]]]]].
      inversion h3. subst.
      exists nil.
      exists (x ~ a0 ++ D2).
      exists nil.
      exists (x ~ (q1,a0) ++ G2').
      simpl_env. split; auto.
    - clear h.
      specialize (IHD G1 G0 G3 ltac:(eauto)).
      move: IHD => [D1 [D2 [G1' [G2' [h1 [h2 [h3 h4]]]]]]].
      exists (x ~ a0 ++ D1).
      exists D2.
      exists (x ~ (q1, a0) ++ G1').
      exists G2'.
      subst.
      simpl_env.
      repeat split; auto.
Qed.

Lemma three_ctx_sub {A}{D:list(atom*A)} : forall {G1 x q1 s G2 G},
    ctx_sub D (G1 ++ x ~ (q1, s) ++ G2) G ->
    exists D1, exists D2, exists G1', exists G2', exists q2, D = D1 ++ x ~ s ++ D2 /\  G = G1' ++ x ~ (q2, s) ++ G2' /\
                        ctx_sub D1 G1 G1' /\ (q1 <= q2) /\ ctx_sub D2 G2 G2'.
Proof.
  induction D; intros.
  + match goal with [ H : ctx_sub _ _ _ |- _ ] => inversion H end.
    destruct G1; simpl in *; discriminate.
  + destruct G1 as [|[y B] G1'].
    ++ simpl in H. inversion H; subst.
       exists nil. eexists D. exists nil. exists G0. exists q2. simpl_env. auto.
    ++ inversion H. subst.
       simpl_env in *.
       specialize (IHD _ _ _ _ _ _ H7).
       move: IHD => [D1' [D2' [G1'' [G2'' [q2' [E1 [S1 [S2 [S3 S4]]]]]]]]].
       subst.
       exists (y ~ a0 ++ D1'). eexists.
       exists (y ~ (q2, a0) ++ G1''). eexists. eexists.
       simpl_env.
       split; eauto.
Qed.

Ltac destruct_ctx_sub :=
    let D1 := fresh "D" in
    let D2 := fresh "D" in
    let G1' := fresh "G" in
    let G2' := fresh "G" in
    let E1  := fresh "E" in
    let S1  := fresh "S" in
    let S2  := fresh "S" in
    let S3  := fresh "S" in
    let q2  := fresh "q" in
    match goal with
      | [H : ctx_sub ?D ?G (?G1 ++ ?G2) |- _ ] =>
        apply ctx_sub_app_split_r in H;
        move: H => [D1 [D2 [G1' [G2' [E1 [S1 [S2 S3]]]]]]];
        subst G
     | [H : ctx_sub ?D (?G1 ++ ?x ~ (?q,?A) ++ ?G2) ?G |- _ ] =>
        apply three_ctx_sub in H;
        move: H => [D1 [D2 [G1' [G2' [q2 [E1 [S1 [S2 [S3 S4]]]]]]]]];
        subst G
     | [ H : ctx_sub ?D ?G3 ([(?x, ?s)] ++ ?G2) |- _ ] =>
       inversion H; subst; clear H
     | [ H : ctx_sub ?D ?G3 ([(?x, ?s)]) |- _ ] =>
       inversion H; subst; clear H
     | [ H : ctx_sub ?D ?G3 nil |- _ ] =>
       inversion H; subst; clear H
    end.


Require Import Coq.Setoids.Setoid.
Require Import VST.msl.Extensionality.

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

Copied From Coq.Logic.JMeq.

No longer involving JMeq_eq, which is potentially inconsistenty with homotopy
type theory.

TODO: let reflexivity, symmetry and transitivity work again.

******************************************)

Definition JMeq {A:Type} (x:A) {B:Type} (y: B): Prop :=
  {H: @eq Type A B | @eq_rect Type A (fun T: Type => T) x B H = y}.

Lemma JMeq_refl: forall {A: Type} (x: A), JMeq x x.
Proof.
  intros.
  exists eq_refl.
  rewrite <- eq_rect_eq.
  auto.
Qed.
#[export] Hint Resolve JMeq_refl : core.

Lemma JMeq_sym : forall {A: Type} {B:Type} {x:A} {y:B}, JMeq x y -> JMeq y x.
Proof.
  intros.
  destruct H as [?H ?H].
  exists (eq_sym H).
  rewrite <- H0.
  destruct H.
  simpl.
  apply eq_refl.
Qed.
#[export] Hint Immediate JMeq_sym : core.

Lemma JMeq_trans :
 forall {A: Type} {B: Type} {C:Type} {x:A} {y:B} {z:C}, JMeq x y -> JMeq y z -> JMeq x z.
Proof.
  intros.
  destruct H as [?H ?H], H0 as [?H ?H].
  exists (eq_trans H H0).
  destruct H, H0.
  rewrite <- H2, <- H1.
  reflexivity.
Qed.

Lemma JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y.
Proof.
  intros.
  destruct H.
  rewrite <- eq_rect_eq in e.
  exact e.
Qed.

Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'.
inversion H'.
subst.
 case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_congr :
 forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y.
Proof.
intros A x B f y H; case JMeq_eq with (1 := H); trivial.
Qed.

(** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *)

Require Import Coq.Logic.Eqdep.

Lemma JMeq_eq_dep_id :
 forall (A:Type) (B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X:Type => X) A x B y.
Proof.
destruct 1.
subst.
rewrite <- eq_rect_eq.
apply eq_dep_intro.
Qed.

Lemma eq_dep_id_JMeq :
 forall (A: Type) (B:Type) (x:A) (y:B), eq_dep Type (fun X:Type => X) A x B y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

(** [eq_dep U P p x q y] is strictly finer than [JMeq (P p) x (P q) y] *)

Lemma eq_dep_JMeq :
 forall (U: Type) (P: U -> Type) p x q y, eq_dep U P p x q y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

Lemma eq_dep_strictly_stronger_JMeq :
 exists (U: Type) (P: U -> Type) p q x y, JMeq x y /\ ~ eq_dep U P p x q y.
Proof.
exists bool. exists (fun _ => True). exists true. exists false.
exists I. exists I.
split.
trivial.
intro H.
assert (true=false) by (destruct H; reflexivity).
discriminate.
Qed.

(** However, when the dependencies are equal, [JMeq (P p) x (P q) y]
    is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *)

Lemma JMeq_eq_dep :
  forall (U:Type) (P:U->Prop) p q (x:P p) (y:P q),
  p = q -> JMeq x y -> eq_dep U P p x q y.
Proof.
intros.
destruct H.
apply JMeq_eq in H0 as ->.
reflexivity.
Qed.

(* Compatibility *)
Notation sym_JMeq := JMeq_sym (only parsing).
Notation trans_JMeq := JMeq_trans (only parsing).

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

The following is the original floyd/jmeq_lemmas.v

******************************************)

Lemma eq_rect_JMeq: forall (A:Type) (x y: A) (F: A -> Type) (v: F x) (H: x = y), JMeq (eq_rect x F v y H) v.
Proof.
  intros.
  subst.
  rewrite <- eq_rect_eq.
  apply JMeq_refl.
Qed.

Lemma eq_rect_r_JMeq: forall (A:Type) (x y: A) (F: A -> Type) (v: F x) (H: y = x), JMeq (eq_rect_r F v H) v.
Proof.
  intros.
  subst.
  unfold eq_rect_r; rewrite <- eq_rect_eq.
  apply JMeq_refl.
Qed.

Lemma JMeq_sumtype_ll: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A) (y: C), @eq Type A C -> @eq Type B D ->
  (@JMeq (A + B) (inl x) (C + D) (inl y)) ->
  JMeq x y.
Proof.
  intros.
  exists H.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
  apply eq_refl.
Qed.

Lemma JMeq_sumtype_rr: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: B) (y: D), @eq Type A C -> @eq Type B D ->
  (@JMeq (A + B) (inr x) (C + D) (inr y)) ->
  JMeq x y.
Proof.
  intros.
  exists H0.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
  apply eq_refl.
Qed.

Lemma JMeq_sumtype_lr: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A) (y: D), @eq Type A C -> @eq Type B D -> ~ (@JMeq (A + B) (inl x) (C + D) (inr y)).
Proof.
  unfold not.
  intros.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
Qed.

Lemma JMeq_sumtype_rl: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: B) (y: C), @eq Type A C -> @eq Type B D -> ~ (@JMeq (A + B) (inr x) (C + D) (inl y)).
Proof.
  unfold not.
  intros.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  inversion H2.
Qed.

Ltac solve_JMeq_sumtype H :=
  match type of H with
  | JMeq ?x ?y =>
    destruct x; destruct y;
     [apply JMeq_sumtype_ll in H; auto
     |apply JMeq_sumtype_lr in H; auto; inversion H
     |apply JMeq_sumtype_rl in H; auto; inversion H
     |apply JMeq_sumtype_rr in H; auto]
  end.

Lemma JMeq_inl: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A) (y: C), @eq Type B D -> JMeq x y -> @JMeq (A + B) (inl x) (C + D) (inl y).
Proof.
  intros.
  destruct H0 as [?H ?H].
  pose (f_equal2 :=
          fun (A1 : Type) (A2 : Type) (B : Type) (f : forall (_ : A1) (_ : A2), B)
            (x1 y1 : A1) (x2 y2 : A2) (H : @eq A1 x1 y1) =>
          match H in (eq _ y) return (forall _ : @eq A2 x2 y2, @eq B (f x1 x2) (f y y2)) with
          | eq_refl => fun H0 : @eq A2 x2 y2 => match H0 in (eq _ y) return (@eq B (f x1 x2) (f x1 y)) with
                                                | eq_refl => @eq_refl B (f x1 x2)
                                                end
          end).
  exists (f_equal2 _ _ _ sum _ _ _ _ H0 H).
  destruct H, H0.
  rewrite <- H1.
  unfold f_equal2.
  simpl.
  apply eq_refl.
Qed.

Lemma JMeq_inr: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: B) (y: D), @eq Type A C -> JMeq x y -> @JMeq (A + B) (inr x) (C + D) (inr y).
Proof.
  intros.
  destruct H0 as [?H ?H].
  pose (f_equal2 :=
          fun (A1 : Type) (A2 : Type) (B : Type) (f : forall (_ : A1) (_ : A2), B)
            (x1 y1 : A1) (x2 y2 : A2) (H : @eq A1 x1 y1) =>
          match H in (eq _ y) return (forall _ : @eq A2 x2 y2, @eq B (f x1 x2) (f y y2)) with
          | eq_refl => fun H0 : @eq A2 x2 y2 => match H0 in (eq _ y) return (@eq B (f x1 x2) (f x1 y)) with
                                                | eq_refl => @eq_refl B (f x1 x2)
                                                end
          end).
  exists (f_equal2 _ _ _ sum _ _ _ _ H H0).
  destruct H, H0.
  rewrite <- H1.
  unfold f_equal2.
  simpl.
  apply eq_refl.
Qed.

Lemma JMeq_fst: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A*B) (y: C*D), @eq Type A C -> @eq Type B D -> JMeq x y -> JMeq (fst x) (fst y).
Proof.
  intros.
  exists H.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  rewrite H2.
  apply eq_refl.
Qed.

Lemma JMeq_snd: forall (A: Type) (B: Type) (C: Type) (D: Type) (x: A*B) (y: C*D), @eq Type A C -> @eq Type B D -> JMeq x y -> JMeq (snd x) (snd y).
Proof.
  intros.
  exists H0.
  destruct H1 as [?H ?H].
  revert H1 H2.
  destruct H, H0.
  intros.
  rewrite <- eq_rect_eq in H2.
  rewrite H2.
  apply eq_refl.
Qed.

Lemma JMeq_pair: forall (A: Type) (B: Type) (C: Type) (D: Type) (a: A) (b: B) (c: C) (d: D), JMeq a b -> JMeq c d -> JMeq (a, c) (b, d).
Proof.
  intros.
  destruct H as [?H ?H], H0 as [?H ?H].
  pose (f_equal2 :=
          fun (A1 : Type) (A2 : Type) (B : Type) (f : forall (_ : A1) (_ : A2), B)
            (x1 y1 : A1) (x2 y2 : A2) (H : @eq A1 x1 y1) =>
          match H in (eq _ y) return (forall _ : @eq A2 x2 y2, @eq B (f x1 x2) (f y y2)) with
          | eq_refl => fun H0 : @eq A2 x2 y2 => match H0 in (eq _ y) return (@eq B (f x1 x2) (f x1 y)) with
                                                | eq_refl => @eq_refl B (f x1 x2)
                                                end
          end).
  exists (f_equal2 _ _ _ prod _ _ _ _ H H0).
  destruct H, H0.
  rewrite <- H1, <- H2.
  unfold f_equal2.
  simpl.
  apply eq_refl.
Qed.

Lemma eq_rect_r_eq_rect_r_eq_sym: forall {T} {A B: T} F x (H: A = B),
  eq_rect_r F (eq_rect_r F x H) (eq_sym H) = x.
Proof.
  intros.
  destruct H.
  reflexivity.
Qed.

Lemma eq_rect_r_eq_rect_r_eq_sym': forall {T} {A B: T} F x (H: B = A),
  eq_rect_r F (eq_rect_r F x (eq_sym H)) H = x.
Proof.
  intros.
  destruct H.
  reflexivity.
Qed.

Lemma JMeq_func: forall (A: Type) (B: Type) (C: Type) (D: Type) (f: A -> B) (g: C -> D) x y,
  @eq Type B D ->
  JMeq x y -> JMeq f g -> JMeq (f x) (g y).
Proof.
  intros.
  exists H.
  destruct H0 as [?H ?H], H1 as [?H ?H].
  destruct H, H0.
  rewrite <- eq_rect_eq in H3.
  rewrite H3, <- H2.
  apply eq_refl.
Qed.

Lemma eq_JMeq: forall A (x y: A), x=y -> JMeq x y.
Proof. intros. subst. apply JMeq_refl.
Qed.

Lemma list_func_JMeq: forall {A: Type} {B: Type} {C: Type} (a: list A) (b: list B) (f: forall X, list X -> C), @eq Type A B -> JMeq a b -> f A a = f B b.
Proof.
  intros.
  destruct H0 as [? ?].
  destruct H.
  rewrite <- eq_rect_eq in e.
  rewrite e.
  auto.
Qed.

Lemma list_func_JMeq': forall {A: Type} {B: Type} (a: list A) (b: list B) (a': A) (b': B) (f: forall X, list X -> X -> X), JMeq a b -> JMeq a' b' -> JMeq (f A a a') (f B b b').
Proof.
  intros.
  destruct H as [?H ?H], H0 as [?H ?H].
  exists H0.
  rewrite <- H1, <- H2.
  destruct H0.
  simpl.
  rewrite <- eq_rect_eq.
  apply eq_refl.
Qed.

Lemma JMeq_sigT: forall {A: Type} {B: Type} (a: A), @eq Type A B -> {b: B | JMeq a b}.
Proof.
  intros.
  unfold JMeq.
  destruct H.
  exists a.
  apply JMeq_refl.
Qed.

Arguments JMeq_eq {A} {x y} _.