Require Import all_ssreflect.

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

(*******************************************************************************
 An efficient construction technique for balanced binary trees from lists:
 - This method can preserves the order of elements, and
 - All recursions used in this methods are structural.
*******************************************************************************)

(* Implementation 1: for binary trees with labeled leaves *)

Inductive tree (A : Type) := tbin of tree A & tree A | tsingle of A.

Module Construction_1.

Section Definitions.

Variable (A : Type).

Fixpoint push (t : tree A) (ts : seq (option (tree A))) :
  seq (option (tree A)) :=
  match ts with
    | [::] as ts' | None :: ts' => Some t :: ts'
    | Some t' :: ts' => None :: push (tbin t' t) ts'
  end.

Fixpoint pop (t : tree A) (ts : seq (option (tree A))) : tree A :=
  match ts with
    | [::] => t
    | None :: ts' => pop t ts'
    | Some t' :: ts' => pop (tbin t' t) ts'
  end.

Fixpoint rep_push (ts : seq (option (tree A))) (xs : seq A) (x : A) :
  tree A :=
  match xs with
    | [::] => pop (tsingle x) ts
    | x' :: xs' => rep_push (push (tsingle x) ts) xs' x'
  end.

Definition construct (xs : seq A) : option (tree A) :=
  match xs with
    | [::] => None
    | x :: xs => Some (rep_push [::] xs x)
  end.

End Definitions.

Notation "#< x >" := (tsingle x) (at level 75).
Notation "l ## r" := (tbin l r) (at level 75, no associativity).

Eval compute in (construct (iota 0 30)).
Eval compute in (construct (iota 0 31)).
Eval compute in (construct (iota 0 32)).
Eval compute in (construct (iota 0 33)).
Eval compute in (construct (iota 0 34)).

End Construction_1.

(* Implementation 2: for binary trees with labeled nodes *)

Inductive tree' (A : Type) := tnode of tree' A & A & tree' A | tnil.

Arguments tnil {A}.

Module Construction_2.

Section Definitions.

Variable (A : Type).

Fixpoint push (t : tree' A) (x : A) (ts : seq (option (tree' A * A))) :
  seq (option (tree' A * A)) :=
  match ts with
    | [::] as ts' | None :: ts' => Some (t, x) :: ts'
    | Some (t', x') :: ts' => None :: push (tnode t' x' t) x ts'
  end.

Fixpoint pop (t : tree' A) (ts : seq (option (tree' A * A))) : tree' A :=
  match ts with
    | [::] => t
    | None :: ts' => pop t ts'
    | Some (t', x') :: ts' => pop (tnode t' x' t) ts'
  end.

