Require Import Verse.Word.
Require Import Verse.Types.Internal.
Require Import Verse.Types.
Require Import Verse.Language.
Require Import Verse.Syntax.

Require Import PeanoNat.
Require Import Eqdep_dec.
Require Import Bool.
Require Import Equality.
Require Import Vector.
Import VectorNotations.
Require Import VectorEq.

Set Implicit Arguments.
Generalizable All Variables.

Notation decidable P := ({P} + {~ P}) (only parsing).

Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P.
Proof.
tauto.
Defined.

Theorem dec_True : decidable True.
Proof.
auto.
Defined.

Theorem dec_False : decidable False.
Proof.
unfold not; auto.
Defined.

Theorem dec_or :
 forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B).
Proof.
tauto.
Defined.

Theorem dec_and :
 forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B).
Proof.
tauto.
Defined.

Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A).
Proof.
tauto.
Defined.

Theorem dec_imp :
 forall A B:Prop, decidable A -> decidable B -> decidable (A -> B).
Proof.
tauto.
Defined.

Theorem dec_iff :
 forall A B:Prop, decidable A -> decidable B -> decidable (A<->B).
Proof.
tauto.
Defined.

Theorem iff_dec :
  forall A B:Prop, A <-> B -> decidable A -> decidable B.
Proof.
  intros A B H AOR.
  destruct AOR as [a | na].
  left; apply H; easy.
  right; intro; contradict na; apply H; easy.
Defined.

Notation eq_dec A := (forall A1 A2 : A, {A1 = A2} + {A1 <> A2}) (only parsing).
Notation eq_dec_P A := (forall A1 A2 : A, A1 = A2 \/ A1 <> A2) (only parsing).

Definition eq_dec_eq_dec_P A : eq_dec A -> eq_dec_P A :=
  fun A_eq_dec a1 a2 => match A_eq_dec a1 a2 with
                        | left p => or_introl p
                        | right p => or_intror p
                        end.

Definition nat_eq_dec : eq_dec nat := Nat.eq_dec.
Definition bool_eq_dec : eq_dec bool := bool_dec.

Hint Resolve dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff nat_eq_dec bool_eq_dec
 : decidable_prop.

Ltac solve_decidable :=
  match goal with
  | |- decidable _ => solve [ auto 100 with decidable_prop core ]
  end.

Lemma eq_dec_refl {T} (T_eq_dec : eq_dec T) (t : T)
  : {p : t = t | T_eq_dec t t = left p}.
  pose (T_eq_dec t t).
  change (T_eq_dec t t) with s.
  destruct s.
  destruct e. exists eq_refl; trivial.
  destruct n; trivial.
Qed.

Lemma eq_dec_neq {T} (T_eq_dec : eq_dec T) (t1 t2 : T)
  : t1 <> t2 -> { p : t1 <> t2 | T_eq_dec t1 t2 = right p}.
  intros.
  pose (T_eq_dec t1 t2).
  change (T_eq_dec t1 t2) with s.
  destruct s;
    [contradiction | ].
  exists n; trivial.
Qed.

(* undep_eq not actually used any more *)
(*
Ltac undep_eq :=
  match goal with
  | [ H : existT _ _ ?a = existT _ _ ?b |- _ ]
    => let He := fresh H in
       assert (He : a = b) by (refine (inj_pair2_eq_dec _ _ _ _ _ _ H);
                             auto with decidable_prop);
       rewrite He in *; clear H
  end.
*)
Ltac crush_eq_dec := repeat aux_match; aux_solve
  with aux_match :=  (intros;
                     match goal with
                     | [ H1 : ?T, H2 : ?T, _ : _ <> _ |- _ ] => idtac
                     | [ H1 : ?T, H2 : ?T, H3 : ?T |- _ ]    => aux_cases2 H1 H3 T
                     | [ H1 : ?T, H2 : ?T |- _ ]             => aux_cases H1 H2 T
                     end)
  with aux_cases H1 H2 T :=
                       let T_eq_dec := fresh "T" in assert (T_eq_dec : eq_dec T) by (intros; solve_decidable);
                                                    destruct (T_eq_dec H1 H2) as [ eq | ];
                                                    [ subst | ..]; clear T_eq_dec
  (* Heuristic for pairing up four hypothesis of the same type by alternation *)
  with aux_cases2 H1 H2 T :=
                       let T_eq_dec := fresh "T" in assert (T_eq_dec : eq_dec T) by (intros; solve_decidable);
                                                    destruct (T_eq_dec H1 H2) as [ eq | ];
                                                    [ symmetry in eq; subst | ..]; clear T_eq_dec
  with aux_solve := try solve [left; constructor; trivial |
                               right; inversion 1; try congruence; easy ].

Ltac crush_eqb_eq :=
  repeat (match goal with
          | [ |- _ <-> _ ] => constructor
          | |- context [?H ?x ?x] => destruct (eq_dec_refl H x) as [eq deceq]; rewrite deceq; trivial
          | H : ?a = ?a -> False |- _ => contradict H; trivial
          | H : ?a = ?b -> False |- context [?Heq_dec ?a ?b] => destruct (Heq_dec a b)
          | |- _ -> _ => intros
          | H : _ = _ |- _ => dependent destruction H
          | _ => try contradiction
          end; autounfold in *).

Section DecFacts.

  Variable T : Type.
  Variable T_dec : forall (a b : T), decidable (a = b).

  (* Boolean equality for decidable Types *)
  Definition eqdec_eqb := fun a b => if T_dec a b then true else false.

  Definition eqdec_eqb_eq : forall a b, eqdec_eqb a b = true <-> a = b.
    unfold eqdec_eqb. intros.
    destruct (T_dec a b);
      unfold iff; split; first [discriminate | contradiction | trivial].
  Defined.

  (* Vector equality is decidable *)
  Definition vec_eq_dec n : eq_dec (Vector.t T n).
    apply (Vector.eq_dec T eqdec_eqb eqdec_eqb_eq).
  Defined.

End DecFacts.

(** Decidable equality for Verse constructs *)

Lemma kind_eq_dec : eq_dec kind.
  refine (
  fun k1 k2 => match k1, k2 with
               | direct, direct => left eq_refl
               | memory, memory => left eq_refl
               | _, _           => right _
               end); intro; exact (match H with end).
Defined.

Lemma endian_eq_dec : eq_dec endian.
  refine (fun e1 e2 => match e1, e2 with
                       | hostE, hostE
                       | bigE, bigE
                       | littleE, littleE => left eq_refl
                       | _, _ => right _
                       end); inversion 1.
Defined.

Hint Resolve vec_eq_dec kind_eq_dec endian_eq_dec : decidable_prop.

Lemma directTy_eq_dec : eq_dec (type direct).
  refine (fun ty => match ty as ty0 in type direct return
                          forall ty' : type direct, {ty0 = ty'} + {ty0 <> ty'} with
                    | word n => fun ty' => match ty' as ty0' in type direct
                                                 return
                                                 {word n = ty0'} + {word n <> ty0'}
                                           with
                                           | word n' => _
                                           | multiword _ _ => _
                                           end
                    | multiword m n => fun ty' => match ty' as ty0' in type direct
                                                        return
                                                        {multiword m n = ty0'} + {multiword m n <> ty0'}
                                                  with
                                                  | word _ => _
                                                  | multiword m' n' => _
                                                  end
                    end).
  all: crush_eq_dec.
(*
  refine (fun (ty ty' : type direct) => match ty in type direct, ty' as ty0' in type direct return {ty = ty0'} + {ty <> ty'} with
                        | word n, word n' => if nat_eq_dec n n'
                                             then _
                                             else _
                        | multiword n m, multiword n' m' => if nat_eq_dec n n'
                                                            then if nat_eq_dec m m'
                                                                 then left _
                                                                 else right _
                                                            else right _
                        | _, _ => right _
                        end).
 *)
(*
  dependent destruction A1; dependent destruction A2; crush_eq_dec.
 *)
Defined.

Hint Resolve directTy_eq_dec.

Lemma ty_eq_dec : forall {k}, eq_dec (type k).
  induction k.
  apply directTy_eq_dec.
  intros ty ty'.
  refine (match ty, ty' with
          | array n e t, array n' e' t' => _
          end).
  crush_eq_dec.
Defined.

Lemma bytes_eq_dec : forall (n : nat), eq_dec (bytes n).
  destruct A1. destruct A2.
  unfold Bvector.Bvector in b, b0.
  crush_eq_dec.
Defined.

Hint Resolve ty_eq_dec bytes_eq_dec : decidable_prop.

Lemma op_eq_dec {ar} : eq_dec (op ar).
  refine (
  fun o1 o2 => match o1 as o1' in op ar'
                     return forall o : op ar', {o1' = o} + {o1' <> o}
               with
               | plus    => fun o => match o as o' in op binary
                                           return {plus = o'} + {plus <> o'}
                                     with
                                     | plus => _
                                     | _    => _
                                     end
               | minus   => fun o => match o as o' in op binary
                                           return {minus = o'} + {minus <> o'}
                                     with
                                     | minus => _
                                     | _     => _
                                     end
               | mul     => fun o => match o as o' in op binary
                                           return {mul = o'} + {mul <> o'}
                                     with
                                     | mul   => _
                                     | _     => _
                                     end
               | quot     => fun o => match o as o' in op binary
                                           return {quot = o'} + {quot <> o'}
                                     with
                                     | quot  => _
                                     | _    => _
                                      end
               | rem      => fun o => match o as o' in op binary
                                            return {rem = o'} + {rem <> o'}
                                      with
                                      | rem  => _
                                      | _    => _
                                      end
               | bitOr    => fun o => match o as o' in op binary
                                            return {bitOr = o'} + {bitOr <> o'}
                                      with
                                      | bitOr  => _
                                      | _    => _
                                      end
               | bitAnd   => fun o => match o as o' in op binary
                                            return {bitAnd = o'} + {bitAnd <> o'}
                                      with
                                      | bitAnd  => _
                                      | _    => _
                                      end
               | bitXor   => fun o => match o as o' in op binary
                                            return {bitXor = o'} + {bitXor <> o'}
                                      with
                                      | bitXor  => _
                                      | _    => _
                                      end
               | bitComp  => fun o => match o as o' in op unary
                                            return {bitComp = o'} + {bitComp <> o'}
                                      with
                                      | bitComp => _
                                      | _       => _
                                      end
               | rotL n   => fun o => match o as o' in op unary
                                            return {rotL n = o'} + {rotL n <> o'}
                                      with
                                      | rotL n' => _
                                      | _       => _
                                      end
               | rotR n   => fun o => match o as o' in op unary
                                            return {rotR n = o'} + {rotR n <> o'}
                                      with
                                      | rotR n' => _
                                      | _       => _
                                      end
               | shiftL n   => fun o => match o as o' in op unary
                                            return {shiftL n = o'} + {shiftL n <> o'}
                                      with
                                      | shiftL n' => _
                                      | _       => _
                                      end
               | shiftR n   => fun o => match o as o' in op unary
                                            return {shiftR n = o'} + {shiftR n <> o'}
                                      with
                                      | shiftR n' => _
                                      | _         => _
                                        end
               | nop        => fun o => match o as o' in op unary
                                              return {nop = o'} + {nop <> o'}
                                        with
                                        | nop  => _
                                        | _    => _
                                        end
               end o2); solve [exact idProp | crush_eq_dec].
Defined.

Hint Resolve vec_eq_dec kind_eq_dec endian_eq_dec ty_eq_dec bytes_eq_dec op_eq_dec
  : decidable_prop.

(* Equality is decidable for scopeVar *)

Fixpoint idxInScope n (vT : Vector.t (some type) n)
         k (ty : type k) (x : scopeVar vT ty) : nat  :=
  match x with
  | headVar    => 0
  | restVar x' => S (idxInScope x')
  end.

Definition scopeVar_eqb n (vT : Vector.t (some type) n)
           k (ty : type k) (x y : scopeVar vT ty) : bool :=
  if Nat.eq_dec (idxInScope x) (idxInScope y)
  then true else false.

Definition scopeVar_eqb_eq n (vT : Vector.t (some type) n)
           k (ty : type k) (x y : scopeVar vT ty) : scopeVar_eqb x y = true <-> x = y.
  constructor.
  * intro eqb_x_y.
    unfold scopeVar_eqb in eqb_x_y.
    simpl in eqb_x_y.
    destruct (Nat.eq_dec (idxInScope x) (idxInScope y));
      [idtac | discriminate].

    dependent induction x; dependent induction y.
  - trivial.
  - contradict e; discriminate.
  - contradict e; discriminate.
  - f_equal.
    apply IHx. apply (eq_add_S e).
    all: trivial.
  * intro.
    unfold scopeVar_eqb.
    rewrite H.
    destruct (Nat.eq_dec (idxInScope y) (idxInScope y));
      congruence.
