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

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

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

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem len_append: forall (l1 l2: lst), len (append l1 l2) = plus (len l1) (len l2).
Proof.
  induction l1; induction l2; simpl.
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { reflexivity. }
  { reflexivity. }
Qed.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem len_rev: forall (l: lst), len (rev l) = len l.
Proof.
  induction l; simpl.
  +
    rewrite len_append.
lfind.  simpl.  f_equal.  assumption.
Admitted.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (rev (append x y))) (plus (len x) (len y)).
Proof.
  intros.
  rewrite len_rev.
  apply len_append.
Qed.


(**
 CoqTL user theorem: Table_name_uniqueness
 Def: if all classes in the source model have unique name,
      then the target tables generated in the target model
      have unique name.
 **)

Require Import Coq.Arith.Gt.
Require Import Coq.Arith.EqNat.
Require Import List.
Require Import String.
Require Import core.utils.Utils.

(*Require Import core.Semantics.
Require Import core.Certification.*)
Require Import core.Semantics.
Require Import core.Certification.
Require Import core.modeling.ModelingMetamodel.
Require Import core.Model.

Require Import transformations.Class2Relational.Class2Relational.
Require Import transformations.Class2Relational.ClassMetamodel.
Require Import transformations.Class2Relational.RelationalMetamodel.

Theorem Table_name_uniqueness:
forall (cm : ClassModel) (rm : RelationalModel),
(* transformation *)
    rm = execute Class2Relational cm ->
(* precondition *)
(forall (c1: Class) (c2: Class),
    In (ClassMetamodel_toObject ClassClass c1) (allModelElements cm) ->
    In (ClassMetamodel_toObject ClassClass c2) (allModelElements cm) ->
    c1 <> c2 ->
    getClassName c1 <> getClassName c2) ->
(* postcondition *)
(forall (t1: Table) (t2: Table),
    In (RelationalMetamodel_toObject TableClass t1) (allModelElements rm) ->
    In (RelationalMetamodel_toObject TableClass t2) (allModelElements rm) ->
    t1 <> t2 ->
    getTableName t1 <> getTableName t2).