Fixpoint rep_push (ts : seq (option (tree' A * A))) (xs : seq A) : tree' A :=
  match xs with
    | [::] => pop tnil ts
    | [:: x] => pop (tnode tnil x tnil) ts
    | x :: x' :: xs' => rep_push (push (tnode tnil x tnil) x' ts) xs'
  end.

Definition construct (xs : seq A) : tree' A := rep_push [::] xs.

End Definitions.

Notation "l #< x ># r" := (tnode l x r) (at level 75, no associativity).

Eval compute in (construct (iota 0 29)).
Eval compute in (construct (iota 0 30)).
Eval compute in (construct (iota 0 31)).
Eval compute in (construct (iota 0 32)).
Eval compute in (construct (iota 0 33)).

End Construction_2.


(* -------------------------Description--------------------------------------

   In this file we capture the notion of ordType. This type has
   elements with decidable equality. This is almost same and inspired by
   ssreflect library.
   We also connect natural numbers and booleans to this type by creating
   canonical instances nat_eqType and bool_eqType.

   Structure type: Type:=  Pack {
                             E: Type;
                             eqb: E-> E -> bool;
                             eqP: forall x y, reflect (eq x y)(eqb x y) }.

  Notation "x == y":= (@Decidable.eqb _ x y)(at level 70, no associativity).

  Some important results are:

  Lemma eqP  (T:ordType)(x y:T): reflect (x=y)(eqb  x y).
  Lemma nat_eqP (x y:nat): reflect (x=y)(Nat.eqb x y).

  Canonical nat_eqType: eqType:=
                              {| Decidable.E:= nat; Decidable.eqb:= Nat.eqb;
                                  Decidable.eqP:= nat_eqP |}.

  Lemma bool_eqP (x y:bool): reflect (x=y)(Bool.eqb x y).

  Canonical bool_eqType: eqType:=
                             {| Decidable.E:= bool; Decidable.eqb:= Bool.eqb;
                                  Decidable.eqP:= bool_eqP |}.

   ------------------------------------------------------------------------- *)

From Coq Require Export ssreflect  ssrbool.
Require Export  GenReflect Omega.

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

Module Decidable.
  Structure type: Type:= Pack {
                             E: Type;
                             eqb: E-> E -> bool;
                             eqP: forall x y, reflect (eq x y)(eqb x y) }.
  Module Exports.
    Coercion E : type >-> Sortclass.
    Notation eqType:= type.
    End Exports.
End Decidable.
Export Decidable.Exports.

Notation "x == y":= (@Decidable.eqb _ x y)(at level 70, no associativity): bool_scope.

Lemma eqP  (T:eqType)(x y:T): reflect (x=y)(x == y).
Proof. apply Decidable.eqP. Qed.

Hint Resolve eqP: core.

Lemma eq_to_eqb (T:eqType)(x y:T): (x=y)-> (x == y).
Proof.  intro; apply /eqP; auto. Qed.
Lemma eqb_to_eq (T:eqType) (x y:T): (x == y)-> (x=y).
Proof. intro;apply /eqP; auto. Qed.

Hint Immediate eq_to_eqb eqb_to_eq: core.

Lemma eq_refl (T: eqType)(x:T): x == x.
Proof. apply /eqP; auto. Qed.
Lemma eq_symm (T: eqType)(x y:T): (x == y)=(y == x).
Proof. { case (x== y) eqn:H1; case ( y== x) eqn:H2;  try(auto).
       { assert (H3: x=y). apply /eqP;auto.
         rewrite H3 in H2; rewrite eq_refl in H2; inversion H2. }
       { assert (H3: y= x). apply /eqP; auto.
         rewrite H3 in H1; rewrite eq_refl in H1; inversion H1.  } } Qed.

Hint Resolve eq_refl eq_symm: core.

(*--------- Natural numbers as an instance of eqType---------------------*)

Lemma nat_eqb_ref (x:nat): Nat.eqb x x = true.
Proof. induction x;simpl;auto. Qed.
Hint Resolve nat_eqb_ref:core.

Lemma nat_eqb_elim (x y:nat):  Nat.eqb x y -> x = y.
Proof. { revert y. induction x.
       { intro y. case y. tauto. simpl; intros n H; inversion H. }
       intro y. case y. simpl; intro H; inversion H. simpl. eauto. } Qed.
Hint Resolve nat_eqb_elim: core.

Lemma nat_eqb_intro (x y:nat): x=y -> Nat.eqb x y.
Proof. intro H. subst x. eauto. Qed.
Hint Resolve nat_eqb_intro: core.

Lemma nat_eqP (x y:nat): reflect (x=y)(Nat.eqb x y).
Proof. apply reflect_intro.  split; eauto. Qed.
Hint Resolve nat_eqP: core.

Canonical nat_eqType: eqType:= {| Decidable.E:= nat; Decidable.eqb:= Nat.eqb;
                                  Decidable.eqP:= nat_eqP |}.

(*--------- Bool as an instance of eqType --------------------------------*)
Lemma bool_eqb_ref (x:bool): Bool.eqb x x = true.
Proof. destruct x; simpl; auto. Qed.
Hint Resolve bool_eqb_ref: core.

Lemma bool_eqb_elim (x y:bool): (Bool.eqb x y) -> x = y.
Proof. destruct x; destruct y; simpl; try (auto || tauto). Qed.

Lemma bool_eqb_intro (x y:bool): x = y -> (Bool.eqb x y).
Proof. intros; subst y; destruct x; simpl; auto. Qed.

Hint Immediate bool_eqb_elim bool_eqb_intro: core.

Lemma bool_eqP (x y:bool): reflect (x=y)(Bool.eqb x y).
Proof. apply reflect_intro.
       split. apply bool_eqb_intro. apply bool_eqb_elim. Qed.
Hint Resolve bool_eqP: core.

Canonical bool_eqType: eqType:= {| Decidable.E:= bool; Decidable.eqb:= Bool.eqb;
                                  Decidable.eqP:= bool_eqP |}.

Ltac conflict_eq :=
    match goal with
    | H:  (?x == ?x)= false  |- _
      => switch_in H; cut(False);[tauto |auto]
    | H: ~(is_true (?x == ?x)) |- _
      => cut(False);[tauto |auto]
    | H: ~ (?x = ?x) |- _
      => cut(False);tauto
    | H: (?x == ?y) = true, H1: ?x <> ?y |- _
      => absurd (x = y);auto
    | H:  is_true (?x == ?y), H1: ?x <> ?y |- _
      => absurd (x = y);auto
    | H: (?x == ?y) = true, H1: ?y <> ?x |- _
      => absurd (y = x);[auto | (symmetry;auto)]
    | H: is_true (?x == ?y), H1: ?y <> ?x |- _
      => absurd (y = x);[auto | (symmetry;auto)]
    | H: (?x == ?y) = false, H1: ?x = ?y |- _
      => switch_in H; absurd (x=y); auto
    | H: (?x == ?y) = false, H1: ?y = ?x |- _
      => switch_in H; symmetry in H1; absurd (x=y); auto
    end.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Essentials.HoTT_Facts.
Require Import Category.Main.

(**
Fro categories C and C', a functor F : C -> C' consists of an arrow map from objects of C to objects of C' and an arrow map from arrows of C to arrows of C' such that an arrow h : a -> b is mapped to (F h) : F a -> F b.

Furthermore, we require functors to map identitiies to identities. Additionally, the immage of the coposition of two arrows must be the same as composition of their images.
*)
Record Functor (C C' : Category) : Type :=
{
  (** Object map *)
  FO : C → C';

  (** Arrow map *)
  FA : ∀ {a b}, (a –≻ b)%morphism → ((FO a) –≻ (FO b))%morphism;

  (** Mapping of identities *)
  F_id : ∀ c, FA (id c) = id (FO c);

  (** Functor commuting with composition *)
  F_compose : ∀ {a b c} (f : (a –≻ b)%morphism) (g : (b –≻ c)%morphism),
      (FA (g ∘ f) = (FA g) ∘ (FA f))%morphism

  (* F_id and F_compose together state the fact that functors are morphisms of categories (preserving the structure of categories!)*)
}.

Arguments FO {_ _} _ _.
Arguments FA {_ _} _ {_ _} _, {_ _} _ _ _ _.
Arguments F_id {_ _} _ _.
Arguments F_compose {_ _} _ {_ _ _} _ _.

Notation "C –≻ D" := (Functor C D) : functor_scope.

Bind Scope functor_scope with Functor.

Notation "F '_o'" := (FO F) : object_scope.

Notation "F '@_a'" := (@FA _ _ F) : morphism_scope.

Notation "F '_a'" := (FA F) : morphism_scope.

Hint Extern 2 => (apply F_id).

Local Open Scope morphism_scope.
Local Open Scope object_scope.

Ltac Functor_Simplify :=
  progress
    (
      repeat rewrite F_id;
      (
        repeat
          match goal with
          | [|- ?F _a ?A = id (?F _o ?x)] =>
            (rewrite <- F_id; (cbn+idtac))
          | [|- (id (?F _o ?x)) = ?F _a ?A] =>
            (rewrite <- F_id; (cbn+idtac))
          | [|- ?F _a ?A ∘ ?F _a ?B = ?F _a ?C ∘ ?F _a ?D] =>
            (repeat rewrite <- F_compose; (cbn+idtac))
          | [|- ?F _a ?A ∘ ?F _a ?B = ?F _a ?C] =>
            (rewrite <- F_compose; (cbn+idtac))
          | [|- ?F _a ?C = ?F _a ?A ∘ ?F _a ?B] =>
            (rewrite <- F_compose; (cbn+idtac))
          | [|- context [?F _a ?A ∘ ?F _a ?B]] =>
            (rewrite <- F_compose; (cbn+idtac))
          end
      )
    )
.

Hint Extern 2 => Functor_Simplify.

Section Functor_eq_simplification.

  Context {C C' : Category} (F G : (C –≻ C')%functor).

  (** Two functors are equal if their object maps and arrow maps are. *)
  Lemma Functor_eq_simplify (Oeq : F _o = G _o) :
    ((fun x y => match Oeq in _ = V return ((x –≻ y) → ((V x) –≻ (V y)))%morphism with idpath => F  @_a x y end) = G @_a) -> F = G.
  Proof.
    destruct F as [Fo Fa Fi Fc]; destruct G as [Go Ga Gi Gc].
    basic_simpl.
    ElimEq.
    doHomPIR.
    trivial.
  Defined.

  (** Extensionality for arrow maps of functors. *)
  Theorem FA_extensionality (Oeq : F _o = G _o) :
    (
      ∀ (a b : Obj)
        (h : (a –≻ b)%morphism),
        (
          fun x y =>
            match Oeq in _ = V return
                  ((x –≻ y) → ((V x) –≻ (V y)))%morphism
            with
              idpath => F  @_a x y
            end
        ) _ _ h = G _a h
    )
    →
    (
      fun x y =>
        match Oeq in _ = V return
              ((x –≻ y) → ((V x) –≻ (V y)))%morphism
        with
          idpath => F  @_a x y
        end
    ) = G @_a.
  Proof.
    auto.
  Defined.

  (** Fucntor extensionality: two functors are equal of their object maps are equal and their arrow maps are extensionally equal. *)
  Lemma Functor_extensionality (Oeq : F _o = G _o) :
    (
      ∀ (a b : Obj) (h : (a –≻ b)%morphism),
        (
          fun x y =>
            match Oeq in _ = V return
                  ((x –≻ y) → ((V x) –≻ (V y)))%morphism
            with
              idpath => F  @_a x y
            end
        ) _ _ h = G _a h
    ) → F = G.
  Proof.
    intros H.
    apply (Functor_eq_simplify Oeq); trivial.
    apply FA_extensionality; trivial.
  Defined.

End Functor_eq_simplification.

Hint Extern 2 => Functor_Simplify.

Ltac Func_eq_simpl :=
  match goal with
    [|- ?A = ?B :> Functor _ _] =>
    (apply (Functor_eq_simplify A B (idpath : A _o = B _o)%object)) +
    (cut (A _o = B _o)%object; [
       let u := fresh "H" in
       intros H;
         apply (Functor_eq_simplify A B H)
         |
    ])
  end.

Hint Extern 3 => Func_eq_simpl.

Lemma f_equal_Functor_eq_simplify_Oeq
      {C C' : Category} (F G : (C –≻ C')%functor)
      (Oeq : F _o = G _o)
      (H : (fun x y =>
              match Oeq in _ = V return
                    ((x –≻ y) → ((V x) –≻ (V y)))%morphism
              with
                idpath => F  @_a x y
              end
           ) = G @_a
      )
  :
    f_equal FO (Functor_eq_simplify _ _ Oeq H) = Oeq
.
Proof.
  destruct F as [Fo Fa Fi Fc]; destruct G as [Go Ga Gi Gc].
  cbn in *.
  destruct Oeq.
  destruct H.
  doHomPIR.
  cbn.
  repeat rewrite (@contr _ _ idpath).
  trivial.
Qed.

(** Given two categories C and D if the objects of D form a HSet then the type of functors
C –≻ D also form a HSet.

We prove this by estabilishing a left inverse for the Functor_extensionality and showing that
the codomain type of Functor extensionenatilty forms a HSet.
*)
Section CoDom_Cat_HSet_Functor_HSet.
  Context
    (C D : Category)
    {DHS : IsHSet D}
  .

  Lemma Functor_extensionality_inv
        {F G : Functor C D}
        (HO : F _o = G _o)
        (H : F = G)
    :
      (
        ∀ (a b : Obj) (h : (a –≻ b)%morphism),
          (
            fun x y =>
              match HO in _ = V return
                    ((x –≻ y) → ((V x) –≻ (V y)))%morphism
              with
                idpath => F  @_a x y
              end
          ) _ _ h = G _a h
      ).
  Proof.
    destruct H.
    match type of HO with
      ?A = ?B =>
      match type of A with
        ?U =>
        let H := fresh "H" in
        assert (H : IsHSet U);
          [
            repeat (apply @trunc_forall; [typeclasses eauto|intros ?x]);
            refine DHS
          |
          rewrite (@center _ (H _ _ HO idpath)); clear H
          ]
      end
    end.
    trivial.
  Defined.

  Theorem Functor_extensionality_inv_is_left_inverse
          (F G : Functor C D)
          (HO : F _o = G _o)
          (H : F = G)
    :
      Functor_extensionality _ _ HO (Functor_extensionality_inv HO H) = H
  .
  Proof.
    destruct H.
    match type of HO with
      ?A = ?B =>
      match type of A with
        ?U =>
        let H := fresh "H" in
        assert (H : IsHSet U);
          [
            repeat (apply @trunc_forall; [typeclasses eauto|intros ?x]);
            refine DHS
          |
          rewrite (@center _ (H _ _ HO idpath)); clear H
          ]
      end
    end.
    unfold Functor_extensionality; unfold FA_extensionality.
    match goal with
      [|- _ _ _ _ ?A = _] =>
      generalize A as H'
    end.
    intros H'.
    match type of H' with
      ?A = ?B =>
      match type of A with
        ?U =>
        let H := fresh "H" in
        assert (H : IsHSet U);
          [
            repeat (apply @trunc_forall; [typeclasses eauto|intros ?x]);
            refine (Hom_HSet)
          |
          rewrite (@center _ (H _ _ H' idpath)); clear H H'
          ]
      end
    end.
    cbn.
    repeat rewrite (@contr _ _ idpath).
    trivial.
  Qed.

  Theorem CoDom_Cat_HSet_Functor_HSet : IsHSet (Functor C D).
  Proof.
    intros f g H1 H2.
    destruct H1.
    cbn in *.
    assert
      (
        Hc :
          IsHProp
            (
               ∀ (a b : Obj) (h : (a –≻ b)%morphism),
                 (
                   fun x y =>
                     match f_equal FO H2 in _ = V return
                           ((x –≻ y) → ((V x) –≻ (V y)))%morphism
                     with
                       idpath => f  @_a x y
                     end
                 ) _ _ h = f _a h
            )
      ).
    {
      repeat (apply @trunc_forall; [typeclasses eauto|intros ?x]);
      refine (Hom_HSet _ _).
    }
    {
      apply
        (
          @left_inv_equi_trunc
            (f = f)
            _
            _
            Hc
            (Functor_extensionality_inv (f_equal FO H2))
            (Functor_extensionality _ _ (f_equal FO H2))
            (Functor_extensionality_inv_is_left_inverse _ _ (f_equal FO H2))
            idpath
            H2
        ).
    }
  Qed.

End CoDom_Cat_HSet_Functor_HSet.


Lemma succ_neq :
  forall (n : nat),
    n <> S n.
Proof.
  intros.
  intro.
  induction n.
  discriminate.
  destruct IHn.
  congruence.
Qed.

Lemma s_neq :
  forall (n : nat) (m : nat),
    n = S m -> n <> m.
Proof.
  intros.
  intro.
  rewrite H0 in H.
  apply succ_neq in H.
  apply H.
Qed.

Lemma s_neq_2 :
  forall (n : nat) (m : nat),
    S n = S m <-> n = m.
Proof.
  intros.
  split. intro.
  inversion H. tauto.

  intro. rewrite H.
  tauto.
Qed.

Lemma l_sub :
  forall (p : nat) (q : nat) (r : nat),
    p + q = p + r <-> q = r.
Proof.
  intros.
  split.
  intro.
  induction p.
  compute in H. apply H.

  inversion H. apply IHp in H1. apply H1.

  intro.
  rewrite H.
  tauto.
Qed.

Lemma succ_add :
  forall (p : nat),
    S p = p + 1.
Proof.
  intro.

  case_eq (p). intros. compute. auto.
  intros. rewrite <- H.
  assert (p = p + 0).
  apply plus_n_O.
  rewrite H0.
  rewrite plus_n_Sm. rewrite <- H0.
  tauto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal50.

Set Printing Depth 1000.
Definition lfind_eval  n y:=
count y n.

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Nil).


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(**********************************************************)
(** Complements for the reals.Integer and fractional part *)
(*                                                        *)
(**********************************************************)

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

(*********************************************************)
(** *    Fractional part                                 *)
(*********************************************************)

(**********)
Definition Int_part (r:R) : Z := (up r - 1)%Z.

(**********)
Definition frac_part (r:R) : R := r - IZR (Int_part r).

(**********)
Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r.
Proof.
  intros; generalize (archimed r); intro; elim H1; intros; clear H1;
    unfold Rgt in H2; unfold Rminus in H3;
      generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3);
        intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1;
          rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1;
            rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r)));
              intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r));
                auto with zarith real.
