(* Fermat の小定理 *)

(* 2014_3_30 *)

(* suahrahiromichi@gmail.com *)

From mathcomp Require Import eqtype ssrnat fintype div bigop prime binomial.

Require Import ssreflect ssrfun ssrbool.

(**

 全体の証明は、

 http://ja.wikipedia.org/wiki/フェルマーの小定理

 証明(1) に沿う、つもり。

 *)

(* この補題は、Coqによる定理証明 2013 12, p.14 *)

(* 乱数列の網羅性 著者：坂口和彦さん *)

Lemma expSS a p :

  a.+1 ^ p.+1 =

  (a ^ p.+1).+1 + \sum_(1 <= k < p.+1 | 0 < k < p.+1) 'C(p.+1, k) * a ^ k.

Proof.

  rewrite -add1n Pascal big_ord_recl big_ord_recr /= /bump /= !add1n

                 bin0 binn subn0 subnn !mul1n exp1n add1n -addnS addnC.

  rewrite -big_nat.

  rewrite (big_addn 0 p.+1 1) subn1 /= big_mkord.

  by congr (_ + _); apply eq_bigr => m _; rewrite exp1n add1n addn1 mul1n.

Qed.

(* pが素数なら、二項定理を使って (m + 1) ^ p を展開したときの、

  m^p + C + 1 の 「C」がpで割りきれることを証明する。 *)

