(******************************************************************************)
(* PipeCheck: Specifying and Verifying Microarchitectural                     *)
(* Enforcement of Memory Consistency Models                                   *)
(*                                                                            *)
(* Copyright (c) 2014 Daniel Lustig, Princeton University                     *)
(* All rights reserved.                                                       *)
(*                                                                            *)
(* This library is free software; you can redistribute it and/or              *)
(* modify it under the terms of the GNU Lesser General Public                 *)
(* License as published by the Free Software Foundation; either               *)
(* version 2.1 of the License, or (at your option) any later version.         *)
(*                                                                            *)
(* This library is distributed in the hope that it will be useful,            *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU          *)
(* Lesser General Public License for more details.                            *)
(*                                                                            *)
(* You should have received a copy of the GNU Lesser General Public           *)
(* License along with this library; if not, write to the Free Software        *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  *)
(* USA                                                                        *)
(******************************************************************************)

Require Import List.
Import ListNotations.
Require Import Arith.
Require Import util2.

(* Bell numbers *)

Fixpoint UniqueValues'
  (l r : list nat)
  : list nat :=
  match l with
  | [] => r
  | h::t =>
    UniqueValues' t (AddUnique r h)
  end.

(** Return [l], but with all duplicates removed. *)
Definition UniqueValues
  (l : list nat)
  : list nat :=
  let r := UniqueValues' l [] in
  r ++ [length r].

(** Given a list [l], return a list of lists where each unique value used in
  [l] is appended to [l], plus one unused unique value is also appended to
  [l]. *)
Fixpoint Bell'
  (l : list nat)
  : list (list nat) :=
  let v := UniqueValues l in
  let f x := l ++ [x] in
  map f v.

Module BellExample.

Example e1 :
  Bell' [0; 1; 2] = [[0; 1; 2; 0]; [0; 1; 2; 1]; [0; 1; 2; 2]; [0; 1; 2; 3]].
Proof.
auto.
Qed.

End BellExample.

(* Return the set of all possible assignments of unique values to [n] different
  slots.  The total number of such assignments is known as the "Bell number".

  In PipeCheck, this refers to the number of unique ways that [n] addresses can
  be assigned to [n] memory instructions, such that all possible combinations
  of overlapping and non-overlapping addresses are covered.  This is necessary
  whenever the ordering properties depend on whether addresses overlap or not.
*)
Fixpoint Bell
  (n : nat)
  : list (list nat) :=
  match n with
  | 0 => [[]]
  | S n' =>
    fold_left (app (A:=_)) (map Bell' (Bell n')) []
  end.

Module BellExample2.

Example e1 : Bell 4 =
  [[0; 0; 0; 0]; [0; 0; 0; 1]; [0; 0; 1; 0]; [0; 0; 1; 1]; [0; 0; 1; 2];
   [0; 1; 0; 0]; [0; 1; 0; 1]; [0; 1; 0; 2]; [0; 1; 1; 0]; [0; 1; 1; 1];
   [0; 1; 1; 2]; [0; 1; 2; 0]; [0; 1; 2; 1]; [0; 1; 2; 2]; [0; 1; 2; 3]].
Proof.
auto.
Qed.

(* OEIS A000110 : length(Bell n) = 1, 1, 2, 5, 15, 52, ... *)

Example e2 :
  map (fun n => length (Bell n)) [0; 1; 2; 3; 4; 5; 6] = [1; 1; 2; 5; 15; 52; 203].
Proof.
auto.
Qed.

End BellExample2.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

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

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (x : lst) : lst := append x (append Nil x).


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

Require Import List Arith Lia.
Require Fin.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils.

Set Implicit Arguments.

(* @DLW: former definition

Inductive pos : nat -> Set :=
  | pos_fst : forall n, pos (S n)
  | pos_nxt : forall n, pos n -> pos (S n).

Arguments pos_fst {n}.
Arguments pos_nxt {n}.

*)

Notation pos := Fin.t.
Notation pos_fst := Fin.F1.
Notation pos_nxt := Fin.FS.

Notation pos0  := (@pos_fst _).
Notation pos1  := (pos_nxt pos0).
Notation pos2  := (pos_nxt pos1).
Notation pos3  := (pos_nxt pos2).
Notation pos4  := (pos_nxt pos3).
Notation pos5  := (pos_nxt pos4).
Notation pos6  := (pos_nxt pos5).
Notation pos7  := (pos_nxt pos6).
Notation pos8  := (pos_nxt pos7).
Notation pos9  := (pos_nxt pos8).
Notation pos10 := (pos_nxt pos9).
Notation pos11 := (pos_nxt pos10).
Notation pos12 := (pos_nxt pos11).
Notation pos13 := (pos_nxt pos12).
Notation pos14 := (pos_nxt pos13).
Notation pos15 := (pos_nxt pos14).
Notation pos16 := (pos_nxt pos15).
Notation pos17 := (pos_nxt pos16).
Notation pos18 := (pos_nxt pos17).
Notation pos19 := (pos_nxt pos18).
Notation pos20 := (pos_nxt pos19).

Definition pos_iso n m : n = m -> pos n -> pos m.
Proof. intros []; auto. Defined.

Section pos_inv.

  Let pos_inv_t n :=
    match n as x return pos x -> Set with
      | 0   => fun _ => False
      | S n => fun i => (( i = pos_fst ) + { p | i = pos_nxt p })%type
    end.

  Let pos_inv : forall n p, @pos_inv_t n p.
  Proof.
    intros _ [ | n p ]; simpl; [ left | right ]; auto; exists p; auto.
  Defined.

  Definition pos_O_inv : pos 0 -> False.
  Proof. apply pos_inv. Defined.

  Definition pos_S_inv n (p : pos (S n)) : ( p = pos_fst ) + { q | p = pos_nxt q }.
  Proof. apply (pos_inv p). Defined.

  Definition pos_nxt_inj n (p q : pos n) (H : pos_nxt p = pos_nxt q) : p = q :=
    match H in _ = a return
       match a as a' in pos m return
           match m with
             | 0 => Prop
             | S n' => pos n' -> Prop
           end with
         | pos_fst   => fun _  => True
         | pos_nxt y => fun x' => x' = y
       end p with
     | eq_refl => eq_refl
   end.

End pos_inv.

Arguments pos_S_inv {n} p /.

Section pos_invert.

  (* Position inversion, "singleton elimination" free version
     One problem remains to fully use it ... it is not
     correctly traversed by type checking algorithm
     of fixpoints (structural recursion)

     pos_S_inv work better in that respect
  *)

  Let pos_invert_t n : (pos n -> Type) -> Type :=
    match n with
        0   => fun P => True
      | S n => fun P => (P (pos_fst) * forall p, P (pos_nxt p))%type
    end.

  Let pos_invert n : forall (P : pos n -> Type), pos_invert_t P -> forall p, P p.
  Proof.
    intros P HP; induction p; simpl in HP; apply HP.
  Defined.

  Theorem pos_O_invert X : pos 0 -> X.
  Proof.
    apply pos_invert; simpl; trivial.
  Defined.

  Theorem pos_S_invert n P : P (@pos_fst n) -> (forall p, P (pos_nxt p)) -> forall p, P p.
  Proof.
    intros; apply pos_invert; split; auto.
  Defined.

End pos_invert.

Arguments pos_S_invert [n] P _ _ p /.

Ltac pos_O_inv p := exfalso; apply (pos_O_inv p).

Ltac pos_S_inv p :=
  let H := fresh in
  let q := fresh
  in  rename p into q; destruct (pos_S_inv q) as [ H | (p & H) ]; subst q.

(*
Ltac pos_O_inv p := apply (@pos_O_invert _ p).
Ltac pos_S_inv x := induction x as [ | x ] using pos_S_invert.
*)

Ltac pos_inv p :=
  match goal with
    | [ H: pos 0     |- _ ] => match H with p => pos_O_inv p end
    | [ H: pos (S _) |- _ ] => match H with p => pos_S_inv p end
  end.

Tactic Notation "invert" "pos" hyp(H) := pos_inv H; simpl.

Ltac analyse_pos p :=
  match type of p with
    | pos 0     => pos_inv p
    | pos (S _) => pos_inv p; [ | try analyse_pos p ]
  end.

Tactic Notation "analyse" "pos" hyp(p) := analyse_pos p.

Definition pos_O_any X : pos 0 -> X.
Proof. intro p; invert pos p. Qed.

Definition pos_eq_dec n (x y : pos n) : { x = y } + { x <> y }.
Proof.
  revert n x y.
  induction x as [ x | n x IH ]; intros y; invert pos y.
  1: left; trivial.
  1,2: right; discriminate.
  destruct (IH y) as [ | C ].
  + left; subst; trivial.
  + right; contradict C; revert C; apply pos_nxt_inj.
Defined.

Fixpoint pos_left n m (p : pos n) : pos (n+m) :=
  match p with
    | pos_fst   => pos_fst
    | pos_nxt p => pos_nxt (pos_left m p)
  end.

Fixpoint pos_right n m : pos m -> pos (n+m) :=
  match n with
    | 0   => fun x => x
    | S n => fun p => pos_nxt (pos_right n p)
  end.

Definition pos_both n m : pos (n+m) -> pos n + pos m.
Proof.
  induction n as [ | n IHn ]; intros p.
  + right; exact p.
  + simpl in p; pos_inv p.
    * left; apply pos_fst.
    * destruct (IHn p) as [ a | b ].
      - left; apply (pos_nxt a).
      - right; apply b.
Defined.

Definition pos_lr n m : pos n + pos m -> pos (n+m).
Proof.
  intros [ p | p ]; revert p.
  + apply pos_left.
  + apply pos_right.
Defined.

Fact pos_both_left n m p : @pos_both n m (@pos_left n m p) = inl p.
Proof.
  induction p as [ | n p IHp ]; simpl; auto.
  rewrite IHp; auto.
Qed.

Fact pos_both_right n m p : @pos_both n m (@pos_right n m p) = inr p.
Proof.
  revert p; induction n as [ | n IHn]; intros p; simpl; auto.
  rewrite IHn; auto.
Qed.

(* A bijection between pos n + pos m <-> pos (n+m) **)

Fact pos_both_lr n m p : @pos_both n m (pos_lr p) = p.
Proof.
  destruct p as [ p | p ].
  + apply pos_both_left.
  + apply pos_both_right.
Qed.

Fact pos_lr_both n m p : pos_lr (@pos_both n m p) = p.
Proof.
  revert p; induction n as [ | n IHn ]; intros p; auto.
  simpl in p; pos_inv p; simpl; auto.
  specialize (IHn p).
  destruct (pos_both n m p); simpl in *; f_equal; auto.
Qed.

Section pos_left_right_rect.

  Variable (n m : nat) (P : pos (n+m) -> Type).

  Hypothesis (HP1 : forall p, P (pos_left _ p))
             (HP2 : forall p, P (pos_right _ p)).

  Theorem pos_left_right_rect : forall p, P p.
  Proof.
    intros p.
    rewrite <- pos_lr_both.
    generalize (pos_both n m p); clear p; intros [|]; simpl; auto.
  Qed.

End pos_left_right_rect.

Fixpoint pos_list n : list (pos n) :=
  match n with
    | 0   => nil
    | S n => pos0::map pos_nxt (pos_list n)
  end.

Fact pos_list_prop n p : In p (pos_list n).
Proof.
  induction p as [ | n p Hp ].
  left; auto.
  simpl; right.
  apply in_map_iff.
  exists p; auto.
Qed.

Fact pos_list_length n : length (pos_list n) = n.
Proof.
  induction n; simpl; auto.
  rewrite map_length; f_equal; auto.
Qed.

Section pos_map.

  Definition pos_map m n := pos m -> pos n.

  Definition pm_ext_eq m n (r1 r2 : pos_map m n) := forall p, r1 p = r2 p.

  Definition pm_lift m n (r : pos_map m n) : pos_map (S m) (S n).
  Proof.
    intros p.
    invert pos p.
    apply pos_fst.
    apply pos_nxt, (r p).
  Defined.

  Fact pm_lift_fst m n (r : pos_map m n) : pm_lift r pos0 = pos0.
  Proof. auto. Qed.

  Fact pm_lift_nxt m n (r : pos_map m n) p : pm_lift r (pos_nxt p) = pos_nxt (r p).
  Proof. auto. Qed.

  Arguments pm_lift [ m n ] r p.

  Fact pm_lift_ext m n r1 r2 : @pm_ext_eq m n r1 r2 -> pm_ext_eq (pm_lift r1) (pm_lift r2).
  Proof.
    intros H12 p; unfold pm_lift.
    invert pos p; simpl; auto.
    f_equal; apply H12.
  Qed.

  Definition pm_comp l m n : pos_map l m -> pos_map m n -> pos_map l n.
  Proof.
    intros H1 H2 p.
    exact (H2 (H1 p)).
  Defined.

  Fact pm_comp_lift l m n r s : pm_ext_eq (pm_lift (@pm_comp l m n r s)) (pm_comp (pm_lift r) (pm_lift s)).
  Proof.
    intros p.
    unfold pm_comp, pm_lift; simpl.
    invert pos p; simpl; auto.
  Qed.

  Definition pm_id n : pos_map n n := fun p => p.

End pos_map.

Arguments pm_lift { m n } _ _ /.
Arguments pm_comp [ l m n ] _ _ _ /.
Arguments pm_id : clear implicits.

