(* begin hide *)
Require Import Unicode.Utf8.
Require Import CoqCats.Category.
Require Import CoqCats.PolyPrelude.

Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.
(* end hide *)

(** * Categorical products.

    I define products of an arbitrarily indexed set of objects. To
    recover the familiar binary product, set idx to 2.
 *)
Record product {cat : category} {idx}
       (object_product : cat) (components : idx → cat) :=
  { (** The property we care about: An arrow to each component. *)
    property o := ∀ i, o ⇝ (components i);
    (** The projections from our object product. *)
    π : property object_product;
    (** Any object with our property has an arrow to our distingiushed
        object prodcut. *)
    morphism_product : ∀ {o}, property o → o ⇝ object_product;
    (** We now have an indexed set of diagrams: Given an arbitrary
        object satisfying our property, we have an arrow from it to
        our object product and for each i, we have an arrow from
        our object product to the relevant component and an arrow from
        the arbitrary object to the relevant component. Abstracting
        away the distingiushed morphism product and replacing it with
        an arbitrary arrow f from the arbitrary object to our object
        product, we say f commutes with this set of diagrams when each
        diagram commutes in the obvious way.
     *)
    commutes o (γ : property o) f := ∀ i, π i ∘ f = γ i;
    morphism_product_commutes : ∀ {o γ},
        commutes o γ (morphism_product γ);
    morphism_product_unique : ∀ {o γ f},
        commutes o γ f → f = morphism_product γ;
  }.

Arguments morphism_product [cat] [idx] [object_product] [components] _ [o].
Arguments π [cat] [idx] [object_product] [components].
Arguments commutes [cat] [idx] [object_product] [components].
Arguments morphism_product_commutes [cat] [idx] [object_product] [components] _ {o} {γ}.
Arguments morphism_product_unique [cat] [idx] [object_product] [components] _ [o] [γ] [f].

Section product.
  Variable cat : category.
  Section identity.
    Variable idx : Type.
    Variable op : cat.
    Variable comp : idx → cat.
    Variable prod : product op comp.

    (** In prose:
        Lemma: The identity commutes
        Proof: For each i, it's given by the fact that 1 is a right
        identity of ∘.
        Theorem: The identity is the morphism product from the object
        product to itself.
        Proof: The morphism product uniquely commutes, and the
        identity commutes.

        TODO Figure out how tactics work.
     *)
    Definition identity_morphism_product :
      prod.(morphism_product) prod.(π) = 1 :=
      let
        id_commutes _ := cat.(right_identity)
      in eq_sym (prod.(morphism_product_unique) id_commutes).
  End identity.

  Arguments identity_morphism_product [idx] [op] [comp].

  Section product_unique.
    Variable idx : Type.
    Variable op op₂: cat.
    Variable comp : idx → cat.
    Variable prod : product op comp.
    Variable prod₂ : product op₂ comp.
    Definition product_unique_up_to_iso :
      isomorphism (prod.(morphism_product) prod₂.(π)) :=
      {| to := prod₂.(morphism_product) prod.(π);
         comm_from :=
           let
             (** In prose:
                 We want to prove that to ∘ from commutes with the
                 relevant diagram, first we go from πᵢ₂ ∘ to ∘ from
                 to πᵢ₁ ∘ from by the fact that the morphism product
                 (in prod₂) commutes, then we go from πᵢ₁ ∘ from to
                 πᵢ₂ by the fact that the morphism product (in prod₁)
                 commutes
              *)
             loop_commutes i :=
             eq_trans
               (eq_sym cat.(compose_assoc))
               (eq_trans
                  (compose_transport_left
                     (prod₂.(morphism_product_commutes) i))
                  (prod.(morphism_product_commutes) i))
           (** And now that we know the loop commutes, we know it
               must be the identity by uniqueness of the morphism
               product.
            *)
           in eq_trans
                (prod₂.(morphism_product_unique) loop_commutes)
                (prod₂.(identity_morphism_product));
         (** This direction is just the other with indices flipped *)
         comm_to :=
           let
             loop_commutes i :=
             eq_trans
               (eq_sym cat.(compose_assoc))
               (eq_trans
                  (compose_transport_left
                     (prod.(morphism_product_commutes) i))
                  (prod₂.(morphism_product_commutes) i))
           in eq_trans
                (prod.(morphism_product_unique) loop_commutes)
                (prod.(identity_morphism_product));
    |}.
  End product_unique.
End product.


From Hammer Require Import Hammer.

Require Export Wf_nat.
Require Export ZArith.
Open Scope Z_scope.

Definition R_noet (x y : nat * nat) : Prop :=
((fst x) + (snd x) < (fst y) + (snd y))%nat.

Definition f (x : nat * nat) := ((fst x) + (snd x))%nat.

Lemma R_noet_wf : well_founded R_noet.
Proof. hammer_hook "Descent" "Descent.R_noet_wf".
apply (well_founded_lt_compat _ f R_noet); auto.
Qed.

Lemma noetherian : forall P : nat * nat -> Prop,
(forall z : nat * nat, (forall y : nat * nat,
(fst(y) + snd(y) < fst(z) + snd(z))%nat -> P y) -> P z) ->
forall x : nat * nat, P x.
Proof. hammer_hook "Descent" "Descent.noetherian".
intros; generalize (well_founded_ind R_noet_wf P); auto.
Qed.

Lemma infinite_descent_nat : forall P : nat * nat -> Prop,
(forall x : nat * nat, (P x -> exists y : nat * nat,
(fst(y) + snd(y) < fst(x) + snd(x))%nat /\ P y)) ->
forall x : nat * nat, ~(P x).
Proof. hammer_hook "Descent" "Descent.infinite_descent_nat".
intros; apply (noetherian (fun x => ~(P x))); red; intros; elim (H z H1);
intros; apply (H0 x0); tauto.
Qed.

