(** This file was originally written by Niels van der Weide and Dan Frumin.  *)
Require Import HoTT.

(** The diagonal of a function with two arguments. *)
Definition diag2
           {X Z : Type}
           (f : X -> X -> Z)
  : X -> Z
  := fun x => f x x.

(** `ap` on the diagonal of a function. *)
Definition ap_diag2
           {X Z : Type}
           (f : X -> X -> Z)
           {x₁ x₂ : X}
           (p : x₁ = x₂)
  : ap (diag2 f) p = ap (fun z => f x₁ z) p @ ap (fun z => f z x₂) p
  := match p with
     | idpath => idpath
     end.

(** Curries a function on a product. *)
Definition curry
           {X Y Z : Type}
           (f : X * Y -> Z)
  : X -> Y -> Z
  := fun x y => f(x, y).

(** `ap` on an uncurried function. *)
Definition uncurry_ap
           {X Y Z : Type}
           (f : X -> Y -> Z)
           {x₁ x₂ : X} {y₁ y₂ : Y}
           (p : x₁ = x₂) (q : y₁ = y₂)
  : ap (uncurry f) (path_prod' p q)
    =
    ap (fun z => f z y₁) p @ ap (f x₂) q
  := match p, q with
     | idpath, idpath => idpath
     end.

(** `ap` on a curried function. *)
Definition curry_ap
           {X Y Z : Type}
           (f : X * Y -> Z)
           {x₁ x₂ : X * Y}
           (p : x₁ = x₂)
  : ap f p
    =
    (ap (fun z => curry f z (snd x₁)) (ap fst p))
      @ (ap (fun z => curry f (fst x₂) z) (ap snd p))
  := match p with
     | idpath => idpath
     end.

(** `ap` on `λx.(x,y)` with `y` constant. *)
Definition ap_pair_l
           {X Y : Type}
           {x₁ x₂ : X} (y : Y)
           (p : x₁ = x₂)
  : ap (fun x => (x, y)) p = path_prod' p idpath
  := match p with
     | idpath => idpath
     end.

(** `ap` on `λy.(x,y)` with `x` constant. *)
Definition ap_pair_r
           {X Y : Type}
           (x : X) {y₁ y₂ : Y}
           (q : y₁ = y₂)
  : ap (pair x) q = path_prod' idpath q
  := match q with
     | idpath => idpath
     end.

(** Univalence says when two types are equal.
    We can also use this to say when two sets are equal and this is given by `path_hset`.
    We study some properties of `path_hset`.
 *)
Section path_hset_prop.
  Context `{Univalence}.

  (** This function says when two paths given by `path_hset` are equal. *)
  Definition path_trunctype_eq
             {n : trunc_index}
             {A B : TruncType n}
             (f : A <~> B) (g : A <~> B)
             (fg_eq : equiv_fun f == equiv_fun g)
    : path_trunctype f = path_trunctype g.
  Proof.
    refine (ap path_trunctype _).
    apply path_equiv.
    exact (path_forall _ _ fg_eq).
  Qed.
End path_hset_prop.

(** The analogue of `transport_idmap_ap` for `hSets. *)
Definition transport_idmap_ap_set
           {A : Type}
           (P : A -> hSet)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (u : P a₁)
  : transport P p u = transport (idmap : hSet -> hSet) (ap P p) u
  := match p with
     | idpath => idpath
     end.

(** This computes `transport idmap` (on types) to `transport idmap` (on `hSet`). *)
Definition transport_hpath_to_transport_idmap
           {B C : Type}
           {BS : IsHSet B} {CS : IsHSet C}
           (p : B = C)
           (u : B)
           `{Univalence}
  : transport (idmap : hSet -> hSet)
              (ap (fun u0 : {X : Type & IsHSet X} => @BuildhSet u0.1 u0.2)
                  (path_sigma_hprop (B;BS) (C;CS) p))
              u
    = transport idmap p u.
Proof.
  induction p ; cbn.
  assert(CS = BS) as ->.
  { apply path_ishprop. }
  unfold path_sigma_hprop, path_sigma_uncurried.
  cbn.
  induction (center _).
  reflexivity.
Defined.

(** The analogue of `transport_path_universe` for `hSet`. *)
Definition transport_path_hset
           {B C : hSet}
           (f : Equiv B C)
           (u : B)
           `{Univalence}
  : transport (idmap : hSet -> hSet) (path_hset f) u
    =
    f u.
Proof.
  cbn.
  rewrite concat_1p, concat_p1.
  rewrite transport_hpath_to_transport_idmap.
  apply transport_path_universe_uncurried.
Defined.

(** Next we prove the truncation of a production is equivalent to the product of truncations. *)
Definition Trunc_prod
           {A B : Type}
           (n : trunc_index)
  : Trunc n A * Trunc n B -> Trunc n (A * B).
Proof.
  intros x.
  simple refine (Trunc_rec _ (fst x)) ; intros y₁.
  simple refine (Trunc_rec _ (snd x)) ; intros y₂.
  exact (tr(y₁,y₂)).
Defined.

Definition Trunc_prod_inv
           {A B : Type}
           (n : trunc_index)
  : Trunc n (A * B) -> Trunc n A * Trunc n B.
Proof.
  apply Trunc_rec.
  exact (fun x => (tr (fst x), tr (snd x))).
Defined.

Global Instance Trunc_prod_isequiv
       {A B : Type}
       (n : trunc_index)
  : IsEquiv (@Trunc_prod A B n).
Proof.
  simple refine (isequiv_adjointify _ (Trunc_prod_inv n) _ _) ; unfold Sect.
  - simple refine (Trunc_ind _ _).
    reflexivity.
  - intros [x₁ x₂]. revert x₁.
    simple refine (Trunc_ind _ _) ; intros y₁ ; simpl.
    revert x₂.
    simple refine (Trunc_ind _ _) ; intros y₂ ; simpl.
    reflexivity.
Defined.

(** If the index is at least `0`, then the sum of `n`-types is again an `n`-type. *)
Global Instance Truncated_sum
       {A B : Type}
       (n : trunc_index)
       (H : trunc_index_leq 0 n)
       `{IsTrunc n A} `{IsTrunc n B}
  : IsTrunc n (A + B).
Proof.
  apply trunc_sum' ; try apply _.
  exact (trunc_leq H).
Defined.

(** If the index is at least `0`, then truncation of the sum is equivalent to the sum of the truncations. *)
Definition Trunc_sum
           {A B : Type}
           (n : trunc_index)
  : Trunc n A + Trunc n B -> Trunc n (A + B).
Proof.
  intros [x | x].
  - simple refine (Trunc_rec _ x) ; intros y.
    exact (tr(inl y)).
  - simple refine (Trunc_rec _ x) ; intros y.
    exact (tr(inr y)).
Defined.

Definition Trunc_sum_inv
           {A B : Type}
           (n : trunc_index)
           (H : trunc_index_leq 0 n)
  : Trunc n (A + B) -> Trunc n A + Trunc n B.
Proof.
  simple refine (Trunc_rec _).
  - apply (Truncated_sum n H).
  - intros [x | x].
    + exact (inl (tr x)).
    + exact (inr (tr x)).
Defined.

Global Instance Trunc_sum_isequiv
       {A B : Type}
       (n : trunc_index)
       (H : trunc_index_leq 0 n)
  : IsEquiv (@Trunc_sum A B n).
Proof.
  simple refine (isequiv_adjointify _ (Trunc_sum_inv n H) _ _) ; unfold Sect.
  - simple refine (Trunc_ind _ _).
    intros [a | a] ; reflexivity.
  - intros [x | x] ; revert x ; simple refine (Trunc_ind _ _).
    * intros a.
      pose (@Truncated_sum (Trunc n A) (Trunc n B) n H).
      apply _.
    * reflexivity.
    * intros a.
      pose (@Truncated_sum (Trunc n A) (Trunc n B) n H).
      apply _.
    * reflexivity.
Defined.

Definition ap_precompose
           `{Funext}
           {A B C : Type}
           {f g : A -> B}
           (h : B -> C)
           (e : f == g)
  : ap (fun z : A -> B => h o z) (path_forall f g e)
    =
    path_forall (h o f) (h o g) (fun z : A => ap h (e z))
  := @ap_functor_forall _ _ _ _ _ idmap (fun _ => h) f g e.

Definition ap_postcompose
           `{Funext}
           {A B C : Type}
           {f g : B -> C}
           (h : A -> B)
           (e : f == g)
  : ap (fun z : B -> C => z o h) (path_forall f g e)
    =
    path_forall (f o h) (g o h) (e o h).
Proof.
  refine (@ap_functor_forall _ B _ A (fun _ => C) h (fun _ => idmap) f g e @ _).
  apply ap.
  funext x.
  apply ap_idmap.
Defined.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Matrix implemented with dependent record on setoid
  author    : ZhengPu Shi
  date      : 2021.05

  remark    :
  1. use Typeclasses to simplify the writing and proving.
  2. Context and Variable are two similiar keywords, but use Context will
     keep the implicit arguments effect in a section, meanwhile, Variable
     has no such ability.

 *)

Require Export Lia.
Require Export BasicConfig SetoidListListExt.

(* also contain "A*" which * is number, e.g. A0 A1 ... *)
Generalizable Variable A B C Aeq Beq Ceq Aadd Aopp Amul Ainv.

Open Scope nat_scope.
Open Scope list_scope.
Open Scope dlist_scope.
Open Scope mat_scope.

(** ** Definition of Matrix Type *)
Section mat_def.

  Record mat {A : Type} (r c : nat) : Type :=
    mk_mat {
        mdata : list (list A);
        mheight : length mdata = r;
        mwidth : width mdata c
      }.

End mat_def.

Arguments mk_mat {A r c}.
Arguments mdata {A r c}.
Arguments mheight {A r c}.
Arguments mwidth {A r c}.

