Require Import QArith.
Require Import Setoid.
Require Import Coq.Program.Basics.
Require Import Lia.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import directed.
Require Import plotkin.
Require Import joinable.
Require Import approx_rels.
Require Import profinite.
Require Import cusl.

Require Import rational_intervals.

Require Import Qminmax.

Program Definition rint_preord_mixin :
  Preord.mixin_of rational_interval :=
  Preord.Mixin rational_interval rint_ord _ _.
Next Obligation.
  repeat intro; auto.
Qed.
Next Obligation.
  repeat intro; eauto.
Qed.

Canonical Structure rint_preord :=
  Preord.Pack rational_interval rint_preord_mixin.

Definition rint_dec : forall x y:rational_interval,
  { x ≤ y }+{x ≰ y }.
Proof.
  intros.
  destruct (Qlt_le_dec (rint_start y) (rint_start x)).
  - right; intro.
    apply rint_ord_test in H.
    destruct H.
    assert (rint_start y < rint_start y).
    { eapply Qlt_le_trans. apply q. auto. }
    red in H1. lia.
  - destruct (Qlt_le_dec (rint_end x) (rint_end y)).
    + right; intro.
      apply rint_ord_test in H.
      destruct H.
      assert (rint_end x < rint_end x).
      { eapply Qlt_le_trans. apply q0. auto. }
      red in H1. lia.
    + left. apply rint_ord_test.
      split; auto.
Qed.

Definition Z_enum (n:N) :=
  match n with
  | N0 => Some Z0
  | Npos xH => None
  | Npos (xO p) => Some (Zpos p)
  | Npos (xI p) => Some (Zneg p)
  end.

Definition pos_enum (n:N) :=
  match n with
  | N0 => None
  | Npos p => Some p
   end.