Lemma infinite_descent : forall P : Z -> Z -> Prop,
(forall x1 x2 : Z, 0 <= x1 -> 0 <= x2 ->
(P x1 x2 -> exists y1 : Z, exists y2 : Z, 0 <= y1 /\ 0 <= y2 /\
y1 + y2 < x1 + x2 /\ P y1 y2)) ->
forall x y: Z, 0 <= x -> 0 <= y -> ~(P x y).
Proof. hammer_hook "Descent" "Descent.infinite_descent".
intros; elim (Z_of_nat_complete _ H0); clear H0; intros;
elim (Z_of_nat_complete _ H1); clear H1; intros; rewrite H0; rewrite H1;
clear H0 H1;
generalize (infinite_descent_nat
(fun c => P (Z_of_nat (fst c)) (Z_of_nat (snd c)))); intro;
cut (~( P (Z_of_nat (fst (x0, x1))) (Z_of_nat (snd (x0, x1))))); auto.
apply H0; clear H0; intros;
elim (H (Z_of_nat (fst x2)) (Z_of_nat (snd x2)) (Zle_0_nat (fst x2))
(Zle_0_nat (snd x2)) H0); clear H; intros; elim H; clear H; intros;
intuition; elim (Z_of_nat_complete x3 H1); intros;
elim (Z_of_nat_complete x4 H); intros; exists (x5, x6); simpl;
rewrite H3 in H4; rewrite H5 in H4; intuition.
Qed.


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Definitions              *
* Brian Aydemir & Arthur Charguéraud, July 2007                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L ->
        (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.


From Coq Require Import NArith ZArith Lia.

From EVM Require Import Logic2.

(**************************************************************************)

Lemma N_ltb_lt_quad (a b c d: N):
  ((a <? b)%N = (c <? d)%N) <-> ((a < b)%N <-> (c < d)%N).
Proof.
apply relation_quad; apply N.ltb_lt.
Qed.

Lemma Z_ltb_lt_quad (a b c d: Z):
  ((a <? b)%Z = (c <? d)%Z) <-> ((a < b)%Z <-> (c < d)%Z).
Proof.
apply relation_quad; apply Z.ltb_lt.
Qed.

Lemma N_leb_le_quad (a b c d: N):
  ((a <=? b)%N = (c <=? d)%N) <-> ((a <= b)%N <-> (c <= d)%N).
Proof.
apply relation_quad; apply N.leb_le.
Qed.

Lemma Z_leb_le_quad (a b c d: Z):
  ((a <=? b)%Z = (c <=? d)%Z) <-> ((a <= b)%Z <-> (c <= d)%Z).
Proof.
apply relation_quad; apply Z.leb_le.
Qed.

Lemma N2Z_ltb (n m: N):
  (n <? m)%N = (Z.of_N n <? Z.of_N m)%Z.
Proof.
apply (relation_quad N.ltb_lt Z.ltb_lt).
apply N2Z.inj_lt.
Qed.

Lemma N2Z_leb (n m: N):
  (n <=? m)%N = (Z.of_N n <=? Z.of_N m)%Z.
Proof.
apply (relation_quad N.leb_le Z.leb_le).
apply N2Z.inj_le.
Qed.

(**************************************************************************)

Lemma Z_shiftr_pow2 (n: Z) (B: (0 <= n)%Z):
  Z.shiftr (2 ^ n) n = 1%Z.
Proof.
rewrite (Z.shiftr_div_pow2 _ _ B).
apply Z.div_same.
now apply Z.pow_nonzero.
Qed.

Lemma Z_ltb_irrefl (n: Z):
  (n <? n)%Z = false.
Proof.
remember (n <? n)%Z as L.
destruct L; trivial.
symmetry in HeqL.
rewrite Z.ltb_lt in HeqL.
apply Z.lt_irrefl in HeqL.
contradiction.
Qed.

Lemma N_ltb_irrefl (n: N):
  (n <? n)%N = false.
Proof.
remember (n <? n)%N as L.
destruct L; trivial.
symmetry in HeqL.
rewrite N.ltb_lt in HeqL.
apply N.lt_irrefl in HeqL.
contradiction.
Qed.

(**************************************************************************)

Lemma Z_land_pow2_shift (n m: Z) (BM: (0 <= m)%Z):
  Z.land n (2 ^ m) = Z.shiftl (Z.land (Z.shiftr n m) 1) m.
Proof.
rewrite<- (Z_shiftr_pow2 m BM).
rewrite<- Z.shiftr_land.
rewrite<- (Z.ldiff_ones_r _ _ BM).
rewrite Z.ldiff_land.
rewrite<- Z.land_assoc.
f_equal.
apply Z.bits_inj'. intros k Bk.
rewrite Z.land_spec.
rewrite (Z.lnot_spec _ _ Bk).
rewrite (Z.testbit_ones _ _ BM).
rewrite (Z.pow2_bits_eqb _ _ BM).
rewrite<- Z.leb_le in Bk.
rewrite Bk.
rewrite Bool.andb_true_l.
remember (m =? k)%Z as MK. symmetry in HeqMK.
destruct MK.
{
  rewrite Z.eqb_eq in HeqMK. subst.
  now rewrite Z_ltb_irrefl.
}
trivial.
Qed.

Lemma Z_mul_pos_iff_l (n m: Z) (BM: (0 < m)%Z):
  (0 < n)%Z <-> (0 < n * m)%Z.
Proof.
split. { intro. apply Z.mul_pos_pos; assumption. }
apply (Z.mul_pos_cancel_r _ _ BM).
Qed.

Lemma Z_mul_pos_iff_r (n m: Z) (BN: (0 < n)%Z):
  (0 < m)%Z <-> (0 < n * m)%Z.
Proof.
split. { apply (Z.mul_pos_pos _ _ BN). }
apply (Z.mul_pos_cancel_l _ _ BN).
Qed.

Lemma Z_shiftl_pos_iff (n m: Z) (BM: (0 <= m)%Z):
 (0 < n)%Z <-> (0 < Z.shiftl n m)%Z.
Proof.
rewrite (Z.shiftl_mul_pow2 _ _ BM).
apply Z_mul_pos_iff_l.
apply Z.pow_pos_nonneg.
{ rewrite<- Z.ltb_lt. trivial. }
assumption.
Qed.

Lemma Z_odd_land_1 (n: Z) (B: (0 <= n)%Z):
  Z.odd n = (0 <? Z.land n 1)%Z.
Proof.
destruct n; now try destruct p.
Qed.

Lemma Z_testbit_alt (n m: Z) (BN: (0 <= n)%Z) (BM: (0 <= m)%Z):
  Z.testbit n m = (0 <? Z.land n (2 ^ m))%Z.
Proof.
rewrite (Z_land_pow2_shift _ _ BM).
assert (Q: forall x, ((0 <? Z.shiftl x m) = (0 <? x))%Z).
{
  intro x.
  rewrite Z_ltb_lt_quad.
  symmetry.
  apply Z_shiftl_pos_iff.
  assumption.
}
rewrite Q. clear Q.
rewrite Z.testbit_odd.
apply Z_odd_land_1.
apply Z.shiftr_nonneg.
assumption.
Qed.

Lemma Z_testbit_high (a n: Z)
                      (B: (0 <= n)%Z)
                      (A: (0 <= a < 2 ^ n)%Z):
  Z.testbit a n = false.
Proof.
rewrite<- (Z.mod_small a (2 ^ n)%Z A).
apply Z.mod_pow2_bits_high.
split. { assumption. }
apply Z.le_refl.
Qed.

(**************************************************************************)

Lemma Z_to_N_land (x y: Z) (BX: (0 <= x)%Z) (BY: (0 <= y)%Z):
  Z.to_N (Z.land x y) = N.land (Z.to_N x) (Z.to_N y).
Proof.
apply N.bits_inj. intro n.
rewrite N.land_spec.
remember (Z.of_N n) as m.
assert (NM: n = Z.to_N m).
{ subst m. symmetry. apply N2Z.id. }
repeat rewrite NM.
assert (BM: (0 <= m)%Z).
{ subst. apply N2Z.is_nonneg. }
repeat rewrite<- Z2N.inj_testbit; try assumption.
repeat rewrite Z2N.id; try assumption.
{ apply Z.land_spec. }
rewrite Z.land_nonneg. tauto.
Qed.

Lemma N_to_Z_land (x y: N):
  Z.of_N (N.land x y) = Z.land (Z.of_N x) (Z.of_N y).
Proof.
rewrite<- (Z2N.id (Z.land (Z.of_N x) (Z.of_N y))).
{
  f_equal.
  rewrite Z_to_N_land; try apply N2Z.is_nonneg.
  repeat rewrite N2Z.id.
  trivial.
}
apply Z.land_nonneg. left. apply N2Z.is_nonneg.
Qed.

Lemma Z_to_N_lor (x y: Z) (BX: (0 <= x)%Z) (BY: (0 <= y)%Z):
  Z.to_N (Z.lor x y) = N.lor (Z.to_N x) (Z.to_N y).
Proof.
apply N.bits_inj. intro n.
rewrite N.lor_spec.
remember (Z.of_N n) as m.
assert (NM: n = Z.to_N m).
{ subst m. symmetry. apply N2Z.id. }
repeat rewrite NM.
assert (BM: (0 <= m)%Z).
{ subst. apply N2Z.is_nonneg. }
repeat rewrite<- Z2N.inj_testbit; try assumption.
repeat rewrite Z2N.id; try assumption.
{ apply Z.lor_spec. }
rewrite Z.lor_nonneg. tauto.
Qed.

Lemma N_to_Z_lor (x y: N):
  Z.of_N (N.lor x y) = Z.lor (Z.of_N x) (Z.of_N y).
Proof.
rewrite<- (Z2N.id (Z.lor (Z.of_N x) (Z.of_N y))).
{
  f_equal.
  rewrite Z_to_N_lor; try apply N2Z.is_nonneg.
  repeat rewrite N2Z.id.
  trivial.
}
apply Z.lor_nonneg. split; apply N2Z.is_nonneg.
Qed.

Lemma Z_to_N_lxor (x y: Z) (BX: (0 <= x)%Z) (BY: (0 <= y)%Z):
  Z.to_N (Z.lxor x y) = N.lxor (Z.to_N x) (Z.to_N y).
Proof.
apply N.bits_inj. intro n.
rewrite N.lxor_spec.
remember (Z.of_N n) as m.
assert (NM: n = Z.to_N m).
{ subst m. symmetry. apply N2Z.id. }
repeat rewrite NM.
assert (BM: (0 <= m)%Z).
{ subst. apply N2Z.is_nonneg. }
repeat rewrite<- Z2N.inj_testbit; try assumption.
repeat rewrite Z2N.id; try assumption.
{ apply Z.lxor_spec. }
rewrite Z.lxor_nonneg. tauto.
Qed.

Lemma N_to_Z_lxor (x y: N):
  Z.of_N (N.lxor x y) = Z.lxor (Z.of_N x) (Z.of_N y).
Proof.
rewrite<- (Z2N.id (Z.lxor (Z.of_N x) (Z.of_N y))).
{
  f_equal.
  rewrite Z_to_N_lxor; try apply N2Z.is_nonneg.
  repeat rewrite N2Z.id.
  trivial.
}
apply Z.lxor_nonneg. split; intro; apply N2Z.is_nonneg.
Qed.

(**************************************************************************)

Lemma N_testbit_alt (n m: N):
  N.testbit n m = (0 <? N.land n (2 ^ m))%N.
Proof.
rewrite<- Z.testbit_of_N.
replace (0 <? N.land n (2 ^ m))%N with (0 <? Z.land (Z.of_N n) (2 ^ (Z.of_N m)))%Z.
2:{
  rewrite N2Z_ltb.
  rewrite N_to_Z_land.
  cbn.
  repeat f_equal.
  rewrite N2Z.inj_pow.
  trivial.
}
apply Z_testbit_alt; apply N2Z.is_nonneg.
Qed.

(**************************************************************************)

Definition N_0_lt_pow2 (n: N):
  (0 < 2 ^ n)%N.
Proof.
case (N.eq_0_gt_0_cases (2 ^ n)); intro; try assumption.
apply N.pow_nonzero in H. { contradiction. }
discriminate.
Qed.

Definition Z_0_lt_pow2 (n: Z) (B: (0 <= n)%Z):
  (0 < 2 ^ n)%Z.
Proof.
assert (A := N_0_lt_pow2 (Z.to_N n)).
apply N2Z.inj_lt in A.
rewrite N2Z.inj_pow in A.
cbn in A.
now rewrite Z2N.id in A.
Qed.

Lemma N_ne_0_gt_0 (n: N):
  n <> 0%N <-> (0 < n)%N.
Proof.
split; intro H.
{ assert (CN := N.eq_0_gt_0_cases n). tauto. }
destruct n. { now apply N.lt_irrefl in H. }
discriminate.
Qed.

Lemma N_div_0_r (n: N):
  (n / 0 = 0)%N.
Proof.
now destruct n.
Qed.

Lemma Z_div_0_r (n: Z):
  (n / 0 = 0)%Z.
Proof.
now destruct n.
Qed.

Lemma N_div_le (n: N) (d: N):
  (n / d <= n)%N.
Proof.
assert (CN := N.eq_0_gt_0_cases n).
assert (CD := N.eq_0_gt_0_cases d).
case CN; intro. { subst. cbn. apply N.le_refl. }
case CD; intro. { subst. rewrite N_div_0_r. now apply N.lt_le_incl. }
assert (D: N.succ (N.pred d) = d).
{ apply N.succ_pred_pos. assumption. }
remember (N.pred d) as k. clear Heqk. subst.
assert (CK := N.eq_0_gt_0_cases k).
case CK; intro. { subst. cbn. now rewrite N.div_1_r. }
apply N.lt_le_incl.
apply N.div_lt. { assumption. }
now apply N.lt_pred_lt_succ.
Qed.

Lemma Z_div_nonneg (a b: Z)
                    (A: (0 <= a)%Z)
                    (B: (0 <= b)%Z):
  (0 <= a / b)%Z.
Proof.
destruct b. { rewrite Zdiv_0_r. apply Z.le_refl. }
{ apply Z.div_pos; easy. }
easy.
Qed.

Lemma Z_abs_div_le (a b: Z):
  (Z.abs a / Z.abs b <= Z.abs a)%Z.
Proof.
assert(A := Z.abs_nonneg a).
assert(B := Z.abs_nonneg b).
apply Z2N.inj_le. { now apply Z_div_nonneg. }
{ assumption. }
rewrite Z2N.inj_div; try assumption.
apply N_div_le.
Qed.

Lemma Z_abs_sgn (a b: Z):
  Z.abs (Z.sgn a * b)%Z = match a with
                          | 0%Z => 0%Z
                          | _ => Z.abs b
                          end.
Proof.
now destruct a, b.
Qed.

Lemma Z_sgn_abs (a: Z):
  (Z.sgn a * Z.abs a)%Z = a.
Proof.
now destruct a.
Qed.

Lemma Z_add_nocarry_lor (a b: Z) (H: Z.land a b = 0%Z):
  (a + b = Z.lor a b)%Z.
Proof.
rewrite Z.add_nocarry_lxor by assumption.
apply Z.lxor_lor. assumption.
Qed.

Lemma Z_land_pow2_small (a b: Z) (A: (0 <= a < 2 ^ b)%Z) (B: (0 <= b)%Z):
  Z.land a (2 ^ b) = 0%Z.
Proof.
rewrite Arith2.Z_land_pow2_shift by tauto.
replace (Z.shiftr a b) with 0%Z. { cbn. apply Z.shiftl_0_l. }
rewrite Z.shiftr_div_pow2 by tauto.
symmetry. apply Z.div_small. exact A.
Qed.

Lemma Z_testbit_flag_mul_pow2 (f: bool) (k: Z) (K: (0 <= k)%Z):
  Z.testbit ((if f then 1 else 0) * 2 ^ k) k = f.
Proof.
destruct f.
{ rewrite Z.mul_1_l. apply Z.pow2_bits_true. assumption. }
rewrite Z.mul_0_l. apply Z.bits_0.
Qed.

(* A version of Z.bits_above_log2 with a different bound. *)
Lemma Z_testbit_small (a n: Z) (A: (0 <= a)%Z)
                               (B: (a < 2 ^ n)%Z):
  Z.testbit a n = false.
Proof.
destruct a. { apply Z.testbit_0_l. }
{ apply Z.bits_above_log2. trivial. now apply Z.log2_lt_pow2. }
exfalso. rewrite<- Z.leb_le in A. cbn in A. discriminate.
Qed.

(**************************************************************************)

Lemma Z_pos_ne_0 (a: positive):
  Z.pos a <> 0%Z.
Proof.
discriminate.
Qed.

Lemma Z_0_lt_pos (a: positive):
  (0 < Z.pos a)%Z.
Proof.
rewrite<- Z.ltb_lt.
trivial.
Qed.

Lemma Z_ceiling_via_floor (a b: Z) (B: (0 <= b)%Z):
  (- ((- a) / b) = (a + b - 1) / b)%Z.
Proof.
destruct b as [|b|b]. { now repeat rewrite Z_div_0_r. }
{
  assert (D := Z.div_mod (-a) (Z.pos b) (Z_pos_ne_0 b)).
  assert (E := Z.div_mod (a + Z.pos b - 1) (Z.pos b) (Z_pos_ne_0 b)).
  assert (P := Z.mod_pos_bound (-a) (Z.pos b) (Z_0_lt_pos b)).
  assert (Q := Z.mod_pos_bound (a + Z.pos b - 1) (Z.pos b) (Z_0_lt_pos b)).
  nia.
}
rewrite<- Z.leb_le in B. discriminate.
Qed.

(**************************************************************************)

Lemma Z_land_lxor_distr_l (a b c: Z):
  Z.land (Z.lxor a b) c = Z.lxor (Z.land a c) (Z.land b c).
Proof.
apply Z.bits_inj. intro.
repeat (rewrite Z.land_spec || rewrite Z.lxor_spec).
destruct (Z.testbit a n); destruct (Z.testbit b n); destruct (Z.testbit c n); easy.
Qed.

Lemma Z_land_lxor_distr_r (a b c: Z):
  Z.land a (Z.lxor b c) = Z.lxor (Z.land a b) (Z.land a c).
Proof.
apply Z.bits_inj. intro.
repeat (rewrite Z.land_spec || rewrite Z.lxor_spec).
destruct (Z.testbit a n); destruct (Z.testbit b n); destruct (Z.testbit c n); easy.
Qed.

(**************************************************************************)

(* This is a version of Z.log2_lt_pow2 but a can be 0 and b cannot. *)
Lemma Z_log2_lt_pow2 (a b: Z) (BA: (0 <= a)%Z) (BB: (0 < b)%Z):
    (a < 2 ^ b <-> Z.log2 a < b)%Z.
Proof.
destruct a.
{
  cbn. assert (P: (0 < 2 ^ b)%Z). apply Z_0_lt_pow2. { apply Z.lt_le_incl. assumption. }
  tauto.
}
{ apply Z.log2_lt_pow2. rewrite<- Z.ltb_lt. trivial. }
rewrite<- Z.leb_le in BA. discriminate.
Qed.

(**************************************************************************)

Lemma Z_mod_add_l (a b c m: Z)
                  (H: (b mod m = c mod m)%Z):
  ((a + b) mod m = (a + c) mod m)%Z.
Proof.
rewrite<- (Zplus_mod_idemp_r b a).
rewrite<- (Zplus_mod_idemp_r c a).
rewrite H.
trivial.
Qed.

Lemma Z_mod_add_r (a b c m: Z)
                  (H: (a mod m = b mod m)%Z):
  ((a + c) mod m = (b + c) mod m)%Z.
Proof.
rewrite<- (Zplus_mod_idemp_l a c).
rewrite<- (Zplus_mod_idemp_l b c).
rewrite H.
trivial.
Qed.

(**************************************************************************)

Lemma Nat2N_inj_div (a b: nat):
  N.of_nat (a / b) = (N.of_nat a / N.of_nat b)%N.
Proof.
destruct b. { cbn. now rewrite N_div_0_r. }
assert (BNZ: S b <> 0) by discriminate.
assert (D := Nat.div_mod a (S b) BNZ).
remember (a / S b) as q.
remember (a mod S b) as r.
apply N.div_unique with (r := N.of_nat r).
{
  unfold N.lt.
  rewrite<- Nat2N.inj_compare.
  apply Nat.compare_lt_iff.
  subst. apply (Nat.mod_upper_bound _ _ BNZ).
}
rewrite<- Nat2N.inj_mul.
rewrite<- Nat2N.inj_add.
now rewrite D.
Qed.

Lemma Nat2N_inj_mod (a b: nat) (ok: b <> 0):
  N.of_nat (a mod b) = (N.of_nat a mod N.of_nat b)%N.
Proof.
destruct b. { contradiction. }
rewrite Nat.mod_eq by discriminate.
rewrite Nat2N.inj_sub.
rewrite Nat2N.inj_mul.
rewrite Nat2N_inj_div.
symmetry. apply N.mod_eq.
discriminate.
Qed.

(**************************************************************************)
(** This is a strenghtening of Pos.size_nat_monotone from [p < q] to [p <= q]. *)
Lemma Pos_size_nat_monotone (p q: positive) (LE: (p <= q)%positive):
  (Pos.size_nat p <= Pos.size_nat q)%nat.
Proof.
remember (Pos.compare p q) as cmp. symmetry in Heqcmp. destruct cmp.
{ apply Pos.compare_eq in Heqcmp. subst. apply Nat.le_refl. }
{ apply Pos.size_nat_monotone. exact Heqcmp. }
contradiction.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural :=
  plus lf1 x.


(* Library for Finite Sets *)
Require Import List Basics.

Definition set := list.

Fixpoint subset {A} (l : list A) (m: list A) : Prop := match l with
  | nil => True
  | cons x xs => In x m /\ subset xs m
  end.

Definition subset' {A} (l m : list A) : Prop := forall a, In a l -> In a m.


Require Import Coq.Setoids.Setoid.
Require Import New.Ring.

Lemma add_zero_left {A}
  {srops : SemiRingOps A}
  {sra : SemiRingNoAssoc A} :
    forall a : A, 0 + a = a.
Proof.
  intro.
  rewrite add_comm.
  apply add_zero_right.
Qed.

Lemma mul_zero_left {A}
  {srops : SemiRingOps A}
  {sra : SemiRingNoAssoc A} :
    forall a : A, 0 * a = 0.
Proof.
  intro.
  rewrite mul_comm.
  apply mul_zero_right.
Qed.

Lemma mul_one_left {A}
  {srops : SemiRingOps A}
  {sra : SemiRingNoAssoc A} :
    forall a : A, 1 * a = a.
Proof.
  intro.
  rewrite mul_comm.
  apply mul_one_right.
Qed.

Lemma neg_inv {A}
  {rops : RingOps A}
  {ra : Ring A} :
    forall a : A, - -a = a.
Proof.
  intro.
  rewrite <- add_zero_right at 1.
  rewrite <- (sub_zero a).
  rewrite sub_def.
  rewrite add_comm.
  rewrite <- add_assoc.
  rewrite <- sub_def.
  rewrite sub_zero.
  apply add_zero_right.
Qed.

Lemma zero_self_inv {A} {rops : RingOps A} {rna : RingNoAssoc A} : -0 = 0.
Proof.
  rewrite <- add_zero_right at 1.
  rewrite add_comm.
  rewrite <- sub_def.
  apply sub_zero.
Qed.

Lemma neg_sub {A} {rops : RingOps A} {rna : RingNoAssoc A} :
  forall a b : A, -(a - b) = (-a) - (-b).
Proof.
  intros.
  rewrite 2 sub_def.
  apply neg_add.
Qed.

Lemma sub_mul_dist {A} {rops : RingOps A} {rna : RingNoAssoc A} :
  forall a b c : A, a * (b - c) = (a * b) - (a * c).
Proof.
  intros.
  rewrite 2! sub_def.
  rewrite add_mul_dist.
  rewrite neg_mul.
  reflexivity.
Qed.

Lemma add_mul_dist_right {A} {srops : SemiRingOps A} {sra : SemiRingNoAssoc A} :
  forall a b c : A, (b + c) * a = (b * a) + (c * a).
Proof.
  intros.
  rewrite mul_comm at 1.
  rewrite add_mul_dist.
  f_equal.
  apply mul_comm.
  apply mul_comm.
Qed.

Lemma sub_mul_dist_right {A} {srops : RingOps A} {sra : RingNoAssoc A} :
  forall a b c : A, (b - c) * a = (b * a) - (c * a).
Proof.
  intros.
  rewrite mul_comm at 1.
  rewrite sub_mul_dist.
  f_equal.
  apply mul_comm.
  apply mul_comm.
Qed.

Lemma neg_mul_left {A} {srops : RingOps A} {sra : RingNoAssoc A} :
  forall a b : A, -(a * b) = (-a) * b.
Proof.
  intros.
  rewrite mul_comm.
  rewrite neg_mul.
  apply mul_comm.
Qed.


(** * 超絶技巧演習問題 - Coq *)

Require Import Coq.Init.Prelude Coq.Init.Nat.

Open Scope nat_scope.

(** フェルマーの最終定理 *)

Definition felmat
  : forall n : nat, 2 < n -> ~ exists x y z, 0 < x /\ 0 < y /\ 0 < z /\ x ^ n + y ^ n = z ^ n.
Proof.
  (* [Admitted] を [Qed] に取り換えて、この空欄を埋めよ *)
Admitted.

(** カタラン予想 *)

Definition catalanic a b x y := 1 < a /\ 1 < b /\ 1 < x /\ 1 < y /\ x ^ a = 1 + y ^ b.

Definition catalan
  : forall a b x y, catalanic a b x y -> x = 3 /\ a = 2 /\ y = 2 /\ b = 3.
Proof.
  (* [Admitted] を [Qed] に取り換えて、この空欄を埋めよ *)
Admitted.

(** バウデットの予想 *)
Definition baudetic (P : nat -> bool) a b c n := forall p, p < n -> P (a + b * p) = c.

Definition baudet
  : forall P, exists c, forall n, exists a b, baudetic P a b c n.
Proof.
  (* [Admitted] を [Qed] に取り換えて、この空欄を埋めよ *)
Admitted.

(** コラッツの問題 *)
Definition collatzic n := if even n then div2 n else n * 3 + 1.

Definition collatz
  : forall n, n <> 0 -> exists p, iter p collatzic n = 1.
Proof.
  (* [Admitted] を [Qed] に取り換えて、この空欄を埋めよ *)
Admitted.


(**
call/ccと古典論理
======
2015/08/22

@suharahiromichi

# はじめに

継続は古典論理との意味をもって語られることが多いけれど、
実は ``call/cc`` の型（p型を返すとする）、
``((p→void)→p)→p`` が、Curry-Howard同型から、
``forall P, ((P -> False) -> P) -> P)`` という論理式にみなせる、
ということだ（からだとおもう）。

それがどうして古典論理と関係するかというと、
この論理式と排中律や二重否定除去定理が同値だからである。

ここでは、実際にその証明をしてみたい。

証明はSSReflectを使うが、あまり省略しないようにした。
*)

Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq.
Set Implicit Arguments.
Unset Strict Implicit.