Qed.

(**********)
Lemma up_tech :
  forall (r:R) (z:Z), IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = up r.
Proof.
  intros.
  apply tech_up with (1 := H0).
  rewrite plus_IZR.
  now apply Rplus_le_compat_r.
Qed.

(**********)
Lemma fp_R0 : frac_part 0 = 0.
Proof.
  unfold frac_part, Int_part.
  replace (up 0) with 1%Z.
  now rewrite <- minus_IZR.
  destruct (archimed 0) as [H1 H2].
  apply lt_IZR in H1.
  rewrite <- minus_IZR in H2.
  apply le_IZR in H2.
  omega.
Qed.

(**********)
Lemma for_base_fp : forall r:R, IZR (up r) - r > 0 /\ IZR (up r) - r <= 1.
Proof.
  intro; split; cut (IZR (up r) > r /\ IZR (up r) - r <= 1).
  intro; elim H; intros.
  apply (Rgt_minus (IZR (up r)) r H0).
  apply archimed.
  intro; elim H; intros.
  exact H1.
  apply archimed.
Qed.

(**********)
Lemma base_fp : forall r:R, frac_part r >= 0 /\ frac_part r < 1.
Proof.
  intro; unfold frac_part; unfold Int_part; split.
     (*sup a O*)
  cut (r - IZR (up r) >= -1).
  rewrite <- Z_R_minus; simpl; intro; unfold Rminus;
    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
      fold (r - IZR (up r)); fold (r - IZR (up r) - -1);
        apply Rge_minus; auto with zarith real.
  rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
    auto with zarith real.
    (*inf a 1*)
  cut (r - IZR (up r) < 0).
  rewrite <- Z_R_minus; simpl; intro; unfold Rminus;
    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
      fold (r - IZR (up r)); rewrite Ropp_involutive;
        elim (Rplus_ne 1); intros a b; pattern 1 at 2;
          rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
            apply Rplus_lt_compat_l; auto with zarith real.
  elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
    apply Ropp_gt_lt_contravar; auto with zarith real.
Qed.

(*********************************************************)
(** *    Properties                                      *)
(*********************************************************)

(**********)
Lemma base_Int_part :
  forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1.
Proof.
  intro; unfold Int_part; elim (archimed r); intros.
  split; rewrite <- (Z_R_minus (up r) 1); simpl.
  apply Rminus_le.
  replace (IZR (up r) - 1 - r) with (IZR (up r) - r - 1) by ring.
  now apply Rle_minus.
  apply Rminus_gt.
  replace (IZR (up r) - 1 - r - -1) with (IZR (up r) - r) by ring.
  now apply Rgt_minus.
Qed.

(**********)
Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z.of_nat n.
Proof.
  intros n; unfold Int_part.
  cut (up (INR n) = (Z.of_nat n + Z.of_nat 1)%Z).
  intros H'; rewrite H'; simpl; ring.
  symmetry; apply tech_up; auto.
  replace (Z.of_nat n + Z.of_nat 1)%Z with (Z.of_nat (S n)).
  repeat rewrite <- INR_IZR_INZ.
  apply lt_INR; auto.
  rewrite Z.add_comm; rewrite <- Znat.Nat2Z.inj_add; simpl; auto.
  rewrite plus_IZR; simpl; auto with real.
  repeat rewrite <- INR_IZR_INZ; auto with real.
Qed.

(**********)
Lemma fp_nat : forall r:R, frac_part r = 0 ->  exists c : Z, r = IZR c.
Proof.
  unfold frac_part; intros; split with (Int_part r);
    apply Rminus_diag_uniq; auto with zarith real.
Qed.

(**********)
Lemma R0_fp_O : forall r:R, 0 <> frac_part r -> 0 <> r.
Proof.
  red; intros; rewrite <- H0 in H; generalize fp_R0; intro;
    auto with zarith real.
Qed.

