Require Import List.
Import ListNotations.

Require Import Undecidability.PCP.PCP.
Require Import Undecidability.PCP.Util.Facts.
Require Import Undecidability.PCP.Reductions.PCPX_iff_dPCP.

Require Import Undecidability.Synthetic.Definitions.

Lemma PCPb_iff_BPCP P : PCPb P <-> BPCP P.
Proof.
  unfold PCPb; rewrite PCPX_iff_dPCP; split.
  - intros (u & Hu); constructor 1 with u; trivial.
  - intros (u & Hu); exists u; trivial.
Qed.

Lemma reductionLR : PCPb ⪯ BPCP.
Proof. exists id; exact PCPb_iff_BPCP. Qed.

Lemma reductionRL : BPCP ⪯ PCPb.
Proof. exists id; intro; now rewrite PCPb_iff_BPCP. Qed.


(**

  - Dimitri Hendriks 2013-10-09

  - http://www.cs.vu.nl/~diem/coq/calkin-wilf/bijection.html

 *)

Set Implicit Arguments.

Section bijections.

  Variables A B : Type.

  Definition injective (f : A -> B) := forall x y : A, f x = f y -> x = y.

  Definition surjective (f : A -> B) := forall y : B, exists x : A, f x = y.

  Definition bijective (f : A -> B) : Type := injective f /\ surjective f.

  Definition left_inverse (f : A -> B) (f' : B -> A) :=
    forall x : A, f' (f x) = x.

  Definition right_inverse (f : A -> B) (f' : B -> A) :=
    forall y : B, f (f' y) = y.

  Definition inverse f f' :=
    left_inverse f f' /\  right_inverse f f'.

  Lemma left_inv_inj f f' : left_inverse f f' -> injective f.
  Proof.
    intros H x y H0.
    rewrite <- (H x).
    rewrite H0.
    apply H.
  Qed.

  Lemma right_inv_surj f f' : right_inverse f f' -> surjective f.
  Proof.
    intros H y.
    rewrite <- (H y).
    unfold right_inverse in H.
    exists (f' y). reflexivity.
  Qed.

  Lemma inv2bij f f' : inverse f f' -> bijective f.
  Proof.
    intros [H1 H2].
    econstructor. eapply (left_inv_inj H1). eapply (right_inv_surj H2).
  Qed.

End bijections.


Require Import Bool Arith.

Require Import List.
Import ListNotations.

From FormalSystems Require Import Base.

(** * Types and terms *)

Inductive Ty : Type :=
    | TNat : Ty
    | TArr : Ty -> Ty -> Ty.

Notation "a → b" := (TArr a b) (at level 60, right associativity).

Inductive Tm : Type :=
    | K : Tm
    | S : Tm
    | App : Tm -> Tm -> Tm
    | zero : Tm
    | succ : Tm
    | rec  : Tm.

Notation "M @ N" := (App M N) (at level 50, left associativity).

Inductive hasType : Tm -> Ty -> Prop :=
    | hasType_K :
        forall a b : Ty, hasType K (a → b → a)
    | hasType_S :
        forall a b c : Ty,
          hasType S ((a → b → c) → (a → b) → a → c)
    | hasType_App :
        forall (a b : Ty) (f x : Tm),
          hasType f (a → b) -> hasType x a ->
            hasType (App f x) b
    | hasType_zero :
        hasType zero TNat
    | hasType_succ :
        hasType succ (TNat → TNat)
    | hasType_rec :
        forall a : Ty,
          hasType rec (a → (TNat → a → a) → TNat → a).

Inductive red : Tm -> Tm -> Prop :=
    | red_K :
        forall x y : Tm,
          red (K @ x @ y) x
    | red_S :
        forall x y z : Tm,
          red (S @ x @ y @ z) (x @ z @ (y @ z))
    | red_rec_zero :
        forall z s : Tm,
          red (rec @ z @ s @ zero) z
    | red_rec_succ :
        forall z s n : Tm,
          red (rec @ z @ s @ (succ @ n)) (s @ n @ (rec @ z @ s @ n))
    | red_AppL :
        forall t1 t1' t2 : Tm,
          red t1 t1' -> red (t1 @ t2) (t1' @ t2)
    | red_AppR :
        forall t1 t2 t2' : Tm,
          red t2 t2' -> red (t1 @ t2) (t1 @ t2').

Notation "A ~> B" := (red A B) (at level 60).

#[global] Hint Constructors Ty Tm hasType red rtc : core.

Definition reds := rtc red.

#[global] Hint Unfold reds : core.

Infix "~>*" := reds (at level 50).

Definition isNormal (t : Tm) : Prop :=
  forall t' : Tm, ~ red t t'.

Inductive Nf : Tm -> Prop :=
    | Nf_K0    : Nf K
    | Nf_K1    : forall t : Tm, Nf t -> Nf (K @ t)
    | Nf_S0    : Nf S
    | Nf_S1    : forall t : Tm, Nf t -> Nf (S @ t)
    | Nf_S2    : forall t1 t2 : Tm, Nf t1 -> Nf t2 -> Nf (S @ t1 @ t2)
    | Nf_zero  : Nf zero
    | Nf_succ0 : Nf succ
    | Nf_succ1 : forall t : Tm, Nf t -> Nf (succ @ t)
    | Nf_rec0  : Nf rec
    | Nf_rec1  : forall t : Tm, Nf t -> Nf (rec @ t)
    | Nf_rec2  : forall t1 t2 : Tm, Nf t1 -> Nf t2 -> Nf (rec @ t1 @ t2)
    | Nf_Ne    : forall t : Tm, Ne t -> Nf t

with Ne : Tm -> Prop :=
    | Ne_App : forall t1 t2 : Tm, Ne t1 -> Nf t2 -> Ne (t1 @ t2)
    | Ne_rec : forall t1 t2 t3 : Tm, Nf t1 -> Nf t2 -> Ne t3 -> Ne (rec @ t1 @ t2 @ t3).

Inductive Nf' : Tm -> Prop :=
    | Nf'K0   : Nf' K
    | Nf'K1   : forall t : Tm, Nf' t -> Nf' (K @ t)
    | Nf'S0   : Nf' S
    | Nf'S1   : forall t : Tm, Nf' t -> Nf' (S @ t)
    | Nf'S2   : forall t1 t2 : Tm, Nf' t1 -> Nf' t2 -> Nf' (S @ t1 @ t2)
    | Nf'rec0 : Nf' rec
    | Nf'rec1 : forall t : Tm, Nf' t -> Nf' (rec @ t)
    | Nf'rec2 : forall t1 t2 : Tm, Nf' t1 -> Nf' t2 -> Nf' (rec @ t1 @ t2)
    | Nf'Ne'  : forall t : Tm, Ne' t -> Nf' t

with      Ne' : Tm -> Prop :=
    | Ne'zero : Ne' zero
    | Ne'succ : Ne' succ
    | Ne'App  : forall t1 t2 : Tm, Ne' t1 -> Nf' t2 -> Ne' (t1 @ t2).

Inductive Nf3 : Tm -> Prop :=
    | Nf3K1   : forall t : Tm, Nf3 t -> Nf3 (K @ t)
    | Nf3S0   : Nf3 S
    | Nf3S1   : forall t : Tm, Nf3 t -> Nf3 (S @ t)
    | Nf3S2   : forall t1 t2 : Tm, Nf3 t1 -> Nf3 t2 -> Nf3 (S @ t1 @ t2)
    | Nf3rec0 : Nf3 rec
    | Nf3rec1 : forall t : Tm, Nf3 t -> Nf3 (rec @ t)
    | Nf3rec2 : forall t1 t2 : Tm, Nf3 t1 -> Nf3 t2 -> Nf3 (rec @ t1 @ t2)
    | Nf3Ne'  : forall t : Tm, Ne3 t -> Nf3 t

     with Ne3 : Tm -> Prop :=
    | Ne3K0   : Ne3 K
    | Ne3zero : Ne3 zero
    | Ne3succ : Ne3 succ
    | Ne3App  : forall t1 t2 : Tm, Ne3 t1 -> Nf3 t2 -> Ne3 (t1 @ t2).

#[global] Hint Constructors Nf Ne Nf' Ne' Nf3 Ne3 : core.

Ltac wut :=
repeat match goal with
    | |- forall _, _ => intro
    | |- ~ _ => intro
    | |- _ /\ _ => split
    | H : _ /\ _ |- _ => destruct H
    | H : red (_ @ _) _ |- _ => inv H
    | H : red K       _ |- _ => inv H
    | H : red S       _ |- _ => inv H
    | H : red zero    _ |- _ => inv H
    | H : red succ    _ |- _ => inv H
    | H : red rec     _ |- _ => inv H
    | H : isNormal ?t, H' : red ?t _ |- _ => destruct (H _ H')
    | |- isNormal _ => do 2 intro
    | H : exists _, _   |- _ => decompose [ex and] H; clear H
    | H : Ne ?x          |- _ => is_var x + inv H
    | H : Ne' ?x          |- _ => is_var x + inv H
    | _ => auto
end.

Fixpoint Nf_isNormal {t : Tm} (nf : Nf t) {struct nf} : isNormal t

with     Ne_isNormal {t : Tm} (ne : Ne t) {struct ne} : isNormal t.
Proof.
  destruct nf.
    wut.
    red. do 2 intro. inv H.
    1-11: wut; eapply Nf_isNormal;
      repeat match goal with
          | |- red _ _ => eauto
      end; eauto.
    apply Ne_isNormal. assumption.
  destruct ne.
    wut.
      eapply Ne_isNormal; eauto.
      eapply Nf_isNormal; eauto.
    wut.
      eapply Nf_isNormal. 2: eauto. eauto.
      eapply Nf_isNormal. 2: eauto. eauto.
      eapply Ne_isNormal. 2: eauto. eauto.
Qed.

Fixpoint Nf'_isNormal {t : Tm} (nf : Nf' t) {struct nf} : isNormal t

with     Ne'_isNormal {t : Tm} (ne : Ne' t) {struct ne} : isNormal t.
Proof.
  destruct nf; wut.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal. 2: eauto. eauto.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal. 2: eauto. eauto.
    eapply Nf'_isNormal; eauto.
    eapply Ne'_isNormal; eauto.
  destruct ne; wut.
    eapply Ne'_isNormal; eauto.
    eapply Nf'_isNormal; eauto.
Qed.

Lemma isNormal_Nf' :
  forall {t : Tm}, isNormal t -> Nf' t.
