(* Copyright (c)  Inria. All rights reserved. *)
From mathcomp Require Import all_ssreflect all_algebra ssrnum.
Require Import digitn.

(******************************************************************************)
(*                                                                            *)
(*             Proof of the Fast Fourier Transform                            *)
(*              inspired by a paper by V. Capretta                            *)
(******************************************************************************)

(******************************************************************************)
(*                                                                            *)
(* fft n w p    = naive algorithn that returns the polynomial                 *)
(*                p[1] + p[w] * 'X + ... + p[w^(2^n - 1)] * 'X^(2^n - 1)      *)
(* fft1 n w p   = returns the polynomial                                      *)
(*                p[1] + p[w] * 'X + ... + p[w^(2^n - 1)] * 'X^(2^n - 1)      *)
(* istep n w p  = naive iterative algorithn that returns the polynomial       *)
(*                p[1] + p[w] * 'X + ... + p[w^(2^n - 1)] * 'X^(2^n - 1)      *)
(* istep1 n w p = iterative algorithm that returns the polynomial             *)
(*                p[1] + p[w] * 'X + ... + p[w^(2^n - 1)] * 'X^(2^n - 1)      *)
(******************************************************************************)

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

Import GRing.Theory Num.Theory Order.POrderTheory Num.ExtraDef Num.

Section FFT.

Local Open Scope ring_scope.

(* Arbitary idomain                                                           *)
(* In fact  it works for an arbitray ring. We ask for idomain in order to use *)
(* primitive-root and sqr_eqf1                                                *)
Variable R : idomainType.

Implicit Type p : {poly R}.

Lemma prim_exp2nS n (w : R) : (2 ^ n.+1).-primitive_root w -> w ^+ (2 ^ n) = -1.
Proof.
move=> Hp; have /prim_expr_order/eqP := Hp.
rewrite expnS mulnC exprM sqrf_eq1 => /orP[]/eqP // /eqP.
by rewrite -(prim_order_dvd Hp) dvdn_Pexp2l // ltnn.
Qed.

Lemma prim_sqr n (w : R) :
  (2 ^ n.+1).-primitive_root w -> (2 ^ n).-primitive_root (w ^+ 2).
Proof.
move=> Hp.
have -> : (2 ^ n = 2 ^ n.+1 %/ (gcdn 2 (2 ^ n.+1)))%N.
  by rewrite -(expn_min _ 1) (minn_idPl _) // expnS mulKn.
by rewrite exp_prim_root.
Qed.

(* The recursive algorithm                                                    *)
Fixpoint fft (n : nat) (w : R) (p : {poly R}) : {poly R} :=
  if n is n1.+1 then
    let ev := fft n1 (w ^+ 2) (even_poly p) in
    let ov := fft n1 (w ^+ 2) (odd_poly p) in
    \poly_(i < 2 ^ n1.+1) let j := (i %% 2 ^ n1)%N in ev`_j + ov`_ j * w ^+ i
  else (p`_0)%:P.

Lemma size_fft n w p : (size (fft n w p) <= 2 ^ n)%N.
Proof.
by case: n => [|n] /=; [rewrite size_polyC; case: eqP | apply: size_poly].
Qed.

Fact size_odd_poly_exp2n n p :
  (size p <= 2 ^ n.+1 -> size (odd_poly p) <= 2 ^ n)%N.
Proof.
move=> Hs; apply: leq_trans (size_odd_poly _) _.
by rewrite leq_half_double (leq_trans Hs) // -mul2n -expnS.
Qed.

Fact half_exp2n n : (uphalf (2 ^ n.+1) = 2 ^ n)%N.
Proof.
by rewrite uphalf_half !expnS !mul2n doubleK odd_double add0n.
Qed.

Fact size_even_poly_exp2n n p :
  (size p <= 2 ^ n.+1 -> size (even_poly p) <= 2 ^ n)%N.
Proof.
move=> Hs; apply: leq_trans (size_even_poly _) _.
by rewrite -half_exp2n uphalf_leq.
Qed.

Lemma poly_size1 p : (size p <= 1)%N -> p = (p`_0)%:P.
Proof.
move=> sL.
rewrite -[LHS]coefK poly_def; case E : size sL => [|[]]// _.
  by rewrite big_ord0 -[p]coefK E poly_def big_ord0 !coefC.
by rewrite big_ord1 alg_polyC.
Qed.

Lemma poly_size2 p : (size p <= 2)%N -> p = (p`_0)%:P + (p`_1)%:P * 'X.
Proof.
rewrite leq_eqVlt => /orP[/eqP spE|/poly_size1->]; last first.
  by rewrite !coefC /= mul0r addr0.
by rewrite -[LHS]coefK poly_def spE big_ord_recr /=
           big_ord1 alg_polyC mul_polyC.
Qed.

(* Its correctness                                                            *)
Lemma fftE n (w : R) p :
  (size p <= 2 ^ n)%N -> (2 ^ n).-primitive_root w ->
  fft n w p = \poly_(i < 2 ^ n) p.[w ^+ i].
Proof.
elim: n w p => [/= w p sL _ |n IH w p sL wE /=].
  by rewrite poly_def big_ord1 expr0 [p]poly_size1 // !hornerE alg_polyC coefC.
apply/polyP => i; rewrite !coef_poly; case: leqP => // iL.
have imL : (i %% 2 ^ n < 2 ^ n)%N by apply/ltn_pmod/expn_gt0.
have n2P : (0 < 2 ^ n.+1)%N by rewrite expn_gt0.
have wwE := prim_sqr wE.
rewrite !IH ?coef_poly ?imL ?size_even_poly_exp2n ?size_odd_poly_exp2n //.
rewrite -[p in RHS]poly_even_odd.
rewrite !(hornerD, horner_comp, hornerMX, hornerX).
suff -> : (w ^+ 2) ^+ (i %% 2 ^ n) = w ^+ i * w ^+ i by [].
rewrite -!expr2 -!exprM.
have [iLm|mLi] := leqP (2 ^ n) i; last by rewrite modn_small // mulnC.
have -> : (i %% 2 ^ n = i - 2 ^ n)%N.
  rewrite -[in LHS](subnK iLm) modnDr modn_small //.
  by rewrite ltn_psubLR ?expn_gt0 // addnn -mul2n -expnS.
have -> : (i * 2 = 2 * (i - 2 ^ n) + 2 ^ n.+1)%N.
  by rewrite mulnC mulnBr -expnS subnK // expnS leq_mul2l.
rewrite exprD.
suff -> : w ^+ (2 ^ n.+1) = 1 by rewrite mulr1.
by rewrite expnS exprM (prim_expr_order wwE).
Qed.

