From Coq Require Import ssreflect.
From Mon Require Import SPropBase.
From Relational Require Import OrderEnrichedCategory.

Import SPropNotations.

(*
In this file we build the composition of two lax relative monad morphisms.
We also prove a pointwise associativity for lax relative monad morphisms.
There is also support for whisekring a pointwise inequality θi ⪷ κi with another relative monad morpihsm.
*)

(*Some auxiliary lemma*)
Section CompVsOrder.

  Context {C : ord_category}.
  Context {a b c : Obj C}.
  Context (f1 f2 : C⦅ a ; b ⦆) (g1 g2 : C⦅ b ; c ⦆).
  Context (Hf : f1 ⪷ f2) (Hg : g1 ⪷ g2).
  Lemma compVsOrder : g1 ∙ f1 ⪷ g2 ∙ f2.
  Proof.
    eapply (Comp_proper C). assumption. assumption.
  Qed.

End CompVsOrder.

(*To compose two lax relative monad morphisms we must first compose their base squares (nat isos)*)
Section BaseSqu.

  Context {C D1 D2 D3 : ord_category}
          {J1 : ord_functor C D1}
          {J2 : ord_functor C D2}
          {J3 : ord_functor C D3}
          (J12 : ord_functor D1 D2)
          (J23 : ord_functor D2 D3)
          (phi12 : natIso J2 (ord_functor_comp J1 J12)) (psi12 := ni_inv phi12)
          (phi23 : natIso J3 (ord_functor_comp J2 J23)) (psi23 := ni_inv phi23).

  Let J13 := ord_functor_comp J12 J23.

  Let J23CircPhi12 := natIso_whisker_right J23 phi12.

  Let associator := natIso_sym (ord_functor_assoc J1 J12 J23).

  Definition phi13 := natIso_comp phi23 (natIso_comp J23CircPhi12 associator).

End BaseSqu.

(*Composition of two lax relative monad morphisms*)
Section Comp.

  Context {C D1 D2 D3 : ord_category}
          {J1 : ord_functor C D1}
          {J2 : ord_functor C D2}
          {J3 : ord_functor C D3}
          (J12 : ord_functor D1 D2)
          (J23 : ord_functor D2 D3)
          (phi12 : natIso J2 (ord_functor_comp J1 J12)) (psi12 := ni_inv phi12)
          (phi23 : natIso J3 (ord_functor_comp J2 J23)) (psi23 := ni_inv phi23)
          (M1 : ord_relativeMonad J1) (M2: ord_relativeMonad J2) (M3: ord_relativeMonad J3).

  Let J13 := ord_functor_comp J12 J23.
  Let phi13 := phi13 J12 J23 phi12 phi23.

  Program Definition rlmm_comp
  (θ12 : relativeLaxMonadMorphism J12 phi12 M1 M2)
  (θ23 : relativeLaxMonadMorphism J23 phi23 M2 M3)
  : relativeLaxMonadMorphism J13 phi13 M1 M3 :=
    mkRelLaxMonMorph _ _ _ _ _ _ _.
  Next Obligation.
    eapply Comp. eapply θ23. eapply ofmap. eapply θ12.
  Defined.
  Next Obligation.
    cbv.
    move: θ12 => [θ12_rlmm_map θ12_rlmm_law1 _].
    move: θ23 => [θ23_rlmm_map θ23_rlmm_law1 _].
    rewrite -{1}ord_cat_law3. rewrite -{1}ord_functor_law2.
    etransitivity. eapply (Comp_proper D3). reflexivity.
    eapply (ofmap_proper D2 D3 J23). apply θ12_rlmm_law1.
    rewrite {1}ord_functor_law2. rewrite {1}ord_cat_law3.
    rewrite [ θ23_rlmm_map A ∙ ( _ ∙ _)]ord_cat_law3.
    eapply compVsOrder.
      rewrite ord_cat_law2. reflexivity.
    apply θ23_rlmm_law1.
  Qed.
  Next Obligation.
    cbv.
    move: θ12 => [θ12_rlmm_map θ12_rlmm_law1 θ12_rlmm_law2].
    move: θ23 => [θ23_rlmm_map θ23_rlmm_law1 θ23_rlmm_law2].
    rewrite -{1}ord_cat_law3. rewrite -{1}ord_functor_law2.
    etransitivity. eapply (Comp_proper D3). reflexivity.
    eapply (ofmap_proper D2 D3 J23). eapply θ12_rlmm_law2.
    rewrite [ofmap J23 (_ ∙ _)]ord_functor_law2.
    rewrite [θ23_rlmm_map B ∙ (_ ∙ _)]ord_cat_law3.
    etransitivity. eapply compVsOrder. reflexivity. eapply θ23_rlmm_law2.
    rewrite [_ ∙ (θ23_rlmm_map A ∙ _)]ord_cat_law3.
    eapply compVsOrder. reflexivity.
    rewrite ord_cat_law1. eapply compVsOrder. reflexivity.
    eapply ord_relmon_bind_proper.
    rewrite [_ ∙ (_ ∙ phi23 A)]ord_cat_law3.
    eapply compVsOrder. reflexivity.
    rewrite -[(θ23_rlmm_map B ∙ _) ∙ _]ord_cat_law3.
    rewrite -[(θ23_rlmm_map B ∙ _) ∙ _]ord_cat_law3.
    eapply compVsOrder. rewrite ord_functor_law2. rewrite ord_functor_law2.
    reflexivity. reflexivity.
  Qed.

End Comp.

(*Pointwise associativity for lax relative monad morphisms*)
Section Assoc.

  Context {I C1 C2 C3 C4: ord_category}
          {J1 : ord_functor I C1}
          {J2 : ord_functor I C2}
          {J3 : ord_functor I C3}
          {J4 : ord_functor I C4}
          {J12 : ord_functor C1 C2}
          {J23 : ord_functor C2 C3}
          {J34 : ord_functor C3 C4}
          {phi12 : natIso J2 (ord_functor_comp J1 J12)} (psi12 := ni_inv phi12)
          {phi23 : natIso J3 (ord_functor_comp J2 J23)} (psi23 := ni_inv phi23)
          {phi34 : natIso J4 (ord_functor_comp J3 J34)} (psi34 := ni_inv phi34)
          {M1 : ord_relativeMonad J1} {M2: ord_relativeMonad J2}
          {M3: ord_relativeMonad J3} {M4 : ord_relativeMonad J4}.

  (*Three consecutive morphisms*)
  Context (θ12 : relativeLaxMonadMorphism J12 phi12 M1 M2)
          (θ23 : relativeLaxMonadMorphism J23 phi23 M2 M3)
          (θ34 : relativeLaxMonadMorphism J34 phi34 M3 M4).

  Let θleft := rlmm_comp _ _ _ _ _ _ _ θ12 θ23. (*θ23 ∘ θ12*)
  Let θright := rlmm_comp _ _ _ _ _ _ _ θ23 θ34.  (*θ34 ∘ θ23 *)
  (*below (θ34 ∘ θ23) ∘ θ12 *)
  Definition left_assoc_rlmm_comp :=
  rlmm_comp _ _ _ _ _ _ _ θ12 θright.
  (*below θ34 ∘ (θ23 ∘ θ12) *)
  Definition right_assoc_rlmm_comp :=
  rlmm_comp _ _ _ _ _ _ _ θleft θ34.

  Lemma rlmm_comp_assoc : forall i : I,
  left_assoc_rlmm_comp i = right_assoc_rlmm_comp i.
  Proof.
    move=> i.
    cbv.
    rewrite -!ord_cat_law3. f_equal.
    rewrite ord_functor_law2. reflexivity.
  Qed.

End Assoc.