(**********)
Lemma Rminus_Int_part1 :
  forall r1 r2:R,
    frac_part r1 >= frac_part r2 ->
    Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
        intro; clear H4; rewrite Ropp_0 in H0;
          generalize (Rge_le 0 (- frac_part r2) H0); intro;
            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                intro; clear H1; unfold Rgt in H2;
                  generalize
                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
                    intro; elim H1; intros; clear H1; elim (Rplus_ne 1);
                      intros a b; rewrite a in H6; clear a b H5;
                        generalize (Rge_minus (frac_part r1) (frac_part r2) H);
                          intro; clear H; fold (frac_part r1 - frac_part r2) in H6;
                            generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1);
                              intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H;
                                unfold Rminus in H6, H;
                                  rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H;
                                    rewrite (Ropp_involutive (IZR (Int_part r2))) in H;
                                      rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                        in H;
                                        rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                          in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H;
                                            rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                              rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                                  fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H;
                                                    generalize
                                                      (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0
                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H);
                                                      intro; clear H;
                                                        rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                          rewrite <-
                                                            (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                              (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                            in H0; unfold Rminus in H0; fold (r1 - r2) in H0;
                                                              rewrite
                                                                (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
                                                                  (IZR (Int_part r2) + - IZR (Int_part r1))) in H0;
                                                                rewrite <-
                                                                  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                    (- IZR (Int_part r1))) in H0;
                                                                  rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0;
                                                                    elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                      rewrite b in H0; clear a b;
                                                                        elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2)));
                                                                          intros a b; rewrite a in H0; clear a b;
                                                                            rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2));
                                                                              intros a b; rewrite b in H0; clear a b;
                                                                                fold (IZR (Int_part r1) - IZR (Int_part r2)) in H0;
                                                                                rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H6;
                                                                                rewrite (Ropp_involutive (IZR (Int_part r2))) in H6;
                                                                                rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                                                                in H6;
                                                                                rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                                                                in H6; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H6;
                                                                                rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
                                                                                rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                                                in H6;
                                                                                rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
                                                                                fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6;
                                                                                generalize
                                                                                (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6);
                                                                                intro; clear H6;
                                                                                rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                                                rewrite <-
                                                                                (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                                                in H;
                                                                                rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                                                                rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H;
                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                                clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H.
    rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
      generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H);
        intros; clear H H0; unfold Int_part at 1;
          omega.
Qed.

(**********)
Lemma Rminus_Int_part2 :
  forall r1 r2:R,
    frac_part r1 < frac_part r2 ->
    Int_part (r1 - r2) = (Int_part r1 - Int_part r2 - 1)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
        intro; clear H4; rewrite Ropp_0 in H0;
          generalize (Rge_le 0 (- frac_part r2) H0); intro;
            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                intro; clear H1; unfold Rgt in H2;
                  generalize
                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
                    intro; elim H1; intros; clear H1; elim (Rplus_ne (-1));
                      intros a b; rewrite b in H5; clear a b H6;
                        generalize (Rlt_minus (frac_part r1) (frac_part r2) H);
                          intro; clear H; fold (frac_part r1 - frac_part r2) in H5;
                            clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1;
                              rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5;
                                rewrite (Ropp_involutive (IZR (Int_part r2))) in H5;
                                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                    in H5;
                                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                      in H5; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H5;
                                        rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
                                          rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                            in H5;
                                            rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
                                              fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5;
                                                generalize
                                                  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1)
                                                    (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5);
                                                  intro; clear H5;
                                                    rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                      rewrite <-
                                                        (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                          (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                        in H; unfold Rminus in H; fold (r1 - r2) in H;
                                                          rewrite
                                                            (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
                                                              (IZR (Int_part r2) + - IZR (Int_part r1))) in H;
                                                            rewrite <-
                                                              (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                (- IZR (Int_part r1))) in H;
                                                              rewrite (Rplus_opp_l (IZR (Int_part r2))) in H;
                                                                elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                  rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H;
                                                                    elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                      clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H;
                                                                        fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H;
                                                                          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1;
                                                                            rewrite (Ropp_involutive (IZR (Int_part r2))) in H1;
                                                                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                                                                in H1;
                                                                                rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                                                                in H1; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H1;
                                                                                rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                                                                                rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                                                in H1;
                                                                                rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                                                                                fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1;
                                                                                generalize
                                                                                (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1);
                                                                                intro; clear H1;
                                                                                rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                                                rewrite <-
                                                                                (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                                                in H0;
                                                                                rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                                                                rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0;
                                                                                clear a b; rewrite <- (Rplus_opp_l 1) in H0;
                                                                                rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-(1)) 1)
                                                                                in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                auto with zarith real.
  change (_ + -1) with (IZR (Int_part r1 - Int_part r2) - 1) in H;
    rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
      rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
        rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
          generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H);
            intro; clear H;
              generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0);
                intros; clear H0 H1; unfold Int_part at 1;
                  omega.
Qed.

(**********)
Lemma Rminus_fp1 :
  forall r1 r2:R,
    frac_part r1 >= frac_part r2 ->
    frac_part (r1 - r2) = frac_part r1 - frac_part r2.
Proof.
  intros; unfold frac_part; generalize (Rminus_Int_part1 r1 r2 H);
    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
      unfold Rminus;
        rewrite (Ropp_plus_distr (IZR (Int_part r1)) (- IZR (Int_part r2)));
          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
            rewrite (Ropp_involutive (IZR (Int_part r2)));
              rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
                rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                  rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
                      rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                        auto with zarith real.
Qed.

(**********)
Lemma Rminus_fp2 :
  forall r1 r2:R,
    frac_part r1 < frac_part r2 ->
    frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1.
Proof.
  intros; unfold frac_part; generalize (Rminus_Int_part2 r1 r2 H);
    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
      rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
        unfold Rminus;
          rewrite
            (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
            ; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
              rewrite (Ropp_involutive (IZR 1));
                rewrite (Ropp_involutive (IZR (Int_part r2)));
                  rewrite (Ropp_plus_distr (IZR (Int_part r1)));
                    rewrite (Ropp_involutive (IZR (Int_part r2))); simpl;
                      rewrite <-
                        (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1)
                        ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
                          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                            rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
                                rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                                  auto with zarith real.
Qed.

(**********)
Lemma plus_Int_part1 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 >= 1 ->
    Int_part (r1 + r2) = (Int_part r1 + Int_part r2 + 1)%Z.
Proof.
  intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H;
    elim (base_fp r1); elim (base_fp r2); intros; clear H H2;
      generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3);
        intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1);
          intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2;
            generalize
              (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2);
              intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1;
                unfold frac_part in H0, H1; unfold Rminus in H0, H1;
                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                        in H1;
                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                            in H1;
                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                                in H0; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H0;
                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                                    in H0;
                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H0;
                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                                        in H0;
                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                          generalize
                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1
                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0);
                                            intro; clear H0;
                                              generalize
                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1);
                                                intro; clear H1;
                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                    in H;
                                                    rewrite <-
                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                      in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H;
                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H;
                                                          clear a b;
                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                              in H0;
                                                              rewrite <-
                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
                                                                  elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0;
                                                                    clear a b;
                                                                      change 2 with (1 + 1) in H0;
                                                                      rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
                                                                        auto with zarith real.
    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H;
      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
          rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
            rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
              generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0);
                intro; clear H H0; unfold Int_part at 1; omega.
Qed.

(**********)
Lemma plus_Int_part2 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 < 1 ->
    Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2;
        generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1);
          intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b;
            rewrite a in H2; clear a b;
              generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2);
                intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1;
                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                        in H1;
                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                            in H1;
                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                                in H; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H;
                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) in H;
                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H;
                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                                        in H;
                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                          generalize
                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0
                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1);
                                            intro; clear H1;
                                              generalize
                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H);
                                                intro; clear H;
                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                    in H1;
                                                    rewrite <-
                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                      in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1;
                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1;
                                                          clear a b;
                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                              in H0;
                                                              rewrite <-
                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
                                                                  elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2)));
                                                                    intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
                                                                      intros a b; rewrite b in H0; clear a b.
    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
          generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1);
            intro; clear H0 H1; unfold Int_part at 1;
              omega.
Qed.

(**********)
Lemma plus_frac_part1 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 >= 1 ->
    frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1.
Proof.
  intros; unfold frac_part; generalize (plus_Int_part1 r1 r2 H); intro;
    rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1);
      rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl;
        unfold Rminus at 3 4;
          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
            rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
                rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                  rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                    rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
                      unfold Rminus;
                        rewrite
                          (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1)))
                          ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
                            trivial with zarith real.
Qed.

(**********)
Lemma plus_frac_part2 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 < 1 ->
    frac_part (r1 + r2) = frac_part r1 + frac_part r2.
Proof.
  intros; unfold frac_part; generalize (plus_Int_part2 r1 r2 H); intro;
    rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2));
      unfold Rminus at 2 3;
        rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
          rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
            rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
              rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                  rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
                    unfold Rminus; trivial with zarith real.
Qed.


(* (** Finite Closure Iteration *) *)
(* Section Fixedpoints. *)
(*   Variable X: Type. *)
(*   Variable f: X -> X. *)
(*   Definition fp x := f x = x. *)

(*   Lemma fp_trans x: fp x -> fp (f x). *)
(*   Proof. *)
(*     congruence. *)
(*   Qed. *)

(*   Lemma fInduction (p: X -> Prop) (x:X) (px: p x) (IHf: forall y, p y -> p (f y)) n: p (Nat.iter n f x). *)
(*   Proof. *)
(*     induction n. *)
(*     - exact px. *)
(*     -  firstorder. *)
(*   Qed. *)