(** ** matrix equality *)
Section meq.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  (* Infix "==" := Aeq : A_scope. *)
  (* Infix "==" := (eqlistA Aeq) : list_scope. *)
  Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.

  Definition meq {r c} (m1 m2 : mat r c) := mdata m1 == mdata m2.
  Infix "==" := meq : mat_scope.

  Lemma meq_refl : forall r c (m : mat r c), m == m.
  Proof.
    intros. hnf. easy.
  Qed.

  Lemma meq_sym : forall r c (m1 m2 : mat r c), m1 == m2 -> m2 == m1.
  Proof.
    intros. hnf in *. rewrite H. easy.
  Qed.

  Lemma meq_trans : forall r c (m1 m2 m3 : mat r c), m1 == m2 -> m2 == m3 -> m1 == m3.
  Proof.
    intros. hnf in *. rewrite H. easy.
  Qed.

  Lemma Equiv_meq : forall {r c}, Equivalence (@meq r c).
  Proof.
    intros. constructor; intro; intros.
    apply meq_refl.
    apply meq_sym. auto.
    apply meq_trans with y; auto.
  Qed.

  Global Existing Instance Equiv_meq.

  (** The equality of matrix is decidable *)
  Context (Dec_Aeq:Decidable Aeq).
  Lemma meq_dec : forall {r c}, Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. constructor. unfold meq in *. intros.
    apply list_eq_dec.
    apply list_eq_dec.
    apply decidable.
  Qed.

  Lemma mdata_aeq_mor : forall {r c}, Proper (@meq r c ==> eqlistA (eqlistA Aeq)) mdata.
  Proof.
    unfold Proper, respectful.
    intros. destruct x,y. unfold meq in *. simpl in *. auto.
  Qed.

  Global Existing Instance mdata_aeq_mor.

End meq.

