(*** Montgomery Multiplication *)
(** This file implements the proofs for Montgomery Form, Montgomery
    Reduction, and Montgomery Multiplication on [Z].  We follow
    Wikipedia. *)
Require Import Coq.ZArith.ZArith Coq.micromega.Psatz Coq.Structures.Equalities.
Require Import Crypto.Arithmetic.MontgomeryReduction.Definition.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SimplifyRepeatedIfs.
Require Import Crypto.Util.Notations.

Declare Module Nop : Nop.
Module Import ImportEquivModuloInstances := Z.EquivModuloInstances Nop.

Local Existing Instance eq_Reflexive. (* speed up setoid_rewrite as per https://coq.inria.fr/bugs/show_bug.cgi?id=4978 *)

Local Open Scope Z_scope.

Section montgomery.
  Context (N : Z)
          (N_reasonable : N <> 0)
          (R : Z)
          (R_good : Z.gcd N R = 1).
  Local Notation "x ≡ y" := (Z.equiv_modulo N x y) : type_scope.
  Local Notation "x ≡ᵣ y" := (Z.equiv_modulo R x y) : type_scope.
  Context (R' : Z)
          (R'_good : R * R' ≡ 1).

  Lemma R'_good' : R' * R ≡ 1.
  Proof using R'_good. rewrite <- R'_good; apply f_equal2; lia. Qed.

  Local Notation to_montgomery_naive := (to_montgomery_naive R) (only parsing).
  Local Notation from_montgomery_naive := (from_montgomery_naive R') (only parsing).

  Lemma to_from_montgomery_naive x : to_montgomery_naive (from_montgomery_naive x) ≡ x.
  Proof using R'_good.
    unfold to_montgomery_naive, from_montgomery_naive.
    rewrite <- Z.mul_assoc, R'_good'.
    autorewrite with zsimplify; reflexivity.
  Qed.
  Lemma from_to_montgomery_naive x : from_montgomery_naive (to_montgomery_naive x) ≡ x.
  Proof using R'_good.
    unfold to_montgomery_naive, from_montgomery_naive.
    rewrite <- Z.mul_assoc, R'_good.
    autorewrite with zsimplify; reflexivity.
  Qed.

  (** * Modular arithmetic and Montgomery form *)
  Section general.
    Local Infix "+" := add : montgomery_scope.
    Local Infix "-" := sub : montgomery_scope.
    Local Infix "*" := (mul_naive R') : montgomery_scope.

    Lemma add_correct_naive x y : from_montgomery_naive (x + y) = from_montgomery_naive x + from_montgomery_naive y.
    Proof using Type. unfold from_montgomery_naive, add; lia. Qed.
    Lemma add_correct_naive_to x y : to_montgomery_naive (x + y) = (to_montgomery_naive x + to_montgomery_naive y)%montgomery.
    Proof using Type. unfold to_montgomery_naive, add; autorewrite with push_Zmul; reflexivity. Qed.
    Lemma sub_correct_naive x y : from_montgomery_naive (x - y) = from_montgomery_naive x - from_montgomery_naive y.
    Proof using Type. unfold from_montgomery_naive, sub; lia. Qed.
    Lemma sub_correct_naive_to x y : to_montgomery_naive (x - y) = (to_montgomery_naive x - to_montgomery_naive y)%montgomery.
    Proof using Type. unfold to_montgomery_naive, sub; autorewrite with push_Zmul; reflexivity. Qed.

    Theorem mul_correct_naive x y : from_montgomery_naive (x * y) = from_montgomery_naive x * from_montgomery_naive y.
    Proof using Type. unfold from_montgomery_naive, mul_naive; lia. Qed.
    Theorem mul_correct_naive_to x y : to_montgomery_naive (x * y) ≡ (to_montgomery_naive x * to_montgomery_naive y)%montgomery.
    Proof using R'_good.
      unfold to_montgomery_naive, mul_naive.
      rewrite <- !Z.mul_assoc, R'_good.
      autorewrite with zsimplify; apply (f_equal2 Z.modulo); lia.
    Qed.
  End general.

  (** * The REDC algorithm *)
  Section redc.
    Context (N' : Z)
            (N'_in_range : 0 <= N' < R)
            (N'_good : N * N' ≡ᵣ -1).

    Lemma N'_good' : N' * N ≡ᵣ -1.
    Proof using N'_good. rewrite <- N'_good; apply f_equal2; lia. Qed.

    Lemma N'_good'_alt x : (((x mod R) * (N' mod R)) mod R) * (N mod R) ≡ᵣ x * -1.
    Proof using N'_good.
      rewrite <- N'_good', Z.mul_assoc.
      unfold Z.equiv_modulo; push_Zmod.
      reflexivity.
    Qed.

    Section redc.
      Context (T : Z).

      Local Notation m := (((T mod R) * N') mod R).
      Local Notation prereduce := (prereduce N R N').

      Local Ltac t_fin_correct :=
        unfold Z.equiv_modulo; push_Zmod; autorewrite with zsimplify; reflexivity.

      Lemma prereduce_correct : prereduce T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        transitivity ((T + m * N) * R').
        { unfold prereduce.
          autorewrite with zstrip_div; push_Zmod.
          rewrite N'_good'_alt.
          autorewrite with zsimplify pull_Zmod.
          reflexivity. }
        t_fin_correct.
      Qed.

      Lemma reduce_correct : reduce N R N' T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold reduce.
        break_match; rewrite prereduce_correct; t_fin_correct.
      Qed.

      Lemma partial_reduce_correct : partial_reduce N R N' T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold partial_reduce.
        break_match; rewrite prereduce_correct; t_fin_correct.
      Qed.

      Lemma reduce_via_partial_correct : reduce_via_partial N R N' T ≡ T * R'.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold reduce_via_partial.
        break_match; rewrite partial_reduce_correct; t_fin_correct.
      Qed.

      Let m_small : 0 <= m < R. Proof. auto with zarith. Qed.

      Section generic.
        Lemma prereduce_in_range_gen B
        : 0 <= N
          -> 0 <= T <= R * B
          -> 0 <= prereduce T < B + N.
        Proof using N_reasonable m_small. unfold prereduce; auto with zarith nia. Qed.
      End generic.

      Section N_very_small.
        Context (N_very_small : 0 <= 4 * N < R).

        Lemma prereduce_in_range_very_small
          : 0 <= T <= (2 * N - 1) * (2 * N - 1)
            -> 0 <= prereduce T < 2 * N.
        Proof using N_reasonable N_very_small m_small. pose proof (prereduce_in_range_gen N); nia. Qed.
      End N_very_small.

      Section N_small.
        Context (N_small : 0 <= 2 * N < R).

        Lemma prereduce_in_range_small
          : 0 <= T <= (2 * N - 1) * (N - 1)
            -> 0 <= prereduce T < 2 * N.
        Proof using N_reasonable N_small m_small. pose proof (prereduce_in_range_gen N); nia. Qed.

        Lemma prereduce_in_range_small_fully_reduced
          : 0 <= T <= 2 * N
            -> 0 <= prereduce T <= N.
        Proof using N_reasonable N_small m_small. pose proof (prereduce_in_range_gen 1); nia. Qed.
      End N_small.

      Section N_small_enough.
        Context (N_small_enough : 0 <= N < R).

        Lemma prereduce_in_range_small_enough
          : 0 <= T <= R * R
            -> 0 <= prereduce T < R + N.
        Proof using N_reasonable N_small_enough m_small. pose proof (prereduce_in_range_gen R); nia. Qed.

        Lemma reduce_in_range_R
          : 0 <= T <= R * R
            -> 0 <= reduce N R N' T < R.
        Proof using N_reasonable N_small_enough m_small.
          intro H; pose proof (prereduce_in_range_small_enough H).
          unfold reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.

        Lemma partial_reduce_in_range_R
          : 0 <= T <= R * R
            -> 0 <= partial_reduce N R N' T < R.
        Proof using N_reasonable N_small_enough m_small.
          intro H; pose proof (prereduce_in_range_small_enough H).
          unfold partial_reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.

        Lemma reduce_via_partial_in_range_R
          : 0 <= T <= R * R
            -> 0 <= reduce_via_partial N R N' T < R.
        Proof using N_reasonable N_small_enough m_small.
          intro H; pose proof (prereduce_in_range_small_enough H).
          unfold reduce_via_partial, partial_reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.
      End N_small_enough.

      Section unconstrained.
        Lemma prereduce_in_range
          : 0 <= T <= R * N
            -> 0 <= prereduce T < 2 * N.
        Proof using N_reasonable m_small. pose proof (prereduce_in_range_gen N); nia. Qed.

        Lemma reduce_in_range
        : 0 <= T <= R * N
          -> 0 <= reduce N R N' T < N.
        Proof using N_reasonable m_small.
          intro H; pose proof (prereduce_in_range H).
          unfold reduce, prereduce in *; break_match; Z.ltb_to_lt; nia.
        Qed.

        Lemma partial_reduce_in_range
        : 0 <= T <= R * N
          -> Z.min 0 (R - N) <= partial_reduce N R N' T < 2 * N.
        Proof using N_reasonable m_small.
          intro H; pose proof (prereduce_in_range H).
          unfold partial_reduce, prereduce in *; break_match; Z.ltb_to_lt;
            apply Z.min_case_strong; nia.
        Qed.

        Lemma reduce_via_partial_in_range
        : 0 <= T <= R * N
          -> Z.min 0 (R - N) <= reduce_via_partial N R N' T < N.
        Proof using N_reasonable m_small.
          intro H; pose proof (partial_reduce_in_range H).
          unfold reduce_via_partial in *; break_match; Z.ltb_to_lt; lia.
        Qed.
      End unconstrained.

      Section alt.
        Context (N_in_range : 0 <= N < R)
                (T_representable : 0 <= T < R * R).
        Lemma partial_reduce_alt_eq : partial_reduce_alt N R N' T = partial_reduce N R N' T.
        Proof using N_in_range N_reasonable T_representable m_small.
          assert (0 <= T + m * N < 2 * (R * R)) by nia.
          assert (0 <= T + m * N < R * (R + N)) by nia.
          assert (0 <= (T + m * N) / R < R + N) by auto with zarith.
          assert ((T + m * N) / R - N < R) by lia.
          assert (R * R <= T + m * N -> R <= (T + m * N) / R) by auto with zarith.
          assert (T + m * N < R * R -> (T + m * N) / R < R) by auto with zarith.
          assert (H' : (T + m * N) mod (R * R) = if R * R <=? T + m * N then T + m * N - R * R else T + m * N)
            by (break_match; Z.ltb_to_lt; autorewrite with zsimplify; lia).
          unfold partial_reduce, partial_reduce_alt, prereduce.
          rewrite H'; clear H'.
          simplify_repeated_ifs.
          set (m' := m) in *.
          autorewrite with zsimplify; push_Zmod; autorewrite with zsimplify; pull_Zmod.
          break_match; Z.ltb_to_lt; autorewrite with zsimplify; try reflexivity; lia.
        Qed.

        Lemma reduce_via_partial_alt_eq : reduce_via_partial_alt N R N' T = reduce_via_partial N R N' T.
        Proof.
            cbv [reduce_via_partial_alt reduce_via_partial].
            rewrite partial_reduce_alt_eq by omega. reflexivity.
        Qed.
      End alt.
    End redc.

    (** * Arithmetic in Montgomery form *)
    Section arithmetic.
      Local Infix "*" := (mul N R N') : montgomery_scope.

      Local Notation to_montgomery := (to_montgomery N R N').
      Local Notation from_montgomery := (from_montgomery N R N').
      Lemma to_from_montgomery a : to_montgomery (from_montgomery a) ≡ a.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold to_montgomery, from_montgomery.
        transitivity ((a * 1) * 1); [ | apply f_equal2; lia ].
        rewrite <- !R'_good, !reduce_correct.
        unfold Z.equiv_modulo; push_Zmod; pull_Zmod.
        apply f_equal2; lia.
      Qed.
      Lemma from_to_montgomery a : from_montgomery (to_montgomery a) ≡ a.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold to_montgomery, from_montgomery.
        rewrite !reduce_correct.
        transitivity (a * ((R * (R * R' mod N) * R') mod N)).
        { unfold Z.equiv_modulo; push_Zmod; pull_Zmod.
          apply f_equal2; lia. }
        { repeat first [ rewrite R'_good
                       | reflexivity
                       | push_Zmod; pull_Zmod; progress autorewrite with zsimplify
                       | progress unfold Z.equiv_modulo ]. }
      Qed.

      Theorem mul_correct x y : from_montgomery (x * y) ≡ from_montgomery x * from_montgomery y.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold from_montgomery, mul.
        rewrite !reduce_correct; apply f_equal2; lia.
      Qed.
      Theorem mul_correct_to x y : to_montgomery (x * y) ≡ (to_montgomery x * to_montgomery y)%montgomery.
      Proof using N'_good N'_in_range N_reasonable R'_good.
        unfold to_montgomery, mul.
        rewrite !reduce_correct.
        transitivity (x * y * R * 1 * 1 * 1);
          [ rewrite <- R'_good at 1
          | rewrite <- R'_good at 1 2 3 ];
          autorewrite with zsimplify;
          unfold Z.equiv_modulo; push_Zmod; pull_Zmod.
        { apply f_equal2; lia. }
        { apply f_equal2; lia. }
      Qed.
    End arithmetic.
  End redc.
End montgomery.

Module Import LocalizeEquivModuloInstances := Z.RemoveEquivModuloInstances Nop.


(* coq-robot (c) 2017 AIST and INRIA. License: LGPL-2.1-or-later. *)
Require Import NsatzTactic.
From mathcomp Require Import all_ssreflect ssralg ssrint ssrnum rat poly.
From mathcomp Require Import closed_field polyrcf matrix mxalgebra mxpoly zmodp.
From mathcomp Require Import realalg complex fingroup perm.
From mathcomp Require Import interval reals trigo.
Require Import ssr_ext euclidean vec_angle frame rot.
From mathcomp.analysis Require Import forms.
Require Import extra_trigo.

(******************************************************************************)
(*                            Quaternions                                     *)
(*                                                                            *)
(* This file develops the theory of quaternions. It defines the type of       *)
(* quaternions and the type of unit quaternions and show that quaternions     *)
(* form a ZmodType, a RingType, a LmodType, a UnitRingType. It also defines   *)
(* polar coordinates and dual quaternions.                                    *)
(*                                                                            *)
(*        quat R == type of quaternions over the ringType R                   *)
(*          x%:q == quaternion with scalar part x and vector part 0           *)
(*   x \is realq == the quaternion x has no vector part                       *)
(*          u%:v == pure quaternion (or vector quaternion) with scalar part 0 *)
(*                  and vector part u                                         *)
(*   x \is pureq == the quaternion x has no scalar part                       *)
(*    `i, `j, `k == basic quaternions                                         *)
(*           x.1 == scalar part of the quaternion x                           *)
(*           x.2 == vector part of the quaternion x                           *)
(*          x^*q == conjugate of quaternion x                                 *)
(*       normq x == norm of the quaternion x                                  *)
(*       uquat R == type of unit quaternions, i.e., quaternions with norm 1   *)
(* conjugation x == v |-> x v x^*                                             *)
(*                                                                            *)
(* Polar coordinates:                                                         *)
(*     polar_of_quat a == polar coordinates of the quaternion a               *)
(*   quat_of_polar a u == quaternion corresponding to the polar coordinates   *)
(*                        angle a and vector u                                *)
(*          quat_rot x == snd \o conjugation x (rotation of angle 2a about    *)
(*                        vector v where a,v are the polar coordinates of x,  *)
(*                        a unit quaternion                                   *)
(* Dual numbers:                                                              *)
(*     dual R == the type of dual numbers over a ringType R                   *)
(*        x.1 == left part of the dual number x                               *)
(*        x.2 == right part of the dual number x                              *)
(* Dual numbers are equipped with a structure of ZmodType, RingType, and of   *)
(* LmodType when R is a ringType, of Com/UnitRingType when R is a             *)
(* Com/UnitRingType.                                                          *)
(*                                                                            *)
(* Dual quaternions:                                                          *)
(*     x +ɛ* y  == dual number formed by x and y                              *)
(*        dquat == type of dual quaternions                                   *)
(* x \is puredq == the dual quaternion x is pure                              *)
(*   a \is dnum == a has no vector part                                       *)
(*        x^*dq == conjugate of dual quaternion x                             *)
(*                                                                            *)
(******************************************************************************)

Reserved Notation "x %:q" (at level 2, format "x %:q").
Reserved Notation "x %:v" (at level 2, format "x %:v").
Reserved Notation "x '_i'" (at level 1, format "x '_i'").
Reserved Notation "x '_j'" (at level 1, format "x '_j'").
Reserved Notation "x '_k'" (at level 1, format "x '_k'").
Reserved Notation "'`i'".
Reserved Notation "'`j'".
Reserved Notation "'`k'".
Reserved Notation "x '^*q'" (at level 2, format "x '^*q'").
Reserved Notation "r *`i" (at level 3).
Reserved Notation "r *`j" (at level 3).
Reserved Notation "r *`k" (at level 3).
Reserved Notation "x +ɛ* y"
  (at level 40, left associativity, format "x  +ɛ*  y").
Reserved Notation "x -ɛ* y"
  (at level 40, left associativity, format "x  -ɛ*  y").
Reserved Notation "x '^*d'" (at level 2, format "x '^*d'").

Declare Scope quat_scope.
Declare Scope dual_scope.

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

Local Open Scope ring_scope.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Section quaternion0.
Variable R : ringType.

Record quat := mkQuat {quatl : R ; quatr : 'rV[R]_3 }.
Implicit Types x y : quat.

Local Notation "x %:q" := (mkQuat x 0).
Local Notation "x %:v" := (mkQuat 0 x).
Local Notation "'`i'" := ('e_0)%:v.
Local Notation "'`j'" := ('e_1)%:v.
Local Notation "'`k'" := ('e_2%:R)%:v.
Local Notation "x '_i'" := ((x.2)``_0).
Local Notation "x '_j'" := ((x.2)``_1).
Local Notation "x '_k'" := ((x.2)``_(2%:R : 'I_3)).

Coercion pair_of_quat x := let: mkQuat x1 x2 := x in (x1, x2).
Let quat_of_pair (a : R * 'rV[R]_3) := let: (a1, a2) := a in mkQuat a1 a2.

Lemma quat_of_pairK : cancel pair_of_quat quat_of_pair.
Proof. by case. Qed.

Definition quat_eqMixin := CanEqMixin quat_of_pairK.
Canonical Structure quat_eqType := EqType quat quat_eqMixin.
Definition quat_choiceMixin := CanChoiceMixin quat_of_pairK.
Canonical Structure quat_choiceType := ChoiceType quat quat_choiceMixin.

Lemma eq_quat x y : (x == y) = (x.1 == y.1) && (x.2 == y.2).
Proof.
case: x y => [? ?] [? ?] /=.
apply/idP/idP => [/eqP [ -> ->]|/andP[/eqP -> /eqP -> //]]; by rewrite !eqxx.
Qed.

Definition addq x y := nosimpl (mkQuat (x.1 + y.1) (x.2 + y.2)).

Lemma addqC : commutative addq.
Proof. move=> *; congr mkQuat; by rewrite addrC. Qed.

Lemma addqA : associative addq.
Proof. move=> *; congr mkQuat; by rewrite addrA. Qed.

Lemma add0q : left_id 0%:q addq.
Proof. case=> *; by rewrite /addq /= 2!add0r. Qed.

Definition oppq x := nosimpl (mkQuat (- x.1) (- x.2)).

Lemma addNq : left_inverse 0%:q oppq addq.
Proof. move=> *; congr mkQuat; by rewrite addNr. Qed.

Definition quat_ZmodMixin := ZmodMixin addqA addqC add0q addNq.
Canonical quat_ZmodType := ZmodType quat quat_ZmodMixin.

Lemma addqE x y : x + y = addq x y. Proof. by []. Qed.

Lemma oppqE x : - x = oppq x. Proof. by []. Qed.

Local Notation "r *`i" := (mkQuat 0 (r *: 'e_0)).
Local Notation "r *`j" := (mkQuat 0 (r *: 'e_1)).
Local Notation "r *`k" := (mkQuat 0 (r *: 'e_2%:R)).

Lemma quatE x : x = x.1%:q + x.2%:v.
Proof. by apply/eqP; rewrite eq_quat /=; Simp.r. Qed.

Lemma quatrE x : x.2%:v = x _i *`i + x _j *`j + x _k *`k.
Proof. by apply/eqP; rewrite eq_quat /=; Simp.r; rewrite -vec3E. Qed.

Lemma quat_scalarE (r s : R) : (r%:q == s%:q) = (r == s).
Proof. by apply/idP/idP => [/eqP[] ->|/eqP -> //]. Qed.

Lemma quat_realN (r : R) : (- r)%:q = - (r%:q).
Proof. by rewrite oppqE /oppq /= oppr0. Qed.

Lemma quat_vectN (u : 'rV[R]_3) : (- u)%:v = - (u%:v).
Proof. by rewrite oppqE /oppq /= oppr0. Qed.

Lemma quat_realD (r s : R) : (r + s)%:q = r%:q + s%:q.
Proof. by rewrite addqE /addq /= add0r. Qed.

Lemma quat_vectD (u v : 'rV[R]_3) : (u + v)%:v = u%:v + v%:v.
Proof. by rewrite addqE /addq /= addr0. Qed.

Lemma quat_realB (r s : R) : (r - s)%:q = r%:q - s%:q.
Proof. by rewrite quat_realD quat_realN. Qed.

Lemma quat_vectB (u v : 'rV[R]_3) : (u - v)%:v = u%:v - v%:v.
Proof. by rewrite quat_vectD quat_vectN. Qed.

Definition pureq := [qualify x : quat | x.1 == 0].
Fact pureq_key : pred_key pureq. Proof. by []. Qed.
Canonical pureq_keyed := KeyedQualifier pureq_key.

Definition realq := [qualify x : quat | x.2 == 0].
Fact realq_key : pred_key realq. Proof. by []. Qed.
Canonical realq_keyed := KeyedQualifier realq_key.

End quaternion0.

Delimit Scope quat_scope with quat.
Local Open Scope quat_scope.

Notation "r %:q" := (mkQuat r 0) : quat_scope.
Notation "u %:v" := (mkQuat 0 u) : quat_scope.
Notation "'`i'" := ('e_0)%:v : quat_scope.
Notation "'`j'" := ('e_1)%:v : quat_scope.
Notation "'`k'" := ('e_2%:R)%:v : quat_scope.
Notation "x '_i'" := ((x.2)``_0) : quat_scope.
Notation "x '_j'" := ((x.2)``_1) : quat_scope.
Notation "x '_k'" := ((x.2)``_(2%:R : 'I_3)) : quat_scope.
Notation "r *`i" := (mkQuat 0 (r *: 'e_0)) : quat_scope.
Notation "r *`j" := (mkQuat 0 (r *: 'e_1)) : quat_scope.
Notation "r *`k" := (mkQuat 0 (r *: 'e_2%:R)) : quat_scope.

Arguments pureq {R}.

Import rv3LieAlgebra.Exports.

Structure Conjugate := { conjugate_type : Type ;
                         conjugate_op : conjugate_type -> conjugate_type }.

Definition conjugate_op_nosimpl := nosimpl conjugate_op.

Notation "x '^*q'" := (@conjugate_op_nosimpl _ x) : quat_scope.

Section quaternion.
Variable R : comRingType.
Implicit Types x y : quat R.

Definition mulq x y := nosimpl
  (mkQuat (x.1 * y.1 - x.2 *d y.2) (x.1 *: y.2 + y.1 *: x.2 + x.2 *v y.2)).

Lemma mulqA : associative mulq.
Proof.
move=> [a a'] [b b'] [c c']; congr mkQuat => /=.
- rewrite mulrDr mulrDl mulrA -!addrA; congr (_ + _).
  rewrite mulrN !dotmulDr !dotmulDl !opprD !addrA dot_crossmulC; congr (_ + _).
  rewrite addrC addrA; congr (_ + _ + _).
  by rewrite mulrC dotmulvZ mulrN.
  by rewrite dotmulZv.
  by rewrite dotmulvZ dotmulZv.
- rewrite 2![in LHS]scalerDr 1![in RHS]scalerDl scalerA.
  rewrite -4![in LHS]addrA -3![in RHS]addrA; congr (_ + _).
  rewrite [in RHS]scalerDr [in RHS]addrCA
         -[in RHS]addrA -[in LHS]addrA; congr (_ + _).
    by rewrite scalerA mulrC -scalerA.
  rewrite [in RHS]scalerDr [in LHS]scalerDl [in LHS]addrCA
         -[in RHS]addrA -addrA; congr (_ + _).
    by rewrite scalerA mulrC.
  rewrite (addrC (a *: _)) linearD /= (addrC (a' *v _)) linearD /=.
  rewrite -![in LHS]addrA ![in LHS]addrA (addrC (- _ *: a'))
          -![in LHS]addrA; congr (_ + _).
    by rewrite linearZ.
  rewrite [in RHS]lieC /= linearD /= opprD [in RHS]addrCA
         ![in LHS]addrA addrC -[in LHS]addrA.
  congr (_ + _); first by rewrite linearZ /= lieC scalerN.
  rewrite addrA addrC linearD /= opprD [in RHS]addrCA; congr (_ + _).
    by rewrite !linearZ /= lieC.
  rewrite 2!double_crossmul opprD opprK
         [in RHS]addrC addrA; congr (_ + _); last first.
    by rewrite scaleNr.
  by rewrite dotmulC scaleNr; congr (_ + _); rewrite dotmulC.
Qed.

Lemma mul1q : left_id 1%:q mulq.
Proof.
case=> a a'; rewrite /mulq /=; congr mkQuat; Simp.r => /=.
  by rewrite dotmul0v subr0.
by rewrite linear0l addr0.
Qed.

Lemma mulq1 : right_id 1%:q mulq.
Proof.
case=> a a'; rewrite /mulq /=; congr mkQuat; Simp.r => /=.
  by rewrite dotmulv0 subr0.
by rewrite linear0r addr0.
Qed.

Lemma mulqDl : left_distributive mulq (@addq R).
Proof.
move=> [a a'] [b b'] [c c']; rewrite /mulq /=; congr mkQuat => /=.
  by rewrite [in RHS]addrCA 2!addrA -mulrDl (addrC a) dotmulDl opprD addrA.
rewrite scalerDl -!addrA; congr (_ + _).
rewrite [in RHS](addrCA (a' *v c')) [in RHS](addrCA (c *: a')); congr (_ + _).
rewrite scalerDr -addrA; congr (_ + _).
rewrite addrCA; congr (_ + _).
by rewrite lieC linearD /= lieC opprD opprK (lieC b').
Qed.

Lemma mulqDr : right_distributive mulq (@addq R).
Proof.
move=> [a a'] [b b'] [c c']; rewrite /mulq /=; congr mkQuat => /=.
  rewrite mulrDr -!addrA; congr (_ + _).
  rewrite addrCA; congr (_ + _).
  by rewrite dotmulDr opprD.
rewrite scalerDr -!addrA; congr (_ + _).
rewrite [in RHS](addrCA (a' *v b')) [in RHS](addrCA (b *: a')); congr (_ + _).
rewrite scalerDl -addrA; congr (_ + _).
by rewrite addrCA linearD.
Qed.

Lemma oneq_neq0 : 1%:q != 0 :> quat R.
Proof. apply/eqP => -[]; apply/eqP. exact: oner_neq0. Qed.

Definition quat_RingMixin :=
  RingMixin mulqA mul1q mulq1 mulqDl mulqDr oneq_neq0.
Canonical Structure quat_Ring := Eval hnf in RingType (quat R) quat_RingMixin.

Lemma mulqE x y : x * y = mulq x y. Proof. by []. Qed.

Lemma realq_comm x y : x \is realq R -> x * y = y * x.
Proof.
rewrite qualifE; move: x y => [x1 x2] [y1 y2] /= /eqP->.
congr mkQuat => /=; first by rewrite dotmul0v dotmulv0 mulrC.
by rewrite scaler0 !linear0 add0r addr0 -/(crossmulr _ _) linear0 addr0.
Qed.

Lemma realq_real (r : R) : r%:q \is realq R.
Proof. by rewrite qualifE. Qed.

Lemma realqE x : x \is realq R -> x = (x.1)%:q.
Proof. by rewrite qualifE; case: x => [x1 x2] /= /eqP->. Qed.

Lemma quat_realM (r s : R) : (r * s)%:q = r%:q * s%:q.
Proof. by congr mkQuat; rewrite /= (dotmul0v, linear0l); Simp.r. Qed.

Lemma iiN1 : `i * `i = -1.
Proof. by congr mkQuat; rewrite (dote2, liexx) /=; Simp.r. Qed.

Lemma ijk : `i * `j = `k.
Proof. by congr mkQuat; rewrite /= (dote2, vecij); Simp.r. Qed.

Lemma ikNj : `i * `k = - `j.
Proof. by congr mkQuat; rewrite /= (dote2, vecik); Simp.r. Qed.

Lemma jiNk : `j * `i = - `k.
Proof. by congr mkQuat; rewrite /= (dote2, vecji); Simp.r. Qed.

Lemma jjN1 : `j * `j = -1.
Proof. by congr mkQuat; rewrite /= (dote2, liexx); Simp.r. Qed.

Lemma jkNi : `j * `k = `i.
Proof. by congr mkQuat; rewrite /= ?(dote2, vecjk) //; Simp.r. Qed.

Lemma kij : `k * `i = `j.
Proof. by congr mkQuat; rewrite /= (dote2, vecki); Simp.r. Qed.

Lemma kjNi : `k * `j = - `i.
Proof. by congr mkQuat; rewrite /= (dote2, veckj); Simp.r. Qed.

Lemma kkN1 : `k * `k = -1.
Proof. by congr mkQuat; rewrite /= (dote2, liexx); Simp.r. Qed.

Definition scaleq k x := mkQuat (k * x.1) (k *: x.2).

Lemma scaleqA r s x : scaleq r (scaleq s x) = scaleq (r * s) x.
Proof.
rewrite /scaleq /=; congr mkQuat; by [rewrite mulrA | rewrite scalerA].
Qed.

Lemma scaleq1 : left_id 1 scaleq.
Proof.
by move=> q; rewrite /scaleq mul1r scale1r; apply/eqP; rewrite eq_quat /= !eqxx.
Qed.

Lemma scaleqDr : @right_distributive R (quat R) scaleq +%R.
Proof. move=> a b c; by rewrite /scaleq /= mulrDr scalerDr. Qed.

Lemma scaleqDl x : {morph (scaleq^~ x : R -> quat R) : r s / r + s}.
Proof. by move=> r s; rewrite /scaleq mulrDl /= scalerDl; congr mkQuat. Qed.

Definition quat_lmodMixin := LmodMixin scaleqA scaleq1 scaleqDr scaleqDl.
Canonical quat_lmodType := Eval hnf in LmodType R (quat R) quat_lmodMixin.

Lemma scaleqE (k : R) x : k *: x = k *: x.1%:q + k *: x.2%:v.
Proof. by apply/eqP; rewrite eq_quat /=; Simp.r. Qed.

Lemma quat_realZ (k : R) (r : R) : (k * r)%:q = k *: r%:q.
Proof. by congr mkQuat; rewrite scaler0. Qed.

Lemma quat_vectZ (k : R) (u : 'rV[R]_3) : (k *: u)%:v = k *: u%:v.
Proof. by congr mkQuat; rewrite /= mulr0. Qed.

Lemma quatAl k x y : k *: (x * y) = k *: x * y.
Proof.
case: x y => [x1 x2] [y1 y2]; apply/eqP.
rewrite !mulqE /mulq /= scaleqE /= eq_quat /=.
apply/andP; split; first by Simp.r; rewrite mulrBr mulrA dotmulZv.
apply/eqP; Simp.r; rewrite 2!scalerDr scalerA -2!addrA; congr (_ + _).
by rewrite linearZl_LR /=; congr (_ + _); rewrite scalerA mulrC -scalerA.
Qed.
Canonical quat_lAlgType := Eval hnf in LalgType _ (quat R) quatAl.

Lemma quatAr k x y : k *: (x * y) = x * (k *: y).
Proof.
case: x y => [x1 x2] [y1 y2]; apply/eqP.
rewrite !mulqE /mulq /= scaleqE /= eq_quat /=.
apply/andP; split; first by Simp.r; rewrite /= mulrBr mulrCA mulrA dotmulvZ.
apply/eqP; Simp.r; rewrite 2!scalerDr scalerA mulrC -scalerA -!addrA.
by congr (_ + _); rewrite linearZr_LR /= scalerA.
Qed.
Canonical quat_algType := Eval hnf in AlgType _ (quat R) quatAr.

Lemma quat_algE r : r%:q = r%:A.
Proof. by apply/eqP; rewrite eq_quat //=; Simp.r. Qed.

Definition conjq x := nosimpl (mkQuat x.1 (- x.2)).
Canonical Conjugate_quaternion := @Build_Conjugate (quat R) conjq.

Lemma conjq_def x : x^*q = mkQuat x.1 (- x.2).
Proof. by case: x. Qed.

Lemma conjq_linear : linear (@conjugate_op_nosimpl Conjugate_quaternion).
Proof.
move=> k /= x y; rewrite !conjq_def /= scaleqE addqE /addq /=; Simp.r.
by rewrite linearN /= linearD.
Qed.

Canonical conjq_is_additive := Additive conjq_linear.
Canonical conjq_is_linear := AddLinear conjq_linear.

Lemma conjqI x : (x ^*q) ^*q = x.
Proof. by rewrite conjq_def; case: x => x1 x2 /=; rewrite opprK. Qed.

Lemma conjq0 : (0%:v)^*q = 0.
Proof. by rewrite conjq_def oppr0. Qed.

Lemma conjq_comm x : x^*q * x = x * x^*q.
Proof.
apply/eqP; rewrite eq_quat /=.
do ! rewrite (linearNl,linearNr,liexx,dotmulvN,dotmulNv,subr0,opprK,
              scaleNr,scalerN,eqxx) /=.
by rewrite addrC.
Qed.

Lemma conjq_addMC x y : x * y + (x * y)^*q  = y * x + (y * x) ^*q.
Proof.
case: x => x1 x2; case: y => y1 y2; congr mkQuat => /=.
  by rewrite [y1 * _]mulrC [y2 *d _]dotmulC.
rewrite !opprD !addrA [_ + x1 *:y2]addrC -!addrA; congr (_ + (_ + _)).
by rewrite [LHS]addrC [RHS]addrC !addrA !subrK addrC.
Qed.

Lemma realq_conjD x : x + x^*q \is realq R.
Proof.  by case: x => x1 x2; rewrite addqE /addq /= subrr qualifE. Qed.

Lemma realq_conjM x : x * x^*q \is realq R.
Proof.
case: x => [x1 x2]; rewrite mulqE /mulq /= scalerN linearN /=.
by rewrite liexx subr0 [- _ + _]addrC subrr qualifE.
Qed.

Lemma conjq_comm2 x y : y^*q * x + x^*q * y = x * y^*q + y * x^*q.
Proof.
apply: (addIr (x * x ^*q + y * y ^*q)).
rewrite [RHS]addrAC !addrA -mulrDr -[RHS]addrA -mulrDr -mulrDl -linearD /=.
rewrite addrC !addrA -conjq_comm -mulrDr -addrA -conjq_comm -mulrDr -mulrDl.
by rewrite -linearD /= [y + x]addrC conjq_comm.
Qed.

Lemma conjqM x y : (x * y)^*q = y^*q * x^*q.
Proof.
case: x y => [x1 x2] [y1 y2] /=.
rewrite 2!conjq_def /= mulqE /mulq /= mulrC dotmulC dotmulvN dotmulNv opprK;
    congr mkQuat.
by rewrite 2!opprD 2!scalerN linearN /= -(lieC x2) linearN
           /= -2!scaleNr -addrA addrCA addrA.
Qed.

Lemma quat_realC (r : R) : (r%:q)^*q = r%:q.
Proof. by congr mkQuat; rewrite /= oppr0. Qed.

Lemma quat_vectC (u : 'rV_3) : (u%:v)^*q = -(u%:v).
Proof. by congr mkQuat; rewrite /= oppr0. Qed.

End quaternion.
Arguments pureq {R}.
Arguments realq {R}.

Section quaternion1.
Variable R : realType.
Implicit Types x y : quat R.

Definition sqrq x := x.1 ^+ 2 + norm (x.2) ^+ 2.

Lemma sqrq0 : sqrq 0 = 0. Proof. by rewrite /sqrq norm0 expr0n add0r. Qed.

Lemma sqrq_ge0 x : 0 <= sqrq x. Proof. by rewrite addr_ge0 // sqr_ge0. Qed.

Lemma sqrq_eq0 x : (sqrq x == 0) = (x == 0).
Proof.
rewrite /sqrq paddr_eq0 ?sqr_ge0// !sqrf_eq0 norm_eq0 -xpair_eqE.
by rewrite -surjective_pairing.
Qed.

Lemma sqrqN x : sqrq (- x) = sqrq x.
Proof. by rewrite /sqrq /= normN sqrrN. Qed.

Lemma sqrq_conj x : sqrq (x ^*q) = sqrq x.
Proof. by rewrite /sqrq normN. Qed.

Lemma conjqP x : x * x^*q = (sqrq x)%:q.
Proof.
rewrite /mulq /=; congr mkQuat.
  by rewrite /= dotmulvN dotmulvv opprK -expr2.
by rewrite scalerN addNr add0r linearNr liexx oppr0.
Qed.

Lemma conjqZ k x : (k *: x) ^*q = k *: x ^*q.
Proof. by congr mkQuat; rewrite /= scalerN. Qed.

Lemma conjqN (u : 'rV[R]_3) : (- u%:v)^*q = - u%:v^*q.
Proof. by rewrite 2!conjq_def /= opprK oppr0 quat_vectN opprK. Qed.

Lemma pureq_conj x : (x \is pureq) = (x + x^*q == 0).
Proof.
case: x => x1 x2; rewrite qualifE /=; apply/idP/idP=> [/eqP->{x1}|].
  by rewrite conjq_def /= quat_vectN subrr.
by rewrite conjq_def /= => /eqP[/eqP]; rewrite -mulr2n (mulrn_eq0 x1 2).
Qed.

Lemma conjqE x :
  x^*q = - (1 / 2%:R) *: (x + `i * x * `i + `j * x * `j + `k * x * `k).
Proof.
apply/eqP; rewrite eq_quat; apply/andP; split; apply/eqP.
  rewrite [in LHS]/= scaleqE /=.
  rewrite !(mul0r,mulr0,addr0) scale0r !add0r !dotmulDl.
  rewrite dotmulZv dotmulvv normeE expr1n mulr1 dotmulC
          dot_crossmulC liexx dotmul0v addr0.
  rewrite subrr add0r dotmulZv dotmulvv normeE expr1n mulr1
          dotmulC dot_crossmulC liexx.
  rewrite dotmul0v addr0 dotmulZv dotmulvv normeE expr1n mulr1
          opprD addrA dotmulC dot_crossmulC.
  rewrite liexx dotmul0v subr0 -opprD mulrN mulNr
          opprK -mulr2n -(mulr_natl x.1) mulrA.
  by rewrite div1r mulVr ?mul1r // unitfE pnatr_eq0.
rewrite /= !(mul0r,scale0r,add0r,addr0).
rewrite [_ *v 'e_0]lieC /= ['e_0 *v _]linearD /= ['e_0 *v _]linearZ /= liexx.
rewrite scaler0 add0r double_crossmul dotmulvv normeE expr1n scale1r.
rewrite [_ *v 'e_1]lieC /= ['e_1 *v _]linearD /= ['e_1 *v _]linearZ /= liexx.
rewrite scaler0 add0r double_crossmul dotmulvv normeE expr1n scale1r.
rewrite [_ *v 'e_2%:R]lieC /= ['e_2%:R *v _]linearD /=
        ['e_2%:R *v _]linearZ /= liexx.
rewrite scaler0 add0r double_crossmul dotmulvv normeE expr1n scale1r.
rewrite [X in _ = - _ *: X](_ : _ = 2%:R *:x.2).
  by rewrite scalerA mulNr div1r mulVr ?unitfE ?pnatr_eq0 // scaleN1r.
rewrite !opprB (addrCA _ x.2) addrA -mulr2n scaler_nat -[RHS]addr0 -3!addrA;
    congr (_ + _).
do 3 rewrite (addrCA _ x.2).
do 2 rewrite addrC -!addrA.
rewrite -opprB (scaleNr _ 'e_0) opprK -mulr2n addrA -mulr2n.
rewrite addrC addrA -opprB scaleNr opprK -mulr2n.
rewrite opprD.
rewrite (addrCA (- _ *: 'e_2%:R)).
rewrite -opprB scaleNr opprK -mulr2n.
rewrite -!mulNrn -3!mulrnDl -scaler_nat.
apply/eqP; rewrite scalemx_eq0 pnatr_eq0 /=.
rewrite addrA addrC eq_sym -subr_eq add0r opprB opprD 2!opprK.
rewrite !['e__ *d _]dotmulC !dotmul_delta_mx /=.
by rewrite addrA addrAC -addrA addrC [X in _ == X]vec3E.
Qed.

Lemma conjq_scalar x : x.1%:q = (1 / 2%:R) *: (x + x^*q).
Proof.
case: x => x1 x2.
rewrite /conjq /= addqE /addq /= subrr quat_realD scalerDr -scalerDl.
by rewrite -mulr2n -mulr_natr div1r mulVr ?scale1r // unitfE pnatr_eq0.
Qed.

Lemma conjq_vector x : x.2%:v = (1 / 2%:R) *: (x - x^*q).
Proof.
case: x => x1 x2.
rewrite /conjq /= addqE /addq /= subrr opprK quat_vectD scalerDr -scalerDl.
by rewrite -mulr2n -mulr_natr div1r mulVr ?scale1r // unitfE pnatr_eq0.
Qed.

Definition invq a := (1 / sqrq a) *: (a ^*q).

Definition unitq : pred (quat R) := [pred a | a != 0%:q].

Lemma mulVq : {in unitq, left_inverse 1 invq (@mulq R)}.
Proof.
move=> a; rewrite inE /= => a0.
rewrite /invq -mulqE -quatAl conjq_comm conjqP.
by rewrite -quat_realZ mul1r mulVf // sqrq_eq0.
Qed.

Lemma mulqV : {in unitq, right_inverse 1 invq (@mulq R)}.
Proof.
move=> a; rewrite inE /= => a0.
by rewrite /invq -mulqE -quatAr conjqP -quat_realZ mul1r mulVf // sqrq_eq0.
Qed.

Lemma quat_integral x y : (x * y == 0) = ((x == 0) || (y == 0)).
Proof.
case: (x =P 0) => [->|/eqP xNZ] /=; first by rewrite mul0r eqxx.
apply/eqP/eqP => [xyZ|->]; last by rewrite mulr0.
by rewrite -[y]mul1r -(@mulVq x) // -mulrA xyZ mulr0.
Qed.

Lemma unitqP x y : y * x = 1 /\ x * y = 1 -> unitq x.
Proof.
move=> [ba1 ab1]; rewrite /unitq inE; apply/eqP => x0.
move/esym: ab1; rewrite x0 mul0r.
apply/eqP; exact: oneq_neq0.
Qed.

Lemma invq0id : {in [predC unitq], invq =1 id}.
Proof.
move=> a; rewrite !inE negbK => /eqP ->.
by rewrite /invq /= conjq0 scaler0.
Qed.

Definition quat_UnitRingMixin := UnitRingMixin mulVq mulqV unitqP invq0id.
Canonical quat_unitRing := UnitRingType (quat R) quat_UnitRingMixin.

Lemma invqE x : x^-1 = invq x. Proof. by done. Qed.

Definition normq x := Num.sqrt (sqrq x).

Lemma normq0 : normq 0 = 0.
Proof. by rewrite /normq /sqrq expr0n /= norm0 add0r expr0n sqrtr0. Qed.

Lemma normqc x : normq x^*q = normq x.
Proof. by rewrite /normq /sqrq /= normN. Qed.

Lemma normqE x : (normq x ^+ 2)%:q = x^*q * x.
Proof.
rewrite -normqc /normq sqr_sqrtr; last by rewrite /sqrq addr_ge0 // sqr_ge0.
by rewrite -conjqP conjqI.
Qed.

Lemma normq_ge0 x : 0 <= normq x.
Proof. by apply sqrtr_ge0. Qed.

Lemma normq_eq0 x : (normq x == 0) = (x == 0).
Proof. by rewrite /normq -{1}sqrtr0 eqr_sqrt ?sqrq_ge0// sqrq_eq0. Qed.

Lemma normq_vector (u : 'rV[R]_3) : normq u%:v = norm u.
Proof.
by rewrite /normq /sqrq /= expr0n add0r sqrtr_sqr ger0_norm ?norm_ge0.
Qed.

Lemma normqM x y : normq (x * y) = normq x * normq y.
Proof.
apply/eqP; rewrite -(@eqr_expn2 _ 2) // ?normq_ge0 //; last first.
  by rewrite mulr_ge0 // normq_ge0.
rewrite -quat_scalarE normqE conjqM -mulrA (mulrA x^*q) -normqE.
rewrite quat_algE mulr_algl -scalerAr exprMn quat_realM.
by rewrite (normqE y) -mulr_algl quat_algE.
Qed.

Lemma normqZ (k : R) x : normq (k *: x) = `|k| * normq x.
Proof.
by rewrite /normq /sqrq /= normZ 2!exprMn sqr_normr -mulrDr sqrtrM ?sqr_ge0 //
           sqrtr_sqr.
Qed.

Lemma normqV x : normq (x^-1) = normq x / sqrq x.
Proof.
rewrite invqE /invq normqZ ger0_norm; last first.
  by rewrite divr_ge0 // ?ler01 // /sqrq addr_ge0 // sqr_ge0.
by rewrite normqc mulrC mul1r.
Qed.

Definition normQ x := (normq x)%:q.

Lemma normQ_eq0 x : (normQ x == 0) = (x == 0).
Proof. by rewrite /normQ quat_scalarE normq_eq0. Qed.

Definition normalizeq x : quat R := 1 / normq x *: x.

Lemma normalizeq1 x : x != 0 -> normq (normalizeq x) = 1.
Proof.
move=> x0; rewrite /normalizeq normqZ normrM normr1 mul1r normrV; last first.
  by rewrite unitfE normq_eq0.
by rewrite ger0_norm ?normq_ge0 // mulVr // unitfE normq_eq0.
Qed.

Definition lequat x y := (x.2 == y.2) && (x.1 <= y.1).

Lemma lequat_normD x y : lequat (normQ (x + y)) (normQ x + normQ y).
Proof.
rewrite /lequat /= add0r eqxx andTb /normq /sqrq !sqr_norm !sum3E /= !mxE.
pose X := nth 0 [:: x.1; x _i; x _j; x _k].
pose Y := nth 0 [:: y.1; y _i; y _j; y _k].
suff: Num.sqrt (\sum_(i < 4) (X i + Y i)^+2) <=
      Num.sqrt (\sum_(i < 4) (X i) ^+ 2) + Num.sqrt (\sum_(i < 4) (Y i) ^+ 2).
  by rewrite !sum4E /X /Y /= !addrA.
have sqr_normE (x1 : R) : `|x1| ^+2 = x1 ^+ 2.
  by case: (ltrgt0P x1); rewrite ?sqrrN // => ->.
have ler_mul_norm (x1 y1 : R) : x1 * y1 <= `|x1| * `|y1|.
  rewrite {1}(numEsign x1) {1}(numEsign y1) mulrAC mulrA -signr_addb.
  rewrite -mulrA [_ * `|x1|]mulrC.
  case: (_ (+) _); rewrite !(expr0, expr1, mulNr, mul1r) //.
  rewrite -subr_gte0 opprK -mulr2n; apply: mulrn_wge0.
  by apply: mulr_ge0; apply: normr_ge0.
apply: le_trans (_ : Num.sqrt (\sum_(i < 4) (`|X i| + `|Y i|) ^+ 2) <= _).
  rewrite -ler_sqr ?nnegrE; try by apply: sqrtr_ge0.
  rewrite !sqr_sqrtr; try by apply: sumr_ge0 => i _; apply: sqr_ge0.
  apply: ler_sum => i _; rewrite !sqrrD.
  by rewrite !sqr_normE; do ! apply: ler_add => //.
rewrite -ler_sqr ?nnegrE; last 2 first.
- by apply: sqrtr_ge0.
- by apply: addr_ge0; apply: sqrtr_ge0.
rewrite [in X in _ <= X]sqrrD !sqr_sqrtr;
    try by apply: sumr_ge0 => i ; rewrite sqr_ge0.
under eq_bigr do rewrite sqrrD.
rewrite 2!big_split /= sumrMnl.
under [X in _ <= X + _ + _]eq_bigr do rewrite -sqr_normE.
under [X in _ <= _ + _ X * _ *+2  + _]eq_bigr do rewrite -sqr_normE.
under [X in _ <= _ + _ + X]eq_bigr do rewrite -sqr_normE.
under [X in _ <= _ + _ * _ X *+2  + _]eq_bigr do rewrite -sqr_normE.
do 2 (apply: ler_add => //); rewrite ler_muln2r /=.
rewrite -ler_sqr ?nnegrE; last 2 first.
- by apply: sumr_ge0 => i _; apply: mulr_ge0; apply: normr_ge0.
- by apply: mulr_ge0; apply: sqrtr_ge0.
rewrite exprMn !sqr_sqrtr; last 2 first.
- by apply: sumr_ge0=> i _; apply: sqr_ge0.
- by apply: sumr_ge0=> i _; apply: sqr_ge0.
(* This is Cauchy Schwartz *)
rewrite -[_ <= _]orFb -[false]/(2 == 0)%nat -ler_muln2r.
pose u := \sum_(i < 4) \sum_(j < 4) (`|X i| * `|Y j| - `|X j| * `|Y i|) ^+ 2.
set z1 := \sum_(i < _) _; set z2 := \sum_(i < _) _; set z3 := \sum_(i < _) _.
suff ->: z2 * z3 *+ 2 = z1 ^+ 2 *+ 2 + u.
  rewrite -{1}(addr0 (_ *+ 2)).
  apply: ler_add => //.
  by apply: sumr_ge0 => i _; apply: sumr_ge0 => j _; apply: sqr_ge0.
under [X in _ = _ + X]eq_bigr do
  (under eq_bigr do (rewrite sqrrB !exprMn); rewrite !(sumrN, big_split));
  rewrite !(sumrN, big_split, addrA) /=.
under eq_bigr do rewrite -mulr_sumr; rewrite -mulr_suml -/z2 -/z3.
have mswap (a b c d : R) : a * b * (c * d) = (c * b) * (a * d).
  by rewrite mulrC mulrAC [a * _]mulrC !mulrA.
under [X in _ = _ - (X + _) + _]eq_bigr do
  (under eq_bigr do rewrite mswap; rewrite -mulr_suml);
  rewrite -mulr_sumr -expr2 -/z1.
under [X in _ = _ - (_ + X) + _]eq_bigr do
  (under eq_bigr do rewrite mswap; rewrite -mulr_suml);
  rewrite -mulr_sumr -expr2 -/z1 -mulr2n.
under [X in _ = _ + X]eq_bigr do rewrite -mulr_suml;
  rewrite -mulr_sumr -/z2 -/z3.
by rewrite [_ *+ 2 + _]addrC addrK mulr2n.
Qed.

Definition ltquat x y := (x.2 == y.2) && (x.1 < y.1).

Lemma ltquat0_add x y : ltquat 0 x -> ltquat 0 y -> ltquat 0 (x + y).
Proof.
case: x => x0 x1; case: y => y0 y1; rewrite /ltquat /=.
move=> /andP[/eqP<- x0P] /andP[/eqP<- u0P] /=.
by rewrite addr0 eqxx addr_gt0.
Qed.

Lemma ge0_lequat_total x y :
  lequat 0 x -> lequat 0 y -> lequat x y || lequat y x.
Proof.
case: x => x0 x1; case: y => y0 y1; rewrite /lequat /=.
move=> /andP[/eqP<- x0P] /andP[/eqP<- y0P] /=.
case:  (lerP x0 y0); rewrite eqxx //=.
by apply: ltW.
Qed.

Lemma normQM x y : normQ (x * y) = normQ x * normQ y.
Proof. by rewrite {1}/normQ normqM quat_realM. Qed.

Lemma lequat_def x y : lequat x y = (normQ (y - x) == y - x).
Proof.
case: x => x0 x1; case: y => y0 y1; rewrite /normQ /normq  /sqrq /=.
apply/idP/idP.
  rewrite /lequat /=.
  case/andP => /eqP<- x0Ly0.
  apply/eqP; congr mkQuat; rewrite ?subrr ?expr0n ?addr0 //=.
  rewrite norm0 expr0n addr0 sqrtr_sqr.
  by apply/eqP; rewrite eqr_norm_id subr_ge0.
case/eqP => /eqP H H1.
move: (sym_equal H1) H => /subr0_eq->.
rewrite /lequat /= eqxx /=.
by rewrite subrr norm0 expr0n addr0 sqrtr_sqr eqr_norm_id subr_ge0.
Qed.

Lemma ltquat_def x y : ltquat x y = (y != x) && lequat x y.
Proof.
case: x => x0 x1; case: y => y0 y1 /=.
apply/andP/and3P => [[/eqP<- x0Ly0] | ].
  split=> //.
    by apply/negP; case/eqP => y0E; rewrite y0E // ltxx in x0Ly0.
  by apply: ltW.
rewrite eq_quat negb_and /= => [] [/orP[y0Dx0 | y1Dx1] x1Ey1 x0Ly0];
  split => //.
  by rewrite lt_neqAle eq_sym y0Dx0.
by rewrite eq_sym x1Ey1 in y1Dx1.
Qed.

Fail Definition quat_POrderedMixin :=
  NumMixin lequat_normD ltquat0_add eq0_normQ ge0_lequat_total
           normQM lequat_def ltquat_def.
Fail Canonical Structure quat_numDomainType :=
  NumDomainType _ quat_POrderedMixin.

Definition uquat := [qualify x : quat R | normq x == 1].
Fact uquat_key : pred_key uquat. Proof. by []. Qed.
Canonical uquat_keyed := KeyedQualifier uquat_key.

Lemma uquatE x : (x \is uquat) = (sqrq x == 1).
Proof. by rewrite qualifE /normq -{1}sqrtr1 eqr_sqrt // ?sqrq_ge0// ler01. Qed.

Lemma muluq_proof x y : x \is uquat -> y \is uquat -> x * y \is uquat.
Proof. by rewrite 3!qualifE => /eqP Hq /eqP Hp; rewrite normqM Hq Hp mulr1. Qed.

Lemma invq_uquat x : x \is uquat -> x^-1 = x^*q.
Proof.
by rewrite uquatE => /eqP Hq; rewrite invqE /invq Hq invr1 mul1r scale1r.
Qed.

Lemma invuq_proof x : x \is uquat -> normq (x^-1) == 1.
Proof. by move=> ux; rewrite invq_uquat // normqc. Qed.

Lemma cos_atan_uquat x : x \is uquat -> x \isn't pureq ->
  let a := atan (norm x.2 / x.1) in cos a ^+ 2 = x.1 ^+ 2.
Proof.
move=> ux q00 a.
rewrite cos_atan exprMn [x.1 ^-1 ^+2]exprVn.
have /divff <- : x.1 ^+ 2 !=0 by rewrite sqrf_eq0.
rewrite -mulrDl.
rewrite uquatE /sqrq in ux; rewrite (eqP ux) mul1r.
by rewrite -exprVn sqrtr_sqr normfV invrK sqr_normr.
Qed.

Lemma sin_atan_uquat x : x \is uquat -> x \isn't pureq ->
  let a := atan (norm x.2 / x.1) in sin a ^+ 2 = norm x.2 ^+ 2.
Proof.
move=> ux q00 a.
rewrite /a sqr_sin_atan.
have /divrr <- : x.1 ^+ 2 \in GRing.unit by rewrite unitfE sqrf_eq0.
rewrite uquatE /sqrq in ux.
rewrite expr_div_n -mulrDl.
by rewrite (eqP ux) mul1r invrK -mulrA mulVr ?mulr1 // unitrX // unitfE.
Qed.

End quaternion1.
Arguments uquat {R}.

Section conjugation.
Variable R : realType.
Implicit Types (x : quat R) (u : 'rV[R]_3).

Definition conjugation x u : quat R := x * u%:v * x^*q.

Lemma conjugation_is_pure x u : conjugation x u \is pureq.
Proof.
rewrite pureq_conj /conjugation conjqM conjqI conjqM mulrA -mulrDl -mulrDr.
by have := pureq_conj u%:v; rewrite qualifE /= eqxx => /esym/eqP ->; Simp.r.
Qed.

Lemma conjugationE x u : conjugation x u =
  ((x.1 ^+ 2 - norm x.2 ^+ 2) *: u +
   ((x.2 *d u) *: x.2) *+ 2 +
   (x.1 *: (x.2 *v u)) *+ 2)%:v.
Proof.
case: x => x1 x2 /=; rewrite /conjugation /= /conjq /= mulqE /mulq /=.
rewrite mulr0 scale0r addr0 add0r; congr mkQuat.
  rewrite dotmulvN opprK dotmulDl (dotmulC (_ *v _) x2) dot_crossmulC.
  by rewrite liexx dotmul0v addr0 dotmulZv mulNr mulrC dotmulC addrC subrr.
rewrite scalerDr scalerA -expr2 addrCA scalerBl -!addrA; congr (_ + _).
rewrite [in X in _ + X = _]linearN /= (lieC _ x2) linearD /= opprK.
rewrite linearZ /= (addrA (x1 *: _ )) -mulr2n.
rewrite [in LHS]addrCA 2![in RHS]addrA [in RHS]addrC; congr (_ + _).
rewrite scalerN scaleNr opprK -addrA addrCA; congr (_ + _).
by rewrite double_crossmul [in RHS]addrC dotmulvv.
Qed.

Lemma conjugation_uquat x : x \is uquat -> conjugation x x.2 = (x.2)%:v.
Proof.
rewrite uquatE /sqrq => /eqP xu.
rewrite conjugationE liexx scaler0 mul0rn addr0 dotmulvv scalerBl mulr2n addrA.
by rewrite subrK -scalerDl xu scale1r.
Qed.

Lemma conjugation_axis x k : x \is uquat ->
  conjugation x (k *: x.2) = (k *: x.2)%:v.
Proof.
move=> xu; rewrite /conjugation quat_vectZ -scalerAr -scalerAl.
by rewrite -/(conjugation x x.2) conjugation_uquat.
Qed.

Lemma norm_conjugation x u : x \is uquat -> normq (conjugation x u) = norm u.
Proof.
rewrite qualifE => /eqP x1; rewrite /conjugation 2!normqM normqc x1; Simp.r.
by rewrite normq_vector.
Qed.

End conjugation.

Section polar_coordinates.
Variable R : realType.
Implicit Types (x : quat R) (v : 'rV[R]_3) (a : R).

Definition quat_of_polar a v := mkQuat (cos a) (sin a *: v).

Lemma quat_of_polar01 : quat_of_polar 0 'e_1 = 1%:q.
Proof. by rewrite /quat_of_polar /= cos0 sin0 scale0r. Qed.

Lemma quat_of_polarpi1 : quat_of_polar pi 'e_1 = (-1)%:q.
Proof. by rewrite /quat_of_polar cospi sinpi scale0r. Qed.

Lemma quat_of_polarpihalf v : quat_of_polar (pi / 2%:R) v = v%:v.
Proof. by rewrite /quat_of_polar cos_pihalf sin_pihalf scale1r. Qed.

Lemma uquat_of_polar a v (v1 : norm v = 1) : quat_of_polar a v \is uquat.
Proof.
by rewrite uquatE /quat_of_polar /sqrq /= normZ v1 mulr1 sqr_normr cos2Dsin2.
Qed.

Definition quat_rot x v : 'rV[R]_3 := (conjugation x v).2.

Lemma conjugation_quat_of_polar_axis v a : norm v = 1 ->
  quat_rot (quat_of_polar a v) v = v.
Proof.
move=> v1.
rewrite /quat_rot conjugationE /= normZ exprMn v1 expr1n mulr1 sqr_normr.
rewrite dotmulZv dotmulvv v1 expr1n mulr1 linearZl_LR liexx 2!scaler0 mul0rn.
rewrite addr0 scalerA -expr2 mulr2n scalerBl addrA subrK -scalerDl cos2Dsin2.
by rewrite scale1r.
Qed.

Local Open Scope frame_scope.

Lemma conjugation_quat_of_polar_frame_j (f : frame R) a :
  quat_rot (quat_of_polar a f~i) f~j =
  cos (a *+ 2) *: f~j + sin (a *+ 2) *: f~k.
Proof.
rewrite /quat_rot conjugationE /= normZ noframe_norm mulr1 sqr_normr dotmulZv.
have v0 : f~i != 0 by rewrite -norm_eq0 noframe_norm oner_neq0.
rewrite (noframe_idotj f) mulr0 scale0r mul0rn addr0 linearZl_LR /=.
rewrite (frame_icrossj f) scalerA [in RHS]mulr2n cosD sinD -!expr2.
by congr (_ + _); rewrite (mulrC (sin a)) -mulr2n -scalerMnl.
Qed.

Lemma conjugation_quat_of_polar_frame_k (f : frame R) a :
  quat_rot (quat_of_polar a f~i) f~k =
  - sin (a *+ 2) *: f~j + cos (a *+ 2) *: f~k.
Proof.
rewrite /quat_rot conjugationE /= normZ noframe_norm mulr1 sqr_normr dotmulZv.
have v0 : f~i != 0 by rewrite -norm_eq0 noframe_norm oner_neq0.
rewrite (noframe_idotk f) mulr0 scale0r mul0rn addr0 linearZl_LR /=.
rewrite (frame_icrossk f) 2!scalerN scalerA sinD cosD -!expr2 addrC scaleNr.
by congr (_ + _); rewrite (mulrC (sin a)) -mulr2n -scalerMnl mulNrn.
Qed.

Definition polar_of_quat x : (R * 'rV_3)%type :=
  if x.2 == 0 then
    if x.1 == 1 then (0, 'e_1) else (pi, 'e_1)
  else if x.1 == 0 then (pi / 2%:R, x.2) else
  let: u := normalize x.2 in
  let: a := atan (norm x.2 / x.1) in
  if 0 < x.1 then (a, u) else (a + pi, u).

Lemma polar_of_quat0 : polar_of_quat 0 = (pi, 'e_1).
Proof. by rewrite /polar_of_quat eqxx eq_sym oner_eq0. Qed.

Lemma norm_polar_of_quat x : x \is uquat -> norm (polar_of_quat x).2 = 1.
Proof.
case: x => a0 a1; rewrite /= qualifE /polar_of_quat /normq /sqrq /=.
have [/eqP ->|a10] := ifPn; first by case: ifPn; rewrite norm_delta_mx.
case: (sgzP a0) => [-> /eqP| |]; try by rewrite norm_normalize.
by rewrite expr0n add0r sqrtr_sqr ger0_norm // norm_ge0.
Qed.

Lemma polar_of_quatK x : x \is uquat ->
  quat_of_polar (polar_of_quat x).1 (polar_of_quat x).2 = x.
Proof.
case: x => a0 a1; rewrite /= qualifE /polar_of_quat /normq /sqrq /=.
have [->|/eqP a1N u1] := a1 =P 0.
  rewrite norm0 expr0n addr0 sqrtr_sqr; have [?/eqP->|?|_] := ltrgt0P a0.
  - by rewrite eqxx quat_of_polar01.
  - by rewrite eqr_oppLR => /eqP ->; rewrite eqrNxx oner_eq0 quat_of_polarpi1.
  - by rewrite eq_sym oner_eq0.
move: u1; have [-> _|a0P /eqP u1 |a0N /eqP u1] := sgzP a0.
- by rewrite quat_of_polarpihalf.
- congr mkQuat.
    by rewrite cos_atan sqrtr_1sqr2 ?gt_eqF// gtr0_norm// invrK.
  rewrite sin_atan sqrtr_1sqr2 ?gt_eqF// gtr0_norm// invrK -mulrA.
  by rewrite mulVf ?gt_eqF// mulr1 norm_scale_normalize.
- congr mkQuat.
    rewrite cosDpi cos_atan sqrtr_1sqr2 ?lt_eqF// invrK ltr0_norm//.
    by rewrite opprK.
  rewrite sinDpi sin_atan sqrtr_1sqr2// ?lt_eqF// ltr0_norm// 2!invrN mulrN.
  by rewrite invrK opprK -mulrA mulVf ?lt_eqF// mulr1 norm_scale_normalize.
Qed.

Lemma quat_rot_is_linear x : linear (quat_rot x).
Proof.
move=> k u v; rewrite /quat_rot !conjugationE.
rewrite scalerDr scalerA (mulrC _ k) -scalerA.
rewrite 2![in RHS]scalerDr -2![in LHS]addrA -3![in RHS]addrA; congr (_ + _).
rewrite [in RHS]addrA [in RHS]addrCA -[in RHS]addrA; congr (_ + _).
rewrite dotmulDr scalerDl mulrnDl -addrA addrCA; congr (_ + _).
rewrite dotmulvZ -scalerA scalerMnr -addrA; congr (_ + _).
rewrite linearD /= scalerDr mulrnDl; congr (_ + _).
by rewrite linearZ /= scalerA mulrC -scalerA -scalerMnr.
Qed.
Canonical quat_rot_linear x := Linear (quat_rot_is_linear x).

Lemma quat_rot_isRot_polar v a : norm v = 1 ->
  isRot (a *+2) v [linear of quat_rot (quat_of_polar a v)].
Proof.
move=> v1 /=.
have vE : (Base.frame v)~i = v by rewrite Base.frame0E // ?normalizeI // norm1_neq0.
apply/isRotP; split => /=.
- by rewrite conjugation_quat_of_polar_axis.
- by rewrite -{1}vE conjugation_quat_of_polar_frame_j.
- by rewrite -{1}vE conjugation_quat_of_polar_frame_k.
Qed.

Lemma quat_rot_isRot x : x \is uquat ->
  let: a := (polar_of_quat x).1 in
  let: u := (polar_of_quat x).2 in
  isRot (a *+ 2) u [linear of quat_rot x].
Proof.
move=> ux /=; set a := _.1; set u := _.2.
by rewrite -(polar_of_quatK ux) quat_rot_isRot_polar // norm_polar_of_quat.
Qed.

Local Open Scope quat_scope.

(* [bottema] p.150 (2.1) *)
(* compared to cayleyij:
the Rodrigues' parameters a, b, c are "normalized" into r a, b r, c r with r != 0
we have the relation
(1 + a^2 + b^2 + c^2) cayley_transform = cayley_matrix
(r^2 + a^2 + b^2 + c^2) cayley_transform = hcayley_matrix
*)
Definition hcayley00 (r a b c : R) := r ^+ 2 + a ^+ 2 - b ^+ 2 - c ^+ 2.
Definition hcayley01 (r a b c : R) := (a * b - r * c) *+ 2.
Definition hcayley02 (r a b c : R) := (a * c + r * b) *+ 2.
Definition hcayley10 (r a b c : R) := (a * b + r * c) *+ 2.
Definition hcayley11 (r a b c : R) := r ^+ 2 - a ^+ 2 + b ^+ 2 - c ^+ 2.
Definition hcayley12 (r a b c : R) := (b * c - r * a) *+ 2.
Definition hcayley20 (r a b c : R) := (a * c - r * b) *+ 2.
Definition hcayley21 (r a b c : R) := (b * c + r * a) *+ 2.
Definition hcayley22 (r a b c : R) := r ^+ 2 - a ^+ 2 - b ^+ 2 + c ^+ 2.

Lemma matrix_of_quat_rot (q : quat R) (u : 'rV[R]_3) :
(*  q \is uquat ->*)
  let: r := q.1 in let: a := q _i in let: b := q _j in let: c := q _k in
  quat_rot q u =
    u *m (col_mx3
    (row3 (hcayley00 r a b c) (hcayley01 r a b c) (hcayley02 r a b c))
    (row3 (hcayley10 r a b c) (hcayley11 r a b c) (hcayley12 r a b c))
    (row3 (hcayley20 r a b c) (hcayley21 r a b c) (hcayley22 r a b c)))^T.
Proof.
have F (e1 q1 u1 : 'rV[R]_3) : \det (col_mx3 e1 q1 u1) =
  e1``_0 * (q1``_1 * u1``_2%:R - u1``_1 * q1``_2%:R) +
  e1``_1 * (u1``_0 * q1``_2%:R - q1``_0 * u1``_2%:R) +
  e1``_2%:R * (q1``_0 * u1``_1 - u1``_0 * q1``_1).
  by rewrite det_mx33 !mxE.
apply/row3P; apply/and3P; split; apply/eqP.
(* ForAll[{u1, u2, u3, q1, q21, q22, q23},
  q1^2 + q21^2 + q22^2 + q23^2 == 1,
  ((q1^2 - q21^2 - q22^2 - q23^2) {u1, u2, u3} +
      2 (Dot[{q21, q22, q23}, {u1, u2, u3}] {q21, q22, q23}) +
      2 (q1 Cross[{q21, q22, q23}, {u1, u2, u3}]))[[1]] ==
   u1 (q1^2 + q21^2 - q22^2 - q23^2) +
    u2 (2 (q21*q22 - q1*q23)) +
    u3 (2 (q21*q23 + q1*q22))] // Resolve*)
- rewrite !(mxE, sum3E) /=.
  rewrite /crossmul; unlock.
  rewrite !(mxE, sum3E) /= !F !mxE /= !F !mxE /=.
  rewrite !dotmulE sum3E /=.
  rewrite /hcayley00 /hcayley01 /hcayley02 !expr2 !mulr2n.
  nsatz.
(* ForAll[{u1, u2, u3, q1, q21, q22, q23},
  q1^2 + q21^2 + q22^2 + q23^2 == 1,
  ((q1^2 - q21^2 - q22^2 - q23^2) {u1, u2, u3} +
      2 (Dot[{q21, q22, q23}, {u1, u2, u3}] {q21, q22, q23}) +
      2 (q1 Cross[{q21, q22, q23}, {u1, u2, u3}]))[[2]] ==
   u1 (2 (q21*q22 + q1*q23)) +
    u2 (q1^2 - q21^2 + q22^2 - q23^2) +
    u3 (2 (q22*q23 - q1*q21))] // Resolve *)
- rewrite !(mxE, sum3E) /=.
  rewrite /crossmul; unlock.
  rewrite !(mxE, sum3E) /= !F /= !mxE /= !F !mxE /=.
  rewrite !dotmulE sum3E /=.
  rewrite /hcayley10 /hcayley11 /hcayley12 !expr2 !mulr2n.
  nsatz.
(* ForAll[{u1, u2, u3, q1, q21, q22, q23},
  q1^2 + q21^2 + q22^2 + q23^2 == 1,
  ((q1^2 - q21^2 - q22^2 - q23^2) {u1, u2, u3} +
      2 (Dot[{q21, q22, q23}, {u1, u2, u3}] {q21, q22, q23}) +
      2 (q1 Cross[{q21, q22, q23}, {u1, u2, u3}]))[[3]] ==
   u1 (2 (q21*q23 - q1*q22)) +
    u2 (2 (q22*q23 + q1*q21)) +
    u3 (q1^2 - q21^2 - q22^2 + q23^2)] // Resolve *)
rewrite !(mxE, sum3E) /=.
rewrite /crossmul; unlock.
rewrite !(mxE, sum3E) /= !F /= !mxE /= !F !mxE /=.
rewrite !dotmulE sum3E /=.
rewrite /hcayley20 /hcayley21 /hcayley22 !expr2 !mulr2n.
nsatz.
Qed.

End polar_coordinates.

Section dual_number.
Variable R : ringType.
Implicit Types r : R.
Record dual := mkDual {ldual : R ; rdual : R}.
Implicit Types x y : dual.

Local Notation "x +ɛ* y" := (mkDual x y).
Local Notation "x -ɛ* y" := (mkDual x (- y)).

Definition dual0 : dual := 0 +ɛ* 0.
Definition dual1 : dual := 1 +ɛ* 0.

Coercion pair_of_dual x : R * R := let: mkDual x1 x2 := x in (x1, x2).

Let dual_of_pair (z : R * R) := let: (z1, z2) := z in z1 +ɛ* z2.

Lemma dual_of_pairK : cancel pair_of_dual dual_of_pair.
Proof. by case. Qed.

Definition dual_eqMixin := CanEqMixin dual_of_pairK.
Canonical Structure dual_eqType := EqType dual dual_eqMixin.
Definition dual_choiceMixin := CanChoiceMixin dual_of_pairK.
Canonical Structure dual_choiceType := ChoiceType dual dual_choiceMixin.

Definition oppd x := (- x.1) +ɛ* (- x.2).

Definition addd x y := (x.1 + y.1) +ɛ* (x.2 + y.2).

Definition muld x y := x.1 * y.1 +ɛ* (x.1 * y.2 + x.2 * y.1).

Definition deps : 'M[R]_2 :=
  \matrix_(i < 2, j < 2) ((i == 0) && (j == 1))%:R.

Lemma deps2 : deps ^+2 = 0.
Proof.
rewrite expr2; apply/matrixP => i j.
by rewrite !mxE sum2E !mxE /= mulr0 addr0 -ifnot01 eqxx andbF mul0r.
Qed.

Definition mat_of_dual x : 'M[R]_2 := x.1%:M + x.2 *: deps.

Definition dual_of_mat (M : 'M[R]_2) := (M 0 0) +ɛ* (M 0 1).

Lemma adddE x y : addd x y = dual_of_mat (mat_of_dual x + mat_of_dual y).
Proof.
rewrite /addd /dual_of_mat /mat_of_dual /= !mxE; congr mkDual.
by rewrite !eqxx !(mulr1n,andbF,mulr1,mulr0,addr0).
by rewrite !mulr0n !eqxx !mulr1 !add0r.
Qed.

Lemma muldE x y : muld x y = dual_of_mat (mat_of_dual x * mat_of_dual y).
Proof.
rewrite /muld /dual_of_mat /mat_of_dual /= !mxE !sum2E !mxE; congr mkDual.
by rewrite !eqxx !(mulr0n,mulr1n,mulr0,mulr1,addr0).
by rewrite !eqxx !(mulr0n,mulr1n,mulr0,add0r,addr0,mulr1).
Qed.

Lemma adddA : associative addd.
Proof. by move=> x y z; rewrite /addd 2!addrA. Qed.

Lemma adddC : commutative addd.
Proof. by move=> x y; rewrite /addd addrC [in X in _ +ɛ* X = _]addrC. Qed.

Lemma add0d : left_id dual0 addd.
Proof. by move=> x; rewrite /addd 2!add0r; case: x. Qed.

Lemma addNd : left_inverse dual0 oppd addd.
Proof. by move=> x; rewrite /addd 2!addNr. Qed.

Definition dual_ZmodMixin := ZmodMixin adddA adddC add0d addNd.
Canonical dual_ZmodType := ZmodType dual dual_ZmodMixin.

Lemma addd_def x y : x + y = (x.1 + y.1) +ɛ* (x.2 + y.2).
Proof. by []. Qed.

Lemma muldA : associative muld.
Proof.
move=> x y z; rewrite /muld; congr mkDual; first by rewrite mulrA.
by rewrite mulrDr mulrDl !mulrA addrA.
Qed.

Lemma mul1d : left_id dual1 muld.
Proof. by case=> x0 x1; rewrite /muld 2!mul1r mul0r addr0. Qed.

Lemma muld1 : right_id dual1 muld.
Proof. by case=> x0 x1; rewrite /muld 2!mulr1 mulr0 add0r. Qed.

Lemma muldDl : left_distributive muld addd.
Proof.
move=> x y z; rewrite /muld /addd mulrDl; congr mkDual.
by rewrite mulrDl -!addrA; congr (_ + _); rewrite mulrDl addrCA.
Qed.

Lemma muldDr : right_distributive muld addd.
Proof.
move=> x y z; rewrite /muld /addd mulrDr; congr mkDual.
by rewrite mulrDr -!addrA; congr (_ + _); rewrite mulrDr addrCA.
Qed.

Lemma oned_neq0 : dual1 != 0 :> dual.
Proof. by apply/eqP; case; apply/eqP; exact: oner_neq0. Qed.

Definition dual_RingMixin := RingMixin muldA mul1d muld1 muldDl muldDr oned_neq0.
Canonical Structure dual_Ring := Eval hnf in RingType dual dual_RingMixin.

Lemma muld_def x y : x * y = x.1 * y.1 +ɛ* (x.1 * y.2 + x.2 * y.1).
Proof. by []. Qed.

Definition scaled r x := r * x.1 +ɛ* (r * x.2).

Lemma scaledA a b x : scaled a (scaled b x) = scaled (a * b) x.
Proof. by rewrite /scaled /=; congr mkDual; rewrite mulrA. Qed.

Lemma scaled1 : left_id 1 scaled.
Proof. by rewrite /left_id /scaled /=; case=> ? ? /=; rewrite !mul1r. Qed.

Lemma scaledDr : @right_distributive R dual scaled +%R.
Proof. by move=> r x y; rewrite /scaled /= !mulrDr. Qed.

Lemma scaledDl x : {morph (scaled^~ x : R -> dual) : a b / a + b}.
Proof. by move=> a b; rewrite /scaled !mulrDl. Qed.

Definition dual_lmodMixin := LmodMixin scaledA scaled1 scaledDr scaledDl.
Canonical dual_lmodType := Eval hnf in LmodType R dual dual_lmodMixin.

Definition conjd x := x.1 -ɛ* x.2.
Local Notation "x '^*d'" := (conjd x).

Definition duall (r : R) := r +ɛ* 0.

Local Notation "*%:dl" := duall (at level 2).
Local Notation "r %:dl" := (duall r) (at level 2).

Fact duall_is_rmorphism : rmorphism *%:dl.
Proof.
split => [p q|]; first by congr mkDual; rewrite /= subrr.
split => [p q|] //; by congr mkDual; rewrite /=; Simp.r.
Qed.
Canonical duall_rmorphism := RMorphism duall_is_rmorphism.

(* Sanity check : Taylor series for polynomial *)
Lemma dual_deriv_poly (p : {poly R}) r :
  (map_poly *%:dl p).[r +ɛ* 1] = p.[r] +ɛ* p^`().[r].
Proof.
elim/poly_ind : p => [|p b IH]; first by rewrite map_poly0 deriv0 !horner0.
rewrite !(rmorphD, rmorphM) /= map_polyX (map_polyC duall_rmorphism) /=.
rewrite derivD derivC derivM derivX; Simp.r.
rewrite !hornerMXaddC hornerD hornerMX IH; congr mkDual => /=.
by Simp.r; rewrite addrC.
Qed.

End dual_number.

Notation "a +ɛ* b" := (mkDual a b) : dual_scope.
Notation "a -ɛ* b" := (mkDual a (- b)) : dual_scope.

Section dual_comm.
Variable R : comRingType.

Fact muld_comm (p q : dual R) : p * q = q * p.
Proof.
case: p => p1 p2; case: q => q1 q2; rewrite !muld_def /=.
by rewrite addrC mulrC [p2 * _]mulrC [q2 * _]mulrC.
Qed.
Canonical dual_comRingType := Eval hnf in ComRingType (dual R) muld_comm.

End dual_comm.

Section dual_number_unit.
Variable R : unitRingType.
Local Open Scope dual_scope.
Implicit Types x y : dual R.

Definition unitd : pred (dual R) := [pred x : dual R | x.1 \is a GRing.unit].

Definition invd x :=
  if x \in unitd then x.1^-1 -ɛ* (x.1^-1 * x.2 * x.1^-1) else x.

(* NB: invd was previously written using matrices *)
Fact invdE x : x \in unitd ->
  invd x = dual_of_mat (x.1^-1%:M * (1 - deps R * x.2%:M * (x.1)^-1%:M)).
Proof.
move : x => [q r] /=; rewrite inE /= => qu; rewrite /invd inE /= qu.
by rewrite /dual_of_mat !(mxE,sum2E) /=; Simp.r.
Qed.

Lemma mulVd : {in unitd, left_inverse 1 invd *%R}.
Proof.
move=> [q r]; rewrite inE /= => qu.
by rewrite /invd inE qu muld_def /= mulNr -mulrA !mulVr// mulr1 subrr.
Qed.

Lemma muldV : {in unitd, right_inverse 1 invd *%R}.
Proof.
move=> [q r]; rewrite inE /= => qu; rewrite /invd inE qu /= muld_def /=.
by rewrite mulrN 2!mulrA divrr// mul1r addrC subrr.
Qed.

Lemma unitdP x y : y * x = 1 /\ x * y = 1 -> unitd x.
Proof. by rewrite 2!muld_def => -[[? _] [? _]]; apply/unitrP; exists y.1. Qed.

(* The inverse of a non-unit x is constrained to be x itself *)
Lemma invd0id : {in [predC unitd], invd =1 id}.
Proof. by move=> x; rewrite inE /= /invd => /negbTE ->. Qed.

Definition dual_UnitRingMixin := UnitRingMixin mulVd muldV unitdP invd0id.
Canonical dual_unitRing := UnitRingType (dual R) dual_UnitRingMixin.

End dual_number_unit.

Section dual_quaternion.
Variable R : realType (*realType*).
Local Open Scope dual_scope.

Definition dquat := @dual (quat_unitRing R).

Implicit Types x y : dquat.

Definition conjdq x : dquat := (x.1)^*q +ɛ* (x.2)^*q.

Canonical Conjugate_dquaternion := @Build_Conjugate (@dual (quat_unitRing R)) conjdq.

Lemma conjdq_def x : x^*q = (x.1)^*q +ɛ* (x.2)^*q.
Proof. by case: x. Qed.

Lemma conjdqD x y : (x + y)^*q = x^*q + y^*q.
Proof. by rewrite conjdq_def /= 2!linearD. Qed.

Lemma conjdqI x : (x^*q)^*q = x.
Proof. by rewrite !conjdq_def /= !conjqI; case: x. Qed.

Lemma conjdq0 : (0 : dquat)^*q = 0.
Proof. by rewrite conjdq_def /= conjq0. Qed.

Lemma conjdqM x y : (x * y)^*q = y^*q * x^*q.
Proof.
rewrite /= conjdq_def /= !muld_def /= !conjqM; congr mkDual.
by rewrite linearD /= !conjqM addrC.
Qed.

Lemma conjdq_comm x : x^*q * x = x * x^*q.
Proof. by rewrite conjdq_def /= !muld_def /= conjq_comm conjq_comm2 addrC. Qed.

Lemma conjdq_unit x : (x^*q \is a GRing.unit) = (x \is a GRing.unit).
Proof.
case: x => [] [a0 av] [b0 bv].
by rewrite !qualifE /= /unitd /= !qualifE /= /unitq /= !eq_quat /= oppr_eq0.
Qed.

Definition puredq := [qualify x : dquat | (x.1 \is pureq) && (x.2 \is pureq)].
Fact puredq_key : pred_key puredq. Proof. by []. Qed.
Canonical puredq_keyed := KeyedQualifier puredq_key.

Definition dnum := [qualify x : dquat | x^*q == x].
Fact dnum_key : pred_key dnum. Proof. by []. Qed.
Canonical dnum_keyed := KeyedQualifier dnum_key.

Lemma dnumE x : (x \is dnum) = (x^*q == x).
Proof. by []. Qed.

Lemma dnumE' x : (x \is dnum) = (x.1.2 == 0) && (x.2.2 == 0).
Proof.
case: x => [] [a1 a2] [b1 b2]; rewrite dnumE /conjdq /=.
by rewrite -[a2 == 0]andTb -[b2 == 0]andTb;
   congr ((_ && _) && (_ && _)); rewrite ?eqxx //= eq_sym
     -subr_eq0 opprK -mulr2n -scaler_nat scalemx_eq0 (eqr_nat _ 2 0).
Qed.

Lemma dnumE'' x : (x \is dnum) = (x == (x.1.1)%:q +ɛ* (x.2.1)%:q).
Proof.
case: x => [] [a1 a2] [b1 b2]; rewrite dnumE' /=.
by rewrite -[a2 == 0]andTb -[b2 == 0]andTb;
   congr ((_ && _) && (_ && _)); rewrite /= !eqxx.
Qed.

Lemma dnumD x y : x \is dnum -> y \is dnum -> x + y \is dnum.
Proof. by rewrite 3!dnumE conjdqD => /eqP-> /eqP->. Qed.

Lemma dnum0 : 0 \is dnum.
Proof. by rewrite dnumE' eqxx. Qed.

Lemma dnum1 : 1 \is dnum.
Proof. by rewrite dnumE' eqxx. Qed.

Lemma dnum_nat n : n%:R \is dnum.
Proof.
elim: n => [|n IH]; first by rewrite dnum0.
by rewrite -add1n natrD dnumD // dnum1.
Qed.

Lemma dnumM x y : x \is dnum -> y \is dnum -> x * y \is dnum.
Proof.
rewrite 3!dnumE' muld_def /= => /andP[/eqP-> /eqP->] /andP[/eqP-> /eqP->].
by rewrite !linear0r !scaler0 !add0r eqxx.
Qed.

Lemma dnumM_comm x y : x \is dnum -> y * x = x * y.
Proof.
case: y => done1 y2; rewrite dnumE'' => /eqP->.
by rewrite !muld_def /= !quat_algE -!quatAr -!quatAl !mulr1 !mul1r addrC.
Qed.

(* squared norm *)
Definition sqrdq x : dquat := x * x^*q.

Lemma dnum_sqrdq x : sqrdq x \in dnum.
Proof. by rewrite dnumE conjdqM conjdqI. Qed.

(* inverse *)
Definition invdq x : dquat := x^-1.

Lemma invdqEl x : x.1 != 0 -> invdq x = (sqrdq x)^-1 * (x^*q).
Proof.
move=> aD; rewrite /sqrdq -conjdq_comm invrM  ?conjdq_unit //.
by rewrite divrK ?conjdq_unit.
Qed.

Lemma invdqEr x : x.1 != 0 -> invdq x = (x^*q) * (sqrdq x)^-1.
Proof.
move=> aD; rewrite /sqrdq invrM  ?conjdq_unit // mulrA.
by rewrite mulrV ?mul1r // ?conjdq_unit.
Qed.

(* unit dual quaternions *)
Definition udquat := [qualify x : dquat | sqrdq x == 1].
Fact udquat_key : pred_key udquat. Proof. by []. Qed.
Canonical udquat_keyed := KeyedQualifier udquat_key.

Lemma udquatE x : (x \is udquat) = (sqrdq x == 1).
Proof. by []. Qed.

Lemma invdq_udquat x : x \is udquat -> x^-1 = x^*q.
Proof.
rewrite udquatE => /eqP sqE.
suff x1NZ : x.1 != 0 by rewrite [x^-1]invdqEl // sqE invr1 mul1r.
apply/eqP=> x1Z.
move/eqP: sqE; rewrite [sqrdq _]muld_def x1Z !mul0r => /andP[] /=.
by rewrite eq_sym oner_eq0.
Qed.

End dual_quaternion.

(* WIP: dual quaternions and rigid body transformations *)
Section dquat_rbt.
Variable R : realType (*realType*).
Local Open Scope dual_scope.
Implicit Types u x : dquat R.

Definition dconjugation (u : dquat R)(*unit dual quaternion*)
                        (x : dquat R)(*dual vector quaternion*) := u * x * u ^*q.

Definition dquat_from_rot_trans (r t : quat R)
  (_ : r \is uquat) (_ : r \isn't pureq) (_ : (polar_of_quat r).1 != 0)
  (* i.e., rotation around (polar_of_quat r).1 of angle (polar_of_quat r).2 *+ 2 *)
  (_ : t \is pureq)
  : dquat R := r +ɛ* t.

Definition rot_trans_from_dquat x := (x.1, 2%:R *: (x.2 * x.1^*q)).

End dquat_rbt.


Require Import VST.floyd.proofauto.

(*Model-level definitions and associated lemmas.*)

Definition sumlist : list Z -> Z := fold_right Z.add Z0.

Fixpoint decreasing (n: nat) :=
 match n with
 | O => nil
 | S n' => Z.of_nat n :: decreasing n'
 end.

Fixpoint triang (n: nat) :=
 match n with
 | O => 0
 | S n' => Z.of_nat n + triang n'
 end.

Lemma triangular_number:
  forall n, 0 <= n ->
     sumlist (decreasing (Z.to_nat n)) = n*(n+1)/2.
Proof.
intros.
assert (2* sumlist (decreasing (Z.to_nat n)) = n * (n + 1))%Z.
2: rewrite <- H0, Z.mul_comm, Z.div_mul by lia; auto.
rewrite <- (Z2Nat.id n) at 2 3 by lia.
clear H.
induction (Z.to_nat n).
reflexivity.
rewrite inj_S.
unfold decreasing; fold decreasing.
change (sumlist (Z.of_nat (S n0) :: decreasing n0))
  with (Z.of_nat (S n0) + sumlist (decreasing n0)).
rewrite Z.mul_add_distr_l.
rewrite IHn0.
clear.
rewrite inj_S.
forget (Z.of_nat n0) as n.
unfold Z.succ.
rewrite !Z.mul_add_distr_l.
rewrite !Z.mul_add_distr_r.
lia.
Qed.

Lemma sumlist_decreasing_bound:
  forall n, 0 <= n < 1000 ->
  0 <= sumlist (decreasing (Z.to_nat n)) <= Int.max_signed.
Proof.
intros.
rewrite triangular_number by lia.
split.
apply Z.div_pos; try lia.
(*apply Z.mul_nonneg_nonneg; lia.*)
apply Z.div_le_upper_bound; try lia.
eapply Z.le_trans.
apply Z.mul_le_mono_nonneg; try lia.
instantiate (1:=1001); lia.
instantiate (1:=1001); lia.
computable.
Qed.

Lemma sumlist_nonneg: forall sigma,
  Forall (Z.le 0) sigma -> 0 <= sumlist sigma.
Proof.
intros.
induction sigma; simpl. lia. inv H.
apply IHsigma in H3; lia.
Qed.

Lemma decreasing_inc i (I:0 <= i):
  i + 1 :: decreasing (Z.to_nat i) = decreasing (Z.to_nat (i + 1)).
Proof.
    replace (Z.to_nat (i+1)) with (S (Z.to_nat i)).
    unfold decreasing; fold decreasing.
    + f_equal. rewrite inj_S. rewrite Z2Nat.id by lia. lia.
    + rewrite <- Z2Nat.inj_succ by lia. f_equal; lia.
Qed.


(* NOMBRE COMPLETO: Agustín Mista *)

Section Problema1.

  Require Export List.
  Require Export Arith.
  Print beq_nat.

  Set Implicit Arguments.

  (* 1.a *)
  Fixpoint eliminar (z : nat) (l : list nat) : list nat :=
    match l with
    | nil => nil
    | cons x xs =>
      if beq_nat x z
      then xs
      else cons x (eliminar z xs)
    end.

  (* 1.b *)
  Fixpoint pertenece (z : nat) (l : list nat) : bool :=
    match l with
    | nil => false
    | cons x xs =>
      if beq_nat x z
      then true
      else pertenece z xs
    end.

  (* 1.c *)
  Fixpoint concatenar (A : Set) (l1 l2 : list A) : list A :=
    match l1 with
    | nil => l2
    | cons x l1' => cons x (concatenar l1' l2)
    end.

  (* 1.d.1 *)
  Lemma L1_1 : forall (A : Set) (l : list A) (x : A), l <> x::l.
  Proof.
    intros. induction l; unfold not; intros.
    - discriminate.
    - injection H. intros.
      apply IHl. rewrite <- H1. auto.
  Qed.

  (* 1.d.2 *)
  Lemma L1_2 : forall (l1 l2 : list nat) (x : nat),
      pertenece x (concatenar l1 l2) = true ->
      pertenece x l1 = true \/ pertenece x l2 = true.
  Proof.
    intros. induction l1.
    - simpl in H. right. auto.
    - simpl in H. case (a =? x) eqn:eq1.
      + simpl. rewrite eq1. left. auto.
      + apply IHl1 in H. elim H; intros.
        * left. simpl. rewrite eq1. auto.
        * right. auto.
  Qed.

  (* 1.d.3 *)
  Lemma L1_3 : forall (l : list nat) (x : nat),
      pertenece x l = true -> eliminar x l <> l.
  Proof.
    intros. induction l.
    - inversion H.
    - simpl. case (a =? x) eqn:eq1.
      + apply L1_1.
      + simpl in H. rewrite eq1 in H.
        apply IHl in H. injection.
        contradiction.
  Qed.

End Problema1.

Section Problema2.

  Require Import Coq.Bool.Bool.

  (* 2.a *)
  Inductive distintas (A:Set) : list A -> list A -> Prop :=
  | distintas_nil : distintas nil nil
  | distintas_cons : forall l1 l2 x y,
      x <> y -> distintas l1 l2 -> distintas (cons x l1) (cons y l2).

  Hint Constructors distintas.

  (* 2.b *)
  Lemma L2 : forall (l1 : list bool), { l2 : list bool | distintas l1 l2 }.
  Proof.
    intros. induction l1.
    - exists nil. auto.
    - elim IHl1. intros. exists (cons (negb a) x). constructor; auto.
      case a eqn:eq1; simpl; unfold not; intros; discriminate.
  Qed.

End Problema2.

(* 2.3 *)
Extraction Language Haskell.
Extract Inductive bool => "Bool" [ "true" "false" ].
Extraction "L2" L2.

Section Problema3.

  Definition Var := nat.
  Definition Valor := nat.

  Definition Memoria := Var -> Valor.

  (* 3.a *)
  Inductive Instr : Set :=
  | IVar : Var -> Valor -> Instr
  | ISeq : Instr -> Instr -> Instr
  | IIf  : Var -> Valor -> Instr -> Instr -> Instr.

  (* 3.b *)
  Definition lookup (m : Memoria) (v : Var) : Valor := m v.

  Definition update (m : Memoria) (v : Var) (w : Valor) : Memoria :=
    fun v' => if beq_nat v v'
              then w
              else m v'.

  (* 3.c *)
  Inductive Execute : Memoria -> Instr -> Memoria -> Prop :=
  | XAss : forall var val mem,
      Execute mem (IVar var val) (update mem var val)
  | XSeq : forall ins1 ins2 mem1 mem2 mem3,
      Execute mem1 ins1 mem2
      -> Execute mem2 ins2 mem3
      -> Execute mem1 (ISeq ins1 ins2) mem3
  | XIfT : forall var val ins1 ins2 mem1 mem2,
      lookup mem1 var = val
      -> Execute mem1 ins1 mem2
      -> Execute mem1 (IIf var val ins1 ins2) mem2
  | XIfF : forall var val ins1 ins2 mem1 mem2,
      lookup mem1 var <> val
      -> Execute mem1 ins2 mem2
      -> Execute mem1 (IIf var val ins1 ins2) mem2.

  Hint Constructors Execute.

  (* 3.d *)
  Lemma L3_1 : forall (m1 m2 : Memoria) (var : Var) (val : Valor),
      Execute m1 (IVar var val) m2 -> lookup m2 var = val.
  Proof.
    intros. inversion H. unfold update, lookup.
    rewrite <- beq_nat_refl. auto.
  Qed.

  Lemma L3_2 : forall (m1 m2 : Memoria) (v : Var) (val : Valor) (i1 i2 : Instr),
      lookup m1 v <> val
      -> Execute m1 (IIf v val i1 i2) m2
      -> Execute m1 i2 m2.
  Proof.
    intros. unfold not in H.
    inversion_clear H0; auto.
    contradiction.
  Qed.

  Require Import Omega.

  Lemma L3_3: forall (m1 m2 m3 : Memoria) (v1 v2 : Var) (val : Valor) (i1 i2 : Instr),
      v2 <> v1
      -> Execute m1 (ISeq (IVar v1 val) (IVar v2 (val + 1))) m2
      -> Execute m2 i2 m3
      -> Execute m2 (IIf v2 (lookup m2 v1) i1 i2) m3.
  Proof.
    intros. apply XIfF.
    - inversion H0. inversion H5. rewrite <- H9 in H7. inversion H7.
      unfold lookup, update. rewrite <- beq_nat_refl. rewrite <- beq_nat_refl.
      elim (beq_nat_false_iff v2 v1). intros. rewrite (H17 H). omega.
    - inversion H0. auto.
  Qed.

End Problema3.


Require Import ZArith Bool.

Inductive Z_btree : Set :=
 | Z_leaf : Z_btree
 | Z_bnode : Z->Z_btree->Z_btree->Z_btree.

Fixpoint value_present (z:Z)(t:Z_btree) : bool :=
   match t with
   | Z_leaf => false
   | Z_bnode z1  t1 t2 => Zeq_bool z z1 ||
                          value_present z t1  ||
                          value_present z t2
   end.


Require Import List.
Require Import Arith.
Require Import Arith.Max.

Require Import set.
Require Import order.
Require Import elements.

Lemma order_elements : forall (a x:set), In x (elements a) -> order x < order a.
Proof. intro a. elim a. (* induction on a*)
  (* a = Empty *)
  simpl. intro x. apply False_ind.
  (* a = Singleton x *)
  clear a. intro x. intro H. clear H. intro z. simpl. intro H. elim H. intro H'.
  rewrite <- H'. unfold lt. apply le_n. apply False_ind.
  (* a = Union x y *)
  clear a. intros x Hx y Hy z. simpl. intro H.
  cut(In z (elements x) \/ In z (elements y)). intro H'. elim H'.

  intro Hx'. unfold lt. apply le_S. apply le_trans with (m:= order x).
  apply Hx. exact Hx'. apply le_max_l.

  intro Hy'. unfold lt. apply le_S. apply le_trans with (m:= order y).
  apply Hy. exact Hy'. apply le_max_r.

  apply in_app_or. exact H.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (z : natural) (lf2 : natural) : natural :=
  plus (mult (Succ y) z) lf2.


Print bool.

Print bool_rect.
Print bool_ind.
Print bool_rec.

(* negate *)
Definition match_true := match true with true => false | false => true end.

Check match_true.
Eval compute in match_true.

Definition nat_of_bool := bool_rec (fun _ => nat) 1 0.

Check (nat_of_bool : bool -> nat).

Eval compute in (nat_of_bool false).

Definition dep_of_bool := bool_rec (fun b => match b with true => nat | false => bool end) 1 true.

Check (dep_of_bool : forall b, match b with true => nat | false => bool end).

Eval compute in (dep_of_bool false).

Definition dep_of_bool2 b : match b with true => nat | false => bool end :=
  match b with
      true => 1
    | false => true
  end.

Goal dep_of_bool = dep_of_bool2.
reflexivity.
Qed.

Check dep_of_bool2.

From Ssreflect Require Import ssreflect ssrfun ssrbool.

Print andb.
Print negb.
Print orb.

Goal forall a b : bool, ~~ (a && b) = (~~ a) || (~~ b).
by case; case.
Qed.

From Ssreflect Require Import eqtype ssrnat.

Lemma ifP_example : forall n : nat, odd (if odd n then n else n.+1).
Proof.
move=> n.
case: ifP.
  done.
move=> Hn.
rewrite -addn1.
rewrite odd_add.
by rewrite Hn.
Qed.

Check ifP.
(* forall (A : Type) (b : bool) (vT vF : A),
       if_spec b vT vF (b = false) b (if b then vT else vF) *)
Print if_spec.
(* CoInductive if_spec (A : Type) (b : bool) (vT vF : A)
            (not_b : Prop) : bool -> A -> Set :=
    IfSpecTrue : b -> if_spec b vT vF not_b true vT
  | IfSpecFalse : not_b -> if_spec b vT vF not_b false vF
*)
(* ifP is the proof that "if ... is ... then ... else ..." satifies the if_spec predicate *)
(*
upon case analysis, match (a subterm in) the goal with
"(if b then vT else vF)" and generate to goals:
1. b is replaced with true, b is pushed on the stack
1. b is replaced with false, not_b is pushed on the stack
*)

Lemma exo23 : forall n : nat, n * n - 1 < n ^ n.
Proof.
move=> n.
case: (boolP (n == O)).
  admit.
move=> n0.
case: (boolP (n == 1)).
  admit.
move=> n1.
have [m Hm] : exists m, n = m.+2.
  admit.
admit.
Abort.

Check boolP.
(* forall b1 : bool, alt_spec b1 b1 b1 *)
Check (boolP (0 == 1)).
(* alt_spec (0 == 1) (0 == 1) (0 == 1) *)
Check alt_spec.
Print alt_spec.
(* two combinations possible:
   P b true
   P b false
   upon case analysis, there are two branches:
   - "(0 == 1)" is replaced by true and the hypothesis "(0 == 1) (= true)" is pushed
   - "(0 == 1)" is replaced by false and the hypothesis "~~ (0 == 1)" = "(0 != 1)" is pushed
*)


Require Import Shared.Base Shared.FiniteTypes TM.Prelim.
Require Import Shared.Vectors.Vectors.

(** * Relations *)

Definition Rel (X : Type) (Y : Type) := X -> Y -> Prop.

Definition rcomp X Y Z (R : Rel X Y) (S : Rel Y Z) : Rel X Z :=
  fun x z => exists y, R x y /\ S y z.
Notation "R1 '∘' R2" := (rcomp R1 R2) (at level 40, left associativity).
Arguments rcomp {X Y Z} (R S) x y /.

Definition runion X Y (R : Rel X Y) (S : Rel X Y) : Rel X Y := fun x y => R x y \/ S x y.
Notation "R '∪' S" := (runion R S) (at level 42).
Arguments runion { X Y } ( R S ) x y /.

Definition rintersection X Y (R : Rel X Y) (S : Rel X Y) : Rel X Y := fun x y => R x y /\ S x y.
Notation "R '∩' S" := (rintersection R S) (at level 41).
Arguments rintersection { X Y } ( R S ) x y /.

Definition rimplication X Y (R : Rel X Y) (S : Rel X Y) : Rel X Y := fun x y => R x y -> S x y.
Notation "R '⊂' S" := (rimplication R S) (at level 41).
Arguments rimplication { X Y } ( R S ) x y /.

Definition ignoreParam X Y Z (R : Rel X Z) : Rel X (Y * Z)  := fun x '(y,z) => R x z.
Arguments ignoreParam {X Y Z} ( R ) x y /.

Definition rUnion (X Y : Type) (F : Type) (R : F -> Rel X Y) : Rel X Y :=
  fun x y => exists f, R f x y.
Notation "'⋃_' f R" := (rUnion (fun f => R)) (at level 50, f at level 9, R at next level, format "'⋃_' f  R"). (* Todo: This does not work if f is higher than 9. Why? *)
Arguments rUnion { X Y F } ( R ) x y /.

Definition rIntersection (X Y : Type) (F : Type) (R : F -> Rel X Y) : Rel X Y :=
  fun x y => forall f, R f x y.
Notation "'⋂_' f R" := (rIntersection (fun f => R)) (at level 50, f at level 9, R at next level, format "'⋂_' f  R"). (* Todo: This does not work if f is higher than 9. Why? *)
Arguments rIntersection { X Y F } ( R ) x y /.

Definition surjective X Z (R : Rel X Z) :=
  forall x, exists y, R x y.

Definition functional X Z (R : Rel X Z) :=
  forall x z1 z2, R x z1 -> R x z2 -> z1 = z2.

Definition subrel X Y (R S: Rel X Y) := (forall x y, R x y -> S x y).
Notation "R1 <<=2 R2" := (subrel R1 R2) (at level 60).

Instance eqrel_pre X Y : PreOrder (subrel (X := X) (Y := Y)).
Proof. constructor; firstorder. Qed.

Fact subrel_and X Y (R1 R2 R3 : Rel X Y) :
  R1 <<=2 R3 \/ R2 <<=2 R3 -> R1 ∩ R2 <<=2 R3.
Proof. firstorder. Qed.

Fact subrel_or X Y (R1 R2 R3 : Rel X Y) :
  R1 <<=2 R3 /\ R2 <<=2 R3 -> R1 ∪ R2 <<=2 R3.
Proof. firstorder. Qed.

Fact subrel_and2 X Y (R1 R2 R3 R4 : Rel X Y) :
  R1 <<=2 R3 /\ R2 <<=2 R4 -> R1 ∩ R2 <<=2 R3 ∩ R4.
Proof. firstorder. Qed.

Fact subrel_or2 X Y (R1 R2 R3 R4 : Rel X Y) :
  R1 <<=2 R3 /\ R2 <<=2 R4 -> R1 ∪ R2 <<=2 R3 ∪ R4.
Proof. firstorder. Qed.

Definition eqrel X Y (R S: Rel X Y) := (R <<=2 S /\ S <<=2 R) .

Notation "R '=2' S"  := (eqrel R S) (at level 70).

Instance eqrel_eq X Y : Equivalence (eqrel (X := X) (Y := Y)).
Proof. constructor; firstorder. Qed.

(** ** Relational operators on labelled relations *)

(** Restrict the label of a labelled relation and return an unlabelled relation *)
Definition restrict X Y Z (R : Rel X (Y * Z)) f : Rel X Z := (fun x1 x2 => R x1 (f, x2)).
Notation "R '|_' f" := (restrict R f) (at level 30, format "R '|_' f").
Arguments restrict { X Y Z } ( R f ) x y /.

(** Introduce a label that is fixed to a value *)
Definition rfix X Y Z (R : Rel X Z) (p : Y) : Rel X (Y*Z) := (fun x '(y, z) =>
y = p /\ R x z).
Notation "R '||_' f" := (rfix R f) (at level 30, format "R '||_' f").
Arguments rfix { X Y Z } ( R p ) x y /.

(** ** Relations over Vectors *)

Section Fix_X2.
  Variable X Y Z : Type.
  Variable n : nat.

  Local Notation "'V' Z" := (Vector.t Z n) (at level 10).

  Definition Eq_in (f : Fin.t n -> Prop) : Rel (V X) (V X) :=
    fun vx vy => forall i : Fin.t n, f i -> vy[@i] = vx[@i].

  Instance Eq_in_equivalence X (f : Fin.t n -> Prop) :
    Equivalence (@Eq_in X).
  Proof.
    econstructor.
    - econstructor.
    - hnf. intros. hnf in *. intros. rewrite <- H; eauto.
    - hnf. intros. hnf in *. intros. rewrite <- H, <- H0; eauto.
  Qed.

End Fix_X2.

Arguments Eq_in { X n } P x y / : rename.

(** ** Reflexive transitive closure and relational power *)
Section Star_Pow.
  Variable X : Type.
  Variable R : Rel X X.

  Inductive pow : nat -> Rel X X :=
  | pow_0 x : pow 0 x x
  | pow_S k x y z : R x y -> pow k y z -> pow (S k) x z.

  Inductive star : Rel X X :=
  | starR x : star x x
  | starC x y z : R x y -> star y z -> star x z.

  Lemma star_trans : transitive _ star.
  Proof. induction 1; eauto using star. Qed.

  Global Instance star_preorder : PreOrder star.
  Proof. constructor. constructor. apply star_trans. Qed.

  Lemma pow_plus k1 k2 x y z :
    pow k1 x y -> pow k2 y z -> pow (k1 + k2) x z.
  Proof. induction 1; cbn; eauto using pow. Qed.

  Lemma star_pow x y :
    star x y <-> exists n, pow n x y.
  Proof.
    split.
    - induction 1; firstorder eauto using pow.
    - intros (n&H). induction H; eauto using star.
  Qed.

End Star_Pow.


From Coq Require Import Arith.Arith.

Fail Fixpoint false_proof (p : nat) : False := false_proof p.

Fixpoint sum (n : nat) : nat :=
  match n with
  | 0 => 0
  | S n' => n + (sum n')
  end.

Theorem summation :
  forall n, sum n + sum n = n * (n + 1).
Proof.
  induction n.
  - simpl. reflexivity.
  - simpl. apply eq_S. rewrite <- plus_assoc. rewrite <- plus_assoc.
    apply f_equal2_plus. reflexivity.
    simpl. rewrite Nat.add_succ_r.
    apply eq_S. rewrite plus_comm. rewrite <- plus_assoc.
    rewrite IHn. rewrite Nat.mul_succ_r. rewrite plus_comm. reflexivity.
  Qed.

From Coq Require Import Omega.

Theorem summation_ring :
  forall n, sum n + sum n = n * (n + 1).
Proof.
  induction n.
  - simpl. reflexivity.
  - simpl.
    replace (n + sum n + S (n + sum n)) with ((sum n + sum n) + n + S n).
    rewrite IHn. ring. ring. Qed.

Definition excluded_middle := forall P : Prop,
  P \/ ~ P.

Definition injective {A B} (f : A -> B) : Prop :=
  forall a b, f a = f b -> a = b.

Definition FiniteType (A : Type) :=
  exists f : A -> nat, injective f /\ exists n, forall a, f a <= n.

Theorem FiniteBool : FiniteType bool.
Proof.
  unfold FiniteType. exists (fun b : bool => if b then 0 else 1).
  split.
  - unfold injective. intros.
    destruct a; destruct b; auto.
    + inversion H.
    + inversion H.
  - exists 1. intros. destruct a; omega.
  Qed.

Definition InfiniteType (A : Type) : Prop :=
  exists f : nat -> A, injective f.

Theorem InfiniteNat : InfiniteType nat.
Proof.
  exists (fun x => x). repeat intro. assumption. Qed.


Load basic.

Definition app {X} {Y} (f:X->Y) (x:option X) : option Y :=
  match x with
    None => None
  | Some x => Some (f x)
  end.

Fixpoint subst {Pi} (F G:@formula Pi) p :=
  match F, p with
    _, [] => Some G
  | (Not F), 1::p => app Not (subst F G p)
  | (And F1 F2), 1::p => app (fun f => And f F2) (subst F1 G p)
  | (And F1 F2), 2::p => app (And F1) (subst F2 G p)
  | (Or F1 F2), 1::p => app (fun f => Or f F2) (subst F1 G p)
  | (Or F1 F2), 2::p => app (Or F1) (subst F2 G p)
  | (To F1 F2), 1::p => app (fun f => To f F2) (subst F1 G p)
  | (To F1 F2), 2::p => app (To F1) (subst F2 G p)
  | (Equiv F1 F2), 1::p => app (fun f => Equiv f F2) (subst F1 G p)
  | (Equiv F1 F2), 2::p => app (Equiv F1) (subst F2 G p)
  | _, _ => None
  end.

Definition negPol p :=
  match p with
    TT => FF
  | FF => TT
  | NN => NN
  end.

Fixpoint pol {Pi} (F:@formula Pi) p :=
  match F,p with
    _, [] => Some TT
  | (Not F), 1::p => app negPol (pol F p)
  | (And F1 F2), 1::p => pol F1 p
  | (And F1 F2), 2::p => pol F2 p
  | (Or F1 F2), 1::p => pol F1 p
  | (Or F1 F2), 2::p => pol F2 p
  | (To F1 F2), 1::p => app negPol (pol F1 p)
  | (To F1 F2), 2::p => pol F2 p
  | (Equiv F1 F2), 1::p => Some NN
  | (Equiv F1 F2), 2::p => Some NN
  | _,_ => None
  end.

Fixpoint eval {Pi} (A:Pi->bool) (F:@formula Pi) : nat :=
  match F with
    Bot => 0
  | Top => 1
  | V p => A p
  | Not F => 1-eval A F
  | And F G => min (eval A F) (eval A G)
  | Or F G => max (eval A F) (eval A G)
  | To F G => max (1-eval A F) (eval A G)
  | Equiv F G => if eval A F =? eval A G then 1 else 0
  end.

Definition sat {Pi} A (F:@formula Pi) : Prop := eval A F = 1.

Definition satisfiable {Pi} (F:@formula Pi) : Prop :=
  exists A, sat A F.


Definition leibniz (a:Type) (x y:a) : Prop :=
    forall (P:a -> Prop), P x -> P y.

Arguments leibniz {a} _ _.

Notation "x == y" := (leibniz x y) (at level 40).

Lemma equal_refl : forall (a:Type) (x:a), x == x.
Proof. intros a x. unfold leibniz. intros P H. exact H. Qed.

Lemma equal_sym : forall (a:Type) (x y:a), x == y -> y == x.
Proof.
    intros a x y. unfold leibniz. intros H P Hy.
    remember (fun (y:a) => P y -> P x) as Q eqn:H'.
    assert (Q y) as Hq. { apply H. rewrite H'. intros Hx. exact Hx. }
    rewrite H' in Hq. apply Hq. exact Hy.
Qed.

Lemma equal_trans : forall (a:Type) (x y z:a), x == y -> y == z -> x == z.
Proof.
    intros a x y z. unfold leibniz. intros Exy Eyz P Hx.
    apply Eyz, Exy. exact Hx.
Qed.

Lemma leibniz_is_eq : forall (a:Type) (x y:a), x = y <-> x == y.
Proof.
    intros a x y. split.
    - intros E. rewrite E. apply equal_refl.
    - intros E. remember (fun (y:a) => x = y) as Q eqn:H.
        unfold leibniz in E. apply E. rewrite H. reflexivity.
Qed.

(* setoid paper *)


Theorem ex47: forall a : Prop,
              a <-> a.
Proof.
  Require Import Coq.Program.Basics.
  split. apply id. apply id.
Qed.

Theorem ex48: forall a : Prop,
              a \/ ~a.
Proof.
  Require Import Classical.
  intros. apply (classic a).
Qed.

Theorem ex48_1: forall a b : Prop,
                (a -> b) \/ (b -> a).
Proof.
  intros. apply NNPP. intro. elim H.
  left. intro. elim H. right. intro.
  assumption.
Qed.

Theorem ex49: forall a : Prop,
              ~(a /\ ~a).
Proof.
  intros. intro. elim H. intros. contradiction.
Qed.