Theorem frobenius (A : Set) (p : A -> Prop) (q : Prop):
  (exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).
Proof.
  split.
  intros [y [H1 H2]].
  split.
  assumption.
  exists y.
  assumption.
  intros [H1 [y H2]].
  exists y.
  split.
  assumption.
  assumption.
Qed.

Parameter A B C : Set.

(* f : A -> B -> C *)
Definition curry (f : A * B -> C) := fun a => fun b => f (a, b).
Definition uncurry (g : A -> B -> C) := fun p => g (fst p) (snd p).

Theorem prf0 : forall f a b, uncurry (curry f) (a, b)= f (a, b).
Proof.
  intros.
  unfold curry, uncurry.
  simpl.
  reflexivity.
Qed.

Theorem prf1 : forall g a b, curry (uncurry g) a b = g a b.
Proof.
  intros.
  unfold curry, uncurry.
  simpl.
  auto.
Qed.


(*|
##################################
Transitivity of subsequence in Coq
##################################

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

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

I have been working my way through logical foundations and have gotten
very stuck on the transitivity of subsequences exercise.

Exercise: 2 stars, advanced (subsequence)
=========================================

A list is a *subsequence* of another list if all of the elements in
the first list occur in the same order in the second list, possibly
with some extra elements in between. For example,

(Optional, harder) Prove ``subseq_trans`` that subsequence is
transitive -- that is, if ``l1`` is a subsequence of ``l2`` and ``l2``
is a subsequence of ``l3``, then ``l1`` is a subsequence of ``l3``.
Hint: choose your induction carefully!

.. coq:: none
|*)

Require Import List.
Import ListNotations.

(*||*)

Inductive subseq : list nat -> list nat -> Prop :=
| sseq_e (l2 : list nat) : subseq [] l2
| sseq_m (l1 l2 : list nat) (n : nat) (H: subseq l1 l2) : subseq (n::l1) (n::l2)
| sseq_nm (l1 l2 : list nat) (n : nat) (H: subseq l1 l2) : subseq l1 (n::l2).

Theorem subseq_trans : forall l1 l2 l3 : list nat,
    subseq l1 l2 -> subseq l2 l3 -> subseq l1 l3.
Proof.
  intros l1 l2 l3 H H0. induction H.
  - apply sseq_e.
  - induction l3.
    + inversion H0.
    + inversion H0.
      * apply sseq_m.
Abort. (* .none *)

(*|
I am having trouble getting the right induction hypothesis after
having tried a couple of different approaches. I have tried a number
of approaches and end up with a situation where, in my assumptions, I
have something like ``subseq l2 (x::l3)`` but then I need to prove
``subseq l2 l3`` which seems like a dead end. Any pointers in the
right direction would be much appreciated.
|*)

(*|
Answer
******

That experience suggests generalizing the induction hypothesis over
``l3``.
|*)

Theorem subseq_trans : forall l1 l2 l3 : list nat,
    subseq l1 l2 -> subseq l2 l3 -> subseq l1 l3.
Proof.
  intros l1 l2 l3 H. generalize dependent l3. induction H; intros l3 H0.
  - apply sseq_e.
  - induction l3.
    + inversion H0.
    + inversion H0.
      * specialize (IHsubseq l3 H2). apply (sseq_m l1 l3 a IHsubseq).
      * specialize (IHl3 H3). apply (sseq_nm (n :: l1) l3 a IHl3).
  - induction l3.
    + inversion H0.
    + inversion H0.
      * specialize (IHsubseq l3 H2). apply (sseq_nm l1 l3 a IHsubseq).
      * specialize (IHl3 H3). apply (sseq_nm l1 l3 a IHl3).
Qed.


Require Import String.
Require Import Ascii.

Definition L (s : ascii) : Prop := True.

Inductive L1 : string -> Prop :=
| epsilon1 : L1 ""
| cons1 : forall x y, L x -> L1 y -> L1 (String x y).

Inductive L2 : string -> Prop :=
| epsilon2 : L2 ""
| L_e_L2 : forall x, L x -> L2 (String x EmptyString)
| cons2 : forall x y, L2 x -> L2 y -> L2 (x ++ y).

Theorem eq_L1_L2 : forall s, L1 s -> L2 s.
Proof.
induction s.
constructor.
intro.
inversion H.
apply L_e_L2 in H2.
apply IHs in H3.
assert ((append (String a EmptyString) s) = (String a s)).
reflexivity.
rewrite <- H4.
constructor.
exact H2.
exact H3.
Qed.


From mathcomp Require Import all_ssreflect all_algebra all_fingroup.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

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

(** #
#

** Lesson 2 MathCompWS ITP'2016
#
# *)

(** #
#
** Big operators

   - a library to manipulate cumulative operators
   - an encapsulation of the fold function
*)

Section F.

(*
Fixpoint foldr f z s := if s is x :: s' then f x (foldr f z s') else z.
*)

Definition f x := x.*2.
Definition g x y := x + y.
Definition r := [::1; 2; 3].
Lemma bfold : foldr (g \o f) 0 r = 12.
Proof.
rewrite /=.
rewrite /f.
rewrite /g.
by [].
Qed.

End F.