Proof.
    intros.
    rewrite H in H1, H2.
    rewrite (tr_execute_in_elements Class2Relational) in H1, H2.
    do 2 destruct H1, H2.
    destruct x, x0.
    - (* [] [] *) contradiction H4.
    - (* [] [x::_] *) contradiction H4.
    - (* [x::_] [] *) contradiction H5.
    - (* [x::_] [y::_] *) destruct x, x0.
        + (* [x] [y] *) do 2 destruct c, c0.
            * (*[c] [c]*) specialize (H0 c1 c2).
                apply allTuples_incl in H1.
                apply allTuples_incl in H2.
                unfold incl in H1, H2.
                specialize (H1 (ClassMetamodel_toObject ClassClass c1)).
                specialize (H2 (ClassMetamodel_toObject ClassClass c2)).
                assert (In (ClassMetamodel_toObject ClassClass c1) [ClassMetamodel_toObject ClassClass c1]).
                { left. reflexivity. }
                assert (In (ClassMetamodel_toObject ClassClass c2) [ClassMetamodel_toObject ClassClass c2]).
                { left. reflexivity. }
                specialize (H0 (H1 H6)).
                specialize (H0 (H2 H7)).
                simpl in H4, H5.
                destruct H4, H5.
                -- apply rel_invert in H4.
                   apply rel_invert in H5.
                   rewrite <- H4.
                   rewrite <- H5.
                   apply H0.
                   rewrite <- H4 in H3.
                   rewrite <- H5 in H3.
                   destruct c1, c2.
                   simpl in H3.
                   unfold not.
                   intros.
                   unfold not in H3.
                   inversion H8.
                   rewrite H10 in H3.
                   rewrite H11 in H3.
                   contradiction.
                -- contradiction.
                -- contradiction.
                -- contradiction.
            * (*[c] [a]*) destruct c2. destruct b.
                -- contradiction.
                -- simpl in H5. destruct H5. inversion H5. contradiction.
            * (*[a] [c]*) destruct c1. destruct b.
                -- contradiction.
                -- simpl in H4. destruct H4. inversion H4. contradiction.
            * (*[a] [a]*) destruct c1. destruct b.
                -- contradiction.
                -- simpl in H4. destruct H4. inversion H4. contradiction.
        + (* [x] [y;y';_] *)
            do 2 destruct c0, c1.
            * contradiction.
            * contradiction.
            * contradiction.
            * contradiction.
        + (* [x;x';_] [y] *)
            do 2 destruct c, c1.
            * contradiction.
            * contradiction.
            * contradiction.
            * contradiction.
        + (* [x;x';_] [y;y';_] *)
            do 2 destruct c, c1.
            * contradiction.
            * contradiction.
            * contradiction.
            * contradiction.
Qed.


Set Warnings "-notation-overridden".

From Coq Require Extraction ZArith.

Module Classes.

Class Opr (A : Type) : Type := opr : A -> A -> A.
Class Idn (A : Type) : Type := idn : A.
Class Inv (A : Type) : Type := inv : A -> A.
Class Add (A : Type) : Type := add : A -> A -> A.
Class Zero (A : Type) : Type := zero : A.
Class Neg (A : Type) : Type := neg : A -> A.
Class Mul (A : Type) : Type := mul : A -> A -> A.
Class One (A : Type) : Type := one : A.
Class Recip (A : Type) : Type := recip : A -> A.

Notation "x '+' y" := (add x y).
Notation "'0'" := zero.
Notation "'-' x" := (neg x).
Notation "x '-' y" := (x + (- y)).
Notation "x '*' y" := (mul x y).
Notation "'1'" := one.
Notation "'/' x" := (recip x).
Notation "x '/' y" := (x * (/ y)).

Module AdditiveNotations.

Notation "x '+' y" := (opr x y).
Notation "'0'" := idn.
Notation "'-' x" := (inv x).
Notation "x '-' y" := (x + (- y)).

End AdditiveNotations.

Module MultiplicativeNotations.

Notation "x '*' y" := (opr x y).
Notation "'1'" := idn.
Notation "'/' x" := (inv x).
Notation "x '/' y" := (x * (/ y)).

End MultiplicativeNotations.

Section Additive.

Import AdditiveNotations.

Class Semigroup (A : Type) {opr : Opr A} : Prop := {
  ass : forall x y z : A, (x + y) + z = x + (y + z);
}.

Class Monoid (A : Type) {opr : Opr A} {idn : Idn A} : Prop := {
  semigroup :> Semigroup A;
  idn_l : forall x : A, 0 + x = x;
  idn_r : forall x : A, x + 0 = x;
}.

Class Group (A : Type) {opr : Opr A} {idn : Idn A} {inv : Inv A} : Prop := {
  monoid :> Monoid A;
  inv_l : forall x : A, (- x) + x = 0;
  inv_r : forall x : A, x + (- x) = 0;
}.

End Additive.

Class Ring (A : Type) {add : Add A} {zero : Zero A} {neg : Neg A}
  {mul : Mul A} {one : One A} : Prop := {
  add_group :> Group A (opr := add) (idn := zero) (inv := neg);
  add_com : forall x y : A, x + y = y + x;
  mul_monoid :> Monoid A (opr := mul) (idn := one);
  dis_l : forall x y z : A, x * (y + z) = x * y + x * z;
  dis_r : forall x y z : A, (x + y) * z = x * z + y * z;
}.

End Classes.

Module Properties.

Import Classes AdditiveNotations.

Theorem ivl : forall {A : Type}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x : A, - (- x) = x.
Proof.
  intros A opr idn inv grp x.
  destruct grp as [[[pa] pnl pnr] pvl pvr].
  rewrite <- (pnr (- (- x))). rewrite <- (pvl x).
  rewrite <- (pa (- (- x)) (- x) x). rewrite (pvl (- x)). rewrite (pnl x).
  reflexivity. Qed.

Lemma inj_l : forall {A : Type}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, z + x = z + y -> x = y.
Proof.
  intros A opr idn inv grp x y z p.
  destruct grp as [[[pa] pnl pnr] pvl pvr].
  rewrite <- (pnl x). rewrite <- (pvl z). rewrite (pa (- z) z x).
  rewrite p. rewrite <- (pa (- z) z y). rewrite (pvl z). rewrite (pnl y).
  reflexivity. Qed.

Lemma inj_r : forall {A : Type}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, x + z = y + z -> x = y.
Proof.
  intros A opr idn inv grp x y z p.
  destruct grp as [[[pa] pnl pnr] pvl pvr].
  rewrite <- (pnr x). rewrite <- (pvr z). rewrite <- (pa x z (- z)).
  rewrite p. rewrite (pa y z (- z)). rewrite (pvr z). rewrite (pnr y).
  reflexivity. Qed.

Theorem dis : forall {A : Type}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y : A, - (y + x) = (- x) + (- y).
Proof.
  intros A opr idn inv grp x y.
  apply (inj_l (- (y + x)) ((- x) + (- y)) (y + x)).
  destruct grp as [[[pa] pnl pnr] pvl pvr].
  rewrite (pvr (y + x)). rewrite <- (pa (y + x) (- x) (- y)).
  rewrite (pa y x (- x)). rewrite (pvr x). rewrite (pnr y). rewrite (pvr y).
  reflexivity. Qed.

End Properties.

Module Instances.

Import ZArith Z Classes.

Open Scope Z_scope.

Instance Z_AddOpr : Opr Z := fun x y : Z => x + y.

Instance Z_AddSemigroup : Semigroup Z := {
  ass := _;
}.
Proof.
  all: cbv [opr].
  all: cbv [Z_AddOpr].
  - intros x y z. rewrite add_assoc. reflexivity. Qed.

Instance Z_AddIdn : Idn Z := 0.

Instance Z_AddMonoid : Monoid Z := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [opr idn].
  all: cbv [Z_AddOpr Z_AddIdn].
  - intros x. rewrite add_0_l. reflexivity.
  - intros x. rewrite add_0_r. reflexivity. Qed.

Instance Z_AddInv : Inv Z := fun x => - x.

Instance Z_AddGroup : Group Z := {
  inv_l := _; inv_r := _;
}.
Proof.
  all: cbv [opr idn inv].
  all: cbv [Z_AddOpr Z_AddIdn Z_AddInv].
  - intros x. rewrite add_opp_diag_l. reflexivity.
  - intros x. rewrite add_opp_diag_r. reflexivity. Qed.

Instance Z_MulOpr : Opr Z := fun x y : Z => x * y.

Instance Z_MulSemigroup : Semigroup Z := {
  ass := _;
}.
Proof.
  all: cbv [opr].
  all: cbv [Z_MulOpr].
  - intros x y z. rewrite mul_assoc. reflexivity. Qed.

Instance Z_MulIdn : Idn Z := 1.

Instance Z_MulMonoid : Monoid Z := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [opr idn].
  all: cbv [Z_MulOpr Z_MulIdn].
  - intros x. rewrite mul_1_l. reflexivity.
  - intros x. rewrite mul_1_r. reflexivity. Qed.

Instance Z_Add : Add Z := Z_AddOpr.
Instance Z_Zero : Zero Z := Z_AddIdn.
Instance Z_Neg : Neg Z := Z_AddInv.
Instance Z_Mul : Mul Z := Z_MulOpr.
Instance Z_One : One Z := Z_MulIdn.

Instance Z_Ring : Ring Z := {
  add_com := _;
  dis_l := _; dis_r := _;
}.
Proof.
  all: cbv [add zero neg mul one].
  all: cbv [Z_Add Z_Zero Z_Neg Z_Mul Z_One].
  all: cbv [Z_AddOpr Z_AddIdn Z_AddInv Z_MulOpr Z_MulIdn].
  - intros x y. rewrite add_comm. reflexivity.
  - intros x y z. rewrite mul_add_distr_l. reflexivity.
  - intros x y z. rewrite mul_add_distr_r. reflexivity. Qed.

End Instances.

Module Computations.

Section Input.

Import ZArith Z.

Open Scope Z_scope.

Definition meaning := 42.
Definition luck := 13.
Definition fortune := 7.

End Input.

Section Output.

Import Classes.

Example fate := meaning * fortune - luck.

End Output.

End Computations.

Extraction "example.ml" Classes Properties Instances Computations.


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

Require Import HoTT.Basics.
Require Import Types.Empty Types.Unit.
Local Open Scope path_scope.

Generalizable Variables X A B f g n.

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

(** ** Unpacking *)

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

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

Arguments unpack_prod / .

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

Arguments pack_prod / .

(** ** Eta conversion *)

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

Arguments eta_prod / .

(** ** Paths *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(** Path algebra *)

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

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

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

(** ** Transport *)

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

(** ** Functorial action *)

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

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

(** ** Equivalences *)

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

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

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

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

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

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

(** ** Logical equivalences *)

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

(** ** Symmetry *)

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

Definition equiv_prod_symm (A B : Type) : A * B <~> B * A
  := Build_Equiv
       _ _ _
       (Build_IsEquiv
          (A*B) (B*A)
          (fun ab => (snd ab, fst ab))
          (fun ba => (snd ba, fst ba))
          (fun _ => 1)
          (fun _ => 1)
          (fun _ => 1)).

(** ** Associativity *)

(** This, too, is a special property of [prod], of course, not an instance of a general family of facts about types. *)
Definition equiv_prod_assoc (A B C : Type) : A * (B * C) <~> (A * B) * C
  := Build_Equiv
       _ _ _
       (Build_IsEquiv
          (A * (B * C)) ((A * B) * C)
          (fun abc => ((fst abc, fst (snd abc)), snd (snd abc)))
          (fun abc => (fst (fst abc), (snd (fst abc), snd abc)))
          (fun _ => 1)
          (fun _ => 1)
          (fun _ => 1)).

(** ** Unit and annihilation *)

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

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

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

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

(** ** Universal mapping properties *)

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

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

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

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

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

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

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

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

(** ** Products preserve truncation *)

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

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

(** ** Decidability *)

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

(** Interaction of ap and uncurry *)

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


Require Import Merges.Tactics.

Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.

Section Index.
 Variable A : Type.
 Hypothesis Heqdec : forall (a b : A), {a = b} + {a <> b}.

 Fixpoint index_of (x : A) (vs : list A) : option nat
  := match vs with
     | []    => None
     | v::vs' => if   Heqdec x v
                 then Some 0
                 else match index_of x vs' with
                      | None   => None
                      | Some n => Some (S n)
                      end
     end.

 Lemma index_of__lt_length: forall a xs res,
       index_of a xs = Some res ->
       res < length xs.
 Proof.
  induction xs; intros.
   - inversion H.
   - simpl in H.
     destruct (Heqdec a a0).
     + inverts H. simpl. omega.
     + simpl.
       destruct (index_of a xs).
       assert (n0 < length xs). apply IHxs. reflexivity.
       inverts H. omega.
       inverts H.
 Qed.

 Lemma index_of__nth: forall a xs res d,
       index_of a xs = Some res ->
       nth res xs d = a.
 Proof.
  induction xs; intros.
   - inversion H.
   - simpl in H.
     destruct (Heqdec a a0).
     + inverts~ H.
     + destruct (index_of a xs); inverts H.
       applys~ IHxs.
 Qed.

 Lemma index_of__not_In: forall a xs,
       index_of a xs = None ->
       ~ In a xs.
 Proof.
  induction xs; unfold not; intros.
   - inversion H0.
   - simpl in *.
     inverts H0.
     destruct (Heqdec a a).
     inverts H.
     apply~ n.

     destruct (Heqdec a a0).
     inverts H.
     destruct (index_of a xs).
     inverts H.
     apply~ IHxs.
 Qed.

 Lemma In__index_of: forall a xs,
       In a xs ->
       exists n, index_of a xs = Some n.
 Proof.
  induction xs; intros.
   - inversion H.
   - simpl in *.
     inverts H.
      destruct (Heqdec a a). eauto.
      destruct n. eauto.
     apply IHxs in H0.
     destruct H0.
     rewrite H.
     destruct (Heqdec a a0); eauto.
 Qed.

End Index.


Require Import Tactics.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.

Definition letnext {object} m n : term object :=
  subst1 (prev m) n.

Definition sumtype {object} a b : term object :=
  sigma booltp (bite (var 0) (subst sh1 a) (subst sh1 b)).

Definition sumleft {object} m : term object :=
  ppair btrue m.

Definition sumright {object} m : term object :=
  ppair bfalse m.

Definition sumcase {object} m n p : term object :=
  bite (ppi1 m) (subst1 (ppi2 m) n) (subst1 (ppi2 m) p).

Definition nattp {object} : term object :=
  mu (sumtype unittp (var 0)).

Definition nzero {object} : term object :=
  sumleft triv.

Definition nsucc {object} m : term object :=
  sumright m.

Definition theta {object} : term object :=
  app
    (lam (lam (app (var 0) (app (app (var 1) (var 1)) (var 0)))))
    (lam (lam (app (var 0) (app (app (var 1) (var 1)) (var 0))))).

Definition wind {object} f : term object :=
  app theta
    (lam (lam (app
                 (app
                    (app
                       (subst (sh 2) f)
                       (ppi1 (var 0)))
                    (ppi2 (var 0)))
                 (lam (app (var 2) (app (ppi2 (var 1)) (var 0))))))).

Definition leqtp {object} : term object :=
  app theta
    (lam (lam (lam (sumcase
                      (var 1)
                      unittp
                      (sumcase
                         (var 1)
                         voidtp
                         (app (app (var 4) (var 1)) (var 0))))))).

Definition lttp {object} : term object :=
  lam (app (subst sh1 leqtp) (nsucc (var 0))).

Definition pagetp {object} := @nattp object.

Definition leqpagetp {object} m n : term object :=
  app (app leqtp m) n.

Definition ltpagetp {object} m n : term object :=
  app (app lttp m) n.

Definition squash {object} m : term object :=
  set unittp (subst sh1 m).

Definition intersect2 {object} (a b : @term object) :=
  intersect booltp (bite (var 0) (subst sh1 a) (subst sh1 b)).


Require Import Cantor Class Util SetoidClass Omega.

Instance SetoidSum{X Y}`{Setoid X, Setoid Y} : Setoid (X + Y) :=
  {|
    equiv := fun s1 s2 => match s1,s2 with
                          | inl x1, inl x2 => (x1 == x2)%type
                          | inr y1, inr y2 => (y1 == y2)%type
                          | _,_ => False
                          end
  |}.
Proof.
  split.
  intros [|]; reflexivity.
  intros [|] [|]; try tauto;
  intro; symmetry; auto.
  intros [|] [|] [|]; try tauto;
  intros H1 H2; rewrite H1; auto.
Defined.

Instance OrdSum X Y `{Ord X, Ord Y} : Ord (X + Y) :=
  {|
    lt := fun s1 s2 => match s1,s2 with
                       | inl _, inr _ => True
                       | inl x1, inl x2 => x1 << x2
                       | inr y1, inr y2 => y1 << y2
                       | _,_ => False
                       end
  |}.
Proof.
  intros [|] [|] [|] [|] G1 G2;
  simpl in G1, G2; try tauto; try discriminate;
  apply lt_morph; auto.
  intros [|]; apply lt_irref.
  intros [|] [|] [|]; try tauto; apply Class.lt_trans.
  intros [|] [|]; try tauto; simpl; apply lt_trich.
Defined.

Definition nat_to_sum : nat -> nat + nat :=
  fun n => if even n then inl (n/2) else inr (n/2).

Definition nat_from_sum : nat + nat -> nat :=
  fun s => match s with
           | inl n => (2*n)
           | inr n => S (2*n)
           end.

Lemma nat_sum_to_from : forall s, nat_to_sum (nat_from_sum s) = s.
Proof.
  intros []; unfold nat_to_sum, nat_from_sum.
  rewrite even_2k.
  rewrite half_2k; auto.
  rewrite odd_2k1.
  rewrite half_2k1; auto.
Qed.

Lemma nat_sum_from_to : forall n, nat_from_sum (nat_to_sum n) = n.
Proof.
  intro; unfold nat_from_sum, nat_to_sum.
  destruct (even n) eqn:G.
  destruct (even_half _ G) as [k Hk].
  rewrite <- Hk at 1.
  rewrite half_2k; auto.
  destruct (odd_half _ G) as [k Hk].
  rewrite <- Hk at 1.
  rewrite half_2k1; auto.
Qed.

Instance CDLOWOEPSum{X Y}`{Ord X, Ord Y}`{CDLOWOEP X, CDLOWOEP Y}
  : CDLOWOEP (OrdSum X Y) :=
  {| to_nat := fun s => match s with
                        | inl x => nat_from_sum (inl (to_nat x))
                        | inr y => nat_from_sum (inr (to_nat y))
                        end;
     from_nat := fun n => match nat_to_sum n with
                          | inl i => inl (from_nat i)
                          | inr j => inr (from_nat j)
                          end;
     mid := fun s1 s2 => match s1,s2 with
                         | inl x1, inl x2 => inl (mid x1 x2)
                         | inl x, inr y => inl (right x)
                         | inr y, inl x => inl (right x)
                         | inr y1, inr y2 => inr (mid y1 y2)
                         end;
     left := fun s => match s with
                      | inl x => inl (left x)
                      | inr y => inr (left y)
                      end;
     right := fun s => match s with
                       | inl x => inl (right x)
                       | inr y => inr (right y)
                       end
  |}.
Proof.
  intros [|] [|] G; simpl in G; try tauto.
  f_equal; f_equal.
  apply to_nat_morph; auto.
  f_equal; f_equal.
  apply to_nat_morph; auto.
  intro.
  destruct nat_to_sum eqn:G.
  rewrite to_from.
  rewrite <- G.
  apply nat_sum_from_to.
  rewrite to_from.
  rewrite <- G.
  apply nat_sum_from_to.
  intros [|]; rewrite nat_sum_to_from; simpl; apply from_to.
  intros [|] [|] [|] [|]; simpl; intros G1 G2; try tauto.
  apply mid_morph; auto.
  apply right_morph; auto.
  apply right_morph; auto.
  apply mid_morph; auto.
  intros [|] [|]; simpl; intro; try tauto.
  apply mid_lt_left; auto.
  apply right_lt.
  apply mid_lt_left; auto.
  intros [|] [|]; simpl; intro; try tauto.
  apply mid_lt_right; auto.
  apply mid_lt_right; auto.
  intros [|] [|]; simpl; intro; try tauto.
  apply left_morph; auto.
  apply left_morph; auto.
  intros [|]; simpl; apply left_lt.
  intros [|] [|]; simpl; intro; try tauto.
  apply right_morph; auto.
  apply right_morph; auto.
  intros [|]; simpl; apply right_lt.
Defined.

Instance SetoidProd{X Y}`{Setoid X, Setoid Y} : Setoid (X * Y) :=
  {|
    equiv := fun p1 p2 => fst p1 == fst p2 /\ snd p1 == snd p2
  |}.
Proof.
  split.
  intros [x y]; split; simpl; reflexivity.
  intros [x1 y1] [x2 y2]; simpl;
  intros [G1 G2]; split; symmetry; auto.
  intros [x1 y1] [x2 y2] [x3 y3]; simpl.
  intros [] []; split.
  rewrite H1; auto.
  rewrite H2; auto.
Defined.

Instance OrdProd X Y`{Ord X, Ord Y} : Ord (X * Y) :=
  {|
    lt := fun p1 p2 => fst p1 << fst p2 \/ (fst p1 == fst p2 /\ snd p1 << snd p2)
  |}.
Proof.
  intros [x1 y1] [x2 y2] [x3 y3] [x4 y4]; simpl.
  intros [] [] [|].
  left.
  exact (lt_morph _ _ _ _ H3 H5 H7).
  right; destruct H7; split.
  rewrite <- H3, <- H5; auto.
  exact (lt_morph _ _ _ _ H4 H6 H8).
  intros p [|[]].
  exact (lt_irref _ H3).
  exact (lt_irref _ H4).
  intros p1 p2 p3 [|[]] [|[]]; try tauto.
  left; exact (Class.lt_trans _ _ _ H3 H4).
  left; exact (lt_morph _ _ _ _ (reflexivity _) H4 H3).
  left.
  symmetry in H3.
  exact (lt_morph _ _ _ _ H3 (reflexivity _) H5).
  right; split.
  rewrite <- H5; auto.
  exact (Class.lt_trans _ _ _ H4 H6).
  intros; simpl.
  destruct (lt_trich (fst x) (fst y)) as [[|]|].
  tauto.
  destruct (lt_trich (snd x) (snd y)) as [[|]|].
  tauto.
  tauto.
  symmetry in e; tauto.
  tauto.
Defined.

Definition next_pair(p : nat * nat) : nat * nat :=
  match p with
  |(x,0)   => (0,S x)
  |(x,S y) => (S x,y)
  end.

Fixpoint iter{X}(f : X -> X)(n : nat)(x0 : X) : X :=
  match n with
  |0   => x0
  |S m => f (iter f m x0)
  end.

Lemma iter_sum : forall {X}(f : X -> X)(n m : nat)(x0 : X),
  iter f (n + m) x0 = iter f n (iter f m x0).
Proof.
  intros.
  induction n.
  auto.
  simpl.
  rewrite IHn; auto.
Qed.

Definition to_pair : nat -> nat * nat :=
  fun n => iter next_pair n (0,0).

Fixpoint triangle(n : nat) : nat :=
  match n with
  |0   => 0
  |S m => n + (triangle m)
  end.

Definition from_pair(p : nat * nat) : nat :=
  let (x,y) := p in (triangle (x+y) + x).

Lemma next_pair_lemma : forall x y, y <= x -> iter next_pair y (0,x) = (y,x - y).
Proof.
  intro x; induction y; intro.
  inversion H; reflexivity.
  simpl.
  assert (y <= x).
  omega.
  rewrite (IHy H0).
  simpl.
  destruct (x - y) eqn:G.
  omega.
  destruct x.
  omega.
  simpl.
  assert (S x - y = S (x - y)).
  omega.
  rewrite H1 in G.
  inversion G.
  reflexivity.
Qed.

Lemma pair_num : forall x, to_pair (from_pair (0,x)) = (0,x).
Proof.
  unfold from_pair.
  simpl.
  intro x.
  rewrite <- plus_n_O.
  induction x.
  reflexivity.
  assert (triangle (S x) = (S x) + triangle x).
  reflexivity.
  rewrite H.
  unfold to_pair.
  rewrite iter_sum.
  unfold to_pair in IHx.
  rewrite IHx.
  simpl.
  assert (iter next_pair x (0,x) = (x,0)).
  assert (x <= x).
  omega.
  pose (next_pair_lemma _ _ H0).
  rewrite e.
  assert (x - x = 0).
  omega.
  rewrite H1; reflexivity.
  rewrite H0.
  reflexivity.
Qed.

Lemma tp_fp_correct : forall p, to_pair (from_pair p) = p.
Proof.
  unfold to_pair, from_pair.
  destruct p.
  rewrite plus_comm.
  rewrite iter_sum.
  pose (pair_num (n + n0)).
  unfold to_pair, from_pair in e.
  simpl in e.
  rewrite <- plus_n_O in e.
  rewrite e.
  assert (n <= n + n0).
  omega.
  pose (next_pair_lemma _ _ H).
  rewrite e0.
  assert (n + n0 - n = n0).
  omega.
  congruence.
Qed.

Lemma fp_tp_correct : forall n, from_pair (to_pair n) = n.
Proof.
  unfold from_pair, to_pair.
  induction n.
  reflexivity.
  simpl.
  destruct (iter next_pair n (0,0)) eqn:G.
  simpl.
  destruct n1.
  simpl.
  rewrite <- plus_n_O.
  rewrite <- plus_n_O in IHn.
  omega.
  simpl.
  simpl in IHn.
  rewrite <- plus_n_Sm in IHn.
  simpl in IHn.
  omega.
Qed.

Definition nat_to_prod := to_pair.
Definition nat_from_prod := from_pair.

Opaque nat_to_prod.
Opaque nat_from_prod.

Lemma nat_prod_to_from : forall p, nat_to_prod (nat_from_prod p) = p.
Proof.
  exact tp_fp_correct.
Qed.

Lemma nat_prod_from_to : forall n, nat_from_prod (nat_to_prod n) = n.
Proof.
  exact fp_tp_correct.
Qed.

Instance CDLOWOEPProd{X Y}`{Ord X, Ord Y}`{CDLOWOEP X, CDLOWOEP Y}
  : CDLOWOEP (OrdProd X Y) :=
  {|
    to_nat := fun p => nat_from_prod (to_nat (fst p), to_nat (snd p));
    from_nat := fun n => let p := nat_to_prod n in (from_nat (fst p), from_nat (snd p));
    mid := fun p1 p2 => if Class.dec_eq (fst p1) (fst p2) then (fst p1,mid (snd p1) (snd p2)) else (mid (fst p1) (fst p2), mid (snd p1) (snd p2));
    left := fun p => (fst p, left (snd p));
    right := fun p => (fst p, right (snd p))
  |}.
Proof.
  simpl; unfold fst, snd.
  intros [] []; intros [G1 G2].
  f_equal; f_equal; apply to_nat_morph; auto.
  simpl.
  intro; rewrite to_from.
  unfold fst,snd.
  destruct (nat_to_prod n) eqn:G.
  rewrite to_from.
  rewrite <- G.
  apply nat_prod_from_to.
  intro;
  rewrite nat_prod_to_from.
  cbv zeta.
  split; unfold fst,snd; destruct x; apply from_to.
  intros.
  repeat destruct Class.dec_eq; try tauto.
  split.
  simpl fst.
  destruct H7; auto.
  simpl snd.
  destruct H7,H8.
  apply mid_morph; auto.
  elim n.
  destruct H7,H8.
  rewrite <- H7, <- H8; auto.
  elim n.
  destruct H7,H8.
  rewrite H7, H8; auto.
  destruct H7,H8; split.
  simpl fst; apply mid_morph; auto.
  simpl snd; apply mid_morph; auto.
  intros [] [] [|[]].
  destruct Class.dec_eq.
  simpl fst in H7,e.
  elim (lt_irref _ (@lt_morph _ _ _ _ _ _ _  e (reflexivity  _) H7)).
  left.
  simpl fst.
  simpl fst in H7.
  apply mid_lt_left; auto.
  destruct Class.dec_eq.
  clear e.
  right; simpl fst; simpl snd; split.
  reflexivity.
  apply mid_lt_left; auto.
  contradiction.
  intros [] [] [|[]].
  destruct Class.dec_eq.
  simpl fst in H7,e.
  elim (lt_irref _ (@lt_morph _ _ _ _ _ _ _ e (reflexivity _) H7)).
  simpl fst; simpl snd.
  left; simpl fst; apply mid_lt_right; auto.
  destruct Class.dec_eq.
  right; simpl fst; simpl snd; split.
  auto.
  apply mid_lt_right; auto.
  contradiction.
  intros; split; destruct H7.
  simpl fst; auto.
  simpl snd; apply left_morph; auto.
  intros.
  right; simpl fst; simpl snd; split.
  reflexivity.
  apply left_lt.
  intros; split; destruct H7; simpl fst; simpl snd.
  auto.
  apply right_morph; auto.
  intros.
  right; simpl fst; simpl snd; split.
  reflexivity.
  apply right_lt.
Defined.

Require Import QArith Qcountable Lia.

Instance Q_Ord : Ord Q :=
  {|
    lt := Qlt
  |}.
Proof.
  intros.
  rewrite <- H, <-H0; auto.
  exact Qlt_irrefl.
  exact Qlt_trans.
  Search _ Qlt.
  unfold Qlt.
  simpl.
  unfold Qeq.
  intros.
  pose (a := (Qnum x * QDen y)%Z).
  pose (b := (Qnum y * QDen x)%Z).
  fold a; fold b.
  destruct (Z_ge_lt_dec a b).
  destruct (Z.eq_dec a b).
  left; right; auto.
  right.
  lia.
  left; auto.
Defined.

Instance Q_CDLOWOEP : CDLOWOEP Q_Ord :=
  {|
    to_nat := Q_to_nat;
    from_nat := nat_to_Q;
    mid := fun x y => (x + y)/(2 # 1);
    left := fun x => x - 1;
    right := fun x => x + 1
  |}.
Proof.
  exact Q_to_nat_morph.
  exact Q_to_from.
  exact Q_from_to.
  intros.
  rewrite H,H0; reflexivity.
  simpl.
  intro.
  intros.
  assert (x == x / (2#1) + x / (2#1)).
  simpl.
  unfold Qeq.
  simpl.
  lia.
  rewrite H0 at 1.
  unfold Qdiv.
  rewrite Qmult_plus_distr_l.
  apply Qplus_lt_r.
  apply Qmult_lt_compat_r.
  unfold Qinv.
  simpl.
  unfold Qlt.
  simpl; lia.
  exact H.
  intros.
  assert (x' == x' / (2#1) + x' / (2#1)).
  simpl.
  unfold Qeq.
  simpl.
  lia.
  rewrite H0 at 2.
  unfold Qdiv.
  rewrite Qmult_plus_distr_l.
  apply Qplus_lt_l.
  apply Qmult_lt_compat_r.
  unfold Qinv.
  simpl.
  unfold Qlt.
  simpl; lia.
  exact H.
  intros.
  rewrite H; reflexivity.
  intro.
  simpl.
  unfold Qminus.
  Search _ Qplus Qlt.
  rewrite <- (Qplus_0_r x) at 2.
  repeat rewrite (Qplus_comm x).
  apply Qplus_lt_le_compat.
  unfold Qlt.
  simpl.
  lia.
  unfold Qle.
  lia.
  intros.
  rewrite H; reflexivity.
  intro.
  simpl.
  rewrite <- (Qplus_0_l x) at 1.
  rewrite (Qplus_comm x).
  apply Qplus_lt_le_compat.
  unfold Qlt.
  simpl.
  lia.
  unfold Qle.
  lia.
Defined.


Require Import proof.

Set Implicit Arguments.

(* x terminates / R is well-ordered under x / Acc with arguments flipped *)
Inductive Term (A : Type) (R : A -> A -> Prop) (x : A) : Prop :=
  Term_intro : (forall y : A, R x y -> Term R y) -> Term R x.

Section relations.
Variables (cfg : Set) (cstep : cfg -> cfg -> Prop).

CoInductive div_path k : Prop :=
  div_step : forall k', cstep k k' -> div_path k' -> div_path k.

(* Inductive predicate for reaching in finite time *)
Inductive ireaches (k : cfg) (P : cfg -> Prop) : Prop :=
  | idone : P k -> ireaches k P
  | istep : forall k', cstep k k' -> ireaches k' P -> ireaches k P.

Lemma reaches_terminating : forall k P, Term cstep k -> reaches cstep k P -> ireaches k P.
Proof. induction 1;destruct 1;eauto using ireaches. Qed.

Definition excluded_middle_termination x :=
  ~(forall y, cstep x y -> Term cstep y) -> exists y, cstep x y /\ ~Term cstep y.

Lemma diverging_reaches : (forall x, excluded_middle_termination x) ->
  forall k, ~Term cstep k -> forall P, reaches cstep k P.
intros H.
cofix.
intros.
destruct (H k).
contradict H0. constructor;assumption. destruct H1.
apply rstep with x.
assumption.
apply diverging_reaches. assumption.
Qed.

Definition dec_term k := Term cstep k \/ ~Term cstep k.

Lemma adequate_fwd : forall k, dec_term k -> forall P, reaches cstep k P -> ireaches k P \/ ~Term cstep k.
destruct 1;auto using reaches_terminating.
Qed.

Lemma adequate_rev : (forall k, excluded_middle_termination k) ->
         forall k P, ireaches k P \/ ~Term cstep k -> reaches cstep k P.
destruct 2.
induction H0;eauto using reaches.
auto using diverging_reaches.
Qed.
End relations.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 8: Operational Semantics
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.

(* OK, enough with defining transition relations manually.  Let's return to our
 * syntax of imperative programs from Chapter 3. *)

Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : arith)
| Minus (e1 e2 : arith)
| Times (e1 e2 : arith).

Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| If (e : arith) (then_ else_ : cmd)
| While (e : arith) (body : cmd).
(* Important differences: we added [If] and switched [Repeat] to general
 * [While]. *)

(* Here are some notations for the language, which again we won't really
 * explain. *)
Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
Infix "+" := Plus : arith_scope.
Infix "-" := Minus : arith_scope.
Infix "*" := Times : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75).
Infix ";;" := Sequence (at level 76). (* This one changed slightly, to avoid parsing clashes. *)
Notation "'when' e 'then' then_ 'else' else_ 'done'" := (If e%arith then_ else_) (at level 75, e at level 0).
Notation "'while' e 'loop' body 'done'" := (While e%arith body) (at level 75).

(* Here's an adaptation of our factorial example from Chapter 3. *)
Example factorial :=
  "output" <- 1;;
  while "input" loop
    "output" <- "output" * "input";;
    "input" <- "input" - 1
  done.

(* Recall our use of a recursive function to interpret expressions. *)
Definition valuation := fmap var nat.
Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Minus e1 e2 => interp e1 v - interp e2 v
  | Times e1 e2 => interp e1 v * interp e2 v
  end.

(* Our old trick of interpreters won't work for this new language, because of
 * the general "while" loops.  No such interpreter could terminate for all
 * programs.  Instead, we will use inductive predicates to explain program
 * meanings.  First, let's apply the most intuitive method, called
 * *big-step operational semantics*. *)
Inductive eval : valuation -> cmd -> valuation -> Prop :=
| EvalSkip : forall v,
  eval v Skip v
| EvalAssign : forall v x e,
  eval v (Assign x e) (v $+ (x, interp e v))
| EvalSeq : forall v c1 v1 c2 v2,
  eval v c1 v1
  -> eval v1 c2 v2
  -> eval v (Sequence c1 c2) v2
| EvalIfTrue : forall v e then_ else_ v',
  interp e v <> 0
  -> eval v then_ v'
  -> eval v (If e then_ else_) v'
| EvalIfFalse : forall v e then_ else_ v',
  interp e v = 0
  -> eval v else_ v'
  -> eval v (If e then_ else_) v'
| EvalWhileTrue : forall v e body v' v'',
  interp e v <> 0
  -> eval v body v'
  -> eval v' (While e body) v''
  -> eval v (While e body) v''
| EvalWhileFalse : forall v e body,
  interp e v = 0
  -> eval v (While e body) v.

(* Let's run the factorial program on a few inputs. *)
Theorem factorial_2 : exists v, eval ($0 $+ ("input", 2)) factorial v
                                /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.
  (* [eexists]: to prove [exists x, P(x)], switch to proving [P(?y)], for a new
   *   existential variable [?y]. *)

  econstructor.
  econstructor.
  econstructor.
  simplify.
  equality.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  simplify.
  equality.
  econstructor.
  econstructor.
  econstructor.
  apply EvalWhileFalse.
  (* Note that, for this step, we had to specify which rule to use, since
   * otherwise [econstructor] incorrectly guesses [EvalWhileTrue]. *)
  simplify.
  equality.

  simplify.
  equality.
Qed.

(* That was rather repetitive.  It's easy to automate. *)

Ltac eval1 :=
  apply EvalSkip || apply EvalAssign || eapply EvalSeq
  || (apply EvalIfTrue; [ simplify; equality | ])
  || (apply EvalIfFalse; [ simplify; equality | ])
  || (eapply EvalWhileTrue; [ simplify; equality | | ])
  || (apply EvalWhileFalse; [ simplify; equality ]).
Ltac evaluate := simplify; try equality; repeat eval1.

Theorem factorial_2_snazzy : exists v, eval ($0 $+ ("input", 2)) factorial v
                                       /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.
  evaluate.
  evaluate.
Qed.

Theorem factorial_3 : exists v, eval ($0 $+ ("input", 3)) factorial v
                                /\ v $? "output" = Some 6.
Proof.
  eexists; propositional.
  evaluate.
  evaluate.
Qed.

(* Instead of chugging through these relatively slow individual executions,
 * let's prove once and for all that [factorial] is correct. *)
Fixpoint fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => n * fact n'
  end.

Example factorial_loop :=
  while "input" loop
    "output" <- "output" * "input";;
    "input" <- "input" - 1
  done.

Lemma factorial_loop_correct : forall n v out, v $? "input" = Some n
  -> v $? "output" = Some out
  -> exists v', eval v factorial_loop v'
                /\ v' $? "output" = Some (fact n * out).
Proof.
  induct n; simplify.

  exists v; propositional.
  apply EvalWhileFalse.
  simplify.
  rewrite H.
  equality.
  rewrite H0.
  f_equal.
  ring.

  assert (exists v', eval (v $+ ("output", out * S n) $+ ("input", n)) factorial_loop v'
                     /\ v' $? "output" = Some (fact n * (out * S n))).
  apply IHn.
  simplify; equality.
  simplify; equality.
  first_order.
  eexists; propositional.
  econstructor.
  simplify.
  rewrite H.
  equality.
  econstructor.
  econstructor.
  econstructor.
  simplify.
  rewrite H, H0.
  replace (S n - 1) with n by linear_arithmetic.
  (* [replace e1 with e2 by tac]: replace occurrences of [e1] with [e2], proving
   *   [e2 = e1] with tactic [tac]. *)
  apply H1.
  rewrite H2.
  f_equal.
  ring.
Qed.

Theorem factorial_correct : forall n v, v $? "input" = Some n
  -> exists v', eval v factorial v'
                /\ v' $? "output" = Some (fact n).
Proof.
  simplify.
  assert (exists v', eval (v $+ ("output", 1)) factorial_loop v'
                     /\ v' $? "output" = Some (fact n * 1)).
  apply factorial_loop_correct.
  simplify; equality.
  simplify; equality.
  first_order.
  eexists; propositional.
  econstructor.
  econstructor.
  simplify.
  apply H0.
  rewrite H1.
  f_equal.
  ring.
Qed.

(** * Small-step semantics *)

(* Big-step semantics only tells us something about the behavior of terminating
 * programs.  Our imperative language clearly supports nontermination, thanks to
 * the inclusion of general "while" loops.  A switch to *small-step* semantics
 * lets us also explain what happens with nonterminating executions, and this
 * style will also come in handy for more advanced features like concurrency. *)

Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
| StepAssign : forall v x e,
  step (v, Assign x e) (v $+ (x, interp e v), Skip)
| StepSeq1 : forall v c1 c2 v' c1',
  step (v, c1) (v', c1')
  -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
| StepSeq2 : forall v c2,
  step (v, Sequence Skip c2) (v, c2)
| StepIfTrue : forall v e then_ else_,
  interp e v <> 0
  -> step (v, If e then_ else_) (v, then_)
| StepIfFalse : forall v e then_ else_,
  interp e v = 0
  -> step (v, If e then_ else_) (v, else_)
| StepWhileTrue : forall v e body,
  interp e v <> 0
  -> step (v, While e body) (v, Sequence body (While e body))
| StepWhileFalse : forall v e body,
  interp e v = 0
  -> step (v, While e body) (v, Skip).

(* Here's a small-step factorial execution. *)
Theorem factorial_2_small : exists v, step^* ($0 $+ ("input", 2), factorial) (v, Skip)
                                      /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.

  econstructor.
  econstructor.
  econstructor.
  econstructor.
  apply StepSeq2.
  econstructor.
  econstructor.
  simplify.
  equality.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  apply StepSeq2.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  apply StepSeq2.
  econstructor.
  econstructor.
  simplify.
  equality.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  apply StepSeq2.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  apply StepSeq2.
  econstructor.
  apply StepWhileFalse.
  simplify.
  equality.
  econstructor.

  simplify.
  equality.
Qed.

Ltac step1 :=
  apply TrcRefl || eapply TrcFront
  || apply StepAssign || apply StepSeq2 || eapply StepSeq1
  || (apply StepIfTrue; [ simplify; equality ])
  || (apply StepIfFalse; [ simplify; equality ])
  || (eapply StepWhileTrue; [ simplify; equality ])
  || (apply StepWhileFalse; [ simplify; equality ]).
Ltac stepper := simplify; try equality; repeat step1.

Theorem factorial_2_small_snazzy : exists v, step^* ($0 $+ ("input", 2), factorial) (v, Skip)
                                             /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.

  stepper.
  stepper.
Qed.

(* It turns out that these two semantics styles are equivalent.  Let's prove
 * it. *)

(* Automated proofs used here, if only to save time in class.
 * See book code for more manual proofs, too. *)

Local Hint Constructors trc step eval : core.

Theorem big_small : forall v c v', eval v c v'
  -> step^* (v, c) (v', Skip).
Proof.
Admitted.

Theorem small_big : forall v c v', step^* (v, c) (v', Skip)
                                   -> eval v c v'.
Proof.
Admitted.

(** * Small-step semantics gives rise to transition systems. *)

Definition trsys_of (v : valuation) (c : cmd) : trsys (valuation * cmd) := {|
  Initial := {(v, c)};
  Step := step
|}.

Theorem simple_invariant :
  invariantFor (trsys_of ($0 $+ ("a", 1)) ("b" <- "a" + 1;; "c" <- "b" + "b"))
               (fun s => snd s = Skip -> fst s $? "c" = Some 4).
Proof.
  model_check.
Qed.

Inductive isEven : nat -> Prop :=
| EvenO : isEven 0
| EvenSS : forall n, isEven n -> isEven (S (S n)).

Lemma isEven_minus2 : forall n, isEven n -> isEven (n - 2).
Proof.
  induct 1; simplify.

  constructor.

  replace (n - 0) with n by linear_arithmetic.
  assumption.
Qed.

Lemma isEven_plus : forall n m,
  isEven n
  -> isEven m
  -> isEven (n + m).
Proof.
  induct 1; simplify.

  assumption.

  constructor.
  apply IHisEven.
  assumption.
Qed.

Local Hint Constructors isEven : core.
Local Hint Resolve isEven_minus2 isEven_plus : core.

Definition my_loop :=
  while "n" loop
    "a" <- "a" + "n";;
    "n" <- "n" - 2
  done.

Theorem manually_proved_invariant : forall n,
  isEven n
  -> invariantFor (trsys_of ($0 $+ ("n", n) $+ ("a", 0)) (while "n" loop "a" <- "a" + "n";; "n" <- "n" - 2 done))
               (fun s => exists a, fst s $? "a" = Some a /\ isEven a).
Proof.
Admitted.

Definition all_programs := {
  (while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),
  ("a" <- "a" + "n";;
   "n" <- "n" - 2),
  (Skip;;
   "n" <- "n" - 2),
  ("n" <- "n" - 2),
  (("a" <- "a" + "n";;
    "n" <- "n" - 2);;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),
  ((Skip;;
    "n" <- "n" - 2);;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),
  ("n" <- "n" - 2;;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),
  (Skip;;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),
  Skip
}.

Lemma manually_proved_invariant' : forall n,
  isEven n
  -> invariantFor (trsys_of ($0 $+ ("n", n) $+ ("a", 0)) (while "n" loop "a" <- "a" + "n";; "n" <- "n" - 2 done))
               (fun s => all_programs (snd s)
                         /\ exists n a, fst s $? "n" = Some n
                                        /\ fst s $? "a" = Some a
                                        /\ isEven n
                                        /\ isEven a).
Proof.
  simplify; apply invariant_induction; simplify; unfold all_programs in *; first_order; subst; simplify;
  try match goal with
      | [ H : step _ _ |- _ ] => invert H; simplify
      end;
  repeat (match goal with
          | [ H : _ = Some _ |- _ ] => rewrite H
          | [ H : @eq cmd (_ _ _) _ |- _ ] => invert H
          | [ H : @eq cmd (_ _ _ _) _ |- _ ] => invert H
          | [ H : step _ _ |- _ ] => invert2 H
          end; simplify); equality || eauto 7.
Qed.

(* We'll return to these systems and their abstractions in the next few
 * chapters. *)

(** * Contextual small-step semantics *)

(* There is a common way to factor a small-step semantics into different parts,
 * to make the semantics easier to understand and extend.  First, we define a
 * notion of *evaluation contexts*, which are commands with *holes* in them. *)
Inductive context :=
| Hole
| CSeq (C : context) (c : cmd).

(* This relation explains how to plug the hole in a context with a specific
 * term.  Note that we use an inductive relation instead of a recursive
 * definition, because Coq's proof automation is better at working with
 * relations. *)
Inductive plug : context -> cmd -> cmd -> Prop :=
| PlugHole : forall c, plug Hole c c
| PlugSeq : forall c C c' c2,
  plug C c c'
  -> plug (CSeq C c2) c (Sequence c' c2).

(* Now we define almost the same step relation as before, with one omission:
 * only the more trivial of the [Sequence] rules remains. *)
Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
| Step0Assign : forall v x e,
  step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
| Step0Seq : forall v c2,
  step0 (v, Sequence Skip c2) (v, c2)
| Step0IfTrue : forall v e then_ else_,
  interp e v <> 0
  -> step0 (v, If e then_ else_) (v, then_)
| Step0IfFalse : forall v e then_ else_,
  interp e v = 0
  -> step0 (v, If e then_ else_) (v, else_)
| Step0WhileTrue : forall v e body,
  interp e v <> 0
  -> step0 (v, While e body) (v, Sequence body (While e body))
| Step0WhileFalse : forall v e body,
  interp e v = 0
  -> step0 (v, While e body) (v, Skip).

(* We recover the meaning of the original with one top-level rule, combining
 * plugging of contexts with basic steps. *)
Inductive cstep : valuation * cmd -> valuation * cmd -> Prop :=
| CStep : forall C v c v' c' c1 c2,
  plug C c c1
  -> step0 (v, c) (v', c')
  -> plug C c' c2
  -> cstep (v, c1) (v', c2).

(* We can prove equivalence between the two formulations. *)

Local Hint Constructors plug step0 cstep : core.

Theorem step_cstep : forall v c v' c',
  step (v, c) (v', c')
  -> cstep (v, c) (v', c').
Proof.
Admitted.

Theorem cstep_step : forall v c v' c',
  cstep (v, c) (v', c')
  -> step (v, c) (v', c').
Proof.
Admitted.

(** * Determinism *)

(* Each of the relations we have defined turns out to be deterministic.  Let's
 * prove it. *)

Theorem eval_det : forall v c v1,
  eval v c v1
  -> forall v2, eval v c v2
  -> v1 = v2.
Proof.
  induct 1; invert 1; try first_order.

  apply IHeval2.
  apply IHeval1 in H5.
  subst.
  assumption.

  apply IHeval2.
  apply IHeval1 in H7.
  subst.
  assumption.
Qed.

Theorem step_det : forall s out1,
  step s out1
  -> forall out2, step s out2
  -> out1 = out2.
Proof.
  induct 1; invert 1; try first_order.

  apply IHstep in H5.
  equality.

  invert H.

  invert H4.
Qed.

Theorem cstep_det : forall s out1,
  cstep s out1
  -> forall out2, cstep s out2
  -> out1 = out2.
Proof.
  simplify.
  cases s; cases out1; cases out2.
  eapply step_det.
  apply cstep_step.
  eassumption.
  apply cstep_step.
  eassumption.
Qed.

(** * Example of how easy it is to add concurrency to a contextual semantics *)

(** At this point, we add concurrency to the code we already wrote above. *)

(*
(* Here's the classic cautionary-tale program about remembering to lock your
 * concurrent threads. *)
Definition prog :=
  ("a" <- "n";;
   "n" <- "a" + 1)
  || ("b" <- "n";;
      "n" <- "b" + 1).

Local Hint Constructors plug step0 cstep : core.

(* The naive "expected" answer is attainable. *)
Theorem correctAnswer : forall n, exists v, cstep^* ($0 $+ ("n", n), prog) (v, Skip)
                                            /\ v $? "n" = Some (n + 2).
Proof.
  eexists; propositional.
  unfold prog.

  econstructor.
  eapply CStep with (C := CPar1 (CSeq Hole _) _); eauto.

  econstructor.
  eapply CStep with (C := CPar1 Hole _); eauto.

  econstructor.
  eapply CStep with (C := CPar1 Hole _); eauto.

  econstructor.
  eapply CStep with (C := Hole); eauto.

  econstructor.
  eapply CStep with (C := CSeq Hole _); eauto.

  econstructor.
  eapply CStep with (C := Hole); eauto.

  econstructor.
  eapply CStep with (C := Hole); eauto.

  econstructor.

  simplify.
  f_equal.
  ring.
Qed.

(* But so is the "wrong" answer! *)
Theorem wrongAnswer : forall n, exists v, cstep^* ($0 $+ ("n", n), prog) (v, Skip)
                                          /\ v $? "n" = Some (n + 1).
Proof.
  eexists; propositional.
  unfold prog.
Admitted.
*)


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype.
Require Import finfun ssralg bigops groups group_perm signperm.

(* Require Import div connect finset zp. *)

Import GroupScope.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Reserved Notation "\matrix_ ( i , j ) E"
  (at level 36, E at level 36, i, j at level 50,
   format "\matrix_ ( i ,  j )  E").
Reserved Notation "\matrix_ ( i < m , j < n ) E"
  (at level 36, E at level 36, i, m, j, n at level 50,
   format "\matrix_ ( i  <  m ,  j  <  n )  E").
Reserved Notation "\matrix_ ( i , j < n ) E"
  (at level 36, E at level 36, i, j, n at level 50,
   format "\matrix_ ( i ,  j  <  n )  E").

Reserved Notation "''M_' n"       (at level 8, n at level 2, format "''M_' n").
Reserved Notation "''M_' ( m , n )" (at level 8, format "''M_' ( m ,  n )").
Reserved Notation "''M_' ( n )"   (at level 8, only parsing).

Reserved Notation "\0_ n"         (at level 8, n at level 2, format "\0_ n").
Reserved Notation "\0_ ( m , n )" (at level 8, format "\0_ ( m ,  n )").
Reserved Notation "\0_ ( n )"     (at level 8, only parsing).
Reserved Notation "\0"            (at level 8, format "\0").
Reserved Notation "\1_ n"         (at level 8, n at level 2, format "\1_ n").
Reserved Notation "\1"            (at level 8, format "\1").
Reserved Notation "\Z_ n x"       (at level 10, n at level 2, x at level 8,
                                   format "\Z_ n  x").
Reserved Notation "\Z x"          (at level 10, x at level 8, format "\Z  x").
Reserved Notation "\P s"          (at level 10, s at level 8, format "\P  s").

Reserved Notation "A +m B"    (at level 50, format "A  +m  B").
Reserved Notation "x *s A"    (at level 40, format "x  *s  A").
Reserved Notation "A *m B"    (at level 40, format "A  *m  B").
Reserved Notation "\^t A"     (at level 10, A at level 8, format "\^t  A").
Reserved Notation "\tr A"     (at level 10, A at level 8, format "\tr  A").
Reserved Notation "\det A"    (at level 10, A at level 8, format "\det  A").
Reserved Notation "\adj A"    (at level 10, A at level 8, format "\adj  A").

Delimit Scope matrix_scope with MX.

Import Ring.
Notation Local simp := (Monoid.Equations.simpm, oppr0).

Open Scope ring_scope.
Open Scope matrix_scope.

Section MatrixDef.

Variable R : basic. (* commutative_. *)
Variables m n : nat.

(* Basic linear algebra (matrices).                                       *)
(*   We use dependent types (ordinals) for the indices so that ranges are *)
(* mostly inferred automatically; we may have to reconsider this design   *)
(* if it proves too unwieldly for block decomposition theory.             *)

CoInductive matrix : predArgType := Matrix of {ffun 'I_m * 'I_n -> R}.

Notation "''M_' ( m , n )" := (matrix m n).
Notation "''M_' ( n )" := 'M_(n, n).
Notation "''M_' n" := 'M_(n).

Definition matrix_val A := let: Matrix g := A in g.

Lemma can_matrix_val : cancel matrix_val Matrix. Proof. by case. Qed.

Canonical Structure matrix_eqType := CanEqType can_matrix_val.

Definition matrix_of_fun F := locked Matrix [ffun ij => F ij.1 ij.2].

Definition fun_of_matrix := locked (fun A i j => matrix_val A (i, j)).

Coercion fun_of_matrix  : matrix >-> Funclass.

Lemma mxK : forall F, matrix_of_fun F =2 F.
Proof. by unlock matrix_of_fun fun_of_matrix => F i j; rewrite /= ffunE. Qed.

Lemma matrixP : forall A B : matrix, A =2 B <-> A = B.
Proof.
unlock fun_of_matrix => [] [A] [B]; split=> [/= eqAB | -> //].
congr Matrix; apply/ffunP=> [] [i j]; exact: eqAB.
Qed.

End MatrixDef.

Open Scope matrix_scope.

Notation "\matrix_ ( i < m , j < n ) E" :=
  (@matrix_of_fun _ m n (fun i j => E)) (only parsing) : matrix_scope.

Notation "\matrix_ ( i , j < n ) E" :=
  (\matrix_(i < n, j < n) E) (only parsing) : matrix_scope.

Notation "\matrix_ ( i , j ) E" := (\matrix_(i < _, j < _) E) : matrix_scope.

(* Definition of operations for matrix over a ring *)
Section MatrixOpsDef.

Variable R : Ring.basic.

Notation Local "''M_' ( m , n )" := (matrix R m n) : type_scope.
Notation Local "''M_' ( n )" := 'M_(n, n) : type_scope.
Notation Local "''M_' n" := 'M_(n) : type_scope.

Definition addmx m n (A B : 'M_(m, n)) :=
  \matrix_(i, j) (A i j + B i j).

Definition scalemx m n x (A : 'M_(m, n)) := \matrix_(i, j) (x * A i j).

Definition mulmx m n p (A : 'M_(m, n)) (B : 'M_(n, p)) :=
  \matrix_(i, k) \sum_j (A i j * B j k).

Definition null_mx m n : 'M_(m, n) := \matrix_(i, j) 0.

Definition scalar_mx n x : 'M_n :=
  \matrix_(i, j) (if i == j then x else 0).

Definition unit_mx n := scalar_mx n 1.

Definition mx_row m n i0 (A : 'M_(m, n)) := \matrix_(i < 1, j < n) A i0 j.

Definition mx_col m n j0 (A : 'M_(m, n)) := \matrix_(i < m, j < 1) A i j0.

Definition mx_rem_row m n i0 (A : 'M_(m, n)) :=
  \matrix_(i, j) A (lift i0 i) j.

Definition mx_rem_col m n j0 (A : 'M_(m, n)) :=
  \matrix_(i, j) A i (lift j0 j).

(* The shape of the (dependent) height parameter determines where *)
(* the cut is made! *)

Definition mx_lcut m1 m2 n (A : 'M_(m1 + m2, n)) :=
  \matrix_(i, j) A (lshift m2 i) j.

Definition mx_rcut m1 m2 n (A : 'M_(m1 + m2, n)) :=
  \matrix_(i, j) A (rshift m1 i) j.

Definition mx_paste m1 m2 n (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) :=
   \matrix_(i, j) match split i with inl i1 => A1 i1 j | inr i2 => A2 i2 j end.

Definition trmx m n (A : 'M_(m, n)) := \matrix_(i, j) A j i.

Definition perm_mx n (s : 'S_n) : 'M_n :=
   \matrix_(i, j) (if s i == j then 1 else 0).

(* The trace, in 1/4 line. *)
Definition mx_trace n (A : 'M_n) := \sum_i (A i i).

(* The determinants, in one line. *)
Definition determinant n (A : 'M_n) :=
 \sum_(s : 'S_n) (-1)^+s * \prod_i A i (s i).

Notation Local "'\det' A" := (determinant A).
Notation Local row' := mx_rem_row.
Notation Local col' := mx_rem_col.

(* And now, the Laplace formula. *)

Definition cofactor n (A : 'M_n) (i j : 'I_n) :=
   (-1) ^+(i + j) * \det (row' i (col' j A)).

(* The final flurry: adjugates. *)

Definition adjugate n (A : 'M_n) := \matrix_(i, j) (cofactor A j i).

End MatrixOpsDef.

Notation "\0_ ( m , n )" := (null_mx _ m n) (only parsing) : matrix_scope.
Notation "\0_ ( n )" := \0_(n, n) (only parsing) : matrix_scope.
Notation "\0_ n" := \0_(n) (only parsing) : matrix_scope.
Notation "\0" := \0_(_, _) : matrix_scope.
Notation "\1_ n" := (unit_mx _ n) (only parsing) : matrix_scope.
Notation "\1" := \1_(_) : matrix_scope.
Notation "\Z_ n x" := (scalar_mx n x) (only parsing) : matrix_scope.
Notation "\Z x" := (\Z_(_) x) : matrix_scope.
Notation "\P s" := (perm_mx _ s) : matrix_scope.
Notation "A +m B" := (addmx A B) : matrix_scope.
Notation "x *s A" := (scalemx x A) : matrix_scope.
Notation "A *m B" := (mulmx A B) : matrix_scope.
Notation "\^t A" := (trmx A) : matrix_scope.

Notation "'\tr' A" := (mx_trace A) : ring_scope.
Notation "'\det' A" := (determinant A) : ring_scope.
Notation "'\adj' A" := (adjugate A) : ring_scope.

Section MatrixOnRingProp.
Variable R : Ring.basic.

Notation Local "''M_' ( m , n )" := (matrix R m n) : type_scope.
Notation Local "''M_' ( n )" := 'M_(n, n) : type_scope.
Notation Local "''M_' n" := 'M_(n) : type_scope.
Notation Local row := mx_row.
Notation Local row' := mx_rem_row.
Notation Local col := mx_col.
Notation Local col' := mx_rem_col.
Notation Local lcut := mx_lcut.
Notation Local rcut := mx_rcut.
Notation Local paste := mx_paste.

Lemma perm_mx1 : forall n, \P 1%g = \1 :> 'M_n.
Proof. by move=> n; apply/matrixP=> i j; rewrite !mxK perm1. Qed.

Lemma trmxK : forall m n, cancel (@trmx R m n) (@trmx R n m).
Proof. by move=> m n A; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma trmx_inj : forall m n, injective (@trmx R m n).
Proof. move=> m n; exact: can_inj (@trmxK m n). Qed.

Lemma trmx_perm : forall n (s : 'S_n), \^t (\P s) = \P (s^-1) :> 'M_n.
Proof.
move=> n s; apply/matrixP=> i j.
by rewrite !mxK -(inj_eq (@perm_inj _ s^-1)) permK eq_sym.
Qed.

Lemma trmxZ : forall n x, \^t (\Z x) = \Z x :> 'M_n.

Proof. by move=> n x; apply/matrixP=> i j; rewrite !mxK eq_sym. Qed.

Lemma trmx1 : forall n, \^t \1 = \1 :> 'M_n.
Proof. move=> n; exact: trmxZ. Qed.

Lemma trmx0 : forall n, \^t \0 = \0 :> 'M_n.
Proof. by move=> n; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma tr_addmx : forall m n (A B : 'M_(m, n)),
  \^t (A +m B) = \^t A +m \^t B.
Proof. by move=> m n A B; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma tr_scalemx : forall m n x (A : 'M_(m, n)),
  \^t (x *s A) = x *s \^t A.
Proof. by move=> m n x A; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma tr_row : forall m n i0 (A : 'M_(m, n)),
  \^t (row i0 A) = col i0 (\^t A).
Proof. by move=> m n i0 A; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma tr_rem_row : forall m n i0 (A : 'M_(m, n)),
  \^t (row' i0 A) = col' i0 (\^t A).
Proof. by move=> m n i0 A; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma tr_col : forall m n j0 (A : 'M_(m, n)),
  \^t (col j0 A) = row j0 (\^t A).
Proof. by move=> m n j0 A; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma tr_rem_col : forall m n j0 (A : 'M_(m, n)),
  \^t (col' j0 A) = row' j0 (\^t A).
Proof. by move=> m n j0 A; apply/matrixP=> i j; rewrite !mxK. Qed.

Lemma mx_eq_row : forall m n i0 (A : 'M_(m, n)) B,
  row i0 A = B -> A i0 =1 B ord0.
Proof. move=> m n i0 A B [eqAB] j; by rewrite -eqAB !mxK. Qed.

Lemma mx_eq_rem_row : forall m n i i0 (A B : 'M_(m, n)),
  i0 != i -> row' i0 A = row' i0 B -> A i =1 B i.
Proof.
move=> m n i i0 A B; case/unlift_some=> i' -> _  [eqAB] j.
by move/matrixP: eqAB; move/(_ i' j); rewrite !mxK.
Qed.

Lemma mx_paste_cut : forall m1 m2 n (A : 'M_(m1 + m2, n)),
  paste (lcut A) (rcut A) = A.
Proof.
move=> m1 m2 n A; apply/matrixP=> i j; rewrite !mxK.
case: splitP => k Dk //=; rewrite !mxK //=; congr (A _ _); exact: val_inj.
Qed.

(* The matrix graded algebra. *)

Lemma add0mx : forall m n (A : 'M_(m, n)), \0 +m A = A.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK simp. Qed.

Lemma addmxC : forall m n (A B : 'M_(m, n)), A +m B = B +m A.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK addrC. Qed.

Lemma addmxA : forall m n (A B C : 'M_(m, n)),
  A +m (B +m C) = A +m B +m C.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK addrA. Qed.

Lemma scale0mx : forall m n (A : 'M_(m, n)), 0 *s A = \0.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK simp. Qed.

Lemma scalemx0 : forall m n c, c *s \0 = \0 :> 'M_(m, n).
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK simp. Qed.

Lemma scale1mx : forall m n (A : 'M_(m, n)), 1 *s A = A.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK simp. Qed.

Lemma scalarmx0 : forall n, \Z 0 = \0 :> 'M_n.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK if_same. Qed.

Lemma scalarmx1 : forall n, \Z 1 = \1 :> 'M_n.
Proof. done. Qed.

Lemma scalemxA : forall m n c1 c2 (A : 'M_(m, n)),
  c1 *s (c2 *s A) = (c1 * c2) *s A.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK mulrA. Qed.

Lemma scalemx1 : forall n c, c *s \1 = \Z c :> 'M_n.
Proof. by move=> *; apply/matrixP=> i j; rewrite 2!mxK fun_if !simp mxK. Qed.

Lemma scalemx_addl : forall m n x1 x2 (A : 'M_(m, n)),
  (x1 + x2) *s A = x1 *s A +m x2 *s A.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK mulr_addl. Qed.

Lemma scalemx_addr : forall m n x (A B : 'M_(m, n)),
  x *s (A +m B) = x *s A +m x *s B.
Proof. by move=> *; apply/matrixP=> i j; rewrite !mxK mulr_addr. Qed.

Lemma scalemxAl : forall m n p x (A : 'M_(m, n)) (B : 'M_(n, p)),
  x *s (A *m B) = (x *s A) *m B.
Proof.
move=> *; apply/matrixP=> i k; rewrite !mxK big_distrr /=.
by apply: eq_bigr => j _; rewrite mulrA mxK.
Qed.

Lemma addmxN : forall m n (A : 'M_(m, n)), A +m (-1 *s A) = \0.
Proof. by move=> m n A; apply/matrixP=> i j; rewrite !mxK mulN1r addrN. Qed.

Lemma addNmx : forall m n (A : 'M_(m, n)), (- 1 *s A) +m A = \0.
Proof. by move=> m n A; apply/matrixP=> i j; rewrite !mxK mulN1r addNr. Qed.

Lemma mul1mx : forall m n (A : 'M_(m, n)), \1 *m A = A.
Proof.
move=> m n A; apply/matrixP=> i j; rewrite !mxK (bigD1 i) //= mxK eqxx.
by rewrite big1 ?simp //= => k ne_ki; rewrite mxK eq_sym (negbET ne_ki) simp.
Qed.

Lemma mult0mx : forall m n p (A : 'M_(n, p)), \0 *m A = \0 :> 'M_(m, p).
Proof.
move=> m n p A; apply/matrixP=> i k; rewrite !mxK big1 ?simp //= => j _.
by rewrite mxK simp.
Qed.

Lemma multmx0 : forall m n p (A : 'M_(m, n)), A *m \0 = \0 :> 'M_(m, p).
Proof.
move=> m n p A; apply/matrixP=> i k; rewrite !mxK big1 ?simp //= => j _.
by rewrite mxK simp.
Qed.

Lemma mulmx1 : forall m n (A : 'M_(m, n)), A *m \1 = A.
Proof.
move=> m n A; apply/matrixP=> i k; rewrite !mxK.
rewrite (bigD1 k) //= !mxK eq_refl mulr1 -{-1}(addr0 (A i k)); congr (_ + _).
by apply: big1 => j Hj; rewrite mxK (negbET Hj) simp.
Qed.

Lemma mulmx_addl : forall m n p (A1 A2 : 'M_(m, n)) (B : 'M_(n, p)),
  (A1 +m A2) *m B = A1 *m B +m A2 *m B.
Proof.
move=> m n p A1 A2 B; apply/matrixP=> i k; rewrite !mxK -big_split /=.
by apply: eq_bigr => j _; rewrite mxK mulr_addl.
Qed.

Lemma mulmx_addr : forall m n p (A : 'M_(m, n)) (B1 B2 : 'M_(n, p)),
  A *m (B1 +m B2) = A *m B1 +m A *m B2.
Proof.
move=> m n p A B1 B2; apply/matrixP=> i k; rewrite !mxK -big_split /=.
by apply: eq_bigr => j _; rewrite mxK mulr_addr.
Qed.

Lemma mulmxA : forall m n p q (A : 'M_(m, n)) (B : 'M_(n, p)) (C : 'M_(p, q)),
  A *m (B *m C) = A *m B *m C.
Proof.
move=> m n p q A B C; apply/matrixP=> i l; rewrite !mxK.
transitivity (\sum_j (\sum_k (A i j * (B j k * C k l)))).
  by apply: eq_bigr => j _; rewrite mxK big_distrr.
rewrite exchange_big; apply: eq_bigr => j _; rewrite mxK big_distrl /=.
by apply: eq_bigr => k _; rewrite mulrA.
Qed.

Canonical Structure matrix_additive_group m n :=
  AdditiveGroup (@addmxA m n) (@addmxC m n) (@add0mx m n) (@addNmx m n).

(* the additive group structure provides generic sums. *)

Lemma mxK_sum : forall m n I r (P : pred I) (F : I -> 'M_(m, n)) i j,
  (\sum_(k <- r | P k) F k) i j = \sum_(k <- r | P k) F k i j.
Proof.
move=> m n I r P F i j; apply: (big_morph (fun A : 'M_(m, n) => A i j)).
by split=> [|A B]; rewrite !mxK.
Qed.

(* To make a true matrix ring the order needs to be positive!       *)
(* We use a structure to encode that info; it is defined in ssrnat. *)

Section MatrixRing.

Variable n : pos_nat.

Lemma nonzeromx1 : \1 <> \0 :> 'M_n.
Proof.
rewrite -(ltn_predK (pos_natP n)); move/matrixP; move/(_ ord0 ord0).
rewrite !mxK; exact: nonzero1r.
Qed.

Canonical Structure matrix_ring : Ring.basic :=
  Basic (@mulmxA n n n n) (@mul1mx n n) (@mulmx1 n n)
        (@mulmx_addl n n n) (@mulmx_addr n n n) nonzeromx1.

End MatrixRing.

Lemma perm_mxM : forall n (s t : 'S_n), \P (s * t)%g = \P s *m \P t :> 'M_n.
Proof.
move=> n s t; apply/matrixP=> i j; rewrite !mxK (bigD1 (s i)) //= !mxK eqxx.
rewrite simp -permM big1 /= => [|k ne_k_si]; first by rewrite addrC simp.
by rewrite mxK /= eq_sym (negbET ne_k_si) simp.
Qed.

Lemma trace_addmx : forall n (A B : 'M_n), \tr (A +m B) = \tr A + \tr B.
Proof.
by move=> n A B; rewrite -big_split; apply: eq_bigr => i _; rewrite mxK.
Qed.

Lemma trace_scalemx : forall n x (A : 'M_n), \tr (x *s A) = x * \tr A.
Proof.
by move=> *; rewrite big_distrr; apply: eq_bigr => i _; rewrite mxK.
Qed.

Lemma trace_tr : forall n (A : 'M_n), \tr (\^t A) = \tr A.
Proof. by move => *;  apply: eq_bigr => i _; rewrite mxK. Qed.

End MatrixOnRingProp.

Section MatrixOnComRingProp.
Variable R : Ring.commutative_.

Notation Local "''M_' ( m , n )" := (matrix R m n) : type_scope.
Notation Local "''M_' ( n )" := 'M_(n, n) : type_scope.
Notation Local "''M_' n" := 'M_(n) : type_scope.
Notation Local row := mx_row.
Notation Local row' := mx_rem_row.
Notation Local col := mx_col.
Notation Local col' := mx_rem_col.
Notation Local lcut := mx_lcut.
Notation Local rcut := mx_rcut.
Notation Local paste := mx_paste.

Lemma scalemxAr : forall m n p x (A : 'M_(m, n)) (B : 'M_(n, p)),
  x *s (A *m B) = A *m (x *s B).
Proof.
move=> *; apply/matrixP=> i k; rewrite !mxK big_distrr /=.
by apply: eq_bigr => j _; rewrite mxK mulrCA.
Qed.

Lemma tr_mulmx : forall m n p (A : 'M_(m, n)) (B : 'M_(n, p)),
   \^t (A *m B) = \^t B *m \^t A.
Proof.
move=> *; apply/matrixP=> i k; rewrite !mxK; apply: eq_bigr => j _.
by rewrite !mxK mulrC.
Qed.

Lemma trace_mulmxC : forall m n (A : 'M_(m, n)) (B : 'M_(n, m)),
  \tr (A *m B) = \tr (B *m A).
Proof.
move=> m n A B; transitivity (\sum_i \sum_j A i j * B j i).
  by apply: eq_bigr => i _; rewrite mxK.
rewrite exchange_big; apply: eq_bigr => i _ /=; rewrite mxK.
apply: eq_bigr => j _; exact: mulrC.
Qed.

Lemma determinant_multilinear : forall n (A B C : 'M_n) i0 b c,
    row i0 A =2 b *s row i0 B +m c *s row i0 C ->
    row' i0 B =2 row' i0 A ->
    row' i0 C =2 row' i0 A ->
  \det A = b * \det B + c * \det C.
Proof.
move=> n A B C i0 b c ABC; move/matrixP=> BA; move/matrixP=> CA.
move/mx_eq_rem_row: BA => BA; move/mx_eq_rem_row: CA => CA.
rewrite !big_distrr -big_split; apply: eq_bigr => s _ /=.
rewrite -!(mulrCA (_ ^+s)) -mulr_addr; congr (_ * _).
rewrite !(bigD1 i0 (_ : predT i0)) //=.
move/matrixP: ABC => ABC; rewrite (mx_eq_row ABC) !mxK mulr_addl !mulrA.
by congr (_ * _ + _ * _); apply: eq_bigr => i ?; rewrite ?BA ?CA // eq_sym.
Qed.

Lemma alternate_determinant : forall n (A : 'M_n) i1 i2,
  i1 != i2 -> A i1 =1 A i2 -> \det A = 0.
Proof.
move=> n A i1 i2 Di12 A12; pose r := 'I_n.
pose t := tperm i1 i2; pose tr s := (t * s)%g.
have trK : involutive tr by move=> s; rewrite /tr mulgA tperm2 mul1g.
have Etr: forall s, odd_perm (tr s) = even_perm s.
  by move=> s; rewrite odd_permM odd_tperm Di12.
rewrite /(\det _) (bigID (@even_perm _)) /=.
set S1 := \sum_(<- _ | _) _; set T := S1 + _.
rewrite -(addNr S1) addrC; congr (_ + _); rewrite {}/T {}/S1 -sum_opp.
rewrite (reindex tr) /=; last by exists tr => ? _.
symmetry; apply: eq_big => [s | s seven]; first by rewrite negbK Etr.
rewrite -mulNr Etr seven (negbET seven) expr1n; congr (_ * _).
rewrite (reindex t) /=; last by exists (t : _ -> _) => i _; exact: tpermK.
apply: eq_bigr => i _; rewrite permM /t.
by case: tpermP => // ->; rewrite A12.
Qed.

Lemma determinant_tr : forall n (A : 'M_n), \det (\^t A) = \det A.
Proof.
move=> n A; pose r := 'I_n; pose ip p : 'S_n := p^-1.
rewrite /(\det _) (reindex ip) /=; last first.
  by exists ip => s _; rewrite /ip invgK.
apply: eq_bigr => s _; rewrite !odd_permV /= (reindex s).
  by congr (_ * _); apply: eq_bigr => i _; rewrite mxK permK.
by exists (s^-1 : _ -> _) => i _; rewrite ?permK ?permKV.
Qed.

Lemma determinant_perm : forall n (s : 'S_n), \det (\P s) = (-1) ^+s :> R.
Proof.
move=> n s; rewrite /(\det _) (bigD1 s) //=.
rewrite big1 => [|i _]; last by rewrite /= !mxK eqxx.
rewrite big1 => /= [|t Dst]; first by rewrite !simp.
case: (pickP (fun i => s i != t i)) => [i ist | Est].
  by rewrite (bigD1 i) // mulrCA /= mxK (negbET ist) simp.
by case/eqP: Dst; apply/permP => i; move/eqP: (Est i).
Qed.

Lemma determinant1 : forall n, \det \1_n = 1 :> R.
Proof.
move=> n; have:= @determinant_perm n 1%g; rewrite odd_perm1 => /= <-.
congr (\det _); symmetry; exact: perm_mx1.
Qed.

Lemma determinant_scale : forall n x (A : 'M_n),
  \det (x *s A) = x ^+n * \det A.
Proof.
move=> n x A; rewrite big_distrr /=; apply: eq_bigr => s _.
rewrite mulrCA; congr (_ * _).
rewrite -{10}[n]card_ord -prodr_const -big_split /=.
by apply: eq_bigr=> i _; rewrite mxK.
Qed.

Lemma determinantM : forall n (A B : 'M_n), \det (A *m B) = \det A * \det B.
Proof.
move=> n A B; rewrite big_distrl /=.
pose AB (f : {ffun _}) (s : 'S_n) i := A i (f i) * B (f i) (s i).
transitivity (\sum_f \sum_(s : 'S_n) (-1) ^+ s * \prod_i AB f s i).
  rewrite exchange_big; apply: eq_bigr => /= s _.
  rewrite -big_distrr /=; congr (_ * _).
  pose F i j := A i j * B j (s i); rewrite -(bigA_distr_bigA F) /=.
  by apply: eq_bigr => x _; rewrite mxK.
rewrite (bigID (fun f : {ffun _} => injectiveb f)) /= addrC big1 ?simp => [|f Uf].
  rewrite (reindex (fun s => pval s)); last first.
    have s0 : 'S_n := 1%g; pose uf (f : {ffun 'I_n -> 'I_n}) := uniq (val f).
    exists (insubd s0) => /= f Uf; first apply: val_inj; exact: insubdK.
  apply: eq_big => /= [s|s _]; rewrite ?(valP s) // big_distrr /=.
  rewrite (reindex (mulg s)); last first.
    by exists (mulg s^-1) => t _; rewrite ?mulKVg ?mulKg.
  apply: eq_bigr => t _; rewrite big_split /= mulrA mulrCA mulrA mulrCA mulrA.
  rewrite -signr_addb odd_permM !pvalE; congr (_ * _).
  rewrite (reindex s^-1); last first.
    by exists (s : _ -> _) => i _; rewrite ?permK ?permKV.
  by apply: eq_bigr => i _; rewrite permM permKV ?eqxx // -{3}[i](permKV s).
transitivity (\det (\matrix_(i, j) B (f i) j) * \prod_i A i (f i)).
  rewrite mulrC big_distrr /=; apply: eq_bigr => s _.
  rewrite mulrCA big_split //=; congr (_ * (_ * _)).
  by apply: eq_bigr => x _; rewrite mxK.
case/injectivePn: Uf => i1 [i2 Di12 Ef12].
by rewrite (alternate_determinant Di12) ?simp //= => j; rewrite !mxK Ef12.
Qed.

Lemma expand_cofactor : forall n (A : 'M_n) i j,
  cofactor A i j =
    \sum_(s : 'S_n | s i == j) (-1)^+s * \prod_(k | i != k) A k (s k).
Proof.
move=> n.
pose lsf i (s : 'S_(n.-1)) j k :=
  if unlift i k is Some k' then lift j (s k') else j.
have lsfE: forall i s j, (lsf i s j i = j)
                       * (forall k, lsf i s j (lift i k) = lift j (s k)).
- by split=> *; rewrite /lsf ?unlift_none ?liftK.
have inj_lsf : injective (lsf _ _ _).
  move=> i s j; apply: can_inj (lsf j s^-1 i) _ => k.
  by case: (unliftP i k) => [k'|] ->; rewrite !lsfE ?permK.
pose ls := perm (inj_lsf _ _ _).
have ls1 : forall i, ls i 1%g i = 1%g.
  move=> i; apply/permP => k.
  by case: (unliftP i k) => [k'|] ->; rewrite permE lsfE !perm1.
have lsM : forall i s j t k, (ls i s j * ls j t k)%g = ls i (s * t)%g k.
  move=> i s j t k; apply/permP=> l; rewrite permM !permE.
  by case: (unliftP i l) => [l'|] ->; rewrite !lsfE ?permM.
have sign_ls: forall s i j, (-1)^+(ls i s j) = (-1) ^+s * (-1)^+(i + j) :> R.
  pose nfp (s : 'S_(n.-1)) := [pred k | s k != k].
  move=> s i j; elim: {s}_.+1 {-2}s (ltnSn #|nfp s|) => // m IHm s Hm.
  case: (pickP (nfp s)) Hm => [k Dsk | s1 _ {m IHm}].
    rewrite ltnS (cardD1 k) [k \in _]Dsk => Hm.
    pose t := tperm k (fun_of_perm s^-1 k).
    rewrite -(mulKg t s) tpermV -(lsM _ _ i).
    rewrite 2!odd_permM 2!signr_addb -mulrA -{}IHm; last first.
      apply: {m} leq_trans Hm; apply: subset_leq_card; apply/subsetP=> k'.
      rewrite !inE permM /t (eq_sym k').
      case: tpermP=> [->|-> Ds|]; rewrite ?permKV; first by rewrite eqxx.
        by rewrite andbb; apply/eqP=> Dk; case/eqP: Ds; rewrite {1}Dk permKV.
      by move/eqP; rewrite eq_sym => ->.
    suffices ->: ls i t i = tperm (lift i k) (lift i (fun_of_perm s^-1 k)).
      by rewrite !odd_tperm (inj_eq (@lift_inj _ _)).
    apply/permP=> i'; rewrite permE.
    case: (unliftP i i') => [i''|] ->; rewrite lsfE.
      rewrite inj_tperm //; exact: lift_inj.
    case tpermP => //; move/eqP; case/idPn; exact: neq_lift.
  have ->: s = 1%g.
    by apply/permP=> k; rewrite perm1; move/eqP: (s1 k).
  rewrite odd_perm1 simp /=; without loss: i {s s1} j / j <= i.
    case: (leqP j i); first by auto.
    move/ltnW=> ij; move/(_ _ _ ij)=> Wji.
    rewrite -(mulgK (ls j 1%g i) (ls i  _ j)) lsM !(ls1,mul1g).
    by rewrite odd_permV addnC.
  move Dm: i.+1 => m; elim: m i Dm => // m IHm i [im].
  rewrite leq_eqVlt; case/predU1P=> [eqji|ltji].
    by rewrite (val_inj _ _ eqji) ls1 odd_perm1 /= -signr_odd odd_add addbb.
  have m'm: m.-1.+1 = m by rewrite -im (ltn_predK ltji).
  have ltm'n : m.-1 < n by rewrite m'm -im leq_eqVlt orbC (ltn_ord i).
  pose i' := Ordinal ltm'n; rewrite -{1}(mulg1 1%g) -(lsM _ _ i') odd_permM.
  rewrite signr_addb mulrC {}IHm; try by rewrite /= - 1?ltnS ?m'm // -im.
  rewrite im -m'm addSn -addn1 (exprn_addr _ _ 1); congr (_ * _).
  have{j ltji} ii' : i != i' by rewrite -val_eqE /= im /= -m'm eqn_leq ltnn.
  transitivity (((-1) ^+(tperm i i')) : R); last by rewrite odd_tperm ii'.
  congr (_ ^+(odd_perm _)); apply/permP => k.
  case: (unliftP i k) => [k'|] -> {k}; rewrite permE lsfE ?tpermL // perm1.
  apply: val_inj; rewrite permE /transpose (negbET (neq_lift _ _)) /pred1.
  rewrite fun_if -val_eqE /= im /bump; case mk': (m <= _).
    by rewrite eqn_leq ltnNge leq_eqVlt m'm mk' orbT andbF.
  by rewrite add0n leq_eqVlt m'm mk'; case: eqP => //= <-.
move=> A i0 j0; rewrite (reindex (fun s => ls i0 s j0)); last first.
  pose ulsf i (s : 'S_n) k' :=
    if unlift (s i) (s (lift i k')) is Some k then k else k'.
  have ulsfE: forall i (s : 'S_n) k',
      lift (s i) (ulsf i s k') = s (lift i k').
    rewrite /ulsf => i s k'; have:= neq_lift i k'.
    by rewrite -(inj_eq (@perm_inj _ s)); case/unlift_some=> ? ? ->.
  have inj_ulsf: injective (ulsf i0 _).
    move=> s; apply: can_inj (ulsf (s i0) s^-1) _ => k'.
    by rewrite {1}/ulsf ulsfE !permK liftK.
  exists (fun s => perm (inj_ulsf s)) => [s _ | s].
    by apply/permP=> k'; rewrite permE /ulsf !permE !lsfE liftK.
  move/(s _ =P _) => si0; apply/permP=> k.
  by case: (unliftP i0 k) => [k'|] ->; rewrite permE lsfE // permE -si0 ulsfE.
rewrite /cofactor big_distrr /=.
apply: eq_big => [s | s _]; first by rewrite permE lsfE eqxx.
rewrite mulrCA mulrA -{}sign_ls; congr (_ * _).
case: (pickP 'I_(n.-1)) => [k'0 _ | r'0]; last first.
  rewrite !big_pred0 // => k; apply/idP; case/unlift_some=> k'.
  by have:= r'0 k'.
rewrite (reindex (lift i0)).
  by apply: eq_big => [k | k _] /=; rewrite ?neq_lift // !mxK permE lsfE.
pose f k := if unlift i0 k is Some k' then k' else k'0.
by exists f; rewrite /f => k; [rewrite liftK | case/unlift_some=> ? ? ->].
Qed.

Lemma expand_determinant_row : forall n (A : 'M_n) i0,
  \det A = \sum_j A i0 j * cofactor A i0 j.
Proof.
move=> n A i0; rewrite /(\det A).
rewrite (partition_big (fun s : 'S_n => s i0) predT) //=.
apply: eq_bigr => j0 _; rewrite expand_cofactor big_distrr /=.
apply: eq_bigr => s; move/eqP=> Dsi0.
rewrite mulrCA (bigID (pred1 i0)) /= big_pred1_eq Dsi0; congr (_ * (_ * _)).
by apply: eq_bigl => i; rewrite eq_sym.
Qed.

Lemma cofactor_tr : forall n (A : 'M_n) i j,
  cofactor (\^t A) i j = cofactor A j i.
Proof.
move=> n A i j; rewrite /cofactor addnC; congr (_ * _).
rewrite -tr_rem_row -tr_rem_col determinant_tr; congr (\det _).
by apply/matrixP=> ? ?; rewrite !mxK.
Qed.

Lemma expand_determinant_col : forall n (A : 'M_n) j0,
  \det A = \sum_i (A i j0 * cofactor A i j0).
Proof.
move=> n A j0; rewrite -determinant_tr (expand_determinant_row _ j0).
by apply: eq_bigr => i _; rewrite cofactor_tr mxK.
Qed.

Lemma mulmx_adjr : forall n (A : 'M_n), A *m adjugate A = \Z (\det A).
Proof.
move=> n A; apply/matrixP=> i1 i2; rewrite !mxK; case Di: (i1 == i2).
  rewrite (eqP Di) (expand_determinant_row _ i2) //=.
  by apply: eq_bigr => j _; congr (_ * _); rewrite mxK.
pose B := \matrix_(i, j) (if i == i2 then A i1 j else A i j).
have EBi12: B i1 =1 B i2 by move=> j; rewrite /= !mxK Di eq_refl.
rewrite -{2}(alternate_determinant (negbT Di) EBi12).
rewrite (expand_determinant_row _ i2); apply: eq_bigr => j _.
rewrite !mxK eq_refl; congr (_ * (_ * _)).
apply: eq_bigr => s _; congr (_ * _); apply: eq_bigr => i _.
by rewrite !mxK eq_sym -if_neg neq_lift.
Qed.

Lemma adjugate_tr : forall n (A : 'M_n), adjugate (\^t A) = \^t (adjugate A).
Proof. by move=> n A; apply/matrixP=> i j; rewrite !mxK cofactor_tr. Qed.

Lemma mulmx_adjl : forall n (A : 'M_n), adjugate A *m A =  \Z (\det A).
Proof.
move=> n A; apply: trmx_inj; rewrite tr_mulmx -adjugate_tr mulmx_adjr.
by rewrite determinant_tr trmxZ.
Qed.

End MatrixOnComRingProp.

Import Field.
Open Scope field_scope.

Section GenLinGrp.
Variables (K : field) (n : nat).

Notation Local "''M_' ( n )" := (matrix K n n) : matrix_scope.
Notation Local "''M_' n" := 'M_(n) : matrix_scope.
Notation Local "\mulmx" := (@mulmx K n n n) : matrix_scope.

Definition invmx := fun A : 'M_n => (\det A)^-1 *s \adj A.
Notation "A ^-1m" := (invmx A) (at level 2, format "A ^-1m") : matrix_scope.

Lemma mulVmx : forall A : 'M_n, \det A != 0 -> A *m A^-1m = \1.
Proof.
move=> A Ha.
by rewrite -scalemxAr mulmx_adjr -scalemx1 scalemxA mulfV ?scale1mx.
Qed.

Lemma mulmxV : forall A : 'M_n, \det A != 0 -> A^-1m *m A= \1.
Proof.
move=> A Ha.
by rewrite -scalemxAl mulmx_adjl -scalemx1 scalemxA mulfV ?scale1mx//.
Qed.

Lemma mulKmx : forall A : 'M_n,
  \det A != 0 -> cancel (\mulmx A) (\mulmx A^-1m).
Proof. by move=> A Ha B; rewrite mulmxA mulmxV// mul1mx. Qed.

Lemma mulmxK : forall (A : 'M_n),
  \det A != 0 -> cancel (\mulmx^~ A) (\mulmx^~ A^-1m).
Proof. by move=> A Ha B; rewrite -mulmxA mulVmx// mulmx1. Qed.

Lemma mulImx : forall A : 'M_n, \det A != 0 -> injective (\mulmx A).
Proof. move=> A Ha; exact: can_inj (mulKmx Ha). Qed.

Lemma mulmxI : forall A : 'M_n, \det A != 0 -> injective (\mulmx^~ A).
Proof. move=> A Ha; exact: can_inj (mulmxK Ha). Qed.

Lemma neq0_Dmx: forall A : 'M_n, \det A != 0 -> \det A^-1m != 0.
Proof.
move=> A Ha; rewrite determinant_scale.
move: (congr1 (@determinant _ n) (mulmx_adjl A));
 rewrite determinantM -scalemx1 determinant_scale determinant1 mulr1.
move/(congr1 (mul (\det A)^-1)); rewrite mulrCA mulfV// mulr1=> ->.
rewrite mulrCA -exprn_mull mulfV// exp1rn mulr1.
by apply: neq0I.
Qed.

Lemma neq0_Dmx_mul : forall A B : 'M_n,
 \det A != 0 -> \det B != 0 -> \det (A *m B) != 0.
Proof. by move=> *; rewrite determinantM; apply: neq0_mul. Qed.

Lemma invmxK : forall A : 'M_n, \det A != 0 -> (A^-1m)^-1m = A.
Proof.
move=> A Ha; apply: (mulmxI (neq0_Dmx Ha)).
by rewrite mulVmx// mulmxV//; apply: neq0_Dmx.
Qed.

Lemma invmx1 : \1^-1m = \1 :> 'M_n.
Proof.
rewrite -[\1^-1m]mul1mx mulVmx// determinant1;
apply/eqP; exact: nonzero1r.
Qed.

Lemma invmxI : forall A B : 'M_n,
 \det A != 0 -> \det B != 0 -> A^-1m = B^-1m -> A = B.
Proof. by move=> A B Ha Hb Hab; rewrite -(invmxK Ha) -(invmxK Hb) Hab. Qed.

Lemma invmx_mul : forall A B : 'M_n,
 \det A != 0 -> \det B != 0 -> (A *m B)^-1m = B^-1m *m A^-1m.
Proof.
move=> A B Ha Hb; apply: (mulImx (neq0_Dmx_mul Ha Hb)).
rewrite mulVmx; last exact: neq0_Dmx_mul.
by rewrite -mulmxA [B *m (_ *m _)]mulmxA mulVmx// mul1mx mulVmx.
Qed.

End GenLinGrp.

Unset Implicit Arguments.


(*! Utilities | Functions on Vect.index elements !*)
Require Coq.Logic.FinFun.
Require Import Koika.Common Koika.Member.
Require Export Koika.Vect.

Fixpoint all_indices (bound: nat) : vect (index bound) bound :=
  match bound as n return (vect (index n) n) with
  | 0 => vect_nil
  | S bound => vect_cons thisone (vect_map anotherone (all_indices bound))
  end.

Fixpoint all_indices_eqn bound:
  forall idx, vect_nth (all_indices bound) idx = idx.
Proof.
  destruct bound, idx; cbn.
  - reflexivity.
  - rewrite vect_nth_map.
    rewrite all_indices_eqn.
    reflexivity.
Defined.

Lemma all_indices_NoDup bound:
  vect_NoDup (all_indices bound).
Proof.
  induction bound; cbn; econstructor.
  - intro.
    apply vect_to_list_In in H.
    apply vect_map_In_ex in H.
    destruct H as [t (? & ?)]; discriminate.
  - setoid_rewrite vect_to_list_map.
    apply FinFun.Injective_map_NoDup.
    + red; inversion 1; reflexivity.
    + eassumption.
Qed.

Lemma all_indices_surjective bound:
  forall idx, member idx (vect_to_list (all_indices bound)).
Proof.
  intros.
  eapply nth_member.
  rewrite vect_to_list_nth.
  f_equal.
  apply all_indices_eqn.
Defined.

Instance FiniteType_index {n} : FiniteType (Vect.index n).
Proof.
  refine {| finite_index := index_to_nat;
            finite_elements := vect_to_list (all_indices n) |}.
  - intros; rewrite vect_to_list_nth, all_indices_eqn; reflexivity.
  - apply FinFun.Injective_map_NoDup.
    red; apply index_to_nat_injective.
    apply all_indices_NoDup.
Defined.

Fixpoint Vector_find {K: Type} {n: nat} {EQ: EqDec K} (k: K) (v: Vector.t K n) {struct n} : option (Vect.index n).
Proof.
  destruct n.
  - exact None.
  - destruct (eq_dec k (Vector.hd v)).
    + exact (Some thisone).
    + destruct (Vector_find K n EQ k (Vector.tl v)).
      * exact (Some (anotherone i)).
      * exact None.
Defined.

Fixpoint Vector_assoc {K V: Type} {n: nat} {EQ: EqDec K} (k: K) (v: Vector.t (K * V) n) {struct n} : option (Vect.index n).
Proof.
  destruct n.
  - exact None.
  - destruct (eq_dec k (fst (Vector.hd v))).
    + exact (Some thisone).
    + destruct (Vector_assoc K V n EQ k (Vector.tl v)).
      * exact (Some (anotherone i)).
      * exact None.
Defined.

Fixpoint List_assoc {K V: Type} {EQ: EqDec K} (k: K) (l: list (K * V)) {struct l} : option (Vect.index (List.length l)).
Proof.
  destruct l as [| h l].
  - exact None.
  - destruct (eq_dec k (fst h)).
    + exact (Some thisone).
    + destruct (List_assoc K V EQ k l).
      * exact (Some (anotherone i)).
      * exact None.
Defined.

Fixpoint Vector_nth {K: Type} {n: nat} (v: Vector.t K n) (idx: Vect.index n) {struct n} : K.
Proof.
  destruct n; destruct idx.
  - exact (Vector.hd v).
  - exact (Vector_nth K n (Vector.tl v) a).
Defined.

Fixpoint List_nth {K: Type} (l: list K) (idx: Vect.index (List.length l)) {struct l} : K.
Proof.
  destruct l as [| h l]; destruct idx.
  - exact h.
  - exact (List_nth K l a).
Defined.

Fixpoint List_nth_map_cast {A B} (f: A -> B) l:
  List.length l = List.length (List.map f l).
Proof. destruct l; cbn; auto. Defined.

Lemma List_nth_map {A B} (f: A -> B):
  forall l idx,
    f (List_nth l idx) =
    List_nth (List.map f l)
             ltac:(rewrite <- List_nth_map_cast; exact idx).
Proof.
  induction l; destruct idx; cbn;
    set (List_nth (List.map f l)) as x in *; clearbody x.
  - set (List_nth_map_cast _ _) as Heq in *; clearbody Heq.
    destruct Heq; reflexivity.
  - rewrite IHl; clear.
    set (List_nth_map_cast _ _) as Heq in *; clearbody Heq.
    destruct Heq; reflexivity.
Qed.

Lemma List_nth_firstn_1_skipn {A} (l: list A) a:
  List.firstn 1 (List.skipn (index_to_nat a) l) =
  [List_nth l a].
Proof.
  induction l; destruct a; cbn.
  - reflexivity.
  - specialize (IHl a).
    destruct (skipn _ _); inversion IHl; reflexivity.
Qed.

Lemma List_nth_skipn_cons_next {A}:
  forall (l: list A) idx,
    List_nth l idx :: (List.skipn (S (index_to_nat idx)) l) =
    List.skipn (index_to_nat idx) l.
Proof.
  induction l; destruct idx; cbn; try rewrite IHl; reflexivity.
Qed.

Lemma list_sum_member_le:
  forall l idx,
    List_nth l idx <=
    list_sum l.
Proof.
  induction l; destruct idx.
  - cbn; lia.
  - specialize (IHl a0); unfold list_sum, list_sum' in *; cbn; lia.
Qed.

Instance Show_index (n: nat) : Show (index n) :=
  { show x := show (index_to_nat x) }.