Require Import List.

Require Import defns.
Require Import nl_fusion.
Require Import nl_sgn.
Require Import nl_eq.
Require Import nl_struct.

Require Import nl_walgeq.

(**
    context shifting preservers well-formedness of context

    proof by induction on length of the context

 **)

Lemma wfctx_nl_cs:
  forall (S : nsgn) (G G' : nctx) (A : nTy),
    wfctx_nl S G ->
    cs_nctx G 0 A G' ->
    wftype_nl S G A kindstar_nl_type ->
    wfctx_nl S G'.
Proof.
  intros S [ | G ].
  - intros.
    inversion H0.
    econstructor; eauto.
    + constructor.
  - intros.
    inversion H0.
    econstructor; eauto.
    + constructor; eauto using cu_nTy_inverse_cs, cu_nctx_inverse_cs.
Qed.

(**
    erasure preservers well-formedness of signature
**)

Lemma wfsig_nl_erasure:
  forall (S : nsgn),
    wfsig_nl S -> wfssig_nl (erasure_nsgn S).
Proof.
  intros S HwfS.
  induction HwfS.
  - cbn; constructor.
  - cbn; constructor.
    auto.

    intro Hc; eapply H0.
    apply indomsnTCon_stable; auto.

  - cbn; constructor.
    auto.

    intro; eapply H0.
    apply indomsnCon_stable; auto.
Qed.

(**
    * determinacy of wftype
**)

Lemma wftype_nl_determinacy:
  forall (S : nsgn) (G : nctx) (sA : sTy) (A : nTy) (L1 L2 : nK),
    sA = struct_nTy A ->
    wfsig_nl S -> wfctx_nl S G ->
    wftype_nl S G A L1 ->
    wftype_nl S G A L2 ->
    L1 = L2.
Proof.
  intros S G sA A L1 L2 Hstruct HwfS.
  generalize dependent L1.
  generalize dependent L2.
  generalize dependent G.
  generalize dependent A.
  induction sA;
    intros A Hstruct G L1 L2 Hwfctx HwfTy1 HwfTy2.
  -  (* leaf *)
    inversion HwfTy1.
    + rewrite <- H3 in HwfTy2; inversion HwfTy2.
      eauto using boundnTCon_determinacy.
    + rewrite <- H5 in Hstruct; inversion Hstruct.
    + rewrite <- H5 in Hstruct; inversion Hstruct.
  -  (* pi intro *)
    inversion HwfTy1.
    + rewrite <- H3 in Hstruct; inversion Hstruct.
    + rewrite <- H5 in HwfTy2; inversion HwfTy2.
      auto.
    + rewrite <- H5 in Hstruct; inversion Hstruct.
  - (* elim *)
    inversion HwfTy1.
    + rewrite <- H3 in Hstruct; inversion Hstruct.
    + rewrite <- H5 in Hstruct; inversion Hstruct.
    + rewrite <- H5 in Hstruct; inversion Hstruct.
      rewrite <- H5 in HwfTy2; inversion HwfTy2.
      assert ((kindstar_nl_pi_intro nB' nL)
              = (kindstar_nl_pi_intro nB'0 nL0))
        by (eauto using IHsA).
      inversion H18.
      rewrite <- H21 in H17.
      eauto using tuts_nK_determinacy.
Qed.

Lemma wfterm_nl_determinacy:
  forall (S : nsgn) (G : nctx) (sM : ste) (M : nte) (A1 A2 : nTy),
    wfsig_nl S -> wfctx_nl S G ->
    sM = struct_nte M ->
    wfterm_nl S G M A1 ->
    wfterm_nl S G M A2 ->
    A1 = A2.
Proof.
  intros.
  generalize dependent A2.
  generalize dependent A1.
  generalize dependent M.
  generalize dependent G.
  induction sM.
  intros.
  - destruct M as [ c | | | | ] ; inversion H1.
    + inversion H2.
      inversion H3.
      eauto using boundnCon_determinacy.
    + clear H1.
      generalize dependent G.
      generalize dependent A1.
      generalize dependent A2.
      induction ixc.
      * intros.
        inversion H2.
        inversion H3.
        rewrite <- H9 in H5; inversion H5.
        eauto using eq_trans.
      * intros.
        inversion H2.
        rewrite <- H7 in H3.
        inversion H3.
        rewrite <- H7 in H0.
        inversion H0.
        assert (nctx' = nctx'0 /\ nB' = nB'0)
          by (eauto using cu_nctx_determinacy).
        inversion H24.
        assert (nctx'1 = nctx'0)
          by (eapply cu_nctx_determinacy; eauto).
        assert (nA = nA0).
        (* rewrite H19 in H5. *)
        eapply IHixc.
        rewrite H27 in H22.
        exact H22.
        rewrite <- H25.
        exact H5.
        exact H15.
        rewrite <- H28 in H17.
        eauto using cs_nTy_determinacy, eq_trans.
    + inversion H2.
  - intros.
    destruct M; inversion H1.

    inversion H2.
    inversion H3.

    assert (nctx' = nctx'0) by (eauto using cs_nctx_determinacy).
    rewrite <- H26 in H23.
    assert (nM2' = nM2'0) by (eauto using cstu_nte_determinacy).

    assert (nA2 = nA3).
    eapply IHsM.
    rewrite <- H26 in H19.
    eapply wfctx_nl_cs; eauto.
    rewrite H6.
    eapply struct_nte_cstu; eauto.
    rewrite H27 in H13.
    exact H13.
    exact H23.

    rewrite <- H28 in H25.
    f_equal; eauto using cuts_nTy_determinacy.
  - intros.
    destruct M; inversion H1.

    inversion H2.
    inversion H3.

    assert (nA2 = nA3).
    eapply IHsM2; eauto.
    rewrite <- H24 in H23.
    eapply tuts_nTy_determinacy; eauto.
Qed.

(**
    * wftype and wfterm decidability
**)

Fixpoint wftype_nl_dec' (S : nsgn) (G : nctx)
         (sA : sTy) (A : nTy) {struct sA}:
    wfsig_nl S -> wfctx_nl S G ->
    sA = struct_nTy A ->
    { L | wftype_nl S G A L } +
    { forall L, ~ (wftype_nl S G A L)}
with wfterm_nl_dec' (S : nsgn) (G : nctx)
                   (sM : ste) (M : nte) {struct sM}:
    wfsig_nl S -> wfctx_nl S G ->
    sM = struct_nte M ->
    { A | wfterm_nl S G M A } +
    { forall A, ~ (wfterm_nl S G M A)}.
Proof.
  intros.
  generalize dependent A.
  generalize dependent G.
  induction sA.
  - (* struct ~ leaf *)
    intros.
    destruct A.
    + (* tcon *)
      assert ({ L | boundnTCon tcon5 L S } +
              { forall L, ~ (boundnTCon tcon5 L S)})
        by (apply boundnTCon_dec).
      destruct H2 as [ [L] | contra ].
      * (* boundnTCcon *)
        left; eexists; econstructor; eauto.
      * (* ~ not boundnTCon *)
          right; intros; intro Hwf; inversion Hwf.
          eapply contra; eauto.
    + (* pi intro on leaf *)
      inversion H1.
    + (* pi elim on leaf *)
      inversion H1.
  - (* struct step case pi_intro *)
  intros.
  destruct A.
  +  inversion H1.
  +  inversion H1.
     assert ({L | wftype_nl S G A1 L}
          + {forall L, ~ wftype_nl S G A1 L}).
     apply IHsA1.
     exact H0.
     exact H3.
     destruct H2 as [ [L] | contra ].
     * (* exists L *)
       assert ({L = kindstar_nl_type} + {L <> kindstar_nl_type})
         by (apply eq_nK).
     destruct H2.
     { (* L = type *)
       rewrite e in w.
       assert ({ G' | cs_nctx G 0 A1 G'})
         by (apply cs_nctx_dec; auto with arith).
       destruct H2 as [?G'].
       assert ({ A2' | cstu_nTy A2 0 A2'}) by (apply cstu_nTy_dec).
       destruct H2 as [ ?A2' ].
       assert ({L | wftype_nl S G' A2' L}
               + {forall L, ~ wftype_nl S G' A2' L}).
       {
         apply IHsA2.
         eapply wfctx_nl_cs; eauto.
         rewrite H4.
         eapply struct_nTy_cstu; eauto.
       }
       destruct H2 as [ [L2] | ].
       {
         assert ({L2 = kindstar_nl_type} +
                 {L2 <> kindstar_nl_type}) by (apply eq_nK).
         destruct H2.
         { (* the valid subcase *)
           left.
           rewrite e0 in w0.
           eexists; econstructor; eauto.
         }
         {  (* L2 <> typeK case *)
           right; intros; intro HwfA2; inversion HwfA2.
           assert (A2' = nB') by (eapply cstu_nTy_determinacy; eauto).
           rewrite <- H13 in H12.
           assert (G' = nctx') by (eapply cs_nctx_determinacy; eauto).
           rewrite <- H14 in H12.

           assert (struct_nTy A2 = struct_nTy A2')
             by (eapply struct_nTy_cstu; eauto).
           rewrite H15 in H4.

           assert (L2 = kindstar_nl_type).
           eapply wftype_nl_determinacy.
           eauto.
           eauto.
           eapply wfctx_nl_cs.
           exact H0.
           exact c.
           exact H6.
           exact w0.
           exact H12.
           apply n; auto.
         }
       }
       { (*  ~ wftype_nl S x0 x1 L *)
         right; intros; intro.
         inversion H2.
         eapply n.
         assert (A2' = nB') by (eapply cstu_nTy_determinacy; eauto).
         rewrite H14.
         assert (G' = nctx') by (eapply cs_nctx_determinacy; eauto).
         rewrite H15.
         eauto.
       }
     }
     { (* x <> type *)
       right; intros; intro.
       inversion H2.
       assert (L = kindstar_nl_type)
         by (clear H4; eapply wftype_nl_determinacy; eauto).
       apply n; auto.
     }
     * (* pi intro *)
       inversion H1.
       right; intros; intro.
       inversion H2.
       eapply contra; eauto.
  + inversion H1.
  - (* step case: pi elim *)
    intros.
    destruct A.
    + inversion H1.
    + inversion H1.
    + inversion H1.

      assert ( {L : nK | wftype_nl S G A L} +
           {(forall L : nK, ~ wftype_nl S G A L)}).
      apply IHsA; auto.
      destruct H2.
      * destruct s.
        destruct x.
        { (* case : wrong kind of A *)
          right; intros; intro.
          inversion H2.
          assert ( kindstar_nl_type =  (kindstar_nl_pi_intro nB' nL)).
          eapply wftype_nl_determinacy ; eauto.
          inversion H14. }
        { assert ({B : nTy | wfterm_nl S G nte5 B } +
                  {(forall B : nTy, ~ wfterm_nl S G nte5 B )}).

          eapply wfterm_nl_dec' with (sM := ste5).
          auto.
          auto.
          exact H4.

          destruct H2.
          { destruct s.
            assert ({x' | tuts_nK x nte5 x'}) by (apply tuts_nK_dec).
            destruct H2.
            assert ({walgeq_nl_Ty
                       (erasure_nsgn S) (erasure_nctx G)
                       x0 nTy5 skind_nl_type } +
                    { ~ walgeq_nl_Ty
                        (erasure_nsgn S) (erasure_nctx G)
                        x0 nTy5 skind_nl_type }).
            apply walgeq_nTy_check.
            auto.
            apply wfsig_nl_erasure; auto.
            destruct H2.
            left; exists x1.
            eapply ty_nl_pi_elim.
            exact w.
            exact w0.
            exact w1.
            exact t.

            right.
            intros; intro.
            inversion H2.
            assert (x0 = nB) by (eauto using wfterm_nl_determinacy).
            rewrite H14 in n.
            assert (kindstar_nl_pi_intro nTy5 x =
                    kindstar_nl_pi_intro nB' nL)
              by (eauto using wftype_nl_determinacy).
            inversion H15.
            rewrite H17 in n.
            eapply n; eauto.
          }
          { (* not wf B *)
            right; intros; intro.
            inversion H2.
            eapply n; eauto. } }
      * (* not wf A *)
        right; intros; intro.
        inversion H2.
        eapply n; eauto.

  (* mutual lemma *)

  - generalize dependent M.
    generalize dependent G.
    induction sM.

    + (* leaf *)
      intros.
      destruct M as [ c | | | | ].
      * (* con *)
        assert ({ A | boundnCon c A S} + {forall A, ~ boundnCon c A S})
               by (apply boundnCon_dec).
        destruct H2.
        { destruct s as [ A' ].
          left; eexists; constructor; eauto. }
        { right; intros; intro; eapply n.
          inversion H2; eauto. }
      * (* ixc *)
        clear H1.
        generalize dependent G.
        induction ixc.
        { intros.
          destruct G.
          { right; intros; intro.
            inversion H1. }
          { left; eexists; econstructor; eauto. } }
        { destruct G.
          { right; intros; intro.
            inversion H1. }
          { intros.
            assert ({ G'B' | cu_nctx (n :: G) 0 (fst G'B') (snd G'B')} +
                    {forall B' G', ~ cu_nctx (n :: G) 0 G' B'})
              by (apply cu_nctx_dec).
            destruct H1 as [ [[?G' ?B']] | ].
            - cbn in c.
              assert (wfctx_nl S G').
              inversion H0.
              assert (nctx' = G').
              eapply cu_nctx_determinacy; eauto.
              rewrite <- H7; auto.
              assert ({A : nTy | wfterm_nl S G' (termstar_nl_ixc ixc) A} +
                      {(forall A : nTy, ~ wfterm_nl S G' (termstar_nl_ixc ixc) A)})
                by (apply IHixc; auto).

              destruct H2 as [ [ A ] | ].
              + assert ({A' | cs_nTy A 0 A'}) by (apply cs_nTy_dec).
                destruct H2 as [ A' ].
                left; eexists.
                econstructor; eauto.
              + right; intros; intro.
                inversion H2.
                assert (nctx' = G').
                eapply cu_nctx_determinacy; eauto.
                rewrite H11 in H8.
                eapply n0; eauto.
            - right; intros; intro.
              inversion H1.
              eapply n0; eauto. } }
      * (* case ixt - not a w.f. term *)
        right; intro; intro.
        inversion H2.
      * inversion H1.
      * inversion H1.
    + intros.
      destruct M as [ | | | B M | ].
      * inversion H1.
      * inversion H1.
      * inversion H1.
      * inversion H1.
        assert ({L : nK | wftype_nl S G B L} +
                {(forall L : nK, ~ wftype_nl S G B L)}).

        eapply wftype_nl_dec' with (sA := sTy5).
        auto.
        auto.
        auto.

        destruct H2 as [ [L] | ].
        assert ({L = kindstar_nl_type} + {L <> kindstar_nl_type})
          by (apply eq_nK).
        destruct H2.
        rewrite e in w.
        assert ({G' | cs_nctx G 0 B G'})
          by (apply cs_nctx_dec; auto with arith).
        destruct H2 as [G'].
        assert (wfctx_nl S G').
        { destruct G'.
          inversion c.
          econstructor; eauto using cu_nctx_inverse_cs. }
        assert ({M' | cstu_nte M 0 M'}) by (apply cstu_nte_dec).
        destruct H5 as [ M' ].
        assert ({A : nTy | wfterm_nl S G' M' A} +
                {(forall A : nTy, ~ wfterm_nl S G' M' A)}).
        { apply IHsM; auto.
          rewrite H4; eauto using struct_nte_cstu. }
        destruct H5 as [ [A] | ].

        { assert ({A' | cuts_nTy A A'}) as [ A']
            by (apply cuts_nTy_dec).
          left.
          eexists.
          econstructor; eauto. }
        { right; intros; intro.
          inversion H5.
          assert (M' = nM2') by (eauto using cstu_nte_determinacy).
          rewrite <- H16 in  H13.
          assert (nctx' = G') by (eauto using cs_nctx_determinacy).
          rewrite H17 in H13.
          eapply n; eauto. }

        { right; intros; intro.
          inversion H2.
          assert (L = kindstar_nl_type).
          eauto using wftype_nl_determinacy.
          contradiction. }
        { right; intros; intro.
          inversion H2.
          eapply n; eauto. }
      * inversion H1.
    + intros.
      destruct M; inversion H1.
      assert ({A | wfterm_nl S G M1 A} + {forall A, ~ wfterm_nl S G M1 A})
        as [ [A] | ]
          by (eauto using IHsM1).
      * destruct A.

        { right; intros; intro.
          inversion H2.
          assert (typestar_nl_tcon tcon5 = typestar_nl_pi_intro nA2' nA1).
          eauto using wfterm_nl_determinacy.
          inversion H14. }
        { assert ({A1' | wfterm_nl S G M2 A1'} +
                  {forall A1', ~ wfterm_nl S G M2 A1'}) as [ [A1'] | ]
              by (eauto using IHsM2).

          assert ({walgeq_nl_Ty (erasure_nsgn S) (erasure_nctx G)
                                A1' A1 skind_nl_type} +
                  {~ (walgeq_nl_Ty (erasure_nsgn S) (erasure_nctx G)
                                   A1' A1 skind_nl_type)})
            as [ | ]
              by (eauto using walgeq_nTy_check,wfsig_nl_erasure).

          assert ({A1'' | tuts_nTy A1' M2 A1''})
            as [A1''] by (eauto using tuts_nTy_dec).

          left; eexists.
          econstructor; eauto.

          right; intros; intro.
          inversion H2.
          eapply n.
          assert (typestar_nl_pi_intro A1 A2
                  = typestar_nl_pi_intro nA2' nA1).
          eauto using wfterm_nl_determinacy.
          inversion H14.

          assert (A1' = nA2) by (eauto using wfterm_nl_determinacy).
          rewrite H15.
          auto.

          right; intros; intro.
          inversion H2.
          eapply n; eauto. }
        { right; intros; intro.
          inversion H2.
          assert (typestar_nl_pi_elim A nte5 =
                  typestar_nl_pi_intro nA2' nA1).
          eauto using wfterm_nl_determinacy.
          inversion H14. }
      * right; intros; intro.
        inversion H2.
        eapply n; eauto.

Qed.

Lemma wftype_nl_dec (S : nsgn) (G : nctx) (A : nTy):
    wfsig_nl S -> wfctx_nl S G ->
    { L | wftype_nl S G A L } + { forall L, ~ (wftype_nl S G A L)}.
Proof.
  intros; eauto using wftype_nl_dec'.
Qed.

Lemma wfterm_nl_dec (S : nsgn) (G : nctx) (M : nte):
    wfsig_nl S -> wfctx_nl S G ->
    { A | wfterm_nl S G M A } + { forall A, ~ (wfterm_nl S G M A)}.
Proof.
  intros; eauto using wfterm_nl_dec'.
Qed.


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

- Frédéric Blanqui, 2014-02-18

Some structures on integer numbers. *)

Set Implicit Arguments.

Require Import EqUtil QArith OrdSemiRing2 Omega LogicUtil RelUtil
Morphisms ZUtil.

Global Instance Q_as_Setoid : Setoid.
Proof.
  apply Build_Setoid with (s_typ :=Q)(s_eq:=Qeq).
  constructor. fo. fo. unfold Transitive. apply Qeq_trans.
Defined.

Global Instance Q_as_DS : DecidableSetoid.

Proof.
  apply Build_DecidableSetoid with (ds_setoid := Q_as_Setoid).
  intros. simpl in *.
  apply Qeq_dec.
Defined.

Instance Q_as_SR : SemiRing.

Proof.
  apply Build_SemiRing with
  (sr_ds  := Q_as_DS)
  (sr_0   := 0%Q)
  (sr_1   := 1%Q)
  (sr_add := Qplus)
  (sr_mul := Qmult).
  intros x y H z r H1. rewrite H. rewrite H1. refl.
  intros x y H z r H1. rewrite H. rewrite H1. refl.
  constructor.
  exact Qplus_0_l.
  exact Qplus_comm.
  exact Qplus_assoc.
  exact Qmult_1_l. fo.
  exact Qmult_comm.
  exact Qmult_assoc.
  exact Qmult_plus_distr_l.
Defined.

(* Rational numbers as Ring *)

Instance Q_as_R : Ring.

Proof.
  apply Build_Ring with (sr:= Q_as_SR)(r_opp := Qopp).
  intros x y H. rewrite H. refl.
  intros x y H z r H1. rewrite H. rewrite H1. refl.
  apply Qsrt.
Defined.

(* Rational as OrderedRing. *)

Definition Qgt x y := Qlt y x.

Definition Qgt_dec x y : {x > y} + {~ x > y}.

Proof.
  unfold Qlt in |- *. intros.
  exact (Z_lt_dec (Qnum y * QDen x) (Qnum x * QDen y)).
Defined.

Definition Q_bgt x y :=
  match Qgt_dec x y with
    | left _ => true
    | right _ => false
  end.

Lemma Q_bgt_ok : forall x y, Q_bgt x y = true <-> x > y.

Proof.
  intros. unfold Q_bgt. case_eq (Qgt_dec x y); intuition.
Qed.

Lemma one_Qgt_zero : 1 > 0.

Proof.
  apply Zlt_0_1.
Qed.

Lemma add_gt_mono_r : forall x y z, x > y -> x + z > y + z.

Proof.
  unfold Qplus, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl;
  simpl_mult.
  Open Scope Z_scope.
  intros.  match goal with |- ?a < ?b => ring_simplify a b end.
  apply Zplus_lt_compat_r. rewrite <- Zmult_assoc, Zmult_comm.
  rewrite <- !Zmult_assoc. apply Zmult_lt_compat_l.
  apply Zmult_lt_0_compat; apply Zgt_lt; apply Zgt_pos_0.
  set (a := 'x2 * y1). rewrite Zmult_comm.
  unfold a. rewrite Zmult_comm. hyp.
  Close Scope Z_scope.
Qed.

Lemma mul_Qgt_mono_r : forall x y z, z > 0 -> x > y -> x * z > y * z.

Proof.
  intros. apply Qmult_lt_compat_r with (x := y). hyp. hyp.
Qed.

Instance Q_as_OR : OrderedRing.

Proof.
  apply Build_OrderedRing with
  (or     := Q_as_R)
  (or_gt  := Qgt)
  (or_bgt := Q_bgt).
  (* Transitivity *)
  intros m n p.
  unfold Qgt; intros; apply Qlt_trans with n; hyp.
  (* Irreflexive *)
  unfold Irreflexive, complement, Reflexive, Qgt.
  intros. apply Zlt_irrefl in H. hyp.
  (* Correctness of [bgt] *)
  apply Q_bgt_ok.
  (* rel_dec gt *)
  apply Qgt_dec.
  (* 1 > 0 *)
  apply one_Qgt_zero.
  (* x > y -> x + z > y + z *)
  fo. unfold Qgt in H.
  apply add_gt_mono_r. hyp.
  (* z > 0 -> x > y -> x * z > y * z *)
  apply mul_Qgt_mono_r.
  (* gt Proper *)
  intros x y H z r H1.
  unfold Qgt. intuition. rewrite <- H. rewrite <- H1. hyp.
  rewrite H1. rewrite H. hyp.
Defined. (* REMARK: not Qed. *)


Require Import Coq.Relations.Relation_Definitions.
Require Import KonneTactics.
Require Import SpaceSearch.
Require Import Arith.
Require Import Dict.
Require Import Omega.
Require Import Enumerable.
Require Import SpaceSearch.EqDec.
Require Import SpaceSearch.CpdtTactics.
Require Import JamesTactics.
Require Import List.
Require Import Misc.
Require Import Coq.Program.Basics.
Require Import Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Coq.Logic.IndefiniteDescription.
Require Import Coq.Logic.FunctionalExtensionality.
Import EqNotations.
Import ListNotations.

Export Coq.Relations.Relation_Definitions.
Export KonneTactics.
Export SpaceSearch.
Export Coq.Logic.FunctionalExtensionality.
Export Arith.
Export Dict.
Export Omega.
Export Enumerable.
Export EqDec.
Export CpdtTactics.
Export JamesTactics.
Export Coq.Program.Basics.
Export List.
Export Coq.Logic.Classical_Pred_Type.
Export Classical_Prop.
Export EqNotations.
Export ListNotations.

Global Notation "( A ; B )" := (existT _ A B).
Global Notation "∑ r , A" := {r : _ & A} (at level 45).
Global Notation "x .1" := (projT1 x) (at level 3, format "x '.1'").
Global Notation "x .2" := (projT2 x) (at level 3, format "x '.2'").

Arguments const / {_ _} _ _.

Class Decidable (P:Prop) := {
  decide : P + ~P
}.
Arguments decide _ [_].

Global Instance decidableBool b : Decidable (b = true).
  refine {| decide := _ |}.
  destruct b.
  - left. reflexivity.
  - right. congruence.
Defined.

Definition totalDec {A} (le:relation A) := forall a a', le a a' + le a' a.

Class Preference (A:Type) := {
  le : relation A;
  prefReflexive : reflexive _ le;
  prefTransitive : transitive _ le;
  prefTotalDec : totalDec le
}.

Global Notation "a <= b" := (le a b).
Global Notation "a >= b" := (le b a).
Global Notation "a > b" := (~le a b).
Global Notation "a < b" := (~le b a).
Global Notation "a <=? b" := (decide (a <= b)).

Definition prefEq {A} `{Preference A} (a b:A) := a <= b /\ a >= b.

Global Notation "a == b" := (prefEq a b) (at level 45).

Lemma GtImpliesGe {A} `{Preference A} {a a':A} : a > a' -> a >= a'.
  intros h.
  unfold not in h.
  destruct (prefTotalDec a a'); intuition.
Qed.

Lemma prefTransitiveGtL {A} `{Preference A} {a b c} : a > b -> b >= c -> a > c.
  intros h h' h''.
  apply h; clear h.
  eapply prefTransitive; [apply h''|apply h'].
Qed.

Lemma prefTransitiveGtR {A} `{Preference A} {a b c} : a >= b -> b > c -> a > c.
  intros h h' h''.
  apply h'; clear h'.
  eapply prefTransitive; [apply h|apply h''].
Qed.

Global Instance preferenceNat : Preference nat.
  refine {| le n m := (n <= m) % nat |}.
  - exact Nat.le_refl.
  - exact Nat.le_trans.
  - unfold totalDec.
    intros n m.
    destruct (n ?= m) eqn:h.
    + left.
      apply Nat.compare_eq_iff in h.
      omega.
    + left.
      apply Nat.compare_lt_iff in h.
      omega.
    + right.
      apply Nat.compare_gt_iff in h.
      omega.
Defined.

Section ArgMax.
  Variable A B : Type.
  Context `{enumerable A}.
  Context `{Preference B}.
  Variable f : A -> B.

  Fixpoint argMax'' (l:list A) {struct l} : l <> [] -> A.
    refine(match l with
    | [] => _
    | a::l' => fun _ => _
    end); [congruence|].
    refine((match l' as l'' return l' = l'' -> A with
    | [] => fun _ => a
    | _ =>  fun _ => let a' := argMax'' l' _ in
             if prefTotalDec (f a') (f a) then a else a'
    end) _); congruence.
  Defined.

  Lemma allSmallerThanArgMax'' :
    forall l (a:A) (h : l <> []), In a l ->
      f a <= f (argMax'' l h).
  Proof.
    induction l as [|a' l' IHl].
    - congruence.
    - intros a h h'.
      cbn; clear h.
      break_match. {
        destruct h'; [|intuition].
        subst.
        apply prefReflexive.
      }
      generalize_proofs.
      specialize (IHl a p).
      subst_max.
      break_match.
      + destruct h' as [|h'].
        * subst_max.
          apply prefReflexive.
        * eapply prefTransitive; [apply (IHl h')|assumption].
      + destruct h' as [|h'].
        * subst_max.
          assumption.
        * specialize (IHl h').
          assumption.
  Defined.

  Definition argMax' (a:A) : A.
    refine(argMax'' enumerate _).
  Proof.
    specialize (enumerateContainsEverything a).
    intros; intro.
    find_rewrite.
    specialize in_nil.
    crush.
  Defined.

  Lemma allSmallerThanArgMax :
    forall (a' a:A), f a <= f (argMax' a').
  Proof.
    intros.
    unfold argMax'.
    apply allSmallerThanArgMax''.
    apply enumerateContainsEverything.
  Qed.

  Definition argMax : A -> {a:A | forall a', f a' <= f a}.
    intro P.
    refine (exist _ (argMax' P) _).
    apply allSmallerThanArgMax.
  Defined.
End ArgMax.

Arguments argMax [_ _ _ _] _ _.
Opaque argMax.

Global Instance freeSig {A P} `{forall a, Decidable (P a)}
                       `{Free A} :
                         Free {a : A | P a}.
  refine {|
    free := bind (free A) (fun a =>
              match decide (P a) with
              | inl p => single (exist _ a p)
              | _ => empty
              end)
  |}.
Proof.
  intros [a p].
  rewrite <- bindOk; exists a.
  constructor; [apply freeOk|].
  break_match.
  - apply singleOk.
    generalize_proofs.
    reflexivity.
  - intuition.
Defined.

Definition indefinite_description : forall {A:Type} {P:A->Prop}, ex P -> sig P :=
  constructive_indefinite_description.

Lemma classicT (P:Prop) : {P} + {~P}.
  assert (exists p:P + ~P, True) as h. {
    destruct (classic P) as [p|np].
    - exists (inl p).
      trivial.
    - exists (inr np).
      trivial.
  }
  apply indefinite_description in h.
  destruct h as [[p|np] _]; intuition.
Qed.

Definition decidableAll {A} : Decidable A.
  constructor.
  destruct (classicT A); intuition.
Qed.

Definition eqDecAll {A} : eqDec A.
  constructor.
  intros a a'.
  apply classicT.
Qed.

Global Instance enumerableDecidable {P:Prop} `{Decidable P} : enumerable P.
  refine {| enumerate := _ |}. {
    case (decide P) as [p|].
    + exact [p].
    + exact [].
  }
Proof.
  intros p; cbn.
  break_match.
  - generalize_proofs.
    left.
    reflexivity.
  - intuition.
Qed.

Global Instance enumerableSig {A P} `{forall a, Decidable (P a)}
                             `{enumerable A} :
                               enumerable {a : A | P a}.
  refine (let f a := match decide (P a) with
                     | inl p => [exist _ a p]
                     | _ => []
                     end in _); eauto.
  refine {|
    enumerate := bindList
      (enumerate (A := A)) f
  |}.
Proof.
  Opaque concat.
  Opaque map.
  intros.
  destruct a as [a p].
  unfold bindList.
  eapply (concatIn (f a)).
  - subst f; cbn.
    break_match; [|intuition].
    left.
    generalize_proofs.
    reflexivity.
  - apply in_map.
    apply enumerateContainsEverything.
Unshelve.
  apply eqDecAll.
Qed.

Typeclasses Transparent const.

Instance enumerableOption {A} `{enumerable A} : enumerable (option A).
  refine {| enumerate := None::map (@Some _) enumerate |}.
  intros [a|].
  - right.
    apply in_map.
    apply enumerateContainsEverything.
  - left.
    reflexivity.
Defined.

Module RTC.
Section RTC.
  Variable S : Type.
  Variable t : S -> S -> Type.
  Variable s0 : S.

  (* reflexive transitive closure *)
  Inductive rtc : S -> Type :=
  | refl : rtc s0
  | trans {s s'} : rtc s -> t s s' -> rtc s'.

End RTC.
Arguments rtc {_} _ _ _.
End RTC.
Import RTC.

Lemma well_founded_irreflexive {A R} {wf:well_founded R} : forall (a:A), ~(R a a).
  refine (well_founded_ind wf _ _).
  intros a h h'.
  specialize (h a h').
  intuition.
Qed.

Lemma well_founded_asymetric {A} {R} {wf:well_founded R} : forall (a a':A), R a a' -> ~R a' a.
  refine (well_founded_ind wf _ _).
  intros a h a' h' h''.
  apply (h a' h'' a h'').
  assumption.
Qed.

Ltac break_let :=
  match goal with
  | |- let x := ?V in @?E x => let h := fresh in
                               pose (x := V);
                               enough (E x) as h; [apply h|]
  | h:let x := ?V in @?E x |- _ => let h' := fresh in
                                   pose (x := V);
                                   assert (E x) as h' by apply h;
                                   clear h; rename h' into h;
                                   cbv beta in h
  end.

Ltac break_let_as y :=
  match goal with
  | |- let x := ?V in @?E x => let h := fresh in
                               pose (y := V);
                               enough (E y) as h; [apply h|]
  | h:let x := ?V in @?E x |- _ => let h' := fresh in
                                   pose (y := V);
                                   assert (E y) as h' by apply h;
                                   clear h; rename h' into h;
                                   cbv beta in h
  end.

Lemma lastNonEmptyList {A l} {a d d':A} : last (a :: l) d = last (a :: l) d'.
  revert a l.
  induction l.
  - cbn.
    reflexivity.
  - cbn in *.
    destruct l.
    + reflexivity.
    + assumption.
Qed.

Lemma lastAppend {A l} {a d:A} : last (l ++ [a]) d = a.
  induction l.
  - cbn.
    reflexivity.
  - cbn in *.
    rewrite IHl.
    destruct l; reflexivity.
Qed.

Lemma breakDepPair {A B} {a a':A} {b:B a} {b':B a'} : (a;b) = (a';b') -> { eq:a' = a | (rew eq in b') = b }.
  intros.
  assert (a' = a) as h by crush.
  refine (exist _ h _).
  crush.
Qed.

Ltac break_sig_uip :=
  match goal with
  | h:(?A;?B) = (?A';?B') |- _ => let eq  := fresh in
                                let h'  := fresh in
                                  destruct (breakDepPair h) as [eq h'];
                                  specialize (UIP_refl _ _ eq);
                                  intros;
                                  subst eq;
                                  cbn in h';
                                  clear h; rename h' into h
  end.

Ltac break_sig :=
  match goal with
  | h:(?A;?B) = (?A';?B') |- _ => let eq  := fresh in
                                let h'  := fresh in
                                let h'' := fresh in
                                  destruct (breakDepPair h) as [eq h'];
                                  destruct eq; cbn in h';
                                  clear h; rename h' into h
  end.

Ltac eliminate_dead_code :=
  match goal with
  | |- context[if ?E then _ else _] => let h := fresh in
                                       first [destruct E as [h|]; [clear h|exfalso; repeat break_sig; congruence] |
                                              destruct E as [|h]; [exfalso; repeat break_sig; congruence|clear h] ]
  end.

Lemma reuseConjProof {P Q:Prop} : P -> (P -> Q) -> P /\ Q.
  intuition.
Qed.

Definition swap_ex_forall {A B} {P:forall (a:A), B a -> Prop} : (forall a, {b | P a b}) -> {b | forall a, P a (b a)}.
  intros h.
  refine (exist _ _ _).
  - intro a.
    destruct (h a) as [b _].
    exact b.
  - intro a.
    cbn.
    destruct (h a).
    assumption.
Defined.

Lemma neqId {A} {P:A->Prop} {a a'} : P a -> (~P a') -> a <> a'.
  congruence.
Qed.


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

(******************************************************************************)
(*                                Frames                                      *)
(*                                                                            *)
(* This defines frames to describe robot manipulators.                        *)
(*                                                                            *)
(* NOFrame.t R == the type of non-oriented frames defined using an orthogonal *)
(*                matrix                                                      *)
(*        f|,i == the ith vector of the frame f with i:'I_3                   *)
(*         f~i == the x vector of frame f (i.e., f|,0)                        *)
(*         f~j == the y vector of frame f (i.e., f|,1)                        *)
(*         f~k== the z vector of frame f (i.e., f|,2%:R)                     *)
(*   Frame.t R == the type of oriented frames, i.e., non-oriented frames f    *)
(*                such that f \is 'SO[R]_3                                    *)
(*   can_frame == the positive frame consisting of the canonical vectors      *)
(*                'e_0, 'e_1, 'e_2                                            *)
(*  TFrame.t R == tangent frames, i.e., positive frames with an origin        *)
(*       \o{F} == origin of the tangent frame F                               *)
(*     xaxis F == the x-axis defined by the tangent frame F                   *)
(*                (resp. yaxis, zaxis)                                        *)
(* Module Base == given a vector u, the vectors Base.i u, Base.j, and         *)
(*                Base.k u form a positive frame                              *)
(*     A _R^ B == the rotation matrix that transforms a vector expressed in   *)
(*                frame A into a vector expressed in frame B                  *)
(*                                                                            *)
(******************************************************************************)

Declare Scope frame_scope.

Reserved Notation "f '|,' i" (at level 3, i at level 2,
  left associativity, format "f '|,' i").
Reserved Notation "f '~i'" (at level 3, left associativity, format "f '~i'").
Reserved Notation "f '~j'" (at level 3, left associativity, format "f '~j'").
Reserved Notation "f '~k'" (at level 3, left associativity, format "f '~k'").
Reserved Notation "'\o{' F '}'" (at level 3, format "'\o{' F '}'").
Reserved Notation "A _R^ B" (at level 5).

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

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

Local Open Scope ring_scope.

Module NOFrameInterface.
Section noframe_interface.
Variable T : rcfType.
Record t : Type := mk {
  i : 'rV[T]_3 ;
  j : 'rV[T]_3 ;
  k : 'rV[T]_3 ;
  normi : norm i = 1 ;
  normj : norm j = 1 ;
  normk : norm k = 1 ;
  idotj : i *d j = 0 ;
  jdotk : j *d k = 0 ;
  idotk : i *d k = 0
}.
End noframe_interface.
End NOFrameInterface.
Definition normi := NOFrameInterface.normi.
Definition normj := NOFrameInterface.normj.
Definition normk := NOFrameInterface.normk.
Definition idotj := NOFrameInterface.idotj.
Definition jdotk := NOFrameInterface.jdotk.
Definition idotk := NOFrameInterface.idotk.

Module NOFrame.
Section non_oriented_frame_def.

Variable T : ringType.
Record t := mk {
  M :> 'M[T]_3 ;
  MO : M \is 'O[T]_3 }.
Parameter rowframe : t -> 'I_3 -> 'rV[T]_3.
Axiom rowframeE : forall f i, rowframe f i = row i (M f).
End non_oriented_frame_def.
End NOFrame.
Notation noframe := NOFrame.t.
Coercion matrix_of_noframe (T : ringType) (f : noframe T) : 'M[T]_3 :=
  NOFrame.M f.

Definition rowframeE := NOFrame.rowframeE.
Notation "f '~i'" := (NOFrame.rowframe f (0 : 'I_3)) : frame_scope.
Notation "f '~j'" := (NOFrame.rowframe f (1 : 'I_3)) : frame_scope.
Notation "f '~k'" := (NOFrame.rowframe f (2%:R : 'I_3)) : frame_scope.
Notation "f '|,' i" := (NOFrame.rowframe f i) : frame_scope.

Local Open Scope frame_scope.

Section non_oriented_frame_properties.
Variable T : realType.
Let vector := 'rV[T]_3.
Implicit Types p : 'rV[T]_3.
Variable f : noframe T.
Import rv3LieAlgebra.Exports.

Lemma noframe_norm (k : 'I_3) : norm f|,k = 1.
Proof. by rewrite rowframeE; apply norm_row_of_O; case: f. Qed.

Lemma noframe_idotj : f~i *d f~j = 0.
Proof. by rewrite !rowframeE; apply/orthogonalP; case: f. Qed.

Lemma noframe_jdotk : f~j *d f~k = 0.
Proof. by rewrite !rowframeE; apply/orthogonalP; case: f. Qed.

Lemma noframe_idotk : f~i *d f~k = 0.
Proof. by rewrite !rowframeE; apply/orthogonalP; case: f. Qed.

Canonical noframe_is_noframe :=
  NOFrameInterface.mk (noframe_norm 0) (noframe_norm 1) (noframe_norm 2%:R)
  noframe_idotj noframe_jdotk noframe_idotk.

Lemma noframe_is_unit : matrix_of_noframe f \is a GRing.unit.
Proof. apply/orthogonal_unit. by case: f. Qed.

Lemma noframe_inv : (matrix_of_noframe f)^-1 = f^T.
Proof. rewrite -orthogonal_inv //; by case: f. Qed.

Lemma norm_icrossj : norm (f~i *v f~j) = 1.
Proof.
by rewrite norm_crossmul_normal // ?idotj // ?normi // normj.
Qed.

Definition noframe_sgn := \det f.

Lemma noframe_sgnE : noframe_sgn = f~i *d (f~j *v f~k).
Proof.
by rewrite crossmul_triple /noframe_sgn -(col_mx3_row f) 3!rowframeE.
Qed.

Lemma abs_noframe_sgn : `| noframe_sgn | = 1.
Proof. apply orthogonal_det; by case: f. Qed.

Lemma noframek : f~k = f~i *v f~j \/ f~k = - f~i *v f~j.
Proof.
move: abs_noframe_sgn; rewrite noframe_sgnE.
case: (lerP 0 (f~i *d (f~j *v f~k))) => [/ger0_norm ->|/ltr0_norm -> /eqP].
- rewrite dot_crossmulC => /dotmul1_inv H.
  by left; rewrite H // ?noframe_norm // norm_icrossj.
- rewrite eqr_oppLR => /eqP.
  rewrite dot_crossmulC => /dotmulN1_inv H.
  by right; rewrite linearNl /= H // ?opprK // ?noframe_norm // norm_icrossj.
Qed.

Lemma noframe_pos : (f~k == f~i *v f~j) = (noframe_sgn == 1).
Proof.
apply/idP/idP => [/eqP H|].
  by rewrite noframe_sgnE H dot_crossmulC dotmulvv norm_icrossj expr1n.
case: noframek => [/eqP //|] /eqP.
rewrite linearNl -eqr_oppLR noframe_sgnE dot_crossmulC => /eqP <-.
by rewrite dotmulNv dotmulvv noframe_norm expr1n eqrNxx oner_eq0.
Qed.

Lemma noframe_neg : (f~k == - f~i *v f~j) = (noframe_sgn == - 1).
Proof.
apply/idP/idP => [/eqP H|].
- rewrite noframe_sgnE H dot_crossmulC linearNl dotmulvN dotmulvv.
  by rewrite norm_icrossj expr1n.
case: noframek => [|/eqP //] /eqP.
rewrite noframe_sgnE => /eqP ->.
rewrite double_crossmul dotmulvv normj expr1n scale1r (dotmulC f~j) idotj.
by rewrite scale0r subr0 dotmulvv normi expr1n -eqr_oppLR eqrNxx oner_eq0.
Qed.

Lemma noframe_posP : f~k = f~i *v f~j -> f~j = f~k *v f~i /\ f~i = f~j *v f~k.
Proof.
move=> ->; split.
- rewrite (lieC _ f~i) /= double_crossmul idotj scale0r add0r opprK.
  by rewrite dotmulvv noframe_norm expr1n scale1r.
- rewrite double_crossmul dotmulvv noframe_norm expr1n scale1r dotmulC.
  by rewrite idotj scale0r subr0.
Qed.

Lemma noframe_negP : f~k = - f~i *v f~j -> f~j = f~i *v f~k /\ f~i = f~k *v f~j.
Proof.
move=> ->; split.
- rewrite linearNl /= linearNr /= double_crossmul dotmulvv.
  by rewrite noframe_norm expr1n scale1r idotj scale0r add0r opprK.
- rewrite linearNl lieC linearNr opprK /= double_crossmul dotmulvv.
  by rewrite noframe_norm expr1n scale1r dotmulC idotj scale0r subr0.
Qed.

Lemma orthogonal_expansion_helper p :
  p *d f~i = 0 -> p *d f~j = 0 -> p *d f~k = 0 -> p = 0.
Proof.
do 3 rewrite dotmulE sum3E.
move=> H1 H2 H3.
have /eqP : p *m (col_mx3 f~i f~j f~k) ^T = 0.
  by rewrite mul_tr_col_mx3 dotmulE sum3E H1 dotmulE sum3E H2 dotmulE sum3E H3 row30.
rewrite mul_mx_rowfree_eq0; first by move/eqP.
apply/row_freeP; exists (col_mx3 f~i f~j f~k).
by apply/eqP; rewrite -orthogonalEC !rowframeE col_mx3_row (NOFrame.MO _).
Qed.

Lemma orthogonal_expansion p :
  p = (p *d f~i) *: f~i + (p *d f~j) *: f~j + (p *d f~k) *: f~k.
Proof.
set y : 'rV[T]_3 := (p *d f~i) *: f~i + (p *d f~j) *: f~j + (p *d f~k) *: f~k.
suff /eqP : p - y = 0; first by rewrite subr_eq0 => /eqP.
apply orthogonal_expansion_helper.
- rewrite dotmulDl dotmulNv /y 2!dotmulDl dotmulZv dotmulvv noframe_norm expr1n mulr1.
  rewrite 2!opprD 2!addrA subrr add0r dotmulZv (dotmulC f~j) idotj mulr0 oppr0.
  by rewrite dotmulZv (dotmulC f~k) idotk mulr0 subrr.
- rewrite dotmulDl dotmulNv /y 2!dotmulDl dotmulZv idotj mulr0 add0r.
  rewrite dotmulZv dotmulvv noframe_norm expr1n mulr1 opprD addrA subrr.
  by rewrite dotmulZv (dotmulC f~k) jdotk mulr0 subrr.
- rewrite dotmulDl dotmulNv /y 2!dotmulDl dotmulZv idotk mulr0 add0r dotmulZv.
  by rewrite jdotk mulr0 add0r dotmulZv dotmulvv noframe_norm expr1n mulr1 subrr.
Qed.

(* [oneill] lemma 3.5, p.110 *)
Lemma crossmul_noframe_sgn v v1 v2 v3 w w1 w2 w3 :
  v = v1 *: f~i + v2 *: f~j + v3 *: f~k ->
  w = w1 *: f~i + w2 *: f~j + w3 *: f~k ->
  v *v w = noframe_sgn *: ((v2 * w3 - v3 * w2) *: f~i -
                           (v1 * w3 - v3 * w1) *: f~j +
                           (v1 * w2 - v2 * w1) *: f~k).
Proof.
move=> -> ->.
rewrite !linearD /=.
rewrite !linearZ /=.
rewrite (lieC _ f~i).
rewrite (lieC _ f~j).
rewrite (lieC _ f~k).
rewrite ![in LHS]linearD /=.
rewrite (_ : _ *v _ = 0); last by rewrite linearZ /= liexx scaler0.
rewrite oppr0 scaler0 add0r.
case: noframek => e3e1e2.
- case: (noframe_posP e3e1e2) => Hj Hi.
  rewrite (_ : _ *v _ = v2 *: f~k); last by rewrite linearZ /= -e3e1e2.
  rewrite scalerN (_ : _ *v _ = - v3 *: f~j); last first.
    by rewrite linearZ /= lieC /= -Hj scalerN scaleNr.
  rewrite scaleNr opprK (_ : _ *v _ = - v1 *: f~k); last first.
    by rewrite linearZ /= lieC e3e1e2 scalerN scaleNr.
  rewrite scaleNr opprK (_ : _ *v _ = 0); last first.
    by rewrite linearZ /= liexx scaler0.
  rewrite scalerN scaler0 subr0.
  rewrite (_ : _ *v _ = v3 *: f~i); last by rewrite linearZ /= -Hi.
  rewrite scalerN (_ : _ *v _ = v1 *: f~j); last by rewrite linearZ /= Hj.
  rewrite scalerN (_ : _ *v _ = - v2 *: f~i); last first.
    by rewrite linearZ /= lieC /= -Hi scaleNr scalerN.
  rewrite scaleNr opprK (_ : _ *v _ = 0); last first.
    by rewrite linearZ /= liexx scaler0.
  rewrite scalerN scaler0 subr0.
  move/esym : noframe_pos; rewrite e3e1e2 eqxx => /eqP ->.
  rewrite !scale1r -![in LHS]addrA addrC.
  rewrite -![in LHS]addrA.
  rewrite addrCA.
  rewrite addrC.
  rewrite ![in LHS]addrA.
  rewrite -addrA; congr (_ + _); last first.
    by rewrite !scalerA -scaleNr -scalerDl /= addrC mulrC (mulrC w1).
  rewrite -addrA addrACA addrC; congr (_ + _).
    by rewrite -scaleNr !scalerA -scalerDl addrC mulrC mulNr (mulrC w2).
  by rewrite !scalerA -scalerBl scalerN -scaleNr opprB mulrC (mulrC w3).
- case: (noframe_negP e3e1e2) => Hj Hi.
  rewrite (_ : _ *v _ = - v2 *: f~k); last first.
    by rewrite linearZ /= e3e1e2 linearNl scalerN scaleNr opprK.
  rewrite scaleNr opprK.
  rewrite (_ : _ *v _ = v3 *: f~j); last by rewrite linearZ /= -Hj.
  rewrite scalerN.
  rewrite (_ : _ *v _ = v1 *: f~k); last first.
    by rewrite linearZ /= lieC -linearNl /= -e3e1e2.
  rewrite scalerN.
  rewrite (_ : _ *v _ = 0); last by rewrite linearZ /= liexx scaler0.
  rewrite oppr0 scaler0 addr0.
  rewrite (_ : _ *v _ = - v3 *: f~i); last first.
    by rewrite linearZ /= lieC /= -Hi scalerN scaleNr.
  rewrite scaleNr opprK.
  rewrite (_ : _ *v _ = - v1 *: f~j); last first.
    by rewrite linearZ /= lieC /= -Hj scalerN scaleNr.
  rewrite scaleNr opprK.
  rewrite (_ : _ *v _ = v2 *: f~i); last by rewrite linearZ /= -Hi.
  rewrite scalerN.
  rewrite (_ : _ *v _ = 0); last by rewrite linearZ /= liexx scaler0.
  rewrite oppr0 scaler0 addr0.
  move: noframe_neg; rewrite {1}e3e1e2 eqxx => /esym/eqP ->.
  rewrite -![in LHS]addrA addrC -addrA.
  rewrite addrCA -addrA addrC ![in LHS]addrA -addrA; congr (_ + _); last first.
    by rewrite !scalerA -scalerBl mulrN1 opprB mulrC (mulrC w2).
  rewrite -addrA addrACA; congr (_ + _).
    by rewrite !scalerA -scalerBl mulrN1 opprB mulrC (mulrC w3).
  by rewrite !scalerA -scalerBl scalerN mulrN1 scaleNr opprK mulrC (mulrC w1).
Qed.

End non_oriented_frame_properties.

Module FrameInterface.
Section frame_interface.
Variable T : rcfType.
Record t : Type := mk {
  f : NOFrameInterface.t T ;
  icrossj : NOFrameInterface.i f *v NOFrameInterface.j f = NOFrameInterface.k f
}.
End frame_interface.
End FrameInterface.
Definition icrossj := FrameInterface.icrossj.

Module Frame.
Section frame.
Variable T : ringType.
Record t := mk {
  noframe_of :> noframe T ;
  MSO : NOFrame.M noframe_of \is 'SO[T]_3}.
End frame.
End Frame.
Notation frame := Frame.t.
Coercion noframe_of_frame (T : ringType) (f : frame T) : noframe T :=
  Frame.noframe_of f.

Section oriented_frame_properties.
Variables (T : realType) (f : Frame.t T).
Import rv3LieAlgebra.Exports.

(* TODO: useful? *)
Lemma frame_icrossj : f~i *v f~j = f~k.
Proof. by move: (Frame.MSO f); rewrite !rowframeE => /SO_icrossj. Qed.

Lemma frame_icrossk : f~i *v f~k = - f~j.
Proof. by move: (Frame.MSO f); rewrite !rowframeE => /SO_icrossk. Qed.

Lemma frame_kcrossi : f~k *v f~i = f~j.
Proof. by rewrite lieC /= frame_icrossk opprK. Qed.

Lemma frame_jcrossk : f~j *v f~k = f~i.
Proof. by move: (Frame.MSO f); rewrite !rowframeE => /SO_jcrossk. Qed.

Lemma frame_kcrossj : f~k *v f~j = - f~i.
Proof. by rewrite lieC /= frame_jcrossk. Qed.

Definition frame_of_SO (M : 'M[T]_3) (HM : M \is 'SO[T]_3) : frame T :=
  @Frame.mk _ (NOFrame.mk (rotation_sub HM)) HM.

Lemma frame_of_SO_i (M : 'M[T]_3) (HM : M \is 'SO[T]_3) :
  (frame_of_SO HM)~i = row 0 M.
Proof. by rewrite /frame_of_SO /= NOFrame.rowframeE. Qed.

Lemma frame_of_SO_j (M : 'M[T]_3) (HM : M \is 'SO[T]_3) :
  (frame_of_SO HM)~j = row 1 M.
Proof. by rewrite /frame_of_SO /= NOFrame.rowframeE. Qed.

Lemma frame_of_SO_k (M : 'M[T]_3) (HM : M \is 'SO[T]_3) :
  (frame_of_SO HM)~k = row 2%:R M.
Proof. by rewrite /frame_of_SO /= NOFrame.rowframeE. Qed.

(* negative frame *)
Record nframe := mkNFrame {
  noframe_of_nframe :> noframe T ;
  nframeP : noframe_sgn noframe_of_nframe = -1}.

(*NB: remove?
Lemma pframe_swap01 i j k : pframe i j k -> pframe j (- i) k.
Proof.
case => -[] i1 j1 k1 ij jk ik Hsgn.
apply: mkPFrame.
  apply: mkNOFrame => //.
  by rewrite normN.
  by rewrite dotmulvN dotmulC ij oppr0.
  by rewrite dotmulNv ik oppr0.
move=> f.
rewrite /frame_sgn dotmul_crossmulA linearN /= crossmulC -(icrossj (mkPFrame Hsgn)).
by rewrite opprK dotmulvv k1 expr1n.
Qed.
*)

End oriented_frame_properties.

Canonical frame_subtype (T : ringType) := [subType for @Frame.noframe_of T].

(* frame with an origin (tangent frame) *)
Module TFrame.
Section tframe.
Variable T : ringType.
Let point := 'rV[T]_3.
Let vector := 'rV[T]_3.
Record t := mk {
  o : point ;
  frame_of :> frame T }.
Definition trans (f : t) (u : vector) : t := mk (o f + u) f.
End tframe.
End TFrame.
Notation tframe := TFrame.t.
Coercion frame_of_tframe (T : ringType) (f : tframe T) : frame T :=
  TFrame.frame_of f.

Notation "'\o{' F '}'" := (TFrame.o F) : frame_scope.

Definition xaxis (T : fieldType) (F : tframe T) := Line.mk \o{F} F~i.
Definition yaxis (T : fieldType) (F : tframe T) := Line.mk \o{F} F~j.
Definition zaxis (T : fieldType) (F : tframe T) := Line.mk \o{F} F~k.

Section canonical_frame.

Variable T : comUnitRingType.

Definition can_noframe := NOFrame.mk (@orthogonal1 2 T).

Lemma can_frame_is_SO : NOFrame.M can_noframe \is 'SO[T]_3.
Proof. by rewrite /= rotationE det1 orthogonal1 eqxx. Qed.

Definition can_frame := Frame.mk can_frame_is_SO.

Lemma can_frame_1 : can_frame = 1 :> 'M_3.
Proof. by apply/matrix3P/and9P; split; rewrite !mxE. Qed.

(* TODO: useful? *)
Lemma rotation_can_frame (f : frame T) i j : f i j = row j can_frame *d row i f.
Proof. by rewrite /can_frame /= /can_noframe /= row1 mxE_dotmul. Qed.

Definition can_tframe := TFrame.mk 0 can_frame.

End canonical_frame.

Lemma basis_change (T : realType) (M : 'M[T]_3) (F : noframe T) (A : 'M[T]_3) :
  let i := F~i in let j := F~j in let k := F~k in
  i *m M = A 0 0 *: i + A 0 1 *: j + A 0 2%:R *: k ->
  j *m M = A 1 0 *: i + A 1 1 *: j + A 1 2%:R *: k ->
  k *m M = A 2%:R 0 *: i + A 2%:R 1 *: j + A 2%:R 2%:R *: k ->
  let P := col_mx3 i j k in
  M = P^-1 * A * P.
Proof.
move=> i j k H1 H2 H3 P.
have : P * M = A * P.
  rewrite /P -(col_mx3_mul M) -(col_mx3_row A) -col_mx3_mul H1 H2 H3.
  by congr col_mx3; apply/rowP => a; rewrite !mxE sum3E !mxE.
rewrite -mulrA => <-.
rewrite mulrA mulVr ?mul1r // unitmxE unitfE /P -crossmul_triple.
by rewrite -normr_gt0 -noframe_sgnE (abs_noframe_sgn F) ltr01.
Qed.

Module Base1.
Section base1.
Variables (T : realType) (i : 'rV[T]_3).
Hypothesis normi : norm i = 1.
Import rv3LieAlgebra.Exports.

Definition j := if colinear i 'e_0 then 'e_1 else normalize (normalcomp 'e_0 i).

Definition k := i *v j.

Lemma idotj : i *d j = 0.
Proof.
rewrite /j; case: ifPn => [|_]; last first.
  by rewrite dotmulvZ -{3}(normalizeI normi) dotmul_orthogonalize mulr0.
case/colinearP => [| [_ [k ->]]].
  by rewrite -norm_eq0 norm_delta_mx (negbTE (oner_neq0 _)).
by rewrite dotmulZv dote2 mulr0.
Qed.

Lemma idotk : i *d k = 0.
Proof. by rewrite /k dot_crossmulC liexx dotmul0v. Qed.

Lemma jdotk : j *d k = 0.
Proof. by rewrite /k dot_crossmulCA liexx dotmulv0. Qed.

Lemma normj : norm j = 1.
Proof.
rewrite /j; case: ifPn => iVi; first by rewrite norm_delta_mx.
rewrite norm_normalize //; apply: contra iVi.
by rewrite normalcomp_colinear // ?norm1_neq0 // colinear_sym.
Qed.

Lemma normk : norm k = 1.
Proof.
by rewrite /k norm_crossmul_normal // ?norm_normalize// ?normj// idotj // mulr0.
Qed.

Definition M := col_mx3 i j k.

Lemma is_O : M \is 'O[T]_3.
Proof.
apply/orthogonal3P;
  by rewrite !rowK /= normi normj normk idotj idotk jdotk !eqxx.
Qed.

Definition noframe := NOFrame.mk is_O.

Lemma is_SO : NOFrame.M noframe \is 'SO[T]_3.
Proof. apply/rotation3P; by rewrite !rowK /= normi normj idotj !eqxx. Qed.

Definition frame := Frame.mk is_SO.

End base1.

Section base1_lemmas.
Variable T : realType.

(* NB: for information *)
Lemma je0 : j 'e_0 = 'e_1 :> 'rV[T]_3.
Proof. by rewrite /j colinear_refl. Qed.

Lemma ke0 : k 'e_0 = 'e_2%:R :> 'rV[T]_3.
Proof.
by rewrite /k /j colinear_refl vece2 odd_perm301 -exprnP expr0 scale1r.
Qed.

Variable u : 'rV[T]_3.

Lemma jN : j (- u) = j u.
Proof. by rewrite /j colinearNv normalcompvN. Qed.

Lemma kN : k (- u) = - k u.
Proof.
by rewrite /k (_ : j (- u) = j u); [rewrite linearNl | rewrite -jN].
Qed.

End base1_lemmas.
End Base1.

Canonical base1_is_noframe (T : realType) (u : 'rV[T]_3) (u1 : norm u = 1) :=
  NOFrameInterface.mk u1 (Base1.normj u1) (Base1.normk u1)
  (Base1.idotj u1) (Base1.jdotk u) (Base1.idotk u).

Canonical noframe_subtype (T : rcfType) := [subType for @NOFrame.M T].

Module Base.
Section build_base.
Variables (T : realType) (u : 'rV[T]_3).

Definition i := if u == 0 then 'e_0 else normalize u.
Definition j := if u == 0 then 'e_1 else Base1.j i.
Definition k := if u == 0 then 'e_2%:R else Base1.k i.

Lemma normi : norm i = 1.
Proof.
rewrite /i; case: ifP => [_|/eqP/eqP ?]; by rewrite ?normeE // norm_normalize.
Qed.

Parameter frame : 'rV[T]_3 -> frame T.
Axiom frameE : frame u = Base1.frame normi.

Lemma iE : i = (frame u)~i.
Proof. by rewrite !rowframeE frameE rowK. Qed.
Lemma jE : j = (frame u)~j.
Proof.
rewrite !rowframeE frameE /= !rowK /= /j; case: ifP => // u0.
by rewrite /Base1.j /i u0 colinear_refl.
Qed.
Lemma kE : k = (frame u)~k.
Proof.
rewrite !rowframeE frameE /= !rowK /= /k; case: ifP => // u0.
by rewrite /Base1.k /Base1.j /i u0 colinear_refl vecij.
Qed.

Lemma frame0E (u0 : u != 0) : (frame u)~i = normalize u.
Proof. by rewrite -iE /i (negbTE u0). Qed.

Lemma normj : norm j = 1.
Proof. by rewrite jE rowframeE norm_row_of_O // NOFrame.MO. Qed.
Lemma normk : norm k = 1.
Proof. by rewrite kE rowframeE norm_row_of_O // NOFrame.MO. Qed.

Lemma idotj : i *d j = 0.
Proof. by rewrite iE jE !rowframeE dot_row_of_O // NOFrame.MO. Qed.
Lemma idotk : i *d k = 0.
Proof. by rewrite iE kE !rowframeE dot_row_of_O // NOFrame.MO. Qed.
Lemma jdotk : j *d k = 0.
Proof. by rewrite jE kE !rowframeE dot_row_of_O // NOFrame.MO. Qed.

Lemma icrossj : i *v j = k.
Proof. by rewrite iE jE !rowframeE SO_icrossj ?Frame.MSO // -rowframeE -kE. Qed.
Lemma icrossk : i *v k = - j.
Proof. by rewrite iE kE !rowframeE SO_icrossk ?Frame.MSO // -rowframeE -jE. Qed.
Lemma jcrossk : j *v k = i.
Proof. by rewrite jE kE !rowframeE SO_jcrossk ?Frame.MSO // -rowframeE -iE. Qed.

Lemma is_SO : col_mx3 (frame u)~i (frame u)~j (frame u)~k \is 'SO[T]_3.
Proof. by rewrite !rowframeE col_mx3_row Frame.MSO. Qed.

End build_base.

Section build_base_lemmas.
Variables (T : realType) (u : 'rV[T]_3).

Lemma frame0 : frame 0 = can_frame T.
Proof.
do 2 apply val_inj => /=.
apply/row_matrixP => i; rewrite row1.
case/boolP : (i == 0) => [|/ifnot0P/orP[]]/eqP->;
  rewrite frameE /= rowK /= /Base.i eqxx //.
- by rewrite /Base1.j colinear_refl.
- by rewrite /Base1.k /Base1.j colinear_refl vecij.
Qed.

Section scalar.
Variable (p : T).
Section scalar_pos.
Hypothesis p0 : 0 < p.

Lemma iZ : (frame (p *: u))~i = (frame u)~i.
Proof.
rewrite -!iE /i scaler_eq0 (gt_eqF p0) /=; case: ifP => // /eqP/eqP ?.
by rewrite normalizeZ.
Qed.

Lemma jZ_helper : j (p *: u) = j u.
Proof. by rewrite /j scaler_eq0 (gt_eqF p0) /= iE iZ -iE. Qed.

Lemma jZ : (frame (p *: u))~j = (frame u)~j.
Proof. by rewrite -2!jE jZ_helper. Qed.

Lemma kZ_helper : k (p *: u) = k u.
Proof. by rewrite /k scaler_eq0 (gt_eqF p0) /= /Base1.k iE iZ -iE. Qed.

Lemma kZ : (frame (p *: u))~k = (frame u)~k.
Proof. by rewrite -2!kE kZ_helper. Qed.

Lemma Z : frame (p *: u) = frame u.
Proof.
do 2 apply val_inj => /=.
apply/row_matrixP => i; rewrite -!rowframeE.
case/boolP : (i == 0) => [|/ifnot0P/orP[]]/eqP->; by
  [rewrite iZ| rewrite jZ|rewrite kZ].
Qed.
End scalar_pos.

Lemma iN_helper (u0 : u != 0) : i (- u) = - i u.
Proof. by rewrite /i eqr_oppLR oppr0 (negbTE u0) normalizeN. Qed.

Lemma iN (u0 : u != 0) : (frame (- u))~i = - (frame u)~i.
Proof. by rewrite -2!iE iN_helper. Qed.

Lemma jN_helper : j (- u) = j u.
Proof.
rewrite /j eqr_oppLR oppr0; case/boolP : (u == 0) => u0; first reflexivity.
by rewrite (iN_helper u0) Base1.jN.
Qed.

Lemma jN : (frame (- u))~j = (frame u)~j.
Proof. by rewrite -2!jE jN_helper. Qed.

Lemma kN_helper (u0 : u != 0) : k (- u) = - k u.
Proof.
by rewrite /k eqr_oppLR oppr0 (negbTE u0) iN_helper // Base1.kN.
Qed.

Lemma kN (u0 : u != 0) : (frame (- u))~k = - (frame u)~k.
Proof. by rewrite -2!kE kN_helper. Qed.

Section scalar_neg.
Hypothesis p0 : p < 0.

Lemma jZN_helper : j (p *: u) = j u.
Proof.
rewrite /j /i !scaler_eq0 (lt_eqF p0); case/boolP : (u == 0) => u0 /=.
reflexivity.
by rewrite -(opprK p) scaleNr normalizeN Base1.jN normalizeZ // -oppr_lt0 opprK.
Qed.

Lemma jZN : (frame (p *: u))~j = (frame u)~j.
Proof. by rewrite -2!jE jZN_helper. Qed.

Lemma kZN_helper (u0 : u != 0) : k (p *: u) = - k u.
Proof.
rewrite /k /i scaler_eq0 (lt_eqF p0) /= (negbTE u0).
by rewrite -(opprK p) scaleNr normalizeN Base1.kN normalizeZ // oppr_gt0.
Qed.

Lemma kZN (u0 : u != 0) : (frame (p *: u))~k = - (frame u)~k.
Proof. by rewrite -2!kE kZN_helper // (negbTE u0). Qed.

Lemma ZN : frame (p *: u) = frame (- u).
Proof.
case/boolP : (u == 0) => [/eqP ->|u0]; first by rewrite scaler0 oppr0.
do 2 apply val_inj => /=.
apply/row_matrixP => i; rewrite -rowframeE.
case/boolP : (i == 0) => [|/ifnot0P/orP[]]/eqP->.
- rewrite frame0E ?scaler_eq0 ?negb_or ?u0 ?lt_eqF // -rowframeE iN //.
  by rewrite frame0E // -(opprK p) scaleNr normalizeN normalizeZ // oppr_gt0.
- by rewrite -rowframeE jZN // jN.
- by rewrite -rowframeE kZN // kN.
Qed.

End scalar_neg.
End scalar.

Lemma j_tr_mul (v : 'rV[T]_3) (v1 : norm v = 1) : j v *m v^T = 0.
Proof.
rewrite /j (negbTE (norm1_neq0 v1)) /Base1.j.
case: ifPn => [|_].
  case/colinearP => [|[_[k Hk]]].
    move/eqP/rowP/(_ ord0).
    rewrite !mxE !eqxx /= => /eqP; by rewrite oner_eq0.
  rewrite /i (negbTE (norm1_neq0 v1)) normalizeI // in Hk.
  by rewrite dotmulP Hk dotmulvZ dote2 oner_eq0 mulr0 (mx11_scalar 0) mxE.
apply/eqP.
rewrite -scalemxAl scaler_eq0 {2}/i (negbTE (norm1_neq0 v1)) normalizeI //.
by rewrite normalcomp_mul_tr // orbT.
Qed.

Import rv3LieAlgebra.Exports.

Lemma k_tr_mul (v : 'rV[T]_3) (v1 : norm v = 1) : k v *m v^T *m v = 0.
Proof.
rewrite /k (negbTE (norm1_neq0 v1)) /Base1.k /Base1.j.
case: ifPn => [|_].
  case/colinearP => [|[_[k Hk]]].
    move/eqP/rowP/(_ ord0).
    rewrite !mxE !eqxx /= => /eqP; by rewrite oner_eq0.
  rewrite /i (negbTE (norm1_neq0 v1)) normalizeI // in Hk.
  rewrite /i (negbTE (norm1_neq0 v1)) normalizeI //.
  rewrite {1}Hk linearZl_LR /= vecij -2!scalemxAl {1}Hk linearZ /= -scalemxAr.
  by rewrite dotmulP dote2 scale_scalar_mx mulr0 mul_scalar_mx scale0r scaler0.
apply/eqP.
rewrite /normalize linearZr_LR -!scalemxAl scaler_eq0; apply/orP; right.
rewrite /normalcomp linearD /= linearNr 2!linearZr_LR /= liexx 2!scaler0 subr0.
move: (axialcompE (v *v 'e_0) v).
rewrite v1 expr1n invr1 scale1r /i (negbTE (norm1_neq0 v1)) normalizeI // => <-.
by rewrite axialcomp_crossmul.
Qed.

End build_base_lemmas.

End Base.

Lemma colinear_frame0a (T : realType) (u : 'rV[T]_3) : colinear (Base.frame u)~i u.
Proof.
case/boolP : (u == 0) => [/eqP ->|u0]; first by rewrite colinear0.
by rewrite -Base.iE /Base.i (negbTE u0) scale_colinear.
Qed.

Lemma colinear_frame0b (T : realType) (u : 'rV[T]_3) : colinear u (Base.frame u)~i.
Proof. by rewrite colinear_sym colinear_frame0a. Qed.

Definition colinear_frame0 := (colinear_frame0a, colinear_frame0b).

Canonical base_is_noframe (T : realType) (u : 'rV[T]_3) :=
  NOFrameInterface.mk (Base.normi u) (Base.normj u) (Base.normk u)
  (Base.idotj u) (Base.jdotk u) (Base.idotk u).

Canonical frame_is_frame (T : realType) (u : 'rV[T]_3) :=
  @FrameInterface.mk _ (base_is_noframe u) (Base.icrossj u).

(*Module Frame.
Section frame_section.
Variable R : rcfType.
Local Notation coordinate := 'rV[R]_3.
Local Notation basisType := 'M[R]_3.
Definition x_ax : basisType -> 'rV[R]_3 := row 0.
Definition y_ax : basisType -> 'rV[R]_3 := row 1%R.
Definition z_ax : basisType -> 'rV[R]_3 := row 2%:R.

Record t := mkT {
  origin : coordinate ;
  basis :> basisType ;
  _ : unitmx basis }.

Lemma unit (f : t) : basis f \in GRing.unit. Proof. by case: f. Qed.
End frame_section.
End Frame.

Coercion Framebasis R (f : Frame.t R) : 'M[R]_3 := Frame.basis f.
*)
(*Hint Immediate Frame.unit.*)

(* base vectors of A in terms of the basis vectors of B: *)
Definition FromTo (T : comRingType) (A B : frame T) :=
  \matrix_(i, j) (row i A *d row j B).
(* = the rotation matrix that transforms a vector expressed in coordinate frame B
   to a vector expressed in coordinate frame A *)
(* = orientation of frame A relative to B? *)

Notation "A _R^ B" := (@FromTo _ A B) : frame_scope.

Section FromTo_properties.

Variable T : realType.
Implicit Types A B C : frame T.

Lemma FromToE A B : (A _R^ B) = A *m (matrix_of_noframe B)^-1 :> 'M[T]_3.
Proof.
apply/matrixP => i j.
rewrite mxE dotmulE /= mxE; apply eq_bigr => /= k _.
rewrite mxE; congr (_ * _).
by rewrite mxE noframe_inv [in RHS]mxE.
Qed.

Lemma FromTo_to_can A : A _R^ (can_frame T) = A.
Proof. by rewrite FromToE can_frame_1 invr1 mulmx1. Qed.

Lemma FromTo_from_can A : (can_frame T) _R^ A = A^T.
Proof. by rewrite FromToE can_frame_1 mul1mx noframe_inv. Qed.

Lemma FromToI A : A _R^ A = 1.
Proof. by rewrite FromToE mulmxE mulrV // noframe_is_unit. Qed.

Lemma trmx_FromTo A B : (A _R^ B)^T = B _R^ A.
Proof. apply/matrix3P/and9P; split; rewrite !mxE /=; by rewrite dotmulC. Qed.

Lemma FromTo_is_O A B : A _R^ B \is 'O[T]_3.
Proof.
rewrite orthogonalE FromToE trmx_mul.
rewrite {2}(noframe_inv B) trmxK -mulmxE mulmxA -(mulmxA _ (matrix_of_noframe B)^-1).
by rewrite mulVmx ?noframe_is_unit // mulmx1 -noframe_inv mulmxV // noframe_is_unit.
Qed.

Lemma FromTo_unit A B : A _R^ B \is a GRing.unit.
Proof. exact/orthogonal_unit/FromTo_is_O. Qed.

Lemma FromTo_is_SO A B : A _R^ B \is 'SO[T]_3.
Proof.
by rewrite FromToE rpredM // ?Frame.MSO // noframe_inv rotationV Frame.MSO.
Qed.

Lemma FromTo_comp A B C : (C _R^ B) *m (B _R^ A) = C _R^ A.
Proof.
rewrite 2!FromToE -mulmxA (mulmxA _ B) mulVmx; last first.
  by rewrite unitmxE (rotation_det (Frame.MSO B)) unitr1.
rewrite mul1mx; apply/matrixP => i j.
rewrite !mxE dotmulE; apply/eq_bigr => k _.
rewrite 2![row _ _ _ _]mxE; congr (_ * _).
by rewrite noframe_inv mxE.
Qed.

End FromTo_properties.

(* TODO: move? *)
Lemma sqr_norm_frame (T : realType) (a : frame T) (v : 'rV[T]_3) :
  norm v ^+ 2 = \sum_(i < 3) (v *d (a |, i%:R))^+2.
Proof.
have H : norm v = norm (v *m (can_frame T) _R^ a).
  by rewrite orth_preserves_norm // FromTo_is_O.
rewrite H sqr_norm [in LHS]sum3E [in RHS]sum3E; congr (_ ^+ 2 + _ ^+ 2 + _ ^+ 2);
  by rewrite FromTo_from_can mxE_dotmul_row_col -tr_row trmxK row_id NOFrame.rowframeE.
Qed.

Definition noframe_of_FromTo (T : realType) (A B : frame T) : noframe T :=
  NOFrame.mk (FromTo_is_O A B).

Definition frame_of_FromTo (T : realType) (B A : frame T) : frame T :=
  @Frame.mk _ (noframe_of_FromTo B A) (FromTo_is_SO B A).

Module FramedVect.
Section framed_vector.
Variable T : ringType.
Record t (F : frame T) := mk { v : 'rV[T]_3 }.
End framed_vector.
End FramedVect.
Notation fvec := FramedVect.t.

Notation "`[ v $ F ]" := (FramedVect.mk F v)
  (at level 5, v, F at next level, format "`[ v  $  F ]").

Definition FramedVect_add (T : ringType) (F : tframe T) (a b : fvec F) : fvec F :=
  `[ FramedVect.v a + FramedVect.v b $ F ].

Notation "a \+f b" := (FramedVect_add a b) (at level 39).

Lemma fv_eq (T : ringType) a b : a = b -> forall F : frame T, `[ a $ F ] = `[ b $ F ].
Proof. by move=> ->. Qed.

Section change_of_coordinate_by_rotation.

Variable T : realType.
Implicit Types A B : frame T.

Lemma FramedVectvK A (x : fvec A) : `[FramedVect.v x $ A] = x.
Proof. by case: x. Qed.

(* change of coordinates: "rotation mapping" from frame A to frame B *)
Definition rmap A B (x : fvec A) : fvec B := `[FramedVect.v x *m (A _R^ B) $ B].

Lemma rmapK A B (x : fvec A) : rmap A (rmap B x) = x.
Proof.
rewrite /rmap /= 2!FromToE -2!mulmxA (mulmxA (matrix_of_noframe B)^-1).
rewrite mulmxE mulVr ?noframe_is_unit // mulmxA mul1r -mulmxA mulmxE.
by rewrite divrr ?noframe_is_unit // mulmx1 /= FramedVectvK.
Qed.

Lemma rmapE A B (x : 'rV[T]_3) :
  rmap B `[x $ A] = `[x *m A (*A->can*) *m B^T(*can->B*) $ B].
Proof. by rewrite /rmap FromToE noframe_inv mulmxA. Qed.

Lemma rmapE_from_can A (x : 'rV[T]_3) :
  rmap A `[x $ can_tframe T] = `[x *m A^T $ A].
Proof. by rewrite rmapE can_frame_1 mulmx1. Qed.

Lemma rmapE_to_can A (x : 'rV[T]_3) :
  rmap (can_tframe T) `[x $ A] = `[x *m A $ can_tframe T].
Proof. by rewrite rmapE can_frame_1 trmx1 mulmx1. Qed.

End change_of_coordinate_by_rotation.

(*Section about_frame.

Variable R : rcfType.
Let coordinate := 'rV[R]_3.
Let vector := 'rV[R]_3.
Let frame := Frame.t R.

(* coordinate in frame f *)
Inductive coor (f : frame) : Type := Coor of 'rV[R]_3.

Definition absolute_coor (f : frame) (x : coor f) : 'rV[R]_3 :=
  match x with Coor v => Frame.origin f + v *m Frame.basis f end.

Definition relative_coor f (x : coordinate) : coor f :=
  Coor _ ((x - Frame.origin f) *m (Frame.basis f)^-1).

Lemma absolute_coorK f (x : coor f) : relative_coor f (absolute_coor x) = x.
Proof.
case: x => /= v.
by rewrite /relative_coor addrC addKr -mulmxA mulmxV // ?mulmx1 // Frame.unit.
Qed.

Lemma relative_coorK f (x : coordinate) : absolute_coor (relative_coor f x) = x.
Proof. by rewrite /= -mulmxA mulVmx // ?Frame.unit // mulmx1 addrC addrNK. Qed.

(* vector in frame f *)
Inductive vec (f : frame) : Type := Vec of 'rV[R]_3.

Definition absolute_vec f (x : vec f) : 'rV[R]_3 :=
  match x with Vec v => v *m Frame.basis f end.

Definition relative_vec f (x : vector) : vec f :=
  Vec _ (x *m (Frame.basis f)^-1).

Lemma absolute_vecK f (x : vec f) : relative_vec f (absolute_vec x) = x.
Proof. case: x => /= v. by rewrite /relative_vec -mulmxA mulmxV // ?Frame.unit // mulmx1. Qed.

Lemma relative_vecK f (x : vector) : absolute_vec (relative_vec f x) = x.
Proof. by rewrite /= -mulmxA mulVmx // ?Frame.unit // mulmx1. Qed.

End about_frame.*)

(* construction of a frame out of three non-colinear points *)
Module triad.
Section triad.
Variable T : realType.
Let point := 'rV[T]_3.

Variables a b c : point.
Hypothesis ab : a != b.
Hypothesis abc : ~~ colinear (b - a) (c - a).

Import rv3LieAlgebra.Exports.

Definition i := normalize (b - a).

Definition j := normalize (normalcomp (c - a) i).

Definition k := i *v j.

Definition t := (i, j, k).

Let ac : a != c.
Proof. by apply: contra abc => /eqP ->; rewrite subrr /colinear linear0r. Qed.

Lemma normi : norm i = 1.
Proof. by rewrite /i norm_normalize // subr_eq0 eq_sym. Qed.

Lemma i_neq0 : i != 0.
Proof. by rewrite -norm_eq0 normi oner_neq0. Qed.

Lemma normj : norm j = 1.
Proof.
rewrite /j norm_normalize // normalcomp_colinear; last first.
  by rewrite -norm_eq0 normi oner_neq0.
apply: contra (abc); rewrite colinearvZ invr_eq0 norm_eq0 subr_eq0.
by rewrite eq_sym (negPf ab) /= colinear_sym.
Qed.

Lemma j_neq0 : j != 0.
Proof. by rewrite -norm_eq0 normj oner_neq0. Qed.

Lemma idotj : i *d j = 0.
Proof. by rewrite /= /i /j dotmulZv dotmulvZ dotmul_orthogonalize 2!mulr0. Qed.

Lemma jdotk : j *d k = 0.
Proof. by rewrite /k dot_crossmulCA liexx dotmulv0. Qed.

Lemma idotk : i *d k = 0.
Proof. by rewrite /k dot_crossmulC liexx dotmul0v. Qed.

Lemma normk : norm k = 1.
Proof. by rewrite norm_crossmul_normal // ?normi // ?normj // idotj. Qed.

Lemma k_neq0 : k != 0.
Proof. by rewrite -norm_eq0 normk oner_neq0. Qed.

Lemma is_O : col_mx3 i j k \is 'O[T]_3.
Proof.
apply/orthogonal3P;
  by rewrite !rowK /= normi normj normk idotj idotk jdotk !eqxx.
Qed.

Definition noframe := NOFrame.mk is_O.

Lemma is_SO : NOFrame.M noframe \is 'SO[T]_3.
Proof.
rewrite rotationE /= is_O /= -crossmul_triple double_crossmul dotmulvv normj.
by rewrite expr1n scale1r (dotmulC j) idotj scale0r subr0 dotmulvv normi expr1n.
Qed.

Definition frame := Frame.mk is_SO.

End triad.
End triad.

(* construction d'une transformation (rotation + translation) etant donnes
   trois points de depart et leurs positions d'arrivee
   sample lemma: the rotation obtained behaves like a change of coordinates from left to right *)
Section transformation_given_three_points.
Variable T : realType.
Let vector := 'rV[T]_3.
Let point := 'rV[T]_3.

Variables l1 l2 l3 r1 r2 r3 : point.
Hypotheses (l12 : l1 != l2) (r12 : r1 != r2).
Hypotheses (l123 : ~~ colinear (l2 - l1) (l3 - l1))
           (r123 : ~~ colinear (r2 - r1) (r3 - r1)).

Import rv3LieAlgebra.Exports.

Definition lmat := triad.frame l12 l123.
Definition rmat := triad.frame r12 r123.

(* TODO: move? *)
Lemma mulmx_tr (M1 M2 : 'M[T]_3) : M1^T *m M2 = \matrix_(i < 3, j < 3) (row i M1^T *d row j M2^T).
Proof.
apply/matrixP => i j; rewrite /dotmul !mxE.
apply eq_bigr => /= k _; by rewrite !mxE.
Qed.

Definition rot_l2r := lmat^T *m rmat.

Definition trans3 : vector := r1 - l1 *m rot_l2r.

Lemma i_l_r : triad.i l1 l2 *m rot_l2r = triad.i r1 r2.
Proof.
rewrite /rot_l2r /= mulmxA mul_tr_col_mx3 dotmulvv triad.normi // expr1n.
rewrite triad.idotj triad.idotk /matrix_of_noframe mulmx_row3_col3.
by rewrite !scale0r scale1r !addr0.
Qed.

Lemma j_l_r : triad.j l1 l2 l3 *m rot_l2r = triad.j r1 r2 r3.
Proof.
rewrite /rot_l2r /= mulmxA mul_tr_col_mx3 dotmulC triad.idotj dotmulvv triad.normj //.
rewrite expr1n dot_crossmulCA liexx dotmulv0 /matrix_of_noframe /=.
rewrite col_mx3E row3E (mul_row_col 0%:M) mul_scalar_mx scale0r add0r.
by rewrite (mul_row_col 1%:M) mul_scalar_mx scale1r mul_scalar_mx scale0r addr0.
Qed.

Lemma k_l_r : triad.k l1 l2 l3 *m rot_l2r = triad.k r1 r2 r3.
Proof.
rewrite /rot_l2r /= mulmxA mul_tr_col_mx3 {1}/triad.k dotmulC dot_crossmulC.
rewrite liexx dotmul0v {1}/triad.k -dot_crossmulC liexx dotmulv0.
rewrite /matrix_of_noframe /= dotmulvv triad.normk // expr1n col_mx3E row3E.
do 2 rewrite (mul_row_col 0%:M) mul_scalar_mx scale0r add0r.
by rewrite mul_scalar_mx scale1r.
Qed.

End transformation_given_three_points.


Load "include/ops_header.v".

(* These preconditions are temporarily set to True, and will be refined
   by the very process of formalization. *)
Module precond.

Definition Sn2 (n : int) := (n != - 2%:~R) /\ (n != - 1).

End precond.

Load "include/ann_z.v".

Record Ann z : Type := ann {
  Sn2_ : Sn2 z
}.


From Cat Require Import Imports Category Preorder Monoid Poset.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Set Universe Polymorphism.

Lemma funextcontra: ∏ (A B : Type) (f g : A -> B), f = g -> (∏ x : A, f x = g x).
Proof. intros.
       rewrite H.
       reflexivity.
Qed.

(** Injection, Surjection and Bijection *)

Definition injective {X Y: @obj TypeCat} (f: arrow Y X) := forall x x', f x = f x' -> x = x'.

Definition surjective {X Y: @obj TypeCat} (f: X -> Y) := forall y, { x | f x = y }.

Class bijection {X Y: @obj TypeCat} (f: X -> Y) :=
{
  finj: injective f;
  fsurj: surjective f
}.

(** Left Canecallable, Right Cancellable *)

Definition leftCancellable {C: Category} {X Y Z: @obj C} (h: arrow Z Y) (f g: arrow Y X) :=
  h o f = h o g -> f = g.

Lemma injlc: forall {X Y Z: @obj TypeCat} (h: arrow Z Y) (f g: arrow Y X),
  injective h -> leftCancellable h f g.
Proof. unfold injective, leftCancellable.
       intros X Y Z h f g i e.
       apply functional_extensionality.
       intro x.
       specialize (i (f x) (g x)).
       apply i.
       simpl in e.
       apply funextcontra with (x := x) in e.
       rewrite e.
       reflexivity.
Qed.

Definition rightCancellable {C: Category}  {X Y Z: @obj C} (h: arrow Y X) (f g: arrow Z Y) :=
  f o h = g o h -> f = g.

Lemma surjrc: forall {X Y Z: @obj TypeCat} (h: arrow Y X) (f g: arrow Z Y),
  surjective h -> rightCancellable h f g.
Proof. unfold surjective, rightCancellable.
       intros X Y Z h f g i e.
       apply functional_extensionality.
       intro y.
       specialize (i y).
       destruct i as (x, i).
       simpl in e.
       apply funextcontra with (x := x) in e.
       rewrite i in e.
       exact e.
Qed.

(** Isomorphism *)

Class Isomorphism (C: Category) {X Y: @obj C} (f: @arrow C Y X) :=
{
  isoinv: @arrow C X Y;
  isoidl: f o isoinv = @identity C Y;
  isoidr: isoinv o f = @identity C X
}.

Lemma IsomorphismEq: forall {C: Category} {X Y: @obj C} (f: arrow Y X) (i j: Isomorphism C f),
      @isoinv C X Y f i = @isoinv C X Y f j ->   i = j.
Proof. intros C X Y f (finv1, fax11, fax12) (finv2, fax21, fax22) eq.
       simpl in *.
       subst.
       f_equal.
       - now destruct (proof_irrelevance _ fax11 fax21).
       - now destruct (proof_irrelevance _ fax12 fax22).
Qed.

Lemma isolc: forall {C: Category} {X Y Z: @obj C} (h: arrow Z Y) (f g: arrow Y X),
  Isomorphism C h -> leftCancellable h f g.
Proof. unfold injective, leftCancellable.
       intros C X Y Z h f g (hinv, hax1, hax2) e.
       assert (ee: hinv o h o f = hinv o h o g).
       { rewrite <- assoc, e.
         rewrite assoc.
         reflexivity.
       }
       rewrite hax2, !identity_f in ee.
       exact ee.
Qed.

Lemma isorc: forall {C: Category} {X Y Z: @obj C} (h: arrow Y X) (f g: arrow Z Y),
  Isomorphism C h -> rightCancellable h f g.
Proof. unfold injective, rightCancellable.
       intros C X Y Z h f g (hinv, hax1, hax2) e.
       assert (ee: f o h o hinv = g o h o hinv).
       { rewrite e.
         reflexivity.
       }
       rewrite <- assoc, hax1, <- assoc, hax1, !f_identity in ee.
       exact ee.
Qed.

Lemma comp_iso: forall {C: Category} {X Y Z: @obj C} (f: arrow Y X) (g: arrow Z Y),
  Isomorphism C f ->
  Isomorphism C g ->
  Isomorphism C (g o f).
Proof. intros C X Y Z f g (finv, finv_ax1, finv_ax2) (ginv, ginv_ax1, ginv_ax2).
       unshelve econstructor.
       - exact (finv o ginv).
       - rewrite assoc.
         setoid_rewrite <- assoc at 2.
         rewrite finv_ax1, f_identity.
         rewrite ginv_ax1.
         reflexivity.
       - rewrite assoc.
         setoid_rewrite <- assoc at 2.
         rewrite ginv_ax2, f_identity.
         rewrite finv_ax2.
         reflexivity.
Qed.

Lemma comp_iso_r: forall {C: Category} {X Y Z: @obj C} (f: arrow Y X) (g: arrow Z Y),
  Isomorphism C f ->
  Isomorphism C (g o f) ->
  Isomorphism C g.
Proof. intros C X Y Z f g fiso gofiso.
       pose proof fiso as fiso'.
       destruct fiso as (finv, finv_ax1, finv_ax2).
       destruct gofiso as (gofinv, gofinv_ax1, gofinv_ax2).
       unshelve econstructor.
       - exact (f o gofinv).
       - rewrite assoc.
         rewrite gofinv_ax1.
         reflexivity.
       - simpl.
         specialize (@isorc C X Y Y f (f o gofinv o g) (identity Y) fiso'); intro CC.
         unfold rightCancellable in CC.
         apply CC.
         do 2 rewrite <- assoc.
         rewrite gofinv_ax2.
         rewrite f_identity, identity_f.
         reflexivity.
Qed.

Definition Bijective (X Y: Type) := { f: X -> Y & bijection f }.

Definition Isomorphic {C: Category} (X Y: @obj C) := { f: (@arrow C Y X) & Isomorphism C f }.

Lemma bijisol: forall X Y (f: @arrow SetCat Y X), bijection f -> Isomorphism SetCat f.
Proof. intros X Y f (finj, fsurj).
       unfold injective, surjective in *.
       unshelve econstructor.
       - simpl in *.
         intro a.
         specialize (fsurj a).
         exact (proj1_sig fsurj).
       - simpl in *.
         apply functional_extensionality.
         intro y.
         unfold proj1_sig.
         destruct (fsurj y) as (a, a_ax).
         exact a_ax.
       - simpl in *.
         apply functional_extensionality.
         intro a.
         unfold proj1_sig.
         simpl.
         destruct (fsurj (f a)) as (x, x_ax).
         apply finj.
         exact x_ax.
Qed.

Lemma bijisor: forall X Y (f: @arrow SetCat Y X), Isomorphism SetCat f -> bijection f.
Proof. intros X Y f (finv, ax1, ax2). simpl in *.
(*     specialize (@funextcontra _ _ _ _ ax1).
       intro ax1'. simpl in ax1'. *)
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl ax1) as ax1';
       cbv beta in ax1'.
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl ax2) as ax2';
       cbv beta in ax2'.
       unshelve econstructor.
       - unfold injective.
         intros x y H.
         pose proof ax2' as ax2''.
         specialize (ax2' x).
         rewrite H in ax2'.
         rewrite ax2'' in ax2'.
         symmetry.
         exact ax2'.
       - unfold surjective.
         intro y.
         exists (finv y).
         rewrite ax1'.
         reflexivity.
Qed.

Lemma bijisolT: forall X Y (f: @arrow TypeCat Y X), bijection f -> Isomorphism TypeCat f.
Proof. intros X Y f (finj, fsurj).
       unfold injective, surjective in *.
       unshelve econstructor.
       - simpl in *. intro y.
         specialize (fsurj y).
         destruct fsurj as (x, xax).
         exact x.
       - cbn in *.
         apply functional_extensionality.
         intro y.
         destruct (fsurj y) as (x, xax).
         exact xax.
       - simpl in *.
         apply functional_extensionality.
         intro x.
         destruct (fsurj (f x)) as (y, yax).
         apply finj. easy.
Qed.

Lemma bijisorT: forall X Y (f: @arrow TypeCat Y X), Isomorphism TypeCat f -> bijection f.
Proof. intros X Y f (finv, ax1, ax2). simpl in *.
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl ax1) as ax1';
       cbv beta in ax1'.
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl ax2) as ax2';
       cbv beta in ax2'.
       unshelve econstructor.
       - unfold injective.
         intros x y H.
         pose proof ax2' as ax2''.
         specialize (ax2' x).
         rewrite H in ax2'.
         rewrite ax2'' in ax2'. easy.
       - unfold surjective.
         intro y.
         exists (finv y).
         rewrite ax1'. easy.
Qed.

Definition iffT (A B : Type) := ((A -> B) * (B -> A))%type.

Lemma bijiso: forall X Y (f: @arrow SetCat Y X), iffT (Isomorphism SetCat f) (bijection f).
Proof. intros.
       red. split.
       - intro H. apply bijisor. easy.
       - intro H. apply bijisol. easy.
Qed.

Lemma bijisoT: forall X Y (f: @arrow SetCat Y X), iffT (Isomorphism TypeCat f) (bijection f).
Proof. intros.
       red. split.
       - intro H. apply bijisor. easy.
       - intro H. apply bijisol. easy.
Qed.

Lemma bijlc: forall {X Y Z: @obj TypeCat} (h: arrow Z Y) (f g: arrow Y X),
  bijection h -> leftCancellable h f g.
Proof. unfold injective, leftCancellable.
       intros X Y Z h f g e.
       apply bijisolT in e.
       apply isolc.
       exact e.
Qed.

Lemma bijrc: forall {X Y Z: @obj TypeCat} (h: arrow Y X) (f g: arrow Z Y),
  bijection h -> rightCancellable h f g.
Proof. unfold surjective, rightCancellable.
       intros X Y Z h f g e.
       apply bijisolT in e.
       apply isorc.
       exact e.
Qed.

Lemma MonoidMapIsol: forall (M1 M2: Monoid) (f: MonoidMap M1 M2),
 bijection (@monmap M1 M2 f) -> Isomorphism Mon f.
Proof. intros (M1, e1, op1, ax1, ax2, ax3) (M2, e2, op2, ax4, ax5, ax6) (f, fax1, fax2) (finj, fsurj).
       simpl in *.
       unfold injective, surjective in *.
       unshelve econstructor.
       - simpl. unshelve econstructor.
         + simpl. intro y.
           exact (proj1_sig (fsurj y)).
         + simpl.
           unfold proj1_sig.
           destruct (fsurj e2) as (x, xax).
           rewrite <- fax1 in xax.
           specialize (finj _ _ xax).
           exact finj.
         + simpl. intros x y.
           unfold proj1_sig.
           destruct (fsurj (op2 x y)) as (a, aax).
           destruct (fsurj x) as (b, bax).
           destruct (fsurj y) as (c, cax).
           rewrite <- bax, <- cax, <- fax2 in aax.
           specialize (finj _ _ aax).
           exact finj.
       - apply MonoidMapEq. simpl.
         apply functional_extensionality.
         intro x.
         destruct (fsurj x) as (a, aax).
         simpl.
         easy.
       - apply MonoidMapEq. simpl.
         apply functional_extensionality.
         intro x.
         destruct (fsurj (f x)) as (a, aax).
         specialize (finj _ _ aax).
         easy.
Qed.

Lemma MonoidMapIsor: forall (M1 M2: Monoid) (f: MonoidMap M1 M2),
 Isomorphism Mon f -> bijection (@monmap M1 M2 f).
Proof. intros (M1, e1, op1, ax1, ax2, ax3) (M2, e2, op2, ax4, ax5, ax6)
              (f, fax1, fax2) ((finv, finvax1, finvax2), ob1, ob2).
       simpl in *.
       inversion ob1.
       inversion ob2.
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H0) as H0';
       cbv beta in H0'.
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H1) as H1';
       cbv beta in H1'.
       unshelve econstructor.
       - unfold injective.
         intros x y H.
         pose proof H1' as H2.
         specialize (H1' y).
         rewrite <- H, H2 in H1'.
         rewrite H1'.
         reflexivity.
       - unfold surjective.
         intro y.
         exists (finv y).
         rewrite H0'.
         reflexivity.
Qed.

Lemma MonoidMapIso: forall (M1 M2: Monoid) (f: MonoidMap M1 M2),
  iffT (bijection (@monmap M1 M2 f)) (Isomorphism Mon f).
Proof. intros.
       split.
       - apply MonoidMapIsol.
       - apply MonoidMapIsor.
Qed.

Lemma PoSetdMapIsol: forall (P1 P2: PoSet) (f: PoSetMap P1 P2),
 surjective (@posmap _ _ (@posetmap P1 P2 f)) *
 (forall x x', (@pohrel (@poset P2)) ((@posmap _ _ (@posetmap P1 P2 f)) x) ((@posmap _ _ (@posetmap P1 P2 f)) x') = true ->
               (@pohrel (@poset P1) x x' = true)) ->
 Isomorphism Poset f.
Proof. intros P1 P2 f (H, Hrlctv).
       destruct P1 as ((P1, le1, r1, t1), a1).
       destruct P2 as ((P2, le2, r2, t2), a2).
       destruct f as (f). destruct f as (f, Hf).
       simpl in *.
       unfold surjective in H.
       unshelve econstructor.
       - simpl. unshelve econstructor.
         + simpl. unshelve econstructor.
           ++ simpl. intro y.
              destruct (H y) as (x, xax).
              exact x.
           ++ simpl. intros x x' Hx.
              destruct (H x) as (a, aax).
              destruct (H x') as (b, bax).
              apply Hrlctv. (** crucial -- additional assumption of 'reflective'ness *)
              rewrite <- aax, <- bax in Hx. easy.
       - apply PoSetMapEq, PreOrderMapEq.
         simpl.
         apply functional_extensionality.
         intro x.
         destruct (H x) as (a, aax).
         easy.
       - apply PoSetMapEq, PreOrderMapEq.
         simpl.
         apply functional_extensionality.
         intro x.
         destruct (H (f x)).
         apply a1. (** the reason why this characterization does not work for Preord *)
         split.
         + apply Hrlctv. rewrite e. apply r2.
         + apply Hrlctv. rewrite e. apply r2.
Qed.

Lemma PoSetdMapIsor: forall (P1 P2: PoSet) (f: PoSetMap P1 P2),
 Isomorphism Poset f ->
 surjective (@posmap _ _ (@posetmap P1 P2 f)) *
 (forall x x', (@pohrel (@poset P2)) ((@posmap _ _ (@posetmap P1 P2 f)) x) ((@posmap _ _ (@posetmap P1 P2 f)) x') = true -> (@pohrel (@poset P1) x x' = true)).
Proof. intros P1 P2 f (finv, fax1, fax2).
       destruct P1 as ((P1, le1, r1, t1), a1).
       destruct P2 as ((P2, le2, r2, t2), a2).
       destruct f as (f). destruct f as (f, Hf).
       simpl in *.
       destruct finv as (finv). destruct finv as (finv, Hfinv).
       simpl in *.
       inversion fax1.
       inversion fax2.
       clear fax1 fax2.
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H0) as fax1;
       cbv beta in fax1.
       pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H1) as fax2;
       cbv beta in fax2.
       split.
       - unshelve econstructor.
         + exact (finv y).
         + apply fax1.
       - intros x x' Hfx.
         specialize (Hfinv (f x) (f x')).
         rewrite !fax2 in Hfinv.
         apply Hfinv.
         easy.
Qed.

Lemma PoSetdMapIso: forall (P1 P2: PoSet) (f: PoSetMap P1 P2),
 iffT (Isomorphism Poset f)
 (surjective (@posmap _ _ (@posetmap P1 P2 f)) *
 (forall x x', (@pohrel (@poset P2)) ((@posmap _ _ (@posetmap P1 P2 f)) x) ((@posmap _ _ (@posetmap P1 P2 f)) x') = true -> (@pohrel (@poset P1) x x' = true))).
Proof. intros. split.
       - intros. apply PoSetdMapIsor. easy.
       - intros. apply PoSetdMapIsol. easy.
Qed.


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

- Adam Koprowski, 2004-09-06
- William Delobel, 2005-10-07

This file provides some basic results concerning relations that were
missing in the standard library.
*)

Set Implicit Arguments.

Require Import RelUtil LogicUtil Max Arith Setoid.
Require Export Relations.

(***********************************************************************)
(** strict order *)

Section StrictOrder.

  Variable A : Type.
  Variable R : relation A.

  Record strict_order : Prop := {
    sord_trans : transitive R;
    sord_irrefl : irreflexive R
  }.

  Variable so : strict_order.

  Lemma so_not_symmetric : forall a b, R a b -> R b a -> False.

  Proof.
    unfold not; intros a b Rab Rba.
    exact (sord_irrefl so (sord_trans so Rab Rba)).
  Qed.

  Variable eq : relation A.
  Variable Req_compat : forall x x' y y',
    eq x x' -> eq y y' -> R x y -> R x' y'.
  Variable eq_setoid : Setoid_Theory A eq.

  Lemma so_strict : forall x y, eq x y -> R x y -> False.

  Proof.
    intros.
    assert (R y x).
    apply Req_compat with x y; auto.
    apply (Seq_sym A eq eq_setoid); trivial.
    absurd (R x x).
    unfold not; intro xx; exact (sord_irrefl so xx).
    exact (sord_trans so H0 H1).
  Qed.

End StrictOrder.

(***********************************************************************)
(** module types for setoids with decidable equality *)

Module Type SetA.
  Parameter A : Type.
End SetA.

Module Type Eqset.

  Parameter A : Type.

  Parameter eqA : relation A.
  Notation "X =A= Y" := (eqA X Y) (at level 70).

  Parameter sid_theoryA : Setoid_Theory A eqA.

  Hint Resolve (Seq_refl  A eqA sid_theoryA) : sets.
  Hint Resolve (Seq_trans A eqA sid_theoryA) : sets.
  Hint Resolve (Seq_sym   A eqA sid_theoryA) : sets.

End Eqset.

Module Type Eqset_dec.

  Declare Module Export Eq : Eqset.

  Parameter eqA_dec : forall x y, {x =A= y} + {~x =A= y}.

End Eqset_dec.

Module Eqset_def (A : SetA) <: Eqset.

  Definition A := A.A.

  Definition eqA := eq (A:=A).

  Definition sid_theoryA := Build_Setoid_Theory _ eqA
     (refl_equal (A:=A)) (sym_eq (A:=A)) (trans_eq (A:=A)).

  Hint Resolve (Seq_refl  A eqA sid_theoryA) : sets.
  Hint Resolve (Seq_trans A eqA sid_theoryA) : sets.
  Hint Resolve (Seq_sym   A eqA sid_theoryA) : sets.

End Eqset_def.

(***********************************************************************)
(** module types for ordered setoids *)

Section Eqset_def_gtA_eqA_compat.

  Variable A : Type.
  Variable gtA : relation A.

  Lemma Eqset_def_gtA_eqA_compat :
    forall x x' y y', x = x' -> y = y' -> gtA x y -> gtA x' y'.

  Proof.
    intros x x' y y' x_x' y_y' x_y.
    rewrite <- x_x'; rewrite <- y_y'; trivial.
  Qed.

End Eqset_def_gtA_eqA_compat.

Module Type Ord.

  Parameter A : Type.

  Declare Module Export S : Eqset with Definition A := A.

  Parameter gtA : relation A.
  Notation "X >A Y" := (gtA X Y) (at level 70).

  Parameter gtA_eqA_compat : forall x x' y y',
    x =A= x' -> y =A= y' -> x >A y -> x' >A y'.

  Hint Resolve gtA_eqA_compat : sets.

End Ord.

Module OrdLemmas (P : Ord).

  Export P.

  Definition ltA := transp gtA.
  Definition geA x y := ~ ltA x y.
  Definition leA x y := ~ gtA x y.
  Definition AccA := Acc ltA.

  Notation "X <A Y" := (ltA X Y) (at level 70).
  Notation "X >=A Y" := (geA X Y) (at level 70).
  Notation "X <=A Y" := (leA X Y) (at level 70).

  Hint Unfold ltA geA leA AccA : sets.

  Add Setoid A eqA sid_theoryA as sidA.

  Add Morphism gtA
    with signature eqA ==> eqA ==> iff
      as gtA_morph.

  Proof.
    split; eauto with sets.
  Qed.

  Add Morphism ltA
    with signature eqA ==> eqA ==> iff
      as ltA_morph.

  Proof.
    split. eauto with sets.
    cut (y0 =A= x0). intro. eauto with sets.
    apply (Seq_sym _ _ sid_theoryA). hyp.
  Qed.

  Add Morphism AccA
    with signature eqA ==> iff
      as AccA_morph.

  Proof.
    intros a b eq_ab. split.
    intro acc_a. inversion acc_a. constructor. intros.
    apply H. rewrite eq_ab. hyp.
    intros acc_b. inversion acc_b. constructor. intros.
    apply H. rewrite <- eq_ab. hyp.
  Qed.

End OrdLemmas.

Module Type Poset.

  Parameter A : Type.

  Declare Module Export O : Ord with Definition A := A.

  Parameter gtA_so : strict_order gtA.

  Hint Resolve (sord_trans gtA_so) : sets.
  Hint Resolve (sord_irrefl gtA_so) : sets.
  Hint Resolve (so_not_symmetric gtA_so) : sets.
  Hint Resolve (so_strict gtA_so gtA_eqA_compat sid_theoryA) : sets.

End Poset.

Module nat_ord <: Ord.

  Module natSet <: SetA.
    Definition A := nat.
    Definition eqA_dec := eq_nat_dec.
  End natSet.

  Module S := Eqset_def natSet.

  Definition A := nat.
  Definition gtA := gt.

  Lemma gtA_eqA_compat : forall x x' y y',
    x = x' -> y = y' -> x > y -> x' > y'.

  Proof.
    intros x x' y y' xx' yy'.
    rewrite <- xx'; rewrite <- yy'; trivial.
  Qed.

End nat_ord.

(***********************************************************************)
(** lemmas on transitive closure *)

Section Transitive_Closure.

  Variable A : Type.
  Variable R : relation A.

  Lemma trans_clos_step_l : forall x y,
    R! x y -> R x y \/ (exists2 z, R x z & R! z y).

  Proof.
    intros x y; compute; intro xy; induction xy.
    left; trivial.
    inversion IHxy1; inversion IHxy2; right; solve [eauto |
      inversion H; try inversion H0; exists x0;
      [trivial | constructor 2 with y; auto]].
  Qed.

  Lemma trans_clos_step_r : forall x y,
    R! x y -> R x y \/ (exists2 z, R! x z & R z y).

  Proof.
    intros x y; compute; intro xy; induction xy.
    left; trivial.
    inversion_clear IHxy1; inversion_clear IHxy2; right;
      solve [eauto | inversion H0; exists x0;
      [constructor 2 with y; auto | trivial]].
  Qed.

  Variable eqA : relation A.

  Parameter sid_theoryA : Setoid_Theory A eqA.
  Parameter R_eqA_comp : forall x y x' y',
    eqA x x' -> eqA y y' -> R x y -> R x' y'.
  Parameter R_so : strict_order R.

  Hint Resolve R_eqA_comp.

  Lemma trans_clos_mirror : forall x y x' y',
    eqA x x' -> eqA y y' -> R! x y -> R! x' y'.

  Proof.
    intros x y x' y' eq_xx' eq_yy' R_xy.
    case (trans_clos_step_l R_xy).
    intro Rxy; constructor 1; eauto.
    intro R_xzy; destruct R_xzy as [w Rxw R_wy].
    case (trans_clos_step_r R_wy).
    intro Rwy; constructor 1; apply R_eqA_comp with x y;
      solve [trivial | apply (sord_trans R_so) with w; trivial].
    intro R_wpy; destruct R_wpy as [p Rwp R_py].
    constructor 2 with w.
    constructor 1; apply R_eqA_comp with x w;
      solve [trivial | apply (Seq_refl A eqA sid_theoryA)].
    constructor 2 with p.
    trivial.
    constructor 1; apply R_eqA_comp with p y;
      solve [trivial | apply (Seq_refl A eqA sid_theoryA)].
  Qed.

  Lemma trans_clos_transp : forall x y, transp (R!) x y <-> (transp R)! x y.

  Proof.
    intros; split; compute.
    induction 1.
    constructor; trivial.
    constructor 2 with y; auto.
    induction 1.
    constructor; trivial.
    constructor 2 with y; auto.
  Qed.

End Transitive_Closure.

(***********************************************************************)
(** specification *)

Section Specif.

  Inductive sigPS2 (A : Type) (P: A -> Prop) (Q: A -> Set) : Type :=
    existPS2: forall x:A, P x -> Q x -> sigPS2 (A:=A) P Q.

  Notation "{ x : A # P & Q }"
    := (sigPS2 (fun x:A => P) (fun x:A => Q)) : type_scope.

  Variable A : Type.
  Variables P Q : A -> Prop.

  Definition proj1_sig2 (e: sig2 P Q) :=
    match e with
    | exist2 a p q => a
    end.

End Specif.

(***********************************************************************)
(** lemmas on the option type *)

Section option.

  Variable A : Type.

  Lemma option_dec : forall (el: option A),
    el = None \/ exists w: A, el = Some w.

  Proof.
    intros.
    destruct el.
    right; exists a; trivial.
    left; trivial.
  Qed.

End option.

(***********************************************************************)
(** tactics *)

Ltac pair_destruct t0 t1 :=
  first [destruct t0 | intros until t0; destruct t0];
  first [destruct t1 | intros until t1; destruct t1];
  try contr; simpl.

Ltac rewrite_lr term := apply (proj1 term).
Ltac rewrite_rl term := apply (proj2 term).

Ltac try_solve :=
   simpl in *; try (intros; solve
     [ contr
     | discr
     | auto with terms
     | tauto
     | congruence
     ]
).