(* The algorithm with explicitely the butterfly                               *)
Fixpoint fft1 n w p : {poly R} :=
  if n is n1.+1 then
  let ev := fft1 n1 (w ^+ 2) (even_poly p) in
  let ov := fft1 n1 (w ^+ 2) (odd_poly p) in
  \sum_(j < 2 ^ n1)
    ((ev`_j + ov`_ j * w ^+ j) *: 'X^j +
     (ev`_j - ov`_ j * w ^+ j) *: 'X^(j + 2 ^ n1))
  else (p`_0)%:P.

Lemma fft1S n w p :
  fft1 n.+1 w p =
  let ev := fft1 n (w ^+ 2) (even_poly p) in
  let ov := fft1 n (w ^+ 2) (odd_poly p) in
  \sum_(j < 2 ^ n)
    ((ev`_j + ov`_ j * w ^+ j) *: 'X^j +
     (ev`_j - ov`_ j * w ^+ j) *: 'X^(j + 2 ^ n)).
Proof. by []. Qed.

Lemma fft1E n (w : R) p : (2 ^ n).-primitive_root w -> fft1 n w p = fft n w p.
Proof.
elim: n w p => [// |n IH w p wE /=].
have wwE := prim_sqr wE.
rewrite poly_def -(@big_mkord _ (0 : {poly R}) +%R (2 ^ n.+1) xpredT
   (fun (i : nat) =>
      ((fft n (w ^+ 2) (even_poly p))`_(i %% 2 ^ n) +
    (fft n (w ^+ 2) (odd_poly p))`_(i %% 2 ^ n) * w ^+ i) *: 'X^i)).
have F : (2 ^ n <= 2 ^ n.+1)%N by rewrite leq_exp2l.
apply: sym_equal.
rewrite (big_cat_nat _ _ _ _ F) //=.
rewrite big_nat; under eq_bigr do rewrite modn_small // ; rewrite -big_nat /=.
rewrite -(add0n (2 ^ n)%N) big_addn add0n.
rewrite [(2 ^ n.+1)%N]expnS mul2n -addnn addnK.
rewrite big_split /= big_mkord; congr (_ + _).
  by apply: eq_bigr => i _;
      rewrite !IH ?size_even_poly_exp2n ?size_odd_poly_exp2n //.
rewrite big_nat; under eq_bigr do
    rewrite modnDr modn_small // exprD (prim_exp2nS wE) mulrN1 mulrN;
    rewrite -big_nat /=.
rewrite big_mkord; apply: eq_bigr => i _.
by rewrite !IH ?size_even_poly_exp2n ?size_odd_poly_exp2n.
Qed.

Definition step m n w (p : {poly R}) :=
  \sum_(l < 2 ^ m)
  let ev := \poly_(i < 2 ^ n) p`_(i + l * 2 ^ n.+1) in
  let ov := \poly_(i < 2 ^ n) p`_(i + l * 2 ^ n.+1 + 2 ^ n) in
    \sum_(j < 2 ^ n)
      ((ev`_j + ov`_ j * w ^+ j) *: 'X^(j + l * 2 ^ n.+1) +
       (ev`_j - ov`_ j * w ^+ j) *: 'X^(j + l * 2 ^ n.+1 + 2 ^ n)).

Lemma stepE m n w (p : {poly R}) :
  step m n w p =
  \sum_(l < 2 ^ m)
  let ev := \poly_(i < 2 ^ n) p`_(i + l * 2 ^ n.+1) in
  let ov := \poly_(i < 2 ^ n) p`_(i + l * 2 ^ n.+1 + 2 ^ n) in
    (\sum_(j < 2 ^ n)
      ((ev`_j + ov`_ j * w ^+ j) *: 'X^j +
       (ev`_j - ov`_ j * w ^+ j) *: 'X^(j + 2 ^ n))) *
    'X^ (l * 2 ^ n.+1).
Proof.
apply: eq_bigr => i _ /=.
rewrite [RHS]mulr_suml.
apply: eq_bigr => j _ /=.
rewrite mulrDl; congr (_ + _); rewrite -scalerAl -exprD //.
by rewrite addnAC.
Qed.

Fact bound_step m n i j :
  (i < 2 ^ m -> j < 2 ^ n ->
   j + i * 2 ^ n.+1 + 2 ^ n < 2 ^ (m + n).+1)%N.
Proof.
move=> Hi Hj.
rewrite addnAC.
apply: leq_trans (_ : 2 ^ n + 2 ^ n + i *2 ^ n.+1 <= _ )%N.
  by rewrite -!addnA ltn_add2r.
by rewrite addnn -mul2n -expnS -mulSn -addnS expnD leq_mul2r expn_eq0 /=.
Qed.

Lemma size_step m n w p : (size (step m n w p) <= (2 ^ (m + n).+1))%N.
Proof.
apply: leq_trans (size_sum _ _ _) _.
apply/bigmax_leqP_seq => i _ _.
apply: leq_trans (size_sum _ _ _) _.
apply/bigmax_leqP_seq => j _ _.
apply: leq_trans (size_add _ _) _.
rewrite geq_max; apply/andP; split;
    apply: leq_trans (size_scale_leq _ _) _; rewrite size_polyXn.
  apply: leq_trans (bound_step (ltn_ord i) (ltn_ord j)).
  by rewrite ltnS leq_addr.
by apply: bound_step.
Qed.

Fact stepE1 (m n : nat) w p i :
  w ^+ (2 ^ n) = -1 ->
  (i < 2 ^ (m + n).+1)%N ->
  let l := (i %/ 2 ^ n.+1)%N in
  let j := (i %% 2 ^ n.+1)%N in
  let j1 := (i %% 2 ^ n)%N in
  (step m n w p)`_i =
      p`_(j1 + l * 2 ^ n.+1) +
      p`_(j1 + l * 2 ^ n.+1 + 2 ^ n) * w ^+ j.
Proof.
move=> Hw Hi l j j1.
have lL2m : (l < 2 ^ m)%N.
  by rewrite ltn_divLR ?expn_gt0 // -expnD addnS.
have jL2n : (j < 2 ^ n.+1)%N by rewrite ltn_mod // expn_gt0.
have j1L2n : (j1 < 2 ^ n)%N by rewrite ltn_mod // expn_gt0.
have F1 : (2 ^ n <= j -> j = 2 ^ n + j1)%N.
  move=> Hj.
  rewrite (divn_eq j (2 ^ n)) modn_dvdm -/j1 ?dvdn_Pexp2l //.
  suff-> : (j %/ 2 ^ n = 1)%N by rewrite mul1n.
  have F1 : (j - 2 ^ n < 2 ^ n)%N.
    by rewrite ltn_subLR // addnn -mul2n -expnS.
  rewrite -(subnK Hj) divnD ?expn_gt0 // divn_small ?F1 //.
  rewrite add0n divnn expn_gt0 //=.
  by rewrite modn_small ?(ltnW F1) // modnn addn0 leqNgt F1 addn0.
have F2 : (j < 2 ^ n -> j = j1)%N.
  move=> F2.
  by rewrite -(modn_small F2) modn_dvdm // dvdn_Pexp2l.
rewrite coef_sum (bigD1 (Ordinal lL2m)) //= [X in _ + X]big1 ?addr0.
  rewrite coef_sum (bigD1 (Ordinal j1L2n)) //= [X in _ + X]big1 ?addr0.
    rewrite !(coefD, coefZ, coefXn, coef_poly).
    rewrite j1L2n (divn_eq i (2 ^ n.+1)) -/l [(l * _ + _)%N]addnC.
    rewrite [(_ + 2 ^ n)%N]addnC addnA !eqn_add2r -/j -/j1.
    have [Hul|Hlu] := leqP (2 ^ n) j.
      rewrite F1 // -[X in _ == X]add0n eqn_add2r expn_eq0 mulr0 add0r.
      by rewrite eqxx mulr1 exprD Hw mulN1r mulrN.
    by rewrite F2 // eqxx mulr1 -[X in X == _]add0n eqn_add2r eq_sym
               expn_eq0 mulr0 addr0.
  move=> i1 /eqP/val_eqP/= Hi1.
  rewrite !(coefD, coefZ, coefXn, coef_poly).
  rewrite ltn_ord // (divn_eq i (2 ^ n.+1)) -/l [(l * _ + _)%N]addnC.
  rewrite [(_ + 2 ^ n)%N]addnC addnA !eqn_add2r -/j -/j1.
  have [Hul|Hlu] := leqP (2 ^ n) j.
    rewrite eqn_leq [(j <= _)%N]leqNgt (leq_trans (ltn_ord _)) //=.
    rewrite mulr0 add0r.
    by rewrite F1 // eqn_add2l eq_sym (negPf Hi1) mulr0.
  rewrite [(_ == (_ + _))%N]eqn_leq [(_ <= j)%N]leqNgt.
  rewrite (leq_trans Hlu) ?leq_addr // andbF mulr0 addr0.
  by rewrite F2 // eq_sym (negPf Hi1) mulr0.
move=> i1 /eqP/val_eqP/= Hi1.
rewrite coef_sum big1 // => i2 _.
rewrite !(coefD, coefZ, coefXn, coef_poly).
rewrite (_ : _ == _ = false); last first.
  apply/idP => /eqP iE; have /eqP[] := Hi1.
  rewrite /l iE divnDMl ?expn_gt0 // divn_small //.
  by rewrite (leq_trans (ltn_ord _)) // leq_exp2l.
rewrite (_ : _ == _ = false) ?mulr0 ?addr0 //.
apply/idP => /eqP iE; have /eqP[] := Hi1.
rewrite addnC addnA in iE.
rewrite /l iE divnDMl ?expn_gt0 // divn_small //.
rewrite expnS mul2n -addnn ltn_add2l.
by rewrite (leq_trans (ltn_ord _)) // leq_exp2l.
Qed.

Lemma take_step m n w (p : {poly R}) :
  (size p <= 2 ^ (m + n).+2)%N ->
  take_poly (2 ^ (m + n).+1) (step m.+1 n w p) =
  step m n w (take_poly (2 ^ (m + n).+1) p).
Proof.
move=> pLmn; rewrite stepE.
apply/polyP=> i; rewrite coef_take_poly.
case: leqP => [mnLi|iLmn].
  rewrite nth_default //.
  by apply: leq_trans (size_step _ _ _ _) _.
rewrite stepE !coef_sum expnS mul2n -addnn big_split_ord /=.
rewrite [X in _ + X = _]big1 ?addr0 => [|j _]; last first.
  by rewrite coefMXn ifT // (leq_trans iLmn) // mulnDl -expnD addnS leq_addr.
apply: eq_bigr => j _.
congr (((_ * _) : {poly R}) `_ _).
apply: eq_bigr => k _.
have F : (k + j * 2 ^ n.+1 < 2 ^ (m + n).+1)%N.
  apply: leq_trans (bound_step (ltn_ord j) (ltn_ord k)).
  by rewrite ltnS leq_addr.
have F1 : (k + j * 2 ^ n.+1 + 2 ^ n < 2 ^ (m + n).+1)%N.
  by apply: bound_step.
by rewrite !coef_poly F F1.
Qed.

Lemma drop_step m n w (p : {poly R}) :
  (size p <= 2 ^ (m + n).+2)%N ->
  drop_poly (2 ^ (m + n).+1) (step m.+1 n w p) =
  step m n w (drop_poly (2 ^ (m + n).+1) p).
Proof.
move=> pLmn.
apply/polyP=> i; rewrite coef_drop_poly.
rewrite !stepE !coef_sum expnS mul2n -addnn big_split_ord /=.
rewrite [X in X + _ = _]big1 ?add0r => [|j _]; last first.
  rewrite coefMXn ifN; last first.
    rewrite -leqNgt (leq_trans _ (leq_addl _ _)) //.
    by rewrite -addnS expnD leq_mul2r // ltnW ?orbT.
  rewrite nth_default //.
  apply: leq_trans (_ : 2 ^ n.+1 <= _)%N.
    apply: leq_trans (size_sum _ _ _) _.
    apply/bigmax_leqP => k _.
    apply: leq_trans (size_add _ _) _.
    rewrite geq_max; apply/andP; split; apply: leq_trans (size_scale_leq _ _) _.
      rewrite size_polyXn.
      by apply: leq_trans (ltn_ord _) _; rewrite leq_exp2l.
    by rewrite size_polyXn expnS mul2n -addnn ltn_add2r.
  rewrite leq_subRL (leq_trans _ (leq_addl _ _)) //.
    by rewrite addnC -mulSn -addnS expnD leq_mul2r ltn_ord orbT.
  by rewrite -addnS expnD leq_mul2r ltnW ?orbT // ltn_ord.
apply: eq_bigr => j _.
rewrite !coefMXn addnC mulnDl -expnD addnS ltn_add2l.
case: leqP => // jLi; rewrite subnDl.
congr ((_ : {poly R}) `_ _).
apply: eq_bigr => k _.
have F : (k + j * 2 ^ n.+1 + 2 ^ (m + n).+1 =
          k + (2 ^ (m + n).+1 + j * 2 ^ n.+1))%N.
  by rewrite addnAC addnA.
have F1 :
  ((k + j * 2 ^ n.+1 + 2 ^ n + 2 ^ (m + n).+1) =
    (k + (2 ^ (m + n).+1 + j * 2 ^ n.+1) + 2 ^ n))%N.
  by rewrite !addnA [(k + _ + _)%N in RHS]addnAC [(_ + 2 ^ n)%N in RHS]addnAC.
by rewrite !(coef_drop_poly, coef_poly) ltn_ord // F F1.
Qed.

Definition reverse_poly n (p : {poly R}) :=
  \poly_(i < 2 ^ n) p`_(rdigitn 2 n i).

Lemma size_reverse_poly  n p : (size (reverse_poly n p) <= 2 ^ n)%N.
Proof. by rewrite size_poly. Qed.

Lemma reverse_poly0 p : reverse_poly 0 p = (p`_0)%:P.
Proof. by apply/polyP => [] [|i]; rewrite coef_poly coefC. Qed.

Lemma reverse_polyS n p :
  reverse_poly n.+1 p =
  reverse_poly n (even_poly p) + reverse_poly n (odd_poly p) * 'X^(2 ^ n).
Proof.
rewrite /reverse_poly /even_poly /odd_poly.
under [X in X + _]eq_poly do rewrite coef_poly.
under [X in _ + X * _]eq_poly do rewrite coef_poly.
apply/polyP => i.
rewrite coefD coefMXn !coef_poly.
have [tnLi|iLtn] := leqP (2 ^ n) i.
  rewrite ltn_subLR // addnn -mul2n -expnS add0r.
  case: leqP => [//|iLtSn].
  suff Hf : (rdigitn 2 n.+1 i) = (rdigitn 2 n (i - 2 ^ n)).*2.+1.
    case: leqP => [iLn|nLi]; last by rewrite Hf.
    suff/leq_sizeP-> : (size p <= rdigitn 2 n.+1 i)%N by [].
    rewrite Hf.
    by rewrite leq_half_double in iLn.
  rewrite !rdigitnE big_ord_recl /= subn0 muln1 /bump /= .
  rewrite {1}/digitn -{1}(subnK tnLi).
  rewrite divnDr ?dvdnn // divnn expn_gt0 /= divn_small ?add1n; last first.
    by rewrite ltn_subLR // addnn -mul2n -expnS.
  under eq_bigr do rewrite add1n; congr (_.+1).
  under eq_bigr do rewrite expnS mulnCA.
  rewrite -big_distrr /= mul2n; congr (_.*2).
  apply: eq_bigr => j _; congr (_ * _)%N.
  have ->: (n.-1 - j = n - j.+1)%N.
    rewrite subnS.
    by case: (n) j => //= n1 j; rewrite subSn // -ltnS.
  rewrite /digitn -{1}(subnK tnLi) -[X in (_ + 2 ^ X)%N](subnK (ltn_ord j)).
  rewrite expnD mulnC divnDMl ?expn_gt0 //.
  by rewrite -modnDm // expnS modnMr addn0 modn_mod.
rewrite addr0 ifT; last by rewrite (leq_trans iLtn) // leq_exp2l.
suff Hf : (rdigitn 2 n.+1 i) = (rdigitn 2 n i).*2.
  case: leqP => [iLn|nLi]; last by rewrite Hf.
  suff/leq_sizeP-> : (size p <= rdigitn 2 n.+1 i)%N by [].
  rewrite leq_uphalf_double in iLn.
  by rewrite (leq_trans iLn) // Hf.
rewrite !rdigitnE big_ord_recl /= subn0 muln1 /bump /= .
rewrite {1}/digitn divn_small // add0n.
under eq_bigr do rewrite add1n expnS mulnCA.
rewrite -big_distrr /= mul2n; congr (_.*2).
apply: eq_bigr => j _; congr (_ _ _ * _)%N.
rewrite subnS.
by case: (n) j => //= n1 j; rewrite subSn // -ltnS.
Qed.

Fixpoint all_results_fft1 n m w p q :=
  if n is n1.+1 then
  all_results_fft1 n1 m w (even_poly p) (take_poly (2 ^ (m + n1)) q) /\
  all_results_fft1 n1 m w (odd_poly p) (drop_poly (2 ^ (m + n1)) q)
  else q = fft1 m w p.

Lemma all_resultsS_fft1 n m w p q :
  all_results_fft1 n.+1 m w p q <->
  all_results_fft1 n m w (even_poly p) (take_poly (2 ^ (m + n)) q) /\
  all_results_fft1 n m w (odd_poly p) (drop_poly (2 ^ (m + n)) q).
Proof. by []. Qed.

Lemma all_results_fft1_reverse_poly p n w :
  (size p <= 2 ^ n)%N -> all_results_fft1 n 0 w p (reverse_poly n p).
Proof.
elim: n p => /= [p spL1|n IH p spLb].
  by rewrite reverse_poly0 -poly_size1.
split.
  rewrite /take_poly reverse_polyS poly_def.
  under eq_bigr do rewrite coefD coefMXn ifT // addr0.
  rewrite -poly_def.
  have -> : \poly_(i < 2 ^ n) (reverse_poly n (even_poly p))`_i =
            \poly_(i < size (reverse_poly n (even_poly p)))
                       (reverse_poly n (even_poly p))`_i.
    apply/polyP => i; rewrite coef_poly [RHS]coef_poly.
    case: leqP => [n2Li|iLn2].
      by rewrite ifN // -leqNgt (leq_trans _ n2Li) // size_reverse_poly.
    case: leqP => [epLi|iLep] => //.
    by suff /leq_sizeP-> : (size (reverse_poly n (even_poly p)) <= i)%N by [].
  rewrite coefK.
  apply: IH.
  by rewrite size_even_poly_exp2n.
rewrite add0n.
have -> : drop_poly (2 ^ n) (reverse_poly n.+1 p) =
         \poly_(i < 2 ^ n) (reverse_poly n.+1 p)`_(i + 2 ^ n).
  apply/polyP=> i; rewrite coef_drop_poly coef_poly.
  case: leqP => // nLn; rewrite nth_default //.
  apply: leq_trans (size_reverse_poly _ _) _.
  by rewrite expnS mul2n -addnn leq_add2r.
rewrite reverse_polyS poly_def.
under eq_bigr do rewrite coefD coefMXn ltnNge leq_addl /= addnK scalerDl.
rewrite big_split /= big1 ?add0r => [|i _]; last first.
  suff /leq_sizeP-> : (size (reverse_poly n (even_poly p)) <= i + 2 ^ n)%N.
  - by rewrite scale0r.
  - by [].
  by apply: leq_trans (size_reverse_poly _ _) (leq_addl _ _).
rewrite -poly_def.
have -> : \poly_(i < 2 ^ n) (reverse_poly n (odd_poly p))`_i =
          \poly_(i < size (reverse_poly n (odd_poly p)))
                      (reverse_poly n (odd_poly p))`_i.
  apply/polyP => i; rewrite coef_poly [RHS]coef_poly.
  case: leqP => [n2Li|iLn2].
    by rewrite ifN // -leqNgt (leq_trans _ n2Li) // size_reverse_poly.
  case: leqP => [epLi|iLep] => //.
  by suff /leq_sizeP-> : (size (reverse_poly n (odd_poly p)) <= i)%N by [].
rewrite coefK.
apply: IH.
by rewrite size_odd_poly_exp2n.
Qed.

Lemma poly1 (s : nat -> R) : \poly_(i < 1) s i = (s 0%N)%:P.
Proof. by apply/polyP => i; rewrite coef_poly coefC; case: i. Qed.

Lemma all_results_fft1_step m n w (p q : {poly R}):
  (size p <= 2 ^ (m + n).+1)%N ->
  (size q <= 2 ^ (m + n).+1)%N ->
  all_results_fft1 m.+1 n (w ^+ 2) p q ->
  all_results_fft1 m n.+1 w p (step m n w q).
Proof.
elim: m n w p q => [n p w q|
                    m IH n w p q Hsp Hsp1/all_resultsS_fft1[H2 H3]].
  rewrite add0n => Hp Hq [H1 H2].
  rewrite /= -H1 -H2 /step big_ord1 mul0n !addn0.
  apply: eq_bigr => /= i _.
  by rewrite !coef_drop_poly !coef_poly !addn0 ltn_ord.
apply/all_resultsS_fft1; split.
  rewrite [(_ + m)%N]addnC addnS take_step //.
  apply: IH => //.
  - by apply: size_even_poly_exp2n.
  - by rewrite size_poly.
  by rewrite [(m + _)%N]addnC -addnS.
rewrite addnC addnS drop_step //.
apply: IH => //.
- by apply: size_odd_poly_exp2n.
- rewrite size_drop_poly.
  by rewrite leq_subLR addnn -mul2n -expnS.
by rewrite [(m + _)%N]addnC -addnS.
Qed.

Fixpoint istep_aux m n w p :=
  if m is m1.+1 then istep_aux m1 n.+1 w (step m1 n (w ^+ (2 ^ m1)) p) else p.

Definition istep n w p := istep_aux n 0 w (reverse_poly n p).

Lemma istep_fft1 n p w : (size p <= 2 ^ n)%N -> istep n w p = fft1 n w p.
Proof.
move=> Hs.
suff /(_ n 0%N): forall m1 n1 (p1 q1 : {poly R}),
    (size p1 <= 2 ^ (m1 + n1))%N ->
    (size q1 <= 2 ^ (m1 + n1))%N ->
    all_results_fft1 m1 n1 (w ^+ (2 ^ m1)) p1 q1 ->
    all_results_fft1 0 (m1 + n1) w p1 (istep_aux m1 n1 w q1).
  rewrite addn0 /=.
   apply => //; first by apply: size_reverse_poly.
  by apply: all_results_fft1_reverse_poly.
elim => [//| m1 IH] n1 p1 q1 Hs1 Hs2 H1.
rewrite /istep_aux -/istep_aux addSnnS.
apply: IH; first by rewrite addnS.
  rewrite addnS.
  by apply: size_step.
apply: all_results_fft1_step => //.
by rewrite -exprM mulnC -expnS.
Qed.

(* Refined version of step 1                                                  *)
Definition step1 m n w (p : {poly R}) :=
  \poly_(i < 2 ^ (m + n).+1)
    let j := (i %% 2 ^ n.+1)%N in
    if (j < 2 ^ n)%N then
      p`_i + p`_(i + 2 ^ n) * w ^+ j
    else
      p`_(i - 2 ^ n) - p`_i * w ^+ (j - 2 ^ n).

Lemma step1E m n w p : step1 m n w p = step m n w p.
Proof.
apply/polyP => i.
rewrite coef_poly coef_sum.
have [mnLi|iLmn] := leqP.
  rewrite big1 // => j _; rewrite coef_sum /=.
  rewrite big1 // => k _; rewrite !coef_poly !(coefD, coefZ, coefXn).
  rewrite !gtn_eqF ?mulr0 ?addr0 // (leq_trans _ mnLi) //.
    by apply: bound_step.
  apply: leq_trans (bound_step (ltn_ord j) (ltn_ord k)).
  by rewrite ltnS leq_addr.
set l := (i %/ 2 ^ n.+1)%N.
have l_ltn : (l < 2 ^ m)%N.
  by rewrite ltn_divLR ?expn_gt0 // -expnD addnS.
rewrite (bigD1 (Ordinal l_ltn)) //= [X in _ = _ + X]big1; last first.
  move=> i1 /eqP/val_eqP /= i1Dl.
  rewrite coef_sum big1 // => i2 _.
  rewrite coefD !coefZ !coefXn.
  case: (ltngtP i1 l) i1Dl => // i1Dl _.
    rewrite leq_divRL ?expn_gt0 // in i1Dl.
    rewrite !gtn_eqF ?mulr0 ?addr0 //; apply: leq_trans i1Dl.
      by rewrite addnAC mulSn -!addSn leq_add // expnS mul2n -addnn leq_add2r.
    rewrite mulSn -!addSn leq_add // (leq_trans (ltn_ord _)) //.
    by rewrite expnS mul2n -addnn leq_addr.
  rewrite ltn_divLR ?expn_gt0 // in i1Dl.
  rewrite !ltn_eqF ?mulr0 ?addr0 //; apply: leq_trans i1Dl _.
    by rewrite addnAC leq_addl.
  by rewrite leq_addl.
rewrite addr0.
have F : (i %% 2 ^ n.+1 + l * 2 ^ n.+1 = i)%N by rewrite addnC -divn_eq.
rewrite coef_sum.
case: leqP => H.
  have Fi : (2 ^ n <= i)%N by apply: leq_trans H (leq_mod _ _).
  have F1 : (i %% 2 ^ n.+1 - 2 ^ n < 2 ^ n)%N.
    by rewrite ltn_subLR // addnn -mul2n -expnS ltn_pmod ?expn_gt0.
  have F2 : ((i %% 2 ^ n.+1) %% 2 ^ n = i %% 2 ^ n.+1 - 2 ^ n)%N.
    by rewrite -[in LHS](subnK H) modnDr modn_small.
  rewrite (bigD1 (Ordinal F1)) //= ?big1.
    rewrite addr0 coefD !coefZ !coefXn.
    rewrite addnBAC // F subnK // eqxx mulr1 gtn_eqF; last first.
      by rewrite ltn_subLR // (ltn_add2r _ 0) expn_gt0.
    rewrite mulr0 add0r !coef_poly F1.
    by rewrite addnBAC // F subnK // eqxx mulr1 gtn_eqF.
  move=> i1 /eqP/val_eqP/= Hi1.
  rewrite !coef_poly ltn_ord coefD !coefZ !coefXn.
  rewrite -F addnAC !eqn_add2r gtn_eqF ?mulr0 ?add0r; last first.
    by apply: leq_trans H.
  by rewrite -(subnK H) eqn_add2r eq_sym (negPf Hi1) mulr0.
rewrite (bigD1 (Ordinal H)) //= ?big1.
  rewrite addr0 coefD !coefZ !coefXn F.
  rewrite eqxx mulr1 ltn_eqF ?mulr0 ?addr0 // ?(ltn_add2l _ 0) ?expn_gt0 //.
    by rewrite !coef_poly F H.
  by rewrite addnC (ltn_add2r _ 0) expn_gt0.
move=> i1 /eqP/val_eqP/= Hi1.
rewrite !coef_poly ltn_ord coefD !coefZ !coefXn.
rewrite -F eqn_add2r eq_sym (negPf Hi1) mulr0 add0r.
rewrite addnAC eqn_add2r ltn_eqF ?mulr0 //.
by apply: leq_trans H (leq_addl _ _).
Qed.

Fixpoint istep1_aux m n w p :=
  if m is m1.+1 then istep1_aux m1 n.+1 w (step1 m1 n (w ^+ (2 ^ m1)) p) else p.

Definition istep1 n w p := istep1_aux n 0 w (reverse_poly n p).

Lemma istep1_fft1 n p w : (size p <= 2 ^ n)%N -> istep1 n w p = fft1 n w p.
Proof.
move=> Hs; rewrite -istep_fft1 // /istep1 /istep.
elim: n {Hs}(size_reverse_poly n p) 0%N w (reverse_poly _ _) =>
    //= n IH pLn n1 w p1.
rewrite step1E.
apply: IH.
by apply: size_reverse_poly.
Qed.

End FFT.

Section iFFT.

Local Open Scope ring_scope.

(* Arbitrary field                                                            *)
Variable F : fieldType.

Lemma unity_rootJ n (w : F) : n.-unity_root w^-1 = n.-unity_root w.
Proof.
apply/unity_rootP/unity_rootP; rewrite exprVn => /eqP.
  by rewrite invr_eq1 => /eqP.
by move=> H; apply/eqP; rewrite invr_eq1.
Qed.

Lemma primJ n (w : F) : n.-primitive_root w -> n.-primitive_root (w^-1).
Proof.
move/andP=> [nP /forallP H]; apply/andP; split => //.
apply/forallP => i; apply/eqP; rewrite -(eqP (H i)).
by apply: unity_rootJ.
Qed.

Implicit Type p : {poly F}.

(* The inverse algorithm                                                      *)
Definition ifft n w p : {poly F} := (2^ n)%:R^-1%:P * (fft n w^-1 p).

(* Its correctness                                                            *)
Lemma fftK n (w : F) p :
  2%:R != 0 :> F -> (size p <= 2 ^ n)%N -> (2 ^ n).-primitive_root w ->
  ifft n w (fft n w p) = p.
Proof.
move=> char2 sL wE.
have wE1 : w ^+ (2 ^ n) = 1 by apply: prim_expr_order.
have wNZ : w != 0.
  apply/eqP=> wZ; move/eqP: wE1.
  by rewrite eq_sym wZ expr0n expn_eq0 /= oner_eq0.
have wVE := primJ wE.
have wIE : w^-1 = w ^+ (2 ^ n).-1.
  by apply: (mulfI wNZ); rewrite mulfV // -exprS prednK ?expn_gt0.
rewrite /ifft !fftE ?size_poly //.
apply/polyP => i; rewrite coefCM coef_poly /=.
case: leqP => iL; first by rewrite nth_default ?mulr0 // (leq_trans _ iL).
rewrite horner_poly.
have pE : p = \poly_(j <  2 ^ n) p`_j.
  apply/polyP => j; rewrite coef_poly; case: leqP => // jL.
  by rewrite nth_default // (leq_trans _ jL).
under [X in _ * X = _]eq_bigr => j H do
  rewrite {1}pE horner_poly /= mulr_suml (bigD1 (Ordinal iL)) //=
          -!exprM mulnC -mulrA -exprMn ?(divff, expr1n, mulr1, addr0) //.
rewrite big_split /=.
rewrite sumr_const card_ord mulrDr.
rewrite -[X in _ * X + _ = _]mulr_natl mulrA mulVf ?mul1r; last first.
  by rewrite natrX expf_eq0 (negPf char2) andbF.
rewrite exchange_big /= big1 ?(mulr0, addr0) //= => k /eqP /val_eqP /= kDi.
under [LHS] eq_bigr do
  rewrite -mulrA -exprM mulnC !exprM -exprMn wIE -!exprM -exprD.
set x := w ^+ _; rewrite -mulr_sumr.
suff xDone : x - 1 != 0.
  suff -> : (\sum_(i0 < 2 ^ n) x ^+ i0) = 0 by rewrite mulr0.
  apply: (mulfI xDone).
  by rewrite -subrX1 mulr0 -exprM mulnC exprM wE1 expr1n subrr.
(* There should be a simpler way to prove this *)
rewrite subr_eq0 -(prim_order_dvd wE).
case: {x}i iL kDi => [|i] iL xDi.
  rewrite muln0 addn0; apply/negP=> /dvdn_leq.
  by rewrite lt0n leqNgt ltn_ord => /(_ xDi).
rewrite -subn1 mulnBl mul1n mulnS addnC [(_ ^ _ + _)%N]addnC.
rewrite -addnBA ?(leq_trans _ iL) //.
rewrite /dvdn mulnC -addnA modnMDl; apply/negP => /dvdnP[q /eqP qE].
suff : (q < 2)%N.
  case: q qE => [|[|]] //.
    by rewrite mul0n; rewrite addn_eq0 subn_eq0 leqNgt iL.
  by rewrite mul1n -(eqn_add2r (i.+1)) addnAC subnK
             ?(eqn_add2l, negPf xDi) // ltnW.
rewrite -(ltn_pmul2r (_ : 0 < 2 ^ n)%N) ?expn_gt0 //.
rewrite -(eqP qE) mul2n -addnn.
apply: (leq_trans (_ : _ <= 2 ^ n - i.+1 + 2 ^ n)%N).
  by rewrite ltn_add2l.
by rewrite leq_add2r leq_subr.
Qed.

End iFFT.


From Hammer Require Import Hammer.

Require Import NAxioms NSub NZGcd.

Module Type NGcdProp
(Import A : NAxiomsSig')
(Import B : NSubProp A).

Include NZGcdProp A A B.

Definition divide_1_r n : (n | 1) -> n == 1
:= divide_1_r_nonneg n (le_0_l n).

Definition divide_antisym n m : (n | m) -> (m | n) -> n == m
:= divide_antisym_nonneg n m (le_0_l n) (le_0_l m).

Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p).
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.divide_add_cancel_r".
intros n m p (q,Hq) (r,Hr).
exists (r-q). rewrite mul_sub_distr_r, <- Hq, <- Hr.
now rewrite add_comm, add_sub.
Qed.

Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p).
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.divide_sub_r".
intros n m p H H'.
destruct (le_ge_cases m p) as [LE|LE].
apply sub_0_le in LE. rewrite LE. apply divide_0_r.
apply divide_add_cancel_r with p; trivial.
now rewrite add_comm, sub_add.
Qed.

Definition gcd_0_l n : gcd 0 n == n := gcd_0_l_nonneg n (le_0_l n).
Definition gcd_0_r n : gcd n 0 == n := gcd_0_r_nonneg n (le_0_l n).
Definition gcd_diag n : gcd n n == n := gcd_diag_nonneg n (le_0_l n).
Definition gcd_unique' n m p := gcd_unique n m p (le_0_l p).
Definition gcd_unique_alt' n m p := gcd_unique_alt n m p (le_0_l p).
Definition divide_gcd_iff' n m := divide_gcd_iff n m (le_0_l n).

Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m.
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_add_mult_diag_r".
intros. apply gcd_unique_alt'.
intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial.
apply divide_add_r; trivial. now apply divide_mul_r.
apply divide_add_cancel_r with (p*n); trivial.
now apply divide_mul_r. now rewrite add_comm.
Qed.

Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m.
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_add_diag_r".
intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r.
Qed.

Lemma gcd_sub_diag_r : forall n m, n<=m -> gcd n (m-n) == gcd n m.
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_sub_diag_r".
intros n m H. symmetry.
rewrite <- (sub_add n m H) at 1. apply gcd_add_diag_r.
Qed.

Definition Bezout n m p := exists a b, a*n == p + b*m.

Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout.
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.Bezout_wd".
unfold Bezout. intros x x' Hx y y' Hy z z' Hz.
setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz.
Qed.

Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1.
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.bezout_1_gcd".
intros n m (q & r & H).
apply gcd_unique; trivial using divide_1_l, le_0_1.
intros p Hn Hm.
apply divide_add_cancel_r with (r*m).
now apply divide_mul_r.
rewrite add_comm, <- H. now apply divide_mul_r.
Qed.

Lemma gcd_bezout_pos_pos : forall n, 0<n -> forall m, 0<m ->
Bezout n m (gcd n m) /\ Bezout m n (gcd n m).
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_bezout_pos_pos".
intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn.
pattern n. apply strong_right_induction with (z:=1); trivial.
unfold Bezout. solve_proper.
clear n Hn. intros n Hn IHn.
intros m Hm. rewrite <- le_succ_l, <- one_succ in Hm.
pattern m. apply strong_right_induction with (z:=1); trivial.
unfold Bezout. solve_proper.
clear m Hm. intros m Hm IHm.
destruct (lt_trichotomy n m) as [LT|[EQ|LT]].

destruct (IHm (m-n)) as ((a & b & EQ), (a' & b' & EQ')).
rewrite one_succ, le_succ_l.
apply lt_add_lt_sub_l; now nzsimpl.
apply sub_lt; order'.
split.
exists (a+b). exists b.
rewrite mul_add_distr_r, EQ, mul_sub_distr_l, <- add_assoc.
rewrite gcd_sub_diag_r by order.
rewrite sub_add. reflexivity. apply mul_le_mono_l; order.
exists a'. exists (a'+b').
rewrite gcd_sub_diag_r in EQ' by order.
rewrite (add_comm a'), mul_add_distr_r, add_assoc, <- EQ'.
rewrite mul_sub_distr_l, sub_add. reflexivity. apply mul_le_mono_l; order.

rewrite EQ. rewrite gcd_diag.
split.
exists 1. exists 0. now nzsimpl.
exists 1. exists 0. now nzsimpl.

rewrite gcd_comm, and_comm.
apply IHn; trivial.
now rewrite <- le_succ_l, <- one_succ.
Qed.

Lemma gcd_bezout_pos : forall n m, 0<n -> Bezout n m (gcd n m).
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_bezout_pos".
intros n m Hn.
destruct (eq_0_gt_0_cases m) as [EQ|LT].
rewrite EQ, gcd_0_r. exists 1. exists 0. now nzsimpl.
now apply gcd_bezout_pos_pos.
Qed.

Lemma gcd_bezout : forall n m,
Bezout n m (gcd n m) \/ Bezout m n (gcd n m).
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_bezout".
intros n m.
destruct (eq_0_gt_0_cases n) as [EQ|LT].
right. rewrite EQ, gcd_0_l. exists 1. exists 0. now nzsimpl.
left. now apply gcd_bezout_pos.
Qed.

Lemma gcd_mul_mono_l :
forall n m p, gcd (p * n) (p * m) == p * gcd n m.
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_mul_mono_l".
intros n m p.
apply gcd_unique'.
apply mul_divide_mono_l, gcd_divide_l.
apply mul_divide_mono_l, gcd_divide_r.
intros q H H'.
destruct (eq_0_gt_0_cases n) as [EQ|LT].
rewrite EQ in *. now rewrite gcd_0_l.
destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial.
apply divide_add_cancel_r with (p*m*b).
now apply divide_mul_l.
rewrite <- mul_assoc, <- mul_add_distr_l, add_comm, (mul_comm m), <- EQ.
rewrite (mul_comm a), mul_assoc.
now apply divide_mul_l.
Qed.

Lemma gcd_mul_mono_r :
forall n m p, gcd (n*p) (m*p) == gcd n m * p.
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gcd_mul_mono_r".
intros. rewrite !(mul_comm _ p). apply gcd_mul_mono_l.
Qed.

Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p).
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.gauss".
intros n m p H G.
destruct (eq_0_gt_0_cases n) as [EQ|LT].
rewrite EQ in *. rewrite gcd_0_l in G. now rewrite <- (mul_1_l p), <- G.
destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial.
rewrite G in EQ.
apply divide_add_cancel_r with (m*p*b).
now apply divide_mul_l.
rewrite (mul_comm _ b), mul_assoc. rewrite <- (mul_1_l p) at 2.
rewrite <- mul_add_distr_r, add_comm, <- EQ.
now apply divide_mul_l, divide_factor_r.
Qed.

Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) ->
exists q r, n == q*r /\ (q | m) /\ (r | p).
Proof. hammer_hook "NGcd" "NGcd.NGcdProp.divide_mul_split".
intros n m p Hn H.
assert (G := gcd_nonneg n m). le_elim G.
destruct (gcd_divide_l n m) as (q,Hq).
exists (gcd n m). exists q.
split. now rewrite mul_comm.
split. apply gcd_divide_r.
destruct (gcd_divide_r n m) as (r,Hr).
rewrite Hr in H. rewrite Hq in H at 1.
rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order].
apply gauss with r; trivial.
apply mul_cancel_r with (gcd n m); [order|].
rewrite mul_1_l.
rewrite <- gcd_mul_mono_r, <- Hq, <- Hr; order.
symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order.
Qed.

End NGcdProp.


(** * Utheory.v: Specification of [U], interval [ [0,1] ] *)

Add Rec LoadPath "." as ALEA.

Require Export Misc.
Require Export Ccpo.
Set Implicit Arguments.
Open Local Scope O_scope.

(** ** Basic operators of U *)
(**
    - Constants : [0] and [1]
    - Constructor : [ [1/1+] n ] $(\equiv \frac{1}{n+1})$ #(=1/(1+n))#
    - Operations : [x+y] (=min (x+y,1)), [x*y], [ [1-] x]
    - Relations : [x <= y], [x==y]
*)

Module Type Universe.
Parameter U : Type.
Generalizable All Variables.
Declare Instance ordU: ord U.
Declare Instance cpoU: cpo U.
Bind Scope U_scope with U.
Delimit Scope U_scope with U.

Parameters Uplus Umult Udiv: U -> U -> U.
Parameter Uinv : U -> U.
Parameter Unth : nat -> U.

Infix "+" := Uplus : U_scope.
Infix "*"  := Umult  : U_scope.
Infix "/"  := Udiv  : U_scope.
Notation "[1-]  x" := (Uinv x)  (at level 35, right associativity) : U_scope.

Notation "[1/]1+ n" := (Unth n) (at level 35, right associativity) : U_scope.
Open Local Scope U_scope.

Definition U1 : U := [1-] 0.
Notation "1" := U1 : U_scope.
Notation "0" := (@D0 U ordU cpoU) : U_scope.

(** ** Basic Properties *)

Hypothesis Udiff_0_1 : ~ 0 == 1.
(*
Hypothesis Unit : forall x:U, x <= 1.
*)

Hypothesis Uplus_sym : forall x y:U, x + y == y + x.
Hypothesis Uplus_assoc : forall x y z:U, x + (y + z) == x + y + z.
Hypothesis Uplus_zero_left : forall x:U, 0 + x == x.

Hypothesis Umult_sym : forall x y:U, x * y == y * x.
Hypothesis Umult_assoc : forall x y z:U, x * (y * z) == x * y * z.
Hypothesis Umult_one_left : forall x:U, 1 * x == x.

Hypothesis Uinv_one : [1-] 1 == 0.

(*
Hypothesis Uinv_opp_left : forall x, [1-] x + x == 1.
*)

Hypothesis Umult_div : forall x y, ~ 0 == y -> x <= y -> y * (x/y) == x.
Hypothesis Udiv_le_one : forall x y,  ~ 0 == y -> y <= x -> (x/y) == 1.
Hypothesis Udiv_by_zero : forall x y,  0 == y -> (x/y) == 0.

(** - Property  : [1 - (x + y) + x = 1 - y ] holds when [x+y] does not overflow *)
Hypothesis Uinv_plus_left : forall x y, y <= [1-] x -> [1-] (x + y) + x == [1-] y.

(** - Property  : [(x + y) * z  = x * z + y * z] holds when [x+y] does not overflow *)
Hypothesis Udistr_plus_right : forall x y z, x <= [1-] y -> (x + y) * z == x * z + y * z.

(** - Property  : [1 - (x  y) = (1 - x) * y + (1-y) ] *)
Hypothesis Udistr_inv_right : forall x y:U,  [1-] (x * y) == ([1-] x) * y + [1-] y.

(** - Totality of the order *)
Hypothesis Ule_class : forall x y : U, class (x <= y).

Hypothesis Ule_total : forall x y : U, orc (x <= y) (y <= x).
Implicit Arguments Ule_total [].

(** - The relation [x <=  y] is compatible with operators *)

Declare Instance Uplus_mon_right :forall x,monotonic (Uplus x).

(* Instance Uplus_mon_right : forall x, monotonic (Uplus x). *)

Declare Instance Umult_mon_right : forall x, monotonic (Umult x).
(* Instance Umult_mon_right : forall x, monotonic (Umult x). *)

Hypothesis Uinv_le_compat : forall x y:U, x <= y -> [1-] y <= [1-] x.

(** - Properties of simplification in case there is no overflow *)
Hypothesis Uplus_le_simpl_right : forall x y z, z <= [1-] x -> x + z <= y + z -> x <= y.

Hypothesis Umult_le_simpl_left : forall x y z: U, ~ 0 == z -> z * x <= z * y -> x <= y .

(** -  Property of [Unth]: [1 / n+1 == 1 - n  * (1/n+1)] *)
Hypothesis Unth_prop : forall n, [1/]1+n == [1-](compn Uplus 0 (fun k => [1/]1+n) n).

(** - Archimedian property *)
Hypothesis archimedian : forall x, ~0 == x -> exc (fun n => [1/]1+n <= x).

(** - Stability properties of lubs with respect to [+] and [*] *)

Hypothesis Uplus_right_continuous : forall k, continuous (mon (Uplus k)).
Hypothesis Umult_right_continuous : forall k, continuous (mon (Umult k)).

End Universe.

Declare Module Univ:Universe.
Export Univ.

Hint Resolve Udiff_0_1 Unth_prop.
Hint Resolve Uplus_sym Uplus_assoc Umult_sym Umult_assoc.
Hint Resolve Uinv_one  Uinv_plus_left Umult_div Udiv_le_one Udiv_by_zero.
Hint Resolve Uplus_zero_left Umult_one_left Udistr_plus_right Udistr_inv_right.
Hint Resolve Uplus_mon_right Umult_mon_right Uinv_le_compat.
Hint Resolve lub_le le_lub Uplus_right_continuous Umult_right_continuous.
(* lub_eq_mult lub_eq_plus_cte_left.*)
Hint Resolve Ule_total Ule_class.


(** * Decide: Programming with Decision Procedures *)

Set Warnings "-notation-overridden,-parsing".
From VFA Require Import Perm.

(* ################################################################# *)
(** * Using [reflect] to characterize decision procedures *)

(** Thus far in _Verified Functional Algorithms_ we have been using
   - propositions ([Prop]) such as [a<b] (which is Notation for [lt a b])
   - booleans ([bool]) such as [a<?b] (which is Notation for [ltb a b]). *)

Check Nat.lt.  (* : nat -> nat -> Prop *)
Check Nat.ltb.  (* : nat -> nat -> bool *)

(** The [Perm] chapter defined a tactic called [bdestruct] that
    does case analysis on (x <? y) while giving you hypotheses (above
    the line) of the form (x<y).   This tactic is built using the [reflect]
    type and the [blt_reflect] theorem. *)

Print reflect.
(* Inductive reflect (P : Prop) : bool -> Set :=
    | ReflectT : P -> reflect P true
    | ReflectF : ~ P -> reflect P false  *)

Check blt_reflect.  (* : forall x y, reflect (x<y) (x <? y) *)

(** The name [reflect] for this type is a reference to _computational
   reflection_,  a technique in logic.  One takes a logical formula, or
   proposition, or predicate,  and designs a syntactic embedding of
   this formula as an "object value" in the logic.  That is, _reflect_ the
   formula back into the logic. Then one can design computations
   expressible inside the logic that manipulate these syntactic object
   values.  Finally, one proves that the computations make transformations
   that are equivalent to derivations (or equivalences) in the logic.

   The first use of computational reflection was by Goedel, in 1931:
   his syntactic embedding encoded formulas as natural numbers, a
   "Goedel numbering."  The second and third uses of reflection were
   by Church and Turing, in 1936: they encoded (respectively)
   lambda-expressions and Turing machines.

   In Coq it is easy to do reflection, because the Calculus of Inductive
   Constructions (CiC) has Inductive data types that can easily encode
   syntax trees.  We could, for example, take some of our propositional
   operators such as [and], [or], and make an [Inductive] type that is an
   encoding of these, and build a computational reasoning system for
   boolean satisfiability.

   But in this chapter I will show something much simpler.  When
   reasoning about less-than comparisons on natural numbers, we have
   the advantage that [nat] already an inductive type; it is "pre-reflected,"
   in some sense.  (The same for [Z], [list], [bool], etc.)  *)

(** Now, let's examine how [reflect] expresses the coherence between
  [lt] and [ltb]. Suppose we have a value [v] whose type is
  [reflect (3<7) (3<?7)].  What is [v]?  Either it is
  - ReflectT [P] (3<?7), where [P] is a proof of [3<7],  and [3<?7] is [true], or
  - ReflectF [Q] (3<?7), where [Q] is a proof of [~(3<7)], and [3<?7] is [false].
  In the case of [3,7], we are well advised to use [ReflectT], because
   (3<?7) cannot match the [false] required by [ReflectF]. *)

Goal (3<?7 = true). Proof. reflexivity. Qed.

(** So [v] cannot be [ReflectF Q (3<?7)] for any [Q], because that would
   not type-check.  Now, the next question:  must there exist a value
   of type [reflect (3<7) (3<?7)]  ?  The answer is yes; that is the
   [blt_reflect] theorem.  The result of [Check blt_reflect], above, says that
   for any [x,y], there does exist a value (blt_reflect x y) whose type
   is exactly [reflect (x<y)(x<?y)].     So let's look at that value!  That is,
   examine what [H], and [P], and [Q] are equal to at "Case 1" and "Case 2": *)

Theorem three_less_seven_1: 3<7.
Proof.
assert (H := blt_reflect 3 7).
remember (3<?7) as b.
destruct H as [P|Q] eqn:?.
* (* Case 1: H = ReflectT (3<7) P *)
apply P.
* (* Case 2: H = ReflectF (3<7) Q *)
compute in Heqb.
inversion Heqb.
Qed.

(** Here is another proof that uses [inversion] instead of [destruct].
   The [ReflectF] case is eliminated automatically by [inversion]
   because [3<?7] does not match [false]. *)

Theorem three_less_seven_2: 3<7.
Proof.
assert (H := blt_reflect 3 7).
inversion H as [P|Q].
apply P.
Qed.

(** The [reflect] inductive data type is a way of relating a _decision
   procedure_ (a function from X to [bool]) with a predicate (a function
   from X to [Prop]).   The convenience of [reflect], in the verification
   of functional programs, is that we can do [destruct (blt_reflect a b)],
   which relates [a<?b] (in the program) to the [a<b] (in the proof).
   That's just how the [bdestruct] tactic works; you can go back
   to [Perm.v] and examine how it is implemented in the [Ltac]
   tactic-definition language. *)

(* ################################################################# *)
(** * Using [sumbool] to Characterize Decision Procedures *)

Module ScratchPad.

(** An alternate way to characterize decision procedures,
   widely used in Coq, is via the inductive type [sumbool].

   Suppose [Q]  is a proposition, that is, [Q: Prop].  We say [Q] is
   _decidable_ if there is an algorithm for computing a proof of
   [Q] or [~Q].  More generally, when [P] is a predicate (a function
   from some type [T] to [Prop]), we say [P] is decidable when
   [forall x:T, decidable(P)].

   We represent this concept in Coq by an inductive datatype: *)

Inductive sumbool (A B : Prop) : Set :=
 | left : A -> sumbool A B
 | right : B -> sumbool A B.

(** Let's consider [sumbool] applied to two propositions: *)

Definition t1 := sumbool (3<7) (3>2).
Lemma less37: 3<7. Proof. omega. Qed.
Lemma greater23: 3>2. Proof. omega. Qed.

Definition v1a: t1 := left (3<7) (3>2) less37.
Definition v1b: t1 := right (3<7) (3>2) greater23.

(** A value of type [sumbool (3<7) (3>2)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (3>2).   *)

(** Now let's consider: *)

Definition t2 := sumbool (3<7) (2>3).
Definition v2a: t2 := left (3<7) (2>3) less37.

(** A value of type [sumbool (3<7) (2>3)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (2>3).
  But since there are no proofs of 2>3, only [left] values (such as [v2a])
  exist.  That's OK. *)

(** [sumbool] is in the Coq standard library, where there is [Notation]
   for it:  the expression [ {A}+{B} ] means [sumbool A B]. *)

Notation "{ A } + { B }" := (sumbool A B) : type_scope.

(** A very common use of [sumbool] is on a proposition and its negation.
   For example, *)

Definition t4 := forall a b, {a<b}+{~(a<b)}.

(** That expression, [forall a b, {a<b}+{~(a<b)}], says that for any
 natural numbers [a] and [b], either [a<b] or [a>=b].  But it is _more_
 than that!  Because [sumbool] is an Inductive type with two constructors
 [left] and [right], then given the [{3<7}+{~(3<7)}] you can pattern-match
 on it and learn _constructively_ which thing is true.  *)

Definition v3: {3<7}+{~(3<7)} := left _ _ less37.

Definition is_3_less_7:  bool :=
 match v3 with
 | left _ _ _ => true
 | right _ _ _ => false
 end.

Eval compute in is_3_less_7. (* = true : bool *)

Print t4.  (* = forall a b : nat, {a < b} + {~ a < b} *)

(** Suppose there existed a value [lt_dec] of type [t4].  That would be a
  _decision procedure_ for the less-than function on natural numbers.
  For any nats [a] and [b], you could calculate [lt_dec a b], which would
  be either [left ...] (if [a<b] was provable) or [right ...] (if [~(a<b)] was
  provable).

  Let's go ahead and implement [lt_dec].  We can base it on the function
  [ltb: nat -> nat -> bool] which calculates whether [a] is less than [b],
  as a boolean.  We already have a theorem that this function on booleans
  is related to the proposition [a<b]; that theorem is called [blt_reflect]. *)

Check blt_reflect.  (* : forall x y, reflect (x<y) (x<?y) *)

(** It's not too hard to use [blt_reflect] to define [lt_dec] *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match blt_reflect a b with
| ReflectT _ P => left (a < b) (~ a < b) P
| ReflectF _ Q => right (a < b) (~ a < b) Q
end.

(** Another, equivalent way to define [lt_dec] is to use
     definition-by-tactic: *)

Definition lt_dec' (a: nat) (b: nat) : {a<b}+{~(a<b)}.
  destruct (blt_reflect a b) as [P|Q]. left. apply P.  right. apply Q.
Defined.

Print lt_dec.
Print lt_dec'.

Theorem lt_dec_equivalent: forall a b, lt_dec a b = lt_dec' a b.
Proof.
intros.
unfold lt_dec, lt_dec'.
reflexivity.
Qed.

(** Warning: these definitions of [lt_dec] are not as nice as the
  definition in the Coq standard library, because these are not
  fully computable.  See the discussion below. *)

End ScratchPad.

(* ================================================================= *)
(** ** [sumbool] in the Coq Standard Library *)

Module ScratchPad2.
Locate sumbool. (* Coq.Init.Specif.sumbool *)
Print sumbool.

(** The output of [Print sumbool] explains that the first two arguments
   of [left] and [right] are implicit.  We use them as follows (notice that
   [left] has only one explicit argument [P]:  *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match blt_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

Definition le_dec (a: nat) (b: nat) : {a<=b}+{~(a<=b)} :=
match ble_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

(** Now, let's use [le_dec] directly in the implementation of insertion
   sort, without mentioning [ltb] at all. *)

Fixpoint insert (x:nat) (l: list nat) :=
  match l with
  | nil => x::nil
  | h::t => if le_dec x h then x::h::t else h :: insert x t
 end.

Fixpoint sort (l: list nat) : list nat :=
  match l with
  | nil => nil
  | h::t => insert h (sort t)
end.

Inductive sorted: list nat -> Prop :=
| sorted_nil:
    sorted nil
| sorted_1: forall x,
    sorted (x::nil)
| sorted_cons: forall x y l,
   x <= y -> sorted (y::l) -> sorted (x::y::l).

(** **** Exercise: 2 stars (insert_sorted_le_dec)  *)
Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
  intros a l H.
  induction H.
  - constructor.
  - unfold insert.
    destruct (le_dec a x) as [ Hle | Hgt].

   (** Look at the proof state now.  In the first subgoal, we have
      above the line, [Hle: a <= x].  In the second subgoal, we have
      [Hgt: ~ (a < x)].  These are put there automatically by the
      [destruct (le_dec a x)].  Now, the rest of the proof can proceed
      as it did in [Sort.v], but using [destruct (le_dec _ _)] instead of
      [bdestruct (_ <=? _)]. *)

(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Decidability and Computability *)

(** Before studying the rest of this chapter, it is helpful to study the
   [ProofObjects] chapter of _Software Foundations volume 1_ if you
   have not done so already.

   A predicate [P: T->Prop] is _decidable_ if there is a computable
   function [f: T->bool] such that, forall [x:T], [f x = true <-> P x].
   The second and most famous example of an _undecidable_ predicate
   is the Halting Problem (Turing, 1936): [T] is the type of Turing-machine
   descriptions, and [P(x)] is, Turing machine [x] halts.  The first, and not
   as famous, example is due to Church, 1936 (six months earlier): test
   whether a lambda-expression has a normal form.  In 1936-37, as a
   first-year PhD student before beginning his PhD thesis work, Turing
   proved these two problems are equivalent.

   Classical logic contains the axiom [forall P, P \/ ~P].  This is not provable
   in core Coq, that is, in the bare Calculus of Inductive Constructions.  But
   its negation is not provable either.   You could add this axiom to Coq
   and the system would still be consistent (i.e., no way to prove [False]).

   But [P \/ ~P] is a weaker statement than [ {P}+{~P} ], that is,
   [sumbool P (~P)].  From [ {P}+{~P} ] you can actually _calculate_ or
   [compute] either [left (x:P)] or [right(y: ~P)].     From [P \/ ~P] you cannot
   [compute] whether [P] is true.  Yes, you can [destruct] it in a proof,
   but not in a calculation.

   For most purposes its unnecessary to add the axiom [P \/ ~P] to Coq,
   because for specific predicates there's a specific way to prove [P \/ ~P]
   as a theorem.  For example,  less-than on natural numbers is decidable,
   and the existence of [blt_reflect] or [lt_dec] (as a theorem, not as an axiom)
   is a demonstration of that.

   Furthermore, in this "book" we are interested in _algorithms_.  An axiom
   [P \/ ~P] does not give us an algorithm to compute whether P is true.  As
   you saw in the definition of [insert] above, we can use [lt_dec] not only as
   a theorem that either [3<7] or [~(3<7)], we can use it as a function to
   compute whether [3<7].  In Coq, you can't compute with axioms!
   Let's try it: *)

Axiom lt_dec_axiom_1:  forall i j: nat, i<j \/ ~(i<j).

(** Now, can we use this axiom to compute with?  *)

(* Uncomment and try this:
Definition max (i j: nat) : nat :=
   if lt_dec_axiom_1 i j then j else i.
*)

(** That doesn't work, because an [if] statement requires an [Inductive]
  data type with exactly two constructors; but [lt_dec_axiom_1 i j] has
  type [i<j \/ ~(i<j)],  which is not Inductive.  But let's try a different axiom: *)

Axiom lt_dec_axiom_2:  forall i j: nat, {i<j} + {~(i<j)}.

Definition max_with_axiom (i j: nat) : nat :=
   if lt_dec_axiom_2 i j then j else i.

(** This typechecks, because [lt_dec_axiom_2 i j]  belongs to type
     [sumbool (i<j) (~(i<j))]   (also written [ {i<j} + {~(i<j)} ]), which does have
     two constructors.

     Now, let's use this function: *)

Eval compute in max_with_axiom 3 7.
  (*  = if lt_dec_axiom_2 3 7 then 7 else 3
     : nat *)

(** This [compute] didn't compute very much!  Let's try to evaluate it
    using [unfold]: *)

Lemma prove_with_max_axiom:   max_with_axiom 3 7 = 7.
Proof.
unfold max_with_axiom.
try reflexivity.  (* does not do anything, reflexivity fails *)
(* uncomment this line and try it:
   unfold lt_dec_axiom_2.
*)
destruct (lt_dec_axiom_2 3 7).
reflexivity.
contradiction n. omega.
Qed.

(** It is dangerous to add Axioms to Coq: if you add one that's inconsistent,
   then it leads to the ability to prove [False].  While that's a convenient way
   to get a lot of things proved, it's unsound; the proofs are useless.

   The Axioms above, [lt_dec_axiom_1] and [lt_dec_axiom_2], are safe enough:
   they are consistent.  But they don't help in computation.  Axioms are not
   useful here. *)

End ScratchPad2.

(* ################################################################# *)
(** * Opacity of [Qed] *)

(** This lemma [prove_with_max_axiom] turned out to be _provable_, but the proof
    could not go by _computation_.  In contrast, let's use [lt_dec], which was built
    without any axioms: *)

Lemma compute_with_lt_dec:  (if ScratchPad2.lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
(* uncomment this line and try it:
   unfold blt_reflect.
*)
Abort.

(** Unfortunately, even though [blt_reflect] was proved without any axioms, it
    is an _opaque theorem_  (proved with [Qed] instead of with [Defined]), and
    one cannot compute with opaque theorems.  Not only that, but it is proved with
    other opaque theorems such as [iff_sym] and [Nat.ltb_lt].  If we want to
    compute with an implementation of [lt_dec] built from [blt_reflect], then
    we will have to rebuild [blt_reflect] without using [Qed] anywhere, only [Defined].

    Instead, let's use the version of [lt_dec] from the Coq standard library,
    which _is_ carefully built without any opaque ([Qed]) theorems.
*)

Lemma compute_with_StdLib_lt_dec:  (if lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
reflexivity.
Qed.

(** The Coq standard library has many decidability theorems.  You can
   examine them by doing the following [Search] command. The results
   shown here are only for the subset of the library that's currently
   imported (by the [Import] commands above); there's even more out there. *)

Search ({_}+{~_}).
(*
reflect_dec: forall (P : Prop) (b : bool), reflect P b -> {P} + {~ P}
lt_dec: forall n m : nat, {n < m} + {~ n < m}
list_eq_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall l l' : list A, {l = l'} + {l <> l'}
le_dec: forall n m : nat, {n <= m} + {~ n <= m}
in_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall (a : A) (l : list A), {In a l} + {~ In a l}
gt_dec: forall n m : nat, {n > m} + {~ n > m}
ge_dec: forall n m : nat, {n >= m} + {~ n >= m}
eq_nat_decide: forall n m : nat, {eq_nat n m} + {~ eq_nat n m}
eq_nat_dec: forall n m : nat, {n = m} + {n <> m}
bool_dec: forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}
Zodd_dec: forall n : Z, {Zodd n} + {~ Zodd n}
Zeven_dec: forall n : Z, {Zeven n} + {~ Zeven n}
Z_zerop: forall x : Z, {x = 0%Z} + {x <> 0%Z}
Z_lt_dec: forall x y : Z, {(x < y)%Z} + {~ (x < y)%Z}
Z_le_dec: forall x y : Z, {(x <= y)%Z} + {~ (x <= y)%Z}
Z_gt_dec: forall x y : Z, {(x > y)%Z} + {~ (x > y)%Z}
Z_ge_dec: forall x y : Z, {(x >= y)%Z} + {~ (x >= y)%Z}
*)

(** The type of [list_eq_dec] is worth looking at.  It says that if you
     have  a decidable equality for an element type [A], then
    [list_eq_dec] calculates for you a decidable equality for type [list A].
    Try it out: *)

Definition list_nat_eq_dec:
    (forall al bl : list nat, {al=bl}+{al<>bl}) :=
  list_eq_dec eq_nat_dec.

Eval compute in if list_nat_eq_dec [1;3;4] [1;4;3] then true else false.
 (* = false : bool *)

Eval compute in if list_nat_eq_dec [1;3;4] [1;3;4] then true else false.
 (* = true : bool *)

(** **** Exercise: 2 stars (list_nat_in)  *)
(** Use [in_dec] to build this function. *)

Definition list_nat_in: forall (i: nat) (al: list nat), {In i al}+{~ In i al}
 (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example in_4_pi:  (if list_nat_in 4  [3;1;4;1;5;9;2;6] then true else false) = true.
Proof.
simpl.
(* reflexivity. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** In general, beyond [list_eq_dec] and [in_dec], one can construct a
     whole programmable calculus of decidability, using the
     programs-as-proof  language of Coq.  But is it a good idea?  Read on! *)

(* ################################################################# *)
(** * Advantages and Disadvantages of [reflect] Versus [sumbool] *)

(** I have shown two ways to program decision procedures in Coq,
    one using [reflect] and the other using [{_}+{~_}], i.e., [sumbool].

   - With [sumbool], you define _two_ things: the operator in [Prop]
      such as [lt: nat -> nat -> Prop] and the decidability "theorem"
      in [sumbool], such as [lt_dec: forall i j, {lt i j}+{~ lt i j}].  I say
      "theorem" in quotes because it's not _just_ a theorem, it's also
      a (nonopaque) computable function.

   - With [reflect], you define _three_ things:  the operator in [Prop],
      the operator in [bool] (such as [ltb: nat -> nat -> bool], and the
      theorem that relates them (such as [ltb_reflect]).

   Defining three things seems like more work than defining two.
   But it may be easier and more efficient.  Programming in [bool],
   you may have more control over how your functions are implemented,
   you will have fewer difficult uses of dependent types, and you
   will run into fewer difficulties with opaque theorems.

   However, among Coq programmers, [sumbool] seems to be more
   widely used, and it seems to have better support in the Coq standard
   library.  So you may encounter it, and it is worth understanding what
   it does.   Either of these two methods is a reasonable way of programming
   with proof.  *)


(** 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 := mult lf2 x.


Require Import OrderedType.
Require Import Arith.

Module NatOrder <: OrderedType.
  Definition t := nat.

  (*
  Definition eq (A:Type) := eq A.
  Definition lt := lt.
  *)

  Definition eq_refl : forall x : t, x = x.
  Proof.
    auto.
  Defined.

  Definition eq_sym : forall x y : t, eq x y -> eq y x.
  Proof.
    auto.
  Defined.

  Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof.
    congruence.
  Defined.

  Require Import Omega.
  Definition lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros ; omega.
  Defined.

  Definition lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    intros ; omega.
  Defined.

  Definition eq := eq (A:=nat).
  Definition lt := lt.
  Hint Unfold eq.
  Hint Unfold lt.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros. case (lt_eq_lt_dec x y) ; firstorder.
  Defined.

End NatOrder.


Require Import Coq.micromega.Lia.
Require Import Coq.NArith.NArith.

Module N.
  Lemma testbit_ones n i : N.testbit (N.ones n) i = N.ltb i n.
  Proof using Type.
    pose proof N.ones_spec_iff n i.
    destruct (N.testbit _ _) eqn:? in*; destruct (N.ltb_spec i n); trivial.
    { pose proof (proj1 H eq_refl); lia. }
    { pose proof (proj2 H H0). inversion H1. }
  Qed.

  Lemma ones_min m n : N.ones (N.min m n) = N.land (N.ones m) (N.ones n).
  Proof using Type.
    eapply N.bits_inj_iff; intro i.
    rewrite N.land_spec.
    rewrite !N.testbit_ones.
    destruct (N.ltb_spec0 i (N.min m n));
      destruct (N.ltb_spec0 i m);
      destruct (N.ltb_spec0 i n);
      try reflexivity;
      lia.
  Qed.
End N.


(** 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) (y : natural) (x : natural) (lf1 : natural)
  : natural := mult x lf2.


(*|
#############################
Proof by contradiction in Coq
#############################

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

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

I am trying to understand the apparent paradox of the logical
framework of theorem provers like Coq not including LEM yet also being
able to construct proofs by contradiction. Specifically the
intuitionistic type theory that these theorem provers are based on
does not allow for any logical construction of the form ``￢(￢P)⇒P``,
and so what is required in order to artificially construct this in a
language like Coq? And how is the constructive character of the system
preserved if this is allowed?
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

I think you are mixing up two related uses of contradiction in logic.
One is the technique of *proof by contradiction*, which says that you
can prove ``P`` by proving ``~ (~ P)`` -- that is, by showing that ``~
P`` entails a contradiction. This technique is actually *not*
available in general in constructive logics like Coq, unless one of
the following applies.

1. You add the excluded middle ``forall P, P \/ ~ P`` as an axiom. Coq
   supports this, but this addition means that you are not working in
   a constructive logic anymore.
2. The proposition ``P`` is known to be decidable (i.e., ``P \/ ~ P``
   holds). This is the case, for example, for the equality of two
   natural numbers ``n`` and ``m``, which we can prove by induction.
3. The proposition ``P`` is of the form ``~ Q``. Since ``Q -> ~ (~
   Q)`` holds constructively, by the law of contrapositives (which is
   also valid constructively), we obtain ``~ (~ (~ Q)) -> (~ Q)``.

The other use of contradiction is the `principle of explosion
<https://en.wikipedia.org/wiki/Principle_of_explosion>`__, which says
that anything follows once you assume a contradiction (i.e., ``False``
in Coq). Unlike proof by contradiction, the principle of explosion is
*always* valid in constructive logic, so there is no paradox here.
|*)

(*|
Answer (L. Garde)
*****************

In constructive logic, by definition, a contradiction is an inhabitant
of the empty type ``0``, and, also by definition, the negation ``￢P``
of a proposition ``P`` is a function of type: ``P -> 0`` that gives an
inhabitant of the empty type ``0`` from an inhabitant (a proof) of
``P``.

If you assume an inhabitant (proof) of ``P``, and derive
constructively an inhabitant of ``0``, you have defined a function
inhabiting the type ``P -> 0``, i.e. a proof of ``￢P``. This is a
constructive sort of proof by contradiction: assume ``P``, derive a
contradiction, conclude ``￢P``.

Now if you assume ``￢P`` and derive a contradiction, you have a
constructive proof of ``￢￢P``, but cannot conclude constructively
that you have a proof of ``P``: for this you need the LEM axiom.
|*)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.

(** Monoids are categories. *)
Record Monoid : Type :=
{
  Mon_car : Type;

  Mon_op : Mon_car → Mon_car → Mon_car;

  Mon_assoc : ∀ a b c, Mon_op a (Mon_op b c) = Mon_op (Mon_op a b) c;

  Mon_unit : Mon_car;

  Mon_unit_left : ∀ a, Mon_op Mon_unit a = a;

  Mon_unit_right : ∀ a, Mon_op a Mon_unit = a
}.

Section Monoid_Cat.
  Context (M : Monoid).

  Hint Resolve Mon_unit_left Mon_unit_right Mon_assoc : core.

  Program Definition Monoid_Cat : Category :=
    {|
      Obj := unit;
      Hom := fun _ _ => Mon_car M;
      compose := fun _ _ _ => Mon_op M;
      id := fun a => Mon_unit M
    |}.

End Monoid_Cat.


From Coq Require Import PeanoNat Lia.

Theorem a_pow_4_sub_b_pow_4 : forall a b,
  a ^ 4 - b ^ 4 = (a - b) * (a + b) * (a ^ 2 + b ^ 2).
Proof.
  intros.
  assert (a <= b \/ a > b) by lia.
  destruct H.
  rewrite <- Nat.sub_0_le in H.
  enough (a ^ 4 - b ^ 4 = 0) by lia.
  rewrite Nat.sub_0_le in H.
  assert (a ^ 4 <= b ^ 4).
  simpl.
  enough (a * a <= b * b) by nia.
  nia.
  rewrite Nat.sub_0_le.
  exact H0.
  assert ((a - b) * (a + b) = a * a - b * b) by nia.
  rewrite H0.
  simpl.
  nia.
Qed.


Require Import pra.QuoteTerm.

(* Primality of natural numbers *)
Definition divides (n m : nat) : Prop := exists k : nat, k <= m /\ k * n = m.

Definition prime (n : nat) : Prop :=
  n > 1 /\ (forall d : nat, d <= n -> divides d n -> (d = 1 \/ d = n)).

Theorem prime_test: prime 61.
Proof.
  unfold prime. unfold divides. Time PRA.
Qed.

Theorem prime_test2: ~(prime 60).
Proof.
  unfold prime. unfold divides. Time PRA.
Qed.

Theorem prime_test3: ~(prime 100).
Proof.
  unfold prime. unfold divides. Time PRA.
Qed.

Theorem prime_test4: prime 101.
Proof.
  unfold prime. unfold divides. Time PRA.
Qed.

(* Primality of integers with ZArith *)
Definition zdivides (n m : Z) : Prop :=
  exists k : Z, ((k > 0)%Z /\ (k <= m)%Z) /\ (k * n)%Z = m.

Definition zprime (n : Z) : Prop :=
  (n > 1)%Z /\ (forall d : Z,
  (d > 0)%Z /\ (d <= n)%Z -> zdivides d n -> (d = 1%Z \/ d = n)).

Theorem zprime_test: zprime 61.
Proof.
  unfold zprime. unfold zdivides. Time PRA.
Qed.

Theorem zprime_test2: ~(zprime 60).
Proof.
  unfold zprime. unfold zdivides. Time PRA.
Qed.


Require Import Arith.

Axiom todo : forall {A}, A.

(* Tactics needed:
   [intros], [destruct], [induction], [exists], [apply],
   [rewrite], [assumption], [contradiction] *)

(* The proof of easy_implication consists in breaking the pair of data
   stored in hypothesis {n : nat | P n = true} and to
   instantaeoulsy rebuild a new pair, with the same components,
   in a different 'container', which lands in sort Prop. *)
Lemma easy_implication (P : nat -> bool) :
{n : nat | P n = true} -> exists n, P n = true.
Proof.
  intros [n Pn]. exists n. assumption.
Qed.

(* However the same operation does not work in the opposite
  direction, because of restricted elimination rules. *)
Lemma harder_implication (P : nat -> bool) :
  (exists n, P n = true) -> {n : nat | P n = true}.
Proof.
  intros H. Fail destruct H.
Abort.

Section Markov.

(* This is what we call a boolean predicate on natural numbers. A
    witness for P is an (x : nat) for which P x = true. *)

Variable (P : nat -> bool).

(* We should not formalize the existence of a witness for P as:
   Variable (x : nat).
   Hypothesis Px : P x = true.

   This is indeed a stronger statement than the exP hypothesis
   that we use below, since it readily breaks the pair which seemed
   difficult to break in script harder above... *)

Hypothesis exP : exists n, P n = true.

(* The purpose of this exercise is to show that it is still possible
   to forge a proof term which takes benefit from exP in order to
   build an instance of the Type-sorted pair, without hitting
   the restricted elimination barrier.*)

(* The computational content of a statement asserting the
   existence of an (x : nat) such that P x = true is a search
   algorithm which terminates with outputting a natural number
   for which P x = true.*)

(* The harder statement states that from a 'non computational'
   proof (in sort Prop), possibly using a computational axiom,
   we can deduce a computational proof  (a search algorithm) that
   eventually terminates and produces a concrete and correct
   natural number. This algorithm will be the naive search
   trying natural numbers one after the other starting from 0
   and exP the justification that it terminates. We need
   to turn exP into a data we can compute on by recursion. *)

(* The structure of a proof term of the proposition
   (acc_nat i) measures the distance from i to a witness for P.
   By distance we mean the distance between i and a greater or equal
   number at which P holds. *)

(* Note that this a simplified version of the instance of the
   Acc accessiblity predicate that could also be used for
   the purpose of this proof. *)

(* Note that in the AccNatS constructor, we see how
   values of the parameters can be modified in the arguments of
   constructors, while being imposed in their conclusion:
   we use an (acc_nat (S i)) to build a term in (acc_nat i). *)

Inductive acc_nat (i : nat) : Prop :=
  |AccNat0 : P i = true -> acc_nat i
  |AccNatS : acc_nat (S i) -> acc_nat i.

(* The following lemma describes formally the informal intuition
   described above.  *)
(* uses plus_Snm_nSm *)
Lemma acc_nat_plus :  forall x n : nat, P (x + n) = true -> acc_nat n.
Proof.
   intros.
	induction x as [|x' Hx'] in n,H |-*.
	apply AccNat0.
	apply H.
	apply AccNatS.
	apply Hx'.
	rewrite <- plus_Snm_nSm.
	apply H.
Qed.

(* In particular we can use exP to show that acc_nat holds at
   0, since we carefully put the acc_nat predicate in Prop. *)
(* uses plus_0_r *)
Lemma acc_nat0 : acc_nat 0.
Proof.
   destruct exP .
   apply (acc_nat_plus x).
   rewrite plus_0_r.
   apply H.
Qed.

(* Now the main step of the proof : if acc_nat holds for an (n : nat),
   we can compute a value for which P holds. We compute
   by induction on the proof of (acc_nat n). *)
Lemma find_ex : forall n : nat, acc_nat n -> {m | P m = true}.
Proof.
fix find_ex 2.
Show Proof.
(* we could be tempted to cheat using the seamingly correct
   correct:

   exact find_ex.
   Qed.

   but Coq complains because the proof term we just built is
   a non-terminating recursive function, of the form:
      fix f n := f n
   which cannot be accepted without risking consistency troubles... *)
   intros n accn.

   case (Bool.bool_dec (P n) true); intros Heq.
   exists n. assumption.
   apply (find_ex (S n)).
   destruct accn.
   - contradiction.
   - apply accn.
Qed.

(* We are done: *)
Theorem Markov : {m | P m = true}.
Proof.

apply todo.
Qed.

End Markov.

(* Here is the complete statement we prouved, as available outside
   of the section. *)
Check Markov.


(** ** Section
他の tactic の説明の前に、Section というコマンドを紹介しましょう。
Section というのはセクションを作ります。
Foo というセクションを作るには Section Foo. でセクションを始めて、
End Foo. でセクションを終ります。
セクションの中では共通する仮定を宣言することができ、
その仮定に依存した証明は、セクションを終ると、仮定を引数として受け取るように変形されます。
*)

Section SectionExplanation.

Variable P : Prop.
(**
Variable コマンドにより、P が Prop である、つまり何らかの命題Pが存在することが宣言されます。
*)

Lemma LemmaPP': P -> P.
Proof. auto. Qed.
(**
何らかの命題 P が存在することを前提を用いて、
P が成り立つならば P が成り立つことを証明し、その証明に LemmaPP' という名前をつけます。
*)

Print LemmaPP'.
(**
<<
LemmaPP' = fun H : P => H
     : P -> P
>>
証明が終った後、セクションを終る前に、
Print LemmaPP' とすると、上のように表示されます。
つまり、LemmaPP' は P型の値Hを受け取ってHを返す関数です。
*)

End SectionExplanation.

Print LemmaPP'.
(**
<<
LemmaPP' = fun (P : Prop) (H : P) => H
     : forall P : Prop, P -> P
>>
セクションを終ってから再度 Print LemmaPP' とすると、上のように異なる表示になります。
ここでは、命題Pを受け取り、P型の値Hを受け取り、Hを返す関数となっています。
つまり、セクションの中での LemmaPP' の値の外側に、Pを受け取る関数抽象が追加されています。
*)


(** * Merge:  Merge Sort, With Specification and Proof of Correctness*)

From VFA Require Import Perm.
From VFA Require Import Sort.
From Coq Require Import Recdef.  (* needed for [Function] feature *)

(** Mergesort is a well-known sorting algorithm, normally presented
    as an imperative algorithm on arrays, that has worst-case
    O(n log n) execution time and requires O(n) auxiliary space.

    The basic idea is simple: we divide the data to be sorted into two
    halves, recursively sort each of them, and then
    merge together the (sorted) results from each half:

    [[
    mergesort xs =
      split xs into ys,zs;
      ys' = mergesort ys;
      zs' = mergesort zs;
      return (merge ys' zs')
    ]]

    (As usual, if you are unfamiliar with mergesort see Wikipedia or
    your favorite algorithms textbook.)

    Mergesort on lists works essentially the same way: we split the
    original list into two halves, recursively sort each sublist,
    and then merge the two sublists together again.  The only
    difference, compared to the imperative algorithm, is that splitting
    the list takes O(n) rather than O(1) time; however, that
    does not affect the asymptotic cost, since the merge step already
    takes O(n) anyhow.
*)

(* ================================================================= *)
(** ** Split and its properties *)

(** Let us try to write down the Gallina code for mergesort.
    The first step is to write a splitting function. There are
    several ways to do this, since the exact splitting method does
    not matter as long as the results are (roughly) equal in size.
    For example, if we know the length of the list, we could use that to split
    at the half-way point. But here is an attractive alternative, which simply
    alternates assigning the elements into left and right sublists:
*)

Fixpoint split {X:Type} (l:list X) : (list X * list X) :=
  match l with
  | [] => ([],[])
  | [x] => ([x],[])
  | x1::x2::l' =>
    let (l1,l2) := split l' in
    (x1::l1,x2::l2)
  end.

(** Note: For generality, we made this function polymorphic, since the
    type of the values in the list is irrelevant to the splitting process.

    While this function is straightforward to define, it can be a bit challenging
    to work with.  Let's try to prove the following lemma, which is obviously true:
*)

Lemma split_len_first_try: forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  induction l; intros.
  - inv H. simpl. omega.
  - destruct l as [| x l'].
    + inv H.
      split; simpl; auto.
    + inv H. destruct (split l') as [l1' l2'] eqn:E. inv H1.
      (* We're stuck! The IH talks about [split (x::l')] but we
         only know aobut [split (a::x::l'). *)
Abort.

(** The problem here is that the standard induction principle for lists
    requires us to show that the property being proved follows for
    any non-empty list if it holds for the tail of that list.
    What we want here is a "two-step" induction principle, that instead requires
    us to show that the property being proved follows for a list of
    length at least two, if it holds for the tail of the tail of that list.
    Formally:
*)

Definition list_ind2_principle:=
    forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a:A), P [a]) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l.

(** If we assume the correctness of this "non-standard" induction principle,
    our [split_len] proof is easy, using a form of the [induction] tactic
    that lets us specify the induction principle to use:
*)

Lemma split_len': list_ind2_principle ->
    forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  unfold list_ind2_principle; intro IP.
  induction l using IP; intros.
  - inv H. omega.
  - inv H. simpl; omega.
  - inv H. destruct (split l) as [l1' l2']. inv H1.
    simpl.
    destruct (IHl l1' l2') as [P1 P2]; auto; omega.
Qed.

(** We still need to prove [list_ind2_principle].  There are several
    ways to do this, but one direct way is to write an explicit proof
    term, thus: *)

Definition list_ind2 :
  forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a:A), P [a]) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l :=
  fun (A : Type)
      (P : list A -> Prop)
      (H : P [])
      (H0 : forall a : A, P [a])
      (H1 : forall (a b : A) (l : list A), P l -> P (a :: b :: l))  =>
    fix IH (l : list A) :  P l :=
    match l with
    | [] => H
    | [x] => H0 x
    | x::y::l' => H1 x y l' (IH l')
    end.

(** Here, the [fix] keyword defines a local recursive function [IH]
    of type [forall l:list A, P l], which is returned as the overall value of
    [list_ind2]. As usual, this function must be obviously terminating
    to Coq (which it is because the recursive call is on a sublist [l']
    of the original argument [l]) and the [match] must be exhaustive over
    all possible lists (which it evidently is).
*)

(** With our induction principle in hand, we can finally prove
    [split_len] free and clear:
*)

Lemma split_len: forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
 apply (@split_len' list_ind2).
Qed.

(** **** Exercise: 3 stars, standard (split_perm)  *)

(** Here's another fact about [split] that we will find useful later on.
*)

Lemma split_perm : forall {X:Type} (l l1 l2: list X),
    split l = (l1,l2) -> Permutation l (l1 ++ l2).
Proof.
  induction l as [| x | x1 x2 l1' IHl'] using list_ind2; intros.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Defining Merge *)

(** Next, we need a [merge] function, which takes two
    sorted lists (of naturals) and returns their sorted result.
    This would seem easy to write:

    [[
    Fixpoint merge l1 l2 :=
      match l1, l2 with
      | [], _ => l2
      | _, [] => l1
      | a1::l1', a2::l2' =>
          if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge l1 l2'
      end.
    ]]

    But Coq will reject this definition with the message:

    [[
    Error: Cannot guess decreasing argument of fix.
    ]]

    Coq insists the every [Fixpoint] definition be structurally recursive
    on some specified argument, meaning that at each recursive call the
    callee is passed a value that is a sub-term of the caller's argument value.
    This check guarantees that every [Fixpoint] is actually terminating.

    It is fairly obvious that this function is in fact terminating, because
    at each call, either [l1] or [l2] is passed the tail of its original value.
    But unfortunately, [Fixpoint] recursive calls must always decrease on
    a _single fixed_ argument -- and neither [l1] nor [l2] will do. (That's
    why Coq couldn't guess the one to use.)  We might reasonably wish
    that Coq was a little smarter, but it isn't.

    There are a number of ways to get around the problem of convincing
    Coq that a function is actually terminating when the "natural" [Fixpoint]
    doesn't work. In this case, a little creativity (or a peek at the Coq
    library) might lead us to the following definition:
*)

Fixpoint merge l1 l2  {struct l1} :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

(** Coq accepts the outer definition because it is structurally
    decreasing on [l1] (we specify that with the [{struct l1}] annotation,
    although Coq would have guessed this even if we didn't write it),
    and it accepts the inner definition because it is structurally recursive
    on its (sole) argument. (Note that [let fix ... in ... end] is just a
    mechanism for  defining a local recursive function.)

    This definition will turn out to work pretty well; the only irritation
    is that simplification will show the definition of [merge_aux], as
    illustrated by the following examples.

    First, let's remind ourselves that Coq desugars a [match] over multiple
    arguments into a nested sequence of matches:
*)

Print merge.

(** ==> (after a little renaming for clarity)

    [[
    fix merge (l1 l2 : list nat) {struct l1} : list nat :=
      let
        fix merge_aux (l2 : list nat) : list nat :=
          match l1 with
          | [] => l2
          | a1 :: l1' =>
              match l2 with
              | [] => l1
              | a2 :: l2' =>
                  if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
              end
          end in
      merge_aux l2.
    ]]
*)

(** Let's prove the following simple lemmas about [merge]:
*)

Lemma merge2 : forall (x1 x2:nat) r1 r2,
    x1 <= x2 ->
    merge (x1::r1) (x2::r2) =
    x1::merge r1 (x2::r2).
Proof.
  intros.
  simpl. (* This blows up in an unpleasant way, but we can
      still make some sense of it.  Look at the
      [(fix merge_aux ...)] term. It represents the
      the local function [merge_aux] after the value of the
      free variable [l1] has been substituted by [x1::r1],
      the match over [l1] has been simplified to its
      second arm (the non-empty case) and [x1] and [r1] have
      been substituted for the pattern variables [a1] and [l1'].
      The entire [fix] is applied to [r2], but Coq won't attempt
      any further simplification until the structure of [r2]
      is known. *)
  bdestruct (x1 <=? x2).
  - auto.
  - (* Since [H] and [H0] are contradictory, this case follows by [omega].
       But (ignoring that for the moment), note that we can get further
       simplification to occur if we give some structure to [l2]: *)
    simpl. (* does nothing *)
    destruct r2; simpl.  (* makes some progress *)
    + omega.
    + omega.
Qed.

Lemma merge_nil_l : forall l, merge [] l = l.
Proof.
  intros. simpl.
  (* Once again, we see a version of [merge_aux] specialized to
  the value [l1 = nil]. Now we see only the first arm (the
  empty case) of the [match] expression, which simply returns [l2];
  in other words, here the [fix] is just the identity function.
  And once again, the [fix] is applied to [l].  Irritatingly,
  Coq _still_ refuses to perform the application unless [l]
  is destructured first (even though the answer is always [l]). *)
  destruct l.
  - auto.
  - auto.
Qed.

(** Morals:

    (1) Even though the proof state involving local recursive
        functions can can be hard to read, persevere!

    (2) If Coq won't simplify an "obvious" application, try destructing
        the argument.

    We will defer stating and proving other properties of [merge] until later.
*)

(* ================================================================= *)
(** ** Defining Mergesort *)

(** Finally, we need to define the main mergesort function itself.
    Once again, we might hope to write something simple like this:

    [[
    Fixpoint mergesort (l: list nat) :  list nat :=
       let (l1,l2) := split l in
       merge (mergesort l1) (mergesort l2).
    ]]

    Since this function has only one argument, Coq guesses that it is
    intended to be structurally decreasing, but still
    rejects the definition, this time with the complaint:

    [[
    Recursive call to mergesort has principal argument equal to
    "l1" instead of a subterm of "l".
    ]]

    Again, the problem is that Coq has no way to know that [l1] and [l2]
    are "smaller" than [l].  And this time, it is hard to complain that
    Coq is being stupid, since the fact that [split] returns smaller
    lists than it is passed is nontrivial.

    In fact, it isn't true! Consider the behavior of [split] on
    empty or singleton lists...  This is case where Coq's totality
    requirements can actually help us correct the definition of
    our code.  What we really want to write is something more like:

    [[
    Fixpoint mergesort (l: list nat) :  list nat :=
        match l with
        | [] => []
        | [x] => [x]
        | _ => let (l1,l2) := split l in merge (mergesort l1) (mergesort l2).
    ]]

    Now this function really is terminating!  But Coq still won't let us
    write it with a [Fixpoint].  Instead, we need to use a mechanism
    (there are several available) for defining functions that accommodates
    an explicit way to show that the function only calls itself on smaller
    arguments.   We will use the [Function] command:
*)

Function mergesort (l: list nat) {measure length l} :  list nat :=
  match l with
  | [] => []
  | [x] => [x]
  | _ => let (l1,l2) := split l in
         merge (mergesort l1) (mergesort l2)
  end.

(** [Function] is similar to [Fixpoint], but it lets us specify
    an explicit _measure_ on the function arguments.
    The annotation [{measure length l}] says that the function
    [length] applied to argument [l] serves as a decreasing measure.
    After processing this definition, Coq enters proof mode and demands
    proofs that each recursive call is indeed on a shorter list.
    Happily, we proved that fact already.
*)

Proof.
  - (* recursive call on l1 *)
    intros.
    simpl in *.  destruct (split l1) as [l1' l2'] eqn:E. inv teq1.
    destruct (split_len _ _ _ E).
    simpl. omega.
  - (* recursive call on l2 *)
    intros.
    simpl in *. destruct (split l1) as [l1' l2'] eqn:E. inv teq1.
    destruct (split_len _ _ _ E).
    simpl. omega.
Defined.

(** Notice that the [Proof] must end with the keyword [Defined] rather
    than [Qed]; if we don't do this, we won't be able to actually
    compute with [mergesort].

    Defining [mergesort] with [Function] rather than [Fixpoint] causes
    the automatic generation of some useful auxiliary definitions that we
    will need when working with it.
    First, we get a lemma [mergesort_equation], which performs a one-level
    unfolding of the function. *)

Check mergesort_equation.

(** ==>

    [[
    mergesort_equation
     : forall l : list nat,
       mergesort l =
       match l with
       | [] => []
       | [x] => [x]
       | x :: _ :: _ =>
           let (l2, l3) := split l in merge (mergesort l2) (mergesort l3)
       end
    ]]

    We should always use [apply mergesort_equation]
    to simplify a call to [mergesort] rather than trying to [unfold] or [simpl]
    it, which will lead to ugly or mysterious results.

    Second, we get an induction principle [mergesort_ind]; performing
    induction using this principle can be much easier than trying to
    use list induction over the argument [l].
*)

Check mergesort_ind.

(** ==>
    [[
    mergesort_ind
     : forall P : list nat -> list nat -> Prop,
       (forall l : list nat, l = [] -> P [] []) ->
       (forall (l : list nat) (x : nat), l = [x] -> P [x] [x]) ->
       (forall l _x : list nat,
        l = _x ->
        match _x with
        | _ :: _ :: _ => True
        | _ => False
        end ->
        forall l1 l2 : list nat,
        split l = (l1, l2) ->
        P l1 (mergesort l1) ->
        P l2 (mergesort l2) -> P _x (merge (mergesort l1) (mergesort l2))) ->
        forall l : list nat, P l (mergesort l)
    ]]
*)

(* ================================================================= *)
(** ** Correctness: Sortedness *)

(** As with insertion sort, our goal is to prove that mergesort produces
    a sorted list that is a permutation of the original list, i.e. to prove

    [[
    is_a_sorting_algorithm mergesort
    ]]

    We will start by showing that [mergesort] produces a sorted list.  The key
    lemma is to show that [merge] of two sorted lists produces a sorted list.
    It is perhaps easiest to break out a sub-lemma first:
*)

(** **** Exercise: 2 stars, standard (sorted_merge1)  *)
Lemma sorted_merge1 : forall x x1 l1 x2 l2,
    x <= x1 -> x <= x2 ->
    sorted (merge (x1::l1) (x2::l2)) ->
    sorted (x :: merge (x1::l1) (x2::l2)).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, standard (sorted_merge)  *)
Lemma sorted_merge : forall l1, sorted l1 ->
                     forall l2, sorted l2 ->
                     sorted (merge l1 l2).
Proof.
  (* Hint: This is one unusual case where it is _much_ easier to do induction on
     [l1] rather than on [sorted l1]. You will also need to do
     nested inductions on [l2]. *)
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (mergesort_sorts)  *)
Lemma mergesort_sorts: forall l, sorted (mergesort l).
Proof.
  apply mergesort_ind; intros. (* Note that we use the special induction principle. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Correctness: Permutation *)

(** Finally, we must show that [mergesort] returns a permutation of its input.

    As usual, the key lemma is for [merge].

    Incidentally, you are welcome to import the alternative characterizations
    of permutations as multisets given in [Multiset] or [BagPerm]
    and use that instead of [Permutation] if you think it will be easier.
    (I'm not sure!)
*)

(** **** Exercise: 3 stars, advanced (merge_perm)  *)
Lemma merge_perm: forall (l1 l2: list nat),
    Permutation (l1 ++ l2) (merge l1 l2).
Proof.
  (* Hint: A nested induction on [l2] is required. *)
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (mergesort_perm)  *)
Lemma mergesort_perm: forall l, Permutation l (mergesort l).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Putting it all together: *)

Theorem mergesort_correct:
  is_a_sorting_algorithm mergesort.
Proof.
  split.
  apply mergesort_perm.
  apply mergesort_sorts.
Qed.

(** $Date$ *)

(* 2020-08-07 17:08 *)


(*EXAMEN GRUPO B*)
(* Directorio /PRACTICAS/EI/ExMD2Dic/P2 *)

(*NOMBRE: JESUS ANGEL PEREZ-ROCA FERNANDEZ*)

(* ejercicio 1:(PUNTOS: 2 )
  Probar las siguientes proposiciones sin hacer uso de Tauto ni de Auto: *)

Theorem Imp_trans:(P,Q,R:Prop)(P->Q)->(Q->R)->(P->R).
Intros.
Apply (H0 (H H1)).
Defined.

Theorem Ignore_Q:(P,Q,R:Prop)(P->R)->P->Q->R.
Intros.
Apply (H H0).
Defined.

Theorem Delta_imp:(P,Q:Prop)(P->P->Q)->P->Q.
Intros.
Apply (H H0).
Trivial.
Defined.

Theorem Losange:(P,Q,R,S:Prop)(P->Q)->(P->R)->(Q->R->S)->P->S.
Intros.
Apply (H1 (H H2) (H0 H2)).
Defined.

Print Imp_trans.
Print Ignore_Q.
Print Delta_imp.
Print Losange.

(* En logica intuicionista de segundo orden, los conectivos
"falso", "o" e "y" pueden ser definidos en funcion de "para todo" y
la implicacion *)

(* definicion de falso *)

Definition new_false := (a:Prop)a .

(* exercise 2: (PUNTOS 2)
   probar el siguiente teorema *)

Theorem ef : (a:Prop)(new_false -> a).
Intros.
Apply H.
Defined.

Print ef.

(* Definicion de "o":
 a"o"b es verdad si todo lo que se deduce de {a} y de {b} es verdad *)

Definition new_or:=[a,b:Prop](c:Prop)(a->c)->(b->c)->c.

(* ejercicio 3 :(PUNTOS 3)
   probar dos teoremas que juntos demuestren la
   equivalencia de new_or y \/. *)

Theorem equiv_or1: (a,b:Prop)(new_or a b)->(a\/b).
Intros.
Apply H.
Intro.
Left.
Trivial.
Intro.
Right.
Trivial.
Defined.

Theorem equiv_or2: (a,b:Prop)(a\/b)->(new_or a b).
Intros.
Unfold new_or.
Intros.
Elim H.
Trivial.
Trivial.
Defined.

(* usando polimorfismo podemos definir tipos de datos como
   numeros naturales y booleanos aunque
   Coq use definiciones inductivas porque resulta
   mas eficiente *)

(* booleanos *)

Definition new_bool := (a:Set)(a->a->a) .
Definition t := [a:Set][x,y:a]x .
Definition f := [a:Set][x,y:a]y .

(* exercicio 4 :(PUNTOS 3)
   Dar una definicion de new_not:new_bool -> new_bool
   para la negacion en new_bool
   y chequearla con dos entradas diferentes *)

Definition new_not:new_bool->new_bool.
Unfold new_bool.
Intros.
Apply H.
Exact H1.
Exact H0.
Defined.

Print new_not.

Eval Compute in (new_not t).

Eval Compute in (new_not f).

(* Estos dos resultados serian para los tipos polimorficos.
   Si quisieramos probarlo para el tipo bool la comprobacion seria asi:*)

Eval Compute in (t bool true false).

Eval Compute in ((new_not t) bool true false).

Eval Compute in (f bool true false).

Eval Compute in ((new_not f) bool true false).


Theorem True_provable : True.
Proof.
  exact I.
Qed.

Definition not (A:Prop) := A -> False.

Notation "~ x" := (not x) : type_scope.

Theorem False_unprovable : ~ False.
Proof.
  unfold not.
  intros pf_False.
  exact pf_False.
Qed.

Theorem False_unprovable_again : ~ False.
Proof.
  unfold not.
  intros pf_False.
  case pf_False.
Qed.

Theorem True_not_implies_False : ~ (True -> False).
Proof.
  unfold not.
  intros True_imp_False.
  pose (pf_False := True_imp_False I).
  case pf_False.
Qed.

Theorem False_implies_True : False -> True.
Proof.
  intros pf_False.
  case pf_False.
Qed.

Theorem False_implies_False : False -> False.
Proof.
  intros pf_False.
  case pf_False.
Qed.

Require Import Bool.

Theorem true_is_True : Is_true true.
Proof.
  simpl.
  exact I.
Qed.

Theorem not_true_eqb_false : ~ (Is_true (eqb true false)).
Proof.
  simpl.
  exact False_unprovable.
Qed.

Theorem left_or : forall A B : Prop, A -> A \/ B.
Proof.
  intros A B pf_A.
  pose (pf_A_or_B := or_introl pf_A : A \/ B).
  exact pf_A_or_B.
Qed.

Theorem right_or : forall A B : Prop, B -> A \/ B.
Proof.
  intros A B pf_B.
  pose (pf_A_or_B := or_intror pf_B : A \/ B).
  exact pf_A_or_B.
Qed.

Theorem or_commutes : forall A B, A \/ B -> B \/ A.
Proof.
  intros A B pf_A_or_B.
  case pf_A_or_B.
    (* right *)
    intros pf_A.
    refine (or_intror _).
    exact pf_A.
    (* left *)
    intros pf_B.
    refine (or_introl _).
    exact pf_B.
Qed.

Theorem both_and : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B pf_A pf_B.
  pose (pf_A_and_B := conj pf_A pf_B).
  exact pf_A_and_B.
Qed.

Theorem and_commutes : forall A B : Prop, A /\ B -> B /\ A.
Proof.
  intros A B pf_A_and_B.
  case pf_A_and_B.
  intros pf_A pf_B.
  pose (pf_B_and_A := conj pf_B pf_A).
  exact pf_B_and_A.
Qed.

Theorem and_commutes_1 : forall A B : Prop, A /\ B -> B /\ A.
Proof.
  intros A B pf_A_and_B.
  case pf_A_and_B.
  intros pf_A pf_B.
  refine (conj _ _).
    exact pf_B.
    exact pf_A.
Qed.

Theorem and_commutes_2 : forall A B : Prop, A /\ B -> B /\ A.
Proof.
  intros A B pf_A_and_B.
  destruct pf_A_and_B as [ pf_A pf_B ].
  refine (conj _ _).
    exact pf_B.
    exact pf_A.
Qed.

Theorem orb_is_or : forall a b, Is_true (orb a b) <-> Is_true a \/ Is_true b.
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    (* forward *)
    intros H.
    case a, b.
      simpl.
      exact (or_introl I).
      exact (or_introl I).
      exact (or_intror I).
      simpl in H.
      case H.
    (* backward *)
    intros H.
    case a, b.
      simpl. exact I.
      simpl. exact I.
      simpl.
      case H.
        simpl. exact False_implies_True.
        simpl. intros pf_True. exact I.
      simpl in H.
      case H.
        simpl. exact False_implies_False.
        simpl. exact False_implies_False.
Qed.