Section pos_nat.

  Fixpoint pos_nat n (p : pos n) : { i | i < n }.
  Proof.
    refine (match p with
              | pos_fst   => exist _ 0 _
              | pos_nxt q => exist _ (S (proj1_sig (pos_nat _ q))) _
            end).
    apply lt_O_Sn.
    apply lt_n_S, (proj2_sig (pos_nat _ q)).
  Defined.

  Definition pos2nat n p := proj1_sig (@pos_nat n p).

  Fact pos2nat_prop n p : @pos2nat n p < n.
  Proof. apply (proj2_sig (pos_nat p)). Qed.

  Fixpoint nat2pos n : forall x, x < n -> pos n.
  Proof.
     refine (match n as n' return forall x, x < n' -> pos n' with
              | O   => fun x H => _
              | S i => fun x H => _
            end).
    exfalso; revert H; apply lt_n_O.
    destruct x as [ | x ].
    apply pos_fst.
    apply pos_nxt.
    apply (nat2pos i x); revert H; apply lt_S_n.
  Defined.

  Definition nat_pos n : { i | i < n } -> pos n.
  Proof. intros (? & H); revert H; apply nat2pos. Defined.

  Arguments pos2nat n !p /.

  Fact pos2nat_inj n (p q : pos n) : pos2nat p = pos2nat q -> p = q.
  Proof.
    revert q.
    induction p as [ n | n p IHp ]; intros q; invert pos q; simpl; auto; try discriminate 1.
    intros H; f_equal; apply IHp; injection H; trivial.
  Qed.

  Fact pos2nat_nat2pos n i (H : i < n) : pos2nat (nat2pos H) = i.
  Proof.
    revert i H;
    induction n as [ | n IHn ]; intros [ | i ] H; simpl; auto; try lia.
    f_equal.
    apply IHn.
  Qed.

  Fact nat2pos_pos2nat n p (H : pos2nat p < n) : nat2pos H = p.
  Proof.
    apply pos2nat_inj; rewrite pos2nat_nat2pos; auto.
  Qed.

  Fact pos2nat_fst n : pos2nat (@pos_fst n) = 0.
  Proof. auto. Qed.

  Fact pos2nat_nxt n p : pos2nat (@pos_nxt n p) = S (pos2nat p).
  Proof. auto. Qed.

  Fact pos2nat_left n m p : pos2nat (@pos_left n m p) = pos2nat p.
  Proof. induction p; simpl; auto. Qed.

  Fact pos2nat_right n m p : pos2nat (@pos_right n m p) = n+pos2nat p.
  Proof.
    revert m p; induction n as [ | n IHn ]; intros m p; auto.
    simpl pos_right; simpl plus; rewrite pos2nat_nxt; f_equal; auto.
  Qed.

  Fixpoint pos_sub n (p : pos n) { struct p } : forall m, n < m -> pos m.
  Proof.
    destruct p as [ | n p ]; intros [ | m ] Hm.
    exfalso; clear pos_sub; abstract lia.
    apply pos_fst.
    exfalso; clear pos_sub; abstract lia.
    apply pos_nxt.
    apply (pos_sub n p), lt_S_n, Hm.
  Defined.

  Fact pos_sub2nat n p m Hm : pos2nat (@pos_sub n p m Hm) = pos2nat p.
  Proof.
    revert m Hm; induction p as [ n | n p IH ]; intros [ | m ] Hm; try lia.
    simpl; auto.
    simpl pos_sub; repeat rewrite pos2nat_nxt; f_equal; auto.
  Qed.

End pos_nat.

Global Opaque pos_nat.

Fact pos_list2nat n : map (@pos2nat n) (pos_list n) = list_an 0 n.
Proof.
  induction n as [ | n IHn ]; simpl; f_equal.
  rewrite <- (map_S_list_an 0), <- IHn.
  do 2 rewrite map_map.
  apply map_ext.
  intros; rewrite pos2nat_nxt; auto.
Qed.

Section pos_prod.

  Variable n : nat.

  Let ll := flat_map (fun p => map (fun q => (p,q)) (pos_list n)) (pos_list n).
  Let ll_prop p q : In (p,q) ll.
  Proof.
    apply in_flat_map; exists p; split.
    apply pos_list_prop.
    apply in_map_iff.
    exists q; split; auto.
    apply pos_list_prop.
  Qed.

  Definition pos_not_diag := filter (fun c => if pos_eq_dec (fst c) (snd c) then false else true) ll.

  Fact pos_not_diag_spec p q : In (p,q) pos_not_diag <-> p <> q.
  Proof.
    unfold pos_not_diag.
    rewrite filter_In; simpl.
    destruct (pos_eq_dec p q).
    split.
    intros (_ & ?); discriminate.
    intros []; auto.
    split; try tauto; split; auto.
  Qed.

End pos_prod.


Inductive vector (A:Set) : nat -> Set :=
| vnil : vector A 0
| vcons : forall n, A -> vector A n -> vector A (S n).
Implicit Arguments vnil [A].
Implicit Arguments vcons [A n].

Definition vapp : forall `A n m`, vector A n -> vector A m -> vector A (n+m).
Proof.
  induction 1.
  intros. simpl. auto.
  intros. simpl. eapply vcons. auto. apply IHvector. auto.
Defined.

Definition vapp' : forall `A n m`, vector A n -> vector A m -> vector A (n+m).
  refine
    (fix vapp' (A:Set) (n m:nat) (v1 : vector A n) (v2 : vector A m) : vector A (n+m) :=
      (match v1 as v0 in (vector _ n0) return (n=n0 -> vector A (n+m)) with
         | vnil => _
         | vcons n' a v1' => _
       end) (refl_equal n)). intros.  subst. simpl. auto.
  intros. rewrite H. simpl. apply vcons. auto.
  destruct n. inversion H. inversion H. rewrite <- H1. apply vapp' ; auto. rewrite H1. auto.
Defined.

Print vapp'.

Print vapp.
Print vector_rec.

Notation "[]" := vnil.
Infix "::" := vcons (at level 55).
Notation "[ x , .. , y ]" := (vcons x .. (vcons y vnil) ..) (at level 35).

Check [1, 2].

Eval compute in vapp ([1, 2, 3]) ([4, 5, 6]).


Require Import Classical.

Theorem Ex045 (A B C : Prop): C -> ~A \/ ((B \/ C) -> A).
Proof.
  intro.
  apply NNPP.
  intro.
  apply H0.
  left.
  intro.
  apply H0.
  right.
  intro.
  exact H1.
Qed.


(*
  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 Recursive Pair
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. the definition of vec inspired by Coquelicot.
  2. all definitions are polymorphism.
 *)

Require Export SetoidListListExt.

Require Export Arith.   (* minus_plus *)
Require Export Lia.
Require Export FunctionalExtensionality.
Require Export DepPair.Vector.

Open Scope nat_scope.
Open Scope A_scope.
Open Scope vec_scope.
Open Scope mat_scope.

Generalizable Variable A B C Aeq Beq Ceq Aadd Aopp Amul Ainv.

(** ** Definitions of matrix module, it is implemented as a Vector 2 *)
Section mat.

  Context {A : Type}.

  Definition mat (r c : nat) : Type := @vec (@vec A c) r.

  Lemma mat_r0 (c : nat) (m : mat 0 c) : m = tt.
  Proof.
    destruct m. auto.
  Qed.

  Lemma mat_rS (r c : nat) (m : mat (S r) c) : {v & {m' | m = (v, m')}}.
  Proof.
    apply vec_S.
  Qed.

End mat.

(* Arguments mat {A}. *)
(* Arguments mat_r0 {A c}. *)
(* Arguments mat_rS {A r c}. *)

Example mat_ex1 : mat 2 3 := [[1;2;3];[4;5;6]].
Example mat_ex2 : mat 2 3 := [[7;8;9];[10;11;12]].
Example mat_ex3 : mat 3 2 := [[1;2];[3;4];[5;6]].

(** ** Equality of two matrices *)
Section meq.

  Context `{Equiv_Aeq : Equivalence A Aeq}.

  Definition meq {r c} (m1 m2 : mat r c) := veq (Aeq:=veq (Aeq:=Aeq)) m1 m2.

  Lemma meq_equiv : forall r c, Equivalence (meq (r:=r) (c:=c)).
  Proof.
    intros. apply veq_equiv.
  Qed.

  Global Existing Instance meq_equiv.

End meq.

(** ** Construct a matrix with a function *)
Section mmake.

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

  Definition mmake (r c : nat) (f : nat -> nat -> A) : mat r c :=
    vmake r (fun ic => (vmake c (f ic))).

  Lemma mmake_row_S : forall {r c : nat} (f : nat -> nat -> A),
      mmake (S r) c f == (vmake c (f 0), mmake r c (fun i j => f (S i) j)).
  Proof.
    unfold mmake,vmake. intros; simpl. split. easy. rewrite vmakeAux_S. easy.
  Qed.

End mmake.

(** ** Get (ir,rc) element of a matrix *)
Section mnth.
  Context `{Equiv_Aeq : Equivalence A Aeq} {A0 : A}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  Definition mnth {r c} (m : mat r c) (ir ic : nat) : A :=
    vnth (A0:=A0) ic (vnth (A0:=vconst c A0) ir m).

  (** meq and mnth should satisfy this constraint *)
  Lemma meq_iff_mnth : forall {r c : nat} (m1 m2 : mat r c),
      m1 == m2 <-> (forall ri ci, ri < r -> ci < c -> (mnth m1 ri ci == mnth m2 ri ci)%A).
  Proof.
    unfold meq, mnth. intros. split; intros.
    - rewrite H. easy.
    - apply (veq_iff_vnth (A0:=vconst c A0)). intros.
      apply (veq_iff_vnth (A0:=A0)). intros. auto.
  Qed.

  Lemma mnth_mmake : forall {r c} f i j,
      i < r -> j < c -> (mnth (mmake r c f) i j == f i j)%A.
  Proof.
    unfold mnth, mmake. intros.
    rewrite vnth_vmake_valid; auto.
    rewrite vnth_vmake_valid; auto. easy.
  Qed.

End mnth.

Arguments mnth {A} A0 {r c}.

(** Convert between matrix and list list *)
Section m2l_l2m.

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

  Fixpoint m2l {r c} : (@mat A r c) -> list (list A) :=
    match r with
    | O => fun (m : @vec (@vec A c) 0) => nil
    | S r' => fun (m : @vec (@vec A c) (S r')) =>
               cons (v2l (fst m)) (m2l (snd m))
    end.

  Fixpoint l2m (dl : list (list A)) (r c : nat) {struct r} : @mat A r c :=
    match r as r0 return (@vec (@vec A c) r0) with
    | 0 => tt
    | S n' => (l2v (A0:=A0) (hd nil dl) c, l2m (tl dl) n' c)
    end.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)) (H1 : length dl = r)
                       (H2 : width dl c), (m2l (l2m dl r c) == dl)%dlist.
  Proof.
    induction r; intros; simpl.
    - apply length_zero_iff_nil in H1. subst. easy.
    - destruct dl. easy. inv H1. inv H2. simpl.
      f_equiv; auto. apply v2l_l2v_id. auto.
  Qed.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) r c == m.
  Proof.
    unfold mat. induction r; intros; vsimp; simpl; auto.
    split; auto. apply l2v_v2l_id.
  Qed.

End m2l_l2m.

Arguments m2l {A r c}.
Arguments l2m {A} A0 dl r c.

(** ** Construct a matrix with same element *)
Section mconst.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := (meq (Aeq:=Aeq)) : A_scope.

  Definition mconst (r c : nat) (a : A) : mat r c := mmake r c (fun _ _ => a).

  Lemma mconst_r0 {c} a : mconst 0 c a = tt.
  Proof.
    auto.
  Qed.

  Lemma mconst_rS {r c} a : (mconst (S r) c a == (vconst c a, mconst r c a)).
  Proof.
    split; simpl.
    - apply vmake_const_eq_vconst.
    - rewrite vmakeAux_S. easy.
  Qed.

  Lemma mconst_c0 {r} a : mconst r 0 a == vec0 tt r.
  Proof.
    unfold mconst,mmake,vmake. rewrite vmakeAux_const_eq_vconst. easy.
  Qed.

  Lemma mat_c0 {r : nat} (m : mat r 0) : m == vec0 tt r.
  Proof.
    induction r; simpl; auto. destruct m; auto.
  Qed.

End mconst.