Proof.

      Ltac hehe :=
      repeat match goal with
          | H : forall _, ~ _ |- False => eapply H; eauto
          | H : _ -> Nf' _ |- Nf' _ => apply H; do 2 intro
          | |- Nf' (_ @ _) => constructor; auto
          | |- Ne' (_ @ _) => constructor; auto
          | H : Nf' (_ @ _) |- _ => inv H
          | H : Ne' (_ @ _) |- _ => inv H
      end.

  unfold isNormal.
  induction t; intros; auto.
  destruct t1.
    1-2, 4-6: hehe.
    destruct t1_1. all: cycle 3.
      do 2 constructor.
        assert (Nf' (zero @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0.
        apply IHt2. do 2 intro. eapply H. eauto.
      do 2 constructor.
        assert (Nf' (succ @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0.
        apply IHt2. do 2 intro. eapply H. eauto.
      constructor.
        assert (Nf' (rec @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0. inv H1.
        apply IHt2. do 2 intro. eapply H. eauto.
      specialize (H t1_2). contradict H. eauto.
      constructor.
        assert (Nf' (S @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0. inv H1.
        apply IHt2. do 2 intro. eapply H. eauto.
      assert (Nf' (t1_1_1 @ t1_1_2 @ t1_2)).
        apply IHt1. do 2 intro. eapply H. eauto.
        inv H0.
          specialize (H (t1_1_2 @ t2 @ (t1_2 @ t2))). contradict H. eauto.
          exfalso. eapply H.
Abort.

Goal
  forall t : Tm,
    Nf' t -> hasType t TNat -> t = zero \/ exists t' : Tm, t = succ @ t' /\ hasType t' TNat.
Proof.
  induction 1; intros HT; inv HT.
    inv H2.
    inv H2.
    inv H3. inv H4.
    inv H2.
    inv H3. inv H4.
    revert x a H0 H1 H. induction f; intros.
      inv H0.
      inv H0.
      inv H0. inv H4.
        inv H. inv H3. inv H2.
        inv H.
Abort.

Lemma isNormal_Nf' :
  forall {t : Tm} {a : Ty}, hasType t a -> isNormal t -> Nf' t.
Proof.
  unfold isNormal.
  induction 1; intros; auto.
  inv H; cycle 3.
    do 2 constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    inv H2. all: cycle 3.
      constructor.
        assert (Nf' (rec @ x0)).
          apply IHhasType1. wut. eapply H1. eauto.
          inv H. inv H2.
        apply IHhasType2. wut. eapply H1. eauto.
      specialize (H1 x0). contradict H1. eauto.
      constructor; auto.
        assert (Nf' (S @ x0)).
          apply IHhasType1. wut. eapply H1. eauto.
          inv H. inv H2.
        apply IHhasType2. wut. eapply H1. eauto.
      assert (Nf' (f @ x1 @ x0)).
        apply IHhasType1. do 2 intro. eapply H1. eauto.
        inv H2.
          specialize (H1 (x1 @ x @ (x0 @ x))). contradict H1. eauto.
          assert (Nf' x).
            apply IHhasType2. do 2 intro. eapply H1. eauto.
            inv H. inv H0; try inv H6; try inv H8; try inv H6.
              inv H.
                inv H2.
                  inv H0.
                  inv H0.
                  inv H. inv H10. inv H8.
                    inv H0.
Abort.

Definition hasNormal (t : Tm) : Prop :=
  exists t' : Tm, reds t t' /\ isNormal t'.

Definition WN (t : Tm) (a : Ty) : Prop :=
  exists t' : Tm, hasType t' a /\ rtc red t t' /\ isNormal t'.

Fixpoint Reducible (t : Tm) (ty : Ty) : Prop :=
match ty with
    | TNat     => WN t TNat
    | TArr a b => WN t (TArr a b) /\
                  forall t' : Tm,
                    hasType t' a -> Reducible t' a -> Reducible (t @ t') b
end.

Fixpoint R' (t : Tm) (ty : Ty) : Prop :=
match ty with
    | TNat     => True
    | TArr a b => forall t' : Tm,
                    hasType t' a -> R' t' a -> R' (t @ t') b
end.

Goal
  forall t ty,
    Reducible t ty <-> WN t ty /\ R' t ty.
Proof.
  split.
    revert t. induction ty; cbn; intros.
      auto.
      firstorder. destruct ty2; cbn.
        trivial.
        intros. cbn in *. edestruct IHty2.
Abort.

Lemma reds_AppL :
  forall t1 t1' t2 : Tm,
    reds t1 t1' -> reds (t1 @ t2) (t1' @ t2).
Proof.
  unfold reds.
  induction 1; eauto.
Qed.

Lemma reds_AppR :
  forall t1 t2 t2' : Tm,
    reds t2 t2' -> reds (t1 @ t2) (t1 @ t2').
Proof.
  unfold reds.
  induction 1; eauto.
Qed.

Lemma reds_App :
  forall t1 t1' t2 t2' : Tm,
    reds t1 t1' -> reds t2 t2' -> reds (t1 @ t2) (t1' @ t2').
Proof.
  intros.
  eapply rtc_trans.
    apply reds_AppL. eassumption.
    apply reds_AppR. eassumption.
Qed.

Lemma hasType_Reducible :
  forall {a : Ty} {t : Tm},
    hasType t a -> Reducible t a.
Proof.
  induction 1.
    cbn. split.
      red. exists K. repeat split; auto. wut.
      split; intros.
        red. destruct a; cbn in *; unfold WN in *.
          decompose [ex and] H0; clear H0. exists (K @ x). split; eauto. split.
            apply reds_AppR. assumption.
            wut.
          decompose [ex and] H0; clear H0. exists (K @ x). split; eauto. split.
            apply reds_AppR. assumption.
            wut.
        clear -a H0. induction a; cbn in *; unfold WN in *; intros.
          wut. exists x. wut. constructor 3 with (K @ x @ t'0).
            apply reds_AppL, reds_AppR. assumption.
            auto.
          wut.
            exists x. wut. constructor 3 with (K @ x @ t'0).
              apply reds_AppL, reds_AppR. assumption.
              auto.
            admit.
    admit.
    cbn in *. wut.
    cbn. wut. red. exists zero. wut.
    cbn. wut.
      red. exists succ. wut.
      unfold WN in *. wut. exists (succ @ x). wut.
        eauto.
        apply reds_AppR. assumption.
    cbn. unfold WN. wut.
      exists rec. wut.
      destruct a; cbn in *; unfold WN in *; wut.
        exists (rec @ x). wut.
          eauto.
          apply reds_AppR. assumption.
        exists (rec @ x). wut.
          eauto.
          apply reds_AppR. assumption.
      destruct a; cbn in *; unfold WN in *; wut.
        exists (rec @ x0 @ x). wut.
          eauto.
          repeat apply reds_App; unfold reds; auto.
        exists (rec @ x0 @ x). wut.
          eauto.
          repeat apply reds_App; unfold reds; auto.
      edestruct (H5 _ H7).
        exists x. wut.
        wut. destruct a; cbn.
Abort.


Add LoadPath "$COQ_PROOFS" as Path.
Load unit_1_002_bool.

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday (next_weekday saturday)).
(* ==> tuesday : day *)

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Definition is_weekday (d:day) : bool :=
  match d with
  | monday => true
  | tuesday => true
  | wednesday => true
  | thursday => true
  | friday => true
  | saturday => false
  | sunday => false
  end.


Require Import Setoid.

Generalizable All Variables.

Module PO.

  Class BoolPreorder {A:Type}(leb : A -> A -> bool) :=
    { leb_refl : forall a:A, leb a a = true;
      leb_trans :
        forall a b c, leb a b = true -> leb b c = true -> leb a c = true;
      leb_false : forall a b, leb a b = false -> leb b a = true}.

  (** derivate boolean functions *)

  Definition ltb {A:Type}{leb : A -> A -> bool}{P: BoolPreorder leb}:=
    fun a b => if leb a b then negb (leb b a) else false.

  Definition equivb  {A:Type}{leb : A -> A -> bool}{P: BoolPreorder leb}:=
    fun a b => if leb a b then leb b a else false.

  (** Derivate Predicates *)

  Definition le {A:Type}{leb : A -> A -> bool}{P: BoolPreorder leb}:=
    fun a b => leb a b = true.

  Definition lt {A} {leb: A -> A -> bool} {P : BoolPreorder leb} (a b: A) :=
    ltb a b = true.

  Definition equiv {A} {leb: A -> A -> bool} {P : BoolPreorder leb} (a b: A) :=
    equivb a b = true.

  Section Properties.
    Variables (A: Type) (leb : A -> A -> bool).
    Context (P: BoolPreorder leb).

    Lemma le_refl : forall a, le a a.
    Proof.
      intro a; unfold le; now rewrite leb_refl.
    Qed.

    Lemma le_trans : forall a b c, le a b -> le b c -> le a c.
    Proof.
      intros a b c H H0; unfold le.
      rewrite (leb_trans a b c H H0); trivial.
    Qed.

    Lemma ltb_irrefl : forall a, ltb a a = false.
    Proof.
      intro a; unfold ltb.
      now rewrite leb_refl.
    Qed.

    Lemma ltb_lt : forall a b, ltb a b = true <-> lt a b.
    Proof.
      unfold lt; tauto.
    Qed.
    Lemma leb_le : forall a b, leb a b = true <-> le a b.
    Proof.
      unfold le; tauto.
    Qed.
    Lemma equivb_equiv : forall a b, equivb a b = true <-> equiv a b.
    Proof.
      unfold equiv; tauto.
    Qed.

    Lemma lt_irrefl : forall a:A , ~ lt a a.
    Proof.
      intros a H; unfold lt in H.
      rewrite ltb_irrefl in H.
      discriminate.
    Qed.

    Hint Resolve le_refl le_trans lt_irrefl.

    Lemma le_lt_or_equiv :  forall a b, le a b -> lt a b \/ equiv a b.
    Proof.
      unfold le, lt, ltb, equiv, equivb;intros.
      case_eq (leb a b); case_eq (leb b a); intros; auto.
      - congruence.
      - congruence.
    Qed.

    Lemma lt_not_equiv : forall a b, lt a b -> ~ equiv a b.
    Proof.
      unfold lt, equiv, ltb, equivb.
      intros a b;case_eq (leb a b); case_eq (leb b a);auto; try discriminate.
    Qed.

    Lemma equiv_refl : forall a, equiv a a.
    Proof.
      intros ; unfold equiv, equivb; now rewrite leb_refl.
    Qed.

    Lemma equiv_trans: forall a b c, equiv a b -> equiv b c -> equiv a c.
    Proof.
      unfold equiv, equivb; intros.
      case_eq (leb a b);case_eq (leb b c).
      - intros ;  rewrite H1, H2 in *;  rewrite (leb_trans  a b c H2 H1);
        now rewrite (leb_trans  c b a H0 H).
      -  intros;   rewrite H1, H2 in *;    discriminate.
      -  intros;   rewrite H1, H2 in *;    discriminate.
      -  intros;   rewrite H1, H2 in *;    discriminate.
    Qed.

    Lemma equiv_sym: forall a b , equiv a b -> equiv b a.
    Proof.
      unfold equiv, equivb; intros.
      case_eq (leb a b).
      - intro H0; rewrite H0 in *.
        now rewrite H.
      -  intro H0; rewrite H0 in H.
         discriminate.
    Qed.

    Hint Resolve equiv_sym equiv_trans.

    Lemma le_or_lt : forall a b, le a b \/ lt b a.
    Proof.
      unfold le, lt, ltb.
      intros a b; case_eq (leb a b); auto.
      right;   now rewrite (leb_false _ _ H).
    Qed.

    Lemma negb_inv : forall b, negb b = true <-> b = false.
    Proof.
      destruct b;split;auto.
    Qed.

    Lemma lt_trans : forall a b c:A , lt a b -> lt b c -> lt a c.
    Proof.
      unfold lt, ltb.
      intros a b c; case  (leb a b); case_eq (leb b c); try discriminate.
      intros.
      rewrite negb_inv in H0, H1.
      case_eq (leb c a).
      intro H2.
      rewrite (leb_trans _ _ _ H H2) in H0; discriminate.
      intro H2; apply leb_false in H2; now rewrite H2.
    Qed.

    Hint Resolve lt_trans.

    Lemma lt_not_le : forall a b, lt a b -> ~ le b a.
    Proof.
      intros a b H H0; destruct (le_lt_or_equiv _ _ H0).
      - destruct (lt_irrefl a);eauto.
      -  destruct (lt_not_equiv a b);auto.
    Qed.

    Hint Resolve lt_not_le.

    Lemma lt_iff : forall a b, lt a b <-> le a b /\ ~ equiv a b.
    Proof.
      split; intros.
      - split.
        red; apply leb_false;auto.
        red in H.
        unfold ltb in H.
        case_eq (leb a b); intro H0; rewrite H0 in *.
        +  now  rewrite negb_inv in H.
        +   discriminate.
        +  unfold lt, equiv, ltb, equivb  in *.
           case_eq (leb a b).
           *  intro H0; rewrite H0 in *; rewrite negb_inv in H;
              rewrite H;discriminate.
           *   discriminate.
      -
        destruct H;  unfold lt, equiv, ltb, equivb  in *.
        case_eq (leb a b).
        +  intro H1; rewrite H1 in *; rewrite negb_inv;  destruct (leb b a);auto.
           * now destruct H0.
        + intro H1; rewrite H1 in *.
          red in H;rewrite H in H1; discriminate.
    Qed.

    Lemma equiv_iff : forall a b, equiv a b <-> le a b /\ le b a.
    Proof.
      split; intros  H.
      - unfold le, equiv in *.
        unfold equivb in H.
        case_eq (leb a b).
        + intro H0; rewrite H0 in *; auto.
        +   intro H0; rewrite H0 in *; auto.
            discriminate.
      - unfold le, equiv, equivb  in *.
        destruct H as [H0 H1]; now rewrite H0, H1 in *.
    Qed.

    Lemma equiv_lt : forall a b c, equiv a b -> lt b c -> lt a c.
      intros.
      rewrite lt_iff in *.
      destruct H0;split.
      rewrite equiv_iff in H1.
      apply le_trans with b;auto.
      rewrite equiv_iff in H; tauto.
      intro H2; destruct H1.
      apply equiv_trans with a.
      now apply equiv_sym.
      auto.
    Qed.

    Lemma lt_equiv : forall a b c, lt a b -> equiv b c -> lt a c.
      intros.
      rewrite lt_iff in *.
      rewrite equiv_iff in H0.
      destruct H, H0; split.

      apply le_trans with b;auto.
      intro H3; destruct H1.
      apply equiv_trans with c; trivial. rewrite  equiv_iff; auto.
    Qed.

    Lemma le_lt_trans : forall a b c, le a b -> lt b c -> lt a c.
    Proof.
      intros a b c H H0.
      destruct (le_lt_or_equiv _ _ H).
      now apply lt_trans with b.
      apply equiv_lt with b;auto.
    Qed.

    Lemma lt_le_trans : forall a b c, lt a b -> le b c -> lt a c.
    Proof.
      intros a b c H H0.
      destruct (le_lt_or_equiv _ _ H0).
      now apply lt_trans with b.
      apply lt_equiv with b;auto.
    Qed.

  End Properties.

  Instance BoolReverse {A}{leb : A -> A -> bool}(P: BoolPreorder leb):
    BoolPreorder (fun x y => leb y x).
  Proof.
    split.
    -  apply leb_refl.
    - intros; now apply (@leb_trans A leb P c b a).
    - intros; now apply (@leb_false A leb P   b a).
  Qed.

  Definition lexico_leb {A B : Type} {lebA : A -> A -> bool}
             {lebB : B -> B -> bool} (PA: BoolPreorder lebA)
             (PB: BoolPreorder lebB)
  : A * B -> A * B -> bool :=
    fun p q =>
      if ltb (fst p) (fst q)
      then true
      else  if equivb (fst p) (fst q)
            then lebB (snd p) (snd q)
            else false.

  Instance Lexico {A B : Type} {lebA : A -> A -> bool}
           {lebB : B -> B -> bool} (PA: BoolPreorder lebA)
           (PB: BoolPreorder lebB) : BoolPreorder (lexico_leb PA PB).

  unfold lexico_leb; split.
  - intro a; rewrite ltb_irrefl. unfold equivb. now repeat rewrite leb_refl.
  - intros a b c ;
    case_eq (ltb (fst a) (fst b)); case_eq  (ltb (fst b) (fst c)); intros.

    repeat (rewrite ltb_lt in * ||
            rewrite leb_le in * ||
            rewrite equivb_equiv in *) .
            generalize (lt_trans _ _ _ _ _ _ H0 H).
            rewrite <- ltb_lt; intro H3;rewrite H3; trivial.

 Admitted.

End PO.

Require Import ZArith.
Import PO.

Instance Z_leb : BoolPreorder Z.leb.
Proof.
  split.
  -  intros; now rewrite Z.leb_refl.
  -   intros; eapply Zle_bool_trans; eauto.
  -   intros a b H; rewrite    Z.leb_gt in H.
      apply Zle_imp_le_bool; auto with zarith.
Qed.

Definition Z_down := BoolReverse Z_leb.
About ltb.

Compute ltb (P:= Z_down) 8%Z (-4)%Z.

Definition  Z2 : BoolPreorder (lexico_leb Z_leb Z_leb).
Proof.
  apply Lexico.
Qed.

Compute ltb  (5,8900)%Z (6,0)%Z.

Compute ltb  (5,8900)%Z (5,0)%Z.

About lt.
Goal lt (5,8900)%Z (6,0)%Z.
  unfold lt.
  reflexivity.
Qed.

Locate le_lt_trans.

About Top.le_lt_trans.

(** Must be re-declared ouside the Section *)

Hint Resolve lt_trans.
Goal forall a b c : Z * Z, lt a b -> lt b c -> lt a c.
  eauto.
Qed.

(** Exemple *)

Require Import List.
Fixpoint mini_aux {A} {leb: A -> A -> bool}
         {P: BoolPreorder leb} x (l:list A) :=
  match l with
    | nil => x
    | (a::l') => if ltb a x then mini_aux a l' else mini_aux x l'
  end.

Definition mini {A} {leb: A -> A -> bool}{P: BoolPreorder leb}
           (l:list A) : option A :=
  match l with
    | nil => None
    | x::l' => Some (@mini_aux A leb P  x l')
  end.

Compute mini (P:= Z_down)  (4::6::2::nil)%Z.

Compute mini (P:= Z_leb)  (4::6::2::nil)%Z.

Compute mini ((4,8)::(4,9)::(3,999)::nil)%Z.

Compute mini (P:= BoolReverse Z2) ((4,8)::(4,9)::(3,999)::nil)%Z. Generalizable All Variables.

Class BoolPreorder {A:Type}(leb : A -> A -> bool) :=
  { leb_refl : forall a:A, leb a a = true;
    leb_trans :
      forall a b c, leb a b = true -> leb b c = true -> leb a c = true;
    leb_false : forall a b, leb a b = false -> leb b a = true}.

Definition ltb {A:Type}{leb : A -> A -> bool}{P: BoolPreorder leb}:=
fun a b => if leb a b then negb (leb b a) else false.

Definition equivb  {A:Type}{leb : A -> A -> bool}{P: BoolPreorder leb}:=
 fun a b => if leb a b then leb b a else false.

Definition le {A:Type}{leb : A -> A -> bool}{P: BoolPreorder leb}:=
fun a b => leb a b = true.

Definition lt {A} {leb: A -> A -> bool} {P : BoolPreorder leb} (a b: A) :=
ltb a b = true.

Definition equiv {A} {leb: A -> A -> bool} {P : BoolPreorder leb} (a b: A) :=
equivb a b = true.

Section Properties.
Variables (A: Type) (leb : A -> A -> bool).
Context (P: BoolPreorder leb).

 Lemma le_refl : forall a, le a a.
 Proof.
   intro a; unfold le; now rewrite leb_refl.
 Qed.

 Lemma le_trans : forall a b c, le a b -> le b c -> le a c.
 Proof.
  intros a b c H H0; unfold le.
  rewrite (leb_trans a b c H H0); trivial.
 Qed.

 Lemma ltb_irrefl : forall a, ltb a a = false.
 Proof.
 intro a; unfold ltb.
 now rewrite leb_refl.
 Qed.

 Lemma lt_irrefl : forall a:A , ~ lt a a.
 Proof.
  intros a H; unfold lt in H.
  rewrite ltb_irrefl in H.
  discriminate.
 Qed.

  Lemma le_lt_or_equiv :  forall a b, le a b -> lt a b \/ equiv a b.
  Proof.
 unfold le, lt, ltb, equiv, equivb;intros.
 case_eq (leb a b); case_eq (leb b a); intros; auto.
 - congruence.
 -   congruence.
 Qed.

 Lemma lt_not_equiv : forall a b, lt a b -> ~ equiv a b.
 Proof.
   unfold lt, equiv, ltb, equivb.
  intros a b;case_eq (leb a b); case_eq (leb b a);auto; try discriminate.
 Qed.

 Lemma le_or_lt : forall a b, le a b \/ lt b a.
 Proof.
   unfold le, lt, ltb.
   intros a b; case_eq (leb a b); auto.
   right.
   now rewrite (leb_false _ _ H).
 Qed.

 Lemma lt_not_le : forall a b, lt a b -> ~ le b a.
 Proof.
  unfold le, lt, ltb.
   intros a b; case_eq (leb a b); auto.
    case (leb b a);
    discriminate.
  discriminate.
Qed.

  Lemma lt_trans : forall a b c:A , lt a b -> lt b c -> lt a c.
  Proof.
    unfold lt, ltb.
    intros a b c; case  (leb a b); case_eq (leb b c); try discriminate.
   intros.
   Admitted.

End Properties.


Inductive BHeapF {A : Type} (R : A -> A -> Prop) (X : Type) (Y : A -> X -> Prop) : Type :=
| E
| N (v : A) (l r : X) (okl : Y v l) (okr : Y v r).

Arguments E {A R X Y}.
Arguments N {A R X Y} _ _ _ _ _.

Definition OKR
  {A : Type} (R : A -> A -> Prop) (X : Type) (Y : A -> X -> Prop)
  (v : A) (h : BHeapF R X Y) : Prop :=
match h with
| E => True
| N hv l _ _ _ => R v hv
end.

Fail Inductive BHeap {A : Type} (R : A -> A -> Prop) : Type :=
| In : BHeapF R (BHeap R) (OKR R (BHeap R) (fun _ _ => True)) -> BHeap R.

Module SecondTry.

Inductive BHeapF {A : Type} (R : A -> A -> Prop) (X Y Z : Type) : Type :=
| E
| N (v : A) (l r : X) (okl : Y) (okr : Z).

Arguments E {A R X Y Z}.
Arguments N {A R X Y Z} _ _ _ _ _.

Definition OKR
  {A : Type} (R : A -> A -> Prop) (X Y Z : Type)
  (v : A) (h : BHeapF R X Y Z) : Prop :=
match h with
| E => True
| N hv l _ _ _ => R v hv
end.

Fail Inductive BHeap {A : Type} (R : A -> A -> Prop) : Type :=
| In : BHeapF R (BHeap R) (OKR R (BHeap R) (forall _ _, True) (forall _ _, True)) (OKR R (BHeap R) (fun _ _ => True)) -> BHeap R.

End SecondTry.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.

Require Export HoTT.Basics.Trunc.
Require Export HoTT.Types.Forall.
Require Export HoTT.Types.Sum.

Section left_inv_equi_contr.
  Context
    {A B : Type}
    (Bc : Contr B)
    {f : A → B}
    {g : B → A}
    (Hd : ∀ x, g (f x) = x)
  .

  Theorem f_equal_inv
          {a b : A}
          (u : a = b)
    :
      match Hd a in _ = x return x = _ with
        idpath =>
        match Hd b in _ = y return _ = y with
          idpath =>
          f_equal g (f_equal f u)
        end
      end
      = u
  .
  Proof.
    destruct u.
    cbn.
    destruct (Hd a).
    trivial.
  Defined.

  Instance left_inv_equi_contr : Contr A.
  Proof.
    refine (BuildContr _ (g (@center _ Bc)) _).
    intros y.
    match goal with
      [|- ?A = ?B] =>
      rewrite <- (Hd A);
        rewrite <- (Hd B)
    end.
    apply f_equal.
    match goal with
      [|- ?A = ?B] =>
      transitivity (@center _ Bc);
        [symmetry|]; apply (@contr _ Bc)
    end.
  Qed.

End left_inv_equi_contr.

Section left_inv_equi_trunc.
  Context
    {A B : Type}
    (n : trunc_index)
    (Bc : IsTrunc n B)
    {f : A → B}
    {g : B → A}
    (Hd : ∀ x, g (f x) = x)
  .

  Instance left_inv_equi_trunc : IsTrunc n A.
  Proof.
    revert A B f g Bc Hd.
    induction n as [|t]; clear n.
    {
      intros.
      eapply left_inv_equi_contr; eauto.
    }
    {
      intros A B f g Bt Hd.
      intros x y.
      assert (H := @f_equal_inv _ _ _ _ Hd x y).
      set (W := @f_equal _ _ f x y).
      set (V :=
             fun u =>
               match Hd x in _ = m return m = _ with
                 idpath =>
                 match Hd y in _ = n return _ = n with
                   idpath =>
                   @f_equal _ _ g (f x) (f y) u
                 end
               end
          ).
      apply (IHt _ _ W V).
      apply Bt.
      intros u.
      unfold V, W; clear V W.
      apply (f_equal_inv Hd u).
    }
  Qed.

End left_inv_equi_trunc.

Section eq_sig_morph.
  Context
    {A : Type}
    {P : A → hProp}
  .

  Definition eq_sig_morph_eq_morph
             {h h' : sigT P}
             (H : h = h')
    : projT1 h = projT1 h'
  .
  Proof.
    destruct H.
    reflexivity.
  Defined.

  Definition eq_morph_eq_sig_morph
             {h h' : sigT P}
             (H : projT1 h = projT1 h')
    : h = h'
  .
  Proof.
    destruct h as [x Hx].
    destruct h' as [y Hy].
    cbn in H.
    destruct H.
    destruct (@center _ (istrunc_trunctype_type (P x) Hx Hy)).
    reflexivity.
  Defined.

Theorem eq_sig_morph_eq_morph_inv
          {h h' : sigT P}
          (H : h = h')
    : eq_morph_eq_sig_morph (eq_sig_morph_eq_morph H) = H
  .
  Proof.
    unfold eq_sig_morph_eq_morph, eq_morph_eq_sig_morph.
    destruct H.
    destruct h as [x Hx].
    rewrite (@contr _ (istrunc_trunctype_type (P x) Hx Hx) idpath).
    reflexivity.
  Defined.

  Theorem eq_morph_eq_sig_morph_inv
          {h h' : sigT P}
          (H : projT1 h = projT1 h')
    : eq_sig_morph_eq_morph (eq_morph_eq_sig_morph H) = H
  .
  Proof.
    unfold eq_sig_morph_eq_morph, eq_morph_eq_sig_morph.
    destruct h as [x Hx]; destruct h' as [y Hy].
    cbn in *.
    destruct H.
    destruct (@center _ _).
    reflexivity.
  Defined.

  Theorem sig_f_equal_inv
          {h h' : sigT P}
          (H H': h = h')
          (u : H = H')
    :
      match eq_sig_morph_eq_morph_inv H in _ = x return x = _ with
        idpath =>
        match eq_sig_morph_eq_morph_inv H' in _ = y return _ = y with
          idpath =>
          f_equal eq_morph_eq_sig_morph (f_equal eq_sig_morph_eq_morph u)
        end
      end
      = u
  .
  Proof.
    destruct u.
    destruct H.
    cbn.
    destruct h as [x Hx].
    destruct Overture.internal_paths_rew_r.
    trivial.
  Defined.

End eq_sig_morph.

Section HSet_then_sig_HProp_HSet.
  Context
    {A : hProp}
    {P : A → hProp}
  .

  Instance HProp_then_sig_HProp_HProp : IsHProp (sig P).
  Proof.
    intros [x Hx] [y Hy].
    cbn in *.
    refine (BuildContr _ _ _).
    destruct (@center _ (istrunc_trunctype_type A x y)).
    destruct (@center _ (istrunc_trunctype_type (P x) Hx Hy)).
    trivial.
    intros u.
    cbn.
    destruct (@center _ (istrunc_trunctype_type A x y)).
    destruct (@center _ (istrunc_trunctype_type (P x) Hx Hy)).
    rewrite <- (eq_sig_morph_eq_morph_inv 1).
    rewrite <- (eq_sig_morph_eq_morph_inv u).
    apply f_equal.
    transitivity ((@center _ (istrunc_trunctype_type A x x)));
      [symmetry|];
      apply ((@contr _ (istrunc_trunctype_type A x x)) _).
  Qed.

End HSet_then_sig_HProp_HSet.

Section Trunc_then_sig_HProp_Trunc.
  Context
    {n : trunc_index}
    {A : (n.+1)-Type}
    (P : A → hProp)
  .

  Instance Trunc_then_sig_HProp_Trunc : IsTrunc n.+1 (sig P).
  Proof.
    induction n as [|t]; clear n.
    apply HProp_then_sig_HProp_HProp.
    intros x y h h'.
    specialize
      (IHt
         (@BuildTruncType _ _ (istrunc_trunctype_type A (x.1) (y.1)))
         (fun u => HUnit)
         (exist (fun u => Unit) (eq_sig_morph_eq_morph h) tt)
         (exist (fun u => Unit) (eq_sig_morph_eq_morph h') tt)
      ).
    destruct x as [x Hx]; destruct y as [y Hy].
    assert (W := f_equal projT1 h).
    cbn in W.
    destruct W.
    destruct (@center _ (istrunc_trunctype_type (P x) Hx Hy)).
    transparent
      assert
      (g :
         (
           (
             (exist (fun u => Unit) (eq_sig_morph_eq_morph h) tt)
             = (exist (fun u => Unit) (eq_sig_morph_eq_morph h') tt)
           ) → h = h'
         )
      ).
    {
      intros H.
      rewrite <- (eq_sig_morph_eq_morph_inv h).
      rewrite <- (eq_sig_morph_eq_morph_inv h').
      apply f_equal.
      exact (f_equal pr1 H).
    }
    eapply
      (
        @left_inv_equi_trunc
          _
          _
          _
          IHt
          (
            fun w =>
              ((f_equal (fun v => (f_equal projT1 v; tt)) w))
          )
          g
      ).
    intros u.
    destruct u.
    unfold g; clear g.
    unfold Overture.internal_paths_rew.
    cbn in *.
    destruct (eq_sig_morph_eq_morph_inv h).
    trivial.
  Qed.

End Trunc_then_sig_HProp_Trunc.

Section Prod_Contr.
  Context
    {A B : Type}
    (CA : Contr A)
    (CB : Contr B)
  .

  Definition eq_componens_eq (x y : A * B) (H : x = y) : ((fst x = fst y) * (snd x = snd y)).
  Proof.
    refine (f_equal fst H, f_equal snd H).
  Defined.

  Definition componens_eq_eq (x y : A * B) (H : (fst x = fst y) * (snd x = snd y)) : x = y.
  Proof.
    refine (@pair_eq _ _ _ _ (fst H) (snd H)).
  Defined.

  Theorem eq_componens_eq_left_inv (x y : A * B) (H : x = y) :
    componens_eq_eq x y (eq_componens_eq x y H) = H.
  Proof.
    destruct H.
    destruct x.
    trivial.
  Qed.

  Instance Prod_Contr : Contr (A * B).
  Proof.
    refine (BuildContr _ (@center _ CA, @center _ CB) _).
    intros [y1 y2].
    apply pair_eq; apply contr.
  Qed.

End Prod_Contr.

Section Prod_Trunc.
  Context
    {n : trunc_index}
    {A B : Type}
    (HA : IsTrunc n A)
    (HB : IsTrunc n B)
  .

  Instance Prod_Trunc : IsTrunc n (A * B).
  Proof.
    revert A B HA HB.
    induction n as [|t]; clear n.
    intros; apply Prod_Contr; trivial.
    intros A B HA HB [x1 x2] [y1 y2].
    assert (Ht : IsTrunc t ((x1 = y1) * (x2 = y2))).
    {
      apply IHt.
      apply HA.
      apply HB.
    }
    {
      apply (
          @left_inv_equi_trunc
            ((x1, x2) = (y1, y2))
            ((x1 = y1) * (x2 = y2))
            t
            Ht
            (eq_componens_eq (x1, x2) (y1, y2))
            (componens_eq_eq (x1, x2) (y1, y2))
            (eq_componens_eq_left_inv (x1, x2) (y1, y2))
        ).
    }
  Qed.

End Prod_Trunc.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_extension_1 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable axiom_betweennesssymmetry_2 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable axiom_innertransitivity_3 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A B C)).
Variable defray_4 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_5 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).
Variable lemma_3_7b_6 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A B D)).

Theorem lemma_ray4_2_7 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Proof.
  time tac.
Qed.

End FOFProblem.


From hydras Require Import OrdinalNotations.ON_Generic.
From Coq Require Import Relations.

(** Prove that, in any ordinal notation, every ordinal has
     at most one predecessor and one successor *)

Section Proofs_of_unicity.

Context (A:Type)
        (lt : relation A)
        (compare : A -> A -> comparison)
        (On : ON lt compare).

(** Please remind that [Successor beta alpha] must be read as
    "[beta] is a successor of [alpha]" *)

Lemma Successor_unicity (alpha beta gamma : A):
  Successor beta alpha ->
  Successor gamma alpha ->
  gamma = beta.
Admitted.

Lemma Predecessor_unicity (alpha beta gamma : A):
  Successor beta alpha ->
  Successor beta gamma ->
  gamma = alpha.
Admitted.

End Proofs_of_unicity.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. rewrite 2 append_Nil. reflexivity.
  - simpl. rewrite append_Nil.  reflexivity.
  - simpl. rewrite 2 append_Nil. reflexivity.
Qed.

Theorem append_rev_Cons:
  forall (l1 l2: lst) (x: natural),
    rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
    f_equal. }
  { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
  induction l1.
  { induction l2.
    { simpl. lfind.
Admitted.

Theorem theorem0 : forall (x : lst), eq (rev (rev x)) x.
Proof.
  induction x.
  { simpl. rewrite rev_append. simpl. f_equal.
    assumption. }
  { simpl. reflexivity. }
Qed.


Require Import AbsTheorySyn.
Import Compare_dec List.

(*Instantiate Module sig*)
Module PresburgerSig <: TheorySig.

Inductive foterm' :=
| Var' : nat -> foterm'
| Cst_0' : foterm'
| Cst_1' : foterm'
| Df_Add' : foterm' -> foterm' -> foterm'.

Definition foterm := foterm'.
Definition Var := Var'.
Definition Cst_0 := Cst_0'.
Definition Cst_1 := Cst_1'.
Definition Df_Add := Df_Add'.

Fixpoint lift_term_rec t n k:=
  match t with
    | Var i =>
      match le_gt_dec k i with
        | left _ => Var (i+n)
        | right _ => Var i
      end
    | Cst_0 => Cst_0
    | Cst_1 => Cst_1
    | Df_Add u v => Df_Add (lift_term_rec u n k) (lift_term_rec v n k)
  end.

Definition lift_term t n := lift_term_rec t n 0.

Lemma lift_term0 : forall t, lift_term t 0 = t.
induction t; intros; unfold lift_term; simpl; trivial.
 apply f_equal; omega.

 unfold lift_term in IHt1, IHt2; rewrite IHt1, IHt2; trivial.
Qed.

Lemma lift_term_split : forall t n k,
  lift_term_rec t (S n) k = lift_term_rec (lift_term_rec t n k) 1 k.
induction t; trivial; unfold lift_term in *; simpl; intros.
 destruct (le_gt_dec k n) as [le|gt]; simpl.
  destruct (le_gt_dec k (n+n0)) as [le'|gt]; simpl; [apply f_equal|]; omega.

  destruct (le_gt_dec k n) as [le|gt']; simpl; [omega|trivial].

 rewrite IHt1, IHt2; trivial.
Qed.

Fixpoint subst_term_rec M N n:=
  match M with
    | Var i =>
      match lt_eq_lt_dec n i with
        | inleft (left _) => Var (pred i)
        | inleft (right _) => lift_term N n
        | inright _ => Var i
      end
    | Cst_0 => Cst_0
    | Cst_1 => Cst_1
    | Df_Add M1 M2 => Df_Add (subst_term_rec M1 N n) (subst_term_rec M2 N n)
  end.

Definition subst_term M N := subst_term_rec M N 0.

Fixpoint fv_term_rec t k : list nat :=
  match t with
    | Var n =>
      match le_gt_dec k n with
        | left _ => (n-k)::nil
        | right _ => nil
      end
    | Cst_0 => nil
    | Cst_1 => nil
    | Df_Add M N => (fv_term_rec M k) ++ (fv_term_rec N k)
  end.

Definition fv_term t := fv_term_rec t 0.

Lemma in_S_fv_term : forall t n k,
  In (S n) (fv_term_rec t k) <->
  In n (fv_term_rec t (S k)).
induction t; split; [| |contradiction|contradiction|contradiction|contradiction| |]; intros.
 simpl in H. destruct (le_gt_dec k n); [|contradiction].
  simpl in H. destruct H; [|contradiction].
   assert (n = (S k + n0)) by omega.
   subst n. unfold fv_term_rec.
   case_eq (le_gt_dec (S k) (S k + n0)); intros; [simpl; left|]; omega.

 unfold fv_term_rec in H.
 case_eq (le_gt_dec (S k) n); intros; rewrite H0 in H; [|contradiction].
  simpl in H. destruct H; [|contradiction].
   assert (n = k + S n0) by omega.
   subst n; unfold fv_term_rec.
   destruct (le_gt_dec k (k + S n0)); [simpl; left|]; omega.

 simpl in H |- *. rewrite in_app_iff in H |- *.
 destruct H as [Hl|Hr]; [left; apply IHt1|right; apply IHt2]; trivial.

 simpl in H |- *. rewrite in_app_iff in H |- *.
 destruct H as [Hl|Hr]; [left; apply IHt1|right; apply IHt2]; trivial.
Qed.

Lemma in_fv_term_lift : forall t n k k' k'',
  In n (fv_term_rec (lift_term_rec t k' k'') (k+k'+k'')) <->
  In n (fv_term_rec t (k+k'')).
induction t; simpl; intros; try reflexivity.
 destruct (le_gt_dec k'' n) as [le|gt]; simpl.
  destruct (le_gt_dec (k+k'+k'') (n+k')) as [le'|gt]; [simpl|].
   destruct (le_gt_dec (k+k'') n) as [le''|gt]; [simpl|omega].
    replace (n+k'-(k+k'+k'')) with (n-(k+k'')) by omega; reflexivity.

   destruct (le_gt_dec (k+k'') n) as [le'|gt']; [omega|reflexivity].

  destruct (le_gt_dec (k+k'+k'') n) as [le|gt']; [omega|].
   destruct (le_gt_dec (k+k'') n) as [le|gt'']; [omega|reflexivity].

 do 2 rewrite in_app_iff. rewrite IHt1, IHt2; reflexivity.
Qed.

Lemma in_fv_term_subst_split : forall t n N k k',
  In n (fv_term_rec (subst_term_rec t N k') (k+k')) ->
  In n (fv_term_rec N k) \/ In (S n) (fv_term_rec t (k+k')).
induction t; intros.
 unfold subst_term_rec in H |- *. simpl fv_term_rec at 2.
 destruct (lt_eq_lt_dec k' n) as [[lt|eq]|gt].
  unfold fv_term_rec in H; simpl in H.
  destruct (le_gt_dec (k+k') (pred n)) as [le|gt]; [|contradiction].
   simpl in H. destruct H; [right|contradiction].
   destruct (le_gt_dec (k+k') n) as [le'|gt]; [simpl; left|]; omega.

  subst n; left. unfold lift_term in H.
  replace (k+k') with (k+k'+0) in H by omega.
  apply (in_fv_term_lift _ _ k k' 0) in H.
  replace (k+0) with k in H by omega; trivial.

  simpl in H. destruct (le_gt_dec (k+k') n) as [le|gt']; [omega|contradiction].

 simpl in H; contradiction.

 simpl in H; contradiction.

 simpl in H |- *. rewrite in_app_iff in H |- *. destruct H.
  apply IHt1 in H. destruct H; [left|right; left]; trivial.

  apply IHt2 in H. destruct H; [left|right; right]; trivial.
Qed.

Lemma in_fv_term_subst : forall t n N k k',
  In (S n) (fv_term_rec t (k+k')) ->
  In n (fv_term_rec (subst_term_rec t N k') (k+k')).
induction t; simpl; intros; trivial.
 destruct (le_gt_dec (k + k') n) as [le|gt]; [|contradiction].
  simpl in H. destruct H; [|contradiction].
   assert (n=S (k+k'+n0)) by omega.
   subst n. destruct (lt_eq_lt_dec k' (S (k+k'+n0))) as [[lt|eq]|lt]; [simpl|omega|omega].
    destruct (le_gt_dec (k + k') (k + k' + n0)) as [le'|gt]; [simpl; left|]; omega.

 rewrite in_app_iff in H |- *. destruct H; [left; apply IHt1|right; apply IHt2]; trivial.
Qed.

End PresburgerSig.

(*Instantiate Module ax*)
Module PresburgerAx <: TheoryAx PresburgerSig.

Include FoLang PresburgerSig.

Definition ax_syn hyp f :=
  f = (fall (neg (eq_foterm Cst_0 (Df_Add (Var 0) Cst_1))))      \/
  f = (fall (fall (implf (eq_foterm (Df_Add (Var 0) Cst_1)
    (Df_Add (Var 1) Cst_1)) (eq_foterm (Var 0) (Var 1)))))       \/
  f = (fall (eq_foterm (Var 0) (Df_Add (Var 0) Cst_0)))          \/
  f = (fall(fall (eq_foterm (Df_Add (Df_Add (Var 0) (Var 1)) Cst_1)
                   (Df_Add (Var 0) (Df_Add (Var 1) (Cst_1)))))) \/
  exists g, (wf_fml (None::hyp) g) /\ f = (implf (subst_fml g Cst_0)
    (implf (fall (implf g
      (subst_fml (lift_fml_rec g 1 1) (Df_Add (Var 0) Cst_1))))
    (fall g))).

Lemma ax_wf : forall (hyp : HYP) (f : foformula), ax_syn hyp f -> wf_fml hyp f.
intros hyp f Hax.
destruct Hax as [Hax|[Hax|[Hax|[Hax|(g, (H', Hax))]]]]; subst f;
  try (unfold wf_fml, fv_fml, fv_term; simpl; intros; contradiction).
 unfold wf_fml, fv_fml in H' |- *; simpl; intros.
 apply in_app_or in H; destruct H.
  unfold subst_fml in H. apply (in_fv_fml_subst_split _ _ _ 0 0) in H.
  simpl in H. destruct H; [contradiction|apply H' in H; simpl in H; trivial].

  apply in_app_or in H. destruct H.
   apply in_app_or in H. destruct H.
    apply in_S_fv_fml in H. apply H' in H. simpl in H; trivial.

    unfold subst_fml in H. apply (in_fv_fml_subst_split _ _ _ 1 0) in H.
    simpl in H. destruct H; [contradiction|].
    rewrite in_S_fv_fml in H. replace 2 with (0+1+1) in H by omega.
    apply in_fv_fml_lift in H. simpl in H. rewrite <- in_S_fv_fml in H.
    apply H' in H; simpl in H; trivial.

   rewrite <- in_S_fv_fml in H. apply H' in H; simpl in H; trivial.
Qed.

End PresburgerAx.

Module PresburgerTheory <: TheorySyn.

Module sig <: TheorySig := PresburgerSig.
Export sig.

Module ax <: TheoryAx sig := PresburgerAx.
Export ax.

Include FoDeriv sig ax.

End PresburgerTheory.


(**
An introduction to small scale reflection in Coq

5. Type inference using canonical structures

http://hal.inria.fr/docs/00/55/53/79/PDF/main-rr.pdf
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Require Import path choice fintype tuple finfun finset.

Set Implicit Arguments.
(* この宣言は必須である。これによって省かれた項はコメントしてある。 *)
Unset Strict Implicit.
Import Prenex Implicits.

(**
5.1 Canonical Structures
*)

Record zmodule_mixin_of (T : Type) : Type :=
  ZmoduleMixin {
      zero : T;
      opp : T -> T;
      add : T -> T -> T;
      addA : associative add;
      addC : commutative add;
      addm0 : left_id zero add;
      add0m : left_inverse zero opp add
    }.

Record zmodule : Type :=
  Zmodule {
      carrier :> Type;
      spec : zmodule_mixin_of carrier
    }.
Print Graph.
(* [carrier] : zmodule >-> Sortclass *)

(* コアーションが定義される。 *)
(* [carrier] : zmodule >-> Sortclass *)
Check carrier : zmodule -> Type.

(** bool_zodule は少し後ろにずらした。 *)

Definition zmadd (Z : zmodule) := add (spec Z).
(* add の forall T の T （つまり、 zmodule_mixin_of (T : Type) の T)
 が省かれている。zmaddACの証明も同様。 *)
Check zmadd : forall Z : zmodule, Z -> Z -> Z.

Notation "x \+ y" := (zmadd x y) (at level 50, left associativity).
(* zmadd の Zが省かれている。zmoduleなZが決まらないと、使えない。 *)

(** Excercise 5.1.1 *)
Lemma zmaddAC : forall (Z : zmodule) (x y z : Z),
                  x \+ y \+ z = x \+ z \+ y.
Proof.
  move=> Z x y z.
  rewrite /zmadd.
  rewrite -[add (spec Z) (add (spec Z) x y) z]addA.
  rewrite [add (spec Z) y z]addC.
  rewrite [add (spec Z) x (add (spec Z) z y)]addA.
  by [].
Qed.

(** bool_zodule *)
Definition bool_zmoduleMixin :=
  @ZmoduleMixin
    bool false (@id bool) addb              (* @を取ると、最初の4引数が省かれる。 *)
    addbA addbC addFb addbb.

(* Definition bool_zmodule := Zmodule (* bool *) bool_zmoduleMixin. *)
Canonical bool_zmodule := Zmodule (* bool *) bool_zmoduleMixin.
(* Zmodule の bool が省かれている。  *)
(* Canonical Structure bool_zmodule.
   の代わりに、Canonocal bool_zmodule := ... とするのが、SSReflect風。 *)
Print Canonical Projections.
(* bool <- carrier ( bool_zmodule ) *)

Check carrier bool_zmodule : Type.
Check zmadd : forall Z : zmodule, Z -> Z -> Z.
Check @zmadd bool_zmodule false true : bool_zmodule. (* これは、Definition でも有効。 *)
Locate "_ \+ _".

(* Canonical にすることによって、以下が有効になる。 *)
(*
補足：2015/08/13

@zmadd の第2引数以降にbool型の値(true, false)を書いた場合に、
の第1引数 (zmodule型) に、bool_zmoduleをを推論することができる。
そのため、@zmaddの第1引数が省略できるようになる
ため、``zmadd false true`` や ``false \+ true`` と書けるようになる。

これを、bool_zmoduleがzmoduleのカノニカル・インスタンスであるという。

zmoduleのインスタンスは無数に作れるので、そのどれが@zmaddの第1引数として推論するべきか判らない。
一旦、bool_zmoduleが選ばれれば、コアーションで ``carrier bool_zmodule = bool`` を
第2第3引数にとってもよいと判断できる。
コアーションは型変換（キャスト）の関数を表記上省略することであり、
カノニカルは型推論（省略された引数の推論）のためのヒントであるので、両者は別物である。
*)

Check @zmadd _ false true : bool.           (* ！！多分これが、一番重要！！ *)
Fail Check @zmadd bool false true : bool.   (* 明示的に指定することは、できない。 *)
Check zmadd false true : bool.
Check false \+ true : bool.
(* carrier によるコアーションは、「zmodule を型とみなす」であるから、これはコアーションではない。 *)

Check @zmadd _ false true : bool_zmodule.
Check zmadd false true : bool_zmodule.
Check false \+ true : bool_zmodule.
Eval compute in false \+ true.              (* true *)

(* Canonical にすることによって、以下が有効になる。 *)
(* zmodule な型であるべきところに、bool をユニファイできる。 *)
Goal forall x y z : bool, x (+) y (+) z = x (+) z (+) y.
Proof.
  Locate "(+)".                             (* addb *)
  Check zmaddAC.
  apply zmaddAC.                            (* これが有効になる。 *)
(*  *)
Qed.

(**
5.2 Canonical constructions
*)

(* eqtype.v の定義が使用される。 *)
Lemma unit_eqP : Equality.axiom (fun _ _ : unit => true).
Proof.
    by do 2!case; left.
Qed.

Definition unit_eqMixin := EqMixin unit_eqP.
Canonical unit_eqType := EqType unit unit_eqMixin.
Print Canonical Projections.
(* unit <- Equality.sort ( eqtype.unit_eqType ) *)

(** Exercise 5.2.1 *)

(** bool *)
Definition eqb x y :=
  if x then y else ~~ y.

Lemma bool_eqP : Equality.axiom eqb.
Proof.
  move=> x y.
  apply (iffP idP).
(*
これより簡単！
  apply/(@iffP (eqb x y)).
  - by apply/idP.
*)
  - case: x=> /= Hy.
    + by [].
    + by move/negPf in Hy.
  - case: x=> /= Hy.
    + by [].
    + by apply/negPf.
Qed.

Definition bool_eqMixin := EqMixin bool_eqP.
Canonical bool_eqType := EqType bool bool_eqMixin.
Print Canonical Projections.
(* bool <- Equality.sort ( eqtype.bool_eqType ) *)

(** nat *)
Lemma nat_eqP : Equality.axiom (fun m n : nat => eqn m n).
Proof.
  move=> m n.
  apply: (iffP idP).
  - by apply/eqP.
  - by move/eqP.
Qed.

Definition nat_eqMixin := EqMixin nat_eqP.
Canonical nat_eqType := EqType nat nat_eqMixin.
Print Canonical Projections.
(* nat <- Equality.sort ( ssrnat.nat_eqType ) *)

(** Exercise 5.2.2 *)

Definition pair_eq (T1 T2 : eqType) :=
  [rel u v : T1 * T2 | (u.1 == v.1) && (u.2 == v.2)].

Lemma tuto_pair_eqP : forall T1 T2, Equality.axiom (pair_eq T1 T2).
Proof.
  (* u v の場合わけして、u1 u2 v1 v2としてpopするのが味噌 *)
  move=> T1 T2 [u1 u2] [v1 v2].
  apply: (iffP idP).
(*
  apply/(@iffP (pair_eq T1 T2 (u1, u2) (v1, v2))).
  - by apply/idP.
*)
  - rewrite /pair_eq /=.
    case/andP.
    move/eqP => H1.
    move/eqP => H2.
    by subst.
  - rewrite /pair_eq /=.
    (* 前提 (u1,u2)=(v1,v2)を u1=v1とu2=v2にわけてpopするのが味噌 *)
    move=> [H1 H2].
    apply/andP.
    by subst.
Qed.

Definition prod_eqMixin (T1 T2 : eqType) := EqMixin (@tuto_pair_eqP T1 T2).
Canonical prod_eqType (T1 T2 : eqType) := EqType (T1 * T2) (prod_eqMixin T1 T2).    (* 最後のT1 T2 は略せない。 *)

Print Canonical Projections.
(* prod <- Equality.sort ( prod_eqType ) *)

Check (true, 3) == (true && true, 1 + 2) : bool.

Set Printing Coercions.
Print Graph.                                (* [Equality.sort] : Equality.type >-> Sortclass *)
Check @eq_op : forall T : eqType, rel (Equality.sort T).
Check @eqP : forall T : eqType, Equality.axiom eq_op.
Unset Printing Coercions.

(**
5.3 Predtypes: canonical structures for notations
 *)
Section SeqMem.
  Variable T : eqType.
  Implicit Type s : seq T.
  Implicit Types x y : T.

  Lemma tuto_in_cons : forall y s x,
                         (x \in y :: s) = (x == y) || (x \in s).
  Proof.
      by [].
  Qed.

  (** Exercise 5.3.1 *)
  Lemma tuto_in_nil : forall x, (x \in [::]) = false.
  Proof.
    by [].
  Qed.

  Lemma tuto_mem_seq1 : forall x y, (x \in [:: y]) = (x == y).
  Proof.
    move=> x y.
    Locate "\in".
    rewrite /in_mem /=.
      by case: (x == y).
  Qed.

  Lemma tuto_mem_head : forall x s, x \in x :: s.
  Proof.
    move=> x s.
    rewrite /in_mem /=.
    apply/orP.
    by left.
  Qed.

  (** Exercise 5.3.2 *)
  Lemma tuto_mem_cat : forall x s1 s2,
                         (x \in s1 ++ s2) = (x \in s1) || (x \in s2).
  Proof.
    have orC p q r : p || q || r = p || (q || r)
      by case: p; case: q; case: r.
    move=> x s1 s2.
    rewrite /in_mem /=.
    elim: s1.
    + by [].
    + move=> a l IH /=.
      by rewrite IH. (* rewrite orC. も使われる。 *)
  Qed.

  Lemma tuto_mem_behead: forall s, {subset (behead s) <= s}.
  Proof.
    rewrite /sub_mem /in_mem /mem /=.
    elim.                                   (* by s *)
    + by [].
    + move=> a l IH /= x H.
      apply/orP.
      by right.
  Qed.

  Lemma tuto_mem_tail : forall y y0 m,
                          y \in m -> y \in y0 :: m.
  Proof.
    move=> y y0 m.
      by rewrite tuto_in_cons=> H5; apply/orP; right.
  Qed.

  Lemma tuto_hasP'' : forall (a : pred T) s,
                      reflect (exists2 x, (x \in s) & (a x)) (has a s).
  Proof.
    move=> a s.
    elim: s => [|y s IHs] /=.
    - right.                                (* s = [::] *)
      move=> H. case: H. by [].             (* by case. *)
    - case ay : (a y).                      (* ay が前提に残る。 *)
      + left; exists y.                     (* ay = true *)
        * by rewrite ?mem_head.
        * by [].
      + apply: (iffP IHs) => [] [x ysx ax]. (* ay = false *)
        * exists x => //.
          by apply: mem_behead.
        * exists x => //.
          case: (predU1P ysx) ax => [H1|H2].
                 + rewrite H1. rewrite ay. by [].
                 + by [].
  Qed.

  Lemma has__exists : forall (a : pred T) s,
                        has a s -> (exists2 x : T, x \in s & a x).
  Proof.
    move=> a s.
    elim: s => [|y l IH /=].
    - by [].
    - case/orP=> [H1 | H2].
      + exists y.
        rewrite /in_mem /=.
        apply/orP.
        * by left.
        * by [].
      (* ここでmoveせず、caseで=>[|..]する。 *)
      + case IH => [|x H3 H4].
        * by [].
        (* ここでmoveせず、caseで=>[|..]する。 *)
        * exists x.
           - by apply: tuto_mem_tail.
           - by [].
  Qed.

  Lemma exists__has : forall (a : pred T) s,
                        (exists2 x : T, x \in s & a x) -> has a s.
  Proof.
    move=> a s.
    elim: s =>  [|y l IH H /=].
    - case=> x /=.
            by rewrite -(tuto_in_nil x).
    - case ay : (a y).                      (* ！味噌！ *)
      + apply/orP. by left.                 (* a y = true *)
      + apply/orP. right. apply IH.         (* a y = false *)
        case: H => x ylx ax.
        exists x.
        * case: (predU1P ylx) ay => xy ay.  (* *** *)
          - move: ax.
            rewrite xy ay. by [].
          - by [].
        * by [].
  Qed.

  Lemma all_allin : forall (a : pred T) s,
                      all a s -> forall x, x \in s -> a x.
  Proof.
    move=> a.
    elim.                                   (* by s *)
    - by [].
    - move=> y l IH.
      rewrite /in_mem /=.
      move/andP => [ay  allal] x.
      move/orP => [xy | lx].
      * move/eqP in xy.                     (* x == y *)
          by rewrite xy.
      + apply IH.                           (* l x *)
        * by [].
        * by [].
  Qed.

  Lemma allin_all : forall (a : pred T) s,
                    (forall x, x \in s -> a x) -> all a s.
  Proof.
    move=> a.
    elim.                                   (* by s *)
    - by [].
    - rewrite /in_mem /= => y l IH.
      move=> H.
      apply/andP.
      split.
      + apply: H. apply/orP.
          by left.
      + apply: IH => x lx.
        apply: H.
        apply/orP.
          by right.
  Qed.

  Lemma tuto_allP : forall (a : pred T) s,
                      reflect (forall x, x \in s -> a x) (all a s).
  Proof.
    move=> a s.
    apply (iffP idP).
(*
これより簡単！
    apply: (@iffP (all a s)).
    - by apply/idP.
*)
    - by apply: all_allin.
    - by apply: allin_all.
  Qed.

  Lemma notall_exnot : forall (a : pred T) s,
                         (~~ all a s) -> (exists2 x, x \in s & ~~ a x).
  Proof.
    move=> a.
    elim=> [|y l IH].
    - by [].
    - case ay : (a y).
      + move/negP; rewrite /not=> Hc.       (* a y = true *)
        case: IH.
        * apply/negP. rewrite /not=> allal. (* ~~ all a l *)
          apply: Hc => /=.
          apply/andP.
          split.
            by [].                          (* a y *)
            by [].                          (* all a l *)
        * move=> x lx notax.                (* 前提のexistに対するcase *)
          exists x.
          rewrite /in_mem /=.
          rewrite /in_mem /= in lx.
          apply/orP.
          right.
            by [].                          (* l x *)
            by [].                          (* ~~ a x *)
      + move=> /= Hc.                       (* a y = false *)
        exists y.
        * by apply: tuto_mem_head.
        * move/negP in Hc. rewrite /not in Hc.
          apply/negP. rewrite /not.
          move=> ay'.
          move/negP in ay. rewrite /not in ay.
          apply: ay.
          by [].
  Qed.

  Lemma exnot_notall : forall (a : pred T) s,
                           (exists2 x, x \in s & ~~ a x) -> (~~ all a s).
  Proof.
    move=> a.
    elim=> [|y l IH /= H].
    - case.
      by [].
    - apply/negP => /andP Hc.               (* apply/negP; move/andP *)
      case: Hc => ay.
      apply/negP. apply: IH.                (* ~~ all a l に戻る。 *)
      case: H => x lxy notax.
      exists x.
      + case: (predU1P lxy) ay => [H11 | H12].
        * rewrite -H11.
          move=> ax.                        (* a x *)
          move=> /negP in notax.            (* ~ a x *)
            by [].                          (* ゴールの x in l はどうでもよい。 *)
        * by [].
      + by [].
  Qed.

  Lemma tuto_allPn : forall (a : pred T) s,
                       reflect (exists2 x, x \in s & ~~ a x) (~~ all a s).
  Proof.
    move=> a s.
    apply (iffP idP).
(*
これより簡単
    apply: (@iffP (~~ all a s)).
    - by apply/idP.
*)
    - by apply: notall_exnot.
    - by apply: exnot_notall.
  Qed.
End SeqMem.

(* END *)


(*This file contains two theorems: forward and mixed error bounds for
  the dot product of two floating point lists; the functional model for
  the vanilla dot product is defined in dotprod_model.v.*)

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

Require Import Reals.
Open Scope R.

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

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

Variable (fp : ftype t).
Hypothesis Hfp : 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 bound *)
Lemma 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)); auto.
inversion Hfp. inversion H2. subst.
assert ( HFINa:
      (Binary.is_finite (fprec t) (femax t) (BMULT (fst a) (snd a)) = true /\
      Binary.is_finite (fprec t) (femax t) (Zconst t 0) = true)).
  { destruct (BMULT (fst a) (snd a)); unfold pos_zero; simpl; auto. }
  destruct HFINa as (A & C).
rewrite BPLUS_B2R_zero; auto.
pose proof BMULT_accurate'  (fst a) (snd a) A as Hmula.
destruct Hmula as (d' & e' & Hed' & Hd' & He' & B); rewrite B; clear B.
unfold g1, g; simpl.
inversion Hra. inversion H3; subst.
rewrite Rmult_1_r. rewrite !Rplus_0_r.
replace (1 + D - 1) with (D) by nra. field_simplify;
field_simplify_Rabs.  unfold FR2. destruct a; simpl.
eapply Rle_trans. apply Rabs_triang. rewrite Rabs_mult.
eapply Rle_trans.
apply Rplus_le_compat. apply Rmult_le_compat; try apply Rabs_pos.
apply Rle_refl. apply Hd'. apply He'.
rewrite Rmult_comm.
apply Rplus_le_compat; try nra.
rewrite Rmult_assoc.
rewrite <- Rabs_mult. try nra.
}
(* non-empty l *)
intros; inversion Hfp;
inversion Hrp; inversion Hra; subst.
(destruct (BPLUS_finite_e _ _ Hfin) as (A & B)).
(* IHl *)
specialize (IHl s s0 s1 H3 H7 H11 B).
destruct (BPLUS_accurate'  (BMULT (fst a) (snd a)) s Hfin) as (d' & Hd'& Hplus);
rewrite Hplus; clear Hplus.
destruct (BMULT_accurate'  (fst a) (snd a) A) as (d & e & Hed & Hd& He& Hmul);
rewrite Hmul; clear Hmul.
(* algebra *)
apply length_not_empty_nat in H.
destruct a; cbv [ FR2 Rabsp fst snd].
simpl.
set (n:= length l) in *.
set (F:= FT2R f * FT2R f0).
field_simplify_Rabs.
replace (F * d * d' + F * d + F * d' + e * d' + e + FT2R s * d' + FT2R s - s0) with
((F * d * d' + F * d + F * d' + FT2R s * d') + (FT2R s - s0) + (1 + d') * e) by nra.
eapply Rle_trans;
  [ apply Rabs_triang | ].
eapply Rle_trans;
  [  apply Rplus_le_compat; [eapply Rle_trans;
  [ apply Rabs_triang | ] |]  | ].
apply Rplus_le_compat_l; apply IHl .
rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos | apply He].
rewrite  Rplus_assoc.
eapply Rle_trans;
  [  apply Rplus_le_compat_r ; eapply Rle_trans; [ apply Rabs_triang | ] | ].
apply Rplus_le_compat_l; rewrite Rabs_mult; rewrite Rmult_comm;
  apply Rmult_le_compat; [ apply Rabs_pos| 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. }
field_simplify.
fold D E n.
rewrite !Rplus_assoc.
replace (Rabs (F * d * d' + (F * d + F * d')) +
(D * g n *  s1 +
 (D *  s1 +
  (D * g1 n (n - 1) +
   ( s1 * g n + (g1 n (n - 1) + Rabs (1 + d') * E)))))) with
(Rabs (F * d * d' + (F * d + F * d')) + ((1+ D) * g n *  s1 + D *  s1) +
 (D * g1 n (n - 1) + (g1 n (n - 1) + Rabs (1 + d') * E))) by nra.
replace (s1 * g (S n) + (g (S n) * Rabs (FT2R f) * Rabs (FT2R f0) + g1 (S n) (n - 0)))
with (g (S n) * Rabs (FT2R f * FT2R f0) + s1 * g (S n) + g1 (S n) (n - 0)) by
(rewrite Rmult_assoc, <- Rabs_mult; nra).
apply Rplus_le_compat.
apply Rplus_le_compat.
eapply Rle_trans;
  [ apply Rabs_triang | ].
eapply Rle_trans;
  [ apply Rplus_le_compat; [rewrite !Rabs_mult| eapply Rle_trans; [apply Rabs_triang| ]] | ].
apply Rmult_le_compat; [rewrite <- Rabs_mult; apply Rabs_pos | apply Rabs_pos|  |  apply Hd'].
apply Rmult_le_compat_l; [apply Rabs_pos  | apply Hd ].
apply Rplus_le_compat; rewrite Rabs_mult.
apply Rmult_le_compat_l; [apply Rabs_pos  | apply Hd ].
apply Rmult_le_compat_l; [apply Rabs_pos  | apply Hd' ].
fold D F. replace (Rabs F * D * D + (Rabs F * D + Rabs F * D)) with
  ( ((1 + D)*(1+D) - 1) * Rabs F ) by nra.
apply Rmult_le_compat_r; try apply Rabs_pos; unfold D, g.
apply Rplus_le_compat; try nra.
rewrite <- tech_pow_Rmult.
apply Rmult_le_compat_l.
eapply Rle_trans with 1; try nra; apply default_rel_plus_1_ge_1.
eapply Rle_trans with ((1 + D)^1); try nra.
fold D; nra.
apply Rle_pow; auto with commonDB.
apply Req_le; rewrite one_plus_d_mul_g.
rewrite Rmult_comm.
repeat f_equal;  try lia.
rewrite <- Rplus_assoc.
eapply Rle_trans; [apply Rplus_le_compat_l;
  apply Rmult_le_compat_r; [ unfold E; apply default_abs_ge_0| eapply Rle_trans] | ].
apply Rabs_triang. rewrite Rabs_R1.
apply  Rplus_le_compat_l; apply Hd'.
rewrite !Rmult_plus_distr_r. rewrite Rmult_1_l.
rewrite <- !Rplus_assoc.
replace (D * g1 n (n - 1) + g1 n (n - 1)) with (g1 n (n-1) * (1+D)) by nra;
rewrite one_plus_d_mul_g1; auto.
rewrite Rplus_assoc.
replace (E + D * E) with
  ((1+D) * E) by nra.
eapply Rle_trans; [apply plus_d_e_g1_le; auto| apply Req_le; f_equal;lia].
Qed.

End ForwardError.

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 : dot_prod_rel vF fp.
Hypothesis Hfin: Binary.is_finite (fprec t) (femax t) fp = true.

(* mixed error bound *)
Lemma dotprod_mixed_error:
  exists (u : list R) (eta : R),
    length u = length v2 /\
    R_dot_prod_rel (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).
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.
{ (* case singleton lists *)
clear IHl. inversion Hfp; subst.
inversion H2; subst; clear H2.
 simpl in  Hfp, Hfin; unfold fst, snd.
assert (FINmul: Binary.is_finite (fprec t) (femax t) (BMULT f a) = true).
{ destruct (BMULT f a); unfold neg_zero in *; simpl; try discriminate; auto. }
rewrite BPLUS_B2R_zero in *; auto.
pose proof BMULT_accurate' f a FINmul as Hacc.
destruct Hacc as (d & e & Hed & Hd & He & Hacc).
exists [FT2R f * (1  +d)], e; repeat split.
{ simpl. rewrite Hacc. replace (FT2R f * FT2R a * (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; rewrite H; simpl; nra.
eapply Rle_trans; [apply Hd| apply d_le_g_1; simpl; auto].
}
eapply Rle_trans; [apply He|]. apply e_le_g1; simpl in *; auto.
}
(* case cons lists*)
(* apply IH *)
pose proof (length_not_empty l H) as Hlen3.
inversion Hfp;  subst.
unfold fst, snd in Hfin, Hfp; unfold fst, snd.
destruct (BPLUS_finite_e _ _ Hfin) as (A & B).
destruct (BMULT_finite_e _ _ A) as (C & _).
(* IHl *)
specialize (IHl s l0 H3 B Hlen1).
(* construct u *)
destruct (BPLUS_accurate' (BMULT f a) s Hfin) as (d' & Hd'& Hplus);
rewrite Hplus; clear Hplus.
destruct (BMULT_accurate' f a A) as (d & e & Hed & Hd& He& Hmul);
rewrite Hmul; clear Hmul.
destruct IHl as (u & eta & Hlenu & Hurel & Hun & Heta).
exists (FT2R f * (1+d) * (1 + d') :: map (Rmult (1+d')) u),
  (e * (1 + d') + 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. specialize (H0 Hlenu Hurel); simpl.
replace
 ((FT2R f * FT2R a * (1 + d) + e + FT2R s) * (1 + d') -
   (e * (1 + d') + eta * (1 + d')))
with
 (FT2R f * (1 + d) * (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 ((1 + d) * (1 + d') -1); split.
  { field_simplify; nra. }
  { field_simplify_Rabs. eapply Rle_trans; [apply Rabs_triang|].
    eapply Rle_trans; [apply Rplus_le_compat; [apply Rabs_triang | apply Hd' ] |].
    eapply Rle_trans; [apply Rplus_le_compat_r; apply Rplus_le_compat; [|apply Hd] |  ].
    rewrite Rabs_mult. apply Rmult_le_compat;
        [apply Rabs_pos | apply Rabs_pos | apply Hd | apply Hd'].
    eapply Rle_trans with ((1 + D) * (1 + D) - 1); try nra.
    unfold g. apply Rplus_le_compat; try nra.
    rewrite <- tech_pow_Rmult; apply Rmult_le_compat; try nra; try
    (eapply Rle_trans with 1; try nra; apply (default_rel_plus_1_ge_1)).
    eapply Rle_trans with ((1 + D) ^ 1); try nra.
    apply Rle_pow; try
    (eapply Rle_trans with 1; try nra; apply (default_rel_plus_1_ge_1)).
     rewrite <- Hlen1; auto. lia. }
}
simpl in H0; assert (Hn: (n < length l)%nat) by lia.
specialize (Hun n Hn);
   destruct Hun as (delta & Hun & Hdelta). simpl;
replace 0 with (Rmult  (1+d') 0) by nra. rewrite map_nth.
rewrite Hun.
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 Hdelta] | ].
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 Hdelta.
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; [rewrite Rabs_mult| rewrite Rabs_mult] | ].
eapply Rmult_le_compat; try apply Rabs_pos.
apply He.
eapply Rle_trans; [apply Rabs_triang | rewrite Rabs_R1; apply Rplus_le_compat_l; apply Hd'].
eapply Rmult_le_compat; try apply Rabs_pos.
apply Heta.
eapply Rle_trans; [apply Rabs_triang | rewrite Rabs_R1; apply Rplus_le_compat_l; apply Hd'].
rewrite Rplus_comm. rewrite one_plus_d_mul_g1'.
assert (Hp: (1 <= S (length l))%nat) by lia.
pose proof @plus_d_e_g1_le' t (length l) (S (length l)) Hlen3 Hp as HYP; clear Hp.
eapply Rle_trans; [| apply HYP]; apply Req_le; nra.
Qed.

End MixedError.

Section ErrorExtra.

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.
Hypothesis Hfin: Binary.is_finite (fprec t) (femax t) (dotprod v1 v2) = true.

Lemma dotprod_mixed_error':
  exists (u : list R) (eta : R),
    length u = length v2 /\
    dotprodR u (map FT2R v2) = (FT2R (dotprod v1 v2)) - 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).
Proof.
intros.
assert (Datatypes.length (combine v1 v2) = length v1) by
 (rewrite combine_length; lia).
assert (Hlenr : length (rev v1) = length (rev v2)) by (rewrite !rev_length; auto).
rewrite <- rev_length in Hlen.
pose proof dot_prod_rel_fold_right v1 v2 as H1.
rewrite <- combine_rev in H1.
rewrite rev_length in Hlen.
pose proof (dotprod_mixed_error (rev v1) (rev v2) Hlenr (dotprod v1 v2) H1 Hfin) as
  (u & eta & H2 & H3 & H4 & H5).
exists (rev u), eta; repeat split; auto.
rewrite rev_length in H2; rewrite <- rev_length in H2; auto.
pose proof dotprodR_rel u (map FT2R (rev v2)).
eapply R_dot_prod_rel_eq; eauto.
rewrite <- dotprodR_rev, <- map_rev; auto.
rewrite rev_length in H2; rewrite map_length; auto.
rewrite !rev_length in H4.
intros.
assert ((length u - S n < length v2)%nat).
{ rewrite rev_length in H2.
rewrite H2.
apply Nat.sub_lt; try lia.
}
specialize (H4 (length u - S n)%nat H6).
rewrite rev_nth in H4.
rewrite rev_nth.
destruct H4 as (delta & Hn & HD).
exists delta; split.
rewrite Hn; repeat f_equal.
rewrite rev_length in H2.
rewrite Hlen.
rewrite H2.
rewrite <- Nat.sub_succ_l.
simpl. lia.
apply Arith_prebase.lt_le_S_stt; auto.
apply HD.
rewrite rev_length in H2.
rewrite H2; auto.
rewrite Hlen; auto.
rewrite !rev_length in H5; auto.
rewrite rev_length in Hlen; auto.
Qed.

End ErrorExtra.

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 : dot_prod_rel (combine v1 v2) fp.
Hypothesis Hfin: Binary.is_finite (fprec t) (femax t) fp = true.

Notation v1R := (map FT2R v1).

Variable (rp rp_abs : R).
Hypothesis Hrp  : R_dot_prod_rel (map FR2 (combine v1 v2)) rp.
Hypothesis Hra : R_dot_prod_rel (map Rabsp (map FR2 (combine v1 v2))) rp_abs.

Notation g := (@common.g t).
Notation g1 := (@common.g1 t).
Notation nnzR := (nnzR v1R).

Lemma sparse_dotprod_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 (BMULT a f); destruct s0;
   try discriminate; simpl in *; auto;
  destruct s0; destruct s2; try discriminate; auto. }
assert (HFIN2: Binary.is_finite (fprec t) (femax t) (BMULT a f) = true).
{ simpl in Hfin. destruct (BMULT a f); destruct s0;
   try discriminate; simpl in *; 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 (BPLUS (BMULT 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 Bmult_0R a f HFIN2 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 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.
rewrite Bplus_0R; auto.
destruct (@BMULT_accurate' t NAN a f HFIN2)
  as (d' & e' & Hed' & Hd' & He' & Hacc).
rewrite Hacc; clear Hacc.
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 He'| ]; auto with commonDB; nra.
}
(* tail not all zeros *)
destruct (@BPLUS_accurate' t NAN (BMULT a f) s0 Hfin)
  as (d' & Hd' & Hacc).
rewrite Hacc; clear Hacc.
destruct (@BMULT_accurate' t NAN a f HFIN2)
  as (d & e & Hed & Hd & He & Hacc).
rewrite Hacc; clear Hacc.
set (F:= FT2R a * FT2R f ).
field_simplify_Rabs.
replace (F * d * d' + F * d + F * d' + e * d' + e + FT2R s0 * d' + FT2R s0 - s) with
((F * d * d' + F * d + F * d' + FT2R s0 * d') + (FT2R s0 - s) + (1 + d') * e) by nra.
eapply Rle_trans;
  [ apply Rabs_triang | ].
eapply Rle_trans;
  [  apply Rplus_le_compat; [eapply Rle_trans;
  [ apply Rabs_triang | ] |]  | ].
apply Rplus_le_compat_l; apply IHl .
rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos | apply He].
rewrite  Rplus_assoc.
eapply Rle_trans;
  [  apply Rplus_le_compat_r ; eapply Rle_trans; [ apply Rabs_triang | ] | ].
apply Rplus_le_compat_l; rewrite Rabs_mult; rewrite Rmult_comm;
  apply Rmult_le_compat; [ apply Rabs_pos| 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.
  apply Rplus_le_compat.
  apply Rmult_le_compat; auto with commonDB; try apply Rle_refl.
  rewrite <- (R_dot_prod_rel_Rabs_eq (map FR2 (combine l l0)) s1); auto;
  apply Rabs_pos.
  apply Rle_refl.
  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. }
field_simplify.
unfold g1, g in IHl.
field_simplify in IHl.
set (D:= default_rel).
set (E:= default_abs).
rewrite !Rplus_assoc.
rewrite H.
match goal with |-context[?A<= ?B] =>
replace A with (Rabs (F * d * d' + (F * d + F * d')) + ((1+ D) * g n2 *  s1 + D *  s1) +
 (D * g1 n2 (n2 - 1) + (g1 n2 (n2 -1) + Rabs (1 + d') * E))) by nra;
replace B with
(g (S n2) * Rabs F + s1 * g (S n2) + g1 (S n2) (S n2 - 1) ) by
(rewrite Rmult_assoc, <-Rabs_mult; fold F; nra)
end.
apply Rplus_le_compat.
apply Rplus_le_compat.
unfold g.
eapply Rle_trans;
  [ apply Rabs_triang | ].
eapply Rle_trans;
  [ apply Rplus_le_compat; [rewrite !Rabs_mult| eapply Rle_trans; [apply Rabs_triang| ]] | ].
apply Rmult_le_compat; [rewrite <- Rabs_mult; apply Rabs_pos | apply Rabs_pos|  |  apply Hd'].
apply Rmult_le_compat_l; [apply Rabs_pos  | apply Hd ].
apply Rplus_le_compat; rewrite Rabs_mult.
apply Rmult_le_compat_l; [apply Rabs_pos  | apply Hd ].
apply Rmult_le_compat_l; [apply Rabs_pos  | apply Hd' ].
fold D. replace (Rabs F * D * D + (Rabs F * D + Rabs F * D)) with
  ( ((1 + D)*(1+D) - 1) * Rabs F ) by nra.
apply Rmult_le_compat_r; try apply Rabs_pos; unfold D, g.
apply Rplus_le_compat; try nra.
rewrite <- tech_pow_Rmult.
apply Rmult_le_compat_l; auto with commonDB.
eapply Rle_trans with ((1 + D)^1); try nra.
fold D; nra.
apply Rle_pow; auto with commonDB.
apply Req_le. unfold D,E. rewrite one_plus_d_mul_g.
rewrite Rmult_comm.
repeat f_equal;  try lia.
rewrite <- !Rplus_assoc.
replace (D * g1 n2 (n2 - 1) + g1 n2 (n2 - 1)) with (g1 n2 (n2-1) * (1+D)) by nra.
unfold D.
rewrite one_plus_d_mul_g1; auto.
eapply Rle_trans; [apply Rplus_le_compat_l |].
apply Rmult_le_compat_r; unfold E; auto with commonDB.
assert (Rabs (1 + d') <= 1 + D).
eapply Rle_trans; [apply Rabs_triang| rewrite Rabs_R1].
apply Rplus_le_compat_l; apply Hd'.
apply H1.
eapply Rle_trans; [apply plus_d_e_g1_le; auto| apply Req_le; f_equal;lia].
Qed.

End SparseError.


Require Import Setoid.
Require Import Lib.EqDec.

Inductive Empty : Type := .

Definition dot {A B C} (f: B -> C) (g: A -> B) := fun (x: A) => f (g x).

Notation "f $ g" := (dot f g) (at level 75).
Notation "! f" := (f -> Empty) (at level 75).
Notation "p ^" := (eq_sym p) (at level 30).
Notation "f @ g" := (eq_trans f g) (at level 40).

Class Decidable (A : Type) :=
  dec : A + (A -> False).

Class DecidableEq (A : Type) :=
  dec_eq : forall x y: A, Decidable (x = y).
Arguments dec A {_}.

Class isContr (A: Type) := ContrBuilder {
  center : A;
  contr : forall x: A, x = center
}.

Class isHProp (P : Type) :=
  hProp : forall p q : P, p = q.

Class isHSet (X : Type) :=
  hSet : forall (x y : X) (p q : x = y), p = q.

Class WeaklyConstant {A B: Type} (f : A -> B) :=
  wconst : forall x y, f x = f y.

Class Collapsible (A : Type) :={
  collapse        : A -> A ;
  wconst_collapse : forall x y: A, collapse x = collapse y
}.

Theorem map_tought_isHProp : forall A B P: Type, forall f: A -> P, forall g: P -> B,
  isHProp P -> WeaklyConstant (g $ f).
Proof.
  intros A B P f g isHProp. unfold WeaklyConstant. intros x y. unfold dot. assert (f x = f y).
  - destruct (isHProp  (f x) (f y)). reflexivity.
  - destruct H. reflexivity.
Qed.

Theorem dec_is_collaps : forall A : Type, Decidable A -> Collapsible A.
Proof.
  intros A eq. destruct eq.
  - exists (fun x => a). intros x y. reflexivity.
  - exists (fun x => x); intros x y.
    exfalso; apply f; assumption.
Qed.

Class PathCollapsible (A : Type) :=
  path_coll : forall (x y : A), Collapsible (x = y).

Theorem eq_dec_is_path_collaps : forall A : Type, DecidableEq A -> PathCollapsible A.
Proof.
  intros A dec x y. apply dec_is_collaps. apply dec.
Qed.

Lemma loop_eq : forall A: Type, forall x y: A, forall p: x = y,
  eq_refl = eq_trans (eq_sym p) p.
Proof.
  intros A x y []. cbn. reflexivity.
Qed.

Lemma loop_eq' : forall A: Type, forall x y: A, forall p: x = y,
  eq_refl = p @ (p ^).
Proof.
  intros A x y []. cbn. reflexivity.
Qed.

Theorem path_collaps_is_hset (A : Type) : PathCollapsible A -> isHSet A.
Proof.
  unfold isHSet, PathCollapsible; intros C x y.
  cut (forall e: x=y, e = eq_trans (eq_sym(collapse(eq_refl x))) (collapse e)).
  - intros H p q.
    rewrite (H q), (H p), (wconst_collapse p q).
    reflexivity.
  - intros []. apply loop_eq.
Qed.

Theorem pathdec_hset (A: Type) : DecidableEq A -> isHSet A.
Proof.
  intros H. apply path_collaps_is_hset. apply eq_dec_is_path_collaps. assumption.
Qed.

Theorem eqDec_pathdec (A: Type) `{EqDec A} : DecidableEq A.
Proof.
  intros x y. case_eq (eqf x y).
  - intro H1. left. apply eqf_iff; auto.
  - intro H1. right. intro H2. subst. rewrite eqf_refl in H1. inversion H1.
Qed.

Definition isLeft {A B: Type} (x : A + B): bool :=
  match x with
  | inl _ => true
  | _ => false
  end.

Theorem pathdec_eqDec {A: Type} `{DecidableEq A} : EqDec A.
Proof.
  unfold DecidableEq in H. exists (fun x y => isLeft (H x y)).
  intros x y. destruct (H x y); cbn; constructor; auto.
Qed.

Theorem dec_eq_hset {A: Type} `{EqDec A} : isHSet A.
Proof.
  apply pathdec_hset. apply eqDec_pathdec. assumption.
Qed.

Definition path_contr {A: Type} `{isContr A} (x y: A) : x = y :=
 eq_trans (contr x) (eq_sym (contr y)).

Lemma all_path_eq_in_contr {A: Type} `{isContr A} {x y: A}: forall p q: x = y, p = q.
Proof.
  intros p q. assert (forall e: x = y, e = path_contr x y).
  - intros []. unfold path_contr. unfold contr. destruct H. apply loop_eq'.
  - rewrite (H0 p). rewrite (H0 q). reflexivity.
Qed.

Lemma contr_bottom (A: Type) `{isContr A} (x y: A): isContr (x = y).
Proof.
  exists (path_contr x y).
  intros p. apply all_path_eq_in_contr.
Qed.

Theorem contr_is_hprop (A: Type) `{isContr A} : isHProp A.
Proof.
  unfold isHProp. intros p q. destruct H. rewrite contr0.
  specialize (contr0 p). rewrite contr0. reflexivity.
Qed.

Theorem contr_not_eq_hprop : exists A: Type, isHProp A /\ (! isContr A).
Proof.
  exists Empty. split.
  - unfold isHProp. intros [] _.
  - intros []. destruct center0.
Qed.

Lemma all_path_eq_in_hprop {A: Type} `{isHProp A} {x y: A}: forall p q: x = y, p = q.
Proof.
  intros p q. assert (isHProp (x=y)).
  - apply contr_is_hprop. apply contr_bottom. exists x. intro z. apply H.
  - apply H0.
Qed.

Theorem hprop_def (A: Type) `{isHProp A} (x y: A) : isContr (x = y).
Proof.
  exists (H x y). intro p. apply all_path_eq_in_hprop.
Qed.

Theorem hprop_inv (A: Type) `{isContr A} (x y: A) : isHProp (x = y).
Proof.
  apply contr_is_hprop. apply contr_bottom. assumption.
Qed.

Theorem hprop_is_hset (A: Type) `{isHProp A} : isHSet A.
Proof.
  unfold isHSet. intros x y p q. apply all_path_eq_in_hprop.
Qed.

Theorem hprop_not_eq_hset : exists A: Type, isHSet A /\ !isHProp A.
Proof.
  exists bool. split.
  - apply pathdec_hset. intros x y. unfold Decidable.
    destruct x, y; auto; right; intro H; discriminate.
  - intro H. specialize (H true false). discriminate.
Qed.

Theorem hset_def {A: Type} `{isHSet A} (x y: A) : isHProp (x = y).
Proof.
  unfold isHProp. apply H.
Qed.

Theorem paths_between_paths_are_eq_in_hset {A: Type} `{isHSet A} {x y: A} {a b: x = y}:
 forall p q: a = b, p = q.
Proof.
  intros p q. assert (isContr (p = q)).
  - unfold isHSet in H. apply contr_bottom. apply contr_bottom. exists a. intro c. apply H.
  - destruct H0. assumption.
Qed.

Theorem hset_inv {A: Type} `{isHProp A} (x y: A) : isHSet (x = y).
Proof.
  intros a b p q. assert (isHSet A) by (apply hprop_is_hset; assumption).
  apply paths_between_paths_are_eq_in_hset.
Qed.

Inductive universe_level : Type :=
| minus_two  : universe_level
| S_universe : universe_level -> universe_level.

Definition HPropLevel := S_universe minus_two.

Definition HSetLevel := S_universe HPropLevel.

Fixpoint isNType (n : universe_level) (A : Type) : Type :=
match n with
| minus_two => isContr A
| S_universe n' => forall x y: A, isNType n' (x = y)
end.

Theorem isHProp_def : forall A: Type, isNType HPropLevel A -> isHProp A.
Proof.
  unfold isNType. cbn.
  intros A H p q. destruct (H p q). assumption.
Qed.

Theorem isHProp_def' : forall A: Type, isHProp A -> isNType HPropLevel A.
Proof.
  unfold isNType. cbn.
  intros A H p q. apply hprop_def. assumption.
Qed.

Theorem isHSet_def : forall A: Type, isNType HSetLevel A -> isHSet A.
Proof.
  unfold isNType. cbn.
  intros A H x y p q. destruct (H x y p q). assumption.
Qed.

Theorem isHSet_def' : forall A: Type, isHSet A -> isNType HSetLevel A.
Proof.
  unfold isNType. cbn.
  intros A H x y p q. apply hprop_def. apply hset_def.
Qed.

Theorem NType_incusion : forall A: Type, forall n : universe_level,
  isNType n A -> isNType (S_universe n) A.
Proof.
  intros A n; revert A.
  induction n; intros A H.
  - cbn in *; intros x y.
    apply contr_bottom.
    assumption.
  - simpl in *; intros x y.
    apply IHn.
    apply H.
Qed.

Definition id {A: Type} (x: A) := x.

Definition ap {A B: Type} {x y: A} (f: A -> B) (p: x = y): f x = f y :=
  match p with
  | eq_refl => eq_refl
  end.

Definition transport {A: Type} {x y: A} {P: A -> Type} (path: x = y) (q : P x) : P y :=
match path with
| eq_refl => q
end.

Notation "p *" := (transport p) (at level 20).

Definition apd {A: Type} {x y: A} {P: A -> Type} (f: forall x:A, P x) (p: x = y) :
  (p *) (f x) = f y :=
  match p with
  | eq_refl => eq_refl
  end.

(* ap proofs *)

Theorem ap_distr {A B: Type} {x y z: A} (f: A -> B) (p: x = y) (q: y = z)
  : ap f (p @ q) = (ap f p) @ (ap f q).
Proof.
  destruct p, q. cbn. reflexivity.
Qed.

Theorem ap_inv {A B: Type} {x y: A} (f: A -> B) (p: x = y) : ap f (p ^) = (ap f p) ^.
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem ap_conn {A B C: Type} {x y: A} (f: A -> B) (g: B -> C) (p: x = y)
  : ap g (ap f p) = ap (g $ f) p.
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem ap_id {A B: Type} {x y: A} (p: x = y) : ap id p = p.
Proof.
  destruct p. cbn. reflexivity.
Qed.

(* transport proofs *)

Theorem transport_dist {A: Type} {P: A -> Type} {x y z: A} (p: x = y) (q: y = z) (u: P x)
  : (q *) ((p *) u) = ((p @ q) *) u.
Proof.
  destruct p, q. cbn. reflexivity.
Qed.

Theorem transport_ap {A B: Type} {P: B -> Type} {x y: A} (f: A -> B) (p: x = y) (u: P (f x))
  : transport (P := P $ f) p u = transport (ap f p) u.
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem transport_fun {A: Type} {P Q: A -> Type} {x y: A} (f: forall x, P x -> Q x) (p: x = y)
  (u: P x) : transport (P := Q) p (f x u) = f y (transport (P := P) p u).
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem dep_pair_eq : forall (A: Type) (P: A -> Type) (x y: A) (p: P x) (q: P y),
  existT P x p = existT P y q -> exists path: x = y, transport path p = q.
Proof.
  intros A P x y p q H. inversion H.
  exists eq_refl. cbn. trivial.
Qed.

Theorem dep_pair_eq_inv : forall (A: Type) (P: A -> Type) (x y: A) (p: P x) (q: P y),
   (exists e: x = y, transport e p = q) -> existT P x p = existT P y q.
Proof.
  intros A P x y p q (-> & []). cbn. reflexivity.
Qed.

Definition pointwise_paths {A B: Type}  (f g : A -> B)
  := forall x, f x = g x.

Notation "f == g" := (pointwise_paths f g) (at level 100).

Class IsEquiv {A B : Type} (f : A -> B) := {
  equiv_inv : B -> A ;
  eisretr : (f $ equiv_inv) == id ;
  eissect : (equiv_inv $ f) == id ;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x) ;
}.

Arguments IsEquiv {A B}.

Class IsEquiv' {A B : Type} (f : A -> B) := {
  equiv_inv_A : B -> A ;
  equiv_inv_B : B -> A ;
  equiv_id_A : f $ equiv_inv_A == id ;
  equiv_id_B : equiv_inv_B $ f == id ;
}.

Class IsEquiv'' {A B : Type} (f : A -> B) :=
  contr_equiv : forall y: B, isContr(exists x, f x = y).

Theorem equiv_same (A B: Type) (f: A -> B) `{IsEquiv A B f} : IsEquiv' f.
Proof.
  destruct H. exists equiv_inv0 equiv_inv0; assumption.
Qed.

Theorem equiv_same' (A B: Type) (f: A -> B) `{IsEquiv' A B f} : IsEquiv f.
Proof.
  destruct H.
Abort.

Record Equiv A B := {
  equiv_fun : A -> B ;
  equiv_isequiv : IsEquiv equiv_fun
}.

Notation "A <~> B" := (Equiv A B) (at level 120).

Check (fun x => equiv_inv (equiv_fun x)).

Theorem hprop_from_hset_eq (A: Type) `{isHSet A} (P: A -> Prop) (f: A -> A)
  (H0: forall x, x = f x <~> P x) (x: A) : isHProp (P x).
Proof.
  intros p q. specialize (H0 x). destruct H0. destruct equiv_isequiv0.
  unfold pointwise_paths in *. assert (id p = id q).
  - rewrite <- eisretr0. rewrite <- (eisretr0 q). unfold dot.