Definition Q_enum (n:N) :=
  let (p,q) := pairing.unpairing n in
    match Z_enum p, pos_enum q with
    | Some n1, Some n2 => Some (n1#n2)%Q
    | _, _ => None
    end.

Definition rint_enum (n:N) :=
  let (p,q) := pairing.unpairing n in
    match Q_enum p, Q_enum q with
    | Some n1, Some n2 =>
      match Qlt_le_dec n2 n1 with
      | left _  => None
      | right H => Some (RatInt n1 n2 H)
      end
    | _, _ => None
    end.

Lemma Z_enum_complete :
  forall z:Z, exists n:N,
    Z_enum n = Some z.
Proof.
  intros. destruct z.
  exists N0. simpl; auto.
  exists (Npos (xO p)). simpl. auto.
  exists (Npos (xI p)). simpl. auto.
Qed.

Lemma pos_enum_complete :
  forall p:positive, exists n:N,
    pos_enum n = Some p.
Proof.
  intros.
  exists (Npos p). simpl. auto.
Qed.

Lemma Q_enum_complete :
  forall q:Q, exists n:N,
    Q_enum n = Some q.
Proof.
  intros.
  destruct q.
  destruct (Z_enum_complete Qnum) as [p ?].
  destruct (pos_enum_complete Qden) as [q ?].
  exists (pairing.pairing (p,q)).
  unfold Q_enum.
  rewrite pairing.unpairing_pairing.
  rewrite H. rewrite H0. auto.
Qed.

Lemma rint_enum_complete :
  forall i:rint_preord, exists n:N,
    exists i', rint_enum n = Some i' /\ i ≈ i'.
Proof.
  intros.
  destruct (Q_enum_complete (rint_start i)).
  destruct (Q_enum_complete (rint_end i)).
  exists (pairing.pairing (x,x0)).
  unfold rint_enum.
  case_eq (Qlt_le_dec (rint_end i) (rint_start i)).
  - intros.
    elimtype False.
    generalize (rint_proper i). intros.
    assert (rint_end i < rint_end i).
    { eapply Qlt_le_trans. apply q. auto. }
    red in H3. simpl in H3. lia.
  - intros.
    exists (RatInt (rint_start i) (rint_end i) q).
    rewrite pairing.unpairing_pairing.
    rewrite H. rewrite H0.
    rewrite H1. split; auto.
    destruct i as [m n R]. simpl in *.
    red. simpl.
    split; hnf; simpl;
      unfold in_interval; simpl; intros; auto.
Qed.

Lemma rint_enum_complete' x: x ∈ (rint_enum : eset rint_preord).
Proof.
  destruct (rint_enum_complete x) as [n [x' [??]]].
  exists n. rewrite H. auto.
Qed.

Program Definition rint_eff : effective_order rint_preord :=
  EffectiveOrder rint_preord rint_dec rint_enum _.
Next Obligation.
  intros. hnf; simpl; intros.
  destruct (rint_enum_complete x) as [n [i' [??]]].
  exists n. rewrite H. auto.
Qed.

Lemma rint_cusl : cusl rint_preord.
Proof.
  constructor.
  intros.

  destruct (Qlt_le_dec (rint_start x) (rint_start y)) as [H|H].
  - destruct (Qlt_le_dec (rint_end x) (rint_end y)) as [H0|H0].
    + destruct (Qlt_le_dec (rint_end x) (rint_start y)) as [H1|H1].
      * right.
        intros.
        apply rint_ord_test in H2.
        apply rint_ord_test in H3.
        intuition.
        generalize (rint_proper z). intros.
        assert (rint_end x < rint_end x).
        { apply Qlt_le_trans with (rint_start y); auto.
          apply Qle_trans with (rint_start z); auto.
          apply Qle_trans with (rint_end z); auto.
        }
        red in H7. lia.
      * left.
        exists (RatInt _ _ H1).
        split; simpl; intros.
        ** apply rint_ord_test. simpl.
           split; auto.
           *** apply Qlt_le_weak; auto.
           *** apply Qle_refl.
        ** split; auto.
           *** apply rint_ord_test. simpl.
               split.
               **** apply Qle_refl.
               **** apply Qlt_le_weak; auto.

           *** intros.
               apply rint_ord_test. simpl.
               apply rint_ord_test in H2; destruct H2.
               apply rint_ord_test in H3; destruct H3.
               split; auto.

    + left.
      exists y.
      split.
      * apply rint_ord_test.
        split; auto.
        apply Qlt_le_weak. auto.
      * split; auto.

  - destruct (Qlt_le_dec (rint_end x) (rint_end y)) as [H0|H0].
    + left.
      exists x.
      split; auto.
      split; auto.
      apply rint_ord_test.
      split; auto.
      apply Qlt_le_weak. auto.

    + destruct (Qlt_le_dec (rint_end y) (rint_start x)) as [H1|H1].
      * right. intros.
        apply rint_ord_test in H2.
        apply rint_ord_test in H3.
        destruct H2. destruct H3.
        assert (rint_end y < rint_end y).
        { apply Qlt_le_trans with (rint_start x); auto.
          apply Qle_trans with (rint_start z); auto.
          apply Qle_trans with (rint_end z); auto.
          apply rint_proper.
        }
        red in H6. lia.

      * left. exists (RatInt _ _ H1).
        split.
        ** apply rint_ord_test. simpl.
           split; auto. apply Qle_refl.
        ** split.
           *** apply rint_ord_test. simpl.
               split; auto. apply Qle_refl.
           *** intros.
               apply rint_ord_test. simpl.
               apply rint_ord_test in H2.
               apply rint_ord_test in H3.
               intuition.
Qed.

Lemma rint_plotkin : plotkin_order true rint_preord.
Proof.
  apply cusl_plotkin.
  - apply rint_eff.
  - apply rint_cusl.
Qed.

Program Definition Qpreord_mixin : Preord.mixin_of Q :=
  Preord.Mixin Q Qeq Qeq_refl Qeq_trans.
Canonical Structure Qpreord := Preord.Pack Q Qpreord_mixin.

Program Definition Qpreord_eff : effective_order Qpreord :=
  EffectiveOrder Qpreord Qeq_dec Q_enum _.
Next Obligation.
  intros.
  destruct (Q_enum_complete x) as [n ?].
  exists n. rewrite H. auto.
Qed.

Lemma Q_has_normals : has_normals Qpreord Qpreord_eff true.
Proof.
  repeat intro. exists X.
  split; [ red; auto |].
  split; auto.
  repeat intro. exists z.
  split.
  - repeat intro. apply H in H0.
    apply finsubset_elem in H0.
    + destruct H0; auto.
    + intros. rewrite <- H2. auto.
  - apply finsubset_elem.
    + intros. rewrite <- H0. auto.
    + split; auto.
      destruct Hinh0.
      apply H in H0.
      apply finsubset_elem in H0.
      * destruct H0.
        apply member_eq with x; auto.
        split; auto.
        red. simpl. red in H1. simpl in H1.
        apply Qeq_sym. auto.
      * intros. rewrite <- H2; auto.
Qed.

Definition Q_plotkin : plotkin_order true Qpreord
  := norm_plt Qpreord Qpreord_eff true Q_has_normals.

Definition QDom : ∂PLT :=
  PLT.Ob true Q
     (PLT.Class true Q Qpreord_mixin Qpreord_eff Q_plotkin).

Definition PreRealDom : ∂PLT :=
  PLT.Ob true rational_interval
     (PLT.Class true rational_interval rint_preord_mixin rint_eff rint_plotkin).

Definition canonical (A:∂PLT) (f : A → PreRealDom) :=
  forall a x, (a,x) ∈ PLT.hom_rel f  ->
    exists x', (a,x') ∈ PLT.hom_rel f /\ way_inside x' x.

Definition canon_rel : erel PreRealDom PreRealDom :=
  esubset_dec (prod_preord PreRealDom PreRealDom)
     (fun x => way_inside (fst x) (snd x))
     (fun x => way_inside_dec (fst x) (snd x))
     (eprod rint_enum rint_enum).

Lemma canon_rel_elem x y :
   (x,y) ∈ canon_rel <-> way_inside x y.
Proof.
  unfold canon_rel. rewrite esubset_dec_elem.
  - simpl. intuition.
    apply eprod_elem; split.
    + destruct (rint_enum_complete x) as [n [r' [??]]]; auto.
      exists n. rewrite H0. auto.
    + destruct (rint_enum_complete y) as [n [r' [??]]]; auto.
      exists n. rewrite H0. auto.
  - simpl; intros.
    destruct H. destruct H0.
    destruct H. destruct H1.
    apply rint_ord_test in H.
    apply rint_ord_test in H1.
    apply rint_ord_test in H3.
    apply rint_ord_test in H4.
    split.
    + intuition.
      eapply Qle_lt_trans; eauto.
      eapply Qlt_le_trans; eauto.
    + intuition.
      eapply Qle_lt_trans; eauto.
      eapply Qlt_le_trans; eauto.
Qed.

Program Definition canon : PreRealDom → PreRealDom :=
  PLT.Hom true PreRealDom PreRealDom canon_rel _ _.
Next Obligation.
  intros.
  apply canon_rel_elem in H1. apply canon_rel_elem.
  apply rint_ord_test in H.
  apply rint_ord_test in H0. red in H1. red.
  intuition.
  - eapply Qle_lt_trans; eauto.
    eapply Qlt_le_trans; eauto.
  - eapply Qle_lt_trans; eauto.
    eapply Qlt_le_trans; eauto.
Qed.
Next Obligation.
  intro q. apply prove_directed; auto.
  intros r1 r2 ? ?.
  rewrite erel_image_elem in H.
  rewrite erel_image_elem in H0.
  apply canon_rel_elem in H.
  apply canon_rel_elem in H0.
  destruct H. destruct H0.
  assert (Qmax (rint_start r1) (rint_start r2) <= Qmin (rint_end r1) (rint_end r2)).
  { apply Q.max_case; intros.
    - rewrite <- H3; auto.
    - apply Q.min_case; intros.
      + rewrite <- H3; auto.
      + apply rint_proper.
      + apply Qlt_le_weak.
        apply Qlt_trans with (rint_start q); auto.
        apply Qle_lt_trans with (rint_end q); auto.
        apply rint_proper.
    - apply Q.min_case; intros.
      + rewrite <- H3; auto.
      + apply Qlt_le_weak.
        apply Qlt_trans with (rint_start q); auto.
        apply Qle_lt_trans with (rint_end q); auto.
        apply rint_proper.
      + apply rint_proper.
  }
  exists (RatInt _ _ H3).
  split; simpl.
  - apply rint_ord_test; split; simpl.
    + apply Q.le_max_l.
    + apply Q.le_min_l.
  - split; simpl.
    + apply rint_ord_test; split; simpl.
      * apply Q.le_max_r.
      * apply Q.le_min_r.
    + apply erel_image_elem.
      apply canon_rel_elem.
      split; simpl.
      * apply Q.max_case; intros; auto.
        rewrite <- H4; auto.
      * apply Q.min_case; intros; auto.
        rewrite <- H4; auto.
Qed.

Lemma canon_idem : canon ∘ canon ≈ canon.
Proof.
  split; hnf; simpl; intros.
  - destruct a as [a b].
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    simpl in *.
    rewrite canon_rel_elem in H.
    rewrite canon_rel_elem in H0.
    rewrite canon_rel_elem.
    red in H, H0. red. intuition.
    + eapply Qlt_trans; eauto.
    + eapply Qlt_trans; eauto.
  - destruct a as [a b]. simpl. apply PLT.compose_hom_rel.
    apply canon_rel_elem in H.
    destruct H.
    destruct (Q_dense (rint_start b) (rint_start a)) as [m [??]]; auto.
    destruct (Q_dense (rint_end a) (rint_end b)) as [n [??]]; auto.
    assert (m <= n).
    { apply Qlt_le_weak.
      eapply Qlt_trans; eauto.
      eapply Qle_lt_trans; eauto.
      apply rint_proper.
    }
    exists (RatInt m n H5).
    split; simpl; rewrite canon_rel_elem.
    + split; simpl; auto.
    + split; simpl; auto.
Qed.

Lemma canon_canonical (A:∂PLT) (f:A → PreRealDom) :
  canonical A (canon ∘ f).
Proof.
  red. intros.
  apply PLT.compose_hom_rel in H.
  destruct H as [x' [??]].
  simpl in H0.
  apply canon_rel_elem in H0.
  destruct H0.
  destruct (Q_dense _ _ H0) as [q1 [??]].
  destruct (Q_dense _ _ H1) as [q2 [??]].
  assert (q1 <= q2).
  { apply Qlt_le_weak.
    apply Qlt_trans with (rint_start x'); auto.
    apply Qle_lt_trans with (rint_end x'); auto.
    apply rint_proper.
  }
  exists (RatInt q1 q2 H6).
  split; simpl.
  - apply PLT.compose_hom_rel.
    exists x'. split; auto.
    simpl. apply canon_rel_elem.
    split; simpl; auto.
  - split; simpl; auto.
Qed.

Lemma canon_canonical_iff (A:∂PLT) (f:A → PreRealDom) :
  canonical A f  <-> f ≈ canon ∘ f.
Proof.
  split; intros.
  - split; hnf; intros.
    + destruct a as [a x].
      hnf in H.
      destruct (H a x H0) as [x' [??]].
      apply PLT.compose_hom_rel.
      exists x'. split; auto.
      simpl. apply canon_rel_elem; auto.
    + destruct a as [a x].
      apply PLT.compose_hom_rel in H0.
      destruct H0 as [x' [??]].
      simpl in H1. apply canon_rel_elem in H1.
      apply PLT.hom_order with a x'; auto.
      apply rint_ord_test.
      destruct H1; split; apply Qlt_le_weak; auto.

  - hnf; simpl; intros.
    destruct H.
    apply H in H0.
    apply PLT.compose_hom_rel in H0.
    destruct  H0 as [x' [??]].
    exists x'. split; auto.
    simpl in H2. apply canon_rel_elem in H2; auto.
Qed.

Definition realdom_lt (A:∂PLT) (f g:A → PreRealDom) :=
  forall a, exists x y,
    (a,x) ∈ PLT.hom_rel f /\
    (a,y) ∈ PLT.hom_rel g /\
    rint_end x < rint_start y.

Definition realdom_lt' (A:∂PLT) (f g:A → PreRealDom) :=
  forall a (ε:Q), ε >= 0 -> exists x y,
    (a,x) ∈ PLT.hom_rel f /\
    (a,y) ∈ PLT.hom_rel g /\
    rint_end x < rint_start y + ε.

Definition realdom_le (A:∂PLT) (f g:A → PreRealDom) :=
  forall a (ε:Q), ε > 0 -> exists x y,
    (a,x) ∈ PLT.hom_rel f /\
    (a,y) ∈ PLT.hom_rel g /\
    rint_end x < rint_start y + ε.

Lemma realdom_lt_eq A f g :
  realdom_lt A f g <-> realdom_lt' A f g.
Proof.
  split; red; intros.
  - destruct (H a) as [x [y [?[??]]]].
    exists x. exists y. intuition.
    apply Qlt_le_trans with (rint_start y + 0)%Q; auto.
    + ring_simplify; auto.
    + apply Qplus_le_compat; auto. apply Qle_refl.

  - destruct (H a 0%Q) as [x [y [?[??]]]].
    + apply Qle_refl.
    + exists x. exists y. intuition.
      ring_simplify in H2. auto.
Qed.

Add Parametric Morphism (A:∂PLT) :
  (@realdom_lt A)
    with signature (Preord.ord_op _) ==> (Preord.ord_op _) ==> impl
    as realdom_lt_morphism.
Proof.
  repeat intro.
  destruct (H1 a) as [?[?[?[??]]]].
  exists x1. exists x2. intuition.
Qed.

Add Parametric Morphism (A:∂PLT) :
  (@realdom_lt A)
    with signature (eq_op _) ==> (eq_op _) ==> iff
    as realdom_lt_eq_morphism.
Proof.
  split; intros.
  - generalize (realdom_lt_morphism).
    unfold impl. intros. eapply H2; eauto.
  - generalize (realdom_lt_morphism).
    unfold impl. intros. eapply H2; eauto.
Qed.

Add Parametric Morphism (A:∂PLT) :
  (@realdom_le A)
    with signature (Preord.ord_op _) ==> (Preord.ord_op _) ==> impl
    as realdom_le_morphism.
Proof.
  repeat intro.
  destruct (H1 a ε H2) as [?[?[?[??]]]].
  exists x1. exists x2. intuition.
Qed.

Add Parametric Morphism (A:∂PLT) :
  (@realdom_le A)
    with signature (eq_op _) ==> (eq_op _) ==> iff
    as realdom_le_eq_morphism.
Proof.
  split; intros.
  - generalize (realdom_le_morphism).
    unfold impl. intros. eapply H2; eauto.
  - generalize (realdom_le_morphism).
    unfold impl. intros. eapply H2; eauto.
Qed.

Definition realdom_apart (A:∂PLT) (f g:A → PreRealDom) :=
  exists a x y,
    (a,x) ∈ PLT.hom_rel f /\
    (a,y) ∈ PLT.hom_rel g /\
    (rint_end x < rint_start y \/ rint_end y < rint_start x).

Definition realdom_converges (A:∂PLT) (f:A → PreRealDom) :=
  forall a ε, ε > 0 ->
    exists x, (a,x) ∈ PLT.hom_rel f /\
      rint_end x - rint_start x <= ε.

Lemma realdom_napart_common (A:∂PLT) (f g:A → PreRealDom) :
  ~realdom_apart A f g ->
  forall a x y,
    (a,x) ∈ PLT.hom_rel f ->
    (a,y) ∈ PLT.hom_rel g ->
    exists q,
      in_interval q x /\
      in_interval q y.
Proof.
  intros.
  destruct (Qlt_le_dec (rint_end x) (rint_start y)).
  - elim H.
    exists a, x, y; intuition.
  - destruct (Qlt_le_dec (rint_end y) (rint_start x)).
    + elim H.
      exists a, x, y; intuition.

    + exists (Qmax (rint_start x) (rint_start y)).
      split.
      * hnf; split.
        ** apply Q.le_max_l.
        ** apply Q.max_case; auto.
           *** intros. rewrite <- H2; auto.
           *** apply rint_proper.
      * split.
        ** apply Q.le_max_r.
        ** apply Q.max_case; auto.
           *** intros. rewrite <- H2; auto.
           *** apply rint_proper.
Qed.

Lemma realdom_napart_le (A:∂PLT) (f g:A → PreRealDom) :
  canonical A f ->
  realdom_converges A g ->
  ~realdom_apart A f g ->
  f ≤ g.
Proof.
  repeat intro.
  destruct a as [a x].
  destruct (H a x) as [x' [??]]; auto.
  set (ε := Qmin (rint_start x' - rint_start x) (rint_end x - rint_end x')).
  destruct (H0 a ε) as [y [??]].
  - destruct H4.
    unfold ε.
    apply Q.min_case_strong; intros.
    + rewrite <- H6; auto.
    + rewrite <- (Qplus_lt_r _ _ (rint_start x)). ring_simplify. auto.
    + rewrite <- (Qplus_lt_r _ _ (rint_end x')). ring_simplify. auto.

  - destruct (realdom_napart_common A f g H1 a x' y) as [q [??]]; auto.
    destruct H7. destruct H8.
    apply PLT.hom_order with a y; auto.
    apply rint_ord_test.
    destruct H4.
    split.

    + rewrite <- (Qplus_le_l _ _ ε).
      apply Qle_trans with (rint_start x').
      * unfold ε.
        apply Q.min_case_strong.
        ** intros. rewrite <- H12; auto.
        ** intros. ring_simplify. apply Qle_refl.
        ** intros.
           eapply Qle_trans.
           *** apply Qplus_le_r. apply H12.
           *** ring_simplify. apply Qle_refl.
      * apply Qle_trans with q; auto.
        apply Qle_trans with (rint_end y); auto.
        rewrite <- (Qplus_le_l _ _ (- rint_start y)).
        ring_simplify.
        ring_simplify in H6.
        auto.

    + rewrite <- (Qplus_le_l _ _ (- ε)).
      apply Qle_trans with (rint_end x').
      * apply Qle_trans with q; auto.
        apply Qle_trans with (rint_start y); auto.
        rewrite <- (Qplus_le_l _ _ (- rint_start y)).
        rewrite <- (Qplus_le_l _ _ ε).
        ring_simplify.
        ring_simplify in H6.
        auto.
      * unfold ε.
        apply Q.min_case_strong.
        ** intros. rewrite <- H12; auto.
        ** intros.
           rewrite <- (Qplus_le_l _ _ (rint_start x' - rint_start x)).
           eapply Qle_trans.
           *** apply Qplus_le_r. apply H12.
           *** ring_simplify. apply Qle_refl.
        ** intros.
           ring_simplify. apply Qle_refl.
Qed.

Lemma realdom_napart_eq A (f g:A → PreRealDom) :
  canonical A f ->
  canonical A g ->
  realdom_converges A f ->
  realdom_converges A g ->
  ~realdom_apart A f g ->
  f ≈ g.
Proof.
  intros; split; apply realdom_napart_le; auto.
  intro. apply H3.
  destruct H4 as [a [x [y [?[??]]]]].
  exists a, y, x; intuition.
Qed.

Lemma realdom_le_napart A (f g:A → PreRealDom) :
  g ≤ f -> ~realdom_apart A f g.
Proof.
  intros. red; intros.
  destruct H0 as [a [x [y [?[??]]]]].
  assert ((a,y) ∈ PLT.hom_rel f).
  { apply H; auto. }
  destruct (PLT.hom_directed true _ _ f a (x::y::nil)%list) as [q [??]].
  - exists x. apply cons_elem; auto.
  - red; intros. apply erel_image_elem.
    apply cons_elem in H4. destruct H4.
    + apply PLT.hom_order with a x; auto.
    + apply cons_elem in H4. destruct H4.
      * apply PLT.hom_order with a y; auto.
      * apply nil_elem in H4. elim H4.
  - apply erel_image_elem in H5.
    assert (x ≤ q).
    { apply H4. apply cons_elem; auto. }
    assert (y ≤ q).
    { apply H4. apply cons_elem; right. apply cons_elem; auto. }
    apply rint_ord_test in H6.
    apply rint_ord_test in H7.
    destruct H6. destruct H7.
    assert (rint_end q < rint_end q).
    { destruct H2.
      - eapply Qle_lt_trans; [ apply H8 |].
        eapply Qlt_le_trans; [ apply H2 |].
        apply Qle_trans with (rint_start q); auto.
        apply rint_proper.
      - eapply Qle_lt_trans; [ apply H9 |].
        eapply Qlt_le_trans; [ apply H2 |].
        apply Qle_trans with (rint_start q); auto.
        apply rint_proper.
    }
    red in H10. lia.
Qed.

Lemma realdom_napart_eq_iff A (f g:A → PreRealDom) :
  canonical A f ->
  canonical A g ->
  realdom_converges A f ->
  realdom_converges A g ->
  (~realdom_apart A f g <-> f ≈ g).
Proof.
  intuition.
  - apply realdom_napart_eq; auto.
  - revert H4; apply realdom_le_napart; auto.
Qed.

Lemma realdom_apart_comm A (f g: A → PreRealDom) :
  realdom_apart A f g -> realdom_apart A g f.
Proof.
  unfold realdom_apart.
  intros [a [x [y [?[??]]]]].
  exists a, y, x; intuition.
Qed.

Lemma realdom_apart_cotransitive A (f g h:A → PreRealDom) :
  realdom_converges A h ->
  realdom_apart A f g ->
  realdom_apart A f h \/ realdom_apart A h g.
Proof.
  unfold realdom_apart; intuition.
  destruct H0 as [a [x [y [?[??]]]]].
  destruct H2.

  - set (ε := (rint_start y - rint_end x) / (2#1)%Q).
    assert (Hε : 0 < ε).
    { unfold ε.
      apply Qlt_shift_div_l.
      compute. auto.
      rewrite <- (Qplus_lt_l _ _ (rint_end x)).
      ring_simplify.
      auto.
    }
    destruct (H a ε) as [q [??]]; auto.
    destruct (Qlt_le_dec (rint_end x) (rint_start q)).
    + left. exists a, x, q.
      intuition.
    + destruct (Qlt_le_dec (rint_end q) (rint_start y)).
      * right. exists a, q, y. intuition.
      * exfalso.
        assert (rint_start y <= ε + rint_end x).
        { apply Qle_trans with (rint_end q); auto.
          rewrite <- (Qplus_le_l _ _ (- rint_start q)).
          apply Qle_trans with ε.
          - ring_simplify.
            ring_simplify in H4; auto.
          - rewrite <- (Qplus_le_l _ _ (rint_start q)).
            ring_simplify.
            apply Qplus_le_r. auto.
        }
        assert (rint_start y - rint_end x <= ε).
        { unfold ε.
          rewrite <- (Qplus_le_l _ _ (rint_end x)).
          ring_simplify.
          unfold ε in H5.
          rewrite Qplus_comm. auto.
        }
        assert (ε <= 0).
        rewrite <- (Qplus_le_l _ _ ε).
        ring_simplify.
        eapply Qle_trans; [ | apply H6 ].
        unfold ε. field_simplify.
        apply Qle_refl.
        assert (ε < ε).
        { apply Qle_lt_trans with 0%Q; auto. }
        red in H8. lia.

  - set (ε := (rint_start x - rint_end y) / (2#1)%Q).
    assert (Hε : 0 < ε).
    { unfold ε.
      apply Qlt_shift_div_l.
      - compute. auto.
      - rewrite <- (Qplus_lt_l _ _ (rint_end y)).
        ring_simplify.
        auto.
    }
    destruct (H a ε) as [q [??]]; auto.
    destruct (Qlt_le_dec (rint_end y) (rint_start q)).
    + right. exists a, q, y.
      intuition.
    + destruct (Qlt_le_dec (rint_end q) (rint_start x)).
      * left. exists a, x, q. intuition.
      * exfalso.

        assert (rint_start x <= ε + rint_end y).
        { apply Qle_trans with (rint_end q); auto.
          rewrite <- (Qplus_le_l _ _ (- rint_start q)).
          apply Qle_trans with ε.
          - ring_simplify.
            ring_simplify in H4; auto.
          - rewrite <- (Qplus_le_l _ _ (rint_start q)).
            ring_simplify.
            apply Qplus_le_r. auto.
        }
        assert (rint_start x - rint_end y <= ε).
        { unfold ε.
          rewrite <- (Qplus_le_l _ _ (rint_end y)).
          ring_simplify.
          unfold ε in H5.
          rewrite Qplus_comm. auto.
        }
        assert (ε <= 0).
        { rewrite <- (Qplus_le_l _ _ ε).
          ring_simplify.
          eapply Qle_trans; [ | apply H6 ].
          unfold ε. field_simplify.
          apply Qle_refl.
        }
        assert (ε < ε).
        { apply Qle_lt_trans with 0%Q; auto. }
        red in H8. lia.
Qed.

Lemma realdom_lt_apart (f g : 1 → PreRealDom) :
  realdom_apart 1 f g <-> (realdom_lt 1 f g \/ realdom_lt 1 g f).
Proof.
  split; intuition.
  - destruct H as [a [x [y [?[??]]]]].
    destruct H1; [ left | right ].
    + red; intros; exists x; exists y;
        destruct a; destruct a0; intuition.
    + red; intros; exists y; exists x;
        destruct a; destruct a0; intuition.

  - destruct (H0 tt) as [x[y[?[??]]]].
    exists tt, x, y; intuition.
  - destruct (H0 tt) as [x[y[?[??]]]].
    exists tt, y, x; intuition.
Qed.

Lemma realdom_lt_cotransitive (f g h:1 → PreRealDom) :
  realdom_converges 1 h ->
  realdom_lt 1 f g ->
  realdom_lt 1 f h \/ realdom_lt 1 h g.
Proof.
  intros.
  destruct (H0 tt) as [x[y [?[??]]]].

  set (ε := (rint_start y - rint_end x) / (2#1)%Q).
  assert (Hε : 0 < ε).
  { unfold ε.
    apply Qlt_shift_div_l.
    - compute. auto.
    - rewrite <- (Qplus_lt_l _ _ (rint_end x)).
      ring_simplify.
      auto.
  }
  destruct (H tt ε) as [q [??]]; auto.
  destruct (Qlt_le_dec (rint_end x) (rint_start q)).
  - left.
    red; intros. exists x. exists q.
    intuition.
  - destruct (Qlt_le_dec (rint_end q) (rint_start y)).
    + right.
      red; intros. exists q. exists y. intuition.

    + exfalso.
      assert (rint_start y <= ε + rint_end x).
      { apply Qle_trans with (rint_end q); auto.
        rewrite <- (Qplus_le_l _ _ (- rint_start q)).
        apply Qle_trans with ε.
        - ring_simplify.
          ring_simplify in H5; auto.
        - rewrite <- (Qplus_le_l _ _ (rint_start q)).
          ring_simplify.
          apply Qplus_le_r. auto.
      }
      assert (rint_start y - rint_end x <= ε).
      { unfold ε.
        rewrite <- (Qplus_le_l _ _ (rint_end x)).
        ring_simplify.
        unfold ε in H6.
        rewrite Qplus_comm. auto.
      }
      assert (ε <= 0).
      { rewrite <- (Qplus_le_l _ _ ε).
        ring_simplify.
        eapply Qle_trans; [ | apply H7 ].
        unfold ε. field_simplify.
        apply Qle_refl.
      }
      assert (ε < ε).
      { apply Qle_lt_trans with 0%Q; auto. }
      red in H9; lia.
Qed.

Lemma converges_maximal A (f g:A → PreRealDom) :
  canonical A g ->
  realdom_converges A f ->
  f ≤ g -> f ≈ g.
Proof.
  intros H H0 H1. split; auto.
  apply realdom_napart_le; auto.
  intro.
  destruct H2 as [a [r [s [?[??]]]]].
  apply H1 in H3.
  destruct (plt_hom_directed2 _ _ _ g a r s) as [t [?[??]]]; auto.
  apply rint_ord_test in H6.
  apply rint_ord_test in H7.
  intuition.
  - apply (Qlt_irrefl (rint_end r)).
    apply Qlt_le_trans with (rint_start s); auto.
    apply Qle_trans with (rint_start t); auto.
    apply Qle_trans with (rint_end t); auto.
    apply rint_proper.
  - apply (Qlt_irrefl (rint_end s)).
    apply Qlt_le_trans with (rint_start r); auto.
    apply Qle_trans with (rint_start t); auto.
    apply Qle_trans with (rint_end t); auto.
    apply rint_proper.
Qed.

Lemma realdom_converges_le A (f g:A → PreRealDom) :
  f ≤ g ->
  realdom_converges A f ->
  realdom_converges A g.
Proof.
  repeat intro.
  destruct (H0 a ε) as [r [??]]; auto.
  exists r; split; auto.
Qed.

Lemma realdom_lt_asym A (f g:A → PreRealDom) (a:A) :
  realdom_lt A f g -> realdom_lt A g f -> False.
Proof.
  unfold realdom_lt; intros.
  destruct (H a) as [x [y [?[??]]]].
  destruct (H0 a) as [p [q [?[??]]]].
  destruct (PLT.hom_directed _ _ _ f a (x::q::nil)%list) as [x' [??]]; auto.
  - exists x. apply cons_elem; auto.
  - red; intros ? HIN.
    apply erel_image_elem.
    apply cons_elem in HIN. destruct HIN as [HIN|HIN].
    + apply PLT.hom_order with a x; auto.
    + apply cons_elem in HIN. destruct HIN as [HIN|HIN].
      * apply PLT.hom_order with a q; auto.
      * apply nil_elem in HIN; elim HIN.
  - apply erel_image_elem in H8.
    assert (x ≤ x').
    { apply H7. apply cons_elem. auto. }
    assert (q ≤ x').
    { apply H7. apply cons_elem. right. apply cons_elem. auto. }
    apply rint_ord_test in H9.
    apply rint_ord_test in H10.
    destruct (PLT.hom_directed _ _ _ g a (y::p::nil)%list) as [y' [??]]; auto.
    + exists y. apply cons_elem; auto.
    + red; intros ? HIN.
      apply erel_image_elem.
      apply cons_elem in HIN. destruct HIN as [HIN|HIN].
      * apply PLT.hom_order with a y; auto.
      * apply cons_elem in HIN. destruct HIN as [HIN|HIN].
        ** apply PLT.hom_order with a p; auto.
        ** apply nil_elem in HIN; elim HIN.
    + apply erel_image_elem in H12.
      assert (y ≤ y').
      { apply H11. apply cons_elem. auto. }
      assert (p ≤ y').
      { apply H11. apply cons_elem. right. apply cons_elem. auto. }
      apply rint_ord_test in H13.
      apply rint_ord_test in H14.
      intuition.
      assert (rint_end x < rint_end x).
      { apply Qlt_le_trans with (rint_start y); auto.
        apply Qle_trans with (rint_start y'); auto.
        apply Qle_trans with (rint_end y').
        - apply rint_proper.
        - apply Qle_trans with (rint_end p); auto.
          apply Qlt_le_weak.
          apply Qlt_le_trans with (rint_start q); auto.
          apply Qle_trans with (rint_start x'); auto.
          apply Qle_trans with (rint_end x'); auto.
          apply rint_proper.
      }
      red in H14. lia.
Qed.

Require Import cont_profinite.

Definition RealDom : c∂PLT :=
  cPLT.Ob true PreRealDom canon canon_idem.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Cat: Category Theory with classes.
 *
 * This module defines functors and some standard instances.
 *
 * Author: Matthieu Sozeau <mattam@mattam.org>
 *)

Set Implicit Arguments.
Unset Strict Implicit.

Require Export Cat.Category.

Require Import Coq.Program.Tactics.
Obligation Tactic := program_simpl ; auto with category.

(** Definition of a [Functor] between two categories with its two components, on objects and morphisms.
   We keep them as parameters because they are an essential part of the definition and we will quantify on them
   and mention them in later specifications. *)

Class  Functor `(C : Category obj hom, D : Category obj' hom')
  (Fobj : obj -> obj') (Fmor : forall a b, hom a b -> hom' (Fobj a) (Fobj b) ) := {
  functor_map_morphism :> forall a b, Morphism (equiv ++> equiv) (Fmor a b) ;

  preserve_ident : forall a, Fmor a a id == id ;

  preserve_assoc : forall a b c (f : hom a b) (g : hom b c),
    Fmor a c (compose f g) == Fmor b c g ∘ Fmor a b f
}.

Implicit Arguments Functor [obj hom obj' hom'].

Program Instance identity_Functor `(C : Category obj hom) :
  Functor C C Datatypes.id (fun a b => Datatypes.id).

  Solve Obligations using program_simpl ; unfold Datatypes.id ; try reflexivity.

(** Class Abbreviations needed ? Fundep problem : the obj and hom should uniquely determine the category ? *)

Class EndoFunctor `( Functor obj hom obj hom Fobj Fmor).

Definition endo_functor obj hom c Fobj Fmor : _ := @Functor obj hom c obj hom c Fobj Fmor.

(** A Natural Transformation is determined by an [eta] component for each object of the domain category giving
   a morphism in the codomain category between the images of the object by the two functors. *)

Class NaturalTransformation
  `( C : Category obj hom, D : Category obj' hom',
     CD : ! Functor C D Fobj F, DC : ! Functor C D Gobj G)
:= {
  eta : forall ob : obj, hom' (Fobj ob) (Gobj ob) ;
  eta_law : forall a b (f : hom a b), eta b ∘ F a b f == G a b f ∘ eta a
}.

(** Bijection is invertibility of a function, here we do it up to setoids. *)

Definition bijective `(Setoid A, Setoid B) (f : A -> B) : _ :=
  forall y, { x : A | f x == y /\ forall z : A, f z == y -> x == z }.
Implicit Arguments bijective [A H B H0].

(** Finally, the concept of an adjunction between two functors is defined. It is an isomorphism
   between the section by F of the homset of category C and the points category induced by G in D.
   Hopefully we'll have an example of a useful adjunction in the examples below...
   For now it just demonstrates how we might define complex constructions using this system.
   *)

Class Adjunction `(C : Category obj hom, D : Category obj' hom',
                   F : !Functor C D Fobj Fm, G : !Functor D C Gobj Gm) := {
  phi : forall (x : obj) (y : obj'),
    hom x (Gobj y) -> hom' (Fobj x) y;

  phi_law : forall x y, bijective (@phi x y)
}.

(** Constructions to hide the Fobj and Fmor components. *)
Notation "( x & y )" := (@existT _ _ x y) : core_scope.

Definition functor (c d : category) :=
  let (obj, hom, cat) := c in
  let (obj', hom', cat') := d in
    { Fobj : obj -> obj' &
      { Fmor : forall a b : obj, hom a b -> hom' (Fobj a) (Fobj b) &
        Functor cat cat' Fobj Fmor } }.

Definition identity_functor (c : category) : functor c c :=
  match c with mkCat obj hom categ =>
    (Datatypes.id & (fun a b : obj => Datatypes.id & identity_Functor categ))
  end.

Instance composition_morphism  (A B C : Type)
  `(m : !Morphism (R' ++> R'') (g : B -> C))
  `(n : !Morphism (R ++> R') (f : A -> B))
  : Morphism (R ++> R'') (g ∘ f)%prg.
Proof.
  do 2 red ; intros.
  unfold Basics.compose.
  apply (respect (Morphism:=m)).
  apply (respect (Morphism:=n)).
  assumption.
Qed.

Implicit Arguments composition_morphism [A B C R' R'' g m R f n].

Ltac setoid_refl :=
  match goal with
    | [ |- @equiv ?A ?s ?x _ ] => apply (@reflexive A (@equiv A s) (@setoid_refl A s) x)
    | [ |- @JMeq ?A ?x _ _ ] => apply JMeq_refl
  end.

Ltac reflex := setoid_refl || reflexivity.

Program Instance composed_Functor
  `( C : Category obj₁ hom₁, D : Category obj₂ hom₂, E : Category obj₃ hom₃,
     F : !Functor C D fobj fmor, G : !Functor D E gobj gmor )
  : Functor C E (gobj ∘ fobj)%prg
    (fun a b => gmor (fobj a) (fobj b) ∘ fmor a b)%prg.

  Next Obligation.
  Proof.
    do 2 red ; intros.
    pose (functor_map_morphism (Functor:=F)).
    pose (functor_map_morphism (Functor:=G)).
    pose (composition_morphism (m:=m0 (fobj a) (fobj b)) (n:=m a b)).
    apply (respect (Morphism:=m1)).
    assumption.
  Qed.

  Next Obligation.
  Proof.
    intros.
    pose (functor_map_morphism (Functor:=F)).
    pose (functor_map_morphism (Functor:=G)).
    unfold Basics.compose.
    rewrite (preserve_ident a).
    rewrite (preserve_ident (fobj a)).
    reflex.
  Qed.

  Next Obligation.
  Proof.
    pose (functor_map_morphism (Functor:=F)) as Fm.
    pose (functor_map_morphism (Functor:=G)) as Gm.
    unfold Basics.compose.
    rewrite (preserve_assoc f g).
    apply (preserve_assoc (fmor a b f) (fmor b c g)).
  Qed.
Implicit Arguments composed_Functor [obj₁ hom₁ obj₂ hom₂ obj₃ hom₃ fobj fmor gobj gmor C D E F G].

Definition functor_composition (c d e : category) : functor c d -> functor d e -> functor c e :=
  match c, d, e with
    | mkCat obj₁ hom₁ cat₁,
      mkCat obj₂ hom₂ cat₂,
      mkCat obj₃ hom₃ cat₃ =>
      fun f g =>
        let '(Fobj & (Fmor & F)) := f in
        let '(Gobj & (Gmor & G)) := g in
          (_ & (_ & composed_Functor (F:=F) (G:=G)))
  end.

Definition subst_hom {obj hom} {C : Category obj hom} {objorig} (f g : objorig -> obj)
  {a b} (p : f = g) (m : hom (f a) (f b)) : hom (g a) (g b).
Proof. intros ; subst. exact m. Defined.

Definition functor_equality {c d : category} : functor c d -> functor c d -> Prop :=
  match c, d return relation (functor c d) with
    | mkCat obj₁ hom₁ cat₁,
      mkCat obj₂ hom₂ cat₂ =>
      fun f g =>
        let '(Fobj & (Fmor & F)) := f in
        let '(Gobj & (Gmor & G)) := g in
          exists H : Fobj = Gobj, JMeq Fmor Gmor
  end.

Definition functor_equivalence (c d : category) : Equivalence (@functor_equality c d).
Proof.
  intros [obj₁ hom₁ cat₁].
  intros [obj₂ hom₂ cat₂].

  simpl.
  constructor ; red ; try red ; intros.
  destruct x as [Fobj [Fmor F]] ; simpl.
  exists (refl_equal Fobj).
  reflex.

  destruct x as [Fobj [Fmor F]] ; simpl.
  destruct y as [Gobj [Gmor G]] ; simpl.
  destruct H. exists (sym_eq x). now symmetry.

  destruct x as [Fobj [Fmor F]] ; simpl.
  destruct y as [Gobj [Gmor G]] ; simpl.
  destruct z as [Iobj [Imor I]] ; simpl.
  destruct_conjs. split_dep. now transitivity Gobj.
  eapply trans_JMeq; eauto.
Qed.

(* Definition functor_equality {c d : category} : functor c d -> functor c d -> Prop := *)
(*   match c, d return relation (functor c d) with *)
(*     | mkCat obj₁ hom₁ cat₁, *)
(*       mkCat obj₂ hom₂ cat₂ => *)
(*       fun f g => *)
(*         let '(Fobj & (Fmor & F)) := f in *)
(*         let '(Gobj & (Gmor & G)) := g in *)
(*           exists H : Gobj = Fobj, *)
(*             forall a b (m : hom₁ a b), equiv (A:=hom₂ (Fobj a) (Fobj b)) (Fmor _ _ m)  *)
(*               (subst_hom (C:=cat₂) H (Gmor _ _ m)) *)
(*   end. *)

(* Definition functor_equivalence (c d : category) : Equivalence (@functor_equality c d). *)
(* Proof. *)
(*   intros [obj₁ hom₁ cat₁].  *)
(*   intros [obj₂ hom₂ cat₂]. *)

(*   simpl. *)
(*   constructor ; red ; try red ; intros. *)
(*   destruct x as [Fobj [Fmor F]] ; simpl. *)
(*   exists (refl_equal Fobj).  *)
(*   reflex. *)

(*   destruct x as [Fobj [Fmor F]] ; simpl. *)
(*   destruct y as [Gobj [Gmor G]] ; simpl. *)
(*   destruct H. exists (sym_eq x). intros. *)
(*   move x at top. *)
(*   generalize dependent Fobj. simplify_dep_elim.  *)
(*   specialize (H a b m). unfold subst_hom in *; simpl in *. *)
(*   unfold eq_rect_r in *. simpl in *. rewrite H. reflex. *)

(*   destruct x as [Fobj [Fmor F]] ; simpl. *)
(*   destruct y as [Gobj [Gmor G]] ; simpl. *)
(*   destruct z as [Iobj [Imor I]] ; simpl. *)
(*   destruct_conjs. move H at top; move H0 at top. generalize dependent obj₁.  *)
(*   simplify_dep_elim. unfold subst_hom, eq_rect_r in *. simpl in *.  *)
(*   exists (refl_equal Iobj). simpl. intros. rewrite H2, H1. reflex. *)
(* Qed. *)

Program Instance functor_setoid (a b : category) : Setoid (functor a b) := {
  equiv := functor_equality
}.

  Next Obligation.
    apply functor_equivalence.
  Qed.


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

Require Import BinInt.
Require Import Zcompare.
Require Import Zorder.
Require Import Znat.
Require Import Zmisc.
Require Import Wf_nat.
Local Open Scope Z_scope.

(** Our purpose is to write an induction shema for {0,1,2,...}
  similar to the [nat] schema (Theorem [Natlike_rec]). For that the
  following implications will be used :
<<
 ∀n:nat, Q n == ∀n:nat, P (Z.of_nat n) ===> ∀x:Z, x <= 0 -> P x

       	     /\
             ||
             ||

 (Q O) ∧ (∀n:nat, Q n -> Q (S n)) <=== (P 0) ∧ (∀x:Z, P x -> P (Z.succ x))

				  <=== (Z.of_nat (S n) = Z.succ (Z.of_nat n))

				  <=== Z_of_nat_complete
>>
  Then the  diagram will be closed and the theorem proved. *)

Lemma Z_of_nat_complete (x : Z) :
 0 <= x -> exists n : nat, x = Z.of_nat n.
Proof.
 intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id.
Qed.

Lemma Z_of_nat_complete_inf (x : Z) :
 0 <= x -> {n : nat | x = Z.of_nat n}.
Proof.
 intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id.
Qed.

Lemma Z_of_nat_prop :
  forall P:Z -> Prop,
    (forall n:nat, P (Z.of_nat n)) -> forall x:Z, 0 <= x -> P x.
Proof.
 intros P H x Hx. now destruct (Z_of_nat_complete x Hx) as (n,->).
Qed.

Lemma Z_of_nat_set :
 forall P:Z -> Set,
   (forall n:nat, P (Z.of_nat n)) -> forall x:Z, 0 <= x -> P x.
Proof.
 intros P H x Hx. now destruct (Z_of_nat_complete_inf x Hx) as (n,->).
Qed.

Lemma natlike_ind :
 forall P:Z -> Prop,
   P 0 ->
   (forall x:Z, 0 <= x -> P x -> P (Z.succ x)) ->
   forall x:Z, 0 <= x -> P x.
Proof.
 intros P Ho Hrec x Hx; apply Z_of_nat_prop; trivial.
 induction n. exact Ho.
 rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg.
Qed.

Lemma natlike_rec :
 forall P:Z -> Set,
   P 0 ->
   (forall x:Z, 0 <= x -> P x -> P (Z.succ x)) ->
   forall x:Z, 0 <= x -> P x.
Proof.
 intros P Ho Hrec x Hx; apply Z_of_nat_set; trivial.
 induction n. exact Ho.
 rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg.
Qed.

Section Efficient_Rec.

  (** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed
      to give a better extracted term. *)

  Let R (a b:Z) := 0 <= a /\ a < b.

  Let R_wf : well_founded R.
  Proof.
   apply well_founded_lt_compat with Z.to_nat.
   intros x y (Hx,H). apply Z2Nat.inj_lt; Z.order.
  Qed.

  Lemma natlike_rec2 :
    forall P:Z -> Type,
      P 0 ->
      (forall z:Z, 0 <= z -> P z -> P (Z.succ z)) ->
      forall z:Z, 0 <= z -> P z.
  Proof.
   intros P Ho Hrec.
   induction z as [z IH] using (well_founded_induction_type R_wf).
   destruct z; intros Hz.
   - apply Ho.
   - set (y:=Z.pred (Zpos p)).
     assert (LE : 0 <= y) by (unfold y; now apply Z.lt_le_pred).
     assert (EQ : Zpos p = Z.succ y) by (unfold y; now rewrite Z.succ_pred).
     rewrite EQ. apply Hrec, IH; trivial.
     split; trivial. unfold y; apply Z.lt_pred_l.
   - now destruct Hz.
  Qed.

  (** A variant of the previous using [Z.pred] instead of [Z.succ]. *)

  Lemma natlike_rec3 :
    forall P:Z -> Type,
      P 0 ->
      (forall z:Z, 0 < z -> P (Z.pred z) -> P z) ->
      forall z:Z, 0 <= z -> P z.
  Proof.
   intros P Ho Hrec.
   induction z as [z IH] using (well_founded_induction_type R_wf).
   destruct z; intros Hz.
   - apply Ho.
   - assert (EQ : 0 <= Z.pred (Zpos p)) by now apply Z.lt_le_pred.
     apply Hrec. easy. apply IH; trivial. split; trivial.
     apply Z.lt_pred_l.
   - now destruct Hz.
  Qed.

  (** A more general induction principle on non-negative numbers using [Z.lt]. *)

  Lemma Zlt_0_rec :
    forall P:Z -> Type,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof.
   intros P Hrec.
   induction x as [x IH] using (well_founded_induction_type R_wf).
   destruct x; intros Hx.
   - apply Hrec; trivial. intros y (Hy,Hy').
     assert (0 < 0) by now apply Z.le_lt_trans with y.
     discriminate.
   - apply Hrec; trivial. intros y (Hy,Hy').
     apply IH; trivial. now split.
   - now destruct Hx.
  Defined.

  Lemma Zlt_0_ind :
    forall P:Z -> Prop,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof. intros; now apply Zlt_0_rec. Qed.

  (** Obsolete version of [Z.lt] induction principle on non-negative numbers *)

  Lemma Z_lt_rec :
    forall P:Z -> Type,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof.
    intros P Hrec; apply Zlt_0_rec; auto.
  Qed.

  Lemma Z_lt_induction :
    forall P:Z -> Prop,
      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
      forall x:Z, 0 <= x -> P x.
  Proof.
    intros; now apply Z_lt_rec.
  Qed.

  (** An even more general induction principle using [Z.lt]. *)

  Lemma Zlt_lower_bound_rec :
    forall P:Z -> Type, forall z:Z,
      (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
      forall x:Z, z <= x -> P x.
  Proof.
    intros P z Hrec x Hx.
    rewrite <- (Z.sub_simpl_r x z). apply Z.le_0_sub in Hx.
    pattern (x - z); apply Zlt_0_rec; trivial.
    clear x Hx. intros x IH Hx.
    apply Hrec. intros y (Hy,Hy').
    rewrite <- (Z.sub_simpl_r y z). apply IH; split.
    now rewrite Z.le_0_sub.
    now apply Z.lt_sub_lt_add_r.
    now rewrite <- (Z.add_le_mono_r 0 x z).
  Qed.

  Lemma Zlt_lower_bound_ind :
    forall P:Z -> Prop, forall z:Z,
      (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
      forall x:Z, z <= x -> P x.
  Proof.
    intros; now apply Zlt_lower_bound_rec with z.
  Qed.

End Efficient_Rec.


Set Implicit Arguments.

Class Dec (P: Prop) := dec: {P} + {~P}.
Arguments dec _ {_}.

Class Dec1 {X} (p: X -> Prop) := dec1: forall x, Dec (p x).
Arguments dec1 {_} _ {_}.

Class Dec2 {X Y} (p: X -> Y -> Prop) :=  dec2: forall x, Dec1 (p x).
Arguments dec2 {_} {_} _ {_}.

Instance dec_conj P Q: Dec P -> Dec Q -> Dec (P /\ Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

Instance dec_disj P Q: Dec P -> Dec Q -> Dec (P \/ Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

Instance dec_imp P Q: Dec P -> Dec Q -> Dec (P -> Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

Instance dec_iff P Q: Dec P -> Dec Q -> Dec (P <-> Q).
Proof.
  intros; unfold iff; typeclasses eauto.
Qed.

Instance dec_neg P: Dec P -> Dec (~ P).
Proof.
  intros [p|np]; firstorder.
Qed.

Lemma iff_dec P Q: Q <-> P -> Dec P -> Dec Q.
Proof. firstorder. Qed.

Instance dec1_dec X P (x: X): Dec1 P -> (Dec (P x)).
Proof. intros H; apply H. Qed.

Instance dec1_conj X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x /\ Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec1_disj X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x \/ Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec1_imp X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x -> Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec1_iff X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x <-> Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec1_neg X (P: X -> Prop): Dec1 P ->  Dec1 (fun x => ~ P x).
Proof.
  intros Hq x; typeclasses eauto.
Qed.

Instance dec2_dec1 X Y (P: X -> Y -> Prop)  x: Dec2 P -> Dec1 (P x).
Proof. intros H; apply H. Qed.

Instance dec2_dec1' X Y (P: X -> Y -> Prop) y: Dec2 P -> Dec1 (fun x => P x y).
Proof. intros H x; apply H. Qed.

Instance dec2_conj X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y /\ Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec2_disj X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y \/ Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec2_imp X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y -> Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec2_iff X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y <-> Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

Instance dec2_neg X Y (P: X -> Y -> Prop): Dec2 P ->  Dec2 (fun x y => ~ P x y).
Proof.
  intros Hq x; typeclasses eauto.
Qed.

Section DecBool.
  Definition decb P {D: Dec P} := if dec P then true else false.
  Arguments decb _ {_}.

  Definition decb1 {X: Type} (Q: X -> Prop) {D: Dec1 Q} x := decb (Q x).
  Arguments decb1 {_} _ {_} _.

  Definition decb2 {X Y: Type} (R: X -> Y -> Prop) {D: Dec2 R} x := decb1 (R x).
  Arguments decb2 {_} {_} _ {_} _.

  Lemma dec_decb (P: Prop) {D: Dec P}: P -> decb P = true.
  Proof.
    unfold decb; destruct (dec P); intuition; discriminate.
  Qed.

  Lemma decb_dec (P: Prop) {D: Dec P}: decb P = true -> P.
  Proof.
    unfold decb; destruct (dec P); intuition; discriminate.
  Qed.

End DecBool.

Hint Resolve dec_decb.
Arguments decb _ {_}.
Arguments decb1 {_} _ {_} _.
Arguments decb2 {_} {_} _ {_} _.

(* Discreteness *)

Class Dis (X: Type) := eq_dec: Dec2 (@eq X).

Notation "a == b" := (eq_dec a b) (at level 60).

Instance dis_dec X (D: Dis X): Dec2 (@eq X).
Proof. firstorder. Qed.

Instance discrete_False: Dis False.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

Instance discrete_unit: Dis unit.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

Instance discrete_nat: Dis nat.
Proof.
   unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

Instance discrete_bool: Dis bool.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

Instance discrete_option (X: Type) {D: Dis X}: Dis (option X).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  eapply eq_dec.
Qed.

Instance discrete_sum (X Y: Type) {D1: Dis X} {D2: Dis Y}: Dis (X + Y).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  all: eapply eq_dec.
Qed.

Instance discrete_prod (X Y: Type) {D1: Dis X} {D2: Dis Y}: Dis (X * Y).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  all: eapply eq_dec.
Qed.

Instance discrete_list (X: Type) {D: Dis X}: Dis (list X).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  eapply eq_dec.
Qed.

Require Import List Omega.

Instance In_dec (X: Type) {D: Dis X}: Dec2 (@In X).
Proof.
  intros ??; eapply in_dec, eq_dec.
Qed.

Definition dec_in {X: Type} {D: Dis X} (x: X) (A: list X) :=
  dec2 (@In X) x A.

Notation "x 'el' A" := (dec_in x A) (at level 60).

Instance lt_dec : Dec2 lt.
Proof.
  intros ??; eapply lt_dec.
Qed.

Instance le_dec : Dec2 le.
Proof.
  intros ??; eapply le_dec.
Qed.

Instance gt_dec : Dec2 gt.
Proof.
  intros ??; eapply lt_dec.
Qed.

Instance ge_dec : Dec2 ge.
Proof.
  intros ??; eapply le_dec.
Qed.

Instance dec_all Y (P: Y -> Prop) (D: Dec1 P):
  Dec1 (fun A => forall x, In x A -> P x).
Proof.
  intros A. eapply iff_dec; [symmetry; eapply Forall_forall|].
  unfold Dec; eapply Forall_dec; eauto.
Qed.


Require Import Frap.

Set Implicit Arguments.

Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : arith)
| Minus (e1 e2 : arith)
| Times (e1 e2 : arith).

Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| If (e : arith) (then_ else_ : cmd)
| While (e : arith) (body : cmd).

Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
(*Declare Scope arith_scope.*)
Infix "+" := Plus : arith_scope.
Infix "-" := Minus : arith_scope.
Infix "*" := Times : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75).
Infix ";;" := Sequence (at level 76). (* This one changed slightly, to avoid parsing clashes. *)
Notation "'when' e 'then' then_ 'else' else_ 'done'" := (If e%arith then_ else_) (at level 75, e at level 0).
Notation "'while' e 'loop' body 'done'" := (While e%arith body) (at level 75).

Definition valuation := fmap var nat.
Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Minus e1 e2 => interp e1 v - interp e2 v
  | Times e1 e2 => interp e1 v * interp e2 v
  end.

Inductive eval : valuation -> cmd -> valuation -> Prop :=
| EvalSkip : forall v,
  eval v Skip v
| EvalAssign : forall v x e,
  eval v (Assign x e) (v $+ (x, interp e v))
| EvalSeq : forall v c1 v1 c2 v2,
  eval v c1 v1
  -> eval v1 c2 v2
  -> eval v (Sequence c1 c2) v2
| EvalIfTrue : forall v e then_ else_ v',
  interp e v <> 0
  -> eval v then_ v'
  -> eval v (If e then_ else_) v'
| EvalIfFalse : forall v e then_ else_ v',
  interp e v = 0
  -> eval v else_ v'
  -> eval v (If e then_ else_) v'
| EvalWhileTrue : forall v e body v' v'',
  interp e v <> 0
  -> eval v body v'
  -> eval v' (While e body) v''
  -> eval v (While e body) v''
| EvalWhileFalse : forall v e body,
  interp e v = 0
  -> eval v (While e body) v.

Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
| StepAssign : forall v x e,
  step (v, Assign x e) (v $+ (x, interp e v), Skip)
| StepSeq1 : forall v c1 c2 v' c1',
  step (v, c1) (v', c1')
  -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
| StepSeq2 : forall v c2,
  step (v, Sequence Skip c2) (v, c2)
| StepIfTrue : forall v e then_ else_,
  interp e v <> 0
  -> step (v, If e then_ else_) (v, then_)
| StepIfFalse : forall v e then_ else_,
  interp e v = 0
  -> step (v, If e then_ else_) (v, else_)
| StepWhileTrue : forall v e body,
  interp e v <> 0
  -> step (v, While e body) (v, Sequence body (While e body))
| StepWhileFalse : forall v e body,
  interp e v = 0
  -> step (v, While e body) (v, Skip).

Global Hint Constructors trc step eval : core.

Lemma step_star_Seq : forall v c1 c2 v' c1',
  step^* (v, c1) (v', c1')
  -> step^* (v, Sequence c1 c2) (v', Sequence c1' c2).
Proof.
  induct 1; eauto.
  cases y; eauto.
Qed.

Global Hint Resolve step_star_Seq : core.

Theorem big_small : forall v c v', eval v c v'
  -> step^* (v, c) (v', Skip).
Proof.
  induct 1; eauto 6 using trc_trans.
Qed.

Lemma small_big'' : forall v c v' c', step (v, c) (v', c')
                                      -> forall v'', eval v' c' v''
                                                     -> eval v c v''.
Proof.
  induct 1; simplify;
  repeat match goal with
         | [ H : eval _ _ _ |- _ ] => invert1 H
         end; eauto.
Qed.

Global Hint Resolve small_big'' : core.

Lemma small_big' : forall v c v' c', step^* (v, c) (v', c')
                                     -> forall v'', eval v' c' v''
                                                    -> eval v c v''.
Proof.
  induct 1; eauto.
  cases y; eauto.
Qed.

Global Hint Resolve small_big' : core.

Theorem small_big : forall v c v', step^* (v, c) (v', Skip)
                                   -> eval v c v'.
Proof.
  eauto.
Qed.

Definition trsys_of (v : valuation) (c : cmd) : trsys (valuation * cmd) := {|
  Initial := {(v, c)};
  Step := step
|}.

Inductive context :=
| Hole
| CSeq (C : context) (c : cmd).

Inductive plug : context -> cmd -> cmd -> Prop :=
| PlugHole : forall c, plug Hole c c
| PlugSeq : forall c C c' c2,
  plug C c c'
  -> plug (CSeq C c2) c (Sequence c' c2).

Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
| Step0Assign : forall v x e,
  step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
| Step0Seq : forall v c2,
  step0 (v, Sequence Skip c2) (v, c2)
| Step0IfTrue : forall v e then_ else_,
  interp e v <> 0
  -> step0 (v, If e then_ else_) (v, then_)
| Step0IfFalse : forall v e then_ else_,
  interp e v = 0
  -> step0 (v, If e then_ else_) (v, else_)
| Step0WhileTrue : forall v e body,
  interp e v <> 0
  -> step0 (v, While e body) (v, Sequence body (While e body))
| Step0WhileFalse : forall v e body,
  interp e v = 0
  -> step0 (v, While e body) (v, Skip).

Inductive cstep : valuation * cmd -> valuation * cmd -> Prop :=
| CStep : forall C v c v' c' c1 c2,
  plug C c c1
  -> step0 (v, c) (v', c')
  -> plug C c' c2
  -> cstep (v, c1) (v', c2).

Global Hint Constructors plug step0 cstep : core.

Theorem step_cstep : forall v c v' c',
  step (v, c) (v', c')
  -> cstep (v, c) (v', c').
Proof.
  induct 1; repeat match goal with
                   | [ H : cstep _ _ |- _ ] => invert H
                   end; eauto.
Qed.

Global Hint Resolve step_cstep : core.

Lemma step0_step : forall v c v' c',
  step0 (v, c) (v', c')
  -> step (v, c) (v', c').
Proof.
  invert 1; eauto.
Qed.

Global Hint Resolve step0_step : core.

Lemma cstep_step' : forall C c0 c,
  plug C c0 c
  -> forall v' c'0 v c', step0 (v, c0) (v', c'0)
  -> plug C c'0 c'
  -> step (v, c) (v', c').
Proof.
  induct 1; simplify; repeat match goal with
                             | [ H : plug _ _ _ |- _ ] => invert1 H
                             end; eauto.
Qed.

Global Hint Resolve cstep_step' : core.

Theorem cstep_step : forall v c v' c',
  cstep (v, c) (v', c')
  -> step (v, c) (v', c').
Proof.
  invert 1; eauto.
Qed.


Require Import Tactics.
Require Import Sigma.
Require Export Coq.Logic.EqdepFacts.

Require Import Axioms.

(* Equality *)

Definition transport {A : Type} {x x'} (e : @eq A x x') (P : A -> Type) (y : P x) : P x' :=
  eq_rect x P y x' e.

Definition eqsymm {A : Type} {x x'} (e : @eq A x x') : eq x' x :=
  eq_rect _ (fun y => eq y x) (eq_refl x) _ e.

Definition eqtrans {A : Type} {x y z : A} (e : x = y) (e' : y = z) : x = z :=
  eq_rect _ (fun w => w = z) e' _ (eqsymm e).

Definition eqcompat {A B : Type} {x y : A} (f : A -> B) (e : x = y) : f x = f y :=
  eq_rect _ (fun z => f x = f z) (eq_refl (f x)) _ e.

Lemma transport_left_inv :
  forall (A : Type) (B : A -> Type) (a a' : A) (x : B a) (e : a = a'),
    transport (eqsymm e) B (transport e B x) = x.
Proof.
intros A B a a' x e.
subst a'.
reflexivity.
Qed.

Lemma transport_right_inv :
  forall (A : Type) (B : A -> Type) (a a' : A) (x : B a') (e : a = a'),
    transport e B (transport (eqsymm e) B x) = x.
Proof.
intros A B a a' x e.
subst a'.
reflexivity.
Qed.

Lemma transport_compose :
  forall (A : Type) (B : A -> Type) (a1 a2 a3 : A) (x : B a1) (e1 : a1 = a2) (e2 : a2 = a3),
    transport e2 B (transport e1 B x) = transport (eqtrans e1 e2) B x.
Proof.
intros A B a1 a2 a3 x e1 e2.
subst a2 a3.
cbn.
reflexivity.
Qed.

Lemma transport_compat :
  forall A B (f : A -> B) (C : B -> Type) (a a' : A) (x : C (f a)) (h : a = a'),
    transport (eqcompat f h) C x
    =
    transport h (fun z => C (f z)) x.
Proof.
intros A B f C a a' x h.
subst a'.
cbn.
reflexivity.
Qed.

Lemma transport_back :
  forall A (B : A -> Type) a a' (h : a = a') (h' : a' = a) (x : B a),
    transport h' B (transport h B x) = x.
Proof.
intros A B a a' h h' x.
subst a'.
substrefl h'.
cbn.
reflexivity.
Qed.

Lemma transport_self :
  forall (A : Type) (B : A -> Type) (a : A) (h : a = a) x,
    transport h B x = x.
Proof.
intros A a a' h.
substrefl h.
auto.
Qed.

Lemma transport_symm :
  forall A (B : A -> Type) (a a' : A) (h : a = a') (x : B a) (y : B a'),
    transport h B x = y
    -> x = transport (eqsymm h) B y.
Proof.
intros A B a a' h x y Heq.
subst a'.
exact Heq.
Qed.

Lemma transport_symm' :
  forall A (B : A -> Type) (a a' : A) (h : a' = a) (x : B a) (y : B a'),
    transport (eqsymm h) B x = y
    -> x = transport h B y.
Proof.
intros A B a a' h x y Heq.
subst a'.
exact Heq.
Qed.

Lemma transport_const :
  forall A B (a a' : A) (h : a = a') (b : B),
    transport h (fun _ => B) b = b.
Proof.
intros A B a a' h b.
subst a'.
reflexivity.
Qed.

(* Usually need to fill in C and h. *)
Lemma pi1_transport_lift :
  forall (A : Type) (B : Type) (C : A -> B -> Type)
    (a a' : A) (h : a = a') (x : exT B (C a)),
      pi1 (transport h (fun a'' => exT B (C a'')) x)
      = pi1 x.
Proof.
intros A B C a a' h x.
subst a'.
reflexivity.
Qed.

Lemma pi1_transport_dep_lift :
  forall (A : Type) (B : A -> Type) (C : forall (a:A), B a -> Type)
    (a a' : A) (h : a = a') (x : exT (B a) (C a)),
      pi1 (transport h (fun z => exT (B z) (C z)) x)
      =
      transport h B (pi1 x).
Proof.
intros A B C a a' h x.
subst a'.
cbn.
reflexivity.
Qed.

Lemma app_transport_dom :
  forall (A : Type) (B : A -> Type) (C : Type) (a a' : A) (h : a = a')
    (f : B a -> C) (x : B a'),
      transport h (fun z => B z -> C) f x
      =
      f (transport (eqsymm h) B x).
Proof.
intros A B C a a' h f x.
subst a'.
cbn.
reflexivity.
Qed.

Lemma app_transport_cod_dep :
  forall (A : Type) (B : Type) (C : A -> B -> Type) (a a' : A) (h : a = a')
    (f : forall (b:B), C a b) (x : B),
      transport h (fun z => forall (b:B), C z b) f x
      =
      transport h (fun z => C z x) (f x).
Proof.
intros A B C a a' h f x.
subst a'.
reflexivity.
Qed.

Lemma transport_commute :
  forall A B (f : A -> B) (C : B -> Type) a a' (h : a = a') (x : C (f a)),
    transport h (fun z => C (f z)) x
    =
    transport (f_equal f h) C x.
Proof.
intros A B f C a a' h x.
subst a'.
reflexivity.
Qed.

Lemma transport_f_equal :
  forall A B (C : B -> Type) (f : A -> B) (a a' : A) (h : a = a') (x : C (f a)),
    transport (f_equal f h) C x
    =
    transport h (fun z => C (f z)) x.
Proof.
intros A B C f a a' h x.
subst a'.
cbn.
reflexivity.
Qed.

Lemma prod_extensionality :
  forall A B (p q : A * B),
    fst p = fst q
    -> snd p = snd q
    -> p = q.
Proof.
intros A B p q Hfst Hsnd.
destruct p as (a, b).
destruct q as (c, d).
f_equal; auto.
Qed.

(* Dependent equality *)

Definition transportdep {A:Type} {B : A -> Type} {a a' : A} {b : B a} {b' : B a'}
  (e : eq_dep A B a b a' b')
  (P : forall a, B a -> Type)
  (x : P a b)
  : P a' b'
  :=
  eq_dep_rect A B a b P x a' b' e.

Lemma eq_impl_eq_dep_snd :
  forall A (B : A -> Type) a (b b' : B a),
    b = b'
    -> eq_dep _ _ a b a b'.
Proof.
intros A B a b b' H.
subst b'.
apply eq_dep_refl.
Qed.

Lemma eq_impl_eq_dep_fst :
  forall A (B : A -> Type) (a a' : A) (b : forall a, B a),
    a = a'
    -> eq_dep _ _ a (b a) a' (b a').
Proof.
intros A B a a' b H.
subst a'.
apply eq_dep_refl.
Qed.

Lemma eq_impl_eq_dep :
  forall A (B : A -> Type) (a a' : A) (b : B a) (b' : B a') (h : a = a'),
    transport h B b = b'
    -> eq_dep A B a b a' b'.
Proof.
intros A B a a' b b' h H.
subst a'.
subst b'.
cbn.
apply eq_dep_refl.
Qed.

Lemma eq_impl_eq_dep_free :
  forall A B (a a' : A) (b b' : B),
    a = a'
    -> b = b'
    -> eq_dep _ (fun _ => B) a b a' b'.
Proof.
intros A B a a' b b' Heq Heq'.
subst a' b'.
reflexivity.
Qed.

Lemma transport_eq_transportdep_snd :
  forall A (B : A -> Type) (C : forall a, B a -> Type) a (b b' : B a) (h : b = b') (x : C a b),
    transport h (C a) x
    =
    transportdep (eq_impl_eq_dep_snd A B a b b' h) C x.
Proof.
intros A B C a b b' h x.
subst b'.
replace (eq_impl_eq_dep_snd A B a b b eq_refl) with (eq_dep_intro A B a b) by (apply proof_irrelevance).
cbn.
reflexivity.
Qed.

Lemma transport_eq_transportdep_fst :
  forall A (B : A -> Type) (C : forall a, B a -> Type) (a a' : A) (b : forall a, B a)
    (h : a = a') (x : C a (b a)),
      transport h (fun z => C z (b z)) x
      =
      transportdep (eq_impl_eq_dep_fst A B a a' b h) C x.
Proof.
intros A B C a a' b h x.
subst a'.
replace (eq_impl_eq_dep_fst A B a a b eq_refl) with (eq_dep_intro A B a (b a)) by (apply proof_irrelevance).
cbn.
reflexivity.
Qed.

Lemma transportdep_compose :
  forall (A : Type) (B : A -> Type) (C : forall a, B a -> Type)
    (a1 a2 a3 : A) (b1 : B a1) (b2 : B a2) (b3 : B a3) (x : C a1 b1)
    (e1 : eq_dep _ _ a1 b1 a2 b2) (e2 : eq_dep _ _ a2 b2 a3 b3),
      transportdep e2 C (transportdep e1 C x)
      =
      transportdep (eq_dep_trans _#8 e1 e2) C x.
Proof.
intros A B C a1 a2 a3 b1 b2 b3 x e1 e2.
case e2.
case e1.
cbn.
(* This next step shouldn't be necessary, but since eq_dep_trans is opaque, it doesn't reduce. *)
replace (eq_dep_trans A B a1 a1 a1 b1 b1 b1 (eq_dep_intro A B a1 b1) (eq_dep_intro A B a1 b1)) with (eq_dep_intro A B a1 b1) by (apply proof_irrelevance).
cbn.
reflexivity.
Qed.

Lemma eq_dep_impl_eq :
  forall A (B : A -> Type) (a a' : A) (b : B a) (b' : B a'),
    eq_dep _ _ a b a' b'
    -> exists (h : a = a'), transport h B b = b'.
Proof.
intros A B a a' b b' H.
induct H.
exists (eq_refl _).
cbn.
reflexivity.
Qed.

Lemma eq_dep_impl_eq_fst :
  forall A (B : A -> Type) (a a' : A) (b : B a) (b' : B a'),
    eq_dep _ _ a b a' b'
    -> a = a'.
Proof.
intros A B a a' b b' H.
so (eq_dep_impl_eq _#6 H) as (h & _).
exact h.
Qed.

Lemma eq_dep_impl_eq_snd :
  forall A (B : A -> Type) (a : A) (b : B a) (b' : B a),
    eq_dep _ _ a b a b'
    -> b = b'.
Proof.
intros A B a b b' H.
so (eq_dep_impl_eq _#6 H) as (h & H').
substrefl h.
exact H'.
Qed.

Lemma eq_dep_impl_eq_snd_free :
  forall A (B : Type) (a a' : A) (b b' : B),
    eq_dep _ _ a b a' b'
    -> b = b'.
Proof.
intros A B a a' b b' Heq.
so (eq_dep_impl_eq_fst _#6 Heq); subst a'.
exact (eq_dep_impl_eq_snd _#5 Heq).
Qed.

Lemma eq_dep_pi1 :
  forall (A : Type) (B : A -> Type) (C : forall a, B a -> Type) (a a' : A)
    (x : exT (B a) (C a)) (y : exT (B a') (C a')),
      eq_dep _ (fun a => exT (B a) (C a)) a x a' y
      -> eq_dep _ B a (pi1 x) a' (pi1 y).
Proof.
intros A B C a a' x y Heq.
so (eq_dep_impl_eq_fst _#6 Heq); subst a'.
so (eq_dep_impl_eq_snd _#5 Heq); subst y.
reflexivity.
Qed.

Lemma eq_dep_prod_fst :
  forall A B (C : A -> Type) (x x' : A * B) (y : C (fst x)) (y' : C (fst x')),
    snd x = snd x'
    -> eq_dep A C (fst x) y (fst x') y'
    -> eq_dep (A * B) (fun z => C (fst z)) x y x' y'.
Proof.
intros A B C x x' y y' Hsnd Heq.
destruct x as (a, b).
destruct x' as (a', b').
cbn in y, y', Hsnd, Heq.
subst b'.
so (eq_dep_impl_eq_fst _#6 Heq).
subst a'.
so (eq_dep_impl_eq_snd _#5 Heq).
subst y'.
apply eq_dep_refl.
Qed.

Lemma functional_extensionality_eq_dep_dom :
  forall A (B : A -> Type) C (a a' : A) (f : B a -> C) (f' : B a' -> C),
    a = a'
    -> (forall (x : B a) (x' : B a'),
          eq_dep A B a x a' x' -> f x = f' x')
    -> eq_dep A (fun z => B z -> C) a f a' f'.
Proof.
intros A B C a a' f f' Heqa H.
subst a'.
apply eq_impl_eq_dep_snd.
fextensionality 1.
intro x.
apply H.
apply eq_dep_refl.
Qed.

Lemma functional_extensionality_eq_dep_cod :
  forall A B (C : A -> Type) (a a' : A) (f : B -> C a) (f' : B -> C a'),
    a = a'
    -> (forall (x : B), eq_dep A C a (f x) a' (f' x))
    -> eq_dep A (fun z => B -> C z) a f a' f'.
Proof.
intros A B C a a' f f' Heqa H.
subst a'.
apply eq_impl_eq_dep_snd.
fextensionality 1.
intro y.
apply eq_dep_impl_eq_snd; auto.
Qed.

Lemma functional_extensionality_eq_dep_cod' :
  forall A B (C : A -> Type) (a a' : A) (f : B -> C a) (f' : B -> C a'),
    B
    -> (forall (x : B), eq_dep A C a (f x) a' (f' x))
    -> eq_dep A (fun z => B -> C z) a f a' f'.
Proof.
intros A B C a a' f f' x H.
so (eq_dep_impl_eq_fst _#6 (H x)); subst a'.
apply eq_impl_eq_dep_snd.
fextensionality 1.
intro y.
apply eq_dep_impl_eq_snd; auto.
Qed.

(* Heterogeneous (so-called "John Major") equality.

   Exists in the standard library as JMeq.  Redefine it here
   because the Coq tactic library silently uses axioms when
   you use JMeq.
*)

Inductive heq {A : Type} (x : A) : forall {B : Type}, B -> Prop :=
| heq_refl : heq x x.

Hint Resolve heq_refl.

Lemma heq_trans :
  forall A B C (a : A) (b : B) (c : C),
    heq a b
    -> heq b c
    -> heq a c.
Proof.
intros A B C a b c Hab Hbc.
revert Hbc.
induct Hab.
auto.
Qed.

Lemma heq_symm :
  forall A B (a : A) (b : B), heq a b -> heq b a.
Proof.
intros A B a b H.
induct H.
apply heq_refl.
Qed.

Lemma heq_transport :
  forall A (B : A -> Type) a a' (h : a = a') (x : B a),
    heq (transport h B x) x.
Proof.
intros A B a a' h x.
subst a'.
cbn.
apply heq_refl.
Qed.

Lemma eq_impl_heq :
  forall A (x y : A),
    x = y
    -> heq x y.
Proof.
intros A x y H.
subst y.
apply heq_refl.
Qed.

Lemma heq_impl_eq :
  forall (A : Type) (x y : A),
    heq x y
    -> x = y.
Proof.
cut (forall (A B : Type) (x : A) (y : B) (e : A = B),
       heq x y
       -> eq_rect _ (fun z => z) x _ e = y).
  {
  intros H A x y Heq.
  exact (H A A x y (eq_refl _) Heq).
  }
intros A B x y e H.
revert e.
destruct H.
intro e.
pose proof (proof_irrelevance _ e (eq_refl _)).
subst e.
simpl.
reflexivity.
Qed.

Lemma eq_heq_impl_eq_dep :
  forall A (B : A -> Type) (a a' : A) (b : B a) (b' : B a'),
    a = a'
    -> heq b b'
    -> eq_dep A B a b a' b'.
Proof.
intros A B a a' b b' Heqa Heqb.
subst a'.
apply eq_impl_eq_dep_snd.
apply heq_impl_eq; auto.
Qed.

Lemma heq_pair :
  forall A A' B B' (a : A) (a' : A') (b : B) (b' : B'),
    heq a a'
    -> heq b b'
    -> heq (a, b) (a', b').
Proof.
intros A A' B B' a a' b b' Ha.
cases Ha.
intro Hb.
cases Hb.
apply heq_refl.
Qed.

Lemma heq_prop :
  forall (A B : Prop) (a : A) (b : B), heq a b.
Proof.
intros A B a b.
assert (A = B).
  {
  pextensionality; auto.
  }
subst B.
apply eq_impl_heq.
apply proof_irrelevance.
Qed.

(* SigT *)

(* For use with the built-in injection tactic. *)
Lemma existT_injection_2 :
  forall (T : Type) (P : T -> Type) (x : T) (y y' : P x),
    existT _ x y = existT _ x y'
    -> y = y'.
Proof.
intros T P x y y' Heq.
assert (heq (projT2 (existT _ x y)) (projT2 (existT _ x y'))) as Heq'.
  {
  rewrite -> Heq; [].
  apply heq_refl.
  }
simpl in Heq'.
apply heq_impl_eq; auto.
Qed.

(* Sigma *)

Lemma exT_extensionality :
  forall (A : Type) (P : A -> Type) (x y : exT A P),
    forall (h : pi1 x = pi1 y),
      transport h P (pi2 x) = pi2 y
      -> x = y.
Proof.
intros A P x y Heq1 Heq2.
destruct x as [x1 x2].
destruct y as [y1 y2].
simpl in Heq1.
subst y1.
simpl in Heq2.
subst y2.
reflexivity.
Qed.

Lemma existsT_unique_equal :
  forall (A : Type) (P : A -> Type),
    (existsT! (x : A), P x)
    -> forall x y, P x -> P y -> x = y.
Proof.
intros A P H x y Hx Hy.
destruct H as (z & _ & Hunique).
transitivity z.
- symmetry; apply Hunique; auto.

- apply Hunique; auto.
Qed.

Lemma expair_injection_1 :
  forall (T : Type) (P : T -> Type) (x x' : T) (y : P x) (y' : P x'),
    expair x y = expair x' y'
    -> x = x'.
Proof.
intros T P x x' y y' Heq.
assert (pi1 (expair x y) = pi1 (expair x' y')) as Heq'.
  {
  rewrite -> Heq.
  reflexivity.
  }
simpl in Heq'.
exact Heq'.
Qed.

Lemma expair_eta :
  forall S (T : S -> Type) (x : exT S T),
    expair (pi1 x) (pi2 x) = x.
Proof.
intros S T x.
destruct x.
simpl; reflexivity.
Qed.

Lemma exT_extensionality_prop :
  forall (A : Type) (P : A -> Prop) (x y : exT A P),
    pi1 x = pi1 y
    -> x = y.
Proof.
intros A P x y Heq.
apply (exT_extensionality _ _ _ _ Heq); [].
apply proof_irrelevance.
Qed.

Lemma exT_extensionality_prop_eq_dep :
  forall A (B : A -> Type) (P : forall a, B a -> Prop) (a a' : A) (x : exT (B a) (P a)) (x' : exT (B a') (P a')),
    eq_dep A B a (pi1 x) a' (pi1 x')
    -> eq_dep A (fun z => exT (B z) (P z)) a x a' x'.
Proof.
intros A B P a a' x x' H.
so (eq_dep_impl_eq_fst _#6 H); subst a'.
apply eq_impl_eq_dep_snd.
apply exT_extensionality_prop.
apply eq_dep_impl_eq_snd; auto.
Qed.

Lemma expair_injection_2 :
  forall (T : Type) (P : T -> Type) (x : T) (y y' : P x),
    expair x y = expair x y'
    -> y = y'.
Proof.
intros T P x y y' Heq.
assert (heq (pi2 (expair x y)) (pi2 (expair x y'))) as Heq'.
  {
  rewrite -> Heq; [].
  apply heq_refl.
  }
simpl in Heq'.
apply heq_impl_eq; auto.
Qed.

Lemma expair_injection_transport :
  forall (T : Type) (P : T -> Type) (x x' : T) (y : P x) (y' : P x'),
    expair x y = expair x' y'
    -> exists (h : x = x'), transport h P y = y'.
Proof.
intros T P x x' y y' Heq.
so (expair_injection_1 _#6 Heq).
subst x'.
exists (eq_refl _).
cbn.
exact (expair_injection_2 _#5 Heq).
Qed.

Lemma expair_injection_dep :
  forall A (B : A -> Type) a a' (b : B a) (b' : B a'),
    expair a b = expair a' b'
    -> eq_dep A B a b a' b'.
Proof.
intros A B a a' b b' H.
so (expair_injection_1 _#6 H); subst a'.
so (expair_injection_2 _#5 H); subst b'.
reflexivity.
Qed.

Lemma expair_compat_dep :
  forall A (B : A -> Type) a a' (b : B a) (b' : B a'),
    eq_dep A B a b a' b'
    -> expair a b = expair a' b'.
Proof.
intros A B a a' b b' H.
so (eq_dep_impl_eq_fst _#6 H); subst a'.
so (eq_dep_impl_eq_snd _#5 H); subst b'.
reflexivity.
Qed.

Lemma expair_compat_heq :
  forall A (B : A -> Type) a a' (b : B a) (b' : B a'),
    a = a'
    -> heq b b'
    -> expair a b = expair a' b'.
Proof.
intros A B a a' b b' ? Heq.
subst a'.
so (heq_impl_eq _#3 Heq).
subst b'.
reflexivity.
Qed.

Lemma expair_compat_transport :
  forall A (B : A -> Type) a a' (b : B a) (b' : B a') (h : a = a'),
    transport h B b = b'
    -> expair a b = expair a' b'.
Proof.
intros A B a a' b b' h H.
subst a'.
cbn in H.
subst b'.
reflexivity.
Qed.

Lemma exT_equal :
  forall (A : Type) (B : A -> Type) (C C' : forall a, B a -> Type) (a a' : A),
    eq_dep A (fun a => B a -> Type) a (C a) a' (C' a')
    -> exT (B a) (C a) = exT (B a') (C' a').
Proof.
intros A B C C' a a' Heq.
so (eq_dep_impl_eq_fst _#6 Heq).
subst a'.
f_equal.
exact (eq_dep_impl_eq_snd _#5 Heq).
Qed.

Ltac injectionT H :=
  let H' := fresh H
  in
    match type of H with
    | existT _ ?x _ = existT _ ?x _ =>
        so (existT_injection_2 _#5 H) as H';
        clear H;
        revert H'

    | expair ?x _ = expair ?x _ =>
        so (expair_injection_2 _#5 H) as H';
        clear H;
        revert H'

    | eq_dep _ _ ?x _ ?x _ =>
        so (eq_dep_impl_eq_snd _#5 H) as H';
        clear H;
        revert H'

    | eq_dep _ _ ?x _ ?y _ =>
        so (eq_dep_impl_eq_fst _#6 H) as H';
        revert H'
    end.

Lemma f_equal_dep :
  forall A (B : A -> Type) (C : Type) (a a' : A) (b : B a) (b' : B a') (f : forall a, B a -> C),
    eq_dep A B a b a' b'
    -> f a b = f a' b'.
Proof.
intros A B C a a' b b' f Heq.
injectionT Heq.
intros <-.
injectionT Heq.
intros <-.
reflexivity.
Qed.


(** This file contains three main theorems: forward and mixed error bounds for
  the fused muliply add dot product of two floating point lists, and a forward error bound
  for the case when the number of nonzeros in one of the lists is known;
  the functional model for the fma dot product is defined in dotprod_model.v and
  nnz (number of nonzeros) is defined in the file common.v .*)

Require Import vcfloat.VCFloat.
Require Import List.
Import ListNotations.
Require Import common op_defs dotprod_model sum_model float_acc_lems list_lemmas.

Require Import Reals.
Open Scope R.

Section ForwardError.
Context {NAN: Nans} {t : type}.

Variable (vF : list (ftype t * ftype t)).
Notation vR  := (map FR2 vF).
Notation vR' := (map Rabsp (map FR2 vF)).

Variable (fp : ftype t).
Hypothesis Hfp : fma_dot_prod_rel vF fp.
Hypothesis Hfin: Binary.is_finite (fprec t) (femax t) fp = true.

Variable (rp rp_abs : R).
Hypothesis Hrp  : R_dot_prod_rel vR rp.
Hypothesis Hra : R_dot_prod_rel vR' rp_abs.

Notation g := (@g t).
Notation g1 := (@g1 t).
Notation D := (@default_rel t).
Notation E := (@default_abs t).

(* forward error bounds *)
Lemma fma_dotprod_forward_error:
  Rabs (FT2R fp - rp) <=  g (length vF) * rp_abs + g1 (length vF) (length vF - 1).
Proof.
revert Hfp Hrp Hra Hfin. revert fp rp rp_abs.
induction vF.
{
intros;
inversion Hrp;
inversion Hfp;
inversion Hra;
subst.
unfold g, g1; simpl;
rewrite Rminus_eq_0;
rewrite Rabs_R0;
field_simplify; try apply default_rel_sep_0;
  try apply Stdlib.Rdiv_pos_compat; try nra;
apply default_rel_gt_0.
}
intros.
assert (Hl: l = [] \/ l <> []).
destruct l; auto.
right.
eapply hd_error_some_nil; simpl; auto.
destruct Hl.
(* list (a0 :: a :: l) *)
(* case empty l *)
{
subst; simpl.
rewrite (R_dot_prod_rel_single rp (FR2 a)).
inversion Hfp. inversion H2. subst.
pose proof fma_accurate' (fst a) (snd a) (Zconst t 0) Hfin as Hacc.
destruct Hacc as (e & d & Hz & He & Hd & A). rewrite A; clear A.
inversion Hra; inversion H3; subst.
unfold g1, g; simpl.
rewrite Rmult_1_r. rewrite !Rplus_0_r.
replace (1 + @default_rel t - 1) with (@default_rel t) by nra.
field_simplify_Rabs. destruct a; simpl.
eapply Rle_trans. apply Rabs_triang. rewrite Rabs_mult.
rewrite Rmult_plus_distr_l. rewrite Rmult_comm.
apply Rplus_le_compat; try nra.
  apply Rmult_le_compat; try apply Rabs_pos; try apply Rle_refl;
  try apply Rabs_pos; auto.
rewrite <- Rabs_mult; apply Req_le; nra.
simpl in Hrp; auto.
}
(* non-empty l *)
intros; inversion Hfp;
inversion Hrp; inversion Hra; subst.
(destruct (BMFA_finite_e _ _ _ Hfin) as (A & B & C)).
(* IHl *)
specialize (IHl s s0 s1 H3 H7 H11 C).
pose proof (fma_accurate' (fst a) (snd a) s Hfin) as Hplus.
destruct Hplus as (d' & e'& Hz & Hd'& He'& Hplus); rewrite Hplus;
  clear Hplus.
(* algebra *)
destruct a; cbv [ FR2 Rabsp fst snd].
simpl.
set (n:= length l).
field_simplify_Rabs.
replace (FT2R f * FT2R f0 * d' + FT2R s * d' + FT2R s + e' - s0) with
   (d' * (FT2R f * FT2R f0) + d' * FT2R s + (FT2R s - s0) + e') by nra.
eapply Rle_trans;
  [ apply Rabs_triang | eapply Rle_trans; [ apply Rplus_le_compat_r; apply Rabs_triang
    | ] ].
eapply Rle_trans;
  [  apply Rplus_le_compat_r | ].
apply Rplus_le_compat_r.
apply Rabs_triang.
eapply Rle_trans;
  [apply Rplus_le_compat_r; apply Rplus_le_compat_l | ].
apply IHl.
eapply Rle_trans;
  [apply Rplus_le_compat; [apply Rplus_le_compat_r| apply He' ] | ].
apply Rplus_le_compat.
rewrite Rabs_mult;
apply Rmult_le_compat_r; try apply Rabs_pos;
apply Hd'.
rewrite Rabs_mult;
apply Rmult_le_compat; try apply Rabs_pos.
apply Hd'.
apply Rabs_le_minus in IHl.
assert (Hs: Rabs (FT2R s) <=
      g (length l) * s1 + g1 (length l) (length l - 1) + s1).
{ eapply Rle_trans. apply IHl.
apply Rplus_le_compat_l.
rewrite <- (R_dot_prod_rel_Rabs_eq (map FR2 l) s1); auto.
apply (dot_prod_sum_rel_R_Rabs (map FR2 l)); auto. }
apply Hs.
fold n.
set (F:=Rabs (FT2R f * FT2R f0)).
rewrite !Rmult_plus_distr_l.
replace (D * F + (D * (g  n * s1) + D * g1 n (n - 1) + D * s1) +
(g n * s1 + g1  n (n - 1)) + E) with
(D * F + ((1 + D) * g  n * s1 + D * s1) + g1 n (n - 1) * (1 + D) + E) by nra.
rewrite one_plus_d_mul_g. rewrite one_plus_d_mul_g1.
rewrite Rplus_assoc.
apply Rplus_le_compat.
apply Rplus_le_compat.
rewrite <- Rabs_mult. fold F.
apply Rmult_le_compat_r.
unfold F; apply Rabs_pos.
apply d_le_g_1; lia.
apply Rmult_le_compat_r.
rewrite <- (R_dot_prod_rel_Rabs_eq (map FR2 l) s1); auto. apply Rabs_pos.
apply Req_le; f_equal; auto; lia.
unfold E; rewrite Nat.sub_0_r. apply plus_e_g1_le.
unfold n; apply length_not_empty in H; auto.
Qed.

End ForwardError.

Section ForwardErrorFold.
Context {NAN: Nans} {t : type}.

Variables vF : list (ftype t * ftype t).
Notation v1 := (fst (List.split vF)).
Notation v2 := (snd (List.split vF)).
Notation vR  := (map FR2 vF).
Notation vR' := (map Rabsp (map FR2 vF)).

Hypothesis Hfin: Binary.is_finite (fprec t) (femax t) (fma_dotprod v1 v2) = true.

Notation g := (@g t).
Notation g1 := (@g1 t).
Notation prods := (map (uncurry Rmult) vR).
Notation abs_prods := (map (uncurry Rmult) vR').

Lemma fma_dotprod_forward_error_2:
  Rabs (FT2R (fma_dotprod v1 v2) - sum_fold prods) <= g (length v1) * sum_fold abs_prods + g1 (length v1) (length v1 - 1).
Proof.
intros.
rewrite split_length_l, <- rev_length.
pose proof fma_dot_prod_rel_fold_right v1 v2 as HA.
pose proof R_dot_prod_rel_fold_right t v1 v2 as HB.
pose proof R_dot_prod_rel_fold_right_Rabs t v1 v2 as HC.
rewrite (split_combine vF) in HA, HB, HC.
rewrite <- map_rev in HB, HC.
rewrite <- map_rev in HC.
apply (fma_dotprod_forward_error
  (rev vF) (fma_dotprod v1 v2) HA Hfin (sum_fold prods) (sum_fold abs_prods) HB HC).
all: destruct (List.split vF); auto.
Qed.

End ForwardErrorFold.

Section MixedError.
Context {NAN: Nans} {t : type}.

Notation g := (@g t).
Notation g1 := (@g1 t).
Notation D := (@default_rel t).
Notation E := (@default_abs t).

Variables (v1 v2 : list (ftype t)).
Hypothesis Hlen : length v1 = length v2.
Notation vF  := (combine v1 v2).

Variable (fp : ftype t).
Hypothesis Hfp : fma_dot_prod_rel vF fp.
Hypothesis Hfin: Binary.is_finite (fprec t) (femax t) fp = true.

(* mixed error bounds *)
Lemma fma_dotprod_mixed_error:
  exists (u : list R) (eta : R),
    length u = length v1 /\
    R_dot_prod_rel (List.combine u (map FT2R v2)) (FT2R fp - eta) /\
    (forall n, (n <= length v2)%nat -> exists delta,
      nth n u 0 = FT2R (nth n v1 neg_zero) * (1 + delta) /\ Rabs delta <= g (length v2))  /\
    Rabs eta <= g1 (length v2) (length v2 - 1).
Proof.
revert Hfp Hfin Hlen. revert fp v1.
induction v2.
{ simpl; intros.   replace v1 with (@nil (ftype t)) in * by (symmetry; apply length_zero_iff_nil; auto).
  exists [], 0; repeat split;
  [inversion Hfp; subst; rewrite Rminus_0_r; simpl; auto;
  apply R_dot_prod_rel_nil  | | rewrite Rabs_R0; unfold g1, g; simpl; nra ].
  intros; exists 0; split;
  [ assert (n = 0)%nat by lia; subst; simpl; nra | rewrite Rabs_R0; unfold g; nra].
}
intros.
  destruct v1; intros.
  { simpl in Hlen. pose proof Nat.neq_0_succ (length l); try contradiction. }
    assert (Hv1: l = [] \/ l <> []).
    destruct l; auto. right.
    eapply hd_error_some_nil; simpl; auto.
    assert (Hlen1: length l0 = length l) by (simpl in Hlen; auto).
    destruct Hv1.
    assert (l0 = []). { simpl in Hlen; apply length_zero_iff_nil;
          apply length_zero_iff_nil in H; rewrite H in Hlen1; auto. }
    subst; clear Hlen1.
{
inversion Hfp; subst.
inversion H2; subst; clear H2.
simpl in Hfp, Hfin.
pose proof fma_accurate' f a (Zconst t 0) Hfin as Hacc.
destruct Hacc as (d & e & Hde & Hd & He& Hacc).
exists [FT2R f * (1  +d)], e; repeat split.
{ simpl. rewrite Hacc. replace ((FT2R f * FT2R a + FT2R (Zconst t 0)) * (1 + d) + e - e) with
  (FT2R f * (1 + d) * FT2R a + 0) by (simpl; nra).
apply R_dot_prod_rel_cons; apply R_dot_prod_rel_nil. }
{ intros; exists d; split; auto. simpl in H.
  destruct n. { simpl; auto. }
  apply le_S_n in H; apply Nat.le_0_r in H; subst; simpl; nra.
eapply Rle_trans; [apply Hd| apply d_le_g_1; simpl; auto].
}
eapply Rle_trans; [apply He|]. unfold g1, g; simpl; nra.
}
 (* apply IH *)
pose proof (length_not_empty l H) as Hlen3.
inversion Hfp; subst.
(destruct (BMFA_finite_e _ _ _ Hfin) as (A' & B' & C')).
specialize (IHl s l0).
destruct IHl as (u & eta & Hlenu & A & B & C ); auto.
(* construct u0 *)
simpl in Hfin.
pose proof fma_accurate'   f a s Hfin as Hacc;
destruct Hacc as (d & e & Hz & Hd & He & Hacc).
unfold fst, snd; rewrite Hacc.
exists (FT2R f * (1+d) :: map (Rmult (1+d)) u), (e + eta * (1 + d)).
repeat split.
{ simpl. rewrite map_length; auto. }
{ pose proof dot_prod_combine_map_Rmult (1+d) u (map FT2R l) (FT2R s - eta).
rewrite map_length in H0.
rewrite Hlen1 in Hlenu.
specialize (H0 Hlenu A); simpl.
replace  ((FT2R f * FT2R a + FT2R s) * (1 + d) + e - (e + eta * (1 + d))) with
(FT2R f * (1 + d) * FT2R a + (FT2R s - eta)*(1+d)) by nra.
apply R_dot_prod_rel_cons. rewrite Rmult_comm; auto. }
{ intros. destruct n. simpl.
{ simpl. exists d; split; auto. eapply Rle_trans; [apply Hd| ]. apply d_le_g_1. apply le_n_S; lia. }
assert (n<=length l)%nat by (simpl in H0; lia); clear H0.
specialize (B n H1); destruct B as (delta & B & HB); simpl.
replace 0 with (Rmult (1 + d) 0) by nra. rewrite map_nth.
rewrite B.
exists ( (1+d) * (1+delta) -1).
split; [nra | ].
field_simplify_Rabs.
eapply Rle_trans; [apply Rabs_triang | ].
eapply Rle_trans; [apply Rplus_le_compat; [ apply Rabs_triang | apply HB] | ].
eapply Rle_trans; [apply Rplus_le_compat_r; [rewrite Rabs_mult] | ].
apply Rplus_le_compat; [apply Rmult_le_compat;  try apply Rabs_pos | ].
apply Hd.
apply HB.
apply Hd.
replace (D * g  (length l) + D + g (length l)) with
((1 + D ) * g  (length l) *1 + D *1) by nra.
rewrite one_plus_d_mul_g.
rewrite Rmult_1_r.
apply Req_le; f_equal; lia.
}
simpl.
eapply Rle_trans; [apply Rabs_triang| ].
eapply Rle_trans; [apply Rplus_le_compat; [apply He| rewrite Rabs_mult] | ].
eapply Rmult_le_compat; try apply Rabs_pos.
apply C.
eapply Rle_trans; [apply Rabs_triang| ].
rewrite Rabs_R1.
eapply Rle_trans; [apply Rplus_le_compat_l; apply Hd| apply Rle_refl ].
rewrite one_plus_d_mul_g1; try lia.
unfold g1; field_simplify.
rewrite Rplus_assoc.
eapply Rplus_le_compat.
eapply Rmult_le_compat; try apply g_pos.
apply Rmult_le_pos; [apply default_abs_ge_0| apply pos_INR ].
eapply Rmult_le_compat; try apply default_abs_ge_0; try  apply pos_INR.
apply Req_le; auto.
apply le_INR; lia.
apply Req_le; f_equal; auto; lia.
set (n:= length l).
replace (INR (S n)) with (INR n + 1)%R.
apply Req_le; nra.
apply transitivity with (INR (n + 1)).
rewrite plus_INR; simpl; auto. f_equal; simpl; lia.
Qed.

End MixedError.

Section SparseError.
Context {NAN: Nans} {t : type}.

Variables (v1 v2 : list (ftype t)).
Hypothesis (Hlen : length v1 = length v2).

Variable (fp : ftype t).
Hypothesis Hfp : fma_dot_prod_rel (combine v1 v2) fp.
Hypothesis Hfin: Binary.is_finite (fprec t) (femax t) fp = true.

Notation v1R := (map FT2R v1).
Notation vR  := (map FR2 (combine v1 v2)).
Notation vR' := (map Rabsp (map FR2 (combine v1 v2))).

Variable (rp rp_abs : R).
Hypothesis Hrp  : R_dot_prod_rel vR rp.
Hypothesis Hra : R_dot_prod_rel vR' rp_abs.

Notation g := (@common.g t).
Notation g1 := (@common.g1 t).
Notation D := (@default_rel t).
Notation E := (@default_abs t).
Notation nnzR := (nnzR v1R).

Lemma sparse_fmadotprod_forward_error:
  Rabs (FT2R fp - rp) <=  g nnzR * rp_abs + g1 nnzR (nnzR - 1).
Proof.
revert Hlen Hfp Hfin Hrp Hra.
revert rp rp_abs fp v2.
unfold nnz.
induction v1; intros.
{ simpl in Hlen; symmetry in Hlen; apply length_zero_iff_nil in Hlen; subst.
inversion Hfp; inversion Hrp; subst; simpl; field_simplify_Rabs.
  rewrite Rabs_R0.
  apply Rplus_le_le_0_compat; auto with commonDB.
  apply Rmult_le_pos;  auto with commonDB.
 rewrite <- (R_dot_prod_rel_Rabs_eq [] rp_abs); auto;
  apply Rabs_pos. }
destruct v2; try discriminate.
assert (Hlen1 : length l = length l0) by (simpl; auto).
set (n2:= (common.nnzR (map FT2R l))%nat) in *.
inversion Hrp. inversion Hfp. inversion Hra; subst.
assert (HFIN: Binary.is_finite (fprec t) (femax t) s0 = true).
{ simpl in Hfin. destruct a; destruct f; destruct s0;
   try discriminate; simpl in *; auto;
  destruct s0; destruct s2; destruct s3; try discriminate; auto. }
simpl.
specialize (IHl s s1 s0 l0 Hlen1 H6 HFIN H2 H10).
(* reason by cases on the head of the list *)
destruct (Req_EM_T (FT2R a) 0%R).
(* start  head of list is zero *)
{ rewrite e. unfold common.nnzR; rewrite nnz_cons.
replace (FT2R (BFMA a f s0)) with (FT2R s0).
field_simplify_Rabs.
eapply Rle_trans; [apply IHl|].
apply Req_le; f_equal; try nra. unfold n2, common.nnzR.
rewrite Rabs_R0, Rmult_0_l,  Rplus_0_l; nra.
pose proof Bfma_mult_0R a f s0 Hfin as H; destruct H; auto; rewrite H;
try rewrite Bplus_neg_zero; try rewrite Bplus_neg_zero; auto;
repeat (destruct s0; simpl; auto). } (* end head of list is zero *)
(* start head of list is non-zero *)
unfold common.nnzR, nnz. rewrite !count_occ_cons_neq; auto.
set (l1:= (map FT2R l)) in *.
set (n1:= (length (FT2R a :: l1) - @count_occ R Req_EM_T l1 0%R)%nat).
assert (n1 = S n2).
{ unfold n1, n2. pose proof @count_occ_bound R Req_EM_T 0%R l1.
  unfold common.nnzR, nnz.
  destruct (count_occ Req_EM_T l1 0%R); unfold l1 in *; simpl; try lia. }
(* start case on nnz = case on nnz in tail *)
assert (H0: (n2 = 0)%nat \/ (1<=n2)%nat) by lia; destruct H0.
(* tail all zeros *)
{ rewrite H0 in *. rewrite H.
pose proof R_dot_prod_rel_nnzR l l0 Hlen1 s H2 H0; subst.
pose proof fma_dot_prod_rel_nnzR l l0 Hlen1 s0 H6 HFIN H0.
pose proof R_dot_prod_rel_nnzR_abs l l0 Hlen1 s1 H10 H0; subst.
destruct (fma_accurate' a f s0 Hfin) as (e & d & ed & He & Hd & Hacc).
rewrite Hacc; clear Hacc.
rewrite H1.
unfold g1, g.
simpl; field_simplify;
field_simplify_Rabs.
eapply  Rle_trans; [apply Rabs_triang | ].
apply Rplus_le_compat.
rewrite Rabs_mult.
rewrite Rmult_comm.
rewrite Rabs_mult. rewrite Rmult_assoc.
apply Rmult_le_compat_r; auto with commonDB.
rewrite <- Rabs_mult; apply  Rabs_pos.
eapply Rle_trans; [apply Hd| ]; auto with commonDB; nra.
}
pose proof (fma_accurate' a f s0 Hfin) as Hplus.
destruct Hplus as (d' & e'& Hz & Hd'& He'& Hplus); rewrite Hplus;
  clear Hplus.
(* algebra *)
field_simplify_Rabs.
replace (FT2R a * FT2R f * d' + FT2R s0 * d' + FT2R s0 + e' - s) with
   (d' * (FT2R a * FT2R f) + d' * FT2R s0 + (FT2R s0 - s) + e') by nra.
eapply Rle_trans;
  [ apply Rabs_triang | eapply Rle_trans; [ apply Rplus_le_compat_r; apply Rabs_triang
    | ] ].
eapply Rle_trans;
  [  apply Rplus_le_compat_r | ].
apply Rplus_le_compat_r.
apply Rabs_triang.
eapply Rle_trans;
  [apply Rplus_le_compat_r; apply Rplus_le_compat_l | ].
apply IHl.
eapply Rle_trans;
  [apply Rplus_le_compat; [apply Rplus_le_compat_r| apply He' ] | ].
apply Rplus_le_compat.
rewrite Rabs_mult;
apply Rmult_le_compat_r; try apply Rabs_pos;
apply Hd'.
rewrite Rabs_mult;
apply Rmult_le_compat; try apply Rabs_pos.
apply Hd'.
apply Rabs_le_minus in IHl.
assert (Hs: Rabs (FT2R s0) <=
      g n2 * s1 + g1 n2 (n2  - 1) + s1).
{ eapply Rle_trans. apply IHl.
apply Rplus_le_compat_l.
rewrite <- (R_dot_prod_rel_Rabs_eq (map FR2 (combine l l0)) s1); auto.
apply (dot_prod_sum_rel_R_Rabs (map FR2 (combine l l0))); auto. }
apply Hs.
set (F:=Rabs (FT2R a * FT2R f)).
rewrite !Rmult_plus_distr_l.
replace (D * F + (D * (g  n2 * s1) + D * g1 n2 (n2 - 1) + D * s1) +
(g n2 * s1 + g1  n2 (n2 - 1)) + E) with
(D * F + ((1 + D) * g  n2 * s1 + D * s1) + g1 n2 (n2 - 1) * (1 + D) + E) by nra.
rewrite one_plus_d_mul_g. rewrite one_plus_d_mul_g1; auto.
rewrite Rplus_assoc.
apply Rplus_le_compat.
apply Rplus_le_compat.
rewrite <- Rabs_mult. fold F.
apply Rmult_le_compat_r.
unfold F; apply Rabs_pos.
apply d_le_g_1; lia.
apply Rmult_le_compat_r.
rewrite <- (R_dot_prod_rel_Rabs_eq (map FR2 (combine l l0)) s1); auto. apply Rabs_pos.
apply Req_le; f_equal; auto; lia.
rewrite H.
eapply Rle_trans.
apply plus_e_g1_le; auto.
rewrite <- H.
replace n2 with (n1 - 1)%nat; try nra; lia.
Qed.

End SparseError.


From Hammer Require Import Hammer.

Require Import ZArith_base ZArithRing Zcomplements Zdiv Znumtheory.
Require Export Zpower.
Local Open Scope Z_scope.

Lemma Zpower_pos_1_r x : Z.pow_pos x 1 = x.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_pos_1_r".  exact ((Z.pow_1_r x)). Qed.

Lemma Zpower_pos_1_l p : Z.pow_pos 1 p = 1.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_pos_1_l".   now apply (Z.pow_1_l (Zpos p)). Qed.

Lemma Zpower_pos_0_l p : Z.pow_pos 0 p = 0.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_pos_0_l".   now apply (Z.pow_0_l (Zpos p)). Qed.

Lemma Zpower_pos_pos x p : 0 < x -> 0 < Z.pow_pos x p.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_pos_pos".   intros. now apply (Z.pow_pos_nonneg x (Zpos p)). Qed.

Theorem Zpower_le_monotone a b c :
0 < a -> 0 <= b <= c -> a^b <= a^c.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_le_monotone".   intros. now apply Z.pow_le_mono_r. Qed.

Theorem Zpower_lt_monotone a b c :
1 < a -> 0 <= b < c -> a^b < a^c.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_lt_monotone".   intros. apply Z.pow_lt_mono_r; auto with zarith. Qed.

Theorem Zpower_gt_1 x y : 1 < x -> 0 < y -> 1 < x^y.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_gt_1".   apply Z.pow_gt_1. Qed.

Theorem Zmult_power p q r : 0 <= r -> (p*q)^r = p^r * q^r.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zmult_power".   intros. apply Z.pow_mul_l. Qed.

Hint Resolve Z.pow_nonneg Z.pow_pos_nonneg : zarith.

Theorem Zpower_le_monotone3 a b c :
0 <= c -> 0 <= a <= b -> a^c <= b^c.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_le_monotone3".   intros. now apply Z.pow_le_mono_l. Qed.

Lemma Zpower_le_monotone_inv a b c :
1 < a -> 0 < b -> a^b <= a^c -> b <= c.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_le_monotone_inv".
intros Ha Hb H. apply (Z.pow_le_mono_r_iff a); trivial.
apply Z.lt_le_incl; apply (Z.pow_gt_1 a); trivial.
apply Z.lt_le_trans with (a^b); trivial. now apply Z.pow_gt_1.
Qed.

Notation Zpower_nat_Zpower := Zpower_nat_Zpower (only parsing).

Theorem Zpower2_lt_lin n : 0 <= n -> n < 2^n.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower2_lt_lin".   intros. now apply Z.pow_gt_lin_r. Qed.

Theorem Zpower2_le_lin n : 0 <= n -> n <= 2^n.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower2_le_lin".   intros. apply Z.lt_le_incl. now apply Z.pow_gt_lin_r. Qed.

Lemma Zpower2_Psize n p :
Zpos p < 2^(Z.of_nat n) <-> (Pos.size_nat p <= n)%nat.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower2_Psize".
revert p; induction n.
destruct p; now split.
assert (Hn := Nat2Z.is_nonneg n).
destruct p; simpl Pos.size_nat.
- specialize IHn with p.
rewrite Pos2Z.inj_xI, Nat2Z.inj_succ, Z.pow_succ_r; omega.
- specialize IHn with p.
rewrite Pos2Z.inj_xO, Nat2Z.inj_succ, Z.pow_succ_r; omega.
- split; auto with zarith.
intros _. apply Z.pow_gt_1. easy.
now rewrite Nat2Z.inj_succ, Z.lt_succ_r.
Qed.

Theorem Zpower_mod p q n :
0 < n -> (p^q) mod n = ((p mod n)^q) mod n.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_mod".
intros Hn; destruct (Z.le_gt_cases 0 q) as [H1|H1].
- pattern q; apply natlike_ind; trivial.
clear q H1. intros q Hq Rec. rewrite !Z.pow_succ_r; trivial.
rewrite Z.mul_mod_idemp_l; auto with zarith.
rewrite Z.mul_mod, Rec, <- Z.mul_mod; auto with zarith.
- rewrite !Z.pow_neg_r; auto with zarith.
Qed.

Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z :=
match m with
| xH => a mod n
| xO m' =>
let z := Zpow_mod_pos a m' n in
match z with
| 0 => 0
| _ => (z * z) mod n
end
| xI m' =>
let z := Zpow_mod_pos a m' n in
match z with
| 0 => 0
| _ => (z * z * a) mod n
end
end.

Definition Zpow_mod a m n :=
match m with
| 0 => 1 mod n
| Zpos p => Zpow_mod_pos a p n
| Zneg p => 0
end.

Theorem Zpow_mod_pos_correct a m n :
n <> 0 -> Zpow_mod_pos a m n = (Z.pow_pos a m) mod n.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpow_mod_pos_correct".
intros Hn. induction m.
- rewrite Pos.xI_succ_xO at 2. rewrite <- Pos.add_1_r, <- Pos.add_diag.
rewrite 2 Zpower_pos_is_exp, Zpower_pos_1_r.
rewrite Z.mul_mod, (Z.mul_mod (Z.pow_pos a m)) by trivial.
rewrite <- IHm, <- Z.mul_mod by trivial.
simpl. now destruct (Zpow_mod_pos a m n).
- rewrite <- Pos.add_diag at 2.
rewrite Zpower_pos_is_exp.
rewrite Z.mul_mod by trivial.
rewrite <- IHm.
simpl. now destruct (Zpow_mod_pos a m n).
- now rewrite Zpower_pos_1_r.
Qed.

Theorem Zpow_mod_correct a m n :
n <> 0 -> Zpow_mod a m n = (a ^ m) mod n.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpow_mod_correct".
intros Hn. destruct m; simpl; trivial.
- apply Zpow_mod_pos_correct; auto with zarith.
Qed.

Lemma Zpower_divide p q : 0 < q -> (p | p ^ q).
Proof. hammer_hook "Zpow_facts" "Zpow_facts.Zpower_divide".
exists (p^(q - 1)).
rewrite Z.mul_comm, <- Z.pow_succ_r; f_equal; auto with zarith.
Qed.

Theorem rel_prime_Zpower_r i p q :
0 <= i -> rel_prime p q -> rel_prime p (q^i).
Proof. hammer_hook "Zpow_facts" "Zpow_facts.rel_prime_Zpower_r".
intros Hi Hpq; pattern i; apply natlike_ind; auto with zarith.
simpl. apply rel_prime_sym, rel_prime_1.
clear i Hi. intros i Hi Rec; rewrite Z.pow_succ_r; auto.
apply rel_prime_mult; auto.
Qed.

Theorem rel_prime_Zpower i j p q :
0 <= i ->  0 <= j -> rel_prime p q -> rel_prime (p^i) (q^j).
Proof. hammer_hook "Zpow_facts" "Zpow_facts.rel_prime_Zpower".
intros Hi Hj H. apply rel_prime_Zpower_r; trivial.
apply rel_prime_sym. apply rel_prime_Zpower_r; trivial.
now apply rel_prime_sym.
Qed.

Theorem prime_power_prime p q n :
0 <= n -> prime p -> prime q -> (p | q^n) -> p = q.
Proof. hammer_hook "Zpow_facts" "Zpow_facts.prime_power_prime".
intros Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn.
- simpl; intros.
assert (2<=p) by (apply prime_ge_2; auto).
assert (p<=1) by (apply Z.divide_pos_le; auto with zarith).
omega.
- intros n Hn Rec.
rewrite Z.pow_succ_r by trivial. intros.
assert (2<=p) by (apply prime_ge_2; auto).
assert (2<=q) by (apply prime_ge_2; auto).
destruct prime_mult with (2 := H); auto.
apply prime_div_prime; auto.
Qed.