(** ** Construct a matrix with a vector and a matrix *)
Section mcons.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  (** Construct by row *)
  Definition mconsr {r c} (v : @vec A c) (m : @mat A r c) : @mat A (S r) c :=
    (v, m).

  (** Construct by column *)
  Fixpoint mconsc {r c} : vec r -> @mat A r c -> @mat A r (S c) :=
    match r with
    | O => fun (v : vec 0) (m : mat 0 c) => tt
    | S r' => fun (v : vec (S r')) (m : mat (S r') c) =>
               ((fst v, fst m), mconsc (snd v) (snd m))
    end.

  Infix "@" := mconsc : mat_scope.

  (** mconsc is proper morphism *)
  Lemma mconsc_aeq_mor : forall r c : nat,
      Proper (veq (Aeq:=Aeq)(n:=r) ==>
                veq (Aeq:=veq (Aeq:=Aeq)(n:=c)) ==>
                veq (Aeq:=veq (Aeq:=Aeq)(n:=S c))) mconsc.
  Proof.
    unfold Proper, respectful.
    induction r; intros; vsimp; simpl; auto. split; auto. apply IHr; auto.
  Qed.

  Global Existing Instance mconsc_aeq_mor.

  (** Equality of two forms of ConstructByRow *)
  Lemma mconsr_eq {r c} (v : vec c) (m : mat r c) : mconsr v m == (v, m).
  Proof.
    simpl. split; easy.
  Qed.

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

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

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

  (** Note that, mconsc_mc0 is in another section below, it need v2cm *)

  (** Get a row vector of the matrix build by mconsc with v and m, equal to
      build the vector with two parts which are the n-th element of v and m *)
  Lemma vnth_mconsc : forall r c {A0:A} (v: vec (A:=A) r) (m: mat (A:=A) r c) i,
      (vnth (A0:=vec0 A0 (S c)) i (v @ m) ==
         (vnth (A0:=A0) i v, vnth (A0:=vec0 A0 c) i m))%vec.
  Proof.
    unfold mat; induction r; intros; vsimp; simpl. easy.
    destruct i. easy.
    specialize (IHr c A0 v v1 i).
    (** Tips: We need to handle type conversion manually *)
    (* Set Printing Implicit. *)
    assert (((vnth (A0:=(A0, vec0 A0 c)) i (v @ v1)):(vec (S c)))
            == (vnth (A0:=A0) i v, vnth (A0:=vec0 A0 c) i v1))%vec by auto.
    destruct (vnth (A0:=(A0, vec0 A0 c)) i (v @ v1)). easy.
  Qed.

End mcons.

(** ** Get head row, tail rows, head column and tail columns of a matrix *)
Section mhd_mtl.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.
  Infix "@" := mconsc : mat_scope.

  (** Get head row of a matrix *)
  Definition mhdr {r c} (m : @mat A (S r) c) : vec c := fst m.

  (** Get tail rows of a matrix *)
  Definition mtlr {r c} (m : @mat A (S r) c) : @mat A r c := snd m.

  (** Get head column of a matrix *)
  Fixpoint mhdc {r c} : @mat A r (S c) -> vec r :=
    match r with
    | O => fun (m : mat 0 (S c)) => tt
    | S r' => fun (m : mat (S r') (S c)) =>
               (fst (fst m), mhdc (snd m))
    end.

  (** Get tail columns of a matrix *)
  Fixpoint mtlc {r c} : @mat A r (S c) -> @mat A r c :=
    match r with
    | O => fun (m : mat 0 (S c)) => tt
    | S r' => fun (m : mat (S r') (S c)) =>
               (snd (fst m), mtlc (snd m))
    end.

  (** mhdc is proper morphism *)
  Lemma mhdc_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq)(r:=r)(c:=S c) ==> veq (Aeq:=Aeq)(n:=r)) mhdc.
  Proof.
    unfold Proper, respectful, mat.
    induction r; intros; simpl; auto. split.
    - f_equiv. rewrite H. easy.
    - apply IHr. rewrite H. easy.
  Qed.

  Global Existing Instance mhdc_aeq_mor.

  (** mtlc is proper morphism *)
  Lemma mtlc_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq)(r:=r)(c:=S c) ==> meq (Aeq:=Aeq)(r:=r)(c:=c)) mtlc.
  Proof.
    unfold Proper, respectful, mat.
    induction r; intros; simpl; auto. split.
    - f_equiv. rewrite H. easy.
    - apply IHr. rewrite H. easy.
  Qed.

  Global Existing Instance mtlc_aeq_mor.

  (** consr (hdr m) (tlr m) = m *)
  Lemma mhdr_mtlr {r c} (m : @mat A (S r) c) : mconsr (mhdr m) (mtlr m) == m.
  Proof.
    destruct m. simpl. easy.
  Qed.

  (** consc (hdc m) (tlc m) = m *)
  Lemma mhdc_mtlc {r c} (m : @mat A r (S c)) : (mhdc m) @ (mtlc m) == m.
  Proof.
    induction r; destruct m; simpl; auto. destruct v; simpl. split; auto. easy.
  Qed.

  (** hdc (const) = const *)
  Lemma mhdc_const_const_eq_const : forall {r c} a,
      (mhdc (vconst r (vconst (S c) a)) == vconst r a)%vec.
  Proof.
    induction r; intros; simpl; auto. split. easy. apply IHr.
  Qed.

  (** Head row of a matrix which constructed by rows *)
  Lemma mhdr_mconsr : forall {r c} (v : @vec A c) (m : @mat A r c),
      (mhdr (mconsr v m) == v)%vec.
  Proof.
    intros. simpl. easy.
  Qed.

  (** Tail rows of a matrix which constructed by rows *)
  Lemma mtlr_mconsr : forall {r c} (v : @vec A c) (m : @mat A r c),
      mtlr (mconsr v m) == m.
  Proof.
    intros. simpl. easy.
  Qed.

  (** Head column of a matrix which constructed by columns *)
  Lemma mhdc_mconsc : forall {r c} (v : @vec A r) (m : @mat A r c),
      (mhdc (v @ m) == v)%vec.
  Proof.
    induction r; intros; destruct m,v; simpl; auto. easy.
  Qed.

  (** Tail columns of a matrix which constructed by columns *)
  Lemma mtlc_mconsc : forall {r c} (v : @vec A r) (m : @mat A r c),
      mtlc (v @ m) == m.
  Proof.
    induction r; intros; destruct m,v; simpl; auto. easy.
  Qed.

  (** The n-th of a vector constructed by mhdc, equal to mnth element. *)
  Lemma vnth_mhdc : forall r c {A0 : A} (m : mat (A:=A) r (S c)) i,
      (vnth (A0:=A0) i (mhdc m) == mnth A0 m i 0)%A.
  Proof.
    unfold mat; induction r; intros; vsimp; simpl. easy.
    destruct i. easy.
    unfold mnth in *. simpl. rewrite IHr. simpl. easy.
  Qed.

End mhd_mtl.

(** Convert from a vector to a row matrix or column matrix, and convert the
 matrix back to a vector *)
Section v2m_m2v.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  (* (** Type Conversion *) *)
  (* Definition vv2m {r c} (vv : @vec (@vec A c) r) : @mat A r c := vv. *)
  (* Definition m2vv {r c} (m : @mat A r c) : @vec (@vec A c) r := m. *)

  (* Lemma vv2m_eq : forall {r c} (vv : @vec (@vec A c) r), vv = vv2m vv. *)
  (* Proof. intros. easy. Qed. *)
  (* Lemma m2vv_eq : forall {r c} (m : @mat A r c), m = m2vv m. *)
  (* Proof. intros. easy. Qed. *)
  (* Lemma m2vv_vv2m_id : forall {r c} (vv : @vec (@vec A c) r),  *)
  (*     vv == m2vv (vv2m vv). *)
  (* Proof. intros. easy. Qed. *)
  (* Lemma vv2m_m2vv_id : forall {r c} (m : @mat A r c), m = vv2m (m2vv m). *)
  (* Proof. intros. auto. Qed. *)

  (** Convert a vector to a row matrix *)
  Definition v2rm {n} (v : @vec A n) : @mat A 1 n := [v].

  (** Convert a row matrix to a vector *)
  Definition rm2v {n} (m : @mat A 1 n) : @vec A n := fst m.

  (** Convert a vector to a column matrix *)
  Fixpoint v2cm {n} : @vec A n -> @mat A n 1 :=
    match n with
    | O => fun (v : @vec A 0) => tt
    | S r' => fun (v : @vec A (S r')) => ([fst v], v2cm (snd v))
    end.

  (** Convert a column matrix to a vector *)
  Fixpoint cm2v {n} : @mat A n 1 -> @vec A n :=
    match n with
    | O => fun (m : @mat A 0 1) => let v : @vec A 0 := tt in v
    | S r' => fun (m : @mat A (S r') 1) =>
               let v : @vec A (S r') :=
                 (fst (fst m), cm2v (snd m)) in v
    end.

  Lemma v2rm_rm2v_id : forall {n} (m : @mat A 1 n), v2rm (rm2v m) == m.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; auto. easy.
  Qed.

  Lemma rm2v_v2rm_id : forall {n} (v : @vec A n), (rm2v (v2rm v) == v)%vec.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; auto. easy.
  Qed.

  Lemma v2cm_cm2v_id : forall {n} (m : @mat A n 1), v2cm (cm2v m) == m.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; auto. easy.
  Qed.

  Lemma cm2v_v2cm_id : forall {n} (v : @vec A n), (cm2v (v2cm v) == v)%vec.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; auto. easy.
  Qed.

  Lemma rm2v_eq_mhdr : forall {n} (m : @mat A 1 n), (rm2v m == mhdr m)%vec.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; auto. easy.
  Qed.

  Lemma cm2v_eq_mhdc : forall {n} (m : @mat A n 1), (cm2v m == mhdc m)%vec.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; auto. easy.
  Qed.

  Lemma mat_r1_ex_v2rm : forall {n} (m : @mat A 1 n), {v | m == v2rm v}.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; eauto. exists (a,v). easy.
  Qed.

  Lemma mat_c1_ex_v2cm : forall {n} (m : @mat A n 1), {v | m == v2cm v}.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; eauto.
    destruct (IHn v0). exists (a,x). easy.
  Qed.

  (** Construct a matrix by columns with the matrix which column is 0 *)
  Lemma mconsc_mc0 : forall {n} (v : @vec A n) (m : @mat A n 0), mconsc v m == v2cm v.
  Proof.
    unfold mat; induction n; intros; vsimp; simpl; auto. easy.
  Qed.

End v2m_m2v.

(* Arguments v2rm {A n}. *)
(* Arguments rm2v {A n}. *)
(* Arguments v2cm {A n}. *)
(* Arguments cm2v {A n}. *)
(* Arguments v2rm_rm2v_id {A n}. *)
(* Arguments rm2v_v2rm_id {A n}. *)
(* Arguments v2cm_cm2v_id {A n}. *)
(* Arguments cm2v_v2cm_id {A n}. *)
(* Arguments rm2v_eq_mhdr {A n}. *)
(* Arguments cm2v_eq_mhdc {A n}. *)
(* Arguments mat_r1_ex_v2rm {A n}. *)
(* Arguments mat_c1_ex_v2cm {A n}. *)
(* Arguments mconsc_mc0 {A n}. *)

(* Transpose a matrix *)
Section mtrans.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.
  Infix "@" := mconsc : mat_scope.

  Fixpoint mtrans {r c} : @mat A r c -> mat c r :=
    match c with
    | O => fun (m : @mat A r 0) => tt
    | S c' => fun (m : @mat A r (S c')) => (mhdc m, mtrans (mtlc m))
    end.

  Notation "m \T" := (mtrans m) : mat_scope.

  (** mtrans is a proper morphism *)
  Lemma mtrans_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq)(r:=r)(c:=c) ==> meq (Aeq:=Aeq)(r:=c)(c:=r)) mtrans.
  Proof.
    unfold Proper, respectful.
    intros r c. revert r. induction c; intros; simpl; auto. split; auto.
    - rewrite H. easy.
    - apply IHc. rewrite H. easy.
  Qed.

  Global Existing Instance mtrans_aeq_mor.

  (** Head row of a transposed matrix equal to Head column *)
  Lemma mhdr_mtrans_eq_mhdc : forall {r c} (m : @mat A r (S c)),
    (mhdr (m\T) == mhdc m)%vec.
  Proof.
    induction r; intros; try easy.
  Qed.

  (** Tail rows of a transposed matrix equal to transposed tail columns *)
  Lemma mtlr_mtrans_eq_mtrans_mtlc : forall {r c} (m : @mat A r (S c)),
    mtlr (m\T) == (mtlc m)\T.
  Proof.
    induction r; intros; try easy.
  Qed.

  (** Head column of a transposed matrix equal to Head row *)
  Lemma mhdc_mtrans_eq_mhdr : forall {r c} (m : @mat A (S r) c),
      (mhdc (m\T) == mhdr m)%vec.
  Proof.
    unfold mhdr. destruct m. simpl. induction c; destruct v; simpl; auto.
    split; try easy.
  Qed.

  (** Tail columns of a transposed matrix equal to transposed tail rows *)
  Lemma mtlc_mtrans_eq_mtrans_mtlr : forall {r c} (m : @mat A (S r) c),
    mtlc (m\T) == (mtlr m)\T.
  Proof.
    unfold mtlr. induction c; destruct m; simpl; auto. split; try easy.
    rewrite IHc. simpl. easy.
  Qed.

  (** Transpose twice return back *)
  Lemma mtrans_trans : forall {r c} (m : @mat A r c), m\T\T == m.
  Proof.
    induction r; intros; destruct m; simpl; auto.
    rewrite mhdc_mtrans_eq_mhdr. rewrite mtlc_mtrans_eq_mtrans_mtlr.
    rewrite IHr. simpl. easy.
  Qed.

  (** Transpose a matrix composed by head column and tail columns, equal to
      seperately transpose two part of them append by row *)
  Lemma mtrans_hdc_tlc : forall {r c} (m : @mat A r (S c)),
      ((mhdc m) @ (mtlc m))\T == (mhdr (m\T), mtlr (m\T)).
  Proof.
    destruct r; intros; vsimp; simpl. easy. split.
    - split; try easy. rewrite mhdc_mtlc. easy.
    - apply mtrans_aeq_mor. constructor; try easy.
      rewrite mhdc_mtlc. easy.
  Qed.

  (** Transpose a matrix composed by head row and tail rows, equal to
      seperately transpose two part of them append by column *)
  Lemma mtrans_hdr_tlr : forall {r c} (m : @mat A (S r) c),
      ((mhdr m, mtlr m) : @mat A (S r) c)\T == (mhdc (m\T)) @ (mtlc (m\T)).
  Proof.
    unfold mat. destruct r; intros; vsimp; simpl.
    - induction c; intros; simpl; auto. split; auto. split; easy.
    - induction c; intros; simpl; auto. split; auto. split; easy.
  Qed.

  (** Transpose a zero rows matrix *)
  Lemma mtrans_r0 {n} (m : @mat A 0 n) : m\T == vec0 tt n.
  Proof.
    induction n; simpl; auto; f_equal; auto.
  Qed.

  (** Transpose a zero columns matrix *)
  Lemma mtrans_c0 {n} (m : @mat A n 0) : m\T == tt.
  Proof.
    induction n; simpl; auto.
  Qed.

  (** Transpose a one row matrix *)
  Lemma mtrans_r1 : forall {n} (m : @mat A 1 n), m\T == v2cm (rm2v m).
  Proof.
    induction n; intros; destruct m; simpl; auto. split; try easy.
    rewrite IHn. simpl. easy.
  Qed.

  (** Transpose a one column matrix *)
  Lemma mtrans_c1 : forall {n} (m : @mat A n 1), m\T == v2rm (cm2v m).
  Proof.
    destruct n; intros; destruct m; simpl; auto.
    destruct v; destruct v. simpl.
    repeat split; try easy. rewrite cm2v_eq_mhdc. easy.
  Qed.

  (** Transpose a one column matrix created by a vector *)
  Lemma mtrans_v2cm : forall {n} (v : @vec A n), (v2cm v)\T == v2rm v.
  Proof.
    destruct n; intros; destruct v; simpl; auto.
    repeat split; try easy.
    rewrite <- cm2v_eq_mhdc. rewrite cm2v_v2cm_id. easy.
  Qed.

  (** Transpose a one row matrix created by a vector *)
  Lemma mtrans_v2rm : forall {n} (v : @vec A n), (v2rm v)\T == v2cm v.
  Proof.
    destruct n; intros; destruct v; simpl; auto.
    rewrite mtrans_r1. simpl. easy.
  Qed.

  (** Transpose a matrix which build by row *)
  Lemma mtrans_consr : forall {r c} (v : @vec A c) (m : @mat A r c),
      ((v, m) : mat (S r) c)\T == v @ (m\T).
  Proof.
    induction c; intros; destruct v; simpl; auto. easy.
  Qed.

  (** Transpose a matrix which build column *)
  Lemma mtrans_consc : forall {r c} (v : @vec A r) (m : @mat A r c),
      (mconsc v m)\T == (v, m\T).
  Proof.
    destruct r; intros; destruct m,v; simpl; auto. easy.
    rewrite mhdc_mconsc. rewrite mtlc_mconsc. easy.
  Qed.

End mtrans.