(* Lemma fp_iter_trans x n: fp (Nat.iter n f x) -> forall m, m >= n -> fp (Nat.iter m f x). *)
(* Proof. *)
(*   intros F m H. induction m. *)
(*   - destruct n; auto. omega.  *)
(*   - decide (S m = n). *)
(*     + now rewrite e. *)
(*     + assert (m >= n) as G by omega. *)
(*       specialize (IHm G). simpl. now apply fp_trans. *)
(* Qed. *)

(* End Fixedpoints. *)

(* Definition admissible (X: eqType) f := forall A: list X,  fp f A \/ card (f A) > card A. *)

(* Lemma fp_card_admissible (X:eqType) f n: *)
(*   admissible f -> forall A: list X, fp f (Nat.iter n f A) \/ card (Nat.iter n f A) >= n. *)
(*  Proof. *)
(*    intros M A. induction n. *)
(*      - cbn in *. right. omega. *)
(*      - simpl in *. destruct IHn as [IHn | IHn] . *)
(*        + left.  now apply fp_trans. *)
(*        + destruct (M ((Nat.iter n f A))) as [M' | M']. *)
(*          * left.  now apply fp_trans. *)
(*          * right. omega.  *)
(*  Qed. *)

(*  Lemma fp_admissible (X:finType) (f: list X -> list X): *)
(*    admissible f -> forall A, fp f (Nat.iter (Cardinality X) f A). *)
(*  Proof. *)
(*    intros F A. *)
(*    destruct (fp_card_admissible (Cardinality X) F A) as [H | H]. *)
(*    - exact H. *)
(*    - specialize (F (Nat.iter (Cardinality X) f A)).  destruct F as [F |F]. *)
(*      + tauto. *)
(*      + pose proof (card_upper_bound (f (Nat.iter (Cardinality X) f A))). omega. *)
(* Qed.  *)

(* Section FiniteClosureIteration. *)
(*   Variable X : finType. *)
(*   Variable step:list X -> X -> Prop. *)
(*   Variable step_dec: forall A x, dec (step A x). *)

