(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg finalg poly polydiv cyclic.
From mathcomp Require Import perm matrix mxpoly.
Require Import ssr_ext ssralg_ext cyclic_code dft.

(******************************************************************************)
(*        Error-locator, error-evaluator, and syndrome polynomials            *)
(*                                                                            *)
(* Definitions:                                                               *)
(*   \sigma_(a , e )  == error locator polynomial for the vector e            *)
(*   \sigma_(a, e, i) == the ith punctured locator polynomial for             *)
(*   t.-rV[R]_ n      == error vector with support of cardinal <= t           *)
(*   \omega_(f, a, e) == error evaluator polynomial                           *)
(*   syndromep        == syndrome polynomial                                  *)
(*                                                                            *)
(* Lemmas:                                                                    *)
(*   coprime_errloc_erreval == the error locator and evaluator polynomials    *)
(*                             are coprime                                    *)
(*   erreval_vecE == characterization of an error vector in terms of the      *)
(*                   error and the evaluator polynomials                      *)
(******************************************************************************)

Reserved Notation "'\sigma_(' a , e )" (at level 3).
Reserved Notation "'\sigma_(' a , e , i )" (at level 3).
Reserved Notation "t '.-'rV[' R ]_ n" (at level 2).
Reserved Notation "'\omega_(' f , a , e )" (at level 3).

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

Import GRing.Theory.
Local Open Scope ring_scope.

(* TODO: move to poly_ext? *)
Lemma modp_Xn (R : idomainType) j (p : {poly R}) i :
  i <= j -> size (p %% 'X^j) <= i -> p %% 'X^i = p %% 'X^j.
Proof.
move=> ij H0.
have H : forall n, lead_coef 'X^n \is a GRing.unit
  by move=> ??; rewrite lead_coefXn GRing.unitr1.
rewrite (Pdiv.IdomainUnit.divp_eq (H R j) p).
rewrite (Pdiv.IdomainUnit.modpD (H R i)).
rewrite modp_eq0; last by rewrite dvdp_mull // dvdp_exp2l.
by rewrite add0r -(Pdiv.IdomainUnit.divp_eq (H R j) p) modp_small // size_polyXn.
Qed.

(* TODO: useful? *)
Lemma size_one_minus_X (R : idomainType) (a : R) (a0 : a != 0) :
  size (1 - a *: 'X) = 2%N.
Proof.
rewrite addrC size_addl.
  by rewrite size_opp size_scale ?size_polyX // expf_neq0.
by rewrite size_opp size_scale ?expf_neq0 // size_polyX size_polyC oner_eq0.
Qed.

Lemma one_minus_X_neq0 (R : idomainType) (a : R) : 1 - a *: 'X != 0.
Proof.
rewrite subr_eq0; apply/eqP => /(congr1 (fun x => x.[0])).
rewrite !hornerE; apply/eqP; by rewrite oner_eq0.
Qed.

(* NB: not used *)
Section error_locator_polynomial_alt.

Variables (F : fieldType) (n : nat) (a : {ffun 'I_n -> F}).

Definition errloc_alt (E : {set 'I_n}) : {poly F} :=
  \prod_(i in E) ('X - (a i)%:P).

End error_locator_polynomial_alt.

Local Open Scope vec_ext_scope.

Section distinct_non_zero.

Variables (F : fieldType) (n : nat).

Definition distinct_non_zero (a : 'rV[F]_n) :=
  injective [ffun i => a ``_i] /\ (forall i, a ``_ i != 0).

Lemma distinct_non_zero_rVexp (a : F) (a0 : a != 0) (H : not_uroot_on a n) :
  distinct_non_zero (rVexp a n).
Proof.
rewrite /distinct_non_zero; split; first by apply rVexp_inj.
move=> ?; by rewrite mxE expf_neq0.
Qed.

End distinct_non_zero.

Section error_locator_polynomial.

Variables (F : fieldType) (n : nat).

Definition errloc (a : 'rV[F]_n) (E : {set 'I_n}) : {poly F} :=
  \prod_(i in E) (1 - a ``_ i *: 'X).

Lemma errloc0 (a : 'rV[F]_n) : errloc a set0 = 1.
Proof. by rewrite /errloc big_set0. Qed.

Lemma horner_errloc_0 (a : 'rV[F]_n) E : (errloc a E).[0] = 1.
Proof.
rewrite /errloc horner_prod (eq_bigr (fun=> 1)) ?big1_eq //.
by move=> /= j _; rewrite !hornerE subr0.
Qed.

Lemma derive_errloc (a : 'rV[F]_n) E : (errloc a E)^`() =
  \sum_(j in E) - a ``_ j *: \prod_(k in E :\ j) (1 - a ``_ k *: 'X).
Proof.
move Hm : (#| E |) => m.
elim: m E Hm => [E /eqP| m IH E Em].
  rewrite cards_eq0 => /eqP ->; by rewrite /errloc 2!big_set0 derivC.
have [/= f Hf] : exists f, f \in E by apply/set0Pn; rewrite -cards_eq0 Em.
rewrite /errloc (big_setD1 f) //= derivM IH; last first.
  move: (cardsD1 f E); rewrite Hf /= add1n Em; by case.
rewrite derivB derivC sub0r linearZ /= derivX.
rewrite [in RHS](big_setD1 f) //=; congr (_ + _).
  by rewrite alg_polyC -mul_polyC polyCN.
rewrite big_distrr /=; apply eq_bigr => i Hi.
rewrite mulrC -!mul_polyC -mulrA; congr (_ * _).
rewrite [in RHS](big_setD1 f) //=; last first.
  rewrite in_setD1; by move: Hi; rewrite in_setD1 eq_sym => /andP [] ->.
rewrite mulrC mul_polyC; congr (_ * _).
apply eq_bigl => ?; rewrite !in_setD1; bool_congr.
Qed.

Lemma decomp_errloc (a :'rV[F]_n) E : (forall i, a ``_ i != 0) ->
  errloc a E = (\prod_(i in E) (- a ``_ i)%:P) * \prod_(i in E) ('X - (a ``_ i)^-1%:P).
Proof.
move=> a0.
rewrite /errloc (eq_bigr (fun i : 'I_n => (- a ``_ i)%:P * ('X - (a ``_ i)^-1%:P))).
  by rewrite big_split.
move=> i iE.
rewrite -polyCN mulrDr -polyCM mulrNN divff //.
by rewrite polyC1 -(addrC 1) polyCN mulNr mul_polyC.
Qed.

Lemma errloc_neq0 a E : errloc a E != 0.
Proof. apply/prodf_neq0 => /= i _; by rewrite one_minus_X_neq0. Qed.

Lemma size_errloc a E : size (errloc a E) <= #| E |.+1.
Proof.
apply: (leq_trans (size_prod_leq (fun x => x \in E) (fun i => 1 - a ``_ i *: 'X))).
apply (@leq_trans (#|E|.*2.+1 - #|E|)); last first.
  by rewrite subSn -addnn ?leq_addr // addnK.
rewrite leq_sub // ltnS.
apply (@leq_trans (\sum_(i in E) 2)); last by rewrite big_const iter_addn_0 mul2n.
apply leq_sum => /= i iE.
case/boolP : (a ``_ i == 0) => [/eqP ->|ai0].
  by rewrite scale0r subr0 size_poly1.
by rewrite size_one_minus_X.
Qed.

Lemma errloc_zero (a : 'rV[F]_n) E (i : 'I_n) : distinct_non_zero a ->
  ((errloc a E).[(a ``_ i)^-1] == 0) = (i \in E).
Proof.
move=> Ha; apply/idP/idP => H.
- apply/negPn/negP => abs; move/eqP: H.
  apply/rootP.
  rewrite (decomp_errloc _ (proj2 Ha)) ?unitfE //= rootM negb_or.
  apply/andP; split.
    rewrite -(@big_morph _ _ _ _ _ 1 _ (@polyCM F)) // rootC prodf_seq_neq0 /=.
    apply/allP => n0 _.
    apply/implyP => _; by rewrite oppr_eq0 (proj2 Ha).
  move: (root_prod_XsubC [seq (a ``_ x)^-1 | x : 'I_n <- enum E] (a ``_ i)^-1).
  rewrite big_map -[in X in _ -> X]big_filter => ->.
  apply: contra abs.
  case/mapP => /= j Hj /invr_inj aij.
  move: (proj1 Ha) => /(_ i j); rewrite 2!ffunE => /(_ aij) ->.
  by rewrite -mem_enum.
- rewrite /errloc horner_prod prodf_seq_eq0.
  apply/hasP; exists i => //.
  rewrite H /= !hornerE divff ?(proj2 Ha) ?subrr // expf_neq0.
Qed.

Lemma size_errloc_eq a E : distinct_non_zero a -> size (errloc a E) = #| E |.+1.
Proof.
move=> Ha.
rewrite /errloc.
rewrite (eq_bigr (fun i : 'I_n => (- a ``_ i *: ('X - (a ``_ i)^-1%:P)))); last first.
  move=> i iE.
  rewrite scalerDr addrC !scaleNr scalerN opprK; congr (_ + _).
  rewrite -mul_polyC -!alg_polyC mulr_algl scalerA.
  rewrite divrr // ?alg_polyC // unitfE.
  by case: Ha => _; apply.
rewrite scaler_prod size_scale; last first.
  apply/prodf_neq0 => i iE; by rewrite oppr_eq0 (proj2 Ha).
rewrite (_ : \prod_(i in E) ('X - (a ``_ i)^-1%:P) =
  \prod_(i <- enum E) ('X - (a ``_ i)^-1%:P)); last by rewrite big_filter.
by rewrite size_prod_XsubC cardE.
Qed.

End error_locator_polynomial.

Notation "'\sigma_(' a , e )" := (errloc a (supp e)).
Notation "'\sigma_(' a , e , i )" := (errloc a (supp e :\ i)).

Lemma errloc_puncture (F : fieldType) n (f : 'rV[F]_n) (y : 'rV[F]_n) i :
  i \in supp y -> \sigma_(f, y) = (1 - f ``_ i *: 'X ) * \sigma_(f, y, i).
Proof.
move=> ?; rewrite {1}/errloc (bigD1 i) //=; congr (_ * _).
by apply eq_bigl => j; rewrite in_setD1 andbC.
Qed.

Record errvec n (F : fieldType) t := Errvec {
  errvect :> 'rV[F]_n ;
  errsupp : #| supp errvect | <= t }.

Notation "t '.-'rV[' R ]_ n" := (@errvec n R t) (only parsing).

Lemma supp_neq0 n (F : fieldType) t (e : t.-'rV[F]_n) : supp e != set0 -> t != O.
Proof.
apply: contra => /eqP t0; case: e => /= e; by rewrite t0 leqn0 -cards_eq0.
Qed.

Section error_evaluator_polynomial_def.

Variables (F : fieldType) (n : nat).

Definition erreval (b a : 'rV[F]_n) e :=
  \sum_(i in supp e) e ``_ i * b ``_ i *: \sigma_(a, e, i).

End error_evaluator_polynomial_def.

Notation "'\omega_(' f , a , e )" := (erreval f a e).

Section error_evaluator_polynomial_prop.

Variables (F : fieldType) (n : nat) (a : 'rV[F]_n).
Variables (t : nat) (e : t.-'rV[F]_n).
Variables (f : 'rV[F]_n).

Lemma size_erreval : size \omega_(f, a, e) <= t.
Proof.
eapply leq_trans; first by apply size_sum.
apply/bigmax_leqP => i; rewrite inE => /= iE.
eapply leq_trans; first by rewrite -mul_polyC; apply size_mul_leq.
rewrite size_polyC.
apply (@leq_trans (1 + size \sigma_( a, e, i)).-1).
  rewrite add1n /= addnC; case: (_ != _) => //=.
  by rewrite addn1.
  by rewrite addn0 leq_pred.
rewrite add1n /= (leq_trans (size_errloc _ _)) //.
rewrite (_ : #|_| = #|supp e|.-1); last by rewrite (cardsD1 i (supp e)) inE /= iE.
rewrite -insupp in iE.
rewrite prednK // ?(errsupp e) // lt0n cards_eq0; by apply/set0Pn; exists i.
Qed.

Hypothesis Ha : distinct_non_zero a.
Hypothesis Hf : forall i, f ``_ i != 0.

Lemma coprime_errloc_erreval E : coprimep \sigma_(a, E) \omega_(f, a, E).
Proof.
apply/coprimepP => p p_sigma p_eta.
suff no_root_p : forall x, root p x -> False.
  move : p_sigma; rewrite (decomp_errloc _ (proj2 Ha)) //.
  move/(dvdp_mull (\prod_(i in supp E) (- a ``_ i)^-1%:P)).
  rewrite mulrA -big_split /= (eq_bigr (fun=> 1%:P)); last first.
    move=> i _; by rewrite -polyCM mulVr // unitrN unitfE (proj2 Ha).
  rewrite big1 // mul1r -big_filter; case/dvdp_prod_XsubC => bs.
  set mask_bs := mask bs _.
  case size_bsE : (size mask_bs).
    move: size_bsE => /size0nil ->; by rewrite big_nil.
  have : 0 < size mask_bs by rewrite size_bsE.
  rewrite -has_predT => /hasP [/= i i_mask_bs] _ => p_prod.
  suff : root (\prod_(j <- mask_bs) ('X - (a ``_ j)^-1%:P)) (a ``_ i)^-1.
    rewrite -(eqp_root p_prod); by move/no_root_p.
  rewrite (@big_morph _ _ (fun p => root p (a ``_ i)^-1) false orb); last 2 first.
    move=> ? ?; by rewrite rootM.
    by apply/negP/negP/root1.
  rewrite big_has /=; apply/hasP; exists i => //; by rewrite root_XsubC.
move=> x px.
have [n0 [n0e xan0]] : exists n0, n0 \in supp E /\ x = (a ``_ n0)^-1.
  have : root \sigma_(a, E) x.
    rewrite -dvdp_XsubCl; apply: dvdp_trans p_sigma; by rewrite dvdp_XsubCl.
  rewrite /root (decomp_errloc _ (proj2 Ha)) hornerM mulf_eq0; case/orP.
  - rewrite horner_prod; case/prodf_eq0 => n0 n0e.
    by rewrite !hornerE oppr_eq0 (negPf (proj2 Ha n0)).
  - rewrite horner_prod; case/prodf_eq0 => n0 n0e.
    rewrite !hornerE subr_eq0 => /eqP ->; by exists n0.
rewrite {x}xan0 in px.
have {px} : root \omega_(f, a, E) (a ``_ n0)^-1.
  rewrite -dvdp_XsubCl; apply: dvdp_trans p_eta; by rewrite dvdp_XsubCl.
rewrite /root horner_sum (bigD1 _ n0e) /=.
set q := (X in _ + X == 0 -> _).
have {q}-> : q = 0.
  rewrite {}/q (eq_bigr (fun=> 0)); first by rewrite big_const /= iter_addr0.
  move=> i /andP[ie in0].
  rewrite !hornerE /= horner_prod (bigD1 n0) /=; last first.
    by rewrite in_setD1 n0e eq_sym andbT.
  by rewrite !hornerE /= divrr ?unitfE ?(proj2 Ha) // subrr mulr0 mul0r.
rewrite addr0 !hornerE /= mulf_eq0; case/orP.
- rewrite mulf_eq0 (negbTE (Hf _)) orbF.
  by move: n0e; rewrite inE /= => /negbTE ->.
- by rewrite errloc_zero // in_setD1 eqxx.
Qed.

Lemma erreval0 : \omega_(f, a, (0 : 'rV_n)) = 0.
Proof. by rewrite /erreval supp0 big_set0. Qed.

End error_evaluator_polynomial_prop.

Section characterization_of_error_vector.

Variables (F : fieldType) (n : nat) (e : 'rV[F]_n).
Variable a : 'rV[F]_n.
Hypothesis Ha : distinct_non_zero a.
Variable f : 'rV[F]_n.

Lemma erreval_vecE i : i \in supp e ->
  e ``_ i * f ``_ i = - a ``_ i *
    \omega_(f, a, e).[(a ``_ i)^-1] / \sigma_(a, e)^`().[(a ``_ i)^-1].
Proof.
move=> iE.
have morph_horner_add : {morph (fun x => x.[(a ``_ i)^-1]) : x y / x + y >-> x + y}.
  move=> x y; exact: hornerD.
have morph_horner_mul : {morph (fun x => x.[(a ``_ i)^-1]) : x y / x * y >-> x * y}.
  move=> x y; exact: hornerM.
have -> : \omega_(f, a, e).[(a ``_ i)^-1] =
    e ``_ i * f ``_ i * \prod_(j in supp e :\ i) (1 - a ``_ j * (a ``_ i)^-1).
  rewrite (@big_morph _ _ _ 0 _ _ _ morph_horner_add); last by rewrite horner0.
  rewrite [in LHS](big_setD1 i) //= [X in _ + X = _](_ :_  = 0); last first.
    rewrite (eq_bigr (fun=> 0)); first by rewrite big_const iter_addr0.
    move=> j Hj.
    rewrite !hornerE /= (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
    rewrite (big_setD1 i) /=; last first.
      rewrite !inE eq_sym in Hj.
      rewrite !inE.
      case/andP : Hj => /= ->.
      by rewrite insupp in iE.
    by rewrite !hornerE /= divrr ?unitfE ?(proj2 Ha) // ?Ht' // subrr mulr0 mul0r.
  rewrite addr0 !hornerE /=; congr (_ * _).
  rewrite (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
  apply eq_bigr => ? ?; by rewrite !hornerE.
have -> : (\sigma_(a, e)^`()).[(a ``_ i)^-1] = - a ``_ i *
  \prod_(j in supp e :\ i) (1 - a ``_ j * (a ``_ i)^-1).
  rewrite derive_errloc (@big_morph _ _ _ 0 _ _ _ morph_horner_add); last by rewrite horner0.
  rewrite [in LHS](big_setD1 i) //= [X in _ + X = _](_ :_  = 0); last first.
    rewrite (eq_bigr (fun=> 0)); first by rewrite big_const iter_addr0.
    move=> j Hj.
    rewrite !hornerE /= (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
    rewrite (big_setD1 i) /=; last first.
      rewrite !inE; move: Hj.
      rewrite !inE eq_sym => /andP[-> /=].
      by rewrite insupp in iE.
    by rewrite !hornerE /= divrr ?unitfE ?(proj2 Ha) // ?Ht' // subrr mulr0 mul0r.
  rewrite addr0 !hornerE /=; congr (_ * _).
  rewrite (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
  apply eq_bigr => ? ?; by rewrite !hornerE.
rewrite mulrCA mulrK // unitrM unitrN unitfE (proj2 Ha) /=.
apply big_ind.
- by rewrite unitr1.
- by move=> x y; rewrite unitrM => -> ->.
- move=> j Hj; rewrite GRing.unitfE.
  suff : a ``_ j / a ``_ i != 1.
    by apply: contra => /eqP /(congr1 (fun x => x + a ``_ j / a ``_ i)); rewrite subrK add0r => <-.
  apply/eqP => /(congr1 (fun x => x * a ``_ i)).
  rewrite -mulrA mulVr ?unitfE ?(proj2 Ha) ?expf_neq0 // mulr1 mul1r.
  move: (proj1 Ha) => /(_ j i); rewrite 2!ffunE => aij.
  move/aij => ij; subst j.
  move: Hj; by rewrite in_setD1 eqxx.
Qed.

End characterization_of_error_vector.

Local Open Scope dft_scope.

Section syndrome_polynomial.

Variables (F : fieldType) (n' : nat).
Let n := n'.+1.
Implicit Types u : 'rV[F]_n.

(* polynomial of degree <= t.-1 *)
Definition syndromep u y t := \poly_(k < t) y ^`_(u, inord k.+1).

Variable u :'rV[F]_n.
Variable t : nat.

Lemma syndromepE y : syndromep u y t =
  \sum_(j in supp y) \sum_(i < t) (y ``_ j * u ``_ (inord i.+1) ^+ j) *: 'X^i.
Proof.
rewrite /syndromep exchange_big /= poly_def; apply/eq_bigr => i _; rewrite /fdcoor horner_poly.
rewrite (bigID (fun i => i \in supp y)) /= -[RHS]addr0 scalerDl; congr (_ + _).
  rewrite scaler_suml; apply/eq_bigr => j Hj.
  rewrite insubT // => H; congr ((y ord0 _ * _) *: _); by apply val_inj.
apply/eqP; rewrite scaler_eq0 (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 ?eqxx //.
move=> j Hj; rewrite insubT // => H; rewrite (_ : Sub _ _ = j); last by apply/val_inj.
move: Hj; rewrite inE negbK => /eqP ->; by rewrite mul0r.
Qed.

Lemma size_syndromep y : size (syndromep u y t) <= t.
Proof.
rewrite /syndromep poly_def (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP => i _.
case/boolP : (fdcoor u y (inord i.+1) == 0) => [/eqP -> | ?].
- by rewrite scale0r size_poly0.
- by rewrite size_scale // size_polyXn.
Qed.

Lemma syndromepD x y : syndromep u (x + y) t = syndromep u x t + syndromep u y t.
Proof.
rewrite /syndromep !poly_def -big_split /=; apply/eq_bigr => i _.
by rewrite fdcoorD scalerDl.
Qed.

Lemma syndromepN x : syndromep u (- x) t = - syndromep u x t.
Proof.
rewrite /syndromep !poly_def -[RHS]mulN1r big_distrr; apply eq_bigr => /= i _.
by rewrite fdcoorN mulN1r scaleNr.
Qed.

Lemma syndromepB x y : syndromep u (x - y) t = syndromep u x t - syndromep u y t.
Proof. by rewrite syndromepD syndromepN. Qed.

Lemma syndromep0 : syndromep u 0 t = 0.
Proof. by rewrite -[in LHS](subrr 0) syndromepB subrr. Qed.

End syndrome_polynomial.

Section twisted_error_pattern.

Variables (F : fieldType) (a : F) (n : nat).

(* twisted error pattern; see [McEliece 2002] p. 243 (def 9.36), p. 259 *)
Definition twisted (y : 'rV[F]_n) := \row_(i < n) (y ``_ i * a ^+ i).

Hypothesis a_neq0 : a != 0.

Lemma supp_twisted y : supp (twisted y) = supp y.
Proof.
apply/setP => i; by rewrite inE mxE mulf_eq0 negb_or expf_neq0 // andbT inE.
Qed.

End twisted_error_pattern.

Section syndromep_prop.

Variables (F : fieldType) (n' : nat).
Let n := n'.+1.
Variable a : F.
Hypothesis a_neq0 : a != 0.
Variable (y : 'rV[F]_n).
Variable (t : nat).
Hypothesis tn : t < n.

Lemma dft_syndromep (v : 'rV[F]_n) :
  rVpoly (dft (rVexp a n) t (twisted a v)) = syndromep (rVexp a n) v t.
Proof.
case/boolP : (a == 0) => [/eqP -> | a0].
  apply/polyP => i.
  rewrite !coef_poly.
  case: ifPn => // it.
  rewrite insubT !mxE.
  rewrite /fdcoor !horner_poly.
  apply eq_bigr => j _.
  rewrite insubT // => jt.
  rewrite !mxE (_ : Sub _ _ = j); last by apply val_inj.
  rewrite (_ : Sub _ _ = Ordinal it) //=.
  rewrite inordK //; last by rewrite (leq_trans it) // ltnW.
  rewrite inordK; last by rewrite ltnS // (leq_trans it).
  rewrite !expr0n.
  set x := (i == _).
  case/boolP : (x) => //= Hx; first by rewrite expr1n mulr1.
  rewrite expr0n.
  set z := (_ == _).
  case/boolP : (z) => //= Hz; by [rewrite !mulr1 | rewrite !mulr0].
rewrite dftE /syndromep /fdcoor.
transitivity (\sum_(i in supp v) (\sum_(j < t) (twisted a v) ``_ i * (rVexp a n) ``_ (inord j) ^+ i *: 'X^j)).
  rewrite supp_twisted //.
  apply eq_bigr => /= i _.
  rewrite scaler_sumr; apply eq_bigr => j _.
  by rewrite scalerA.
rewrite exchange_big /= poly_def; apply eq_bigr => /= i _.
rewrite horner_poly scaler_suml.
transitivity (\sum_(i0 in 'I_n) ((twisted a v) ``_ i0 * (rVexp a n) ``_ (inord i) ^+ i0) *: 'X^i).
  apply/esym.
  rewrite (bigID (fun i => (twisted a v) ``_ i != 0)) /=.
  rewrite [X in _ + X = _](eq_bigr (fun => 0)); last first.
    move=> j.
    rewrite negbK => /eqP ->; by rewrite mul0r scale0r.
  rewrite big_const iter_addr0 addr0.
  apply eq_bigl => j; by rewrite mxE inE mulf_eq0 negb_or expf_neq0 // andbT.
apply eq_bigr => /= j _.
rewrite insubT // => jn.
rewrite (_ : Sub _ _ = j); last by apply val_inj.
rewrite !mxE inordK; last by rewrite (leq_trans (ltn_ord i)) // ltnW.
rewrite inordK //; last by rewrite ltnS // (leq_trans (ltn_ord i)).
by rewrite -exprM mulnC exprM -mulrA -exprS -exprM mulnC exprM.
Qed.

End syndromep_prop.

Lemma syndromep_t0 (F : fieldType) n (a : 'rV[F]_n.+1) e : syndromep a e 0 = 0.
Proof. by rewrite /syndromep poly_def big_ord0. Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e383m31_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
   + intros. reflexivity.
   + destruct n2.
   * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
   * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
   + intros. destruct n. reflexivity. reflexivity.
   + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

(* It's possible this can be proven without a helper lemma but I couldn't figure it out. *)
Theorem theorem0 : forall (w : natural) (x : natural) (y : natural) (z : lst), eq (drop (Succ w) (drop x (Cons y z))) (drop w (drop x z)).
Proof.
intros. lfind. Admitted.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Export RelationPairs SetoidList Orders.

Set Implicit Arguments.
Unset Strict Implicit.

(** * Specialization of results about lists modulo. *)

Module OrderedTypeLists (Import O:OrderedType).

Section ForNotations.

Notation In:=(InA eq).
Notation Inf:=(lelistA lt).
Notation Sort:=(sort lt).
Notation NoDup:=(NoDupA eq).

Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
Proof. intros. rewrite <- H; auto. Qed.

Lemma ListIn_In : forall l x, List.In x l -> In x l.
Proof. exact (In_InA eq_equiv). Qed.

Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
Proof. exact (InfA_ltA lt_strorder). Qed.

Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed.

Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed.

Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l.
Proof. exact (@In_InfA t lt). Qed.

Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l.
Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed.

Lemma Inf_alt :
 forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)).
Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed.

Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed.

End ForNotations.

Hint Resolve ListIn_In Sort_NoDup Inf_lt.
Hint Immediate In_eq Inf_lt.

End OrderedTypeLists.

(** * Results about keys and data as manipulated in FMaps. *)

Module KeyOrderedType(Import O:OrderedType).
 Module Import MO:=OrderedTypeLists(O).

 Section Elt.
 Variable elt : Type.
 Notation key:=t.

  Local Open Scope signature_scope.

  Definition eqk : relation (key*elt) := eq @@1.
  Definition eqke : relation (key*elt) := eq * Logic.eq.
  Definition ltk : relation (key*elt) := lt @@1.

  Hint Unfold eqk eqke ltk.

  (* eqke is stricter than eqk *)

  Global Instance eqke_eqk : subrelation eqke eqk.
  Proof. firstorder. Qed.

  (* eqk, eqke are equalities, ltk is a strict order *)

  Global Instance eqk_equiv : Equivalence eqk := _.

  Global Instance eqke_equiv : Equivalence eqke := _.

  Global Instance ltk_strorder : StrictOrder ltk := _.

  Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
  Proof. unfold eqk, ltk; auto with *. Qed.

  (* Additionnal facts *)

  Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt).
  Proof. apply pair_compat. Qed.

  Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
  Proof.
  intros e e' LT EQ; rewrite EQ in LT.
  elim (StrictOrder_Irreflexive _ LT).
  Qed.

  Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
  Proof.
  intros e e' LT EQ; rewrite EQ in LT.
  elim (StrictOrder_Irreflexive _ LT).
  Qed.

  Lemma InA_eqke_eqk :
     forall x m, InA eqke x m -> InA eqk x m.
  Proof.
    unfold eqke, RelProd; induction 1; firstorder.
  Qed.
  Hint Resolve InA_eqke_eqk.

  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
  Definition In k m := exists e:elt, MapsTo k e m.
  Notation Sort := (sort ltk).
  Notation Inf := (lelistA ltk).

  Hint Unfold MapsTo In.

  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)

  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
  Proof.
  firstorder.
  exists x; auto.
  induction H.
  destruct y; compute in H.
  exists e; left; auto.
  destruct IHInA as [e H0].
  exists e; auto.
  Qed.

  Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l.
  Proof.
  unfold In, MapsTo.
  setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
  firstorder.
  exists (snd x), x; auto.
  Qed.

  Lemma In_nil : forall k, In k nil <-> False.
  Proof.
  intros; rewrite In_alt2; apply Exists_nil.
  Qed.

  Lemma In_cons : forall k p l,
   In k (p::l) <-> eq k (fst p) \/ In k l.
  Proof.
  intros; rewrite !In_alt2, Exists_cons; intuition.
  Qed.

  Global Instance MapsTo_compat :
   Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
  Proof.
  intros x x' Hx e e' He l l' Hl. unfold MapsTo.
  rewrite Hx, He, Hl; intuition.
  Qed.

  Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
  Proof.
  intros x x' Hx l l' Hl. rewrite !In_alt.
  setoid_rewrite Hl. setoid_rewrite Hx. intuition.
  Qed.

  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
  Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.

  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
  Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.

  Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
  Proof. intros l x x' H. rewrite H; auto. Qed.

  Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
  Proof. apply InfA_ltA; auto with *. Qed.

  Hint Immediate Inf_eq.
  Hint Resolve Inf_lt.

  Lemma Sort_Inf_In :
      forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
  Proof. apply SortA_InfA_InA; auto with *. Qed.

  Lemma Sort_Inf_NotIn :
      forall l k e, Sort l -> Inf (k,e) l ->  ~In k l.
  Proof.
    intros; red; intros.
    destruct H1 as [e' H2].
    elim (@ltk_not_eqk (k,e) (k,e')).
    eapply Sort_Inf_In; eauto.
    repeat red; reflexivity.
  Qed.

  Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l.
  Proof. apply SortA_NoDupA; auto with *. Qed.

  Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
  Proof.
   intros; invlist sort; eapply Sort_Inf_In; eauto.
  Qed.

  Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
      ltk e e' \/ eqk e e'.
  Proof.
    intros; invlist InA; auto with relations.
    left; apply Sort_In_cons_1 with l; auto with relations.
  Qed.

  Lemma Sort_In_cons_3 :
    forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
  Proof.
    intros; invlist sort; red; intros.
    eapply Sort_Inf_NotIn; eauto using In_eq.
  Qed.

  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
  Proof.
    intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
    right; exists x; auto.
  Qed.

  Lemma In_inv_2 : forall k k' e e' l,
      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
  Proof.
   intros; invlist InA; intuition.
  Qed.

  Lemma In_inv_3 : forall x x' l,
      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
  Proof.
   intros; invlist InA; compute in * |- ; intuition.
  Qed.

 End Elt.

 Hint Unfold eqk eqke ltk.
 Hint Extern 2 (eqke ?a ?b) => split.
 Hint Resolve ltk_not_eqk ltk_not_eqke.
 Hint Resolve InA_eqke_eqk.
 Hint Unfold MapsTo In.
 Hint Immediate Inf_eq.
 Hint Resolve Inf_lt.
 Hint Resolve Sort_Inf_NotIn.
 Hint Resolve In_inv_2 In_inv_3.

End KeyOrderedType.


(**************************)
(**************************)
(****                  ****)
(****   Substitution   ****)
(****                  ****)
(**************************)
(**************************)

Require Import Coq.Lists.List.
Require Import Main.SystemF.FreeVar.
Require Import Main.SystemF.LocalClosure.
Require Import Main.SystemF.Name.
Require Import Main.SystemF.Syntax.
Require Import Main.Tactics.

Fixpoint eeSub e1 x1 e2 :=
  match e1 with
  | eFreeVar x2 => if nameEq x1 x2 then e2 else e1
  | eBoundVar _ => e1
  | eAbs t e3 => eAbs t (eeSub e3 x1 e2)
  | eApp e3 e4 => eApp (eeSub e3 x1 e2) (eeSub e4 x1 e2)
  | eTAbs e3 => eTAbs (eeSub e3 x1 e2)
  | eTApp e3 t => eTApp (eeSub e3 x1 e2) t
  end.

Fixpoint ttSub t1 x1 t2 :=
  match t1 with
  | tFreeVar x2 => if nameEq x1 x2 then t2 else t1
  | tBoundVar _ => t1
  | tArrow t3 t4 => tArrow (ttSub t3 x1 t2) (ttSub t4 x1 t2)
  | tForAll t3 => tForAll (ttSub t3 x1 t2)
  end.

Fixpoint etSub e1 x1 t1 :=
  match e1 with
  | eFreeVar _ => e1
  | eBoundVar _ => e1
  | eAbs t2 e2 => eAbs (ttSub t2 x1 t1) (etSub e2 x1 t1)
  | eApp e2 e3 => eApp (etSub e2 x1 t1) (etSub e3 x1 t1)
  | eTAbs e2 => eTAbs (etSub e2 x1 t1)
  | eTApp e2 t2 => eTApp (etSub e2 x1 t1) (ttSub t2 x1 t1)
  end.

(******************************************************************)
(* Substituting a non-free variable of a term/type has no effect. *)
(******************************************************************)

Theorem tttSubBound :
  forall t1 t2 x,
  ~ In x (tFreeVars t1) ->
  ttSub t1 x t2 = t1.
Proof.
  induction t1; search.
Qed.

#[export] Hint Resolve tttSubBound : main.

Theorem eeeSubBound :
  forall e1 e2 x,
  ~ In x (eeFreeVars e1) ->
  eeSub e1 x e2 = e1.
Proof.
  induction e1; search.
Qed.

#[export] Hint Resolve eeeSubBound : main.

Theorem eetSubBound :
  forall e t x,
  ~ In x (etFreeVars e) ->
  etSub e x t = e.
Proof.
  induction e; search; clean; f_equal; search; apply tttSubBound; search.
Qed.

#[export] Hint Resolve eetSubBound : main.

(*****************************************)
(* Substitution preserves local closure. *)
(*****************************************)

Theorem ttSubLocallyClosed :
  forall i t1 t2 x,
  tLocallyClosed t1 i ->
  tLocallyClosed t2 i ->
  tLocallyClosed (ttSub t1 x t2) i.
Proof.
  clean. outro i. induction t1; search; clean; invert H; search.
  constructor. apply IHt1; search.
  apply tLocalClosureMonotonic with (i1 := i); search.
Qed.

#[export] Hint Resolve ttSubLocallyClosed : main.

Theorem eeSubLocallyClosed :
  forall e1 e2 ie it x,
  eLocallyClosed e1 ie it ->
  eLocallyClosed e2 ie it ->
  eLocallyClosed (eeSub e1 x e2) ie it.
Proof.
  clean. outro ie it. induction e1; search; clean; invert H; search;
    constructor; search; apply IHe1; search;
    apply eLocalClosureMonotonic with (ie1 := ie) (it1 := it); search.
Qed.

#[export] Hint Resolve eeSubLocallyClosed : main.

Theorem etSubLocallyClosed :
  forall e ie it t x,
  eLocallyClosed e ie it ->
  tLocallyClosed t it ->
  eLocallyClosed (etSub e x t) ie it.
Proof.
  clean. outro ie it. induction e; search; clean; invert H; search.
  constructor. apply IHe; search.
  apply tLocalClosureMonotonic with (i1 := it); search.
Qed.

#[export] Hint Resolve etSubLocallyClosed : main.

(************************************)
(* Free variables of a substitution *)
(************************************)

#[local] Theorem inclAppRemoveWeakeningLeft :
  forall x l1 l2 l3,
  incl (l1 ++ remove nameEq x l2) (l1 ++ remove nameEq x (l2 ++ l3)).
Proof.
  unfold incl. clean.
  pose proof (in_app_or l1 (remove nameEq x l2) a H).
  destruct H0; search.
  apply in_or_app. right.
  induction l2; search.
Qed.

#[local] Hint Resolve inclAppRemoveWeakeningLeft : main.

#[local] Theorem inclAppRemoveWeakeningRight :
  forall x l1 l2 l3,
  incl (l1 ++ remove nameEq x l3) (l1 ++ remove nameEq x (l2 ++ l3)).
Proof.
  unfold incl. clean.
  pose proof (in_app_or l1 (remove nameEq x l3) a H).
  destruct H0; search.
  apply in_or_app. right.
  induction l2; search.
Qed.

#[local] Hint Resolve inclAppRemoveWeakeningRight : main.

Theorem tttFreeSub :
  forall t1 t2 x,
  incl
    (tFreeVars (ttSub t1 x t2))
    (tFreeVars t2 ++ remove nameEq x (tFreeVars t1)).
Proof.
  clean. induction t1; search. clean. apply incl_app.
  - apply incl_tran with (
      m := tFreeVars t2 ++ remove nameEq x (tFreeVars t1_1)
    ); search.
  - apply incl_tran with (
      m := tFreeVars t2 ++ remove nameEq x (tFreeVars t1_2)
    ); search.
Qed.

#[export] Hint Resolve tttFreeSub : main.

Theorem eeeeFreeSub :
  forall e1 e2 x,
  incl
    (eeFreeVars (eeSub e1 x e2))
    (eeFreeVars e2 ++ remove nameEq x (eeFreeVars e1)).
Proof.
  clean. induction e1; search. clean. apply incl_app.
  - apply incl_tran with (
      m := eeFreeVars e2 ++ remove nameEq x (eeFreeVars e1_1)
    ); search.
  - apply incl_tran with (
      m := eeFreeVars e2 ++ remove nameEq x (eeFreeVars e1_2)
    ); search.
Qed.

#[export] Hint Resolve eeeeFreeSub : main.

Theorem eeetFreeSub :
  forall e t x,
  incl (eeFreeVars (etSub e x t)) (eeFreeVars e).
Proof.
  clean. induction e; search.
Qed.

#[export] Hint Resolve eeetFreeSub : main.

Theorem eteeFreeSub :
  forall e1 e2 x,
  incl (etFreeVars (eeSub e1 x e2)) (etFreeVars e2 ++ etFreeVars e1).
Proof.
  clean. induction e1; search; clean; apply incl_app.
  - apply incl_tran with (m := etFreeVars e2 ++ tFreeVars t); search.
  - apply incl_tran with (m := etFreeVars e2 ++ etFreeVars e1); search.
  - apply incl_tran with (m := etFreeVars e2 ++ etFreeVars e1_1); search.
  - apply incl_tran with (m := etFreeVars e2 ++ etFreeVars e1_2); search.
  - apply incl_tran with (m := etFreeVars e2 ++ etFreeVars e1); search.
  - apply incl_tran with (m := etFreeVars e1 ++ tFreeVars t); search.
Qed.

#[export] Hint Resolve eteeFreeSub : main.

Theorem etetFreeSub :
  forall e t x,
  incl
    (etFreeVars (etSub e x t))
    (tFreeVars t ++ remove nameEq x (etFreeVars e)).
Proof.
  clean. induction e; search; clean; apply incl_app.
  - apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (tFreeVars t0)
    ); search.
  - apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (etFreeVars e)
    ); search.
  - apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (etFreeVars e1)
    ); search.
  - apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (etFreeVars e2)
    ); search.
  - apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (etFreeVars e)
    ); search.
  - apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (tFreeVars t0)
    ); search.
Qed.

#[export] Hint Resolve etetFreeSub : main.


Require Import Basics.
Require Import Cubical.DPath.
Require Import Cubical.PathSquare.
Require Import Cubical.DPathSquare.
Require Import Cubical.PathCube.

Declare Scope dcube_scope.
Delimit Scope dcube_scope with dcube.

(* In this file we define a dependent cube *)

(* Dependent cubes *)
Definition DPathCube {A} (B : A -> Type)
  {x000 x010 x100 x110 x001 x011 x101 x111 : A}
  {p0i0 : x000 = x010} {p1i0 : x100 = x110}
  {pi00 : x000 = x100} {pi10 : x010 = x110}
  {p0i1 : x001 = x011} {p1i1 : x101 = x111}
  {pi01 : x001 = x101} {pi11 : x011 = x111}
  {p00i : x000 = x001} {p01i : x010 = x011}
  {p10i : x100 = x101} {p11i : x110 = x111}
  {s0ii : PathSquare p0i0 p0i1 p00i p01i}
  {s1ii : PathSquare p1i0 p1i1 p10i p11i}
  {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
  {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
  {si0i : PathSquare p00i p10i pi00 pi01}
  {si1i : PathSquare p01i p11i pi10 pi11}
  (cube : PathCube s0ii s1ii sii0 sii1 si0i si1i)
  {b000 : B x000} {b010 : B x010} {b100 : B x100} {b110 : B x110}
  {b001 : B x001} {b011 : B x011} {b101 : B x101} {b111 : B x111 }
  {bp0i0 : DPath B p0i0 b000 b010} {bp1i0 : DPath B p1i0 b100 b110}
  {bpi00 : DPath B pi00 b000 b100} {bpi10 : DPath B pi10 b010 b110}
  {bp0i1 : DPath B p0i1 b001 b011} {bp1i1 : DPath B p1i1 b101 b111}
  {bpi01 : DPath B pi01 b001 b101} {bpi11 : DPath B pi11 b011 b111}
  {bp00i : DPath B p00i b000 b001} {bp01i : DPath B p01i b010 b011}
  {bp10i : DPath B p10i b100 b101} {bp11i : DPath B p11i b110 b111}
  (bs0ii : DPathSquare B s0ii bp0i0 bp0i1 bp00i bp01i)
  (bs1ii : DPathSquare B s1ii bp1i0 bp1i1 bp10i bp11i)
  (bsii0 : DPathSquare B sii0 bp0i0 bp1i0 bpi00 bpi10)
  (bsii1 : DPathSquare B sii1 bp0i1 bp1i1 bpi01 bpi11)
  (bsi0i : DPathSquare B si0i bp00i bp10i bpi00 bpi01)
  (bsi1i : DPathSquare B si1i bp01i bp11i bpi10 bpi11) : Type.
Proof.
  destruct cube.
  exact (PathCube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i).
Defined.

Section DPathCubeConst.

  Definition dc_const' {A B : Type}
    {x000 x010 x100 x110 x001 x011 x101 x111 : A}
    {p0i0 : x000 = x010} {p1i0 : x100 = x110}
    {pi00 : x000 = x100} {pi10 : x010 = x110}
    {p0i1 : x001 = x011} {p1i1 : x101 = x111}
    {pi01 : x001 = x101} {pi11 : x011 = x111}
    {p00i : x000 = x001} {p01i : x010 = x011}
    {p10i : x100 = x101} {p11i : x110 = x111}
    {s0ii : PathSquare p0i0 p0i1 p00i p01i}
    {s1ii : PathSquare p1i0 p1i1 p10i p11i}
    {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
    {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
    {si0i : PathSquare p00i p10i pi00 pi01}
    {si1i : PathSquare p01i p11i pi10 pi11}
    {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i}
    {b000 b010 b100 b110 b001 b011 b101 b111 : B}
    {bp0i0 : DPath (fun _ => B) p0i0 b000 b010}
    {bp1i0 : DPath (fun _ => B) p1i0 b100 b110}
    {bpi00 : DPath (fun _ => B) pi00 b000 b100}
    {bpi10 : DPath (fun _ => B) pi10 b010 b110}
    {bp0i1 : DPath (fun _ => B) p0i1 b001 b011}
    {bp1i1 : DPath (fun _ => B) p1i1 b101 b111}
    {bpi01 : DPath (fun _ => B) pi01 b001 b101}
    {bpi11 : DPath (fun _ => B) pi11 b011 b111}
    {bp00i : DPath (fun _ => B) p00i b000 b001}
    {bp01i : DPath (fun _ => B) p01i b010 b011}
    {bp10i : DPath (fun _ => B) p10i b100 b101}
    {bp11i : DPath (fun _ => B) p11i b110 b111}
    {bs0ii : DPathSquare (fun _ => B) s0ii bp0i0 bp0i1 bp00i bp01i}
    {bs1ii : DPathSquare (fun _ => B) s1ii bp1i0 bp1i1 bp10i bp11i}
    {bsii0 : DPathSquare (fun _ => B) sii0 bp0i0 bp1i0 bpi00 bpi10}
    {bsii1 : DPathSquare (fun _ => B) sii1 bp0i1 bp1i1 bpi01 bpi11}
    {bsi0i : DPathSquare (fun _ => B) si0i bp00i bp10i bpi00 bpi01}
    {bsi1i : DPathSquare (fun _ => B) si1i bp01i bp11i bpi10 bpi11}
    : PathCube
      (ds_const'^-1 bs0ii) (ds_const'^-1 bs1ii) (ds_const'^-1 bsii0)
      (ds_const'^-1 bsii1) (ds_const'^-1 bsi0i) (ds_const'^-1 bsi1i)
    -> DPathCube (fun _ => B) cube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i.
  Proof.
    by destruct cube.
  Defined.

  Global Instance isequiv_dc_const' {A B : Type}
    {x000 x010 x100 x110 x001 x011 x101 x111 : A}
    {p0i0 : x000 = x010} {p1i0 : x100 = x110}
    {pi00 : x000 = x100} {pi10 : x010 = x110}
    {p0i1 : x001 = x011} {p1i1 : x101 = x111}
    {pi01 : x001 = x101} {pi11 : x011 = x111}
    {p00i : x000 = x001} {p01i : x010 = x011}
    {p10i : x100 = x101} {p11i : x110 = x111}
    {s0ii : PathSquare p0i0 p0i1 p00i p01i}
    {s1ii : PathSquare p1i0 p1i1 p10i p11i}
    {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
    {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
    {si0i : PathSquare p00i p10i pi00 pi01}
    {si1i : PathSquare p01i p11i pi10 pi11}
    {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i}
    {b000 b010 b100 b110 b001 b011 b101 b111 : B}
    {bp0i0 : DPath (fun _ => B) p0i0 b000 b010}
    {bp1i0 : DPath (fun _ => B) p1i0 b100 b110}
    {bpi00 : DPath (fun _ => B) pi00 b000 b100}
    {bpi10 : DPath (fun _ => B) pi10 b010 b110}
    {bp0i1 : DPath (fun _ => B) p0i1 b001 b011}
    {bp1i1 : DPath (fun _ => B) p1i1 b101 b111}
    {bpi01 : DPath (fun _ => B) pi01 b001 b101}
    {bpi11 : DPath (fun _ => B) pi11 b011 b111}
    {bp00i : DPath (fun _ => B) p00i b000 b001}
    {bp01i : DPath (fun _ => B) p01i b010 b011}
    {bp10i : DPath (fun _ => B) p10i b100 b101}
    {bp11i : DPath (fun _ => B) p11i b110 b111}
    {bs0ii : DPathSquare (fun _ => B) s0ii bp0i0 bp0i1 bp00i bp01i}
    {bs1ii : DPathSquare (fun _ => B) s1ii bp1i0 bp1i1 bp10i bp11i}
    {bsii0 : DPathSquare (fun _ => B) sii0 bp0i0 bp1i0 bpi00 bpi10}
    {bsii1 : DPathSquare (fun _ => B) sii1 bp0i1 bp1i1 bpi01 bpi11}
    {bsi0i : DPathSquare (fun _ => B) si0i bp00i bp10i bpi00 bpi01}
    {bsi1i : DPathSquare (fun _ => B) si1i bp01i bp11i bpi10 bpi11}
    : IsEquiv (dc_const' (cube:=cube) (bs0ii:=bs0ii) (bs1ii:=bs1ii)
       (bsii0:=bsii0) (bsii1:=bsii1) (bsi0i:=bsi0i) (bsi1i:=bsi1i)).
  Proof.
    destruct cube; exact _.
  Qed.

  Definition dc_const {A B : Type}
    {x000 x010 x100 x110 x001 x011 x101 x111 : A}
    {p0i0 : x000 = x010} {p1i0 : x100 = x110}
    {pi00 : x000 = x100} {pi10 : x010 = x110}
    {p0i1 : x001 = x011} {p1i1 : x101 = x111}
    {pi01 : x001 = x101} {pi11 : x011 = x111}
    {p00i : x000 = x001} {p01i : x010 = x011}
    {p10i : x100 = x101} {p11i : x110 = x111}
    {s0ii : PathSquare p0i0 p0i1 p00i p01i}
    {s1ii : PathSquare p1i0 p1i1 p10i p11i}
    {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
    {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
    {si0i : PathSquare p00i p10i pi00 pi01}
    {si1i : PathSquare p01i p11i pi10 pi11}
    {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i}
    {b000 b010 b100 b110 b001 b011 b101 b111 : B}
    {bp0i0 : b000 = b010} {bp1i0 : b100 = b110}
    {bpi00 : b000 = b100} {bpi10 : b010 = b110}
    {bp0i1 : b001 = b011} {bp1i1 : b101 = b111}
    {bpi01 : b001 = b101} {bpi11 : b011 = b111}
    {bp00i : b000 = b001} {bp01i : b010 = b011}
    {bp10i : b100 = b101} {bp11i : b110 = b111}
    {bs0ii : PathSquare bp0i0 bp0i1 bp00i bp01i}
    {bs1ii : PathSquare bp1i0 bp1i1 bp10i bp11i}
    {bsii0 : PathSquare bp0i0 bp1i0 bpi00 bpi10}
    {bsii1 : PathSquare bp0i1 bp1i1 bpi01 bpi11}
    {bsi0i : PathSquare bp00i bp10i bpi00 bpi01}
    {bsi1i : PathSquare bp01i bp11i bpi10 bpi11}
    : PathCube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i
    -> DPathCube (fun _ => B) cube (ds_const bs0ii) (ds_const bs1ii) (ds_const bsii0)
       (ds_const bsii1) (ds_const bsi0i) (ds_const bsi1i).
  Proof.
    by destruct cube.
  Defined.

  Global Instance isequiv_dc_const {A B : Type}
    {x000 x010 x100 x110 x001 x011 x101 x111 : A}
    {p0i0 : x000 = x010} {p1i0 : x100 = x110}
    {pi00 : x000 = x100} {pi10 : x010 = x110}
    {p0i1 : x001 = x011} {p1i1 : x101 = x111}
    {pi01 : x001 = x101} {pi11 : x011 = x111}
    {p00i : x000 = x001} {p01i : x010 = x011}
    {p10i : x100 = x101} {p11i : x110 = x111}
    {s0ii : PathSquare p0i0 p0i1 p00i p01i}
    {s1ii : PathSquare p1i0 p1i1 p10i p11i}
    {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
    {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
    {si0i : PathSquare p00i p10i pi00 pi01}
    {si1i : PathSquare p01i p11i pi10 pi11}
    {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i}
    {b000 b010 b100 b110 b001 b011 b101 b111 : B}
    {bp0i0 : b000 = b010} {bp1i0 : b100 = b110}
    {bpi00 : b000 = b100} {bpi10 : b010 = b110}
    {bp0i1 : b001 = b011} {bp1i1 : b101 = b111}
    {bpi01 : b001 = b101} {bpi11 : b011 = b111}
    {bp00i : b000 = b001} {bp01i : b010 = b011}
    {bp10i : b100 = b101} {bp11i : b110 = b111}
    {bs0ii : PathSquare bp0i0 bp0i1 bp00i bp01i}
    {bs1ii : PathSquare bp1i0 bp1i1 bp10i bp11i}
    {bsii0 : PathSquare bp0i0 bp1i0 bpi00 bpi10}
    {bsii1 : PathSquare bp0i1 bp1i1 bpi01 bpi11}
    {bsi0i : PathSquare bp00i bp10i bpi00 bpi01}
    {bsi1i : PathSquare bp01i bp11i bpi10 bpi11}
     : IsEquiv (dc_const (cube:=cube) (bs0ii:=bs0ii) (bs1ii:=bs1ii)
       (bsii0:=bsii0) (bsii1:=bsii1) (bsi0i:=bsi0i) (bsi1i:=bsi1i)).
  Proof.
    destruct cube; exact _.
  Defined.

End DPathCubeConst.

(** Dependent Kan fillers *)

Section Kan.
Context {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A}
  {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100}
  {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111}
  {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001}
  {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111}
  {s1ii : PathSquare p1i0 p1i1 p10i p11i} {s0ii : PathSquare p0i0 p0i1 p00i p01i}
  {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
  {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11}
  (c : PathCube s0ii s1ii sii0 sii1 si0i si1i)
  {P : A -> Type} {y000 y010 y100 y110 y001 y011 y101 y111}
  {q0i0 : DPath P p0i0 y000 y010} {q1i0 : DPath P p1i0 y100 y110} {qi00 : DPath P pi00 y000 y100}
  {qi10 : DPath P pi10 y010 y110} {q0i1 : DPath P p0i1 y001 y011} {q1i1 : DPath P p1i1 y101 y111}
  {qi01 : DPath P pi01 y001 y101} {qi11 : DPath P pi11 y011 y111} {q00i : DPath P p00i y000 y001}
  {q01i : DPath P p01i y010 y011} {q10i : DPath P p10i y100 y101} {q11i : DPath P p11i y110 y111}.

Definition dc_fill_left
  (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
  (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
  (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
  : {t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
Proof.
  destruct c.
  apply cu_fill_left.
Defined.

Definition dc_fill_right
  (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i)
  (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
  (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
  : {t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
Proof.
  destruct c.
  apply cu_fill_right.
Defined.

Definition dc_fill_top
  (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
                                                  (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
  (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
  : {tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
Proof.
  destruct c.
  apply cu_fill_top.
Defined.

Definition dc_fill_bottom
  (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
  (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10)
  (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
  : {tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
Proof.
  destruct c.
  apply cu_fill_bottom.
Defined.

Definition dc_fill_front
  (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
  (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
                                                  (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
  : {ti0i : DPathSquare P si0i q00i q10i qi00 qi01 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
Proof.
  destruct c.
  apply cu_fill_front.
Defined.

Definition dc_fill_back
  (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
  (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
  (ti0i : DPathSquare P si0i q00i q10i qi00 qi01)
  : {ti1i : DPathSquare P si1i q01i q11i qi10 qi11 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
Proof.
  destruct c.
  apply cu_fill_back.
Defined.

End Kan.


Require Export Finite_sets Classical_sets Finite_sets_facts Arith Classical Omega Program.

Set Implicit Arguments.

Theorem Intersection_Empty_set_r U (S : Ensemble U) :
  Intersection _ S (Empty_set U) = Empty_set U.
  apply Extensionality_Ensembles.
  intuition.
Qed.

Theorem Intersection_Empty_set_l U (S : Ensemble U) :
  Intersection _ (Empty_set U) S = Empty_set U.
  apply Extensionality_Ensembles.
  intuition.
Qed.

Theorem Union_Empty_set_r U (S : Ensemble U) :
  Union _ S (Empty_set U) = S.
  apply Extensionality_Ensembles.
  intuition.
Qed.

Theorem Union_Empty_set_l U (S : Ensemble U) :
  Union _ (Empty_set U) S = S.
  apply Extensionality_Ensembles.
  intuition.
Qed.

Theorem In_Intersection_In_l U (L R : Ensemble U) x :
  In _ (Intersection _ L R) x -> In _ L x.
  destruct 1.
  trivial.
Qed.

Theorem In_Intersection_In_r U (L R : Ensemble U) x :
  In _ (Intersection _ L R) x -> In _ R x.
  destruct 1.
  trivial.
Qed.

Theorem not_In_Subtract U (L : Ensemble U) x :
  ~ (In _ (Subtract _ L x) x).
  intuition.
  destruct H.
  auto with *.
Qed.

Theorem Inclusion_Exclusion_Principle U (L R : Ensemble U) n l m r :
  cardinal _ (Union _ L R) n ->
    cardinal _ L l -> cardinal _ R r -> cardinal _ (Intersection _ L R) m -> n = l + r - m.
  intros.
  generalize dependent n.
  generalize dependent m.
  generalize dependent r.
  generalize dependent R.
  generalize dependent L.
  induction l;
  intros.
  apply cardinalO_empty in H0.
  simpl in *.
  subst.
  rewrite Intersection_Empty_set_l in H2.
  apply cardinal_Empty in H2.
  subst.
  rewrite Union_Empty_set_l in H.
  replace r with n in *.
  auto with *.
  eapply cardinal_unicity;
  eauto.
  destruct (cardinal_invert _ L (S l)).
  trivial.
  destruct H3.
  destruct H3.
  destruct H4.
  subst.
  destruct (classic (In _ R x0)).
  destruct m.
  apply cardinalO_empty in H2.
  apply Extension in H2.
  unfold Same_set in H2.
  destruct H2.
  unfold Included in *.
  specialize (H2 x0).
  assert(In U (Intersection U (Add U x x0) R) x0).
  constructor.
  right.
  constructor.
  trivial.
  intuition.
  destruct H8.
  assert(cardinal U (Intersection U x R) m).
  pose (card_soustr_1 U (Intersection U (Add U x x0) R) (S m) H2 x0).
  assert (In U (Intersection U (Add U x x0) R) x0).
  constructor.
  auto with *.
  trivial.
  simpl in *.
  intuition.
  replace (Intersection U x R) with (Subtract U (Intersection U (Add U x x0) R) x0).
  trivial.
  apply Extensionality_Ensembles.
  constructor;
  unfold Included;
  intros.
  destruct(classic (x0 = x1)).
  subst.
  apply not_In_Subtract in H8.
  tauto.
  do 3 destruct H8.
  auto with *.
  tauto.
  destruct (classic (x0 = x1)).
  subst.
  apply In_Intersection_In_l in H8.
  tauto.
  constructor.
  constructor.
  constructor.
  eapply In_Intersection_In_l.
  eauto.
  eapply In_Intersection_In_r.
  eauto.
  auto with *.
  specialize(IHl x H5 R r H1 m H6 n).
  simpl in *.
  apply IHl.
  replace (Union U x R) with (Union U (Add U x x0) R).
  trivial.
  apply Extensionality_Ensembles.
  constructor.
  unfold Included.
  intros.
  destruct(classic (x0 = x1)).
  subst.
  right.
  trivial.
  destruct H7.
  destruct H7.
  left.
  trivial.
  auto with *.
  right.
  trivial.
  unfold Included.
  intros.
  destruct(classic (x0 = x1)).
  subst.
  left.
  right.
  auto with *.
  destruct H7;
  auto with *.
  replace (Intersection U (Add U x x0) R) with (Intersection U x R) in *.
  destruct n.
  apply cardinalO_empty in H.
  apply Extension in H.
  unfold Same_set in H.
  destruct H.
  unfold Included in *.
  specialize(H x0).
  assert(In U (Union U (Add U x x0) R) x0).
  constructor.
  apply Add_intro2.
  intuition.
  destruct H8.
  specialize(IHl x H5 R r H1 m H2 n).
  assert(cardinal U (Union U x R) n).
  pose (card_soustr_1 U (Union U (Add U x x0) R) (S n) H x0).
  simpl in *.
  assert(In U (Union U (Add U x x0) R) x0).
  auto with *.
  intuition.
  replace (Union U x R) with (Subtract U (Union U (Add U x x0) R) x0).
  trivial.
  apply Extensionality_Ensembles.
  constructor;
  unfold Included;
  intros;
  destruct (classic (x0 = x1));
  subst.
  destruct H8.
  auto with *.
  destruct H8.
  destruct H8.
  destruct H8.
  left.
  trivial.
  tauto.
  right.
  trivial.
  destruct H8;
  tauto.
  constructor.
  destruct H8;
  auto with *.
  auto with *.
  intuition.
  subst.
  assert(r >= m).
  unfold ge.
  eapply incl_card_le;
  eauto.
  apply Intersection_decreases_r.
  omega.
  apply Extensionality_Ensembles.
  unfold Same_set.
  intuition;
  constructor.
  apply In_Intersection_In_l in H6.
  constructor.
  trivial.
  apply In_Intersection_In_r in H6.
  trivial.
  destruct (classic (x0 = x1)).
  subst.
  apply In_Intersection_In_r in H6.
  tauto.
  apply In_Intersection_In_l in H6.
  destruct H6.
  trivial.
  destruct H6.
  tauto.
  apply In_Intersection_In_r in H6.
  trivial.
Qed.

Print Assumptions Inclusion_Exclusion_Principle.


Require Export GeoCoq.Tarski_dev.Ch04_cong_bet.

Section T4_1.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma col_permutation_1 : forall A B C,Col A B C -> Col B C A.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_2 : forall A B C, Col A B C -> Col C A B.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_3 : forall A B C, Col A B C -> Col C B A.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_4 : forall A B C, Col A B C -> Col B A C.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_5 : forall A B C, Col A B C -> Col A C B.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

End T4_1.

#[global]
Hint Resolve bet_col col_permutation_1 col_permutation_2
col_permutation_3 col_permutation_4 col_permutation_5 : col.

Ltac Col := auto 3 with col.
Ltac Col5 := auto with col.

Section T4_2.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma not_col_permutation_1 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col B C A.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_2 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col C A B.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_3 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col C B A.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_4 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col B A C.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_5 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col A C B.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

End T4_2.

#[global]
Hint Resolve not_col_permutation_1 not_col_permutation_2
not_col_permutation_3 not_col_permutation_4 not_col_permutation_5 : col.

Section T4_3.

Context `{Tn:Tarski_neutral_dimensionless}.

(** This lemma is used by tactics for trying several permutations. *)
Lemma Col_cases :
 forall A B C,
 Col A B C \/ Col A C B \/ Col B A C \/
 Col B C A \/ Col C A B \/ Col C B A ->
 Col A B C.
Proof.
    intros.
    decompose [or] H; Col.
Qed.

Lemma Col_perm :
 forall A B C,
 Col A B C ->
 Col A B C /\ Col A C B /\ Col B A C /\
 Col B C A /\ Col C A B /\ Col C B A.
Proof.
    intros.
    repeat split; Col.
Qed.

Lemma col_trivial_1 : forall A B, Col A A B.
Proof.
    unfold Col.
    intros.
    Between.
Qed.

Lemma col_trivial_2 : forall A B, Col A B B.
Proof.
    unfold Col.
    intros.
    Between.
Qed.

Lemma col_trivial_3 : forall A B, Col A B A.
Proof.
    unfold Col.
    intros.
    right;Between.
Qed.

End T4_3.

#[global]
Hint Immediate col_trivial_1 col_trivial_2 col_trivial_3: col.

Section T4_4.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma l4_13 : forall A B C A' B' C',
 Col A B C -> Cong_3 A B C A' B' C' -> Col A' B' C'.
Proof.
    unfold Col.
    intros.
    decompose [or] H;
      eauto 6  using l4_6 with cong3.
Qed.

Lemma l4_14 : forall A B C A' B',
  Col A B C -> Cong A B A' B' -> exists C', Cong_3 A B C A' B' C'.
Proof.
    unfold Col.
    intros.
    intuition.
      prolong A' B' C' B C.
      exists C'.
      assert (Cong A C A' C') by (eapply l2_11;eCong).
      unfold Cong_3;intuition.
      assert (exists C', Bet A' C' B' /\ Cong_3 A C B A' C' B') by (eapply l4_5;Between).
      ex_and H1 C'.
      exists C'.
      auto with cong3.
    prolong B' A' C' A C.
    exists C'.
    assert (Cong B C B' C') by (eapply l2_11;eBetween;Cong).
    unfold Cong_3;intuition.
Qed.

Lemma l4_16 : forall A B C D A' B' C' D',
   FSC A B C D A' B' C' D' -> A<>B -> Cong C D C' D'.
Proof.
    unfold FSC.
    unfold Col.
    intros.
    decompose [or and] H; clear H.
      assert (Bet A' B' C') by (eapply l4_6;eauto).
      unfold Cong_3 in *; spliter.
      assert(OFSC A B C D A' B' C' D') by (unfold OFSC;repeat split; assumption).
      eapply five_segment_with_def; eauto.
      assert(Bet B' C' A') by (apply (l4_6 B C A B' C' A'); Cong;auto with cong3).
      apply (l4_2 B C A D B' C' A' D').
      unfold IFSC; unfold Cong_3 in *; spliter; repeat split;Between;Cong.
    assert (Bet C' A' B') by (eapply (l4_6 C A B C' A' B'); auto with cong3).
    eapply (five_segment_with_def B A C D B' A'); unfold OFSC; unfold Cong_3 in *; spliter; repeat split; Between; Cong.
Qed.

Lemma l4_17 : forall A B C P Q,
  A<>B -> Col A B C -> Cong A P A Q -> Cong B P B Q -> Cong C P C Q.
Proof.
    intros.
    assert (FSC A B C P A B C Q) by (unfold FSC; unfold Cong_3;repeat split; Cong).
    eapply l4_16; eauto.
Qed.

Lemma l4_18 : forall A B C C',
  A<>B -> Col A B C -> Cong A C A C' -> Cong B C B C' -> C=C'.
Proof.
    intros.
    apply cong_identity with C.
    apply (l4_17 A B); Cong.
Qed.

Lemma l4_19 : forall A B C C',
 Bet A C B -> Cong A C A C' -> Cong B C B C' -> C=C'.
Proof.
    intros.
    induction (eq_dec_points A B).
      treat_equalities; reflexivity.
    apply (l4_18 A B); Cong.
    auto using bet_col with col.
Qed.

Lemma not_col_distincts : forall A B C ,
 ~ Col A B C ->
 ~ Col A B C /\ A <> B /\ B <> C /\ A <> C.
Proof.
    intros.
    repeat split;(auto;intro); subst; apply H; Col.
Qed.

Lemma NCol_cases :
 forall A B C,
 ~ Col A B C \/ ~ Col A C B \/ ~ Col B A C \/
 ~ Col B C A \/ ~ Col C A B \/ ~ Col C B A ->
 ~ Col A B C.
Proof.
    intros.
    decompose [or] H; Col.
Qed.

Lemma NCol_perm :
 forall A B C,
 ~ Col A B C ->
 ~ Col A B C /\ ~ Col A C B /\ ~ Col B A C /\
 ~ Col B C A /\ ~ Col C A B /\ ~ Col C B A.
Proof.
    intros.
    repeat split; Col.
Qed.

Lemma col_cong_3_cong_3_eq : forall A B C A' B' C1 C2,
  A <>B -> Col A B C -> Cong_3 A B C A' B' C1 -> Cong_3 A B C A' B' C2 -> C1 = C2.
Proof.
intros A B C A' B' C1 C2 HAB HCol HCong1 HCong2.
apply l4_18 with A' B'; try apply l4_13 with A B C; Col;
unfold Cong_3 in *; spliter.
  intro; treat_equalities; intuition.
  apply cong_transitivity with A C; Cong.
  apply cong_transitivity with B C; Cong.
Qed.

End T4_4.