(** ** Mapping matrix *)
Section mmap.
  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  Fixpoint mmap {r c} (f : A -> A) : mat r c -> mat r c :=
    match r with
    | O => fun (m : mat 0 _) => tt
    | S r' => fun (m : mat (S r') c) => (vmap f (fst m), mmap f (snd m))
    end.

  Fixpoint mmap2 {r c} (f : A -> A -> A) : mat r c -> mat r c -> mat r c :=
    match r with
       | O => fun (m1 m2 : mat 0 _) => tt
       | S r' => fun (m1 m2 : mat (S r') c) =>
                   (vmap2 f (fst m1) (fst m2), mmap2 f (snd m1) (snd m2))
       end.

  Lemma mmap2_comm : forall {r c} (m1 m2 : mat r c) (f : A -> A -> A)
                       (Comm : forall a b, (f a b == f b a)%A),
    mmap2 f m1 m2 == mmap2 f m2 m1.
  Proof.
    unfold mat. induction r,c; intros; vsimp; simpl; auto. split; try easy.
    - split; try easy. apply vmap2_comm. constructor. auto.
    - apply IHr; auto.
  Qed.

  Lemma mmap2_assoc : forall {r c} (m1 m2 m3 : mat r c) (f : A -> A -> A)
                        (Assoc : forall a b c, (f (f a b) c == f a (f b c))%A),
      mmap2 f (mmap2 f m1 m2) m3 == mmap2 f m1 (mmap2 f m2 m3).
  Proof.
    unfold mat. induction r,c; intros; vsimp; simpl; auto. split; try easy.
    - split; try easy. apply vmap2_assoc. constructor. auto.
    - apply IHr; auto.
  Qed.

End mmap.

(** ** Zero matrix *)
Section mat0.

  Context `{Equiv_Aeq : Equivalence A Aeq} (A0 : A).
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.
  Notation "m \T" := (mtrans m) : mat_scope.

  Definition mat0 r c : @mat A r c := mmake r c (fun i j => A0).

  Lemma mat0_eq_vec0 {r c} : mat0 r c == vec0 (vec0 A0 c) r.
  Proof.
    unfold mat0. unfold mmake.
    rewrite vmake_const_eq_vconst. unfold vec0. f_equiv.
    apply vmake_const_eq_vconst.
  Qed.

  Lemma mat0_S : forall {r c}, mat0 (S r) c == ((vec0 A0 c, mat0 r c) : mat (S r) c).
  Proof.
    intros. rewrite mat0_eq_vec0. simpl. split; try easy.
    rewrite mat0_eq_vec0. easy.
  Qed.

  (** mhdr (mat0) = vec0 *)
  Lemma mhdr_mat0 : forall {r c}, (mhdr (mat0 (S r) c) == vec0 A0 c)%vec.
  Proof.
    intros. simpl. apply vmake_const_eq_vconst.
  Qed.

  (** mhdc (mat0) = vec0 *)
  Lemma mhdc_mat0 : forall {r c}, (mhdc (mat0 r (S c)) == vec0 A0 r)%vec.
  Proof.
    induction r; intros; simpl; auto. split; try easy. rewrite <- IHr.
    f_equiv. cbn. apply vmakeAux_S.
  Qed.

  (** mtlr (mat0) = mat0 *)
  Lemma mtlr_mat0 : forall {r c}, mtlr (mat0 (S r) c) == mat0 r c.
  Proof.
    intros. simpl. apply vmakeAux_S.
  Qed.

  (** mtlc (mat0) = mat0 *)
  Lemma mtlc_mat0 : forall {r c}, mtlc (mat0 r (S c)) == mat0 r c.
  Proof.
    induction r; intros; simpl; auto. split.
    - apply vmakeAux_S.
    - cbn. unfold mat0,mmake,vmake in *.
      rewrite (vmakeAux_S r 0 (fun _ => vmakeAux c 0 (fun _ => A0))).
      rewrite <- IHr. f_equiv.
      simpl. apply vmakeAux_S.
  Qed.

  (** v2cm (vec0) = mat0 *)
  Lemma v2cm_vec0_eq_mat0 : forall {n}, v2cm (vec0 A0 n) == mat0 n 1.
  Proof.
    unfold mat. induction n; intros; vsimp; simpl; auto. split; try easy.
    rewrite IHn. cbn. unfold mat0, mmake, vmake.
    apply symmetry. simpl. apply vmakeAux_S.
  Qed.

  (** v2rm (vec0) = mat0 *)
  Lemma v2rm_vec0_eq_mat0 : forall {n}, v2rm (vec0 A0 n) == mat0 1 n.
  Proof.
    intros. unfold v2rm. unfold mat0,mmake. simpl.
    rewrite vmake_const_eq_vconst. easy.
  Qed.

  (** mat0\T = mat0 *)
  Lemma mtrans_mat0 : forall {r c}, (mat0 r c)\T == mat0 c r.
  Proof.
    intros r c. revert r. induction c; intros; simpl; auto. split.
    - rewrite mhdc_mat0. rewrite vmake_const_eq_vconst. easy.
    - rewrite mtlc_mat0. rewrite IHc.
      unfold mat0,mmake,vmake. rewrite vmakeAux_S. easy.
  Qed.

End mat0.

(** ** Unit matrix *)
Section mat1.

  Context `{Equiv_Aeq : Equivalence A Aeq} (A0 A1 : A).
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.
  Notation "m \T" := (mtrans m) : mat_scope.

  Fixpoint mat1 n : mat n n :=
    match n with
    | O => tt
    | S n' =>
        let v1 := vconst n' A0 in
        mconsr ((A1, v1) : vec (S n')) (mconsc v1 (mat1 n'))
    end.

  (** mat1\T = mat1 *)
  Lemma mtrans_mat1 : forall {n}, (mat1 n)\T == mat1 n.
  Proof.
    induction n; simpl; auto. split.
    - split. easy. rewrite mhdc_mconsc. easy.
    - rewrite mtlc_mconsc. rewrite mtrans_consr.
      rewrite IHn. easy.
  Qed.

  (** Another definition of mat1, function style instead of structure style,
      similiar to mat0 *)
  Definition mat1f n : mat n n :=
    mmake n n (fun ri ci => if ri =? ci then A1 else A0) .

  Lemma mat1_eq_mat1f : forall n, mat1 n == mat1f n.
  Proof.
    induction n; simpl; auto. split; auto.
    - split; auto. easy. rewrite vmakeAux_S. rewrite vmakeAux_const_eq_vconst. easy.
    - apply (veq_iff_vnth (A0:=vec0 A0 (S n))). intros.
      rewrite IHn. rewrite vmakeAux_S.
      rewrite vnth_mconsc.
      rewrite vnth_vmakeAux_valid by lia. simpl. split; auto.
      + rewrite vnth_const; auto. easy.
      + unfold mat1f, mmake.
        rewrite vnth_vmake_valid; auto. unfold vmake. rewrite vmakeAux_S.
        f_equiv. hnf. intros; subst.
        rewrite Nat.add_0_r. easy.
  Qed.
End mat1.

(** ** Get row or column of a matrix as a vector *)
Section mrow_mcol.
  Context `{Equiv_Aeq : Equivalence A Aeq} {A0 : A}.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  (* Note that, mhdr and mtlr is a bit different, they only working on "mat (S r) c"
     type. Here, mrow and mcol are designed for "mat r c" type. *)

  Definition mrow {r c} ir (m : @mat A r c) : vec c :=
    vnth (A0:=vec0 A0 c) ir m.

  Fixpoint mcol {r c} (ic : nat) : @mat A r c -> vec r :=
    match r with
    | O => fun (m : mat 0 _) => tt
    | S r' => fun (m : mat (S r') c) =>
                (vnth (A0:=A0) ic (fst m), mcol ic (snd m))
    end.

  Lemma mrow_0 {r c} (m : @mat A (S r) c) : (mrow 0 m == mhdr m)%vec.
  Proof.
    destruct m. simpl. easy.
  Qed.

  Lemma mrow_S {r c} i (m : @mat A (S r) c) : (mrow (S i) m == mrow i (mtlr m))%vec.
  Proof.
    destruct m. simpl. easy.
  Qed.

  Lemma mcol_0 {r c} (m : @mat A r (S c)) : (mcol 0 m == mhdc m)%vec.
  Proof.
    induction r; destruct m; simpl; auto. easy.
  Qed.

  Lemma mcol_S {r c} i (m : @mat A r (S c)) : (mcol (S i) m == mcol i (mtlc m))%vec.
  Proof.
    induction r; destruct m; simpl; auto. easy.
  Qed.

End mrow_mcol.

(** ** Append two matrix with same column number or row number *)
Section mapp.
  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  (** Append two matrix with same column number by row *)
  Definition mappr {r1 r2 c} (m1 : @mat A r1 c) (m2 : @mat A r2 c)
    : @mat A (r1 + r2) c := vapp m1 m2.

  (** Append two matrix with same row number by column *)
  Fixpoint mappc {r c1 c2} : @mat A r c1 -> @mat A r c2 -> @mat A r (c1 + c2) :=
    match r with
    | O => fun _ _ => tt
    | S r' => fun (m1 : mat (S r') c1) (m2 : mat (S r') c2) =>
               (vapp (fst m1) (fst m2), mappc (snd m1) (snd m2))
    end.

End mapp.

(** ** Split a matrix to two parts by row or column *)
Section msplit.
  Context `{Equiv_Aeq : Equivalence A Aeq} {A0:A}.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.

  (** Split a matrix to two parts by row *)
  Definition msplitr r1 r2 {c} (m: @mat A (r1+r2) c)
    : (@mat A r1 c) * (@mat A (r1+r2-r1) c) :=
    (vfirstn (A0:=vconst c A0) r1 m, vskipn r1 m).

  (** I can't write this lemma, because of type issue. Fix it below *)
  (* Lemma mappr_msplitr r1 r2 {c} def (m : @mat A (r1+r2) c) : *)
  (*   mappr (msplitr r1 r2 def m) = m. *)

  (** Convert Type as well, but too complicated!! *)
  Definition cvtMatShape r1 r2 {c} (m1 : @mat A (r1 + r2 - r1) c)
    : @mat A r2 c.
  Proof.
    rewrite Nat.add_comm in m1.
    rewrite Nat.add_sub in m1.
    exact m1.
  Defined.

  Definition msplitr' r1 r2 {c} (m: @mat A (r1+r2) c)
    : (@mat A r1 c) * (@mat A r2 c) :=
    (vfirstn (A0:=vconst c A0) r1 m, cvtMatShape r1 r2 (vskipn r1 m)).

  Lemma mappr_msplitr' r1 r2 {c} (m : @mat A (r1+r2) c) :
    let '(m1,m2) := msplitr' r1 r2 m in
    let m' : @mat A (r1+r2) c := mappr m1 m2 in
    m' == m.
  Proof.
    unfold mat; induction r1,r2; vsimp; simpl in *; auto.
    (* simpl. induction r1. *)
    (* - induction r2; destruct m; simpl. *)
    (*   + unfold cvtMatShape. simpl (0+0-0). unfold eq_rect. Abort. *)
    Abort.

  (** Split a matrix to two parts by column *)
  Fixpoint msplitc {r} c1 c2 :
    (@mat A r (c1+c2)) -> (@mat A r c1) * (@mat A r (c1+c2-c1)) :=
    match r with
    | O => fun (_ : mat 0 (c1+c2)) => (tt, tt)
    | S r' => fun (m : mat (S r') (c1+c2)) =>
                let defV : vec (c1+c2) := vconst (c1+c2) A0 in
                let (m1, m2) := msplitc c1 c2 (vtl m) in
                ((vfirstn (A0:=A0) c1 (vhd defV m), m1), (vskipn c1 (vhd defV m), m2))
    end.

End msplit.