(** ** Get Matrix Element *)
Section mnth.

  Context `{Aeq:relation A} (A0:A) {r c:nat}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  Definition mnth (m : mat r c) (ri ci : nat) : A :=
    nth ci (nth ri (mdata m) []) A0.

  Notation "m @ i # j" :=
    (mnth m i j) (at level 20, i at next level, j at next level).

  Context `{Equiv_Aeq:Equivalence A Aeq}.
  Lemma meq_iff_mnth : forall (m1 m2 : mat r c),
      m1 == m2 <->
        (forall (ri cj : nat), ri < r -> cj < c -> (m1 @ ri # cj == m2 @ ri # cj)%A).
  Proof.
    intros. unfold meq,mnth. destruct m1,m2; simpl. split.
    - intros.
      apply nth_aeq_mor; try easy.
      apply nth_aeq_mor; try easy.
    - intros.
      rewrite (dlist_eq_iff_nth_nth (A0:=A0) r c); auto.
  Qed.

End mnth.

(** ** Convert between function and matrix *)
Section f2m_m2f.

  Context `{Aeq:relation A} (A0:A).
  Infix "==" := Aeq : A_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  Definition f2m {r c} (f : nat -> nat -> A) : @mat A r c :=
    mk_mat (@f2dl A r c f) (f2dl_length r c f) (f2dl_width r c f).

  Definition m2f {r c} (m : mat r c) : (nat -> nat -> A) :=
    dl2f (r:=r) (c:=c) (A0:=A0) (mdata m).

End f2m_m2f.

(** ** matrix with specific size *)

(** mat_1_1 *)
Section mat_1_1.

  Context {A:Type}.
  Variable a : A.

  Let data := [[a]].
  Let cond_h : length data = 1. auto. Qed.
  Let cond_w : width data 1. constructor; auto. Qed.

  Definition mk_mat_1_1 : mat 1 1 := mk_mat data cond_h cond_w.

End mat_1_1.

(** mat_1_2 *)
Section mat_1_2.

  Context {A:Type}.
  Variable a b : A.

  Let data : list (list A) := [[a; b]].
  Let cond_h : length data = 1. auto. Qed.
  Let cond_w : width data 2. constructor; auto. Qed.

  Definition mk_mat_1_2' : mat 1 2 := mk_mat data cond_h cond_w.

End mat_1_2.

(** mat_0_c *)
Section mat_0_c.

  Context {A:Type}.
  Variable c : nat.

  Let data : list (list A) := [].
  Let cond_h : length data = 0. auto. Qed.
  Let cond_w : width data c. constructor; auto. Qed.

  Definition mk_mat_0_c : mat 0 c := mk_mat data cond_h cond_w.

End mat_0_c.

(** mat_1_c *)
Section mat_1_c.

  Context {A:Type}.
  Variable l : list A.
  Variable c : nat.
  Variable H1 : length l = c.

  Let data : list (list A) := [l].
  Let cond_h : length data = 1. auto. Qed.
  Let cond_w : width data c. constructor; auto. Qed.

  Definition mk_mat_1_c : mat 1 c := mk_mat data cond_h cond_w.

End mat_1_c.

(** mat_1_2, mat_1_3, ... *)
Definition mk_mat_1_2 {A} (a1 a2 : A) : mat 1 2 :=
  mk_mat_1_c [a1;a2] 2 eq_refl.

Definition mk_mat_1_3 {A} (a1 a2 a3 : A) : mat 1 3 :=
  mk_mat_1_c [a1;a2;a3] 3 eq_refl.

Definition mk_mat_1_4 {A} (a1 a2 a3 a4 : A) : mat 1 4 :=
  mk_mat_1_c [a1;a2;a3;a4] 4 eq_refl.

(** mat_r_0 *)
Section mat_r_0.

  Context {A:Type}.
  Variable l : list A.
  Variable r : nat.
  Variable H1 : length l = r.

  Let data : list (list A) := @dnil A r.
  Let cond_h : length data = r. unfold data. rewrite dnil_length. auto.
  Qed.
  Let cond_w : width data 0. unfold data. apply dnil_width. Qed.

  Definition mk_mat_r_0 : mat r 0 := mk_mat data cond_h cond_w.

End mat_r_0.

(** mat_r_1 *)
Section mat_r_1.

  Context {A:Type}.
  Variable l : list A.
  Variable r : nat.
  Variable H1 : length l = r.

  Let data : list (list A) := row2col l.
  Let cond_h : length data = r. unfold data. rewrite row2col_length. auto.
  Qed.
  Let cond_w : width data 1. unfold data. apply row2col_width; auto. Qed.

  Definition mk_mat_r_1 : mat r 1 := mk_mat data cond_h cond_w.

End mat_r_1.

(** mat_2_1, mat_3_1, ... *)
Definition mk_mat_2_1 {A} (a1 a2 : A) : mat 2 1 :=
  mk_mat_r_1 [a1;a2] 2 eq_refl.

Definition mk_mat_3_1 {A} (a1 a2 a3 : A) : mat 3 1 :=
  mk_mat_r_1 [a1;a2;a3] 3 eq_refl.

Definition mk_mat_4_1 {A} (a1 a2 a3 a4 : A) : mat 4 1 :=
  mk_mat_r_1 [a1;a2;a3;a4] 4 eq_refl.

(** mat_2_2 *)
Section mat_2_2.

  Context {A:Type}.
  Variable a11 a12 a21 a22 : A.

  Let data : list (list A) := [[a11;a12];[a21;a22]].
  Let cond_h : length data = 2. auto. Qed.
  Let cond_w : width data 2. unfold data. constructor; auto. Qed.

  Definition mk_mat_2_2 : mat 2 2 := mk_mat data cond_h cond_w.

End mat_2_2.

(** mat_3_3 *)
Section mat_3_3.

  Context {A:Type}.
  Variable a11 a12 a13 a21 a22 a23 a31 a32 a33 : A.

  Let data : list (list A) := [[a11;a12;a13];[a21;a22;a23];[a31;a32;a33]].
  Let cond_h : length data = 3. auto. Qed.
  Let cond_w : width data 3. unfold data. constructor; auto. Qed.

  Definition mk_mat_3_3 : mat 3 3 := mk_mat data cond_h cond_w.

End mat_3_3.

(** ** Matrix map to a dlist *)
Section matmapdl.

  Context {A B:Type} {r c : nat}.
  Variable f : A -> B.

  Definition matmapdl (m : mat r c) : list (list B) :=
    dmap f (mdata m).

  Lemma matmapdl_length : forall (m : mat r c),
      length (matmapdl m) = r.
  Proof.
    intros; simpl. unfold matmapdl. rewrite dmap_length.
    apply mheight.
  Qed.

  Lemma matmapdl_width : forall (m : mat r c),
      width (matmapdl m) c.
  Proof.
    intros; simpl. unfold matmapdl. rewrite <- dmap_width.
    apply mwidth.
  Qed.

End matmapdl.

(** ** Matrix map2 to a dlist *)
Section matmap2dl.

  Context {A B C : Type} {r c : nat}.
  Variable f : A -> B -> C.

  Definition matmap2dl (m1 : mat r c) (m2 : @mat B r c)
    : list (list C) :=
    dmap2 f (mdata m1) (mdata m2).

  Lemma matmap2dl_length : forall (m1 : mat r c) (m2 : @mat B r c),
      length (matmap2dl m1 m2) = r.
  Proof.
    intros; simpl. unfold matmap2dl. rewrite dmap2_length;
      repeat rewrite mheight; auto.
  Qed.

  Lemma matmap2dl_width : forall (m1 : mat r c) (m2 : @mat B r c),
      width (matmap2dl m1 m2) c.
  Proof.
    intros; simpl. unfold matmap2dl. apply dmap2_width;
      apply mwidth.
  Qed.

End matmap2dl.

(** ** Matrix map *)
Section matmap.

  Context {A B : Type} {r c : nat}.
  Variable f : A -> B.

  Definition matmap (m : mat r c) : @mat B r c :=
    mk_mat (matmapdl f m) (matmapdl_length f m) (matmapdl_width f m).

End matmap.

(** ** Matrix map2 *)
Section matmap2.

  Context {A B C : Type} {r c : nat}.

  Definition matmap2 (f : A -> B -> C) (m1 : mat r c) (m2 : @mat B r c)
    : @mat C r c :=
    mk_mat (matmap2dl f m1 m2) (matmap2dl_length f m1 m2)
      (matmap2dl_width f m1 m2).

End matmap2.

(** ** Matrix map2 with same base type *)
Section matmap2_sametype.

  Context `{Aeq:relation A} `{Aadd:A->A->A}.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  Context `{Comm_Aadd : Commutative A Aadd Aeq}.
  Lemma matmap2_comm : forall {r c} (m1 m2 : mat r c),
      matmap2 Aadd m1 m2 == matmap2 Aadd m2 m1.
  Proof.
    intros. unfold meq,matmap2,matmap2dl; simpl.
    apply dmap2_comm; auto.
  Qed.

  Context `{Assoc_Aadd : Associative A Aadd Aeq}.
  Context `{Equiv_Aeq: Equivalence A Aeq}.
  Lemma matmap2_assoc : forall {r c} (m1 m2 m3 : mat r c),
      matmap2 Aadd (matmap2 Aadd m1 m2) m3 == matmap2 Aadd m1 (matmap2 Aadd m2 m3).
  Proof.
    intros. unfold meq,matmap2,matmap2dl; simpl.
    apply dmap2_assoc; auto.
  Qed.

End matmap2_sametype.

(** ** zero matrix and unit matrix *)
Section mat0_mat1.

  Context {A:Type} (A0 A1 : A).
  Definition mat0 {r c} := mk_mat (dlzero A0 r c) dlzero_length dlzero_width.
  Definition mat1 {n} := mk_mat (dlunit A0 A1 n) dlunit_length dlunit_width.

End mat0_mat1.

(** ** matrix transpose *)
Section mtrans.

  Context `{Aeq:relation A}.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  Definition mtrans {r c} (m : @mat A r c) : mat c r :=
    let dl := mdata m in
    mk_mat (dltrans dl c)
      (dltrans_length dl c (mwidth m))
      (dltrans_width dl r c (mheight m) (mwidth m)).

  (** Transpose twice return back *)
  Context `{Equiv_Aeq: Equivalence A Aeq}.
  Lemma mtrans_trans : forall {r c} (m : mat r c),
      mtrans (mtrans m) == m.
  Proof.
    intros. destruct m; unfold meq; simpl.
    rewrite dltrans_trans; try easy.
  Qed.

End mtrans.

(** ** matrix addition,opposition,subtraction *)
Section madd_opp_sub.

  Context `{G:AGroup A Aadd A0 Aopp Aeq}.
  Notation Asub := (fun a b => Aadd a (Aopp b)).
  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  (** matrix addition *)
  Definition madd {r c} (m1 m2 : mat r c) : mat r c :=
    matmap2 Aadd m1 m2.
  Infix "+" := madd : mat_scope.

  Lemma madd_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq) (r:=r) (c:=c)) madd.
  Proof.
    unfold Proper, respectful.
    intros. destruct x, y, x0, y0. unfold meq in *; simpl in *.
    unfold matmap2dl; simpl. rewrite H,H0. easy.
  Qed.

  Global Existing Instance madd_aeq_mor.

  (** matrix opposition *)
  Definition mopp {r c} (m : mat r c) : mat r c :=
    matmap Aopp m.
  Notation "- m" := (mopp m) : mat_scope.

  Lemma mopp_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq) (r:=r) (c:=c)) mopp.
  Proof.
    unfold Proper, respectful.
    intros. destruct x, y. unfold meq in *; simpl in *.
    unfold matmapdl; simpl. rewrite H. easy.
  Qed.

  (* matrix subtraction *)
  Definition msub {r c} (m1 m2 : mat r c) : mat r c :=
    matmap2 Asub m1 m2.
  Infix "-" := msub : mat_scope.

  Global Existing Instance mopp_aeq_mor.

  Lemma msub_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq) (r:=r) (c:=c)) msub.
  Proof.
    unfold Proper, respectful.
    intros. destruct x, y, x0, y0. unfold meq in *; simpl in *.
    unfold matmap2dl; simpl.
    rewrite H,H0. easy.
  Qed.

  Global Existing Instance msub_aeq_mor.

  Lemma madd_comm : forall {r c} (m1 m2 : mat r c),
      m1 + m2 == m2 + m1.
  Proof.
    intros. unfold meq,matmap2dl. apply dmap2_comm.
  Qed.

  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c),
      (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof.
    intros. unfold meq, matmap2dl. apply dmap2_assoc.
  Qed.

  (** 0 + m = m *)
  Lemma madd_zero_l : forall {r c} (m : mat r c), (mat0 A0) + m == m.
  Proof.
    intros. unfold meq,matmap2dl.
    apply dladd_zero_l; auto. apply mheight. apply mwidth.
  Qed.

  (** m + 0 = m *)
  Lemma madd_zero_r : forall {r c} (m : mat r c), m + (mat0 A0) == m.
  Proof.
    intros. unfold meq, madd.
    rewrite matmap2_comm. apply madd_zero_l.
  Qed.

  (** - (- m) = m *)
  Lemma mopp_opp : forall {r c} (m : mat r c), - (- m) == m.
  Proof.
    intros. unfold meq,mopp,matmap,matmapdl,dmap. simpl.
    (** Remark: with the help of "map_map, map_id on setoid", the proof is well *)
    rewrite map_map. rewrite map_id. easy.
    intros. rewrite map_map. rewrite map_id. easy.
    intros. rewrite group_inv_inv. easy.
  Qed.

  Lemma mopp_exchange : forall {r c} (m1 m2 : mat r c), -m1 == m2 <-> m1 == -m2.
  Proof.
    intros. split; intros.
    - rewrite <- H. rewrite mopp_opp. easy.
    - rewrite H. rewrite mopp_opp. easy.
  Qed.

  Lemma mopp_mat0 : forall {r c:nat}, - (@mat0 A A0 r c) == mat0 A0.
  Proof.
    intros. hnf. unfold mopp,mat0; simpl. unfold matmapdl; simpl.
    unfold dmap,dlzero. revert c.
    induction r; intros; simpl; try easy. apply cons_aeq_mor; auto.
    induction c; intros; simpl; try easy. apply cons_aeq_mor; auto.
    apply group_opp_zero_eq_zero.
  Qed.

  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == mat0 A0.
  Proof.
    intros. destruct m as [dl H W]. hnf.
    unfold mopp,madd,meq; simpl. unfold matmap2dl; simpl.
    unfold dmap2,matmapdl,dlzero,dmap. simpl.
    revert c dl H W. induction r; intros; simpl.
    - apply List.length_zero_iff_nil in H. subst. simpl. auto.
    - destruct dl. easy. inv H. inv W.
      rewrite map_cons. simpl. apply cons_aeq_mor.
      + (* needn't induction, use map_id and map2_map_map *)
        rewrite <- (map_id l (fun x => x)) at 1; try easy.
        rewrite map2_map_map with (g:=fun x => Aadd x (Aopp x)); try easy.
        apply map_eq_zero; auto. intros. group_simpl.
      + apply IHr; auto.
  Qed.

  (* m1 - m2 = - (m2 - m1) *)
  Lemma msub_comm : forall {r c} (m1 m2 : mat r c),
      m1 - m2 == - (m2 - m1).
  Proof.
    intros. destruct m1,m2.
    unfold meq,msub,mopp,matmap2,matmap2dl; simpl.
    unfold matmapdl; simpl. subst.
    rewrite (dlsub_comm _ _ c); easy.
  Qed.

  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c),
      (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    intros. unfold meq,msub,mopp,madd,matmap2,matmap2dl. simpl.
    apply (dlsub_assoc _ _ _ c); try apply mwidth;
      repeat rewrite mheight; auto.
  Qed.

  (** 0 - m = - m *)
  Lemma msub_zero_l : forall {r c} (m : mat r c),
      (mat0 A0) - m == - m.
  Proof.
    intros. unfold meq, msub, mopp, matmap2dl. simpl.
    unfold matmap2dl, matmapdl.
    apply dlsub_zero_l; auto. apply mheight. apply mwidth.
  Qed.

  (** m - 0 = m *)
  Lemma msub_zero_r : forall {r c} (m : mat r c),
      m - (mat0 A0) == m.
  Proof.
    intros. unfold meq, msub, mopp, matmap2dl. simpl.
    unfold matmap2dl, matmapdl.
    apply dlsub_zero_r; auto. apply mheight. apply mwidth.
  Qed.

  (** m - m = 0 *)
  Lemma msub_self : forall {r c} (m : mat r c),
      m - m == (mat0 A0).
  Proof.
    intros. unfold meq, msub, mopp, matmap2dl. simpl.
    unfold matmap2dl, matmapdl.
    apply dlsub_self; auto. apply mheight. apply mwidth.
  Qed.

End madd_opp_sub.

(** ** matrix multiplication *)
Section mcmul_mmulc_mmul.

  Context {A:Type} {A0 A1:A}.
  Context `{R:Ring A Aadd A0 Aopp Amul A1 Aeq}.
  Add Ring ring_inst : make_ring_theory.
  Infix "+" := Aadd : A_scope.
  Infix "*" := Amul : A_scope.
  Notation "- a" := (Aopp a) : A_scope.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.

  Infix "+" := (madd (Aadd:=Aadd)) : mat_scope.
  Notation "- m" := (mopp (Aopp:=Aopp) m) : mat_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  Definition mcmul {r c : nat} (a : A) (m : @mat A r c) : @mat A r c.
    refine (mk_mat (dmap (fun x => Amul a x) (mdata m)) _ _).
    - rewrite dmap_length. destruct m. simpl. auto.
    - apply dmap_width. destruct m. simpl. auto.
  Defined.
  Infix "c*" := mcmul : mat_scope.

  Definition mmulc {r c : nat} (m : @mat A r c) (a : A) : @mat A r c.
    refine (mk_mat (dmap (fun x => Amul x a) (mdata m)) _ _).
    - rewrite dmap_length. destruct m. simpl. auto.
    - apply dmap_width. destruct m. simpl. auto.
  Defined.
  Infix "*c" := mmulc : mat_scope.

  Definition mmul {r c t : nat} (m1 : @mat A r c) (m2 : @mat A c t) : @mat A r t.
    refine (mk_mat (dldotdl (Aadd:=Aadd) (A0:=A0) (Amul:=Amul)
                      (mdata m1) (mdata (mtrans m2))) _ _).
    - destruct m1 as [dl1 H1 W1], m2 as [dl2 H2 W2]; simpl.
      apply dldotdl_length; auto.
    - destruct m1 as [dl1 H1 W1], m2 as [dl2 H2 W2]; simpl.
      apply (dldotdl_width _ _ _ c);
        auto using dltrans_length, dltrans_width.
  Defined.
  Infix "*" := mmul : mat_scope.

  (** matrix muliplication left distributve over addition.
        A * (B + C) = A * B + A * C *)
  Lemma mmul_add_distr_l : forall {r c t} (m1 : mat r c) (m2 m3 : mat c t),
      m1 * (m2 + m3) == (m1 * m2) + (m1 * m3).
  Proof.
    intros. destruct m1,m2,m3.
    unfold meq; simpl. unfold matmap2dl; simpl.
    rewrite dltrans_dmap2; auto.
    rewrite (dldotdl_dmap2_distr_r _ _ _ mwidth0);
      auto using dltrans_length, dltrans_width. easy. lia.
  Qed.

  (** matrix muliplication right distributve over addition.
        (A + B) * C = A * C + B * C *)
  Lemma mmul_add_distr_r : forall {r c t} (m1 m2 : mat r c) (m3 : mat c t),
      (m1 + m2) * m3 == (m1 * m3) + (m2 * m3).
  Proof.
    intros. destruct m1,m2,m3.
    unfold meq; simpl. unfold matmap2dl; simpl.
    rewrite (dldotdl_dmap2_distr_l _ _ _ mwidth0);
      auto using dltrans_length, dltrans_width. easy.
  Qed.

  (** matrix muliplication association.
        (A * B) * C = A * (B * C) *)
  Lemma mmul_assoc : forall {r c t s} (m1 : mat r c) (m2 : mat c t) (m3 : mat t s),
      (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. destruct m1,m2,m3.
    unfold meq; simpl. unfold matmap2dl; simpl.
    rewrite dldotdl_assoc; auto.
    rewrite dltrans_length; easy. apply dltrans_width; auto.
  Qed.

  (** 0 * A = 0 *)
  Lemma mmul_0_l : forall {r c t} (m : mat c t), (mat0 A0) * m == (@mat0 A A0 r t).
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl.
    rewrite dldotdl_zero_l. rewrite dltrans_length; auto. easy.
    apply dltrans_width; auto.
  Qed.

  (** A * 0 = 0 *)
  Lemma mmul_0_r : forall {r c t} (m : mat r c), m * (mat0 A0) == (@mat0 A A0 r t).
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl.
    rewrite dltrans_zero. rewrite dldotdl_zero_r; auto. subst. easy.
  Qed.

  (** 1 * A = A *)
  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 A0 A1) * m == m.
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl.
    rewrite dldotdl_dlunit_l;
      auto using dltrans_length, dltrans_width.
    apply dltrans_trans; auto.
  Qed.

  (** A * 1 = A *)
  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 A0 A1) == m.
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl.
    rewrite dltrans_dlunit.
    rewrite dldotdl_dlunit_r;
      auto using dltrans_length, dltrans_width. easy.
  Qed.

  (** a * M = M * a *)
  Lemma mmulc_eq_mcmul : forall {r c} (m : mat r c) a, m *c a == a c* m.
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl.
    rewrite dmap_ext with (g:=(fun x => (a*x)%A)). easy.
    intros. ring.
  Qed.

  (** a * (b * M) = (a * b) * M *)
  Lemma mcmul_assoc : forall {r c} (m : mat r c) a1 a2,
      a1 c* (a2 c* m) == (a1 * a2)%A c* m.
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl. unfold dmap; simpl.
    (* Remark: with the help of "map_ext on setoid", the proof is simplified. *)
    rewrite map_map. apply map_ext. intros.
    rewrite map_map. apply map_ext. intros. ring.
  Qed.

  (** a * (b * M) = (a * b) * M *)
  Lemma mcmul_perm : forall {r c} (m : mat r c) a1 a2,
      a1 c* (a2 c* m) == a2 c* (a1 c* m).
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl. unfold dmap; simpl.
    (* Remark: with the help of "map_ext on setoid", the proof is simplified. *)
    rewrite ?map_map. apply map_ext. intros.
    rewrite ?map_map. apply map_ext. intros. ring.
  Qed.

  (** a * (M1 + M2) = (a * M1) + (a * M2) *)
  Lemma mcmul_distr_l : forall {r c} a (m1 m2 : mat r c),
      a c* (m1 + m2) == (a c* m1) + (a c* m2).
  Proof.
    intros. destruct m1,m2; simpl.
    unfold meq; simpl. unfold matmap2dl; simpl.
    apply symmetry.
    apply dmap2_dmap_hom.
    intros. ring.
  Qed.

  (** (a1 + a2) * M = (a1 * M) + (a2 * M) *)
  Lemma mcmul_distr_r : forall {r c} a1 a2 (m : mat r c),
      (a1 + a2)%A c* m == (a1 c* m) + (a2 c* m).
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl. unfold matmap2dl; simpl.
    rewrite (dmap2_dmap_dmap _ _ (fun x => (a1 + a2) * x)%A). easy.
    intros. ring.
  Qed.

  (* 0 c* m = mat0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m == mat0 A0.
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl.
    rewrite dmap_ext with (g:=(fun x => A0)).
    - apply dmap_eq_zero; auto.
    - intros. ring.
  Qed.

  (* 1 c* m = m *)
  Lemma mcmul_1 : forall {r c} (m : mat r c), A1 c* m == m.
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl. unfold dmap.
    apply map_id. intros.
    apply map_id. intros.
    ring.
  Qed.

  (* (-a) * m = - (a * m) *)
  Lemma mcmul_neg : forall {r c} a (m : mat r c), (- a)%A c* m == - (a c* m).
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl. unfold matmapdl; simpl. unfold dmap; simpl.
    rewrite map_map. apply map_ext. intros.
    rewrite map_map. apply map_ext. intros. ring.
  Qed.

  (* (-a) * (- m) = (a * m) *)
  Lemma mcmul_neg_mopp : forall {r c} a (m : mat r c),
      (- a)%A c* (- m) == a c* m.
  Proof.
    intros. destruct m; simpl.
    unfold meq; simpl. unfold matmapdl; simpl. unfold dmap; simpl.
    rewrite map_map. apply map_ext. intros.
    rewrite map_map. apply map_ext. intros. ring.
  Qed.

  (** Properties below, need a field structure *)
  Context `{F:Field A Aadd A0 Aopp Amul A1 Ainv Aeq}.
  Context `{Dec_Aeq:Decidable A Aeq}.

  (** k * m = 0 -> (m = 0) \/ (k = 0) *)
  Lemma mcmul_eq0_imply_m0_or_k0 : forall {r c} (m : mat r c) k,
      let m0 := mat0 A0 in
      (k c* m == m0) -> (m == m0) \/ (k == A0)%A.
  Proof.
    intros. unfold mcmul, meq in *; simpl in *.
    destruct m as [dl HH HW]; simpl in *.
    unfold dlzero, dmap in *.
    apply dlcmul_zero_imply_k0_or_dlzero in H; auto. tauto.
  Qed.

  (** (m <> 0 \/ k * m = 0) -> k = 0 *)
  Lemma mcmul_mnonzero_eq0_imply_k0 : forall {r c} (m : mat r c) k,
      let m0 := mat0 A0 in
      ~(m == m0) -> k c* m == m0 -> (k == A0)%A.
  Proof.
    intros. apply mcmul_eq0_imply_m0_or_k0 in H0; auto. tauto.
  Qed.

  (** k * m = m -> k = 1 \/ m = 0 *)
  Lemma mcmul_same_imply_coef1_or_mzero : forall {r c} k (m : mat r c),
      k c* m == m -> (k == A1)%A \/ (m == mat0 A0).
  Proof.
    intros. destruct m. unfold mcmul,meq in *; simpl in *.
    apply (dlcmul_fixpoint_imply_k1_or_dlzero (r:=r) (c:=c)) in H; auto.
  Qed.

  (** (m1 <> 0 /\ m2 <> 0 /\ k * m1 = m2) -> k <> 0 *)
  Lemma mcmul_eq_mat_implfy_not_k0 : forall {r c} (m1 m2 : mat r c) k,
      let m0 := mat0 A0 in
      ~(m1 == m0) -> ~(m2 == m0) -> k c* m1 == m2 -> ~(k == A0)%A.
  Proof.
    intros. intro. destruct m1,m2. unfold meq in *; simpl in *. unfold dmap in *.
    rewrite (map_ext) with (g:=map (fun x=>A0)) (l:=mdata0) in H1.
    - setoid_rewrite dmap_eq_zero with (dl:=mdata0) in H1.
      (* ToDo: why can not use "rewrite"? *)
      rewrite H1 in H0. destruct H0; easy. auto. auto.
    - intros. apply map_ext. intros. rewrite H2. ring.
  Qed.

End mcmul_mmulc_mmul.

(* Arguments mmul A0 Aadd Amul {r c t}. *)
(* Arguments mcmul Amul {r c}. *)
(* Arguments mmulc Amul {r c}. *)

(** ** Matrix_1x1 to scalar *)
Section mat_1_1_to_scalar.

  Context {A:Type}.
  Variable A0 : A.

  Definition mat_1_1_to_s (m : @mat A 1 1) : A.
  Proof.
    destruct m as [dl].
    refine (hd A0 (hd [] dl)).
  Defined.

End mat_1_1_to_scalar.

(* Arguments mat_1_1_to_s {A}. *)

(** ** Convert from list list to mat *)

Section l2m.
  Context `{Equiv_Aeq:Equivalence A Aeq}.
  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.
  Variable A0 : A.

  (** list to fixed-length list *)
  Fixpoint l2v_aux (l : list A) (n : nat) : list A :=
    match n with
    | 0 => []
    | S n' => (hd A0 l) :: (l2v_aux (tl l) n')
    end.

  Lemma l2v_aux_length : forall (l : list A) (n : nat),
      length (l2v_aux l n) = n.
  Proof.
    intros l n. gd l. induction n; intros; simpl; auto.
  Qed.

  Lemma l2v_aux_eq : forall (l : list A) (n : nat)
                            (H1 : length l = n), (l2v_aux l n == l)%list.
  Proof.
    intros l n. gd l. induction n; intros; simpl.
    - apply (length_zero_iff_nil (Aeq:=Aeq)) in H1. easy.
    - destruct l. easy. inv H1. apply cons_aeq_mor; auto. simpl. easy.
  Qed.

  (* list list to fixed-shape list list *)
  Fixpoint l2m_aux (dl : list (list A)) (r c : nat) : list (list A)
    := match r with
       | 0 => []
       | S n' => (l2v_aux (hd nil dl) c) :: (l2m_aux (tl dl) n' c)
       end.

  Lemma l2m_aux_length : forall (dl : list (list A)) (r c : nat),
      length (l2m_aux dl r c) = r.
  Proof.
    intros dl r. gd dl. induction r; intros; simpl; auto.
  Qed.

  Lemma l2m_aux_width : forall (dl : list (list A)) (r c : nat),
      width (l2m_aux dl r c) c.
  Proof.
    unfold width; intros dl r. revert dl.
    induction r; intros; simpl; auto. constructor; auto.
    apply l2v_aux_length.
  Qed.

  Lemma l2m_aux_eq : forall (dl : list (list A)) (r c : nat)
                            (H1 : length dl = r) (H2 : width dl c),
      (l2m_aux dl r c == dl)%dlist.
  Proof.
    intros dl r. gd dl. induction r; intros; simpl; auto.
    - apply (length_zero_iff_nil (Aeq:=eqlistA Aeq)) in H1. easy.
    - destruct dl. easy. inv H1. inv H2.
      rewrite IHr; auto. simpl. rewrite l2v_aux_eq; auto. easy.
  Qed.

  Definition l2m (dl : list (list A)) (r c : nat) : mat r c :=
    mk_mat (l2m_aux dl r c) (l2m_aux_length dl r c) (l2m_aux_width dl r c).

  Lemma l2m_inj : forall {r c} (d1 d2 : list (list A)),
      length d1 = r -> width d1 c ->
      length d2 = r -> width d2 c ->
      ~(d1 == d2)%dlist -> ~(l2m d1 r c == l2m d2 r c).
  Proof.
    intros. unfold l2m. unfold meq; simpl.
    rewrite ?l2m_aux_eq; auto.
  Qed.

  Lemma l2m_surj : forall {r c} (m : mat r c), (exists d, l2m d r c == m).
  Proof.
    intros. exists (mdata m). unfold l2m,meq; simpl.
    apply l2m_aux_eq; auto. apply mheight. apply mwidth.
  Qed.

  Context `{R : Ring A Aadd A0 (Aeq:=Aeq)}.
  Infix "+" := (madd (Aadd:=Aadd)) : mat_scope.

  (** m2l (m1 + m2) = (m2l m1) + (m2l m2) *)
  Lemma m2l_madd_homo : forall r c (m1 m2 : mat r c),
      (mdata (m1 + m2) == dmap2 Aadd (mdata m1) (mdata m2))%dlist.
  Proof.
    intros. destruct m1,m2. simpl. unfold matmap2dl. simpl. easy.
  Qed.

End l2m.

(* Arguments l2v_aux {A}. *)
(* Arguments l2m_aux {A}. *)
(* Arguments l2m_aux_length {A}. *)
(* Arguments l2m_aux_width {A}. *)
(* Arguments l2m {A}. *)

(* ======================================================================= *)
(** ** Extra Properties *)
Section Extra.

  Context {A:Type} (A0:A).
  (** Vector type *)
  Definition vecr n := @mat A 1 n.
  Definition vecc n := @mat A n 1.

  (** Construct a matrix with a row vector and a a matrix *)
  Definition mconsr {r c} (v : vecr c) (m : @mat A r c) : @mat A (S r) c.
    destruct v as [v], m as [m].
    refine (mk_mat ((hd [] v) :: m) _ _); simpl; auto.
    unfold width in *. constructor; auto.
    destruct v; try easy. simpl. inv mwidth0. auto.
  Defined.

  (** Construct a matrix with a column row vector and a a matrix *)
  Definition mconsc {r c} (v : vecc r) (m : @mat A r c) : @mat A r (S c).
    destruct v as [v], m as [m].
    refine (mk_mat (consc (hdc A0 v) m) _ _).
    - apply consc_length; auto. rewrite hdc_length; auto.
    - apply consc_width; auto. rewrite hdc_length; subst; auto.
  Defined.

  (* (** Equality of two forms of ConstructByRow *) *)
  (* Lemma mconsr_eq {r c} (v : vecr c) (m : @mat A r c) : mconsr v m == (v, m). *)
  (* Proof. unfold mconsr. auto. Qed. *)

  (* (** Construct a matrix by rows with the matrix which row number is 0 *) *)
  (* Lemma mconsr_mr0 : forall {n} (v : @vec A n) (m : @mat A 0 n), *)
  (*   mconsr v m = [v]. *)
  (* Proof. intros. destruct m. unfold mconsr. auto. Qed. *)

  (* (** Construct a matrix by rows with the matrix which row column is 0 *) *)
  (* Lemma mconsr_mc0 : forall {n} (v : @vec A 0) (m : @mat A n 0), *)
  (*   mconsr v m = (tt, m). *)
  (* Proof. intros. destruct v. unfold mconsr. auto. Qed. *)

  (* (** Construct a matrix by columns with the matrix which row number is 0 *) *)
  (* Lemma mconsc_mr0 : forall {n} (v : @vec A 0) (m : @vec (@vec A n) 0), *)
  (*   mconsc v m = tt. *)
  (* Proof. intros. destruct m. unfold mconsc. auto. Qed.   *)

  (* Definition det_of_mat_3_3 (m : mat 3 3) : A := *)
  (*   let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) := *)
  (*     m2t_3x3 m in *)
  (*   let b1 := (a11 * a22 * a33)%A in *)
  (*   let b2 := (a12 * a23 * a31)%A in *)
  (*   let b3 := (a13 * a21 * a32)%A in *)
  (*   let c1 := (a11 * a23 * a32)%A in *)
  (*   let c2 := (a12 * a21 * a33)%A in *)
  (*   let c3 := (a13 * a22 * a31)%A in *)
  (*   let b := (b1 + b2 + b3)%A in *)
  (*   let c := (c1 + c2 + c3)%A in *)
  (*     (b - c)%A. *)

  (* Definition skew_sym_mat_of_v3 (v : V3) : mat 3 3. *)
  (* Proof. *)
  (*   destruct (v3_to_t3 v) as [[x y] z]. *)
  (*   refine (mk_mat_3_3  *)
  (*     A0    (-z)    y *)
  (*     z     A0     (-x) *)
  (*     (-y)  x       A0)%A. *)
  (* Defined. *)

  (* Definition v3cross (v1 v2 : V3) : vec 3 := (skew_sym_mat_of_v3 v1) * v2. *)

  (* Definition so3 (m : mat 3 3) : Prop :=  *)
  (*   let so3_mul_unit : Prop := (m \T) * m = mat1 3 in *)
  (*   let so3_det : Prop := (det_of_mat_3_3 m) = A1 in *)
  (*     so3_mul_unit /\ so3_det. *)

End Extra.

(* ======================================================================= *)
(** ** Matrix Inverse *)
Section MatInv.

  (** *** permutation *)
  Section Permutation.

  End Permutation.

  Variable A : Type.

  (*   Check mat. *)

End MatInv.

(* Import FieldR. *)
(* Module Import MatrixR := MatrixThy FieldDefR. *)

Module coordinate_transform_test.

  Import Reals.
  Open Scope R.
  Open Scope mat_scope.

  (* ref:
  https://en.wikipedia.org/wiki/Matrix_(mathematics)#Basic_operations
   *)

  Infix "*" := Rmult : A_scope.
  Infix "+" := Rplus : A_scope.
  Infix "+" := (madd (Aadd:=Rplus)) : mat_scope.
  Infix "*" := (mmul (Aadd:=Rplus) (Amul:=Rmult) (A0:=R0)) : mat_scope.
  Infix "c*" := (mcmul (Amul:=Rmult)) : mat_scope.
  Notation "m \T" := (mtrans m) : mat_scope.
  Infix "==" := (meq (Aeq:=eq)) : mat_scope.

  Definition m1 := l2m 0 [[1;3;1];[1;0;0]] 2 3.
  Definition m2 := l2m 0 [[0;0;5];[7;5;0]] 2 3.
  Definition m3 := l2m 0 [[1;3;6];[8;5;0]] 2 3.
  Example madd_m1_m2_eq_m3 : m1 + m2 == m3.
  Proof.
    unfold meq; simpl. cbn. repeat constructor; ring.
  Qed.

  Definition m4 := l2m 0 [[1; 8;-3];[4;-2; 5]] 2 3.
  Definition m5 := l2m 0 [[2;16;-6];[8;-4;10]] 2 3.
  Example mscale_2_m4_eq_m5 : 2 c* m4 == m5.
  Proof.
    unfold meq; simpl. cbn. repeat constructor; ring.
  Qed.

  Definition m6 := l2m 0 [[1;2;3];[0;-6;7]]   2 3.
  Definition m7 := l2m 0 [[1;0];[2;-6];[3;7]] 3 2.
  Example mtrans_m6_eq_m7 : m6\T == m7.
  Proof.
    unfold meq; simpl. easy.
  Qed.

  Variable θ ψ φ : R.
  Definition Rx (α : R) : mat 3 3 := mk_mat_3_3
                                        1         0           0
                                        0         (cos α)     (sin α)
                                        0         (-sin α)%R    (cos α).

  Definition Ry (β : R) : mat 3 3 := mk_mat_3_3
                                        (cos β)   0           (-sin β)%R
                                        0         1           0
                                        (sin β)   0           (cos β).

  Definition Rz (γ : R) : mat 3 3 := mk_mat_3_3
                                        (cos γ)   (sin γ)   0
                                        (-sin γ)%R  (cos γ)   0
                                        0         0         1.

  Definition R_b_e_direct : mat 3 3 := (mk_mat_3_3
                                          (cos θ * cos ψ)
                                          (cos ψ * sin θ * sin φ - sin ψ * cos φ)
                                          (cos ψ * sin θ * cos φ + sin φ * sin ψ)

                                          (cos θ * sin ψ)
                                          (sin ψ * sin θ * sin φ + cos ψ * cos φ)
                                          (sin ψ * sin θ * cos φ - cos ψ * sin φ)

                                          (-sin θ)
                                          (sin φ * cos θ)
                                          (cos φ * cos θ))%A.

  Opaque cos sin.

  Lemma Rx_Ry_Rz_eq_Rbe : (Rz ψ)\T * (Ry θ)\T * (Rx φ)\T == R_b_e_direct.
  Proof.
    unfold meq; simpl. cbn. repeat constructor; ring.
  Qed.

End coordinate_transform_test.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about cartesian products *)

