Require Import Coq.NArith.NArith
  Znumtheory Lia
  Zdiv Zpow_facts.
From Coq Require Import Even.

Section Fn.

  Fixpoint repeat_op_ntimes_rec (e : N) (n : positive) (w : N) : N :=
    match n with
    | xH => N.modulo e w
    | xO p => let ret := repeat_op_ntimes_rec e p w in
        N.modulo (ret * ret) w
    | xI p => let ret := repeat_op_ntimes_rec e p w in
        N.modulo (e * (ret * ret)) w
    end.

  Definition Npow_mod (e : N) (n w : N) :=
    match n with
    | N0 => Npos xH
    | Npos p => repeat_op_ntimes_rec e p w
    end.

  (* Npow_mod is an efficient function *)

  (* Inducive Type to capture the complexity of
    repeat_op_ntimes_rec. This is suffices for
    our purpose because we will call this
    function for exponentiation. In sigma protocol,
    we need to demonstrate that it's efficient, i.e.,
    linear in number of bits (complexity bounded by
    log). However, this won't scale for a bigger
    project because we can't compose the
    inductive datatype. Also see:
    https://users.cs.northwestern.edu/~robby/publications/papers/flops2016-mfnff.pdf
    https://dl.acm.org/doi/10.1145/3473585
    https://dl.acm.org/doi/10.1145/3158124
    https://www.cse.chalmers.se/~nad/publications/danielsson-popl2008.pdf
    *)
  Inductive complexity_repeat_op_ntimes_rec
    (e t : N) : positive -> N -> N -> Prop :=
  | xH_case : complexity_repeat_op_ntimes_rec e t xH
      (N.modulo e t) N0
  | xO_case p ret w :
      complexity_repeat_op_ntimes_rec e t p ret w ->
      complexity_repeat_op_ntimes_rec e t (xO p)
      (N.modulo (ret * ret) t) (N.succ w)
  | xI_case p ret w :
      complexity_repeat_op_ntimes_rec e t p ret w ->
      complexity_repeat_op_ntimes_rec e t (xI p)
      (N.modulo (e * (ret * ret)) t) (N.succ w).

  Lemma correct_complexity_repeat_op_ntimes_rec :
    forall n e w,
    complexity_repeat_op_ntimes_rec e w n
      (repeat_op_ntimes_rec e n w)  (N.log2 (N.pos n)).
  Proof.
    induction n;
    intros e w.
    + specialize (IHn e w).
      assert (Hwt : ((N.pos n~1) = (2 * (N.pos n) + 1))%N).
      cbn; nia.
      rewrite Hwt; clear Hwt.
      rewrite N.log2_succ_double.
      remember ((N.log2 (N.pos n))) as p.
      cbn.
      apply xI_case.
      exact IHn.
      nia.
    + specialize (IHn e w).
      assert (Hwt : ((N.pos n~0) = (2 * (N.pos n)))%N).
      cbn; nia.
      rewrite Hwt; clear Hwt.
      rewrite N.log2_double.
      remember ((N.log2 (N.pos n))) as p.
      cbn.
      apply xO_case.
      exact IHn.
      nia.
    + cbn; apply xH_case.
  Qed.

  (* end of the proof efficient funtion *)

  (* slow function, will be used to prove that this slow function is
    equivalent to Npow_mod, faster one. *)
  Fixpoint Npow_mod_unary (e : N) (n : nat) (w : N) : N :=
    match n with
    | 0%nat => Npos xH
    | S n' => N.modulo (e * Npow_mod_unary e n' w) w
    end.

  (* acc is accumulator, for efficient reduction of terms *)
  Fixpoint repeat_op_ntimes_acc
    (e : N) (n : positive) (w acc : N) : N :=
    match n with
    | xH => N.modulo (e * acc) w
    | xO p => let ee := (N.modulo (e * e) w) in repeat_op_ntimes_acc ee p w acc
    | xI p => let ee := (N.modulo (e * e) w) in
              let ea := (N.modulo (e * acc) w) in
              repeat_op_ntimes_acc ee p w ea
    end.

  Lemma op_pushes_out :
    forall n e w, prime (Z.of_N w) ->
    repeat_op_ntimes_rec ((e * e) mod w) n w =
    N.modulo (
      (repeat_op_ntimes_rec e n w * repeat_op_ntimes_rec e n w)) w.
  Proof.
    induction n.
    - simpl; intros ? ? Hw.
      rewrite IHn.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      remember (repeat_op_ntimes_rec e n w * repeat_op_ntimes_rec e n w)%N as enw.
      rewrite <- N.mul_mod_idemp_r.
      repeat rewrite N.mul_mod_idemp_l.
      repeat rewrite N.mul_mod_idemp_r.
      assert (Ht : (e * enw * (e * enw) =
        e * e * (enw * enw))%N). lia.
      rewrite Ht; clear Ht.
      repeat rewrite N.mul_assoc.
      rewrite N.mul_mod_idemp_r.
      reflexivity.
      all:(try lia; try assumption).
    - simpl; intros ? ? Hw.
      rewrite IHn.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      reflexivity. exact Hw.
    - simpl; intros ? ? Hw.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      rewrite N.mod_mod.
      rewrite N.mul_mod_idemp_l.
      rewrite N.mul_mod_idemp_r.
      reflexivity.
      all:lia.
  Qed.

  Lemma positive_mul_group_acc_rec_connection :
    forall n e w acc,
    prime (Z.of_N w) ->
    repeat_op_ntimes_acc e n w acc = N.modulo (acc * repeat_op_ntimes_rec e n w) w.
  Proof.
    induction n.
    - simpl; intros ? ? ? Hw.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      specialize (IHn (N.modulo (e * e) w) w (N.modulo (e * acc) w)).
      rewrite IHn.
      rewrite op_pushes_out.
      remember (repeat_op_ntimes_rec e n w * repeat_op_ntimes_rec e n w)%N as enw.
      rewrite N.mul_mod_idemp_l.
      repeat rewrite N.mul_mod_idemp_r.
      assert (Ht : ((acc * (e * enw) = e * acc * enw)%N)).
      lia.
      rewrite Ht; clear Ht.
      reflexivity.
      all:(try lia; try assumption).
    - simpl; intros ? ? ? Hw.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      rewrite IHn. rewrite op_pushes_out.
      reflexivity.
      all:assumption.
    - simpl; intros ? ? ? Hw.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      rewrite N.mul_mod_idemp_r.
      assert (Ht : (acc * e = e * acc)%N). lia.
      rewrite Ht; clear Ht.
      reflexivity.
      lia.
  Qed.

  Definition Npow_mod_constant_space (e : N) (n w : N) :=
    match n with
    | N0 => Npos xH
    | Npos p => repeat_op_ntimes_acc e p w 1
    end.

  Lemma npow_mod_npow_constant_eqv :
    forall n e w,
    prime (Z.of_N w) ->
    Npow_mod e n w = Npow_mod_constant_space e n w.
  Proof.
    destruct n; simpl; intros ? ? Hw.
    - reflexivity.
    - pose proof positive_mul_group_acc_rec_connection p e w 1 Hw.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      rewrite H. rewrite N.mul_1_l.
      destruct p.
      all:simpl; rewrite N.mod_mod; lia.
  Qed.

  Lemma Npow_mod_unary_bound :
    forall (n : nat) (e w : N),
    prime (Z.of_N w) ->
    (Npow_mod_unary e n w < w)%N.
  Proof.
    induction n.
    - simpl; intros ? ? Hw.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      lia.
    - simpl; intros ? ? Hw.
      apply N.mod_lt.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      lia.
  Qed.

  Lemma binnat_zero :
    forall (n : nat), 0%N = N.of_nat n -> n = 0%nat.
  Proof.
    induction n; try lia.
  Qed.

  Theorem Npow_mod_add_mul :
    forall n m e w,
    prime (Z.of_N w) ->
    Npow_mod_unary e (n + m) w = N.modulo (Npow_mod_unary e n w *
    Npow_mod_unary e m w) w.
  Proof.
    induction n.
    - intros ? ? ? Hw.
      rewrite Nat.add_0_l.
      assert (Ht : Npow_mod_unary e 0 w = Npos xH).
      simpl. reflexivity.
      rewrite Ht.
      rewrite N.mul_1_l.
      induction m.
      + simpl. rewrite N.mod_1_l.
        reflexivity.
        pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
        lia.
      + simpl. rewrite N.mod_mod.
        reflexivity.
        pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
        lia.
    - simpl; intros ? ? ? Hw.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
      rewrite IHn.
      rewrite N.mul_mod_idemp_r.
      rewrite N.mul_mod_idemp_l.
      rewrite N.mul_assoc. reflexivity.
      lia. lia. assumption.
  Qed.

  Lemma binnat_odd :
    forall (p : positive) (n : nat),
    N.pos (xI p) = N.of_nat n ->
    exists k,  n = (2 * k + 1)%nat /\  (N.pos p) = (N.of_nat k).
  Proof.
    intros p n Hp.
    destruct (Even.even_or_odd n) as [H | H].
    apply Even.even_equiv in H. destruct H as [k Hk].
    (* Even (impossible) Case *)
    rewrite Hk in Hp; lia.
    (* Odd (possible) case *)
    apply Even.odd_equiv in H. destruct H as [k Hk].
    rewrite Hk in Hp. exists k.
    split. exact Hk. lia.
  Qed.

  Lemma binnat_even : forall (p : positive) (n : nat),
    N.pos (xO p) = N.of_nat n :> N ->
    exists k, n = (Nat.mul 2 k) /\  (N.pos p) = (N.of_nat k).
  Proof.
    intros p n Hp.
    destruct (Even.even_or_odd n) as [H | H].
    apply Even.even_equiv in H. destruct H as [k Hk].
    (* Even (possible) case*)
    rewrite Hk in Hp. exists k.
    split. exact Hk. lia.
    (* Odd (impossible) case *)
    apply Even.odd_equiv in H.
    destruct H as [k Hk].
    rewrite Hk in Hp. lia.
  Qed.

  (* slow is equivalent to fast *)
  Lemma npow_mod_exp_unary_binary_eqv :
    forall (n : N) e w, prime (Z.of_N w) ->
    Npow_mod_unary e (N.to_nat n) w = Npow_mod e n w.
  Proof.
    destruct n.
    - simpl; intros ? ? Hw.
      reflexivity.
    - simpl; revert p.
      induction p.
      + simpl; intros ? ? Hw.
        pose proof (prime_ge_2 (Z.of_N w) Hw) as Htt.
        rewrite <-IHp.
        rewrite ZL6.
        rewrite Npow_mod_add_mul.
        rewrite N.mul_mod_idemp_r.
        reflexivity.
        lia. exact Hw.
        exact Hw.
      + simpl; intros ? ? Hw.
        rewrite <-IHp.
        rewrite Pos2Nat.inj_xO.
        assert (Ht : (2 * Pos.to_nat p =
          Pos.to_nat p + Pos.to_nat p)%nat).
        lia. rewrite Ht.
        rewrite Npow_mod_add_mul.
        reflexivity.
        exact Hw.
        exact Hw.
      + simpl; intros ? ? Hw.
        rewrite N.mul_1_r.
        reflexivity.
  Qed.

  Lemma mod_reduce_pow :
    forall n e w, prime (Z.of_N w) ->
    repeat_op_ntimes_rec e n w =
    repeat_op_ntimes_rec (N.modulo e w) n w.
  Proof.
    induction n.
    - simpl; intros ? ? Hp.
      rewrite IHn.
      remember (repeat_op_ntimes_rec (e mod w) n w *
      repeat_op_ntimes_rec (e mod w) n w)%N as t.
      rewrite N.mul_mod_idemp_l.
      reflexivity.
      pose proof (prime_ge_2 (Z.of_N w) Hp) as Ht.
      lia. exact Hp.
    - simpl; intros ? ? Hp.
      rewrite IHn.
      reflexivity.
      exact Hp.
    - simpl; intros ? ? Hp.
      rewrite N.mod_mod.
      reflexivity.
      pose proof (prime_ge_2 (Z.of_N w) Hp) as Ht.
      lia.
  Qed.

  Lemma Nmod_reduce_pow : forall n e w, prime (Z.of_N w) ->
    Npow_mod e n w = Npow_mod (N.modulo e w) n w.
  Proof.
    destruct n.
    - simpl; intros ? ? Hp.
      reflexivity.
    - simpl; intros ? ? Hp.
      apply mod_reduce_pow.
      exact Hp.
  Qed.

  Lemma wp_mod_zero :
    forall (w k p : N),
    prime (Z.of_N p) ->
    (2 <= k)%N -> (2 <= p)%N ->
    (w mod p = 0)%N ->  (Npow_mod (w mod p) k p = 0)%N.
  Proof.
    intros ? ? ? Hp Hk Hpt Hwp.
    rewrite Hwp.
    unfold Npow_mod.
    destruct k. lia.
    clear Hk.
    induction p0.
    simpl. rewrite N.mod_0_l.
    reflexivity. lia.
    simpl. rewrite IHp0.
    rewrite N.mod_0_l.
    reflexivity. lia.
    simpl. rewrite N.mod_0_l.
    reflexivity. lia.
  Qed.

  Lemma wp_mod_one :
    forall (w k p : N),
    prime (Z.of_N p) ->
    (2 <= k)%N -> (2 <= p)%N ->
    (w mod p = 1)%N ->  (Npow_mod (w mod p) k p = 1)%N.
  Proof.
    intros ? ? ? Hp Hk Hpt Hwp.
    rewrite Hwp.
    unfold Npow_mod.
    destruct k. lia.
    clear Hk.
    induction p0.
    simpl. rewrite IHp0.
    simpl. rewrite N.mod_1_l.
    reflexivity. lia.
    simpl. rewrite IHp0.
    rewrite N.mod_1_l.
    reflexivity. lia.
    simpl. rewrite N.mod_1_l.
    reflexivity. lia.
  Qed.

  Lemma zmod_nmod :
    forall (b a w : N),
    prime (Z.of_N w) ->
    Z.of_N (Npow_mod a b w) =
    Zpow_mod (Z.of_N a) (Z.of_N b) (Z.of_N w).
  Proof.
    intros ? ? ? Hw.
    rewrite Zpow_mod_correct.
    destruct b; simpl.
    - symmetry.
      rewrite Z.mod_1_l.
      reflexivity.
      pose proof (prime_ge_2 (Z.of_N w) Hw) as Ht.
      lia.
    - revert p.
      induction p.
      + simpl.
        assert (Ht : (p~1 = p + p + 1)%positive).
        lia. rewrite Ht.
        rewrite Zpower_pos_is_exp.
        rewrite Zpower_pos_is_exp.
        rewrite Zpower_pos_1_r.
        rewrite N2Z.inj_mod.
        rewrite N2Z.inj_mul.
        rewrite N2Z.inj_mul.
        rewrite IHp.
        remember (Z.pow_pos (Z.of_N a) p) as zps.
        remember (Z.of_N a) as za.
        remember (Z.of_N w) as zw.
        assert (Hzp: zps * zps * za = za * (zps * zps)).
        lia. rewrite Hzp; clear Hzp; clear Ht.
        rewrite <-Zmult_mod_idemp_l.
        assert (Ht : (za * (zps * zps)) mod zw = (za mod zw * (zps * zps)) mod zw).
        rewrite <-Zmult_mod_idemp_l.
        reflexivity. rewrite Ht; clear Ht.
        assert (Ht : (za mod zw * (zps * zps)) mod zw =
        (za mod zw * ((zps * zps) mod zw)) mod zw).
        rewrite <-Zmult_mod_idemp_r. reflexivity.
        rewrite Ht; clear Ht.
        assert (Ht : (zps * zps) mod zw =
          (zps mod zw * (zps mod zw)) mod zw).
        rewrite <-Zmult_mod_idemp_l.
        rewrite <-Zmult_mod_idemp_r.
        reflexivity.
        rewrite Ht.
        rewrite Zmult_mod_idemp_r.
        reflexivity.
      + simpl.
        assert (Ht : (p~0 = p + p)%positive).
        lia. rewrite Ht.
        rewrite Zpower_pos_is_exp.
        rewrite N2Z.inj_mod.
        rewrite N2Z.inj_mul.
        rewrite IHp.
        remember (Z.pow_pos (Z.of_N a) p) as zps.
        remember (Z.of_N a) as za.
        remember (Z.of_N w) as zw.
        rewrite Zmult_mod_idemp_l.
        rewrite Zmult_mod_idemp_r.
        reflexivity.
      + simpl. rewrite Zpower_pos_1_r.
        rewrite N2Z.inj_mod.
        reflexivity.
    - pose proof (prime_ge_2 (Z.of_N w) Hw) as Ht.
      lia.
  Qed.

  Lemma npow_mod_nat : forall (n a p : nat),
    prime (Z.of_nat p) ->
    Npow_mod_unary (N.of_nat a) n (N.of_nat p) =
    N.of_nat (Nat.modulo (Nat.pow a n) p).
  Proof.
    induction n.
    + intros * Hp.
      pose proof prime_ge_2 (Z.of_nat p) Hp as Hf.
      simpl. rewrite Nat.mod_1_l.
      lia. lia.
    + intros * Hp.
      simpl.
      pose proof (IHn a p Hp).
      rewrite H.
      rewrite <-Nat2N.inj_mul,
      <-Nat2N.inj_mod.
      f_equal.
      rewrite Nat.mul_mod_idemp_r.
      reflexivity.
      pose proof prime_ge_2 (Z.of_nat p) Hp as Hf.
      lia.
  Qed.

  Lemma N_to_nat_exp : forall (n a p : N),
    prime (Z.of_N p) ->
    N.modulo (N.pow a n) p =
    N.of_nat (Nat.modulo (Nat.pow (N.to_nat a)
      (N.to_nat n)) (N.to_nat p)).
  Proof.
    intros * Hp.
    rewrite <-N2Nat.inj_pow.
    rewrite <-N2Nat.inj_mod.
    lia.
  Qed.

