(* We copied and modified this file from https://github.com/roglo/coq_euler_prod_form/blob/master/Primisc.v *)

(* experiments with primes... *)

Set Nested Proofs Allowed.
Require Import Utf8 Arith.
Import List List.ListNotations.
Require Import Misc Primes.
Require Import PTotient.

Theorem prime_pow_φ' : ∀ p, prime p →
  ∀ k, k ≠ 0 → φ' (p ^ k) = p ^ (k - 1) * φ' p.
Proof.
intros * Hp * Hk.
rewrite (prime_φ' p); [ | easy ].
destruct (Nat.eq_dec p 0) as [Hpz| Hpz]; [ now subst p | ].
unfold φ'.
unfold coprimes'.
rewrite (filter_ext_in _ (λ d, negb (d mod p =? 0))). 2: {
  intros a Ha.
  apply in_seq in Ha.
  rewrite Nat.add_comm, Nat.sub_add in Ha. 2: {
    apply Nat.neq_0_lt_0.
    now apply Nat.pow_nonzero.
  }
  remember (a mod p) as r eqn:Hr; symmetry in Hr.
  destruct r. {
    apply Nat.eqb_neq.
    apply Nat.mod_divides in Hr; [ | easy ].
    destruct Hr as (d, Hd).
    rewrite Hd.
    destruct k; [ easy | cbn ].
    rewrite Nat.gcd_mul_mono_l.
    intros H.
    apply Nat.eq_mul_1 in H.
    destruct H as (H, _).
    now subst p.
  } {
    apply Nat.eqb_eq.
    assert (Hg : Nat.gcd p a = 1). {
      rewrite <- Nat.gcd_mod; [ | easy ].
      rewrite Nat.gcd_comm.
      apply eq_gcd_prime_small_1; [ easy | ].
      split; [ rewrite Hr; flia | ].
      now apply Nat.mod_upper_bound.
    }
    clear - Hg.
    induction k; [ easy | ].
    now apply Nat_gcd_1_mul_l.
  }
}
clear Hp.
replace k with (k - 1 + 1) at 1 by flia Hk.
rewrite Nat.pow_add_r, Nat.pow_1_r.
remember (p ^ (k - 1)) as a eqn:Ha.
clear k Hk Ha Hpz.
induction a; [ easy | ].
cbn.
destruct (Nat.eq_dec p 0) as [Hpz| Hpz]. {
  subst p; cbn.
  now rewrite Nat.mul_0_r.
}
destruct (Nat.eq_dec a 0) as [Haz| Haz]. {
  subst a; cbn.
  do 2 rewrite Nat.add_0_r.
  rewrite (filter_ext_in _ (λ d, true)). 2: {
    intros a Ha.
    apply in_seq in Ha.
    rewrite Nat.mod_small; [ | flia Ha ].
    destruct a; [ flia Ha | easy ].
  }
  clear.
  destruct p; [ easy | ].
  rewrite Nat.sub_succ, Nat.sub_0_r.
  induction p; [ easy | ].
  rewrite <- (Nat.add_1_r p).
  rewrite seq_app, filter_app, app_length.
  now rewrite IHp.
}
rewrite <- Nat.add_sub_assoc. 2: {
  apply Nat.neq_0_lt_0.
  now apply Nat.neq_mul_0.
}
rewrite Nat.add_comm.
rewrite seq_app, filter_app, app_length.
rewrite IHa, Nat.add_comm; f_equal.
rewrite Nat.add_comm, Nat.sub_add. 2: {
  apply Nat.neq_0_lt_0.
  now apply Nat.neq_mul_0.
}
replace p with (1 + (p - 1)) at 2 by flia Hpz.
rewrite seq_app, filter_app, app_length.
cbn.
rewrite Nat.mod_mul; [ | easy ]; cbn.
rewrite (filter_ext_in _ (λ d, true)). 2: {
  intros b Hb.
  remember (b mod p) as c eqn:Hc; symmetry in Hc.
  destruct c; [ | easy ].
  apply Nat.mod_divide in Hc; [ | easy ].
  destruct Hc as (c, Hc).
  subst b.
  apply in_seq in Hb.
  destruct Hb as (Hb1, Hb2).
  clear - Hb1 Hb2; exfalso.
  revert p a Hb1 Hb2.
  induction c; intros; [ flia Hb1 | ].
  cbn in Hb1, Hb2.
  destruct (Nat.eq_dec a 0) as [Haz| Haz]. {
    subst a.
    cbn in Hb1, Hb2.
    destruct p; [ flia Hb1 | ].
    rewrite Nat.sub_succ, Nat.sub_0_r in Hb2.
    flia Hb2.
  }
  destruct (Nat.eq_dec p 0) as [Hpz| Hpz]. {
    subst p; flia Hb1.
  }
  specialize (IHc p (a - 1)) as H1.
  assert (H : (a - 1) * p + 1 ≤ c * p). {
    rewrite Nat.mul_sub_distr_r, Nat.mul_1_l.
    rewrite <- Nat.add_sub_swap. 2: {
      destruct a; [ easy | ].
      cbn; flia.
    }
    flia Hb1 Haz Hpz.
  }
  specialize (H1 H); clear H.
  apply H1.
  apply (Nat.add_lt_mono_l _ _ p).
  eapply lt_le_trans; [ apply Hb2 | ].
  ring_simplify.
  do 2 apply Nat.add_le_mono_r.
  rewrite Nat.mul_sub_distr_l, Nat.mul_1_r.
  rewrite Nat.sub_add. 2: {
    destruct a; [ easy | rewrite Nat.mul_succ_r; flia ].
  }
  now rewrite Nat.mul_comm.
}
clear.
remember (a * p + 1) as b; clear a Heqb.
destruct p; [ easy | ].
rewrite Nat.sub_succ, Nat.sub_0_r.
revert b.
induction p; intros; [ easy | ].
rewrite <- Nat.add_1_r.
rewrite seq_app, filter_app, app_length.
now rewrite IHp.
Qed.

Theorem divide_add_div_le : ∀ m p q,
  2 ≤ p
  → 2 ≤ q
  → Nat.divide p m
  → Nat.divide q m
  → m / p + m / q ≤ m.
Proof.
intros * H2p H2q Hpm Hqm.
destruct Hpm as (kp, Hkp).
destruct Hqm as (kq, Hkq).
destruct (Nat.eq_dec p 0) as [Hpz| Hpz]; [ flia Hpz H2p | ].
destruct (Nat.eq_dec q 0) as [Hqz| Hqz]; [ flia Hqz H2q | ].
rewrite Hkq at 2.
rewrite Nat.div_mul; [ | easy ].
rewrite Hkp at 1.
rewrite Nat.div_mul; [ | easy ].
apply (Nat.mul_le_mono_pos_r _ _ (p * q)). {
  destruct p; [ easy | ].
  destruct q; [ easy | cbn; flia ].
}
rewrite Nat.mul_add_distr_r.
rewrite Nat.mul_assoc, <- Hkp.
rewrite Nat.mul_assoc, Nat.mul_shuffle0, <- Hkq.
rewrite <- Nat.mul_add_distr_l.
apply Nat.mul_le_mono_l.
rewrite Nat.add_comm.
apply Nat.add_le_mul. {
  destruct p; [ easy | ].
  destruct p; [ easy | flia ].
} {
  destruct q; [ easy | ].
  destruct q; [ easy | flia ].
}
Qed.

Theorem length_filter_mod_seq : ∀ a b,
  a mod b ≠ 0
  → length (filter (λ d, negb (d mod b =? 0)) (seq a b)) = b - 1.
Proof.
intros a b Hab1.
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]; [ now subst b | ].
specialize (Nat.div_mod a b Hbz) as H1.
remember (a / b) as q eqn:Hq.
remember (a mod b) as r eqn:Hr.
move q after r; move Hq after Hr.
replace b with (b - r + r) at 1. 2: {
  apply Nat.sub_add.
  now rewrite Hr; apply Nat.lt_le_incl, Nat.mod_upper_bound.
}
rewrite seq_app, filter_app, app_length.
rewrite List_filter_all_true. 2: {
  intros c Hc.
  apply Bool.negb_true_iff, Nat.eqb_neq.
  apply in_seq in Hc.
  intros Hcon.
  specialize (Nat.div_mod c b Hbz) as H2.
  rewrite Hcon, Nat.add_0_r in H2.
  remember (c / b) as s eqn:Hs.
  subst a c.
  clear Hcon.
  destruct Hc as (Hc1, Hc2).
  rewrite Nat.add_sub_assoc in Hc2. 2: {
    rewrite Hr.
    now apply Nat.lt_le_incl, Nat.mod_upper_bound.
  }
  rewrite Nat.add_sub_swap in Hc2; [ | flia ].
  rewrite Nat.add_sub in Hc2.
  replace b with (b * 1) in Hc2 at 3 by flia.
  rewrite <- Nat.mul_add_distr_l in Hc2.
  apply Nat.mul_lt_mono_pos_l in Hc2; [ | flia Hbz ].
  rewrite Nat.add_1_r in Hc2.
  apply Nat.succ_le_mono in Hc2.
  apply Nat.nlt_ge in Hc1.
  apply Hc1; clear Hc1.
  apply (le_lt_trans _ (b * q)); [ | flia Hab1 ].
  now apply Nat.mul_le_mono_l.
}
rewrite seq_length.
replace r with (1 + (r - 1)) at 3 by flia Hab1.
rewrite seq_app, filter_app, app_length; cbn.
rewrite H1 at 1.
rewrite Nat.add_sub_assoc. 2: {
  rewrite Hr.
  now apply Nat.lt_le_incl, Nat.mod_upper_bound.
}
rewrite Nat.add_sub_swap; [ | flia ].
rewrite Nat.add_sub.
rewrite Nat_mod_add_l_mul_l; [ | easy ].
rewrite Nat.mod_same; [ cbn | easy ].
rewrite List_filter_all_true. 2: {
  intros c Hc.
  apply Bool.negb_true_iff, Nat.eqb_neq.
  apply in_seq in Hc.
  intros Hcon.
  specialize (Nat.div_mod c b Hbz) as H2.
  rewrite Hcon, Nat.add_0_r in H2.
  remember (c / b) as s eqn:Hs.
  subst a c.
  clear Hcon.
  destruct Hc as (Hc1, Hc2).
  rewrite Nat.add_sub_assoc in Hc2. 2: {
    rewrite Hr.
    rewrite Nat_mod_add_l_mul_l; [ | easy ].
    rewrite Nat.mod_small; [ flia Hab1 | ].
    rewrite Hr.
    now apply Nat.mod_upper_bound.
  }
  rewrite Nat.add_sub_swap in Hc2; [ | flia ].
  rewrite Nat.add_sub in Hc2.
  rewrite Nat.add_sub_assoc in Hc2. 2: {
    rewrite Hr.
    now apply Nat.lt_le_incl, Nat.mod_upper_bound.
  }
  rewrite Nat.sub_add in Hc2; [ | flia ].
  rewrite Nat.add_sub_assoc in Hc1. 2: {
    rewrite Hr.
    now apply Nat.lt_le_incl, Nat.mod_upper_bound.
  }
  rewrite Nat.add_sub_swap in Hc1; [ | flia ].
  rewrite Nat.add_sub in Hc1.
  rewrite Nat.add_shuffle0 in Hc2.
  apply Nat.nlt_ge in Hc1; apply Hc1; clear Hc1.
  rewrite Nat.add_1_r.
  apply -> Nat.succ_le_mono.
  replace b with (b * 1) at 3 by flia.
  rewrite <- Nat.mul_add_distr_l.
  apply Nat.mul_le_mono_l.
  replace b with (b * 1) in Hc2 at 3 by flia.
  rewrite <- Nat.mul_add_distr_l in Hc2.
  apply Nat.nlt_ge; intros Hc1.
  replace s with ((q + 1) + S (s - (q + 2))) in Hc2 by flia Hc1.
  rewrite Nat.mul_add_distr_l in Hc2.
  apply Nat.add_lt_mono_l in Hc2.
  apply Nat.nle_gt in Hc2; apply Hc2; clear Hc2.
  rewrite Nat.mul_comm; cbn.
  transitivity b; [ | flia Hc1 ].
  rewrite Hr.
  now apply Nat.lt_le_incl, Nat.mod_upper_bound.
}
rewrite seq_length.
rewrite Nat.add_sub_assoc; [ | flia Hab1 ].
rewrite Nat.sub_add; [ easy | ].
rewrite Hr.
now apply Nat.lt_le_incl, Nat.mod_upper_bound.
Qed.

Theorem gcd_1_div_mul_exact : ∀ m p q kp kq,
  q ≠ 0
  → Nat.gcd p q = 1
  → m = kp * p
  → m = kq * q
  → kp = q * (kp / q).
Proof.
intros * Hqz Hg Hkp Hkq.
rewrite <- Nat.divide_div_mul_exact; [ | easy | ]. 2: {
  apply (Nat.gauss _ p). {
    rewrite Nat.mul_comm, <- Hkp, Hkq.
    now exists kq.
  } {
    now rewrite Nat.gcd_comm.
  }
}
now rewrite Nat.mul_comm, Nat.div_mul.
Qed.

Theorem Nat_gcd_1_mul_divide : ∀ m p q,
  Nat.gcd p q = 1
  → Nat.divide p m
  → Nat.divide q m
  → Nat.divide (p * q) m.
Proof.
intros * Hg Hpm Hqm.
destruct (Nat.eq_dec m 0) as [Hmz| Hmz]. {
  subst m; cbn.
  now exists 0.
}
assert (Hpz : p ≠ 0). {
  destruct Hpm as (k, Hk).
  now intros H; rewrite H, Nat.mul_0_r in Hk.
}
assert (Hqz : q ≠ 0). {
  destruct Hqm as (k, Hk).
  now intros H; rewrite H, Nat.mul_0_r in Hk.
}
destruct Hpm as (kp, Hkp).
destruct Hqm as (kq, Hkq).
exists (kp * kq / m).
rewrite Nat.mul_comm.
rewrite Hkp at 2.
rewrite Nat.div_mul_cancel_l; [ | easy | ]. 2: {
  intros H; subst kp.
  rewrite Hkp in Hkq; cbn in Hkq.
  symmetry in Hkq.
  apply Nat.eq_mul_0 in Hkq.
  destruct Hkq as [H| H]; [ | now subst q ].
  now subst kq.
}
rewrite (Nat.mul_comm p), <- Nat.mul_assoc.
rewrite <- Nat.divide_div_mul_exact; [ | easy | ]. 2: {
  exists (kq / p).
  rewrite Nat.mul_comm.
  rewrite Nat.gcd_comm in Hg.
  now apply (gcd_1_div_mul_exact m q p kq kp).
}
rewrite (Nat.mul_comm p).
rewrite Nat.div_mul; [ | easy ].
now rewrite Nat.mul_comm.
Qed.

Theorem prime_divisors_decomp : ∀ n a,
  a ∈ prime_divisors n ↔ a ∈ prime_decomp n.
Proof.
intros.
split; intros Ha. {
  apply filter_In in Ha.
  destruct Ha as (Ha, H).
  apply Bool.andb_true_iff in H.
  destruct H as (Hpa, Hna).
  apply Nat.eqb_eq in Hna.
  apply in_seq in Ha.
  apply Nat.mod_divide in Hna; [ | flia Ha ].
  apply prime_decomp_in_iff.
  split; [ | split ]; [ flia Ha | easy | easy ].
} {
  apply filter_In.
  apply prime_decomp_in_iff in Ha.
  destruct Ha as (Hnz & Ha & Han).
  split. {
    apply in_seq.
    split. {
      transitivity 2; [ flia | ].
      now apply prime_ge_2.
    } {
      destruct Han as (k, Hk); subst n.
      destruct k; [ easy | flia ].
    }
  }
  apply Bool.andb_true_iff.
  split; [ easy | ].
  apply Nat.eqb_eq.
  apply Nat.mod_divide in Han; [ easy | ].
  now intros H1; subst a.
}
Qed.

Theorem prime_divisors_nil_iff: ∀ n, prime_divisors n = [] ↔ n = 0 ∨ n = 1.
Proof.
intros.
split; intros Hn. {
  apply prime_decomp_nil_iff.
  remember (prime_decomp n) as l eqn:Hl; symmetry in Hl.
  destruct l as [| a l]; [ easy | ].
  specialize (proj2 (prime_divisors_decomp n a)) as H1.
  rewrite Hl, Hn in H1.
  now exfalso; apply H1; left.
} {
  now destruct Hn; subst n.
}
Qed.


(**********************************************************************)
(* A few examples showing the current limits of the conversion algorithm *)
(**********************************************************************)

(*** We define (pseudo-)divergence from Ackermann function ***)

Definition ack (n : nat) :=
  (fix F (n0 : nat) : nat -> nat :=
     match n0 with
     | O => S
     | S n1 =>
         fun m : nat =>
         (fix F0 (n2 : nat) : nat :=
            match n2 with
            | O => F n1 1
            | S n3 => F n1 (F0 n3)
            end) m
     end) n.

Notation OMEGA := (ack 4 4).

Definition f (x:nat) := x.

(* Evaluation in tactics can somehow be controlled *)
Lemma l1 : OMEGA = OMEGA.
reflexivity.  (* succeed: identity *)
Qed.          (* succeed: identity *)

Lemma l2 : OMEGA = f OMEGA.
reflexivity.  (* fail: conversion wants to convert OMEGA with f OMEGA *)
Abort.        (* but it reduces the right side first! *)

Lemma l3 : f OMEGA = OMEGA.
reflexivity.  (* succeed: reduce left side first *)
Qed.          (* succeed: expected concl (the one with f) is on the left *)

Lemma l4 : OMEGA = OMEGA.
assert (f OMEGA = OMEGA) by reflexivity. (* succeed *)
unfold f in H.   (* succeed: no type-checking *)
exact H.         (* succeed: identity *)
Qed.             (* fail: "f" is on the left *)

(* This example would fail whatever the preferred side is *)
Lemma l5 : OMEGA = f OMEGA.
unfold f.
assert (f OMEGA = OMEGA) by reflexivity.
unfold f in H.
exact H.
Qed. (* needs to convert (f OMEGA = OMEGA) and (OMEGA = f OMEGA) *)

(**********************************************************************)
(* Analysis of the inefficiency in Nijmegen/LinAlg/LinAlg/subspace_dim.v *)
(* (proof of span_ind_uninject_prop *)

In the proof, a problem of the form   (Equal S t1 t2)
is "simpl"ified, then "red"uced to    (Equal S' t1 t1)
where the new t1's are surrounded by invisible coercions.
A reflexivity steps conclude the proof.

The trick is that Equal projects the equality in the setoid S, and
that (Equal S) itself reduces to some (fun x y => Equal S' (f x) (g y)).

At the Qed time, the problem to solve is (Equal S t1 t2) = (Equal S' t1 t1)
and the algorithm is to first compare S and S', and t1 and t2.
Unfortunately it does not work, and since t1 and t2 involve concrete
instances of algebraic structures, it takes a lot of time to realize that
it is not convertible.

The only hope to improve this problem is to observe that S' hides
(behind two indirections) a Setoid constructor. This could be the
argument to solve the problem.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski and Johannes Waldmann, 2010-04
*)

Set Implicit Arguments.

From CoLoR Require Import AMonAlg Matrix OrdSemiRing VecUtil SN RelUtil
  LogicUtil AMatrixBasedInt.
From Coq Require Import Morphisms Setoid.

(** Module type for proving termination with matrix interpretations *)

Module Type TTropicalBasedInt.

  Declare Module Export OSR : OrdSemiRingType.

  Module Export M := Matrix OSR.

  Parameter sig : Signature.
  Parameter dim : nat.
  Parameter dim_pos : dim > 0.
  Parameter trsInt : forall f : sig, matrixInt A matrix dim (arity f).

End TTropicalBasedInt.

Module TropicalBasedInt (Export TBI : TTropicalBasedInt).

  Module Conf <: MatrixMethodConf.

    Module Export M := TBI.M.
    Module Export OSRT := TBI.OSR.

    Definition sig := sig.
    Definition dim := dim.
    Definition dim_pos := dim_pos.

    Definition trsInt := trsInt.
    Notation vec := (vec dim).
    Definition vec_at0 (v : vec) := Vnth v dim_pos.

     (* TODO: for refactoring we should change this condition to a
        predicate on [vec_at0], which would be general enough to
        cover all three: arctic/arctic-below-zero/tropical *)
    Definition vec_invariant (v : vec) := A0 >> vec_at0 v.

    Parameter A0_gt_A1 : A0 >> A1.

    Lemma inv_id_matrix :
      vec_invariant (Vreplace (Vconst A0 dim) dim_pos A1).

    Proof.
      unfold vec_invariant, vec_at0. rewrite Vnth_replace. exact A0_gt_A1.
    Qed.

  End Conf.

  Module Export MBI := MatrixBasedInt Conf.

  Section ABI.

    Notation matrixInt := (matrixInt A matrix).
    Notation mint := (matrixInt dim).
    Notation mat := (matrix dim dim).

    Definition Sig := sig.
    Notation PlusInf := A0.

    Variable A0_min : forall x, x >>= PlusInf.
    Variable ge_gt_eq : forall x y, x >>= y -> x >> y \/ x =A= y.

    Definition gtx x y := x >> y \/ (x =A= PlusInf /\ y =A= PlusInf).
    Notation "x >_0 y" := (gtx x y) (at level 70).

    Global Instance gtx_mor : Proper (eqA ==> eqA ==> iff) gtx.

    Proof.
      intros x x' xx' y y' yy'. unfold gtx. intuition.
      left. rewrite <- xx', <- yy'. hyp. right.
      split. trans x; hyp. trans y; hyp.
      left. rewrite xx', yy'. hyp. right. split.
      trans x'; hyp. trans y'; hyp.
    Qed.

    Global Instance gtx_trans : Transitive gtx.

    Proof.
      unfold gtx. intros x y z. intuition.
      left. apply OSR.gt_trans with y; hyp.
      rewrite H2. rewrite H0 in H1. auto.
      rewrite H. rewrite H2 in H1. auto.
    Qed.

    Definition succ_vec {n} := Vforall2 gtx (n:=n).
    Definition succ (x y : dom) := succ_vec (dom2vec x) (dom2vec y).
    Notation "x >v y" := (succ x y) (at level 70).

    Global Instance succ_trans : Transitive succ.

    Proof.
      change (Transitive (Rof succ_vec dom2vec)). apply Rof_trans.
      unfold succ_vec. class.
    Qed.

    (*FIXME: Proper*)
    Lemma ge_gtx_compat : forall x y z, x >>= y -> y >_0 z -> x >_0 z.

    Proof.
      unfold gtx. intuition. left. apply ge_gt_compat with y; hyp.
      rewrite H2. rewrite H0 in H. destruct (ge_gt_eq H); intuition.
    Qed.

    Variable succ_wf : WF succ.

    Variable gtx_plus_compat : forall m m' n n',
      m >_0 m' -> n >_0 n' -> m + n >_0 m' + n'.

    Variable gtx_mult_compat : forall m m' n n',
      m >_0 m' -> n >>= n' -> m * n >_0 m' * n'.

    Lemma succ_succeq_compat : absorbs_left succ succeq.

    Proof.
      intros x z xz. destruct xz as [y [xy yz] ].
      unfold succ, succ_vec. apply Vforall2_intro_nth. intros.
      apply ge_gtx_compat with (Vnth (dom2vec y) ip).
      apply Vforall2_elim_nth. hyp.
      apply Vforall2_elim_nth. hyp.
    Qed.

    Lemma gtx_dec : rel_dec gtx.

    Proof.
      intros x y. destruct (gt_dec x y).
      left. left. hyp.
      destruct (eqA_dec x PlusInf).
      destruct (eqA_dec y PlusInf).
      left. right. auto.
      right. unfold gtx. intuition.
      right. unfold gtx. intuition.
    Defined.

    Lemma succ_dec : rel_dec succ.

    Proof.
      intros x y. unfold succ.
      apply (Vforall2_dec gtx_dec (dom2vec x) (dom2vec y)).
    Defined.

    Variable mi_eval_ok : forall f v,
      vec_invariant (mi_eval_aux (trsInt f) (Vmap dom2vec v)).

    Notation I := (MBI.I mi_eval_ok).
    Notation IR_succ := (IR I succ).

    Definition mat_gt := mat_forall2 gtx (m:=dim) (n:=dim).
    Definition vec_gt := Vforall2 gtx (n:=dim).

    Definition mint_gt n (l r : mint n) :=
      Vforall2 mat_gt (args l) (args r) /\ vec_gt (const l) (const r).

    Definition term_gt := MBI.term_gt mint_gt.

    Lemma mat_gt_dec : rel_dec mat_gt.

    Proof.
      unfold mat_gt. apply mat_forall2_dec. exact gtx_dec.
    Defined.

    Lemma vec_gt_dec : rel_dec vec_gt.

    Proof.
      unfold vec_gt, rel_dec. apply Vforall2_dec. exact gtx_dec.
    Defined.

    Lemma mint_gt_dec : forall n, rel_dec (@mint_gt n).

    Proof.
      intros n x y. unfold mint_gt.
      destruct (Vforall2_dec mat_gt_dec (args x) (args y));
        intuition.
      destruct (vec_gt_dec (const x) (const y)); intuition.
    Defined.

    Lemma Vfold_left_gtx_compat : forall n (v v' : vector A n),
      (forall i (ip: i < n), Vnth v ip >_0 Vnth v' ip) ->
      Vfold_left_rev Aplus A0 v >_0 Vfold_left_rev Aplus A0 v'.

    Proof.
      induction v; simpl; intros.
      VOtac. simpl. right. intuition.
      VSntac v'. simpl. apply gtx_plus_compat.
      apply IHv. intros.
      apply Vforall2_elim_nth. change v with (Vtail (Vcons h v)).
      apply Vforall2_tail. apply Vforall2_intro_nth. hyp.
      change h with (Vhead (Vcons h v)). rewrite !Vhead_nth.
      apply (H _ (Lt.lt_O_Sn n)).
    Qed.

    Section Matrix.

      Variables (m n p : nat) (M M' : matrix m n) (N N' : matrix n p).

      Notation vge := (Vforall2 ge).
      Notation vgt := (Vforall2 gtx).
      Notation mge := mat_ge.
      Notation mgt := (mat_forall2 gtx).

      Lemma arctic_dot_product_mon : forall i (v v' w w' : vector A i),
        vgt v v' -> vge w w' -> dot_product v w >_0 dot_product v' w'.

      Proof.
        unfold dot_product. induction v; intros; simpl.
        right. intuition.
        apply gtx_plus_compat.
        apply IHv.
        change v with (Vtail (Vcons h v)). apply Vforall2_tail. hyp.
        apply Vforall2_tail. hyp.
        apply gtx_mult_compat. change h with (Vhead (Vcons h v)).
        rewrite !Vhead_nth. apply Vforall2_elim_nth. hyp.
        rewrite !Vhead_nth. apply Vforall2_elim_nth. hyp.
      Qed.

      Lemma mat_arctic_mult_mon : mgt M M' -> mge N N' ->
        mgt (M <*> N) (M' <*> N').

      Proof.
        intros. unfold mat_forall2. intros.
        rewrite !mat_mult_spec. apply arctic_dot_product_mon.
        apply Vforall2_intro_nth. intros.
        exact (H i i0 ip ip0).
        apply Vforall2_intro_nth. intros.
        rewrite <- !get_elem_swap. exact (H0 i0 j ip0 jp).
      Qed.

    End Matrix.

    Lemma mat_vec_prod_gt_compat : forall (M M' : mat) m m',
      mat_gt M M' -> m >=v m' ->
      vec_gt (mat_vec_prod M m) (mat_vec_prod M' m').

    Proof.
      intros. unfold mat_vec_prod, vec_gt. apply Vforall2_intro_nth.
      intros. rewrite !Vnth_col_mat.
      apply mat_arctic_mult_mon. hyp.
      intros k l pk pl. rewrite !vec_to_col_mat_spec.
      apply Vforall2_elim_nth. hyp.
    Qed.

    Lemma mint_eval_mon_succ : forall (val : valuation I) k
      (mi mi' : mint k), mint_gt mi mi' ->
      succ_vec (mint_eval val mi) (mint_eval val mi').

    Proof.
      intros. unfold succ_vec. apply Vforall2_intro_nth. intros. destruct H.
      eapply gtx_mor. eapply Vforall2_elim_nth; rewrite mint_eval_split; refl.
      eapply Vforall2_elim_nth. rewrite mint_eval_split. refl.
      rewrite !vector_plus_nth.
      apply gtx_plus_compat.
      apply Vforall2_elim_nth. hyp.
      rewrite !add_vectors_nth.
      apply Vfold_left_gtx_compat. intros.
      rewrite !Vnth_map, !Vnth_map2.
      set (eval := Vnth (Vbuild (fun i (_ : i < k) => val i)) ip0).
      apply Vforall2_elim_nth. apply mat_vec_prod_gt_compat.
      apply Vforall2_elim_nth. hyp. refl.
    Qed.

    Lemma term_gt_incl_succ : term_gt << IR_succ.

    Proof.
      intros l r lr v. destruct (mint_eval_equiv l r v). simpl in *.
      unfold succ. unfold succ_vec. symmetry in H. symmetry in H0.
      rewrite (Vforall2_aux_Proper gtx_mor _ _ H _ _ H0).
      apply mint_eval_mon_succ. hyp.
    Qed.

    Definition succ' := term_gt.
    Definition succ'_sub := term_gt_incl_succ.
    Definition succ'_dec := term_gt_dec mint_gt mint_gt_dec.

  End ABI.

End TropicalBasedInt.


Require Export List.
Require Export Util.

Module Type RED_LANG_CS.

  (** The languages of terms, values, redex, and context, the empty context is also needed. *)
  Parameters term value redex elem_context : Set.
  Definition context := list elem_context.
  Definition empty : context := nil.

  (** The values and redexes are sublanguages of terms *)
  Parameter value_to_term : value -> term.
  Parameter redex_to_term : redex -> term.
  Axiom value_to_term_injective : forall v v' : value, value_to_term v = value_to_term v' -> v = v'.
  Axiom redex_to_term_injective : forall r r' : redex, redex_to_term r = redex_to_term r' -> r = r'.

  (** The main functions of reduction semantics, defining plugging terms into contexts and
      composing contexts, effectively defining reduction semantics, and some properties. *)
  Definition compose (c0 c1 : context) : context := app c0 c1.
  Parameter atom_plug : term -> elem_context -> term.
  Definition plug (t : term) (c : context) : term := fold_left atom_plug c t.

  (** The other main function of reduction semantics -- contraction of a redex into a term *)
  Parameter contract : redex -> context -> option (term * context).

  Definition only_empty (t : term) : Prop := forall t' c, plug t' c = t -> c = empty.
  Definition only_trivial (t : term) : Prop := forall t' c, plug t' c = t -> c = empty \/ exists v, t' = value_to_term v.

  Axiom value_trivial : forall v : value, only_trivial (value_to_term v).
  Axiom redex_trivial : forall r : redex, only_trivial (redex_to_term r).
  Axiom value_redex : forall (v : value) (r : redex), value_to_term v <> redex_to_term r.
  Axiom trivial_val_red : forall t : term, only_trivial t ->
    (exists v : value, t = value_to_term v) \/ (exists r : redex, t = redex_to_term r).

  (** Datatype of decompositions -- either a value or a redex in a context (analogous to the decompose lemma) *)
  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_term: term -> elem_context -> interm_dec.

  Definition decomp_to_term (d : decomp) : term :=
  match d with
    | d_val v => value_to_term v
    | d_red r c0 => plug (redex_to_term r) c0
  end.

End RED_LANG_CS.

Module Type LANG_PROP (R : RED_LANG_CS).

  Axiom plug_empty : forall t, R.plug t R.empty = t.
  Axiom compose_empty : forall c : R.context, c = R.compose c R.empty.
  Axiom plug_compose : forall (c c' : R.context) (t : R.term), R.plug t (R.compose c c') = R.plug (R.plug t c) c'.

End LANG_PROP.

Module Type RED_REF_LANG_CS (R : RED_LANG_CS).

(*  Declare Module R : RED_LANG_CS. *)

  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Inductive subterm_one_step : R.term -> R.term -> Prop :=
  | st_1 : forall t t0 ec (DECT : t = R.atom_plug t0 ec), subterm_one_step t0 t.
  Axiom wf_st1 : well_founded subterm_one_step.

  Definition subterm_order := clos_trans_n1 R.term subterm_one_step.
  Notation " a <| b " := (subterm_order a b) (at level 40).
  Definition wf_sto : well_founded subterm_order := wf_clos_trans_r _ _ wf_st1.

  Parameter ec_order : R.elem_context -> R.elem_context -> Prop.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Axiom wf_eco : well_founded ec_order.

  Axiom dec_term_red_empty  : forall t r, dec_term t = R.in_red r -> R.only_empty t.
  Axiom dec_term_val_empty  : forall t v, dec_term t = R.in_val v -> R.only_empty t.
  Axiom dec_term_term_top   : forall t t' ec, dec_term t = R.in_term t' ec -> forall ec', ~ec <: ec'.
  Axiom dec_context_red_bot : forall ec v r, dec_context ec v = R.in_red r -> forall ec', ~ ec' <: ec.
  Axiom dec_context_val_bot : forall ec v v', dec_context ec v = R.in_val v' -> forall ec', ~ ec' <: ec.
  Axiom dec_context_term_next : forall ec v t ec', dec_context ec v = R.in_term t ec' -> ec' <: ec /\ forall ec'', ec'' <: ec -> ~ ec' <: ec''.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t' ec => R.atom_plug t' ec = t
    end.
  Axiom dec_context_correct : forall ec v, match dec_context ec v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) ec
    | R.in_val v' => R.value_to_term v' = R.atom_plug (R.value_to_term v) ec
    | R.in_term t ec' => R.atom_plug t ec' = R.atom_plug (R.value_to_term v) ec
    end.

  Axiom ec_order_antisym : forall ec ec0, ec <: ec0 -> ~ ec0 <: ec.
  Axiom dec_ec_ord : forall t0 t1 ec0 ec1, R.atom_plug t0 ec0 = R.atom_plug t1 ec1 -> ec0 <: ec1 \/ ec1 <: ec0 \/ (t0 = t1 /\ ec0 = ec1).
  Axiom elem_context_det : forall t0 t1 ec0 ec1, ec0 <: ec1 -> R.atom_plug t0 ec0 = R.atom_plug t1 ec1 ->
    exists v, t1 = R.value_to_term v.

End RED_REF_LANG_CS.

  Ltac prove_st_wf := intro a; constructor; induction a; (intros y H;
    inversion H as [t t0 ec DECT]; subst; destruct ec; inversion DECT; subst; constructor; auto).
  Ltac prove_ec_wf := intro a; destruct a; repeat (constructor; intros ec T; destruct ec; inversion T; subst; clear T).

Module Type ABSTRACT_MACHINE.

  Parameters term value configuration : Set.
  Parameter c_init : term -> configuration.
  Parameter c_final : value -> configuration.
  Parameter transition : configuration -> configuration -> Prop.

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
  | multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

End ABSTRACT_MACHINE.

Module Type SOS_SEM.

  Parameters term value : Set.
  Parameter step : term -> term -> Prop.
  Parameter value_to_term : value -> term.

  Inductive step_close : term -> value -> Prop :=
  | s_val  : forall v, step_close (value_to_term v) v
  | s_step : forall t t0 v, step t t0 -> step_close t0 v -> step_close t v.

End SOS_SEM.


From mathcomp.ssreflect
Require Import ssreflect ssrfun ssrbool eqtype seq.
Require Import Setoid Morphisms.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* First some basic propositional equalities Basically, we need to repeat *)
(* most of ssrbool.v here but we'll do it as we go. *)

Lemma andTp p : True /\ p <-> p.      Proof. by intuition. Qed.
Lemma andpT p : p /\ True <-> p.      Proof. by intuition. Qed.
Lemma andFp p : False /\ p <-> False. Proof. by intuition. Qed.
Lemma andpF p : p /\ False <-> False. Proof. by intuition. Qed.
Lemma orTp p : True \/ p <-> True.    Proof. by intuition. Qed.
Lemma orpT p : p \/ True <-> True.    Proof. by intuition. Qed.
Lemma orFp p : False \/ p <-> p.      Proof. by intuition. Qed.
Lemma orpF p : p \/ False <-> p.      Proof. by intuition. Qed.

Delimit Scope rel_scope with rel.
Open Scope rel_scope.

(**************************************************************************)
(* We follow ssrbool, and provide four different types of predicates.     *)
(*                                                                        *)
(* (1) Pred is the type of propositional functions                        *)
(* (2) Simpl_Pred is the type of predicates that automatically simplify   *)
(*     when used in an applicative position.                              *)
(* (3) Mem_Pred is for predicates that support infix notation x \In P     *)
(* (4) PredType is the structure for interpreting various types, such as  *)
(* lists, tuples, etc. as predicates.                                     *)
(*                                                                        *)
(* Important point is that custom lemmas over predicates can be stated in *)
(* terms of Pred, while Simpl_Pred, Mem_Pred and PredType are for         *)
(* technical developments used in this file only. More on this point      *)
(* can be found in ssrbool.                                               *)
(**************************************************************************)

Definition Pred T := T -> Prop.
Identity Coercion fun_of_Pred : Pred >-> Funclass.

Notation xPred0 := (fun _ => False).
Notation xPred1 := (fun x y => x = y).
Notation xPredT := (fun _ => True).
Notation xPredI := (fun (p1 p2 : Pred _) x => p1 x /\ p2 x).
Notation xPredU := (fun (p1 p2 : Pred _) x => p1 x \/ p2 x).
Notation xPredC := (fun (p : Pred _) x => ~ p x).
Notation xPredD := (fun (p1 p2 : Pred _) x => ~ p2 x /\ p1 x).
Notation xPreim := (fun f (p : Pred _) x => p (f x)).

Section Predicates.
Variable T : Type.

(* simple predicates *)

Definition Simpl_Pred := simpl_fun T Prop.
Definition SimplPred (p : Pred T) : Simpl_Pred := SimplFun p.
Coercion Pred_of_Simpl (p : Simpl_Pred) : Pred T := p : T -> Prop.

(* it's useful to declare the operations as simple predicates, so that *)
(* complex expressions automatically reduce when used in applicative   *)
(* positions *)

Definition Pred0 := SimplPred xPred0.
Definition Pred1 x := SimplPred (xPred1 x).
Definition PredT := SimplPred xPredT.
Definition PredI p1 p2 := SimplPred (xPredI p1 p2).
Definition PredU p1 p2 := SimplPred (xPredU p1 p2).
Definition PredC p := SimplPred (xPredC p).
Definition PredD p1 p2 := SimplPred (xPredD p1 p2).
Definition Preim rT f (d : Pred rT) := SimplPred (xPreim f d).

(* membership predicates *)

CoInductive Mem_Pred : Type := MemProp of Pred T.
Definition isMem pT toPred mem := mem = (fun p : pT => MemProp [eta toPred p]).

(* the general structure for predicates *)

Structure PredType : Type := PropPredType {
  Pred_Sort :> Type;
  toPred : Pred_Sort -> Pred T;
  _ : {mem | isMem toPred mem}}.

Definition mkPredType pT toP := PropPredType (exist (@isMem pT toP) _ (erefl _)).

(* Pred, SimplPred, Mem_Pred, pred and simpl_pred are PredType's *)
Canonical Structure PredPredType := Eval hnf in @mkPredType (Pred T) id.
Canonical Structure SimplPredPredType := Eval hnf in mkPredType Pred_of_Simpl.
Coercion Pred_of_Mem mp : Pred_Sort PredPredType :=
  let: MemProp p := mp in [eta p].
Canonical Structure MemPredType := Eval hnf in mkPredType Pred_of_Mem.
Canonical Structure predPredType := Eval hnf in @mkPredType (pred T) id.
Canonical Structure simplpredPredType :=
  Eval hnf in @mkPredType (simpl_pred T) (fun p x => p x).

End Predicates.

Implicit Arguments Pred0 [T].
Implicit Arguments PredT [T].
Prenex Implicits Pred0 PredT PredI PredU PredC PredD Preim.

Notation "r1 +p r2" := (PredU r1 r2 : Pred _)
  (at level 55, right associativity) : rel_scope.
Notation "r1 *p r2" := (xPredI r1 r2 : Pred _)
  (at level 45, right associativity) : rel_scope.

Notation "[ 'Pred' : T | E ]" := (SimplPred (fun _ : T => E))
  (at level 0, format "[ 'Pred' :  T  |  E ]") : fun_scope.
Notation "[ 'Pred' x | E ]" := (SimplPred (fun x => E))
  (at level 0, x ident, format "[ 'Pred'  x  |  E ]") : fun_scope.
Notation "[ 'Pred' x : T | E ]" := (SimplPred (fun x : T => E))
  (at level 0, x ident, only parsing) : fun_scope.
Notation "[ 'Pred' x y | E ]" := (SimplPred (fun t => let: (x, y) := t in E))
  (at level 0, x ident, y ident, format "[ 'Pred'  x  y  |  E ]") : fun_scope.
Notation "[ 'Pred' x y : T | E ]" :=
  (SimplPred (fun t : (T*T) => let: (x, y) := t in E))
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Definition repack_Pred T pT :=
  let: PropPredType _ a mP := pT return {type of @PropPredType T for pT} -> _ in
   fun k => k a mP.

Notation "[ 'PredType' 'of' T ]" := (repack_Pred (fun a => @PropPredType _ T a))
  (at level 0, format "[ 'PredType'  'of'  T ]") : form_scope.

Notation Pred_Class := (Pred_Sort (PredPredType _)).
Coercion Sort_of_Simpl_Pred T (p : Simpl_Pred T) : Pred_Class := p : Pred T.

Definition PredArgType := Type.
Coercion Pred_of_argType (T : PredArgType) : Simpl_Pred T := PredT.

Notation "{ :: T }" := (T%type : PredArgType)
  (at level 0, format "{ ::  T }") : type_scope.

(* These must be defined outside a Section because "cooking" kills the *)
(* nosimpl tag. *)
Definition Mem T (pT : PredType T) : pT -> Mem_Pred T :=
  nosimpl (let: PropPredType _ _ (exist mem _) := pT return pT -> _ in mem).
Definition InMem T x mp := nosimpl Pred_of_Mem T mp x.

Prenex Implicits Mem.

(* Membership Predicates can be used as simple ones *)
Coercion Pred_of_Mem_Pred T mp := [Pred x : T | InMem x mp].

(* equality and subset *)

Definition EqPredType T (pT : PredType T) (p1 p2 : pT) :=
  forall x : T, toPred p1 x <-> toPred p2 x.

Definition SubPredType T (pT : PredType T) (p1 p2 : pT) :=
  forall x : T, toPred p1 x -> toPred p2 x.

(* Definition EqPred T (p1 p2 : Pred T) := EqPredType p1 p2. *)
(* Definition SubPred T (p1 p2 : Pred T) := SubPredType p1 p2.  *)
Definition EqSimplPred T (p1 p2 : Simpl_Pred T) := EqPredType p1 p2.
Definition SubSimplPred T (p1 p2 : Simpl_Pred T) := SubPredType p1 p2.
(*
Definition EqMem T (p1 p2 : Mem_Pred T) := EqPredType p1 p2.
Definition SubMem T (p1 p2 : Mem_Pred T) := SubPredType p1 p2.
*)

Definition EqPredFun T1 T2 (pT2 : PredType T2) p1 p2 :=
  forall x : T1, @EqPredType T2 pT2 (p1 x) (p2 x).
Definition SubPredFun T1 T2 (pT2 : PredType T2) p1 p2 :=
  forall x : T1, @SubPredType T2 pT2 (p1 x) (p2 x).

Definition EqMem T p1 p2 := forall x : T, InMem x p1 <-> InMem x p2.
Definition SubMem T p1 p2 := forall x : T, InMem x p1 -> InMem x p2.

Notation "A <~> B" := (@EqPredType _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A ~> B" := (@SubPredType _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A <~1> B" := (@EqPredFun _ _ _ A B)
  (at level 70, no associativity) : rel_scope.
Notation "A ~1> B" := (@SubPredFun _ _ _ A B)
  (at level 70, no associativity) : rel_scope.

Notation "x \In A" := (InMem x (Mem A))
  (at level 70, no associativity) : rel_scope.
Notation "x \Notin A" := (~ (x \In A))
  (at level 70, no associativity) : rel_scope.
Notation "A =p B" := (EqMem (Mem A) (Mem B))
  (at level 70, no associativity) : type_scope.
Notation "A <=p B" := (SubMem (Mem A) (Mem B))
  (at level 70, no associativity) : type_scope.

(* Some notation for turning PredTypes into Pred or Simple Pred *)
Notation "[ 'Mem' A ]" := (Pred_of_Simpl (Pred_of_Mem_Pred (Mem A)))
  (at level 0, only parsing) : fun_scope.
Notation "[ 'PredI' A & B ]" := (PredI [Mem A] [Mem B])
  (at level 0, format "[ 'PredI'  A  &  B ]") : fun_scope.
Notation "[ 'PredU' A & B ]" := (PredU [Mem A] [Mem B])
  (at level 0, format "[ 'PredU'  A  &  B ]") : fun_scope.
Notation "[ 'PredD' A & B ]" := (PredD [Mem A] [Mem B])
  (at level 0, format "[ 'PredD'  A  &  B ]") : fun_scope.
Notation "[ 'PredC' A ]" := (PredC [Mem A])
  (at level 0, format "[ 'PredC'  A ]") : fun_scope.
Notation "[ 'Preim' f 'of' A ]" := (Preim f [Mem A])
  (at level 0, format "[ 'Preim'  f  'of'  A ]") : fun_scope.

Notation "[ 'Pred' x \In A ]" := [Pred x | x \In A]
  (at level 0, x ident, format "[ 'Pred'  x  \In  A ]") : fun_scope.
Notation "[ 'Pred' x \In A | E ]" := [Pred x | (x \In A) /\ E]
  (at level 0, x ident, format "[ 'Pred'  x  \In  A  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A & B | E ]" :=
  [Pred x y | (x \In A) /\ (y \In B) /\ E]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  &  B  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A & B ]" := [Pred x y | (x \In A) /\ (y \In B)]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  &  B ]") : fun_scope.
Notation "[ 'Pred' x y \In A | E ]" := [Pred x y \In A & A | E]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A  |  E ]") : fun_scope.
Notation "[ 'Pred' x y \In A ]" := [Pred x y \In A & A]
  (at level 0, x ident, y ident,
   format "[ 'Pred'  x  y  \In  A ]") : fun_scope.

Section Simplifications.
Variables (T : Type) (pT : PredType T).

Lemma Mem_toPred : forall (p : pT), Mem (toPred p) = Mem p.
Proof. by rewrite /Mem; case: pT => T1 app1 [mem1  /= ->]. Qed.

Lemma toPredE : forall x (p : pT), toPred p x = (x \In p).
Proof. by move=> *; rewrite -Mem_toPred. Qed.

Lemma In_Simpl : forall x (p : Simpl_Pred T), (x \In p) = p x.
Proof. by []. Qed.

Lemma Simpl_PredE : forall (p : Pred T), p <~> [Pred x | p x].
Proof. by []. Qed.

(* Definition InE := (In_Simpl, Simpl_PredE). (* to be extended *) *)

Lemma Mem_Simpl : forall (p : Simpl_Pred T), Mem p = p :> Pred T.
Proof. by []. Qed.

Definition MemE := Mem_Simpl. (* could be extended *)

Lemma Mem_Mem : forall p : pT, (Mem (Mem p) = Mem p) * (Mem [Mem p] = Mem p).
Proof. by move=> p; rewrite -Mem_toPred. Qed.

End Simplifications.

(**************************************)
(* Definitions and lemmas for setoids *)
(**************************************)

Section RelProperties.
Variables (T : Type) (pT : PredType T).

Lemma EqPredType_refl (r : pT) : EqPredType r r. Proof. by []. Qed.
Lemma SubPredType_refl (r : pT) : SubPredType r r. Proof. by []. Qed.

Lemma EqPredType_sym (r1 r2 : pT) : EqPredType r1 r2 -> EqPredType r2 r1.
Proof. by move=>H1 x; split; move/H1. Qed.

Lemma EqPredType_trans' (r1 r2 r3 : pT) :
  EqPredType r1 r2 -> EqPredType r2 r3 -> EqPredType r1 r3.
Proof. by move=>H1 H2 x; split; [move/H1; move/H2 | move/H2; move/H1]. Qed.

Lemma SubPredType_trans' (r1 r2 r3 : pT) :
  SubPredType r1 r2 -> SubPredType r2 r3 -> SubPredType r1 r3.
Proof. by move=>H1 H2 x; move/H1; move/H2. Qed.

Definition EqPredType_trans r2 r1 r3 := @EqPredType_trans' r1 r2 r3.
Definition SubPredType_trans r2 r1 r3 := @SubPredType_trans' r1 r2 r3.
End RelProperties.

Hint Resolve EqPredType_refl SubPredType_refl.

(* Declaration of relations *)

(* Unfortunately, Coq setoids don't seem to understand implicit coercions *)
(* and canonical structures so we have to repeat relation declarations    *)
(* for all instances. This is really annoying, but at least I don't have  *)
(* to reprove the lemmas on refl, sym and trans                           *)
(*                                                                        *)
Add Parametric Relation T (pT : PredType T) : pT (@EqPredType _ pT)
   reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqPredType_rel.

(*                                                                        *)
(* Add Parametric Relation T (pT : PredType T) : pT (@SubPredType _ pT)   *)
(*  reflexivity proved by (@SubPredType_refl _ _)                         *)
(*  transitivity proved by (@SubPredType_trans' _ _) as SubPredType_rel.  *)

(* Add Parametric Relation T : (Pred T) (@EqPred _)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqPred_rel.

Add Parametric Relation T : (Pred T) (@SubPred _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubPred_rel.
*)

Add Parametric Relation T : (Simpl_Pred T) (@EqSimplPred _)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqSimplPred_rel.

Add Parametric Relation T : (Simpl_Pred T) (@SubSimplPred _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubSimplPred_rel.

Add Parametric Relation T : (Mem_Pred T) (@EqMem T)
  reflexivity proved by (@EqPredType_refl _ _)
  symmetry proved by (@EqPredType_sym _ _)
  transitivity proved by (@EqPredType_trans' _ _) as EqMem_rel.

Add Parametric Relation T : (Mem_Pred T) (@SubMem _)
  reflexivity proved by (@SubPredType_refl _ _)
  transitivity proved by (@SubPredType_trans' _ _) as SubMem_rel.

(* Declaring morphisms. *)
(* Annoyingly, even the coercions must be declared *)

Add Parametric Morphism T : (@Pred_of_Simpl T) with signature
      @EqSimplPred _ ==> @EqPredType T (PredPredType T) as Pred_of_Simpl_morph.
Proof. by []. Qed.

(* Do we need other coercions? We'll discover as we go *)

(* Now the other morphisms. Again, not clear which ones are needed.   *)
(* However, for all this to work, it seems that morphisms must be     *)
(* declared with most specific signatures, or else the system         *)
(* complains. For example, we use EqPred _ instead of EqPredType _ _, *)
(* even though the former is an instance of the later.                *)

(*
Add Parametric Morphism T : (@EqPred T) with signature
    @EqPred _ ==> @EqPred _ ==> iff as EqPred_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; rewrite H1 H2. Qed.
*)

Add Parametric Morphism T (pT : PredType T) : (@EqPredType T pT) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> iff as EqPredType_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; rewrite H1 H2. Qed.

Add Parametric Morphism T (pT : PredType T) : (@SubPredType T pT) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> iff as SubPred_morph.
Proof. by move=>r1 s1 H1 r2 s2 H2; split=>H x; move/H1; move/H; move/H2. Qed.

Add Parametric Morphism T : (@InMem T) with signature
    @eq _ ==> @EqMem _ ==> iff as InMem_morph.
Proof. by move=>x r s H; split; move/H. Qed.

Add Parametric Morphism T (pT : PredType T) : (@Mem T pT) with signature
  @EqPredType _ _ ==> @EqMem _ as Mem_morhp.
Proof. by move=>x y H p; rewrite /EqPredType -!toPredE in H *; rewrite H. Qed.

Add Parametric Morphism T : (@PredU T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> @EqSimplPred _ as predU_morph.
Proof.
move=>r1 s1 H1 r2 h2 H2 x; split;
by case; [move/H1 | move/H2]=>/=; auto.
Qed.

Add Parametric Morphism T : (@PredI T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ ==> @EqPredType _ _ as predI_morph.
Proof.
move=>r1 s1 H1 r2 s2 H2 x; split;
by case; move/H1=>T1; move/H2=>T2.
Qed.

Add Parametric Morphism T : (@PredC T) with signature
    @EqPredType _ _ ==> @EqPredType _ _ as predC_morph.
Proof. by move=>r s H x; split=>H1; apply/H. Qed.

Section RelLaws.
Variable (T : Type).

Lemma orrI (r : Pred nat) : r +p r <~> r.
Proof.  by move=>x; split; [case | left]. Qed.

Lemma orrC (r1 r2 : Pred T) : r1 +p r2 <~> r2 +p r1.
Proof. move=>x; split=>/=; tauto. Qed.

Lemma orr0 (r : Pred T) : r +p Pred0 <~> r.
Proof. by move=>x; split; [case | left]. Qed.

Lemma or0r (r : Pred T) : Pred0 +p r <~> r.
Proof. by rewrite orrC orr0. Qed.

Lemma orrCA (r1 r2 r3 : Pred T) : r1 +p r2 +p r3 <~> r2 +p r1 +p r3.
Proof. by move=>x; split=>/=; intuition. Qed.

Lemma orrAC (r1 r2 r3 : Pred T) : (r1 +p r2) +p r3 <~> (r1 +p r3) +p r2.
Proof. by move=>?; split=>/=; intuition. Qed.

Lemma orrA (r1 r2 r3 : Pred T) : (r1 +p r2) +p r3 <~> r1 +p r2 +p r3.
Proof. by rewrite (orrC r2) orrCA orrC. Qed.

(* absorption *)
Lemma orrAb (r1 a : Pred T) : r1 <~> r1 +p a <-> a ~> r1.
Proof.
split; first by move=>-> x /=; auto.
move=>H x /=; split; first by auto.
by case=>//; move/H.
Qed.

Lemma sub_orl (r1 r2 : Pred T) : r1 ~> r1 +p r2. Proof. by left. Qed.
Lemma sub_orr (r1 r2 : Pred T) : r2 ~> r1 +p r2. Proof. by right. Qed.

End RelLaws.

Section SubMemLaws.
Variable T : Type.

Lemma subp_refl (p : Pred T) : p <=p p.
Proof. by []. Qed.

Lemma subp_asym (p1 p2 : Pred T) : p1 <=p p2 -> p2 <=p p1 -> p1 =p p2.
Proof. by move=>H1 H2 x; split; [move/H1 | move/H2]. Qed.

Lemma subp_trans (p2 p1 p3 : Pred T) : p1 <=p p2 -> p2 <=p p3 -> p1 <=p p3.
Proof. by move=>H1 H2 x; move/H1; move/H2. Qed.

Lemma subp_or (p1 p2 q : Pred T) : p1 <=p q /\ p2 <=p q <-> p1 +p p2 <=p q.
Proof.
split=>[[H1] H2 x|H1]; first by case; [move/H1 | move/H2].
by split=>x H2; apply: H1; [left | right].
Qed.

Lemma subp_and (p1 p2 q : Pred T) : q <=p p1 /\ q <=p p2 <-> q <=p p1 *p p2.
Proof.
split=>[[H1] H2 x|] H; last by split=>x; case/H.
by split; [apply: H1 | apply: H2].
Qed.

Lemma subp_orl (p1 p2 q : Pred T) : p1 <=p p2 -> p1 +p q <=p p2 +p q.
Proof. by move=>H x; case; [move/H; left|right]. Qed.

Lemma subp_orr (p1 p2 q : Pred T) : p1 <=p p2 -> q +p p1 <=p q +p p2.
Proof. by move=>H x; case; [left | move/H; right]. Qed.

Lemma subp_andl (p1 p2 q : Pred T) : p1 <=p p2 -> p1 *p q <=p p2 *p q.
Proof. by by move=>H x [H1 H2]; split; [apply: H|]. Qed.

Lemma subp_andr (p1 p2 q : Pred T) : p1 <=p p2 -> q *p p1 <=p q *p p2.
Proof. by move=>H x [H1 H2]; split; [|apply: H]. Qed.

End SubMemLaws.

Hint Resolve subp_refl.

Section ListMembership.
Variable T : Type.

Fixpoint Mem_Seq (s : seq T) :=
  if s is y::s' then (fun x => x = y \/ Mem_Seq s' x) else xPred0.

Definition EqSeq_Class := seq T.
Identity Coercion seq_of_EqSeq : EqSeq_Class >-> seq.

Coercion Pred_of_Eq_Seq (s : EqSeq_Class) : Pred_Class := [eta Mem_Seq s].

Canonical Structure seq_PredType := @mkPredType T (seq T) Pred_of_Eq_Seq.
(* The line below makes Mem_Seq a canonical instance of topred. *)
Canonical Structure Mem_Seq_PredType := mkPredType Mem_Seq.

Lemma In_cons : forall y s x, (x \In y :: s) <-> (x = y) \/ (x \In s).
Proof. by []. Qed.

Lemma In_nil : forall x, (x \In [::]) <-> False.
Proof. by []. Qed.

Lemma Mem_Seq1 : forall x y, (x \In [:: y]) <-> (x = y).
Proof. by move=> x y; rewrite In_cons orpF. Qed.

Definition InE := (Mem_Seq1, In_cons, In_Simpl).
(* I also wanted to add Simpl_PredE, but setoid rewrite returns an error *)
(* and instead of trying the other rules in the tuple, it just stops *)
(* This is ridiculuous *)

Lemma Mem_cat : forall x s1 s2, (x \In s1 ++ s2) <-> x \In s1 \/ x \In s2.
Proof.
move=>x; elim=>[|y s1 IH] s2 /=; first by split; [right | case].
rewrite !InE /=.
split.
- case=>[->|/IH]; first by left; left.
  by case; [left; right | right].
case; first by case; [left | move=>H; right; apply/IH; left].
by move=>H; right; apply/IH; right.
Qed.

End ListMembership.

Lemma Mem_map T T' (f : T -> T') x (s : seq T) :
         x \In s -> f x \In (map f s).
Proof.
elim: s=>[|y s IH] //; rewrite InE /=.
by case=>[<-|/IH]; [left | right].
Qed.

Lemma Mem_map_inv T T' (f : T -> T') x (s : seq T) :
        x \In (map f s) -> exists y, x = f y /\ y \In s.
Proof.
elim: s=>[|y s IH] //=; rewrite InE /=.
case; first by move=>->; exists y; split=>//; left.
by case/IH=>z [->]; exists z; split=>//; right.
Qed.

Prenex Implicits Mem_map_inv.

(* Setoids for extensional equality of functions *)

Lemma eqfun_refl A B (f : A -> B) : f =1 f. Proof. by []. Qed.
Lemma eqfun_sym A B (f1 f2 : A -> B) : f1 =1 f2 -> f2 =1 f1.
Proof. by move=>H x; rewrite H. Qed.
Lemma eqfun_trans A B (f1 f2 f3 : A -> B) : f1 =1 f2 -> f2 =1 f3 -> f1 =1 f3.
Proof. by move=>H1 H2 x; rewrite H1 H2. Qed.

Add Parametric Relation A B : (A -> B) (@eqfun _ _)
  reflexivity proved by (@eqfun_refl A B)
  symmetry proved by (@eqfun_sym A B)
  transitivity proved by (@eqfun_trans A B) as eqfun_morph.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tREWRITE_ : Universe -> Universe -> Prop.
Variable tREFLEXIVE_REWRITE_ : Universe -> Universe -> Prop.
Variable tEQUALISH_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable z_ : Universe.
Variable y_ : Universe.
Variable x_ : Universe.

Variable initial_model_1 : (dom_ x_ /\ (dom_ y_ /\ (dom_ z_ /\ (tREFLEXIVE_REWRITE_ x_ y_ /\ tREFLEXIVE_REWRITE_ x_ z_)))).
Variable ax1_2 : (forall A : Universe, ((tREFLEXIVE_REWRITE_ y_ A /\ tREFLEXIVE_REWRITE_ z_ A) -> goal_)).
Variable ax2_3 : (forall A B : Universe, (tREWRITE_ A B -> tREFLEXIVE_REWRITE_ A B)).
Variable ax3_4 : (forall A B : Universe, (tEQUALISH_ A B -> tREFLEXIVE_REWRITE_ A B)).
Variable ax4_5 : (forall A B C : Universe, ((tEQUALISH_ A B /\ tREFLEXIVE_REWRITE_ B C) -> tREFLEXIVE_REWRITE_ A C)).
Variable ax5_6 : (forall A B : Universe, (tEQUALISH_ A B -> tEQUALISH_ B A)).
Variable ax6_7 : (forall A : Universe, (dom_ A -> tEQUALISH_ A A)).
Variable ax7_8 : (forall A B : Universe, (tREFLEXIVE_REWRITE_ A B -> (tEQUALISH_ A B \/ tREWRITE_ A B))).
Variable ax8_9 : (forall A B C : Universe, ((tREWRITE_ A B /\ tREWRITE_ A C) -> (exists D : Universe, (dom_ D /\ (tREWRITE_ B D /\ tREWRITE_ C D))))).

Theorem dpe_a_10 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


(* coq-robot (c) 2017 AIST and INRIA. License: LGPL-2.1-or-later. *)
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 reals interval trigo.
Require Import ssr_ext euclidean extra_trigo.
From mathcomp.analysis Require Import forms.

(******************************************************************************)
(*                          Vector angles and lines                           *)
(*                                                                            *)
(* This file defines angles between two vectors and develops their theory     *)
(* (e.g., multiplication by an orthogonal matrix preserves the angle between  *)
(* two vectors, etc.) and a theory of lines.                                  *)
(*                                                                            *)
(*         vec_angle v w == angle in [0;pi] formed by the vectors v and w     *)
(*          colinear u v == the vectors u and v are colinear, defined using   *)
(*                          the cross-product                                 *)
(*         axialcomp v e == the axial component of vector v along e, or the   *)
(*                          projection of v on e                              *)
(*        normalcomp v e == the normal component of vector v w.r.t. e         *)
(*                                                                            *)
(*              Line.t T == the type of lines defined in a parametric way     *)
(*                          using a point belonging to the line and a vector  *)
(*                          (the direction of the line)                       *)
(*                \pt{l} == the point used to define the line l               *)
(*               \vec{l} == the direction of the line l                       *)
(*        parallel l1 l2 == the lines l1 and l2 are parallel                  *)
(*   perpendicular l1 l2 == the lines l1 and l2 are perpendicular             *)
(*  coplanar p1 p2 p3 p3 == the four points p1, p2, p3, and p4 are coplanar   *)
(*            skew l1 l2 == l1 and l2 are skew lines                          *)
(*      intersects l1 l2 == the lines l1 and l2 intersects                    *)
(* is_interpoint p l1 l2 == the lines l1 and l2 intersects at the point p     *)
(* distance_point_line p l == the distance between the point p and the line l *)
(* distance_between_lines l1 l2 == the distance between the lines l1 and l2   *)
(******************************************************************************)

Reserved Notation "'\pt(' l ')'" (at level 3, format "'\pt(' l ')'").
Reserved Notation "'\pt2(' l ')'" (at level 3, format "'\pt2(' l ')'").
Reserved Notation "'\vec(' l ')'" (at level 3, format "'\vec(' l ')'").

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

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

Local Open Scope ring_scope.

Lemma norm_le1 [T : rcfType] (u : 'rV[T]_2) :
  norm u <= 1 -> (- 1 <= u``_ 0 <= 1) /\ (- 1 <= u``_1 <= 1).
Proof.
move=> nuL1; rewrite -!ler_norml.
rewrite -!(expr_le1 (_ : 0 < 2)%N (normr_ge0 _)) //.
suff sL1 : `|u``_0| ^+ 2 + `|u``_1| ^+ 2 <= 1.
  split; apply: le_trans sL1.
    by rewrite -[X in X <= _]addr0 ler_add // sqr_ge0.
  by rewrite -[X in X <= _]add0r ler_add // sqr_ge0.
rewrite !sqr_normr //.
suff : norm u ^+ 2 <= 1 by rewrite sqr_norm sum2E.
by apply: exprn_ile1 (norm_ge0 _) _.
Qed.

Lemma norm1_cossin (T : realType) (v : 'rV[T]_2) :
  norm v = 1 -> {a | v``_0 = cos a /\ v``_1 = sin a}.
Proof.
move=> nvE.
exists (if 0 <= v``_1 then acos v``_0 else -acos v``_0).
have /norm_le1[v0B v1B] : norm v <= 1 by rewrite nvE.
have [v0_ge0|v0_gt0] := leP 0%R (v``_1).
  rewrite acosK ?in_itv //= sin_acos ?in_itv //=.
  rewrite -(expr1n T 2) -nvE sqr_norm sum2E [_ + _^+2] addrC addrK.
  by rewrite sqrtr_sqr ger0_norm.
rewrite cosN sinN acosK ?in_itv //= sin_acos ?in_itv //=.
rewrite -(expr1n T 2) -nvE sqr_norm sum2E [_ + _^+2] addrC addrK.
by rewrite sqrtr_sqr ltr0_norm ?opprK.
Qed.

Import rv3LieAlgebra.Exports.

Section vec_angle.
Variable T : realType.
Implicit Types u v : 'rV[T]_3.

Definition vec_angle v w : T :=
  if v == 0 then 0 else
  if w == 0 then 0 else acos (v *d w / (norm v * norm w)).

Lemma vec_anglev0 v : vec_angle v 0 = 0.
Proof. by rewrite /vec_angle eqxx if_same. Qed.

Lemma vec_angle0v v : vec_angle 0 v = 0.
Proof. by rewrite /vec_angle eqxx. Qed.

Definition vec_angle0 := (vec_anglev0, vec_angle0v).

Lemma vec_angleC v w : vec_angle v w = vec_angle w v.
Proof.
by rewrite /vec_angle  dotmulC [norm _ * _]mulrC; do 2 case: eqP.
Qed.

Lemma vec_anglevZ u v k : 0 < k -> vec_angle u (k *: v) = vec_angle u v.
Proof.
move=> k_gt0; rewrite /vec_angle; case: eqP => // /eqP u0.
rewrite scaler_eq0 (negPf (lt0r_neq0 _)) //=.
rewrite dotmulvZ normZ gtr0_norm // mulrCA -mulf_div divff ?mul1r //.
by rewrite lt0r_neq0.
Qed.

Lemma vec_angleZv u v (k : T) : 0 < k -> vec_angle (k *: u) v = vec_angle u v.
Proof. move=> ?; rewrite vec_angleC vec_anglevZ; by [rewrite vec_angleC|]. Qed.

Lemma vec_anglevZN u v k : k < 0 -> vec_angle u (k *: v) = vec_angle u (- v).
Proof.
move=> k_lt0; rewrite /vec_angle; case: eqP => // /eqP u0.
rewrite scaler_eq0 (negPf (ltr0_neq0 _)) //= oppr_eq0.
rewrite dotmulvZ normZ ltr0_norm // normN dotmulvN mulrCA -mulf_div.
rewrite invrN mulrN divff ?(mulN1r, mulNr) //.
by rewrite ltr0_neq0.
Qed.

Lemma vec_angleZNv u v k : k < 0 -> vec_angle (k *: u) v = vec_angle (- u) v.
Proof. move=> ?; rewrite vec_angleC vec_anglevZN; by [rewrite vec_angleC|]. Qed.

Lemma vec_anglevv u : u != 0 -> vec_angle u u = 0.
Proof.
move=> u0.
rewrite /vec_angle /= (negPf u0) dotmulvv -expr2 divff ?acos1 //.
by rewrite expf_eq0 //= norm_eq0.
Qed.

Lemma dotmul_div_N11 v w :
  v != 0 -> w != 0 -> v *d w / (norm v * norm w) \in `[(-1), 1].
Proof.
move=> u0 v0.
rewrite in_itv /= -ler_norml -(expr_le1 (_ : 0 < 2)%N) //.
rewrite sqr_normr expr_div_n ler_pdivr_mulr ?mul1r.
rewrite -subr_ge0 -norm_crossmul' ?exprn_ge0 ?norm_ge0 //.
by rewrite exprn_gt0 // mulr_gt0 // norm_gt0.
Qed.

Lemma cos_vec_angleNv v w : v != 0 -> w != 0 ->
  cos (vec_angle (- v) w) = - cos (vec_angle v w).
Proof.
move=> u0 v0.
rewrite /vec_angle oppr_eq0 (negPf u0) (negPf v0) normN dotmulNv mulNr.
have H := dotmul_div_N11 u0 v0.
by rewrite !acosK ?oppr_itvcc ?opprK.
Qed.

Lemma cos_vec_anglevN v w : v != 0 -> w != 0 ->
  cos (vec_angle v (- w)) = - cos (vec_angle v w).
Proof.
by move=> u0 v0; rewrite ![_ v _]vec_angleC; apply: cos_vec_angleNv.
Qed.

Lemma sin_vec_angle_ge0 u v (u0 : u != 0) (v0 : v != 0) :
  0 <= sin (vec_angle u v).
Proof.
rewrite /vec_angle (negPf u0) (negPf v0).
rewrite sin_acos ?sqrtr_ge0 //.
by have := dotmul_div_N11 u0 v0; rewrite in_itv.
Qed.

Lemma sin_vec_anglevN u v : sin (vec_angle u (- v)) = sin (vec_angle u v).
Proof.
rewrite /vec_angle oppr_eq0; case: eqP => [//|/eqP uD0].
case: eqP => [//|/eqP vD0].
have H := dotmul_div_N11 uD0 vD0; rewrite in_itv in H.
rewrite normN dotmulvN mulNr !sin_acos ?sqrrN //.
by rewrite ler_oppr opprK ler_oppl andbC.
Qed.

Lemma sin_vec_angleNv u v : sin (vec_angle (- u) v) = sin (vec_angle u v).
Proof. by rewrite vec_angleC [in RHS]vec_angleC [in LHS]sin_vec_anglevN. Qed.

Lemma dotmul_cos u v : u *d v = norm u * norm v * cos (vec_angle u v).
Proof.
wlog /andP[u0 v0] : u v / (u != 0) && (v != 0).
  case/boolP : (u == 0) => [/eqP ->{u}|u0]; first by rewrite dotmul0v norm0 !mul0r.
  case/boolP : (v == 0) => [/eqP ->{v}|v0]; first by rewrite dotmulv0 norm0 !(mulr0,mul0r).
  apply; by rewrite u0.
rewrite /vec_angle (negPf u0) (negPf v0) acosK; last by apply: dotmul_div_N11.
by rewrite mulrC divfK // mulf_eq0 negb_or !norm_eq0 u0.
Qed.

Lemma dotmul0_vec_angle u v : u != 0 -> v != 0 ->
  u *d v = 0 -> `| sin (vec_angle u v) | = 1.
Proof.
move=> u0 v0 uv0.
by rewrite /vec_angle (negPf u0) (negPf v0) uv0 mul0r acos0 sin_pihalf normr1.
Qed.

Lemma triine u v :
  (norm u * norm v * cos (vec_angle u v)) *+ 2 <= norm u ^+ 2 + norm v ^+ 2.
Proof.
move/eqP: (sqrrD (norm u) (norm v)); rewrite addrAC -subr_eq => /eqP <-.
rewrite ler_subr_addr -mulrnDl -{2}(mulr1 (norm u * norm v)) -mulrDr.
apply (@le_trans _ _ (norm u * norm v * 2%:R *+ 2)).
  rewrite ler_muln2r /=; apply ler_pmul => //.
    by apply mulr_ge0; apply norm_ge0.
    rewrite -ler_subl_addr add0r; move: (cos_max (vec_angle u v)).
    by rewrite ler_norml => /andP[].
  rewrite -ler_subr_addr {2}(_ : 1 = 1%:R) // -natrB //.
  move: (cos_max (vec_angle u v)); by rewrite ler_norml => /andP[].
rewrite sqrrD mulr2n addrAC; apply ler_add; last by rewrite mulr_natr.
by rewrite -subr_ge0 addrAC mulr_natr -sqrrB sqr_ge0.
Qed.

Lemma normB u v : norm (u - v) ^+ 2 =
  norm u ^+ 2 + norm u * norm v * cos (vec_angle u v) *- 2 + norm v ^+ 2.
Proof.
rewrite /norm dotmulD {1}dotmulvv sqr_sqrtr; last first.
  rewrite !dotmulvN !dotmulNv opprK dotmulvv dotmul_cos.
  by rewrite addrAC mulNrn subr_ge0 triine.
rewrite sqr_sqrtr ?le0dotmul // !dotmulvv !sqrtr_sqr normN dotmulvN dotmul_cos.
by rewrite ger0_norm ?norm_ge0 // ger0_norm ?norm_ge0 // mulNrn.
Qed.

Lemma normD u v : norm (u + v) ^+ 2 =
  norm u ^+ 2 + norm u * norm v * cos (vec_angle u v) *+ 2 + norm v ^+ 2.
Proof.
rewrite {1}(_ : v = - - v); last by rewrite opprK.
rewrite normB normN.
case/boolP: (u == 0) => [/eqP ->|u0].
  by rewrite !(norm0,expr0n,add0r,vec_angle0,mul0r,mul0rn,oppr0).
case/boolP: (v == 0) => [/eqP ->|v0].
  by rewrite !(norm0,expr0n,add0r,vec_angle0,mulr0,mul0r,mul0rn,oppr0).
by rewrite [in LHS]cos_vec_anglevN // mulrN mulNrn opprK.
Qed.

Lemma cosine_law' a b c :
  norm (b - c) ^+ 2 = norm (c - a) ^+ 2 + norm (b - a) ^+ 2 -
  norm (c - a) * norm (b - a) * cos (vec_angle (b - a) (c - a)) *+ 2.
Proof.
rewrite -[in LHS]dotmulvv (_ : b - c = b - a - (c - a)); last first.
  by rewrite -!addrA opprB (addrC (- a)) (addrC a) addrK.
rewrite dotmulD dotmulvv [in X in _ + _ + X = _]dotmulvN dotmulNv opprK.
rewrite dotmulvv dotmulvN addrAC (addrC (norm (b - a) ^+ _)); congr (_ + _).
by rewrite dotmul_cos mulNrn (mulrC (norm (b - a))).
Qed.

Lemma cosine_law a b c : norm (c - a) != 0 -> norm (b - a) != 0 ->
  cos (vec_angle (b - a) (c - a)) =
  (norm (b - c) ^+ 2 - norm (c - a) ^+ 2 - norm (b - a) ^+ 2) /
  (norm (c - a) * norm (b - a) *- 2).
Proof.
move=> H0 H1.
rewrite (cosine_law' a b c) -2!addrA addrCA -opprD subrr addr0.
rewrite -mulNrn -mulr_natr mulNr -mulrA -(mulrC 2%:R) mulrA.
rewrite -mulNrn -[in X in _ = - _ / X]mulr_natr 2!mulNr invrN mulrN opprK.
rewrite mulrC mulrA mulVr ?mul1r // unitfE mulf_eq0 negb_or pnatr_eq0 andbT.
by rewrite mulf_eq0 negb_or H0 H1.
Qed.

Lemma norm_crossmul u v :
  norm (u *v v) = norm u * norm v * `| sin (vec_angle u v) |.
Proof.
suff /eqP : (norm (u *v v))^+2 = (norm u * norm v * `| sin (vec_angle u v) |)^+2.
  rewrite -eqr_sqrt ?sqr_ge0 // 2!sqrtr_sqr ger0_norm; last by rewrite norm_ge0.
  rewrite ger0_norm; first by move/eqP.
  by rewrite -mulrA mulr_ge0 // ?norm_ge0 // mulr_ge0 // ? norm_ge0.
rewrite norm_crossmul' dotmul_cos !exprMn.
apply/eqP; rewrite subr_eq -mulrDr.
rewrite real_normK //; first by rewrite addrC cos2Dsin2 mulr1.
by rewrite realE; case: ltgtP.
Qed.

Lemma norm_dotmul_crossmul u v : u != 0 -> v != 0 ->
  (`|u *d v +i* norm (u *v v)| = (norm u * norm v)%:C)%C.
Proof.
move=> u0 v0 .
rewrite {1}dotmul_cos {1}norm_crossmul normc_def.
rewrite exprMn (@exprMn _ 2 _ `| sin _ |) -mulrDr.
rewrite sqrtrM ?sqr_ge0 // sqr_normr cos2Dsin2 sqrtr1 mulr1.
rewrite sqrtr_sqr normrM; by do 2 rewrite ger0_norm ?norm_ge0 //.
Qed.

Lemma vec_angle0_inv u v : u != 0 -> v != 0 ->
  vec_angle u v = 0 -> u = (norm u / norm v) *: v.
Proof.
move=> uD0 vD0 uv0.
apply/eqP; rewrite -subr_eq0 -norm_eq0.
rewrite -(@eqr_expn2 _ 2) // ?norm_ge0 // expr0n /= normB.
rewrite vec_anglevZ; last by rewrite divr_gt0 // norm_gt0.
rewrite uv0 cos0 mulr1 !normZ ger0_norm; last first.
  by rewrite divr_ge0 // norm_ge0.
by rewrite divfK ?norm_eq0 // -expr2 addrAC -mulr2n subrr.
Qed.

Lemma vec_anglepi_inv u v : u != 0 -> v != 0 ->
  vec_angle u v = pi -> u = - (norm u / norm v) *: v.
Proof.
move=> uD0 vD0 uvpi.
apply/eqP; rewrite -subr_eq0 -norm_eq0 scaleNr opprK.
rewrite -(@eqr_expn2 _ 2) // ?norm_ge0 // expr0n /= normD.
rewrite vec_anglevZ; last by rewrite divr_gt0 // norm_gt0.
rewrite uvpi cospi mulrN1 !normZ ger0_norm; last first.
  by rewrite divr_ge0 // norm_ge0.
rewrite mulNrn divfK ?norm_eq0 //.
by rewrite addrC addrA -expr2 -mulr2n subrr.
Qed.

Lemma vec_angle_bound u v : 0 <= vec_angle u v <= pi.
Proof.
have z_bound : 0 <= (0 : T) <= pi by rewrite lexx pi_ge0.
rewrite /vec_angle; case: eqP => // /eqP uD0; case: eqP => // /eqP vD0.
have := dotmul_div_N11 uD0 vD0; rewrite in_itv /= => uv_bound.
by rewrite acos_ge0 // acos_lepi.
Qed.

Lemma dotmul1_inv u v : norm u = 1 -> norm v = 1 -> u *d v = 1 -> u = v.
Proof.
move=> u1 v1; rewrite dotmul_cos u1 v1 2!mul1r => Huv.
suff: u = (norm u / norm v) *: v.
rewrite u1 v1 ?divff ?(scale1r, oner_neq0) //.
apply: vec_angle0_inv; first by rewrite -norm_eq0 u1 oner_neq0.
  by rewrite -norm_eq0 v1 oner_neq0.
apply: cos_inj; rewrite ?in_itv /=; last by rewrite cos0.
  by apply: vec_angle_bound.
by rewrite lexx pi_ge0.
Qed.

Lemma dotmulN1_inv u v : norm u = 1 -> norm v = 1 -> u *d v = - 1 -> u = - v.
Proof.
move=> u1 v1 Huv.
by apply: dotmul1_inv; rewrite ?normN // dotmulvN Huv opprK.
Qed.

Lemma cos_vec_angle a b : a != 0 -> b != 0 ->
  `| cos (vec_angle a b) | = Num.sqrt (1 - (norm (a *v b) / (norm a * norm b)) ^+ 2).
Proof.
move=> Ha Hb.
rewrite norm_crossmul mulrAC divrr // ?mul1r.
  by rewrite sqr_normr -cos2sin2 sqrtr_sqr.
by rewrite unitfE mulf_neq0 // norm_eq0.
Qed.

Lemma orth_preserves_vec_angle M : M \is 'O[T]_3 ->
  {mono (fun u => u *m M) : v w / vec_angle v w}.
Proof.
move=> MO v w.
have [->|/eqP vD0]:= v =P 0; first by rewrite mul0mx !vec_angle0.
have [->|/eqP wD0]:= w =P 0; first by rewrite mul0mx !vec_angle0.
apply: cos_inj; try by apply: vec_angle_bound.
have /mulfI : norm v * norm w != 0.
  by rewrite mulf_eq0 !norm_eq0 negb_or vD0 wD0.
apply; rewrite -[RHS]dotmul_cos.
have /orth_preserves_dotmul/(_ v w)<-  := MO.
by rewrite [RHS]dotmul_cos !orth_preserves_norm.
Qed.

End vec_angle.

Section colinear.
Variable R : comRingType.
Implicit Types u v : 'rV[R]_3.

Definition colinear u v := u *v v == 0.

Lemma colinearvv u : colinear u u.
Proof. by rewrite /colinear liexx. Qed.

Lemma scale_colinear k v : colinear (k *: v) v.
Proof. by rewrite /colinear lieC linearZ /= liexx scaler0 oppr0. Qed.

Lemma colinear_refl : reflexive colinear.
Proof. move=> ?; by rewrite /colinear liexx. Qed.

(* NB: remove "ssrbool." as soon as clash is resolved,
   PR in progress to forms.v in mathcomp-analysis *)
Lemma colinear_sym : ssrbool.symmetric colinear.
Proof. by move=> u v; rewrite /colinear lieC -eqr_opp opprK oppr0. Qed.

Lemma colinear0v u : colinear 0 u.
Proof. by rewrite /colinear linear0l. Qed.

Lemma colinearv0 u : colinear u 0.
Proof. by rewrite colinear_sym colinear0v. Qed.

Definition colinear0 := (colinear0v, colinearv0).

Lemma colinearNv u v : colinear (- u) v = colinear u v.
Proof. by rewrite /colinear linearNl eqr_oppLR oppr0. Qed.

Lemma colinearvN u v : colinear u (- v) = colinear u v.
Proof. by rewrite colinear_sym colinearNv colinear_sym. Qed.

Lemma colinearD u v w : colinear u w -> colinear v w -> colinear (u + v) w.
Proof. by rewrite /colinear linearDl /= => /eqP-> /eqP->; rewrite addr0. Qed.

End colinear.

Lemma col_perm_eq0 (T : ringType) (u : 'rV[T]_3) (s : 'S_3) :
  (col_perm s u == 0) = (u == 0).
Proof.
apply/eqP/eqP; last by move->; rewrite col_permE mul0mx.
move=> /rowP u0; apply/rowP=> i.
by have := u0 (s^-1%g i); rewrite !mxE /= permKV.
Qed.

Lemma colinear_permE (T : idomainType) (s : 'S_3) (u v : 'rV[T]_3) :
  colinear u v = colinear (col_perm s u) (col_perm s v).
Proof.
rewrite /colinear !col_permE -mulmx_crossmul; last exact: unitmx_perm.
rewrite -scalemxAr scalemx_eq0 det_perm signr_eq0 /=.
by rewrite perm_mxV invrK tr_perm_mx -col_permE col_perm_eq0.
Qed.

Lemma colinear_trans (T : idomainType) (v u w : 'rV[T]_3) :
  u != 0 -> colinear v u -> colinear u w -> colinear v w.
Proof.
move=> /eqP/rowP/eqfunP; rewrite negb_forall => /existsP [j].
rewrite mxE; wlog: v u w j / j = 0.
  move=> hwlog ujn0; set s := tperm j 0.
  rewrite (colinear_permE s) => vu; rewrite (colinear_permE s) => uw.
  rewrite (colinear_permE s); apply: hwlog 0 _ _ vu uw => //.
  by rewrite mxE tpermR.
move=>-> /lregP u0n0; rewrite /colinear !crossmulE => /eqP/rowP vu /eqP/rowP uw.
apply/eqP/rowP=> i; rewrite !mxE /=; case: ifP => _.
  apply/eqP; rewrite -(mulrI_eq0 _ u0n0) mulrBr !mulrA.
  have := vu 1; rewrite !mxE /= => /subr0_eq; rewrite mulrC =>->.
  rewrite [u``_0 * _]mulrC; have := vu 2%:R; rewrite !mxE /= => /subr0_eq => <-.
  rewrite -mulrA; have := uw 0; rewrite !mxE /= => /subr0_eq =>->.
  by rewrite mulrA subrr.
case: ifP => _.
  apply/eqP; rewrite -(mulrI_eq0 _ u0n0) mulrBr !mulrA.
  rewrite [u``_0 * _]mulrC; have := vu 1; rewrite !mxE /= => /subr0_eq ->.
  rewrite -[X in X - _]mulrA; have := uw 1; rewrite !mxE /= => /subr0_eq ->.
  by rewrite mulrCA mulrA subrr.
case: ifP => _ //; apply/eqP; rewrite -(mulrI_eq0 _ u0n0) mulrBr !mulrA.
rewrite mulrAC; have := uw 2%:R; rewrite !mxE /= => /subr0_eq ->.
rewrite mulrAC [u``_1 * _]mulrC; have := vu 2%:R; rewrite !mxE /= => /subr0_eq.
by move->; rewrite [v``_1 * _]mulrC subrr.
Qed.

Lemma colinearZv (T : fieldType) (u v : 'rV[T]_3) k :
  colinear (k *: u) v = (k == 0) || colinear u v.
Proof. by rewrite /colinear linearZl_LR scaler_eq0. Qed.

Lemma colinearvZ (T : fieldType) (u v : 'rV[T]_3) k :
  colinear u (k *: v) = (k == 0) || colinear u v.
Proof. by rewrite /colinear linearZr_LR scaler_eq0. Qed.

Lemma colinearP (T : fieldType) (u v : 'rV[T]_3) :
  reflect (v == 0 \/ (v != 0 /\ exists k, u = k *: v)) (colinear u v).
Proof.
apply: (iffP idP); last first.
  case=> [/eqP ->|]; first by rewrite colinear0.
  case=> v0 [k ukv].
  by rewrite /colinear ukv lieC linearZ /= liexx scaler0 oppr0.
rewrite /colinear => uv.
case/boolP : (v == 0) => v0; [by left | right; split; first by done].
move: v0 => /eqP/rowP/eqfunP; rewrite negb_forall => /existsP [j].
rewrite mxE => v0; exists (u``_j / v``_j); apply/rowP => i; rewrite mxE.
case: (eqVneq i j) => [->|inej]; first by rewrite mulrVK ?unitfE.
move: uv; rewrite crossmul0E => /forallP /(_ j) /forallP /(_ i).
rewrite eq_sym => /implyP /(_ inej) /eqP uvij; apply: (mulfI v0).
by rewrite mulrC !mulrA -mulrA mulrACA mulfV ?mul1r.
Qed.

Section colinear1.

Variable T : realType.
Implicit Types u v : 'rV[T]_3.

Lemma colinear_sin u v (uD0 : u != 0) (vD0 : v != 0) :
  (colinear u v) = (sin (vec_angle u v) == 0).
Proof.
have uND0 : -u != 0 by rewrite oppr_eq0.
have vND0 : -v != 0 by rewrite oppr_eq0.
apply/idP/idP.
  rewrite colinear_sym => /colinearP.
  rewrite (negbTE uD0).
  case=> // -[_ [k Hk]]; rewrite Hk; case: (ltgtP 0 k) => [k_gt0|k_gt0|<-].
  - by rewrite vec_anglevZ // vec_anglevv // sin0.
  - by rewrite vec_anglevZN // sin_vec_anglevN vec_anglevv // sin0.
  by rewrite scale0r vec_angle0 sin0.
rewrite -norm_cos_eq1 -cos0 => /eqP.
have [c_le0|c_gt0 Hc] := ler0P (cos (vec_angle u v)).
  rewrite -cos_vec_anglevN // -colinearvN => Hc.
  rewrite (vec_angle0_inv uD0 vND0).
    by rewrite colinearZv colinearvv orbT.
  apply: cos_inj => //; rewrite in_itv /= ?(lexx, pi_ge0) //.
  by apply: vec_angle_bound.
rewrite (vec_angle0_inv uD0 vD0).
  by rewrite colinearZv colinearvv orbT.
apply: cos_inj => //; rewrite in_itv /= ?(lexx, pi_ge0) //.
by apply: vec_angle_bound.
Qed.

Lemma sin_vec_angle_iff (u v : 'rV[T]_3) (u0 : u != 0) (v0 : v != 0) :
  0 <= sin (vec_angle u v) ?= iff (colinear u v).
Proof. split; [exact: sin_vec_angle_ge0|by rewrite colinear_sin]. Qed.

Lemma invariant_colinear (u : 'rV[T]_3) (M : 'M[T]_3) :
  u != 0 -> u *m M = u -> forall v, colinear u v -> v *m M = v.
Proof.
move=> u0 uMu v /colinearP[/eqP->|[v0 [k Hk]]]; first by rewrite mul0mx.
move: uMu; rewrite Hk -scalemxAl => /eqP.
rewrite -subr_eq0 -scalerBr scaler_eq0 => /orP [/eqP k0|].
  by move: u0; rewrite Hk k0 scale0r eq_refl.
by rewrite subr_eq0 => /eqP.
Qed.

End colinear1.

Section axial_normal_decomposition.

Variable T : realType.
Let vector := 'rV[T]_3.
Implicit Types u v e : vector.

Definition axialcomp v e := normalize e *d v *: normalize e.

Lemma axialcomp0v e : axialcomp 0 e = 0.
Proof. by rewrite /axialcomp dotmulv0 scale0r. Qed.

Lemma axialcompv0 v : axialcomp v 0 = 0.
Proof. by rewrite /axialcomp /normalize norm0 invr0 ?(scale0r,dotmul0v). Qed.

Lemma axialcompE v e : axialcomp v e = (norm e) ^- 2 *: (v *m e^T *m e).
Proof.
have [/eqP ->|?] := boolP (e == 0); first by rewrite axialcompv0 mulmx0 scaler0.
rewrite /axialcomp dotmulZv scalerA mulrAC dotmulP mul_scalar_mx dotmulC.
by rewrite -invrM ?unitfE ?norm_eq0 // -expr2 scalerA.
Qed.

Lemma axialcompvN v e : axialcomp v (- e) = axialcomp v e.
Proof. by rewrite /axialcomp normalizeN dotmulNv scalerN scaleNr opprK. Qed.

Lemma axialcompNv v e : axialcomp (- v) e = - axialcomp v e.
Proof. by rewrite /axialcomp dotmulvN scaleNr. Qed.

Lemma axialcompZ k e : axialcomp (k *: e) e = k *: e.
Proof.
rewrite /axialcomp dotmulvZ dotmulC dotmul_normalize_norm.
have [/eqP u0|u0] := boolP (e == 0); first by rewrite u0 normalize0 2!scaler0.
by rewrite scalerA -mulrA divrr ?unitfE ?norm_eq0 // mulr1.
Qed.

Lemma axialcomp_dotmul v e : e *d v = 0 -> axialcomp v e = 0.
Proof.
move=> H; by rewrite axialcompE dotmulP dotmulC H mul_scalar_mx scale0r scaler0.
Qed.

Lemma crossmul_axialcomp v e : e *v axialcomp v e = 0.
Proof.
by apply/eqP; rewrite /axialcomp linearZ /= linearZr_LR /= liexx 2!scaler0.
Qed.

(* NB: not used *)
Lemma colinear_axialcomp v e : colinear e (axialcomp v e).
Proof. by rewrite /colinear crossmul_axialcomp. Qed.

Lemma axialcomp_crossmul v e : axialcomp (e *v v) e == 0.
Proof.
rewrite /axialcomp -dotmul_crossmul2 /normalize !linearZl_LR /= linearZr_LR /=.
by rewrite liexx linear0l 2!scaler0.
Qed.

Lemma norm_axialcomp v e : e *d v < 0 ->
  norm (axialcomp v e) = - (normalize e *d v).
Proof.
move=> H.
have ? : e != 0 by apply: contraTN H => /eqP ->; rewrite dotmul0v ltxx.
rewrite /axialcomp scalerA normZ ltr0_norm; last first.
  rewrite pmulr_llt0 ?invr_gt0 ?norm_gt0 //.
  by rewrite /normalize dotmulZv pmulr_rlt0 // invr_gt0 norm_gt0.
by rewrite mulNr -(mulrA _ _ (norm e)) mulVr ?mulr1 ?unitfE ?norm_eq0.
Qed.

Lemma axialcomp_mulO Q p e : Q \is 'O[T]_3 -> e *m Q = e ->
  axialcomp (p *m Q) e = axialcomp p e.
Proof.
move=> HQ uQu.
rewrite !axialcompE; congr (_ *: _).
rewrite -!mulmxA; congr (_ *m _).
rewrite !mulmxA; congr (_ *m _).
by rewrite -{1}uQu trmx_mul mulmxA orthogonal_mul_tr // mul1mx.
Qed.

Lemma vec_angle_axialcomp v e : 0 < e *d v ->
  vec_angle v (axialcomp v e) = vec_angle v e.
Proof.
move=> H.
have ? : e != 0 by apply: contraTN H => /eqP ->; rewrite dotmul0v ltxx.
rewrite /axialcomp scalerA vec_anglevZ // divr_gt0 // ?norm_gt0 //.
by rewrite /normalize dotmulZv mulr_gt0 // invr_gt0 norm_gt0.
Qed.

Definition normalcomp v e := v - axialcomp v e.

Lemma axialnormalcomp v e : v = axialcomp v e + normalcomp v e.
Proof. by rewrite /axialcomp /normalcomp addrC subrK. Qed.

Lemma normalcompE v e : normalcomp v e = v *m (1 - norm e ^-2 *: (e^T *m e)).
Proof.
by rewrite /normalcomp axialcompE -mulmxA scalemxAr -{1}(mulmx1 v) -mulmxBr.
Qed.

Lemma normalcomp0v e : normalcomp 0 e = 0.
Proof. by rewrite /normalcomp axialcomp0v subrr. Qed.

Lemma normalcompv0 v : normalcomp v 0 = v.
Proof. by rewrite /normalcomp axialcompv0 subr0. Qed.

Lemma normalcompvN v e : normalcomp v (- e) = normalcomp v e.
Proof. by rewrite /normalcomp axialcompvN. Qed.

Lemma normalcompNv v e : normalcomp (- v) e = - normalcomp v e.
Proof. by rewrite /normalcomp opprB axialcompNv opprK addrC. Qed.

Lemma normalcompZ k e : normalcomp (k *: e) e = 0.
Proof. by rewrite /normalcomp axialcompZ subrr. Qed.

Lemma normalcompB v1 v2 : normalcomp (v1 - v2) v2 = normalcomp v1 v2.
Proof.
apply/esym/eqP.
rewrite /normalcomp subr_eq -addrA -scaleNr -scalerDl -dotmulvN -dotmulDr.
rewrite opprB -(addrA v1) (addrCA v1) subrK dotmulC dotmul_normalize_norm.
by rewrite norm_scale_normalize addrC addrK.
Qed.

Lemma normalcomp_colinear_helper v e : normalcomp v e = 0 -> colinear v e.
Proof.
move/eqP; rewrite subr_eq0 => /eqP ->.
by rewrite !colinearZv ?colinear_refl 2!orbT.
Qed.

Lemma normalcomp_colinear v e (e0 : e != 0) :
  (normalcomp v e == 0) = colinear v e.
Proof.
apply/idP/idP => [/eqP|/colinearP]; first exact: normalcomp_colinear_helper.
case; first by rewrite (negbTE e0).
case=> _ [k ->]; by rewrite normalcompZ.
Qed.

Lemma crossmul_normalcomp v e : e *v normalcomp v e = e *v v.
Proof.
by rewrite /normalcomp linearD /= linearNr /= crossmul_axialcomp subr0.
Qed.

Lemma dotmul_normalcomp v e : normalcomp v e *d e = 0.
Proof.
case/boolP : (e == 0) => [/eqP ->|?]; first by rewrite dotmulv0.
rewrite /normalcomp dotmulBl !dotmulZv dotmulvv (exprD _ 1 1) expr1.
rewrite (mulrA (_^-1)) mulVr ?unitfE ?norm_eq0 // mul1r mulrAC.
by rewrite mulVr ?unitfE ?norm_eq0 // mul1r dotmulC subrr.
Qed.

Lemma axialnormal v e : axialcomp v e *d normalcomp v e = 0.
Proof.
by rewrite /axialcomp !dotmulZv (dotmulC _ (normalcomp v e))
  dotmul_normalcomp // !mulr0.
Qed.

Lemma ortho_normalcomp v e : (v *d e == 0) = (normalcomp v e == v).
Proof.
apply/idP/idP => [/eqP uv0|/eqP <-].
  by rewrite /normalcomp axialcomp_dotmul ?subr0 // dotmulC.
by rewrite dotmul_normalcomp.
Qed.

Lemma normalcomp_mulO e p Q : Q \is 'O[T]_3 -> e *m Q = e ->
  normalcomp (p *m Q) e = normalcomp p e *m Q.
Proof.
move=> QO uQu.
rewrite 2!normalcompE -!mulmxA; congr (_ *m _).
rewrite mulmxBr mulmx1 mulmxBl mul1mx; congr (_ - _).
rewrite -scalemxAr -scalemxAl; congr (_ *: _).
by rewrite -{1}uQu trmx_mul !mulmxA orthogonal_mul_tr // mul1mx -mulmxA uQu.
Qed.

Lemma normalcomp_mul_tr e (e1 : norm e = 1) : normalcomp 'e_0 e *m e^T == 0.
Proof.
rewrite /normalcomp mulmxBl -scalemxAl -scalemxAl dotmul1 // dotmulC /dotmul.
by rewrite e1 invr1 scalemx1 scalemx1 normalizeI // {1}dotmulP subrr.
Qed.

Definition orthogonalize v e := normalcomp v (normalize e).

Lemma dotmul_orthogonalize v e : e *d orthogonalize v e = 0.
Proof.
rewrite /normalcomp /normalize dotmulBr !(dotmulZv, dotmulvZ).
rewrite mulrACA -invfM -expr2 dotmulvv mulrCA.
have [->|u_neq0] := eqVneq e 0; first by rewrite norm0 invr0 dotmul0v !mul0r subrr.
rewrite norm_normalize // expr1n invr1 mul1r.
rewrite (mulrC _ (e *d _)).
rewrite -mulrA (mulrA (_^-1)) -expr2 -exprMn mulVr ?expr1n ?mulr1 ?subrr //.
by rewrite unitfE norm_eq0.
Qed.

End axial_normal_decomposition.

Section law_of_sines.

Variable T : comRingType.
Let point := 'rV[T]_3.
Let vector := 'rV[T]_3.
Implicit Types a b c : point.
Implicit Types v : vector.

Definition tricolinear a b c := colinear (b - a) (c - a).

Lemma tricolinear_rot a b c : tricolinear a b c = tricolinear b c a.
Proof.
rewrite /tricolinear /colinear !linearD /= !linearDl /= !(linearNl,linearNr) /=.
by rewrite !opprK !liexx !addr0 -addrA addrC (lieC a c) opprK (lieC b c).
Qed.

Lemma tricolinear_perm a b c : tricolinear a b c = tricolinear b a c.
Proof.
rewrite /tricolinear /colinear !linearD /= !linearDl /= !(linearNl,linearNr) /=.
rewrite !(opprK,liexx,addr0) -{1}oppr0 -eqr_oppLR 2!opprB addrC (lieC a b).
by rewrite opprK.
Qed.

End law_of_sines.

Section law_of_sines1.

Variable T : realType.
Let point := 'rV[T]_3.
Let vector := 'rV[T]_3.
Implicit Types a b c : point.
Implicit Types v : vector.

Lemma cos0sin1 [R : realType] [x : R] : cos x = 0 -> `|sin x| = 1.
Proof. by move/eqP; rewrite -norm_sin_eq1 => /eqP. Qed.

Lemma triangle_sin_vector_helper v1 v2 : ~~ colinear v1 v2 ->
  norm v1 ^+ 2 * sin (vec_angle v1 v2) ^+ 2 = norm (normalcomp v1 v2) ^+ 2.
Proof.
move=> H.
have v10 : v1 != 0 by apply: contra H => /eqP ->; rewrite colinear0.
have v20 : v2 != 0 by apply: contra H => /eqP ->; rewrite colinear_sym colinear0.
rewrite /normalcomp [in RHS]normB.
case/boolP : (0 < v2 *d v1) => [v2v1|].
  rewrite normZ gtr0_norm; last first.
    by rewrite dotmulZv mulr_gt0 // invr_gt0 norm_gt0.
  rewrite norm_normalize // mulr1 vec_angle_axialcomp //.
  rewrite dotmul_cos norm_normalize // mul1r vec_angleZv; last first.
    by rewrite invr_gt0 norm_gt0.
  rewrite [in RHS]mulrA (vec_angleC v1) -expr2 -mulrA -expr2 exprMn.
  by rewrite mulr2n opprD addrA subrK sin2cos2 mulrBr mulr1.
rewrite -leNgt le_eqVlt => /orP[|v2v1].
  rewrite {1}dotmul_cos -mulrA mulf_eq0 norm_eq0 (negbTE v20) /=.
  rewrite mulf_eq0 norm_eq0 (negbTE v10) /= => /eqP Hcos.
  rewrite axialcomp_dotmul; last by rewrite dotmul_cos Hcos mulr0.
  rewrite norm0 mulr0 mul0r expr0n mul0rn addr0 subr0.
  by rewrite -(sqr_normr (sin _)) vec_angleC cos0sin1 ?expr1n ?mulr1.
rewrite vec_anglevZN //; last first.
  by rewrite /normalize dotmulZv pmulr_rlt0 // invr_gt0 norm_gt0.
rewrite cos_vec_anglevN // ?normalize_eq0 //.
rewrite norm_axialcomp // !(mulrN,mulNr,opprK,sqrrN).
rewrite vec_anglevZ // ?invr_gt0 ?norm_gt0 //.
rewrite dotmul_cos norm_normalize // mul1r vec_angleZv ?invr_gt0 ?norm_gt0 //.
rewrite (vec_angleC v2) mulrA -expr2 exprMn addrAC -addrA -mulrA -mulrnAr.
rewrite -mulrBr -{2}(mulr1 (norm v1 ^+ 2)) -mulrDr; congr (_ * _).
by rewrite sin2cos2 -expr2 mulr2n opprD !addrA addrK.
Qed.

Lemma triangle_sin_vector v1 v2 : ~~ colinear v1 v2 ->
  sin (vec_angle v1 v2) = norm (normalcomp v1 v2) / norm v1.
Proof.
move=> H.
have v10 : v1 != 0 by apply: contra H => /eqP ->; rewrite colinear0.
have v20 : v2 != 0 by apply: contra H => /eqP ->; rewrite colinear_sym colinear0.
apply/eqP.
rewrite -(@eqr_expn2 _ 2) // ?divr_ge0 // ?norm_ge0 // ?sin_vec_angle_ge0 //.
rewrite exprMn -triangle_sin_vector_helper // mulrAC exprVn divrr ?mul1r //.
by rewrite unitfE sqrf_eq0 norm_eq0.
Qed.

Lemma triangle_sin_point (p1 p2 p : 'rV[T]_3) : ~~ tricolinear p1 p2 p ->
  let v1 := p1 - p in let v2 := p2 - p in
  sin (vec_angle v1 v2) = norm (normalcomp v1 v2) / norm v1.
Proof.
move=> H v1 v2; apply triangle_sin_vector; apply: contra H.
by rewrite tricolinear_perm 2!tricolinear_rot /tricolinear /v1 /v2 colinear_sym.
Qed.

Lemma law_of_sines_vector v1 v2 : ~~ colinear v1 v2 ->
  sin (vec_angle v1 v2) / norm (v2 - v1) = sin (vec_angle (v2 - v1) v2) / norm v1.
Proof.
move=> H.
move: (triangle_sin_vector H) => /= H1.
rewrite [in LHS]H1.
have H' : ~~ colinear v2 (v2 - v1).
  rewrite colinear_sym; apply: contra H => H.
  move: (colinear_refl v2); rewrite -colinearNv => /(colinearD H).
  by rewrite addrAC subrr add0r colinearNv.
have H2 : sin (vec_angle v2 (v2 - v1)) = norm (normalcomp (v2 - v1) v2) / norm (v2 - v1).
  rewrite vec_angleC; apply triangle_sin_vector; by rewrite colinear_sym.
rewrite [in RHS]vec_angleC [in RHS]H2.
by rewrite -normalcompB mulrAC -(opprB v2) normalcompNv normN.
Qed.

Lemma law_of_sines_point (p1 p2 p : 'rV[T]_3) : ~~ tricolinear p1 p2 p ->
  let v1 := p1 - p in let v2 := p2 - p in
  sin (vec_angle v1 v2) / norm (p2 - p1) =
  sin (vec_angle (p2 - p1) (p2 - p)) / norm (p1 - p).
Proof.
move=> H v1 v2.
rewrite (_ : p2 - p1 = v2 - v1); last by rewrite /v1 /v2 opprB addrA subrK.
apply law_of_sines_vector.
apply: contra H.
by rewrite tricolinear_perm 2!tricolinear_rot /tricolinear /v1 /v2 colinear_sym.
Qed.

End law_of_sines1.

Module Line.
Section line_def.
(* could be zmodType but then the coercion line_pred does not satisfy the
   uniform inheritance condition *)
Variable T : comRingType.
Record t := mk {
  point : 'rV[T]_3 ;
  vector :> 'rV[T]_3
}.
Definition point2 (l : t) := point l + vector l.
Lemma vectorE l : vector l = point2 l - point l.
Proof. by rewrite /point2 addrAC subrr add0r. Qed.
End line_def.
End Line.

Notation "'\pt(' l ')'" := (Line.point l).
Notation "'\pt2(' l ')'" := (Line.point2 l).
Notation "'\vec(' l ')'" := (Line.vector l).

Coercion line_pred (T : comRingType) (l : Line.t T) : pred 'rV[T]_3 :=
  [pred p | (p == \pt( l )) ||
    (\vec( l ) != 0) && colinear \vec( l ) (p - \pt( l ))].

Lemma line_point_in (T : comRingType) (l : Line.t T) : \pt(l) \in (l : pred _).
Proof. by case: l => p v /=; rewrite inE /= eqxx. Qed.

Section line.

Variable T : fieldType.
Let point := 'rV[T]_3.
Let vector := 'rV[T]_3.
Implicit Types l : Line.t T.

Lemma lineP p l :
  reflect (exists k', p = \pt( l ) + k' *: \vec( l)) (p \in (l : pred _)).
Proof.
apply (iffP idP) => [|[k' ->]].
  rewrite inE.
  case/orP => [/eqP pl|]; first by exists 0; rewrite scale0r addr0.
  case/andP => l0 /colinearP[|[pl [k Hk]]].
    rewrite subr_eq0 => /eqP ->; exists 0; by rewrite scale0r addr0.
  have k0 : k != 0.
    by apply/negP => /eqP k0; move: l0; rewrite Hk k0 scale0r eq_refl.
  exists k^-1.
  by rewrite Hk scalerA mulVr ?unitfE // scale1r addrCA subrr addr0.
rewrite inE.
case/boolP : (\vec( l ) == 0) => [/eqP ->|l0 /=].
  by rewrite scaler0 addr0 eqxx.
by rewrite addrAC subrr add0r colinearvZ colinear_refl 2!orbT.
Qed.

Lemma mem_add_line l (p : point) (v : vector) : \vec( l ) != 0 ->
  colinear v \vec( l ) -> p + v \in (l : pred _) = (p \in (l : pred _)).
Proof.
move=> l0 vl.
apply/lineP/idP => [[] x /eqP|pl].
  rewrite eq_sym -subr_eq => /eqP <-.
  rewrite inE l0 /=; apply/orP; right.
  rewrite -!addrA addrC !addrA subrK colinear_sym.
  by rewrite colinearD // ?colinearZv ?colinear_refl ?orbT // colinearNv.
case/colinearP : vl => [|[_ [k ->]]]; first by rewrite (negPf l0).
case/lineP : pl => k' ->.
exists (k' + k); by rewrite -addrA -scalerDl.
Qed.

End line.

Definition parallel (T : comRingType) : rel (Line.t T) :=
  [rel l1 l2 | colinear \vec( l1 ) \vec( l2 )].

Definition perpendicular (T : comRingType) : rel (Line.t T) :=
  [rel l1 l2 | \vec( l1 ) *d \vec( l2 ) == 0].

Definition coplanar (T : comRingType) (p1 p2 p3 p4 : 'rV[T]_3) : bool :=
  (p1 - p3) *d ((p2 - p1) *v (p4 - p3)) == 0.

Definition skew (T : comRingType) : rel (Line.t T) := [rel l1 l2 |
  ~~ coplanar \pt( l1 ) \pt2( l1 ) \pt( l2 ) \pt2( l2) ].

Lemma skewE (T : comRingType) (l1 l2 : Line.t T) :
  skew l1 l2 = ~~ coplanar \pt( l1 ) \pt2( l1 ) \pt( l2 ) \pt2( l2).
Proof. by []. Qed.

Section line_line_intersection.

Variable T : realFieldType.
Let point := 'rV[T]_3.
Implicit Types l : Line.t T.

Definition intersects : rel (Line.t T) :=
  [rel l1 l2 | ~~ skew l1 l2 && ~~ parallel l1 l2 ].

Definition is_interpoint p l1 l2 :=
  (p \in (l1 : pred _)) && (p \in (l2 : pred _)).

Definition interpoint_param x l1 l2 :=
  let v1 := \vec( l1 ) in let v2 := \vec( l2 ) in
  \det (col_mx3 (\pt( l2 ) - \pt( l1 )) x (v1 *v v2)) / ((v1 *v v2) *d (v1 *v v2)).

Lemma interpoint_param0 l1 l2 v : \pt( l1 ) = \pt( l2 ) ->
  interpoint_param v l1 l2 = 0.
Proof.
move=> p1p2.
by rewrite /interpoint_param p1p2 subrr -crossmul_triple dotmul0v mul0r.
Qed.

Definition interpoint_s l1 l2 := interpoint_param \vec( l1 ) l1 l2.

Definition interpoint_t l1 l2 := interpoint_param \vec( l2 ) l1 l2.

Lemma interparamP l1 l2 : intersects l1 l2 ->
  let v1 := \vec( l1 ) in let v2 := \vec( l2 ) in
  \pt( l1 ) + interpoint_t l1 l2 *: v1 = \pt( l2 ) + interpoint_s l1 l2 *: v2.
Proof.
move=> Hinter v1 v2.
rewrite /interpoint_t /interpoint_s /interpoint_param  -/v1 -/v2.
do 2 rewrite -crossmul_triple (dot_crossmulC (\pt( l2) - \pt( l1 ))).
apply/eqP; set v1v2 := v1 *v v2.
rewrite -subr_eq -addrA eq_sym addrC -subr_eq.
rewrite 2!(mulrC _ _^-1) -2!scalerA -scalerBr.
rewrite dotmulC dot_crossmulC (dotmulC _ v1v2) (dot_crossmulC).
rewrite -double_crossmul.
rewrite (lieC (v1v2 *v _)) /= double_crossmul dotmulC -{2}(opprB _ \pt( l2 )) dotmulNv.
case/andP: Hinter.
rewrite skewE negbK /coplanar -2!Line.vectorE => /eqP -> ?.
rewrite oppr0 scale0r add0r opprK scalerA mulVr ?scale1r //.
by rewrite unitfE dotmulvv0.
Qed.

Lemma intersects_interpoint l1 l2 : intersects l1 l2 ->
  {p | is_interpoint p l1 l2 /\
   p = \pt( l1 ) + interpoint_t l1 l2 *: \vec( l1 ) /\
   p = \pt( l2 ) + interpoint_s l1 l2 *: \vec( l2 )}.
Proof.
move=> Hinter.
case/boolP : (\pt( l1 ) == \pt( l2 )) => [/eqP|]p1p2.
  exists \pt( l1 ); split.
    rewrite /is_interpoint; apply/andP; split; by [
      rewrite inE eqxx !(orTb,orbT) | rewrite inE p1p2 eqxx orTb].
  rewrite /interpoint_t /interpoint_s interpoint_param0 //.
  by rewrite interpoint_param0 // 2!scale0r 2!addr0.
exists (\pt( l1) + interpoint_t l1 l2 *: \vec( l1 )).
split; last first.
  split=> //; exact: interparamP.
rewrite /is_interpoint; apply/andP; split.
  apply/lineP; by exists (interpoint_t l1 l2).
apply/lineP; eexists; exact: interparamP.
Qed.

Lemma interpoint_intersects l1 l2 : {p | is_interpoint p l1 l2} ->
  ~~ skew l1 l2.
Proof.
case=> p; rewrite /is_interpoint => /andP[H1 H2].
rewrite skewE negbK /coplanar -2!Line.vectorE.
case/lineP : (H1) => k1 /eqP; rewrite -subr_eq => /eqP <-.
case/lineP : (H2) => k2 /eqP; rewrite -subr_eq => /eqP <-.
rewrite opprB -addrA addrC addrA subrK dotmulDl !(dotmulNv,dotmulZv).
rewrite dot_crossmulC 2!dotmul_crossmul_shift 2!liexx.
by rewrite !(dotmul0v,dotmulv0,mulr0,oppr0,addr0).
Qed.

Lemma interpointE p l1 l2 : ~~ parallel l1 l2 -> is_interpoint p l1 l2 ->
  let s := interpoint_s l1 l2 in let t := interpoint_t l1 l2 in
  let v1 := \vec( l1 ) in let v2 := \vec( l2 ) in
  \pt( l1 ) + t *: v1 = p /\ \pt( l2 ) + s *: v2 = p.
Proof.
move=> ?.
case/andP => /lineP[t' Hs] /lineP[s' Ht] s t.
move=> v1 v2.
have H (a b va vb : 'rV[T]_3) (k l : T) :
  a + k *: va = b + l *: vb -> k *: (va *v vb) = (b - a) *v vb.
  clear.
  move=> /(congr1 (fun x => x - a)).
  rewrite addrAC subrr add0r addrAC => /(congr1 (fun x => x *v vb)).
  rewrite (linearZl_LR _ vb) /= linearDl /=.
  by rewrite (linearZl_LR _ _ l) /= liexx scaler0 addr0.
have Ht' : t' = interpoint_t l1 l2.
  have : t' *: (v1 *v v2) = (\pt( l2 ) - \pt( l1 )) *v v2.
    by rewrite (H \pt( l1 ) \pt( l2 ) _ _ _ s') // -Hs -Ht.
  move/(congr1 (fun x => x *d (v1 *v v2))).
  rewrite dotmulZv.
  move/(congr1 (fun x => x / ((v1 *v v2) *d (v1 *v v2)))).
  rewrite -mulrA divrr ?mulr1; first by rewrite -dot_crossmulC crossmul_triple.
  by rewrite unitfE dotmulvv0.
have Hs' : s' = interpoint_s l1 l2.
  have : s' *: (v1 *v v2) = (\pt( l2) - \pt( l1 )) *v v1.
    move: (H \pt( l2 ) \pt( l1 ) v2 v1 s' t').
    rewrite -Hs -Ht => /(_ erefl).
    by rewrite (lieC v1 v2) /= scalerN -opprB => ->; rewrite linearNl opprK.
  move/(congr1 (fun x => x *d (v1 *v v2))).
  rewrite dotmulZv.
  move/(congr1 (fun x => x / ((v1 *v v2) *d (v1 *v v2)))).
  rewrite -mulrA divrr ?mulr1; first by rewrite -dot_crossmulC crossmul_triple.
  by rewrite unitfE dotmulvv0.
by rewrite /t /s -Ht' -Hs'.
Qed.

Lemma interpoint_unique p q l1 l2 : ~~ parallel l1 l2 ->
  is_interpoint p l1 l2 -> is_interpoint q l1 l2 -> p = q.
Proof.
by move=> l1l2 /interpointE => /(_ l1l2) [<- _] /interpointE => /(_ l1l2) [<- _].
Qed.

Definition intersection l1 l2 : option point :=
  if ~~ intersects l1 l2 then None
  else Some (\pt( l1 ) + interpoint_t l1 l2 *: \vec( l1 )).

End line_line_intersection.

Section distance_line.

Variable T : rcfType.
Let point := 'rV[T]_3.

Definition distance_point_line (p : point) l : T :=
  norm ((p - \pt( l )) *v \vec( l )) / norm \vec( l ).

Definition distance_between_lines (l1 l2 : Line.t T) : T :=
  if intersects l1 l2 then
    0
  else if parallel l1 l2 then
    distance_point_line \pt( l1 ) l2
  else (* skew lines *)
    let n := \vec( l1 ) *v \vec( l2 ) in
    `| (\pt( l2 ) - \pt( l1 )) *d n | / norm n.

End distance_line.


Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.Fol.Syntax.
Require Import Logic.Fol.Functor.

Require Import Logic.Func.Permute.
Require Import Logic.Func.Replace.
Require Import Logic.Func.Composition.

Require Import Logic.List.In.
Require Import Logic.List.Replace.
Require Import Logic.List.Coincide.

(* We do not have sets: the variables of a formula are a list, not a set.       *)

Fixpoint var (v:Type) (p:P v) : list v :=
    match p with
    | Bot       => nil
    | Elem x y  => cons x (cons y nil)
    | Imp p1 p2 => var v p1 ++ var v p2
    | All x p1  => cons x (var v p1)
    end.

Arguments var {v} _.

Lemma var_fmap : forall (v w:Type) (f:v -> w) (p:P v),
    var (fmap f p) = map f (var p).
Proof.
    intros v w f.
    induction p as [|x y|p1 IH1 p2 IH2|x p1 IH1]; simpl.
    - reflexivity.
    - reflexivity.
    - rewrite map_app, IH1, IH2. reflexivity.
    - rewrite IH1. reflexivity.
Qed.

(* If two functions f g coincide on the variables of a formula p, then the      *)
(* formulas fmap f t and fmap g t are equal, and conversely.                    *)
Lemma var_support : forall (v w:Type) (f g:v -> w) (p:P v),
    coincide (var p) f g  <-> fmap f p = fmap g p.
Proof.
    intros v w f g. unfold coincide.
    induction p as [|x y|p1 [IH1 IH1'] p2 [IH2 IH2']|x p1 [IH1 IH1']];
    simpl; split.
    - intros. reflexivity.
    - intros. exfalso. assumption.
    - intros H. rewrite (H x), (H y).
        + reflexivity.
        + right. left. reflexivity.
        + left. reflexivity.
    - intros H. inversion H. intros z [H'|[H'|H']].
        + subst. assumption.
        + subst. assumption.
        + exfalso. assumption.
    - intros H. rewrite IH1, IH2.
        + reflexivity.
        + intros x H'. apply H. apply in_or_app. right. assumption.
        + intros x H'. apply H. apply in_or_app. left.  assumption.
    - intros H. inversion H. intros x H'. apply in_app_or in H'.
      destruct H' as [H'|H'].
        + apply IH1'; assumption.
        + apply IH2'; assumption.
    - intros H. rewrite IH1.
        + rewrite (H x). { reflexivity. } { left. reflexivity. }
        + intros y H'.  apply H. right. assumption.
    - intros H. inversion H. intros y [H'|H'].
        + subst. assumption.
        + apply IH1'; assumption.
Qed.

Lemma var_replace_permute : forall (v:Type) (e:Eq v) (x y:v) (p:P v),
    ~ y :: var p -> fmap (y // x) p = fmap (y <:> x) p.
Proof.
    intros v e x y t H. apply var_support, replace_permute. assumption.
Qed.

Lemma var_replace_trans : forall (v:Type) (e:Eq v) (x y z:v) (t:P v),
    ~ y :: var t ->
    fmap (z // y) (fmap (y // x) t) = fmap (z // x) t.
Proof.
    intros v e x y z t H.
    remember (z // y) as g eqn:Eg.
    remember (y // x) as f eqn:Ef.
    fold ((fmap g ; fmap f) t). rewrite <- fmap_comp.
    apply var_support.
    rewrite Eg, Ef. apply replace_trans.
    assumption.
Qed.

Lemma var_replace_remove : forall (v:Type) (e:Eq v) (x y:v) (p:P v),
    x <> y -> ~ x :: var (fmap (y // x) p).
Proof.
    intros v e x y p E H. rewrite var_fmap in H.
    apply in_map_iff in H. destruct H as [u [H1 H2]].
    destruct (eqDec u x) as [H'|H'].
    - subst. rewrite replace_x in H1. apply E. symmetry. assumption.
    - rewrite replace_not_x in H1.
        + apply H'. assumption.
        + assumption.
Qed.