(** ** matrix algebra *)
(** matrix addition, opposition, subtraction, scalar multiplication, multiplication *)
Section mat_alg.
  (* Variable A : Type. *)
  (* Variable A0 : A. *)
  (* Variable fadd fmul : A -> A -> A. *)
  (* Variable fadd_comm : forall a b, fadd a b = fadd b a. *)
  (* Variable fmul_comm : forall a b, fmul a b = fmul b a. *)
  (* Variable fadd_assoc : forall a b c, fadd (fadd a b) c = fadd a (fadd b c). *)
  (* Variable fmul_assoc : forall a b c, fmul (fmul a b) c = fmul a (fmul b c). *)
  (* Variable fmul_fadd_dist_l : forall a b c,  *)
  (*     fmul a (fadd b c) = fadd (fmul a b) (fmul a c). *)
  (* Variable fmul_0_l : forall a, fmul A0 a = A0. *)
  (* Variable fadd_0_l : forall a, fadd A0 a = a. *)
  (* Variable fadd_0_r : forall a, fadd a A0 = a. *)

  Context `{AG : AGroup}.

  Infix "+" := Aadd : A_scope.
  Infix "+" := (vadd (Aadd:=Aadd)) : vec_scope.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.
  Infix "@" := mconsc : mat_scope.
  Notation "m \T" := (mtrans m) : mat_scope.

  (** *** Matrix Addition *)

  Definition madd {r c} (m1 m2 : @mat A r c) : @mat A r c :=
    vmap2 (vadd (Aadd:=Aadd)) m1 m2.
  Infix "+" := madd : mat_scope.
  Open Scope mat_scope.

  (** madd is proper morphism *)
  Lemma madd_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq))
        (madd (r:=r)(c:=c)).
  Proof.
    intros. apply (vadd_aeq_mor (AG:=vec_AG c)).
  Qed.

  Global Existing Instance madd_aeq_mor.

  (** (v1 @ m1) + (v2 @ m2) = (v1 + v2) @ (m1 + m2) *)
  Lemma madd_mconsc : forall {r c} (v1 v2 : @vec A r) (m1 m2 : mat r c),
      (v1 @ m1) + (v2 @ m2) == (v1 + v2) @ (m1 + m2).
  Proof.
    unfold mat; induction r; intros; vsimp; simpl; auto. split; try easy.
    (* Tips: type issue *)
    Fail rewrite IHr.
    assert (v1 @ v4 + v2 @ v0 == (v1 + v2) @ (v4 + v0)); auto.
  Qed.

  (** m1 + m2 = m2 + m1 *)
  Lemma madd_comm : forall {r c} (m1 m2 : @mat A r c), m1 + m2 == m2 + m1.
  Proof.
    intros. apply (vadd_comm (AG:=vec_AG c)).
  Qed.

  (** (m1 + m2) + m3 = m1 + (m2 + m3) *)
  Lemma madd_assoc : forall {r c} (m1 m2 m3 : @mat A r c), (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof.
    intros. apply (vadd_assoc (AG:=vec_AG c)).
  Qed.

  (** mat0 + m = m *)
  Lemma madd_0_l : forall {r c} (m : @mat A r c), (mat0 A0 r c) + m == m.
  Proof.
    (* Tips: reuse group and vector theory, good example *)
    intros. rewrite mat0_eq_vec0. apply (vadd_0_l (AG:=vec_AG c)).
  Qed.

  (** m + mat0 = m *)
  Lemma madd_0_r : forall {r c} (m : @mat A r c), m + (mat0 A0 r c) == m.
  Proof.
    intros. rewrite mat0_eq_vec0. apply (vadd_0_r (AG:=vec_AG c)).
  Qed.

  (** (m1 + m2)\T = m1\T + m2\T *)
  Lemma mtrans_madd : forall {r c} (m1 m2 : @mat A r c), (m1 + m2)\T == m1\T + m2\T.
  Proof.
    induction r; intros.
    - destruct m1,m2. simpl. rewrite ?mtrans_r0.
      induction c; simpl; auto.
    - destruct m1 as [v1 m1], m2 as [v2 m2].
      rewrite !mtrans_consr. rewrite madd_mconsc. rewrite <- IHr.
      unfold madd. simpl. rewrite mtrans_consr. easy.
  Qed.

  (** *** Matrix Opposition *)

  Definition mopp {r c} (m : mat r c) : mat r c := vmap (vopp (Aopp:=Aopp)) m.
  Notation "- m" := (mopp m) : mat_scope.

  (** mopp is proper morphism *)
  Lemma mopp_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq)) (mopp (r:=r)(c:=c)).
  Proof.
    intros. apply (vopp_aeq_mor (AG:=vec_AG c)).
  Qed.

  Global Existing Instance mopp_aeq_mor.

  (** - (- m) = m *)
  Lemma mopp_mopp : forall {r c} (m : mat r c), - (- m) == m.
  Proof.
    induction r; intros; destruct m; simpl; auto. split; auto.
    - apply vopp_vopp.
    - apply IHr.
  Qed.

  (** *** Matrix Subtraction *)

  Definition msub {r c} (m1 m2 : @mat A r c) : @mat A r c :=
    m1 + (-m2).
  (* vmap2 (vsub fsub) m1 m2. *)
  Infix "-" := msub : mat_scope.

  (** msub is proper morphism *)
  Lemma msub_aeq_mor : forall r c,
      Proper (meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq) ==> meq (Aeq:=Aeq)) (msub (r:=r)(c:=c)).
  Proof.
    intros. apply (vsub_aeq_mor (AG:=vec_AG c)).
  Qed.

  Global Existing Instance msub_aeq_mor.

  (** m1 - m2 = - (m2 - m1) *)
  Lemma msub_comm : forall {r c} (m1 m2 : @mat A r c), m1 - m2 == - (m2 - m1).
  Proof.
    intros. apply (vsub_comm (AG:=vec_AG c)).
  Qed.

  (** (m1 - m2) - m3 = m1 - (m2 + m3) *)
  Lemma msub_assoc : forall {r c} (m1 m2 m3 : @mat A r c), (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    intros. apply (vsub_assoc (AG:=vec_AG c)).
  Qed.

  (** mat0 - m = - m *)
  Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 A0 r c) - m == - m.
  Proof.
    intros. rewrite mat0_eq_vec0. apply (vsub_0_l (AG:=vec_AG c)).
  Qed.

  (** m - mat0 = - m *)
  Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 A0 r c) == m.
  Proof.
    intros. rewrite mat0_eq_vec0. apply (vsub_0_r (AG:=vec_AG c)).
  Qed.

  (** m - m = mat0 *)
  Lemma msub_self : forall {r c} (m : mat r c), m - m == mat0 A0 r c.
  Proof.
    intros. rewrite mat0_eq_vec0. apply (vsub_self (AG:=vec_AG c)).
  Qed.

  (** *** Below, we need Ring structure *)
  Context `{R : Ring A Aadd A0 Aopp Amul A1 Aeq}.
  Add Ring ring_inst : make_ring_theory.

  Infix "*" := Amul : A_scope.
  Infix "c*" := (vcmul (Amul:=Amul)) : vec_scope.
  Infix "*c" := (vmulc (Amul:=Amul)) : vec_scope.
  Notation vdot := (vdot (Aadd:=Aadd)(A0:=A0)(Amul:=Amul)).

  (** *** Scalar multiplication *)

  (** Left scalar multiplication *)
  Definition mcmul {r c : nat} a m : mat r c := mmap (fun x => a * x) m.
  Infix "c*" := mcmul : mat_scope.

  (** Right scalar multiplication *)
  Definition mmulc {r c : nat} m a : mat r c := mmap (fun x => x * a) m.
  Infix "*c" := mmulc : mat_scope.

  (** m *c a = a c* m *)
  Lemma mmulc_eq_mcmul : forall {r c} (a : A) (m : mat r c), m *c a == a c* m.
  Proof.
    induction r; intros; simpl; auto. split; auto.
    - apply (vmulc_eq_vcmul a).
    - apply IHr.
  Qed.

  (** a c* (b c* m) = (a * b) c* m *)
  Lemma mcmul_assoc : forall {r c} (a b : A) (m : mat r c),
      a c* (b c* m) == (a * b) c* m.
  Proof.
    induction r; intros; simpl; auto. split; [|apply IHr].
    apply (vcmul_assoc a b).
  Qed.

  (** a c* (b c* m) = b c* (a c* m) *)
  Lemma mcmul_perm : forall {r c} (a b : A) (m : mat r c),
      a c* (b c* m) == b c* (a c* m).
  Proof.
    induction r; intros; simpl; auto. split; [|apply IHr].
    apply (vcmul_perm a b).
  Qed.

  (** a c* (m1 + m2) = (a c* m1) + (a c* m2) *)
  Lemma mcmul_add_distr_l : forall {r c} (a : A) (m1 m2 : mat r c),
      a c* (m1 + m2) == (a c* m1) + (a c* m2).
  Proof.
    induction r; intros; simpl; auto. split; [|apply IHr].
    apply (vcmul_add_distr_l a).
  Qed.

  (** (a + b) c* m = (a c* m) + (b c* m) *)
  Lemma mcmul_add_distr_r : forall {r c} (a b : A) (m : mat r c),
      (a + b)%A c* m == (a c* m) + (b c* m).
  Proof.
    induction r; intros; simpl; auto. split; [|apply IHr].
    apply (vcmul_add_distr_r a).
  Qed.

  (** 0 c* m = mat0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m == mat0 A0 r c.
  Proof.
    induction r; intros; simpl; auto. destruct m. simpl. split.
    - pose proof (vcmul_0_l (n:=c)).
      unfold vcmul in H. rewrite H. rewrite vmake_const_eq_vconst. easy.
    - unfold mcmul in IHr. rewrite IHr.
      rewrite vmakeAux_S. easy.
  Qed.

  (** A1 c* m = m *)
  Lemma mcmul_1_l : forall {r c} (m : mat r c), A1 c* m == m.
  Proof.
    induction r; intros; simpl; auto. destruct m. split; [|apply IHr].
    simpl. apply (vcmul_1_l v).
  Qed.

  (** *** Inner product a vector and a matrix. v(c) *' m(r,c) = v(r) *)

  Fixpoint vdotm {r c} (v : @vec A c) : @mat A r c -> @vec A r :=
    match r with
    | O => fun (m : mat 0 _) => tt
    | S r' => fun (m : mat (S r') c) =>
               (vdot v (fst m), vdotm v (snd m))
    end.

  (** vdotm is proper morphism *)
  Lemma vdotm_aeq_mor : forall r c : nat,
      Proper (veq (Aeq:=Aeq)(n:=c) ==>
                meq (Aeq:=Aeq)(r:=r)(c:=c) ==>
                veq (Aeq:=Aeq)(n:=r)) vdotm.
  Proof.
    unfold Proper, respectful.
    induction r; intros; vsimp; simpl; auto. split; auto.
    - rewrite H,H0. easy.
    - apply IHr; auto. rewrite H0. easy.
  Qed.

  Global Existing Instance vdotm_aeq_mor.

  Lemma vdotm_c0 : forall {n} (v : vec 0) (m : mat n 0), (vdotm v m == (vec0 A0 n))%vec.
  Proof.
    induction n; intros; destruct v; simpl; auto. split; auto.
    destruct m. simpl. cbn. easy.
  Qed.

  Lemma vdotm_r0 : forall {n} (v : vec n) (m : mat 0 n), vdotm v m = tt.
  Proof.
    induction n; intros; destruct v,m; simpl; auto.
  Qed.

  Lemma vdotm_split : forall {r c} (v : vec c) (m : mat (S r) c),
      (vdotm v m == (vdot v (mhdr m), vdotm v (mtlr m)))%vec.
  Proof.
    induction r; intros; simpl; try easy.
  Qed.

  Lemma vdotm_cons : forall {r c} a (v : vec c) (m : mat r (S c)),
      (@vdotm r (S c) (a, v) m == (a c* (mhdc m)) + (vdotm v (mtlc m)))%vec.
  Proof.
    induction r; intros; destruct m; simpl; auto.
    split; try easy.
    rewrite IHr. easy.
  Qed.

  Lemma vdotm_vcmul : forall {r c} a (v : vec c) (m : mat r c),
      (vdotm (a c* v) m == a c* (vdotm v m))%vec.
  Proof.
    induction r; intros; destruct m; simpl; auto. rewrite IHr. split; try easy.
    apply vdot_vcmul_l.
  Qed.

  Lemma vdotm_add_distr_l : forall {r c} (v : vec r) (m1 m2 : mat c r),
      (vdotm v (m1 + m2)%mat == (vdotm v m1) + (vdotm v m2))%vec.
  Proof.
    intros r c. revert c.
    induction c; intros; destruct m1,m2; simpl; auto.
    split; try easy. apply vdot_vadd_l.
    rewrite <- IHc. easy.
  Qed.

  Lemma vdotm_add_distr_r : forall {r c} (v1 v2 : vec c) (m : mat r c),
      (vdotm (v1 + v2) m == (vdotm v1 m) + (vdotm v2 m))%vec.
  Proof.
    induction r; intros; destruct m; simpl; auto. split; try easy.
    apply vdot_vadd_r.
  Qed.

  (** 0 . m = 0 *)
  Lemma vdotm_0_l : forall {r c} (m : @mat A r c),
      (vdotm (vec0 A0 c) m == vec0 A0 r)%vec.
  Proof.
    induction r; intros; simpl; auto. split; [|easy].
    apply vdot_0_l.
  Qed.

  (** v . 0 = 0 *)
  Lemma vdotm_0_r : forall {r c} (v : vec c), (vdotm v (mat0 A0 r c) == vec0 A0 r)%vec.
  Proof.
    induction r; intros; simpl; auto. split.
    - rewrite vmake_const_eq_vconst. rewrite vdot_0_r. easy.
    - rewrite vmakeAux_const_eq_vconst.
      rewrite vmake_const_eq_vconst.
      rewrite <- ?vec0_eq_vconst0.
      rewrite <- mat0_eq_vec0.
      auto.
  Qed.

  (** v . 1 = v *)
  Lemma vdotm_1_r : forall {n} (v : vec n), (vdotm v (mat1 A0 A1 n) == v)%vec.
  Proof.
    induction n; intros; destruct v; simpl; auto. split.
    - rewrite vdot_S. rewrite vdot_0_r; auto. ring.
    - rewrite vdotm_cons. rewrite mtlc_mconsc. rewrite mhdc_mconsc.
      rewrite IHn. rewrite <- vec0_eq_vconst0. rewrite vcmul_0_r.
      apply vadd_0_l.
  Qed.

  (** *** Inner product two matrix. m(r1,c) *' (m(r2,c) = m(r1,r2) *)

  Fixpoint mdot {r c t} : (@mat A r c) -> (@mat A t c) -> (@mat A r t) :=
    match r with
    | O => fun (m1 : mat 0 _) m2 => tt
    | S r' => fun (m1 : mat (S r') _) m2 =>
                (vdotm (fst m1) m2, mdot (snd m1) m2)
    end.

  (** mdot is proper morphism *)
  Lemma mdot_aeq_mor : forall r c t : nat,
      Proper (meq (Aeq:=Aeq)(r:=r)(c:=c) ==>
                meq (Aeq:=Aeq)(r:=t)(c:=c) ==>
                meq (Aeq:=Aeq)(r:=r)(c:=t)) mdot.
  Proof.
    unfold Proper, respectful.
    induction r; intros; vsimp; simpl; auto. split; auto.
    - rewrite H,H0. easy.
    - apply IHr; auto. rewrite H. easy.
  Qed.

  Global Existing Instance mdot_aeq_mor.

  (** v . m = m . v *)
  Lemma vdotm_comm_mdot : forall {r c} (v : vec c) (m : @mat A r c),
      (vdotm v m == cm2v (mdot m (v2rm v)))%vec.
  Proof.
    induction r; intros; destruct m; simpl; auto. split; auto.
    apply vdot_comm.
  Qed.

  Lemma mhdc_mdot_eq_vdotm : forall {r c t} (v : vec c) (m1 : mat r c) (m2 : mat t c),
    (mhdc (@mdot t c (S r) m2 (v, m1)) == vdotm v m2)%vec.
  Proof.
    induction t; destruct m2; simpl; auto. split; auto.
    apply vdot_comm.
  Qed.

  (** tl (m1 . m2) = m1 . (tl m2). *)
  Lemma mtlc_mdot : forall {r c t} (m1 : mat r c) (m2 : mat (S t) c),
      mtlc (mdot m1 m2) == mdot m1 (mtlr m2).
  Proof.
    induction r; intros; destruct m1,m2; simpl; auto. split; auto.
    easy. apply IHr.
  Qed.

  (** (v, m1) . m2 = ((v . m2), (m1 . m2)) *)
  Lemma mdot_split_l {r c t} (v : vec c) (m1 : mat r c) (m2 : mat t c) :
    @mdot (S r) c t (v, m1) m2 == ((vdotm v m2), (mdot m1 m2)).
  Proof.
    induction r; destruct m1; simpl; try easy.
  Qed.

  (** (m1 . (v, m2)) = (m1 . v) @ (m1 . m2) *)
  Lemma mdot_split_r {r c t} (v : vec c) (m1 : mat r c) (m2 : mat t c) :
    mdot m1 ((v, m2):mat (S t) c) == (cm2v (mdot m1 (v2rm v))) @ (mdot m1 m2).
  Proof.
    induction r; destruct m1; simpl; auto. rewrite IHr. easy.
  Qed.

  (** m1 . m2 = (m2 . m1)\T *)
  Lemma mdot_comm : forall {r c t} (m1 : @mat A r c) (m2 : @mat A t c),
      mdot m1 m2 == (mdot m2 m1)\T.
  Proof.
    induction r; intros; destruct m1; simpl; auto. split.
    - rewrite mhdc_mdot_eq_vdotm. easy.
    - rewrite IHr. f_equiv. rewrite mtlc_mdot. simpl. easy.
  Qed.

  (** m1[r,0] . m2[c,0] = mat0 *)
  Lemma mdot_c0_c0_eq_mat0 : forall {r c} (m1 : mat r 0) (m2 : mat c 0),
      mdot m1 m2 == mat0 A0 r c.
      (* mdot m1 m2 = vconst r (vec0 A0 c). *)
  Proof.
    induction r; intros; destruct m1; simpl; auto. split.
    - rewrite vdotm_c0. rewrite vmake_const_eq_vconst. easy.
    - rewrite IHr.
      rewrite vmakeAux_const_eq_vconst. rewrite vmake_const_eq_vconst.
      rewrite mat0_eq_vec0. easy.
  Qed.

  (** hdr ((v,m1) . m2) = v . m2 *)
  Lemma mhdr_mdot : forall {r c t} (v : vec c) (m1 : mat r c) (m2 : mat t c),
      (mhdr (mdot ((v, m1) : mat (S r) c) m2) == vdotm v m2)%vec.
  Proof.
    induction r; intros; destruct m1; simpl; easy.
  Qed.

  (** hdc (m1 . (v, m2)) = v . m1 *)
  Lemma mhdc_mdot : forall {r c t} (m1 : mat r c) (v : vec c) (m2 : mat t c),
      (mhdc (mdot m1 ((v, m2) : mat (S t) c)) == vdotm v m1)%vec.
  Proof.
    induction r; intros; destruct m1; simpl; auto. split; auto.
    apply vdot_comm.
  Qed.

  (** (v . m1) . m2 = v . (m2 . m1\T) *)
  Lemma vdotm_assoc : forall {r c t} (v : vec r) (m1 : mat c r) (m2 : mat t c),
      (vdotm (vdotm v m1) m2 == vdotm v (mdot m2 (m1\T)))%vec.
  Proof.
    induction r; intros; destruct v; simpl.
    - rewrite ?vdotm_0_l. easy.
    - rewrite ?vdotm_cons. rewrite vdotm_add_distr_r. f_equiv.
      + rewrite vdotm_vcmul. rewrite mhdc_mdot. easy.
      + rewrite IHr. rewrite mtlc_mdot. simpl. easy.
  Qed.

  (** (m1 . m2) . m3 == m1 . (m3 . m2\T) *)
  Lemma mdot_assoc : forall {r c t s} (m1: @mat A r c) (m2: @mat A t c) (m3: @mat A s t),
      mdot (mdot m1 m2) m3 == mdot m1 (mdot m3 (m2\T)).
  Proof.
    induction r; intros; destruct m1; simpl; auto. split; auto.
    apply vdotm_assoc.
  Qed.

  (** m1 . (m2 + m3) = (m1 . m2) + (m1 . m3) *)
  Lemma mdot_add_distr_l : forall {r c t} (m1 : @mat A r c) (m2 m3 : @mat A t c),
      mdot m1 (m2 + m3) == (mdot m1 m2) + (mdot m1 m3).
  Proof.
    induction r; intros; destruct m1; simpl; auto. split; auto.
    - apply vdotm_add_distr_l.
    - apply IHr.
  Qed.

  (** (m1 + m2) . m3 = (m1 . m3) + (m2 . m3) *)
  Lemma mdot_add_distr_r : forall {r c t} (m1 m2 : @mat A r c) (m3 : @mat A t c),
      mdot (m1 + m2) m3 == (mdot m1 m3) + (mdot m2 m3).
  Proof.
    induction r; intros; destruct m1; simpl; auto. split; auto.
    - apply vdotm_add_distr_r.
    - apply IHr.
  Qed.

  (** m . mat0 = mat0 *)
  Lemma mdot_0_r : forall {r c t} (m : @mat A r c), mdot m (mat0 A0 t c) == mat0 A0 r t.
  Proof.
    induction r; intros; destruct m; simpl; auto. split.
    - rewrite vdotm_0_r. rewrite vmake_const_eq_vconst. easy.
    - rewrite IHr. rewrite mat0_eq_vec0.
      rewrite vmakeAux_const_eq_vconst. rewrite vmake_const_eq_vconst. easy.
  Qed.

  (** mat0 . m = mat0 *)
  Lemma mdot_0_l : forall {r c t} (m : @mat A t c), mdot (mat0 A0 r c) m == mat0 A0 r t.
  Proof.
    intros. rewrite mdot_comm. rewrite mdot_0_r.
    rewrite mtrans_mat0. easy.
  Qed.

  (** mat1 . m = m\T *)
  Lemma mdot_1_l : forall {r c} (m : @mat A r c),
    mdot (mat1 A0 A1 c) m == m\T.
  Proof.
  Abort.

  (** *** Vector multiplication (I don't sure what's the exact name?) *)
  (** v1 * v2 : vec r -> vec c -> mat r c.
      Example:
      (a1 a2) * (b1 b2 b3)
      = [[a1b1 a1b2 a1b3];
         [a2b1 a2b2 a2b3]]
   *)
  Definition vmul {r c} (v1 : @vec A r) (v2 : @vec A c) : @mat A r c :=
    (* mmake r c (fun ri ci => Amul (vnth (A0:=A0) ri v1) (vnth (A0:=A0) ci v2)). *)
    vmake r (fun ri => vcmul (Amul:=Amul) (vnth (A0:=A0) ri v1) v2).

  (* Lemma vmul_aeq_mor : forall (r c:nat), *)
  (*     Proper (veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq) ==> meq (Aeq:=Aeq)) *)
  (*       (vmul (r:=r)(c:=c)). *)
  (*   Admitted. *)
  (* Global Existing Instance vmul_aeq_mor. *)

  (* v1 . (a,v2) = (v1 *c a) @ (v1 . v2) *)
  Lemma vmul_cons_r : forall r c a (v1 : vec r) (v2 :vec c),
      vmul v1 ((a,v2):vec (S c)) == mconsc ((v1 *c a)%vec) (vmul v1 v2).
  Proof.
    induction r; intros; vsimp; simpl; auto. split.
    - split; try easy.
    - unfold vmul in *. unfold vmake in *. unfold vmulc in *.
      (* Tips: type issue. because "vec (S c)" is diff with "(prod A (@vec A c))" *)
      Fail rewrite vmakeAux_S.
      (* Check (prod A (@vec A c)). *)

      (* So, manually type issue *)
      assert (vmakeAux r 1
                (fun ri : nat => (match ri with
                              | 0 => a0
                              | S i' => vnth (A0:=A0) i' v
                              end c* v2)%vec) ==
                vmakeAux r 0 (fun ri => (vnth (A0:=A0) ri v) c* v2)%vec)
        by apply vmakeAux_S. rewrite H; clear H.
      assert (vmakeAux r 1
                (fun ri : nat => (match ri with
                              | 0 => a0
                              | S i' => vnth (A0:=A0) i' v
                              end c* ((a, v2):vec (S c)))%vec) ==
                vmakeAux r 0 (fun ri => (vnth (A0:=A0) ri v) c* ((a, v2):vec (S c)))%vec)
        by apply vmakeAux_S. rewrite H; clear H.
      rewrite IHr. easy.
  Qed.

  (** Tail column of a matrix build by vmakeAux, equal to a matrix build by
      vmakeAux directly *)
  Lemma mtlc_vmakeAux : forall (r c r_ofst : nat) (f : nat -> vec (S c)),
      mtlc (vmakeAux r r_ofst (fun ri => f ri)) ==
        vmakeAux r r_ofst (fun ri => (vtl (f ri))).
  Proof.
    induction r; intros; simpl; auto. split. easy.
    rewrite IHr. easy.
  Qed.

  (** Tail column of a matrix build by vmake, equal to a matrix build by
      vmake directly *)
  Lemma mtlc_vmake : forall (r c : nat) (f : nat -> vec (S c)),
      mtlc (vmake r (fun ri => f ri)) == vmake r (fun ri => (vtl (f ri))).
  Proof.
    intros. unfold vmake. rewrite mtlc_vmakeAux. easy.
  Qed.

  (** vmul v1 v2 = (vmul v2 v1)\T *)
  Lemma vmul_comm_eq_trans_comm : forall r c (v1 : vec r) (v2 : vec c),
      vmul v1 v2 == (vmul v2 v1)\T.
  Proof.
    induction r; intros; simpl; auto. vsimp; simpl. split.
    - rewrite vmul_cons_r. rewrite mhdc_mconsc.
      rewrite vmulc_eq_vcmul. easy.
    - unfold vmul in *. unfold vmake in *.
      rewrite vmakeAux_S. rewrite IHr. f_equiv.
      unfold vcmul. simpl.
      rewrite mtlc_vmakeAux. simpl. f_equiv.
  Qed.

  (** vmul vec0 v = mat0 *)
  Lemma vmul_0_l : forall r c (v : vec c), vmul (vec0 A0 r) v == mat0 A0 r c.
  Proof.
    induction r; intros; vsimp; simpl; auto. split; auto.
    - rewrite vcmul_0_l. rewrite vmake_const_eq_vconst. easy.
    - rewrite ?vmakeAux_S.
      apply (veq_iff_vnth (A0:=vec0 A0 c)). intros.
      rewrite ?vnth_vmakeAux_valid by lia.
      unfold vec0. rewrite vnth_const by lia. rewrite vcmul_0_l.
      rewrite vmake_const_eq_vconst. easy.
  Qed.

  (** vmul v vec0 = mat0 *)
  Lemma vmul_0_r : forall r c (v : vec r), vmul v (vec0 A0 c) == mat0 A0 r c.
  Proof.
    intros. rewrite vmul_comm_eq_trans_comm. rewrite vmul_0_l.
    rewrite mtrans_mat0. easy.
  Qed.

  (** mdot (v1 @ m1) (v2 @ m2) = (vmul v1 v2) + (mdot m1 m2). *)
  Lemma mdot_consc_consc : forall r c s (v1: vec r) (m1: mat r c) (v2: vec s) (m2: mat s c),
      mdot (v1 @ m1) (v2 @ m2) == (vmul v1 v2) + (mdot m1 m2).
  Proof.
    unfold mat; induction r; intros; vsimp; simpl; auto. split.
    - rewrite vdotm_cons. rewrite mhdc_mconsc. rewrite mtlc_mconsc. easy.
    - rewrite IHr.
      (* Tips: here, a subtle problem. we shouldn't use "unfold madd".
         If we do it, after "f_equiv", we cannot prove.
         Because typeclasses issue.
         The details could be checked after "Set Printing All".
         We can find the "eq" and "Aeq" differences *)
      (* unfold madd. *)
      f_equiv.
      rewrite vmakeAux_S. unfold vmul. unfold vmake. f_equiv.
  Qed.

  (** *** Matrix Multiplication. m1(r,c) * m2(c,t) = m(r,t) *)

  Definition mmul {r c s} (m1 : @mat A r c) (m2 : @mat A c s) : @mat A r s :=
    mdot m1 (m2\T).
  Infix "*" := mmul : mat_scope.

  (** (m1 * m2)\T = m2\T * m1\T *)
  Lemma mmul_trans : forall {r c s} (m1 : @mat A r c) (m2 : @mat A c s),
      (m1 * m2)\T == (m2\T) * (m1\T).
  Proof.
    intros. unfold mmul. rewrite <- mdot_comm. rewrite mtrans_trans. easy.
  Qed.

  (** (m1 * m2) * m3 = m1 * (m2 * m3) *)
  Lemma mmul_assoc : forall {r c s t} (m1: @mat A r c) (m2: @mat A c s) (m3: @mat A s t),
      (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. unfold mmul. rewrite <- mdot_comm.
    rewrite mdot_assoc. rewrite mtrans_trans. easy.
  Qed.

  (** m1 * (m2 + m3) = (m1 * m2) + (m1 * m3) *)
  Lemma mmul_add_distr_l : forall {r c s} (m1 : mat r c) (m2 m3 : mat c s),
      m1 * (m2 + m3) == (m1 * m2) + (m1 * m3).
  Proof.
    intros. unfold mmul. rewrite mtrans_madd.
    rewrite mdot_add_distr_l. easy.
  Qed.

  (** (m1 + m2) * m3 = (m1 * m3) + (m2 * m3) *)
  Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
      (m1 + m2) * m3 == (m1 * m3) + (m2 * m3).
  Proof.
    intros. unfold mmul. rewrite mdot_add_distr_r. easy.
  Qed.

  (** (v1, m1) * m2 = ((v1 . m2\T), m1 * m2) *)
  Lemma mmul_consr_l : forall {r c s} (v1 : vec c) (m1 : mat r c) (m2 : mat c s),
      ((v1, m1) : mat (S r) c) * m2 == (vdotm v1 (m2\T), m1 * m2).
  Proof.
    intros. unfold mmul. rewrite mdot_split_l. easy.
  Qed.

  (* a difficult lemma *)
  (** (v1 @ m1) * (v2, m2) = [v1^T]*[v2] + m1 * m2 *)
  Lemma mmul_consc_consr : forall {r c s} (v1 : vec r) (m1 : mat r c) (v2 : vec s)
                             (m2 : mat c s),
      (v1 @ m1) * (v2, m2) == ((v2cm v1) * (v2rm v2)) + (m1 * m2).
  Proof.
    unfold mmul.
    induction r.
    - intros; simpl; auto.
    - induction c; intros; simpl.
      + destruct v1,m1,m2. destruct v0. simpl. split.
        * rewrite vdotm_0_l. rewrite vadd_0_r. easy.
        * rewrite IHr. rewrite mdot_c0_c0_eq_mat0.
          rewrite ?madd_0_r.
          (* Tips: manually type conversion *)
          assert (vmap2 (vadd (Aadd:=Aadd)) (mdot (v2cm v) (v2rm v2 \T)) (mat0 A0 r s)
                  == madd (mdot (v2cm v) (v2rm v2 \T)) (mat0 A0 r s)).
          { easy. }
          rewrite H. rewrite madd_0_r. easy.
      + destruct v1,m1,m2. destruct v0. simpl. split; try apply IHr.
        rewrite vdotm_cons. rewrite vdotm_cons.
        rewrite mhdc_mtrans_eq_mhdr. simpl.
        unfold v2rm; simpl. rewrite ?vdotm_cons.
        rewrite ?mtlc_mtrans_eq_mtrans_mtlr. simpl.
        rewrite ?mhdc_mtrans_eq_mhdr. simpl.
        rewrite vdotm_c0. rewrite vadd_0_r.
        rewrite <- vadd_assoc. easy.
  Qed.

  (** mat0 * m = mat0 *)
  Lemma mmul_0_l : forall {r c t} (m : mat c t), (mat0 A0 r c) * m == mat0 A0 r t.
  Proof.
    intros. unfold mmul. rewrite mdot_0_l. easy.
  Qed.

  (** m * mat0 = mat0 *)
  Lemma mmul_0_r : forall {r c t} (m : mat r c), m * (mat0 A0 c t) == mat0 A0 r t.
  Proof.
    intros. unfold mmul. rewrite mtrans_mat0. rewrite mdot_0_r. easy.
  Qed.

  (** m * mat1 = m *)
  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 A0 A1 c) == m.
  Proof.
    induction r; intros; destruct m; simpl; auto. split.
    - rewrite mtrans_mat1. rewrite vdotm_1_r. easy.
    - apply IHr.
  Qed.

  (** mat1 * m = m *)
  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 A0 A1 r) * m == m.
  Proof.
    induction r; intros; destruct m; simpl; auto. split.
    - rewrite vdotm_cons. rewrite vdotm_0_l. rewrite vadd_0_r.
      rewrite mhdc_mtrans_eq_mhdr. simpl. rewrite vcmul_1_l. easy.
    - rewrite mtrans_consr.
      rewrite mdot_consc_consc.
      unfold mmul in IHr. rewrite IHr.
      rewrite vmul_0_l. apply madd_0_l.
  Qed.

  (** *** Row-vector multiply a matrix, or matrix multiply column-vector.
      1. v(r) converted to mv(1,r)
      2. v(r) * m(r,c) = mv(1,r) * m(r,c) = m'(1,c) *)

  Definition vmulm {r c} (v : @vec A r) (m : @mat A r c) : (@mat A 1 c) :=
    (v2rm v) * m.

  Definition mmulv {r c} (m : @mat A r c) (v : @vec A c) : @mat A r 1:=
    m * (v2cm v).

End mat_alg.


Require Import MyNotations.
Require Import Coq.Lists.List.

Section SeqOfList.
  Context {t : Type}.
  Context {b : Bottom t}.
  Variable (teq : Equiv t).
  Variable (tequiv : Equivalence teq).

  Existing Instance b.
  Existing Instance teq.
  Existing Instance tequiv.

  Definition V_cons (x : t) (u : nat -> t) (n : nat) :=
    match n with
      | 0 => x
      | S n => u n
    end.
  Infix ":::" := V_cons (right associativity, at level 60).

  Definition V_tail (u : nat -> t) (n : nat) := u (S n).

  Instance nat_t_equal : Equiv (nat -> t) := pointwise_relation nat (=).
  Lemma V_cons_compose : forall f x u, f ∘ (V_cons x u) = V_cons (f x) (f ∘ u).
  Proof.
    intros.
    unfold compose, V_cons, equiv, nat_t_equal, pointwise_relation.
    intro.
    destruct a ; reflexivity.
  Qed.

  Fixpoint seq_of_list (l : list t) : (nat -> t) :=
    match l with
      | [] => fun _ => ⊥
      | h :: q => h ::: (seq_of_list q)
    end.

  Inductive listeq : forall u v : list t, Prop :=
  | listeq_nil : listeq nil nil
  | listeq_cons : forall a b u v, a = b -> listeq u v -> listeq (a :: u) (b :: v).
  Instance listeq_equiv : Equiv (list t) := listeq.

  Lemma listeq_refl : Reflexive listeq.
  Proof.
    unfold Reflexive.
    induction x.
    apply listeq_nil.
    apply listeq_cons ; auto.
  Qed.

  Lemma listeq_trans : Transitive listeq.
  Proof.
    unfold Transitive.
    induction x ; intros.
    inversion H. subst. assumption.
    inversion H. inversion H0. subst.
    inversion H0. subst.
    inversion H8. subst.
    rewrite H6 in H3.
    apply listeq_cons. assumption.
    apply IHx with (y := v) ; assumption.
  Qed.

  Lemma listeq_sym : Symmetric listeq.
    unfold Symmetric.
    induction x ; intros.
    - inversion H. apply listeq_nil.
    - inversion H. subst. apply listeq_cons.
      symmetry. assumption.
      apply IHx ; assumption.
  Qed.
End SeqOfList.

Add Parametric Relation (t : Type) (teq : Equiv t) (tequiv : Equivalence teq) : (list t) (listeq teq)
    reflexivity proved by (listeq_refl teq tequiv)
    symmetry proved by (listeq_sym teq tequiv)
    transitivity proved by (listeq_trans teq tequiv) as listeq_rel.

Add Parametric Morphism (t : Type) (teq : Equiv t) (tequiv : Equivalence teq) (b : Bottom t): seq_of_list with signature
    ((listeq teq) ==> pointwise_relation nat teq) as seq_of_list_morphism.
Proof.
  unfold pointwise_relation.
  induction x ; intros ; inversion H ; subst.
  reflexivity.
  destruct a0 ; simpl.
  + assumption.
  + apply IHx. assumption.
Qed.

Infix ":::" := V_cons (right associativity, at level 60).

Section compose.
  Context {t : Type}.
  Context {b : Bottom t}.
  Context {t' : Type}.
  Context {b' : Bottom t'}.
  Variable (teq : Equiv t').
  Variable (tequiv : Equivalence teq).
  Existing Instance teq.
  Instance nat_t'_equal : Equiv (nat -> t') := pointwise_relation nat (=).

  Lemma seq_of_list_compose : forall (f: t -> t') l, f ⊥ = ⊥ -> seq_of_list (map f l) = f ∘ (seq_of_list l).
  Proof.
    induction l; unfold compose, equiv, nat_t'_equal, pointwise_relation ; intros ; simpl.
    - symmetry. assumption.
    - destruct a0.
      + reflexivity.
      + simpl. apply (IHl H).
  Qed.

End compose.


(*
compare_nat contains comparable_nat,
which is a instance of comparable for nat.
*)

Set Implicit Arguments.
Set Asymmetric Patterns.

Require Import Coq.Lists.List.

Require Import CoqStock.comparable.

Definition nat_compare := Nat.compare.

Lemma nat_proof_compare_eq_is_equal:
  forall (x y: nat)
         (p: nat_compare x y = Eq),
    x = y.
Proof.
induction x, y.
- compute. trivial.
- compute. intros. discriminate.
- compute. intros. discriminate.
- simpl.
  intros.
  remember (IHx y p).
  rewrite e.
  reflexivity.
Qed.

Lemma nat_proof_compare_eq_is_equal' x y:
  nat_compare x y = Eq ->
  x = y.
Proof.
(* Because of how the lemma is stated, `x' and `y' are already introduced into
   the context, causing our inductive hypothesis to become too weak to solve the
   goal. `generalize dependent y' returns `y' to the goal and makes sure any
   dependent terms are updated. *)
generalize dependent y.
induction x, y.
- compute. trivial.
- compute. intros. discriminate.
- compute. intros. discriminate.
- simpl.
  intros.
  remember (IHx y H).
  rewrite e.
  reflexivity.
Qed.

Lemma nat_proof_compare_eq_reflex
  : forall (x: nat)
  , nat_compare x x = Eq.
Proof.
(* TODO *)
Admitted.

Lemma nat_proof_compare_eq_trans
  : forall (x y z: nat)
           (p: nat_compare x y = Eq)
           (q: nat_compare y z = Eq)
  , nat_compare x z = Eq.
Proof.
(* TODO *)
Admitted.

Lemma nat_proof_compare_lt_trans
  : forall (x y z: nat)
           (p: nat_compare x y = Lt)
           (q: nat_compare y z = Lt)
  , nat_compare x z = Lt.
Proof.
(* TODO *)
Admitted.

Lemma nat_proof_compare_gt_trans
  : forall (x y z: nat)
           (p: nat_compare x y = Gt)
           (q: nat_compare y z = Gt)
  , nat_compare x z = Gt.
Proof.
(* TODO *)
Admitted.

Instance comparable_nat : comparable nat :=
  { compare := nat_compare
  ; proof_compare_eq_is_equal := nat_proof_compare_eq_is_equal
  ; proof_compare_eq_reflex := nat_proof_compare_eq_reflex
  ; proof_compare_eq_trans := nat_proof_compare_eq_trans
  ; proof_compare_lt_trans := nat_proof_compare_lt_trans
  ; proof_compare_gt_trans := nat_proof_compare_gt_trans
  }.

(* test_compare_list simply tests whether nat can be used
   with a function that expects a comparable instance.
   compare_list is defined in comparable,
   specifically for this use case.
*)
Definition test_compare_list : Prop :=
  comparable_list (1 :: 2 :: nil) (1 :: 3 :: nil) = Lt.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Nnat ZArith_base Lia ZArithRing Zdiv Morphisms.

Local Open Scope Z_scope.

(** This file provides results about the Round-Toward-Zero Euclidean
  division [Z.quotrem], whose projections are [Z.quot] (noted ÷)
  and [Z.rem].

  This division and [Z.div] agree only on positive numbers.
  Otherwise, [Z.div] performs Round-Toward-Bottom (a.k.a Floor).

  This [Z.quot] is compatible with the division of usual
  programming languages such as Ocaml. In addition, it has nicer
  properties with respect to opposite and other usual operations.

  The definition of this division is now in file [BinIntDef],
  while most of the results about here are now in the main module
  [BinInt.Z], thanks to the generic "Numbers" layer. Remain here:

  - some compatibility notation for old names.

  - some extra results with less preconditions (in particular
      exploiting the arbitrary value of division by 0).
*)

Notation Ndiv_Zquot := N2Z.inj_quot (only parsing).
Notation Nmod_Zrem := N2Z.inj_rem (only parsing).
Notation Z_quot_rem_eq := Z.quot_rem' (only parsing).
Notation Zrem_lt := Z.rem_bound_abs (only parsing).
Notation Zquot_unique := Z.quot_unique (compat "8.7").
Notation Zrem_unique := Z.rem_unique (compat "8.7").
Notation Zrem_1_r := Z.rem_1_r (compat "8.7").
Notation Zquot_1_r := Z.quot_1_r (compat "8.7").
Notation Zrem_1_l := Z.rem_1_l (compat "8.7").
Notation Zquot_1_l := Z.quot_1_l (compat "8.7").
Notation Z_quot_same := Z.quot_same (compat "8.7").
Notation Z_quot_mult := Z.quot_mul (only parsing).
Notation Zquot_small := Z.quot_small (compat "8.7").
Notation Zrem_small := Z.rem_small (compat "8.7").
Notation Zquot2_quot := Zquot2_quot (compat "8.7").

(** Particular values taken for [a÷0] and [(Z.rem a 0)].
    We avise to not rely on these arbitrary values. *)

Lemma Zquot_0_r a : a ÷ 0 = 0.
Proof. now destruct a. Qed.

Lemma Zrem_0_r a : Z.rem a 0 = a.
Proof. now destruct a. Qed.

(** The following results are expressed without the [b<>0] condition
    whenever possible. *)

Lemma Zrem_0_l a : Z.rem 0 a = 0.
Proof. now destruct a. Qed.

Lemma Zquot_0_l a : 0÷a = 0.
Proof. now destruct a. Qed.

Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r
 : zarith.

Ltac zero_or_not a :=
  destruct (Z.eq_decidable a 0) as [->|?];
  [rewrite ?Zquot_0_l, ?Zrem_0_l, ?Zquot_0_r, ?Zrem_0_r;
   auto with zarith|].

Lemma Z_rem_same a : Z.rem a a = 0.
Proof. zero_or_not a. now apply Z.rem_same. Qed.

Lemma Z_rem_mult a b : Z.rem (a*b) b = 0.
Proof. zero_or_not b. now apply Z.rem_mul. Qed.

(** * Division and Opposite *)

(* The precise equalities that are invalid with "historic" Zdiv. *)

Theorem Zquot_opp_l a b : (-a)÷b = -(a÷b).
Proof. zero_or_not b. now apply Z.quot_opp_l. Qed.

Theorem Zquot_opp_r a b : a÷(-b) = -(a÷b).
Proof. zero_or_not b. now apply Z.quot_opp_r. Qed.

Theorem Zrem_opp_l a b : Z.rem (-a) b = -(Z.rem a b).
Proof. zero_or_not b. now apply Z.rem_opp_l. Qed.

Theorem Zrem_opp_r a b : Z.rem a (-b) = Z.rem a b.
Proof. zero_or_not b. now apply Z.rem_opp_r. Qed.

Theorem Zquot_opp_opp a b : (-a)÷(-b) = a÷b.
Proof. zero_or_not b. now apply Z.quot_opp_opp. Qed.

Theorem Zrem_opp_opp a b : Z.rem (-a) (-b) = -(Z.rem a b).
Proof. zero_or_not b. now apply Z.rem_opp_opp. Qed.

(** The sign of the remainder is the one of [a]. Due to the possible
   nullity of [a], a general result is to be stated in the following form:
*)

Theorem Zrem_sgn a b : 0 <= Z.sgn (Z.rem a b) * Z.sgn a.
Proof.
  zero_or_not b.
  - apply Z.square_nonneg.
  - zero_or_not (Z.rem a b).
    rewrite Z.rem_sign_nz; trivial. apply Z.square_nonneg.
Qed.

(** This can also be said in a simplier way: *)

Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a.
Proof.
  zero_or_not b.
  - apply Z.square_nonneg.
  - now apply Z.rem_sign_mul.
Qed.

(** Reformulation of [Z.rem_bound_abs] in 2 then 4 particular cases. *)

Theorem Zrem_lt_pos a b : 0<=a -> b<>0 -> 0 <= Z.rem a b < Z.abs b.
Proof.
  intros; generalize (Z.rem_nonneg a b) (Z.rem_bound_abs a b);
    lia.
Qed.

Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0.
Proof.
  intros; generalize (Z.rem_nonpos a b) (Z.rem_bound_abs a b);
   lia.
Qed.

Theorem Zrem_lt_pos_pos a b : 0<=a -> 0<b -> 0 <= Z.rem a b < b.
Proof.
  intros; generalize (Zrem_lt_pos a b); lia.
Qed.

Theorem Zrem_lt_pos_neg a b : 0<=a -> b<0 -> 0 <= Z.rem a b < -b.
Proof.
  intros; generalize (Zrem_lt_pos a b); lia.
Qed.

Theorem Zrem_lt_neg_pos a b : a<=0 -> 0<b -> -b < Z.rem a b <= 0.
Proof.
  intros; generalize (Zrem_lt_neg a b); lia.
Qed.

Theorem Zrem_lt_neg_neg a b : a<=0 -> b<0 -> b < Z.rem a b <= 0.
Proof.
  intros; generalize (Zrem_lt_neg a b); lia.
Qed.

(** * Unicity results *)

Definition Remainder a b r :=
  (0 <= a /\ 0 <= r < Z.abs b) \/ (a <= 0 /\ -Z.abs b < r <= 0).

Definition Remainder_alt a b r :=
  Z.abs r < Z.abs b /\ 0 <= r * a.

Lemma Remainder_equiv : forall a b r,
 Remainder a b r <-> Remainder_alt a b r.
Proof.
  unfold Remainder, Remainder_alt; intuition.
  - lia.
  - lia.
  - rewrite <-(Z.mul_opp_opp). apply Z.mul_nonneg_nonneg; lia.
  - assert (0 <= Z.sgn r * Z.sgn a).
    { rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto. }
    destruct r; simpl Z.sgn in *; lia.
Qed.

Theorem Zquot_mod_unique_full a b q r :
  Remainder a b r -> a = b*q + r -> q = a÷b /\ r = Z.rem a b.
Proof.
  destruct 1 as [(H,H0)|(H,H0)]; intros.
  apply Zdiv_mod_unique with b; auto.
  apply Zrem_lt_pos; auto.
  lia.
  rewrite <- H1; apply Z.quot_rem'.

  rewrite <- (Z.opp_involutive a).
  rewrite Zquot_opp_l, Zrem_opp_l.
  generalize (Zdiv_mod_unique b (-q) (-a÷b) (-r) (Z.rem (-a) b)).
  generalize (Zrem_lt_pos (-a) b).
  rewrite <-Z.quot_rem', Z.mul_opp_r, <-Z.opp_add_distr, <-H1.
  lia.
Qed.

Theorem Zquot_unique_full a b q r :
  Remainder a b r -> a = b*q + r -> q = a÷b.
Proof.
 intros; destruct (Zquot_mod_unique_full a b q r); auto.
Qed.

Theorem Zrem_unique_full a b q r :
  Remainder a b r -> a = b*q + r -> r = Z.rem a b.
Proof.
 intros; destruct (Zquot_mod_unique_full a b q r); auto.
Qed.

(** * Order results about Zrem and Zquot *)

(* Division of positive numbers is positive. *)

Lemma Z_quot_pos a b : 0 <= a -> 0 <= b -> 0 <= a÷b.
Proof. intros. zero_or_not b. apply Z.quot_pos; auto with zarith. Qed.

(** As soon as the divisor is greater or equal than 2,
    the division is strictly decreasing. *)

Lemma Z_quot_lt a b : 0 < a -> 2 <= b -> a÷b < a.
Proof. intros. apply Z.quot_lt; auto with zarith. Qed.

(** [<=] is compatible with a positive division. *)

Lemma Z_quot_monotone a b c : 0<=c -> a<=b -> a÷c <= b÷c.
Proof. intros. zero_or_not c. apply Z.quot_le_mono; auto with zarith. Qed.

(** With our choice of division, rounding of (a÷b) is always done toward 0: *)

Lemma Z_mult_quot_le a b : 0 <= a -> 0 <= b*(a÷b) <= a.
Proof. intros. zero_or_not b. apply Z.mul_quot_le; auto with zarith. Qed.

Lemma Z_mult_quot_ge a b : a <= 0 -> a <= b*(a÷b) <= 0.
Proof. intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed.

(** The previous inequalities between [b*(a÷b)] and [a] are exact
    iff the modulo is zero. *)

Lemma Z_quot_exact_full a b : a = b*(a÷b) <-> Z.rem a b = 0.
Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed.

(** A modulo cannot grow beyond its starting point. *)

Theorem Zrem_le a b : 0 <= a -> 0 <= b -> Z.rem a b <= a.
Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed.

(** Some additional inequalities about Zdiv. *)

Theorem Zquot_le_upper_bound:
  forall a b q, 0 < b -> a <= q*b -> a÷b <= q.
Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_le_upper_bound. Qed.

Theorem Zquot_lt_upper_bound:
  forall a b q, 0 <= a -> 0 < b -> a < q*b -> a÷b < q.
Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_lt_upper_bound. Qed.

Theorem Zquot_le_lower_bound:
  forall a b q, 0 < b -> q*b <= a -> q <= a÷b.
Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_le_lower_bound. Qed.

Theorem Zquot_sgn: forall a b,
  0 <= Z.sgn (a÷b) * Z.sgn a * Z.sgn b.
Proof.
  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
  unfold Z.quot; simpl; destruct N.pos_div_eucl; simpl; destruct n; simpl; auto with zarith.
Qed.

(** * Relations between usual operations and Zmod and Zdiv *)

(** First, a result that used to be always valid with Zdiv,
    but must be restricted here.
    For instance, now (9+(-5)*2) rem 2 = -1 <> 1 = 9 rem 2 *)

Lemma Z_rem_plus : forall a b c:Z,
 0 <= (a+b*c) * a ->
 Z.rem (a + b * c) c = Z.rem a c.
Proof. intros. zero_or_not c. apply Z.rem_add; auto with zarith. Qed.

Lemma Z_quot_plus : forall a b c:Z,
 0 <= (a+b*c) * a -> c<>0 ->
 (a + b * c) ÷ c = a ÷ c + b.
Proof. intros. apply Z.quot_add; auto with zarith. Qed.

Theorem Z_quot_plus_l: forall a b c : Z,
 0 <= (a*b+c)*c -> b<>0 ->
 b<>0 -> (a * b + c) ÷ b = a + c ÷ b.
Proof. intros. apply Z.quot_add_l; auto with zarith. Qed.

(** Cancellations. *)

Lemma Zquot_mult_cancel_r : forall a b c:Z,
 c<>0 -> (a*c)÷(b*c) = a÷b.
Proof. intros. zero_or_not b. apply Z.quot_mul_cancel_r; auto. Qed.

Lemma Zquot_mult_cancel_l : forall a b c:Z,
 c<>0 -> (c*a)÷(c*b) = a÷b.
Proof.
 intros. rewrite (Z.mul_comm c b). zero_or_not b.
 rewrite (Z.mul_comm b c). apply Z.quot_mul_cancel_l; auto.
Qed.

Lemma Zmult_rem_distr_l: forall a b c,
  Z.rem (c*a) (c*b) = c * (Z.rem a b).
Proof.
 intros. zero_or_not c. rewrite (Z.mul_comm c b). zero_or_not b.
 rewrite (Z.mul_comm b c). apply Z.mul_rem_distr_l; auto.
Qed.

Lemma Zmult_rem_distr_r: forall a b c,
  Z.rem (a*c) (b*c) = (Z.rem a b) * c.
Proof.
 intros. zero_or_not b. rewrite (Z.mul_comm b c). zero_or_not c.
 rewrite (Z.mul_comm c b). apply Z.mul_rem_distr_r; auto.
Qed.

(** Operations modulo. *)

Theorem Zrem_rem: forall a n, Z.rem (Z.rem a n) n = Z.rem a n.
Proof. intros. zero_or_not n. apply Z.rem_rem; auto. Qed.

Theorem Zmult_rem: forall a b n,
 Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n.
Proof. intros. zero_or_not n. apply Z.mul_rem; auto. Qed.

(** addition and modulo

  Generally speaking, unlike with Zdiv, we don't have
       (a+b) rem n = (a rem n + b rem n) rem n
  for any a and b.
  For instance, take (8 + (-10)) rem 3 = -2 whereas
  (8 rem 3 + (-10 rem 3)) rem 3 = 1. *)

Theorem Zplus_rem: forall a b n,
 0 <= a * b ->
 Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n.
Proof. intros. zero_or_not n. apply Z.add_rem; auto. Qed.

Lemma Zplus_rem_idemp_l: forall a b n,
 0 <= a * b ->
 Z.rem (Z.rem a n + b) n = Z.rem (a + b) n.
Proof. intros. zero_or_not n. apply Z.add_rem_idemp_l; auto. Qed.

Lemma Zplus_rem_idemp_r: forall a b n,
 0 <= a*b ->
 Z.rem (b + Z.rem a n) n = Z.rem (b + a) n.
Proof.
 intros. zero_or_not n. apply Z.add_rem_idemp_r; auto.
 rewrite Z.mul_comm; auto.
Qed.

Lemma Zmult_rem_idemp_l: forall a b n, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n.
Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_l; auto. Qed.

Lemma Zmult_rem_idemp_r: forall a b n, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n.
Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_r; auto. Qed.

(** Unlike with Zdiv, the following result is true without restrictions. *)

Lemma Zquot_Zquot : forall a b c, (a÷b)÷c = a÷(b*c).
Proof.
 intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c.
 rewrite Z.mul_comm. apply Z.quot_quot; auto.
Qed.

(** A last inequality: *)

Theorem Zquot_mult_le:
 forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a÷b) <= (c*a)÷b.
Proof. intros. zero_or_not b. apply Z.quot_mul_le; auto with zarith. Qed.

(** Z.rem is related to divisibility (see more in Znumtheory) *)

Lemma Zrem_divides : forall a b,
 Z.rem a b = 0 <-> exists c, a = b*c.
Proof.
 intros. zero_or_not b. firstorder.
 rewrite Z.rem_divide; trivial.
 split; intros (c,Hc); exists c; subst; auto with zarith.
Qed.

(** Particular case : dividing by 2 is related with parity *)

Lemma Zquot2_odd_remainder : forall a,
 Remainder a 2 (if Z.odd a then Z.sgn a else 0).
Proof.
 intros [ |p|p]. simpl.
 left. simpl. auto with zarith.
 left. destruct p; simpl; auto with zarith.
 right. destruct p; simpl; split; now auto with zarith.
Qed.

Lemma Zrem_odd : forall a, Z.rem a 2 = if Z.odd a then Z.sgn a else 0.
Proof.
 intros. symmetry.
 apply Zrem_unique_full with (Z.quot2 a).
 apply Zquot2_odd_remainder.
 apply Zquot2_odd_eqn.
Qed.

Lemma Zrem_even : forall a, Z.rem a 2 = if Z.even a then 0 else Z.sgn a.
Proof.
 intros a. rewrite Zrem_odd, Zodd_even_bool. now destruct Z.even.
Qed.

Lemma Zeven_rem : forall a, Z.even a = Z.eqb (Z.rem a 2) 0.
Proof.
 intros a. rewrite Zrem_even.
 destruct a as [ |p|p]; trivial; now destruct p.
Qed.

Lemma Zodd_rem : forall a, Z.odd a = negb (Z.eqb (Z.rem a 2) 0).
Proof.
 intros a. rewrite Zrem_odd.
 destruct a as [ |p|p]; trivial; now destruct p.
Qed.

(** * Interaction with "historic" Zdiv *)

(** They agree at least on positive numbers: *)

Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b ->
  a÷b = a/b /\ Z.rem a b = a mod b.
Proof.
  intros.
  apply Zdiv_mod_unique with b.
  apply Zrem_lt_pos; auto with zarith.
  rewrite Z.abs_eq; auto with *; apply Z_mod_lt; auto with *.
  rewrite <- Z_div_mod_eq; auto with *.
  symmetry; apply Z.quot_rem; auto with *.
Qed.

Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b ->
  a÷b = a/b.
Proof.
 intros a b Ha Hb. Z.le_elim Hb.
 - generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); intuition.
 - subst; now rewrite Zquot_0_r, Zdiv_0_r.
Qed.

Theorem Zrem_Zmod_pos : forall a b, 0 <= a -> 0 < b ->
  Z.rem a b = a mod b.
Proof.
 intros a b Ha Hb; generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb);
 intuition.