End Fn.


From elpi Require Import elpi.
From HB Require Import structures.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

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

(** *** Exercices on polynomials
- Formalisation of the algebraic  part of  a
 simple proof that PI is irrational  described in:
- http://projecteuclid.org/download/pdf_1/euclid.bams/1183510788
*)

Section Algebraic_part.

Open Scope ring_scope.
Import GRing.Theory Num.Theory.

(** *** Parameters definitions:
- Let n na nb be  natural numbers
- Suppose nb is a non zero nat: nb != 0
- Define the corresponding rationals a , b
- Define pi as a/b.
*)
(* to complete  for na nb*)
Variable n : nat.
(*D*)Variables na nb: nat.
Hypothesis nbne0: nb != 0%N.

Definition a:rat := (Posz na)%:~R.
Definition b:rat :=
(*D*)(Posz nb)%:~R.

Definition pi :=
(*D*)a / b.

(** *** Definition of the polynomials:
-  Look at the f definition: the factorial, the coercion nat :> R (as a Ring), etc...
- Define F:{poly rat} using bigop.
*)
Definition f :{poly rat} :=
  (n`!)%:R^-1 *: ('X^n * (a%:P -  b*:'X)^+n).

(*D*)Definition F :{poly rat} := \sum_(i < n.+1) (-1)^i *: f^`(2*i).

(** *** Prove that:
- b is non zero rational.
*)
(* Some intermediary simple theorems *)
Lemma bne0: b != 0.
(*D*)Proof. by rewrite intr_eq0. Qed.
(** *** Prove that:
-  (a -  bX) has a size of 2
*)
Lemma P1_size: size (a%:P -  b*:'X) = 2%N.
Proof.
(*D*)have hs:  size (- (b *: 'X)) = 2%N.
(*D*)  by rewrite size_opp size_scale ?bne0 // size_polyX.
(*D*)by rewrite  addrC size_addl hs ?size_polyC //;  case:(a!= 0).
Qed.

(** *** Prove that:
-  the lead_coef of (a -  bX) is -b.
*)
Lemma P1_lead_coef: lead_coef (a%:P -  b*:'X) = -b.
Proof.
(*D*)rewrite addrC lead_coefDl.
(*D*)  by rewrite lead_coefN lead_coefZ lead_coefX mulr1.
(*D*)by rewrite size_opp size_scale ?bne0 // size_polyX size_polyC; case:(a!= 0).
Qed.

(** *** Prove that:
-  the size of (a-X)^n is n.+1
*)
Lemma P_size : size ((a%:P -  b*:'X)^+n)  = n.+1.
(*D*)elim:n=>[| n0 Hn0]; first by rewrite expr0 size_polyC.
(*D*)rewrite exprS size_proper_mul.
(*D*)  by rewrite P1_size /= Hn0.
(*D*)by rewrite lead_coef_exp P1_lead_coef -exprS expf_neq0 // oppr_eq0 bne0.
Qed.

(* 2 useful lemmas for the  Qint predicat. *)
Lemma int_Qint (z:int) : z%:~R \is a Qint.
Proof. by apply/QintP; exists z. Qed.

Lemma nat_Qint (m:nat) : m%:R \is a Qint.
Proof. by apply/QintP; exists m. Qed.

(** *** Prove that:
- Exponent and composition of polynomials combine:
*)
Lemma comp_poly_exprn:
   forall (p q:{poly rat}) i, p^+i \Po q = (p \Po q) ^+i.
(*D*)move=> p q; elim=>[| i Hi].
(*D*)  by rewrite !expr0 comp_polyC.
(*D*)by rewrite !exprS comp_polyM Hi.
Qed.

(** *** Prove that:
- f's small coefficients are zero
*)
(* Let's begin the Niven proof *)
Lemma f_small_coef0 i: (i < n)%N -> f`_i = 0.
Proof.
(*D*)move=> iltn;rewrite /f coefZ.
(*D*)apply/eqP; rewrite mulf_eq0 invr_eq0 pnatr_eq0 eqn0Ngt (fact_gt0 n) /=.
(*D*)by rewrite coefXnM iltn.
Qed.

(** *** Prove that:
- f/n! as integral coefficients
*)

Lemma f_int i: (n`!)%:R * f`_i \is a Qint.
Proof.
(*D*)rewrite /f coefZ mulrA mulfV; last by rewrite pnatr_eq0 -lt0n (fact_gt0 n).
(*D*)rewrite mul1r; apply/polyOverP.
(*D*)rewrite rpredM ?rpredX ?polyOverX //.
(*D*)by rewrite rpredB ?polyOverC ?polyOverZ ?polyOverX // int_Qint.
Qed.

(** *** Prove that:
the f^`(i) (x) have integral values for x = 0
*)
Lemma derive_f_0_int: forall i, f^`(i).[0] \is a Qint.
Proof.
(*D*)move=> i.
(*D*)rewrite horner_coef0 coef_derivn addn0 binomial.ffactnn.
(*D*)case:(boolP (i <n)%N).
(*D*)  move/f_small_coef0 ->.
(*D*)  by rewrite mul0rn // int_Qint.
(*D*)rewrite -leqNgt.
(*D*)move/binomial.bin_fact <-.
(*D*)rewrite /f coefZ -mulrnAl -mulr_natr mulrC rpredM //; last first.
(*D*)  rewrite mulnC !natrM !mulrA  mulVf ?mul1r ?rpredM ?nat_Qint //.
(*D*)  by rewrite  pnatr_eq0 eqn0Ngt (fact_gt0 n).
(*D*)apply/polyOverP;rewrite rpredM // ?rpredX ?polyOverX //.
(*D*)by rewrite ?rpredB ?polyOverC ?polyOverZ ?polyOverX // int_Qint.
Qed.

(** *** Deduce that:
F (0) has an integral value
*)

Lemma F0_int : F.[0] \is a Qint.
Proof.
(*D*)rewrite /F horner_sum rpred_sum // =>  i _ ; rewrite !hornerE rpredM //.
(*D*)  by rewrite -exprnP rpredX.
(*D*)by rewrite derive_f_0_int.
Qed.

(** *** Then prove
- the symmetry argument f(x) = f(pi -x).
*)
Lemma pf_sym:  f \Po (pi%:P -'X) = f.
Proof.
(*D*)rewrite /f comp_polyZ;congr (_ *:_).
(*D*)rewrite comp_polyM   !comp_poly_exprn.
(*D*)rewrite comp_polyB comp_polyC !comp_polyZ !comp_polyX scalerBr /pi.
(*D*)have h1:    b%:P * (a / b)%:P = a%:P.
(*D*)  by rewrite polyCM mulrC -mulrA -polyCM mulVf ?bne0 // mulr1.
(*D*)suff->: (a%:P - (b *: (a / b)%:P - b *: 'X)) = b%:P * 'X.
(*D*)  rewrite exprMn mulrA - exprMn [X in _ = X]mulrC.
(*D*)  congr (_ *_); congr (_^+_).
(*D*)  rewrite mulrC mulrBr; congr (_ -_)=>//.
(*D*)  by rewrite mul_polyC.
(*D*)by rewrite -!mul_polyC h1 opprB addrA addrC addrA addNr add0r.
Qed.

(** *** Prove
- the symmetry for the derivative
*)

Lemma  derivn_fpix i :
      (f^`(i)\Po(pi%:P -'X))= (-1)^+i *: f^`(i).
Proof.
(*D*)elim:i ; first by rewrite /= expr0 scale1r pf_sym.
(*D*)move => i Hi.
(*D*)set fx := _ \Po _.
(*D*)rewrite derivnS exprS -scalerA -derivZ -Hi deriv_comp !derivE.
(*D*)by rewrite mulrBr mulr0 add0r mulr1 -derivnS /fx scaleN1r opprK.
Qed.

(** *** Deduce that
- F(pi) is an integer
*)
Lemma FPi_int : F.[pi] \is a Qint.
Proof.
(*D*)rewrite /F horner_sum rpred_sum //.
(*D*)move=> i _ ; rewrite !hornerE rpredM //.
(*D*)  by rewrite -exprnP rpredX.
(*D*)move:(derivn_fpix (2*i)).
(*D*)rewrite  mulnC exprM sqrr_sign scale1r => <-.
(*D*)by rewrite horner_comp !hornerE subrr derive_f_0_int.
Qed.

(** *** if you have time
- you can prove the  equality  F^`(2) + F = f
- that is  needed by the analytic part of the Niven proof
*)

Lemma D2FDF : F^`(2) + F = f.
Proof.
(*D*)rewrite /F linear_sum /=.
(*D*)rewrite (eq_bigr (fun i:'I_n.+1 => (((-1)^i *: f^`(2 * i.+1)%N)))); last first.
(*D*)  move=> i _ ;rewrite !derivZ; congr (_ *:_).
(*D*)  rewrite -!derivnS;congr (_^`(_)).
(*D*)  by rewrite mulnS addnC addn2.
(*D*)rewrite [X in _ + X]big_ord_recl muln0 derivn0.
(*D*)rewrite -exprnP expr0 scale1r (addrC f) addrA -[X in _ = X]add0r.
(*D*)congr (_ + _).
(*D*)rewrite big_ord_recr addrC addrA -big_split big1=>[| i _].
(*D*)  rewrite add0r /=; apply/eqP; rewrite scaler_eq0 -derivnS derivn_poly0.
(*D*)    by rewrite eqxx orbT.
(*D*)  suff ->: (size f) = (n + n.+1)%N by rewrite -plus_n_O leqnSn.
(*D*)  rewrite /f size_scale; last first.
(*D*)    by rewrite invr_neq0 // pnatr_eq0 -lt0n (fact_gt0 n).
(*D*)  rewrite size_monicM ?monicXn //; last by rewrite -size_poly_eq0 P_size.
(*D*)  by rewrite  size_polyXn P_size.
(*D*)rewrite /bump /= -scalerDl.
(*D*)apply/eqP;rewrite scaler_eq0 /bump -exprnP add1n exprSr.
(*D*)by rewrite mulrN1 addrC subr_eq0 eqxx orTb.
Qed.

End Algebraic_part.


From mathcomp Require Import ssreflect.

Require Import zf.

Inductive SymDiffOfCollection {U:Type} (A B:Collection U): Collection U :=
| intro_sym_diff_of_collection:
    forall x:U, x ∈ (A \ B) ∪ (B \ A) -> x ∈ SymDiffOfCollection A B.

Notation "A △ B" := (SymDiffOfCollection A B) (right associativity, at level 30).

Inductive DirectSumOfCollection {U:Type} (X':Collection (Collection U)): Collection U:=
| definition_of_direct_sum_of_collection: forall x:U,
    x ∈ (⋃ X')  /\
    (forall A B:Collection U, A ∈ X' /\ B ∈ X' -> A ∩ B = `Ø`)
    -> x ∈ DirectSumOfCollection X'.

Definition CoveringBySets {U:Type} (X:Collection U) (X':Collection (Collection U)) := X = (⋃ X').

Definition CollectionIsPartition {U:Type} (X:Collection U) (X':Collection (Collection U)) :=
  X = (⋃ X') /\
  forall A B:Collection U, A ∈ X' /\ B ∈ X' -> A ∩ B <> `Ø` -> A = B.

Section CollectionOperator.
  Variable U:Type.
  Theorem AbsorptionEmpty:
    forall A:Collection U, (A ∪ `Ø`) = A.
  Proof.
    move => A.
    apply mutally_included_iff_eq.
    split => x.
    case. by [].
    apply all_collection_included_empty.
    move => H.
    left. by [].
  Qed.

  Theorem AbsorptionFull:
    forall A:Collection U, (A ∪ (FullCollection U)) = FullCollection U.
  Proof.
    move => A.
    apply mutally_included_iff_eq.
    split => x.
    case. exact.
    exact.
    move => H.
    right. by [].
  Qed.

  Theorem LawOfExcludedMiddleAtCollection:
    forall A:Collection U, A ∪ (A ^c) = FullCollection U.
  Proof.
    move => A.
    apply mutally_included_iff_eq.
    split => x H.
    exact.
    apply: in_or_to_in_union.
    apply LawOfExcludedMiddle.
  Qed.

  Theorem LawOfDistributiveByUnion:
    forall A B C:Collection U, (A ∩ B) ∪ C = (A ∪ C) ∩ (B ∪ C).
  Proof.
    move => A B C.
    apply mutally_included_iff_eq.
    split => x H0.
    apply in_intersection_iff_in_and.
    suff: (x ∈ A \/ x ∈ C) /\ (x ∈ B \/ x ∈ C).
    case => HAC HBC.
    split; apply in_or_to_in_union; by [].
    have L1: (x ∈ A /\ x ∈ B) \/ x ∈ C.
    case: H0 => x0 HAB; [left; apply in_intersection_iff_in_and | right]; by[].
    apply LawOfDistributiveByOr. by[].
    suff: (x ∈ A /\ x ∈ B) \/ x ∈ C.
    case => H; [left; apply in_intersection_iff_in_and | right]; by[].
    apply LawOfDistributiveByOr.
    case H0 => x0 H1 H2.
    split; apply in_union_iff_in_or; by [].
  Qed.

  Theorem LawOfDistributiveByIntersection:
    forall A B C:Collection U, (A ∪ B) ∩ C = (A ∩ C) ∪ (B ∩ C).
  Proof.
    move => A B C.
    apply mutally_included_iff_eq.
    split => x H0.
    apply in_union_iff_in_or.
    suff: (x ∈ A /\ x ∈ C) \/ (x ∈ B /\ x ∈ C).
    case => H; [left|right]; apply in_intersection_iff_in_and; by [].
    apply LawOfDistributiveByAnd.
    case: H0 => x0 HAB HC.
    split; [apply in_union_iff_in_or|]; by[].
    suff: (x ∈ A \/ x ∈ B) /\ x ∈ C.
    case => HAB HC.
    apply in_and_to_in_intersection.
    split; [apply in_union_iff_in_or|]; by[].
    apply LawOfDistributiveByAnd.
    case H0 => x0 H1; [left|right]; apply in_intersection_iff_in_and; by [].
  Qed.

  Theorem LawOfAbsorptionToUnion:
    forall A B:Collection U, (A ∩ B) ∪ A = A.
  Proof.
    move => A B.
    apply union_iff_subcollect.
    move => x. case => x0 HA HB. by [].
  Qed.

  Theorem LawOfAbsorptionToIntersection:
    forall A B:Collection U, (A ∪ B) ∩ A = A.
  Proof.
    move => A B.
    rewrite LawOfCommutativeAtIntersection.
    apply subcollect_to_intersection.
    move => x. left. by [].
  Qed.

  Theorem DoMorgranLawAtUnion:
    forall A B:Collection U, (A ∪ B)^c = A^c ∩ B^c.
  Proof.
    move => A B.
    apply mutally_included_iff_eq.
    split => x H.
    apply in_and_to_in_intersection.
    apply LawOfDeMorgan_NegtationOfDisjunction.
    move => HAB.
    apply H.
    apply in_or_to_in_union. by [].
    apply in_intersection_to_in_and in H.
    apply LawOfDeMorgan_NegtationOfDisjunction in H.
    move => HF.
    apply H.
    apply in_union_to_in_or. by [].
  Qed.

  Theorem DoMorgranLawAtIntersection:
    forall A B:Collection U, (A ∩ B)^c = A^c ∪ B^c.
  Proof.
    move => A B.
    apply mutally_included_iff_eq.
    split => x H.
    apply in_or_to_in_union.
    apply LawOfDeMorgan_NegtationOfConjunction => HAB.
    apply H.
    apply in_and_to_in_intersection in HAB. by [].
    apply in_union_to_in_or in H.
    apply LawOfDeMorgan_NegtationOfConjunction in H.
    move => HAB.
    apply H.
    apply in_intersection_to_in_and. by [].
  Qed.

  Goal forall (A B:Collection U), A △ B = A^c △ B^c.
  Proof.
    move => A B.
    apply mutally_included_to_eq.
    split => x H.
    +inversion H as [x0 H0 Hx0].
     split.
     ++inversion H0 as [x1 H1|x1 H1];
         [right|left];
         inversion H1 as [x2 H3 H4 H5];
         split.
       apply notin_collect_iff_in_complement.
       apply H4.
       apply notin_collect_iff_in_complement.
       rewrite -complement_of_complement_collect_is_self.
       apply H3.
       apply H4.
       apply notin_collect_iff_in_complement.
       rewrite -complement_of_complement_collect_is_self.
       apply H3.
    +inversion H.
     inversion H0; split;
       [right|left];
       split; inversion H2.
     apply DoubleNegativeElimination.
     apply H5.
     apply notin_collect_iff_in_complement.
     apply H4.
     apply DoubleNegativeElimination.
     apply H5.
     apply notin_collect_iff_in_complement.
     apply H4.
  Qed.

  Goal
    forall (X:Collection U) (X':Collection (Collection U)),
      CollectionIsPartition X X' -> CoveringBySets X X'.
  Proof.
    move => X X' H.
    inversion H.
    trivial.
  Qed.

End CollectionOperator.

Require Export zf.


Require Import Coq.Lists.List.

Import ListNotations.

Theorem Forall_app : forall (A : Type) (P : A -> Prop) (xs ys : list A),
  Forall P xs ->
  Forall P ys ->
  Forall P (xs ++ ys).
Proof.
  intros A P xs ys H1.
  generalize dependent ys.
  induction H1; intros ys H2.
  - assumption.
  - simpl.
    auto using Forall_cons.
Qed.

Inductive Zip {A B : Type} : list A -> list B -> list (A * B) -> Prop :=
| Zip_nil : Zip [] [] []
| Zip_cons : forall x y xs ys zs,
    Zip xs ys zs -> Zip (x :: xs) (y :: ys) ((x, y) :: zs).

Theorem Zip_app : forall (A B : Type) (xs1 xs2 : list A) (ys1 ys2 : list B)
  (zs1 zs2 : list (A * B)),
  Zip xs1 ys1 zs1 ->
  Zip xs2 ys2 zs2 ->
  Zip (xs1 ++ xs2) (ys1 ++ ys2) (zs1 ++ zs2).
Proof.
  intros A B xs1 xs2 ys1 ys2 zs1 zs2 HZip1.
  generalize dependent zs2.
  generalize dependent ys2.
  generalize dependent xs2.
  induction HZip1; intros xs2 ys2 zs2 HZip2; simpl; auto using Zip_cons.
Qed.


From mathcomp Require Import all_ssreflect.
From fcsl Require Import axioms pred prelude domain.

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

Lemma nat_leq_refl : forall x : nat, x <= x.
Proof.
exact: leqnn.
Qed.

Lemma nat_leq_antisymmetric : forall x y, x <= y -> y <= x -> x = y.
Proof.
  move => x' y'.
  rewrite leq_eqVlt.
  move/orP.
  case.
  - by move/eqP.
  - move => Hlt.
    rewrite leq_eqVlt.
    move/orP.
    case.
    * by move/eqP.
    * move => Ht'.
      rewrite ltnNge in Ht'.
      rewrite ltnNge in Hlt.
      have Ht := leq_total x' y'.
      move/orP: Ht.
      case.
      + move => Hlt'.
        by move/negP in Ht'.
      + move => Hlt'.
        by move/negP in Hlt.
Qed.

Lemma nat_leq_trans : forall x y z, x <= y -> y <= z -> x <= z.
Proof.
move => x y z.
apply: leq_trans.
Qed.

Definition nat_leq_PosetMixin :=
  PosetMixin nat_leq_refl nat_leq_antisymmetric nat_leq_trans.
Canonical nat_leq_Poset := Eval hnf in Poset nat nat_leq_PosetMixin.

Inductive nat_top :=
| nat_top_nat (n : nat)
| nat_top_top.

Inductive nat_top_leq : nat_top -> nat_top -> Prop :=
| nat_top_leq_nat_nat : forall m n, m <= n -> nat_top_leq (nat_top_nat m) (nat_top_nat n)
| nat_top_leq_nat_top : forall n, nat_top_leq (nat_top_nat n) nat_top_top
| nat_top_leq_top_top : nat_top_leq nat_top_top nat_top_top.

Notation "x <=T y" := (nat_top_leq x y) (at level 40).

Lemma nat_top_leq_refl : forall x, x <=T x.
Proof.
case.
- move => n.
  apply nat_top_leq_nat_nat.
  exact: leqnn.
- apply nat_top_leq_top_top.
Qed.

Lemma nat_top_leq_antisymmetric : forall x y, x <=T y -> y <=T x -> x = y.
Proof.
case.
- move => m.
  case.
  * move => n Hle Hle'.
    inversion Hle; subst.
    inversion Hle'; subst.
    by rewrite (nat_leq_antisymmetric H1 H2).
  * move => Hle Hle'.
    by inversion Hle'.
- case => //=.
  move => n Hle.
  by inversion Hle.
Qed.

Lemma nat_top_leq_trans : forall x y z, x <=T y -> y <=T z -> x <=T z.
Proof.
case.
- move => x.
  case.
  * move => y.
    case.
    + move => z.
      move => Hle Hle'.
      inversion Hle; subst.
      inversion Hle'; subst.
      apply nat_top_leq_nat_nat.
      by eapply nat_leq_trans; eauto.
    + move => Hle Hle'.
      exact: nat_top_leq_nat_top.
  * case.
    + move => n.
      move => Hle Hle'.
      by inversion Hle'.
    + move => Hle Hle'.
      exact: nat_top_leq_nat_top.
- case.
  * move => m.
    case.
    + move => n.
      move => Hle Hle'.
      by inversion Hle.
    + move => Hle.
      by inversion Hle.
  * case.
    + move => n Hle Hle'.
      by inversion Hle'.
    + move => Hle Hle'.
      exact: nat_top_leq_top_top.
Qed.

Definition nat_top_leq_PosetMixin :=
  PosetMixin nat_top_leq_refl nat_top_leq_antisymmetric nat_top_leq_trans.
Canonical nat_top_leq_Poset := Eval hnf in Poset nat_top nat_top_leq_PosetMixin.

Section LatticeFacts.

Variable L : lattice.

Variable S T : Pred L.

Local Notation "⋁ S" := (sup S) (at level 40).
Local Notation "⋀ S" := (inf S) (at level 40).
Local Notation "s ⋞ t" := (Poset.leq s t) (at level 70).
Local Notation "s ∈ S" := (s \In S) (at level 70).

(* Mini-exercises from p. 44 in Ordered Sets and Complete Lattices *)
(* http://profs.sci.univr.it/~giaco/paperi/lattices-for-CS.pdf *)

Lemma mini_i_1 : forall s, s ∈ S -> s ⋞ ⋁ S.
Proof.
exact: supP.
Qed.

Lemma mini_i_2 : forall s, s ∈ S -> ⋀ S ⋞ s.
Proof.
exact: infP.
Qed.

Lemma mini_iv_1 :
  ⋁ S ⋞ ⋀ T ->
  (forall s t, s ∈ S -> t ∈ T -> s ⋞ t).
Proof.
move => HST s t Hs Ht.
have HsupP := supP Hs.
have HinfP := infP Ht.
have Hle: s ⋞ inf T.
  move: HsupP HST.
  exact: poset_trans.
move: Hle HinfP.
exact: poset_trans.
Qed.

Lemma mini_iv_2 :
  (forall s t, s ∈ S -> t ∈ T -> s ⋞ t) ->
  ⋁ S ⋞ ⋀ T.
Proof.
move => Hst.
have HsupM := @supM _ S (inf T).
apply HsupM.
move => y Hy.
have HinfM := @infM _ T y.
apply HinfM.
move => x Hx.
exact: Hst.
Qed.

Hypothesis S_subset_T : forall s, s ∈ S -> s ∈ T.

Lemma mini_v_1 : ⋁ S ⋞ ⋁ T.
Proof.
apply supM.
move => y H.
apply supP.
exact: S_subset_T.
Qed.

Lemma mini_v_2 : ⋀ T ⋞ ⋀ S.
Proof.
apply infM.
move => y H.
apply infP.
exact: S_subset_T.
Qed.

End LatticeFacts.


Require DTS_Def.
Module DTS_Example <: DTS_Def.DTS_Par.

(** Die Zustaende des Wechselschalters und die Instanziierung. *)

Inductive Q' := on : Q' | off : Q'.
Definition Q := Q'.

(** Das Eingabealphabet des Wechselschalters und die Instanziierung. *)

Inductive Sigma' := press : Sigma'.
Definition Sigma := Sigma'.

(** Definition, welche Uebergaenge moeglich sind. *)

Definition delta (p : Q) (a : Sigma) : Q :=
  match p with
    | on  => off
    | off  => on
  end.

(** Startzustand: *)

Definition q0 := off.

(** Akzeptierende Zustaende: *)

Definition is_accepting (q : Q) : Type :=
  match q with
    | on => True
    | off => False
  end.

End DTS_Example.

Module Ex_Prop := DTS_Def.DTS_Fun DTS_Example.
Require Import Words.
Import DTS_Example.
Import Ex_Prop.

(** Durch die oben gegebenen Definitionen lassen sich zwei Sprachen definieren, die mit
 einer geraden Anzahl an Eingaben [even_press] und die mit einer ungeraden Anzahl
 an Eingaben [odd_press]. *)

Inductive even_press : @Word Sigma -> Type :=
  | eps_even : even_press eps
  | snoc_even {w : @Word Sigma} {a : Sigma} : odd_press w -> even_press (snoc w a)
with odd_press : @Word Sigma -> Type :=
  | snoc_odd {w : @Word Sigma} {a : Sigma} : even_press w -> odd_press (snoc w a).

(** Beweis, dass die Sprache des [DTS_Example] = [odd_press] ist, indem die folgenden
 Implikationen gezeigt werden.
 - forall w, Lang_delta w -> odd_press w
 - forall w, odd_press w -> Lang_delta w
 Dazu wird ein typwertiges Praedikat benoetigt, um zu wissen in welchem Zustand sich
 der Automat nach der Eingabe befindet. *)

Lemma finish_input : forall w,
      ((even_press w * (delta_hat q0 w = off)) +
      (odd_press w * (delta_hat q0 w = on)))%type.
Proof.
  induction w.
  - simpl.
    left.
    split.
    + exact eps_even.
    + reflexivity.
  - simpl.
    destruct IHw as [[peven x] | [podd y]].
    + right.
       split.
       * exact (snoc_odd peven).
       * rewrite x.
         simpl.
         reflexivity.
    + left.
       split.
       * exact (snoc_even podd).
       * rewrite y.
         simpl.
         reflexivity.
Defined.

(** Die Eingabe hat eine gerade oder ungerade Laenge. [even_press] und [odd_press]
 sind disjunkt. *)

Lemma even_odd_disjoint (w : @Word Sigma) :
      even_press w -> odd_press w -> False.
Proof.
  intros even odd.
  induction w.
  - inversion odd.
  - inversion even.
    inversion odd.
    exact (IHw X0 X).
Defined.

(** Jetzt koennen beide Richtungen der Aequivalenz gezeigt werden.
 - forall w, Lang_delta w -> odd_press w
 - forall w, odd_press w -> Lang_delta w *)

Lemma Lang_odd : forall w, Lang_delta w -> odd_press w.
Proof.
  unfold Lang_delta.
  intros w w_in_L.
  pose (finish_input w) as decide_L.
  destruct decide_L as [[even off] |[odd on]].
  - rewrite off in w_in_L.
    simpl in w_in_L.
    destruct w_in_L.
  - exact odd.
Defined.

Lemma odd_Lang : forall w, odd_press w -> Lang_delta w.
Proof.
  unfold Lang_delta.
  intros w odd.
  pose (finish_input w) as decide_L.
  destruct decide_L as [[even off] |[odd' on]].
  - pose (even_odd_disjoint w even odd) as ff.
    destruct ff.
  - rewrite on.
    simpl.
    exact I.
Defined.

(** Aequivalenz zwischen odd_press und Lang_delta. Die Sprache die von dem
Toggle Automaten akzeptiert wird, besteht genau aus den Woertern deren Laenge
ungerade ist. *)

Require Import Equivalences.
Module Lang_Toggle : Logical_EQ_type_valued_pred.
Definition  base := @Word Sigma.
Definition P := odd_press.
Definition Q := Lang_delta.
Definition pq := odd_Lang.
Definition qp := Lang_odd.
End Lang_Toggle.

(** Es muss noch gezeigt werden, dass das Eingabealphabet und die Zustandsmenge
 endlich sind. *)

Require Import FiniteClass.
Require Import Fin.
Require Import Program.

(** Die Zustandsmenge ist endlich. *)

Instance Q_Finite : Finite Q := {
  card := 2;
  to x := match x with
    | off => F1
    | on => FS (F1)
  end;
  from i := match i with
    | F1             => off
    | FS  (F1 )   => on
    | FS  (FS _) => off
  end
}.
Proof.
  - intro i.
    repeat dependent destruction i; reflexivity.
  - intro x.
    destruct x;reflexivity.
Qed.

(** Das Eingabealphabet ist endlich. *)

Instance Sigma_Finite : Finite Sigma := {
  card := 1;
  to x := match x with
    | press => F1
  end;
  from i := match i with
    | F1             => press
    | FS  (F1 )   => press
    | FS  (FS _) => press
  end
}.
Proof.
  - intro i.
    repeat dependent destruction i; reflexivity.
  - intro x.
    destruct x;reflexivity.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_congruenceflip.
Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthancongruence.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_TGsymmetric :
   forall A B C a b c,
   TG A a B b C c ->
   TG B b A a C c.
Proof.
intros.
rename_H H;
let Tf:=fresh in
assert (Tf:exists H, (BetS A a H /\ Cong a H B b /\ Lt C c A H)) by (conclude_def TG );destruct Tf as [H];spliter.
assert (neq a H) by (forward_using lemma_betweennotequal).
assert (neq B b) by (conclude axiom_nocollapse).
assert (neq A a) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists F, (BetS B b F /\ Cong b F A a)) by (conclude lemma_extension);destruct Tf as [F];spliter.
assert (Cong a A F b) by (forward_using lemma_doublereverse).
assert (Cong A a F b) by (forward_using lemma_congruenceflip).
assert (Cong a H b B) by (forward_using lemma_congruenceflip).
assert (BetS F b B) by (conclude axiom_betweennesssymmetry).
assert (Cong A H F B) by (conclude cn_sumofparts).
assert (Cong A H B F) by (forward_using lemma_congruenceflip).
assert (Lt C c B F) by (conclude lemma_lessthancongruence).
assert (TG B b A a C c) by (conclude_def TG ).
close.
Qed.

End Euclid.


Require Import Bool Arith List Lib.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

(* ---------- Source language of our compiler ------------- *)

Inductive type : Set := Nat | Bool.

(* Map types of object language to Coq types. *)
Definition typeDenote (t : type) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

(* Syntax of the source language. *)
Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq : forall t, tbinop t t Bool (* Polymorphism: allow equality of any two values of any type, as long as they have the same type. *)
| TLt : tbinop Nat Nat Bool.

(* Interpret with standard library. *)
Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
  | TPlus => plus
  | TTimes => mult
  | TEq Nat => beq_nat
  | TEq Bool => eqb
  | TLt => leb
  end.

(* Our type of arithmetic expressions. *)
Inductive texp : type -> Set :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
  | TNConst n => n
  | TBConst b => b
  | TBinop _ _ _ b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

(* Evaluate examples. *)
Eval simpl in texpDenote (TNConst 41).
Eval simpl in texpDenote (TBConst true).
Eval simpl in texpDenote (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).
Eval simpl in texpDenote (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).
Eval simpl in texpDenote (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).

(* ---------- Target language of our compiler ------------- *)

(* Stack types classify sets of possible stacks. *)
Definition tstack := list type.

(* Instructions in terms of stack types.
   Every instruction's type tells what initial stack type it expects and
   what final stack type it will produce. *)
Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall s, nat -> tinstr s (Nat :: s)
| TiBConst : forall s, bool -> tinstr s (Bool :: s)
| TiBinop : forall arg1 arg2 res s,
    tbinop arg1 arg2 res -> tinstr (arg1 :: arg2 :: s) (res :: s).

(* Stack machine programs must guarantee that intermediate stack types
   match within a program. *)
Inductive tprog : tstack -> tstack -> Set :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
    tinstr s1 s2 -> tprog s2 s3 -> tprog s1 s3.

(* Value stacks at runtime. *)
Fixpoint vstack (ts : tstack) : Set :=
  match ts with
  | nil => unit
  | t :: ts' => typeDenote t * vstack ts'
  end%type.

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
  | TiNConst _ n => fun s => (n ,s)
  | TiBConst _ b => fun s => (b, s)
  | TiBinop _ _ _ _ b => fun s =>
                           let '(arg1, (arg2, s')) := s in
                           ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
  | TNil _ => fun s => s
  | TCons _ _ _ i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

(* ---------- Compiler definition ------------- *)

(* Translation. *)

(* Helper for concatenating two stack machine programs. *)
Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
  | TNil _ => fun p' => p'
  | TCons _ _ _ i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
  | TNConst n => TCons (TiNConst _ n) (TNil _)
  | TBConst b => TCons (TiBConst _ b) (TNil _)
  | TBinop _ _ _ b e1 e2 => tconcat (tcompile e2 _) (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

(* Run some compiled programs. *)

Eval simpl in tprogDenote (tcompile (TNConst 42) nil) tt.
Eval simpl in tprogDenote (tcompile (TBConst true) nil) tt.
Eval simpl in tprogDenote (tcompile (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)) nil) tt.
Eval simpl in tprogDenote (tcompile (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)) nil) tt.
Eval simpl in tprogDenote (tcompile (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)) nil) tt.

(* Show translation correctness. *)

(* Strategy: In addition to the source expression and its type,
   we quantify over an initial stack type and a stack compatible with it.
   Running the compilation of the program starting from that stack,
   we should arrive at a stack that differs only in having the program's
   denotation pushed onto it. *)
Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
    tprogDenote (tcompile e ts) s = (texpDenote e, s).
Abort.

(* Analogue to the [app_assoc_reverse]. *)
Lemma tconcat_corret : forall ts ts' ts'' (p : tprog ts ts') (p' : tprog ts' ts'') (s : vstack ts),
    tprogDenote (tconcat p p') s = tprogDenote p' (tprogDenote p s).
Proof.
  induction p; crush.
Qed.

(* Register lemma to be used by the brute-force script. *)
Hint Rewrite tconcat_corret.

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
    tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
  induction e; crush.
Qed.

Hint Rewrite tcompile_correct'.

Theorem tcompile_correct : forall t (e : texp t),
    tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
Proof.
  crush.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import coqutil.Word.Interface coqutil.Datatypes.HList coqutil.Datatypes.PrimitivePair.
Require Import coqutil.Word.Properties.
Require Import coqutil.Z.bitblast.
Require Import coqutil.Z.prove_Zeq_bitwise.
Require Import coqutil.Byte.
Local Set Universe Polymorphism.

Local Open Scope Z_scope.

Section BigEndian. Local Set Default Proof Using "All".

  Fixpoint combine (n : nat) : forall (bs : tuple byte n), Z :=
    match n with
    | O => fun _ => 0
    | S m => fun bs => Z.lor (Z.shiftl (byte.unsigned (pair._1 bs)) (8 * Z.of_nat m))
                             (combine m (pair._2 bs))
    end.

  Fixpoint split (n : nat) (w : Z) : tuple byte n :=
    match n with
    | O => tt
    | S m => pair.mk (byte.of_Z (Z.shiftr w (8 * Z.of_nat m))) (split m w)
    end.

  Arguments Z.mul: simpl never.
  Arguments Z.pow: simpl never.
  Arguments Z.of_nat: simpl never.
  Arguments Nat.mul: simpl never.

  Lemma combine_bound: forall {n: nat} (t: HList.tuple byte n),
      0 <= combine n t < 2 ^ (8 * Z.of_nat n).
  Proof.
    induction n; intros.
    - destruct t. cbv. intuition discriminate.
    - destruct t as [b t]. unfold combine. simpl.
      specialize (IHn t).
      match goal with
      | |- context [?F n t] => change (F n t) with (combine n t)
      end.
      pose proof (byte.unsigned_range b).
      replace (8 * Z.of_nat (S n)) with (8 * Z.of_nat n + 8) by blia.
      rewrite Z.pow_add_r by blia.
      rewrite Z.or_to_plus.
      + rewrite (Z.shiftl_mul_pow2 (byte.unsigned b)) by blia. Lia.nia.
      + prove_Zeq_bitwise.
  Qed.

  Lemma combine_split (n : nat) (z : Z) :
    combine n (split n z) = z mod 2 ^ (Z.of_nat n * 8).
  Proof.
    revert z; induction n.
    - cbn. intros. rewrite Z.mod_1_r. trivial.
    - cbn [split combine PrimitivePair.pair._1 PrimitivePair.pair._2]; intros.
      erewrite IHn; clear IHn.
      rewrite byte.unsigned_of_Z, Nat2Z.inj_succ, Z.mul_succ_l by blia.
      unfold byte.wrap.
      rewrite <-! Z.land_ones by blia.
      Z.bitblast.
  Qed.

  Lemma split_combine (n: nat) bs :
    split n (combine n bs) = bs.
  Proof.
    revert bs; induction n.
    - destruct bs. reflexivity.
    - destruct bs; cbn [split combine PrimitivePair.pair._1 PrimitivePair.pair._2]; intros.
      f_equal.
      { eapply byte.unsigned_inj.
        rewrite byte.unsigned_of_Z, <-byte.wrap_unsigned; cbv [byte.wrap].
        pose proof combine_bound _2 as B.
        Z.bitblast. cbn. subst.
        rewrite (testbit_above B) by blia.
        Z.bitblast_core. }
      { etransitivity. 1: symmetry. 1: eapply IHn.
        rewrite combine_split.
        rewrite <-IHn.
        f_equal.
        pose proof combine_bound _2 as B.
        rewrite <- (Z.mod_small _ _ B) at 2.
        rewrite <-?Z.land_ones by blia.
        Z.bitblast; subst; cbn.
        rewrite (Z.testbit_neg_r _ (i - 8 * Z.of_nat n)) by blia.
        reflexivity. }
  Qed.

End BigEndian.

Arguments combine: simpl never.
Arguments split: simpl never.


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


(**
フィボナッチ数の最大公約数 (GCD of Fibonacci Numbers)
============================

@suharahiromichi

2022/01/21

2022/01/29 GCDの帰納法について修正した。
*)

(**
このソースは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/math/ssr_fib_3.v
*)

(**
# はじめに

m番めとn番めフィボナッチ数の最大公約数は、mとnの最大公約数番めのフィボナッチ数に等しい、
という定理があります。

```math
gcd(F_m, F_n) = F_{gcd(m, n)}

```

これは エドゥアール・リュカ (ルーカス）が最初に報告したのを
クヌース先生が紹介して広まったのだそうです。
TAOCP[2]に掲載されているようですが、私が読んだのは [1]と[1'] のほうで、
証明は演習問題(6.27)になっています。

そこで、早速答えをみると、
フィボナッチ数の加法定理に相当する式から、「$ m > n $
ならば、$ gcd(F_m, F_n) = gcd(F_{m - n}, F_n) $
であることに注意して、帰納法使って証明せよ」、とだけ書いてあります。

証明を集めたサイト[3]を見ても書いてあることは同じで、[4]
はもう少し詳しいですが、帰納法のところは証明というより説明になっています。

では、この定理の証明をCoqでやってみましょう、とりあえず、以下の方針でおこないます。

1. gcdに関する帰納法が肝なので、そこは Coq の Functional Induction [5] に任せる。

2. 1.のためには、Function コマンドで自分でフィボナッチ数を定義する必要がある。
それも [5] を参考にした。

3. MathComp の GCDに関する豊富な補題を使うために、2.の定義と
MathCompのGCDの定義が同じであることを証明しておく。

MathCompで証明をするならば、MathCompで定義されている
自然数の最大公約数の関数 gcdn について、なんらかのかたちで帰納法の原理を用意するのが
正しいアプローチですが、それは [7] を参照してください。

また、フィボナッチ数の加法定理については、[6] で証明しているため、証明は省略します。
*)

From mathcomp Require Import all_ssreflect.
Require Import FunInd.                      (* Functional Scheme *)
Require Import Recdef.                      (* Function *)
Require Import Wf_nat.                      (* wf *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

Section Fib3.

(**
# フィボナッチ数の定義と定理
*)
  Function fib (n : nat) : nat :=
    match n with
    | 0 => 0
    | 1 => 1
    | (m.+1 as pn).+1 => fib m + fib pn (* fib n.-2 + fib n.-1 *)
    end.

(**
1個分のフィボナッチ数の計算
 *)
  Lemma fib_n n : fib n.+2 = fib n + fib n.+1.
  Proof.
    done.
  Qed.

(**
隣り合ったフィボナッチ数は互いに素である。
*)
  Lemma fib_coprime (n : nat) : coprime (fib n) (fib n.+1).
  Proof.
    rewrite /coprime.
    elim: n => [//= | n IHn].
    rewrite fib_n.
      by rewrite gcdnDr gcdnC.
  Qed.

(**
フィボナッチ数列の加法定理
*)
  Lemma fib_addition n m :
    1 <= m -> fib (n + m) = fib m * fib n.+1 + fib m.-1 * fib n.
  Proof.
    (* see. ssr_fib_2.v *)
  Admitted.                                 (* OK *)

(**
# GCDの定義と定理
*)
(**
Function を使って定義します。
*)
  Function gcd (m n : nat) {wf lt m} : nat :=
    match m with
    | 0 => n
    | _ => gcd (n %% m) m
    end.
  Proof.
    - move=> m n m0 _.
      apply/ltP.
        by rewrite ltn_mod.
    - by apply: lt_wf.
  Qed.

(**
MathComp の gcdn を同じであることを証明する。
*)
  Lemma gcdE m n : gcdn m n = gcd m n.
  Proof.
    functional induction (gcd m n).
    - by rewrite gcd0n.
    - rewrite -IHn0.
        by rewrite gcdnC gcdn_modl.
  Qed.

(**
GCDの可換性
*)
  Check gcdnC : forall m n, gcdn m n = gcdn n m.
  Lemma gcdC m n : gcd m n = gcd n m.
  Proof.
      by rewrite -2!gcdE gcdnC.
  Qed.

(**
GCDの簡単な性質
*)
  Lemma gcd0m m : gcd 0 m = m.
  Proof.
      by rewrite gcd_equation.            (* gcd の定義で展開する。 *)
  Qed.

  Lemma gcdmm m : gcd m m = m.
  Proof.
    case: m => [| m].
    - by rewrite gcd_equation.
    - by rewrite gcd_equation modnn gcd0m.
  Qed.

  Lemma gcdnn_gcd0n n : gcd n n = gcd 0 n.
  Proof.
      by rewrite gcdmm gcd0m.
  Qed.

  Check gcdnMDl : forall k m n : nat, gcdn m (k * m + n) = gcdn m n.
  Lemma gcdMDl (k m n : nat) : gcd m (k * m + n) = gcd m n.
  Proof.
      by rewrite -2!gcdE gcdnMDl.
  Qed.

  Check Gauss_gcdl : forall p m n : nat, coprime p n -> gcdn p (m * n) = gcdn p m.
  Lemma Gauss_gcdl' p m n : coprime p n -> gcd p (m * n) = gcd p m.
  Proof.
    rewrite -2!gcdE.
      by apply: Gauss_gcdl.
  Qed.

(**
# フィボナッチ数のGCD
*)

(**
GKPの解答にある、``m > n`` ならば ``gcd (fib m) (fib n) = gcd (fib (m - n)) (fib n)``
と同じものを証明するが、そのために ``m`` を ``0`` と非0で振り分ける。
 *)
  Lemma fib_lemma_gkp' m n :
    1 <= m -> gcd (fib (n + m)) (fib n) = gcd (fib m) (fib n).
  Proof.
    move=> H.
    rewrite fib_addition //.
    rewrite gcdC addnC gcdMDl.
    rewrite Gauss_gcdl'.
    - by rewrite gcdC.
    - by apply: fib_coprime.
  Qed.

  Lemma fib_lemma_gkp m n :
    gcd (fib (n + m)) (fib n) = gcd (fib m) (fib n).
  Proof.
    case: m => [| m].
    - rewrite addn0 /=.
        by apply: gcdnn_gcd0n.
    - rewrite fib_lemma_gkp' //=.
  Qed.

(**
gcdnMDl のフィボナッチ数版
*)
  Check gcdnMDl : forall k m n : nat, gcdn m (k * m + n) = gcdn m n.
  Lemma fib_gcdMDl n q r :
    gcd (fib (q * n + r)) (fib n) = gcd (fib n) (fib r).
  Proof.
    elim: q => [| q IHq].
    - rewrite mul0n add0n.
      rewrite gcdC.
      done.
    - Search _ (_.+1 * _).
      rewrite mulSn -addnA.
      rewrite [LHS]fib_lemma_gkp.
      done.
  Qed.

(**
gcdn_modr のフィボナッチ数版
*)
  Check gcdn_modr : forall m n : nat, gcdn m (n %% m) = gcdn m n.
  Lemma fin_gcd_modr m n :
    gcd (fib m) (fib n) = gcd (fib n) (fib (m %% n)).
  Proof.
    move: (fib_gcdMDl n (m %/ n) (m %% n)).
    rewrite -divn_eq.
    done.
  Qed.

(**
# 証明したいもの

$ F_0 = 0 $ や $ F_1 = 1 $ でも成り立つことを確認しておく。
*)
  Compute gcdn 0 0.                         (* 0 *)
  Compute gcdn 1 0.                         (* 1 *)
  Compute gcdn 0 1.                         (* 1 *)
  Compute gcdn 1 1.                         (* 1 *)

  Goal gcd (fib 1) (fib 0) = fib (gcd 1 0).
  Proof.
    rewrite gcd_equation //=.
      by rewrite gcd_equation.
  Qed.

(**
functional induction を使って証明します。
*)
  Theorem gcd_fib__fib_gcd (m n : nat) : gcd (fib m) (fib n) = fib (gcd m n).
  Proof.
    rewrite gcdC.
    functional induction (gcd m n).
    - rewrite gcdC.
      rewrite gcd_equation.
      done.
    (*
  IHn0 : gcd (fib m) (fib (n %% m)) = fib (gcd (n %% m) m)
  ============================
  gcd (fib n) (fib m) = fib (gcd (n %% m) m)
     *)
    - rewrite fin_gcd_modr.
      done.
  Qed.

End Fib3.

Section Fib3_2.
(**
# おまけ

Coq Tokyo 終了後に教えてもらった GCD の帰納法
*)
  Lemma my_gcdn_ind (P : nat -> nat -> nat -> Prop) :
    (forall n, P 0 n n) ->
    (forall m n, P (n %% m) m (gcdn (n %% m) m) -> P m n (gcdn m n)) ->
    forall m n, P m n (gcdn m n).
  Proof.
    move => H0 Hmod.
    elim/ltn_ind => [[| m ]] // H n.
    - have -> : gcdn 0 n = n by elim: n.
      done.
    - apply : Hmod.
      exact : H (ltn_mod _ _) _.
  Qed.

(**
これを使うと functional induction を使わずに証明できます。

[7] を参照してください。
*)
End Fib3_2.

(**
# 文献

[1] Graham, Knuth, Patashnik "Concrete Mathematics", Second Edition

[1'] 有澤、安村、萩野、石畑訳、「コンピュータの数学」共立出版

[2] D.E.Knuth, "The Art of Computer Programming: Vol.1: Fundamental Algorithms (3rd ed.) "

[3] "GCD of Fibonacci Numbers"、https://proofwiki.org/wiki/GCD_of_Fibonacci_Numbers

[4] ぱるち、「フィボナッチ数列で互除法っぽいこと」、https://mathlog.info/articles/278

[5] 名古屋大学 2021年度秋・数理解析・計算機数学 IV (同 概論IV) "Mathcomp, 自己反映と数論の証明"、
https://www.math.nagoya-u.ac.jp/~garrigue/lecture/2021_AW/ssrcoq5.pdf

[6] https://github.com/suharahiromichi/coq/blob/master/math/ssr_fib_2.v

[7] https://github.com/suharahiromichi/coq/blob/master/math/ssr_fib_3_2.v
*)

(* END *)