(**
``call/cc``と排中律が同値であるこを証明する。
 *)
Goal (forall (P : Prop), ((P -> False) -> P) -> P) <->
(forall (P : Prop), P \/ ~P).
Proof.
  split.
  - move=> Callcc P.
    apply: (Callcc (P \/ ~P)).
    move=> H.
    right=> H1.
    apply: H.
    left.
    by apply: H1.
  - move=> Em P.
    case: (Em P)=> HP H1.
    + by apply: HP.
    + apply: H1.
      by apply: HP.
Qed.

(**
``call/cc``と二重否定除去が同値であることを証明する。
 *)
Goal (forall (P : Prop), ((P -> False) -> P) -> P) <->
(forall (P : Prop), ~ ~ P -> P).
Proof.
  split.
  - move=> Callcc P.
    apply: Callcc => H1 H2.
    exfalso.
    apply: H2 => HP.
    apply: H1 => H3.
    by apply: HP.
  - move=> Dn P H1.
    apply: (Dn P) => HnP.
    apply HnP.
    apply H1 => HP.
    apply HnP.
    by apply HP.
Qed.

(**
``call/cc``とパースの論理式が同値であるこを証明する。
 *)
Goal (forall (P : Prop), ((P -> False) -> P) -> P) <->
(forall (P Q : Prop), ((P -> Q) -> P) -> P).
Proof.
  split.
  - move=> Callcc P Q H1.
    apply: Callcc => H2.
    apply: H1 => HP.
    exfalso.
    apply: H2.
    by apply: HP.
  - move=> Pe P.
    by apply (Pe P False).
Qed.