Qed.

(** Modulos are null at the same places *)

Theorem Zrem_Zmod_zero : forall a b, b<>0 ->
 (Z.rem a b = 0 <-> a mod b = 0).
Proof.
 intros.
 rewrite Zrem_divides, Zmod_divides; intuition.
Qed.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* EXAMPLE FOR SECTION 6.2.1                                             *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.

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

Import ListNotations.
Open Scope list_scope.

Inductive nt: Type:= | S' | A | B.
Inductive t: Type:= | a | b.
Inductive rs: nt -> list (nt + t) -> Prop:=
  r1: rs S' [inr a; inl S']
| r2: rs S' [inr b].

Notation sf:= (list (nt + t)).
Notation nlist:= (list nt).
Notation tlist:= (list t).

Lemma rs_finite:
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In S' ntl /\
forall left: nt,
forall right: sf,
rs left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: nt, In (inl s) right -> In s ntl) /\
(forall s: t, In (inr s) right -> In s tl).
Proof.
exists 2, [S'], [a; b].
split.
- simpl; left; reflexivity.
- intros left right H.
  inversion H.
  + simpl.
    split.
    * omega.
    * {
      split.
      - left; reflexivity.
      - split.
        + intros s H2.
          destruct H2 as [H2 | H2].
          * inversion H2.
          * {
            destruct H2 as [H2 | H2].
            - left; inversion H2. reflexivity.
            - contradiction.
            }
        + intros s H2.
          destruct H2 as [H2 | H2].
          * inversion H2. left; reflexivity.
          * {
            destruct H2 as [H2 | H2].
            - inversion H2.
            - contradiction.
            }
      }
  + simpl. split.
    * omega.
    * {
      split.
      - left; reflexivity.
      - split.
        + intros s H2. destruct H2 as [H2 | H2].
          * inversion H2.
          * contradiction.
        + intros s H2.
          destruct H2 as [H2 | H2].
          * inversion H2. right; left; reflexivity.
          * contradiction.
      }
Qed.

Definition g: cfg nt t:= {|
start_symbol:= S';
rules:= rs;
rules_finite:= rs_finite |}.