Require Import Basics.Overture Basics.Equivalences Basics.PathGroupoids
               Basics.Tactics Basics.Trunc Basics.Decidable.
Require Import Types.Empty.
Local Open Scope path_scope.

Generalizable Variables X A B f g n.

Scheme prod_ind := Induction for prod Sort Type.
Arguments prod_ind {A B} P f p.

(** ** Unpacking *)

(** Sometimes we would like to prove [Q u] where [u : A * B] by writing [u] as a pair [(fst u ; snd u)]. This is accomplished by [unpack_prod]. We want tight control over the proof, so we just write it down even though is looks a bit scary. *)

Definition unpack_prod `{P : A * B -> Type} (u : A * B) :
  P (fst u, snd u) -> P u
  := idmap.

Arguments unpack_prod / .

(** Now we write down the reverse. *)
Definition pack_prod `{P : A * B -> Type} (u : A * B) :
  P u -> P (fst u, snd u)
  := idmap.

Arguments pack_prod / .

(** ** Eta conversion *)

Definition eta_prod `(z : A * B) : (fst z, snd z) = z
  := 1.

Arguments eta_prod / .

(** ** Paths *)

(** With this version of the function, we often have to give [z] and [z'] explicitly, so we make them explicit arguments. *)
Definition path_prod_uncurried {A B : Type} (z z' : A * B)
  (pq : (fst z = fst z') * (snd z = snd z'))
  : (z = z').
Proof.
  change ((fst z, snd z) = (fst z', snd z')).
  case (fst pq). case (snd pq).
  reflexivity.
Defined.

(** This is the curried one you usually want to use in practice.  We define it in terms of the uncurried one, since it's the uncurried one that is proven below to be an equivalence. *)
Definition path_prod {A B : Type} (z z' : A * B) :
  (fst z = fst z') -> (snd z = snd z') -> (z = z')
  := fun p q => path_prod_uncurried z z' (p,q).

(** This version produces only paths between pairs, as opposed to paths between arbitrary inhabitants of product types.  But it has the advantage that the components of those pairs can more often be inferred. *)
Definition path_prod' {A B : Type} {x x' : A} {y y' : B}
  : (x = x') -> (y = y') -> ((x,y) = (x',y'))
  := fun p q => path_prod (x,y) (x',y') p q.

(** Now we show how these things compute. *)

Definition ap_fst_path_prod {A B : Type} {z z' : A * B}
  (p : fst z = fst z') (q : snd z = snd z') :
  ap fst (path_prod _ _ p q) = p.
Proof.
  change z with (fst z, snd z).
  change z' with (fst z', snd z').
  destruct p, q.
  reflexivity.
Defined.

Definition ap_snd_path_prod {A B : Type} {z z' : A * B}
  (p : fst z = fst z') (q : snd z = snd z') :
  ap snd (path_prod _ _ p q) = q.
Proof.
  change z with (fst z, snd z).
  change z' with (fst z', snd z').
  destruct p, q.
  reflexivity.
Defined.

Definition eta_path_prod {A B : Type} {z z' : A * B} (p : z = z') :
  path_prod _ _(ap fst p) (ap snd p) = p.
Proof.
  destruct p. reflexivity.
Defined.

Definition ap_path_prod {A B C : Type} (f : A -> B -> C)
           {z z' : A * B} (p : fst z = fst z') (q : snd z = snd z')
: ap (fun z => f (fst z) (snd z)) (path_prod _ _ p q)
  = ap011 f p q.
Proof.
  destruct z, z'; simpl in *; destruct p, q; reflexivity.
Defined.

(** Now we show how these compute with transport. *)

Lemma transport_path_prod_uncurried {A B} (P : A * B -> Type) {x y : A * B}
      (H : (fst x = fst y) * (snd x = snd y))
      (Px : P x)
: transport P (path_prod_uncurried _ _ H) Px
  = transport (fun x => P (x, snd y))
              (fst H)
              (transport (fun y => P (fst x, y))
                         (snd H)
                         Px).
Proof.
  destruct x, y, H; simpl in *.
  path_induction.
  reflexivity.
Defined.

Definition transport_path_prod {A B} (P : A * B -> Type) {x y : A * B}
           (HA : fst x = fst y)
           (HB : snd x = snd y)
           (Px : P x)
: transport P (path_prod _ _ HA HB) Px
  = transport (fun x => P (x, snd y))
              HA
              (transport (fun y => P (fst x, y))
                         HB
                         Px)
  := transport_path_prod_uncurried P (HA, HB) Px.

Definition transport_path_prod'
           {A B} (P : A * B -> Type)
           {x y : A}
           {x' y' : B}
           (HA : x = y)
           (HB : x' = y')
           (Px : P (x,x'))
: transport P (path_prod' HA HB) Px
  = transport (fun x => P (x, y'))
              HA
              (transport (fun y => P (x, y))
                         HB
                         Px)
  := @transport_path_prod _ _ P (x, x') (y, y') HA HB Px.

(** This lets us identify the path space of a product type, up to equivalence. *)

Global Instance isequiv_path_prod {A B : Type} {z z' : A * B}
: IsEquiv (path_prod_uncurried z z') | 0.
Proof.
  refine (Build_IsEquiv _ _ _
            (fun r => (ap fst r, ap snd r))
            eta_path_prod
            (fun pq => path_prod'
                         (ap_fst_path_prod (fst pq) (snd pq))
                         (ap_snd_path_prod (fst pq) (snd pq)))
            _).
  destruct z as [x y], z' as [x' y'].
  intros [p q]; simpl in p, q.
  destruct p, q; reflexivity.
Defined.

Definition equiv_path_prod {A B : Type} (z z' : A * B)
  : (fst z = fst z') * (snd z = snd z')  <~>  (z = z')
  := Build_Equiv _ _ (path_prod_uncurried z z') _.

(** Path algebra *)

(** Composition.  The next three lemma are displayed equations in section 2.6 of the book, but they have no numbers so we can't put them into [HoTTBook.v]. *)
Definition path_prod_pp {A B : Type} (z z' z'' : A * B)
           (p : fst z = fst z') (p' : fst z' = fst z'')
           (q : snd z = snd z') (q' : snd z' = snd z'')
: path_prod z z'' (p @ p') (q @ q') = path_prod z z' p q @ path_prod z' z'' p' q'.
Proof.
  destruct z, z', z''; simpl in *; destruct p, p', q, q'.
  reflexivity.
Defined.

(** Associativity *)
Definition path_prod_pp_p  {A B : Type} (u v z w : A * B)
           (p : fst u = fst v) (q : fst v = fst z) (r : fst z = fst w)
           (p' : snd u = snd v) (q' : snd v = snd z) (r' : snd z = snd w)
: path_prod_pp u z w (p @ q) r (p' @ q') r'
  @ whiskerR (path_prod_pp u v z p q p' q') (path_prod z w r r')
  @ concat_pp_p (path_prod u v p p') (path_prod v z q q') (path_prod z w r r')
  = ap011 (path_prod u w) (concat_pp_p p q r) (concat_pp_p p' q' r')
    @ path_prod_pp u v w p (q @ r) p' (q' @ r')
    @ whiskerL (path_prod u v p p') (path_prod_pp v z w q r q' r').
Proof.
  destruct u, v, z, w; simpl in *; destruct p, p', q, q', r, r'.
  reflexivity.
Defined.

(** Inversion *)
Definition path_prod_V {A B : Type} (u v: A * B)
           (p : fst u = fst v)
           (q : snd u = snd v)
  : path_prod v u p^ q^ = (path_prod u v p q)^.
Proof.
  destruct u, v; simpl in *; destruct p, q.
  reflexivity.
Defined.

(** ** Transport *)

Definition transport_prod {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a')
  (z : P a * Q a)
  : transport (fun a => P a * Q a) p z  =  (p # (fst z), p # (snd z))
  := match p with idpath => 1 end.

(** ** Functorial action *)

Definition functor_prod {A A' B B' : Type} (f:A->A') (g:B->B')
  : A * B -> A' * B'
  := fun z => (f (fst z), g (snd z)).

Definition ap_functor_prod {A A' B B' : Type} (f:A->A') (g:B->B')
  (z z' : A * B) (p : fst z = fst z') (q : snd z = snd z')
  : ap (functor_prod f g) (path_prod _ _ p q)
  = path_prod (functor_prod f g z) (functor_prod f g z') (ap f p) (ap g q).
Proof.
  destruct z as [a b]; destruct z' as [a' b'].
  simpl in p, q. destruct p, q. reflexivity.
Defined.

(** ** Equivalences *)

Global Instance isequiv_functor_prod `{IsEquiv A A' f} `{IsEquiv B B' g}
: IsEquiv (functor_prod f g) | 1000.
Proof.
  refine (Build_IsEquiv
            _ _ (functor_prod f g) (functor_prod f^-1 g^-1)
            (fun z => path_prod' (eisretr f (fst z)) (eisretr g (snd z))
                      @ eta_prod z)
            (fun w => path_prod' (eissect f (fst w)) (eissect g (snd w))
                      @ eta_prod w)
            _).
  intros [a b]; simpl.
  unfold path_prod'.
  rewrite !concat_p1.
  rewrite ap_functor_prod.
  rewrite !eisadj.
  reflexivity.