(** #
# *)

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

(**  #
#

   ** Notation

   - the basic \big notation
   - operations on elements of a list
   - special notations for usual case (\sum, \prod, \bigcap ..)
*)

Lemma bfoldl : \big[addn/0]_(i <- [::1; 2; 3]) i.*2 = 12.
Proof.
set bigop := BigOp.bigop.
rewrite /bigop.
rewrite big_cons.
rewrite big_cons.
rewrite big_cons.
rewrite big_nil.
by [].
Qed.

Lemma bfoldlm : \big[muln/1]_(i <- [::1; 2; 3]) i.*2 = 48.
Proof.
set bigop := BigOp.bigop.
rewrite /bigop.
rewrite big_cons.
rewrite big_cons.
rewrite big_cons.
rewrite big_nil.
by [].
Qed.

(** #
# *)

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

(**  #
#
   ** Range
   - different ranges are provided
*)

Lemma bfoldl1 : \sum_(1 <= i < 4) i.*2 = 12.
Proof.
set bigop := BigOp.bigop.
rewrite /bigop.
have bl := big_ltn.
have be := big_geq.
rewrite bl.
  rewrite bl.
    rewrite bl.
      rewrite be.
        by [].
      by [].
    by [].
  by [].
by [].
Qed.

Lemma bfoldl2 : \sum_(i < 4) i.*2 = 12.
Proof.
set bigop := BigOp.bigop.
Print ordinal.
rewrite /bigop.
rewrite big_ord_recl.
Check lift.
Print bump.
rewrite /=.
rewrite big_ord_recl.
rewrite /=.
rewrite big_ord_recl.
rewrite big_ord_recl.
rewrite big_ord0.
by [].
Qed.
Qed.

Lemma bfoldl3 : \sum_(i : 'I_4) i.*2 = 12.
Proof.
exact: bfoldl2.
Qed.

(** #
# *)

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

(**  #
#
   ** Filtering
   - selecting some elements of the range
*)

Lemma bfoldl4 : \sum_(i <- [::1; 2; 3; 4; 5; 6] | ~~ odd i) i = 12.
Proof.
set bigop := BigOp.bigop.
rewrite /bigop.
have bp0 := big_pred0.
have bC := big_hasC.
have bmc := big_mkcond.
pose x :=  \sum_(i < 8 | ~~ odd i) i.
pose y :=  \sum_(0 <= i < 8 | ~~ odd i) i.
rewrite big_cons.
rewrite /=.
rewrite big_cons.
rewrite /=.
rewrite big_cons.
rewrite /=.
rewrite big_cons.
rewrite /=.
rewrite big_cons.
rewrite /=.
rewrite big_cons.
rewrite /=.
rewrite big_nil.
by [].
Qed.

(** #
# *)

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

(**  #
#
   ** Switching range
   - changing representation (big_nth, big_mkord).
*)

Lemma bswitch :
  \sum_(i <- [::1; 2; 3]) i.*2 = \sum_(i < 3) (nth 0 [::1; 2; 3] i).*2.
Proof.
have bn := big_nth.
rewrite (big_nth 0).
rewrite /=.
have bm := big_mkord.
rewrite big_mkord.
by [].
Qed.

(** #
# *)

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

(**  #
#
   ** Few examples from the library
*)

(**
   - prime.v
*)

Check divn_count_dvd.
Check logn_count_dvd.
Check dvdn_sum.
Check totient_count_coprime.
Check totientE.

(**- poly.v
*)

Check horner_sum.
Check nderiv_taylor.

(**

   - matrix.v
*)

Check expand_cofactor.
Check expand_det_row.

(**
   - vector.v
*)

Check sumv_sup.
Check freeP.

(** #
# *)

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

(**  #
#
  ** Big operators and equality
  - replacing function and/or predicate
 *)

Lemma beql :
  \sum_(i < 4 | odd i || ~~ odd i) i.*2 =  \sum_(i < 4) i.*2.
Proof.
have ebl := eq_bigl.
apply: eq_bigl  => /=.
move=> n.
by case: odd.
Qed.

Lemma beqr :
  \sum_(i < 4) i.*2 = \sum_(i < 4) (i + i).
Proof.
have ebr := eq_bigr.
apply: eq_bigr.
rewrite /=.
move=> n _.
rewrite addnn.
by [].
Qed.

Lemma beq :
  \sum_(i < 4 | odd i || ~~ odd i) i.*2 = \sum_(i < 4) (i + i).
Proof.
have eb := eq_big.
apply: eq_big => [n|i Hi]; first by case: odd.
by rewrite addnn.
Qed.

(** #
# *)

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

(**  #
#
  ** Monoid structure
  - regrouping thanks to associativity
 *)

Lemma bmon1 : \sum_(i <- [::1; 2; 3]) i.*2 = 12.
Proof.
have bc := big_cat.
rewrite -[[::1; 2; 3]]/([::1] ++ [::2; 3]).
rewrite big_cat.
rewrite /=.
rewrite !big_cons !big_nil.
by [].
Qed.

Lemma bmon2 : \sum_(1 <= i < 4) i.*2 = 12.
Proof.
have bcn := big_cat_nat.
rewrite (big_cat_nat _ _ _ (isT : 1 <= 2)).
  rewrite /=.
  rewrite big_ltn //=.
  rewrite big_geq //.
  by rewrite 2?big_ltn //= big_geq.
by [].
Qed.

Lemma bmon3 : \sum_(i < 4) i.*2 = 12.
Proof.
have borl := big_ord_recl.
have borr := big_ord_recr.
rewrite big_ord_recr.
rewrite /=.
rewrite !big_ord_recr //=.
rewrite big_ord0.
by [].
Qed.

Lemma bmon4 : \sum_(i < 8 | ~~ odd i) i = 12.
Proof.
have H := big_mkcond.
rewrite big_mkcond.
rewrite /=.
rewrite !big_ord_recr /=.
rewrite big_ord0.
by [].
Qed.

(** #
# *)

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

(**  #
#
  ** Abelian Monoid structure
  - dispatching thanks to communitativity
 *)

Lemma bab : \sum_(i < 4) i.*2 = 12.
Proof.
have bd1 := bigD1.
pose x := Ordinal (isT : 2 < 4).
rewrite (bigD1 x).
  rewrite /=.
  rewrite big_mkcond /=.
  rewrite !big_ord_recr /= big_ord0.
  by [].
by [].
Qed.

Lemma bab1 : \sum_(i < 4) (i + i.*2) = 18.
Proof.
have H := big_split.
rewrite big_split /=.
rewrite !big_ord_recr ?big_ord0 /=.
by [].
Qed.

Lemma bab2 :
  \sum_(i < 3) \sum_(j < 4) (i + j) = \sum_(i < 4) \sum_(j < 3) (i + j).
Proof.
have H := exchange_big.
have H1 := reindex_inj.
rewrite exchange_big.
rewrite /=.
apply: eq_bigr.
move=> i _.
apply: eq_bigr.
move=>   j _.
by rewrite addnC.
Qed.

(** #
# *)

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

(**  #
#
  ** Distributivity
  - exchanging sum and product
 *)

Lemma bab3 : \sum_(i < 4) (2 * i) = 2 * \sum_(i < 4) i.
Proof.
have H := big_distrr.
by rewrite big_distrr.
Qed.

Lemma bab4 :
  (\prod_(i < 3) \sum_(j < 4) (i ^ j)) =
  \sum_(f : {ffun 'I_3 -> 'I_4}) \prod_(i < 3) (i ^ (f i)).
Proof.
have bdb := big_distr_big.
have bdbd := big_distr_big_dep.
rewrite  (big_distr_big ord0).
rewrite /=.
apply: eq_bigl.
move=> f.
rewrite /=.
apply/forallP.
rewrite /=.
by [].
Qed.

(** #
# *)

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

(**  #
#
  ** Property, Relation and Morphism
   - higher-order properties
 *)

Lemma bap n : ~~ odd (\sum_(i < n) i.*2).
Proof.
have bi := big_ind.
have bi2 := big_ind2.
have bm := big_morph.
elim/big_ind: _.
- by [].
- move=> x y.
  rewrite odd_add.
  case: odd.
     by [].
  by [].
rewrite /=.
move=> i _.
by rewrite odd_double.
Qed.

(** #
# *)

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

(**  #
#
     ** Leibniz Triangle
   *)

Definition leibnizn m n := m.+1 *  'C(m, n).

Notation "''L' ( n , m )" := (leibnizn n m)
  (at level 8, format "''L' ( n ,  m )") : nat_scope.

Lemma leibn0 n : 'L(n, 0) = n.+1.
Proof. by rewrite /leibnizn bin0 muln1. Qed.

Lemma leibnn n : 'L(n, n) = n.+1.
Proof. by rewrite /leibnizn binn muln1. Qed.

Lemma leibn_small m n : m < n -> 'L(m, n) = 0.
Proof. by move=> Hmn; rewrite /leibnizn bin_small ?muln0. Qed.

Lemma leibn_sub m n :  n <= m -> 'L(m, m - n) = 'L(m, n).
Proof. by move=> Lnm; rewrite /leibnizn bin_sub. Qed.

Lemma leibn_gt0 m n : n <= m -> 0 < 'L(m, n).
Proof. by move=> Lnm; rewrite /leibnizn muln_gt0 bin_gt0. Qed.

Lemma bin_up m n : m.+1 * 'C(m, n) = (m.+1 - n) * 'C(m.+1, n).
Proof.
elim: m n => [|m IHm] [|n] //.
case: (leqP m.+1 n)=> [H|H].
  by apply/eqP; rewrite bin_small // muln0 eq_sym muln_eq0 subn_eq0 ltnS H.
rewrite subSS mulSn {2}binS mulnDr !IHm addnA subSS -mulSn -subSn //.
by rewrite -mulnDr -binS.
Qed.

Lemma leibn_up m n : m.+2 * 'L(m, n) = (m.+1 - n) * 'L(m.+1, n).
Proof. by rewrite /leibnizn bin_up mulnCA. Qed.

Lemma bin_right m n : n.+1 * 'C(m.+1, n.+1) = (m.+1 - n) * 'C(m.+1, n).
Proof.
elim: m n => [|m IHm] [|n] //; first by rewrite bin0 bin1 muln1 mul1n.
rewrite [in RHS]binS subSS mulnDr -IHm -mulnDl -mul_Sm_binm.
case: (leqP n m.+1)=> [H|H]; first by rewrite addnS subnK.
by rewrite bin_small ?muln0 // ltnW.
Qed.

Lemma leibn_right m n : n.+1 * 'L(m.+1, n.+1) = (m.+1 - n) * 'L(m.+1, n).
Proof. by rewrite /leibnizn mulnCA bin_right mulnCA. Qed.

Lemma leibnS m n :
  'L(m.+1, n.+1) * 'L(m.+1, n) = 'L(m, n) * ('L(m.+1, n.+1) + 'L(m.+1, n)).
Proof.
case: (leqP n m.+1) => H; last first.
  by rewrite leibn_small 1?ltnW // leibn_small.
apply/eqP.
have /eqn_pmul2l<- : m.+2 * n.+1 > 0 by [].
apply/eqP.
rewrite -[_.+2 * _ * _]mulnA [n.+1 * _]mulnA.
rewrite [in RHS]mulnCA -[_.+2 * _ * _ in RHS]mulnA.
rewrite mulnDr leibn_right.
rewrite mulnDr [m.+2 * (_.+1 * _) in RHS] mulnCA.
rewrite -{1}leibn_up [in RHS]mulnC mulnDl.
rewrite -mulnA ['L(_,_) * _]mulnC 2!mulnA.
rewrite -mulnDl; congr (_ * _).
rewrite [X in _ = X + _]mulnA [X in _ = _ + X]mulnA.
rewrite -mulnDl; congr (_ * _).
by rewrite [_ * _.+2 in RHS]mulnC -mulnDr addnS subnK.
Qed.

Lemma lcmn_swap a b c :
    a * c = b * (a + c) -> lcmn b c = lcmn a c.
Proof.
case: a => [|a].
  by move/eqP; rewrite add0n eq_sym muln_eq0=> /orP[] /eqP->; rewrite !(lcm0n,lcmn0).
case: b => [|b].
  by move/eqP; rewrite muln_eq0=> /orP[] /eqP->; rewrite !(lcm0n,lcmn0).
case: c => [|c H].
  by move/eqP; rewrite addn0 eq_sym muln0 muln_eq0=> /orP[] /eqP->;
     rewrite !(lcm0n,lcmn0).
apply/eqP.
have /eqn_pmul2r<- : a.+1 * gcdn b.+1 c.+1 > 0 by rewrite muln_gt0 gcdn_gt0.
  rewrite {2}muln_gcdr H [b.+1 * _]mulnC mulnDl gcdnDl.
  by rewrite mulnCA muln_lcm_gcd -muln_gcdl !mulnA muln_lcm_gcd [X in _ == X]mulnAC.
Qed.

Lemma leibn_lcm_swap m n :
   lcmn 'L(m.+1, n) 'L(m, n) = lcmn 'L(m.+1, n) 'L(m.+1, n.+1).
Proof.
rewrite ![lcmn 'L(m.+1, n) _]lcmnC.
by apply/lcmn_swap/leibnS.
Qed.

(** #
# *)

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

(**  #
#
    ** Lcm bigop
   *)

Notation "\lcm_ ( i < n ) F" :=
 (\big[lcmn/1%N]_(i < n ) F%N)
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \lcm_ ( i  <  n  ) '/  '  F ']'") : nat_scope.

Canonical Structure lcmn_moid : Monoid.law 1 :=
  Monoid.Law lcmnA lcm1n lcmn1.
Canonical lcmn_comoid := Monoid.ComLaw lcmnC.

Lemma leib_line n i k : lcmn 'L(n.+1, i) (\lcm_(j < k) 'L(n, i + j)) =
                   \lcm_(j < k.+1) 'L(n.+1, i + j).
Proof.
elim: k i => [i|k1 IH i].
  by rewrite big_ord_recr !big_ord0 /= lcmn1 lcm1n addn0.
rewrite big_ord_recl /= addn0.
rewrite lcmnA leibn_lcm_swap.
rewrite (eq_bigr (fun j : 'I_k1 => 'L(n, i.+1 + j))).
rewrite -lcmnA.
rewrite IH.
rewrite [RHS]big_ord_recl.
rewrite addn0; congr (lcmn _ _).
by apply: eq_bigr => j _; rewrite addnS.
move=> j _.
by rewrite addnS.
Qed.

Lemma leib_corner n : \lcm_(i < n.+1) 'L(i, 0) = \lcm_(i < n.+1) 'L(n, i).
Proof.
elim: n => [|n IH]; first by rewrite !big_ord_recr !big_ord0 /=.
rewrite big_ord_recr /= IH lcmnC.
rewrite (eq_bigr (fun i : 'I_n.+1 => 'L(n, 0 + i))) //.
by rewrite leib_line.
Qed.

Lemma main_result n : 2^n.-1 <= \lcm_(i < n) i.+1.
Proof.
case: n => [|n /=]; first by rewrite big_ord0.
have <-: \lcm_(i < n.+1) 'L(i, 0) = \lcm_(i < n.+1) i.+1.
  by apply: eq_bigr => i _; rewrite leibn0.
rewrite leib_corner.
have -> : forall j,  \lcm_(i < j.+1) 'L(n, i) = n.+1 *  \lcm_(i < j.+1) 'C(n, i).
  elim=> [|j IH]; first by rewrite !big_ord_recr !big_ord0 /= !lcm1n.
  by rewrite big_ord_recr [in RHS]big_ord_recr /= IH muln_lcmr.
rewrite (expnDn 1 1) /=  (eq_bigr (fun i : 'I_n.+1 => 'C(n, i))) =>
       [|i _]; last by rewrite !exp1n !muln1.
have <- : forall n m,  \sum_(i < n) m = n * m.
  by move=> m1 n1; rewrite sum_nat_const card_ord.
apply: leq_sum => i _.
apply: dvdn_leq; last by rewrite (bigD1 i) //= dvdn_lcml.
apply big_ind => // [x y Hx Hy|x H]; first by rewrite lcmn_gt0 Hx.
by rewrite bin_gt0 -ltnS.
Qed.

(** #
# *)

(**
#

# *)


(* Exercise 102 *)

Require Import BenB.

Variables A B C D : Prop.

(* Inverse Double Contrapositive *)

Theorem exercise_102 : (~~A -> ~~B) -> (A -> B).
Proof.
imp_i a1.
imp_i a2.
neg_e' (~B) a3.
imp_e (~~A).
hyp a1.
neg_i A a4.
hyp a4.
hyp a2.
hyp a3.
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 (lf2 : natural) (lf1 : natural) (y : natural) (x : natural)
  : natural := plus x y.


Require Import StateMachines.Preliminaries.
Require Import StateMachines.Concepts.
Import ListNotations.

Section MachineTheory.
Variable m : Machine.

(* Rest law *)
Definition act0 (f : state m → list (input m) → state m)
:= ∀ s : state m, f s [] = s.
(* Single impact law *)
Definition act1 (f : state m → list (input m) → state m)
:= ∀ (s : state m) (i : input m), f s [i] = pass m s i.
(* Cumulative law *)
Definition actC (f : state m → list (input m) → state m)
:= ∀ (s : state m) (u' u'' : list (input m)),
     f s (u' ++ u'') = f (f s u') u''.

Lemma run0 : act0 (run m).
Proof. unfold act0. trivial. Qed.

Lemma run1 : act1 (run m).
Proof. unfold act1. trivial. Qed.

Lemma runC : actC (run m).
Proof.
  unfold actC. intros. revert s.
  induction u' as [| i v IHu']; intro; simpl.
  - reflexivity.
  - exact (IHu' (pass m s i)).
Qed.

Section UniquenessTheorem.
Variable run' : state m → list (input m) → state m.
Hypotheses (H0 : act0 run')
           (H1 : act1 run')
           (HC : actC run').

Theorem run_uniqueness : ∀ (s : state m) (u : list (input m)),
  run' s u = run m s u.
Proof.
  intros. revert s.
  induction u as [| i u' IHu]; intro; simpl.
  - apply H0.
  - assert (H : [i] ++ u' = i :: u'). { trivial. }
    rewrite <- H. rewrite (HC s [i] u').
    rewrite <- (H1 s). apply IHu.
Qed.
End UniquenessTheorem.
End MachineTheory.


(* Exercise 35 *)

Require Import BenB.

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

Theorem exercise_035 : (forall y, Q y -> ~ exists x, P x) /\ (forall x, P x) -> (forall y, ~ Q y).
Proof.
imp_i a1.
all_i a.
neg_i (exists x:D, P x) a2.
imp_e (Q a).
all_e (forall y:D, Q y -> ~(exists x:D, P x)) a.
con_e1 (forall x:D, P x).
hyp a1.
hyp a2.
exi_i a.
all_e (forall x:D, P x) a.
con_e2 (forall y:D, Q y -> ~(exists x:D, P x)).
hyp a1.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.

(* Zadanie 83. *)

Module Tree83.

Inductive Tree a :=
  | L : a -> Tree a
  | B : Tree a -> Tree a -> Tree a
.

Class Functor (F: Type -> Type) := {
  fmap : forall {A B}, (A -> B) -> (F A -> F B);
  fmap_pres_comp : forall (A B C: Type) (f: A->B) (g: B->C),
    fmap (compose g f) = compose (fmap g) (fmap f);
  fmap_pres_id : forall A, fmap (@id A) = @id (F A);
}.

Definition Natural F G {FunF : Functor F} {FunG : Functor G} := forall A, F A -> G A.

Instance Functor_tree : Functor Tree := {
  fmap := fix rec A X f t :=
    match t with
    | L _ a => L X (f a)
    | B _ l r => B X (rec A X f l) (rec A X f r)
    end
}.
Proof.
  - intros.
    extensionality l.
    induction l.
    + trivial.
    + simpl.
      rewrite IHl1.
      rewrite IHl2.
      trivial.
  - intros.
    extensionality l.
    induction l.
    + trivial.
    + simpl.
      rewrite IHl1.
      rewrite IHl2.
      trivial.
Defined.

Class Applicative (F: Type -> Type) := {
  applicative_functor: Functor F;
  pure : forall {A}, A -> F A;
  ap : forall {A B}, F (A -> B) -> F A -> F B;
  pure_id : forall A (v: F A),
    ap (pure (@id A)) v = v;
  pure_compose : forall A B C
    (u:F (B->C)) (v: F (A->B)) (w: F A),
    ap (ap (ap (pure compose) u) v) w = ap u (ap v w);
  pure_homo : forall A B (f:A->B) (x:A),
    ap (pure f) (pure x) = pure (f x);
  pure_int : forall A B (u : F (A->B)) (y: A),
    ap u (pure y) = ap (pure (fun x => x y)) u;
}.

Fixpoint ap_tree {A X} (ff: Tree (A->X)) (fa: Tree A) :=
  match ff with
  | L _ f => fmap f fa
  | B _ l r => B X (ap_tree l fa) (ap_tree r fa)
  end.

Instance Applicative_Tree : Applicative Tree := {
  applicative_functor := Functor_tree;
  pure := L;
  ap := @ap_tree;
}.
Proof.
  - intros.
    induction v.
    + trivial.
    + unfold ap_tree.
      rewrite fmap_pres_id.
      unfold id.
      trivial.
  - intros A B C u v w.
    induction u; induction v; induction w.
    + trivial.
    + simpl in *.
      rewrite IHw1.
      rewrite IHw2.
      trivial.
    + simpl in *.
      rewrite IHv1.
      rewrite IHv2.
      trivial.
    + simpl in *.
      rewrite IHv1.
      rewrite IHv2.
      trivial.
    + simpl in *.
      rewrite IHu1.
      rewrite IHu2.
      trivial.
    + simpl in *.
      rewrite IHu1.
      rewrite IHu2.
      trivial.
    + simpl in *.
      rewrite IHu1.
      rewrite IHu2.
      trivial.
    + simpl in *.
      rewrite IHu1.
      rewrite IHu2.
      trivial.
  - intros.
    simpl in *.
    trivial.
  - intros.
    induction u.
    + trivial.
    + simpl in *.
      rewrite IHu1.
      rewrite IHu2.
      trivial.
Defined.

Class Monad (F: Type -> Type) := {
  monad_applicative : Applicative F;
  ret : forall {A}, A -> F A;
  bind : forall {A X}, F A -> (A -> F X) -> F X;
  monad_left_id : forall A X (a: A) (f: A -> F X),
    bind (ret a) f = f a;
  monad_right_id : forall A (m: F A), bind m ret = m;
  monad_assoc : forall A X Y (m : F A) (f: A -> F X) (g: X -> F Y),
    bind (bind m f) g = bind m (fun x => bind (f x) g);
}.

Fixpoint Tree_bind {A X} (fa: Tree A) (f: A -> Tree X) : Tree X :=
  match fa with
  | L _ a => f a
  | B _ l r => B X (Tree_bind l f) (Tree_bind r f)
  end.

Instance Monad_Tree : Monad Tree := {
  monad_applicative := Applicative_Tree;
  ret := L;
  bind := @Tree_bind;
}.
Proof.
  - trivial.
  - intros.
    induction m.
    + trivial.
    + simpl in *.
      rewrite IHm1.
      rewrite IHm2.
      trivial.
  - intros.
    induction m.
    + trivial.
    + simpl in *.
      rewrite IHm1.
      rewrite IHm2.
      trivial.
Defined.

Class MonadJoin (F: Type -> Type) := {
  monadjoin_applicative : Applicative F;
  monadjoin_functor : Functor F := applicative_functor;
  eta : forall {A}, A -> F A;
  mu : forall {A}, F (F A) -> F A;
  monadjoin_left_id : forall A (fa: F A), mu (eta fa) = fa;
  monadjoin_right_id : forall A (fa: F A),
    mu (fmap eta fa) = fa;
  monadjoin_assoc : forall A (ma : F (F (F A))),
    mu (mu ma) = mu (fmap mu ma);
}.

Fixpoint Tree_mu {A} (ma: Tree (Tree A)) : Tree A :=
  match ma with
  | L _ t => t
  | B _ l r => B A (Tree_mu l) (Tree_mu r)
  end.

Instance MonadJoin_Tree : MonadJoin Tree := {
  eta := L;
  mu := @Tree_mu;
}.
Proof.
  - trivial.
  - intros.
    induction fa.
    + trivial.
    + simpl in *.
      rewrite IHfa1.
      rewrite IHfa2.
      trivial.
  - intros.
    induction ma.
    + trivial.
    + simpl in *.
      rewrite IHma1.
      rewrite IHma2.
      trivial.
Defined.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.

Module Chapter2.

  (* Большинство из этого я уже знаю,
     поэтому буду много пропускать. *)

  Lemma muln_eq0 m n :
    (m * n == 0) = (m == 0) || (n == 0).
  Proof.
    (* Читается как: [m] может быть или [0] или
       некоторым выражением [m.+1] (для нового [m])*)
    case: m=> [|m].
    by [].
    (* По умолчанию successor case становится 2-ой подцелью
       (согласно порядку, в котором определены конструкторы
       соответствующего индуктивного типа). Мы можем это изменить
       при помощи [; last first] "суффикса" *)
    case: n=> [|k]; last first.
    - by [].
    by rewrite muln0.
  Abort.

  Lemma seq_eq_ext (s1 s2 : seq nat) :
    size s1 = size s2 ->
    (forall i : nat, nth 0 s1 i = nth 0 s2 i) ->
    s1 = s2.
  Proof.
  Admitted.

  Lemma size_map (T1 T2 : Type) :
    forall (f : T1 -> T2) (s : seq T1),
      size (map f s) = size s.

    (* [forall (f : T1 -> T2) (s : seq T1)]
       is a syntactic sugar for
       [forall f : T1 - T2, forall s : seq T1] *)
  Admitted.

  (* Квантификаторы так же могут быть
     использованы в теле определений *)
  Definition commutative (S T : Type) (op : S -> S -> T) :=
    forall x y, op x y = op y x.

  (* Такие определения позволяют более лаконично
     записывать вещи вроде *)
  Lemma addnC : commutative addn. Admitted.

  Check (3 = 3).
  Check (commutative addn).

  Lemma leqnn n : n <= n. Proof. Admitted.

  Lemma example1 a b : a + b <= a + b.
  Proof. apply: leqnn. Qed.

  (* The comparison performed by the
     [apply] tactic is up to computation *)
  (* Т.е. перед тем, как применить тактику [apply] с указанной леммой,
     будут выполнены возможные символические вычисления *)
  Lemma example2 a b : a.+1 + b <= (a + b).+1.
  Proof. apply: leqnn. Qed.

  (* Чтобы упростить доказательства, мы можем усилить терминатор [by],
     включив в него некоторые дополнительные леммы.
     Для этого используется команда [Hint Resolve]: *)
  Hint Resolve leqnn. (* Это нужно писать рядом с доказанной леммой *)

  (* Теперь предыдущую лемму можно доказать тривиально *)
  Lemma example3 a b : a + b <= a + b.
  Proof. by []. Qed.

  Lemma contra' (c b : bool) : (c -> b) -> ~~ b -> ~~ c.
  Proof.
    (* rewrite /negb. *)
    case: b.
    - by [].
    case: c.
    - by [].
    by [].
  Qed.

  Lemma negbNE' b : ~~ ~~ b -> b.
  Proof.
    rewrite /negb.
    case: b.
    - by [].
    by [].
  Qed.

  Locate "%|".
  About dvdn.
  (* Definition dvdn d m := m %% d == 0. *)

  Lemma prime_example1 m p :
    (* - [p] простое
       - [p] делит [m! + 1] без остатка *)
    prime p -> p %| m`! + 1 -> m < p.
  Proof.
    move=> H_prime_p.
    (* Преoбразуем в обратное утверждение *)
    (* contraLR : forall c b : bool,
       (~~ c -> ~~ b) -> b -> c *)
    apply: contraLR.

    (* leqNgt : forall m n : nat,
       (m <= n) = ~~ (n < m) *)
    rewrite -leqNgt=> leq_p_m.
    (* dvdn_addr : forall m d n : nat,
       d %| m -> (d %| m + n) = (d %| n) *)

    (* Можно переписывать и "условные равенства".
       При попытке это сделать нам придётся доказать предпосылку
       (создастся\добавится соответствующая подцель). *)
    rewrite dvdn_addr.

    (* gtnNdvd n d : 0 < n -> n < d -> (d %| n) = false *)
    rewrite gtnNdvd=> // //.
    (* Сразу убрали 2 тривиально-доказуемых неравенства при помощи [// //]. *)
    - apply: prime_gt1. (* prime_gt1 p : prime p -> 1 < p *)
      exact: H_prime_p.
   (* dvdn_fact m n : 0 < m <= n -> m %| n`! *)
   apply: dvdn_fact.
   (* Имеем [0 < p <= m], что есть сокращённая запись для
      [(0 < p) && (p <= m)] *)
   (* Воспользуемся [prime_gt0 p : prime p -> 0 < p].
      Нужно это читать как [prime p -> 0 < p = true] *)
   (* Тут происходит по сути тоже самое, что и в примере выше, где
      мы переписывали с [dvdn_addr] -- Coq заменит [0 < p] на [true] и
      попросит нас доказать препосылку [prime p] *)
   rewrite prime_gt0.
   - exact: leq_p_m.
   - exact: H_prime_p.
  Qed.

End Chapter2.


Section ExtensionalEqualityAndComposition.

Variables A B C D : Type.

(** Exercise 2a *)
(** [\o] is a notation for function composition in MathComp, prove that it's associative *)

Definition compA (f : A -> B) (g : B -> C) (h : C -> D) :
  (h \o g) \o f = h \o (g \o f)
:=

(** [=1] stands for extensional equality on unary functions,
    i.e. [f =1 g] means [forall x, f x = g x].
    This means it's an equivalence relation, i.e. it's reflexive, symmetric and transitive.
    Let us prove a number of facts about [=1]. *)

(** Exercise: Reflexivity *)
Definition eqext_refl :
  forall (f : A -> B), f =1 f
:=

(** Exercise: Symmetry *)
Definition eqext_sym :
  forall (f g : A -> B), f =1 g -> g =1 f
:=

(** Exercise: Transitivity *)
Definition eqext_trans :
  forall (f g h : A -> B), f =1 g -> g =1 h -> f =1 h
:=

(** Exercise: left congruence *)
Definition eq_compl :
  forall (f g : A -> B) (h : B -> C),
    f =1 g -> h \o f =1 h \o g
:=

(** Exercise: right congruence *)
Definition eq_compr :
  forall (f g : B -> C) (h : A -> B),
    f =1 g -> f \o h =1 g \o h
:=

End ExtensionalEqualityAndComposition.


(** * Maps: Total and Partial Maps *)

(** Maps (or dictionaries) are ubiquitous data structures, both in
    software construction generally and in the theory of programming
    languages in particular; we're going to need them in many places
    in the coming chapters.  They also make a nice case study using
    ideas we've seen in previous chapters, including building data
    structures out of higher-order functions (from [Basics] and
    [Poly]) and the use of reflection to streamline proofs (from
    [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we start.

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [SearchAbout] command is a good way to look for theorems
    involving objects of specific types. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  For this purpose, we again use the type [id] from the
    [Lists] chapter.  To make this chapter self contained, we repeat
    its definition here, together with the equality comparison
    function for [id]s and its fundamental property. *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity. Qed.

(** The following useful property of [beq_id] follows from an
    analogous lemma about numbers: *)

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

(** Similarly: *)

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This useful variant follows just by rewriting: *)

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about their behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := id -> A.

(** Intuitively, a total map over an element type [A] _is_ just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

(** This definition is a nice example of higher-order programming.
    The [t_update] function takes a _function_ [m] and yields a new
    function [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) (Id 1) false)
           (Id 3) true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

Example update_example1 : examplemap (Id 0) = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id 1) = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id 2) = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id 3) = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave.  Even if you don't work the following
    exercises, make sure you thoroughly understand the statements of
    the lemmas!  (Some of the proofs require the functional
    extensionality axiom, which is discussed in the [Logic]
    chapter and included in the Coq standard library.) *)

(** **** Exercise: 1 star, optional (t_apply_empty)  *)
(** First, the empty map returns its default element for all keys: *)
Lemma t_apply_empty:  forall A x v, @t_empty A v x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(** **** Exercise: 2 stars (beq_idP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** Using the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma apply_empty : forall A x, @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(** $Date: 2015-12-11 17:17:29 -0500 (Fri, 11 Dec 2015) $ *)


(****************************************************************************

          IEEE754  :  FPred

          Laurent Thery

  ******************************************************************************)
Require Export FSucc.
Section pred.
Variable b : Fbound.
Variable radix : Z.
Variable precision : nat.

Let FtoRradix := FtoR radix.
Local Coercion FtoRradix : float >-> R.

Hypothesis radixMoreThanOne : (1 < radix)%Z.
Hypothesis precisionNotZero : precision <> 0.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Definition FPred (x : float) :=
  match Z_eq_bool (Fnum x) (- pPred (vNum b)) with
  | true => Float (- nNormMin radix precision) (Zsucc (Fexp x))
  | false =>
      match Z_eq_bool (Fnum x) (nNormMin radix precision) with
      | true =>
          match Z_eq_bool (Fexp x) (- dExp b) with
          | true => Float (Zpred (Fnum x)) (Fexp x)
          | false => Float (pPred (vNum b)) (Zpred (Fexp x))
          end
      | false => Float (Zpred (Fnum x)) (Fexp x)
      end
  end.

Theorem FPredSimpl1 :
 forall x : float,
 Fnum x = (- pPred (vNum b))%Z ->
 FPred x = Float (- nNormMin radix precision) (Zsucc (Fexp x)).
intros x H'; unfold FPred in |- *.
generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b)));
 case (Z_eq_bool (Fnum x) (- pPred (vNum b))); auto.
intros H'0; Contradict H'0; auto.
Qed.

Theorem FPredSimpl2 :
 forall x : float,
 Fnum x = nNormMin radix precision ->
 Fexp x <> (- dExp b)%Z -> FPred x = Float (pPred (vNum b)) (Zpred (Fexp x)).
intros x H' H'0; unfold FPred in |- *.
generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b)));
 case (Z_eq_bool (Fnum x) (- pPred (vNum b))); auto.
intros H'1; absurd (0%nat < Fnum x)%Z; auto with zarith arith.
apply Zle_not_lt; rewrite H'1; replace (Z_of_nat 0) with (- (0))%Z;
 [ apply Zle_Zopp | simpl in |- *; auto ].
unfold pPred in |- *; apply Zle_Zpred; red in |- *; simpl in |- *; auto.
rewrite H'.
apply nNormPos; auto with zarith.
intros H'1;
 generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision));
 case (Z_eq_bool (Fnum x) (nNormMin radix precision)).
intros H'2; generalize (Z_eq_bool_correct (Fexp x) (- dExp b));
 case (Z_eq_bool (Fexp x) (- dExp b)); auto.
intros H'3; Contradict H'0; auto.
intros H'2; Contradict H'2; auto.
Qed.

Theorem FPredSimpl3 :
 FPred (Float (nNormMin radix precision) (- dExp b)) =
 Float (Zpred (nNormMin radix precision)) (- dExp b).
unfold FPred in |- *; simpl in |- *.
generalize (Z_eq_bool_correct (nNormMin radix precision) (- pPred (vNum b)));
 case (Z_eq_bool (nNormMin radix precision) (- pPred (vNum b)));
 auto.
intros H'0; absurd (0 < pPred (vNum b))%Z; auto with zarith arith.
rewrite <- (Zopp_involutive (pPred (vNum b))); rewrite <- H'0.
apply Zle_not_lt; replace 0%Z with (- (0))%Z;
 [ apply Zle_Zopp | simpl in |- *; auto ].
apply Zlt_le_weak; apply nNormPos; auto with float zarith.
unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *;
 auto with float zarith.
simpl in |- *; apply vNumbMoreThanOne with (3 := pGivesBound); auto.
intros H';
 generalize
  (Z_eq_bool_correct (nNormMin radix precision) (nNormMin radix precision));
 case (Z_eq_bool (nNormMin radix precision) (nNormMin radix precision)).
intros H'0; generalize (Z_eq_bool_correct (- dExp b) (- dExp b));
 case (Z_eq_bool (- dExp b) (- dExp b)); auto.
intros H'1; Contradict H'1; auto.
intros H'1; Contradict H'1; auto.
Qed.

Theorem FPredSimpl4 :
 forall x : float,
 Fnum x <> (- pPred (vNum b))%Z ->
 Fnum x <> nNormMin radix precision ->
 FPred x = Float (Zpred (Fnum x)) (Fexp x).
intros x H' H'0; unfold FPred in |- *.
generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b)));
 case (Z_eq_bool (Fnum x) (- pPred (vNum b))); auto.
intros H'1; Contradict H'; auto.
intros H'1;
 generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision));
 case (Z_eq_bool (Fnum x) (nNormMin radix precision));
 auto.
intros H'2; Contradict H'0; auto.
Qed.

Theorem FPredFopFSucc :
 forall x : float, FPred x = Fopp (FSucc b radix precision (Fopp x)).
intros x.
generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b)));
 case (Z_eq_bool (Fnum x) (- pPred (vNum b))); intros H'1.
rewrite FPredSimpl1; auto; rewrite FSuccSimpl1; auto.
unfold Fopp in |- *; simpl in |- *; rewrite H'1; auto with zarith.
generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision));
 case (Z_eq_bool (Fnum x) (nNormMin radix precision));
 intros H'2.
generalize (Z_eq_bool_correct (Fexp x) (- dExp b));
 case (Z_eq_bool (Fexp x) (- dExp b)); intros H'3.
replace x with (Float (Fnum x) (Fexp x)).
rewrite H'2; rewrite H'3; rewrite FPredSimpl3; unfold Fopp in |- *;
 simpl in |- *; rewrite FSuccSimpl3; simpl in |- *;
 auto.
rewrite <- Zopp_Zpred_Zs; rewrite Zopp_involutive; auto.
case x; simpl in |- *; auto.
rewrite FPredSimpl2; auto; rewrite FSuccSimpl2; unfold Fopp in |- *;
 simpl in |- *; try rewrite Zopp_involutive;
 auto.
rewrite H'2; auto.
rewrite FPredSimpl4; auto; rewrite FSuccSimpl4; auto.
unfold Fopp in |- *; simpl in |- *; rewrite <- Zopp_Zpred_Zs;
 rewrite Zopp_involutive; auto.
unfold Fopp in |- *; simpl in |- *; Contradict H'1; rewrite <- H'1;
 rewrite Zopp_involutive; auto.
unfold Fopp in |- *; simpl in |- *; Contradict H'2; auto with zarith.
Qed.

Theorem FPredDiff1 :
 forall x : float,
 Fnum x <> nNormMin radix precision ->
 Fminus radix x (FPred x) = Float 1%nat (Fexp x) :>R.
intros x H'; rewrite (FPredFopFSucc x).
pattern x at 1 in |- *; rewrite <- (Fopp_Fopp x).
rewrite <- Fopp_Fminus_dist.
rewrite Fopp_Fminus.
unfold FtoRradix in |- *; rewrite FSuccDiff1; auto.
replace (Fnum (Fopp x)) with (- Fnum x)%Z.
Contradict H'; rewrite <- (Zopp_involutive (Fnum x)); rewrite H';
 auto with zarith.
case x; simpl in |- *; auto.
Qed.

Theorem FPredDiff2 :
 forall x : float,
 Fnum x = nNormMin radix precision ->
 Fexp x = (- dExp b)%Z -> Fminus radix x (FPred x) = Float 1%nat (Fexp x) :>R.
intros x H' H'0; rewrite (FPredFopFSucc x).
pattern x at 1 in |- *; rewrite <- (Fopp_Fopp x).
rewrite <- Fopp_Fminus_dist.
rewrite Fopp_Fminus.
unfold FtoRradix in |- *; rewrite FSuccDiff2; auto.
rewrite <- H'; case x; auto.
Qed.

Theorem FPredDiff3 :
 forall x : float,
 Fnum x = nNormMin radix precision ->
 Fexp x <> (- dExp b)%Z ->
 Fminus radix x (FPred x) = Float 1%nat (Zpred (Fexp x)) :>R.
intros x H' H'0; rewrite (FPredFopFSucc x).
pattern x at 1 in |- *; rewrite <- (Fopp_Fopp x).
rewrite <- Fopp_Fminus_dist.
rewrite Fopp_Fminus.
unfold FtoRradix in |- *; rewrite FSuccDiff3; auto.
rewrite <- H'; case x; auto.
Qed.

Theorem FBoundedPred : forall f : float, Fbounded b f -> Fbounded b (FPred f).
intros f H'; rewrite (FPredFopFSucc f); auto with float.
Qed.

Theorem FPredCanonic :
 forall a : float, Fcanonic radix b a -> Fcanonic radix b (FPred a).
intros a H'.
rewrite FPredFopFSucc; auto with float.
Qed.

Theorem FPredLt : forall a : float, (FPred a < a)%R.
intros a; rewrite FPredFopFSucc.
pattern a at 2 in |- *; rewrite <- (Fopp_Fopp a).
unfold FtoRradix in |- *; repeat rewrite Fopp_correct.
apply Ropp_lt_contravar.
rewrite <- Fopp_correct; auto with float.
Qed.

Theorem R0RltRlePred : forall x : float, (0 < x)%R -> (0 <= FPred x)%R.
intros x H'; rewrite FPredFopFSucc.
unfold FtoRradix in |- *; repeat rewrite Fopp_correct.
replace 0%R with (-0)%R; auto with real.
apply Ropp_le_contravar.
apply R0RltRleSucc; auto.
unfold FtoRradix in |- *; repeat rewrite Fopp_correct.
replace 0%R with (-0)%R; auto with real.
Qed.

Theorem FPredProp :
 forall x y : float,
 Fcanonic radix b x -> Fcanonic radix b y -> (x < y)%R -> (x <= FPred y)%R.
intros x y H' H'0 H'1; rewrite FPredFopFSucc.
rewrite <- (Fopp_Fopp x).
unfold FtoRradix in |- *; rewrite Fopp_correct with (x := Fopp x).
rewrite Fopp_correct with (x := FSucc b radix precision (Fopp y));
 auto with float real.
apply Ropp_le_contravar.
apply FSuccProp; auto with float.
repeat rewrite Fopp_correct; auto with real.
Qed.

Theorem FPredZleEq :
 forall p q : float,
 (FPred p < q)%R -> (q <= p)%R -> (Fexp p <= Fexp q)%Z -> p = q :>R.
intros p q H' H'0 H'1.
rewrite <- (Ropp_involutive p); rewrite <- (Ropp_involutive q);
 apply Ropp_eq_compat.
unfold FtoRradix in |- *; repeat rewrite <- Fopp_correct.
apply FSuccZleEq with (b := b) (precision := precision); auto.
repeat rewrite Fopp_correct; auto with real.
apply Ropp_lt_cancel.
repeat rewrite <- Fopp_correct; rewrite <- FPredFopFSucc; rewrite Fopp_Fopp;
 auto.
Qed.

Definition FNPred (x : float) := FPred (Fnormalize radix b precision x).

Theorem FNPredFopFNSucc :
 forall x : float, FNPred x = Fopp (FNSucc b radix precision (Fopp x)).
intros x; unfold FNPred, FNSucc in |- *; auto.
rewrite Fnormalize_Fopp; auto.
apply FPredFopFSucc; auto.
Qed.

Theorem FNPredCanonic :
 forall a : float, Fbounded b a -> Fcanonic radix b (FNPred a).
intros a H'; unfold FNPred in |- *.
apply FPredCanonic; auto with float.
Qed.

Theorem FNPredLt : forall a : float, (FNPred a < a)%R.
intros a; unfold FNPred in |- *.
unfold FtoRradix in |- *;
 rewrite <- (FnormalizeCorrect _ radixMoreThanOne b precision a).
apply FPredLt; auto.
Qed.

Theorem FNPredProp :
 forall x y : float,
 Fbounded b x -> Fbounded b y -> (x < y)%R -> (x <= FNPred y)%R.
intros x y H' H'0 H'1; unfold FNPred in |- *.
replace (FtoRradix x) with (FtoRradix (Fnormalize radix b precision x)).
apply FPredProp; auto with float.
unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto.
unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto.
Qed.

Theorem FPredSuc :
 forall x : float,
 Fcanonic radix b x -> FPred (FSucc b radix precision x) = x.
intros x H; unfold FPred, FSucc in |- *.
cut (Fbounded b x); [ intros Fb0 | apply FcanonicBound with (1 := H) ].
generalize (Z_eq_bool_correct (Fnum x) (pPred (vNum b)));
 case (Z_eq_bool (Fnum x) (pPred (vNum b))); simpl in |- *.
generalize (Z_eq_bool_correct (nNormMin radix precision) (- pPred (vNum b)));
 case (Z_eq_bool (nNormMin radix precision) (- pPred (vNum b)));
 simpl in |- *.
intros H'; Contradict H'; apply sym_not_equal; apply Zlt_not_eq; auto.
apply Zlt_le_trans with (- 0%nat)%Z.
apply Zlt_Zopp; unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *;
 apply vNumbMoreThanOne with (3 := pGivesBound); auto.
simpl in |- *; apply Zlt_le_weak; apply nNormPos; auto.
generalize
 (Z_eq_bool_correct (nNormMin radix precision) (nNormMin radix precision));
 case (Z_eq_bool (nNormMin radix precision) (nNormMin radix precision));
 simpl in |- *.
generalize (Z_eq_bool_correct (Zsucc (Fexp x)) (- dExp b));
 case (Z_eq_bool (Zsucc (Fexp x)) (- dExp b)); simpl in |- *.
intros H' H'0 H'1 H'2; absurd (- dExp b <= Fexp x)%Z; auto with float.
rewrite <- H'; auto with float zarith.
replace (Zpred (Zsucc (Fexp x))) with (Fexp x);
 [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto.
intros H' H'0 H'1 H'2; rewrite <- H'2; auto.
apply floatEq; auto.
intros H'; case H'; auto.
generalize (Z_eq_bool_correct (Fnum x) (- nNormMin radix precision));
 case (Z_eq_bool (Fnum x) (- nNormMin radix precision));
 simpl in |- *.
generalize (Z_eq_bool_correct (Fexp x) (- dExp b));
 case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *.
generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (- pPred (vNum b)));
 case (Z_eq_bool (Zsucc (Fnum x)) (- pPred (vNum b)));
 simpl in |- *.
intros H0 H1 H2; absurd (Zsucc (Fnum x) <= Fnum x)%Z; auto with zarith.
rewrite H0; rewrite H2; (apply Zle_Zopp; auto with float arith).
unfold pPred in |- *; apply Zle_Zpred; apply ZltNormMinVnum; auto with zarith.
generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (nNormMin radix precision));
 case (Z_eq_bool (Zsucc (Fnum x)) (nNormMin radix precision));
 simpl in |- *.
intros H' H'0 H'1 H'2; Contradict H'2.
rewrite <- H'; auto with zarith.
replace (Zpred (Zsucc (Fnum x))) with (Fnum x);
 [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto.
intros H' H'0 H'1 H'2 H'3; apply floatEq; auto.
generalize (Z_eq_bool_correct (- pPred (vNum b)) (- pPred (vNum b)));
 case (Z_eq_bool (- pPred (vNum b)) (- pPred (vNum b)));
 auto.
intros H' H'0 H'1 H'2; rewrite <- H'1.
replace (Zsucc (Zpred (Fexp x))) with (Fexp x);
 [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto.
apply floatEq; auto.
intros H'; case H'; auto.
generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (- pPred (vNum b)));
 case (Z_eq_bool (Zsucc (Fnum x)) (- pPred (vNum b)));
 simpl in |- *.
intros H'; absurd (- pPred (vNum b) <= Fnum x)%Z; auto with float.
rewrite <- H'; auto with zarith.
apply Zle_Zabs_inv1; auto with float.
unfold pPred in |- *; apply Zle_Zpred; auto with float.
generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (nNormMin radix precision));
 case (Z_eq_bool (Zsucc (Fnum x)) (nNormMin radix precision));
 simpl in |- *.
generalize (Z_eq_bool_correct (Fexp x) (- dExp b));
 case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *.
intros H' H'0 H'1 H'2 H'3.
replace (Zpred (Zsucc (Fnum x))) with (Fnum x);
 [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto.
apply floatEq; auto.
intros H' H'0 H'1 H'2 H'3; case H.
intros H'4; absurd (nNormMin radix precision <= Zabs (Fnum x))%Z.
replace (Fnum x) with (Zpred (Zsucc (Fnum x)));
 [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto.
rewrite H'0.
apply Zlt_not_le; rewrite Zabs_eq; auto with zarith.
apply Zle_Zpred; apply nNormPos; auto with float zarith.
apply pNormal_absolu_min with (b := b); auto.
intros H'4; Contradict H'; apply FsubnormalFexp with (1 := H'4).
intros H' H'0 H'1 H'2; apply floatEq; simpl in |- *; auto.
unfold Zpred, Zsucc in |- *; ring.
Qed.

Theorem FSucPred :
 forall x : float,
 Fcanonic radix b x -> FSucc b radix precision (FPred x) = x.
intros x H; unfold FPred, FSucc in |- *.
cut (Fbounded b x); [ intros Fb0 | apply FcanonicBound with (1 := H) ].
generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b)));
 case (Z_eq_bool (Fnum x) (- pPred (vNum b))); simpl in |- *.
generalize (Z_eq_bool_correct (- nNormMin radix precision) (pPred (vNum b)));
 case (Z_eq_bool (- nNormMin radix precision) (pPred (vNum b)));
 simpl in |- *.
intros H'; Contradict H'; apply Zlt_not_eq; auto.
rewrite <- (Zopp_involutive (pPred (vNum b))); apply Zlt_Zopp.
apply Zlt_le_trans with (- 0%nat)%Z.
apply Zlt_Zopp; unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *.
apply (vNumbMoreThanOne radix) with (precision := precision); auto.
simpl in |- *; apply Zlt_le_weak; apply nNormPos; auto with zarith arith.
generalize
 (Z_eq_bool_correct (- nNormMin radix precision) (- nNormMin radix precision));
 case (Z_eq_bool (- nNormMin radix precision) (- nNormMin radix precision));
 simpl in |- *.
generalize (Z_eq_bool_correct (Zsucc (Fexp x)) (- dExp b));
 case (Z_eq_bool (Zsucc (Fexp x)) (- dExp b)); simpl in |- *.
intros H' H'0 H'1 H'2; absurd (- dExp b <= Fexp x)%Z; auto with float.
rewrite <- H'; auto with zarith.
intros H' H'0 H'1 H'2; rewrite <- H'2; apply floatEq; simpl in |- *; auto;
 unfold Zsucc, Zpred in |- *; ring.
intros H'; case H'; auto.
generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision));
 case (Z_eq_bool (Fnum x) (nNormMin radix precision));
 simpl in |- *.
generalize (Z_eq_bool_correct (Fexp x) (- dExp b));
 case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *.
generalize (Z_eq_bool_correct (Zpred (Fnum x)) (pPred (vNum b)));
 case (Z_eq_bool (Zpred (Fnum x)) (pPred (vNum b)));
 simpl in |- *.
intros H' H'0 H'1 H'2; absurd (nNormMin radix precision <= pPred (vNum b))%Z;
 auto with float.
rewrite <- H'; rewrite H'1; auto with zarith.
rewrite <- H'1; auto with float.
apply Zle_Zabs_inv2; auto with float zarith.
unfold pPred in |- *; apply Zle_Zpred; auto with float.
generalize (Z_eq_bool_correct (Zpred (Fnum x)) (- nNormMin radix precision));
 case (Z_eq_bool (Zpred (Fnum x)) (- nNormMin radix precision));
 simpl in |- *.
intros H' H'0 H'1 H'2 H'3;
 absurd (Zpred (nNormMin radix precision) = (- nNormMin radix precision)%Z);
 auto with zarith.
intros H' H'0 H'1 H'2 H'3; apply floatEq; simpl in |- *; auto;
 unfold Zpred, Zsucc in |- *; ring.
generalize (Z_eq_bool_correct (pPred (vNum b)) (pPred (vNum b)));
 case (Z_eq_bool (pPred (vNum b)) (pPred (vNum b)));
 auto.
intros H' H'0 H'1 H'2; rewrite <- H'1; apply floatEq; simpl in |- *; auto;
 unfold Zpred, Zsucc in |- *; ring.
intros H'; case H'; auto.
generalize (Z_eq_bool_correct (Zpred (Fnum x)) (pPred (vNum b)));
 case (Z_eq_bool (Zpred (Fnum x)) (pPred (vNum b)));
 simpl in |- *.
intros H'; absurd (Fnum x <= pPred (vNum b))%Z; auto with float.
rewrite <- H'.
apply Zlt_not_le; apply Zlt_pred; auto.
apply Zle_Zabs_inv2; unfold pPred in |- *; apply Zle_Zpred; auto with float.
generalize (Z_eq_bool_correct (Zpred (Fnum x)) (- nNormMin radix precision));
 case (Z_eq_bool (Zpred (Fnum x)) (- nNormMin radix precision));
 simpl in |- *.
generalize (Z_eq_bool_correct (Fexp x) (- dExp b));
 case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *.
intros H' H'0 H'1 H'2 H'3; apply floatEq; simpl in |- *; auto;
 unfold Zsucc, Zpred in |- *; ring.
intros H' H'0 H'1 H'2 H'3; case H; intros C0.
absurd (nNormMin radix precision <= Zabs (Fnum x))%Z; auto with float.
replace (Fnum x) with (Zsucc (Zpred (Fnum x)));
 [ idtac | unfold Zsucc, Zpred in |- *; ring ].
rewrite H'0.
rewrite <- Zopp_Zpred_Zs; rewrite Zabs_Zopp.
rewrite Zabs_eq; auto with zarith.
apply Zle_Zpred; simpl in |- *; apply nNormPos; auto with float zarith.
apply pNormal_absolu_min with (b := b); auto.
Contradict H'; apply FsubnormalFexp with (1 := C0).
intros H' H'0 H'1 H'2; apply floatEq; simpl in |- *; auto.
unfold Zpred, Zsucc in |- *; ring.
Qed.

Theorem FNPredSuc :
 forall x : float,
 Fbounded b x -> FNPred (FNSucc b radix precision x) = x :>R.
intros x H'; unfold FNPred in |- *; rewrite FcanonicFnormalizeEq; auto.
unfold FNSucc in |- *; rewrite FPredSuc; auto.
unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
apply FnormalizeCanonic; auto.
apply FNSuccCanonic; auto.
Qed.

Theorem FNPredSucEq :
 forall x : float,
 Fcanonic radix b x -> FNPred (FNSucc b radix precision x) = x.
intros x H'.
apply FcanonicUnique with (precision := precision) (5 := H'); auto.
apply FNPredCanonic; auto with float.
apply FcanonicBound with (radix := radix); auto.
apply FNSuccCanonic; auto.
apply FcanonicBound with (radix := radix); auto.
apply FNPredSuc; auto.
apply FcanonicBound with (radix := radix); auto.
Qed.

Theorem FNSucPred :
 forall x : float,
 Fbounded b x -> FNSucc b radix precision (FNPred x) = x :>R.
intros x H'; unfold FNSucc in |- *; rewrite FcanonicFnormalizeEq; auto.
unfold FNPred in |- *; rewrite FSucPred; auto.
unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
apply FnormalizeCanonic; auto.
apply FNPredCanonic; auto.
Qed.

Theorem FNSucPredEq :
 forall x : float,
 Fcanonic radix b x -> FNSucc b radix precision (FNPred x) = x.
intros x H'.
apply FcanonicUnique with (5 := H') (precision := precision); auto.
apply FNSuccCanonic; auto.
apply FcanonicBound with (radix := radix); auto.
apply FNPredCanonic; auto.
apply FcanonicBound with (radix := radix); auto.
apply FNSucPred; auto.
apply FcanonicBound with (radix := radix); auto.
Qed.

End pred.
Hint Resolve FBoundedPred FPredCanonic FPredLt R0RltRleSucc FPredProp
  FNPredCanonic FNPredLt FNPredProp: float.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype div ssrint.
From mathcomp Require Import ssrnum fintype ssralg ssrfun.
From mathcomp Require Import choice seq bigop matrix intdiv.

Require Import ec.

Import GRing.Theory.

Open Local Scope ring_scope.

Section Multiexponentiation.

Fixpoint nat_to_bin_aux (n a : nat) : seq bool :=
  match a with
    |0 => [::]
    |a.+1 =>
      match n with
        |0 => [::]
        |_.+1 => (odd n) :: (nat_to_bin_aux n./2 a)
      end
  end.

Definition nat_to_bin (n : nat) := nat_to_bin_aux n n.

(*lsb ... msb*)

Lemma nat_to_bin0 : nat_to_bin 0 = [::].
Proof. by []. Qed.

Lemma nat_to_bin1 : nat_to_bin 1 = [:: true].
Proof. by []. Qed.

Lemma nat_to_bin_eq_nil n : (nat_to_bin n == [::]) = (n == 0%N).
Proof.
apply/eqP/eqP => h.
+ by case: n h.
+ by rewrite h.
Qed.

Lemma nat_to_bin_simpl n a :
nat_to_bin_aux n.+1 a.+1 = (odd n.+1) :: (nat_to_bin_aux (n.+1)./2 a).
Proof. by []. Qed.

Lemma general_ind :
forall (P : nat -> Prop),
(forall n, (forall p : nat , (p < n)%N -> P p) -> P n) ->
forall n, P n.
Proof.
    move=> P ind n; move: {-2}n (leqnn n); elim: n => [|n IHn] p.
      by rewrite leqn0=> /eqP->; apply: ind.
    move=> lt_p_Sn; apply: ind=> k lt_k_p; apply: IHn.
    by rewrite -ltnS; rewrite (leq_trans lt_k_p).
  Qed.

Lemma nat_to_bin_aux_G (n m : nat) :
(n <= m)%N -> nat_to_bin_aux n m = nat_to_bin_aux n n.
Proof.
elim/general_ind : n m.
case.
* by move=> IH m nGETm /= ;  case : m nGETm.
* move => n IH m nLTm ; case : m nLTm IH.
 + by rewrite ltn0.
 + move=> m nLTm IH; rewrite !nat_to_bin_simpl.
* have h1 : nat_to_bin_aux (n.+1)./2 m = nat_to_bin_aux (n.+1)./2 (n.+1)./2.
  apply: IH.
+ rewrite -divn2 ; apply: ltn_Pdiv => //.
+ case : m nLTm.
  * rewrite ltnS leqn0; move/eqP => nEQ0; by rewrite nEQ0 /=.
  * move=> m; rewrite ltnS; move=> nLTm; rewrite -divn2.
    have hn : (n.+1 %/ 2 <= n)%N.
    rewrite -ltnS;  by apply: ltn_Pdiv.
    apply: (leq_trans hn nLTm).
* have h2 : nat_to_bin_aux (n.+1)./2 n = nat_to_bin_aux (n.+1)./2 (n.+1)./2.
  apply: IH.
+ rewrite -divn2; apply: ltn_Pdiv => //.
+ rewrite -ltnS -divn2; apply: ltn_Pdiv => //.
by rewrite h1 h2.
Qed.

Lemma nat_to_bin_S :
forall (x : bool) (m : nat), m != 0%N ->
nat_to_bin (x + 2 * m)%N = x :: (nat_to_bin m).
Proof.
move=> x m mN0.
case : x.
* rewrite addnC addn1 /nat_to_bin /=.
  rewrite {2}mul2n uphalf_double -dvdn2 dvdn_mulr; last by rewrite dvdnn.
  have h : nat_to_bin_aux m (2 * m) = nat_to_bin_aux m m.
  + apply: nat_to_bin_aux_G; by apply: leq_pmull.
  by rewrite h.
* rewrite add0n /nat_to_bin /=.
  have h : exists n, m = n.+1.
  + move: mN0; case:m => // x hx; exists x => //.
  move:h => [x mSx]; rewrite mSx.
  have h : (2 * x.+1)%N = ((2 * x).+1).+1.
  + by rewrite -[x.+1]addn1 mulnDr muln1 mul2n addn2.
  rewrite h nat_to_bin_simpl.
  have hodd : (odd (2 * x).+2) = false.
  + apply: negbTE; rewrite -h -dvdn2 dvdn_mulr // dvdnn.
  rewrite hodd -h -divn2 mulKn //.
  have H : nat_to_bin_aux x.+1 (2 * x).+1 = nat_to_bin_aux x.+1 x.+1.
  + apply: nat_to_bin_aux_G; rewrite ltnS; by apply: leq_pmull.
  by rewrite H.
Qed.

Fixpoint bin_to_nat (l : seq bool) : nat :=
  match l with
    |[::] => 0%N
    |x :: xs => (x + 2 * (bin_to_nat xs))%N
  end.

Definition epurate (b : bool):=
  match b with
    |true => [:: true]
    |false => [::]
  end.

Fixpoint norm_bin1 (u : seq bool) :=
  match u with
    |[::] => [::]
    |x :: xs =>
      let v := norm_bin1 xs in
        match v with
          |[::] => epurate x
          |y :: ys => x :: v
        end
  end.

Fixpoint norm_bin_rev (v : seq bool) : seq bool :=
  match v with
    |[::] => [::]
    |x :: xs =>
      if (x == true) then v
        else norm_bin_rev xs
  end.

(* norm_bin2 was an alternative but not used *)
Definition norm_bin2 (u : seq bool) :=
  rev (norm_bin_rev (rev u)).

Lemma norm_bin2_true : norm_bin2 [:: true] = [:: true].
Proof. by []. Qed.

Lemma norm_bin2_false : norm_bin2 [:: false] = [::].
Proof. by []. Qed.

Lemma norm_bin2_nil : norm_bin2 [::] = [::].
Proof. by []. Qed.

Lemma norm_bin1_true : norm_bin1 [:: true] = [:: true].
Proof. by []. Qed.

Lemma norm_bin1_false : norm_bin1 [:: false] = [::].
Proof. by []. Qed.

Lemma norm_bin1_nil : norm_bin1 [::] = [::].
Proof. by []. Qed.

Lemma rev_last :
forall (x b : bool) (xs : seq bool), last b (rev (x::xs)) = x.
Proof.
move=> x b xs.
by rewrite rev_cons last_rcons.
Qed.

Lemma correct_norm_bin (u : seq bool) :
bin_to_nat u == bin_to_nat (norm_bin1 u).
Proof.
elim: u => //=.
move=> x xs.
case h : (norm_bin1 xs)=> [//= | y ys].
* move/eqP => h0.
rewrite h0 muln0 addn0.
rewrite /epurate.
case: x => //=.
* move/eqP=> IH.
by rewrite IH.
Qed.

Lemma cancelB u :
nat_to_bin (bin_to_nat u) = norm_bin1 u.
Proof.
elim: u.
* by rewrite /=.
* move=> x xs IH; rewrite /=.
case Hbtn: (bin_to_nat xs).
+ rewrite muln0 addn0; move: IH.
rewrite Hbtn nat_to_bin0 => <-.
by case: x.
+ rewrite nat_to_bin_S // -Hbtn IH.
case thenilcase : (norm_bin1 xs) => [|y ys //].
have absurd : bin_to_nat xs = 0%N.
* move: (correct_norm_bin xs).
  rewrite thenilcase //=.
  move/eqP => -> //.
move: Hbtn.
by rewrite absurd.
Qed.

Lemma bin_to_nat_nil : bin_to_nat [::] = 0%N.
Proof. by []. Qed.

Lemma bin_to_nat_true : bin_to_nat [:: true] = 1%N.
Proof. by []. Qed.

Lemma bin_to_nat_false u : norm_bin1 u = [::] -> bin_to_nat u = 0%N.
Proof.
move/eqP: (correct_norm_bin u)=> -> -> //. Qed.

Lemma bin_to_nat_cons x xs : bin_to_nat (x :: xs) = (x + 2 * bin_to_nat xs)%N.
Proof. by []. Qed.

Lemma uphalf_len m : (uphalf m <= m)%N.
Proof.
elim:m => //.
move=> n IH.
have uphalfS : (uphalf (n.+1) <= (uphalf n) + 1)%N.
* by rewrite /= uphalf_half -addnA addn1 ltn_addl.
rewrite -(leq_add2r 1 (uphalf n) n) in IH.
rewrite -{2}[n.+1]addn1.
apply: (leq_trans uphalfS IH).
Qed.

Lemma uphalf_S m : (~~ odd m + 2 * (odd m + m./2))%N = m.+1.
Proof.
move: (odd_double_half m)=> Hm.
rewrite -[m.+1]addn1 -{4}Hm.
case HHm : (odd m) => /=; rewrite !add0n.
by rewrite mulnDr muln1 [(1 + (m./2).*2)%N]addnC -[((m./2).*2 + 1 + 1)%N]addnA addn1 addnC mul2n.
by rewrite mul2n addnC.
Qed.

Lemma cancelN n :
bin_to_nat (nat_to_bin n) = n.
Proof.
elim/general_ind : n => n IH.
case Hn : n => [// | m].
have h : nat_to_bin (uphalf m) = nat_to_bin_aux (uphalf m) m.
* rewrite /nat_to_bin; symmetry.
  apply : nat_to_bin_aux_G.
  by rewrite uphalf_len.
* rewrite /= -h IH.
+ by rewrite uphalf_half uphalf_S.
+ have mltn : (m < n)%N. by rewrite Hn ltnSn.
  by apply: (leq_ltn_trans (uphalf_len m) mltn).
Qed.

Definition block (u : seq bool) (w i : nat) :=
 mkseq (fun k => nth false u (w*i + k)) w.

(*first block is the zero-block*)
(* when i > (size u)%/w then block = [::false; .. ; false] *)
(* block [::] w i = [::false; .. ;false] *)

Definition n_blocks (u : seq bool) (w : nat) :=
if size u is 0%N then 0%N
else (((size u).-1) %/ w).+1.

Lemma size_block u w i:
size (block u w i) = w.
Proof.
by rewrite size_mkseq.
Qed.

Lemma block_size0 u i w: w = 0%N -> block u w i = [::].
Proof. by move => ->. Qed.

Lemma n_blocks_nil w : n_blocks [::] w = 0%N.
Proof. by []. Qed.

Lemma n_blocks_size0 u : u != [::] -> n_blocks u 0%N = 1%N.
Proof. by case : u. Qed.

Lemma n_blocks_cons x xs w : n_blocks (x :: xs) w != 0%N.
Proof. by []. Qed.

Lemma n_blocks0_eq_nil u w : (n_blocks u w == 0%N) = (u == [::]).
Proof.
apply/eqP/eqP => h.
+ by case : u h.
+ by rewrite h n_blocks_nil.
Qed.

Variable G : zmodType.

Definition expG w (u : seq bool) (P : G) :=
    let d := (n_blocks u w) in
    foldl
      (fun R i =>
        let R := R *+ (2^w) in
          R + (P *+ (bin_to_nat (block u w i))))
      0 (rev (iota 0 d)).

Lemma expG_nil w P : expG w [::] P = 0.
Proof. by []. Qed.

Lemma size_normalized_lt_seq b:
(size (norm_bin1 b) <= size b)%N.
Proof.
elim:b => [//= | x xs IH].
rewrite /=; case H : (norm_bin1 xs) => [|y ys].
+ by case: x => /=.
+ rewrite {1}/size // -/size.
have hsize : size (norm_bin1 xs) = (size ys).+1.
* by rewrite H.
by rewrite -hsize ltnS.
Qed.

Lemma size_seq_lt_block b (w : nat):
  w != 0%N -> ((size b) <= w * (n_blocks b w))%N.
Proof.
move=> wNz.
elim:b => [//| x xs IH].
rewrite /n_blocks //=  mulnC; apply: ltn_ceil.
by rewrite lt0n.
Qed.

Lemma nat2bin_size_block b (w : nat):
  w != 0%N -> (size (norm_bin1 b) <= w * (n_blocks b w))%N.
Proof.
move=> wNz.
move: (size_seq_lt_block b w wNz) => ineq.
apply: (leq_trans (size_normalized_lt_seq b) ineq).
Qed.

Lemma norm_bin1_cons_true xs :
 norm_bin1 (true :: xs) = true :: (norm_bin1 xs).
Proof.
case H : (norm_bin1 xs) => [|y ys] ; by rewrite /= H.
Qed.

Lemma norm_bin1_cons_false1 xs :
norm_bin1 xs != nil -> norm_bin1 (false :: xs) = false :: (norm_bin1 xs).
Proof.
case H : (norm_bin1 xs) => [|y ys] ; by rewrite /= H.
Qed.

Lemma norm_bin1_cons_false2 xs :
norm_bin1 xs = nil -> norm_bin1 (false :: xs) = (norm_bin1 xs).
Proof.
move=> Hnil.
by rewrite /= Hnil.
Qed.

Lemma half_leqn n : ((n./2) <= n)%N.
Proof. by rewrite -divn2 leq_div. Qed.

Lemma halfS_ltSn n : (((n.+1)./2) < n.+1)%N.
Proof.
rewrite -divn2.
by apply: ltn_Pdiv.
Qed.

Lemma nat2bin_normalized n:
  norm_bin1 (nat_to_bin n) = nat_to_bin n.
Proof.
elim/general_ind : n => n IH.
rewrite /nat_to_bin; case Hn : n => [//|m].
rewrite nat_to_bin_simpl; case H : (odd m.+1).
+ rewrite norm_bin1_cons_true !nat_to_bin_aux_G; last by rewrite -ltnS halfS_ltSn.
  rewrite !IH //; by rewrite Hn halfS_ltSn.
+ rewrite !nat_to_bin_aux_G; last by rewrite -ltnS halfS_ltSn.
  have h : nat_to_bin (m.+1)./2 = nat_to_bin_aux (m.+1)./2 (m.+1)./2. by [].
  rewrite -h; set s := nat_to_bin _ ; rewrite /=.
  have notodd : ((m.+1)./2 > 0)%N.
  * move/negbT : H; rewrite -dvdn2 -divn2; move=> H; by rewrite ltn_divRL.
  case H1 : (norm_bin1 s)=> [|x xs //].
  * move: H1; rewrite /s; move/bin_to_nat_false; rewrite cancelN.
    move: notodd; rewrite lt0n; move=> h1 h2.
    move: h1; by rewrite h2.
  * by rewrite -H1 /s IH ; last by rewrite Hn halfS_ltSn.
Qed.

Lemma bin_to_nat_MSB0:
  forall b n, bin_to_nat (b ++ nseq n false) = bin_to_nat b.
Proof.
move=> b n.
elim: b=> //=.
+ elim: n => //=.
  move=> n IH; by rewrite IH.
+ move=> x xs IH; by rewrite IH.
Qed.

Lemma bin_to_nat_singl b : bin_to_nat [:: b] = b%N.
Proof.
case : b.
by rewrite bin_to_nat_true.
by apply: bin_to_nat_false.
Qed.

Lemma bin_to_nat_last x xs :
bin_to_nat (rcons xs x) =
((bin_to_nat xs) + bin_to_nat [:: x] * 2 ^ (size xs))%N.
Proof.
elim: xs=> [ /= |y ys IH].
+ by rewrite !muln0 !addn0 add0n expn0 muln1.
+ rewrite /= muln0 addn0 IH bin_to_nat_singl.
  rewrite expnS mulnA [(x * 2)%N]mulnC mulnDr.
  by rewrite addnA mulnA.
Qed.

Lemma take_drop_lemma l k :
bin_to_nat l = (bin_to_nat (take k l) + bin_to_nat (drop k l) * 2 ^ k)%N.
Proof.
case H : (l == [::]).
* rewrite (eqP H) //=.
* elim : k => [| n IH].
  + by rewrite take0 drop0 expn0 muln1.
  + move/negbT :H.
    rewrite -[l!= [::]]Bool.andb_true_r.
    move/predD1P; case => lNnil _.
    case Hsize: (size l < n.+1)%N; last first.
    * have Hn: (n < size l)%N.
    by rewrite ltnNge (negbT Hsize).
    rewrite (@take_nth _ false _ _) // bin_to_nat_last size_takel; last first.
    + by rewrite leq_eqVlt Hn orbT.
    + rewrite expnS mulnA -addnA -mulnDl [(_ * 2)%N]mulnC.
    rewrite bin_to_nat_singl -bin_to_nat_cons -drop_nth //.
    * rewrite take_oversize.
    rewrite drop_oversize.
    rewrite bin_to_nat_nil mul0n addn0 //.
    by apply: ltnW.
    by apply: ltnW.
Qed.

Lemma block_false bs w i k:
block (bs ++ nseq k false) w i = block bs w i.
Proof.
rewrite /block /=.
have funeq : (fun k0 : nat => nth false (bs ++ nseq k false) (w * i + k0)) =1
(fun k0 : nat => nth false bs (w * i + k0)).
+ move=> n /=.
  rewrite nth_cat.
  case H : (w * i + n < size bs)%N => //.
  rewrite nth_nseq //=.
  case: (w * i + n - size bs < k)%N ; symmetry; apply: nth_default; by rewrite leqNgt H.
move: (eq_mkseq funeq)=> H.
by rewrite (H w).
Qed.

Lemma take_block us w i :
w != 0%N ->
(w * i.+1 <= size us)%N ->
(block us w i) = take w (drop (w * i) us).
Proof.
move=> wNz ineq.
apply: (@eq_from_nth _ false _ _).
rewrite size_block size_take size_drop.
+ have H : (w <= size us  - w * i)%N.
    rewrite -(leq_add2r (w * i) _ _) subnK.
    by rewrite addnC -{2}[w]muln1 -mulnDr addn1.
    have h : (w * i <= w * i.+1)%N.
    by rewrite leq_pmul2l ?leqnSn // ?lt0n.
    by apply: leq_trans h ineq.
  move: H; rewrite leq_eqVlt.
  move/orP; case=> H.
  by rewrite -(eqP H) //= ltnn.
  by rewrite H.
+ rewrite size_block; move=> k Hsize.
  by rewrite nth_take // nth_drop /block nth_mkseq.
Qed.

(* missing property for drop *)
Lemma drop_add k m (us: seq bool) :
  drop (k + m) us = drop k (drop m us).
Proof.
elim: us m => [|x us ih] // [|m].
by rewrite addn0 drop0. by rewrite addnS /= ih.
Qed.

Lemma lemma us w i :
  w != 0%N ->
  (w * i.+1 <= size us)%N ->
  (bin_to_nat (drop (w * i.+1) us) * 2 ^ w  +  bin_to_nat (block us w i))%N  =
  bin_to_nat (drop (w * i) us).
Proof.
move=> wNz ineq.
rewrite take_block //.
have dropw : drop (w * i.+1) us = drop w (drop (w * i) us).
by rewrite -addn1 mulnDr muln1 addnC drop_add.
rewrite dropw.
rewrite addnC.
by rewrite -take_drop_lemma.
Qed.

(* Fancy proof :) *)
Lemma expG_correct : forall (P : G) (n w : nat),
  w != 0%N -> expG w (nat_to_bin n) P = P *+ n.
Proof.
  move=> x n w nz_w; rewrite /expG foldl_rev.
  set d := (n_blocks _ _).
  set f := (fun _ _ => _).
  rewrite -[n]cancelN -(bin_to_nat_MSB0 _ (w * d - size (nat_to_bin n))).
  set u := (nseq _ _).
  have ->: nat_to_bin n ++ u = drop (w * (d - d)) (nat_to_bin n ++ u).
    by rewrite subnn muln0 drop0.
  move: (erefl (0 + d)%N).
  rewrite {1}add0n => /esym.
  move: 0%N => i; move: {1 3 5}d => j.
  elim : j i => [|j IH] i //=.
   move=> _;  rewrite subn0 drop_oversize //.
   rewrite -nat2bin_normalized.
   rewrite size_cat size_nseq.
   rewrite nat2bin_normalized addnC subnK ?leqnn //.
   + rewrite /d -{1}nat2bin_normalized; by apply: nat2bin_size_block.
  move=> H; rewrite IH /f; last by rewrite addSnnS.
  rewrite -mulrnA -mulrnDr; congr (_ *+ _).
  rewrite -H -{1}addSnnS -!addnBA // !subnn !addn0.
  set us := nat_to_bin n ++ u.
  have Hblock : block (nat_to_bin n) w i = block us w i.
  by rewrite /us /u block_false.
  rewrite Hblock.
  apply: lemma => //.
  have size_us : size us = (w * d)%N.
  rewrite /us size_cat /u size_nseq subnKC //.
  by rewrite /d -{1}nat2bin_normalized nat2bin_size_block.
  rewrite size_us leq_pmul2l ?lt0n.
  by rewrite -H -{1}[i]addn0 ltn_add2l.
  done.
Qed.

(******************************************)
(*          MULTIEXPONENTIATION !!!       *)
(******************************************)

Definition algoG (w : nat) (u v : seq bool) (P Q : G) :=
let d := maxn (n_blocks u w) (n_blocks v w) in
foldl
( fun (R : G) (i : nat) =>
 let R0 := R *+ 2 ^ w in
   R0 + (P *+ bin_to_nat (block u w i)) + (Q *+ bin_to_nat (block v w i)))  0
(rev (iota 0 d)).

Lemma algo_nil2 w P Q : algoG w [::] [::] P Q = 0.
Proof. by []. Qed.

Lemma algo_correct :
  forall (P Q : G) (n m w : nat),
    w != 0%N ->
    algoG w (nat_to_bin n) (nat_to_bin m) P Q = P *+ n + Q *+ m.
Proof.
  move=> P Q n m w nz_w; rewrite /algoG foldl_rev.
  set d := maxn  _ _.
  set f := (fun _ _ => _).
  rewrite -[n]cancelN -(bin_to_nat_MSB0 _ (w * d - size (nat_to_bin n))).
  set u := (nseq _ _).
  rewrite -[m]cancelN -(bin_to_nat_MSB0 (nat_to_bin m) (w * d - size (nat_to_bin m))).
  set v := (nseq _ _).
  have Hn: nat_to_bin n ++ u = drop (w * (d - d)) (nat_to_bin n ++ u).
    by rewrite subnn muln0 drop0.
  have Hm: nat_to_bin m ++ v = drop (w * (d - d)) (nat_to_bin m ++ v).
    by rewrite subnn muln0 drop0.
  rewrite Hn Hm; clear Hn Hm.
  move: (erefl (0 + d)%N).
  rewrite {1}add0n => /esym.
  move: 0%N => i; move: {1 3 5 7}d => j.
  elim : j i => [|j IH] i //=.
   move=> _;  rewrite subn0 !drop_oversize //.
   by rewrite bin_to_nat_nil !mulr0n addr0.
   + rewrite size_cat size_nseq subnKC.
   by rewrite leqnn.
   move: (size_seq_lt_block (nat_to_bin m) w nz_w)=> H1.
   move: (leq_maxr (n_blocks (nat_to_bin n) w) (n_blocks (nat_to_bin m) w)).
   rewrite -/d -(@leq_pmul2l w (n_blocks (nat_to_bin m) w) d) ?lt0n //.
   move=> H2; by rewrite (leq_trans H1 H2).
   + rewrite size_cat size_nseq subnKC.
   by rewrite leqnn.
   move: (size_seq_lt_block (nat_to_bin n) w nz_w)=> H1.
   move: (leq_maxl (n_blocks (nat_to_bin n) w) (n_blocks (nat_to_bin m) w)).
   rewrite -/d -(@leq_pmul2l w (n_blocks (nat_to_bin n) w) d) ?lt0n //.
   move=> H2; by rewrite (leq_trans H1 H2).
 move=> H; rewrite IH /f; last by rewrite addSnnS.
 set us := nat_to_bin n ++ u.
 set vs := nat_to_bin m ++ v.
 rewrite mulrnDl -!mulrnA [(P *+ _) + _]addrC.
 set q1 := (bin_to_nat (drop (w * (d - j)) vs) * 2 ^ w)%N.
 set q2 := bin_to_nat (block (nat_to_bin m) w i)%N.
 set p1 := (bin_to_nat (drop (w * (d - j)) us) * 2 ^ w)%N.
 set p2 :=  bin_to_nat (block (nat_to_bin n) w i)%N.
 rewrite -[Q *+ q1 + P *+ p1 + P *+ p2]addrA.
 rewrite -mulrnDr addrC addrA -mulrnDr addrC.
 have Hp : (p1 + p2 = bin_to_nat (drop (w * (d - j.+1)) us))%N.
 * rewrite /p1 /p2.
 have Hblock : block (nat_to_bin n) w i = block us w i.
 by rewrite /us /u block_false.
 rewrite Hblock.
 rewrite -H -{1}addSnnS -!addnBA // !subnn !addn0.
 apply: lemma=> //.
 + rewrite /us size_cat /u size_nseq subnKC -H.
  rewrite leq_pmul2l ?lt0n //.
  move: (ltn_add2l i 0 j.+1);  by rewrite addn0.
 + rewrite H.
  move: (size_seq_lt_block (nat_to_bin n) w nz_w)=> H1.
  move: (leq_maxl (n_blocks (nat_to_bin n) w) (n_blocks (nat_to_bin m) w)).
  rewrite -/d -(@leq_pmul2l w (n_blocks (nat_to_bin n) w) d) ?lt0n //.
  move=> H2; by rewrite (leq_trans H1 H2).
 have Hq : (q1 + q2 = bin_to_nat (drop (w * (d - j.+1)) vs))%N.
 * rewrite /q1 /q2.
 have Hblock : block (nat_to_bin m) w i = block vs w i.
 by rewrite /us /u block_false.
 rewrite Hblock.
 rewrite -H -{1}addSnnS -!addnBA // !subnn !addn0.
 apply: lemma=> //.
 + rewrite /us size_cat /u size_nseq subnKC -H.
  rewrite leq_pmul2l ?lt0n //.
  move: (ltn_add2l i 0 j.+1);  by rewrite addn0.
 + rewrite H.
  move: (size_seq_lt_block (nat_to_bin m) w nz_w)=> H1.
  move: (leq_maxr (n_blocks (nat_to_bin n) w) (n_blocks (nat_to_bin m) w)).
  rewrite -/d -(@leq_pmul2l w (n_blocks (nat_to_bin m) w) d) ?lt0n //.
  move=> H2.
  by rewrite (leq_trans H1 H2).
rewrite [(q2 + q1)%N]addnC.
by rewrite Hp Hq.
Qed.

Lemma algo_nilf w m P Q : w != 0%N -> algoG w [::] (nat_to_bin m) P Q = Q *+ m.
Proof.
  move=> wNz.
  rewrite -nat_to_bin0 algo_correct //.
  by rewrite mulr0n add0r.
Qed.

Lemma algo_nils w n P Q : w != 0%N -> algoG w (nat_to_bin n) [::] P Q = P *+ n.
Proof.
  move=> wNz.
  rewrite -nat_to_bin0 algo_correct //.
  by rewrite mulr0n addr0.
Qed.

End Multiexponentiation.

Section Decomposition.

(****************************************)
(*        short vectors                 *)
(****************************************)
(*  The Algorithm :                     *)
(*                                      *)
(* Let E ec over Fq                     *)
(* Let P <- E(Fq) of prime order n      *)
(* Let h endomorphism over Fq and       *)
(* Let l : nat, st h(P) = [l]*P         *)
(*                                      *)
(* Input : n, l, k                      *)
(* Output k1 and k2 st k = k1 + k2 * l [mod n]       *)
(*                                                   *)
(*   Methodology                                     *)
(* Following the GLV-paper we can divide the problem *)
(*   into the two following subproblems:             *)
(* (1) finding two short linearly ind vectors v1 = (x1, y1), v2 = (x2, y2) st  *)
(* f (v1) = f (v2) = 0 i.e.                                                    *)
(* (x1 + lamda * y1) mod n = (x2 + lamda * y2) mod n  = 0                      *)
(* (2) find vector v in the lattice L(v1, v2) close to (k, 0)                  *)
(* Then we take (k1 , k2) = (k, 0) - v                                         *)
(*******************************************************************************)

Definition P (a b : nat) (r : nat) (x y : int) :=
  r%:Z = x * a%:Z + y * b%:Z.

 Fixpoint eea_rec (r' : nat) (u' v' : int) (acc : seq (nat * int * int)) n :=
  match n with
  | 0    => None
  | n.+1 =>
    if   r' == 0%N
    then Some acc
    else
      let: (r, u, v) := head (0%N, 0, 0) acc in
        let (q, m) := (r %/ r', r %% r') in
          eea_rec m (u - q%:Z * u') (v - q%:Z * v') ((r', u', v') :: acc) n
  end.

Definition eea (a b : nat) : seq (nat * int * int) :=
  if   a == 0%N
  then [:: (b, 0, 1)]
  else odflt [::] (eea_rec b 0 1 [:: (a, 1, 0)] (maxn a b).+1).

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

Lemma relation_eea_rec a b:
  forall r' u' v' (acc : (seq (nat * int * int))) n,
    (P a b) r' u' v' ->
    (forall r x y, (r, x, y) \in acc -> (P a b) r x y )->
    acc != [::] ->
    (forall r u v, (r, u, v) \in odflt [::] (eea_rec r' u' v' acc n) ->
      (P a b) r u v).
Proof.
  move=> r' u' v' acc n.
  elim : n acc r' u' v' => [//|n IH acc r' u' v'].
  case Hr' : r' IH => [//=|m]  IH P1 inacc acc_Nnil r u v /=.
  set R := head _ _ .
  have : R = head (0%N, 0, 0) acc. done.
  move: R => [[r1 u1] v1] HR H.
  apply : (IH  ((m.+1, u', v') :: acc) (r1 %% m.+1) (u1 - (r1 %/ m.+1)%:Z * u') (v1 - (r1 %/ m.+1)%:Z * v'));
    rewrite //=; last first.
  + move => r0 x y; rewrite in_cons; case/orP.
  by move/eqP=>  [-> -> ->].
  by apply: inacc.
  + have HP : P a b r1 u1 v1.
  apply: inacc; by rewrite HR -nth0 mem_nth // lt0n size_eq0.
  move: HP; rewrite /P => HP; rewrite -Hr'.
  set k := _ %% _; set q := _ %/ _.
  rewrite !mulrBl addrAC addrA -HP -!mulrA -addrA -!mulNr -(mulrDr (- q%:Z) (v' * b) (u' * a)).
  rewrite -Hr' /P in P1.
  rewrite [_ * _ + _ * _]addrC -P1 /k /q {2}(divn_eq r1 r') mulNr.
  symmetry; apply/eqP; by rewrite subr_eq addrC.
Qed.

Lemma relation_eea a b :
  forall v,
    let: (r, x, y) := v in
      (r, x, y) \in (eea a b) -> (P a b) r x y.
Proof.
  move=> [[r x] y]; rewrite /eea /P.
  case Ha : (a == 0%N).
  + by rewrite mem_seq1 => /eqP [-> -> ->]; rewrite mul0r mul1r add0r.
  + set d := (maxn _ _).+1 ; set acc := [:: _]; move=> H.
  apply: (relation_eea_rec a b b 0 1 acc d).
  * by rewrite /P mul0r add0r mul1r.
  * move=> r1 x1 y1; rewrite /acc /P.
  by rewrite mem_seq1 => /eqP [-> -> ->]; rewrite mul0r mul1r addr0.
  * by rewrite /acc.
  done.
Qed.

Lemma eea_mod a b :
  forall v,
    let: (r, x, y) := v in
      (r, x, y) \in (eea a b) -> r%:Z - y * b%:Z = x * a%:Z.
Proof.
  move=> [[r x] y] H.
  move: (relation_eea a b (r, x, y) H).
  rewrite /P; move/eqP; rewrite -subr_eq; move/eqP => //.
Qed.

Lemma in_acc_in_eea r u v (acc : seq ( nat * int * int))
n (x : nat * int * int) :
(r <= n)%N ->
x \in acc -> x \in odflt [::] (eea_rec r u v acc n.+1).
Proof.
elim : n acc r u v x.
+ move=> acc r u v x; rewrite leqn0.
move/eqP => -> //.
+ move=> n IH acc r u v x rleqSn xin.
case Head : (head (0%N, 0%:Z, 0%:Z) acc) => [[r1 u1] v1].
set q := r1 %/ r; set m := r1 %% r.
have H1 : r == 0%N -> odflt [::] (eea_rec r u v acc n.+2) = acc.
* move/eqP => -> //.
have H2 : r != 0%N -> eea_rec r u v acc n.+2 =
eea_rec m (u1 - q%:Z * u) (v1 - q%:Z * v) ((r, u, v) :: acc) n.+1.
* move=> rnz; by rewrite //= Head (negbTE rnz) /m.
case Hr : (r == 0%N); first by rewrite (H1 Hr).
rewrite (H2 (negbT Hr)); apply: IH.
rewrite /m; move: rleqSn.
rewrite leq_eqVlt; move/orP; case => H.
* by rewrite (eqP H) -ltnS ltn_mod.
* have : (r1 %% r < r)%N.
by rewrite ltn_mod lt0n (negbT Hr).
move=> lt2; rewrite -ltnS.
by rewrite (ltn_trans lt2 H).
* rewrite in_cons; apply/orP; by right.
Qed.

Lemma size_cons : forall (T : Type) (x : T) (xs : seq T),
size (x :: xs) = (size xs).+1.
Proof. by rewrite {1}/size. Qed.

Lemma eea_size_nz a b :
a != 0%N -> b != 0%N -> (size (eea a b) > 1)%N.
Proof.
move=> a_nz b_nz.
have a_in : (a, 1, 0) \in (eea a b).
+ rewrite /eea (negbTE a_nz).
  apply: in_acc_in_eea; by rewrite ?inE ?eqxx ?leq_maxr.
have b_in : (b, 0, 1) \in (eea a b).
  rewrite /eea (negbTE a_nz) /= (negbTE b_nz).
  case Hmaxn : (maxn _ _)=> [|n].
+ move: Hmaxn; rewrite /maxn; case ineq : (a < b)%N => H.
  by move: b_nz; rewrite H.
  by move: a_nz; rewrite H.
+ apply: in_acc_in_eea.
* rewrite -ltnS -Hmaxn; move: (leq_maxr a b)=> H2.
  have H1: (a %% b < b)%N by rewrite ltn_mod lt0n.
  move: H2; rewrite leq_eqVlt; move/orP; case.
  + move/eqP=> H2; rewrite -H2 ltn_mod lt0n //.
  + by apply: ltn_trans.
* rewrite inE; apply/orP; left; done.
case: (eea a b) a_in b_in => [//|x xs].
rewrite in_cons; move/orP; case=> A.
+ rewrite in_cons; move/orP; case=> B.
  move/eqP:A => A; move:B; rewrite -A.
  by rewrite !xpair_eqE //= oner_eq0 Bool.andb_false_r.
  rewrite size_cons; case: xs B => [//| y ys B].
  by rewrite size_cons.
+ rewrite in_cons; move/orP; case=> B.
  move/eqP:B => B; rewrite size_cons.
  case: xs A => [//| y ys A]; by rewrite size_cons.
  rewrite size_cons; case: xs A B => [//| y ys A].
  by rewrite size_cons.
Qed.

Definition filter_sqrr (n : nat) (rs : seq (nat * int * int)) :=
[seq t <- rs | let: (r, x, y) := t in (n <= r ^2)%N].

Definition eea_sqrr (n l : nat) :=
filter_sqrr n (eea n l).

Lemma head_in n l :  head (0%N, 0%:Z, 0%:Z) (eea_sqrr n l) \in eea n l.
Proof.
rewrite /eea_sqrr; set s := eea _ _.
have Hs : forall x, x \in (filter_sqrr n s) -> x \in s.
+ move=> x; rewrite /filter_sqrr mem_filter.
move/andP; case=> _ -> //.
+ apply: Hs; rewrite -nth0; apply: mem_nth.
rewrite lt0n size_eq0 /filter_sqrr /s -has_filter //=.
apply/hasP => //=; case Hn : n => [|k].
+ rewrite /eea //=; exists (l, 0, 1); rewrite ?inE ?eqxx ?leq0n //.
+ rewrite /eea.
have Hk : (k.+1 == 0%N) = false by [].
rewrite Hk; clear Hk; exists (k.+1, 1, 0).
apply: in_acc_in_eea; rewrite ?leq_maxr ?inE //.
clear Hn; case:k => [//|k].
rewrite -mulnn -{1}[k.+1]mul1n.
by apply: ltn_mul.
Qed.

Lemma eea_size_gt0 a b :
(size (eea a b) > 0)%N.
Proof.
rewrite lt0n size_eq0.
case H: (eea a b)=> [|//].
move: (head_in a b); by rewrite H.
Qed.

(* as it is in the math proof but for our case is just the index of the head *)
(* not used in the proof *)
Definition maxrseq (n l : nat) :=
\max_(i <- (eea_sqrr n l)) (index i (eea n l)).

Definition index_hd (n l : nat) :=
index (head (0%N, 0, 0) (eea_sqrr n l)) (eea n l).

(* before
Definition base (n l : nat) :=
if (l %| n) then ((l, -1),(n, 0)) else
let m := index_hd n l in
let: (r1, x1, y1) := nth (0%N, 0, 0) (eea n l) m.-1 in
let: (r0, x0, y0) := nth (0%N, 0, 0) (eea n l) m in
let: (r2, x2, y2) := nth (0%N, 0, 0) (eea n l) m.-2 in
if (r0%:Z ^+ 2 + y0 ^+ 2 <= r2%:Z ^+ 2 + y2 ^+ 2) then ((r1, -y1),(r0, -y0))
else ((r1, -y1),(r2, -y2)).
(*  what is going on with the first if branch :                    *)
(*  if l %| n then size (eea n l) == 2                             *)
(*  in that case we have m = index_hd n l = 0 or 1                 *)
(*  and then m-1 or m-2 = -1 in theory                             *)
(*  but by definition in nat, 0.-1 = 0                             *)
(*  i.e. if m == 0 => m.-1 == 0 => m.-2 == 0  case 5 5             *)
(*  in practice we never enter the if branch because n is prime    *)
(*  (page 4 of the GLV article :) Let E be an ec defined over Fq   *)
(*   and P <- E(Fq) be a point of prime order n                    *)

(*  in the case that l %| n we definitely have a problem but it will never happen  *)
(*  if l does not divide n then size (eea n l) >= 3                                *)
(*  but in that case we may have problems too                                      *)
(*  because nothing stops m from being 1 or 0 ,                                    *)
(*  (case 9 8,  m = 1) (case 9 87, m = 0)                                          *)
(*  m == 0 -> take (triplet_0, triplet_1) what else can I do ?                     *)
(*  m == 1 -> take (triplet_0, triplet_1) this is normal enough                    *)
*)

Definition base (n l : nat) :=
let m := index_hd n l in
if (m <= 1)%N then
let: (r0, x0, y0) := nth (0%N, 0, 0) (eea n l) 0%N in
let: (r1, x1, y1) := nth (0%N, 0, 0) (eea n l) 1%N in
((r0, -y0),(r1, -y1))
else
let: (r1, x1, y1) := nth (0%N, 0, 0) (eea n l) m.-1 in
let: (r0, x0, y0) := nth (0%N, 0, 0) (eea n l) m in
let: (r2, x2, y2) := nth (0%N, 0, 0) (eea n l) m.-2 in
if (r0%:Z ^+ 2 + y0 ^+ 2 <= r2%:Z ^+ 2 + y2 ^+ 2) then ((r1, -y1),(r0, -y0))
else ((r1, -y1),(r2, -y2)).

(****************************************************)
(* n != 0 ok because n = order of the point & n prime *)
(* l != 0 ok because l from the endomorphism of the curve *)
(* to clean *)
Lemma base_modn_snd n l :
n != 0%N -> l != 0%N ->
let (u,v) := base n l in
((v.1)%:Z + v.2 * l = 0 %[mod n])%Z.
Proof.
move=> n_nz l_nz.
case Hbase : (base n l)=> [u v].
apply /eqP.
rewrite eqz_mod_dvd subr0.
set m := index_hd n l.
case Hm : (m <= 1)%N.
+ move : (Hbase); rewrite /base Hm.
case Hnth0 : (nth (0%N, 0, 0) (eea n l) 0) => [[r0 x0] y0].
case Hnth1 : (nth (0%N, 0, 0) (eea n l) 1) => [[r1 x1] y1].
move/eqP; rewrite xpair_eqE; move/andP; case => Hu Hv.
rewrite (surjective_pairing u) in Hu; rewrite (surjective_pairing v) in Hv.
move : Hv; rewrite xpair_eqE; case/andP; rewrite eq_sym; move/eqP=> -> //.
rewrite eq_sym; move/eqP=> -> //.
apply/dvdzP.
exists x1.
rewrite mulNr.
apply: (eea_mod n l (r1, x1, y1)).
rewrite -Hnth1; apply: mem_nth.
apply: eea_size_nz => //.

(* seconde case *)
move : (Hbase); rewrite /base Hm.
case Hnth : (nth (0%N, 0, 0) (eea n l) m.-1) => [[rm xm] ym].
case Hnth0 : (nth (0%N, 0, 0) (eea n l) m) => [[rm0 xm0] ym0].
case Hnth2 : (nth (0%N, 0, 0) (eea n l) m.-2) => [[rm2 xm2] ym2].
case H : (rm0%:Z ^+ 2 + ym0 ^+ 2 <= rm2%:Z ^+ 2 + ym2 ^+ 2).

(*one*)
move/eqP; rewrite xpair_eqE; move/andP; case.
move=> _; rewrite eq_sym; move/eqP=> //.
rewrite (surjective_pairing v).
move/eqP; rewrite xpair_eqE; move/andP; case => H1 H2.
rewrite (eqP H1) (eqP H2) //=.
apply/dvdzP.
exists xm0.
rewrite mulNr.
apply : (eea_mod n l (rm0, xm0, ym0)).
rewrite -Hnth0.
apply: mem_nth.
rewrite /m /index_hd.
by rewrite index_mem head_in.

(* two *)
move/eqP; rewrite xpair_eqE; move/andP; case.
move=> _; rewrite eq_sym; move/eqP=> //.
rewrite (surjective_pairing v).
move/eqP; rewrite xpair_eqE; move/andP; case => H1 H2.
rewrite (eqP H1) (eqP H2) //=.
apply/dvdzP.
exists xm2.
rewrite mulNr.
apply : (eea_mod n l (rm2, xm2, ym2)).
rewrite -Hnth2.
apply: mem_nth.

have Hinter: (m < size (eea n l))%N.
by rewrite /m /index_hd index_mem head_in.

have Hfst : (m.-2 < m)%N.
move: (leq_trans (leq_pred m.-1) (leq_pred m)).
rewrite leq_eqVlt.
move/orP; case=> //.
move/eqP => H0.

case h : m=> [|x].
by move: Hm; rewrite h.
rewrite //=.
case X : x=> [//|y //].
apply: (ltn_trans Hfst Hinter).
Qed.

Lemma base_modn_fst n l :
let (u,v) := base n l in
((u.1)%:Z + u.2 * l = 0 %[mod n])%Z.
Proof.
case Hbase : (base n l)=> [u v].
apply /eqP.
rewrite eqz_mod_dvd subr0.
set m := index_hd n l.
case Hm : (m <= 1)%N.
+ move : (Hbase); rewrite /base Hm.
case Hnth0 : (nth (0%N, 0, 0) (eea n l) 0) => [[r0 x0] y0].
case Hnth1 : (nth (0%N, 0, 0) (eea n l) 1) => [[r1 x1] y1].
move/eqP; rewrite xpair_eqE; move/andP; case => Hu Hv.
rewrite (surjective_pairing u) in Hu; rewrite (surjective_pairing v) in Hv.
move : Hu; rewrite xpair_eqE; case/andP; rewrite eq_sym; move/eqP=> -> //.
rewrite eq_sym; move/eqP=> -> //.
apply/dvdzP.
exists x0.
rewrite mulNr.
apply: (eea_mod n l (r0, x0, y0)).
rewrite -Hnth0; apply: mem_nth.
by rewrite eea_size_gt0.

move : (Hbase); rewrite /base Hm.
case Hnth : (nth (0%N, 0, 0) (eea n l) m.-1) => [[rm xm] ym].
case Hnth0 : (nth (0%N, 0, 0) (eea n l) m) => [[rm0 xm0] ym0].
case Hnth2 : (nth (0%N, 0, 0) (eea n l) m.-2) => [[rm2 xm2] ym2].

move=> Hu.

have U : u = (rm, -ym).
case H : (rm0%:Z ^+ 2 + ym0 ^+ 2 <= rm2%:Z ^+ 2 + ym2 ^+ 2).
+ move/eqP: Hu; rewrite H //.
rewrite xpair_eqE; move/andP; case.
rewrite eq_sym. move/eqP=> U _; by rewrite U.
+ move/eqP: Hu; rewrite H //.
rewrite xpair_eqE; move/andP; case.
rewrite eq_sym. move/eqP=> U _; by rewrite U.
move:U; rewrite (surjective_pairing u).
move/eqP; rewrite xpair_eqE; move/andP; case => H1 H2.
rewrite (eqP H1) (eqP H2) //=.
apply/dvdzP.
exists xm.
rewrite mulNr.
apply: (eea_mod n l (rm, xm, ym)).
rewrite -Hnth; apply: mem_nth.

have ineq : (m < size (eea n l))%N.
by rewrite /m /index_hd index_mem head_in.
apply: leq_ltn_trans (leq_pred m) ineq.
Qed.

(*approximation of n/m (in Q) by an integer*)
Definition approx (n m : nat) :=
let r := n %% m in
let q := n %/ m in
if (2*r <= m)%N then q else q.+1.

Definition approxZ (n m : int) :=
((sgz n) * (sgz m)) * (approx (absz n) (absz m))%:Z.

(*using base*)
Definition cramer_coefs n l k :=
let (u, v) := base n l in
let D := u.1%:Z * v.2 - u.2 * v.1%:Z in
(approxZ (k * v.2) D, approxZ (- k * u.2) D).

Definition decomp (n l k : nat) : int * int :=
let (a, b) := cramer_coefs n l k in
let (u, v) := base n l in
let k1 := k%:Z - (a * u.1%:Z + b * v.1%:Z) in
let k2 := - (a * u.2 + b * v.2) in
(k1, k2).

Lemma correct_decomp n l k :
let (k1, k2) := decomp n l k in
n != 0%N -> l != 0%N ->
(k = (k1 + k2 * l) %[mod n])%Z.
Proof.
case Hdecomp : (decomp n l k)=> [k1 k2].
move=> nNz lNz.
move: Hdecomp; rewrite /decomp.
case Hcramer : (cramer_coefs n l k)=> [a b].
case Hbase : (base n l)=> [u v].
move/eqP; rewrite xpair_eqE; move/andP; case => H1 H2.
move: H1; rewrite eq_sym; move/eqP => -> //.
move: H2; rewrite eq_sym; move/eqP => -> //.
rewrite mulNr mulrDl; apply/eqP.
rewrite eqz_mod_dvd.
rewrite opprB addrA opprB addrA addrC.
rewrite addrA addrA [_ + k%:Z]addrC.
have Hk : k%:Z - k%:Z = 0.
by apply/eqP; rewrite subr_eq0.
rewrite Hk; clear Hk.
rewrite add0r -addrA [b * v.2 * l + _]addrC.
rewrite -addrA -[b * v.2 * l]mulrA -mulrDr.
rewrite addrA  -[a * u.2 * l]mulrA  -mulrDr.
rewrite [_ + u.1%:Z]addrC.
move : (base_modn_fst n l); rewrite Hbase.
move/eqP; rewrite eqz_mod_dvd subr0; move=> Hu.
move : (base_modn_snd n l nNz lNz); rewrite Hbase.
move/eqP; rewrite eqz_mod_dvd subr0; move=> Hv.
apply/ dvdzP.
move/dvdzP :Hu=> [x Hu].
move/dvdzP :Hv=> [y Hv].
rewrite Hu Hv.
exists (a * x + b * y).
by rewrite mulrDl !mulrA.
Qed.

End Decomposition.


Require Import QArith.
Require Import ZNatPairs.
Require Import Zsqrt.

(**
    encode(k1, k2) = (k1 + k2) * (k1 + k2 + 1) / 2 + k2
**)

Definition encode (k : (Z * Z)) : Q :=
Qmake
  (((fst k) + (snd k)) * ((fst k) + (snd k) + 1) + 2 * (snd k))
    2.

(**
    decode(z):
        w = (sqrt(8z + 1) - 1) / 2
        t = (w^2 + w) / 2
        y = z - t
        x = w - y
        return <x, y>

    x = w - (z - t)
    y = z - t
**)

Definition to_pos (z:Z) : positive :=
  match z with
    | Zpos p => p
    | _ => 1%positive
  end.

Definition Zsqrt_plain_pos (p : positive) : positive :=
to_pos (Zsqrt_plain (Zpos p)).

Definition W (z : Q) : Q :=
 let x := (Zsqrt_plain (8 * (Qnum z) + (Zpos (Qden z)))) in
 let y := (Zsqrt_plain_pos (Qden z)) in
 Qmake (x - (Zpos y)) (2 * y).

Definition T (w : Q) : Q :=
  let a := (Qnum w) in
  let b := (Qden w) in
Qmake (a*a + a* (Zpos b)) (2 * b * b).

Definition ZofQ (x : Q) : option Z :=
  let (q,r) := Zdiv_eucl (Qnum x) (Zpos (Qden x)) in
  match r with
  | Z0 => Some q
  | Zpos r' => None
  | Zneg r' => None
  end.

Definition option_bind {A B:Type} (f : A -> option B) (o : option A) :=
match o with
| Some a => f a
| None => None
end.

Definition mdecode (z : Q) : option (Z * Z) :=
option_bind (fun lhs =>
 option_bind (fun rhs => Some (lhs, rhs))
 (ZofQ (z - (T (W z)))))
 (ZofQ ((W z) - (z - T (W z)))).

Theorem mdecode_some :
 forall z,
  { zz | mdecode z = Some zz }.
Proof.
  intros.
Admitted.

Definition decode z :=
match mdecode_some z with
| exist zz _ => zz
end.

Theorem decode_encode : forall x y ,
    decode (encode (x, y)) = (x, y).
Proof.
 intros x y.
 unfold decode.
 remember (encode (x, y)) as exy.
 destruct (mdecode_some exy) as [[ax ay] P].

Admitted.

Theorem encode_decode : forall z ,
    encode (decode z) = z.
Proof.
Admitted.


Require Import Nat Arith.

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

Fixpoint add (add_arg0 : INT) (add_arg1 : INT) : INT
           := match add_arg0, add_arg1 with
              | n, zero => n
              | n, succ m => succ (add n m)
              | add x y, z => add x (add y z)
              | x, y => add y x
              end.

Fixpoint mult (mult_arg0 : INT) (mult_arg1 : INT) : INT
           := match mult_arg0, mult_arg1 with
              | n, zero => zero
              | n, succ m => add n (mult n m)
              | zero, n => mult n zero
              end.

Theorem theorem0 : forall (n : INT) (m : INT), eq (mult n m) (mult m n).
Proof.
Admitted.


(* Exercise 53 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_053 : ((A -> B) -> B) -> ~A -> B.
Proof.
imp_i a1.
imp_i a2.
imp_e (A -> B).
hyp a1.
imp_i a3.
neg_e (A).
hyp a2.
hyp a3.
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 (lf2 : natural) (x : natural) (lf1 : natural) : natural :=
  plus lf1 Zero.