(* END *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (x : natural) (y : natural) (lf2 : natural)
  : natural := plus (Succ Zero) y.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint plus (plus_arg0 : Nat) (plus_arg1 : Nat) : Nat
           := match plus_arg0, plus_arg1 with
              | zero, n => n
              | succ n, m => succ (plus n m)
              end.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint len (len_arg0 : Lst) : Nat
           := match len_arg0 with
              | nil => zero
              | cons x y => succ (len y)
              end.

(* No helper lemma required *)
Theorem theorem0 : forall (x : Lst) (y : Lst), eq (len (append x y)) (plus (len x) (len y)).
Proof.
  intros. induction x.
  - simpl. rewrite IHx. reflexivity.
  - reflexivity.
Qed.


(** * ProofObjects (Объекты-Доказательства): Соответствие Curry-Howard *)

(** "_Алгоритмы это вычислитльное содержание доказательств_."  --Robert Harper *)

Require Export IndProp.

(** Мы видели, Coq механизмы для _программировния_, используящие
    индуктивные типы данных вроде [nat] или [list] и функций над этими
    типами, а для _доказательства_ свойств этих программ, использования
    индуктивных пропозиции (вроде [ev]), импликации, кванторов универсальности
    , и другие. До сих пор, мы в основном использовали эти механизмы
    так будто они довольно различны, и для многих целей это хороший
    способ смотреть на вещи. Но мы также видели признаки того, что
    программирование и доказательство в Coq тесно связаны.
    Например, ключевое слово [Inductive] было использовано как для
    декларирования типов, так и пропозиций. [->] используется как
    для описания типа функций на данных, так и логическую импликацию.
    Это не просто синтаксическое совпадение! На самом деле, программы
    и доказательства в Coq практически одно и тоже. В этой главе
    мы изучим как это работает.

    Мы уже увидели фундаментальную идею: доказуемость в Coq
    представляется через конкретное _свидетельство_.  Когда
    мы строим доказательство базовой пропозиции, мы на самом деле
    строим дерево свидетельства, которое может быть рассмотренно
    как структура данных.

    Если пропозиция есть импликация вроде [A -> B], тогда его доказательством
    будет _трансформер_ свидетельств: рецепт для конвертации свидетельства
    A в свидетельство для B. Таким образом, на фундаментальном уровне,
    доказательства это просто программы для манипулирования свидетельствами. *)

(** Вопрос: Если свидетельство есть данные, чем тогда являются сами пропозиции?

    Ответы: Они являются типами!

    Взгляните снова на формальное определение свойства [ev].  *)

Print ev.
(* ==>
  Inductive ev : nat -> Prop :=
    | ev_0 : ev 0
    | ev_SS : forall n, ev n -> ev (S (S n)).
*)

(** Предположим, что мы ввели альтернативное произношение для "[:]".
    Вместо "имеет тип", мы говорим "есть доказательство для". Например,
    вторая строчка в определении [ev] декларирует что [ev_0 : ev
    0].  Вместо "[ev_0] имеет тип [ev 0]," мы можем сказать что "[ev_0]
    есть доказательство для [ev 0]." *)

(** Такое отношение между типами и пропозициями -- [:] как "имеет тип"
    и [:] как "доказательство для" или "свидетельство для" -- называется
    _соответствием Curry-Howard_. Оно предлагает глубокую связь
    между миром логики и миром вычислений:

                 пропозиции            ~  типы
                 доказательства        ~  значения данных

    Смотрите [Wadler 2015] для короткой истории и современной экспозиции.

    Многие полезные идеи следуют из данной связи. Для начала, она
    дает естественную интерпретацию типа для конструктора [ev_SS]: *)

Check ev_SS.
(* ===> ev_SS : forall n,
                  ev n ->
                  ev (S (S n)) *)

(** Оно может быть прочтено как "[ev_SS] есть конструктор, который
    берет два аргумента -- число [n] и свидетельство для пропозиции [ev
    n] -- а затем производит свидетельство для пропозиции [ev (S (S n))]." *)

(** Теперь давайте снова взглянем на предыдущее доказательство использующее
    [ev]. *)

Theorem ev_4 : ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

(** Как и в случае обычных значений данных и функций, мы можем использовать
    команду [Print] для того чтобы увидеть _объект доказательство_ получаемый
    из данного скрипта доказательства. *)

Print ev_4.
(* ===> ev_4 = ev_SS 2 (ev_SS 0 ev_0)
     : ev 4  *)

(** Более того, мы также можем записать данный объект доказательства
    _напрямую_, без необходимости для отдельного скрипта докозательства: *)

Check (ev_SS 2 (ev_SS 0 ev_0)).
(* ===> ev 4 *)

(** Выраэение [ev_SS 2 (ev_SS 0 ev_0)] может быть рассмотренно как
    инстанциация параметризованного конструктора [ev_SS] со специфическими
    аргументами [2] и [0] плюс соответствующими объектами доказательств
    для предпосылок [ev 2] и [ev 0].  Альтернативно, мы можем думать
    о [ev_SS] как о примитивном "конструкторе свидетельств", который
    будучи применен к заданному числу, хочет в дальнейшем быть применен
    к свидетельству того, что данное число четно; его тип,

      forall n, ev n -> ev (S (S n)),

    выражает эту функциональнсть, таким же способом полиморфный тип
    [forall X, list X] выражает факт того, что конструктор
    [nil] может быть задуман как функция из типов в пустые списки
    с элементами этих типов. *)

(** Вы можете вспомнить (как было показано в главе [Logic]) что можно
    использовать синтаксис применения функции для инстанциации
    переменных за кванторами всеобщности в леммах, а также предоставлять
    свидетельство для тех предположений, что леммы требуют. Например: *)

Theorem ev_4': ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

(** Мы теперь можем увидеть, что данное свойство есть тривиальное
    следствия статуса который Coq предоставляют доказательствам и пропозициям:
    Леммы и гипотезы могут быть объединены в выражениях (т.е.
    объекты доказательств) следуя тем же основным правилам что
    используются для программ. *)

(* ################################################################# *)
(** * Скрипты Доказательств *)

(** _Объекты доказательств_ которые мы обсуждали лежат в основе
    того как работает Coq. Когда Coq следует скрипту доказательства,
    внутри него последовательно строится объект доказательства -- терм
    чьим типом является доказуемая пропозиция. Тактики между
    [Proof] и [Qed] указывают как построить терм требуемого типа. Чтобы
    увидеть данный процесс в действии, используем команду
    [Show Proof] для демонстрации текущего состояния дерева
    доказательства в различных точках следующего доказательства
    тактиками. *)

Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

(** В каждый заданный момент, Coq построил терм с некоторыми
    "пропусками" (указанымми с помощью [?1], [?2], и так далее), и он знает
    какой тип свидетельства требуется для каждого пропуска.  *)

(** Каждый из пропусков соответствует подцели, и доказательство завершенно
    когда больше нет подцелей. В этой точке, свидетельство, что мы
    построили, хранится в глобальном контексте под именем заданным
    командой [Theorem]. *)

(** Доказательство тактиками полезно и удобно, но оно не обязательно:
    в принципе, мы всегда можем построить требуемое свидетельство
    руками, как показано сверху. Затем мы можем использовать [Definition]
    (вместо [Theorem]) для задания глобального имени напрямую для
    построенного свидетельства. *)

Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

(** Все эти различные пути построения доказательств приводят точно к
    тем же самым свидетельствам сохраненным в глобальном окружении. *)

Print ev_4.
(* ===> ev_4    =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'.
(* ===> ev_4'   =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4''.
(* ===> ev_4''  =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'''.
(* ===> ev_4''' =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)

(** **** Упражнение: 1 звездочка (eight_is_even)  *)
(** Задайте доказательство тактиками, а также объект доказательства того
    что [ev 8]. *)

Theorem ev_8 : ev 8.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *) Admitted.

Definition ev_8' : ev 8
  (* ЗАМЕНИТЕ ДАННУЮ СТРОКУ НА  := _ваше_определение_ . *) . Admitted.
(** [] *)

(* ################################################################# *)
(** * Кванторы, Импликации, Функции *)

(** В вычислительной вселенной Coq (где обитают структуры данных и программы
    ), есть два вида значений со стрелками в своих типах: _конструкторы_ вводимые
    типами определенными через [Inductive], и _функции_.

    Аналогично, в логической вселенной Coq (в которой мы производим доказательства),
    есть два способа предоставить свидетелюство для импликации:
    конструкторы введеные [Inductive]-но определенными пропозициями,
    и... функции!

    Например, рассмотрим следующее утверждение: *)

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

(** Что является объектом доказательства соответствующим [ev_plus4]?

    Мы ищем выражение чьим _типом_ было бы [forall n, ev n ->
    ev (4 + n)] -- т.е., _функция_ которая берет два аргумента (одно
    число и свидететельство) и возвращает также свидетельство!
    Вот она: *)

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4'.
(* ===> ev_plus4' : forall n : nat, ev n -> ev (4 + n) *)

(** Вспомните что [fun n => blah] означает "функция которая, имея [n],
    производит [blah]," и Coq рассматривает [4 + n] и [S (S (S (S n)))]
    как синонимы. Другой эквивалентный способ записать данное определение: *)

Definition ev_plus4'' (n : nat) (H : ev n) : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.
(* ===> ev_plus4'' : forall n : nat, ev n -> ev (4 + n) *)

(** Когда мы рассматриваем пропозицию, доказуемою через [ev_plus4] кк
    тип функции, один аспект может показаться необычным. Тип
    второго аргумента, [ev n], упоминает _значение_ первого аргумента
    [n]. Хотя такие _зависимые типы_ не встречаются в обычных языках
    программирования, они также могут быть полезны в программировании,
    как это показывает последнии достижения в сообществе
    функционального программирования.

    Заметьте, что как импликация ([->]) так и кванторы всеобщности ([forall])
    соответствуют функциям на свидетельства. На самом деле, они представляют
    из себя одно и тоже: [->] есть просто сокращение для вырожденного случая
    применения [forall], когда зависимость отсутствует, т.е. нет необходимости
    предоставлять имя типу в левой стороне стрелки. *)

(** Например, рассмотрим следующую пропозицию: *)

Definition ev_plus2 : Prop :=
  forall n, forall (E : ev n), ev (n + 2).

(** Терм доказательства населяющий данную пропозицию будет функцией от
    двух аргументов: числа [n] и некоторого свидетельства [E] того, что [n]
    четно. Но имя [E] для этого свидетельства не использовано в дальнейшем
    нигде в выражении [ev_plus2], таким образом немного глупо придумывать
    ему имя. Мы могли бы вместо этого записать все следующим образом,
    используя пропуск [_] вместо настощего имени: *)

Definition ev_plus2' : Prop :=
  forall n, forall (_ : ev n), ev (n + 2).

(** Или, эквивалентно, мы можем записать его в более знакомой нотации: *)

Definition ev_plus2'' : Prop :=
  forall n, ev n -> ev (n + 2).

(** В целом, "[P -> Q]" есть просто синтаксический сахар для
    "[forall (_:P), Q]". *)

(* ################################################################# *)
(** * Связки как Индуктивные Типы *)

(** Индуктивные определения достаточно мощны чтобы выразить большинство
    связок и кванторов, что мы уже видели. Действительно, только
    квантор всеобщности (и таким образом импликация) встроенны Coq;
    все остальные определены индуктивно. Мы изучим эти определения
    в данной секции. *)

Module Props.

(** ** Конъюкция

    Чтобы доказать что [P /\ Q] справедливо, мы должны предоставить
    свидетельство как для [P], так и для [Q]. Таким образом, имеет
    смысл определить объект доказательства для [P/\ Q] как состоящего
    из пары двух доказательств: одного для [P] и другого
    для [Q]. Это приводит к следующему определению. *)

Module And.

Inductive and (P Q : Prop) : Prop :=
| conj : P -> Q -> and P Q.

End And.

(** Заметьте сходство с определением типа [prod], предоставленного
    в главе [Poly]; единственная разница лишь в том, что [prod] принимает
    [Type] аргументы, когда [and] принимает [Prop] аргументы. *)

Print prod.
(* ===>
   Inductive prod (X Y : Type) : Type :=
   | pair : X -> Y -> X * Y. *)

(** Это должно прояснить, почему мы паттерны [destruct] и [intros] могут
    быть использованы на конъюктивных гипотезах.  Анализ случаев позволяет
    нам рассмотреть все возможные пути, которыми можно доказать [P /\ Q] --
    здесь всего лишь один (конструктор [conj]).  Аналогично, тактика [split]
    на самом деле работает для любой индуктивно определенной пропозиции
    с только одним конструктором. В частности, она работает для [and]: *)

Lemma and_comm : forall P Q : Prop, P /\ Q <-> Q /\ P.
Proof.
  intros P Q. split.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
Qed.

(** Это показывает почему индуктивное определение [and] может быть
    манипулировано тактиками как мы и делали. Мы также можем использовать
    его для построения доказательств напрямуп, используя паттерн матчинг.
    Например: *)

Definition and_comm'_aux P Q (H : P /\ Q) :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q : P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

(** **** Упражнение: 2 звездочки, дополнительное (conj_fact)  *)
(** Посторйте объект доказательства демонстрирующий следующую пропозицию. *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R
  (* ЗАМЕНИТЕ ДАННУЮ СТРОКУ НА   := _ваше определение_ . *). Admitted.
(** [] *)

(** ** Дизъюнкция

    Индуктивное определение дизъюнкции использует два конструктора, два для
    каждой части: *)

Module Or.

Inductive or (P Q : Prop) : Prop :=
| or_introl : P -> or P Q
| or_intror : Q -> or P Q.

End Or.

(** Данная декларация объясняет поведение тактики [destruct] на
    дизъюнктивной гипотезе, так как сгенерированные подцели соответствуют
    форме конструкторов [or_introl] и [or_intror].

    Опять же, мы можем также напрямую записать объекты доказательств для
    теорем включающих [or], без обращения к тактикам. *)

(** **** Упражнение: 2 звездочки, дополнительное (or_commut'')  *)
(** Попробуйте записать явный объект доказательства для [or_commut] (без применения
   [Print] чтобы увидеть уже готовое!). *)

Definition or_comm : forall P Q, P \/ Q -> Q \/ P
(* ЗАМЕНИТЕ ЭТУ СТРОКУ НА   := _ваше определение_ . *). Admitted.
(** [] *)

(** ** Квантор Существования

    Для предоставления доказательства в случае квантора существования, мы
    упаковываем свидетельство [x] вместе с доказательством того что [x] удовлетворяет
    свойству [P]: *)

Module Ex.

Inductive ex {A : Type} (P : A -> Prop) : Prop :=
| ex_intro : forall x : A, P x -> ex P.

End Ex.

(** Это стоило бы немного разъяснить. Основа определения состоит в
    формирующем тип [ex] которое может быть использовано для построения
    пропозиций в форме [ex P], где [P] само по себе есть _функция_ из
    значений свидетельства типа [A] в пропозиции. Конструктор [ex_intro]
    таким образом предоставляет способ построения доказательства для [ex P],
    имея свидетельство [x] и доказательство [P x].

    Более знакомая форма [exists x, P x] есть синтаксический сахар для
    выражения включающего [ex]: *)

Check ex (fun n => ev n).
(* ===> exists n : nat, ev n
        : Prop *)

(** Вот пример того как определять явно объект доказательства включающий [ex]: *)

Definition some_nat_is_even : exists n, ev n :=
  ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

(** **** Упражнение: 2 звездочки, дополнительное (ex_ev_Sn)  *)
(** Завершите определение следующего объекта доказательства: *)

Definition ex_ev_Sn : ex (fun n => ev (S n))
  (* ЗАМЕНИТЕ ДАННУЮ СТРОКУ НА   := _ваше определение_ . *). Admitted.
(** [] *)

(* ================================================================= *)
(** ** [True] и [False] *)

(** Индуктивное определение пропозиции [True] просто: *)

Inductive True : Prop :=
  I : True.

(** Оно имеет один конструктор (так что все доказательства [True] одинаковы,
    так что иметь доказательство [True] не очень информативно.) *)

(** [False] аналогично прост -- действительно, настолько просто, что может
    показаться синктаксически неверным на первый взгляд! *)

Inductive False : Prop :=.

(** И да, [False] является индуктивным типом _без_ конструкторов --
    т.е., не существует способа построить его доказательства. *)

End Props.

(* ################################################################# *)
(** * Программирование с Тактиками *)

(** Если мы может строить доказательства преоставляя явные термы, вместо
    запуска скриптов с тактиками, то можно спросить а можем ли
    мы строить _программы_ используя _тактики_ вместо явных термов.
    Естественно, ответ положителен! *)

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : nat => S n
         : nat -> nat
*)

Compute add1 2.
(* ==> 3 : nat *)

(** Заметьте, что мы завершили [Definition] используя [.] вместо
    [:=] с последующим термом. Это говорит Coq зйати в режим _скрипта
    доказательства_ для построения объекта типа [nat -> nat]. Также, мы
    завершаем доказательство с [Defined] вместо [Qed]; это делает определение
    _прозрачным_ так что оно может быть использовано в вычислениях как
    и нормально определенная функция.  ([Qed]-определенные объекты не
    прозрачны для вычислений.)

    Данное свойство в основном полезно для написания функция с
    зависимыми типами, которые мы не будем особенно затрагивать
    в данной книге. Но оно иллюстрирует всеобщность и
    ортогональность основных идей в Coq. *)

(* ################################################################# *)
(** * Равенство *)

(** Даже отношение равенства не встроено в Coq.  Оно имеет следующее
    индуктивное определение.  (На самом деле, определение в стандарной
    библиотеке есть небольшая вариация его, котораое предоставляет
    принцип индукции слегка более удобный для применения.) *)

Module MyEquality.

Inductive eq {X:Type} : X -> X -> Prop :=
| eq_refl : forall x, eq x x.

Notation "x = y" := (eq x y)
                    (at level 70, no associativity)
                    : type_scope.

(** Способ которым нужно думать о данном определении следующий, имея множество
    [X], оно определяет _семейство_ пропозиций "[x] равно [y]," индексированных
    парами значений ([x] и [y]) из [X]. Существует лишь один способ
    предоставления свидетельства для каждого члена этого семейства:
    применяя конструктор [eq_refl] к типу [X] и значению [x :
    X] что производит доказательство того, что [x] равно [x]. *)

(** **** Упражнение: 2 звездочки (leibniz_equality)  *)
(** Индуктивное определение равенства соответствует _равенству по
    Лейбницу_: под "[x] и [y] равны" мы понимаем, что каждое свойство [P]
    справедливое для [x] также справедливо для
    [y].  *)

Lemma leibniz_equality : forall (X : Type) (x y: X),
  x = y -> forall P:X->Prop, P x -> P y.
Proof.
  (* ЗАПОЛНИТЕ ЗДЕСЬ *)
Admitted.
(** [] *)

(** Мы можем использовать [eq_refl] для построения доказательства что,
    например, [2 = 2]. Можем ли мы также использовать его для построения
    доказательства того что [1 + 1 = 2]? Да, мы можем. Действительно,
    это тоже самое доказательство! Причина, по которой Coq принимает тоже
    доказательство в том что он счичает "одинаковыми" любые два терма которые
    _взаимно конвертируемы_ согласно простому набору вычислительных правил.
    Эти правила, которые похожи на те что используются [Compute], включают
    вычисления применения функции, раскрытие определений, и упрощение [match]ей.  *)

Lemma four: 2 + 2 = 1 + 3.
Proof.
  apply eq_refl.
Qed.

(** Тактика [reflexivity] которая была использована для доказательства
    равенств до сих пор есть просто сокращение для [apply refl_equal].

    В доказательствах равенств основанных на тактиках, правила конвертации
    обычно скрыты в использованиях [simpl] (либо явно, либо неявно
    в других тактиках как [reflexivity]). Но бы можете увидеть их
    напрямую в работе в следующих явных объектах доказательств: *)

Definition four' : 2 + 2 = 1 + 3 :=
  eq_refl 4.

Definition singleton : forall (X:Set) (x:X), []++[x] = x::[]  :=
  fun (X:Set) (x:X) => eq_refl [x].

End MyEquality.

Definition quiz6 : exists x,  x + 3 = 4
  := ex_intro (fun z => (z + 3 = 4)) 1 (refl_equal 4).

(* ================================================================= *)
(** ** Инверсия, Снова *)

(** Мы видели применение [inversion] как в случае равенства, так и в случае
    индуктивно определенных пропозиций. Теперь, когда мы увидели, что это
    теже самые вещи, мы можем более детально изучить как ведет себя [inversion].

    В целом, тактика [inversion]...

    - берет гипотезу [H] чей тип [P] индуктивно определен и

    - для каждого конструктора [C] в определении [P],

      - генерирует новую подцель, в которой предполагает что [H] было
        посторено с [C],

      - добавляет аргументы (предпосылки) для [C] в контекст подцели как
        дополнительные гипотезы,

      - сравнивает заключение (тип результата) [C] с текущей целью
        и вычисляет множество равенств которые должны иметь место
        для того чтобы [C] было применимо,

      - добавляет данные равенства в контекст (и, для удобства
        переписывает их в цели), и

      - если равенства не могут быть удовлетворены (т.е., они включают
        вещи вроде [S n = O]), сразу разрешает подцель. *)

(** _Пример_: Если мы инвертируем гипотезу построенную с помощью [or],
   то есть два конструктора, так что генерируются две подцели. Заключение
   (окончательный тип) конструктора ([P \/ Q]) не ставит никаких ограничений
   на форму [P] или [Q], так что мы не получаем дополнительных равенств
   в контексте подцелей.

   _Example_: If we invert a hypothesis built with [and], there is
   only one constructor, so only one subgoal gets generated.  Again,
   the conclusion (result type) of the constructor ([P /\ Q]) doesn't
   place any restrictions on the form of [P] or [Q], so we don't get
   any extra equalities in the context of the subgoal.  The
   constructor does have two arguments, though, and these can be seen
   in the context in the subgoal.

   _Пример_: Если мы инвертируем гипотезу постронную с [eq], то у нас
   опять всего лишь один конструктор, так что генерируется лишь одна подцель.
   Теперь, форма конструктора [refl_equal] предоставляет нам дополнительную
   информацию: она говорит нам что два аргумента [eq] должны быть одним и
   тем же!  Тактика [inversion] добавлает данный факт в контекст. *)

(** $Date: 2016-07-14 17:02:35 -0400 (Thu, 14 Jul 2016) $ *)


(*|
##############################
Induction principle for ``le``
##############################

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

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

For the inductive type ``nat``, the generated induction principle uses
the constructors ``O`` and ``S`` in its statement:
|*)

Print nat. (* .unfold .no-in *)
Check nat_ind. (* .unfold .no-in *)

(*|
But for ``le``, the generated statement does not uses the constructors
``le_n`` and ``le_S``:
|*)

Print le. (* .unfold .no-in *)
Check le_ind. (* .unfold .no-in *)

(*|
However it is possible to state and prove an induction principle
following the same shape as the one for ``nat``:
|*)

Lemma le_ind' : forall n (P : forall m, le n m -> Prop),
    P n (le_n n) ->
    (forall m (p : le n m), P m p -> P (S m) (le_S n m p)) ->
    forall m (p : le n m), P m p.
Proof.
  fix H 6. intros. destruct p.
  - apply H0.
  - apply H1, H. apply H0. apply H1.
Qed.

(*|
I guess the generated one is more convenient. But how does Coq chooses
the shape for its generated induction principle? If there is any rule,
I cannot find them in the reference manual. What about other proof
assistants such as Agda?
|*)

(*|
Answer
******

You can manually generate an induction principle for an inductive type
by using the command ``Scheme`` (see the `documentation
<https://coq.inria.fr/distrib/current/refman/user-extensions/proof-schemes.html#generation-of-induction-principles-with-scheme>`__).

The command comes in two flavours:

- ``Scheme scheme := Induction for Sort Prop`` generates the standard
  induction scheme.
- ``Scheme scheme := Minimality for Sort Prop`` generates a simplified
  induction scheme more suited to inductive predicates.

If you define an inductive type in ``Type``, the generated induction
principle is of the first kind. If you define an inductive type in
``Prop`` (i.e. an inductive predicate), the generated induction
principle is of the second kind.

To obtain the induction principle that you want in the case of ``le``,
you can define it in ``Type``:
|*)

Inductive le (n : nat) : nat -> Type :=
| le_n : le n n
| le_S : forall m : nat, le n m -> le n (S m).

Check le_ind. (* .unfold *)

(*|
or you can manually ask Coq to generate the expected induction principle:
|*)

Reset le. (* .none *)
Inductive le (n : nat) : nat -> Prop :=
| le_n : le n n
| le_S : forall m : nat, le n m -> le n (S m).

Check le_ind. (* .unfold *)

Scheme le_ind2 := Induction for le Sort Prop.
Check le_ind2. (* .unfold *)


Require Export ArithRing.

Require Import XRbase.
Require Export XRpow_def.
Require Export XR_Ifp.
Require Export XRbasic_fun.
Require Export XR_sqr.
Require Export XSplitAbsolu.
Require Export XSplitRmult.
Require Export XArithProp.
Require Import Omega.
Require Import Zpower.
Local Open Scope nat_scope.
Local Open Scope XR_scope.

Lemma INR_fact_neq_0 : forall n:nat, INR (fact n) <> R0.
Proof.
  intros n.
  (* forall n, n <> 0 -> INR n <> 0 *)
  apply not_O_INR.
  (* forall n : nat, fact n <> 0 *)
  apply fact_neq_0.
Qed.

Local Open Scope nat_scope.
Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n).
Proof.
  intro n. simpl. reflexivity.
Qed.
Local Close Scope nat_scope.

Lemma simpl_fact :
  forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n).
Proof.
  intro n.
  rewrite fact_simpl.
  rewrite Rinv_involutive.
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  rewrite Rmult_assoc.
  rewrite Rinv_l.
  rewrite Rmult_1_r.
  reflexivity.
  apply INR_fact_neq_0.
  rewrite S_INR.
  apply tech_Rplus.
  apply pos_INR.
  apply Rlt_0_1.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
Qed.

Infix "^" := pow : XR_scope.

Lemma pow_O : forall x:R, x ^ 0 = R1.
Proof.
  intro x.
  simpl.
  reflexivity.
Qed.

Lemma pow_1 : forall x:R, x ^ 1 = x.
Proof.
  intro x.
  simpl.
  rewrite Rmult_1_r.
  reflexivity.
Qed.

Lemma pow_add : forall (x:R) (n m:nat), x ^ (n + m) = x ^ n * x ^ m.
Proof.
  intros x n.
  induction n as [ | n i ].
  { intro m. simpl. rewrite Rmult_1_l. reflexivity. }
  { intro m. simpl. rewrite i. rewrite Rmult_assoc.
    reflexivity.
  }
Qed.

Lemma Rpow_mult_distr : forall (x y:R) (n:nat), (x * y) ^ n = x^n * y^n.
Proof.
  intros x y n.
  induction n as [ | n i ].
  { simpl. rewrite Rmult_1_l. reflexivity. }
  { simpl. rewrite i.
    repeat (rewrite Rmult_assoc).
    rewrite (Rmult_comm y).
    repeat (rewrite Rmult_assoc).
    rewrite (Rmult_comm _ y).
    reflexivity.
  }
Qed.

Lemma pow_nonzero : forall (x:R) (n:nat), x <> R0 -> x ^ n <> R0.
Proof.
  intro. simple induction n. simpl.
  intro. red. intro. apply R1_neq_R0. assumption.
  intros. red. intro. elim (Rmult_integral x (x ^ n0) H1).
  intro. auto.
  apply H. assumption.
Qed.

Hint Resolve pow_O pow_1 pow_add pow_nonzero: real.

Lemma pow_RN_plus :
  forall (x:R) (n m:nat), x <> R0 -> x ^ n = x ^ (n + m) * / x ^ m.
Proof.
  intros x n m h.
  rewrite pow_add.
  rewrite Rmult_assoc.
  rewrite Rinv_r.
  rewrite Rmult_1_r.
  reflexivity.
  apply pow_nonzero.
  assumption.
Qed.

Lemma pow_lt : forall (x:R) (n:nat), R0 < x -> R0 < x ^ n.
Proof.
  intros x n h.
  induction n as [ | n i ].
  simpl. apply Rlt_0_1.
  simpl.
  rewrite <- Rmult_0_r with R0.
  apply Rmult_le_0_lt_compat.
  right;reflexivity.
  right;reflexivity.
  assumption.
  assumption.
Qed.
Hint Resolve pow_lt: real.

Lemma Rlt_pow_R1 : forall (x:R) (n:nat), R1 < x -> (0 < n)%nat -> R1 < x ^ n.
Proof.
  intros x n.
  induction n as [ | n i ].
  {
    intros hx hf.
    inversion hf.
  }
  {
    destruct n.
    {
      intros hx hu.
      simpl.
      rewrite Rmult_1_r.
      exact hx.
    }
    {
      intros hx hn.
      rewrite <- Rmult_1_l with R1.
      apply Rlt_trans with (x * R1).
      { rewrite Rmult_1_r. rewrite Rmult_1_r. exact hx. }
      {
        simpl.
        apply Rmult_lt_compat_l.
        {
          apply Rlt_trans with R1.
          { apply Rlt_0_1. }
          { exact hx. }
        }
        {
          simpl in i.
          apply i.
          { exact hx. }
          { unfold lt. apply le_n_S. apply le_0_n. }
        }
      }
    }
  }
Qed.
Hint Resolve Rlt_pow_R1: real.

Lemma Rlt_pow : forall (x:R) (n m:nat), R1 < x -> (n < m)%nat -> x ^ n < x ^ m.
Proof.
  intros x n.
  induction n as [ | n i ].
  { simpl. intros m hx hm. apply Rlt_pow_R1. exact hx. exact hm. }
  {
    destruct m.
    { simpl. intros hx hn. inversion hn. }
    { intros hx hnm. unfold lt in hnm. apply le_S_n in hnm.
      simpl. apply Rmult_lt_compat_l.
      apply Rlt_trans with R1. apply Rlt_0_1. exact hx.
      apply i. exact hx. unfold lt. exact hnm.
    }
  }
Qed.
Hint Resolve Rlt_pow: real.

Lemma tech_pow_Rmult : forall (x:R) (n:nat), x * x ^ n = x ^ S n.
Proof.
  intros x n.
  simpl.
  reflexivity.
Qed.

Arguments INR _ : simpl nomatch.

Lemma tech_pow_Rplus :
  forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a.
Proof.
  intros x a n.
  induction n as [ | n i ].
  { simpl. rewrite Rmult_0_l. rewrite Rmult_1_l. rewrite Rplus_0_r. reflexivity. }
  {
    simpl.
    rewrite <- i.
    rewrite S_INR.
    rewrite Rmult_plus_distr_r.
    rewrite Rmult_plus_distr_r.
    rewrite Rmult_1_l.
    rewrite Rplus_comm.
    apply Rplus_eq_compat_r.
    rewrite Rplus_comm.
    reflexivity.
  }
Qed.

Lemma poly : forall (n:nat) (x:R), R0 < x -> R1 + INR n * x <= (R1 + x) ^ n.
Proof.
  intros n x hx.
  induction n as [ | n i ].
  { simpl. rewrite Rmult_0_l. rewrite Rplus_0_r. right. reflexivity. }
  { destruct n.
    { simpl. rewrite Rmult_1_l. rewrite Rmult_1_r. right. reflexivity. }
    {
      rewrite S_INR.
      rewrite Rmult_plus_distr_r.
      rewrite Rmult_1_l.
      rewrite <- tech_pow_Rmult.
      rewrite Rmult_plus_distr_r.
      rewrite Rmult_1_l.
      pose (l:= R1 + INR (S n) * x).
      fold l in i.
      rewrite <- Rplus_assoc.
      fold l.
      pose (r:= (R1+x)^(S n)).
      fold r in i.
      fold r.
      apply Rplus_le_compat.
      { exact i. }
      {
        pattern x at 1;rewrite <- Rmult_1_r.
        apply Rmult_le_compat_l.
        { left. exact hx. }
        {
          left.
          unfold r.
          apply Rlt_pow_R1.
          {
            pattern R1 at 1;rewrite <- Rplus_0_r.
            apply Rplus_lt_compat_l.
            exact hx.
          }
          {
            unfold lt.
            apply le_n_S.
            apply le_0_n.
          }
        }
      }
    }
  }
Qed.

Lemma Power_monotonic :
  forall (x:R) (m n:nat),
    R1 < Rabs x -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n).
Proof.
  intros x m n hx hmn.

  unfold Rabs in hx. destruct (Rcase_abs x).
  {
    generalize dependent n.
    induction m as [ | m mi ].
    {
      induction n as [ | n ni].
      { simpl. intro u. right. reflexivity. }
      {
        simpl. intro u.
        simpl in ni.
        apply Rle_trans with (Rabs (x^n)).
        apply ni. apply le_0_n.
        rewrite Rabs_mult.
        pattern (Rabs (x^n)) at 1;rewrite <- Rmult_1_l.
        apply Rmult_le_compat_r.
        apply Rabs_pos.
        left.
        unfold Rabs. destruct (Rcase_abs x).
        exact hx.
        destruct r0.
        exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x;assumption.
        subst x. apply Rlt_irrefl in r. contradiction.
      }
    }
    {
      intro n. destruct n.
      { simpl. intro hm.
        rewrite Rabs_mult.
        specialize (mi 0%nat).
        simpl in mi.
        inversion hm.
      }
      {
        intros hmn.
        apply le_S_n in hmn.
        simpl.
        rewrite Rabs_mult.
        rewrite Rabs_mult.
        apply Rmult_le_compat_l.
        apply Rabs_pos.
        apply mi.
        exact hmn.
      }
    }
  }
  {
    destruct r.
    {
      generalize dependent n.
      induction m as [ | m mi ].
      {
        induction n as [ | n ni].
        { simpl. intro u. right. reflexivity. }
        {
          simpl. intro u.
          simpl in ni.
          apply Rle_trans with (Rabs (x^n)).
          apply ni. apply le_0_n.
          rewrite Rabs_mult.
          pattern (Rabs (x^n)) at 1;rewrite <- Rmult_1_l.
          apply Rmult_le_compat_r.
          apply Rabs_pos.
          left.
          unfold Rabs. destruct (Rcase_abs x).
          exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x;assumption.
          exact hx.
        }
      }
      {
        intro n. destruct n.
        { simpl. intro hm.
          inversion hm.
        }
        {
          intros hmn.
          apply le_S_n in hmn.
          simpl.
          rewrite Rabs_mult.
          rewrite Rabs_mult.
          apply Rmult_le_compat_l.
          apply Rabs_pos.
          apply mi.
          exact hmn.
        }
      }
    }
    {
      subst x.
      exfalso. apply Rlt_irrefl with R1. apply Rlt_trans with R0.
      assumption. apply Rlt_0_1.
    }
  }
Qed.

Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n).
Proof.
  intros x n.
  induction n as [ | n i ].
  { simpl. rewrite Rabs_R1. reflexivity. }
  { simpl. rewrite Rabs_mult. rewrite i. reflexivity. }
Qed.

Lemma XD_INR_Rge : forall r:R, exists n:nat, r <= INR n.
Proof.
  intro r.
  destruct (archimed r) as [ agt ale ].
  exists (Z.abs_nat (up r)).
  destruct (up r) eqn:upeq.
  { (* up r = 0 *)
    simpl.
    left. exact agt.
  }
  { (* up r = Z.pos p *)
    simpl.
    destruct (Pos.to_nat p) eqn:poseq.
    { (* Pos.to_nat p = 0 *)
      simpl.
      generalize (Pos2Nat.is_pos p);intro hpos.
      rewrite poseq in hpos.
      inversion hpos.
    }
    { (* Pos.to_nat p = S n *)
      (* rewrite S_INR. *)
      left.
      rewrite INR_IZR_INZ.
      rewrite <- poseq.
      rewrite positive_nat_Z.
      exact agt.
    }
  }
  { (* up r = Z.neg p *)
    simpl.
    destruct (Pos.to_nat p) eqn:poseq.
    { (* Pos.to_nat p = 0 *)
      simpl.
      generalize (Pos2Nat.is_pos p);intro hpos.
      rewrite poseq in hpos.
      inversion hpos.
    }
    { (* Pos.to_nat p = S n *)
      left.
      rewrite INR_IZR_INZ.
      rewrite <- poseq.
      rewrite positive_nat_Z.
      apply Rlt_trans with (IZR (Z.neg p)).
      { exact agt. }
      {
        apply IZR_lt.
        apply Pos2Z.neg_lt_pos.
      }
    }
  }
Qed.

Lemma Pow_x_infinity :
  forall x:R,
    R1 < Rabs x ->
    forall b:R,
      exists N : nat, (forall n:nat, (n >= N)%nat -> b <= Rabs (x ^ n) ).
Proof.
  intros.
  pose (exp := b * / (Rabs x - R1)).
  destruct (archimed exp) as [H0 H1].
  clear H1.
  {
    destruct (XD_INR_Rge exp) as [x0 H1].
    exists x0.
    intros n H2.
    apply Rle_trans with (Rabs (x ^ x0)).
    {
      rewrite <- RPow_abs.
      rewrite <- Rplus_0_l with (Rabs x).
      rewrite <- Rplus_opp_r with R1.
      rewrite Rplus_assoc.
      rewrite (Rplus_comm _ (Rabs x)).
      fold (Rabs x - R1).
      apply Rle_trans with (R1 + INR x0 * (Rabs x - R1)).
      {
        apply Rle_trans with (INR x0 * (Rabs x - R1)).
        {
          rewrite <- Rmult_1_r with b.
          pattern R1 at 1;rewrite <- Rinv_l with (Rabs x - R1).
          rewrite <- Rmult_assoc.
          fold (b / (Rabs x - R1)).
          {
            apply Rmult_le_compat_r.
            {
              apply Rplus_le_reg_r with R1.
              unfold Rminus.
              rewrite Rplus_0_l, Rplus_assoc, Rplus_opp_l, Rplus_0_r.
              left.
              exact H.
            }
            {
              fold exp.
              fold exp in H0, H1.
              exact H1.
            }
          }
          {
            apply Rlt_dichotomy_converse.
            right.
            apply Rplus_lt_reg_r with R1.
            unfold Rminus.
            rewrite Rplus_0_l, Rplus_assoc, Rplus_opp_l, Rplus_0_r.
            exact H.
          }
        }
        {
          left.
          rewrite (Rplus_comm R1).
          pattern (INR x0 * (Rabs x - R1)) at 1;rewrite <- Rplus_0_r.
          apply Rplus_lt_compat_l.
          apply Rlt_0_1.
        }
      }
      {
        apply poly.
        apply Rplus_lt_reg_r with R1.
        unfold Rminus.
        rewrite Rplus_0_l, Rplus_assoc, Rplus_opp_l, Rplus_0_r.
        exact H.
      }
    }
    {
      apply Power_monotonic.
      { exact H. }
      { unfold ge in H2. exact H2. }
    }
  }
Qed.

Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> R0 ^ n = R0.
Proof.
  intros n h.
  destruct n.
  { exfalso. apply h. reflexivity. }
  { simpl. rewrite Rmult_0_l. reflexivity. }
Qed.

Lemma Rinv_pow : forall (x:R) (n:nat), x <> R0 -> / x ^ n = (/ x) ^ n.
Proof.
  intros x n h.
  induction n as [ | n i].
  simpl. rewrite Rinv_1. reflexivity.
  simpl. rewrite Rinv_mult_distr. rewrite i. reflexivity.
  exact h.
  apply pow_nonzero. exact h.
Qed.

(* stopped here *)

Lemma Rlt_0_half : R0 < / (IZR 2). Admitted.
Lemma half_nz : / (IZR 2) <> R0. Admitted.

Lemma lala :
    Rabs (/ (IZR 2)) < R1 ->
    forall y:R,
      R0 < y ->
      exists N : nat, (/ (IZR 2)) ^ N < y.
Proof.
  intros H y hy.
  assert (hadx : R1 < Rabs (/ (/ (IZR 2))) ).
  {
    rewrite <- (Rinv_involutive R1).
    {
      rewrite Rabs_Rinv.
      {
        apply Rinv_lt_contravar.
        {
          apply Rmult_lt_0_compat.
          {
            apply Rabs_pos_lt.
            exact half_nz.
          }
          {
            rewrite Rinv_1.
            apply Rlt_0_1.
          }
        }
        {
          rewrite Rinv_1.
          exact H.
        }
      }
      { exact half_nz. }
    }
    {
      apply R1_neq_R0.
    }
  }
  generalize Pow_x_infinity;intro hpow.
  specialize (hpow (/ (/ (IZR 2)))).
  specialize (hpow hadx).
  specialize (hpow (/ y + R1)).
  destruct hpow as [N hpow].
  exists N.
  specialize (hpow N).
  assert (ob:(N >= N)%nat). constructor.
  specialize (hpow ob).
  rewrite <- (Rinv_involutive y).
  {
    {
      {
        {

rewrite <- Rinv_pow.
apply Rinv_lt_contravar.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
exact hy.
apply pow_lt.

(*
      {
        rewrite <- Rabs_Rinv.
        {
          rewrite Rinv_pow.
          {
            apply Rlt_le_trans with (/ y + 1).
            {
              pattern (/ y) at 1;rewrite <- Rplus_0_r.
              apply Rplus_lt_compat_l.
              apply Rlt_0_1.
            }
            {
              apply Rge_le.
              exact hpow.
            }
          }
          { exact half_nz. }
        }
        {
          apply pow_nonzero.
          exact half_nz.
        }
      }
    }
    {
      apply Rabs_no_R0.
      apply pow_nonzero.
      exact half_nz.
    }
  }
  {
    apply Rlt_dichotomy_converse.
    right.
    unfold Rgt.
    exact hy.
  }
*)
Admitted.

Lemma pow_lt_1_zero :
  forall x:R,
    Rabs x < R1 ->
    forall y:R,
      R0 < y ->
      exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y).
Proof.
  intros x H y hy.
  destruct (Req_dec x R0) as [hz | hnz]. (* x = 0 \/ x <> 0 *)
  { (* x = 0 *)
    subst x.
    exists 1%nat.
    intros n hn.
    rewrite pow_ne_zero. (* n <> 0 -> 0 ^ n = 0 *)
    {
      rewrite Rabs_R0. (* Rabs 0 = 0 *)
      exact hy.
    }
    {
      inversion hn as [ heq | m hmn ].
      {
        intro eq.
        inversion eq.
      }
      {
        subst n.
        intro eq.
        inversion eq.
      }
    }
  }
  { (* x <> 0 *)
    assert (hadx : R1 < Rabs (/ x) ).
    {
      rewrite <- (Rinv_involutive R1).
      {
        rewrite Rabs_Rinv.
        {
          apply Rinv_lt_contravar.
          {
            apply Rmult_lt_0_compat.
            {
              apply Rabs_pos_lt.
              exact hnz.
            }
            {
              rewrite Rinv_1.
              apply Rlt_0_1.
            }
          }
          {
            rewrite Rinv_1.
            exact H.
          }
        }
        { exact hnz. }
      }
      {
        apply R1_neq_R0.
      }
    }
    generalize Pow_x_infinity;intro hpow.
    specialize (hpow (/ x)).
    specialize (hpow hadx).
    specialize (hpow (/ y + R1)).
    destruct hpow as [N hpow].
    exists N.
    intros n hnN.
    specialize (hpow n).
    specialize (hpow hnN).
    rewrite <- (Rinv_involutive y).
    {
      rewrite <- (Rinv_involutive (Rabs (x ^ n))).
      {
        apply Rinv_lt_contravar.
        {
          apply Rmult_lt_0_compat.
          {
            apply Rinv_0_lt_compat.
            exact hy.
          }
          {
            apply Rinv_0_lt_compat.
            apply Rabs_pos_lt.
            apply pow_nonzero.
            exact hnz.
          }
        }
        {
          rewrite <- Rabs_Rinv.
          {
            rewrite Rinv_pow.
            {
              apply Rlt_le_trans with (/ y + R1).
              {
                pattern (/ y) at 1;rewrite <- Rplus_0_r.
                apply Rplus_lt_compat_l.
                apply Rlt_0_1.
              }
              {
                exact hpow.
              }
            }
            { exact hnz. }
          }
          {
            apply pow_nonzero.
            exact hnz.
          }
        }
      }
      {
        apply Rabs_no_R0.
        apply pow_nonzero.
        exact hnz.
      }
    }
    {
      apply Rlt_dichotomy_converse.
      right.
      exact hy.
    }
  }
Qed.

Lemma XD_Rabs_lt_0_Sn: forall r n,
  r<>R0 ->
  R1 < Rabs r ->
  Rabs r ^ 0 < Rabs r ^ S n.
Proof.
  intros r n hrnz harlt.
  simpl.
  induction n as [ | n i ].
  {
    simpl.
    rewrite Rmult_1_r.
    exact harlt.
  }
  {
    simpl.
    apply Rlt_trans with (Rabs r).
    {
      exact harlt.
    }
    {
      pattern (Rabs r) at 1;rewrite <- Rmult_1_r.
      apply Rmult_lt_compat_l.
      2:exact i.
      {
        apply Rabs_pos_lt.
        exact hrnz.
      }
    }
  }
Qed.

Lemma pow_R1 : forall (r:R) (n:nat), r ^ n = R1 -> Rabs r = R1 \/ n = 0%nat.
Proof.
  intros r n h.
  destruct (Req_dec (Rabs r) R1) as [ hareq | harneq ].
  { (* Rabs r = 1 *)
    left. exact hareq.
  }
  { (* Rabs r <> 1 *)
    right.
    apply Rdichotomy in harneq.
    destruct harneq as [ harlt | hargt ].
    { (* Rabs r < 1 *)
      {
        destruct n as [ | n ].
        { (* n = 0 *)
          reflexivity.
        }
        { (* n <> 0 *)
          {
            (* h is absurd when r = 0 *)
            assert (hrnz: r<>R0).
            {
              intro heq.
              subst r.
              simpl in h.
              rewrite Rmult_0_l in h.
              apply R1_neq_R0.
              symmetry.
              exact h.
            }
            (* from there, it's obvious that Rabs r <> 0 *)
            assert (harnz : Rabs r <> R0).
            { apply Rabs_no_R0. exact hrnz. }
            (* We cannot show this goal, so there must be an inconsistency *)
            exfalso.
            (* We use XD_Rabs_lt_0_Sn to reveal the inconsistency *)
            apply Rlt_irrefl with R1.
            pattern R1 at 1;rewrite <- pow_O with (Rabs (/ r)).
            rewrite <- Rabs_R1.
            rewrite <- Rinv_1.
            rewrite <- h.
            rewrite Rinv_pow.
            2:exact hrnz.
            rewrite <- RPow_abs.
            apply XD_Rabs_lt_0_Sn.
            {
              apply Rinv_neq_0_compat.
              exact hrnz.
            }
            {
              rewrite Rabs_Rinv.
              2:exact hrnz.
              pattern R1 at 1;rewrite <- Rinv_involutive.
              2:exact R1_neq_R0.
              apply Rinv_lt_contravar.
              {
                rewrite Rinv_1.
                rewrite Rmult_1_r.
                apply Rabs_pos_lt.
                exact hrnz.
              }
              {
                rewrite Rinv_1.
                exact harlt.
              }
            }
          }
        }
      }
    }
    {
      destruct n as [ | n ].
      { reflexivity. }
      {
        assert (hrnz:r<>R0).
        {
          intro hrz.
          subst r.
          simpl in h.
          rewrite Rmult_0_l in h.
          symmetry in h.
          apply R1_neq_R0 in h.
          contradiction.
        }
        assert (harnz:Rabs r <> R0).
        {
          apply Rabs_no_R0.
          exact hrnz.
        }
        exfalso.
        apply Rlt_irrefl with R1.
        pattern R1 at 1;rewrite <- pow_O with (Rabs r).
        rewrite <- Rabs_R1.
        rewrite <- h.
        rewrite <- RPow_abs.
        apply XD_Rabs_lt_0_Sn.
        exact hrnz.
        exact hargt.
      }
    }
  }
Qed.

Lemma pow_Rsqr : forall (x:R) (n:nat), x ^ (2 * n) = Rsqr x ^ n.
Proof.
  intros x n.
  induction n as [ | n i ].
  { simpl. reflexivity. }
  {
    simpl.
    rewrite plus_comm.
    simpl.
    rewrite (plus_comm n).
    simpl.
    simpl in i.
    rewrite plus_comm in i.
    rewrite <- plus_assoc in i.
    simpl in i.
    rewrite i.
    unfold Rsqr.
    repeat (rewrite Rmult_assoc).
    reflexivity.
  }
Qed.

Lemma pow_le : forall (a:R) (n:nat), R0 <= a -> R0 <= a ^ n.
Proof.
  intros a n h.
  induction n as [ | n i ].
  { simpl. left. apply Rlt_0_1. }
  { simpl. apply Rmult_le_pos. exact h. exact i. }
Qed.

Lemma pow_1_even : forall n:nat, (-R1) ^ (2 * n) = R1.
Proof.
  intro n. induction n as [ | n i ].
  { simpl. reflexivity. }
  { rewrite pow_Rsqr. rewrite pow_Rsqr in i. simpl.
    rewrite i. rewrite Rmult_1_r.
    unfold Rsqr.
    unfold IZR.
    rewrite <- Ropp_mult_distr_l.
    rewrite <- Ropp_mult_distr_r.
    rewrite Ropp_involutive.
    rewrite Rmult_1_r.
    reflexivity.
  }
Qed.

Lemma pow_1_odd : forall n:nat, (-R1) ^ S (2 * n) = -R1.
Proof.
  intros n.
  pose (twice:=(2*n)%nat).
  fold twice.
  simpl.
  unfold twice.
  rewrite pow_1_even.
  rewrite Rmult_1_r.
  reflexivity.
Qed.

Lemma XD_even_odd : forall n:nat, ((exists n', n=2 * n') \/ (exists n', n = S(2 * n')))%nat.
Proof.
  intro n.
  induction n as [ | n i ].
  {
    simpl.
    left. exists 0%nat. simpl. reflexivity.
  }
  {
    destruct i as [ l | r ].
    {
      destruct l as [ n' h ].
      subst n.
      simpl.
      right. exists n'. reflexivity.
    }
    {
      destruct r as [ n' h ].
      subst n.
      simpl.
      left.
      exists (S n').
      simpl.
      rewrite (plus_comm n').
      rewrite (plus_comm n').
      simpl.
      rewrite plus_n_Sm.
      reflexivity.
    }
  }
Qed.

Lemma pow_1_abs : forall n:nat, Rabs ((-R1) ^ n) = R1.
Proof.
  intros n.
  destruct (XD_even_odd n) as [ heven | hodd ].
  destruct heven as [n' eq].
  subst n. rewrite pow_1_even. rewrite Rabs_R1. reflexivity.
  destruct hodd as [n' eq].
  subst n. rewrite pow_1_odd. unfold IZR. rewrite Rabs_Ropp.
  fold (IZR 1). rewrite Rabs_R1. reflexivity.
Qed.

(* stopped here *)

Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2.
Proof.
  intros x n m.
  induction n as [ | n i ].
  { simpl.
    induction m as [ | m i ].
    { simpl. reflexivity. }
    { simpl. rewrite <- i. rewrite Rmult_1_r. reflexivity. }
  }
  {
    simpl.
    rewrite pow_add.
    rewrite i.
    rewrite Rpow_mult_distr.
    reflexivity.
  }
Qed.

Lemma pow_incr : forall (x y:R) (n:nat), R0 <= x <= y -> x ^ n <= y ^ n.
Proof.
  intros x y n h.
  induction n as [ | n i ].
  { simpl. right. reflexivity. }
  {
    simpl.
    destruct h as [ l r ].
    apply Rmult_le_compat.
    { exact l. }
    { apply pow_le. exact l. }
    { exact r. }
    { exact i. }
  }
Qed.

Lemma pow_R1_Rle : forall (x:R) (k:nat), R1 <= x -> R1 <= x ^ k.
Proof.
  intros x n h.
  induction n as [ | n i ].
  { simpl. right. reflexivity. }
  {
    simpl.
    pattern R1 at 1;rewrite <- Rmult_1_l.
    apply Rmult_le_compat.
    left. exact Rlt_0_1.
    left. exact Rlt_0_1.
    exact h.
    exact i.
  }
Qed.

Lemma Rle_pow :
  forall (x:R) (m n:nat), R1 <= x -> (m <= n)%nat -> x ^ m <= x ^ n.
Proof.
  intros x m.
  induction m as [ | m mi ].
  {
    intros n hx hn.
    simpl.
    apply pow_R1_Rle.
    exact hx.
  }
  {
    intros n hx hn.
    destruct n.
    { inversion hn. }
    {
      simpl.
      apply Rmult_le_compat_l.
      apply Rle_trans with R1.
      left. exact Rlt_0_1.
      exact hx.
      apply mi.
      exact hx.
      apply le_S_n.
      exact hn.
    }
  }
Qed.

Lemma pow1 : forall n:nat, R1 ^ n = R1.
Proof.
  intro n.
  induction n as [ | n i ].
  simpl. reflexivity.
  simpl. rewrite i. rewrite Rmult_1_l. reflexivity.
Qed.

Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n.
Proof.
  intros x n.
  destruct n.
  { simpl. right. reflexivity. }
  {
    simpl.
    unfold Rabs in *.
    destruct (Rcase_abs x).
    {
      destruct (XD_even_odd n) as [ [ n' heven ] | [ n' hodd ]  ].
      {
        subst n. rename n' into n.
        pattern (-x) at 2;rewrite <- Rmult_1_r.
        rewrite <- (Ropp_mult_distr_l _ R1).
        rewrite (Ropp_mult_distr_r _ R1).
        rewrite Rpow_mult_distr.
        rewrite pow_1_even.
        rewrite Rmult_1_r.
        apply Rmult_le_compat_r.
        {
          rewrite pow_Rsqr.
          apply pow_le.
          apply Rle_0_sqr.
        }
        {
          left.
          apply Rlt_trans with R0.
          exact r.
          rewrite <- Ropp_0.
          apply Ropp_lt_contravar.
          exact r.
        }
      }
      {
        subst n.
        pattern (-x) at 2;rewrite <- Rmult_1_r.
        rewrite <- (Ropp_mult_distr_l _ R1).
        rewrite (Ropp_mult_distr_r _ R1).
        rewrite Rpow_mult_distr.
        rewrite pow_1_odd.
        unfold IZR.
        rewrite <- Ropp_mult_distr_r.
        fold (IZR 1).
        rewrite Rmult_1_r.
        rewrite <- Ropp_mult_distr_r.
        rewrite <- Ropp_mult_distr_l.
        rewrite Ropp_involutive.
        right.
        reflexivity.
      }
    }
    {
      right.
      reflexivity.
    }
  }
Qed.

Lemma pow_maj_Rabs : forall (x y:R) (n:nat), Rabs y <= x -> y ^ n <= x ^ n.
Proof.
  intros x y n h.
  assert (hx:R0 <= x).
  {
    apply Rle_trans with (Rabs y).
    apply Rabs_pos.
    exact h.
  }
  {
    apply Rle_trans with (Rabs y ^ n).
    { apply pow_Rabs. }
    { induction  n as [ | n i ].
      { right. simpl. reflexivity. }
      {
        simpl.
        apply Rle_trans with (x * Rabs y ^ n).
        {
          apply Rmult_le_compat_r.
          {
            apply pow_le.
            apply Rabs_pos.
          }
          { exact h. }
        }
        {
          apply Rmult_le_compat_l.
          { exact hx. }
          { apply i. }
        }
      }
    }
  }
Qed.

Lemma Rsqr_pow2 : forall x, Rsqr x = x ^ 2.
Proof.
  intro x.
  unfold Rsqr.
  simpl.
  rewrite Rmult_1_r.
  reflexivity.
Qed.

Section PowerRZ.

Local Coercion Z_of_nat : nat >-> Z.

Section Z_compl.

Local Open Scope Z_scope.

Inductive Z_spec (x : Z) : Z -> Type :=
| ZintNull : x = 0 -> Z_spec x 0
| ZintPos (n : nat) : x = n -> Z_spec x n
| ZintNeg (n : nat) : x = - n -> Z_spec x (- n).

Lemma intP (x : Z) : Z_spec x x.
Proof.
  induction x.
  {
    apply ZintNull. (* x = 0 -> Z_spec x 0 *)
    reflexivity.
  }
  {
    rewrite <- positive_nat_Z at 2. (* Pos.to_nat p = Z.pos p *)
    apply ZintPos. (* x = n -> Z_spec x n *)
    rewrite positive_nat_Z.
    reflexivity.
  }
  {
    rewrite  <- Pos2Z.opp_pos. (* - Z.pos p = Z.neg p *)
    rewrite <- positive_nat_Z at 2.
    apply ZintNeg.
    rewrite positive_nat_Z.
    reflexivity.
  }
Qed.

End Z_compl.

Definition powerRZ (x:R) (n:Z) :=
  match n with
    | Z0 => R1
    | Zpos p => x ^ Pos.to_nat p
    | Zneg p => / x ^ Pos.to_nat p
  end.

Local Infix "^Z" := powerRZ (at level 30, right associativity) : XR_scope.

Lemma Zpower_NR0 :
  forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z.
Proof.
  intros x n h.
  induction n as [ | n i ].
  {
    simpl.
    unfold Z.le.
    simpl.
    intro eq.
    inversion eq.
  }
  {
    simpl.
    apply Z.mul_nonneg_nonneg.
    exact h.
    exact i.
  }
Qed.

Lemma powerRZ_O : forall x:R, x ^Z 0 = R1.
Proof.
  intro x.
  simpl.
  reflexivity.
Qed.

Lemma powerRZ_1 : forall x:R, x ^Z Z.succ 0 = x.
Proof.
  intro x.
  simpl.
  rewrite Rmult_1_r.
  reflexivity.
Qed.

Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> R0 -> x ^Z z <> R0.
Proof.
  intros x z neq eq.
  destruct z;simpl in eq.
  {
    apply R1_neq_R0. exact eq.
  }
  {
    apply (pow_nonzero _ (Pos.to_nat p)) in neq.
    contradiction.
  }
  {
    generalize neq;intro neqpow.
    apply Rinv_neq_0_compat in neqpow.
    apply (pow_nonzero _ (Pos.to_nat p)) in neqpow.
    rewrite Rinv_pow in eq.
    contradiction.
    exact neq.
  }
Qed.

(* skipped *)
Lemma powerRZ_pos_sub (x:R) (n m:positive) : x <> R0 ->
   x ^Z (Z.pos_sub n m) = x ^ Pos.to_nat n * / x ^ Pos.to_nat m.
Proof.
 intro Hx.
 rewrite Z.pos_sub_spec.
 case Pos.compare_spec; intro H; simpl.
 - subst; auto with real.
 - rewrite Pos2Nat.inj_sub by trivial.
   rewrite Pos2Nat.inj_lt in H.
   rewrite (pow_RN_plus x _ (Pos.to_nat n)) by auto with real.
   rewrite plus_comm, le_plus_minus_r by auto with real.
   rewrite Rinv_mult_distr, Rinv_involutive; auto with real.
 - rewrite Pos2Nat.inj_sub by trivial.
   rewrite Pos2Nat.inj_lt in H.
   rewrite (pow_RN_plus x _ (Pos.to_nat m)) by auto with real.
   rewrite plus_comm, le_plus_minus_r by auto with real.
   reflexivity.
Qed.

(* skipped *)
Lemma powerRZ_add :
  forall (x:R) (n m:Z), x <> R0 -> x ^Z (n + m) = x ^Z n * x ^Z m.
Proof.
  intros x [|n|n] [|m|m]; simpl; intros; auto with real.
  - (* + + *)
    rewrite Pos2Nat.inj_add; auto with real.
  - (* + - *)
    now apply powerRZ_pos_sub.
  - (* - + *)
    rewrite Rmult_comm. now apply powerRZ_pos_sub.
  - (* - - *)
    rewrite Pos2Nat.inj_add; auto with real.
    rewrite pow_add; auto with real.
    apply Rinv_mult_distr; apply pow_nonzero; auto.
Qed.
Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real.

(* skipped *)
Lemma Zpower_nat_powerRZ :
  forall n m:nat, IZR (Zpower_nat (Z.of_nat n) m) = INR n ^Z Z.of_nat m.
Proof.
  intros n m; elim m; simpl; auto with real.
  intros m1 H'; rewrite SuccNat2Pos.id_succ; simpl.
  replace (Zpower_nat (Z.of_nat n) (S m1)) with
  (Z.of_nat n * Zpower_nat (Z.of_nat n) m1)%Z.
  rewrite mult_IZR; auto with real.
  repeat rewrite <- INR_IZR_INZ; simpl.
  rewrite H'; simpl.
  case m1; simpl; auto with real.
  intros m2; rewrite SuccNat2Pos.id_succ; auto.
  unfold Zpower_nat; auto.
Qed.

(* skipped *)
Lemma Zpower_pos_powerRZ :
  forall n m, IZR (Z.pow_pos n m) = IZR n ^Z Zpos m.
Proof.
  intros.
  rewrite Zpower_pos_nat; simpl.
  induction (Pos.to_nat m).
  easy.
  unfold Zpower_nat; simpl.
  rewrite mult_IZR.
  now rewrite <- IHn0.
Qed.

(* skipped *)
Lemma powerRZ_lt : forall (x:R) (z:Z), R0 < x -> R0 < x ^Z z.
Proof.
  intros x z; case z; simpl; auto with real.
Qed.
Hint Resolve powerRZ_lt: real.

(* skipped *)
Lemma powerRZ_le : forall (x:R) (z:Z), R0 < x -> R0 <= x ^Z z.
Proof.
  intros x z H'; apply Rlt_le; auto with real.
Qed.
Hint Resolve powerRZ_le: real.

(* skipped *)
Lemma Zpower_nat_powerRZ_absolu :
  forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Z.abs_nat m)) = IZR n ^Z m.
Proof.
  intros n m; case m; simpl; auto with zarith.
  intros p H'; elim (Pos.to_nat p); simpl; auto with zarith.
  intros n0 H'0; rewrite <- H'0; simpl; auto with zarith.
  rewrite <- mult_IZR; auto.
  intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith.
Qed.

(* skipped *)
Lemma powerRZ_R1 : forall n:Z, R1 ^Z n = R1.
Proof.
  intros n; case n; simpl; auto.
  intros p; elim (Pos.to_nat p); simpl; auto; intros n0 H'; rewrite H'.
    rewrite Rmult_1_r.
reflexivity.
  intros p; elim (Pos.to_nat p); simpl.
  exact Rinv_1.
  intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H';
    auto with real.
Qed.

Local Open Scope Z_scope.

(* skipped *)
Lemma pow_powerRZ (r : R) (n : nat) :
  (r ^ n)%R = powerRZ r (Z_of_nat n).
Proof.
  induction n; [easy|simpl].
  now rewrite SuccNat2Pos.id_succ.
Qed.

(* skipped *)
Lemma powerRZ_ind (P : Z -> R -> R -> Prop) :
  (forall x, P 0 x R1) ->
  (forall x n, P (Z.of_nat n) x (x ^ n)%R) ->
  (forall x n, P ((-(Z.of_nat n))%Z) x (Rinv (x ^ n))) ->
  forall x (m : Z), P m x (powerRZ x m)%R.
Proof.
  intros ? ? ? x m.
  destruct (intP m) as [Hm|n Hm|n Hm].
  - easy.
  - now rewrite <- pow_powerRZ.
  - unfold powerRZ.
    destruct n as [|n]; [ easy |].
    rewrite Nat2Z.inj_succ, <- Zpos_P_of_succ_nat, Pos2Z.opp_pos.
    now rewrite <- Pos2Z.opp_pos, <- positive_nat_Z.
Qed.

(* skipped *)
Lemma powerRZ_inv x alpha : (x <> R0)%R -> powerRZ (/ x) alpha = Rinv (powerRZ x alpha).
Proof.
  intros; destruct (intP alpha).
  - now simpl; rewrite Rinv_1.
  - now rewrite <-!pow_powerRZ, ?Rinv_pow, ?pow_powerRZ.
  - unfold powerRZ.
    destruct (- n).
    + now rewrite Rinv_1.
    + now rewrite Rinv_pow.
    + now rewrite <-Rinv_pow.
Qed.

(* skipped *)
Lemma powerRZ_neg x : forall alpha, x <> R0 -> powerRZ x (- alpha) = powerRZ (/ x) alpha.
Proof.
  intros [|n|n] H ; simpl.
  - easy.
  - now rewrite Rinv_pow.
  - rewrite Rinv_pow by now apply Rinv_neq_0_compat.
    now rewrite Rinv_involutive.
Qed.

(* skipped *)
Lemma powerRZ_mult_distr :
  forall m x y, ((Z.le Z0 m)%Z \/
		(x * y <> R0)%R) ->
           (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R.
Proof.
  intros m x0 y0 Hmxy.
  destruct (intP m) as [ | | n Hm ].
  - now simpl; rewrite Rmult_1_l.
  - now rewrite <- !pow_powerRZ, Rpow_mult_distr.
  - destruct Hmxy as [H|H].
    + assert(m = 0) as -> by now omega.
      now rewrite <- Hm, Rmult_1_l.
    + assert(x0 <> R0)%R by now intros ->; apply H; rewrite Rmult_0_l.
      assert(y0 <> R0)%R by now intros ->; apply H; rewrite Rmult_0_r.
      rewrite !powerRZ_neg by assumption.
      rewrite Rinv_mult_distr by assumption.
      now rewrite <- !pow_powerRZ, Rpow_mult_distr.
Qed.

End PowerRZ.

Local Infix "^Z" := powerRZ (at level 30, right associativity) : XR_scope.

Definition decimal_exp (r:R) (z:Z) : R := (r * (IZR 10) ^Z z).

Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) : nat :=
  match n with
    | O => f 0%nat
    | S n' => (sum_nat_f_O f n' + f (S n'))%nat
  end.

Definition sum_nat_f (s n:nat) (f:nat -> nat) : nat :=
  sum_nat_f_O (fun x:nat => f (x + s)%nat) (n - s).

Definition sum_nat_O (n:nat) : nat := sum_nat_f_O (fun x:nat => x) n.

Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x).

Fixpoint sum_f_R0 (f:nat -> R) (N:nat) : R :=
  match N with
    | O => f 0%nat
    | S i => sum_f_R0 f i + f (S i)
  end.

Definition sum_f (s n:nat) (f:nat -> R) : R :=
  sum_f_R0 (fun x:nat => f (x + s)%nat) (n - s).

Definition fGP (x:R) (n : nat) := x ^n.

Lemma GP_finite :
  forall (x:R) (n:nat),
    sum_f_R0 (fGP x) n * (x - R1) = x ^ (n + 1) - R1.
Proof.
  intros x n.
  pose (f:=fun k => x^k).
  fold f.
  induction n as [ | n i].
  { simpl. rewrite Rmult_1_l. rewrite Rmult_1_r. reflexivity. }
  {
    simpl.
    unfold fGP at 2.
    rewrite Rmult_plus_distr_r.
    rewrite i.
    unfold Rminus.
    rewrite Rmult_plus_distr_l.
    rewrite <- Ropp_mult_distr_r.
    rewrite Rmult_1_r.
    rewrite pow_add.
    simpl.
    rewrite Rmult_1_r.
    repeat (rewrite Rplus_assoc).
    rewrite Rplus_comm at 1.
    repeat (rewrite Rplus_assoc).
    rewrite (Rmult_comm x (x^n)).
    rewrite Rplus_opp_l.
    rewrite Rplus_0_r.
    rewrite Rplus_comm.
    apply Rplus_eq_compat_r.
    rewrite Rmult_comm.
    reflexivity.
  }
Qed.

Definition fTR (f : nat -> R) (n:nat) := Rabs (f n).

Lemma sum_f_R0_triangle :
  forall (f:nat -> R) (n:nat),
    Rabs (sum_f_R0 f n) <= sum_f_R0 (fTR f) n.
Proof.
  intros f n.
  induction n as [ | n i ].
  { simpl. unfold fTR. right. reflexivity. }
  {
    simpl.
    pose (a:=sum_f_R0 f n).
    fold a in i.
    pose (b:=sum_f_R0 (fTR f) n).
    fold b in i. fold b.
    fold a.
    pose (c:= f (S n)).
    fold c.
    apply Rle_trans with (Rabs a + Rabs c).
    apply Rabs_triang.
    apply Rplus_le_compat.
    exact i.
    unfold c. unfold fTR. right. reflexivity.
  }
Qed.

Definition R_dist (x y:R) : R := Rabs (x - y).

Lemma R_dist_pos : forall x y:R, R0 <= R_dist x y .
Proof.
  intros x y.
  unfold R_dist.
  apply Rabs_pos.
Qed.

Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x.
Proof.
  intros x y.
  unfold R_dist.
  rewrite Rabs_minus_sym.
  reflexivity.
Qed.

Lemma R_dist_refl : forall x y:R, R_dist x y = R0 <-> x = y.
Proof.
  intros x y.
  split.
  {
    intro eq.
    unfold R_dist in eq.
    unfold Rabs in eq.
    unfold Rminus in eq.
    destruct (Rcase_abs (x + - y)).
    {
      apply Rplus_eq_reg_r with (-y).
      rewrite Rplus_opp_r.
      rewrite <- Ropp_0.
      rewrite <- eq.
      rewrite Ropp_involutive.
      reflexivity.
    }
    {
      apply Rplus_eq_reg_r with (-y).
      rewrite Rplus_opp_r.
      rewrite eq.
      reflexivity.
    }
  }
  { intro eq. subst y. unfold R_dist. unfold Rminus. rewrite Rplus_opp_r. rewrite Rabs_R0. reflexivity. }
Qed.

Lemma R_dist_eq : forall x:R, R_dist x x = R0.
Proof.
  intros x.
  unfold R_dist.
  unfold Rminus.
  rewrite Rplus_opp_r.
  rewrite Rabs_R0.
  reflexivity.
Qed.

Lemma R_dist_tri : forall x y z:R, R_dist x y <= R_dist x z + R_dist z y.
Proof.
  intros x y z.
  unfold R_dist.
  unfold Rminus.
  pattern x at 1;rewrite <- Rplus_0_r.
  rewrite <- Rplus_opp_l with z.
  rewrite Rplus_assoc.
  rewrite Rplus_assoc.
  rewrite <- (Rplus_assoc x).
  apply Rle_trans with (Rabs (x+-z) + Rabs (z+-y)).
  apply Rabs_triang.
  right.
  reflexivity.
Qed.

Lemma R_dist_plus :
  forall a b c d:R, R_dist (a + c) (b + d) <= R_dist a b + R_dist c d.
Proof.
  intros a b c d.
  unfold R_dist.
  unfold Rminus.
  rewrite Ropp_plus_distr.
  rewrite Rplus_assoc.
  rewrite (Rplus_comm c).
  rewrite Rplus_assoc.
  rewrite (Rplus_comm _ c).
  rewrite <- (Rplus_assoc a).
  apply Rabs_triang.
Qed.

Lemma R_dist_mult_l : forall a b c,
  R_dist (a * b) (a * c) = Rabs a * R_dist b c.
Proof.
  intros a b c.
  unfold R_dist at 1.
  unfold Rminus.
  rewrite Ropp_mult_distr_r.
  rewrite <- Rmult_plus_distr_l.
  fold (b-c).
  rewrite Rabs_mult.
  fold (R_dist b c).
  reflexivity.
Qed.

Definition infinite_sum (s:nat -> R) (l:R) : Prop :=
  forall eps:R,
    R0 < eps ->
    exists N : nat,
      (forall n:nat, (n >= N)%nat -> R_dist (sum_f_R0 s n) l < eps).

Notation infinit_sum := infinite_sum (only parsing).


Open Scope list_scope.

Inductive alpha : Set := M : alpha | I : alpha | U : alpha.
Definition word : Set := list alpha.
Check length.

Definition word_M : list alpha := M :: nil.
Definition word_MI := M::I::nil.
Definition word_MU := M::U::nil.
Definition word_I := I::nil.
Definition word_IU := I::U::nil.
Definition word_III := I::I::I::nil.
Definition word_U := U::nil.
Definition word_UU := U::U::nil.

Inductive lang : word -> Prop :=
  | axiom :
      lang word_MI
  | rule1 : forall x,
      lang (x ++ word_I) -> lang (x ++ word_IU)
  | rule2 : forall x,
      lang (word_M ++ x) -> lang (word_M ++ x ++ x)
  | rule3 : forall x y,
      lang (x ++ word_III ++ y) -> lang (x ++ word_U ++ y)
  | rule4 : forall x y,
      lang (x ++ word_UU ++ y) -> lang (x ++ y).

  Definition hd_error (l:word) : option alpha :=
    match l with
      | nil => None
      | x :: _ => Some x
    end.

Lemma commence_par_M :
  forall m : word, lang m -> hd_error m = Some M.
Proof.
intros.
induction H.
  - simpl. reflexivity.
  - destruct x.
    + simpl in *.
    (* *)
    discriminate.
    (* on a faux dans l'hypothèse donc
    chouet on peut tout prouver avec.
    on peut aussi utiliser assumption. *)
    + simpl in *. assumption.
  - simpl. assumption.
  - destruct x.
    + simpl in *. discriminate.
    + simpl in *. assumption.
  - destruct x.
    + simpl in *. discriminate.
    + simpl in *. assumption.
Qed.

Inductive Z3 : Set := Z0 : Z3 | Z1 : Z3 | Z2 : Z3.


From Coq Require Import
  List.
From FunProofs.Lib Require Import
  List.

Section ZipMap.
  Context {A B C : Type}.

  Definition zipMap (f : A -> B -> C) xs ys : list C :=
    map (fun xy => f (fst xy) (snd xy)) (combine xs ys).

  Lemma zipMap_split {D E} (f : D -> A) (g : E -> B) (h : A -> B -> C) xs : forall ys,
    map (fun xy => h (f (fst xy)) (g (snd xy))) (combine xs ys) =
    zipMap h (map f xs) (map g ys).
  Proof.
    unfold zipMap; induction xs; cbn; intros; auto.
    destruct ys; cbn; auto.
    rewrite IHxs; auto.
  Qed.

  Lemma zipMap_repeat_r (f : A -> B -> C) y xs : forall n,
    n = length xs -> zipMap f xs (repeat y n) = map (fun x => f x y) xs.
  Proof.
    unfold zipMap; induction xs; cbn; intros; subst; auto.
    erewrite <- IHxs; eauto; auto.
  Qed.

  Lemma zipMap_app (f : A -> B -> C) xs xs' ys ys' :
    length xs = length ys ->
    length xs' = length ys' ->
    zipMap f (xs ++ xs') (ys ++ ys') = zipMap f xs ys ++ zipMap f xs' ys'.
  Proof. unfold zipMap; intros; rewrite combine_app, map_app; auto. Qed.

  Lemma zipMap_rev (f : A -> B -> C) xs ys :
    length xs = length ys -> rev (zipMap f xs ys) = zipMap f (rev xs) (rev ys).
  Proof. unfold zipMap; intros; rewrite <- map_rev, combine_rev; auto. Qed.
End ZipMap.


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

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

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

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

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

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

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. lfind.  reflexivity.
Admitted.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Lemma qreva_rev : forall (x y : lst), qreva x y = append (rev x) y.
Proof.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (qreva (qreva x (rev y)) Nil) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite qreva_rev. rewrite rev_rev. reflexivity.
   - intros. simpl.
   rewrite (eq_refl : Cons n (rev y) = append (rev (Cons n Nil)) (rev y)).
   rewrite <- rev_append.
   rewrite IHx.
   rewrite append_assoc.
   simpl. reflexivity.
Qed.