Defined.

Definition equiv_functor_prod `{IsEquiv A A' f} `{IsEquiv B B' g}
  : A * B <~> A' * B'.
Proof.
  exists (functor_prod f g).
  exact _. (* i.e., search the context for instances *)
Defined.

Definition equiv_functor_prod' {A A' B B' : Type} (f : A <~> A') (g : B <~> B')
  : A * B <~> A' * B'.
Proof.
  exists (functor_prod f g).
  exact _.
Defined.

Notation "f *E g" := (equiv_functor_prod' f g) : equiv_scope.

Definition equiv_functor_prod_l {A B B' : Type} (g : B <~> B')
  : A * B <~> A * B'
  := 1 *E g.

Definition equiv_functor_prod_r {A A' B : Type} (f : A <~> A')
  : A * B <~> A' * B
  := f *E 1.

(** ** Logical equivalences *)

Definition iff_functor_prod {A A' B B' : Type} (f : A <-> A') (g : B <-> B')
  : A * B <-> A' * B'
  := (functor_prod (fst f) (fst g) , functor_prod (snd f) (snd g)).

(** ** Symmetry *)

(** This is a special property of [prod], of course, not an instance of a general family of facts about types. *)

Definition equiv_prod_symm (A B : Type) : A * B <~> B * A.
Proof.
  make_equiv.
Defined.

(** ** Associativity *)

(** This, too, is a special property of [prod], of course, not an instance of a general family of facts about types. *)
Definition equiv_prod_assoc (A B C : Type) : A * (B * C) <~> (A * B) * C.
Proof.
  make_equiv.
Defined.

(** ** Unit and annihilation *)

Definition prod_empty_r X : X * Empty <~> Empty
  := (Build_Equiv _ _ snd _).

Definition prod_empty_l X : Empty * X <~> Empty
  := (Build_Equiv _ _ fst _).

Definition prod_unit_r X : X * Unit <~> X.
Proof.
  refine (Build_Equiv _ _ fst _).
  simple refine (Build_IsEquiv _ _ _ (fun x => (x,tt)) _ _ _).
  - intros x; reflexivity.
  - intros [x []]; reflexivity.
  - intros [x []]; reflexivity.
Defined.

Definition prod_unit_l X : Unit * X <~> X.
Proof.
  refine (Build_Equiv _ _ snd _).
  simple refine (Build_IsEquiv _ _ _ (fun x => (tt,x)) _ _ _).
  - intros x; reflexivity.
  - intros [[] x]; reflexivity.
  - intros [[] x]; reflexivity.
Defined.

(** ** Universal mapping properties *)

(** Ordinary universal mapping properties are expressed as equivalences of sets or spaces of functions.  In type theory, we can go beyond this and express an equivalence of types of *dependent* functions.  Moreover, because the product type can expressed both positively and negatively, it has both a left universal property and a right one. *)

(* First the positive universal property. *)
Global Instance isequiv_prod_ind `(P : A * B -> Type)
: IsEquiv (prod_ind P) | 0
  := Build_IsEquiv
       _ _
       (prod_ind P)
       (fun f x y => f (x, y))
       (fun _ => 1)
       (fun _ => 1)
       (fun _ => 1).

Definition equiv_prod_ind `(P : A * B -> Type)
  : (forall (a : A) (b : B), P (a, b)) <~> (forall p : A * B, P p)
  := Build_Equiv _ _ (prod_ind P) _.

(* The non-dependent version, which is a special case, is the currying equivalence. *)
Definition equiv_uncurry (A B C : Type)
  : (A -> B -> C) <~> (A * B -> C)
  := equiv_prod_ind (fun _ => C).

(* Now the negative universal property. *)
Definition prod_coind_uncurried `{A : X -> Type} `{B : X -> Type}
  : (forall x, A x) * (forall x, B x) -> (forall x, A x * B x)
  := fun fg x => (fst fg x, snd fg x).

Definition prod_coind `(f : forall x:X, A x) `(g : forall x:X, B x)
  : forall x, A x * B x
  := prod_coind_uncurried (f, g).

Global Instance isequiv_prod_coind `(A : X -> Type) (B : X -> Type)
: IsEquiv (@prod_coind_uncurried X A B) | 0
  := Build_IsEquiv
       _ _
       (@prod_coind_uncurried X A B)
       (fun h => (fun x => fst (h x), fun x => snd (h x)))
       (fun _ => 1)
       (fun _ => 1)
       (fun _ => 1).

Definition equiv_prod_coind `(A : X -> Type) (B : X -> Type)
  : ((forall x, A x) * (forall x, B x)) <~> (forall x, A x * B x)
  := Build_Equiv _ _ (@prod_coind_uncurried X A B) _.

(** ** Products preserve truncation *)

Global Instance istrunc_prod `{IsTrunc n A} `{IsTrunc n B} : IsTrunc n (A * B) | 100.
Proof.
  generalize dependent B; generalize dependent A.
  simple_induction n n IH; simpl; (intros A ? B ?).
  { exists (center A, center B).
    intros z; apply path_prod; apply contr. }
  intros x y.
  exact (istrunc_equiv_istrunc _ (equiv_path_prod x y)).
Defined.

Global Instance contr_prod `{CA : Contr A} `{CB : Contr B} : Contr (A * B) | 100
  := @istrunc_prod (-2) A CA B CB.

(** ** Decidability *)

Global Instance decidable_prod {A B : Type}
       `{Decidable A} `{Decidable B}
: Decidable (A * B).
Proof.
  destruct (dec A) as [x1|y1]; destruct (dec B) as [x2|y2].
  - exact (inl (x1,x2)).
  - apply inr; intros [_ x2]; exact (y2 x2).
  - apply inr; intros [x1 _]; exact (y1 x1).
  - apply inr; intros [x1 _]; exact (y1 x1).
Defined.

(** Interaction of ap and uncurry *)

(* The function in ap011 can be uncurried *)
Definition ap_uncurry {A B C} (f : A -> B -> C) {a a' : A} (p : a = a')
  {b b' : B} (q : b = b')
  : ap (uncurry f) (path_prod' p q) = ap011 f p q.
Proof.
  by destruct q, p.
Defined.

(** Fibers *)

(** ** Fibers of [functor_prod] *)
Definition hfiber_functor_prod {A B C D : Type} (f : A -> B) (g : C -> D) y
  : hfiber (functor_prod f g) y <~> (hfiber f (fst y) * hfiber g (snd y)).
Proof.
  unfold functor_prod.
  snrefine (equiv_adjointify _ _ _ _).
  - exact (fun x => ((fst x.1; ap fst x.2), (snd x.1; ap snd x.2))).
  - refine (fun xs => (((fst xs).1, (snd xs).1); _)).
    apply Prod.path_prod;simpl.
    + exact (fst xs).2.
    + exact (snd xs).2.
  - destruct y as [y1 y2]; intros [[x1 p1] [x2 p2]].
    simpl in *. destruct p1,p2. reflexivity.
  - intros [[x1 x2] p]. destruct p;cbn. reflexivity.
Defined.

Global Instance istruncmap_functor_prod (n : trunc_index) {A B C D : Type}
  (f : A -> B) (g : C -> D) `{!IsTruncMap n f} `{!IsTruncMap n g}
  : IsTruncMap n (Prod.functor_prod f g)
  := fun y => istrunc_equiv_istrunc _ (hfiber_functor_prod _ _ _)^-1.


Require Export Arith.
Require Export Omega.
Require Export ArithRing.

Lemma sub_decrease : forall b n m:nat, n <= S b -> 0 < m -> n - m <= b.
Proof. intros; omega. Qed.

Ltac remove_minus :=
  match goal with
  |  |- context [(?X1 - ?X2 + ?X3)] =>
      rewrite <- (plus_comm X3); remove_minus
  |  |- context [(?X1 + (?X2 - ?X3) + ?X4)] =>
      rewrite (plus_assoc_reverse X1 (X2 - X3)); remove_minus
  |  |- context [(?X1 + (?X2 + (?X3 - ?X4)))] =>
      rewrite (plus_assoc X1 X2 (X3 - X4))
  |  |- (_ = ?X1 + (?X2 - ?X3)) =>
      apply (fun n m p:nat => plus_reg_l m p n) with X3;
       try rewrite (plus_permute X3 X1 (X2 - X3));
       rewrite le_plus_minus_r
  end.

Definition bdivspec :
  forall b n m:nat,
    n <= b -> 0 < m -> {q : nat &  {r : nat | n = m * q + r /\ r < m}}.
 fix bdivspec 1.
 {  intros b; case b.
    -  intros n m Hle Hlt; rewrite <- (le_n_O_eq _ Hle);
       exists 0; exists 0; split;
       auto with arith.
       ring.
    - intros b' n m Hle Hlt; case (le_gt_dec m n).
      +  intros Hle';
         generalize (bdivspec b' (n - m) m (sub_decrease b' n m Hle Hlt) Hlt).
         intros [q' [r [Heq Hlt']]];
           exists (S q'); exists r; split; auto with arith.
        replace (m * S q' + r) with (m * q' + r + m).
        rewrite <- Heq;  remove_minus; trivial.
        ring.
      + intros Hgt; exists 0; exists n; split; auto with arith.
         ring.
}
Qed.


Require Import StrictProp.
Require Import Setoid.

Lemma Spr1_inj {A P} {a b : @Ssig A P} (e : Spr1 a = Spr1 b) : a = b.
Proof.
  destruct a, b. cbn in e. subst. reflexivity.
Qed.

(* To jest nasza funkcja kanalizująca*)

Definition normalzation {A: Type} (f: A -> A) :=
  forall x: A, f x = f (f x).

Inductive Seq {A: Type} : A -> A -> SProp :=
| srefl : forall x: A, Seq x x.

Definition Squotient {A: Type} {f: A->A} (N: normalzation f) : Type :=
  Ssig (fun x : A => Seq x (f x)).

Class equivalance_relation {A: Type} (R: A -> A -> Prop) := equiv_proof {
  equiv_refl  : forall x: A, R x x;
  equiv_sym   : forall x y: A, R x y -> R y x;
  equiv_trans : forall x y z: A, R x y -> R y z -> R x z;
}.

Definition norm_equiv {A: Type} (f: A -> A) (N: normalzation f) (x y: A) : Prop :=
  f x = f y.

Theorem norm_equiv_is_equivalance_relation (A: Type) (f: A -> A) (N: normalzation f)
  : equivalance_relation (norm_equiv f N).
Proof.
  unfold norm_equiv. apply equiv_proof.
  - intro x. reflexivity.
  - intros x y H. symmetry. assumption.
  - intros x y z H H0. destruct H, H0. reflexivity.
Qed.

Print Ssig.

Theorem only_one_repersentant {A: Type} (f: A -> A) (N: normalzation f)
  (q q': Squotient N) : norm_equiv f N (Spr1 q) (Spr1 q') -> Seq q q'.
Proof.
  intro H.
  destruct q, q'. cbn in *.
  assert (E: Seq Spr1 Spr0).
  - unfold norm_equiv in H. destruct Spr2, Spr3.
    subst. constructor.
  - destruct E. constructor.
Qed.

Check only_one_repersentant.

(* Możemy skorzystać zamiast tego z funkcji określającej czy coś jest w postaci normalnej *)
(* Ale do stworzenia takiej funckji porzebowalibyśmy rozstrzygalenj równości na type A
    albo wyłączonego środka  *)

(* From HoTT *)

Inductive Empty : Type := .
Notation "! f" := (f -> Empty) (at level 75).
Notation "p ^" := (eq_sym p) (at level 30).
Notation "f @ g" := (eq_trans f g) (at level 40).

Class Decidable (A : Type) :=
  dec : A + (!A).
Arguments dec A {_}.

Definition DecidablePath (A : Type) :=
  forall x y: A, Decidable (x = y).

Class EqDec (A : Type) := {
  eqf : A -> A -> bool ;
  eqf_leibniz : forall x y, eqf x y = true <-> x = y
}.

Class HSet (X : Type) :=
  hSet : forall (x y : X) (p q : x = y), p = q.

Class WeaklyConstant {A B: Type} (f : A -> B) :=
  wconst : forall x y, f x = f y.

Class Collapsible (A : Type) :={
  collapse : A -> A ;
  wconst_collapse : WeaklyConstant collapse
}.

Theorem dec_means_collaps : forall A : Type, Decidable A -> Collapsible A.
Proof.
  intros A eq. destruct eq.
  - exists (fun x => a). unfold WeaklyConstant. intros x y. reflexivity.
  - exists (fun x => x). unfold WeaklyConstant. intros x y. assert Empty by auto. destruct H.
Qed.

Class PathCollapsible (A : Type) :=
  path_coll : forall (x y : A), Collapsible (x = y).

Theorem eq_dec_means_collapsible : forall A : Type, DecidablePath A -> PathCollapsible A.
Proof.
  intros A dec x y. apply dec_means_collaps. specialize (dec x y). assumption.
Qed.

Lemma loop_eq : forall A: Type, forall x y: A, forall p: x = y,
  eq_refl = (p ^) @ p.
Proof.
  intros A x y []. cbn. reflexivity.
Qed.

Theorem pathcoll_means_hset (A : Type) : PathCollapsible A -> HSet A.
Proof.
  unfold HSet. intros H x y. unfold PathCollapsible in *.
  assert (h: forall e: x=y, e = ((collapse (eq_refl x)) ^) @ (collapse e)).
  - intros []. apply loop_eq.
  - intros p q. rewrite (h q), (h p), (wconst_collapse p q). reflexivity.
Qed.

Theorem pathdec_hset (A: Type) : DecidablePath A -> HSet A.
Proof.
  intros H. apply pathcoll_means_hset. apply eq_dec_means_collapsible. assumption.
Qed.

Theorem eqDec_pathdec : forall A: Type, EqDec A -> DecidablePath A.
Proof.
  intros A H x y. destruct H. case_eq (eqf0 x y).
  - intro H1. left. apply (eqf_leibniz0 x y). assumption.
  - intro H1. right. intro H2. rewrite <- (eqf_leibniz0 x y) in H2. rewrite H1 in H2.
    discriminate.
Qed.

Theorem dec_eq_hset : forall A: Type, EqDec A -> HSet A.
Proof.
  intros A H. apply pathdec_hset. apply eqDec_pathdec. assumption.
Qed.

Theorem bool_hset : HSet bool.
Proof.
  apply dec_eq_hset. exists (fun x y: bool => (if x then y else (if y then false else true))).
  intros x y. destruct x, y; split; intro H; auto.
Qed.

Definition id {A: Type} (x: A) := x.

(* End HoTT *)

Definition get_norm_check {A: Type} (E: EqDec A) {f: A -> A} (N: normalzation f) (x: A)
  : bool := eqf x (f x).

Record quotient' {A: Type} (E: EqDec A) {f: A->A} (N: normalzation f)  := {
  val': A;
  proof': get_norm_check E N val' = true
}.