(*   Lemma pick A : {x | step A x /\ ~ (x el A)} + forall x, step A x -> x el A. *)
(*   Proof. *)
(*     decide (forall x, step A x -> x el A). *)
(*     - tauto. *)
(*     - left. destruct (DM_notAll _ (p:= fun x => step A x -> x el A)) as [H _]. *)
(*       destruct (finType_cc _ (H n)) as [x H']. firstorder. *)
(*   Defined. *)

(*   Definition FCStep A := *)
(*     match (pick A) with *)
(*     | inl L => match L with *)
(*                 exist _ x _ => x::A end *)
(*     | inr _ => A end. *)

(*   Definition FCIter := Nat.iter (Cardinality X) FCStep. *)

(* Lemma FCStep_admissible: admissible FCStep. *)
(* Proof. *)
(*   intro A.  unfold fp. unfold FCStep. destruct (pick A) as [[y [S ne]] | S];auto. *)
(*   right. cbn. dec. *)
(*   - tauto. *)
(*   - omega. *)
(* Qed. *)

(* Lemma FCIter_fp A: fp FCStep (FCIter A). *)
(* Proof. *)
(*   unfold FCIter. apply fp_admissible. exact FCStep_admissible. *)
(* Qed.         *)

(* (* inclp A p means every x in A satisfies p *) *)

(* Lemma FCIter_ind (p: X -> Prop) A :  inclp A p ->  (forall A x , (inclp A p) -> (step A x -> p x)) -> inclp (FCIter A) p. *)
(* Proof. *)
(*   intros incl H. unfold FCIter. apply fInduction. *)
(*   - assumption.  *)
(*   - intros B H1 x E. unfold FCStep in E. destruct (pick B) as [[y [S nE]] | S]. *)
(*     + destruct E as [E|E]; try subst x; eauto. *)
(*     + auto. *)
(* Qed.  *)

(* Lemma Closure x A: fp FCStep A -> step A x -> x el A. *)
(* Proof. *)
(*   intros F. unfold fp in F.  unfold FCStep in F. destruct (pick A) as [[y _] | S]. *)
(*   - contradiction (list_cycle F). *)
(*   - exact (S x). *)
(* Qed. *)

(* Lemma Closure_FCIter x A: step (FCIter A) x -> x el (FCIter A). *)
(* Proof. apply Closure. apply FCIter_fp. *)
(* Qed. *)

(* Lemma preservation_step A: A <<= FCStep A. *)
(* Proof. *)
(*   intro H. unfold FCStep. destruct (pick A) as [[y [S ne]] | S]; cbn; tauto. *)
(* Qed. *)

(* Lemma preservation_iter A n: A <<= Nat.iter n FCStep A. *)
(* Proof. *)
(*   intros x E. induction n. *)
(*   - assumption. *)
(*   - simpl. now apply preservation_step. *)
(* Qed. *)

(* Lemma preservation_FCIter A: A <<= FCIter A.  *)
(* Proof. *)
(*  apply preservation_iter. *)
(* Qed. *)

(* Definition least_fp_containing f (B A: list X) := fp f B /\ A <<= B /\ forall B', fp f B' /\ A <<= B' -> B <<= B'. *)

(* Definition step_consistent:= forall A x, step A x -> forall A', A <<= A' -> step A' x. *)

(* Lemma step_iter_consistent: step_consistent -> forall A x n, step A x -> step (Nat.iter n FCStep A) x. *)
(* Proof. *)
(*   intros H A x n S. eapply H. *)
(*   - exact S. *)
(*   - apply preservation_iter. *)
(* Qed. *)

(* Lemma step_trans_fp_incl: step_consistent -> forall A B, fp FCStep B -> A <<= B -> forall n, Nat.iter n FCStep A <<= B. *)
(* Proof. *)
(*  intros ST A B F H n. apply fInduction. *)
(*   - exact H. *)
(*   - intros B' H'. unfold FCStep at 1. destruct (pick B') as [[y [S _]] | _]. *)
(*     + specialize (ST  _ _ S _ H'). intros x [E |E]. *)
(*       * subst x. now apply Closure. *)
(*       * auto. *)
(*     + exact H'. *)
(* Qed. *)

(* Lemma step_consistent_least_fp: step_consistent -> forall A, least_fp_containing FCStep (FCIter A) A. *)
(* Proof. *)
(*   intros ST A.  repeat split. *)
(*   - apply FCIter_fp. *)
(*   - apply preservation_FCIter. *)
(*   - intros B [H H']. now apply step_trans_fp_incl. *)
(* Qed. *)

(*   (** Dupfreeness of FCIter *)
(* - relict of an old proof *)
(* - might still be useful in concrete applications *) *)

(* Lemma dupfree_FCStep A: dupfree A -> dupfree (FCStep A). *)
(* Proof. *)
(*   intro DA. unfold FCStep. destruct (pick A) as [[y [S ne]] | S]; auto. now constructor. *)
(* Qed. *)

(*  Lemma dupfree_iterstep n A: dupfree A -> dupfree (Nat.iter n FCStep A). *)
(*  Proof. *)
(*    induction n. *)
(*    -  now cbn. *)
(*    - intro H. simpl. apply dupfree_FCStep; tauto. *)
(*  Qed. *)

(*  Lemma dupfree_FCIter A : dupfree A -> dupfree (FCIter A). *)
(*  Proof. *)
(*    apply dupfree_iterstep. *)
(*  Qed. *)

(* End FiniteClosureIteration. *)
(* Arguments FCIter {X} step {step_dec} x. *)
(* Arguments FCStep {X} step {step_dec} A. *)
(* Arguments pick {X} {step} {step_dec} A. *)


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

Require Import HoTT.Basics HoTT.Types.

Local Open Scope path_scope.

Generalizable Variables A B.

(** ** Truncatedness is an hprop *)

(** If a type is contractible, then so is its type of contractions.
    Using [issig_contr] and the [equiv_intro] tactic, we can transfer this to the equivalent problem of contractibility of a certain Sigma-type, in which case we can apply the general path-construction functions. *)
Global Instance contr_contr `{Funext} (A : Type)
  : Contr A -> Contr (Contr A) | 100.
Proof.
  intros c; exists c; generalize c.
  equiv_intro (issig_contr A) c'.
  equiv_intro (issig_contr A) d'.
  refine (ap _ _).
  refine (path_sigma _ _ _ ((contr (c'.1))^ @ contr (d'.1)) _).
  refine (path_forall _ _ _); intros x.
  apply path2_contr.
Qed.

(** This provides the base case in a proof that truncatedness is a proposition. *)
Global Instance hprop_trunc `{Funext} (n : trunc_index) (A : Type)
  : IsHProp (IsTrunc n A) | 0.
Proof.
  apply hprop_inhabited_contr.
  revert A.
  simple_induction n n IH; unfold IsTrunc; simpl.
  - intros A ?.
    exact _.
  - intros A AH1.
    exists AH1.
    intro AH2.
    apply path_forall; intro x.
    apply path_forall; intro y.
    apply @path_contr.
    apply IH, AH1.
Qed.
(** By [trunc_hprop], it follows that [IsTrunc n A] is also [m]-truncated for any [m >= -1]. *)

(** Similarly, a map being truncated is also a proposition. *)
Global Instance isprop_istruncmap `{Funext} (n : trunc_index) {X Y : Type} (f : X -> Y)
: IsHProp (IsTruncMap n f).
Proof.
  unfold IsTruncMap.
  exact _.
Defined.

(** ** Alternate characterization of hprops. *)

Theorem equiv_hprop_allpath `{Funext} (A : Type)
  : IsHProp A <~> (forall (x y : A), x = y).
Proof.
  apply (equiv_adjointify (@path_ishprop A) (@hprop_allpath A));
  (* The proofs of the two homotopies making up this equivalence are almost identical.  First we start with a thing [f]. *)
    intro f;
  (* Then we apply funext a couple of times *)
    apply path_forall; intro x;
    apply path_forall; intro y;
  (* Now we conclude that [A] is contractible *)
    try pose (C := Build_Contr A x (f x));
    try pose (D := contr_inhabited_hprop A x);
  (* And conclude because we have a path in a contractible space. *)
    apply path_contr.
Defined.

Theorem equiv_hprop_inhabited_contr `{Funext} {A}
  : IsHProp A <~> (A -> Contr A).
Proof.
  apply (equiv_adjointify (@contr_inhabited_hprop A) (@hprop_inhabited_contr A)).
  - intro ic. by_extensionality x.
    apply @path_contr. apply contr_contr. exact (ic x).
  - intro hp. by_extensionality x. by_extensionality y.
    apply @path_contr. apply contr_contr. exact (hp x y).
Defined.

(** Being an hprop is also equivalent to the diagonal being an equivalence. *)
Definition ishprop_isequiv_diag {A} `{IsEquiv _ _ (fun (a:A) => (a,a))}
: IsHProp A.
Proof.
  apply hprop_allpath; intros x y.
  set (d := fun (a:A) => (a,a)) in *.
  transitivity (fst (d (d^-1 (x,y)))).
  - exact (ap fst (eisretr d (x,y))^).
  - transitivity (snd (d (d^-1 (x,y)))).
    + unfold d; reflexivity.
    + exact (ap snd (eisretr d (x,y))).
Defined.

Global Instance isequiv_diag_ishprop {A} `{IsHProp A}
: IsEquiv (fun (a:A) => (a,a)).
Proof.
  refine (isequiv_adjointify _ fst _ _).
  - intros [x y].
    apply path_prod; simpl.
    + reflexivity.
    + apply path_ishprop.
  - intros a; simpl.
    reflexivity.
Defined.

(** ** A map is an embedding as soon as its ap's have sections. *)

Definition isembedding_sect_ap {X Y} (f : X -> Y)
           (s : forall x1 x2, (f x1 = f x2) -> (x1 = x2))
           (H : forall x1 x2, Sect (s x1 x2) (@ap X Y f x1 x2))
  : IsEmbedding f.
Proof.
  intros y.
  apply hprop_allpath.
  intros [x1 p1] [x2 p2].
  apply path_sigma with (s x1 x2 (p1 @ p2^)).
  abstract (rewrite transport_paths_Fl; cbn;
            rewrite (H x1 x2 (p1 @ p2^));
            rewrite inv_pp, inv_V; apply concat_pV_p).
Defined.

(** ** Alternate characterizations of contractibility. *)

Theorem equiv_contr_inhabited_hprop `{Funext} {A}
  : Contr A <~> A * IsHProp A.
Proof.
  assert (f : Contr A -> A * IsHProp A).
  - intro P. split.
    + exact (@center _ P).
    + apply @trunc_succ. exact P.
  - assert (g : A * IsHProp A -> Contr A).
    + intros [a P]. apply (@contr_inhabited_hprop _ P a).
    + refine (@equiv_iff_hprop _ _ _ _ f g).
      apply hprop_inhabited_contr; intro p.
      apply @contr_prod.
      * exact (g p).
      * apply (@contr_inhabited_hprop _ _ (snd p)).
Defined.

Theorem equiv_contr_inhabited_allpath `{Funext} {A}
  : Contr A <~> A * forall (x y : A), x = y.
Proof.
  transitivity (A * IsHProp A).
  - apply equiv_contr_inhabited_hprop.
  - exact (1 *E equiv_hprop_allpath _).
Defined.

(** ** Logical equivalence of hprops *)

(** Logical equivalence of hprops is not just logically equivalent to equivalence, it is equivalent to it. *)
Global Instance isequiv_equiv_iff_hprop_uncurried
       `{Funext} {A B} `{IsHProp A} `{IsHProp B}
: IsEquiv (@equiv_iff_hprop_uncurried A _ B _) | 0.
Proof.
  pose (@istrunc_equiv).
  refine (isequiv_adjointify
            equiv_iff_hprop_uncurried
            (fun e => (@equiv_fun _ _ e, @equiv_inv _ _ e _))
            _ _);
    intro;
      by apply path_ishprop.
Defined.

Definition equiv_equiv_iff_hprop
       `{Funext} (A B : Type) `{IsHProp A} `{IsHProp B}
  : (A <-> B) <~> (A <~> B)
  := Build_Equiv _ _ (@equiv_iff_hprop_uncurried A _ B _) _.

(** ** Inhabited and uninhabited hprops *)

(** If an hprop is inhabited, then it is equivalent to [Unit]. *)
Lemma if_hprop_then_equiv_Unit (hprop : Type) `{IsHProp hprop} :  hprop -> hprop <~> Unit.
Proof.
  intro p.
  apply equiv_iff_hprop.
  - exact (fun _ => tt).
  - exact (fun _ => p).
Defined.

(** If an hprop is not inhabited, then it is equivalent to [Empty]. *)
Lemma if_not_hprop_then_equiv_Empty (hprop : Type) `{IsHProp hprop} : ~hprop -> hprop <~> Empty.
Proof.
  intro np.
  exact (Build_Equiv _ _ np _).
Defined.

(** Thus, a decidable hprop is either equivalent to [Unit] or [Empty]. *)
Definition equiv_decidable_hprop (hprop : Type)
           `{IsHProp hprop} `{Decidable hprop}
: (hprop <~> Unit) + (hprop <~> Empty).
Proof.
  destruct (dec hprop) as [x|nx].
  - exact (inl (if_hprop_then_equiv_Unit hprop x)).
  - exact (inr (if_not_hprop_then_equiv_Empty hprop nx)).
Defined.


Open Scope list_scope.
Require Import List.

Definition queue (alpha: Set): Set := list alpha * list alpha.

Definition empty (alpha: Set): queue alpha := (nil, nil).

Definition isEmpty {alpha: Set} (q: queue alpha) :=
  match q with
  | (nil, _) => true
  | _ => false
  end.

Definition checkf {alpha: Set} (q: queue alpha) :=
  match q with
  | (nil, r) => (rev r, nil)
  | q' => q'
  end.

Definition fst {alpha: Set} (q: queue alpha) :=
  match q with
  | (f, _) => f
  end.

Definition snd {alpha: Set} (q: queue alpha) :=
  match q with
  | (_, s) => s
  end.

Definition snoc {alpha: Set} (q: queue alpha)(x: alpha) :=
  checkf (fst q, x :: snd q).

Definition head {alpha: Set} (q: queue alpha) :=
  match q with
  | (nil, _) =>  None
  | (x :: f, r) => Some(x)
  end.

Definition tail {alpha: Set} (q: queue alpha) :=
  match q with
  | (nil, _) =>  None
  | (x :: f, r) => Some(checkf (f, r))
  end.

Definition Invaliant {A: Set} (q: queue A) :=
  let '(f, r) := q in
  f = nil -> r = nil.

Lemma snoc_invaliant : forall (A:Set) (q: queue A) (x : A),
    Invaliant q -> Invaliant (snoc q x).
Proof.
  intros A q x H. destruct q as [f r]. unfold snoc, checkf. simpl.
  destruct f.
  - now unfold Invaliant.
  - now unfold Invaliant.
Qed.

Lemma tail_invaliant : forall (A:Set) (q q': queue A),
    Invaliant q -> Some q' = tail q -> Invaliant q'.
Proof.
  intros A q q' H. destruct q as [f r].
  destruct f.
  - now unfold tail.
  - unfold tail, checkf. intros Heq. injection Heq. intros Heq'. clear Heq. subst q'.
    destruct f.
    + now unfold Invaliant.
    + now unfold Invaliant.
Qed.


From Hammer Require Import Hammer.

Require Export NAdd.

Module NOrderProp (Import N : NAxiomsMiniSig').
Include NAddProp N.

Theorem lt_wf_0 : well_founded lt.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_wf_0".
setoid_replace lt with (fun n m => 0 <= n < m).
apply lt_wf.
intros x y; split.
intro H; split; [apply le_0_l | assumption]. now intros [_ H].
Defined.

Theorem nlt_0_r : forall n, ~ n < 0.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.nlt_0_r".
intro n; apply le_ngt. apply le_0_l.
Qed.

Theorem nle_succ_0 : forall n, ~ (S n <= 0).
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.nle_succ_0".
intros n H; apply le_succ_l in H; false_hyp H nlt_0_r.
Qed.

Theorem le_0_r : forall n, n <= 0 <-> n == 0.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_0_r".
intros n; split; intro H.
le_elim H; [false_hyp H nlt_0_r | assumption].
now apply eq_le_incl.
Qed.

Theorem lt_0_succ : forall n, 0 < S n.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_0_succ".
induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r].
Qed.

Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.neq_0_lt_0".
cases n.
split; intro H; [now elim H | intro; now apply lt_irrefl with 0].
intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0].
Qed.

Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.eq_0_gt_0_cases".
cases n.
now left.
intro; right; apply lt_0_succ.
Qed.

Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.zero_one".
setoid_rewrite one_succ.
induct n. now left.
cases n. intros; right; now left.
intros n IH. destruct IH as [H | [H | H]].
false_hyp H neq_succ_0.
right; right. rewrite H. apply lt_succ_diag_r.
right; right. now apply lt_lt_succ_r.
Qed.

Theorem lt_1_r : forall n, n < 1 <-> n == 0.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_1_r".
setoid_rewrite one_succ.
cases n.
split; intro; [reflexivity | apply lt_succ_diag_r].
intros n. rewrite <- succ_lt_mono.
split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0].
Qed.

Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_1_r".
setoid_rewrite one_succ.
cases n.
split; intro; [now left | apply le_succ_diag_r].
intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd.
split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]].
Qed.

Theorem lt_lt_0 : forall n m, n < m -> 0 < m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_lt_0".
intros n m; induct n.
trivial.
intros n IH H. apply IH; now apply lt_succ_l.
Qed.

Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_1_l'".
intros. apply lt_1_l with m; auto.
apply le_lt_trans with n; auto. now apply le_0_l.
Qed.

Section RelElim.

Variable R : relation N.t.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem le_ind_rel :
(forall m, R 0 m) ->
(forall n m, n <= m -> R n m -> R (S n) (S m)) ->
forall n m, n <= m -> R n m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_ind_rel".
intros Base Step; induct n.
intros; apply Base.
intros n IH m H. elim H using le_ind.
solve_proper.
apply Step; [| apply IH]; now apply eq_le_incl.
intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto.
Qed.

Theorem lt_ind_rel :
(forall m, R 0 (S m)) ->
(forall n m, n < m -> R n m -> R (S n) (S m)) ->
forall n m, n < m -> R n m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_ind_rel".
intros Base Step; induct n.
intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]].
rewrite H; apply Base.
intros n IH m H. elim H using lt_ind.
solve_proper.
apply Step; [| apply IH]; now apply lt_succ_diag_r.
intros k H1 H2. apply lt_succ_l in H1. auto.
Qed.

End RelElim.

Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.succ_pred_pos".
intros n H; apply succ_pred; intro H1; rewrite H1 in H.
false_hyp H lt_irrefl.
Qed.

Theorem le_pred_l : forall n, P n <= n.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_pred_l".
cases n.
rewrite pred_0; now apply eq_le_incl.
intros; rewrite pred_succ;  apply le_succ_diag_r.
Qed.

Theorem lt_pred_l : forall n, n ~= 0 -> P n < n.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_pred_l".
cases n.
intro H; exfalso; now apply H.
intros; rewrite pred_succ;  apply lt_succ_diag_r.
Qed.

Theorem le_le_pred : forall n m, n <= m -> P n <= m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_le_pred".
intros n m H; apply le_trans with n. apply le_pred_l. assumption.
Qed.

Theorem lt_lt_pred : forall n m, n < m -> P n < m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_lt_pred".
intros n m H; apply le_lt_trans with n. apply le_pred_l. assumption.
Qed.

Theorem lt_le_pred : forall n m, n < m -> n <= P m.

Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_le_pred".
intro n; cases m.
intro H; false_hyp H nlt_0_r.
intros m IH. rewrite pred_succ; now apply lt_succ_r.
Qed.

Theorem lt_pred_le : forall n m, P n < m -> n <= m.

Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_pred_le".
intros n m; cases n.
rewrite pred_0; intro H; now apply lt_le_incl.
intros n IH. rewrite pred_succ in IH. now apply le_succ_l.
Qed.

Theorem lt_pred_lt : forall n m, n < P m -> n < m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_pred_lt".
intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l].
Qed.

Theorem le_pred_le : forall n m, n <= P m -> n <= m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_pred_le".
intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l].
Qed.

Theorem pred_le_mono : forall n m, n <= m -> P n <= P m.

Proof. hammer_hook "NOrder" "NOrder.NOrderProp.pred_le_mono".
intros n m H; elim H using le_ind_rel.
solve_proper.
intro; rewrite pred_0; apply le_0_l.
intros p q H1 _; now do 2 rewrite pred_succ.
Qed.

Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m).
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.pred_lt_mono".
intros n m H1; split; intro H2.
assert (m ~= 0). apply neq_0_lt_0. now apply lt_lt_0 with n.
now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ;
[apply succ_lt_mono | | |].
assert (m ~= 0). apply neq_0_lt_0. apply lt_lt_0 with (P n).
apply lt_le_trans with (P m). assumption. apply le_pred_l.
apply succ_lt_mono in H2. now do 2 rewrite succ_pred in H2.
Qed.

Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_succ_lt_pred".
intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ.
Qed.

Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m.

Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_succ_le_pred".
intros n m H. apply lt_le_pred. now apply le_succ_l.
Qed.

Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m.

Proof. hammer_hook "NOrder" "NOrder.NOrderProp.lt_pred_lt_succ".
intros n m H. apply lt_succ_r. now apply lt_pred_le.
Qed.

Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m.
Proof. hammer_hook "NOrder" "NOrder.NOrderProp.le_pred_le_succ".
intros n m; cases n.
rewrite pred_0. split; intro H; apply le_0_l.
intro n. rewrite pred_succ. apply succ_le_mono.
Qed.

End NOrderProp.


(* -----------------Description --------------------------------------------------

   This file summarises some useful results from List Module of standard Library.
   We create a hint database to remember important results regarding lists (hint_list).

   Some new definitions:
   Definition Empty (s:list A):Prop := forall a : A, ~ In a s.
   Definition Equal (s s': list A) := forall a : A, In a s <-> In a s'.
   Definition Subset (s s': list A) := forall a : A, In a s -> In a s'.

   Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
   Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).
   Notation "| s |":= (length s) (at level 70, no associativity).

  --------------------   ------------------  ------------------------------------- *)

From Coq Require Export ssreflect  ssrbool.
Require Export Lists.List Omega.

Set Implicit Arguments.

Hint Resolve in_eq in_cons in_inv in_nil in_dec: core.

Section BasicListFacts.
  Variable A:Type.
  Lemma in_inv1 : forall (a b:A) (l:list A), In b (a :: l) -> b = a \/ In b l.
  Proof. { intros  a b l H. cut (a=b \/ In b l).
       Focus 2. auto.  intros H1; destruct H1 as [H1 | H2].
       left; symmetry; auto. right;auto. } Qed.
  Lemma in_inv2: forall (x a:A) (l:list A), In x (a::l)-> x <> a -> In x l.
  Proof.  { intros x a l H. cut (x=a \/ In x l). intro H1;destruct H1 as [Hl1|Hr1].
          intro;contradiction. auto. eapply in_inv1;auto. } Qed.
  Lemma in_inv3: forall (x a:A) (l:list A), In x (a::l)-> ~ In x l -> x = a.
    Proof.  { intros x a l H. cut (x=a \/ In x l). intro H1;destruct H1 as [Hl1|Hr1].
          intro;auto. intro;contradiction.  eapply in_inv1;auto. } Qed.
  Hint Resolve in_inv1 in_inv2 in_inv3 : core.
  (*---------Some facts about NoDup on a list --------------------------------*)
  Lemma nodup_intro (a:A)(l: list A): ~ In a l -> NoDup l -> NoDup (a::l).
    Proof.  intros H1 H2; eapply NoDup_cons_iff;tauto.  Qed.
  Lemma nodup_elim1 (a:A)(l: list A): NoDup (a::l)-> NoDup (l).
  Proof. intro H. eapply NoDup_cons_iff; eauto. Qed.
  Lemma nodup_elim2 (a:A)(l: list A): NoDup (a::l) -> ~ In a l.
    Proof. intro H. eapply NoDup_cons_iff; eauto. Qed.

  Hint Immediate nodup_elim1  nodup_elim2  nodup_intro : core.
  End BasicListFacts.
Hint Resolve in_inv1 in_inv2 in_inv3: core.
Hint Immediate nodup_elim1  nodup_elim2  nodup_intro : core.

Section SetSpec.
  Variable A:Type.
  Definition Empty (s:list A):Prop := forall a : A, ~ In a s.

  Definition Subset (s s': list A) := forall a : A, In a s -> In a s'.
  Definition Equal (s s': list A):= Subset s s' /\ Subset s' s.

  (* Inductive Forall (A : Type) (P : A -> Prop) : list A -> Prop :=
     | Forall_nil : Forall P nil
     | Forall_cons : forall (x : A) (l : list A), P x -> Forall P l -> Forall P (x :: l)  *)

  (* Inductive Exists (A : Type) (P : A -> Prop) : list A -> Prop :=
      |Exists_cons_hd : forall (x : A) (l : list A), P x -> Exists P (x :: l)
      | Exists_cons_tl : forall (x : A) (l : list A), Exists P l -> Exists P (x :: l) *)

  (* Inductive NoDup (A : Type) : list A -> Prop :=
      | NoDup_nil : NoDup nil
      | NoDup_cons : forall (x : A) (l : list A), ~ In x l -> NoDup l -> NoDup (x :: l) *)
End SetSpec.

Ltac unfold_spec := try(unfold Equal);try(unfold Subset);try(unfold Empty).

  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
  Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).
  Notation "| s |":= (length s) (at level 70, no associativity).

Section BasicSetFacts.
  Variable A:Type.

  (*-----------------------Subset (spec) and its properties ------------------------*)
  Lemma Subset_intro (a:A)(l s: list A): l [<=] s -> (a::l) [<=] (a::s).
  Proof. intros H x H1.  destruct H1. subst a;auto. auto. Qed.
  Lemma Subset_intro1 (a:A)(l s: list A): l [<=] s -> l [<=] (a::s).
    Proof. intros H x H1. simpl;right;auto. Qed.
  Lemma Subset_elim1 (a:A) (s s':list A): Subset (a:: s) s'-> In a s'.
  Proof. { unfold Subset. intro H. apply H. auto. } Qed.
   Lemma Subset_elim2 (a:A) (s s':list A): Subset (a:: s) s'->  Subset s s'.
  Proof. { unfold Subset. intro H.  intros a1 H1.
           apply H. auto. } Qed.
  Lemma self_incl (l:list A): l [<=] l.
  Proof. unfold Subset; tauto.  Qed.
  Hint Resolve self_incl: core.

  Lemma Subset_nil (l: list A): nil [<=] l.
  Proof. unfold "[<=]"; simpl; intros; contradiction. Qed.
  Lemma Subset_of_nil (l: list A): l [<=] nil -> l=nil.
    Proof. induction l. auto. intro H. absurd (In a nil); auto. Qed.

  Lemma Subset_trans (l1 l2 l3: list A): l1 [<=] l2 -> l2 [<=] l3 -> l1 [<=] l3.
  Proof. intros H H1 x Hx1. eauto. Qed.

Hint Extern 0 (?x [<=] ?z)  =>
match goal with
| H: (x [<=] ?y) |- _ => apply (@Subset_trans  x y z)
| H: (?y [<=] z) |- _ => apply (@Subset_trans  x y z)
end.

  (* ---------------------- Equal (spec) and their properties--------------------*)
  Lemma Eq_refl (s: list A):  s [=] s.
  Proof.  unfold Equal. split;auto using self_incl.  Qed.
  Lemma Eq_sym (s s':list A): s [=] s' -> s' [=] s.
  Proof. unfold Equal.  tauto. Qed.
  Lemma Eq_trans1 ( x y z : list A) : x [=] y -> y [=] z -> x [=] z.
  Proof. { unfold Equal.  intros H H1. destruct H as [H0 H]; destruct H1 as [H1a H1].
           split; auto. } Qed.

 Hint Extern 0 (?x [=] ?z)  =>
match goal with
| H: (x [=] ?y) |- _ => apply (@Eq_trans1  x y z)
| H: (?y [=] z) |- _ => apply (@Eq_trans1  x y z)
end.

  Lemma Equal_intro (s s': list A): s [<=] s' -> s' [<=] s -> s [=] s'.
  Proof. unfold "[=]".  tauto. Qed.
  Lemma Equal_intro1 (s s': list A): s = s' -> Equal s s'.
  Proof. intro; subst s; apply Eq_refl; auto. Qed.
  Lemma Equal_elim ( s s': list A): s [=] s' ->  s [<=] s' /\ s' [<=] s.
  Proof. unfold_spec; unfold iff. intros H; split; intro a;apply H. Qed.

  (* ---------------- introduction and elimination for filter operation---------- *)
  (* Check filter :  forall A : Type, (A -> bool) -> list A -> list A *)
  (* Check filter_In : forall (A : Type) (f : A -> bool) (x : A) (l : list A),
       In x (filter f l) <-> In x l /\ f x = true *)
  Lemma filter_elim1 (f: A->bool)(l: list A)(x: A): In x (filter f l)-> In x l.
  Proof. apply filter_In. Qed.
  Lemma filter_elim2 (f: A->bool)(l: list A)(x: A): In x (filter f l)-> (f x).
  Proof. apply filter_In. Qed.
  Lemma filter_intro (f: A->bool)(l: list A)(x: A): In x l -> (f x)-> In x (filter f l).
  Proof. intros; apply filter_In; split;auto. Qed.

  Hint Immediate filter_elim1 filter_elim2 filter_intro: core.

 (*--------Strong Induction, Well founded induction and set cardinality ----------*)

Theorem strong_induction: forall P : nat -> Prop,
                    (forall n : nat, (forall k : nat, (k < n -> P k)) -> P n) ->
                    forall n : nat, P n.
Proof. { intros P Strong_IH n.
         pose (Q:= fun (n: nat)=> forall k:nat, k<= n -> P k).
         assert (H: Q n);unfold Q.
         { induction n.
           { intros k H;apply Strong_IH.
             intros k0 H1.  cut (k0 < 0). intro H2; inversion H2. omega.  }
           { intros k H0.
             assert (H1: k < (S n) \/ k = (S n) ).  apply le_lt_or_eq; auto.
             elim H1. intro. apply IHn. omega.
             intro H. subst k. apply Strong_IH. intros. apply IHn. omega. } }
         unfold Q in H. apply H. omega. }   Qed.

Definition lt_set (l1 l2: list A):= |l1| < |l2|.

Lemma lt_set_is_well_founded: well_founded lt_set.
Proof. { unfold well_founded. intro a.
       remember (|a|) as n. revert Heqn. revert a.
       induction n using strong_induction.
       { intros a H1. apply Acc_intro.
         intros a0 H2. apply H with (k:= |a0|).
         subst n; apply H2. auto. } } Qed.

Lemma non_zero_size (a:A)(l: list A): In a l -> |l| > 0.
  Proof. { induction l.
         { simpl; tauto. }
         { intros. simpl. omega. } } Qed.

Hint Resolve non_zero_size: core.

End BasicSetFacts.

Hint Extern 0 (?x [<=] ?z)  =>
match goal with
| H: (x [<=] ?y) |- _ => apply (@Subset_trans _ x y z)
| H: (?y [<=] z) |- _ => apply (@Subset_trans _ x y z)
end.

Hint Extern 0 (?x [=] ?z)  =>
match goal with
| H: (x [=] ?y) |- _ => apply (@Eq_trans1 _ x y z)
| H: (?y [=] z) |- _ => apply (@Eq_trans1 _ x y z)
end.

Hint Immediate Eq_refl Eq_sym Equal_elim Equal_intro Equal_intro1: core.
Hint Immediate  Subset_elim1 Subset_elim2 Subset_nil Subset_of_nil: core.
Hint Resolve  self_incl: core.
Hint Resolve Subset_intro Subset_intro1: core.

Hint Immediate filter_elim1 filter_elim2 filter_intro: core.

Hint Resolve lt_set_is_well_founded: core.

Hint Resolve non_zero_size: core.