(*whisekring ⪷*)
Section Proper_rlmm_comp.
  Notation "β \O α" := (rlmm_comp _ _ _ _ _ _ _ α β) (at level 70).

  Context {I C1 C2 C3: ord_category}
          {J1 : ord_functor I C1}
          {J2 : ord_functor I C2}
          {J3 : ord_functor I C3}
          {J12 : ord_functor C1 C2}
          {J23 : ord_functor C2 C3}
          {phi12 : natIso J2 (ord_functor_comp J1 J12)} (psi12 := ni_inv phi12)
          {phi23 : natIso J3 (ord_functor_comp J2 J23)} (psi23 := ni_inv phi23)
          {M1 : ord_relativeMonad J1} {M2: ord_relativeMonad J2}
          {M3: ord_relativeMonad J3}.

  (*two morphisms θ, κ : M1 -> M2, and two morphisms θ' , κ' : M2 -> M3*)
  Context (θ : relativeLaxMonadMorphism J12 phi12 M1 M2)
          (κ : relativeLaxMonadMorphism J12 phi12 M1 M2)
          (θ' : relativeLaxMonadMorphism J23 phi23 M2 M3)
          (κ' : relativeLaxMonadMorphism J23 phi23 M2 M3).

  (*θ = κ → θ' ∘ θ = θ' ∘ κ*)
  Lemma preeq_rlmm_proper :
  forall i : I, θ i = κ i -> (θ' \O θ) i = (θ' \O κ) i.
  Proof.
    move=> i.
    move=> Heq.
    cbv. rewrite Heq. reflexivity.
  Qed.

  Lemma preeq_rlmm_proper' :
  (forall i : I, θ i = κ i) -> (forall i : I , (θ' \O θ) i = (θ' \O κ) i ).
  Proof.
    move=> Heq. move=> i. move: Heq => /(_ i) Heq.
    cbv. rewrite Heq. reflexivity.
  Qed.

  Lemma posteq_rlmm_proper :
  forall i : I, θ' i = κ' i -> (θ' \O θ) i = (κ' \O θ) i.
  Proof.
    move=> i. cbv.
    move=> Heq. rewrite Heq.
    reflexivity.
  Qed.

  (*θ ⪷1 κ → θ' ∘ θ ⪷1 θ' ∘ κ*)
  Lemma preLeq_rlmm_proper :
  forall i : I, θ i ⪷ κ i -> (θ' \O θ) i ⪷ (θ' \O κ) i.
  Proof.
    cbv. move=> i Hleq.
    apply Comp_proper. reflexivity.
    apply ofmap_proper. assumption.
  Qed.

  Lemma postLeq_rlmm_proper :
  forall i : I, θ' i ⪷ κ' i -> (θ' \O θ) i ⪷ (κ' \O θ) i.
  Proof.
    cbv. move=> i Hleq.
    apply Comp_proper.
      assumption.
      reflexivity.
  Qed.

End Proper_rlmm_comp.

(*a small rewriting lemma for convenience*)
Section PointwiseFormula.
  Notation "β \O α" := (rlmm_comp _ _ _ _ _ _ _ α β) (at level 70).

  Context {I C1 C2 C3: ord_category}
          {J1 : ord_functor I C1}
          {J2 : ord_functor I C2}
          {J3 : ord_functor I C3}
          {J12 : ord_functor C1 C2}
          {J23 : ord_functor C2 C3}
          {phi12 : natIso J2 (ord_functor_comp J1 J12)} (psi12 := ni_inv phi12)
          {phi23 : natIso J3 (ord_functor_comp J2 J23)} (psi23 := ni_inv phi23)
          {M1 : ord_relativeMonad J1} {M2: ord_relativeMonad J2}
          {M3: ord_relativeMonad J3}.

  Context (θ : relativeLaxMonadMorphism J12 phi12 M1 M2)
          (θ' : relativeLaxMonadMorphism J23 phi23 M2 M3).

  Lemma rlmm_comp_pointwise_formula :
  forall i, (θ' \O θ) i = θ' i ∙ ofmap J23 (θ i).
  Proof.
    cbv. reflexivity.
  Qed.

End PointwiseFormula.


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

(** This file axiomatizes proof-irrelevance and derives some consequences *)

Require Import ProofIrrelevanceFacts.

Axiom proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.

Module PI. Definition proof_irrelevance := proof_irrelevance. End PI.

Module ProofIrrelevanceTheory := ProofIrrelevanceTheory(PI).
Export ProofIrrelevanceTheory.


From Hammer Require Import Hammer.

Require Import Coq.Lists.List.

Set Implicit Arguments.
Set Strict Implicit.

Section parametric.
Variable T : Type.

Lemma nth_error_app_L : forall (A B : list T) n,
n < length A ->
nth_error (A ++ B) n = nth_error A n.
Proof. hammer_hook "ListNth" "ListNth.nth_error_app_L".
induction A; destruct n; simpl; intros; auto.
{ inversion H. }
{ inversion H. }
{ eapply IHA. apply Lt.lt_S_n; assumption. }
Qed.

Lemma nth_error_app_R : forall (A B : list T) n,
length A <= n ->
nth_error (A ++ B) n = nth_error B (n - length A).
Proof. hammer_hook "ListNth" "ListNth.nth_error_app_R".
induction A; destruct n; simpl; intros; auto.
+ inversion H.
+ apply IHA. apply Le.le_S_n; assumption.
Qed.

Lemma nth_error_weaken : forall ls' (ls : list T) n v,
nth_error ls n = Some v ->
nth_error (ls ++ ls') n = Some v.
Proof. hammer_hook "ListNth" "ListNth.nth_error_weaken".
clear. induction ls; destruct n; simpl; intros; unfold value, error in *; try congruence; auto.
Qed.

Lemma nth_error_nil : forall n,
nth_error nil n = @None T.
Proof. hammer_hook "ListNth" "ListNth.nth_error_nil".
destruct n; reflexivity.
Qed.

Lemma nth_error_past_end : forall (ls : list T) n,
length ls <= n ->
nth_error ls n = None.
Proof. hammer_hook "ListNth" "ListNth.nth_error_past_end".
clear. induction ls; destruct n; simpl; intros; auto.
+ inversion H.
+ apply IHls. apply Le.le_S_n; assumption.
Qed.

Lemma nth_error_length : forall (ls ls' : list T) n,
nth_error (ls ++ ls') (n + length ls) = nth_error ls' n.
Proof. hammer_hook "ListNth" "ListNth.nth_error_length".
induction ls; simpl; intros.
rewrite Plus.plus_0_r. auto.
rewrite <- Plus.plus_Snm_nSm.
simpl. eapply IHls.
Qed.

Theorem nth_error_length_ge : forall T (ls : list T) n,
nth_error ls n = None -> length ls <= n.
Proof. hammer_hook "ListNth" "ListNth.nth_error_length_ge".
induction ls; destruct n; simpl in *; auto; simpl in *.
+ intro. apply Le.le_0_n.
+ inversion 1.
+ intros. eapply Le.le_n_S. auto.
Qed.

Lemma nth_error_length_lt : forall {T} (ls : list T) n val,
nth_error ls n = Some val -> n < length ls.
Proof. hammer_hook "ListNth" "ListNth.nth_error_length_lt".
induction ls; destruct n; simpl; intros; auto.
+ inversion H.
+ inversion H.
+ apply Lt.lt_0_Sn.
+ apply Lt.lt_n_S. eauto.
Qed.

Theorem nth_error_map : forall U (f : T -> U) ls n,
nth_error (map f ls) n = match nth_error ls n with
| None => None
| Some x => Some (f x)
end.
Proof. hammer_hook "ListNth" "ListNth.nth_error_map".
induction ls; destruct n; simpl; auto.
Qed.

End parametric.


(* Version of Bareiss/Sasaki-Murao based on dvdrings *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path.
From mathcomp Require Import ssralg fintype perm choice.
From mathcomp Require Import matrix bigop zmodp mxalgebra poly polydiv mxpoly.

Require Import ssrcomplements dvdring minor atomic_operations.

Import Pdiv.Ring Pdiv.RingComRreg Pdiv.RingMonic GRing.Theory.

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

Open Scope ring_scope.

Section Bareiss1.
Variable R: comRingType.

Lemma L1 m (a d: R) (l: 'rV[R]_m) (c: 'cV[R]_m) (M: 'M[R]_m):
  \det (block_mx d%:M l (a *: c) (a *: M)) =
  a ^+ m * \det (block_mx d%:M l c M).
Proof.
set X := block_mx d%:M l c M.
have huniq : uniq (map (lift 0) (enum 'I_m)).
- rewrite map_inj_in_uniq; first exact: enum_uniq.
  by move => i j hi hj /= /lift_inj.
have htool : forall s, 0 \notin map (lift 0) s by move => n /=; elim.
have -> : block_mx d%:M l (a *: c) (a *: M) =
  foldl (fun N i => line_scale i a N) X (map (lift 0) (enum 'I_m)).
- apply/row_matrixP => i.
  case: (lines_scale_row a X huniq) => hl hr.
  move: (hl i) (hr i) => {hl hr}.
  case: (splitP i) => j.
  + rewrite [j]ord1 {j} => hi.
    have {i hi}-> : i = 0 by apply/ord_inj.
    move => _ /= ->; last exact: htool.
    apply/rowP => j; rewrite !mxE.
    by case: splitP.

  move => hi.
  have {i hi}-> : i = lift 0 j by apply/ord_inj.
  move => -> /=.
  + move => _.
    apply/rowP => k; rewrite !mxE.
    case: splitP => x; first by rewrite [x]ord1.
    rewrite !mxE => _.
    case: splitP => y; by rewrite !mxE.
  rewrite mem_map ?mem_enum //.
  by apply/lift_inj.
by rewrite det_lines_scale size_map size_enum_ord /=.
Qed.

Definition L3tool m (c: 'cV[R]_m) (d: R) (i: 'I_(1 + m)) :=
  if split i is inr j then c j 0 else d.

Lemma L3toolE0 m (c: 'cV[R]_m) d : L3tool c d 0 = d.
Proof. by rewrite /L3tool; case: splitP. Qed.

Lemma L3toolES m (c: 'cV[R]_m) d (i: 'I_m) : L3tool c d (lift 0 i) = c i 0.
Proof.
rewrite /L3tool.
case: splitP => x /=; first by rewrite [x]ord1.
by rewrite /bump leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->.
Qed.

Lemma L3 m (d: R) (l: 'rV[R]_m) (c c0: 'cV[R]_m) (M: 'M[R]_m):
  \det (block_mx d%:M l c M) =
  \det (block_mx d%:M l (c - d *: c0) (M - c0 *m l)).
Proof.
pose X := block_mx d%:M l c M.
have huniq : uniq (map (lift 0) (enum 'I_m)).
- rewrite map_inj_in_uniq ?enum_uniq //.
  move => i j hi hj /=.
  by apply/lift_inj.
have htool : forall s, 0 \notin map (lift 0) s by move => n /=; elim.
have {}htool := htool _ (enum 'I_m).
have -> : block_mx d%:M l (c -d *: c0) (M - c0 *m l) =
  foldl (fun N i => line_comb i 0 (-(L3tool c0 d i)) N) X
        (map (lift 0) (enum 'I_m)).
- apply/row_matrixP => i.
  case: (lines_comb_row_dep (fun i => - (L3tool c0 d i)) X huniq htool)
     => hl hr.
  move: (hl i) (hr i) => {hl hr}.
  case: (splitP i) => j.
  + rewrite [j]ord1 {j} => hi.
    have {hi i}-> : i = 0 by apply/ord_inj.
    move => _ -> //=.
    apply/rowP => j; rewrite !mxE.
    by case: splitP.
  move => hi.
  have {i hi}-> : i = lift 0 j by apply/ord_inj.
  move => -> /=.
  + rewrite L3toolES => _.
    apply/rowP => k; rewrite !mxE.
    case: splitP => x /= ; first by rewrite [x]ord1.
    rewrite /bump leq0n => /eqP; rewrite eqSS => /eqP/ord_inj{j}->.
    case: splitP => z //; rewrite [z]ord1 {z} !mxE => _.
    case: splitP => y; rewrite !mxE.
    * rewrite [y]ord1 {y} => _.
      by rewrite mulrC mulr1n mulNr.
    by move => _; rewrite big_ord_recl big_ord0 addr0 mulNr.
  rewrite mem_map ?mem_enum //.
  by apply/lift_inj.
by rewrite det_lines_comb_dep // size_map size_enum_ord /=.
Qed.

Lemma key_lemma m d (l: 'rV[R]_m) (c: 'cV[R]_m) M:
  d ^+ m * \det (block_mx d%:M l c M) = d * \det (d *: M - c *m l).
Proof.
by rewrite -L1 (L3 d l (d *: c) c (d *: M)) subrr det_ublock det_scalar1.
Qed.

(*
  The key lemma of our proof: after simplification,
  all the p-minors (involving 1st line/column)
  can be divided by (M 0 0)^p-1
*)

Lemma key_lemma_sub m n k d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n))
  (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n):
  d * (minor f1 f2 (d *: M - c *m l)) =
  d ^+ k * (minor (lift_pred f1) (lift_pred f2) (block_mx d%:M l c M)).
Proof.
by rewrite /minor submatrix_lift_block key_lemma
  submatrix_add submatrix_scale submatrix_opp submatrix_mul.
Qed.

End Bareiss1.

Section Bareiss2.
Variable R: dvdRingType.

Definition dvd_step (m n:nat) (d: R) (M: 'M[R]_(m,n)) : 'M[R]_(m,n) :=
  map_mx (fun x => odflt 0 (x %/? d)) M.

(*
  determinant equality for division step
*)
Lemma det_dvd_step: forall n a (M: 'M[R]_n),
  (forall i j, a %| M i j) ->
  a^+n * \det (dvd_step a M) = \det M.
Proof.
rewrite /dvd_step => n a M hj.
rewrite -detZ; f_equal.
apply/matrixP => i j; rewrite !mxE.
case: odivrP => [d|h] /=; first by rewrite mulrC.
case/dvdrP: (hj i j) => d hd.
by move: (h d); rewrite hd eqxx.
Qed.

Lemma det_dvd_step_tool : forall m n a (M N: 'M[R]_(m,n)),
  M = a *: N -> forall i j, a %| M i j.
Proof.
move => m n a M N /matrixP h i j.
rewrite (h i j) !mxE mulrC.
by apply/dvdr_mull/dvdrr.
Qed.

Let lreg := GRing.lreg.

(*
  some rewriting lemmas to make the main proof more clear
*)
Lemma blockE00 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)):
   (block_mx d%:M l c M) 0 0 = d.
Proof.
rewrite !mxE.
case: splitP => x //; rewrite [x]ord1 {x} !mxE => _.
by case: splitP => x //; rewrite [x]ord1 {x} !mxE => _.
Qed.

Lemma blockE0i m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i:
  (block_mx d%:M l c M) 0 (lift 0 i) = (l 0 i).
Proof.
rewrite !mxE.
case: splitP => x //; rewrite [x]ord1 {x} !mxE => _.
case: splitP => x; first by rewrite [x]ord1.
by rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->.
Qed.

Lemma blockEi0 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i:
  (block_mx d%:M l c M) (lift 0 i) 0 = (c i 0).
Proof.
rewrite !mxE.
case: splitP => x; first by rewrite [x]ord1.
rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->.
rewrite !mxE.
by case: splitP => y //; rewrite [y]ord1 {y} => _.
Qed.

Lemma blockEij m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i j:
  (block_mx d%:M l c M) (lift 0 i) (lift 0 j) = (M i j).
Proof.
rewrite !mxE.
case: splitP => x; first by rewrite [x]ord1.
rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->.
rewrite !mxE.
case: splitP => y; first by rewrite [y]ord1.
by rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->.
Qed.

(*
  main step of the proof
*)
Lemma sketch m n (a d: R) (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)):
 lreg a ->
 (forall (k:nat) (f1: 'I_k.+1 -> 'I_(1 + m)) (f2: 'I_k.+1 -> 'I_(1 + n)),
     a ^+ k %| minor f1 f2 (block_mx d%:M l c M))->
 (forall p (h: p.+1 <= 1 + m) (h': p.+1 <= 1 + n),
   lreg (pminor h h' (block_mx d%:M l c M))) ->
   let M' := d *: M - c *m l in
   let M'':= dvd_step a M' in
     [/\ lreg d,
       (forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n),
         d ^+ k %| minor f1 f2 M''),
       M' = a *: M'' &
  (forall p (h: p.+1 <= m) (h': p.+1 <= n),
   lreg (pminor h h' M''))].
Proof.
rewrite /pminor => ha hM hN.
set M0 := block_mx d%:M l c M.
(* d is the 1x1 principal minor of M0 *)
have hh : d = minor (widen_ord (ltn0Sn _)) (widen_ord (ltn0Sn _)) M0.
- rewrite (@minor_eq _ _ _ _ _ (fun=> 0) _ (fun=> 0)) ?minor1 //.
  + by rewrite /M0 blockE00.
  + by move => x; rewrite ord1; apply: val_inj.
  + by move => x; rewrite ord1; apply: val_inj.
(* all principal minors of M0 are lreg, so M 0 0 is *)
have h2 : lreg d.
- by rewrite hh /M0; apply hN.
set M' := d *: M - c *m l.
set M'' := dvd_step a M'.
set f : forall m, 'I_m -> 'I_2 -> 'I_(1 + m) :=
  fun m (i: 'I_m) (x: 'I_2) => if x == 0 then 0 else lift 0 i.
(*
  all elements of M' can be expressed as 2x2 minors of M,
  so a divide all these
*)
have h4 : forall i j, a %| M' i j.
- move => i j; rewrite /M' !mxE big_ord_recl big_ord0 addr0.
  move: (hM 1%nat (f _ i) (f _ j)). (* (hstrict _ i)). *)
  by rewrite !minor2 /f /= expr1 blockE00 blockEi0 blockE0i blockEij.
(*
  since a divides all M' i j, all the divisions are exact,
  and thus M' = a * M''
*)
have h6 : forall i j, M' i j = a * M'' i j.
- move => i j; rewrite [(dvd_step _ _) i j]mxE.
  case: odivrP => [dv|h] /=; first by rewrite mulrC.
  case/dvdrP: (h4 i j) => dv hdv.
  by move: (h dv); rewrite hdv eqxx.
have h6' : M' = a *: M'' by apply/matrixP => i j; rewrite h6 !mxE.
(*
  from this equality, we can have more information about the minors
  of M' and M''
*)
have h7 : forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n),
    minor f1 f2 M' = a ^+ k * minor f1 f2 M''.
- move => k f1 f2.
  by rewrite h6' /minor submatrix_scale detZ.
(*
  using all theses, we can now prove our goals
*)
have h8: forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n),
  d * minor f1 f2 M' =
    d ^+ k * minor (lift_pred f1) (lift_pred f2) M0.
- move => k f1 f2.
  by rewrite /M0 /M' key_lemma_sub.
have ak : forall k, lreg (a^+k).
- by move => k; apply/lregX.
have h10 : forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n),
  d ^+ k %| minor f1 f2 M''.
- move => k f1 f2.
  move/lregP : (ak k.+1) => ak'.
  rewrite -(@dvdr_mul2l _ (a^+k.+1)) // -h7.
  have hM0 : d != 0 by apply/lregP.
  have hMk : d^+ k.+1 != 0 by apply/lregP/lregX.
  rewrite -(@dvdr_mul2l _ d) // mulrA h8 //.
  by rewrite mulrAC -exprS dvdr_mul2l //.
split => //.
rewrite -/M'' => p h h'.
apply/(@lregMl _ (a ^+ p.+1)).
rewrite -h7.
apply/(@lregMl _ d).
rewrite h8.
apply/lregM; first by apply/lregX.
rewrite (@minor_eq _ _ _ _ _ (widen_ord (size_tool h)) _
                             (widen_ord (size_tool h'))) ?hN.
- by apply: hN.
- by move => x; apply: val_inj; rewrite lift_pred_widen_ord.
- by move => x; apply: val_inj; rewrite lift_pred_widen_ord.
Qed.

(*
  formal definition of Bareiss algorithm
*)
Fixpoint Bareiss_rec m a : 'M[R]_(1 + m) -> R :=
  if m is p.+1 return 'M[R]_(1 + m) -> R then
    fun (M: 'M[R]_(1 + _)) =>
      let d   := M 0 0 in
      let l   := ursubmx M in
      let c   := dlsubmx M in
      let N   := drsubmx M in
      let M'  := d *: N - c *m l in
      let M'' := dvd_step a M' in
      Bareiss_rec d M''
  else fun M => M 0 0.

(*
  from sketch, we can express the properties of Bareiss
*)
Lemma Bareiss_recE : forall m a (M: 'M[R]_(1 + m)),
  lreg a  ->
  (forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_m.+1), a ^+ k %| minor f1 f2 M) ->
  (forall p (h h' :p.+1 <= 1 + m),
   lreg (minor (widen_ord h) (widen_ord h') M)) ->
  a ^+ m * (Bareiss_rec a M) = \det M.
Proof.
elim => [ | m hi] //=.
- move => a M ha h1 h2.
  by rewrite expr0 {2}[M]mx11_scalar det_scalar1 mul1r.
rewrite [(1 + m.+1)%nat]/(1 + (1 + m))%nat => a M ha.
set d := M 0 0.
set l := ursubmx M.
set c := dlsubmx M.
set N := drsubmx M.
have heq : block_mx (M 0 0)%:M (ursubmx M) (dlsubmx M) (drsubmx M) = M.
- have -> : (M 0 0)%:M = ulsubmx M
  by apply/matrixP => i j; rewrite !mxE [i]ord1 [j]ord1 {i j} !lshift0.
  by rewrite submxK.
rewrite -{1 2}heq => hM hm.
have : forall p (h h': p.+1 <= 1 + (1 + m)),
  lreg (minor (widen_ord h) (widen_ord h') M).
- rewrite -heq => p h h'.
  rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)) ?hm //.
  by move => x; apply/ord_inj.
case: (@sketch _ _ a (M 0 0) (ursubmx M) (dlsubmx M) (drsubmx M) ha hM hm)
 => hM00 h1 h2 h3 hlreg.
have h3' : forall p (h h': p < 1 + m),
  lreg (pminor h h' (dvd_step a (d *: N - c *m l)))
  by move => p h h'; apply/h3.
move: (hi d (dvd_step a (d *: N - c *m l)) hM00 h1 h3').
set r := Bareiss_rec _ _ => hh.
have : a ^+ m.+1 *( d ^+m * r) =
       a ^+ m.+1 * \det (dvd_step a (d *: N - c *m l)) by rewrite hh.
rewrite det_dvd_step //; last by move => i j; exact: (det_dvd_step_tool h2).
move => heq2.
have hX : lreg (M 0 0 ^+ (1 + m)) by apply/lregX.
apply/hX.
rewrite -{3}heq key_lemma -heq2 [M 0 0 ^+ (1 + m)]exprS -mulrA.
by congr (_ * _); rewrite mulrCA.
Qed.

(*
  we start the algorithm with a = 1
*)
Definition Bareiss (n: nat) (M: 'M[R]_(1 + n)) :=
  Bareiss_rec 1 M.

Lemma BareissE : forall n (M: 'M[R]_(1 + n)),
 (forall p (h h': p.+1 <= 1 + n), lreg (pminor h h' M)) ->
  Bareiss M = \det M.
Proof.
rewrite /Bareiss => n M h.
have h1 : lreg (1: R) by apply/lreg1.
have h2 : forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_n.+1),
     1 ^+ k %| minor f1 f2 M.
- by move => k f1 f2; rewrite expr1n dvd1r.
move: (Bareiss_recE h1 h2 h).
by rewrite expr1n mul1r.
Qed.

End Bareiss2.

(*
  In practice, we apply this algorithm to the characteristic matrix
  so we get the characteristic polynomial in polynomial time
*)
Require Import polydvd.

Import PolyDvdRing.

Section Bareiss_det.
Variable R: dvdRingType.

(*
  all principal minor of the characteristic matrix are monic
*)
Lemma pminor_char_poly_mx_monic: forall m p (M: 'M[R]_m) (h h': p.+1 <= m),
  pminor h h' (char_poly_mx M) \is monic.
Proof.
rewrite /pminor => m p M h h'.
rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)); first last.
- by apply: widen_ord_eq.
- by move => x.
rewrite /minor submatrix_char_poly_mx; last by apply: inj_widen_ord.
by apply/char_poly_monic.
Qed.

Definition char_poly_alt n (M: 'M[R]_(1 + n)) :=
  Bareiss (char_poly_mx M).

(*
  Here is our alternative definition of char_poly
*)
Lemma char_poly_altE : forall n (M: 'M[R]_(1 + n)),
  char_poly_alt M = char_poly M.
Proof.
rewrite /char_poly_alt /char_poly => n M.
rewrite BareissE //.
move => p h h'; apply/monic_lreg.
exact: pminor_char_poly_mx_monic.
Qed.

(* The actual determinant function based on Bareiss *)
Definition bdet n (M : 'M[R]_(1 + n)) := (char_poly_alt (-M))`_0.

Lemma bdetE : forall n (M : 'M[R]_(1 + n)), bdet M = \det M.
Proof.
move=> n M.
rewrite /bdet char_poly_altE char_poly_det.
have -> : - M = -1 *: M by apply/matrixP => i j; rewrite !mxE mulN1r.
by rewrite detZ mulrA -expr2 sqrr_sign mul1r.
Qed.

End Bareiss_det.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * Typeclass-based relations, tactics and standard instances

   This is the basic theory needed to formalize morphisms and setoids.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Require Export Coq.Classes.Init.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
Require Import Coq.Relations.Relation_Definitions.

(** We allow to unfold the [relation] definition while doing morphism search. *)

Notation inverse R := (flip (R:relation _) : relation _).

Definition complement {A} (R : relation A) : relation A := fun x y => R x y -> False.

(** Opaque for proof-search. *)
Typeclasses Opaque complement.

(** These are convertible. *)

Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R).
Proof. reflexivity. Qed.

(** We rebind relations in separate classes to be able to overload each proof. *)

Set Implicit Arguments.
Unset Strict Implicit.

Class Reflexive {A} (R : relation A) :=
  reflexivity : forall x, R x x.

Class Irreflexive {A} (R : relation A) :=
  irreflexivity : Reflexive (complement R).

Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances.

Class Symmetric {A} (R : relation A) :=
  symmetry : forall x y, R x y -> R y x.

Class Asymmetric {A} (R : relation A) :=
  asymmetry : forall x y, R x y -> R y x -> False.

Class Transitive {A} (R : relation A) :=
  transitivity : forall x y z, R x y -> R y z -> R x z.

Hint Resolve @irreflexivity : ord.

Unset Implicit Arguments.

(** A HintDb for relations. *)

Ltac solve_relation :=
  match goal with
  | [ |- ?R ?x ?x ] => reflexivity
  | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H
  end.

Hint Extern 4 => solve_relation : relations.

(** We can already dualize all these properties. *)

Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.

Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R).
Proof. tauto. Qed.

Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.

Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) :=
  irreflexivity (R:=R).

Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) :=
  fun x y H => symmetry (R:=R) H.

Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) :=
  fun x y H H' => asymmetry (R:=R) H H'.

Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) :=
  fun x y z H H' => transitivity (R:=R) H' H.

Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances.
Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances.
Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances.
Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances.

Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A))
   : Irreflexive (complement R).
Proof. firstorder. Qed.

Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R).
Proof. firstorder. Qed.

Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances.
Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances.

(** * Standard instances. *)

Ltac reduce_hyp H :=
  match type of H with
    | context [ _ <-> _ ] => fail 1
    | _ => red in H ; try reduce_hyp H
  end.

Ltac reduce_goal :=
  match goal with
    | [ |- _ <-> _ ] => fail 1
    | _ => red ; intros ; try reduce_goal
  end.

Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid.

Ltac reduce := reduce_goal.

Tactic Notation "apply" "*" constr(t) :=
  first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) |
    refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ].

Ltac simpl_relation :=
  unfold flip, impl, arrow ; try reduce ; program_simpl ;
    try ( solve [ intuition ]).

Local Obligation Tactic := simpl_relation.

(** Logical implication. *)

Program Instance impl_Reflexive : Reflexive impl.
Program Instance impl_Transitive : Transitive impl.

(** Logical equivalence. *)

Instance iff_Reflexive : Reflexive iff := iff_refl.
Instance iff_Symmetric : Symmetric iff := iff_sym.
Instance iff_Transitive : Transitive iff := iff_trans.

(** Leibniz equality. *)

Instance eq_Reflexive {A} : Reflexive (@eq A) := @eq_refl A.
Instance eq_Symmetric {A} : Symmetric (@eq A) := @eq_sym A.
Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A.

(** Various combinations of reflexivity, symmetry and transitivity. *)

(** A [PreOrder] is both Reflexive and Transitive. *)

Class PreOrder {A} (R : relation A) : Prop := {
  PreOrder_Reflexive :> Reflexive R ;
  PreOrder_Transitive :> Transitive R }.

(** A partial equivalence relation is Symmetric and Transitive. *)

Class PER {A} (R : relation A) : Prop := {
  PER_Symmetric :> Symmetric R ;
  PER_Transitive :> Transitive R }.

(** Equivalence relations. *)

Class Equivalence {A} (R : relation A) : Prop := {
  Equivalence_Reflexive :> Reflexive R ;
  Equivalence_Symmetric :> Symmetric R ;
  Equivalence_Transitive :> Transitive R }.

(** An Equivalence is a PER plus reflexivity. *)

Instance Equivalence_PER `(Equivalence A R) : PER R | 10 :=
  { PER_Symmetric := Equivalence_Symmetric ;
    PER_Transitive := Equivalence_Transitive }.

(** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *)

Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) :=
  antisymmetry : forall {x y}, R x y -> R y x -> eqA x y.

Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) :
  Antisymmetric A eqA (flip R).
Proof. firstorder. Qed.

(** Leibinz equality [eq] is an equivalence relation.
   The instance has low priority as it is always applicable
   if only the type is constrained. *)

Program Instance eq_equivalence : Equivalence (@eq A) | 10.

(** Logical equivalence [iff] is an equivalence relation. *)

Program Instance iff_equivalence : Equivalence iff.

(** We now develop a generalization of results on relations for arbitrary predicates.
   The resulting theory can be applied to homogeneous binary relations but also to
   arbitrary n-ary predicates. *)

Local Open Scope list_scope.

(* Notation " [ ] " := nil : list_scope. *)
(* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *)

(** A compact representation of non-dependent arities, with the codomain singled-out. *)

Fixpoint arrows (l : list Type) (r : Type) : Type :=
  match l with
    | nil => r
    | A :: l' => A -> arrows l' r
  end.

(** We can define abbreviations for operation and relation types based on [arrows]. *)

Definition unary_operation A := arrows (A::nil) A.
Definition binary_operation A := arrows (A::A::nil) A.
Definition ternary_operation A := arrows (A::A::A::nil) A.

(** We define n-ary [predicate]s as functions into [Prop]. *)

Notation predicate l := (arrows l Prop).

(** Unary predicates, or sets. *)

Definition unary_predicate A := predicate (A::nil).

(** Homogeneous binary relations, equivalent to [relation A]. *)

Definition binary_relation A := predicate (A::A::nil).

(** We can close a predicate by universal or existential quantification. *)

Fixpoint predicate_all (l : list Type) : predicate l -> Prop :=
  match l with
    | nil => fun f => f
    | A :: tl => fun f => forall x : A, predicate_all tl (f x)
  end.

Fixpoint predicate_exists (l : list Type) : predicate l -> Prop :=
  match l with
    | nil => fun f => f
    | A :: tl => fun f => exists x : A, predicate_exists tl (f x)
  end.

(** Pointwise extension of a binary operation on [T] to a binary operation
   on functions whose codomain is [T].
   For an operator on [Prop] this lifts the operator to a binary operation. *)

Fixpoint pointwise_extension {T : Type} (op : binary_operation T)
  (l : list Type) : binary_operation (arrows l T) :=
  match l with
    | nil => fun R R' => op R R'
    | A :: tl => fun R R' =>
      fun x => pointwise_extension op tl (R x) (R' x)
  end.

(** Pointwise lifting, equivalent to doing [pointwise_extension] and closing using [predicate_all]. *)

Fixpoint pointwise_lifting (op : binary_relation Prop)  (l : list Type) : binary_relation (predicate l) :=
  match l with
    | nil => fun R R' => op R R'
    | A :: tl => fun R R' =>
      forall x, pointwise_lifting op tl (R x) (R' x)
  end.

(** The n-ary equivalence relation, defined by lifting the 0-ary [iff] relation. *)

Definition predicate_equivalence {l : list Type} : binary_relation (predicate l) :=
  pointwise_lifting iff l.

(** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *)

Definition predicate_implication {l : list Type} :=
  pointwise_lifting impl l.

(** Notations for pointwise equivalence and implication of predicates. *)

Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope.
Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope.

Open Local Scope predicate_scope.

(** The pointwise liftings of conjunction and disjunctions.
   Note that these are [binary_operation]s, building new relations out of old ones. *)

Definition predicate_intersection := pointwise_extension and.
Definition predicate_union := pointwise_extension or.

Infix "/∙\" := predicate_intersection (at level 80, right associativity) : predicate_scope.
Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_scope.

(** The always [True] and always [False] predicates. *)

Fixpoint true_predicate {l : list Type} : predicate l :=
  match l with
    | nil => True
    | A :: tl => fun _ => @true_predicate tl
  end.

Fixpoint false_predicate {l : list Type} : predicate l :=
  match l with
    | nil => False
    | A :: tl => fun _ => @false_predicate tl
  end.

Notation "∙⊤∙" := true_predicate : predicate_scope.
Notation "∙⊥∙" := false_predicate : predicate_scope.

(** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *)

Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l).

  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    fold pointwise_lifting.
    induction l. firstorder.
    intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)).
    firstorder.
  Qed.

Program Instance predicate_implication_preorder :
  PreOrder (@predicate_implication l).
  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    induction l. firstorder.
    unfold predicate_implication in *. simpl in *.
    intro. pose (IHl (x x0) (y x0) (z x0)). firstorder.
  Qed.

(** We define the various operations which define the algebra on binary relations,
   from the general ones. *)

Definition relation_equivalence {A : Type} : relation (relation A) :=
  @predicate_equivalence (_::_::nil).

Class subrelation {A:Type} (R R' : relation A) : Prop :=
  is_subrelation : @predicate_implication (A::A::nil) R R'.

Implicit Arguments subrelation [[A]].

Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A :=
  @predicate_intersection (A::A::nil) R R'.

Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A :=
  @predicate_union (A::A::nil) R R'.

(** Relation equivalence is an equivalence, and subrelation defines a partial order. *)

Set Automatic Introduction.

Instance relation_equivalence_equivalence (A : Type) :
  Equivalence (@relation_equivalence A).
Proof. exact (@predicate_equivalence_equivalence (A::A::nil)). Qed.

Instance relation_implication_preorder A : PreOrder (@subrelation A).
Proof. exact (@predicate_implication_preorder (A::A::nil)). Qed.

(** *** Partial Order.
   A partial order is a preorder which is additionally antisymmetric.
   We give an equivalent definition, up-to an equivalence relation
   on the carrier. *)

Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} :=
  partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)).

(** The equivalence proof is sufficient for proving that [R] must be a morphism
   for equivalence (see Morphisms).
   It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *)

Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R.
Proof with auto.
  reduce_goal.
  pose proof partial_order_equivalence as poe. do 3 red in poe.
  apply <- poe. firstorder.
Qed.

(** The partial order defined by subrelation and relation equivalence. *)

Program Instance subrelation_partial_order :
  ! PartialOrder (relation A) relation_equivalence subrelation.

  Next Obligation.
  Proof.
    unfold relation_equivalence in *. compute; firstorder.
  Qed.

Typeclasses Opaque arrows predicate_implication predicate_equivalence
  relation_equivalence pointwise_lifting.

(** Rewrite relation on a given support: declares a relation as a rewrite
   relation for use by the generalized rewriting tactic.
   It helps choosing if a rewrite should be handled
   by the generalized or the regular rewriting tactic using leibniz equality.
   Users can declare an [RewriteRelation A RA] anywhere to declare default
   relations. This is also done automatically by the [Declare Relation A RA]
   commands. *)

Class RewriteRelation {A : Type} (RA : relation A).

Instance: RewriteRelation impl.
Instance: RewriteRelation iff.
Instance: RewriteRelation (@relation_equivalence A).

(** Any [Equivalence] declared in the context is automatically considered
   a rewrite relation. *)

Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA.

(** Strict Order *)

Class StrictOrder {A : Type} (R : relation A) := {
  StrictOrder_Irreflexive :> Irreflexive R ;
  StrictOrder_Transitive :> Transitive R
}.

Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R.
Proof. firstorder. Qed.

(** Inversing a [StrictOrder] gives another [StrictOrder] *)

Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R).
Proof. firstorder. Qed.

(** Same for [PartialOrder]. *)

Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R).
Proof. firstorder. Qed.

Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances.
Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances.

Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R).
Proof. firstorder. Qed.

Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREER SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

(* with an Hypothesis H : A -> B, specializes H to H : B after
   having provided a proof of A. A is available under U : A
   afterwards
*)

Ltac spec H U :=
  match goal with [ G : ?h -> _ |- _ ] =>
    match G with H => assert h as U; [ idtac | specialize (H U) ] end end.

(* spec but forgets U : A *)

Ltac specf H := let U := fresh in spec H U; [ idtac | clear U ].

(* and do it as much as you can *)

Ltac spec_all_rec H U :=
  try match goal with [ G : ?h -> _ |- _ ] =>
    match G with H => assert h as U; [ idtac | specialize (H U); clear U; spec_all_rec H U ] end end.

Ltac spec_all H := let U := fresh in spec_all_rec H U.

(* with a goal H : A, ... |- B, replace it with A = B *)

Ltac replace_with H :=
  match goal with [ G : ?h |- ?c ] => match H with G => cutrewrite (c = h); [ exact H | f_equal ] end end.

Ltac inhabited_tac :=
  let H := fresh
  in match goal with
       | |- inhabited _ -> _ => intros [ H ]; inhabited_tac; revert H
       | |- inhabited _      => exists
     end.

Definition ex_rect (A : Prop) (P : A -> Prop) (Q : Type) : (forall x : A, P x -> Q) -> (exists x, P x) -> Q.
Proof.
  intros HA H.
  cut({ x | P x}).
  intros [ ? H1 ]; revert H1; apply HA.
  destruct H as (x & ?); exists x; assumption.
Qed.


From mathcomp Require Import all_ssreflect.

Require Import Recdef.

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

(* ********************* *)

Section Seq.
  Lemma filter_size T p (s:seq T) : size (filter p s) <= size s.
  Proof. by rewrite size_filter count_size. Qed.

  Lemma filter_sizeP T p (s:seq T) :
    reflect (size (filter p s) < size s) (has (predC p) s).
  Proof.
    apply : (iffP idP).
    - elim : s =>[|x s IH]//=. case : ifP =>//=_ _. exact : filter_size.
    - elim : s =>[|x s IH]//=. by case : ifP.
  Qed.

  Fixpoint dropuntil (X:eqType) x (s:seq X) :=
    match s with
    | [::] => [::]
    | h :: s' => if x == h then s else dropuntil x s'
    end.

  Definition behind (X:eqType) (s:seq X) f b := b \in dropuntil f s.

  Lemma behind_head (X:eqType) (s:seq X) h b :
    behind (h :: s) h b = (b \in h :: s).
  Proof. by rewrite /behind /= eq_refl. Qed.

  Lemma mem_behind (X:eqType) (s:seq X) f b :
    behind s f b -> b \in s.
  Proof.
    rewrite /behind. elim : s =>[|h s IH]//=. case : ifP =>//_ H.
      by rewrite in_cons (IH H) orbT.
  Qed.

  Lemma behindxx (X:eqType) (s:seq X) x : x \in s -> behind s x x.
  Proof.
    elim : s =>[|h s IH]//. rewrite in_cons /behind =>/orP[/eqP->|Hx]//=.
    - by rewrite eq_refl mem_head.
    - case : ifP =>[/eqP->|_]; [by rewrite mem_head|exact : IH].
  Qed.

  Lemma behind_sub2seq (X:eqType) (s:seq X) f b :
    subseq [:: f; b] s -> behind s f b.
  Proof.
    elim : s =>[|h s IH]//=. rewrite /behind /=.
    case : ifP =>_; [by rewrite sub1seq in_cons =>->; exact : orbT|exact : IH].
  Qed.

  Lemma behindP (X:eqType) (s:seq X) f b:
    reflect (subseq [:: f; b] s || (f == b) && (f \in s)) (behind s f b).
  Proof.
    apply /(iffP idP)=>[|/orP[/behind_sub2seq|/andP[/eqP->/behindxx]]]//.
    rewrite /behind. elim : s =>[|h s IH]//=. rewrite in_cons.
    case : ifP =>[/eqP->|_/IH]//.
    rewrite in_cons =>/orP[/eqP->|]; [by rewrite eq_refl orbT|].
      by rewrite sub1seq =>->.
  Qed.

  Definition onth (T:Type) (s:seq T) n :=
    nth None [seq Some x | x <- s] n.

  Lemma onth0 (T:Type) x (s:seq T) :
    onth (x :: s) 0 = Some x.
  Proof. done. Qed.

  Lemma onth_cons (T:Type) x (s:seq T) n :
    onth (x :: s) n.+1 = onth s n.
  Proof. done. Qed.

  Lemma onth_mem (T:eqType) x (s:seq T) n:
    onth s n = Some x -> x \in s.
  Proof.
    rewrite /onth. elim : s =>[|h s IH]/= in n *; [by rewrite nth_nil|].
    case : n =>[|n]/=; [by case=>->; rewrite mem_head|move/IH].
    rewrite in_cons =>->. exact : orbT.
  Qed.

  Lemma onth_lt (T:eqType) x (s:seq T) n:
    onth s n = Some x -> n < size s.
  Proof.
    rewrite /onth. elim : s =>[|h s IH]/= in n *; [by rewrite nth_nil|].
      by case : n =>[|n]//=/IH.
  Qed.

  Lemma onth_index (T:eqType) x (s:seq T) :
    x \in s -> onth s (index x s) = Some x.
  Proof.
    move => xs. by rewrite /onth (@nth_map _ x) ?index_mem // nth_index.
  Qed.

  Lemma onth_uniq (T:eqType) t (s:seq T) n :
    uniq s -> onth s n = Some t -> index t s = n.
  Proof.
    rewrite /onth => /uniqP uniq st. apply /(uniq t).
    - by rewrite unfold_in /= index_mem (onth_mem st).
    - by rewrite unfold_in /= (onth_lt st).
    - move : (st). rewrite (nth_map t) ?(onth_lt st) // =>[[->]].
      exact : nth_index (onth_mem st).
  Qed.

  Fixpoint mysorted T (R:rel T) (s:seq T) :=
    if s is x :: s' then all (fun y => R y x ==> R x y) s' && mysorted R s'
    else true.

  Lemma mysorted_cat T (R:rel T) s1 s2 :
    mysorted R s1 -> mysorted R s2 ->
    all (fun x => all (fun y => R y x ==> R x y) s2) s1 ->
    mysorted R (s1 ++ s2).
  Proof.
    elim : s1 =>[|x s1 IHs1]//=.
    rewrite all_cat => /andP [->] Hs1 Hs2 /andP [->]/=. exact : IHs1.
  Qed.

  Lemma subseq_mysorted (T:eqType) (R:rel T) s1 s2:
    subseq s1 s2 -> mysorted R s2 -> mysorted R s1.
  Proof.
    elim : s2 =>[|h2 s2 IH]//= in s1 *; [by move =>/eqP->|].
    case : s1 =>[|h1 s1]//=. case : ifP =>[/eqP->|_ s12 /andP[_/(IH _ s12)]]//.
    move => s12 /andP[/allP H2]/(IH _ s12)->. rewrite andbT.
      by apply /allP => z /(mem_subseq s12)/H2.
  Qed.

  Function qsort T (R:rel T) (s:seq T) {measure size s} :=
    if s is x :: s'
    then qsort R [seq y <- s' | R y x] ++ x :: qsort R [seq y <- s' | ~~ R y x]
    else [::].
  Proof.
    - move => T R _ x s _/=. apply /ltP. by rewrite ltnS size_filter count_size.
    - move => T R _ x s _/=. apply /ltP. by rewrite ltnS size_filter count_size.
  Defined.

  Lemma my_qsort_ind T (R:rel T) (P:seq T -> Prop) :
    P [::] ->
    (forall x s, P [seq y <- s | R y x] ->
                 P [seq y <- s | ~~ R y x] -> P (x :: s)) ->
    forall s, P s.
  Proof.
      move => Hnil Hcons s.
      have [n] := ubnP (size s). elim : n s =>[|n IHn][|xs s]//= Hsize.
        by apply : Hcons; exact : IHn (leq_ltn_trans (filter_size _ _) Hsize).
    Qed.

  Lemma all_qsort T (R:rel T) p s : all p (qsort R s) = all p s.
  Proof.
    elim /(@my_qsort_ind _ R) : s =>[|x s]//=.
    rewrite [qsort R (_ :: _)]qsort_equation all_cat /==>->->.
    case : (p x) =>/=; last exact : andbF. elim : s =>[|y s]//=.
    case : ifP =>_/=<-; case : (p y)=>//=. exact : andbF.
  Qed.

  Lemma qsort_sorted T (R:rel T) s : transitive R -> mysorted R (qsort R s).
  Proof.
    move => Htrans.
    elim /(@my_qsort_ind _ R) : s =>[|x s IHs1 IHs2]//.
    rewrite qsort_equation. apply : mysorted_cat =>//=.
    - rewrite IHs2 andbT all_qsort.
        by apply : (sub_all _ (filter_all _ _)) => y /negbTE ->.
    - rewrite all_qsort.
      apply : (sub_all _ (filter_all _ _)) => y Hyx.
      rewrite Hyx implybT all_qsort /=.
      apply : (sub_all _ (filter_all _ _)) => z.
      case Hzy : (R z y)=>//. by rewrite (Htrans _ _ _ Hzy Hyx).
  Qed.

  Lemma perm_qsort (T:eqType) (R:rel T) s: perm_eq (qsort R s) s.
  Proof.
    elim /(@my_qsort_ind _ R) : s =>[|x s IHs1 IHs2]//.
    rewrite qsort_equation perm_catC /= perm_cons perm_sym
    -(perm_filterC (R^~ x)) perm_catC perm_sym. exact : perm_cat.
  Qed.

  Lemma qsort0 T (s:seq T) : qsort (fun _ _ => false) s = s.
  Proof.
    elim /(@my_qsort_ind T (fun _ _ => false)) : s =>[|x s IH1 IH2]//.
      by rewrite qsort_equation IH1 IH2 filter_pred0 filter_predT.
  Qed.
End Seq.

Section PUndup.
  Variable (T S:eqType).
  Variable (X:eqType).

  Function pUndup (s:seq (T * S * X)) {measure size s} : seq (T * S * X) :=
    match s with
    | [::] => [::]
    | h :: s => h :: pUndup [seq x <- s | h.1.1 != x.1.1 & h.1.2 != x.1.2 ]
    end.
  Proof.
    move => s' h s _. apply /ltP. exact : filter_size.
  Defined.

  Lemma my_pUndup_ind (P:seq (T * S * X) -> Prop) :
    P [::] ->
    (forall h s, P [seq x <- s | h.1.1 != x.1.1 & h.1.2 != x.1.2 ] ->
                 P (h :: s)) ->
    forall s, P s.
  Proof.
    move => Hnil Hcons s.
    have [n] := ubnP (size s).
    elim : n s =>[|n IH][|h s]//=. rewrite ltnS => Hsize. apply /Hcons /IH.
    exact : leq_ltn_trans (filter_size _ _) Hsize.
  Qed.

  Lemma pUndup_subseq s : subseq (pUndup s) s.
  Proof.
    elim /my_pUndup_ind : s =>[|h s IH]//=. rewrite pUndup_equation eq_refl.
    exact : subseq_trans IH (filter_subseq _ _).
  Qed.

  Lemma pUndup_uniquel s x y:
    x \in pUndup s -> y \in pUndup s -> x.1.1 = y.1.1 -> x = y.
  Proof.
    elim /my_pUndup_ind : s =>[|h s IH]//. rewrite pUndup_equation !in_cons.
    case : (x =P h) (y =P h) =>[->|xh][->|yh]//=.
    - move =>_ /(mem_subseq (pUndup_subseq _)).
        by rewrite mem_filter =>/andP[/andP[/eqP]].
    - move =>/(mem_subseq (pUndup_subseq _)).
        by rewrite mem_filter eq_sym =>/andP[/andP[/eqP]].
  Qed.

  Lemma pUndup_uniquer s x y:
    x \in pUndup s -> y \in pUndup s -> x.1.2 = y.1.2 -> x = y.
  Proof.
    elim /my_pUndup_ind : s =>[|h s IH]//. rewrite pUndup_equation !in_cons.
    case : (x =P h) (y =P h) =>[->|xh][->|yh]//=.
    - move =>_/(mem_subseq (pUndup_subseq _)).
        by rewrite mem_filter =>/andP[/andP[_/eqP]].
    - move =>/(mem_subseq (pUndup_subseq _)).
        by rewrite mem_filter [h.1.2 == _]eq_sym =>/andP[/andP[_/eqP]].
  Qed.

  Lemma pUndup_maximal s x:
    x \in s -> has (fun m => (m.1.1 == x.1.1) || (m.1.2 == x.1.2)) (pUndup s).
  Proof.
    elim /my_pUndup_ind : s =>[|h s IH]//. rewrite pUndup_equation in_cons.
    case : (x =P h) =>[->|_ xs]/=; [by rewrite eq_refl|].
    rewrite -implyNb negb_or. apply /implyP =>H. apply : IH.
      by rewrite mem_filter H.
  Qed.

  Lemma pUndup_minimal s x:
    x \in s ->
          has (fun m => ((m.1.1 == x.1.1) || (m.1.2 == x.1.2)) && behind s m x)
              (pUndup s).
  Proof.
    elim /my_pUndup_ind : s =>[|h s IH]// Hx. rewrite pUndup_equation /=.
    rewrite -implyNb negb_and negb_or.
    apply /implyP =>/orP[]; [|by rewrite behind_head Hx].
    move : Hx. rewrite in_cons =>/orP[/eqP->|xs H]; [by rewrite eq_refl|].
    apply : (sub_has _ (IH _)) =>[z /andP[]|]; [|by rewrite mem_filter H].
    rewrite /behind /=.
    case : ifP H =>[/eqP->/andP[/negbTE->/negbTE->]|_ hx zx]//. rewrite zx /=.
    elim : s {xs IH}=>[|h' s IH]//=.
    case : ifP =>_/=.
    - case : ifP =>[/eqP<-|]//. apply /mem_subseq =>/=.
        by rewrite eq_refl filter_subseq.
    - case : ifP =>[/eqP<-/mem_behind|]//. apply /mem_subseq.
      exact : subseq_trans (filter_subseq _ _) (subseq_cons _ _).
  Qed.

End PUndup.

Section Pairs.
  Variable (T S:finType).

  Fixpoint pairs_def (fs:S -> seq T) (t:T) (ss:seq S) (nt:nat) :
    seq (T * S * (nat * nat)) :=
    match ss with
    | [::] => [::]
    | s :: ss => let st := fs s in
                 let ns := index t st in
                 if ns < size st
                 then (t,s,(nt,ns)) :: pairs_def fs t ss nt.+1
                 else pairs_def fs t ss nt.+1
    end.

  Lemma pairs_def_index (fs:S -> seq T) (ss:seq S) t s n:
    (t \in fs s) && (s \in ss) ->
    (t,s,(index s ss + n,index t (fs s))) \in pairs_def fs t ss n.
  Proof.
    move =>/andP[Ht Hs].
      elim : ss =>[|h ss IH]//= in Hs n *. move : Hs. rewrite in_cons eq_sym.
      case : ifP =>[/eqP->|_/IH/(_ n.+1)]/=.
      * by rewrite index_mem Ht add0n mem_head.
      * rewrite addnS addSn. case : ifP =>[_|_->]//. rewrite in_cons =>->.
        exact : orbT.
  Qed.

  Lemma ex_pairs_defP (fs:S -> seq T) (xt:T) (ss:seq S) t s n:
    reflect (exists nt ns, (t,s,(nt,ns)) \in pairs_def fs xt ss n)
            [&& t == xt, (t \in fs s) & (s \in ss)].
  Proof.
    apply (iffP and3P)=>[[/eqP<- Ht Hs]|[nt][ns]].
    - exists (index s ss + n), (index t (fs s)).
      apply : pairs_def_index. by rewrite Ht Hs.
    - elim : ss =>[|h ss IH]//= in n *. rewrite index_mem in_cons.
      case : ifP =>[|_/IH[->->->]]; [|by rewrite orbT].
        by rewrite !in_cons => Hh /orP[/eqP[->->_ _]|/IH[->->->]];
                                 [rewrite !eq_refl Hh|rewrite orbT].
  Qed.

  Lemma mem_pairs_def (fs:S -> seq T) (xt:T) (ss:seq S) t s nt ns n:
    (t,s,(nt,ns)) \in pairs_def fs xt ss n ->
                      [/\ t == xt, (t \in fs s) & (s \in ss)].
  Proof.
    move => H. apply /and3P /ex_pairs_defP. exists nt; exists ns. exact : H.
  Qed.

  Lemma pairs_defP (fs:S -> seq T) (xt:T) (ss:seq S) t s nt ns n:
    (forall s, uniq (fs s)) -> uniq ss ->
    reflect [&& t == xt, n <= nt, onth (fs s) ns == Some t &
                                  onth ss (nt - n) == Some s]
            ((t,s,(nt,ns)) \in pairs_def fs xt ss n).
  Proof.
    move => uniqt uniqs.
    apply /(iffP idP).
    - elim : ss {uniqs} =>[|h ss IH]//= in n *. case : ifP =>[|_/IH].
      + rewrite index_mem in_cons => Ht /orP[/eqP[->-><-->]|/IH].
        * by rewrite subnn onth0 onth_index // !eq_refl /= !andbT.
        * case : nt {IH}=>[|nt]; [by case /and4P|move =>/and3P[/eqP->[Hlt]]].
            by rewrite eq_refl subSS subSn // ltnW.
      + case : nt {IH}=>[|nt]; [by case /and3P|move =>/and3P[/eqP->Hlt]].
          by rewrite eq_refl subSS subSn //= ltnW.
    - elim : ss uniqs =>[_|h ss IH /andP[Hh uniqs]]/= in nt n *;
                    [by rewrite /onth /= nth_nil =>/and4P[]|].
      case : ifP =>[|Hlt /and4P[txt]].
      + rewrite index_mem in_cons => ht /and4P[txt].
        case : ltngtP =>[Hlt _ Ht Hs||->_/eqP/(onth_uniq (uniqt _))<-]//.
        * apply /orP. right. apply /IH=>//. move : Ht Hs =>->.
          case : nt =>[|nt]// in Hlt *. by rewrite txt /onth Hlt subSS subSn.
        * move /eqP : txt =>->. rewrite /onth subnn /==>/eqP[<-].
            by rewrite eq_refl.
      + case : ltngtP =>[||->_ /eqP/onth_mem Ht /eqP Hs]//.
        * case : nt =>[|nt]// Hn _ Ht. rewrite subSn // onth_cons => Hs.
          apply /IH =>//. apply /and4P. by split.
        * move /eqP : txt Hs Ht Hlt =>->.
            by rewrite subnn onth0 index_mem =>[[->]]->.
  Qed.

  Definition pairs (ft:T -> seq S) (fs:S -> seq T) :
    seq (T * S * (nat * nat)) :=
    flatten (codom (fun t => pairs_def fs t (ft t) 0)).

  Lemma pairs_index (ft:T -> seq S) (fs:S -> seq T) (t:T) (s:S):
    (t \in fs s) && (s \in ft t) ->
    (t,s,(index s (ft t),index t (fs s))) \in pairs ft fs.
  Proof.
    move /pairs_def_index. move /(_ 0). rewrite addn0 => H. apply /flattenP.
    exists (pairs_def fs t (ft t) 0) =>//. apply /codomP. by exists t.
  Qed.

  Lemma ex_pairsP (ft:T -> seq S) (fs:S -> seq T) (t:T) (s:S):
    reflect (exists nt ns, (t,s,(nt,ns)) \in pairs ft fs)
            ((t \in fs s) && (s \in ft t)).
  Proof.
    apply /(iffP idP)
    =>[H|[nt][ns]/flattenP[x/codomP[xt->]/mem_pairs_def[/eqP<-->->]]]//.
    have /ex_pairs_defP : [&& t == t, t \in fs s & s \in ft t]
      by rewrite eq_refl.
    case /(_ 0) =>[nt][ns] Hts. exists nt, ns.
    apply /flattenP. exists (pairs_def fs t (ft t) 0) =>//.
    apply /codomP. by exists t.
  Qed.

  Lemma mem_pairs (ft:T -> seq S) (fs:S -> seq T) (t:T) (s:S) nt ns:
    (t,s,(nt,ns)) \in pairs ft fs -> (t \in fs s) && (s \in ft t).
  Proof.
    move => H. apply /ex_pairsP. by exists nt, ns.
  Qed.

  Lemma pairsP (ft:T -> seq S) (fs:S -> seq T) (t:T) (s:S) nt ns:
    (forall t, uniq (fs t)) -> (forall s, uniq (ft s)) ->
    reflect ((onth (fs s) ns == Some t) && (onth (ft t) nt == Some s))
            ((t,s,(nt,ns)) \in pairs ft fs).
  Proof.
    move => uniqs uniqt.
    apply /(iffP flattenP)
    =>[[ss /codomP[xt->]/(pairs_defP _ _ _ _ _ _ uniqs (uniqt _))
           /and4P[/eqP-> _->]]|/andP[Ht Hs]]; [by rewrite subn0|].
    exists (pairs_def fs t (ft t) 0).
    - apply /codomP. by exists t.
    - apply /pairs_defP =>//. by rewrite eq_refl subn0 Ht Hs.
  Qed.
End Pairs.

Section MkCouple.
  Variable (R:rel (nat * nat)).
  Variable (T S:finType).

  Definition mkCouple (ft:T -> seq S) (fs:S -> seq T) :
    seq (T * S * (nat * nat)) :=
    pUndup (qsort (fun x y => R x.2 y.2) (pairs ft fs)).

  Lemma mkCouple_kindness (ft:T -> seq S) (fs:S -> seq T) t s nt ns :
    (t,s,(nt,ns)) \in mkCouple ft fs -> (t \in fs s) && (s \in ft t).
  Proof.
    move /(mem_subseq (pUndup_subseq _)).
    by rewrite (perm_mem (perm_qsort _ _))=>/mem_pairs.
  Qed.

  Lemma mkCouple_uniquel (ft:T -> seq S) (fs:S -> seq T) t s s' nt nt' ns ns':
    (t,s,(nt,ns)) \in mkCouple ft fs ->
                      (t,s',(nt',ns')) \in mkCouple ft fs ->
                                           [/\ s = s', nt = nt' & ns = ns'].
  Proof.
    move => H H'. by case : (pUndup_uniquel H H' (erefl _)).
  Qed.

  Lemma mkCouple_uniquer (ft:T -> seq S) (fs:S -> seq T) t t' s nt nt' ns ns':
    (t,s,(nt,ns)) \in mkCouple ft fs ->
                      (t',s,(nt',ns')) \in mkCouple ft fs ->
                                           [/\ t = t', nt = nt' & ns = ns'].
  Proof.
    move => H H'. by case : (pUndup_uniquer H H' (erefl _)).
  Qed.

  Lemma mkCouple_maximal (ft:T -> seq S) (fs:S -> seq T) t s:
    (t \in fs s) && (s \in ft t) ->
    has (fun m => (m.1.1 == t) || (m.1.2 == s)) (mkCouple ft fs).
  Proof.
    case /ex_pairsP =>[nt][ns].
    rewrite -(perm_mem (perm_qsort (fun x y => R x.2 y.2) _)).
    exact : pUndup_maximal.
  Qed.

  Hypothesis (Htrans: transitive R).

  Lemma mkCouple_minimal (ft:T -> seq S) (fs:S -> seq T) t s:
    (t \in fs s) && (s \in ft t) ->
    has (fun m => ((m.1.1 == t) || (m.1.2 == s)) &&
                  let x := (index s (ft t), index t (fs s)) in
                  (R x m.2 ==> R m.2 x))
        (mkCouple ft fs).
  Proof.
    move => /pairs_index ts. move : (ts).
    rewrite -(perm_mem (perm_qsort (fun x y => R x.2 y.2) _))
               =>/pUndup_minimal.
    apply : sub_has => m /=/andP[->]/behindP/orP[|/andP[/eqP->_]];
                         [|exact /implyP].
    have sndtrans : transitive (fun x y: (T * S * (nat * nat)) => R x.2 y.2)
      := fun _ _ _ xy yz => Htrans xy yz.
    move =>/subseq_mysorted. move =>/(_ _ (qsort_sorted _ sndtrans))/=.
      by rewrite !andbT.
  Qed.

End MkCouple.


(** * Beta-reduction definition and properties.*)
Require Import base ut_term.
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt Plus.

Module Type ut_red_mod (X:term_sig)  (TM : ut_term_mod X).
 Import TM.

(** ** Usual Beta-reduction:
 - one step
 - multi step (reflexive, transitive closure)
 - converesion (reflexive, symetric, transitive closure)
 *)
Reserved Notation " A → B " (at level 80).

Inductive Beta : Term -> Term -> Prop :=
 | Beta_head : forall A M  N , (λ[A], M)· N → M [← N]
 | Beta_red1 : forall M M' N , M → M' -> M · N  → M'· N
 | Beta_red2 : forall M N  N', N → N' -> M · N  → M · N'
 | Beta_lam  : forall A M  M', M → M' -> λ[A],M → λ[A ],M'
 | Beta_lam2 : forall A A' M , A → A' -> λ[A],M → λ[A'],M
 | Beta_pi   : forall A B  B', B → B' -> Π(A),B → Π(A ),B'
 | Beta_pi2  : forall A A' B , A → A' -> Π(A),B → Π(A'),B
where "M → N" := (Beta M N) : UT_scope.

Reserved Notation " A →→ B " (at level 80).

Inductive Betas : Term -> Term -> Prop :=
 | Betas_refl  : forall M    , M →→ M
 | Betas_Beta  : forall M N  , M → N  -> M →→ N
 | Betas_trans : forall M N P, M →→ N -> N →→ P -> M →→ P
where  " A →→ B " := (Betas A B) : UT_scope.

Reserved Notation " A ≡ B " (at level 80).

Inductive Betac : Term -> Term -> Prop :=
 | Betac_Betas : forall M N  , M →→ N -> M ≡ N
 | Betac_sym   : forall M N  , M ≡ N  -> N ≡ M
 | Betac_trans : forall M N P, M ≡ N   -> N ≡ P -> M ≡ P
where " A ≡ B " := (Betac A B)  : UT_scope.

Hint Constructors Beta.
Hint Constructors Betas.
Hint Constructors Betac.

(** Facts about [Betas] and [Betac]: Congruence. *)
Lemma Betac_refl : forall M, M ≡ M.
intros; constructor; constructor.
Qed.

Hint Resolve Betac_refl.

Lemma Betas_App : forall M M' N N',M →→ M' -> N →→ N' -> M · N →→ M' · N'.
assert (forall a b c, b →→ c ->  a·b →→ a·c).
induction 1; eauto.
assert (forall a b c, b→→c -> b· a →→ c· a).
induction 1; eauto.
intros; eauto.
Qed.

Hint Resolve Betas_App.

Lemma Betac_App : forall M M' N N' , M ≡ M' -> N ≡ N' -> M · N ≡ M' · N'.
assert (forall a b c, b ≡ c ->  a· b ≡ a· c).
induction 1; eauto.
assert (forall a b c , b ≡ c -> b·a ≡ c·a).
induction 1; eauto.
eauto.
Qed.

Hint Resolve Betac_App.

Lemma Betas_La : forall A A' M M', A →→ A' -> M →→ M' -> λ[A],M →→ λ[A'],M'.
assert (forall a b c , a →→ b -> λ[c],  a →→ λ[c], b).
induction 1; eauto.
assert (forall a b c, a →→ b -> λ[a], c →→ λ[b], c).
induction 1; eauto.
eauto.
Qed.

Hint Resolve Betas_La.

Lemma Betac_La: forall A A' M M', A ≡ A' -> M ≡ M' -> λ[A],M ≡ λ[A'],M'.
assert (forall a b c, a ≡ b -> λ[c], a ≡ λ[c], b).
induction 1; eauto.
assert (forall a b c, a ≡ b -> λ[a], c ≡ λ[b], c).
induction 1; eauto.
eauto.
Qed.

Hint Resolve Betac_La.

Lemma Betas_Pi : forall A A' B B', A →→ A' -> B →→ B' -> Π(A),B →→ Π(A'),B'.
assert (forall a b c , a →→ b -> Π (c), a →→ Π(c), b).
induction 1; eauto.
assert (forall a b c, a →→ b -> Π(a), c →→ Π(b), c).
induction 1; eauto.
eauto.
Qed.

Hint Resolve Betas_Pi.

Lemma Betac_Pi : forall A A' B B', A ≡ A' -> B ≡ B' -> Π(A),B ≡ Π(A'),B'.
assert (forall a b c , a ≡ b -> Π(c), a ≡ Π(c), b).
induction 1; eauto.
assert (forall a b c, a ≡ b -> Π(a), c ≡ Π(b), c).
induction 1; eauto.
eauto.
Qed.

Hint Resolve Betac_Pi.

Lemma Beta_beta : forall M N P n,  M → N ->  M[n←P] → N[n←P] .
intros.
generalize n.
induction H; intros; simpl; intuition.
rewrite (subst_travers).
replace (n0+1) with (S n0).
constructor.
rewrite plus_comm. trivial.
Qed.

(** Some "inversion" lemmas :
 - a variable/sort cannot reduce at all
 - a pi/lam can only reduce to another pi/lam
 - ...
*)
Lemma Betas_V : forall x N, #x →→ N -> N = #x.
intros. remember #x as X; induction H; trivial.
subst; inversion H.
transitivity N. apply IHBetas2. rewrite <- HeqX; intuition. intuition.
Qed.

Lemma Betas_S : forall s N, !s →→ N -> N = !s.
intros. remember !s as S; induction H; trivial.
subst; inversion H.
transitivity N. apply IHBetas2. rewrite <- HeqS; intuition. intuition.
Qed.

Lemma Betas_Pi_inv : forall A B N, Π(A), B →→ N ->
  exists C, exists D, N = Π(C), D /\ A →→ C /\ B →→ D.
intros.
remember (Π(A), B) as P. revert A B HeqP; induction H; intros; subst; eauto.
inversion H; subst; clear H.
exists A; exists B'; intuition.
exists A'; exists B; intuition.
destruct (IHBetas1 A B) as (C' & D' & ?); intuition.
destruct (IHBetas2 C' D') as (C'' & D'' &?); intuition.
exists C''; exists D''; eauto.
Qed.

(** Lift properties.*)
Lemma Beta_lift: forall M N  n m, M → N -> M ↑ n # m → N ↑ n # m .
intros.
generalize n m; clear n m.
induction H; intros; simpl; eauto.
change m with (0+m).
rewrite substP1.
constructor.
Qed.

Lemma Betas_lift : forall M N n m , M →→ N -> M ↑ n # m →→ N ↑ n # m .
intros.
induction H.
constructor.
constructor; apply Beta_lift; intuition.
apply Betas_trans with (N:= N ↑ n # m ); intuition.
Qed.

Lemma Betac_lift : forall M N n m, M ≡ N -> M ↑ n # m ≡ N ↑ n # m .
intros.
induction H.
constructor.
apply Betas_lift; trivial.
apply Betac_sym; trivial.
apply Betac_trans with (N ↑ n # m); trivial.
Qed.

Hint Resolve Beta_lift Betas_lift Betac_lift.

(** Subst properties.*)
Lemma Betas_subst : forall M P P' n, P →→ P' -> M [n←P] →→ M[n← P'].
induction M; intros; simpl; eauto.
destruct (lt_eq_lt_dec v n); intuition.
Qed.

Hint Resolve Betas_subst.

Lemma Betas_subst2 : forall M N P n, M →→ N -> M [n← P] →→ N [n ← P].
induction 1; eauto.
constructor. apply Beta_beta; intuition.
Qed.

Hint Resolve Betas_subst2.

Lemma Betac_subst : forall M P P' n, P ≡ P' -> M[n←P] ≡ M [n←P'].
induction M; simpl; intros; intuition.
destruct (lt_eq_lt_dec v n); intuition.
Qed.

Lemma Betac_subst2 : forall M N P n,
  M ≡ N -> M[n←P] ≡ N[n← P] .
induction 1; eauto.
Qed.

Hint Resolve Betac_subst Betac_subst2.

(** ** Parallel Reduction
We use the parallel reduction to prove that [Beta] is confluent.*)
Reserved Notation "M →' N" (at level 80).

(** Beta parallel definition. *)
Inductive Betap : Term -> Term -> Prop :=
 | Betap_sort : forall s          , !s →' !s
 | Betap_var  : forall x          , #x →' #x
 | Betap_lam  : forall A A' M M'  , A →' A' -> M →' M' -> λ[A],M →' λ[A'],M'
 | Betap_pi   : forall A A' B B'  , A →' A' -> B →' B' -> Π(A),B →' Π(A'),B'
 | Betap_app  : forall M M' N N'  , M →' M' -> N →' N' -> M · N  →' M' · N'
 | Betap_head : forall A M M' N N', M →' M' -> N →' N' -> (λ[A],M)· N →' M'[← N']
where "M →' N" := (Betap M N) : UT_scope.

Notation "m →' n" := (Betap m n) (at level 80) : UT_scope.

Hint Constructors Betap.

Lemma Betap_refl : forall M, M →' M.
induction M; eauto.
Qed.

Hint Resolve Betap_refl.

(** Lift and Subst property of [Betap].*)
Lemma Betap_lift: forall M N n m, M →' N -> M ↑ n # m →' N ↑ n # m .
intros.
revert n m.
induction H; simpl; intuition.
change m with (0+m).
rewrite substP1.
constructor; intuition.
Qed.

Hint Resolve Betap_lift.

Lemma Betap_subst:forall M M' N N' n, M →' M'  -> N →' N' -> M[n←N] →' M'[n←N'].
intros. revert n.
induction H; simpl; intuition.
destruct lt_eq_lt_dec; intuition.
rewrite subst_travers. replace (S n) with (n+1) by (rewrite plus_comm; trivial). constructor; intuition.
Qed.

Hint Resolve Betap_subst.

(** [Betap] has the diamond property. *)
Lemma Betap_diamond : forall M N P,
   M →' N -> M →' P -> exists Q, N →' Q /\ P →' Q.
intros.
revert P H0.
induction H; intros.
(**)
exists P; intuition.
(**)
exists P; intuition.
(**)
inversion H1; subst; clear H1.
destruct (IHBetap1 A'0 H4) as (A'' & ? & ?).
destruct (IHBetap2 M'0 H6) as (M'' & ?& ?).
exists (λ[A''],M''); intuition.
(**)
inversion H1; subst; clear H1.
destruct (IHBetap1 A'0 H4) as (A'' & ? & ?).
destruct (IHBetap2 B'0 H6) as (B'' & ?& ?).
exists (Π(A''), B''); intuition.
(**)
inversion H1; subst; clear H1.
destruct (IHBetap1 M'0 H4) as (M'' & ?& ?).
destruct (IHBetap2 N'0 H6) as (N'' & ?& ?).
exists (M'' · N''); intuition.
inversion H; subst; clear H.
destruct (IHBetap2 N'0 H6) as (N'' & ?& ?).
destruct (IHBetap1 (λ[A],M'0)) as  (L & ?& ?); intuition.
inversion H2; subst; clear H2; inversion H5; subst; clear H5.
exists ( M' [ ← N'']); intuition.
(**)
inversion H1; subst; clear H1.
destruct (IHBetap2 N'0 H6) as (N'' & ?& ?).
inversion H4; subst; clear H4.
destruct (IHBetap1 M'1 H9) as (M'' & ?& ?).
exists (M''[← N'']); intuition.
destruct (IHBetap2 N'0 H7) as (N'' & ?& ?).
destruct (IHBetap1 M'0 H6) as (M'' & ?& ?).
exists (M''[← N'']); intuition.
Qed.

(** Reflexive Transitive closure of [Betap].*)
Reserved Notation " x  →→' y " (at level 80).

Inductive Betaps : Term -> Term -> Prop :=
 | Betaps_refl  : forall M    , M →→' M
 | Betaps_trans : forall M N P, M  →' N -> N  →→' P -> M  →→' P
where " x  →→' y " := (Betaps x y) : UT_scope.

Hint Constructors Betaps.

(** Closure properties to relate [Betaps] and [Betas].*)
Lemma Betas_Betap_closure : forall M N , M →' N -> M →→ N.
induction 1; eauto.
Qed.

Local Hint Resolve Betas_Betap_closure.

Lemma Betas_Betaps_closure : forall M N,  M →→' N -> M →→  N.
induction 1; eauto.
Qed.

Lemma Betap_Beta_closure : forall M N, M → N -> M →' N.
induction 1; intuition.
Qed.

Local Hint Resolve Betas_Betaps_closure Betap_Beta_closure.

Lemma Betaps_Beta_closure :forall M N, M → N -> M →→' N.
eauto.
Qed.

Local Hint Resolve Betaps_Beta_closure.

Lemma Betaps_trans2 : forall M N P, M →→' N -> N →→' P  -> M →→' P.
intros. revert P H0; induction H; eauto.
Qed.

Local Hint Resolve Betaps_trans2.

Lemma Betaps_Betas_closure : forall M N , M →→ N -> M →→' N.
induction 1; eauto.
Qed.

Local Hint Resolve Betaps_Betas_closure.

(** [Betas] inherites its diamond property from [Betaps].*)
Lemma sub_diamond_Betaps :
(   forall M N P, M →' N -> M →'  P -> exists Q, N →'  Q /\ P →' Q )
 -> forall M N P, M →' N -> M →→' P -> exists Q, N →→' Q /\ P →' Q .
intros.
revert N H0. induction H1; eauto.
intros.
destruct (H M N N0 H0 H2) as (Q & ?& ?).
destruct (IHBetaps Q H3) as (Q'' & ? & ?).
exists Q''; eauto.
Qed.

Lemma diamond_Betaps :
( forall M N P, M →'  N -> M →'  P -> exists Q, N →'  Q /\ P →'  Q)  ->
  forall M N P, M →→' N -> M →→' P -> exists Q, N →→' Q /\ P →→' Q .
intros.  revert P H1.
induction H0; intros; eauto.
destruct (sub_diamond_Betaps H M N P0 H0 H2) as (Q & ? & ?).
destruct (IHBetaps Q H3) as (Q'' & ?& ?).
exists Q'';eauto.
Qed.

Theorem Betas_diamond:
  forall M N P, M →→ N -> M →→ P -> exists Q, N →→ Q /\ P →→ Q.
intros.
destruct (diamond_Betaps Betap_diamond M N P) as (Q & ?& ?); intuition.
exists Q; intuition.
Qed.

(** So [Beta] is confluent.*)
Theorem Betac_confl : forall M N, M ≡ N -> exists Q, M →→ Q /\ N →→ Q.
induction 1; eauto. destruct IHBetac as (Q & ? &? ); eauto.
destruct IHBetac1 as (Q1 & ? &? ), IHBetac2 as (Q2 & ? & ?).
destruct (Betas_diamond N Q1 Q2) as (Q'' & ?& ?); trivial.
exists Q''; eauto.
Qed.

(** Some consequences:
 - convertible sorts are equals
 - converitble vars are equals
 - Pi-types are Injective
 - Pi and sorts are not convertible
 *)
Lemma conv_sort : forall s t, !s ≡ !t -> s = t.
intros.
apply Betac_confl in H. destruct H as (z & ?& ?).
apply Betas_S in H.
apply Betas_S in H0.
rewrite H in H0.
injection H0; trivial.
Qed.

Lemma conv_to_sort : forall s T, !s ≡ T ->  T →→ !s.
intros.
apply Betac_confl in H.
destruct H as (z & ?& ?).
apply Betas_S in H.
subst. trivial.
Qed.

Lemma conv_var : forall x y, #x ≡ #y -> x = y.
intros.
apply Betac_confl in H. destruct H as (z & ?& ?).
apply Betas_V in H. apply Betas_V in H0.
rewrite H in H0.
injection H0; trivial.
Qed.

Lemma conv_to_var : forall x T , #x ≡ T -> T →→ #x.
intros.
apply Betac_confl in H.
destruct H as (z & ?& ?).
apply Betas_V in H.
subst; trivial.
Qed.

(* Pi is injective *)
Theorem PiInj : forall A B C D, Π(A), B ≡ Π(C), D ->  A ≡ C /\ B ≡ D.
intros.
apply Betac_confl in H. destruct H as (z & ? & ?).
apply Betas_Pi_inv in H.
apply Betas_Pi_inv in H0.
destruct H as (c1 & d1 & ? & ? & ?).
destruct H0 as (c2 & d2 & ? & ?& ?).
rewrite H0 in H; injection H; intros; subst; split; eauto.
Qed.

Lemma Betac_not_Pi_sort : forall A B s, ~ (Π(A), B ≡ !s ).
intros; intro. apply Betac_sym in H. apply conv_to_sort in H.
apply Betas_Pi_inv in H as (C & D & ? & ? & ?). discriminate.
Qed.

End ut_red_mod.


(* Check the behaviour of Injection *)

(* Check that Injection tries Intro until *)

Lemma l1 : forall x : nat, S x = S (S x) -> False.
 injection 1.
apply n_Sn.
Qed.

Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False.
 injection H.
intros.
apply (n_Sn x H0).
Qed.

(* Check that no tuple needs to be built *)
Lemma l3 :
 forall x y : nat,
 existS (fun n : nat => {n = n} + {n = n}) x (left _ (refl_equal x)) =
 existS (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) ->
 x = y.
intros x y H.
 injection H.
exact (fun H => H).
Qed.

(* Check that a tuple is built (actually the same as the initial one) *)
Lemma l4 :
 forall p1 p2 : {0 = 0} + {0 = 0},
 existS (fun n : nat => {n = n} + {n = n}) 0 p1 =
 existS (fun n : nat => {n = n} + {n = n}) 0 p2 ->
 existS (fun n : nat => {n = n} + {n = n}) 0 p1 =
 existS (fun n : nat => {n = n} + {n = n}) 0 p2.
intros.
 injection H.
exact (fun H => H).
Qed.

(* Test injection as *)

Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z.
intros; injection H as Hyt Hxz.
exact Hxz.
Qed.

(* Check the variants of injection *)

Goal forall x y, S x = S y -> True.
injection 1 as H'.
Undo.
intros.
injection H as H'.
Undo.
Ltac f x := injection x.
f H.
Abort.

Goal (forall x y : nat, x = y -> S x = S y) -> True.
intros.
try injection (H O) || exact I.
Qed.

Goal (forall x y : nat, x = y -> S x = S y) -> True.
intros.
einjection (H O).
instantiate (1:=O).
Abort.

(* Injection does not projects at positions in Prop... allow it?

Inductive t (A:Prop) : Set := c : A -> t A.
Goal forall p q : True\/True, c _ p = c _ q -> False.
intros.
injection H.
Abort.

*)

(* Injection does not project on discriminable positions... allow it?

Goal 1=2 -> 1=0.
intro H.
injection H.
intro; assumption.
Qed.

*)


Require Import Arith FinSummDefs  Omega JMeq ZArith Ring Containers.

(**
------
  Rewrites objects (from left to right) in foo Fin n using foo: Fin n -> nat,
    the function which reduces an object in Fin n to its representation in nat.
-- 1.  nat_finite_id: forall (n k:nat)(h:k<n), (foo (nat_finite k h)) = k.
-- 2.  finite_nat_id_general:
      forall (n:nat)(i:Fin n)(h:(foo i)<n),  (nat_finite (foo i) h) = i.
-- 3.  finite_nat_id:
      forall (n:nat)(i:Fin n), (nat_finite (foo i) (finite_lt_n i)) = i.
-- 4.  foo_emb : forall n (i : Fin n), foo (emb i) = foo i.
-- 5.  foo_rvtp:  forall n : nat, foo (rv (tp n)) = 0.
-- 6.  foo_tp : forall n, foo (tp n) = n.

*)

 Ltac foosimpl :=
      match goal with
      | [ |- context[foo (emb ?x) ]] =>
            let H := constr:(foo_emb x) in rewrite H
      | [ |- context[foo(rv (tp ?x))]] =>
           let H := constr:(foo_rvtp x) in rewrite H
      | [ |- context[foo(tp ?x)]] =>
           let H := constr:(foo_tp x) in rewrite H
      | |- context[(nat_finite (foo ?a) ?b)] =>
         match goal with
         | [ i : Fin ?n |- _ ] =>
             match goal with
             | [ H : (foo i) <  n |-  _ ] =>
                     let E := constr:(finite_nat_id_general i H) in rewrite E
             end
         end
      | [ n : nat, m : nat |- context[foo ?X] ] =>
            match type of X with
            | Fin n =>
                 match goal with
                 [ H : m < n  |- _ ]  =>
                  let E := constr:(nat_finite_id H) in rewrite E
                 end
            end
      | [ |- context [nat_finite (foo ?i) (finite_le_n ?i)] ] =>
             let H := constr:(finite_nat_id i) in rewrite H
     end.

  (** Repeatedly rewrite using foosimpl - rewriting all cases *)
  Ltac fooSimpl := repeat foosimpl.

 (** rewrites cases where 0 occur at the non-recursive argument *)
  Ltac rewrite_right_0' :=
    match goal with
    | [|- context [(?x - 0 ) ] ] =>
         match type of x with
          | nat => let H := constr:(minus_n_O x) in rewrite <- H
          end
    | [|-  context [(?x + 0 ) ] ] =>
         match type of x with
          | nat => let H := constr:(plus_n_O x) in rewrite <- H
          end
    | [|- context [(?x * 0 ) ]]  =>
         match type of x with
          | nat => let H := constr:(mult_0_r x) in rewrite  H
          end
    end.

   (* repeatedly rewrite cases with 0  at the non-recursive argument *)
   Ltac rewrite_right_0 := repeat rewrite_right_0'.

 (* rv i = n - i - i *)
 Lemma rv_foo_m1 : forall n (i : Fin n),  foo (rv i) = n - (foo i) - 1.
   induction i; simpl; foosimpl; rewrite_right_0; auto.
 Qed.

 (*

 rewrites using :
1. forall n m, (n + m - n) = m
2. n - n = 0
3. n <= m ->  n + (m - n) = m

*)
  Ltac minus_simpls :=
    match goal with
    | [|- context [(?n -?n)]] =>
          let H := constr:(minus_diag n) in rewrite H
    | [|- context [(?n + ?m - ?n) ]] =>
          let H := constr:(minus_plus n m) in rewrite H
    | [H : ?n <= ?m |- context[ ?n + (?m - ?n)]] =>
          let Eq := constr:(le_plus_minus_r _ _ H) in rewrite Eq
   end.

 Ltac minus_simpl := repeat minus_simpls.

 Ltac Foosimpl :=
    let rvFoo := (
         match goal with
         | [|- context[foo(rv ?x)]] =>
              let E := constr:(rv_foo_m1 x) in rewrite E
         end) in  repeat (rvFoo ||  foosimpl).

 Ltac FooSimpl := progress Foosimpl.

 (**  Obvious results that can be deduced form m < n  *)
 Lemma n_minus_le : forall (n m : nat), m <= n ->  (n - m - 1) <= n.
 Proof.
   intros; omega.
 Qed.

 Lemma n_minus_lt : forall (n m : nat), m < n ->  (n - m - 1) < n.
 Proof.
   intros; omega.
 Qed.

 Lemma one_minus_nm : forall (n m : nat), m < n -> 1 <= n - m.
 Proof.
    intros; omega.
 Qed.

 Lemma one_minus_nm_minus_1 : forall n m, m < n -> 1 <= n - (n - m - 1).
 Proof.
   intros; omega.
 Qed.

 (** check for a <= b and a < b in the context and then use the
    preceeding lemmas as assimptions *)
 Ltac nm_minus1 :=
   match goal with
   | [ H : ?a <= ?b , Hyp : ?a < ?b |- _ ] =>
       match type of a with
       | nat =>
          let H := constr:(n_minus_le _ _ H) in
            let H1 := constr:(one_minus_nm _ _ Hyp) in
              let H0 := constr:(one_minus_nm_minus_1 _ _ Hyp) in
                let h0 := fresh "h0" in
                  let h1 := fresh "h1" in
                    let h := fresh "h" in
                         set (h := H) ; set (h0 := H1); set (h1 := H0)
       end
   end.

   (** if there is a (n - (foo i)) or ((foo i) - n) in the goal, we may need
      to express the goal in terms of integers rather than natural numbers.
      Here we add (foo i) < n (and (foo i) <= n) to the context and some
      deductions from them, which facilitates the conversion to integers *)
   Ltac add_foo_le_lt :=
      let if_foo_minus_i tac T :=
          (match T with
            | context [ ((foo ?x) - ?y) ] => Foosimpl || tac
            | context [ (?x - (foo ?y)) ] => Foosimpl || tac
            | _ => fail 1
           end) in
       match goal with
       | [ i :  Fin ?n |- ( ?X = ?Y :> nat) ] =>
                  let set_le_lt :=
                     (let H := constr:(finite_le_n i) in
                        let H1 := constr:(finite_lt_n i) in
                          let H0 := fresh "H0" in let h := fresh "h" in
                               set (H0 := H) ; set (h := H1) ) in
                   repeat (if_foo_minus_i set_le_lt X) ; repeat (if_foo_minus_i set_le_lt Y)
        end.

  (** change equality between natural numbers to an equality between
    integers, then try solving it using the ring tactic*)
  Ltac natEq_to_Zeq :=
     match goal with
    | [|- (?X = ?Y :> nat) ] =>
          apply inj_eq_rev; try intros ;
            repeat      (match goal with
                   | [|- context[Z_of_nat(?x + ?y)]] =>
                       let Ijp := constr:(inj_plus x y) in rewrite Ijp
                   | [|- context[Z_of_nat(?x * ?y)]] =>
                       let Ijp := constr:(inj_mult x y) in rewrite Ijp
                   | [ H : ?a <= ?b |-  context[Z_of_nat(?b - ?a) ]] =>
                       let Ijp := constr:(inj_minus1 _ _ H) in rewrite Ijp
                   | [ H : ?a > ?b |- context[Z_of_nat(?b - ?a) ]] =>
                       let Ijp := constr:(inj_minus2 _ _ H) in rewrite Ijp
                  end) ; ring
    end.

  (*Ltac natEq_to_Zeq := repeat natEq_to_zeq. *)

 (* put them together *)
 Ltac foo_minus :=
  rewrite_right_0 ;
    (add_foo_le_lt ;  nm_minus1 ; minus_simpl ; natEq_to_Zeq) .

(*  Lemma test :
    forall (n : nat) ( i : Fin n),
     (n - (n - (foo i) - 1) - 1) = foo i  - (n +  (foo i) - n) + foo i.
    intros; foo_minus.
   Qed. *)

 (** * More arithmetic simplifications *)
  (* evaluations *)
   Definition lt_le_dec  n m : {n < m} + {~ n < m} :=
     match le_lt_dec m n with
     | left l => right (n < m) (le_not_lt m n l)
     | right l => left (~ n < m) l
     end.

 Lemma minus_gt_0 : forall n m, 0 < n - m -> m < n.
   intros; omega.
  Qed.

   Lemma not_minus : forall n m, ~(0 < n - m) -> m < n -> False.
     intros. omega.
   Qed.

   Lemma not_minus1 : forall n m, ~ 0 < n - (n - m - 1) -> m < n -> False.
     intros. omega.
   Qed.

  Lemma nminus_minus1 : forall a b, 0 < b -> a < b - (b - 1) -> a < 1.
    intros; omega.
  Qed.

   Lemma nm_minus_plus : forall n m, n < m - 1 -> n + 1 < m.
    intros; omega.
   Qed.

   Lemma minus1_nm a a0 : a0 < a -> a - (a - a0 - 1) - 1 = a0.
     intros;  omega.
   Qed.

(** Is this really necessary?  *)
  Ltac optimiseOmega_aux :=
     match goal with
     | [ H : ?m < ?n |- context[?n - ?m]] =>
             let h:= constr:(minus1_nm H) in rewrite h
     | [ H : ?m < ?n  |- _ ] =>
          match m with
          |  0  =>  match n with
                    | ?a - ?b =>
                       let h := constr:(minus_gt_0 _ _ H) in generalize h; clear H; intros
                   end
          end
     | [ H : ?a < ?b - 1  |- _] =>
           let K := constr:(nm_minus_plus H) in generalize K; clear H; intros

     | [ H : ~(?a  < ?n - ?m) , H1 : ?m < ?n |- _ ] =>
           match a with
           | 0 => let Cn := constr:(not_minus  H H1) in destruct Cn
           end
     | [H : ~ ?a < ?n - (?n - ?m - ?k) , H1 : ?m < ?n |- _] =>
       match a with
       | 0 => match k with
              | 1 =>  let K := constr:(not_minus1  H H1) in destruct K
              end
       end

    | [H : 0 < ?b , H1 : ?a < ?b - (?b - 1) |- _ ] =>
             let K := constr:(nminus_minus1 H H1) in generalize K;
                      clear H; clear H1; intros
     | [ H : ?X |- _ ] =>
         match X with
         | context[match ?y with
                   | 0 => ?K
                   | S _ => ?K1
                   end ] =>  destruct y
         | context[lt_le_dec ?x ?y] => destruct (lt_le_dec x y)
         end
      (* simplify vlast * )
      | [ H : ?X |- _ ] =>
          let simpV := unfold vlast in *; unfold vhead in *; unfold vtail in *; simpl in * in
             match X with
             | context[vlast] => simpV
             | context[vfirst] => simpV
             end *)
     (* remove duplicate and redundant hypotheses*)
     |[ H : ?a < ?b ,  H1 : ?a < ?b |- _ ] => clear H1
     |[ H : ?a < ?b ,  H1 : ?b > ?a |- _ ] => clear H1
     |[ H : ?a < ?b ,  H1 : ?a <= ?b |- _ ] => clear H1
     |[ H : ?a < ?b ,  H1 : ?b >= ?a |- _ ] => clear H1

     |[ H : ?a > ?b ,  H1 : ?a > ?b |- _ ] => clear H1
     |[ H : ?a > ?b ,  H1 : ?b < ?a |- _ ] => clear H1
     |[ H : ?a > ?b ,  H1 : ?a >= ?b |- _ ] => clear H1
     |[ H : ?a > ?b ,  H1 : ?b <= ?a |- _ ] => clear H1

     |[ H : ?a <= ?b ,  H1 : ?a <= ?b |- _ ] => clear H1
     |[ H : ?a <= ?b ,  H1 : ?b >= ?a |- _ ] => clear H1
     | [ H : ?a - ?b - ?c < ?a ,   H1 : ?b < ?a  |- _ ] =>  match c with
                                                           | 1 => clear H
                                                           end
     | [ H : ?a - ?b  < ?a ,   H1 : ?b < ?a  |- _ ] => clear H
    (* no do the same for integers  *)
     end.

(**
------
 end of arithemetic conversion and simplification
------
*)

 (* Given an equality H :  t1 = t2 or H1 : JMeq t1 = t2, the tactic
    "add_eq_then_tac H tac" adds H to the local context if H or
     its symmetry does not already exist in the context, or it adds
     K if K is equivalent to H   *)

  Ltac add_hyp_then_aux1 H tac :=
   match type of H with
   | ?t1 = ?t2 =>
         match goal with
         | id : context [t1] |- _ =>
             match type of id with
              | t1 = t2 => fail 2
              | t2 = t1 => fail 2
              | t1 = ?t3 => let E := constr:(sym_eq H) in
                              let H1 := constr:(trans_eq E id) in
                                  add_hyp_then_aux1 H1 tac
              end
         | _ =>  let Hyp := fresh "Hyp" in set (Hyp := H); tac
         end
    | JMeq ?t1 ?t2 =>
          match goal with
         | id : context [t1] |- _ =>
             match type of id with
              | JMeq t1 t2 => fail 2
              | JMeq t2 t1 => fail 2
              | JMeq t1 ?t3 => let E := constr:(sym_JMeq H) in
                                 let H1 := constr:(trans_JMeq E id) in
                                    add_hyp_then_aux1 H1 tac
              end
         | _ =>  let Hyp := fresh "Hyp" in set (Hyp := H); tac
         end
    end.

 Ltac add_hyp_then_tac H tac :=
   match type of H with
   | ?t1 = ?t2 =>
           add_hyp_then_aux1 H tac
   | JMeq ?t1 ?t2 =>
            add_hyp_then_aux1 H tac
  end.

 (** naieve heuristic to determine whether to use finSN or finEmtp *)
 Ltac finSn_dest H :=
    match goal with
    | [  |- context [finEmtp ?i]] =>   destruct (finEmtp i)
         (*match i with
         | H =>  destruct (finEmtp i)
         end *)
    | _ => destruct (finSN H)
    end.

 (** * FSimpl  *)
 Ltac Finsimpl :=
   let finsplit_destruct H N :=
        (let fin_decomp H1 N1 :=
           (match N1 with
            | context [ ?a * ?b ] => destruct (fintimes _ _ H1)
            | S _  => finSn_dest H1
            | ?K    => let k := eval compute in K in
                          match k with
                          | 0    => inversion H1
                          end
            end) in

      match goal with
      | [  i : Fin ?n |- _ ] =>
          match goal with
          | _ => match N with
                 | ?n  + ?m =>
                   match goal with
                   | [ i : Fin ?M |- _ ] =>
                        match M with
                        | m + n =>
                            match goal with
                            | [Jm : JMeq H i  |- _ ]  =>
                                let Eq := constr:(finsplit_rv_swap _ _ Jm) in
                                  let Eq1 := constr:(finsplit_rv_swap _ _ (sym_JMeq Jm)) in
                                     rewrite Eq  || rewrite Eq1
                            | [Jm : JMeq i H  |- _ ]  =>
                                let Eq := constr:(finsplit_rv_swap _ _ Jm) in
                                  let Eq1 := constr:(finsplit_rv_swap _ _ (sym_JMeq Jm)) in
                                     rewrite Eq || rewrite Eq1
                            end
                        end
                    | _  =>  let Eq := constr:(match_simpl _ _ H) in
                                  rewrite Eq || destruct (finsplit _ _ H)
                    end

                  | _ => fin_decomp H N
                  end
          end
       end) in

    match goal with
    | [x : ?A, y : ?A |- _ ] =>
             match goal with
             | [ H : JMeq x y |- _ ] =>
               let Eq := constr:(JMeq_eq H) in
                 first [ rewrite Eq in * | rewrite <- Eq in *]; clear H
             end
    | [  H : fs _ = fz _ |- _ ] => inversion H
    | [  H : fz _ = fs _ |- _ ] => inversion H
    | [  |- context [finsplit _ _ (fin_inl ?x ?i) ] ] =>
             let H := constr:(finsplit_inl x i)  in rewrite H
    | [  |- context [finsplit _ _ (fin_inr ?x ?i) ] ] =>
             let H := constr:(finsplit_inr x i)  in rewrite H
    | [ H : fin_inl _ _ = fin_inr _ _ |- _ ] =>
              let H1 := constr:(finsplit_inl_inr _ _  H) in  destruct H1
    | [ H : fin_inr _ _ = fin_inl _ _ |- _ ] =>
              let H1 := constr:(finsplit_inl_inr _ _  (sym_eq H)) in  destruct H1

   (** fincase casefin - etc *)
    | [ |- context[fincase _ _ _ ] ] => unfold fincase; simpl; Finsimpl
    | [ |- context [ ?f (fincase ?l ?r ?i) ] ] =>
            match type of f with
            | ?X -> ?Y => let Eq := constr:(f_fincase f l r i) in
                             rewrite Eq; simpl
            end
    | [ |- context [ (fincase ?f ?g (fs ?i)) ] ] =>
            match type of f with
            | Fin (S _) -> ?Y => let Eq := constr:(fincase1 f g i) in
                             rewrite Eq; simpl
            end
    | [ |- context [FinCase _ ?x (fin_inl  ?x ?i)] ] =>
             let Eq := constr:(FinCase_inl x i) in rewrite Eq
    | [ |- context [FinCase ?x _ (fin_inr  ?x ?i)] ] =>
             let Eq := constr:(FinCase_inr x i) in rewrite Eq
    | [ |- context [FinCase _ ] ] =>
           first  [ (match goal with
                   | [ |- context [sum_n _ ]] => fail 1
                   end) | (unfold FinCase; simpl;  Finsimpl) ]
    | [ |- context [CaseFin _ ] ] => unfold CaseFin; simpl;  Finsimpl
    | [ |- context [ FinCase _ _ (CaseFin ?i) ]] =>
            let Eq := constr:(FinCaseFin i) in rewrite Eq
    | [ |- context [ CaseFin _ _ (FinCase ?i) ]] =>
            let Eq := constr:(CaseFinCase i) in rewrite Eq

    | [ |- context [finplus_swap _ _ _ ] ] => unfold finplus_swap; Finsimpl
    | [ H : fin_inl _ ?i = fin_inl _ ?j  |- _ ] =>
               let H1 := constr:(fin_inl_inject _ _ i j H) in
                  (rewrite H1; auto)  || add_hyp_then_tac H1 Finsimpl
    | [ H : fin_inr _ ?i = fin_inr _ ?j  |- _ ] =>
               let H1 := constr:(fin_inr_inject _ _ i j H) in
                  (rewrite H1; auto) || add_hyp_then_tac H1 Finsimpl
    | [ H : emb _ = emb _ |- _ ] =>
               let H1 := constr:(embInject H) in
                  (rewrite H1; auto) || add_hyp_then_tac H1 Finsimpl
    | [ H : fs _ = fs _ |- _ ] =>
               let H1 := constr:(fsInject H) in
                  (rewrite H1; auto) || add_hyp_then_tac H1 Finsimpl

    (** rewriting using proven results*)
    | [ |- context[rv (emb ?i) ] ] => let H := constr:(emb_S i) in
                  rewrite H  (*||  rewrite <- H *)
    | [ |- context [rv (rv ?i) ] ] =>
              let H := constr:(idem_rvFin i) in rewrite H
    | [ |- context [rot (un_rot ?i) ] ] =>
              let H := constr:(rot_un_rot_id i) in rewrite H
    | [ |- context [un_rot (rot ?i) ] ] =>
              let H := constr:(un_rot_rot_id i) in rewrite H
    | [ |- context [emb (fin_inl 0 ?i) ] ] =>
              let H := constr:(fininl_embO i) in rewrite H
    | [ |- context [rv (fin_inl 0 ?i) ] ] =>
              let H := constr:(rv_fin_inlO i) in rewrite H
    | [ H : rv _ = rv _ |- _ ] => let H1 := constr:(rvInject _ _ H) in
               rewrite H1 || add_hyp_then_tac H1 Finsimpl
    | [ H : rot ?i = rot ?j |- _ ] => let H1 := constr:(rot_inject _ _ H) in
               rewrite H1 || add_hyp_then_tac H1 Finsimpl
    | [ H : un_rot _ = un_rot _ |- _ ] => let H1 := constr:(un_rot_inject _ _ H) in
               rewrite H1 || add_hyp_then_tac H1 Finsimpl
    | [ H : ?n = ?m |- _ ] =>
         match goal with
         | [ i : Fin n, j : Fin m, Hj : JMeq (rv ?i) ?j |- _ ] =>
             let Eq := constr:(rvdistJM H Hj) in add_hyp_then_tac Eq Finsimpl
         end
    | [ i : Fin ?n |- _ ] =>
         match goal with
          (* discharge some contradictions *)
          | [ H1 : ?m + ?x = ?z + ?y ,
              H2 : JMeq (fin_inl ?a (?m + ?x) i) (fin_inr (?a + ?z) ?y ?j) |- _ ] =>
               let C := constr:(fin_inl_inrN m x z H1 H2) in destruct C
          | [ C : emb i = fs i |- _ ] =>
                       let H1 := constr:(fs_emb (sym_eq C)) in destruct H1
          | [ C : fs i = emb i |- _ ] =>
                       let H1 := constr:(fs_emb C) in destruct H1
          | [ C : tp n = emb i |- _ ] =>
                       let H1 := constr:(tp_emb C) in destruct H1
          | [ C : emb i = tp n |- _ ] =>
                       let H1 := constr:(tp_emb (sym_eq C)) in destruct H1
          | [ C : emb (tp (S _ )) = fz (S (S _ )) |- _ ] =>
                       let H1 := constr:(emb_tpm C) in destruct H1
          | [ C : fz (S (S _ )) =  emb (tp (S _ )) |- _ ] =>
                       let H1 := constr:(emb_tpm (sym_eq C)) in destruct H1
          | [ C : rv (fz ?m)  = rv (fs i) |- _ ] =>
                       let H1 := constr:(fsFz i C) in destruct H1
          | [ C : rv (fs i)  = rv (fz ?m) |- _ ] =>
                       let H1 := constr:(fsFz i (sym_eq C)) in destruct H1
          | [ C : JMeq (fin_inl (S ?m)  ?i) (fin_inl _ ?m (fs ?i)) |- _ ] =>
                    let K := constr:(fin_Jmeq_l _ _ C) in destruct K
          | [ C : JMeq (fin_inr _ _) (fin_inl _ (fin_inl _ _)) |- _ ] =>
                   let K := constr:(Jmeq_fin_inl_inr3 _ _ _ _ _ C) in destruct K

         (** augment the hypothesis space *)
         | [ |- context [rv (fin_inl _ _ ) ] ]  =>
                   let K := constr:(rvFin_inl _ i) in  add_hyp_then_tac K Finsimpl
         | [ |- context [fin_inr _ (rv ?i ) ] ] =>
                   let K := constr:(rvFin_inl _ i) in add_hyp_then_tac K Finsimpl
         | [|- context[fs (fin_inr ?m ?i)] ]  =>
             let Jeq := constr:(fin_Jmeq m i)  in add_hyp_then_tac Jeq Finsimpl
         | [|- context[emb (fin_inr ?m ?i)]]  =>
             let Jeq := constr:(JM_rvEmb m i)  in add_hyp_then_tac Jeq Finsimpl
         | [|- context[rv (fin_inl ?m ?i)]]  =>
             let Jeq := constr:(rvFin_inl m i)  in add_hyp_then_tac Jeq Finsimpl
         | [|- context[rv (fin_inr ?m ?i)]]  =>
             let Jeq := constr:(rvFin_inr m i)  in add_hyp_then_tac Jeq Finsimpl
         | [|- context[(fin_inr ?a (?x + n) (fin_inr ?x i)) ]] =>
             let Jeq := constr:(fin_inr_inr a x i)  in add_hyp_then_tac Jeq Finsimpl
         | [ H : JMeq (fin_inr 0 n i) (fin_inl n 0 ?j) |- _ ] =>
             let Req := constr:(inl_inr_eq H) in
                   rewrite H || add_hyp_then_tac Req Finsimpl
         | [ H : JMeq (fin_inl n 0 i) (fin_inr 0 n ?j) |- _ ] =>
             let Req := constr:(inl_inr_eq (sym_JMeq H)) in
                  rewrite H || add_hyp_then_tac Req Finsimpl

          | [ j : Fin ?m |- _ ] =>
              match goal with
              | [  H : ?N = m,  H1 : JMeq (fin_inl _ i)(fin_inl _ j)  |- _ ] =>
                 let Eqt := constr:( fin_inlJm _ H _ _ H1) in
                    let Eqt1 := constr:( fin_inlJm _ (sym_eq H) _ _ (sym_JMeq H1)) in
                      add_hyp_then_tac Eqt Finsimpl || add_hyp_then_tac Eqt1 Finsimpl
                      (* fin_inl_inrZ1*)

              | [  H : ?N = m,  H1 : JMeq (fin_inr _ i)(fin_inr _ j)  |- _ ] =>
                  let Eqt := constr:(fin_inrJm _ H _ _ H1) in (* here *)
                     let Eqt1 := constr:(fin_inrJm _ (sym_eq H) _ _ (sym_JMeq H1)) in
                       add_hyp_then_tac Eqt Finsimpl || add_hyp_then_tac Eqt1 Finsimpl

              | [ H : ?N = m,  H0 : JMeq (fs i) (fs j) |- _  ] =>
                   let Ieqj := constr:(Jmeq_fsInject H H0) in
                     let Ieqj1 := constr:(Jmeq_fsInject (sym_eq H) (sym_JMeq H0)) in
                       add_hyp_then_tac Ieqj Finsimpl || add_hyp_then_tac Ieqj1 Finsimpl

              | [ H : m = ?N,  H0 : JMeq (fs j) (fs i) |- _  ] =>
                  let Ieqj := constr:(Jmeq_fsInject H H0) in
                    let Ieqj1 := constr:(Jmeq_fsInject (sym_eq H) (sym_JMeq H0)) in
                        add_hyp_then_tac Ieqj Finsimpl || add_hyp_then_tac Ieqj1 Finsimpl

              | [  H : ?N = m ,  H1 : JMeq i j  |- _ ] =>
                   destruct H; let Eqt := constr:(JMeq_eq H1) in
                        rewrite Eqt ||  rewrite <- Eqt || add_hyp_then_tac Eqt Finsimpl

              | [  H : m = ?N ,  H1 : JMeq j i  |- _ ] =>
                 destruct H; let Eqt := constr:(JMeq_eq H1) in
                      rewrite Eqt ||  rewrite <- Eqt || add_hyp_then_tac Eqt Finsimpl
               end (*  return here *)

         | _ =>  finsplit_destruct i n
         (* need to add a few caseses*)
         end
    end.

 (** Repeatedly apply the above rewrites and finSumn_simplify *)
  Ltac FSimpl :=
     repeat (FooSimpl || Finsimpl || finSumn_simplify) ; auto.

 (** Combining FSimpl with the conversion integers. foo_minus *)

 Tactic Notation "FSimpl" "with" "arith" :=
    let prog_foo := progress FSimpl in
     repeat (prog_foo || foo_minus || auto with arith).

  Ltac  optimiseOmega :=
       repeat  optimiseOmega_aux; rewrite_right_0 ; minus_simpl;
               repeat (foo_minus || auto with arith).