Arguments val' {A _ _ _} _.
Arguments proof' {A _ _ _} _.

Theorem only_one_repersentant' {A: Type} (E: EqDec A) (f: A -> A) (N: normalzation f)
  : forall q q': (quotient' E N), norm_equiv f N (val' q) (val' q') -> q = q'.
Proof.
  intros q q' H. unfold norm_equiv in H. destruct q, q'. cbn in *. assert (val'0 = val'1).
  - unfold get_norm_check in *. rewrite eqf_leibniz in proof'0, proof'1.
    destruct proof'0, proof'1, H. reflexivity.
  - assert (HSet: HSet bool) by apply bool_hset. subst. assert (proof'0 = proof'1).
    + specialize (HSet (get_norm_check E N val'1) true). apply HSet.
    + subst. reflexivity.
Qed.

(* From Pragmatic Quotints types *)
Record quot_class_of (T Q : Type) := QuotClass {
  repr : Q -> T;
  pi : T -> Q;
  reprK : forall x : Q, pi (repr x) = x
}.

Record quotType (T : Type) := QuotType {
  quot_sort :> Type;
  quot_class : quot_class_of T quot_sort
}.

Theorem quotient'_is_quotType {A: Type} (E: EqDec A) {f: A->A} (N: normalzation f) : quotType A.
Proof.
  exists (quotient' E N).
  - exists val' f. intro x.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                           Group Theory in Coq                            *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*									    *)
(*                                  INRIA                                   *)
(*                             Sophia-Antipolis                             *)
(*									    *)
(*				 January 1996				    *)
(*                                                                          *)
(****************************************************************************)

Require Import Ensembles.
Require Import Laws.
Require Import Group_definitions.
Require Import gr.
Require Import g1.

Theorem auxsub :
 forall (H : Group U) (x : U), subgroup U H Gr -> In U (G_ U H) x -> In U G x.
Proof.
intros H x H'; elim H'; auto with sets.
Qed.

Section Trois.

Variable H K : Group U.
Variable subH : subgroup U H Gr.
Variable subK : subgroup U K Gr.

Inductive Prod : Ensemble U :=
    Definition_of_Prod :
      forall x y z : U,
      In U (G_ U H) x -> In U (G_ U K) y -> star x y = z -> In U Prod z.
End Trois.

Section Quatre.
Variable H K : Group U.
Variable subH : subgroup U H Gr.
Variable subK : subgroup U K Gr.

Theorem T4 : Same_set U (Prod H K) (Prod K H) -> Setsubgroup U (Prod H K) Gr.
Proof.
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'.
apply T_1_6_3 with (witness := e); auto with sets.
rewrite <- (G2c' e); auto with sets.
apply Definition_of_Prod with (x := e) (y := e); auto with sets.
rewrite <- (eh_is_e H); auto with sets.
rewrite <- (eh_is_e K); auto with sets.
red in |- *.
intros x H'0; elim H'0.
intros x0 y z H'1 H'2 H'3; rewrite <- H'3; auto with sets.
intros a b H'0 H'1.
generalize H'1; clear H'1.
elim H'0.
intros x y z H'1 H'2 H'3; rewrite <- H'3.
intro H'4; elim H'4.
intros x0 y0 z0 H'5 H'6 H'7; rewrite <- H'7.
rewrite <- (inv_star' x0 y0); auto with sets.
rewrite <- (G1' x y (star (inv y0) (inv x0))); auto with sets.
red in H'.
elim H'; intros H'8 H'9; red in H'9; clear H'.
rewrite (G1' y (inv y0) (inv x0)); auto with sets.
lapply (H'9 (star (star y (inv y0)) (inv x0)));
 [ intro H'10; elim H'10 | idtac ].
intros x1 y1 z1 H' H'11 H'12; rewrite <- H'12.
rewrite (G1' x x1 y1); auto with sets.
apply Definition_of_Prod with (x := star x x1) (y := y1); auto with sets.
rewrite <- (starH_is_star H); auto with sets.
apply Definition_of_Prod with (x := star y (inv y0)) (y := inv x0).
rewrite <- (starH_is_star K); auto with sets.
rewrite <- (invH_is_inv K); auto with sets.
rewrite <- (invH_is_inv H); auto with sets.
trivial with sets.
Qed.

Theorem T4R : Setsubgroup U (Prod H K) Gr -> Included U (Prod H K) (Prod K H).
Proof.
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'; elim H'.
intros x H'0; red in |- *.
intros x0 H'1.
elim H'0; intros L1 L2; clear H'0.
generalize (auxsub x); intro tx.
cut (exists t : U, In U (Prod H K) t /\ t = inv x0).
intro H'2; elim H'2.
intros x1 H'3; elim H'3; intros H'4 H'5; try exact H'4; clear H'3.
generalize H'5.
elim H'4.
intros x2 y z H'3 H'6 H'7; rewrite <- H'7.
intro H'8.
rewrite (inv_involution' x0); auto with sets.
rewrite <- H'8.
rewrite <- (inv_star' x2 y); auto with sets.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv K subK y); auto with sets.
rewrite <- (invH_is_inv H subH x2); auto with sets.
generalize H'1.
rewrite <- L2; auto with sets.
intro H'0.
apply ex_intro with (x := inv x0).
split; [ idtac | trivial with sets ].
rewrite <- (invH_is_inv x L1 x0); auto with sets.
Qed.

Theorem T4R1 :
 Setsubgroup U (Prod H K) Gr -> Included U (Prod K H) (Prod H K).
Proof.
generalize (auxsub H); intro tH; generalize (auxsub K); intro tK.
intro H'; elim H'.
intros x H'0; red in |- *.
intros x0 H'1.
elim H'0; intros L1 L2; clear H'0.
generalize (auxsub x); intro tx.
cut (exists t : U, In U (Prod K H) t /\ t = inv (inv x0)).
intro H'0; elim H'0.
intros x1 H'2.
elim H'2; intros H'3 H'4; generalize H'4; clear H'2.
elim H'3.
intros x2 y z H'2 H'5 H'6; rewrite <- H'6.
intro H'7.
rewrite (inv_involution' x0).
rewrite <- H'7.
rewrite (inv_involution' (star x2 y)).
rewrite <- (inv_star' x2 y).
rewrite <- (invH_is_inv x L1 (star (inv y) (inv x2))).
rewrite <- L2; auto with sets.
elim L1; simpl in |- *; auto with sets.
intros H'15 H'16; apply (G3a_ U x); auto with sets.
rewrite L2.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv H subH y); auto with sets.
rewrite <- (invH_is_inv K subK x2); auto with sets.
rewrite L2.
apply Definition_of_Prod with (x := inv y) (y := inv x2); auto with sets.
rewrite <- (invH_is_inv H subH y); auto with sets.
rewrite <- (invH_is_inv K subK x2); auto with sets.
elim H'1; intros x3 y0 z0 H'8 H'9 H'10; rewrite <- H'10.
apply ex_intro with (x := star x3 y0).
split; [ idtac | auto with sets ].
apply Definition_of_Prod with (x := x3) (y := y0); trivial with sets.
Qed.
Hint Resolve T4 T4R T4R1.

Theorem T_1_6_8 :
 Same_set U (Prod H K) (Prod K H) <-> Setsubgroup U (Prod H K) Gr.
Proof.
red in |- *; auto with sets.
Qed.
End Quatre.