Lemma bino_body__p m p :

  prime p ->

  (\sum_(1 <= i < p | 0 < i < p) 'C(p, i) * m ^ i) %% p == 0.

Proof.

  apply big_ind => //.

    by rewrite mod0n.

  move=> m1 m2 H1 H2 Hp.

    by apply dvdn_add; [apply H1, Hp | apply H2, Hp].

  move=> i H0 Hp.

    by apply dvdn_mulr, prime_dvd_bin.

Qed.

Lemma mod_m_1p__mp_1 m p :

  prime p.+1 -> m.+1 ^ p.+1 = (m ^ p.+1).+1 %[mod p.+1].

Proof.

  move=> Hp.

  apply/eqP.

  rewrite expSS addSn (eqn_modDl 1)

  -{2}(addn0 (m ^ p.+1)) (eqn_modDl (m ^ p.+1)).

  apply/eqP.

  have H := (bino_body__p m p.+1 Hp).

  move/eqP in H.

  by rewrite mod0n.

Qed.

Lemma mod_1n a b p : a = b %[mod p] -> a.+1 = b.+1 %[mod p].

Proof.

  move=> /eqP H.                            (* move/eqP => H *)

  apply/eqP.

  by rewrite -(addn1 a) -(addn1 b) (eqn_modDr 1 a b p).

Qed.

Theorem Fermat a p:

  prime p.+1 -> a ^ p.+1 = a %[mod p.+1].

Proof.

  move=> Hp.

  elim: a => [|a].

  (* a = 0 *)

  by rewrite exp0n.

  elim: a => [|a] H0.

  (* a = 1 *)

  by rewrite exp1n.

  move=> H1 {H0} {H1}.

  elim: a => [|a].

  (* a = 2 *)

  rewrite (mod_m_1p__mp_1 1 p); last done.  (* last は prime p *)

    by rewrite exp1n.

  (* a = k + 1 *)

  move=> H2.

  rewrite (mod_m_1p__mp_1 a.+2); last done. (* last は prime p *)

  rewrite -addn3.

  Check (mod_1n (a.+2 ^ p.+1) (a + 2) p.+1).

  rewrite (mod_1n (a.+2 ^ p.+1) (a + 2) p.+1).

    by rewrite addn2 addn3.

      by rewrite addn2.

Qed.

(* 使わなかった補題 *)

Lemma mod_2_3n a b p : a = b.+2 %[mod p] -> a.+1 = b.+3 %[mod p].

Proof.

  move=> H.

  apply/eqP.

  move/eqP in H.

  Check eqn_modDr 1 a b.+2 p.

  rewrite -(eqn_modDr 1 a b.+2 p) in H.

  rewrite -addn2 in H.

  rewrite -(addnA b 2 1) in H.

  rewrite addn3 in H.

  rewrite addn1 in H.

  done.

Qed.

Lemma modn_trans l m n d :

  l = m %[mod d] -> m = n %[mod d] -> l = n %[mod d].

Proof.

  move=> Hlm Hmn.

  by rewrite Hlm.

Qed.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Init.Byte.
Require Import Coq.NArith.NArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Cava.Util.Tactics.
Require Coq.Vectors.Vector. (* not imported due to name collisions with List *)

Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.BitArithmeticProperties.
Require Import Cava.Util.List.
Require Import Cava.Util.Vector.
Require Import AesSpec.Polynomial.
Require Import AesSpec.PolynomialProperties.
Import Vector.VectorNotations.
Import ListNotations.
Local Open Scope list_scope.

Section ByteField.
  (* Representation of bytes as polynomials with boolean coefficients;
     relies on N2Bv being little-endian *)
  Definition byte_to_poly (b : byte) : poly bool :=
    Vector.to_list (N2Bv_sized 8 (Byte.to_N b)).
  Definition poly_to_byte (x : poly bool) : byte :=
    match Byte.of_N (N.of_list_bits x) with
    | Some b => b
    | None => Byte.x00 (* error; should not get here! *)
    end.

  (* Operations in GF(2) *)
  Local Instance bitops : FieldOperations bool :=
    {| fzero := false;
       fone := true;
       fis_zero := negb;
       fopp := fun b => b;
       fadd := xorb;
       fsub := xorb;
       fmul := andb;
       fdiv := fun b1 _ => b1; (* divisor must be 1, otherwise division by 0 *)
       fmodulo := fun b1 b2 => xorb b1 (andb b2 b1); (* b1 mod b2 = b1 - b2 * (b1 / b2) *)
    |}.

  (* FIPS 197: 4.2 Multiplication

     In the polynomial representation, multiplication in GF(2^8) (denoted by •)
     corresponds with the multiplication of polynomials modulo an irreducible
     polynomial of degree 8. A polynomial is irreducible if its only divisors
     are one and itself. For the AES algorithm, this irreducible polynomial is

                             m(x) = x^8 + x^4 + x^3 + x + 1                (4.1)

     or {01}{1b} in hexadecimal notation. *)

  (* Modulus for GF(2^8): m(x) = x^8 + x^4 + x^3 + x + 1 *)
  Definition m : poly bool :=
    [true; true; false; true; true; false; false; false; true].

  (* Operations in GF(2^8) *)
  Local Instance byteops : FieldOperations byte :=
    {| fzero := Byte.x00;
       fone := Byte.x01;
       fis_zero := Byte.eqb x00;
       fopp := fun b => b;
       fadd :=
         fun a b => poly_to_byte (add_poly (byte_to_poly a) (byte_to_poly b));
       fsub :=
         fun a b => poly_to_byte (sub_poly (byte_to_poly a) (byte_to_poly b));
       fmul :=
         fun a b =>
           let ab := mul_poly (byte_to_poly a) (byte_to_poly b) in
           poly_to_byte (modulo_poly ab m);
       fdiv :=
         fun a b => poly_to_byte (div_poly (byte_to_poly a) (byte_to_poly b));
       fmodulo :=
         fun a b => poly_to_byte (modulo_poly (byte_to_poly a) (byte_to_poly b));
    |}.

  (* Test case from FIPS : {57} ∘ {83} = {c1} *)
  Goal (let b57 : byte := Byte.x57 in
        let b83 : byte := Byte.x83 in
        let bc1 : byte := Byte.xc1 in
        fmul b57 b83 = bc1).
  Proof. vm_compute. reflexivity. Qed.
End ByteField.

Section Spec.
  Context (bytes_per_word := 4%nat) {Nb : nat}.
  Local Notation column := (Vector.t byte bytes_per_word).
  Local Notation state := (Vector.t column Nb).
  Local Existing Instance byteops.

  (* Convert columns to and from polynomials with coeffs in GF(2^8) *)
  Definition column_to_poly : column -> poly byte := Vector.to_list.
  Definition poly_to_column (c : poly byte) : column :=
    resize_default fzero _ (Vector.of_list c).

  (* Modulus : x^4 + 1 *)
  Definition modulus := [x01; x00; x00; x00; x01]%list.

  (* Multiplication modulo x^4 + 1 *)
  Definition mulmod (x y : poly byte) : poly byte :=
    modulo_poly (mul_poly x y) modulus.

  (* 5.1.3 MixColumns() Transformation

     The MixColumns() transformation operates on the State column-by-column,
     treating each column as a four-term polynomial as described in
     Sec. 4.3. The columns are considered as polynomials over GF(2^8) and
     multiplied modulo x^4 + 1 with a fixed polynomial a(x), given by

               a(x) = {03}x^3 + {01}x^2 + {01}x + {02} (5.5)

     [...]
     As a result of this multiplication, the four bytes in a column are replaced
     by the following:

               c'0 = ({02} ∙ c0) ⊕ ({03} ∙ c1) ⊕ c2 ⊕ c3
               c'1 = c0 ⊕ ({02} ∙ c1) ⊕ ({03} ∙ c2) ⊕ c3
               c'2 = c0 ⊕ c1 ⊕ ({02} ∙ c2) ⊕ ({03} ∙ c3)
               c'3 = ({03} ∙ c0) ⊕ c1 ⊕ c2 ⊕ ({02} ∙ c3)

     (∙ and ⊕ above are multiplication and addition in GF(2^8), respectively)
   *)

  (* MixColumns on a single column using matrix-based formula *)
  Definition mix_single_column (c : column) : column :=
    let sum := Vector.fold_left fadd fzero in
    let prod := Vector.map2 fmul in
    [ sum (prod [x02; x03; x01; x01]%vector c);
      sum (prod [x01; x02; x03; x01]%vector c);
      sum (prod [x01; x01; x02; x03]%vector c);
      sum (prod [x03; x01; x01; x02]%vector c)
    ]%vector.

  (* Polynomial version (slower but possibly helpful for proofs) :*)
  Definition mix_single_column_poly (c : column) : column :=
    let a : poly byte := [x02;x01;x01;x03] in
    let c := column_to_poly c in
    let ac := mulmod a c in
    poly_to_column ac.

  Definition mix_columns : state -> state := Vector.map mix_single_column.

  (* 5.3.3 InvMixColumns() Transformation

     InvMixColumns() is the inverse of the MixColumns() transformation.
     InvMixColumns() operates on the State column-by-column, treating each
     column as a four- term polynomial as described in Sec. 4.3. The columns are
     considered as polynomials over GF(2^8) and multiplied modulo x^4 + 1 with a
     fixed polynomial a^(-1)(x), given by

              a^(-1)(x) = {0b}x 3 + {0d}x 2 + {09}x + {0e}.                (5.9)

     [...]
     As a result of this multiplication, the four bytes in a column are replaced
     by the following:

               c'0 = ({0e} ∙ c0) ⊕ ({0b} ∙ c1) ⊕ ({0d} ∙ c2) ⊕ ({09} ∙ c3)
               c'1 = ({09} ∙ c0) ⊕ ({0e} ∙ c1) ⊕ ({0b} ∙ c2) ⊕ ({0d} ∙ c3)
               c'2 = ({0d} ∙ c0) ⊕ ({09} ∙ c1) ⊕ ({0e} ∙ c2) ⊕ ({0b} ∙ c3)
               c'3 = ({0b} ∙ c0) ⊕ ({0d} ∙ c1) ⊕ ({09} ∙ c2) ⊕ ({0e} ∙ c3)
 *)

  (* InvMixColumns on a single column using matrix-based formula *)
  Definition inv_mix_single_column (c : column) : column :=
    let sum := Vector.fold_left fadd fzero in
    let prod := Vector.map2 fmul in
    [ sum (prod [x0e; x0b; x0d; x09]%vector c);
      sum (prod [x09; x0e; x0b; x0d]%vector c);
      sum (prod [x0d; x09; x0e; x0b]%vector c);
      sum (prod [x0b; x0d; x09; x0e]%vector c)
    ]%vector.

  Definition inv_mix_columns : state -> state := Vector.map inv_mix_single_column.
End Spec.

Section MixColumnsTests.
  Existing Instance byteops.
  Local Open Scope vector_scope.

  (* Check that mix_single_column with polynomials is the same as with matrices *)
  Goal (let c := [x00; x01; x02; x03] in
        mix_single_column_poly c = mix_single_column c).
  Proof. vm_compute. reflexivity. Qed.

  (* test state :
     0
     1
     2
     3 *)
  Goal (let st := [ [x00; x01; x02; x03] ] in (* column-major form *)
        inv_mix_columns (mix_columns st) = st).
  Proof. vm_compute. reflexivity. Qed.

  (* test state :
     0 4 8  12
     1 5 9  13
     2 6 10 14
     3 7 11 15 *)
  Goal ((* state, in column-major form *)
        let st :=
            [ [x00; x01; x02; x03];
              [x04; x05; x06; x07];
              [x08; x09; x0a; x0b];
              [x0c; x0d; x0e; x0f] ] in
        inv_mix_columns (mix_columns st) = st).
  Proof. vm_compute. reflexivity. Qed.
End MixColumnsTests.

Section ByteFieldProperties.
  Existing Instances bitops byteops.
  Local Infix "*" := fmul.
  Local Infix "+" := fadd.
  Local Infix "-" := fsub.

  (* Declare a full ring because we need subtraction for some goals *)
  Definition bit_theory : ring_theory (R:=bool) fzero fone fadd fmul fsub fopp eq
    := BoolTheory.
  Add Ring bitring : bit_theory.

  (* Declare semi-ring for polynomial proof preconditions *)
  Definition BitTheory : semi_ring_theory (R:=bool) fzero fone fadd fmul eq.
  Proof.
    constructor; intros; cbn [fzero fone fadd fmul bitops];
      repeat match goal with x : bool |- _ => destruct x end; reflexivity.
  Qed.

  Lemma poly_to_byte_to_poly p :
    (length p = 8)%nat -> byte_to_poly (poly_to_byte p) = p.
  Proof.
    cbv [poly_to_byte byte_to_poly]; intros.
    destruct_lists_by_length.
    repeat match goal with x : bool |- _ => destruct x end;
      vm_compute; reflexivity.
  Qed.

  Lemma poly_to_byte_to_poly_strip_zeroes p n :
    length p = 8%nat ->
    byte_to_poly (poly_to_byte (p ++ repeat false n)) = p.
  Proof.
    cbv [poly_to_byte byte_to_poly]; intros.
    rewrite N_of_list_bits_app, N_of_list_bits_zero.
    rewrite N.mul_0_r, N.add_0_r.
    apply poly_to_byte_to_poly; auto.
  Qed.

  Lemma byte_to_poly_length b : length (byte_to_poly b) = 8%nat.
  Proof. cbv [byte_to_poly]; length_hammer. Qed.

  Lemma byte_to_poly_inj b1 b2 : byte_to_poly b1 = byte_to_poly b2 -> b1 = b2.
  Proof.
    cbv [byte_to_poly]. intro Heq.
    apply to_list_inj in Heq.
    assert (forall b, N.size_nat (Byte.to_N b) <= 8%nat)
      by (intro b; destruct b; vm_compute; lia).
    apply N2Bv_sized_eq_iff in Heq; [ | solve [auto] .. ].
    apply Byte.to_of_N_iff in Heq.
    rewrite Byte.of_to_N in Heq.
    congruence.
  Qed.

  (* Extra hints for length_hammer *)
  Hint Rewrite @add_poly_length byte_to_poly_length
       using solve [eauto] : push_length.
  Hint Rewrite @mul_poly_length
       using (try apply BitTheory; try apply length_pos_nonnil; length_hammer)
    : push_length.
  Hint Resolve byte_to_poly_length : length.

  (* Some lemmas to simplify boolean expressions *)
  Lemma if_id (b : bool) : (if b then true else false) = b.
  Proof. destruct b; reflexivity. Qed.
  Lemma if_negb (b : bool) : (if b then false else true) = negb b.
  Proof. destruct b; reflexivity. Qed.
  Lemma if_false_formula (b : bool) : (if b then negb b else b) = false.
  Proof. destruct b; reflexivity. Qed.

  (* Complete formula for multiplication of 8-bit vectors in GF(2^8) *)
  Definition mul8 (p q : list bool) : list bool :=
    let p0 := nth 0 p false in
    let p1 := nth 1 p false in
    let p2 := nth 2 p false in
    let p3 := nth 3 p false in
    let p4 := nth 4 p false in
    let p5 := nth 5 p false in
    let p6 := nth 6 p false in
    let p7 := nth 7 p false in
    let q0 := nth 0 q false in
    let q1 := nth 1 q false in
    let q2 := nth 2 q false in
    let q3 := nth 3 q false in
    let q4 := nth 4 q false in
    let q5 := nth 5 q false in
    let q6 := nth 6 q false in
    let q7 := nth 7 q false in
    [ (p0 * q0);
    (p0 * q1) + (p1 * q0);
    (p0 * q2) + (p1 * q1) + (p2 * q0);
    (p0 * q3) + (p1 * q2) + (p2 * q1) + (p3 * q0);
    (p0 * q4) + (p1 * q3) + (p2 * q2) + (p3 * q1) + (p4 * q0);
    (p0 * q5) + (p1 * q4) + (p2 * q3) + (p3 * q2) + (p4 * q1) + (p5 * q0);
    (p0 * q6) + (p1 * q5) + (p2 * q4) + (p3 * q3) + (p4 * q2) + (p5 * q1) + (p6 * q0);
    (p0 * q7) + (p1 * q6) + (p2 * q5) + (p3 * q4) + (p4 * q3) + (p5 * q2) + (p6 * q1) + (p7 * q0);
    (p1 * q7) + (p2 * q6) + (p3 * q5) + (p4 * q4) + (p5 * q3) + (p6 * q2) + (p7 * q1);
    (p2 * q7) + (p3 * q6) + (p4 * q5) + (p5 * q4) + (p6 * q3) + (p7 * q2);
    (p3 * q7) + (p4 * q6) + (p5 * q5) + (p6 * q4) + (p7 * q3);
    (p4 * q7) + (p5 * q6) + (p6 * q5) + (p7 * q4);
    (p5 * q7) + (p6 * q6) + (p7 * q5);
    (p6 * q7) + (p7 * q6);
    (p7 * q7)
    ].

  Lemma mul8_correct p q :
    length p = 8%nat -> length q = 8%nat ->
    mul_poly (ops:=bitops) p q = mul8 p q.
  Proof.
    intros; destruct_lists_by_length.
    vm_compute. rewrite !if_id, !if_negb.
    reflexivity.
  Qed.

  (* Modular reduction with modulus m and 15-bit input:

    round 1 (a[14]):
    a[6] -= a[14]
    a[7] -= a[14]
    a[9] -= a[14]
    a[10] -= a[14]

    round 2 (a[13]):
    a[5] -= a[13]
    a[6] -= a[13]
    a[8] -= a[13]
    a[9] -= a[13]

    round 3 (a[12]):
    a[4] -= a[12]
    a[5] -= a[12]
    a[7] -= a[12]
    a[8] -= a[12]

    round 4 (a[11]):
    a[3] -= a[11]
    a[4] -= a[11]
    a[6] -= a[11]
    a[7] -= a[11]

    round 5 (a[10]):
    a[2] -= a[10]
    a[3] -= a[10]
    a[5] -= a[10]
    a[6] -= a[10]

    round 6 (a[9]):
    a[1] -= a[9]
    a[2] -= a[9]
    a[4] -= a[9]
    a[5] -= a[9]

    round 7 (a[8]):
    a[0] -= a[8]
    a[1] -= a[8]
    a[3] -= a[8]
    a[4] -= a[8]

    final in terms of initial:

    a'[8]  = a[8]  - a[13] - a[12]
    a'[9]  = a[9]  - a[14] - a[13]
    a'[10] = a[10] - a[14]

    a[0] = a[0] - a'[8]
    a[1] = a[1] - a'[9] - a'[8]
    a[2] = a[2] - a'[10] - a'[9]
    a[3] = a[3] - a[11] - a'[10] - a'[8]
    a[4] = a[4] - a[12] - a[11]  - a'[9]  - a'[8]
    a[5] = a[5] - a[13] - a[12]  - a'[10] - a'[9]
    a[6] = a[6] - a[14] - a[13]  - a[11] - a'[10]
    a[7] = a[7] - a[14] - a[12]  - a[11]

   *)
  Definition modulo15 (p : list bool) : list bool :=
    let p0 := nth 0 p false in
    let p1 := nth 1 p false in
    let p2 := nth 2 p false in
    let p3 := nth 3 p false in
    let p4 := nth 4 p false in
    let p5 := nth 5 p false in
    let p6 := nth 6 p false in
    let p7 := nth 7 p false in
    let p8 := nth 8 p false in
    let p9 := nth 9 p false in
    let p10 := nth 10 p false in
    let p11 := nth 11 p false in
    let p12 := nth 12 p false in
    let p13 := nth 13 p false in
    let p14 := nth 14 p false in
    (* redefine p8, p9, and p10 to their final values *)
    let p8 := p8 - p13 - p12 in
    let p9 := p9 - p14 - p13 in
    let p10 := p10 - p14 in
    [ p0 - p8;
    p1 - p9 - p8;
    p2 - p10 - p9;
    p3 - p11 - p10 - p8;
    p4 - p12 - p11 - p9 - p8;
    p5 - p13 - p12 - p10 - p9;
    p6 - p14 - p13 - p11 - p10;
    p7 - p14 - p12 - p11
    ].

  Lemma modulo15_correct p :
    length p = 15%nat -> byte_to_poly (poly_to_byte (modulo_poly p m)) = modulo15 p.
  Proof.
    intros. set (X:=modulo_poly p m).
    destruct_lists_by_length.
    vm_compute in X. subst X.
    (* simplify boolean expressions *)
    rewrite !Tauto.if_same, !if_id, !if_negb, !if_false_formula.
    (* strip zeroes *)
    match goal with
    | |- byte_to_poly
          (poly_to_byte
             [?x0;?x1;?x2;?x3;?x4;?x5;?x6;?x7;
              false;false;false;false;false;false;false]) = _ =>
      let H := fresh in
      pose proof
           (poly_to_byte_to_poly_strip_zeroes
              [x0;x1;x2;x3;x4;x5;x6;x7] 7) as H;
        cbn [repeat app] in H; rewrite H by reflexivity;
          clear H
    end.
    cbv [modulo15 nth].
    fequal_list; clear;
      repeat match goal with b : bool |- _ => destruct b end;
      vm_compute; reflexivity.
  Qed.

  (* Explicit formula for addition of two 8-bit vectors *)
  Definition add8 (p q : list bool) : list bool :=
    let p0 := nth 0 p false in
    let p1 := nth 1 p false in
    let p2 := nth 2 p false in
    let p3 := nth 3 p false in
    let p4 := nth 4 p false in
    let p5 := nth 5 p false in
    let p6 := nth 6 p false in
    let p7 := nth 7 p false in
    let q0 := nth 0 q false in
    let q1 := nth 1 q false in
    let q2 := nth 2 q false in
    let q3 := nth 3 q false in
    let q4 := nth 4 q false in
    let q5 := nth 5 q false in
    let q6 := nth 6 q false in
    let q7 := nth 7 q false in
    [ p0 + q0;
    p1 + q1;
    p2 + q2;
    p3 + q3;
    p4 + q4;
    p5 + q5;
    p6 + q6;
    p7 + q7
    ].

  Lemma add8_correct p q :
    length p = 8%nat -> length q = 8%nat ->
    add_poly p q = add8 p q.
  Proof. intros; destruct_lists_by_length; reflexivity. Qed.

  Local Ltac generalize_bytes_as_polynomials :=
    repeat lazymatch goal with
           | |- context [byte_to_poly ?b] =>
             pose proof (byte_to_poly_length b);
             generalize dependent (byte_to_poly b);
             intros
           end.

  Lemma byte_mul_assoc (a b c : byte) :
    fmul a (fmul b c) = fmul (fmul a b) c.
  Proof.
    cbv [fmul fadd byteops]. apply byte_to_poly_inj.
    rewrite !modulo15_correct, !mul8_correct by length_hammer.
    generalize_bytes_as_polynomials. destruct_lists_by_length.
    lazy [mul8 nth modulo15].
    (* use ring to prove that each element of the list is equal *)
    fequal_list; clear.
    Time all:ring.
  Qed.

  Lemma byte_mul_distr_l (a b c : byte) :
    fmul (fadd a b) c = fadd (fmul a c) (fmul b c).
  Proof.
    cbv [fmul fadd byteops].
    apply byte_to_poly_inj.
    rewrite !modulo15_correct by length_hammer.
    rewrite !mul8_correct by length_hammer.
    rewrite !add8_correct by length_hammer.
    rewrite !poly_to_byte_to_poly by reflexivity.
    pose proof (byte_to_poly_length a).
    pose proof (byte_to_poly_length b).
    pose proof (byte_to_poly_length c).
    generalize dependent (byte_to_poly a); intros A ?.
    generalize dependent (byte_to_poly b); intros B ?.
    generalize dependent (byte_to_poly c); intros C ?.
    destruct_lists_by_length.
    lazy [mul8 add8 nth modulo15].
    (* use ring to prove that each element of the list is equal *)
    fequal_list; clear; ring.
  Qed.

  Definition ByteTheory : semi_ring_theory (R:=byte) fzero fone fadd fmul eq.
  Proof.
    constructor; cbn [fadd fmul byteops].
    { intro b; destruct b; reflexivity. }
    { intros. f_equal. apply @add_poly_comm, BitTheory. }
    { intros. rewrite !poly_to_byte_to_poly by length_hammer.
      f_equal. apply @add_poly_assoc, BitTheory. }
    { intro b; destruct b; vm_compute; reflexivity. }
    { intro b; destruct b; vm_compute; reflexivity. }
    { intros; do 2 f_equal. apply @mul_poly_comm, BitTheory. }
    { apply byte_mul_assoc. }
    { apply byte_mul_distr_l. }
  Qed.
End ByteFieldProperties.
Hint Rewrite @add_poly_length byte_to_poly_length
     using solve [eauto] : push_length.

Section Properties.
  Existing Instance byteops.
  Add Ring bytering : ByteTheory.
  Local Open Scope poly_scope.

  Definition sum (p : poly byte) : byte := List.fold_left fadd p fzero.
  Definition prod (p q : poly byte) : poly byte := map2 fmul p q.

  (* multiplication modulo x^4-1 for 4-digit polynomials *)
  Definition matrix_mulmod (p q : poly byte) : poly byte :=
    let p0 := nth 0 p fzero in
    let p1 := nth 1 p fzero in
    let p2 := nth 2 p fzero in
    let p3 := nth 3 p fzero in
    let q0 := nth 0 q fzero in
    let q1 := nth 1 q fzero in
    let q2 := nth 2 q fzero in
    let q3 := nth 3 q fzero in
    [ sum (prod [q0;q3;q2;q1] [p0;p1;p2;p3]);
      sum (prod [q1;q0;q3;q2] [p0;p1;p2;p3]);
      sum (prod [q2;q1;q0;q3] [p0;p1;p2;p3]);
      sum (prod [q3;q2;q1;q0] [p0;p1;p2;p3])
    ].

  Hint Unfold matrix_mulmod sum prod nth map2 fold_left : matrix_mulmod.

  Lemma matrix_mulmod_assoc a b c :
    length a = 4%nat -> length b = 4%nat -> length c = 4%nat ->
    matrix_mulmod a (matrix_mulmod b c) = matrix_mulmod (matrix_mulmod a b) c.
  Proof.
    intros; destruct_lists_by_length.
    autounfold with matrix_mulmod.
    fequal_list; ring.
  Qed.

  Lemma matrix_mulmod_1_l p :
    length p = 4%nat ->
    matrix_mulmod [fone;fzero;fzero;fzero] p = p.
  Proof.
    intros; destruct_lists_by_length.
    autounfold with matrix_mulmod.
    fequal_list; ring.
  Qed.

  Lemma matrix_mulmod_distr_l a b c :
    length a = 4%nat -> length b = 4%nat -> length c = 4%nat ->
    matrix_mulmod a (map2 fadd b c)
    = map2 fadd (matrix_mulmod a b) (matrix_mulmod a c).
  Proof.
    intros; destruct_lists_by_length.
    autounfold with matrix_mulmod.
    fequal_list; ring.
  Qed.

  Lemma mix_single_column_is_matrix_mulmod d c :
    mix_single_column c = of_list_sized d 4%nat
                                        (matrix_mulmod [x02;x01;x01;x03]
                                                       (Vector.to_list c)).
  Proof.
    cbv [mix_single_column]. constant_vector_simpl c.
    autorewrite with push_to_list.
    autounfold with matrix_mulmod.
    cbv [of_list_sized Vector.of_list].
    rewrite resize_default_id.
    fequal_vector; ring.
  Qed.

  Lemma inv_mix_single_column_is_matrix_mulmod d c :
    inv_mix_single_column c = of_list_sized d 4%nat
                                            (matrix_mulmod [x0e;x09;x0d;x0b]
                                                           (Vector.to_list c)).
  Proof.
    cbv [inv_mix_single_column]. constant_vector_simpl c.
    autorewrite with push_to_list.
    autounfold with matrix_mulmod.
    cbv [of_list_sized Vector.of_list].
    rewrite resize_default_id.
    fequal_vector; try ring.
  Qed.

  Lemma inverse_mix_single_column c :
    inv_mix_single_column (mix_single_column c) = c.
  Proof.
    rewrite inv_mix_single_column_is_matrix_mulmod with (d:=fzero).
    rewrite mix_single_column_is_matrix_mulmod with (d:=fzero).
    autorewrite with push_to_list.
    rewrite matrix_mulmod_assoc by length_hammer.
    match goal with
    | |- context [matrix_mulmod (cons ?a0 ?a) (cons ?b0 ?b)] =>
      compute_expr (matrix_mulmod (cons a0 a) (cons b0 b))
    end.
    rewrite matrix_mulmod_1_l by length_hammer.
    rewrite of_list_sized_to_list; reflexivity.
  Qed.

  Lemma inverse_mix_columns {Nb} (state : Vector.t (Vector.t byte 4) Nb) :
    inv_mix_columns (mix_columns state) = state.
  Proof.
    cbv [inv_mix_columns mix_columns].
    rewrite Vector.map_map.
    apply map_id_ext.
    apply inverse_mix_single_column.
  Qed.

  (* add in this field is the same as add_round_key *)
  Lemma inv_mix_columns_add_comm
        {Nb} (x y : Vector.t (Vector.t byte 4) Nb) :
    Vector.map2 (Vector.map2 fadd) (inv_mix_columns x) (inv_mix_columns y)
    = inv_mix_columns (Vector.map2 (Vector.map2 fadd) x y).
  Proof.
    cbv [inv_mix_columns]. rewrite map2_map, map_map2.
    apply map2_ext; intros.
    rewrite !inv_mix_single_column_is_matrix_mulmod with (d:=fzero).
    apply to_list_inj. autorewrite with push_to_list.
    rewrite matrix_mulmod_distr_l by length_hammer.
    reflexivity.
  Qed.
End Properties.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelflip.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearparallel.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_collinearparallel2 :
   forall A B C D E F,
   Par A B C D -> Col C D E -> Col C D F -> neq E F ->
   Par A B E F.
Proof.
intros.
assert (neq F E) by (conclude lemma_inequalitysymmetric).
assert (nCol A C D) by (forward_using lemma_parallelNC).
assert (neq C D) by (forward_using lemma_NCdistinct).
assert (neq D C) by (conclude lemma_inequalitysymmetric).
assert (Col D C E) by (forward_using lemma_collinearorder).
assert (Col D C F) by (forward_using lemma_collinearorder).
assert (Col C E F) by (conclude lemma_collinear4).
assert (Col C F E) by (forward_using lemma_collinearorder).
assert (Par A B D C) by (forward_using lemma_parallelflip).
assert (Par A B E F).
by cases on (eq E D \/ neq E D).
{
 assert (neq D F) by (conclude cn_equalitysub).
 assert (neq F D) by (conclude lemma_inequalitysymmetric).
 assert (Par A B F D) by (conclude lemma_collinearparallel).
 assert (Par A B D F) by (forward_using lemma_parallelflip).
 assert (Col C F D) by (forward_using lemma_collinearorder).
 assert (Col C F E) by (forward_using lemma_collinearorder).
 assert (Col F D E).
 by cases on (eq C F \/ neq C F).
 {
  assert (Col C D E) by (forward_using lemma_collinearorder).
  assert (Col F D E) by (conclude cn_equalitysub).
  close.
  }
 {
  assert (Col F D E) by (conclude lemma_collinear4).
  close.
  }
(** cases *)
 assert (Col D F E) by (forward_using lemma_collinearorder).
 assert (Par A B E F) by (conclude lemma_collinearparallel).
 close.
 }
{
 assert (Par A B E D) by (conclude lemma_collinearparallel).
 assert (Par A B D E) by (forward_using lemma_parallelflip).
 assert (Col D E F) by (conclude lemma_collinear4).
 assert (Par A B F E) by (conclude lemma_collinearparallel).
 assert (Par A B E F) by (forward_using lemma_parallelflip).
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


Require Import Basics.
Require Import Types.
Require Import Diagrams.Graph.
Require Import Diagrams.Diagram.
Require Import Diagrams.Cocone.

(** Parallel pairs *)

Definition parallel_pair_graph : Graph.
Proof.
  srapply (Build_Graph Bool).
  intros i j.
  exact (if i then if j then Empty else Bool else Empty).
Defined.

(** Parallel pair diagram *)

Definition parallel_pair {A B : Type} (f g : A -> B)
  : Diagram parallel_pair_graph.
Proof.
  srapply Build_Diagram.
  1: intros []; [exact A | exact B].
  intros [] [] []; [exact f | exact g].
Defined.

(** Cones on [parallel_pair]s *)

Definition Build_parallel_pair_cocone {A B Q} {f g : B -> A}
  `(q: A -> Q) (Hq: q o g == q o f)
  : Cocone (parallel_pair f g) Q.
Proof.
  srapply Build_Cocone.
  1: intros []; [exact (q o f) | exact q].
  intros [] [] []; [reflexivity | exact Hq].
Defined.


Axiom excluded_middle : forall (P : Prop), P \/ ~P.

Lemma double_negation_elimination (P : Prop) :
  ~~P -> P.
Proof.
  intros H. destruct (excluded_middle P) as [Hp | Hnp].
  - assumption.
  - contradiction.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Fairness.OrderedType.
Require Import ZArith_base.
Require Import PeanoNat.
Require Import Ascii String.
Require Import NArith Ndec.
Require Import Compare_dec.

(** * Examples of Ordered Type structures. *)

(** First, a particular case of [OrderedTypeLarge] where
    the equality is the usual one of Coq. *)

Module Type UsualOrderedTypeLarge.
 Parameter Inline t : Type.
 Definition eq := @eq t.
 Parameter Inline lt : t -> t -> Prop.
 Definition eq_refl := @eq_refl t.
 Definition eq_sym := @eq_sym t.
 Definition eq_trans := @eq_trans t.
 Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
 Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 Parameter compare : forall x y : t, Compare lt eq x y.
 Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
End UsualOrderedTypeLarge.

(** a [UsualOrderedTypeLarge] is in particular an [OrderedTypeLarge]. *)

Module UOT_to_OT (U:UsualOrderedTypeLarge) <: OrderedTypeLarge := U.

(** [nat] is an ordered type with respect to the usual order on natural numbers. *)

Module Nat_as_OT <: UsualOrderedTypeLarge.

  Definition t := nat.

  Definition eq := @eq nat.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof. unfold lt; intros; apply lt_trans with y; auto. Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof. unfold lt, eq; intros ? ? LT ->; revert LT; apply Nat.lt_irrefl. Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
    case_eq (Nat.compare x y); intro.
    - apply EQ. now apply nat_compare_eq.
    - apply LT. now apply nat_compare_Lt_lt.
    - apply GT. now apply nat_compare_Gt_gt.
  Defined.

  Definition eq_dec := eq_nat_dec.

End Nat_as_OT.

(** [Z] is an ordered type with respect to the usual order on integers. *)

Local Open Scope Z_scope.

Module Z_as_OT <: UsualOrderedTypeLarge.

  Definition t := Z.
  Definition eq := @eq Z.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt (x y:Z) := (x<y).

  Lemma lt_trans : forall x y z, x<y -> y<z -> x<z.
  Proof. exact Z.lt_trans. Qed.

  Lemma lt_not_eq : forall x y, x<y -> ~ x=y.
  Proof. intros x y LT ->; revert LT; apply Z.lt_irrefl. Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
    case_eq (x ?= y); intro.
    - apply EQ. now apply Z.compare_eq.
    - apply LT. assumption.
    - apply GT. now apply Z.gt_lt.
  Defined.

  Definition eq_dec := Z.eq_dec.

End Z_as_OT.

(** [positive] is an ordered type with respect to the usual order on natural numbers. *)

Local Open Scope positive_scope.

Module Positive_as_OT <: UsualOrderedTypeLarge.
  Definition t:=positive.
  Definition eq:=@eq positive.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := Pos.lt.

  Definition lt_trans := Pos.lt_trans.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
  intros x y H. contradict H. rewrite H. apply Pos.lt_irrefl.
  Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
  case_eq (x ?= y); intros H.
  - apply EQ. now apply Pos.compare_eq.
  - apply LT; assumption.
  - apply GT. now apply Pos.gt_lt.
  Defined.

  Definition eq_dec := Pos.eq_dec.

End Positive_as_OT.

(** [N] is an ordered type with respect to the usual order on natural numbers. *)

Module N_as_OT <: UsualOrderedTypeLarge.
  Definition t:=N.
  Definition eq:=@eq N.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := N.lt.
  Definition lt_trans := N.lt_trans.
  Definition lt_not_eq := N.lt_neq.

  Definition compare x y : Compare lt eq x y.
  Proof.
  case_eq (x ?= y)%N; intro.
  - apply EQ. now apply N.compare_eq.
  - apply LT. assumption.
  - apply GT. now apply N.gt_lt.
  Defined.

  Definition eq_dec := N.eq_dec.

End N_as_OT.

(** From two ordered types, we can build a new OrderedTypeLarge
   over their cartesian product, using the lexicographic order. *)

Module PairOrderedTypeLarge(O1 O2:OrderedTypeLarge) <: OrderedTypeLarge.
 Module MO1:=OrderedTypeLargeFacts(O1).
 Module MO2:=OrderedTypeLargeFacts(O2).

 Definition t := prod O1.t O2.t.

 Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y).

 Definition lt x y :=
    O1.lt (fst x) (fst y) \/
    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).

 Lemma eq_refl : forall x : t, eq x x.
 Proof.
 intros (x1,x2); red; simpl; auto with ordered_type.
 Qed.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
 Qed.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type.
 Qed.

 Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition.
 left; eauto with ordered_type.
 left; eapply MO1.lt_eq; eauto.
 left; eapply MO1.eq_lt; eauto.
 right; split; eauto with ordered_type.
 Qed.

 Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition.
 apply (O1.lt_not_eq H0 H1).
 apply (O2.lt_not_eq H3 H2).
 Qed.

 Definition compare : forall x y : t, Compare lt eq x y.
 intros (x1,x2) (y1,y2).
 destruct (O1.compare x1 y1).
 apply LT; unfold lt; auto.
 destruct (O2.compare x2 y2).
 apply LT; unfold lt; auto.
 apply EQ; unfold eq; auto.
 apply GT; unfold lt; auto with ordered_type.
 apply GT; unfold lt; auto.
 Defined.

 Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
 Proof.
 intros; elim (compare x y); intro H; [ right | left | right ]; auto.
 auto using lt_not_eq.
 assert (~ eq y x); auto using lt_not_eq, eq_sym.
 Defined.

End PairOrderedTypeLarge.

(** Even if [positive] can be seen as an ordered type with respect to the
  usual order (see above), we can also use a lexicographic order over bits
  (lower bits are considered first). This is more natural when using
  [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)

Module PositiveOrderedTypeLargeBits <: UsualOrderedTypeLarge.
  Definition t:=positive.
  Definition eq:=@eq positive.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Fixpoint bits_lt (p q:positive) : Prop :=
   match p, q with
   | xH, xI _ => True
   | xH, _ => False
   | xO p, xO q => bits_lt p q
   | xO _, _ => True
   | xI p, xI q => bits_lt p q
   | xI _, _ => False
   end.

  Definition lt:=bits_lt.

  Lemma bits_lt_trans :
    forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
  Proof.
  induction x.
  induction y; destruct z; simpl; eauto; intuition.
  induction y; destruct z; simpl; eauto; intuition.
  induction y; destruct z; simpl; eauto; intuition.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
  exact bits_lt_trans.
  Qed.

  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
  Proof.
  induction x; simpl; auto.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
  intros; intro.
  rewrite <- H0 in H; clear H0 y.
  unfold lt in H.
  exact (bits_lt_antirefl x H).
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
  induction x; destruct y.
  - (* I I *)
    destruct (IHx y) as [l|e|g].
    apply LT; auto.
    apply EQ; rewrite e; red; auto.
    apply GT; auto.
  - (* I O *)
    apply GT; simpl; auto.
  - (* I H *)
    apply GT; simpl; auto.
  - (* O I *)
    apply LT; simpl; auto.
  - (* O O *)
    destruct (IHx y) as [l|e|g].
    apply LT; auto.
    apply EQ; rewrite e; red; auto.
    apply GT; auto.
  - (* O H *)
    apply LT; simpl; auto.
  - (* H I *)
    apply LT; simpl; auto.
  - (* H O *)
    apply GT; simpl; auto.
  - (* H H *)
    apply EQ; red; auto.
  Qed.

  Lemma eq_dec (x y: positive): {x = y} + {x <> y}.
  Proof.
  intros. case_eq (x ?= y); intros.
  - left. now apply Pos.compare_eq.
  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
  Qed.

End PositiveOrderedTypeLargeBits.

Module Ascii_as_OT <: UsualOrderedTypeLarge.
  Definition t := ascii.

  Definition eq := @eq ascii.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition cmp : ascii -> ascii -> comparison := Ascii.compare.

  Lemma cmp_eq (a b : ascii):
    cmp a b = Eq  <->  a = b.
  Proof.
    unfold cmp, Ascii.compare.
    rewrite N.compare_eq_iff.
    split. 2:{ intro. now subst. }
    intro H.
    rewrite<- (ascii_N_embedding a).
    rewrite<- (ascii_N_embedding b).
    now rewrite H.
  Qed.

  Lemma cmp_lt_nat (a b : ascii):
    cmp a b = Lt  <->  (nat_of_ascii a < nat_of_ascii b)%nat.
  Proof.
    unfold cmp. unfold nat_of_ascii, Ascii.compare.
    rewrite N2Nat.inj_compare.
    rewrite Nat.compare_lt_iff.
    reflexivity.
  Qed.

  Lemma cmp_antisym (a b : ascii):
    cmp a b = CompOpp (cmp b a).
  Proof.
    unfold cmp.
    apply N.compare_antisym.
  Qed.

  Definition lt (x y : ascii) := (N_of_ascii x < N_of_ascii y)%N.

  Lemma lt_trans (x y z : ascii):
    lt x y -> lt y z -> lt x z.
  Proof.
    apply N.lt_trans.
  Qed.

  Lemma lt_not_eq (x y : ascii):
     lt x y -> x <> y.
  Proof.
    intros L H. subst.
    exact (N.lt_irrefl _ L).
  Qed.

  Local Lemma compare_helper_eq {a b : ascii} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Local Lemma compare_helper_gt {a b : ascii} (G : cmp a b = Gt):
    lt b a.
  Proof.
    now apply N.compare_gt_iff.
  Qed.

  Definition compare (a b : ascii) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT E
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : ascii): {x = y} + { ~ (x = y)} := ascii_dec x y.
End Ascii_as_OT.

(** [String] is an ordered type with respect to the usual lexical order. *)

Module String_as_OT <: UsualOrderedTypeLarge.

  Definition t := string.

  Definition eq := @eq string.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Inductive lts : string -> string -> Prop :=
    | lts_empty : forall a s, lts EmptyString (String a s)
    | lts_tail : forall a s1 s2, lts s1 s2 -> lts (String a s1) (String a s2)
    | lts_head : forall (a b : ascii) s1 s2,
        lt (nat_of_ascii a) (nat_of_ascii b) ->
        lts (String a s1) (String b s2).

  Definition lt := lts.

  Lemma nat_of_ascii_inverse a b : nat_of_ascii a = nat_of_ascii b -> a = b.
  Proof.
    intro H.
    rewrite <- (ascii_nat_embedding a).
    rewrite <- (ascii_nat_embedding b).
    apply f_equal; auto.
  Qed.

  Lemma lts_tail_unique a s1 s2 : lt (String a s1) (String a s2) ->
    lt s1 s2.
  Proof.
    intro H; inversion H; subst; auto.
    remember (nat_of_ascii a) as x.
    apply lt_irrefl in H1; inversion H1.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    induction x; intros y z H1 H2.
    - destruct y as [| b y']; inversion H1.
      destruct z as [| c z']; inversion H2; constructor.
    - destruct y as [| b y']; inversion H1; subst;
        destruct z as [| c z']; inversion H2; subst.
      + constructor. eapply IHx; eauto.
      + constructor; assumption.
      + constructor; assumption.
      + constructor. eapply lt_trans; eassumption.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    induction x; intros y LT.
    - inversion LT. intro. inversion H.
    - inversion LT; subst; intros EQ.
      * specialize (IHx s2 H2).
        inversion EQ; subst; auto.
        apply IHx; unfold eq; auto.
      * inversion EQ; subst; auto.
        apply Nat.lt_irrefl in H2; auto.
  Qed.

  Definition cmp : string -> string -> comparison := String.compare.

  Lemma cmp_eq (a b : string):
    cmp a b = Eq  <->  a = b.
  Proof.
    revert b.
    induction a, b; try easy.
    cbn.
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; try discriminate;
      try rewrite Ascii_as_OT.cmp_eq in Heqc; try subst;
      try rewrite IHa; intro H.
    { now subst. }
    { now inversion H. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
  Qed.

  Lemma cmp_antisym (a b : string):
    cmp a b = CompOpp (cmp b a).
  Proof.
    revert b.
    induction a, b; try easy.
    cbn. rewrite IHa. clear IHa.
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; rewrite Ascii_as_OT.cmp_antisym in Heqc;
      destruct Ascii_as_OT.cmp; cbn in *; easy.
  Qed.

  Lemma cmp_lt (a b : string):
    cmp a b = Lt  <->  lt a b.
  Proof.
    revert b.
    induction a as [ | a_head a_tail ], b; try easy; cbn.
    { split; trivial. intro. apply lts_empty. }
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; intro H; try discriminate; trivial.
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      apply String_as_OT.lts_tail.
      apply IHa_tail.
      assumption.
    }
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      inversion H; subst. { rewrite IHa_tail. assumption. }
      exfalso. apply (Nat.lt_irrefl (nat_of_ascii a)). assumption.
    }
    {
      apply String_as_OT.lts_head.
      rewrite<- Ascii_as_OT.cmp_lt_nat.
      assumption.
    }
    {
      exfalso. inversion H; subst.
      {
         assert(X: Ascii.compare a a = Eq). { apply Ascii_as_OT.cmp_eq. trivial. }
         rewrite Heqc in X. discriminate.
      }
      rewrite<- Ascii_as_OT.cmp_lt_nat in *.
      unfold Ascii_as_OT.cmp in *.
      rewrite Heqc in *. discriminate.
    }
  Qed.

  Local Lemma compare_helper_lt {a b : string} (L : cmp a b = Lt):
    lt a b.
  Proof.
    now apply cmp_lt.
  Qed.

  Local Lemma compare_helper_gt {a b : string} (G : cmp a b = Gt):
    lt b a.
  Proof.
    rewrite cmp_antisym in G.
    rewrite CompOpp_iff in G.
    now apply cmp_lt.
  Qed.

  Local Lemma compare_helper_eq {a b : string} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Definition compare (a b : string) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT (compare_helper_lt E)
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : string): {x = y} + { ~ (x = y)} := string_dec x y.
End String_as_OT.


(** 二項関係「<」が整礎であることの証明 *)
(* 2015_01_08 @suharahiromichi *)

Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
Require Import div prime.

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

(* well_founded の引数は Prop である必要がある。
コアーションが効いて (n < m) = true になる。
だから、well_founded ltn ではだめである。 *)
Lemma well_founded_ltn : well_founded (fun n m => n < m).
Proof.
  move=> x.
  elim: x {1 3}x (leqnn x) => [| n IHn] x H; apply: Acc_intro.
  - by case: x H.
  - by move=> y H0; apply/IHn/(leq_trans H0 H).
Defined.                                    (* Qedでも。 *)

(** Prop の場合は、lt_wf として定理があるが、自分で証明してみる。 *)
Search well_founded.

Require Import Arith.                       (* Lt *)
(* Coq/Arith/ の定理を使っている。 *)

Lemma well_founded_lt : well_founded lt.
Proof.
  move=> x.
  elim: x {1 3}x (le_refl x) => [| n IHn] x H; apply: Acc_intro.
  - case: x H => [|x] H1 x' H2.
    + by inversion H2.
    + exfalso.
      apply le_not_lt in H1.
      apply H1.
      by apply lt_0_Sn.
  - move=> y H0.
    apply IHn.
    apply lt_n_Sm_le.
    by apply (lt_le_trans y x n.+1 H0 H).
Defined.                                    (* Qedでも。 *)

(* 整礎帰納法の使い方の例 *)
Goal forall c : nat, c ^ 2 >= 0.
Proof.
  move=> c.
  move: c (well_founded_ltn c).
  refine (Acc_ind _ _) => c.
  case: c.
    (*
   (forall y : nat, y < 0 -> Acc (fun n m : nat => n < m) y) ->
   (forall y : nat, y < 0 -> 0 <= y ^ 2) -> 0 <= 0 ^ 2
     *)
  by [].
    (*
   forall n : nat,
   (forall y : nat, y < n.+1 -> Acc (fun n0 m : nat => n0 < m) y) ->
   (forall y : nat, y < n.+1 -> 0 <= y ^ 2) -> 0 <= n.+1 ^ 2
     *)
  by [].
Qed.

(* END *)


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector Theory implemented with NatFun
  author    : ZhengPu Shi
  date      : 2021.12
*)

Require Export VectorTheory.
Require Import NatFun.MatrixTheoryNF.

(* ######################################################################### *)
(** * Basic vector theory implemented with NatFun *)

Module BasicVectorTheoryNF (E : ElementType).

  (* ==================================== *)
  (** ** Also contain matrix theory *)
  Module Export BasicMatrixTheoryNF := BasicMatrixTheoryNF E.

  (* ==================================== *)
  (** ** Vector element type *)
  Export E.

  Infix "==" := (eqlistA Aeq) : list_scope.

  Open Scope nat_scope.
  Open Scope A_scope.
  Open Scope vec_scope.

  (* ==================================== *)
  (** ** Vector type *)

  Definition vec n := mat n 1.

  (** matrix equality *)
  Definition veq {n} (v1 v2 : vec n) := @meq n 1 v1 v2.
  Infix "==" := veq : vec_scope.

  (** meq is equivalence relation *)
  Lemma veq_equiv : forall n, Equivalence (veq (n:=n)).
  Proof.
    intros. unfold veq. unfold meq.
    (* apply meq_equiv. *)
    (* Qed. *)
    (* Tips: a bit different to other models. *)
  Admitted.

  (** Get element of vector *)
  Definition vnth {n} (v : vec n) i : A := @mnth n 1 v i 0.
  Notation "v ! i" := (vnth v i) : vec_scope.

  (** veq and mnth should satisfy this constraint *)
  Lemma veq_iff_vnth : forall {n : nat} (v1 v2 : vec n),
      (v1 == v2) <-> (forall i, i < n -> (vnth v1 i == vnth v2 i)%A).
  Proof.
    intros.
  Admitted.

  (* ==================================== *)
  (** ** Convert between list and vector *)
  Definition v2l {n} (v : vec n) : list A := @Matrix.mcol _ n 1 0 v.
  Definition l2v {n} (l : list A) : vec n := l2m (row2col l).

  Lemma v2l_length : forall {n} (v : vec n), length (v2l v) = n.
  Admitted.

  Lemma v2l_l2v_id : forall {n} (l : list A),
    length l = n -> (@v2l n (@l2v n l) == l)%list.
  Admitted.

  Lemma l2v_v2l_id : forall {n} (v : vec n), l2v (v2l v) == v.
  Admitted.

  (* ==================================== *)
  (** ** Convert between tuples and vector *)
  Definition t2v_2 (t : @T2 A) : vec 2 :=
    let '(a,b) := t in l2m [[a];[b]].
  Definition t2v_3 (t : @T3 A) : vec 3 :=
    let '(a,b,c) := t in l2m [[a];[b];[c]].
  Definition t2v_4 (t : @T4 A) : vec 4 :=
    let '(a,b,c,d) := t in l2m [[a];[b];[c];[d]].

  Definition v2t_2 (v : vec 2) : @T2 A := (v!0, v!1).
  Definition v2t_3 (v : vec 3) : @T3 A := (v!0, v!1, v!2).
  Definition v2t_4 (v : vec 4) : @T4 A := (v!0, v!1, v!2, v!3).

  Lemma v2t_t2v_id_2 : forall (t : A * A), v2t_2 (t2v_2 t) = t.
  Proof.
    intros. destruct t. simpl. unfold v2t_2. f_equal.
  Qed.

  Lemma t2v_v2t_id_2 : forall (v : vec 2), t2v_2 (v2t_2 v) == v.
  Proof.
    intros. apply veq_iff_vnth. intros i Hi. simpl.
    repeat (try destruct i; auto; try lia); easy.
  Qed.

  (** mapping of a vector *)
  Definition vmap {n} (v : vec n) f : vec n := mmap f v.

  (** folding of a vector *)
(*   Definition vfold : forall {B : Type} {n} (v : vec n) (f : A -> B) (b : B), B. *)

  (** mapping of two matrices *)
  Definition vmap2 {n} (v1 v2 : vec n) f : vec n := mmap2 f v1 v2.

End BasicVectorTheoryNF.

(* ######################################################################### *)
(** * Ring vector theory implemented with NatFun *)

(** zero vector, vector addition, opposition, substraction, scalar multiplication,
    dot product *)
Module RingVectorTheoryNF (E : RingElementType) <: RingVectorTheory E.

  (* ==================================== *)
  (** ** Also contain matrix theory *)
  Module Export RingMatrixTheoryNF := RingMatrixTheoryNF E.

  Export E.
  Include (BasicVectorTheoryNF E).

  (** ** Zero vector *)
  Definition vec0 {n} : vec n := mat0 n 1.

  (* (** Assert that a vector is an zero vector. *) *)
  (* Definition vzero {n} (v : vec n) : Prop := v = vec0. *)

  (* (** Assert that a vector is an non-zero vector. *) *)
  (* Definition vnonzero {n} (v : vec n) : Prop := ~(vzero v). *)

  (* (** vec0 is equal to mat0 with column 1 *) *)
  (* Lemma vec0_eq_mat0 : forall n, vec0 = mat0 n 1. *)
  (* Proof. *)
  (*   intros. easy. *)
  (* Qed. *)

  (* (** It is decidable that if a vector is zero vector. *) *)
  (* Lemma vzero_dec : forall {n} (v : vec n), {vzero v} + {vnonzero v}. *)
  (* Proof. *)
  (*   intros. apply meq_dec. *)
  (* Qed. *)

  (** *** Vector addition *)

  Definition vadd {n} (v1 v2 : vec n) : vec n := @madd n 1 v1 v2.
  Infix "+" := vadd.

  (** v1 + v2 = v2 + v1 *)
  Lemma vadd_comm : forall {n} (v1 v2 : vec n), (v1 + v2) == (v2 + v1).
  Proof.
    intros. apply (@madd_comm n 1).
  Qed.

  (** (v1 + v2) + v3 = v1 + (v2 + v3) *)
  Lemma vadd_assoc : forall {n} (v1 v2 v3 : vec n), (v1 + v2) + v3 == v1 + (v2 + v3).
  Proof.
    intros. apply (@madd_assoc n 1).
  Qed.

  (** vec0 + v = v *)
  Lemma vadd_0_l : forall {n} (v : vec n), vec0 + v == v.
  Proof.
    intros. apply (@madd_0_l n 1).
  Qed.

  (** v + vec0 = v *)
  Lemma vadd_0_r : forall {n} (v : vec n), v + vec0 == v.
  Proof.
    intros. apply (@madd_0_r n 1).
  Qed.

  (** *** Vector opposite *)

  Definition vopp {n} (v : vec n) : vec n := @mopp n 1 v.
  Notation "- v" := (vopp v).

  (** v + (- v) = vec0 *)
  Lemma vadd_opp_r : forall {n} (v : vec n), v + (- v) == vec0.
  Proof.
    intros. apply (@madd_opp n 1).
  Qed.

  (** (- v) + v = vec0 *)
  Lemma vadd_opp_l : forall {n} (v : vec n), (- v) + v == vec0.
  Proof.
    intros. rewrite vadd_comm. apply (@madd_opp n 1).
  Qed.

  (** *** Vector subtraction *)

  Definition vsub {n} (v1 v2 : vec n) : vec n := v1 + (- v2).
  Infix "-" := vsub.

  (** *** Vector scalar multiplication *)

  Definition vcmul {n} a (v : vec n) : vec n := @mcmul n 1 a v.
  Definition vmulc {n} (v : vec n) a : vec n := @mmulc n 1 v a.
  Infix "c*" := vcmul.
  Infix "*c" := vmulc.

  (** v *c a = a c* v *)
  Lemma vmulc_eq_vcmul : forall {n} a (v : vec n), (v *c a) == (a c* v).
  Proof.
    intros. apply (@mmulc_eq_mcmul n 1).
  Qed.

  (** a c* (b c* v) = (a * b) c* v *)
  Lemma vcmul_assoc : forall {n} a b (v : vec n), a c* (b c* v) == (a * b) c* v.
  Proof.
    intros. apply (@mcmul_assoc n 1).
  Qed.

  (** a c* (b c* v) = b c* (a c* v) *)
  Lemma vcmul_perm : forall {n} a b (v : vec n), a c* (b c* v) == b c* (a c* v).
  Proof.
    intros. apply (@mcmul_perm n 1).
  Qed.

  (** (a + b) c* v = (a c* v) + (b c* v) *)
  Lemma vcmul_add_distr_l : forall {n} a b (v : vec n),
    (a + b)%A c* v == (a c* v) + (b c* v).
  Proof.
    intros. apply (@mcmul_add_distr_r n 1).
  Qed.

  (** a c* (v1 + v2) = (a c* v1) + (a c* v2) *)
  Lemma vcmul_add_distr_r : forall {n} a (v1 v2 : vec n),
    a c* (v1 + v2) == (a c* v1) + (a c* v2).
  Proof.
    intros. unfold vadd. apply (@mcmul_add_distr_l n 1).
  Qed.

  (** 1 c* v = v *)
  Lemma vcmul_1_l : forall {n} (v : vec n), A1 c* v == v.
  Proof.
    intros. apply (@mcmul_1_l n 1).
  Qed.

  (** 0 c* v = vec0 *)
  Lemma vcmul_0_l : forall {n} (v : vec n), A0 c* v == vec0.
  Proof.
    intros. apply (@mcmul_0_l n 1).
  Qed.

  (** *** Vector dot product *)

  (** dot production of two vectors.
      Here, we use matrix multiplication to do it, and it is a different way to
      general situation. *)

Definition vdot {n : nat} (v1 v2 : vec n) :=
    scalar_of_mat (@mmul 1 n 1 (@mtrans n 1 v1) v2)%mat.

End RingVectorTheoryNF.

(* ######################################################################### *)
(** * Decidable-field vector theory implemented with NatFun  *)

Module DecidableFieldVectorTheoryNF (E : DecidableFieldElementType)
<: DecidableFieldVectorTheory E.

  (* ==================================== *)
  (** ** Also contain matrix theory *)
  Module Export DecidableFieldMatrixTheoryNF := DecidableFieldMatrixTheoryNF E.

  Export E.
  Include (RingVectorTheoryNF E).

  (** veq is decidable *)
  Lemma veq_dec : forall (n : nat), Decidable (veq (n:=n)).
  Proof. intros. apply (@meq_dec n 1). Qed.

End DecidableFieldVectorTheoryNF.

(* ######################################################################### *)
(** * Test  *)
Module Test.

  Module Import VectorR := RingVectorTheoryNF RingElementTypeR.
  Import Reals.
  Open Scope R.

  Definition v1 := @l2v 3 [1;2;3].
  Definition v2 := @l2v 3 [4;5;6].
  Example vdot_ex1 : vdot v1 v2 = (4+10+18)%R.
  Proof.
    compute. ring.
  Qed.

End Test.

(** ** Others, later ... *)
(*

  Lemma vec_eq_vcmul_imply_coef_neq0 : forall {n} (v1 v2 : V n) k,
    vnonzero v1 -> vnonzero v2 -> v1 = k c* v2 -> k <> X0.
  Proof.
    intros. intro. subst. rewrite vcmul_0_l in H. destruct H. easy.
  Qed.

  (* ==================================== *)
  (** ** 2-dim vector operations *)

  Definition vlen2 (v : V 2) : X :=
    let '(x,y) := v2t_2 v in
      (x * x + y * y)%X.

  (* ==================================== *)
  (** ** 3-dim vector operations *)

  Definition vlen3 (v : V 3) : X :=
    let '(x,y,z) := v2t_3 v in
      (x * x + y * y + z * z)%X.

  Definition vdot3 (v0 v1 : V 3) : X :=
    let '(a0,b0,c0) := v2t_3 v0 in
    let '(a1,b1,c1) := v2t_3 v1 in
      (a0 * a1 + b0 * b1 + c0 * c1)%X.

 *)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sorted lists                                                            *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibRelation LibWf LibList
 LibOrder LibNat.

(* ********************************************************************** *)
(** * Permutations of lists *)

Section Permutation.
Variable A : Type.

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

(** We could define permutation in terms of multisets,
    but this would impose additional constraints on the
    type of elements. So instead, we use a definition
    in terms of permutation of two inner segment of lists,
    taking the reflexive-transitive closure. *)

Inductive permut_one : list A -> list A -> Prop :=
  | permut_one_intro : forall l1 l2 l3 l4,
      permut_one (l1++l2++l3++l4) (l1++l3++l2++l4).

Hint Constructors permut_one.

Definition permut := rtclosure permut_one.

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

(** Permutation is an equivalence *)

Lemma permut_refl : forall l,
  permut l l.
Proof using. intros. apply rtclosure_refl. Qed.

Lemma permut_sym : forall l1 l2,
  permut l1 l2 -> permut l2 l1.
Proof using.
  intros. induction H.
  apply permut_refl.
  applys rtclosure_last. apply IHrtclosure. inverts~ H.
Qed.

Lemma permut_trans : forall l2 l1 l3,
  permut l1 l2 -> permut l2 l3 -> permut l1 l3.
Proof using. intros. apply* rtclosure_trans. Qed.

(** Permutation is a congruence with respect to [++] and [::] *)

Lemma permut_flip : forall l1 l2,
  permut (l1++l2) (l2++l1).
Proof using.
  intros. lets: (permut_one_intro nil l1 l2 nil).
  rew_app in *. apply~ rtclosure_once.
Qed.

Lemma permut_app_l : forall l1 l1' l2,
  permut l1 l1' ->
  permut (l1 ++ l2) (l1' ++ l2).
Proof using.
  introv H. gen l2. induction H; intros.
  apply permut_refl.
  specializes IHrtclosure l2. inverts H.
   rew_app in *. eapply permut_trans.
   applys* rtclosure_step. apply permut_refl.
Qed.

Lemma permut_app_r : forall l1 l2 l2',
  permut l2 l2' ->
  permut (l1 ++ l2) (l1 ++ l2').
Proof using.
  introv H. gen l1. induction H; intros.
  apply permut_refl.
  specializes IHrtclosure l1. inverts H.
   rewrite <- app_assoc in *. eapply permut_trans.
   applys* rtclosure_step. apply permut_refl.
Qed.

Lemma permut_app_lr : forall l1 l1' l2 l2',
  permut l1 l1' -> permut l2 l2' ->
  permut (l1 ++ l2) (l1' ++ l2').
Proof using.
  intros. applys rtclosure_trans.
  sapply* permut_app_l.
  apply* permut_app_r.
Qed.

Lemma permut_cons : forall x l1 l1',
  permut l1 l1' ->
  permut (x::l1) (x::l1').
Proof using.
  intros. lets: (@permut_app_r (x::nil) _ _ H).
  rew_app in *. auto.
Qed.

(** Permutation are stable through list reversal *)

Lemma permut_rev : forall l,
  permut l (rev l).
Proof using.
  induction l. apply permut_refl. rew_rev.
  lets: (@permut_flip (a::nil) (rev l)). rew_app in *.
  apply~ (@permut_trans (a::rev l)). apply~ permut_cons.
Qed.

(** Properties of elements are preserved by permutation *)

Lemma Forall_permut_one : forall (P:A->Prop) l1 l2,
  Forall P l1 -> permut_one l1 l2 -> Forall P l2.
Proof using.
  introv F Per. inverts Per.
  lets F0 F345: (Forall_app_inv _ _ F).
  lets F3 F45: (Forall_app_inv _ _ F345).
  lets F4 F5: (Forall_app_inv _ _ F45).
  apply~ Forall_app. apply~ Forall_app. apply~ Forall_app.
Qed.

Lemma Forall_permut : forall (P:A->Prop) l1 l2,
  Forall P l1 -> permut l1 l2 -> Forall P l2.
Proof using.
  introv F1 Per. gen F1. induction Per.
  auto.
  autos* Forall_permut_one.
Qed.

End Permutation.

Hint Resolve permut_refl permut_flip
             permut_app_lr permut_cons.

(* ---------------------------------------------------------------------- *)
(** ** Permutation tactic *)

Section PermutationTactic.
Variable A : Type.
Implicit Types l : list A.

Lemma permut_get_1 : forall l1 l2,
  permut (l1 ++ l2) (l1 ++ l2).
Proof using. intros. apply permut_refl. Qed.
Lemma permut_get_2 : forall l1 l2 l3,
  permut (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3).
Proof using.
  intros. apply rtclosure_once.
  applys (@permut_one_intro _ nil l1 l2 l3).
Qed.
Lemma permut_get_3 : forall l1 l2 l3 l4,
  permut (l1 ++ l2 ++ l3 ++ l4) (l2 ++ l3 ++ l1 ++ l4).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_2.
Qed.
Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
  permut (l1 ++ l2 ++ l3 ++ l4 ++ l5)
         (l2 ++ l3 ++ l4 ++ l1 ++ l5).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_3.
Qed.
Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
  permut (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6)
         (l2 ++ l3 ++ l4 ++ l5 ++ l1 ++ l6).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_4.
Qed.
Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
  permut (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l7)
         (l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l1 ++ l7).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_5.
Qed.

Lemma permut_tactic_setup : forall l1 l2,
  permut (nil ++ l1 ++ nil) (l2 ++ nil) -> permut l1 l2.
Proof using. intros. rew_list~ in H. Qed.

Lemma permut_tactic_keep : forall l1 l2 l3 l4,
  permut ((l1 ++ l2) ++ l3) l4 ->
  permut (l1 ++ (l2 ++ l3)) l4.
Proof using. intros. rew_list~ in H. Qed.

Lemma permut_tactic_simpl : forall l1 l2 l3 l4,
  permut (l1 ++ l3) l4 ->
  permut (l1 ++ (l2 ++ l3)) (l2 ++ l4).
Proof using.
  intros. eapply permut_trans.
  apply permut_get_2. apply~ permut_app_r.
Qed.

Lemma permut_tactic_trans : forall l1 l2 l3,
  permut l3 l2 -> permut l1 l3 -> permut l1 l2.
Proof using. introv P1 P2. apply~ (permut_trans P2 P1). Qed.

End PermutationTactic.

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 ++ l2 ++ .. ++ nil],
    (some of the lists [li] are put in the form [x::nil]). *)
(* todo: improve so as to ensure no rewrite inside elements *)

Hint Rewrite app_assoc app_nil_l app_nil_r : permut_rew.

Ltac permut_lemma_get n :=
  match nat_from_number n with
  | 1 => constr:(permut_get_1)
  | 2 => constr:(permut_get_2)
  | 3 => constr:(permut_get_3)
  | 4 => constr:(permut_get_4)
  | 5 => constr:(permut_get_5)
  end.

Ltac permut_isolate_cons :=
  do 20 try (* todo : repeat *)
    match goal with |- context [?x::?l] =>
      match l with
      | nil => fail 1
      | _ => rewrite <- (@app_cons_one _ x l)
      end
    end.

Ltac permut_simpl_prepare :=
   autorewrite with permut_rew;
   permut_isolate_cons;
   autorewrite with permut_rew;
   apply permut_tactic_setup;
   repeat rewrite app_assoc.

(** [permut_simplify] simplifies a goal of the form
    [permut l l'] where [l] and [l'] are lists built with
    concatenation and consing, by cancelling syntactically
    equal elements *)

Ltac permut_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l ++ _ => constr:(1)
  | _ ++ l ++ _ => constr:(2)
  | _ ++ _ ++ l ++ _ => constr:(3)
  | _ ++ _ ++ _ ++ l ++ _ => constr:(4)
  | _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(5)
  | _ ++ _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(6)
  | _ => constr:(0) (* not found *)
  end.

Ltac permut_simpl_once :=
  match goal with
  | |- permut (_ ++ nil) _ => fail 1
  | |- permut (_ ++ (?l ++ _)) ?l' =>
     match permut_index_of l l' with
     | 0 => apply permut_tactic_keep
     | ?n => let F := permut_lemma_get n in
            eapply permut_tactic_trans;
            [ apply F
            | apply permut_tactic_simpl ]
     end
  end.

Ltac permut_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once;
  autorewrite with permut_rew;
  try apply permut_refl.

(* todo: permut rewrite *)

(* ********************************************************************** *)
(** * Sorted lists *)

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

Section Sorted.
Variable A : Type.
Implicit Types le : binary A.

Inductive sorted le : list A -> Prop :=
  | sorted_nil : sorted le nil
  | sorted_one : forall x, sorted le (x::nil)
  | sorted_two : forall x y l,
     sorted le (y::l) -> le x y ->
     sorted le (x::y::l).

Definition rsorted le := sorted (flip le).

Definition head_of_le le x l :=
  match l with
  | nil => True
  | h::_ => le x h
  end.

Definition head_le le l1 l2 :=
  match l1,l2 with
  | _,nil => True
  | nil,_ => True
  | h1::_,h2::_ => le h1 h2
  end.

End Sorted.

(* ---------------------------------------------------------------------- *)
(** ** Properties about sorted *)

Implicit Arguments sorted [A].
Hint Unfold rsorted.

Section SortedProperties.
Hint Constructors sorted.

Variables (A : Type).
Variable le : binary A.
Hint Resolve sorted_nil sorted_one.

Lemma sorted_inv : forall x l,
  sorted le (x::l) -> head_of_le le x l /\ sorted le l.
Proof using. introv H. inverts H; simpls~. Qed.

Lemma sorted_sub : forall x l,
  sorted le (x::l) -> sorted le l.
Proof using. introv H. inverts~ H. Qed.

Lemma sorted_cons : forall l,
  sorted le l -> forall x,
  head_of_le le x l -> sorted le (x::l).
Proof using. introv S Hd. inverts~ S. Qed.

Lemma head_le_from_sorted : forall x l1 l2,
  sorted le (x::l2) ->
  head_le le l1 (x::l2) ->
  head_le le (x::l1) l2.
Proof using.
  intros. destruct l2; simpl. auto. inverts~ H.
Qed.

Lemma sorted_cons_head_of : forall x l,
  sorted le (x::l) -> head_of_le le x l.
Proof using. introv H. inverts H; simpls~. Qed.

Lemma head_le_nil_l : forall l,
  head_le le nil l.
Proof using. intros. unfolds. destruct~ l. Qed.

Lemma head_le_nil_r : forall l,
  head_le le l nil.
Proof using. intros. unfolds. destruct~ l. Qed.

Lemma sorted_cons_head : forall l1 l2 x,
  head_le le (x::l1) l2 ->
  sorted le l2 ->
  sorted le (x::l2).
Proof using. introv H S2. destruct l2. auto. apply~ sorted_cons. Qed.

Lemma head_le_flip : forall l1 l2,
  head_le (flip le) l1 l2 = head_le le l2 l1.
Proof using. destruct l1; destruct l2; auto. Qed.

Lemma head_le_flip_1 : forall l1 l2,
  head_le (flip le) l1 l2 -> head_le le l2 l1.
Proof using. intros. rewrite~ <- head_le_flip. Qed.

Lemma head_le_flip_2 : forall l1 l2,
  head_le le l2 l1 -> head_le (flip le) l1 l2.
Proof using. intros. rewrite~ head_le_flip. Qed.

Lemma sorted_Forall_le : forall x l,
  total_preorder le ->
  head_of_le le x l -> sorted le l -> Forall (le x) l.
Proof using.
  induction l; simpl; introv Tot LeH Sl. auto. constructor~.
  lets: (sorted_sub Sl). constructor~. apply~ IHl.
  destruct~ l; simpls~. inverts Sl. sapply* total_preorder_trans.
Qed.

Lemma head_of_le_Forall_le : forall x l,
  Forall (le x) l -> head_of_le le x l.
Proof using. introv H. destruct l; simpls. auto. inverts~ H. Qed.

Lemma sorted_flip_flip : forall l,
  sorted le l ->
  sorted (flip (flip le)) l.
Proof using.
  introv H. rewrite flip_flip. induction H.
   constructor. constructor. apply~ sorted_cons.
Qed.

End SortedProperties.

(* ---------------------------------------------------------------------- *)
(** ** Properties about rsorted *)

Section RSortedProperties.
Variables (A : Type).
Variable le : binary A.
Hint Resolve sorted_nil sorted_one.
Hint Constructors sorted.

Lemma rsorted_inv : forall x l,
  rsorted le (x::l) -> head_of_le (flip le) x l /\ rsorted le l.
Proof using. introv H. inverts H; simpls~. Qed.

Lemma head_le_from_rsorted : forall x l1 l2,
  rsorted le (x::l2) ->
  head_le (flip le) l1 (x::l2) ->
  head_le (flip le) (x::l1) l2.
Proof using.
  intros. destruct l2; simpl. auto. inverts~ H.
Qed.

Lemma rsorted_cons_head : forall l1 l2 x,
  head_le (flip le) (x::l1) l2 ->
  rsorted le l2 ->
  rsorted le (x::l2).
Proof using. introv H S2. destruct~ l2. Qed.

Lemma sorted_app : forall l1 l2,
  head_le le l1 l2 -> rsorted le l1 -> sorted le l2 ->
  sorted le ((rev l1) ++ l2).
Proof using.
  introv. gen l2. induction l1; introv Hd S1 S2; rew_rev. auto.
  lets Hd1 S1': (rsorted_inv S1). clear S1.
  apply IHl1. destruct~ l1. auto.
  apply sorted_cons. auto. destruct~ l2.
Qed.

End RSortedProperties.

Lemma rsorted_app : forall (A : Type) (le : binary A) l1 l2,
  head_le le l2 l1 -> sorted le l1 -> rsorted le l2 ->
  rsorted le ((rev l1) ++ l2).
Proof using.
  unfold rsorted. intros. apply sorted_app.
    rewrite~ head_le_flip.
    unfolds. apply~ sorted_flip_flip.
    auto.
Qed.

(* ********************************************************************** *)
(** * Sorting of a list *)

Section Sorts.
Variables (A : Type).
Implicit Types le : binary A.
Hint Resolve sorted_nil sorted_one.

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

Definition sorts le l l' :=
  permut l l' /\ sorted le l'.

Definition rsorts le := sorts (flip le).

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

Lemma sorts_refl : forall le l,
  sorted le l -> sorts le l l.
Proof using. split. apply permut_refl. auto. Qed.

Lemma rsorts_refl : forall le l,
  rsorted le l -> rsorts le l l.
Proof using. intros. apply~ sorts_refl. Qed.

Lemma sorts_app_rev : forall le l1 l2,
 head_le le l1 l2 -> rsorted le l1 -> sorted le l2 ->
 sorts le (l1 ++ l2) (rev l1 ++ l2).
Proof using.
  introv H S1 S2. split.
  apply permut_app_l. apply permut_rev.
  apply~ sorted_app.
Qed.

Lemma rsorts_app_rev : forall le l1 l2,
 head_le le l2 l1 -> sorted le l1 -> rsorted le l2 ->
 rsorts le (l1 ++ l2) (rev l1 ++ l2).
Proof using.
  introv H S1 S2. split.
  apply permut_app_l. apply permut_rev.
  apply~ rsorted_app.
Qed.

Lemma sorts_permut : forall l1 l2 l' le,
  sorts le l1 l' -> permut l2 l1 ->
  sorts le l2 l'.
Proof using.
  introv [P1 S1] Per. split~.
  apply* (@permut_trans _ l1).
Qed.

Lemma rsorts_permut : forall l1 l2 l' le,
  rsorts le l1 l' -> permut l2 l1 ->
  rsorts le l2 l'.
Proof using. intros. apply~ (@sorts_permut l1). Qed.

Lemma sorts_cons : forall le l l' x,
  sorts le l l' -> head_of_le le x l' ->
  sorts le (x::l) (x::l').
Proof using.
  introv [P S] Hd. split.
  apply~ permut_cons. apply~ sorted_cons.
Qed.

Lemma sorts_2 : forall le l x1 x2,
  permut l (x1::x2::nil) ->
  le x1 x2 ->
  sorts le l (x1::x2::nil).
Proof using.
  intros. apply~ (@sorts_permut (x1::x2::nil)).
  apply sorts_refl. apply sorted_cons.
  apply sorted_one. simpls~.
Qed.

Lemma sorts_3 : forall le l x1 x2 x3,
  permut l (x1::x2::x3::nil) ->
  le x1 x2 -> le x2 x3 ->
  sorts le l (x1::x2::x3::nil).
Proof using.
  intros.
   apply~ (@sorts_permut (x1::x2::x3::nil)).
   apply sorts_refl. apply sorted_cons.
   apply sorted_cons. apply sorted_one.
   simpls~. simpls~.
Qed.

Lemma rsorts_2 : forall le l x1 x2,
  permut l (x1::x2::nil) ->
  le x2 x1 ->
  rsorts le l (x1::x2::nil).
Proof using.
  intros.
   apply~ (@rsorts_permut (x1::x2::nil)).
   apply rsorts_refl. applys sorted_cons.
   apply sorted_one. unfold flip. simpls~.
Qed.

Lemma rsorts_3 : forall le l x1 x2 x3,
  permut l (x1::x2::x3::nil) ->
  le x2 x1 -> le x3 x2 ->
  rsorts le l (x1::x2::x3::nil).
Proof using.
  intros.
   apply~ (@rsorts_permut (x1::x2::x3::nil)).
   apply rsorts_refl. applys sorted_cons.
   apply sorted_cons. apply sorted_one.
   simpls~. simpls~.
Qed.

Lemma sorts_length_lt_2 : forall le l,
  length l < 2 -> sorts le l l.
Proof using.
  intros. apply sorts_refl. destruct~ l.
  destruct~ l. rew_length in *. false. nat_math.
Qed.

End Sorts.


(** Jamile Lima Leite **)

(** * INITIATION A COQ *)

(**
Le début de ce fichier a été présenté en cours.
Il est demandé de le réviser à la maison et de le terminer
en préparation du TD suivant.
- Lire attentivement les commentaires explicatifs
- sous emacs/Proof-general,
  - pour avancer d'une étape, faire C-c C-n
  - pour reculer, C-c C-p
  - pour aller d'un coup à la position du curseur, C-c RET.
  D'autres raccourcis sont disponibles, regarder les menus Proof-General et Coq.
*)

(** ** Généralités *)

(** Coq est primitivement un langage de programmation particulier.
    Comme OCaml, c'est un langage fonctionnel typé.
    Son système de types est beaucoup plus riche que celui de OCaml,
    ce qui permet en particulier d'énoncer des formules logiques,
    et éventuellement de les démontrer.

    Dans un premier temps, on se focalise sur l'aspect programmation,
    et les formules logiques considérées sont de simples égalités.
 *)

(** Un script Coq est une suite de déclarations de types, de valeurs,
    (très souvent : des fonctions), d'énoncés de théorèmes suivis
    de leur preuve.

    On a également des requêtes pour obtenir des informations,
    calculer des expressions.
*)

(** À RETENIR : EN COQ, TOUT FINIT PAR UN POINT '.' *)

(** ** Types énumérés *)

(** Le type qui s'écrirait en OCaml
type coulfeu =
  | Vert
  | Orange
  | Rouge

se définit en Coq presque de la même façon.
*)

Inductive coulfeu : Set :=
  | Vert : coulfeu
  | Orange : coulfeu
  | Rouge : coulfeu
.

(** Comme en OCaml, [blabla : machin] se lit "[blabla] a pour type [machin]".
    Ainsi la déclaration précédente indique que [Vert], [Orange] et [Rouge]
    sont de type coulfeu.
    Par ailleurs, en Coq tout a un type ; la déclaration ci-dessus indique que
    le type de [coulfeu] est [Set], cf. notes de cours.
*)

(** ** Définition d'une valeur fonctionnelle *)

Definition coul_suiv : coulfeu -> coulfeu :=
  fun c =>
    match c with
    | Vert => Orange
    | Orange => Rouge
    | Rouge => Vert
    end.

(** La commande Check permet d'obtenir le type d'une expression.
    Elle vérifie que l'expression est bien typée. *)

Check coul_suiv.
Check (coul_suiv Vert).

(** La commande Eval permet de calculer une expression. *)

Eval compute in (coul_suiv Vert).

(** Raccourci *)
Compute (coul_suiv Vert).

(** ** Premier théorème, tactiques cbn et reflexivity *)

Theorem ex1_coul_suiv : coul_suiv (coul_suiv Vert) = Rouge.
Proof. cbn [coul_suiv]. reflexivity. Qed.

(** Remarque : on peut énoncer une théorème à prouver au moyen d'autres
mots-clé, notamment Lemma (pour un résultat auxiliaure) ou Example
(pour un théorème très simple servant à tester le résultat d'une fonction
sur une entrée particulière.
Ces mots-clé sont équivalents, le choix de l'un ou l'autre est affaire de
convention ou d'usage.
Ici on aurait donc plutôt utilisé  Example.
Example ex1_coul_suiv : coul_suiv (coul_suiv Vert) = Rouge.
*)

(** Une *tactique* est une commande permettant de faire progresser une preuve *)

(** On a utilisé ci-dessus les tactiques suivantes :
    - cbn [nom_de_fonction] : évaluation (partielle) de [nom_de_fonction]
    - reflexivity : reconnaissance que les deux membres de l'égalité
                    à prouver sont identiques (preuve de x = x).
 *)

(** ATTENTION À BIEN TERMINER PAR "Qed." *)

(** ** Variables *)

(** Les preuves par réflexivité fonctionnent non seulement
    entre des expressions constantes identiques, mais aussi
    entre des expressions comportant des variables. *)

(** On a la possibilité en Coq (mais pas en OCaml) de déclarer
    des variables :
    ce sont des noms dont on connaît simplement le type.
    Il faut que ces noms soient déclarés dans une portée
    (domaine de visibilité) définie par une section.
*)

(** Ouverture d'une section dans laquelle on va faire quelques
    preuves par réflexivité. *)

Section sec_refl.
  Variable c : coulfeu.
  (** Signification intuitive : "soit [c] une [coulfeu] inconnue". *)

  Theorem th1_refl_simple : c = c.
  (** Remarquer que le but contient un environnement comportant
      l'hypothèse [c : coulfeu]. *)
  Proof. reflexivity. Qed.

  Check c.

(** Fermeture de la section,
    ce qui clôt la portée des variables, ici [c : coulfeu]. *)
End sec_refl.

Fail Check c.
Fail Definition x := Vert + 2.

(* -------------------------------------------------------------------  *)
(** Vu jusqu'ici dans ls CM1 2020, en fait juste avant le End sec_refl. *)
(* -------------------------------------------------------------------  *)

(** ** Principe de Leibniz : tactique rewrite *)

Section sec_reec.
  Variable c : coulfeu.
  Hypothesis crou : c = Rouge.
  (** Signification intuitive, par analogie avec la ligne d'avant :
      "soit [crou] une preuve inconnue de [c = Rouge]". *)

  Theorem coul_suiv_Rouge : coul_suiv c = Vert.
  Proof.
    rewrite crou.
    cbn [coul_suiv].
    reflexivity.
  Qed.

End sec_reec.

(** ** Raisonnement par cas : tactique destruct *)

Section sec_cas.
  Variable c : coulfeu.

  Theorem th3_coul_suiv : coul_suiv (coul_suiv (coul_suiv c)) = c.
  Proof.
    (** reflexivity ne fonctionne pas. *)
    Fail reflexivity.
    (** Il faut raisonner par cas sur les trois valeurs de [c] possibles *)
    (** Cela va donner lieu à trois sous-buts, un pour chaque cas. *)
    destruct c as [ (*Vert*) | (*Orange*) | (*Rouge*) ].
    - cbn [coul_suiv]. reflexivity.
    - cbn [coul_suiv]. reflexivity.
    - cbn [coul_suiv]. reflexivity.
  Qed.

End sec_cas.

(** ** Raisonnement universel : tactique intro *)

(** Il est possible d'énoncer des formules quantifiées universellement.
    Par exemple : [forall c : coulfeu, c = c].
 *)

Theorem th_refl_gen : forall c : coulfeu, c = c.
Proof.
  (** Pour la démontrer, la première étape consiste à dire
      "soit [c0] une couleur arbitraire, démontrons [c0 = c0]." *)
  intro c0.
  (** Remarquer que intro a introduit l'hypothèse [c0 : coulfeu]. *)
  (** On a déjà vu que reflexivity fonctionne dans cette situation. *)
  reflexivity.
Qed.

(** La tactique intro sert également à démontrer une implication. *)
Theorem th_crou_gen : forall c : coulfeu, c = Rouge -> coul_suiv c = Vert.
Proof.
  intro c0.
  (** Pour démontrer [c0 = Rouge -> coul_suiv c0 = Vert],
      on suppose [c0 = Rouge]
      et on doit alors prouver [coul_suiv c0 = Vert]
      sous cette hypothèse supplémentaire ;
      lorsque l'on introduit une hypothèse, on lui donne un nom. *)
  intro c0rou.
  (** Le raisonnement sous-jacent est :
      soit c0rou une preuve arbitraire (inconnue) de [c0 = Rouge],
      on peut s'en servir pour démontrer coul_suiv [c0 = Vert]. *)
  rewrite c0rou. cbn [coul_suiv]. reflexivity.
Qed.

(** Remarque : on est souvent amené à effectuer plusieurs introductions
    successives. On emploie alors le raccourci intros (au pluriel).
    Sur l'exemple précédent cela donne ceci : *)
Theorem th_crou_gen_bis : forall c : coulfeu, c = Rouge -> coul_suiv c = Vert.
Proof.
  intros c0 c0rou.
  rewrite c0rou. cbn [coul_suiv]. reflexivity.
Qed.

(** * Début du travail à faire à la maison *)

(** *** Exercice: Variante du précédent avec section *)

Section sec_variante_th_crou_gen.
  Variable c : coulfeu.
  Theorem th_crou_demi_gen : c = Rouge -> coul_suiv c = Vert.
  Proof.
    (** à compléter *)
    intro c0.
    rewrite c0.
    cbn [coul_suiv].
    reflexivity.
  (* Quand une démonstration est incomplète, on peut passer à la suite
   * à l'aide de Admitted  au lieu de Qed.
   * Ne pas oublier de remplacer Admitted par Qed quand on a réussi ! *)
  Qed.

End sec_variante_th_crou_gen.

(** *** Exercice: Preuve par cas d'un théorème avec forall *)

Lemma suivsuivsuiv_id : forall c:coulfeu, coul_suiv (coul_suiv (coul_suiv c))=c.
Proof.
  (** à compléter ici *)
  intro c0.
  destruct c0 as [(*Rouge*) | (*Orange*) | (*Vert*)].
  - cbn [coul_suiv]. reflexivity.
  - cbn [coul_suiv]. reflexivity.
  - cbn [coul_suiv]. reflexivity.
Qed.

(** ** Type inductif et récurrence structurelle : arbres binaires tricolores *)

Inductive arbin : Set :=
  | F : coulfeu -> arbin
  | N : arbin -> arbin -> arbin.

(**type arbin =
|F of coulfeu
|N of arbin * arbin **)

(**
Pour définir une fonction récursive (l'équivalent de let rec
en OCaml) on utilise le mot clé [Fixpoint].
 *)

Fixpoint renva a : arbin :=
  match a with
  | F c => F c
  | N g d => N (renva d) (renva g)
  end.

(** *** Exercice: prouver que renverser deux fois un arbre rend le même arbre *)
Theorem renva_renva : forall a, renva (renva a) = a.
Proof.
  intro a.
  (** Tentative de raisonnement par cas sur a *)
  (** Les noms mis dans chaque cas (c pour le premier, a2 a2 pour le second)
      désignent les composantes des constructeurs respectivement F puis N *)
  destruct a as [ (* F *) c
                | (* N *) a1 a2 ].
  - cbn [renva]. reflexivity.
  - cbn [renva]. Fail reflexivity.
    (** Il apparaît qu'un simple raisonnement par cas est insuffisant, *)
    (** donc on arrete tout... *)
 Abort.

(** ... et on recommence en raisonnant par récurrence structurelle *)
Theorem renva_renva : forall a, renva (renva a) = a.
Proof.
  intro a.
  (** récurrence structurelle sur le type inductif arbin *)
  (** Remarquer l'analogie avec l'utilisation de la tactique destruct :
      les noms mis dans chaque cas (c pour le premier, a2 a2 pour le second)
      désignent les composantes des constructeurs respectivement F puis N
      mais en complément, on ajoute deux noms pour les hypothèses de récurrence,
       Hrec_a1 pour celle sur a1 et Hrec_a2 pour celle sur a2 *)
  induction a as [ (* F *) c
                 | (* N *) a1 Hrec_a1 a2 Hrec_a2 ].
  (** à completer ici **)
  - cbn [renva]. reflexivity.
  - cbn [renva]. rewrite Hrec_a1. rewrite Hrec_a2. reflexivity.
Qed.

(** Fin du travail à faire à la maison. *)


Require Import Setoid.
Require Import IndefiniteDescription.

Lemma ex_iff_ex:
  forall T (P Q : T -> Prop),
    (forall x, P x <-> Q x) ->
    ex P <-> ex Q.
Proof.
  intuition.
  - destruct H0 as [witness H0].
    exists witness.
    apply H.
    easy.
  - destruct H0 as [witness H0].
    exists witness.
    apply H.
    easy.
Qed.

Lemma all_iff_all:
  forall T (P Q : T -> Prop),
    (forall x, P x <-> Q x) ->
    all P <-> all Q.
Proof.
  unfold all.
  intros.
  setoid_rewrite H.
  reflexivity.
Qed.

Lemma forall_exists_to_exists_forall:
  forall T U (P : T -> U -> Prop),
    (forall (x:T), exists (y:U), P x y) <->
    (exists (f : T -> U), forall (x:T), P x (f x)).
Proof.
  intuition.
  - apply functional_choice.
    easy.
  - destruct H as [f H].
    exists (f x).
    easy.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Pepin.v

    Pepin's Test for Fermat Number

    Definition: PepinTest
  **********************************************************************)
Require Import ZArith.
Require Import ZCAux.
Require Import Pocklington.

Open Scope Z_scope.

Definition FermatNumber n := 2^(2^(Z_of_nat n)) + 1.

Theorem Fermat_pos: forall n, 1 < FermatNumber n.
  unfold FermatNumber; intros n.
  solve [ auto with zarith (* 8.14 *) |
          (apply Z.le_lt_trans with (2 ^ 2 ^(Z_of_nat n)); auto with zarith;
          rewrite <- (Zpower_0_r 2); auto with zarith;
          apply Zpower_le_monotone; try split; auto with zarith)].
Qed.

Theorem PepinTest: forall n, let Fn := FermatNumber n in (3 ^ ((Fn - 1) / 2) + 1) mod Fn = 0 -> prime Fn.
intros n Fn H.
assert (Hn: 1 < Fn).
unfold Fn; apply Fermat_pos.
apply PocklingtonCorollary1 with (F1 := 2^(2^(Z_of_nat n))) (R1 := 1). 2: auto with zarith.
2: unfold Fn, FermatNumber; auto with zarith.
apply Z.lt_le_trans with (2 ^ 1).
rewrite Zpower_1_r; auto with zarith.
apply Zpower_le_monotone. 2: split. 1-2: auto with zarith.
rewrite <- (Zpower_0_r 2); apply Zpower_le_monotone; try split; auto with zarith.
unfold Fn, FermatNumber.
assert (H1: 2 <= 2 ^ 2 ^ Z_of_nat n).
pattern 2 at 1; rewrite <- (Zpower_1_r 2) by auto with zarith.
apply Zpower_le_monotone; split. auto with zarith.
rewrite <- (Zpower_0_r 2); apply Zpower_le_monotone; try split; auto with zarith.
apply Z.lt_le_trans with  (2 * 2 ^2 ^Z_of_nat n).
assert (tmp: forall p, 2 * p = p + p); auto with zarith.
apply Zmult_le_compat_r; auto with zarith.
assert (Hd: (2 | Fn - 1)).
exists (2 ^ (2^(Z_of_nat n) - 1)).
pattern 2 at 3; rewrite <- (Zpower_1_r 2).
rewrite <- Zpower_exp. 3: auto with zarith.
assert (tmp: forall p, p = (p - 1) +1) by auto with zarith; rewrite <- tmp.
unfold Fn, FermatNumber; ring.
assert (0 < 2 ^ Z_of_nat n); auto with zarith.
intros p Hp Hp1; exists 3; split. auto with zarith. split.
rewrite (Zdivide_Zdiv_eq  2 (Fn -1)) by auto with zarith.
rewrite Zmult_comm. rewrite Zpower_mult. 3: auto with zarith.
rewrite Zpower_mod by auto with zarith.
assert (tmp: forall p, p = (p + 1) -1) by auto with zarith; rewrite (fun x => (tmp (3 ^ x))).
rewrite Zminus_mod by auto with zarith.
rewrite H.
rewrite (Zmod_small 1) by auto with zarith.
rewrite <- Zpower_mod by auto with zarith.
rewrite Zmod_small. auto with zarith.
simpl; unfold Zpower_pos; simpl; auto with zarith.
apply Z_div_pos; auto with zarith.
apply Zis_gcd_gcd. auto with zarith.
apply Zis_gcd_intro. 1-2: auto with zarith.
intros x HD1 HD2.
assert (Hd1: p = 2).
apply prime_div_Zpower_prime with (4 := Hp1). 1-2: auto with zarith.
apply prime_2.
assert (Hd2: (x | 2)).
replace 2 with ((3 ^ ((Fn - 1) / 2) + 1) - (3 ^ ((Fn - 1) / 2) - 1)) by auto with zarith.
apply Zdivide_minus_l; auto.
apply Z.divide_trans with (1 := HD2).
apply Zmod_divide; auto with zarith.
rewrite <- Hd1; auto.
replace 1 with (Fn - (Fn - 1)) by auto with zarith.
apply Zdivide_minus_l; auto.
apply Z.divide_trans with (1 := Hd2); auto.
Qed.

(* An optimized version with Zpow_mod *)

Definition pepin_test n :=
  let Fn := FermatNumber n in if  Z.eq_dec (Zpow_mod 3  ((Fn - 1) / 2) Fn)  (Fn - 1) then true else false.

Theorem PepinTestOp: forall n, pepin_test n = true -> prime (FermatNumber n).
intros n; unfold pepin_test.
match goal with |- context[if ?X then _ else _] => case X end; try (intros; discriminate).
intros H1 _; apply PepinTest.
generalize (Fermat_pos n); intros H2.
rewrite Zplus_mod; auto with zarith.
rewrite <- Zpow_mod_Zpower_correct; auto with zarith.
rewrite H1.
rewrite (Zmod_small 1); auto with zarith.
replace (FermatNumber n - 1 + 1) with (FermatNumber n); auto with zarith.
apply Zdivide_mod; auto with zarith.
apply Z_div_pos; auto with zarith.
Qed.

Theorem prime5: prime 5.
exact (PepinTestOp 1 (refl_equal _)).
Qed.

Theorem prime17: prime 17.
exact (PepinTestOp 2 (refl_equal _)).
Qed.

Theorem prime257:  prime 257.
exact (PepinTestOp 3 (refl_equal _)).
Qed.

Theorem prime65537:  prime 65537.
exact (PepinTestOp 4 (refl_equal _)).
Qed.

(* Too tough !!
Theorem prime4294967297:  prime 4294967297.
refine (PepinTestOp 5 (refl_equal _)).
Qed.
*)


(************************************************************************)
(* Copyright (c) 2010, Martijn Vermaat <martijn@vermaat.name>           *)
(*                     Dimitri Hendriks <diem@cs.vu.nl>                 *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

(** This library defines two equalities on infinite terms:
    - Bisimilarity by [term_bis]
    - Pointwise equality by [term_eq]

    These two relations are proved to be the same and to be equivalences.

    In the last section, a third equality via positions is introduced,
    but it is not yet proven equal to the first two. *)

Require Import Signature.
Require Import Variables.
Require Import Term.
Require Import Equality.

Set Implicit Arguments.

Section TermEquality.

Variable F : signature.
Variable X : variables.

Notation term := (term F X).
Notation terms := (vector term).

(** Bisimilarity on terms. *)
CoInductive term_bis : term -> term -> Prop :=
  | Var_bis : forall x, term_bis (Var x) (Var x)
  | Fun_bis : forall f v w,
              (forall i, term_bis (v i) (w i)) ->
              term_bis (Fun f v) (Fun f w).

(** Equality of infinite terms up to a given depth. *)
Inductive term_eq_up_to : nat -> term -> term -> Prop :=
  | teut_0   : forall t u, term_eq_up_to 0 t u
  | teut_var : forall d x, term_eq_up_to d (Var x) (Var x)
  | teut_fun : forall d f v w,
               (forall i, term_eq_up_to d (v i) (w i)) ->
               term_eq_up_to (S d) (Fun f v) (Fun f w).

(** Pointwise equality by generalising equality up to a given depth. *)
Definition term_eq (t u : term) :=
  forall d, term_eq_up_to d t u.

(** Some inversion lemmas on pointwise equality. *)

Lemma teut_fun_inv :
  forall d f v w,
  term_eq_up_to (S d) (Fun f v) (Fun f w) ->
  forall i, term_eq_up_to d (v i) (w i).
Proof.
intros d f v w H.
dependent destruction H.
assumption.
Qed.

Lemma term_eq_fun_inv :
  forall f v w,
  term_eq (Fun f v) (Fun f w) ->
  forall i, term_eq (v i) (w i).
Proof.
intros f v w H i n.
apply teut_fun_inv with (1 := H (S n)).
Qed.

Lemma term_eq_fun_inv_symbol :
  forall (f g : F) (v : terms (arity f)) (w : terms (arity g)),
  term_eq (Fun f v) (Fun g w) -> f = g.
Proof.
intros f g v w H.
assert (H0 := H 1).
inversion_clear H0; simpl.
reflexivity.
Qed.

(** We now prove that bisimilarity is the same as pointwise equality. *)

(** Bisimilarity implies pointwise equality. *)
Lemma term_bis_implies_term_eq :
  forall (t u : term), term_bis t u -> term_eq t u.
Proof.
intros t u H d.
generalize t u H; clear H t u.
induction d as [| d IHd]; intros t u H.
constructor.
destruct H.
constructor.
constructor.
intro i.
apply IHd with (1:=(H i)).
Qed.

(** Pointwise equality implies bisimilarity. *)
Lemma term_eq_implies_term_bis : forall (t u : term), term_eq t u -> term_bis t u.
Proof.
cofix eq2bis.
intros [x|f v] [y|g w] H.
assert (H0 := H 7); inversion_clear H0.
constructor.
assert (H0 := H 1); inversion_clear H0.
assert (H0 := H 1); inversion_clear H0.
assert (H0 := term_eq_fun_inv_symbol H).
dependent destruction H0.
apply Fun_bis.
intro i.
assert (H0 := term_eq_fun_inv H).
apply eq2bis.
apply H0.
Qed.

Lemma term_bis_term_eq :
  forall (t u : term), term_bis t u <-> term_eq t u.
Proof.
split.
apply term_bis_implies_term_eq.
apply term_eq_implies_term_bis.
Qed.

(** Pointwise equality is an equivalence. *)

Lemma term_eq_up_to_trans :
  forall d t u v,
    term_eq_up_to d t u ->
    term_eq_up_to d u v ->
    term_eq_up_to d t v.
Proof.
induction d as [| d IH].
constructor.
intros t u v H1.
inversion_clear H1; intro H2.
assumption.
dependent destruction H2.
constructor.
intro i.
apply IH with (u := w i); trivial.
Qed.

Lemma term_eq_up_to_refl :
  forall d t,
    term_eq_up_to d t t.
Proof.
induction d as [| d IH]; intro t.
constructor.
destruct t.
constructor.
constructor.
intro.
apply IH.
Qed.

Lemma term_eq_up_to_symm :
  forall d t u,
    term_eq_up_to d t u ->
    term_eq_up_to d u t.
Proof.
induction d as [| d IH]; intros t u H.
constructor.
inversion_clear H.
constructor.
constructor.
intro.
apply IH.
apply H0.
Qed.

Lemma term_eq_refl : forall t, term_eq t t.
Proof.
intros t d.
apply (term_eq_up_to_refl d t).
Qed.

Lemma term_eq_symm :
  forall t u, term_eq t u -> term_eq u t.
Proof.
intros t u H d.
apply (term_eq_up_to_symm (H d)).
Qed.

Lemma term_eq_trans :
  forall t u v, term_eq t u -> term_eq u v -> term_eq t v.
Proof.
intros t u v H1 H2 d.
apply (term_eq_up_to_trans (H1 d) (H2 d)).
Qed.

(** Bisimilarity is an equivalence. *)

Lemma term_bis_refl :
  forall t, term_bis t t.
Proof.
cofix.
destruct t as [x|f v]; constructor.
intro i.
apply term_bis_refl.
Qed.

Lemma term_bis_symm :
  forall t u, term_bis t u -> term_bis u t.
Proof.
cofix.
destruct 1 as [x|f v w H]; constructor.
intro i.
apply term_bis_symm.
apply H.
Qed.

Lemma term_bis_trans :
  forall s t u, term_bis s t -> term_bis t u -> term_bis s u.
Proof.
cofix.
destruct 1 as [x|f xs ys H1].
intro. assumption.
intro H2.
dependent destruction H2.
rename w into zs, H into H2.
constructor; intro i.
apply term_bis_trans with (1:=(H1 i)) (2:=(H2 i)).
Qed.

(** Two weakening lemmas on pointwise equality follow. *)

Lemma term_eq_up_to_weaken :
  forall t u d, term_eq_up_to (S d) t u -> term_eq_up_to d t u.
Proof.
intros t u d H.
revert t u H.
induction d; intros t u H.
constructor.
inversion_clear H.
apply term_eq_up_to_refl.
constructor.
intro i.
apply IHd.
apply H0.
Qed.

Lemma term_eq_up_to_weaken_generalized :
  forall t u n m,
    n <= m ->
    term_eq_up_to m t u ->
    term_eq_up_to n t u.
Proof.
induction 1 as [| m H IH]; intro.
assumption.
apply IH.
apply term_eq_up_to_weaken.
assumption.
Qed.

(** Cauchy-converence for a sequence of terms. This is used in the definition
   of rewrite sequences in the library [Rewriting]. *)
Definition converges (f : nat -> term) (t : term) : Prop :=
  forall d, exists n, forall m,
    n <= m ->
    term_eq_up_to d (f m) t.

End TermEquality.

Infix " [~] " := term_bis (no associativity, at level 70).
Infix " [=] " := term_eq (no associativity, at level 70).

Section PositionEquality.

(** We introduce a third equality via positions, but we did not yet succeed
   at proving it equal to the first two. *)

Variable F : signature.
Variable X : variables.

Notation term := (term F X).
Notation terms := (vector term).

(** Equality of terms at a given position. *)
Definition pos_eq (p : position) (t u : term) :=
  match subterm t p, subterm u p with
  | None,   None   => True
  | Some t, Some u => root t = root u
  | _,      _      => False
  end.

(** Equality of terms at all positions. *)
Definition all_pos_eq (t u : term) :=
  forall p : position, pos_eq p t u.

(**
   Didn't really bother to complete this...

[[
Lemma all_pos_eq_fun_inv :
  forall f v w,
    all_pos_eq (Fun f v) (Fun f w) ->
    forall i, all_pos_eq (v i) (w i).
Proof.
intros f v w H i.
revert v w H.
dependent destruction i; intros v w H1 p.
assert (H' := H1 (0 :: p)).
unfold pos_eq in H'.
unfold subterm in H'.
destruct (Bool_nat.lt_ge_dec 0 (arity f)).
unfold pos_eq.
unfold subterm.
assert (vnth_fact : vnth l v = v i0 /\ vnth l w = w i0).
admit. (** vnth should do this *)
rewrite (proj1 vnth_fact), (proj2 vnth_fact) in H'.
assumption.
assert (Habsurd : arity f = 0).
auto with arith.
rewrite Habsurd in *|-.
(** The ugly thing is that dependent destruction i uses different names x0
   (Coq 8.3) and H (Coq 8.2). *)
discriminate.
(** I don't know if we're on the right track here. *)
]]

[[
Lemma all_pos_eq_implies_term_bis :
  forall (t u : term), all_pos_eq t u -> t [~] u.
Proof.
cofix pos2bis.
intros t u H.
assert (H1 := H nil).
unfold pos_eq in H1.
unfold subterm in H1.
destruct t; destruct u. (* "destruct t, u." syntax is Coq 8.3 only *)
injection H1; intro e; rewrite e; apply term_bis_refl.
discriminate H1.
discriminate H1.
dependent destruction H1. (* injection H1; clear H1; intro e; rewrite e. *)
constructor.
intro i.
apply pos2bis.
apply (all_pos_eq_fun_inv H).
Qed.
]]

[[
Lemma term_bis_implies_all_pos_eq :
  forall (t u : term), t [~] u -> all_pos_eq t u.
Proof.
intros t u H p.
revert t u H.
induction p as [| a p IH]; intros t u [x | f v w H].
reflexivity.
reflexivity.
exact I.
unfold pos_eq; simpl; destruct (Bool_nat.lt_ge_dec a (arity f)).
(** vnth should do this of course *)
assert (vnth_fact : exists i : Fin (arity f), vnth l v = v i /\ vnth l w = w i).
admit.
destruct vnth_fact as [i [H1 H2]].
rewrite H1, H2.
assert (Hp := IH (v i) (w i) (H i)).
unfold pos_eq in Hp.
destruct (subterm (v i) p); destruct (subterm (w i) p); assumption.
exact I.
Qed.
]]
*)

End PositionEquality.


Require Import Arith.
Require Import Omega.
Require Import Psatz.

(*
Pozor:
Ali je:
le_ge_dec n m : {n <= m} + {n >= m}.
pravilno definiran?

Mounosti nista izklucujoce,
ampak vedno pa velja vsaj nekaj.
Ampak tu je dec, mogoce bi bilo
boljse drugacno ime?
*)

(**
Zaradi definicije naslednika se mora suma odvijati
po prvem elementu. Sicer povsod problemi z indukcijo.
**)
Fixpoint sum (n : nat) {struct n} : (forall i, i < n -> nat) -> nat :=
  match n with
  | 0 => (fun f => 0)
  | S m =>
    (fun (f : forall i, i < S m -> nat) =>
      f m (le_n (S m)) +
      sum m (fun (i : nat) (p : i < m) =>
        f i (Nat.lt_trans i m (S m) p (le_n (S m)))))
  end.

Definition sum' (n : nat) (f : nat -> nat) := sum n (fun i _ => f i).

(** Given a decidable predicate [P] on [nat], we can count how many numbers up to [n] satisfy [P]. *)
Definition count (n : nat) {P : nat -> Prop} (decP : forall x, {P x} + {~ P x})  :=
  sum' n (fun x => if decP x then 1 else 0).

(* AAA *)
(* verjetno gre v izbiris *)
Definition countA (n : nat) (P : nat -> Prop) (decP : forall x, {P x} + {~ P x}) :=
  sum' n (fun x => if decP x then 1 else 0).

Lemma change_sum (n : nat) (f g : forall i, i < n -> nat) :
  (forall j (p : j < n), f j p = g j p) ->
  sum n f = sum n g.
Proof.
  intro E.
  induction n.
  - reflexivity.
  - simpl.
    f_equal.
    + apply E.
    + apply IHn.
      intros j p.
      apply E.
Qed.

Lemma change_sum' (n : nat) (f g : nat -> nat) :
  (forall j (p : j < n), f j = g j) ->
  sum' n f = sum' n g.
Proof.
  unfold sum'.
  apply change_sum.
Qed.

Lemma sum'_S (n : nat) (f : nat -> nat) :
  sum' (S n) f = f n + sum' n f.
Proof.
  unfold sum'.
  reflexivity.
Qed.

Lemma same_sum' (n c : nat) (f : nat -> nat) :
  (forall j (p : j < n), f j = c) ->
  sum' n f = n * c.
Proof.
  induction n.
  - intro H.
    auto.
  - rewrite sum'_S.
    intro H.
    rewrite IHn.
    + rewrite H.
      * lia.
      * omega.
    + auto.
Qed.

Ltac simpl_sum :=
  try (rewrite sum'_S in *) ; simpl in *.

Lemma sum_n_krat_k (n : nat) (k : nat):
  sum' n (fun y => k) = n * k.
Proof.
  induction n.
  - auto.
  - simpl_sum.
    rewrite IHn.
    omega.
Qed.

Lemma sum_n_krat_1 (n : nat) (k : nat):
  sum' n (fun y => 1) = n.
Proof.
  rewrite (sum_n_krat_k n 1).
  omega.
Qed.

(* AAA *)
Lemma vsota_funkcij (n : nat) (f g : nat -> nat) :
  sum' n (fun x => (f x) + (g x)) = sum' n f + sum' n g.
Proof.
  induction n.
  - auto.
  - rewrite sum'_S.
    rewrite IHn.
    rewrite sum'_S.
    rewrite sum'_S.
    omega.
Qed.

(*
malo je smesno da rabim tole lemo le da zrcali cez enacaj
kako se da drugace?
*)
Lemma vsota_funkcij_rv (n : nat) (f g : nat -> nat) :
  sum' n f + sum' n g = sum' n (fun x => (f x) + (g x)).
Proof.
  rewrite vsota_funkcij.
  auto.
Qed.

Lemma krajsanje_izraza (An_ A_n Ann M Q : nat) :
  A_n + M = Q -> An_ + A_n + Ann + M = Ann + An_ + Q.
Proof.
  omega.
Qed.

Lemma sum_sum_ULD_part (n : nat) (f : nat -> nat -> nat) :
  sum' n (fun x => (sum' x (fun y => f x y) +
                    sum' x (fun y => f y x) +
                    f x x)) =
  sum' n (fun x => sum' n (fun y => f x y)).
Proof.
  induction n.
  - auto.
  - rewrite sum'_S.
    rewrite IHn.
    rewrite sum'_S.
    rewrite sum'_S.
    set (Ann := f n n).
    set (An_ := sum' n (fun y : nat => f n y)).
    set (A_n := sum' n (fun y : nat => f y n)).
    set (M := sum' n (fun x : nat => sum' n (fun y : nat => f x y))).
    set (Q := sum' n (fun x : nat => sum' (S n) (fun y : nat => f x y))).
    apply (krajsanje_izraza An_ A_n Ann M Q).
    unfold A_n.
    unfold M.
    unfold Q.
    rewrite (vsota_funkcij_rv n
      (fun y : nat => f y n)
      (fun x : nat => sum' n (fun y : nat => f x y))).
    apply change_sum.
    intros j p.
    rewrite sum'_S.
    auto.
Qed.

Lemma sum_sum_ULD (n : nat) (f : nat -> nat -> nat) :
  sum' n (fun x => (sum' x (fun y => f x y))) +
  sum' n (fun x => (sum' x (fun y => f y x))) +
  sum' n (fun x => (f x x)) =
  sum' n (fun x => sum' n (fun y => f x y)).
Proof.
  do 2 rewrite vsota_funkcij_rv.
  apply sum_sum_ULD_part.
Qed.


Definition or_comm_aux P Q (H : P \/ Q) : Q \/ P :=
  match H with
  | or_introl H0 => or_intror H0
  | or_intror H0 => or_introl H0
  end.

Definition or_comm : forall P Q , P \/ Q -> Q \/ P :=
fun (P Q : Prop) (PorQ : P \/ Q) =>
match PorQ with
| or_introl P_holds => or_intror P_holds
| or_intror Q_holds => or_introl Q_holds
end.


Require Import SMTCoq.SMTCoq.
Local Open Scope Z_scope.

Import FArray.
Local Open Scope farray_scope.

Parameter fset: Type -> Type.
Parameter contains: forall {E: Type}, fset E -> E -> Prop.

Section DomAndRange.
  Context {K V: Type}.
  Context {orderedInst: OrdType K}.
  Context {kcomp: Comparable K}.
  Context {inhInstOptV: Inhabited (option V)}.

  Parameter domain: farray K (option V) -> fset K.
  Parameter range: farray K (option V) -> fset V.

  Lemma in_domain: forall a k v,
    a[k] = Some v -> contains (domain a) k.
  Proof.
    (* smt. *)
  Abort.

  Lemma in_range: forall a k v,
    a[k] = Some v -> contains (range a) v.
  Proof.
    (* smt. *)
  Abort.

End DomAndRange.