Qed.
(*
Definition scopeVar_eq_dec n (vT : Vector.t (some type) n)
  : forall {k} {ty : type k}, eq_dec (scopeVar vT ty).
  dependent induction A1; dependent induction A2;
    [left | right .. | idtac]; try congruence.
  destruct (IHA1 A2);
    [left; congruence | right].
  contradict n;
  apply (f_equal ((fun (y : scopeVar (tl v) ty) (x : scopeVar v ty) =>
                    (match x in @scopeVar (S n0) v0 _ ty0
                          return scopeVar (tl v0) ty0 -> scopeVar (tl v0) ty0 with
                    | headVar => fun y => y
                    | restVar x' => fun _ => x'
                    end y)) A1)
                 n).
Defined.
*)


Require Export D.

(** **** Problem #13 : 3 stars (apply_exercise1)  *)
(** Hint: you can use [apply] with previously defined lemmas, not
    just hypotheses in the context.  Remember that [SearchAbout] is
    your friend. *)

Lemma rev_involutive : forall l : list nat,
  rev (rev l) = l.
Proof.
  intros. induction l. reflexivity.
  Lemma rev_snoc_lemma : forall n:nat, forall l:list nat,
    rev (n :: l) = snoc (rev l) n.
  Proof. intros. reflexivity. Qed.
  rewrite -> rev_snoc_lemma. simpl.
  Lemma rev_snoc_lemma2 : forall n:nat, forall l:list nat,
    rev (snoc l n) = n :: rev l.
  Proof. intros. induction l. reflexivity.
  simpl. rewrite -> IHl. simpl. reflexivity. Qed.
  rewrite -> rev_snoc_lemma2. rewrite -> IHl. reflexivity.

Qed.

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     rev l = l'.
Proof.
 intros.
   rewrite -> H.  apply rev_involutive.
Qed.


(*|
###############################################
How could I make example for sigma type in Coq?
###############################################

:Link: https://stackoverflow.com/q/56365504
|*)

(*|
Question
********

For that type:
|*)

Record Version :=
  mkVersion {
      major  : nat;
      minor  : nat;
      branch : {b : nat | b > 0 /\ b <= 9};
      hotfix : {h : nat | h > 0 /\ h < 8}
    }.

(*| I'm trying to make an example, and it failed with: |*)

Fail Example ex1 := mkVersion 3 2 (exist _ 5) (exist _ 5). (* .unfold .fails *)

(*| What am I missing? |*)

(*|
Answer
******

The reason it fails is that you need not only provide a witness (``b``
and ``h`` in this case) but also a proof that the corresponding
condition holds for the provided witness.

I would switch to booleans to make my life easier, because this allows
proof by computation, which is basically what ``eq_refl`` does in the
snippet below:
|*)

Reset Initial. (* .none *)
From Coq Require Import Bool Arith.

Coercion is_true : bool >-> Sortclass.

Record Version :=
  mkVersion {
      major  : nat;
      minor  : nat;
      branch : {b : nat | (0 <? b) && (b <=? 9)};
      hotfix : {h : nat | (0 <? h) && (h <? 8)}
    }.

Example ex1 := mkVersion 3 2 (exist _ 5 eq_refl) (exist _ 5 eq_refl).

(*|
We could introduce a notation allowing a nicer representation of literals:
|*)

Notation "<| M ',' m ',' b '~' h |>" :=
  (mkVersion M m (exist _ b eq_refl) (exist _ h eq_refl)).

Example ex2 := <| 3,2,5~5 |>.

(*|
If there is a need to add manual proofs then I'd suggest to use
``Program`` mechanism:
|*)

From Coq Require Import Program.

Program Definition ex3 b h (condb : b =? 5) (condh : h =? 1) :=
  mkVersion 3 2 (exist _ b _) (exist _ h _).
Next Obligation.
  now unfold is_true in * |-; rewrite Nat.eqb_eq in * |-; subst. Qed.
Next Obligation.
  now unfold is_true in * |-; rewrite Nat.eqb_eq in * |-; subst. Qed.

(*| or ``refine`` tactic: |*)

Definition ex3' b h (condb : b =? 5) (condh : h =? 1) : Version.
Proof.
  now refine (mkVersion 3 2 (exist _ b _) (exist _ h _));
    unfold is_true in * |-; rewrite Nat.eqb_eq in * |-; subst.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div fintype.
From mathcomp Require Import tuple finfun bigop.
Require Import Reals Fourier.
Require Import Reals_ext Ranalysis_ext Rssr log2.

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

Local Open Scope Rb_scope.

Section ln_id_sect.

Definition ln_id x := ln x - (x - 1).

Lemma pderivable_ln_id_xle1 : pderivable ln_id (fun x => 0 < x <= 1).
Proof.
rewrite /pderivable => x Hx.
rewrite /ln_id.
apply derivable_pt_plus.
- apply derivable_pt_ln, Hx.
- apply derivable_pt_opp, derivable_pt_minus ; [apply derivable_pt_id | apply derivable_pt_cst].
Defined.

Definition ln_id' x (H : 0 < x <= 1) := derive_pt ln_id x (pderivable_ln_id_xle1 H).

Lemma derive_pt_ln_id_xle1 : forall x (Hx : 0 < x <= 1), (/ x) - 1 = ln_id' Hx.
Proof.
move=> y Hy.
rewrite /ln_id' /pderivable_ln_id_xle1 /ln_id.
rewrite derive_pt_plus derive_pt_opp derive_pt_ln derive_pt_minus derive_pt_id derive_pt_cst.
rewrite Rminus_0_r /Rminus.
reflexivity.
Defined.

Lemma derive_pt_ln_id_xle1_ge0 x (Hx : 0 < x <= 1) : 0 < if x==1 then 1 else ln_id' Hx.
Proof.
case/orP : (orbN (x == 1)) => Hcase ; first by rewrite Hcase; fourier.
move/negbTE in Hcase ; rewrite Hcase.
rewrite -derive_pt_ln_id_xle1.
apply Rgt_lt, Rgt_minus, Rlt_gt.
rewrite -Rinv_1 ; apply Rinv_lt_contravar; first by [rewrite mulR1; apply Hx].
case (Rle_lt_or_eq_dec x 1) ; [apply Hx | done | ].
move/eqP in Hcase ; move => Habs.
rewrite Habs in Hcase ; by contradict Hcase.
Defined.

Lemma ln_idlt0_xlt1 : forall x, 0 < x < 1 -> ln_id x < 0.
Proof.
rewrite {2}(_ : 0 = ln_id 1); last by rewrite /ln_id ln_1 /Rminus Rplus_opp_r Ropp_0 addR0.
move=> x Hx.
have lt01 : 0 < 1 by fourier.
apply (derive_increasing_ad_hoc lt01 derive_pt_ln_id_xle1_ge0).
- by split; [apply Hx | apply Rlt_le, Hx].
- split; by fourier.
- by apply Hx.
Qed.

Lemma ln_idlt0_xgt1 x : 0 < x -> 1 < x -> ln_id x < 0.
Proof.
move=> Hx Hx2.
rewrite /ln_id; apply Rlt_minus, exp_lt_inv.
rewrite exp_ln; last exact Hx.
rewrite -{1}(addR0 x) -(Rplus_opp_l 1) addRA addRC.
apply exp_ineq1, Rgt_minus, Rgt_lt, Hx2.
Qed.

Lemma ln_idgt0 x : 0 < x -> ln_id x <= 0.
Proof.
move=> Hx.
case (total_order_T x 1).
- case => Hx2.
  + by apply Rlt_le, ln_idlt0_xlt1.
  + subst x; rewrite /ln_id ln_1 /Rminus 2!Rplus_opp_r; by apply Rle_refl.
- move=> Hx2; apply Rlt_le, ln_idlt0_xgt1; by [apply Hx | apply Rgt_lt, Hx2].
Qed.

Lemma ln_id_cmp x : 0 < x -> ln x <= x - 1.
Proof. move=> Hx ; apply Rminus_le ; apply ln_idgt0 ; exact Hx. Qed.

Lemma log_id_cmp x : 0 < x -> log x <= (x - 1) * log (exp 1).
Proof.
move=> Hx ; rewrite /log ln_exp /Rdiv mul1R.
apply Rmult_le_compat_r; by
  [apply Rlt_le, Rinv_0_lt_compat, ln_2_pos | apply ln_id_cmp].
Qed.

Lemma ln_id_eq x : 0 < x -> ln x = x - 1 -> x = 1.
Proof.
move=> Hx' Hx.
case (total_order_T x 1) => [ [] // Hx2 | Hx2]; contradict Hx.
- apply Rlt_not_eq, (Rplus_lt_reg_r (- (x - 1))); rewrite (addRC (x - 1)) Rplus_opp_l.
  apply ln_idlt0_xlt1; split; [exact Hx' | exact Hx2].
- apply Rlt_not_eq, (Rplus_lt_reg_r (- (x - 1))); rewrite (addRC (x - 1)) Rplus_opp_l.
  by apply ln_idlt0_xgt1.
Qed.

Lemma log_id_eq x : 0 < x -> log x = (x - 1) * log (exp 1) -> x = 1.
Proof.
move=> Hx' Hx ; rewrite /log ln_exp /Rdiv mul1R in Hx.
apply Rmult_eq_reg_r in Hx; last by apply not_eq_sym, Rlt_not_eq, Rinv_0_lt_compat, ln_2_pos.
apply ln_id_eq; by [apply Hx' | apply Hx].
Qed.

End ln_id_sect.

Section xlnx_sect.

Section xlnx.

Definition xlnx := fun x => if 0 <b x then x * ln x else 0.

Lemma xlnx_0 : xlnx 0 = 0.
Proof. rewrite /xlnx mul0R; by case : ifP. Qed.

Lemma xlnx_1 : xlnx 1 = 0.
Proof. rewrite /xlnx ln_1 mulR0 ; by case : ifP. Qed.

Lemma xlnx_neg x : 0 < x < 1 -> xlnx x < 0.
Proof.
case => lt0x ltx1.
rewrite /xlnx.
have -> : 0 <b x ; first by apply/RltP.
apply Ropp_lt_cancel.
rewrite Ropp_0 -Ropp_mult_distr_r_reverse.
apply Rmult_lt_0_compat => //.
apply Ropp_lt_cancel; rewrite Ropp_involutive Ropp_0.
apply exp_lt_inv.
by rewrite exp_ln // exp_0.
Qed.

Lemma continue_xlnx : continuity xlnx.
Proof.
rewrite /continuity => r.
rewrite /continuity_pt /continue_in /limit1_in /limit_in => eps eps_pos /=.
case (total_order_T 0 r) ; first case ; move=> Hcase.
- have : continuity_pt (fun x => x * ln x) r.
    apply continuity_pt_mult.
      by apply derivable_continuous_pt, derivable_id.
    by apply derivable_continuous_pt, derivable_pt_ln.
  rewrite /continuity_pt /continue_in /limit1_in /limit_in => /(_ eps eps_pos); case => /= k [k_pos Hk].
  exists (Rmin k r); split; first by apply Rlt_gt, Rmin_pos.
  - move=> x ; rewrite /D_x ; move => [[_ Hx1] Hx2].
    rewrite /xlnx.
    have -> : 0 <b x.
      apply/RltP.
      rewrite -(addR0 x) -{2}(Rplus_opp_l r) addRA.
      apply (Rle_lt_trans _ ((x + - r) + Rabs (x + - r))).
        rewrite -(Rplus_opp_r (x + -r)); apply Rplus_le_compat_l.
        rewrite -Rabs_Ropp; by apply Rle_abs.
      apply Rplus_lt_compat_l.
      rewrite /R_dist /Rminus in Hx2.
      apply (Rlt_le_trans _ (Rmin k r)) => //; by apply Rmin_r.
    have -> : 0 <b r by apply/RltP.
    apply Hk.
    split => //.
    by apply (@Rlt_le_trans _ _ _ Hx2), Rmin_l.
- subst r.
  exists (exp (- 2 * / eps)).
  split ; first by apply exp_pos.
  move=> x; rewrite /R_dist /Rminus Ropp_0 addR0; case=> Hx1 Hx2.
  rewrite /xlnx.
  have -> : Rlt_bool 0 0 = false by apply/RltP/Rlt_irrefl.
  case (Rlt_le_dec 0 x) => Hcase.
  + rewrite Rabs_pos_eq in Hx2 ; last by apply Rlt_le.
    have -> : 0 <b x by apply/RltP.
    rewrite /Rminus Ropp_0 addR0 -{1}(exp_ln _ Hcase).
    set X := ln x.
    have X_neg : X < 0.
      apply (Rlt_trans _ (-2 * / eps)).
      by apply exp_lt_inv ; subst X ; rewrite exp_ln.
      rewrite Ropp_mult_distr_l_reverse.
      apply Ropp_0_lt_gt_contravar, Rlt_mult_inv_pos => // ; by apply Rlt_R0_R2.
    apply: (Rlt_le_trans _ (2 * / (- X)) _).
    * rewrite Rabs_left ; last first.
        rewrite -(mulR0 (exp X)).
        apply Rmult_lt_compat_l => // ; by apply exp_pos.
       rewrite -Ropp_mult_distr_r_reverse.
      apply (Rmult_lt_reg_r (/ - X)); first by apply Rinv_0_lt_compat, Ropp_0_gt_lt_contravar.
      rewrite -mulRA Rinv_r; last by apply not_eq_sym, Rlt_not_eq, Ropp_0_gt_lt_contravar.
      rewrite mulR1 -(Rinv_involutive 2); last by apply not_eq_sym, Rlt_not_eq, Rlt_R0_R2.
      rewrite -mulRA ( _ : forall r, r * r = r ^ 2); last by move=> ?; rewrite /pow mulR1.
      rewrite pow_inv; last by apply not_eq_sym, Rlt_not_eq, Ropp_0_gt_lt_contravar.
      rewrite -Rinv_mult_distr; last 2 first.
        by apply Rinv_neq_0_compat, not_eq_sym, Rlt_not_eq, Rlt_R0_R2.
        by apply pow_nonzero, Ropp_neq_0_compat, Rlt_not_eq.
      rewrite -(Rinv_involutive (exp X)); last by apply not_eq_sym, Rlt_not_eq, exp_pos.
      apply Rinv_lt_contravar.
        rewrite -mulRA mulRC; apply Rlt_mult_inv_pos; last fourier.
        apply Rlt_mult_inv_pos; last by apply exp_pos.
        apply pow_gt0; by fourier.
        rewrite -exp_Ropp mulRC (_ : 2 = INR 2`!) //.
        by apply exp_strict_lb, Ropp_0_gt_lt_contravar.
    * apply (Rmult_le_reg_r (/ 2)); first by apply Rinv_0_lt_compat, Rlt_R0_R2.
      rewrite mulRC mulRA Rinv_l; last by apply not_eq_sym, Rlt_not_eq, Rlt_R0_R2.
      rewrite mul1R -(Rinv_involutive eps); last by apply not_eq_sym, Rlt_not_eq.
      rewrite -Rinv_mult_distr ; last 2 first.
        by apply not_eq_sym, Rlt_not_eq, Rinv_0_lt_compat.
        by apply not_eq_sym, Rlt_not_eq, Rlt_R0_R2.
      apply Rle_Rinv.
      - apply Rmult_lt_0_compat; by [apply Rinv_0_lt_compat | apply Rlt_R0_R2].
      - by apply Ropp_0_gt_lt_contravar.
      - rewrite -(Ropp_involutive (/ eps * 2)); apply Ropp_le_contravar.
        rewrite mulRC -Ropp_mult_distr_l_reverse.
        apply exp_le_inv, Rlt_le; subst X; by rewrite exp_ln.
  + have -> : 0 <b x = false by apply/RltP; apply RIneq.Rle_not_lt.
    by rewrite /Rminus Ropp_0 addR0 Rabs_R0.
- exists (- r); split; first by apply Ropp_0_gt_lt_contravar.
  move=> x [[_ Hx1] Hx2].
  rewrite /R_dist /xlnx.
  have -> : 0 <b x = false.
    apply/RltP ; apply Rge_not_lt, Rle_ge.
    rewrite -(addR0 x) -{1}(Rplus_opp_l r) addRA.
    apply (Rle_trans _ ((x + - r) - Rabs (x + - r))).
      apply Rplus_le_compat_l, Rlt_le.
      rewrite -{1}(Ropp_involutive r).
      by apply Ropp_lt_contravar.
    rewrite -(Rplus_opp_r (x + -r)); apply Rplus_le_compat_l.
    by apply Ropp_le_contravar, Rle_abs.
  have -> : Rlt_bool 0 r = false.
    by apply/RltP; apply Rge_not_lt, Rle_ge, Rlt_le.
  rewrite /Rminus Ropp_0 addR0 Rabs_R0; by apply Rgt_lt.
Qed.

(* NB: not used *)
Lemma uniformly_continue_xlnx : uniform_continuity xlnx (fun x => 0 <= x <= 1).
Proof.
apply Heine ; first by apply compact_P3.
move=> x _ ; by apply continue_xlnx.
Qed.

Let xlnx_total := fun y => y * ln y.

Lemma derivable_xlnx_total x : 0 < x -> derivable_pt xlnx_total x.
Proof.
move=> x_pos.
apply derivable_pt_mult.
  by apply derivable_id.
by apply derivable_pt_ln.
Defined.

Lemma xlnx_total_xlnx x : 0 < x -> xlnx x = xlnx_total x.
Proof. by rewrite /xlnx /f => /RltP ->. Qed.

Lemma derivable_pt_xlnx x (x_pos : 0 < x) : derivable_pt xlnx x.
Proof. apply (@derivable_f_eq_g _ _ x 0 xlnx_total_xlnx x_pos (derivable_xlnx_total x_pos)). Defined.

Lemma derive_xlnx_aux1 x (x_pos : 0 < x) :
  derive_pt xlnx x (derivable_pt_xlnx x_pos) =
  derive_pt xlnx_total x (derivable_xlnx_total x_pos).
Proof. by rewrite -derive_pt_f_eq_g. Qed.

Lemma derive_xlnx_aux2 x (x_pos : 0 < x) : derive_pt xlnx x (derivable_pt_xlnx x_pos) = ln x + 1.
Proof.
rewrite derive_xlnx_aux1 /f derive_pt_mult derive_pt_ln.
rewrite Rinv_r; last by apply not_eq_sym, Rlt_not_eq.
rewrite (_ : derive_pt ssrfun.id x (derivable_id x) = 1) ; first by rewrite mul1R.
rewrite -(derive_pt_id x).
by apply proof_derive_irrelevance.
Qed.

Lemma derive_pt_xlnx x (x_pos : 0 < x) (pr : derivable_pt xlnx x) : derive_pt xlnx x pr = ln x + 1.
Proof. rewrite -derive_xlnx_aux2 ; by apply proof_derive_irrelevance. Qed.

Lemma pderivable_Ropp_xlnx : pderivable (fun y => - xlnx y) (fun x => 0 < x <= exp (- 1)).
Proof.
move=> x /= Hx.
apply derivable_pt_opp.
apply derivable_pt_xlnx.
apply Hx.
Defined.

Lemma xlnx_sdecreasing_0_Rinv_e_helper : forall (t : R) (Ht : 0 < t <= exp (-1)),
  0 < (if t == exp (-1) then 1 else derive_pt (fun x => - xlnx x) t (pderivable_Ropp_xlnx Ht)).
Proof.
move=> t [Ht1 Ht2].
case : ifP => [|/negbT] Hcase ; first apply Rlt_0_1.
rewrite derive_pt_opp derive_pt_xlnx //.
apply Ropp_lt_cancel ; rewrite Ropp_involutive Ropp_0.
apply (Rplus_lt_reg_r (- 1)).
rewrite -addRA Rplus_opp_r addR0 add0R.
apply exp_lt_inv.
rewrite exp_ln //.
apply Rlt_le_neq => //.
move/eqP; by apply/negP.
Qed.

Lemma xlnx_sdecreasing_0_Rinv_e x y :
  0 <= x <= exp (-1) -> 0 <= y <= exp (-1) -> x < y -> xlnx x > xlnx y.
Proof.
move=> [Hx1 Hx2] [Hy1 Hy2] xlty.
case/orP : (orbN ( x == 0)).
- move/eqP => -> ; rewrite xlnx_0 ; apply xlnx_neg.
  split ; first by apply (Rle_lt_trans _ x).
  apply (Rle_lt_trans _ (exp (-1)))=> //.
  apply exp_opp_1_lt_1.
move => xnot0.
apply Ropp_lt_cancel.
have x_pos : 0 < x.
  apply Rlt_le_neq => // /eqP.
  rewrite eq_sym ; by apply/negP.
have y_pos : 0 < y by apply (Rlt_trans _ x).
move=> {Hx1 Hy1}.
have aux : 0 < exp(-1) by apply exp_pos.
by apply (derive_increasing_ad_hoc aux xlnx_sdecreasing_0_Rinv_e_helper).
Qed.

Lemma xlnx_decreasing_0_Rinv_e x y :
  0 <= x <= exp (-1) -> 0 <= y <= exp (-1) -> x <= y -> xlnx y <= xlnx x.
Proof.
move=> Hx Hy Hxy.
case/orP : (orbN (x == y)).
- move=> /eqP -> ; by apply Rle_refl.
- move=> H.
  apply Rlt_le, xlnx_sdecreasing_0_Rinv_e => //.
  apply Rlt_le_neq => //.
  move=> /eqP ; by apply/negP.
Qed.

End xlnx.

Section diff_xlnx.

Definition diff_xlnx := fun x => xlnx (1 - x) - xlnx x.

Lemma derivable_pt_diff_xlnx x (Hx : 0 < x < 1) : derivable_pt diff_xlnx x.
Proof.
rewrite /diff_xlnx /Rminus.
apply derivable_pt_plus ; last by apply derivable_pt_opp, derivable_pt_xlnx, Hx.
apply (derivable_pt_comp (fun x => 1 + - x) xlnx).
  apply derivable_pt_plus ; first by apply derivable_pt_const.
  apply derivable_pt_Ropp.
apply derivable_pt_xlnx.
apply (Rplus_lt_reg_r x); rewrite addRC -addRA Rplus_opp_l 2!addR0; by apply Hx.
Defined.

Lemma derive_pt_diff_xlnx x (Hx : 0 < x < 1) :
  derive_pt diff_xlnx x (derivable_pt_diff_xlnx Hx) = -(2 + ln (x * (1-x))).
Proof.
rewrite derive_pt_plus derive_pt_opp derive_pt_xlnx; last by apply Hx.
rewrite derive_pt_comp derive_pt_plus derive_pt_const.
rewrite derive_pt_xlnx /=; last first.
  apply (Rplus_lt_reg_r x); rewrite addRC -addRA Rplus_opp_l 2!addR0; by apply Hx.
rewrite add0R ln_mult; first field.
- by apply Hx.
- apply (Rplus_lt_reg_r x); rewrite addRC -addRA Rplus_opp_l 2!addR0; by apply Hx.
Qed.

Lemma diff_xlnx_0 : diff_xlnx 0 = 0.
Proof. by rewrite /diff_xlnx Rminus_0_r xlnx_0 xlnx_1 Rminus_0_r. Qed.

Lemma diff_xlnx_1 : diff_xlnx 1 = 0.
Proof. by rewrite /diff_xlnx /Rminus Rplus_opp_r xlnx_0 xlnx_1 Rplus_opp_r. Qed.

Lemma derive_diff_xlnx_neg_aux x (Hx : 0 < x < 1) : x < exp (-2) -> 0 < derive_pt diff_xlnx x (derivable_pt_diff_xlnx Hx).
Proof.
rewrite derive_pt_diff_xlnx; case: Hx => Hx1 Hx2 xltexp2.
apply Ropp_lt_cancel; rewrite Ropp_0 Ropp_involutive.
apply (Rplus_lt_reg_r (-2)); rewrite addRC addRA Rplus_opp_l 2!add0R.
apply exp_lt_inv.
rewrite exp_ln ; last first.
  apply Rmult_lt_0_compat => //.
  apply (Rplus_lt_reg_r x); by rewrite addRC -addRA Rplus_opp_l 2!addR0.
apply (Rlt_trans _ ( (exp (-2)) * (1 - x))).
  apply Rmult_lt_compat_r => //.
  apply (Rplus_lt_reg_r x); by rewrite addRC -addRA Rplus_opp_l 2!addR0.
rewrite -{2}(mulR1 (exp (-2))).
apply Rmult_lt_compat_l; first by apply exp_pos.
apply (Rplus_lt_reg_r (-1)).
rewrite /Rminus addRC addRA Rplus_opp_l add0R Rplus_opp_r.
apply Ropp_lt_cancel; by rewrite Ropp_involutive Ropp_0.
Qed.

Lemma derive_diff_xlnx_pos x (Hx : 0 < x < 1) (pr : derivable_pt diff_xlnx x) : x < exp (-2) -> 0 < derive_pt diff_xlnx x pr.
Proof.
rewrite (proof_derive_irrelevance _ (derivable_pt_diff_xlnx Hx)).
apply derive_diff_xlnx_neg_aux.
Qed.

Lemma MVT_cor1_pderivable_new f a b : forall (prd : pderivable f (fun x => a < x < b)) (prc : forall x (Hx : a <= x <= b), continuity_pt f x),
  a < b ->
  exists c (Hc : a < c < b),
    f b - f a = derive_pt f c (prd c Hc) * (b - a) /\ a < c < b.
Proof.
intros prd prc ab.
have H0 : forall c : R, a < c < b -> derivable_pt f c.
  move=> c Hc.
  apply prd.
  case: Hc => ? ?; split; fourier.
have H1 : forall c : R, a < c < b -> derivable_pt id c.
  move=> c _; by apply derivable_pt_id.
have H2 : forall c, a <= c <= b -> continuity_pt f c.
  move=> x Hc.
  by apply prc.
have H3 : forall c, a <= c <= b -> continuity_pt id c.
  move=> x Hc; by apply derivable_continuous_pt, derivable_pt_id.
case: (MVT f id a b H0 H1 ab H2 H3) => c [Hc H'].
exists c.
exists Hc.
split => //.
cut (derive_pt id c (H1 c Hc) = derive_pt id c (derivable_pt_id c));
    [ intro | apply pr_nu ].
rewrite H (derive_pt_id c) mulR1 in H'.
rewrite -H' /= /id mulRC.
f_equal.
by apply pr_nu.
Qed.

Lemma MVT_cor1_pderivable_new_var f a b : forall (prd : pderivable f (fun x => a < x < b)) (prca : continuity_pt f a) (prcb : continuity_pt f b),
  a < b ->
  exists c (Hc : a < c < b),
    f b - f a = derive_pt f c (prd c Hc) * (b - a) /\ a < c < b.
Proof.
intros prd prca prcb ab.
have prc : forall x (Hx : a <= x <= b), continuity_pt f x.
  move=> x Hx.
  case/orP : (orbN (x == a)) ; first by move/eqP => ->.
  move=> xnota.
  case/orP : (orbN (x == b)) ; first by move/eqP => ->.
  move=> xnotb.
  apply derivable_continuous_pt, prd.
  split.
  - apply Rlt_le_neq ; by [apply Hx | move=> /eqP ; apply/negP ; rewrite eq_sym].
  - apply Rlt_le_neq ; by [apply Hx | move=> /eqP ; apply/negP].
have H0 : forall c : R, a < c < b -> derivable_pt f c.
  move=> c Hc.
  apply prd.
  case: Hc => ? ?; split; fourier.
have H1 : forall c : R, a < c < b -> derivable_pt id c.
  move=> c _; by apply derivable_pt_id.
have H2 : forall c, a <= c <= b -> continuity_pt f c.
  move=> x Hc.
  by apply prc.
have H3 : forall c, a <= c <= b -> continuity_pt id c.
  move=> x Hc; by apply derivable_continuous_pt, derivable_pt_id.
case: (MVT f id a b H0 H1 ab H2 H3) => c [Hc H'].
exists c.
exists Hc.
split => //.
cut (derive_pt id c (H1 c Hc) = derive_pt id c (derivable_pt_id c));
    [ intro | apply pr_nu ].
rewrite H (derive_pt_id c) mulR1 in H'.
rewrite -H' /= /id mulRC.
f_equal.
by apply pr_nu.
Qed.

Lemma derive_sincreasing_interv a b (f:R -> R) (pr: pderivable f (fun x => a < x < b)) (prc : forall x (Hx : a <= x <= b), continuity_pt f x) :
    a < b ->
    ((forall t:R, forall (prt : derivable_pt f t), a < t < b -> 0 < derive_pt f t prt) ->
      forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y).
Proof.
intros H H0 x y H1 H2 H3.
- apply Rplus_lt_reg_r with (- f x).
  rewrite Rplus_opp_r.
  have prd' : pderivable f (fun z => x < z < y).
    move=> z /= [Hz1 Hz2] ; apply pr.
    split.
    - apply (Rle_lt_trans _ x) => // ; by apply H1.
    - apply (Rlt_le_trans _ y) => // ; by apply H2.
  have H0' : forall t (Ht : x < t < y), 0 < derive_pt f t (prd' t Ht).
    move=> z /= [Hz0 Hz1].
    apply H0.
    split.
    - apply (Rle_lt_trans _ x) => // ; by apply H1.
    - apply (Rlt_le_trans _ y) => // ; by apply H2.
  have prcx : continuity_pt f x.
    apply prc ; split ; by apply H1.
  have prcy : continuity_pt f y.
    apply prc ; split ; by apply H2.
  have aux : a < b.
    apply (Rle_lt_trans _ x) ; first by apply H1.
    apply (Rlt_le_trans _ y) => // ; by apply H2.
  case: (MVT_cor1_pderivable_new_var prd' prcx prcy H3); intros x0 [x1 [H7 H8]].
  unfold Rminus in H7.
  rewrite H7.
  apply Rmult_lt_0_compat.
  by apply H0'.
apply (Rplus_lt_reg_r x).
by rewrite addRC -addRA Rplus_opp_l 2!addR0.
Qed.

Lemma diff_xlnx_sincreasing_0_Rinv_e2 : forall x y : R, 0 <= x <= exp (-2) -> 0 <= y <= exp (-2) -> x < y -> diff_xlnx x < diff_xlnx y.
Proof.
apply derive_sincreasing_interv.
- move=> x /= [Hx1 Hx2].
  apply derivable_pt_diff_xlnx.
  split => //.
  apply: (@Rlt_trans _ _ _ Hx2 _).
  by apply exp_opp_2_lt_1.
- move=> x /= Hx.
  rewrite /diff_xlnx.
  apply continuity_pt_minus ; last by apply continue_xlnx.
  apply (continuity_pt_comp (fun x => 1 - x) xlnx); last by apply continue_xlnx.
  rewrite /Rminus.
  apply continuity_pt_plus ; first by apply continuity_pt_const.
  apply continuity_pt_opp.
  apply derivable_continuous_pt.
  by apply derivable_pt_id.
- by apply exp_pos.
- move => t prt [Ht1 Ht2].
  apply derive_diff_xlnx_pos => //.
  split => // ; apply (Rlt_trans _ (exp (-2))) => //.
  by apply exp_opp_2_lt_1.
Qed.

Lemma xlnx_ineq x : 0 <= x <= exp (-2) -> xlnx x <= xlnx (1-x).
Proof.
move=> [Hx1 Hx2].
apply Rge_le, Rminus_ge, Rle_ge.
rewrite -diff_xlnx_0 -/(diff_xlnx x).
case/orP : (orbN (0 == x)) ; last move=> xnot0 ; first by [move=> /eqP <- ; apply Rle_refl].
apply Rlt_le, diff_xlnx_sincreasing_0_Rinv_e2.
- split ; by [apply Rle_refl | apply Rlt_le, exp_pos].
- by split.
apply Rlt_le_neq => // /eqP ; by apply/negP.
Qed.

End diff_xlnx.

Definition xlnx_delta a := fun x => xlnx (x + a) - xlnx x.

Lemma derivable_xlnx_delta eps (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) :
  derivable_pt (xlnx_delta eps) x.
Proof.
rewrite /xlnx_delta.
apply derivable_pt_minus.
- apply (derivable_pt_comp (fun x => x + eps) xlnx).
    apply derivable_pt_plus ; first by apply derivable_pt_id.
    by apply derivable_pt_const.
  apply derivable_pt_xlnx.
  apply Rplus_le_lt_0_compat ; by [apply Heps | apply Rlt_le, Hx].
- by apply derivable_pt_xlnx, Hx.
Defined.

Lemma derive_pt_xlnx_delta eps (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) :
  derive_pt (xlnx_delta eps) x (derivable_xlnx_delta Heps Hx) = ln (x + eps) - ln x.
Proof.
rewrite derive_pt_minus derive_pt_comp derive_pt_plus derive_pt_id derive_pt_const derive_pt_xlnx ; last first.
  apply Rplus_lt_0_compat ; by [apply Hx | apply Heps].
rewrite derive_pt_xlnx ; last by apply Hx.
field.
Qed.

Lemma increasing_xlnx_delta eps (Heps : 0< eps < 1) :
  forall x y : R, 0 <= x <= 1 - eps -> 0 <= y <= 1 - eps -> x < y ->
                  xlnx_delta eps x < xlnx_delta eps y.
Proof.
apply derive_sincreasing_interv.
- move=> x /= [Hx1 Hx2] ; rewrite /xlnx_delta.
  apply derivable_pt_minus.
  - apply (derivable_pt_comp (fun x => x + eps) xlnx).
      apply derivable_pt_plus ; first by apply derivable_pt_id.
      by apply derivable_pt_const.
    apply derivable_pt_xlnx.
    apply Rplus_lt_0_compat => // ; by apply Heps.
  - by apply derivable_pt_xlnx.
- move=> x /= [Hx1 Hx2] ; rewrite /xlnx_delta.
  apply continuity_pt_minus.
  - apply (continuity_pt_comp (fun x => x + eps) xlnx); last by apply continue_xlnx.
      apply continuity_pt_plus ; first by apply derivable_continuous_pt, derivable_pt_id.
      by apply continuity_pt_const.
  - by apply continue_xlnx.
- by apply Rgt_lt, Rgt_minus, Rlt_gt, Heps.
- move=> t prd Ht.
  rewrite (proof_derive_irrelevance _ (derivable_xlnx_delta Heps Ht)) derive_pt_xlnx_delta.
  apply Rgt_lt, Rgt_minus, Rlt_gt, ln_increasing ; first by apply Ht.
  rewrite -{1}(addR0 t).
  by apply Rplus_lt_compat_l, Heps.
Qed.

Lemma xlnx_delta_bound eps : 0 < eps <= exp (-2) ->
  forall x, 0 <= x <= 1 - eps -> Rabs (xlnx_delta eps x) <= - xlnx eps.
Proof.
move=> [Heps1 Heps2] x [Hx1 Hx2].
apply Rabs_Rle.
- apply (Rle_trans _ (xlnx_delta eps (1 - eps))).
    case/orP : (orbN (x == 1 - eps)) ; last move=> xnot0 ; first by [move=> /eqP -> ; apply Rle_refl].
    apply Rlt_le, increasing_xlnx_delta => //.
    - split => //.
      apply (Rle_lt_trans _ (exp (-2))) => //.
      by apply exp_opp_2_lt_1.
    - split ; by [apply (Rle_trans _ x) | apply Rle_refl].
    - apply Rlt_le_neq => // /eqP ; by apply/negP.
  rewrite /xlnx_delta /Rminus -addRA Rplus_opp_l addR0 xlnx_1 add0R.
  apply Ropp_le_cancel ; rewrite 2!Ropp_involutive.
  apply xlnx_ineq.
  split => // ; by apply Rlt_le.
rewrite Ropp_involutive.
rewrite (_ : xlnx eps = xlnx_delta eps 0) ; last first.
  rewrite /xlnx_delta.
  by rewrite add0R xlnx_0 Rminus_0_r.
case/orP : (orbN (0 == x)) ; last move=> xnot0 ; first by [move=> /eqP <- ; apply Rle_refl].
apply Rlt_le, increasing_xlnx_delta => //.
- split => //.
  apply (Rle_lt_trans _ (exp (-2))) => //.
  by apply exp_opp_2_lt_1.
- split ; by [apply (Rle_trans _ x) | apply Rle_refl].
- apply Rlt_le_neq => // /eqP ; by apply/negP.
Qed.

Lemma Rabs_xlnx a (Ha : 0 <= a <= exp(-2)) x y :
  0 <= x <= 1 -> 0 <= y <= 1 -> Rabs (x - y) <= a ->
  Rabs (xlnx x - xlnx y) <= - xlnx a.
Proof.
move=> [Hx1 Hx2] [Hy1 Hy2] H.
case : (Rtotal_order x y) ; last case ; move => Hcase.
- have Haux : y = x + Rabs (x - y).
    rewrite /R_dist -Rabs_Ropp Rabs_pos_eq.
      by rewrite Ropp_plus_distr Ropp_involutive addRA Rplus_opp_r add0R.
    apply Ropp_le_cancel; rewrite Ropp_0 Ropp_involutive.
    by apply Rle_minus, Rlt_le.
  rewrite Haux -Rabs_Ropp Ropp_plus_distr Ropp_involutive addRC.
  apply (Rle_trans _ (- xlnx (Rabs (x - y)))).
    apply xlnx_delta_bound.
    - split.
      - by apply Rabs_pos_lt, Rlt_not_eq, Rlt_minus.
      - apply (Rle_trans _ a) => //; by apply Ha.
    - split => //.
      apply (Rplus_le_reg_r (Rabs (x - y))); by rewrite /Rminus -addRA Rplus_opp_l addR0 -Haux.
  apply Ropp_le_cancel ; rewrite 2!Ropp_involutive.
  apply xlnx_decreasing_0_Rinv_e => //.
  - split; first by apply Rabs_pos.
    apply (Rle_trans _ a) => //.
    apply (Rle_trans _ (exp (- 2))); first by apply Ha.
    apply Rlt_le, exp_increasing, Ropp_lt_contravar; fourier.
  - split; first by apply Ha.
    apply (Rle_trans _ (exp (-2))); first by apply Ha.
    apply Rlt_le, exp_increasing, Ropp_lt_contravar; fourier.
- subst x ; rewrite /Rminus Rplus_opp_r Rabs_R0.
  apply Ropp_le_cancel ; rewrite Ropp_involutive Ropp_0.
  case/orP : (orbN (0 == a)); last move=> anot0.
    by [move=> /eqP <- ; rewrite xlnx_0 ; apply Rle_refl].
  apply Rlt_le, xlnx_neg.
  split.
  - apply Rlt_le_neq; first by apply Ha.
    move/eqP; by apply/negP.
  - apply (Rle_lt_trans _ (exp (-2))); first by apply Ha.
    by apply exp_opp_2_lt_1.
- apply Rgt_lt in Hcase.
  have Haux : x = y + Rabs (x - y).
    rewrite Rabs_pos_eq.
      by rewrite addRC /Rminus -addRA Rplus_opp_l addR0.
    by apply Rge_le, Rge_minus, Rle_ge, Rlt_le.
  rewrite Rabs_minus_sym in H Haux.
  rewrite Haux.
  apply (Rle_trans _ (- xlnx (Rabs (y - x)))).
    apply xlnx_delta_bound.
    - split.
      - by apply Rabs_pos_lt, Rlt_not_eq, Rlt_minus.
      - apply (Rle_trans _ a) => //; by apply Ha.
    - split => //.
      apply (Rplus_le_reg_r (Rabs (y - x))); by rewrite /Rminus -addRA Rplus_opp_l addR0 -Haux.
  apply Ropp_le_cancel ; rewrite 2!Ropp_involutive.
  apply xlnx_decreasing_0_Rinv_e => //.
  + split; first by apply Rabs_pos.
    apply (Rle_trans _ a) => //.
    apply (Rle_trans _ (exp (-2))); first by apply Ha.
    apply Rlt_le, exp_increasing, Ropp_lt_contravar; fourier.
  - split; first by apply Ha.
    apply (Rle_trans _ (exp (-2))); first by apply Ha.
    apply Rlt_le, exp_increasing, Ropp_lt_contravar; fourier.
Qed.

End xlnx_sect.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import Cat.Cat.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.

Local Open Scope nattrans_scope.

(** If all components of a natural transformation are monic then
so is that natural transformation. *)
Section is_Monic_components_is_Monic.
  Context
    {C D : Category}
    {F G : (C –≻ D)%functor}
    (N : F –≻ G)
    (H : ∀ c, is_Monic (Trans N c))
  .

  Definition is_Monic_components_is_Monic :
    @is_Monic (Func_Cat _ _) _ _ N.
  Proof.
    intros I g h H2.
    apply NatTrans_eq_simplify.
    extensionality x.
    apply H.
    apply (fun x => f_equal (fun w => Trans w x) H2).
  Qed.

End is_Monic_components_is_Monic.

(** If all components of a natural transformation are epic then
so is that natural transformation. *)
Section is_Epic_components_is_Epic.
  Context
    {C D : Category}
    {F G : (C –≻ D)%functor}
    (N : F –≻ G)
    (H : ∀ c, is_Epic (Trans N c))
  .

  Definition is_Epic_components_is_Epic :
    @is_Epic (Func_Cat _ _) _ _ N.
  Proof.
    intros I g h H2.
    apply NatTrans_eq_simplify.
    extensionality x.
    apply H.
    apply (fun x => f_equal (fun w => Trans w x) H2).
  Qed.

End is_Epic_components_is_Epic.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_extensionunique.
Require Import ProofCheckingEuclid.lemma_localextension.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_BCD.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

(* Originally known as lemma_3_7a *)
Lemma lemma_orderofpoints_ABC_BCD_ACD :
	forall A B C D,
	BetS A B C -> BetS B C D ->
	BetS A C D.
Proof.
	intros A B C D.
	intros BetS_A_B_C.
	intros BetS_B_C_D.
	pose proof (lemma_betweennotequal _ _ _ BetS_A_B_C) as (neq_B_C & neq_A_B & neq_A_C).
	pose proof (lemma_betweennotequal _ _ _ BetS_B_C_D) as (neq_C_D & _ & neq_B_D).
	pose proof (lemma_localextension _ _ _ neq_A_C neq_C_D) as (E & BetS_A_C_E & Cong_CE_CD).
	apply lemma_congruencesymmetric in Cong_CE_CD as Cong_CD_CE.
	pose proof (lemma_orderofpoints_ABC_ACD_BCD _ _ _ _ BetS_A_B_C BetS_A_C_E) as BetS_B_C_E.
	pose proof (lemma_extensionunique _ _ _ _ BetS_B_C_D BetS_B_C_E Cong_CD_CE) as eq_D_E.
	assert (BetS A C D) as BetS_A_C_D by (rewrite eq_D_E; exact BetS_A_C_E).
	exact BetS_A_C_D.
Qed.

End Euclid.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearorder.
Require Export GeoCoq.Elements.OriginalProofs.lemma_ray4.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_ABCequalsCBA :
   forall A B C,
   nCol A B C ->
   CongA A B C C B A.
Proof.
intros.
assert (~ eq B A).
 {
 intro.
 assert (eq A B) by (conclude lemma_equalitysymmetric).
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (~ eq C B).
 {
 intro.
 assert (Col C B A) by (conclude_def Col ).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists E, (BetS B A E /\ Cong A E C B)) by (conclude lemma_extension);destruct Tf as [E];spliter.
assert (~ eq B C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq A B) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists F, (BetS B C F /\ Cong C F A B)) by (conclude lemma_extension);destruct Tf as [F];spliter.
assert (Cong B A F C) by (forward_using lemma_doublereverse).
assert (BetS F C B) by (conclude axiom_betweennesssymmetry).
assert (Cong B E F B) by (conclude cn_sumofparts).
assert (Cong F B B F) by (conclude cn_equalityreverse).
assert (Cong B E B F) by (conclude lemma_congruencetransitive).
assert (Cong B F B E) by (conclude lemma_congruencesymmetric).
assert (Cong E F F E) by (conclude cn_equalityreverse).
assert (Out B A E) by (conclude lemma_ray4).
assert (Out B C F) by (conclude lemma_ray4).
assert (CongA A B C C B A) by (conclude_def CongA ).
close.
Qed.

End Euclid.


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

(*****************************************************************************)
(*                                                                           *)
(*          Buchberger : ordering: lexi and total                            *)
(*                                                                           *)
(*          Laurent Thery 	                                             *)
(*                                                                           *)
(*****************************************************************************)

Require Import Eqdep.
Section lexi_order.
Require Import Monomials.

Inductive orderc : forall n : nat, mon n -> mon n -> Prop :=
  | lo1 :
      forall (n a b : nat) (p : mon n),
      b < a -> orderc (S n) (c_n n a p) (c_n n b p)
  | lo2 :
      forall (n a b : nat) (p q : mon n),
      orderc n p q -> orderc (S n) (c_n n a p) (c_n n b q).
Hint Resolve lo1 lo2.
Require Import Arith.
Require Import Compare_dec.

Theorem orderc_dec :
 forall (n : nat) (a b : mon n), {orderc n a b} + {orderc n b a} + {a = b}.
intros n a; elim a; auto.
intro b.
rewrite <- (mon_0 b); auto.
intros d n0 m H' b; try assumption.
rewrite <- (proj_ok d b).
case (H' (pmon2 (S d) b)).
intro H'0; case H'0.
intro H'1.
left; left; auto.
intro H'1; left; right; auto.
intro H'0.
elim (lt_eq_lt_dec n0 (pmon1 (S d) b)); [ intro H'1; elim H'1 | idtac ];
 intro H'2; auto.
left; right; auto.
rewrite H'0; auto.
right; rewrite H'0; rewrite H'2; auto.
left; left; rewrite H'0; auto.
Qed.

Definition degc : forall n : nat, mon n -> nat.
intros n H'; elim H'.
exact 0.
intros d n1 M n2; exact (n1 + n2).
Defined.

Inductive total_orderc : forall n : nat, mon n -> mon n -> Prop :=
  | total_orderc0 :
      forall (n : nat) (p q : mon n),
      degc n p < degc n q -> total_orderc n p q
  | total_orderc1 :
      forall (n : nat) (p q : mon n),
      degc n p = degc n q -> orderc n p q -> total_orderc n p q.
Hint Resolve total_orderc0 total_orderc1.
Require Import LetP.

Theorem total_orderc_dec :
 forall (n : nat) (a b : mon n),
 {total_orderc n a b} + {total_orderc n b a} + {a = b}.
intros n a b.
apply LetP with (A := nat) (h := degc n a).
intros u H'; apply LetP with (A := nat) (h := degc n b).
intros u0 H'0.
case (le_lt_dec u u0); auto.
intro H'1; case (le_lt_eq_dec u u0); auto.
rewrite H'0; rewrite H'; auto.
rewrite H'0; rewrite H'; intro H'2; case (orderc_dec n a b); auto.
intro H'3; case H'3; auto.
rewrite H'0; rewrite H'; auto.
Qed.
End lexi_order.


(* fmformulas library for yalla *)

(* output in Type *)

(** * Order structure and finite multiset structure on formulas *)

Require Import Injective.
Require Import nattree.
Require Import fmsetlist_Type.

Require Export formulas.

(** ** Encoding of [formula] into [nat]-labelled trees for ordering *)

(** Embedding of [Atom] into [nat] *)
Definition a2n := yalla_ax.a2n.
Definition n2a := yalla_ax.n2a.
Definition a2a_n := yalla_ax.a2a_n.

(** Embedding of [formula] into [nattree] *)
Fixpoint form2nattree A :=
match A with
| var X => Bnt 1 (Bnt (a2n X) Lnt Lnt) Lnt
| covar X => Bnt 2 (Bnt (a2n X) Lnt Lnt) Lnt
| one => Bnt 3 Lnt Lnt
| bot => Bnt 4 Lnt Lnt
| tens A B => Bnt 5 (form2nattree A) (form2nattree B)
| parr A B => Bnt 6 (form2nattree A) (form2nattree B)
| zero => Bnt 7 Lnt Lnt
| top => Bnt 8 Lnt Lnt
| aplus A B => Bnt 9 (form2nattree A) (form2nattree B)
| awith A B => Bnt 10 (form2nattree A) (form2nattree B)
| oc A => Bnt 11 (form2nattree A) Lnt
| wn A => Bnt 12 (form2nattree A) Lnt
end.

Fixpoint nattree2form t :=
match t with
| Bnt 1 (Bnt k Lnt Lnt) Lnt => var (n2a k)
| Bnt 2 (Bnt k Lnt Lnt) Lnt => covar (n2a k)
| Bnt 3 Lnt Lnt => one
| Bnt 4 Lnt Lnt => bot
| Bnt 5 t1 t2 => tens (nattree2form t1) (nattree2form t2)
| Bnt 6 t1 t2 => parr (nattree2form t1) (nattree2form t2)
| Bnt 7 Lnt Lnt => zero
| Bnt 8 Lnt Lnt => top
| Bnt 9 t1 t2 => aplus (nattree2form t1) (nattree2form t2)
| Bnt 10 t1 t2 => awith (nattree2form t1) (nattree2form t2)
| Bnt 11 t1 Lnt => oc (nattree2form t1)
| Bnt 12 t1 Lnt => wn (nattree2form t1)
| _ => one
end.

Lemma form_nattree_section : forall A, nattree2form (form2nattree A) = A.
Proof.
induction A ; simpl ;
  try rewrite IHA1 ; try rewrite IHA2 ;
  try rewrite IHA ;
  try rewrite a2a_n ; try reflexivity.
Qed.

(** ** [BOrder] structure (total order with value into [bool]) *)

Instance border_formula : BOrder.
Proof.
eapply border_inj.
eapply comp_inj.
- apply nattree2nat_inj.
- eapply section_inj.
  apply form_nattree_section.
Defined.

(** ** Finite multi-sets over [formula] *)

Instance fmset_formula : FinMultiset (SortedList _) formula :=
  FMConstr_slist border_formula.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                     not_church_numerals                            *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import List Omega Closure_calculus.

(* primitive recursion
      https://en.wikipedia.org/wiki/Lambda_calculus#Arithmetic_in_lambda_calculus
 *)

(*
The Church numeral n is an iterator, that maps f and x to f^n (x).
Church numerals don't work in closure calculus, at least with the traditinal account of
predecessor, since pred zero reduces to a normal form which, unlike zero,
has a non-empty environment.
*)

Definition zero_c:= ff. (* \fx. x *)
Definition succ_c :=
Abs Iop 2 (Abs (Add Iop 2 (Ref 2)) 1 (Abs (Add (Add Iop 2 (Ref 2)) 1 (Ref 1)) 0
    (Tag (Ref 1) (Tag (Tag (Ref 2) (Ref 1)) (Ref 0))))).
(* \nfx.f(nfx) *)

Fixpoint church n :=
match n with
  | 0 => ff
  | S n => Abs (Add Iop 2 (church n)) 1 (Abs (Add (Add Iop 2 (Ref 2)) 1 (Ref 1)) 0
               (Tag (Ref 1) (Tag (Tag (Ref 2) (Ref 1)) (Ref 0))))
end.

Lemma church_numerals_are_normal: forall n, normal (church n).
Proof.
induction n; unfold church; fold church; unfold zero, value; split_all. unfold ff; auto.
repeat eapply2 nf_abs.
Qed.

Hint Resolve church_numerals_are_normal.

Lemma succ_church: forall n, seq_red (App succ_c (church n)) (church (S n)).
Proof. intro; unfold succ_c. repeat eapply2 succ_red.  Qed.

Definition is_zero_c := Abs Iop 0 (Tag (Tag (Ref 0) (Abs Iop 0 ff)) tt).

Lemma is_zero_c_zero_c: seq_red (App is_zero_c zero_c) tt .
Proof. unfold is_zero_c, zero_c, ff, tt; split_all. repeat eapply2 succ_red. Qed.

Lemma is_zero_c_succ_c: forall n, seq_red (App is_zero_c (church (S n))) ff .
Proof. intros. unfold church, is_zero_c, tt, ff, church. repeat eapply2 succ_red. Qed.

Definition my_pred_c :=
Abs Iop 2 (Abs (Add Iop 2 (Ref 2)) 1 (Abs (Add (Add Iop 2 (Ref 2)) 1 (Ref 1)) 0
    (Tag (Tag (Tag (Ref 2) (Abs (Add (Add Iop 1 (Ref 1)) 0 (Ref 0)) 4
     (Abs (Add (Add (Add Iop 1 (Ref 1)) 0 (Ref 0)) 4 (Ref 4)) 3
        (Tag (Ref 3) (Tag (Ref 4) (Ref 1))))))
              (Abs Iop 5 (Ref 0)))
         Iop)))
  (* λnfx. n (\gh. h(gf))(\u.x)(\u.u) *)
.

Definition pred_0_nf :=
Abs (Add Iop 2 (Abs Iop 1 (Abs Iop 0 (Ref 0)))) 1
     (Abs (Add (Add Iop 2 (Ref 2)) 1 (Ref 1)) 0
        (Tag
           (Tag
              (Tag (Ref 2)
                 (Abs (Add (Add Iop 1 (Ref 1)) 0 (Ref 0)) 4
                    (Abs (Add (Add (Add Iop 1 (Ref 1)) 0 (Ref 0)) 4 (Ref 4)) 3 (Tag (Ref 3) (Tag (Ref 4) (Ref 1))))))
              (Abs Iop 5 (Ref 0))) Iop)).

Lemma pred_0_val : seq_red (App my_pred_c zero_c) pred_0_nf.
Proof. unfold my_pred_c, zero_c, ff, tt. repeat eapply2 succ_red.  Qed.

Lemma pred_zero_fails: ~(seq_red (App my_pred_c zero_c) zero_c).
Proof.
intro.
assert (exists n, seq_red zero_c n /\ seq_red pred_0_nf n).
eapply2 closure_confluence.  eapply2 pred_0_val. split_all.
assert(irreducible zero_c seq_red1).
eapply2 irreducible_iff_normal.
replace zero_c with (church 0) by auto. eapply2 church_numerals_are_normal.
assert(x = zero_c).
inversion H0; auto.
assert False by eapply2 H1. contradiction. subst.
assert(irreducible pred_0_nf seq_red1).
eapply2 irreducible_iff_normal.
unfold pred_0_nf;  auto 20.
assert(zero_c = pred_0_nf).
inversion H2; auto.
assert False by eapply2 H3. contradiction.  discriminate.
Qed.


Require Import core.

Inductive HomotopyCalculus :=
 | Id                 | Refl
 | Inh                | Inc
 | Squash             | InhRec
 | TransU             | TransInvU
 | TransURef          | Singl
 | MapOnPath          | AppOnPath
 | HExt               | EquivEq
 | EquivEqRef         | TransUEquivEq
 | IdP                | MapOnPathD
 | IdS                | MapOnPathS
 | AppOnPathD         | Circle
 | Base               | HLoop
 | CircleRec          | I
 | I0                 | I1
 | Line               | IntRec
 | Undef: Loc -> HomotopyCalculus.

(*
   prop : U -> U
   prop A = (a b : A) -> Id A a b
   Sigma : (A : U) (B : A -> U) -> U
   Sigma A B = (x : A) * B x
   fiber : (A B : U) (f : A -> B) (y : B) -> U
   fiber A B f y = Sigma A (\x -> Id B (f x) y)
   id : (A : U) -> A -> A
   id A a = a
   singl : (A : U) -> A -> U
   singl A a = Sigma A (Id A a)
   pathTo : (A:U) -> A -> U
   pathTo A = fiber A A (id A)
   sId : (A : U) (a : A) -> pathTo A a
   sId A a = (a, refl A a)
   IdS : (A : U) (F : A -> U) (a0 a1 : A) (p : Id A a0 a1) -> F a0 -> F a1 -> U
   IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p)

   Primitives

   Id : (A : U) (a b : A) -> U
   refl : (A : U) (a : A) -> Id A a a
   inh : U -> U
   inc : (A : U) -> A -> inh A
   squash : (A : U) -> prop (inh A)
   inhrec : (A : U) (B : U) (p : prop B) (f : A -> B) (a : inh A) -> B
   contrSingl : (A : U) (a b : A) (p : Id A a b) -> Id (singl A a) (a, refl A a) (b, p)

   equivEq : (A B : U) (f : A -> B) (s : (y : B) -> fiber A B f y)
             (t : (y : B) -> (v : fiber A B f y) ->
             Id (fiber A B f y) (s y) v) -> Id U A B

   transport : (A B : U) -> Id U A B -> A -> B
   transpInv : (A B : U) -> Id U A B -> B -> A

   transportRef : (A : U) (a : A) -> Id A a (transport A A (refl U A) a)

   equivEqRef : (A : U) -> (s : (y : A) -> pathTo A y) ->
                (t : (y : A) -> (v : pathTo A y) ->
                Id (pathTo A y) (s y) v) ->
                Id (Id U A A) (refl U A) (equivEq A A (id A) s t)

   transpEquivEq : (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) ->
                   (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) ->
                   (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a)

   appOnPathD :  (A : U) (F : A -> U) (f g : (x : A) -> F x) -> Id ((x : A) -> F x) f g ->
                 (a0 a1 : A) (p : Id A a0 a1) -> IdS A F a0 a1 p  (f a0) (g a1)

   mapOnPath : (A B : U) (f : A -> B) (a b : A) (p : Id A a b) -> Id B (f a) (f b)
   appOnPath : (A B : U) (f g : A -> B) (a b : A) (q : Id (A -> B) f g) (p : Id A a b) -> Id B (f a) (g b)

   IdP : (A B : U) -> Id U A B -> A -> B -> U

   mapOnPathD : (A:U) (F: A -> U) (f: (x:A) -> F x) (a0 a1: A) (p: Id A a0 a1) -> IdS A F a0 a1 p  (f a0) (f a1)
   mapOnPathS : (A:U) (F: A -> U) (C: U) (f: (x:A) -> F x -> C)
                (a0 a1 : A) (p : Id A a0 a1) (b0 : F a0) (b1 : F a1)
                (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1)

   funHExt : (A : U) (B : A -> U) (f g : (a : A) -> B a) ->
             ((x y : A) -> (p : Id A x y) -> IdS A B x y p (f x) (g y)) ->
             Id ((y : A) -> B y) f g

   S1 : U
   base : S1
   loop : Id S1 base base
   S1rec : (F : S1 -> U) (b : F base) (l : IdS S1 F base base loop b b) (x : S1) -> F x
   I : U
   I0 : I
   I1 : I
   line : Id I I0 I1
   intrec : (F : I -> U) (s : F I0) (e : F I1) (l : IdS I F I0 I1 line s e) (x : I) -> F x

*)


Require Import Coq.Init.Specif.

Theorem proj_left : forall (A B : Type), A * B -> A.
Proof.
  intros A B H.
  destruct H.
  apply a.
Qed.

Theorem proj_right : forall (A B : Type), A * B -> B.
Proof.
  intros A B H.
  destruct H.
  apply b.
Qed.

Theorem inj_left : forall (A B : Type), A -> A + B.
Proof.
  intros A B H.
  left. apply H.
Qed.

Theorem inj_right : forall (A B : Type), B -> A + B.
Proof.
  intros A B H.
  right. apply H.
Qed.

Inductive Sigma (A : Type) (B : A -> Type) :=
  | element (a : A) (b : (B a)).

Check nat = bool.

Check existT.

Check sigT.

Definition homotopy (A : Type) (P : A -> Type) (f g: forall (a : A), P a): Type
  := forall (a : A), (f a) = (g a).

Definition homotopy_ind (A B : Type) (f g: A -> B): Type
  := homotopy A (fun (a : A) => B) f g.

Definition id (A : Type) (a : A) := a.

Check id.

Check forall (a : nat), (fun (a: nat) => bool) a.
Check forall (a : nat), (fun (a: nat) => bool) a.

Definition Pi (A : Type) (P : A -> Type) : Type := forall (a : A), P a.

Check Pi.

Check existT.

(* TODO use existT f such that isequiv f *)
Definition type_equiv (A B : Type) : Type :=
  sigT (fun (f : A -> B) => (
    prod
    (sigT (fun (h : B -> A) => (homotopy_ind A A (fun (a : A) => (h (f a))) (id A))))
    (sigT (fun (g : B -> A) => (homotopy_ind B B (fun (b : B) => (f (g b))) (id B))))
  )).

(*
TODO (more specific things)
    - research Sigma and Pi types (use sig_t in the documentation page
    - try to prove split_prob_general
    - convert theorems at the bottom into levelled versions
*)

(*
Next steps (general)
  - make sure that the axioms are consistent
  - are there any contradictions?
    - step 1: prove that all of the non-induction rules are consistent
    - step 2: prove that adding the induction rules keeps the system consistent
*)


(* Exercise 77 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_077 : (exists x : D, forall y : D, P x \/ P y) -> exists x : D, P x.
Proof.
imp_i a1.
exi_e (exists x:D, forall y:D, P x \/ P y) a a2.
hyp a1.
dis_e (P a \/ P a) a3 a3.
all_e (forall y:D, P a \/ P y) a.
hyp a2.
exi_i a.
hyp a3.
exi_i a.
hyp a3.
Qed.


Require Import ssreflect Arith.
Require Import Arith.EqNat.
Require Import Arith.Compare_dec.
Require Import List.
Require Import Omega.
Require Import untypedLambda.

(*Question 1.4.2*)
Theorem no_index_sub: forall (t u: term) (i: nat), (C i t) -> substitution i t u = t.
Proof.
  induction t.
  simpl.
  intros.
  Search _ (_ < _).
  have:(beq_nat i v = false).
  apply beq_nat_false_iff.
  intro.
  rewrite H0 in H.
  apply Lt.lt_irrefl in H.
  done.
  move => h0.
  rewrite h0.
  done.
  simpl.
  intros.
  rewrite -lambda_equivalence.
  apply IHt.
  done.
  simpl.
  intros.
  rewrite app_equivalence.
  split.
  apply IHt1.
  apply H.
  apply IHt2.
  apply H.
Qed.

Lemma substitution_invariance: forall (t u: term) (i: nat), (C 0 t) -> substitution i t u = t.
Proof.
  induction t.
  move => u i.
  simpl.
  move => h0.
  Search "0".
  apply Lt.lt_n_0 in h0.
  done.
  simpl.
  move => u i h0.
  rewrite -lambda_equivalence.
  apply no_index_sub.
  induction i.
  simpl.
  done.
  apply ind_C_pred.
  rewrite Plus.plus_comm in IHi.
  done.
  intros.
  simpl.
  rewrite app_equivalence.
  simpl in H.
  move:H.
  move => [h0 h1].
  split.
  apply IHt1.
  done.
  apply IHt2.
  done.
Qed.

(*Used for case analysis in if's*)
Lemma dic: forall b : bool, (b = false) \/ (b = true).
Proof.
  move => b.
  case b.
  right.
  done.
  left.
  done.
Qed.

(*Question 1.4.1*)
Theorem id_substitution: forall t: term, forall i: nat, multiple_substitution i t nil = t.
Proof.
  induction t.
  move => i.
  simpl.
  elim (dic (leb i v && leb v (i + 0 - 1))%bool).
  move => h0.
  rewrite h0.
  done.
  move => h0.
  rewrite h0.
  have:(beq_nat v v = true).
  Search "beq".
  apply beq_nat_true_iff.
  done.
  move => h1.
  rewrite h1.
  move: h0.
  case v.
  intro.
  Search "andb".
  apply Bool.andb_true_iff in h0.
  Search "leb_iff".
  destruct h0 as [h0 h01].
  apply leb_iff in h0.
  apply leb_iff in h01.
  simpl.
  done.
  case i.
  intros.
  apply Bool.andb_true_iff in h0.
  destruct h0 as [h0 h01].
  apply leb_iff in h0.
  apply leb_iff in h01.
  omega.
  intros.
  simpl.
  apply Bool.andb_true_iff in h0.
  destruct h0 as [h0 h01].
  apply leb_iff in h0.
  apply leb_iff in h01.
  omega.
  intro.
  simpl.
  rewrite IHt.
  done.
  intro.
  simpl.
  rewrite IHt1.
  rewrite IHt2.
  done.
Qed.

(*Lifting and arithmetic resuts*)
(*-----------------------------*)

Lemma lift_free: forall (t: term) (i k: nat), C i t -> C (i+1) (lifting 1 k t).
Proof.
  induction t.
  simpl.
  intros.
  case (leb k v).
  simpl.
  Search "plus".
  apply Plus.plus_lt_compat_r.
  done.
  simpl.
  Search "plus".
  apply Plus.lt_plus_trans.
  done.
  simpl.
  intros.
  apply IHt.
  done.
  simpl.
  intros.
  split.
  apply IHt1.
  apply H.
  apply IHt2.
  apply H.
Qed.

Lemma extract_lifting: forall (lu: list term) (j: nat) (u: term), (j < length lu) -> (nth j (lift_all 1 0 lu) u) = lifting 1 0 (nth j lu u).
Proof.
  induction lu.
  simpl.
  intros.
  Search _ (_<_).
  apply Lt.lt_n_0 in H.
  done.
  simpl.
  intros.
  induction j.
  done.
  apply IHlu.
  Search _ (_<_).
  apply (Plus.plus_lt_reg_l j (length lu) 1).
  apply H.
Qed.

Lemma lt_plus_l: forall (n m p: nat), n + p < m -> n < m.
Proof.
  induction n.
  induction m.
  simpl.
  intros.
  apply lt_n_0 in H.
  done.
  simpl.
  intros.
  Search _ (_<_).
  apply lt_0_Sn.
  intros.
  omega.
Qed.

Lemma le_plus_l: forall (n m p: nat), n + p <= m -> n <= m.
Proof.
  intros.
  omega.
Qed.

Lemma minus_dist: forall (n m p: nat), n - (m+p) = (n-m) - p.
Proof.
  intros.
  omega.
Qed.

Lemma lift_inv: forall (lu:list term), length lu = length (lift_all 1 0 lu).
Proof.
  induction lu.
  simpl.
  reflexivity.
  simpl.
  rewrite IHlu.
  reflexivity.
Qed.

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

(*Question 1.4.3*)
(*Case when lu is non empty*)
Lemma mult_sub_inv_bis: forall (t u:term) (lu:list term) (i: nat),
 (0 < length lu) -> (forall (j:nat), (j < length lu) -> C i (nth j lu (Var 0))) -> multiple_substitution i t (u :: lu) = substitution i (multiple_substitution (i+1) t lu) (u).
Proof.
  induction t.
  intros.
  simpl.
  have:(true = beq_nat v v).
  Search "beq".
  apply ( beq_nat_refl v).
  intro.
  rewrite -x.
  have:((leb (i+1) v = false) \/ (leb (i+1) v = true)).
  apply (dic (leb (i+1) v)).
  intro.
  case:x0.
  move => h0.
  rewrite h0.
  simpl.
  apply leb_iff_conv in h0.
  have:(v < i)\/(v=i).
  Search _ (_<_).
  apply le_lt_or_eq.
  rewrite ->plus_comm in h0.
  apply lt_n_Sm_le in h0.
  done.
  intro h1.
  apply or_comm in h1.
  case:h1.
  intro h1.
  rewrite h1.
  rewrite minus_diag.
  Search "leb".
  have:(leb i i = true).
  apply leb_iff.
  apply le_refl.
  intro h2.
  rewrite h2.
  simpl.
  have:(beq_nat i i = true).
  apply beq_nat_true_iff.
  reflexivity.
  intro h3.
  rewrite h3.
  have:(leb i (i + (length lu+1) -1) = true).
  apply leb_iff.
  omega.
  intro h4.
  have:i + S (length lu) - 1 = i + (length lu + 1) - 1.
  omega.
  intro.
  rewrite x0.
  rewrite h4.
  done.
  intro.
  have:leb i v = false.
  apply leb_iff_conv.
  done.
  intro.
  rewrite x0.
  simpl.
  have:beq_nat i v = false.
  rewrite beq_nat_false_iff.
  intro.
  rewrite H1 in b.
  apply lt_irrefl in b.
  done.
  intro h1.
  rewrite h1.
  done.
  intro.
  rewrite b.
  simpl.
  apply leb_iff in b.
  apply le_lt_or_eq_iff in b.
  have:i + 1 + length lu - 1 = i + (1 + length lu) - 1.
  omega.
  intro h2.
  rewrite -h2.
  have:(leb v (i + 1 + length lu - 1) = false) \/ leb v (i + 1 + length lu - 1) = true.
  apply dic.
  intro h0.
  case:h0.
  intro h1.
  rewrite h1.
  Search _ (_&&_)%bool "comm".
  rewrite Bool.andb_comm.
  simpl.
  have:(beq_nat i v = false).
  rewrite beq_nat_false_iff.
  intro.
  rewrite H1 in b.
  case b.
  intro.
  omega.
  omega.
  intro h3.
  rewrite h3.
  done.
  intro h1.
  rewrite h1.
  rewrite Bool.andb_comm.
  simpl.
  have:leb i v = true.
  have:(i+1) <= v.
  Search _ (_<=_) "or".
  apply le_lt_or_eq_iff.
  done.
  intro h3.
  apply leb_iff.
  apply (le_plus_l i v 1).
  done.
  intro h3.
  rewrite h3.
  rewrite NPeano.Nat.sub_add_distr.
  destruct (v - i) eqn:h4.
  apply NPeano.Nat.sub_0_le in h4.
  omega.
  simpl.
  rewrite -minus_n_O.
  symmetry.
  apply no_index_sub.
  apply H0.
  apply leb_iff in h1.
  apply leb_iff in h3.
  omega.
  intros.
  simpl.
  rewrite -lambda_equivalence.
  (*Find a way to deal with the lifting operation*)
  apply (IHt (lifting 1 0 u) (lift_all 1 0 lu) (i+1)).
  rewrite -lift_inv.
  done.
  intros.
  rewrite -lift_inv in H1.
  rewrite (extract_lifting).
  apply lift_free.
  apply H0.
  done.
  done.
  intros.
  simpl.
  rewrite app_equivalence.
  split.
  apply (IHt1 u lu i).
  done.
  done.
  apply (IHt2 u lu i).
  done.
  done.
Qed.

(*General case*)
Lemma mult_sub_inv: forall (t u:term) (lu:list term) (i: nat),
 (forall (j:nat), (j < length lu) -> C i (nth j lu (Var 0))) -> multiple_substitution i t (u :: lu) = substitution i (multiple_substitution (i+1) t (lu)) (u).
Proof.
  induction lu.
  move:u.
  induction t.
  intros.
  rewrite id_substitution.
  unfold multiple_substitution.
  have:i + 1 - 1 = i.
  omega.
  intro h0.
  rewrite h0.
  have: ((leb i v && leb v i)%bool = false) \/ (leb i v && leb v i)%bool = true.
  apply dic.
  intro h1.
  case:h1.
  intro h1.
  rewrite h1.
  simpl.
  apply Bool.andb_false_iff in h1.
  case:h1.
  intro h1.
  apply leb_iff_conv in h1.
  have: beq_nat i v = false.
  apply beq_nat_false_iff.
  omega.
  intro h2.
  rewrite h2.
  trivial.
  intro h1.
  apply leb_iff_conv in h1.
  have: beq_nat v i = false.
  apply beq_nat_false_iff.
  omega.
  intro h2.
  apply beq_nat_false_iff in h2.
  apply not_eq_sym in h2.
  apply beq_nat_false_iff in h2.
  rewrite h2.
  trivial.
  intro h1.
  rewrite h1.
  apply Bool.andb_true_iff in h1.
  have: i = v.
  destruct h1 as [h1 h2].
  apply leb_iff in h1.
  apply leb_iff in h2.
  omega.
  intro h2.
  have : v - i = 0.
  omega.
  intro h3.
  rewrite h3.
  simpl.
  rewrite h2.
  trivial.
  intros.
  simpl.
  rewrite -lambda_equivalence.
  apply IHt.
  intros.
  apply ind_C_pred.
  apply H.
  trivial.
  intros.
  simpl.
  rewrite app_equivalence.
  split.
  apply IHt1.
  done.
  apply IHt2.
  done.
  intros.
  apply (mult_sub_inv_bis t u (a::lu) i).
  simpl.
  omega.
  intros.
  apply H.
  done.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Nth.
Require option.Option.

(* Why3 goal *)
Lemma nth_none_1 :
forall {a:Type} {a_WT:WhyType a},
forall (l:(list a)) (i:Z),
 (i < 0%Z)%Z -> ((list.Nth.nth i l) = Init.Datatypes.None).
Proof.
intros a a_WT l.
induction l as [|h q].
easy.
intros i H.
simpl.
generalize (Zeq_bool_if i 0).
case Zeq_bool.
intros H'.
now rewrite H' in H.
intros _.
apply IHq.
omega.
Qed.

(* Why3 goal *)
Lemma nth_none_2 :
forall {a:Type} {a_WT:WhyType a},
forall (l:(list a)) (i:Z),
 ((list.Length.length l) <= i)%Z ->
 ((list.Nth.nth i l) = Init.Datatypes.None).
Proof.
intros a a_WT l.
induction l as [|h q].
easy.
intros i H.
unfold Length.length in H.
fold Length.length in H.
simpl.
generalize (Zeq_bool_if i 0).
case Zeq_bool.
intros H'.
rewrite H' in H.
exfalso.
generalize (Length.Length_nonnegative q).
omega.
intros _.
apply IHq.
omega.
Qed.

(* Why3 goal *)
Lemma nth_none_3 :
forall {a:Type} {a_WT:WhyType a},
forall (l:(list a)) (i:Z),
 ((list.Nth.nth i l) = Init.Datatypes.None) ->
 ((i < 0%Z)%Z \/ ((list.Length.length l) <= i)%Z).
Proof.
intros a a_WT l.
induction l as [|h q].
intros i _.
simpl.
omega.
intros i.
simpl (Nth.nth i (h :: q)).
change (Length.length (h :: q)) with (1 + Length.length q)%Z.
generalize (Zeq_bool_if i 0).
case Zeq_bool.
easy.
intros Hi H.
specialize (IHq _ H).
omega.
Qed.


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

Require Export NumPrelude NZAxioms.
Require Import NZBase NZOrder NZAddOrder Plus Minus.

(** In this file, we investigate the shape of domains satisfying
    the [NZDomainSig] interface. In particular, we define a
    translation from Peano numbers [nat] into NZ.
*)

(** First, a section about iterating a function. *)

Section Iter.
Variable A : Type.
Fixpoint iter (f:A->A)(n:nat) : A -> A := fun a =>
  match n with
    | O => a
    | S n => f (iter f n a)
  end.
Infix "^" := iter.

Lemma iter_alt : forall f n m, (f^(Datatypes.S n)) m = (f^n) (f m).
Proof.
induction n; simpl; auto.
intros; rewrite <- IHn; auto.
Qed.

Lemma iter_plus : forall f n n' m, (f^(n+n')) m = (f^n) ((f^n') m).
Proof.
induction n; simpl; auto.
intros; rewrite IHn; auto.
Qed.

Lemma iter_plus_bis : forall f n n' m, (f^(n+n')) m = (f^n') ((f^n) m).
Proof.
induction n; simpl; auto.
intros. rewrite <- iter_alt, IHn; auto.
Qed.

Global Instance iter_wd (R:relation A) : Proper ((R==>R)==>eq==>R==>R) iter.
Proof.
intros f f' Hf n n' Hn; subst n'. induction n; simpl; red; auto.
Qed.

End Iter.
Implicit Arguments iter [A].
Local Infix "^" := iter.

Module NZDomainProp (Import NZ:NZDomainSig').

(** * Relationship between points thanks to [succ] and [pred]. *)

(** We prove that any points in NZ have a common descendant by [succ] *)

Definition common_descendant n m := exists k l, (S^k) n == (S^l) m.

Instance common_descendant_wd : Proper (eq==>eq==>iff) common_descendant.
Proof.
unfold common_descendant. intros n n' Hn m m' Hm.
setoid_rewrite Hn. setoid_rewrite Hm. auto with *.
Qed.

Instance common_descendant_equiv : Equivalence common_descendant.
Proof.
split; red.
intros x. exists O; exists O. simpl; auto with *.
intros x y (p & q & H); exists q; exists p; auto with *.
intros x y z (p & q & Hpq) (r & s & Hrs).
exists (r+p)%nat. exists (q+s)%nat.
rewrite !iter_plus. rewrite Hpq, <-Hrs, <-iter_plus, <- iter_plus_bis.
auto with *.
Qed.

Lemma common_descendant_with_0 : forall n, common_descendant n 0.
Proof.
apply bi_induction.
intros n n' Hn. rewrite Hn; auto with *.
reflexivity.
split; intros (p & q & H).
exists p; exists (Datatypes.S q). rewrite <- iter_alt; simpl.
 now f_equiv.
exists (Datatypes.S p); exists q. rewrite iter_alt; auto.
Qed.

Lemma common_descendant_always : forall n m, common_descendant n m.
Proof.
intros. transitivity 0; [|symmetry]; apply common_descendant_with_0.
Qed.

(** Thanks to [succ] being injective, we can then deduce that for any two
    points, one is an iterated successor of the other. *)

Lemma itersucc_or_itersucc : forall n m, exists k, n == (S^k) m \/ m == (S^k) n.
Proof.
intros n m. destruct (common_descendant_always n m) as (k & l & H).
revert l H. induction k.
simpl. intros; exists l; left; auto with *.
intros. destruct l.
simpl in *. exists (Datatypes.S k); right; auto with *.
simpl in *. apply pred_wd in H; rewrite !pred_succ in H. eauto.
Qed.

(** Generalized version of [pred_succ] when iterating *)

Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n.
Proof.
induction k.
simpl; auto with *.
simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto.
rewrite <- iter_alt in H; auto.
Qed.

(** From a given point, all others are iterated successors
    or iterated predecessors. *)

Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m.
Proof.
intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]).
exists k; left; auto.
exists k; right. apply succ_swap_pred; auto.
Qed.

(** In particular, all points are either iterated successors of [0]
    or iterated predecessors of [0] (or both). *)

Lemma itersucc0_or_iterpred0 :
 forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0.
Proof.
 intros n. exact (itersucc_or_iterpred n 0).
Qed.

(** * Study of initial point w.r.t. [succ] (if any). *)

Definition initial n := forall m, n ~= S m.

Lemma initial_alt : forall n, initial n <-> S (P n) ~= n.
Proof.
split. intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ).
intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *.
Qed.

Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m.
Proof. firstorder. Qed.

(** First case: let's assume such an initial point exists
    (i.e. [S] isn't surjective)... *)

Section InitialExists.
Hypothesis init : t.
Hypothesis Initial : initial init.

(** ... then we have unicity of this initial point. *)

Lemma initial_unique : forall m, initial m -> m == init.
Proof.
intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]).
destruct p. now simpl in *. destruct (Initial _ H).
destruct p. now simpl in *. destruct (Im _ H).
Qed.

(** ... then all other points are descendant of it. *)

Lemma initial_ancestor : forall m, exists p, m == (S^p) init.
Proof.
intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]).
destruct p; simpl in *; auto. exists O; auto with *. destruct (Initial _ H).
exists p; auto.
Qed.

(** NB : We would like to have [pred n == n] for the initial element,
    but nothing forces that. For instance we can have -3 as initial point,
    and P(-3) = 2. A bit odd indeed, but legal according to [NZDomainSig].
    We can hence have [n == (P^k) m] without [exists k', m == (S^k') n].
*)

(** We need decidability of [eq] (or classical reasoning) for this: *)

Section SuccPred.
Hypothesis eq_decidable : forall n m, n==m \/ n~=m.
Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n.
Proof.
intros n NB. rewrite initial_alt in NB.
destruct (eq_decidable (S (P n)) n); auto.
elim NB; auto.
Qed.
End SuccPred.
End InitialExists.

(** Second case : let's suppose now [S] surjective, i.e. no initial point. *)

Section InitialDontExists.

Hypothesis succ_onto : forall n, exists m, n == S m.

Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n.
Proof.
intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *.
Qed.

Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m.
Proof.
intros n m. intros H; apply succ_wd in H.
rewrite !succ_onto_gives_succ_pred in H; auto.
Qed.

End InitialDontExists.

(** To summarize:

  S is always injective, P is always surjective  (thanks to [pred_succ]).

  I) If S is not surjective, we have an initial point, which is unique.
     This bottom is below zero: we have N shifted (or not) to the left.
     P cannot be injective: P init = P (S (P init)).
     (P init) can be arbitrary.

  II) If S is surjective, we have [forall n, S (P n) = n], S and P are
     bijective and reciprocal.

     IIa) if [exists k<>O, 0 == S^k 0], then we have a cyclic structure Z/nZ
     IIb) otherwise, we have Z
*)

(** * An alternative induction principle using [S] and [P]. *)

(** It is weaker than [bi_induction]. For instance it cannot prove that
    we can go from one point by many [S] _or_ many [P], but only by many
    [S] mixed with many [P]. Think of a model with two copies of N:

    0,  1=S 0,   2=S 1, ...
    0', 1'=S 0', 2'=S 1', ...

    and P 0 = 0' and P 0' = 0.
*)

Lemma bi_induction_pred :
  forall A : t -> Prop, Proper (eq==>iff) A ->
    A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) ->
    forall n, A n.
Proof.
intros. apply bi_induction; auto.
clear n. intros n; split; auto.
intros G; apply H2 in G. rewrite pred_succ in G; auto.
Qed.

Lemma central_induction_pred :
  forall A : t -> Prop, Proper (eq==>iff) A -> forall n0,
    A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) ->
    forall n, A n.
Proof.
intros.
assert (A 0).
destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk.
 clear H2. induction k; simpl in *; auto.
 clear H1. induction k; simpl in *; auto.
apply bi_induction_pred; auto.
Qed.

End NZDomainProp.

(** We now focus on the translation from [nat] into [NZ].
    First, relationship with [0], [succ], [pred].
*)

Module NZOfNat (Import NZ:NZDomainSig').

Definition ofnat (n : nat) : t := (S^n) 0.
Notation "[ n ]" := (ofnat n) (at level 7) : ofnat.
Local Open Scope ofnat.

Lemma ofnat_zero : [O] == 0.
Proof.
reflexivity.
Qed.

Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n].
Proof.
 now unfold ofnat.
Qed.

Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n].
Proof.
 unfold ofnat. destruct n. destruct 1; auto.
 intros _. simpl. symmetry. apply pred_succ.
Qed.

(** Since [P 0] can be anything in NZ (either [-1], [0], or even other
    numbers, we cannot state previous lemma for [n=O]. *)

End NZOfNat.

(** If we require in addition a strict order on NZ, we can prove that
    [ofnat] is injective, and hence that NZ is infinite
    (i.e. we ban Z/nZ models) *)

Module NZOfNatOrd (Import NZ:NZOrdSig').
Include NZOfNat NZ.
Include NZBaseProp NZ <+ NZOrderProp NZ.
Local Open Scope ofnat.

Theorem ofnat_S_gt_0 :
  forall n : nat, 0 < [Datatypes.S n].
Proof.
unfold ofnat.
intros n; induction n as [| n IH]; simpl in *.
apply lt_succ_diag_r.
apply lt_trans with (S 0). apply lt_succ_diag_r. now rewrite <- succ_lt_mono.
Qed.

Theorem ofnat_S_neq_0 :
  forall n : nat, 0 ~= [Datatypes.S n].
Proof.
intros. apply lt_neq, ofnat_S_gt_0.
Qed.

Lemma ofnat_injective : forall n m, [n]==[m] -> n = m.
Proof.
induction n as [|n IH]; destruct m; auto.
intros H; elim (ofnat_S_neq_0 _ H).
intros H; symmetry in H; elim (ofnat_S_neq_0 _ H).
intros. f_equal. apply IH. now rewrite <- succ_inj_wd.
Qed.

Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m.
Proof.
split. apply ofnat_injective. intros; now subst.
Qed.

(* In addition, we can prove that [ofnat] preserves order. *)

Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n<m)%nat.
Proof.
induction n as [|n IH]; destruct m; repeat rewrite ofnat_zero; split.
intro H; elim (lt_irrefl _ H).
inversion 1.
auto with arith.
intros; apply ofnat_S_gt_0.
intro H; elim (lt_asymm _ _ H); apply ofnat_S_gt_0.
inversion 1.
rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith.
rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith.
Qed.

Lemma ofnat_le : forall n m : nat, [n]<=[m] <-> (n<=m)%nat.
Proof.
intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq.
split.
destruct 1; subst; auto with arith.
apply Lt.le_lt_or_eq.
Qed.

End NZOfNatOrd.

(** For basic operations, we can prove correspondance with
    their counterpart in [nat]. *)

Module NZOfNatOps (Import NZ:NZAxiomsSig').
Include NZOfNat NZ.
Local Open Scope ofnat.

Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m.
Proof.
 induction n; intros.
 apply add_0_l.
 rewrite ofnat_succ, add_succ_l. simpl. now f_equiv.
Qed.

Lemma ofnat_add : forall n m, [n+m] == [n]+[m].
Proof.
 intros. rewrite ofnat_add_l.
 induction n; simpl. reflexivity.
 rewrite ofnat_succ. now f_equiv.
Qed.

Lemma ofnat_mul : forall n m, [n*m] == [n]*[m].
Proof.
 induction n; simpl; intros.
 symmetry. apply mul_0_l.
 rewrite plus_comm.
 rewrite ofnat_succ, ofnat_add, mul_succ_l.
 now f_equiv.
Qed.

Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n.
Proof.
 induction m; simpl; intros.
 rewrite ofnat_zero. apply sub_0_r.
 rewrite ofnat_succ, sub_succ_r. now f_equiv.
Qed.

Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m].
Proof.
 intros n m H. rewrite ofnat_sub_r.
 revert n H. induction m. intros.
 rewrite <- minus_n_O. now simpl.
 intros.
 destruct n.
 inversion H.
 rewrite iter_alt.
 simpl.
 rewrite ofnat_succ, pred_succ; auto with arith.
Qed.

End NZOfNatOps.


Require Import List.

Lemma fold_right_map: forall {A1 B1 A2 B2} (f1: A1 -> B1 -> B1) (f2: A2 -> B2 -> B2) gA gB,
  (forall a b, gB (f1 a b) = f2 (gA a) (gB b)) ->
  (forall l b, gB (fold_right f1 b l) = fold_right f2 (gB b) (map gA l)).
Proof.
  intros.
  induction l; auto.
  simpl.
  rewrite H.
  rewrite IHl.
  auto.
Qed.

Lemma fold_left_map: forall {A1 B1 A2 B2} (f1: A1 -> B1 -> A1) (f2: A2 -> B2 -> A2) gA gB,
  (forall a b, gA (f1 a b) = f2 (gA a) (gB b)) ->
  (forall l a, gA (fold_left f1 l a) = fold_left f2 (map gB l) (gA a)).
Proof.
  intros.
  revert a; induction l; auto; intros.
  simpl.
  rewrite <- H.
  rewrite IHl.
  auto.
Qed.

Lemma NoDup_app_iff {A}: forall l1 l2 : list A,
  NoDup (l1 ++ l2) <->
  NoDup l1 /\ NoDup l2 /\ (forall a, In a l1 /\ In a l2 <-> False).
Proof.
  induction l1; intros.
  + simpl.
    split; intros.
    - split; [constructor |].
      split; auto.
      intros; tauto.
    - tauto.
  + split; intros.
    - simpl in H.
      inversion H; subst.
      rewrite IHl1 in H3; destruct H3 as [? [? ?]].
      split; [constructor | split]; auto.
      * rewrite in_app_iff in H2; tauto.
      * intros; specialize (H3 a0).
        simpl.
        split; [| tauto].
        intros [[? | ?] ?]; [| tauto].
        subst a0.
        rewrite in_app_iff in H2; tauto.
    - destruct H as [? [? ?]].
      simpl; constructor.
      * inversion H; subst.
        specialize (H1 a); simpl in H1.
        rewrite in_app_iff; tauto.
      * rewrite IHl1.
        split; [inversion H | split]; auto.
        intros; specialize (H1 a0); simpl in H1; tauto.
Qed.