(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype tuple.
Require Import finfun bigop fingroup perm ssralg zmodp matrix mxalgebra.
Require Import poly polydiv.

(******************************************************************************)
(*   This file provides basic support for formal computation with matrices,   *)
(* mainly results combining matrices and univariate polynomials, such as the  *)
(* Cayley-Hamilton theorem; it also contains an extension of the first order  *)
(* representation of algebra introduced in ssralg (GRing.term/formula).       *)
(*      rVpoly v == the little-endian decoding of the row vector v as a       *)
(*                  polynomial p = \sum_i (v 0 i)%:P * 'X^i.                  *)
(*     poly_rV p == the partial inverse to rVpoly, for polynomials of degree  *)
(*                  less than d to 'rV_d (d is inferred from the context).    *)
(* Sylvester_mx p q == the Sylvester matrix of p and q.                       *)
(* resultant p q == the resultant of p and q, i.e., \det (Sylvester_mx p q).  *)
(*   horner_mx A == the morphism from {poly R} to 'M_n (n of the form n'.+1)  *)
(*                  mapping a (scalar) polynomial p to the value of its       *)
(*                  scalar matrix interpretation at A (this is an instance of *)
(*                  the generic horner_morph construct defined in poly).      *)
(* powers_mx A d == the d x (n ^ 2) matrix whose rows are the mxvec encodings *)
(*                  of the first d powers of A (n of the form n'.+1). Thus,   *)
(*                  vec_mx (v *m powers_mx A d) = horner_mx A (rVpoly v).     *)
(*   char_poly A == the characteristic polynomial of A.                       *)
(* char_poly_mx A == a matrix whose detereminant is char_poly A.              *)
(*   mxminpoly A == the minimal polynomial of A, i.e., the smallest monic     *)
(*                  polynomial that annihilates A (A must be nontrivial).     *)
(* degree_mxminpoly A == the (positive) degree of mxminpoly A.                *)
(* mx_inv_horner A == the inverse of horner_mx A for polynomials of degree    *)
(*                  smaller than degree_mxminpoly A.                          *)
(*  integralOver RtoK u <-> u is in the integral closure of the image of R    *)
(*                  under RtoK : R -> K, i.e. u is a root of the image of a   *)
(*                  monic polynomial in R.                                    *)
(*  algebraicOver FtoE u <-> u : E is algebraic over E; it is a root of the   *)
(*                  image of a nonzero polynomial under FtoE; as F must be a  *)
(*                  fieldType, this is equivalent to integralOver FtoE u.     *)
(*  integralRange RtoK <-> the integral closure of the image of R contains    *)
(*                  all of K (:= forall u, integralOver RtoK u).              *)
(* This toolkit for building formal matrix expressions is packaged in the     *)
(* MatrixFormula submodule, and comprises the following:                      *)
(*     eval_mx e == GRing.eval lifted to matrices (:= map_mx (GRing.eval e)). *)
(*     mx_term A == GRing.Const lifted to matrices.                           *)
(* mulmx_term A B == the formal product of two matrices of terms.             *)
(* mxrank_form m A == a GRing.formula asserting that the interpretation of    *)
(*                  the term matrix A has rank m.                             *)
(* submx_form A B == a GRing.formula asserting that the row space of the      *)
(*                  interpretation of the term matrix A is included in the    *)
(*                  row space of the interpretation of B.                     *)
(*   seq_of_rV v == the seq corresponding to a row vector.                    *)
(*     row_env e == the flattening of a tensored environment e : seq 'rV_d.   *)
(* row_var F d k == the term vector of width d such that for e : seq 'rV[F]_d *)
(*                  we have eval e 'X_k = eval_mx (row_env e) (row_var d k).  *)
(******************************************************************************)

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

Import GRing.Theory.
Import Monoid.Theory.

Open Local Scope ring_scope.

Import Pdiv.Idomain.
(* Row vector <-> bounded degree polynomial bijection *)
Section RowPoly.

Variables (R : ringType) (d : nat).
Implicit Types u v : 'rV[R]_d.
Implicit Types p q : {poly R}.

Definition rVpoly v := \poly_(k < d) (if insub k is Some i then v 0 i else 0).
Definition poly_rV p := \row_(i < d) p`_i.

Lemma coef_rVpoly v k : (rVpoly v)`_k = if insub k is Some i then v 0 i else 0.
Proof. by rewrite coef_poly; case: insubP => [i ->|]; rewrite ?if_same. Qed.

Lemma coef_rVpoly_ord v (i : 'I_d) : (rVpoly v)`_i = v 0 i.
Proof. by rewrite coef_rVpoly valK. Qed.

Lemma rVpoly_delta i : rVpoly (delta_mx 0 i) = 'X^i.
Proof.
apply/polyP=> j; rewrite coef_rVpoly coefXn.
case: insubP => [k _ <- | j_ge_d]; first by rewrite mxE.
by case: eqP j_ge_d => // ->; rewrite ltn_ord.
Qed.

Lemma rVpolyK : cancel rVpoly poly_rV.
Proof. by move=> u; apply/rowP=> i; rewrite mxE coef_rVpoly_ord. Qed.

Lemma poly_rV_K p : size p <= d -> rVpoly (poly_rV p) = p.
Proof.
move=> le_p_d; apply/polyP=> k; rewrite coef_rVpoly.
case: insubP => [i _ <- | ]; first by rewrite mxE.
by rewrite -ltnNge => le_d_l; rewrite nth_default ?(leq_trans le_p_d).
Qed.

Lemma poly_rV_is_linear : linear poly_rV.
Proof. by move=> a p q; apply/rowP=> i; rewrite !mxE coefD coefZ. Qed.
Canonical poly_rV_additive := Additive poly_rV_is_linear.
Canonical poly_rV_linear := Linear poly_rV_is_linear.

Lemma rVpoly_is_linear : linear rVpoly.
Proof.
move=> a u v; apply/polyP=> k; rewrite coefD coefZ !coef_rVpoly.
by case: insubP => [i _ _ | _]; rewrite ?mxE // mulr0 addr0.
Qed.
Canonical rVpoly_additive := Additive rVpoly_is_linear.
Canonical rVpoly_linear := Linear rVpoly_is_linear.

End RowPoly.

Implicit Arguments poly_rV [R d].
Prenex Implicits rVpoly poly_rV.

Section Resultant.

Variables (R : ringType) (p q : {poly R}).

Let dS := ((size q).-1 + (size p).-1)%N.
Local Notation band r := (lin1_mx (poly_rV \o r \o* rVpoly)).

Definition Sylvester_mx : 'M[R]_dS := col_mx (band p) (band q).

Lemma Sylvester_mxE (i j : 'I_dS) :
  let S_ r k := r`_(j - k) *+ (k <= j) in
  Sylvester_mx i j = match split i with inl k => S_ p k | inr k => S_ q k end.
Proof.
move=> S_; rewrite mxE; case: {i}(split i) => i; rewrite !mxE /=;
  by rewrite rVpoly_delta coefXnM ltnNge if_neg -mulrb.
Qed.

Definition resultant := \det Sylvester_mx.

End Resultant.

Lemma resultant_in_ideal (R : comRingType) (p q : {poly R}) :
    size p > 1 -> size q > 1 ->
  {uv : {poly R} * {poly R} | size uv.1 < size q /\ size uv.2 < size p
  & (resultant p q)%:P = uv.1 * p + uv.2 * q}.
Proof.
move=> p_nc q_nc; pose dp := (size p).-1; pose dq := (size q).-1.
pose S := Sylvester_mx p q; pose dS := (dq + dp)%N.
have dS_gt0: dS > 0 by rewrite /dS /dq -(subnKC q_nc).
pose j0 := Ordinal dS_gt0.
pose Ss0 := col_mx (p *: \col_(i < dq) 'X^i) (q *: \col_(i < dp) 'X^i).
pose Ss := \matrix_(i, j) (if j == j0 then Ss0 i 0 else (S i j)%:P).
pose u ds s := \sum_(i < ds) cofactor Ss (s i) j0 * 'X^i.
exists (u _ (lshift dp), u _ ((rshift dq) _)).
  suffices sz_u ds s: ds > 1 -> size (u ds.-1 s) < ds by rewrite !sz_u.
  move/ltn_predK=> {2}<-; apply: leq_trans (size_sum _ _ _) _.
  apply/bigmax_leqP=> i _.
  have ->: cofactor Ss (s i) j0 = (cofactor S (s i) j0)%:P.
    rewrite rmorphM rmorph_sign -det_map_mx; congr (_ * \det _).
    by apply/matrixP=> i' j'; rewrite !mxE.
  apply: leq_trans (size_mul_leq _ _) (leq_trans _ (valP i)).
  by rewrite size_polyC size_polyXn addnS /= -add1n leq_add2r leq_b1.
transitivity (\det Ss); last first.
  rewrite (expand_det_col Ss j0) big_split_ord !big_distrl /=.
  by congr (_ + _); apply: eq_bigr => i _;
    rewrite mxE eqxx (col_mxEu, col_mxEd) !mxE mulrC mulrA mulrAC.
pose S_ j1 := map_mx polyC (\matrix_(i, j) S i (if j == j0 then j1 else j)).
pose Ss0_ i dj := \poly_(j < dj) S i (insubd j0 j).
pose Ss_ dj := \matrix_(i, j) (if j == j0 then Ss0_ i dj else (S i j)%:P).
have{Ss u} ->: Ss = Ss_ dS.
  apply/matrixP=> i j; rewrite mxE [in X in _ = X]mxE; case: (j == j0) => {j}//.
  apply/polyP=> k; rewrite coef_poly Sylvester_mxE mxE.
  have [k_ge_dS | k_lt_dS] := leqP dS k.
    case: (split i) => {i}i; rewrite !mxE coefMXn;
    case: ifP => // /negbT; rewrite -ltnNge ltnS => hi.
      apply: (leq_sizeP _ _ (leqnn (size p))); rewrite -(ltn_predK p_nc).
      by rewrite ltn_subRL (leq_trans _ k_ge_dS) // ltn_add2r.
    - apply: (leq_sizeP _ _ (leqnn (size q))); rewrite -(ltn_predK q_nc).
      by rewrite ltn_subRL (leq_trans _ k_ge_dS) // addnC ltn_add2l.
  by rewrite insubdK //; case: (split i) => {i}i;
     rewrite !mxE coefMXn; case: leqP.
elim: {-2}dS (leqnn dS) (dS_gt0) => // dj IHj dj_lt_dS _.
pose j1 := Ordinal dj_lt_dS; pose rj0T (A : 'M[{poly R}]_dS) := row j0 A^T.
have: rj0T (Ss_ dj.+1) = 'X^dj *: rj0T (S_ j1) + 1 *: rj0T (Ss_ dj).

  apply/rowP=> i; apply/polyP=> k; rewrite scale1r !(Sylvester_mxE, mxE) eqxx.

  rewrite coefD coefXnM coefC !coef_poly ltnS subn_eq0 ltn_neqAle andbC.
  case: (leqP k dj) => [k_le_dj | k_gt_dj] /=; last by rewrite addr0.
  rewrite Sylvester_mxE insubdK; last exact: leq_ltn_trans (dj_lt_dS).
  by case: eqP => [-> | _]; rewrite (addr0, add0r).
rewrite -det_tr => /determinant_multilinear->;
  try by apply/matrixP=> i j; rewrite !mxE eq_sym (negPf (neq_lift _ _)).
have [dj0 | dj_gt0] := posnP dj; rewrite ?dj0 !mul1r.
  rewrite !det_tr det_map_mx addrC (expand_det_col _ j0) big1 => [|i _].
    rewrite add0r; congr (\det _)%:P.
    apply/matrixP=> i j; rewrite [in X in _ = X]mxE; case: eqP => // ->.
    by congr (S i _); apply: val_inj.
  by rewrite mxE /= [Ss0_ _ _]poly_def big_ord0 mul0r.
have /determinant_alternate->: j1 != j0 by rewrite -val_eqE -lt0n.
  by rewrite mulr0 add0r det_tr IHj // ltnW.
by move=> i; rewrite !mxE if_same.
Qed.

Lemma resultant_eq0 (R : idomainType) (p q : {poly R}) :
  (resultant p q == 0) = (size (gcdp p q) > 1).
Proof.
have dvdpp := dvdpp; set r := gcdp p q.
pose dp := (size p).-1; pose dq := (size q).-1.
have /andP[r_p r_q]: (r %| p) && (r %| q) by rewrite -dvdp_gcd.
apply/det0P/idP=> [[uv nz_uv] | r_nonC].
  have [p0 _ | p_nz] := eqVneq p 0.
    have: dq + dp > 0.
      rewrite lt0n; apply: contraNneq nz_uv => dqp0.
      by rewrite dqp0 in uv *; rewrite [uv]thinmx0.
    by rewrite /dp /dq /r p0 size_poly0 addn0 gcd0p -subn1 subn_gt0.
  do [rewrite -[uv]hsubmxK -{1}row_mx0 mul_row_col !mul_rV_lin1 /=] in nz_uv *.
  set u := rVpoly _; set v := rVpoly _; pose m := gcdp (v * p) (v * q).
  have lt_vp: size v < size p by rewrite (polySpred p_nz) ltnS size_poly.
  move/(congr1 rVpoly); rewrite linearD linear0 /=; move/(canRL (addKr _)).
  rewrite !poly_rV_K ?(leq_trans (size_mul_leq _ _)) // => [vq_up||]; first 1 last.
  - by rewrite -subn1 leq_subLR addnCA leq_add ?leqSpred ?size_poly.
  - by rewrite -subn1 leq_subLR addnC addnA leq_add ?leqSpred ?size_poly.
  have nz_v: v != 0.
    apply: contraNneq nz_uv => v0; apply/eqP.
    congr row_mx; apply: (can_inj (@rVpolyK _ _)); rewrite linear0 // -/u.
    move/eqP: vq_up; apply: contraTeq => nz_u.
    by rewrite v0 mul0r addr0 eq_sym oppr_eq0 mulf_neq0.
  have r_nz: r != 0 := dvdpN0 r_p p_nz.
  have /dvdpP [[c w] /= nz_c wv]: v %| m by rewrite dvdp_gcd !dvdp_mulr.
  have m_wd d: m %| v * d -> w %| d.
    case/dvdpP=> [[k f]] /= nz_k; move/(congr1 ( *:%R c)).
    rewrite mulrC scalerA scalerAl scalerAr wv mulrA.
    move/(mulIf nz_v)=> def_fw; apply/dvdpP.
    by exists (c * k, f); rewrite //= mulf_neq0.
  have w_r: w %| r by rewrite dvdp_gcd !m_wd ?dvdp_gcdl ?dvdp_gcdr.
  have w_nz: w != 0 := dvdpN0 w_r r_nz.
  have p_m: p %| m by rewrite dvdp_gcd vq_up addr0 -mulNr !dvdp_mull.
  rewrite (leq_trans _ (dvdp_leq r_nz w_r)) // -(ltn_add2l (size v)).
  rewrite addnC -ltn_subRL subn1 -size_mul // mulrC -wv size_scale //.
  rewrite (leq_trans lt_vp) // dvdp_leq // -size_poly_eq0.
  by rewrite -(size_scale _ nz_c) size_poly_eq0 wv mulf_neq0.
have [[c p'] /= nz_c p'r] := dvdpP _ _ r_p.
have [[k q'] /= nz_k q'r] := dvdpP _ _ r_q.
have def_r := subnKC r_nonC; have r_nz: r != 0 by rewrite -size_poly_eq0 -def_r.
have le_p'_dp: size p' <= dp.
  have [-> | nz_p'] := eqVneq p' 0; first by rewrite size_poly0.
  by rewrite /dp -(size_scale p nz_c) p'r size_mul // addnC -def_r leq_addl.
have le_q'_dq: size q' <= dq.
  have [-> | nz_q'] := eqVneq q' 0; first by rewrite size_poly0.
  by rewrite /dq -(size_scale q nz_k) q'r size_mul // addnC -def_r leq_addl.
exists (row_mx (- c *: poly_rV q') (k *: poly_rV p')).
  apply: contraNneq r_nz; rewrite -row_mx0; case/eq_row_mx=> q0 p0.
  have{p0} p0: p = 0.
    apply/eqP; rewrite -size_poly_eq0 -(size_scale p nz_c) p'r.
    rewrite -(size_scale _ nz_k) scalerAl -(poly_rV_K le_p'_dp) -linearZ p0.
    by rewrite linear0 mul0r size_poly0.
  rewrite /r p0 gcd0p -size_poly_eq0 -(size_scale q nz_k) q'r.
  rewrite -(size_scale _ nz_c) scalerAl -(poly_rV_K le_q'_dq) -linearZ.
  by rewrite -[c]opprK scaleNr q0 !linear0 mul0r size_poly0.
rewrite mul_row_col scaleNr mulNmx !mul_rV_lin1 /= !linearZ /= !poly_rV_K //.
by rewrite !scalerCA p'r q'r mulrCA addNr.
Qed.

Section HornerMx.

Variables (R : comRingType) (n' : nat).
Local Notation n := n'.+1.
Variable A : 'M[R]_n.
Implicit Types p q : {poly R}.

Definition horner_mx := horner_morph (fun a => scalar_mx_comm a A).
Canonical horner_mx_additive := [additive of horner_mx].
Canonical horner_mx_rmorphism := [rmorphism of horner_mx].

Lemma horner_mx_C a : horner_mx a%:P = a%:M.
Proof. exact: horner_morphC. Qed.

Lemma horner_mx_X : horner_mx 'X = A. Proof. exact: horner_morphX. Qed.

Lemma horner_mxZ : scalable horner_mx.
Proof.
move=> a p /=; rewrite -mul_polyC rmorphM /=.
by rewrite horner_mx_C [_ * _]mul_scalar_mx.
Qed.

Canonical horner_mx_linear := AddLinear horner_mxZ.
Canonical horner_mx_lrmorphism := [lrmorphism of horner_mx].

Definition powers_mx d := \matrix_(i < d) mxvec (A ^+ i).

Lemma horner_rVpoly m (u : 'rV_m) :
  horner_mx (rVpoly u) = vec_mx (u *m powers_mx m).
Proof.
rewrite mulmx_sum_row linear_sum [rVpoly u]poly_def rmorph_sum.
apply: eq_bigr => i _.
by rewrite valK !linearZ rmorphX /= horner_mx_X rowK /= mxvecK.
Qed.

End HornerMx.

Section CharPoly.

Variables (R : ringType) (n : nat) (A : 'M[R]_n).
Implicit Types p q : {poly R}.

Definition char_poly_mx := 'X%:M - map_mx (@polyC R) A.
Definition char_poly := \det char_poly_mx.

Let diagA := [seq A i i | i : 'I_n].
Let size_diagA : size diagA = n.
Proof. by rewrite size_image card_ord. Qed.

Let split_diagA :
  exists2 q, \prod_(x <- diagA) ('X - x%:P) + q = char_poly & size q <= n.-1.
Proof.
rewrite [char_poly](bigD1 1%g) //=; set q := \sum_(s | _) _; exists q.
  congr (_ + _); rewrite odd_perm1 mul1r big_map enumT; apply: eq_bigr => i _.
  by rewrite !mxE perm1 eqxx.
apply: leq_trans {q}(size_sum _ _ _) _; apply/bigmax_leqP=> s nt_s.
have{nt_s} [i nfix_i]: exists i, s i != i.
  apply/existsP; rewrite -negb_forall; apply: contra nt_s => s_1.
  by apply/eqP; apply/permP=> i; apply/eqP; rewrite perm1 (forallP s_1).
apply: leq_trans (_ : #|[pred j | s j == j]|.+1 <= n.-1).
  rewrite -sum1_card (@big_mkcond nat) /= size_Msign.
  apply: (big_ind2 (fun p m => size p <= m.+1)) => [| p mp q mq IHp IHq | j _].
  - by rewrite size_poly1.
  - apply: leq_trans (size_mul_leq _ _) _.
    by rewrite -subn1 -addnS leq_subLR addnA leq_add.
  rewrite !mxE eq_sym !inE; case: (s j == j); first by rewrite polyseqXsubC.
  by rewrite sub0r size_opp size_polyC leq_b1.
rewrite -{8}[n]card_ord -(cardC (pred2 (s i) i)) card2 nfix_i !ltnS.
apply: subset_leq_card; apply/subsetP=> j; move/(_ =P j)=> fix_j.
rewrite !inE -{1}fix_j (inj_eq (@perm_inj _ s)) orbb.
by apply: contraNneq nfix_i => <-; rewrite fix_j.
Qed.

Lemma size_char_poly : size char_poly = n.+1.
Proof.
have [q <- lt_q_n] := split_diagA; have le_q_n := leq_trans lt_q_n (leq_pred n).
by rewrite size_addl size_prod_XsubC size_diagA.
Qed.

Lemma char_poly_monic : char_poly \is monic.
Proof.
rewrite monicE -(monicP (monic_prod_XsubC diagA xpredT id)).
rewrite !lead_coefE size_char_poly.
have [q <- lt_q_n] := split_diagA; have le_q_n := leq_trans lt_q_n (leq_pred n).
by rewrite size_prod_XsubC size_diagA coefD (nth_default 0 le_q_n) addr0.
Qed.

Lemma char_poly_trace : n > 0 -> char_poly`_n.-1 = - \tr A.
Proof.
move=> n_gt0; have [q <- lt_q_n] := split_diagA; set p := \prod_(x <- _) _.
rewrite coefD {q lt_q_n}(nth_default 0 lt_q_n) addr0.
have{n_gt0} ->: p`_n.-1 = ('X * p)`_n by rewrite coefXM eqn0Ngt n_gt0.
have ->: \tr A = \sum_(x <- diagA) x by rewrite big_map enumT.
rewrite -size_diagA {}/p; elim: diagA => [|x d IHd].
  by rewrite !big_nil mulr1 coefX oppr0.
rewrite !big_cons coefXM mulrBl coefB IHd opprD addrC; congr (- _ + _).
rewrite mul_polyC coefZ [size _]/= -(size_prod_XsubC _ id) -lead_coefE.
by rewrite (monicP _) ?monic_prod_XsubC ?mulr1.
Qed.

Lemma char_poly_det : char_poly`_0 = (- 1) ^+ n * \det A.
Proof.
rewrite big_distrr coef_sum [0%N]lock /=; apply: eq_bigr => s _.
rewrite -{1}rmorphN -rmorphX mul_polyC coefZ /=.
rewrite mulrA -exprD addnC exprD -mulrA -lock; congr (_ * _).
transitivity (\prod_(i < n) - A i (s i)); last by rewrite prodrN card_ord.
elim: (index_enum _) => [|i e IHe]; rewrite !(big_nil, big_cons) ?coef1 //.
by rewrite coefM big_ord1 IHe !mxE coefB coefC coefMn coefX mul0rn sub0r.
Qed.

End CharPoly.

Lemma mx_poly_ring_isom (R : ringType) n' (n := n'.+1) :
  exists phi : {rmorphism 'M[{poly R}]_n -> {poly 'M[R]_n}},
  [/\ bijective phi,
      forall p, phi p%:M = map_poly scalar_mx p,
      forall A, phi (map_mx polyC A) = A%:P
    & forall A i j k, (phi A)`_k i j = (A i j)`_k].
Proof.
set M_RX := 'M[{poly R}]_n; set MR_X := ({poly 'M[R]_n}).
pose Msize (A : M_RX) := \max_i \max_j size (A i j).
pose phi (A : M_RX) := \poly_(k < Msize A) \matrix_(i, j) (A i j)`_k.
have coef_phi A i j k: (phi A)`_k i j = (A i j)`_k.
  rewrite coef_poly; case: (ltnP k _) => le_m_k; rewrite mxE // nth_default //.
  apply: leq_trans (leq_trans (leq_bigmax i) le_m_k); exact: (leq_bigmax j).
have phi_is_rmorphism : rmorphism phi.
  do 2?[split=> [A B|]]; apply/polyP=> k; apply/matrixP=> i j; last 1 first.
  - rewrite coef_phi mxE coefMn !coefC.
    by case: (k == _); rewrite ?mxE ?mul0rn.
  - by rewrite !(coef_phi, mxE, coefD, coefN).
  rewrite !coef_phi !mxE !coefM summxE coef_sum.
  pose F k1 k2 := (A i k1)`_k2 * (B k1 j)`_(k - k2).
  transitivity (\sum_k1 \sum_(k2 < k.+1) F k1 k2); rewrite {}/F.
    by apply: eq_bigr=> k1 _; rewrite coefM.
  rewrite exchange_big /=; apply: eq_bigr => k2 _.
  by rewrite mxE; apply: eq_bigr => k1 _; rewrite !coef_phi.
have bij_phi: bijective phi.
  exists (fun P : MR_X => \matrix_(i, j) \poly_(k < size P) P`_k i j) => [A|P].
    apply/matrixP=> i j; rewrite mxE; apply/polyP=> k.
    rewrite coef_poly -coef_phi.
    by case: leqP => // P_le_k; rewrite nth_default ?mxE.
  apply/polyP=> k; apply/matrixP=> i j; rewrite coef_phi mxE coef_poly.
  by case: leqP => // P_le_k; rewrite nth_default ?mxE.
exists (RMorphism phi_is_rmorphism).
split=> // [p | A]; apply/polyP=> k; apply/matrixP=> i j.
  by rewrite coef_phi coef_map !mxE coefMn.
by rewrite coef_phi !mxE !coefC; case k; last rewrite /= mxE.
Qed.

Theorem Cayley_Hamilton (R : comRingType) n' (A : 'M[R]_n'.+1) :
  horner_mx A (char_poly A) = 0.
Proof.
have [phi [_ phiZ phiC _]] := mx_poly_ring_isom R n'.
apply/rootP/factor_theorem; rewrite -phiZ -mul_adj_mx rmorphM.
by move: (phi _) => q; exists q; rewrite rmorphB phiC phiZ map_polyX.
Qed.

Lemma eigenvalue_root_char (F : fieldType) n (A : 'M[F]_n) a :
  eigenvalue A a = root (char_poly A) a.
Proof.
transitivity (\det (a%:M - A) == 0).
  apply/eigenvalueP/det0P=> [[v Av_av v_nz] | [v v_nz Av_av]]; exists v => //.
    by rewrite mulmxBr Av_av mul_mx_scalar subrr.
  by apply/eqP; rewrite -mul_mx_scalar eq_sym -subr_eq0 -mulmxBr Av_av.
congr (_ == 0); rewrite horner_sum; apply: eq_bigr => s _.
rewrite hornerM horner_exp !hornerE; congr (_ * _).
rewrite (big_morph _ (fun p q => hornerM p q a) (hornerC 1 a)).
by apply: eq_bigr => i _; rewrite !mxE !(hornerE, hornerMn).
Qed.

Section MinPoly.

Variables (F : fieldType) (n' : nat).
Local Notation n := n'.+1.
Variable A : 'M[F]_n.
Implicit Types p q : {poly F}.

Fact degree_mxminpoly_proof : exists d, \rank (powers_mx A d.+1) <= d.
Proof. by exists (n ^ 2)%N; rewrite rank_leq_col. Qed.
Definition degree_mxminpoly := ex_minn degree_mxminpoly_proof.
Local Notation d := degree_mxminpoly.
Local Notation Ad := (powers_mx A d).

Lemma mxminpoly_nonconstant : d > 0.
Proof.
rewrite /d; case: ex_minnP; case=> //; rewrite leqn0 mxrank_eq0; move/eqP.
move/row_matrixP; move/(_ 0); move/eqP; rewrite rowK row0 mxvec_eq0.
by rewrite -mxrank_eq0 mxrank1.
Qed.

Lemma minpoly_mx1 : (1%:M \in Ad)%MS.
Proof.
by apply: (eq_row_sub (Ordinal mxminpoly_nonconstant)); rewrite rowK.
Qed.

Lemma minpoly_mx_free : row_free Ad.
Proof.
have:= mxminpoly_nonconstant; rewrite /d; case: ex_minnP; case=> // d' _.
move/(_ d'); move/implyP; rewrite ltnn implybF -ltnS ltn_neqAle.
by rewrite rank_leq_row andbT negbK.
Qed.

Lemma horner_mx_mem p : (horner_mx A p \in Ad)%MS.
Proof.
elim/poly_ind: p => [|p a IHp]; first by rewrite rmorph0 // linear0 sub0mx.
rewrite rmorphD rmorphM /= horner_mx_C horner_mx_X.
rewrite addrC -scalemx1 linearP /= -(mul_vec_lin (mulmxr_linear _ A)).
case/submxP: IHp => u ->{p}.
have: (powers_mx A (1 + d) <= Ad)%MS.
  rewrite -(geq_leqif (mxrank_leqif_sup _)).
    by rewrite (eqnP minpoly_mx_free) /d; case: ex_minnP.
  rewrite addnC; apply/row_subP=> i.
  by apply: eq_row_sub (lshift 1 i) _; rewrite !rowK.
apply: submx_trans; rewrite addmx_sub ?scalemx_sub //.
  by apply: (eq_row_sub 0); rewrite rowK.
rewrite -mulmxA mulmx_sub {u}//; apply/row_subP=> i.
rewrite row_mul rowK mul_vec_lin /= mulmxE -exprSr.
by apply: (eq_row_sub (rshift 1 i)); rewrite rowK.
Qed.

Definition mx_inv_horner B := rVpoly (mxvec B *m pinvmx Ad).

Lemma mx_inv_horner0 :  mx_inv_horner 0 = 0.
Proof. by rewrite /mx_inv_horner !(linear0, mul0mx). Qed.

Lemma mx_inv_hornerK B : (B \in Ad)%MS -> horner_mx A (mx_inv_horner B) = B.
Proof. by move=> sBAd; rewrite horner_rVpoly mulmxKpV ?mxvecK. Qed.

Lemma minpoly_mxM B C : (B \in Ad -> C \in Ad -> B * C \in Ad)%MS.
Proof.
move=> AdB AdC; rewrite -(mx_inv_hornerK AdB) -(mx_inv_hornerK AdC).
by rewrite -rmorphM ?horner_mx_mem.
Qed.

Lemma minpoly_mx_ring : mxring Ad.
Proof.
apply/andP; split; first by apply/mulsmx_subP; exact: minpoly_mxM.
apply/mxring_idP; exists 1%:M; split=> *; rewrite ?mulmx1 ?mul1mx //.
  by rewrite -mxrank_eq0 mxrank1.
exact: minpoly_mx1.
Qed.

Definition mxminpoly := 'X^d - mx_inv_horner (A ^+ d).
Local Notation p_A := mxminpoly.

Lemma size_mxminpoly : size p_A = d.+1.
Proof. by rewrite size_addl ?size_polyXn // size_opp ltnS size_poly. Qed.

Lemma mxminpoly_monic : p_A \is monic.
Proof.
rewrite monicE /lead_coef size_mxminpoly coefB coefXn eqxx /=.
by rewrite nth_default ?size_poly // subr0.
Qed.

Lemma size_mod_mxminpoly p : size (p %% p_A) <= d.
Proof.
by rewrite -ltnS -size_mxminpoly ltn_modp // -size_poly_eq0 size_mxminpoly.
Qed.

Lemma mx_root_minpoly : horner_mx A p_A = 0.
Proof.
rewrite rmorphB -{3}(horner_mx_X A) -rmorphX /=.
by rewrite mx_inv_hornerK ?subrr ?horner_mx_mem.
Qed.

Lemma horner_rVpolyK (u : 'rV_d) :
  mx_inv_horner (horner_mx A (rVpoly u)) = rVpoly u.
Proof.
congr rVpoly; rewrite horner_rVpoly vec_mxK.
by apply: (row_free_inj minpoly_mx_free); rewrite mulmxKpV ?submxMl.
Qed.

Lemma horner_mxK p : mx_inv_horner (horner_mx A p) = p %% p_A.
Proof.
rewrite {1}(Pdiv.IdomainMonic.divp_eq mxminpoly_monic p) rmorphD rmorphM /=.
rewrite mx_root_minpoly mulr0 add0r.
by rewrite -(poly_rV_K (size_mod_mxminpoly _)) horner_rVpolyK.
Qed.

Lemma mxminpoly_min p : horner_mx A p = 0 -> p_A %| p.
Proof. by move=> pA0; rewrite /dvdp -horner_mxK pA0 mx_inv_horner0. Qed.

Lemma horner_rVpoly_inj : @injective 'M_n 'rV_d (horner_mx A \o rVpoly).
Proof.
apply: can_inj (poly_rV \o mx_inv_horner) _ => u.
by rewrite /= horner_rVpolyK rVpolyK.
Qed.

Lemma mxminpoly_linear_is_scalar : (d <= 1) = is_scalar_mx A.
Proof.
have scalP := has_non_scalar_mxP minpoly_mx1.
rewrite leqNgt -(eqnP minpoly_mx_free); apply/scalP/idP=> [|[[B]]].
  case scalA: (is_scalar_mx A); [by right | left].
  by exists A; rewrite ?scalA // -{1}(horner_mx_X A) horner_mx_mem.
move/mx_inv_hornerK=> <- nsB; case/is_scalar_mxP=> a defA; case/negP: nsB.
move: {B}(_ B); apply: poly_ind => [|p c].
  by rewrite rmorph0 ?mx0_is_scalar.
rewrite rmorphD ?rmorphM /= horner_mx_X defA; case/is_scalar_mxP=> b ->.
by rewrite -rmorphM horner_mx_C -rmorphD /= scalar_mx_is_scalar.
Qed.

Lemma mxminpoly_dvd_char : p_A %| char_poly A.
Proof. by apply: mxminpoly_min; exact: Cayley_Hamilton. Qed.

Lemma eigenvalue_root_min a : eigenvalue A a = root p_A a.
Proof.
apply/idP/idP=> Aa; last first.
  rewrite eigenvalue_root_char !root_factor_theorem in Aa *.
  exact: dvdp_trans Aa mxminpoly_dvd_char.
have{Aa} [v Av_av v_nz] := eigenvalueP Aa.
apply: contraR v_nz => pa_nz; rewrite -{pa_nz}(eqmx_eq0 (eqmx_scale _ pa_nz)).
apply/eqP; rewrite -(mulmx0 _ v) -mx_root_minpoly.
elim/poly_ind: p_A => [|p c IHp].
  by rewrite rmorph0 horner0 scale0r mulmx0.
rewrite !hornerE rmorphD rmorphM /= horner_mx_X horner_mx_C scalerDl.
by rewrite -scalerA mulmxDr mul_mx_scalar mulmxA -IHp -scalemxAl Av_av.
Qed.

End MinPoly.

(* Parametricity. *)
Section MapRingMatrix.

Variables (aR rR : ringType) (f : {rmorphism aR -> rR}).
Local Notation "A ^f" := (map_mx (GRing.RMorphism.apply f) A) : ring_scope.
Local Notation fp := (map_poly (GRing.RMorphism.apply f)).
Variables (d n : nat) (A : 'M[aR]_n).

Lemma map_rVpoly (u : 'rV_d) : fp (rVpoly u) = rVpoly u^f.
Proof.
apply/polyP=> k; rewrite coef_map !coef_rVpoly.
by case: (insub k) => [i|]; rewrite  /=  ?rmorph0 // mxE.
Qed.

Lemma map_poly_rV p : (poly_rV p)^f = poly_rV (fp p) :> 'rV_d.
Proof. by apply/rowP=> j; rewrite !mxE coef_map. Qed.

Lemma map_char_poly_mx : map_mx fp (char_poly_mx A) = char_poly_mx A^f.
Proof.
rewrite raddfB /= map_scalar_mx /= map_polyX; congr (_ - _).
by apply/matrixP=> i j; rewrite !mxE map_polyC.
Qed.

Lemma map_char_poly : fp (char_poly A) = char_poly A^f.
Proof. by rewrite -det_map_mx map_char_poly_mx. Qed.

End MapRingMatrix.

Section MapResultant.

Lemma map_resultant (aR rR : ringType) (f : {rmorphism {poly aR} -> rR}) p q :
    f (lead_coef p) != 0 -> f (lead_coef q) != 0 ->
  f (resultant p q)= resultant (map_poly f p) (map_poly f q).
Proof.
move=> nz_fp nz_fq; rewrite /resultant /Sylvester_mx !size_map_poly_id0 //.
rewrite -det_map_mx /= map_col_mx; congr (\det (col_mx _ _));
  by apply: map_lin1_mx => v; rewrite map_poly_rV rmorphM /= map_rVpoly.
Qed.

End MapResultant.

Section MapComRing.

Variables (aR rR : comRingType) (f : {rmorphism aR -> rR}).
Local Notation "A ^f" := (map_mx f A) : ring_scope.
Local Notation fp := (map_poly f).
Variables (n' : nat) (A : 'M[aR]_n'.+1).

Lemma map_powers_mx e : (powers_mx A e)^f = powers_mx A^f e.
Proof. by apply/row_matrixP=> i; rewrite -map_row !rowK map_mxvec rmorphX. Qed.

Lemma map_horner_mx p : (horner_mx A p)^f = horner_mx A^f (fp p).
Proof.
rewrite -[p](poly_rV_K (leqnn _)) map_rVpoly.
by rewrite !horner_rVpoly map_vec_mx map_mxM map_powers_mx.
Qed.

End MapComRing.

Section MapField.

Variables (aF rF : fieldType) (f : {rmorphism aF -> rF}).
Local Notation "A ^f" := (map_mx f A) : ring_scope.
Local Notation fp := (map_poly f).
Variables (n' : nat) (A : 'M[aF]_n'.+1).

Lemma degree_mxminpoly_map : degree_mxminpoly A^f = degree_mxminpoly A.
Proof. by apply: eq_ex_minn => e; rewrite -map_powers_mx mxrank_map. Qed.

Lemma mxminpoly_map : mxminpoly A^f = fp (mxminpoly A).
Proof.
rewrite rmorphB; congr (_ - _).
  by rewrite /= map_polyXn degree_mxminpoly_map.
rewrite degree_mxminpoly_map -rmorphX /=.
apply/polyP=> i; rewrite coef_map //= !coef_rVpoly degree_mxminpoly_map.
case/insub: i => [i|]; last by rewrite rmorph0.
by rewrite -map_powers_mx -map_pinvmx // -map_mxvec -map_mxM // mxE.
Qed.

Lemma map_mx_inv_horner u : fp (mx_inv_horner A u) = mx_inv_horner A^f u^f.
Proof.
rewrite map_rVpoly map_mxM map_mxvec map_pinvmx map_powers_mx.
by rewrite /mx_inv_horner degree_mxminpoly_map.
Qed.

End MapField.

Section IntegralOverRing.

Definition integralOver (R K : ringType) (RtoK : R -> K) (z : K) :=
  exists2 p, p \is monic & root (map_poly RtoK p) z.

Definition integralRange R K RtoK := forall z, @integralOver R K RtoK z.

Variables (B R K : ringType) (BtoR : B -> R) (RtoK : {rmorphism R -> K}).

Lemma integral_rmorph x :
  integralOver BtoR x -> integralOver (RtoK \o BtoR) (RtoK x).
Proof. by case=> p; exists p; rewrite // map_poly_comp rmorph_root. Qed.

Lemma integral_id x : integralOver RtoK (RtoK x).
Proof. by exists ('X - x%:P); rewrite ?monicXsubC ?rmorph_root ?root_XsubC. Qed.

Lemma integral_nat n : integralOver RtoK n%:R.
Proof. by rewrite -(rmorph_nat RtoK); apply: integral_id. Qed.

Lemma integral0 : integralOver RtoK 0. Proof. exact: (integral_nat 0). Qed.

Lemma integral1 : integralOver RtoK 1. Proof. exact: (integral_nat 1). Qed.

Lemma integral_poly (p : {poly K}) :
  (forall i, integralOver RtoK p`_i) <-> {in p : seq K, integralRange RtoK}.
Proof.
split=> intRp => [_ /(nthP 0)[i _ <-] // | i]; rewrite -[p]coefK coef_poly.
by case: ifP => [ltip | _]; [apply/intRp/mem_nth | apply: integral0].
Qed.

End IntegralOverRing.

Section IntegralOverComRing.

Variables (R K : comRingType) (RtoK : {rmorphism R -> K}).

Lemma integral_horner_root w (p q : {poly K}) :
    p \is monic -> root p w ->
    {in p : seq K, integralRange RtoK} -> {in q : seq K, integralRange RtoK} ->
  integralOver RtoK q.[w].
Proof.
move=> mon_p pw0 intRp intRq.
pose memR y := exists x, y = RtoK x.
have memRid x: memR (RtoK x) by exists x.
have memR_nat n: memR n%:R by rewrite -(rmorph_nat RtoK).
have [memR0 memR1]: memR 0 * memR 1 := (memR_nat 0%N, memR_nat 1%N).
have memRN1: memR (- 1) by exists (- 1); rewrite rmorphN1.
pose rVin (E : K -> Prop) n (a : 'rV[K]_n) := forall i, E (a 0 i).
pose pXin (E : K -> Prop) (r : {poly K}) := forall i, E r`_i.
pose memM E n (X : 'rV_n) y := exists a, rVin E n a /\ y = (a *m X^T) 0 0.
pose finM E S := exists n, exists X, forall y, memM E n X y <-> S y.
have tensorM E n1 n2 X Y: finM E (memM (memM E n2 Y) n1 X).
  exists (n1 * n2)%N, (mxvec (X^T *m Y)) => y.
  split=> [[a [Ea Dy]] | [a1 [/fin_all_exists[a /all_and2[Ea Da1]] ->]]].
    exists (Y *m (vec_mx a)^T); split=> [i|].
      exists (row i (vec_mx a)); split=> [j|]; first by rewrite !mxE; apply: Ea.
      by rewrite -row_mul -{1}[Y]trmxK -trmx_mul !mxE.
    by rewrite -[Y]trmxK -!trmx_mul mulmxA -mxvec_dotmul trmx_mul trmxK vec_mxK.
  exists (mxvec (\matrix_i a i)); split.
    by case/mxvec_indexP=> i j; rewrite mxvecE mxE; apply: Ea.
  rewrite -[mxvec _]trmxK -trmx_mul mxvec_dotmul -mulmxA trmx_mul !mxE.
  apply: eq_bigr => i _; rewrite Da1 !mxE; congr (_ * _).
  by apply: eq_bigr => j _; rewrite !mxE.
suffices [m [X [[u [_ Du]] idealM]]]: exists m,
  exists X, let M := memM memR m X in M 1 /\ forall y, M y -> M (q.[w] * y).
- do [set M := memM _ m X; move: q.[w] => z] in idealM *.
  have MX i: M (X 0 i).
    by exists (delta_mx 0 i); split=> [j|]; rewrite -?rowE !mxE.
  have /fin_all_exists[a /all_and2[Fa Da1]] i := idealM _ (MX i).
  have /fin_all_exists[r Dr] i := fin_all_exists (Fa i).
  pose A := \matrix_(i, j) r j i; pose B := z%:M - map_mx RtoK A.
  have XB0: X *m B = 0.
    apply/eqP; rewrite mulmxBr mul_mx_scalar subr_eq0; apply/eqP/rowP=> i.
    by rewrite !mxE Da1 mxE; apply: eq_bigr=> j _; rewrite !mxE mulrC Dr.
  exists (char_poly A); first exact: char_poly_monic.
  have: (\det B *: (u *m X^T)) 0 0 == 0.
    rewrite scalemxAr -linearZ -mul_mx_scalar -mul_mx_adj mulmxA XB0 /=.
    by rewrite mul0mx trmx0 mulmx0 mxE.
  rewrite mxE -Du mulr1 rootE -horner_evalE -!det_map_mx; congr (\det _ == 0).
  rewrite !raddfB /= !map_scalar_mx /= map_polyX horner_evalE hornerX.
  by apply/matrixP=> i j; rewrite !mxE map_polyC /horner_eval hornerC.
pose gen1 x E y := exists2 r, pXin E r & y = r.[x]; pose gen := foldr gen1 memR.
have gen1S (E : K -> Prop) x y: E 0 -> E y -> gen1 x E y.
  by exists y%:P => [i|]; rewrite ?hornerC ?coefC //; case: ifP.
have genR S y: memR y -> gen S y.
  by elim: S => //= x S IH in y * => /IH; apply: gen1S; apply: IH.
have gen0 := genR _ 0 memR0; have gen_1 := genR _ 1 memR1.
have{gen1S} genS S y: y \in S -> gen S y.
  elim: S => //= x S IH /predU1P[-> | /IH//]; last exact: gen1S.
  by exists 'X => [i|]; rewrite ?hornerX // coefX; apply: genR.
pose propD (R : K -> Prop) := forall x y, R x -> R y -> R (x + y).
have memRD: propD memR.
  by move=> _ _ [a ->] [b ->]; exists (a + b); rewrite rmorphD.
have genD S: propD (gen S).
  elim: S => //= x S IH _ _ [r1 Sr1 ->] [r2 Sr2 ->]; rewrite -hornerD.
  by exists (r1 + r2) => // i; rewrite coefD; apply: IH.
have gen_sum S := big_ind _ (gen0 S) (genD S).
pose propM (R : K -> Prop) := forall x y, R x -> R y -> R (x * y).
have memRM: propM memR.
  by move=> _ _ [a ->] [b ->]; exists (a * b); rewrite rmorphM.
have genM S: propM (gen S).
  elim: S => //= x S IH _ _ [r1 Sr1 ->] [r2 Sr2 ->]; rewrite -hornerM.
  by exists (r1 * r2) => // i; rewrite coefM; apply: gen_sum => j _; apply: IH.
have gen_horner S r y: pXin (gen S) r -> gen S y -> gen S r.[y].
  move=> Sq Sy; rewrite horner_coef; apply: gen_sum => [[i _] /= _].
  by elim: {2}i => [|n IHn]; rewrite ?mulr1 // exprSr mulrA; apply: genM.
pose S := w :: q ++ p; suffices [m [X defX]]: finM memR (gen S).
  exists m, X => M; split=> [|y /defX Xy]; first exact/defX.
  apply/defX/genM => //; apply: gen_horner => // [i|]; last exact/genS/mem_head.
  rewrite -[q]coefK coef_poly; case: ifP => // lt_i_q.
  by apply: genS; rewrite inE mem_cat mem_nth ?orbT.
pose intR R y := exists r, [/\ r \is monic, root r y & pXin R r].
pose fix genI s := if s is y :: s1 then intR (gen s1) y /\ genI s1 else True.
have{mon_p pw0 intRp intRq}: genI S.
  split; set S1 := _ ++ _; first exists p.
    split=> // i; rewrite -[p]coefK coef_poly; case: ifP => // lt_i_p.
    by apply: genS; rewrite mem_cat orbC mem_nth.
  have: all (mem S1) S1 by exact/allP.
  elim: {-1}S1 => //= y S2 IH /andP[S1y S12]; split; last exact: IH.
  have{q S S1 IH S1y S12 intRp intRq} [q mon_q qx0]: integralOver RtoK y.
    by move: S1y; rewrite mem_cat => /orP[]; [apply: intRq | apply: intRp].
  exists (map_poly RtoK q); split=> // [|i]; first exact: monic_map.
  by rewrite coef_map /=; apply: genR.
elim: {w p q}S => /= [_|x S IH [[p [mon_p px0 Sp]] /IH{IH}[m2 [X2 defS]]]].
  exists 1%N, 1 => y; split=> [[a [Fa ->]] | Fy].
    by rewrite tr_scalar_mx mulmx1; apply: Fa.
  by exists y%:M; split=> [i|]; rewrite 1?ord1 ?tr_scalar_mx ?mulmx1 mxE.
pose m1 := (size p).-1; pose X1 := \row_(i < m1) x ^+ i.
have [m [X defM]] := tensorM memR m1 m2 X1 X2; set M := memM _ _ _ in defM.
exists m, X => y; rewrite -/M; split=> [/defM[a [M2a]] | [q Sq]] -> {y}.
  exists (rVpoly a) => [i|].
    by rewrite coef_rVpoly; case/insub: i => // i; apply/defS/M2a.
  rewrite mxE (horner_coef_wide _ (size_poly _ _)) -/(rVpoly a).
  by apply: eq_bigr => i _; rewrite coef_rVpoly_ord !mxE.
have M_0: M 0 by exists 0; split=> [i|]; rewrite ?mul0mx mxE.
have M_D: propD M.
  move=> _ _ [a [Fa ->]] [b [Fb ->]]; exists (a + b).
  by rewrite mulmxDl !mxE; split=> // i; rewrite mxE; apply: memRD.
have{M_0 M_D} Msum := big_ind _ M_0 M_D.
rewrite horner_coef; apply: (Msum) => i _; case: i q`_i {Sq}(Sq i) => /=.
elim: {q}(size q) => // n IHn i i_le_n y Sy.
have [i_lt_m1 | m1_le_i] := ltnP i m1.
  apply/defM; exists (y *: delta_mx 0 (Ordinal i_lt_m1)); split=> [j|].
    by apply/defS; rewrite !mxE /= mulr_natr; case: eqP.
  by rewrite -scalemxAl -rowE !mxE.
rewrite -(subnK m1_le_i) exprD -[x ^+ m1]subr0 -(rootP px0) horner_coef.
rewrite polySpred ?monic_neq0 // -/m1 big_ord_recr /= -lead_coefE.
rewrite opprD addrC (monicP mon_p) mul1r subrK !mulrN -mulNr !mulr_sumr.
apply: Msum => j _; rewrite mulrA mulrACA -exprD; apply: IHn.
  by rewrite -addnS addnC addnBA // leq_subLR leq_add.
by rewrite -mulN1r; do 2!apply: (genM) => //; apply: genR.
Qed.

Lemma integral_root_monic u p :
    p \is monic -> root p u -> {in p : seq K, integralRange RtoK} ->
  integralOver RtoK u.
Proof.
move=> mon_p pu0 intRp; rewrite -[u]hornerX.
apply: integral_horner_root mon_p pu0 intRp _.
by apply/integral_poly => i; rewrite coefX; apply: integral_nat.
Qed.

Hint Resolve (integral0 RtoK) (integral1 RtoK) (@monicXsubC K).

Let XsubC0 (u : K) : root ('X - u%:P) u. Proof. by rewrite root_XsubC. Qed.
Let intR_XsubC u :
  integralOver RtoK (- u) -> {in 'X - u%:P : seq K, integralRange RtoK}.
Proof. by move=> intRu v; rewrite polyseqXsubC !inE => /pred2P[]->. Qed.

Lemma integral_opp u : integralOver RtoK u -> integralOver RtoK (- u).
Proof. by rewrite -{1}[u]opprK => /intR_XsubC/integral_root_monic; apply. Qed.

Lemma integral_horner (p : {poly K}) u :
    {in p : seq K, integralRange RtoK} -> integralOver RtoK u ->
  integralOver RtoK p.[u].
Proof. by move=> ? /integral_opp/intR_XsubC/integral_horner_root; apply. Qed.

Lemma integral_sub u v :
  integralOver RtoK u -> integralOver RtoK v -> integralOver RtoK (u - v).
Proof.
move=> intRu /integral_opp/intR_XsubC/integral_horner/(_ intRu).
by rewrite !hornerE.
Qed.

Lemma integral_add u v :
  integralOver RtoK u -> integralOver RtoK v -> integralOver RtoK (u + v).
Proof. by rewrite -{2}[v]opprK => intRu /integral_opp; apply: integral_sub. Qed.

Lemma integral_mul u v :
  integralOver RtoK u -> integralOver RtoK v -> integralOver RtoK (u * v).
Proof.
rewrite -{2}[v]hornerX -hornerZ => intRu; apply: integral_horner.
by apply/integral_poly=> i; rewrite coefZ coefX mulr_natr mulrb; case: ifP.
Qed.

End IntegralOverComRing.

Section IntegralOverField.

Variables (F E : fieldType) (FtoE : {rmorphism F -> E}).

Definition algebraicOver (fFtoE : F -> E) u :=
  exists2 p, p != 0 & root (map_poly fFtoE p) u.

Notation mk_mon p := ((lead_coef p)^-1 *: p).

Lemma integral_algebraic u : algebraicOver FtoE u <-> integralOver FtoE u.
Proof.
split=> [] [p p_nz pu0]; last by exists p; rewrite ?monic_neq0.
exists (mk_mon p); first by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0.
by rewrite linearZ rootE hornerZ (rootP pu0) mulr0.
Qed.

Lemma integral_inv u : integralOver FtoE u -> integralOver FtoE u^-1.
Proof.
have [-> | /expf_neq0 nz_u_n] := eqVneq u 0; first by rewrite invr0.
case/integral_algebraic=> p nz_p pu0; apply/integral_algebraic.
exists (Poly (rev p)).
  apply/eqP=> /polyP/(_ 0%N); rewrite coef_Poly coef0 nth_rev ?size_poly_gt0 //.
  by apply/eqP; rewrite subn1 lead_coef_eq0.
apply/eqP/(mulfI (nz_u_n (size p).-1)); rewrite mulr0 -(rootP pu0).
rewrite (@horner_coef_wide _ (size p)); last first.
  by rewrite size_map_poly -(size_rev p) size_Poly.
rewrite horner_coef mulr_sumr size_map_poly.
rewrite [rhs in _ = rhs](reindex_inj rev_ord_inj) /=.
apply: eq_bigr => i _; rewrite !coef_map coef_Poly nth_rev // mulrCA.
by congr (_ * _); rewrite -{1}(subnKC (valP i)) addSn addnC exprD exprVn ?mulfK.
Qed.

Lemma integral_div u v :
  integralOver FtoE u -> integralOver FtoE v -> integralOver FtoE (u / v).
Proof. by move=> algFu /integral_inv; apply: integral_mul. Qed.

Lemma integral_root p u :
    p != 0 -> root p u -> {in p : seq E, integralRange FtoE} ->
  integralOver FtoE u.
Proof.
move=> nz_p pu0 algFp.
have mon_p1: mk_mon p \is monic.
  by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0.
have p1u0: root (mk_mon p) u by rewrite rootE hornerZ (rootP pu0) mulr0.
apply: integral_root_monic mon_p1 p1u0 _ => _ /(nthP 0)[i ltip <-].
rewrite coefZ mulrC; rewrite size_scale ?invr_eq0 ?lead_coef_eq0 // in ltip.
by apply: integral_div; apply/algFp/mem_nth; rewrite -?polySpred.
Qed.

End IntegralOverField.

(* Lifting term, formula, envs and eval to matrices. Wlog, and for the sake  *)
(* of simplicity, we only lift (tensor) envs to row vectors; we can always   *)
(* use mxvec/vec_mx to store and retrieve matrices.                          *)
(* We don't provide definitions for addition, substraction, scaling, etc,    *)
(* because they have simple matrix expressions.                              *)
Module MatrixFormula.

Section MatrixFormula.

Variable F : fieldType.

Local Notation False := GRing.False.
Local Notation True := GRing.True.
Local Notation And := GRing.And (only parsing).
Local Notation Add := GRing.Add (only parsing).
Local Notation Bool b := (GRing.Bool b%bool).
Local Notation term := (GRing.term F).
Local Notation form := (GRing.formula F).
Local Notation eval := GRing.eval.
Local Notation holds := GRing.holds.
Local Notation qf_form := GRing.qf_form.
Local Notation qf_eval := GRing.qf_eval.

Definition eval_mx (e : seq F) := map_mx (eval e).

Definition mx_term := map_mx (@GRing.Const F).

Lemma eval_mx_term e m n (A : 'M_(m, n)) : eval_mx e (mx_term A) = A.
Proof. by apply/matrixP=> i j; rewrite !mxE. Qed.

Definition mulmx_term m n p (A : 'M[term]_(m, n)) (B : 'M_(n, p)) :=
  \matrix_(i, k) (\big[Add/0]_j (A i j * B j k))%T.

Lemma eval_mulmx e m n p (A : 'M[term]_(m, n)) (B : 'M_(n, p)) :
  eval_mx e (mulmx_term A B) = eval_mx e A *m eval_mx e B.
Proof.
apply/matrixP=> i k; rewrite !mxE /= ((big_morph (eval e)) 0 +%R) //=.
by apply: eq_bigr => j _; rewrite /= !mxE.
Qed.

Local Notation morphAnd f := ((big_morph f) true andb).

Let Schur m n (A : 'M[term]_(1 + m, 1 + n)) (a := A 0 0) :=
  \matrix_(i, j) (drsubmx A i j - a^-1 * dlsubmx A i 0%R * ursubmx A 0%R j)%T.

Fixpoint mxrank_form (r m n : nat) : 'M_(m, n) -> form :=
  match m, n return 'M_(m, n) -> form with
  | m'.+1, n'.+1 => fun A : 'M_(1 + m', 1 + n') =>
    let nzA k := A k.1 k.2 != 0 in
    let xSchur k := Schur (xrow k.1 0%R (xcol k.2 0%R A)) in
    let recf k := Bool (r > 0) /\ mxrank_form r.-1 (xSchur k) in
    GRing.Pick nzA recf (Bool (r == 0%N))
  | _, _ => fun _ => Bool (r == 0%N)
  end%T.

Lemma mxrank_form_qf r m n (A : 'M_(m, n)) : qf_form (mxrank_form r A).
Proof.
by elim: m r n A => [|m IHm] r [|n] A //=; rewrite GRing.Pick_form_qf /=.
Qed.

Lemma eval_mxrank e r m n (A : 'M_(m, n)) :
  qf_eval e (mxrank_form r A) = (\rank (eval_mx e A) == r).
Proof.
elim: m r n A => [|m IHm] r [|n] A /=; try by case r.
rewrite GRing.eval_Pick /mxrank unlock /=; set pf := fun _ => _.
rewrite -(@eq_pick _ pf) => [|k]; rewrite {}/pf ?mxE // eq_sym.
case: pick => [[i j]|] //=; set B := _ - _; have:= mxrankE B.
case: (Gaussian_elimination B) r => [[_ _] _] [|r] //= <-; rewrite {}IHm eqSS.
by congr (\rank _ == r); apply/matrixP=> k l; rewrite !(mxE, big_ord1) !tpermR.
Qed.

Lemma eval_vec_mx e m n (u : 'rV_(m * n)) :
  eval_mx e (vec_mx u) = vec_mx (eval_mx e u).
Proof. by apply/matrixP=> i j; rewrite !mxE. Qed.

Lemma eval_mxvec e m n (A : 'M_(m, n)) :
  eval_mx e (mxvec A) = mxvec (eval_mx e A).
Proof. by rewrite -{2}[A]mxvecK eval_vec_mx vec_mxK. Qed.

Section Subsetmx.

Variables (m1 m2 n : nat) (A : 'M[term]_(m1, n)) (B : 'M[term]_(m2, n)).

Definition submx_form :=
  \big[And/True]_(r < n.+1) (mxrank_form r (col_mx A B) ==> mxrank_form r B)%T.

Lemma eval_col_mx e :
  eval_mx e (col_mx A B) = col_mx (eval_mx e A) (eval_mx e B).
Proof. by apply/matrixP=> i j; do 2![rewrite !mxE //; case: split => ?]. Qed.

Lemma submx_form_qf : qf_form submx_form.
Proof.
by rewrite (morphAnd (@qf_form _)) ?big1 //= => r _; rewrite !mxrank_form_qf.
Qed.

Lemma eval_submx e : qf_eval e submx_form = (eval_mx e A <= eval_mx e B)%MS.
Proof.
rewrite (morphAnd (qf_eval e)) //= big_andE /=.
apply/forallP/idP=> /= [|sAB d]; last first.
  rewrite !eval_mxrank eval_col_mx -addsmxE; apply/implyP=> /eqP <-.
  by rewrite mxrank_leqif_sup ?addsmxSr // addsmx_sub sAB /=.
move/(_ (inord (\rank (eval_mx e (col_mx A B))))).
rewrite inordK ?ltnS ?rank_leq_col // !eval_mxrank eqxx /= eval_col_mx.
by rewrite -addsmxE mxrank_leqif_sup ?addsmxSr // addsmx_sub; case/andP.
Qed.

End Subsetmx.

Section Env.

Variable d : nat.

Definition seq_of_rV (v : 'rV_d) : seq F := fgraph [ffun i => v 0 i].

Lemma size_seq_of_rV v : size (seq_of_rV v) = d.
Proof. by rewrite tuple.size_tuple card_ord. Qed.

Lemma nth_seq_of_rV x0 v (i : 'I_d) : nth x0 (seq_of_rV v) i = v 0 i.
Proof. by rewrite nth_fgraph_ord ffunE. Qed.

Definition row_var k : 'rV[term]_d := \row_i ('X_(k * d + i))%T.

Definition row_env (e : seq 'rV_d) := flatten (map seq_of_rV e).

Lemma nth_row_env e k (i : 'I_d) : (row_env e)`_(k * d + i) = e`_k 0 i.
Proof.
elim: e k => [|v e IHe] k; first by rewrite !nth_nil mxE.
rewrite /row_env /= nth_cat size_seq_of_rV.
case: k => [|k]; first by rewrite (valP i) nth_seq_of_rV.
by rewrite mulSn -addnA -if_neg -leqNgt leq_addr addKn IHe.
Qed.

Lemma eval_row_var e k : eval_mx (row_env e) (row_var k) = e`_k :> 'rV_d.
Proof. by apply/rowP=> i; rewrite !mxE /= nth_row_env. Qed.

Definition Exists_row_form k (f : form) :=
  foldr GRing.Exists f (codom (fun i : 'I_d => k * d + i)%N).

Lemma Exists_rowP e k f :
  d > 0 ->
   ((exists v : 'rV[F]_d, holds (row_env (set_nth 0 e k v)) f)
      <-> holds (row_env e) (Exists_row_form k f)).
Proof.
move=> d_gt0; pose i_ j := Ordinal (ltn_pmod j d_gt0).
have d_eq j: (j = j %/ d * d + i_ j)%N := divn_eq j d.
split=> [[v f_v] | ]; last case/GRing.foldExistsP=> e' ee' f_e'.
  apply/GRing.foldExistsP; exists (row_env (set_nth 0 e k v)) => {f f_v}// j.
  rewrite [j]d_eq !nth_row_env nth_set_nth /=; case: eqP => // ->.
  by case/imageP; exists (i_ j).
exists (\row_i e'`_(k * d + i)); apply: eq_holds f_e' => j /=.
move/(_ j): ee'; rewrite [j]d_eq !nth_row_env nth_set_nth /=.
case: eqP => [-> | ne_j_k -> //]; first by rewrite mxE.
apply/mapP=> [[r lt_r_d]]; rewrite -d_eq => def_j; case: ne_j_k.
by rewrite def_j divnMDl // divn_small ?addn0.
Qed.

End Env.

End MatrixFormula.

End MatrixFormula.


Definition tautology : forall P : Prop, P -> P
  := fun (P : Prop) (H : P) => H .

Definition Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P
  :=  fun (P Q : Prop) (H0 : ~ Q /\ (P -> Q)) (H1 : P) =>
        match H0 with conj L R => L (R H1) end.

Definition Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q
  := fun (P Q : Prop) (H0 : P \/ Q) (H1 : ~P) =>
       match H0 with
           | or_introl Hl => False_ind Q (H1 Hl)
           | or_intror Hr => Hr end.

Definition tautology_on_Set : forall A : Set, A -> A
  := fun (A : Set) (H : A) => H.

Definition Modus_tollens_on_Set : forall A B : Set, (B -> Empty_set) * (A -> B) -> (A -> Empty_set)
  := fun (A B : Set) (S0 : (B -> Empty_set) * (A -> B)) (S1 : A) =>
       let (L, R) := S0 in L (R S1).

Definition Disjunctive_syllogism_on_Set : forall A B : Set, (A + B) -> (A -> Empty_set) -> B
  := fun (A B : Set) (S0 : (A + B)) (S1 : A -> Empty_set) =>
       match S0 with
           | inl l => Empty_set_rec (fun _ : Empty_set => B) (S1 l)
           | inr r => r
       end.


Inductive day : Type :=
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day
| sunday : day.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => saturday
  | saturday => sunday
  | sunday => monday
  end.

Inductive bool : Type :=
| true : bool
| false : bool.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1 : bool) (b2 : bool) :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1 : bool) (b2 : bool) :=
  match b1 with
  | true => true
  | false => b2
  end.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end.

Eval simpl in (next_weekday (next_weekday saturday)).

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true ) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true ) = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b1 : bool) (b2 : bool) : bool :=
  match b1, b2 with
  | true, true => false
  | false, true => true
  | true, false => true
  | false, false => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Check (negb true).
Check negb.

Theorem plus_0_n : forall n : nat, 0 + n = n.
Proof.
  simpl. reflexivity. Qed.

Eval simpl in (forall n : nat, n + 0 = n).
Eval simpl in (forall n : nat, 0 + n = n).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Theorem plus_0_n'' : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example : forall n m : nat,
    n = m ->
    n + n = m + m.
Proof.
  intros n m. intros H. rewrite -> H.
  reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
    n = m -> m = o -> n + m = m + o.
Proof.
  intros m n o. intros H. intros I.
  rewrite -> H. rewrite -> I.
  reflexivity.
Qed.

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

Theorem plus_1_n : forall n : nat, 1 + n = S n.
Proof.
  intros n. reflexivity.
Qed.

Theorem mult_1_plus : forall n m : nat,
    (1 + n) * m = m + (n * m).
Proof.
  intros n m.
  rewrite -> plus_1_n.
  reflexivity.
Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat,
    beq_nat (n + 1) 0 = false.
Proof.
  intros n. destruct n as [| n'].
  reflexivity.
  reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
    negb (negb b) = b.
Proof.
  intros b. destruct b.
  reflexivity.
  reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
    beq_nat 0 (n + 1) = false.
Proof.
  intros n. destruct n as [O | S n'].
  reflexivity.
  reflexivity.
Qed.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr (v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
    andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true". reflexivity.
  Case "b = false". rewrite <- H. reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
    andb b c = true -> c = true.
Proof.
  intros [] [].
  - reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
  - reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
Qed.

Theorem plus_0_r : forall n : nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n,
    minus n n = 0.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
  simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem mult_0_r : forall n : nat,
    n * 0 = 0.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
  simpl.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
    S (n + m) = n + (S m).
Proof.
  intros n m.
  induction n as [| n'].
  Case "n = 0".
  simpl.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_0 : forall n : nat,
    n + 0 = n.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
  simpl.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
    n + m = m + n.
Proof.
  intros n m.
  induction n as [ | n'].
  Case "n = 0".
  simpl.
  rewrite -> plus_0.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  rewrite <- plus_n_Sm.
  reflexivity.
Qed.

Fixpoint double (n : nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

Lemma double_plus : forall n, double n = n + n.
Proof.
  intros n.
  induction n as [ | n'].
  Case "n = 0".
  simpl.
  reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'.
  rewrite -> plus_n_Sm.
  reflexivity.
Qed.


(** Type **)
Variable X: Type.
Variable X': forall x x': X, x = x' \/ x <> x'.
Definition UpdateX (x: X) (f: X -> bool) (u: X -> X): X := if f x then u x else x.

(** List **)
Inductive list: Type :=
| nil: list
| cons: X -> list -> list.
Fixpoint InList (l: list) (e: X): Prop :=
    match l with
    | nil => False
    | cons x xs => e = x \/ InList xs e
    end.
Fixpoint UpdateList (l: list) (f: X -> bool) (u: X -> X): list :=
    match l with
    | nil => nil
    | cons x xs => cons (if f x then u x else x) (UpdateList xs f u)
    end.

(** Set **)
Definition set := X -> Prop.
Definition InSet (s: set) (x: X): Prop := s x.
Definition Minus (s: set) (x: X): set := fun x0 => InSet s x0 /\ x <> x0.
Definition Add (s: set) (x: X): set := fun x0 => InSet s x0 \/ x = x0.
Definition UpdateSet (s: set) (f: X -> bool) (u: X -> X): set :=
    fun x0 => exists x: X, InSet s x /\ x0 = if f x then u x else x.

(** Similarity Function **)
Definition Similar (l: list) (s: set): Prop :=
    forall x: X, InList l x <-> InSet s x.

(** Proof **)

(** Helping Lemmas **)
Lemma ClassicalOrInList: forall (l: list) (x: X), InList l x \/ ~ InList l x.
Proof.
    intros. induction l as [| h t].
        right. intuition.
        simpl. pose (X' x h). destruct o.
            intuition.
            destruct IHt.
                intuition.
                right. intuition.
Qed.

Lemma SimilarInclusive: forall (x: X) (xs: list) (s: set),
    Similar (cons x xs) s -> InList xs x -> Similar xs s.
Proof.
    unfold Similar in *. intros. pose (X' x0 x). destruct o.
        intuition.
            apply H. rewrite H1. simpl. left. intuition.
            rewrite H1. intuition.
        intuition.
            apply H. simpl. right. intuition.
            apply H in H2. simpl in H2. intuition.
Qed.

Lemma SimilarExclusive: forall (x: X) (xs: list) (s: set),
    Similar (cons x xs) s -> ~ InList xs x -> Similar xs (Minus s x).
Proof.
    unfold Similar in *. intros. intuition.
        unfold InSet, Minus. split.
            apply H. simpl. intuition.
            intuition. rewrite H2 in H0. intuition.
        unfold InSet, Minus in H1. intuition. apply H in H2. simpl in H2. intuition. rewrite H1 in H3.
        intuition.
Qed.

Lemma InSetMinusInvariant: forall (x x0: X) (s: set) (f: X -> bool) (u: X -> X),
    InSet (UpdateSet (Minus s x0) f u) x -> InSet (UpdateSet s f u) x.
Proof.
    intros. unfold InSet, UpdateSet in *. destruct H. intuition. case_eq (f x1).
        intros. rewrite H in H1. exists x1. intuition.
            unfold Minus in H0. destruct H0. intuition.
            rewrite H. intuition.
        intros. rewrite H in H1. exists x1. intuition.
            unfold Minus in H0. destruct H0. intuition.
            rewrite H. intuition.
Qed.

Lemma InSetMinusUpdatedInvariant: forall (x x0: X) (s: set) (f: X -> bool) (u: X -> X),
    InSet (UpdateSet s f u) x0 -> x0 <> UpdateX x f u -> InSet (UpdateSet (Minus s x) f u) x0.
Proof.
    intros. unfold Minus, UpdateSet, InSet, UpdateX in *. destruct H. destruct H. exists x1. intuition.
    rewrite <- H2 in H1. intuition.
Qed.

(** Main Theorem **)
Theorem UpdateSimilarity: forall (l: list) (s: set) (f: X -> bool) (u: X -> X),
    Similar l s -> Similar (UpdateList l f u) (UpdateSet s f u).
Proof.
    unfold Similar in *. induction l as [| x xs].
    - split.
        simpl. intuition.
        intros. unfold InSet, UpdateSet in H0. destruct H0. intuition. apply H in H1. intuition.
    - split.
        simpl. intros. intuition.
            case_eq (f x).
                intros. rewrite H0 in H1. rewrite H1. unfold InSet, UpdateSet. exists x. split.
                    apply H. simpl. intuition.
                    rewrite H0. intuition.
                intros. rewrite H0 in H1. rewrite H1. unfold InSet, UpdateSet. exists x. split.
                    apply H. simpl. intuition.
                    rewrite H0. intuition.
            pose (ClassicalOrInList xs x). destruct o.
                apply IHxs.
                    apply SimilarInclusive with (x:=x).
                        intuition.
                        intuition.
                    assumption.
                apply InSetMinusInvariant with (x0:=x). apply IHxs.
                    apply SimilarExclusive.
                        intuition.
                        intuition.
                    intuition.
        intros. simpl. pose (X' x0 (if f x then u x else x)). intuition. right. pose (ClassicalOrInList xs x). destruct o.
            apply IHxs with (s:=s).
                apply SimilarInclusive with (x:=x).
                    intuition.
                    intuition.
                intuition.
            apply InSetMinusUpdatedInvariant with (x:=x) in H0.
                apply IHxs with (s:=(Minus s x)).
                    apply SimilarExclusive.
                        intuition.
                        intuition.
                    intuition.
                intuition.
Qed.


(* Exercise 32 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_032 : (A-> (B -> C)) -> ((B /\ ~C) -> ~A).
Proof.
imp_i a1.
imp_i a2.
neg_i C a3.
con_e2 B.
hyp a2.
imp_e B.
imp_e A.
hyp a1.
hyp a3.
con_e1 (~C).
hyp a2.
Qed.


Require Import Limits.Pullback Cubical.PathSquare.
Require Import Algebra.Groups.Group.
Require Import WildCat.

(** Pullbacks of groups are formalized by equipping the set-pullback with the desired group structure. The universal property in the category of groups is proved by saying that the corecursion principle (grp_pullback_corec) is an equivalence. *)

Local Open Scope mc_scope.
Local Open Scope mc_mult_scope.

Section GrpPullback.

  (* Variables are named to correspond with Limits.Pullback. *)
  Context {A B C : Group} (f : B $-> A) (g : C $-> A).

  Local Instance grp_pullback_sgop : SgOp (Pullback f g).
  Proof.
    intros [b [c p]] [d [e q]].
    refine (b * d; c * e; _).
    refine (grp_homo_op f b d @ (_ @ _) @ (grp_homo_op g c e)^).
    - exact (ap (fun y:A => f b * y) q).
    - exact (ap (fun x:A => x * g e) p).
  Defined.

  Local Instance grp_pullback_sgop_associative
    : Associative grp_pullback_sgop.
  Proof.
    intros [x1 [x2 p]] [y1 [y2 q]] [z1 [z2 u]].
    apply equiv_path_pullback; simpl.
    refine (associativity _ _ _; associativity _ _ _; _).
    apply equiv_sq_path.
    apply path_ishprop.
  Defined.

  Local Instance grp_pullback_issemigroup : IsSemiGroup (Pullback f g) := {}.

  Local Instance grp_pullback_mon_unit : MonUnit (Pullback f g)
    := (1; 1; grp_homo_unit f @ (grp_homo_unit g)^).

  Local Instance grp_pullback_leftidentity
    : LeftIdentity grp_pullback_sgop grp_pullback_mon_unit.
  Proof.
    intros [b [c p]]; simpl.
    apply equiv_path_pullback; simpl.
    refine (left_identity _; left_identity _; _).
    apply equiv_sq_path.
    apply path_ishprop.
  Defined.

  Local Instance grp_pullback_rightidentity
    : RightIdentity grp_pullback_sgop grp_pullback_mon_unit.
  Proof.
    intros [b [c p]]; simpl.
    apply equiv_path_pullback; simpl.
    refine (right_identity _; right_identity _; _).
    apply equiv_sq_path.
    apply path_ishprop.
  Defined.

  Local Instance ismonoid_grp_pullback : IsMonoid (Pullback f g) := {}.

  Local Instance grp_pullback_negate : Negate (Pullback f g).
  Proof.
    intros [b [c p]].
    refine (-b; -c; grp_homo_inv f b @ _ @ (grp_homo_inv g c)^).
    exact (ap (fun a => -a) p).
  Defined.

  Local Instance grp_pullback_leftinverse
    : LeftInverse grp_pullback_sgop grp_pullback_negate grp_pullback_mon_unit.
  Proof.
    unfold LeftInverse.
    intros [b [c p]].
    unfold grp_pullback_sgop; simpl.
    apply equiv_path_pullback; simpl.
    refine (left_inverse _; left_inverse _; _).
    apply equiv_sq_path.
    apply path_ishprop.
  Defined.

  Local Instance grp_pullback_rightinverse
    : RightInverse grp_pullback_sgop grp_pullback_negate grp_pullback_mon_unit.
  Proof.
    intros [b [c p]].
    unfold grp_pullback_sgop; simpl.
    apply equiv_path_pullback; simpl.
    refine (right_inverse _; right_inverse _; _).
    apply equiv_sq_path.
    apply path_ishprop.
  Defined.

  Global Instance isgroup_grp_pullback : IsGroup (Pullback f g) := {}.

  Definition grp_pullback : Group
    := Build_Group (Pullback f g) _ _ _ _.

  Definition grp_pullback_pr1 : grp_pullback $-> B.
  Proof.
    snrapply Build_GroupHomomorphism.
    - apply pullback_pr1.
    - intros x y. reflexivity.
  Defined.

  Definition grp_pullback_pr2 : grp_pullback $-> C.
  Proof.
    snrapply Build_GroupHomomorphism.
    - apply pullback_pr2.
    - intros x y. reflexivity.
  Defined.

  Proposition grp_pullback_corec {X : Group}
              (b : X $-> B) (c : X $-> C)
              (p : f o b == g o c)
    : X $-> grp_pullback.
  Proof.
    snrapply Build_GroupHomomorphism.
    - exact (fun x => (b x; c x; p x)).
    - intros x y.
      srapply path_sigma.
      + simpl.
        apply (grp_homo_op b).
      + unfold pr2.
        refine (transport_sigma' _ _ @ _). unfold pr1.
        apply path_sigma_hprop.
        simpl.
        apply (grp_homo_op c).
  Defined.

  Corollary grp_pullback_corec' (X : Group)
    : {b : X $-> B & { c : X $-> C & f o b == g o c}}
      -> (X $-> grp_pullback).
  Proof.
    intros [b [c p]]; exact (grp_pullback_corec b c p).
  Defined.

End GrpPullback.

Definition functor_grp_pullback {A A' B B' C C' : Group}
           (f : B $-> A) (f' : B' $-> A')
           (g : C $-> A) (g' : C' $-> A')
           (alpha : A $-> A') (beta : B $-> B') (gamma : C $-> C')
           (h : f' o beta == alpha o f)
           (k : alpha o g == g' o gamma)
  : grp_pullback f g $-> grp_pullback f' g'.
Proof.
  srapply grp_pullback_corec.
  - exact (beta $o grp_pullback_pr1 f g).
  - exact (gamma $o grp_pullback_pr2 f g).
  - intro x; cbn.
    refine (h _ @ ap alpha _ @ k _).
    apply pullback_commsq.
Defined.

Definition equiv_functor_grp_pullback {A A' B B' C C' : Group}
           (f : B $-> A) (f' : B' $-> A')
           (g : C $-> A) (g' : C' $-> A')
           (alpha : GroupIsomorphism A A')
           (beta : GroupIsomorphism B B')
           (gamma : GroupIsomorphism C C')
           (h : f' o beta == alpha o f)
           (k : alpha o g == g' o gamma)
  : GroupIsomorphism (grp_pullback f g) (grp_pullback f' g').
Proof.
  srapply Build_GroupIsomorphism.
  1: exact (functor_grp_pullback f f' g g' _ _ _ h k).
  srapply isequiv_adjointify.
  { srapply (functor_grp_pullback f' f g' g).
    1-3: rapply grp_iso_inverse; assumption.
    + rapply (equiv_ind beta); intro b.
      refine (ap f (eissect _ _) @ _).
      apply (equiv_ap' alpha _ _)^-1.
      exact ((h b)^ @ (eisretr _ _)^).
    + rapply (equiv_ind gamma); intro c.
      refine (_ @ ap g (eissect _ _)^).
      apply (equiv_ap' alpha _ _)^-1.
      exact (eisretr _ _ @ (k c)^). }
  all: intro x;
    apply equiv_path_pullback_hset; split; cbn.
  1-2: apply eisretr.
  1-2: apply eissect.
Defined.

(** Pulling back along some [g : Y $-> Z] and then [g' : Y' $-> Y] is the same as pulling back along [g $o g']. *)
Definition equiv_grp_pullback_compose_r {X Z Y Y' : Group} (f : X $-> Z) (g' : Y' $-> Y) (g : Y $-> Z)
  : GroupIsomorphism (grp_pullback (grp_pullback_pr2 f g) g') (grp_pullback f (g $o g')).
Proof.
  srapply Build_GroupIsomorphism.
  - srapply grp_pullback_corec.
    + exact (grp_pullback_pr1 _ _ $o grp_pullback_pr1 _ _).
    + apply grp_pullback_pr2.
    + intro x; cbn.
      exact (pullback_commsq _ _ _ @ ap g (pullback_commsq _ _ _)).
  - srapply isequiv_adjointify.
    + srapply grp_pullback_corec.
      * srapply functor_grp_pullback.
        1,2: exact grp_homo_id.
        1: exact g'.
        all: reflexivity.
      * apply grp_pullback_pr2.
      * reflexivity.
    + intro x; cbn.
      by srapply equiv_path_pullback_hset.
    + intros [[x [y z0]] [y' z1]]; srapply equiv_path_pullback_hset; split; cbn.
      2: reflexivity.
      srapply equiv_path_pullback_hset; split; cbn.
      1: reflexivity.
      exact z1^.
Defined.

Section IsEquivGrpPullbackCorec.

  (* New section with Funext at the start of the Context. *)
  Context `{Funext} {A B C : Group} (f : B $-> A) (g : C $-> A).

  Lemma grp_pullback_corec_pr1 {X : Group}
        (b : X $-> B) (c : X $-> C)
        (p : f o b == g o c)
    : grp_pullback_pr1 f g $o grp_pullback_corec f g b c p = b.
  Proof.
    apply equiv_path_grouphomomorphism; reflexivity.
  Defined.

  Lemma grp_pullback_corec_pr2 {X : Group}
        (b : X $-> B) (c : X $-> C)
        (p : f o b == g o c)
    : grp_pullback_pr2 f g $o grp_pullback_corec f g b c p = c.
  Proof.
    apply equiv_path_grouphomomorphism; reflexivity.
  Defined.

  Theorem isequiv_grp_pullback_corec (X : Group)
    : IsEquiv (grp_pullback_corec' f g X).
  Proof.
    snrapply isequiv_adjointify.
    - intro phi.
      refine (grp_pullback_pr1 f g $o phi; grp_pullback_pr2 f g $o phi; _).
      intro x; exact (pullback_commsq f g (phi x)).
    - intro phi.
      apply equiv_path_grouphomomorphism; reflexivity.
    - intro bcp; simpl.
      srapply path_sigma.
      + simpl. apply grp_pullback_corec_pr1.
      + refine (transport_sigma' _ _ @ _).
        apply path_sigma_hprop; simpl pr1.
        simpl. apply grp_pullback_corec_pr2.
  Defined.

End IsEquivGrpPullbackCorec.


(** A library of relation operators defining sequences of transitions
  and useful properties about them. *)

Set Implicit Arguments.

Section SEQUENCES.

Variable A: Type.                 (**r the type of states *)
Variable R: A -> A -> Prop.       (**r the transition relation, from one state to the next *)

(** ** Finite sequences of transitions *)

(** Zero, one or several transitions: reflexive, transitive closure of [R]. *)

Inductive star: A -> A -> Prop :=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

Lemma star_one:
  forall (a b: A), R a b -> star a b.
Proof.
  eauto using star.
Qed.

Lemma star_trans:
  forall (a b: A), star a b -> forall c, star b c -> star a c.
Proof.
  induction 1; eauto using star.
Qed.

(** One or several transitions: transitive closure of [R]. *)

Inductive plus: A -> A -> Prop :=
  | plus_left: forall a b c,
      R a b -> star b c -> plus a c.

Lemma plus_one:
  forall a b, R a b -> plus a b.
Proof.
  eauto using star, plus.
Qed.

Lemma plus_star:
  forall a b,
  plus a b -> star a b.
Proof.
  intros. inversion H. eauto using star.
Qed.

Lemma plus_star_trans:
  forall a b c, plus a b -> star b c -> plus a c.
Proof.
  intros. inversion H. eauto using plus, star_trans.
Qed.

Lemma star_plus_trans:
  forall a b c, star a b -> plus b c -> plus a c.
Proof.
  intros. inversion H0. inversion H; eauto using plus, star, star_trans.
Qed.

Lemma plus_right:
  forall a b c, star a b -> R b c -> plus a c.
Proof.
  eauto using star_plus_trans, plus_one.
Qed.

(** No transitions from a state. *)

Definition irred (a: A) : Prop := forall b, ~(R a b).

(** ** Infinite sequences of transitions *)

(** It is easy to characterize the fact that all transition sequences starting
  from a state [a] are infinite: it suffices to say that any finite sequence
  starting from [a] can always be extended by one more transition. *)

Definition all_seq_inf (a: A) : Prop :=
  forall b, star a b -> exists c, R b c.

(** However, this is not the notion we are trying to characterize: that, starting
  from [a], there exists one infinite sequence of transitions
  [a --> a1 --> a2 --> ... -> aN -> ...].

  Indeed, consider [A = nat] and [R] such that [R 0 0] and [R 0 1].
  [all_seq_inf 0] does not hold, because a sequence [0 -->* 1] cannot be extended.
  Yet, [R] admits an infinite sequence, namely [0 --> 0 --> ...].

  Another attempt would be to represent the sequence of states
  [a0 --> a1 --> a2 --> ... -> aN -> ...] explicitly, as a function
  [f: nat -> A] such that [f i] is the [i]-th state [ai] of the sequence. *)

Definition infseq_with_function (a: A) : Prop :=
  exists f: nat -> A, f 0 = a /\ forall i, R (f i) (f (1 + i)).

(** This is a correct characterization of the existence of an infinite sequence
  of reductions.  However, it is very inconvenient to work with this definition
  in Coq's constructive logic: in most use cases, the function [f] is not
  computable and therefore cannot be defined in Coq.  *)

(** To obtain a practical definition of infinite sequences, we use the following
  coinductive definition of the predicate [infseq a]. *)

CoInductive infseq: A -> Prop :=
  | infseq_step: forall a b,
      R a b -> infseq b -> infseq a.

(** An inductive predicate such as [star a b] holds iff there exists a finite
  derivation of the conclusion [star a b] that uses the constructors
  [star_refl] and [star_step] a finite number of times.

  A coinductive predicate is similar, but holds iff there exists a finite
  OR INFINITE derivation of the conclusion that uses the constructors
  of the predicate a finite OR INFINITE number of times.

  In other words, an inductive predicate is a smallest fixpoint: the smallest predicate
  that satisfies its constructors; a coinductive predicate is a greatest fixpoint:
  the largest predicate that satisfies its constructors.

  The [infseq] predicate above must be defined coinductively.  Indeed, if
  we define it inductively, the predicate would be empty (always false),
  since there are no base cases!

  Coq provides some primitive support for constructing infinite derivations
  of facts such as [infseq a].  Such constructions are proofs by coinduction.
  For example, we can prove the following: *)

Remark cycle_infseq:
  forall a, R a a -> infseq a.
Proof.
  intros. cofix COINDHYP. apply infseq_step with a. auto. apply COINDHYP.
Qed.

(** This style of proof by coinduction, using the [cofix] tactic, is effective
  but can run into limitations of Coq's proof engine (the so-called
  "guard condition").  However, we can derive more conventional
  coinduction principles that are often easier to use. *)

(** Consider a set [X] of states [A], that is, a predicate [X: A -> Prop].
  Assume that for every [a] in [X], we can make one [R] transition to a [b]
  that is still in [X].  Then, starting from [a] in [X], we can transition
  to some [a1] in [X], then to some [a2] still in [X], then... It is clear
  that we are just building an infinite sequence of transitions starting from
  [a]. Therefore [infseq a] should hold.  Let's prove this! *)

Lemma infseq_coinduction_principle:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, R a b /\ X b) ->
  forall a, X a -> infseq a.
Proof.
  intros X P. cofix COINDHYP; intros.
  destruct (P a H) as [b [U V]]. apply infseq_step with b; auto.
Qed.

(** An even more useful variant of this coinduction principle considers a
  set [X] where for every [a] in [X], we can make one *or several* transitions
  to reach a [b] in [X].  *)

Lemma infseq_coinduction_principle_2:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, plus a b /\ X b) ->
  forall a, X a -> infseq a.
Proof.
  intros.
  apply infseq_coinduction_principle with
    (X := fun a => exists b, star a b /\ X b).
- intros.
  destruct H1 as [b [STAR Xb]]. inversion STAR; subst.
+ destruct (H b Xb) as [c [PLUS Xc]]. inversion PLUS; subst.
  exists b0; split. auto. exists c; auto.
+ exists b0; split. auto. exists b; auto.
- exists a; split. apply star_refl. auto.
Qed.

(** Here is an example of use of [infseq_coinduction_principle]:
  if all finite transition sequences starting at [a] can be extended,
  [infseq a] holds. *)

Lemma infseq_if_all_seq_inf:
  forall a, all_seq_inf a -> infseq a.
Proof.
  apply infseq_coinduction_principle.
  intros. destruct (H a) as [b Rb]. constructor.
  exists b; split; auto.
  unfold all_seq_inf; intros. apply H. apply star_step with b; auto.
Qed.

(** Likewise, the function-based characterization [infseq_with_function]
  implies [infseq]. *)

Lemma infseq_from_function:
  forall a, infseq_with_function a -> infseq a.
Proof.
  apply infseq_coinduction_principle.
  intros. destruct H as [f [P Q]].
  exists (f 1); split.
  subst a. apply Q.
  exists (fun n => f (1 + n)); split. auto. intros. apply Q.
Qed.

(** ** Determinism properties for functional transition relations. *)

(** A transition relation is functional if every state can transition to at most
  one other state. *)

Hypothesis R_functional:
  forall a b c, R a b -> R a c -> b = c.

(** Uniqueness of finite transition sequences. *)

Lemma star_star_inv:
  forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
Proof.
  induction 1; intros.
- auto.
- inversion H1; subst.
+ right. eauto using star.
+ assert (b = b0) by (eapply R_functional; eauto). subst b0.
  apply IHstar; auto.
Qed.

Lemma finseq_unique:
  forall a b b',
  star a b -> irred b ->
  star a b' -> irred b' ->
  b = b'.
Proof.
  intros. destruct (star_star_inv H H1).
- inversion H3; subst. auto. elim (H0 _ H4).
- inversion H3; subst. auto. elim (H2 _ H4).
Qed.

(** A state cannot both diverge and terminate on an irreducible state. *)

Lemma infseq_star_inv:
  forall a b, star a b -> infseq a -> infseq b.
Proof.
  induction 1; intros.
- auto.
- inversion H1; subst.
  assert (b = b0) by (eapply R_functional; eauto). subst b0.
  apply IHstar; auto.
Qed.

Lemma infseq_finseq_excl:
  forall a b,
  star a b -> irred b -> infseq a -> False.
Proof.
  intros.
  assert (infseq b) by (eapply infseq_star_inv; eauto).
  inversion H2. elim (H0 b0); auto.
Qed.

(** If there exists an infinite sequence of transitions from [a],
  all sequences of transitions arising from [a] are infinite. *)

Lemma infseq_all_seq_inf:
  forall a, infseq a -> all_seq_inf a.
Proof.
  intros. unfold all_seq_inf. intros.
  assert (infseq b) by (eapply infseq_star_inv; eauto).
  inversion H1. subst. exists b0; auto.
Qed.

End SEQUENCES.


From HB Require Import structures.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype choice order.
From mathcomp Require Import fintype ssrnat bigop.
Require Import mathcomp.analysis.boolp.
Require Import mathcomp.analysis.classical_sets.
Require Import HB_wrappers dioid complete_lattice.

(******************************************************************************)
(* The algebraic structure of complete dioids, as described in:               *)
(*   Michel Minoux, Michel Gondran.                                           *)
(*   'Graphs, Dioids and Semirings. New Models and Algorithms.'               *)
(*   Springer, 2008                                                           *)
(*                                                                            *)
(* This file defines for each structure its type, its packers and its         *)
(* canonical properties:                                                      *)
(*                                                                            *)
(*   * CompleteDioid (dioid with infinte distributivity):                     *)
(*                   (From GONDRAN-MINOUX définition 6.1.8)                   *)
(*    CompleteDioid.yype == interface type for complete Dioid structure       *)
(* CompleteDioid_of_Dioid_and_CompleteLattice.Build D mulDl mulDr             *)
(*                       == packs a CompleteDioid; the carrier type D must    *)
(*                          have both a Dioid and a CompleteLattice canonical *)
(*                          structure (see complete_lattice.v).               *)
(*                   a^i == the power i of a                                  *)
(*                   a^* == the kleene star operator                          *)
(*                          (infinite sum of a^i, i >= 0)                     *)
(*                   a^+ == the 'plus' operator (infinite sum of a^i, i > 0)  *)
(*                 a / b == the residuation operator:                         *)
(*                          x * b <= a <-> x <= a / b                         *)
(* [CompleteDioid of U by <:] == CompleteDioid mixin for a subType whose base *)
(*                          type is both a Dioid and a CompleteLattice.       *)
(*                                                                            *)
(*   * ComCompleteDioid:                                                      *)
(* ComCompleteDioid.type == interface type for complete commutative dioid     *)
(*                          structure                                         *)
(* ComCompleteDioid_of_CompleteDioid.Build D mulC                             *)
(*                       == packs mulC into a ComCompleteDioid; the carrier   *)
(*                          type D must have a CompleteDioid canonical        *)
(*                          structure.                                        *)
(* ComCompleteDioid_of_ComDioid_and_CompleteLattice.Build D mulDl             *)
(*                       == packs mulDl into a ComCompleteDioid; the carrier  *)
(*                          type D must have both a ComDioid and a            *)
(*                          CompleteLattice canonical structure.              *)
(* ComCompleteDioid_of_CompleteLattice.Build D addA addC add0l mulA mulC      *)
(*   mul1l mulDl mul0l le_def set_mulDl                                       *)
(*                       == build a ComCompleteDioid structure from the       *)
(*                          algebraic properties of its operations.           *)
(*                          The carrier type T must have a CompleteLattice    *)
(*                          canonical structure (see complete_lattice.v).     *)
(*                                                                            *)
(* Interesting lemmas:                                                        *)
(* * forall a and b in a complete dioid, a^* * b is the least solution of     *)
(*   x = a * x + b                                                            *)
(* * forall a and b in a complete commutative dioid, (a + b)^* = a^* * b ^*   *)
(*                                                                            *)
(*   Notations are defined in scope dioid_scope (delimiter %D).               *)
(******************************************************************************)

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

Reserved Notation "x ^+" (at level 2, format "x ^+").
Reserved Notation "x ^*" (at level 2, format "x ^*").

Local Open Scope classical_set_scope.
Local Open Scope order_scope.
Local Open Scope dioid_scope.

Import Order.Theory.

HB.mixin Record CompleteDioid_of_Dioid_and_CompleteLattice D
         of Dioid D & CompleteLattice D := {
  set_mulDl : forall (a : D) (B : set D),
      a * set_join B = set_join [set a * x | x in B];
  set_mulDr : forall (a : D) (B : set D),
      set_join B * a = set_join [set x * a | x in B];
}.

HB.structure Definition CompleteDioid :=
  { D of Dioid D & CompleteLattice D
    & CompleteDioid_of_Dioid_and_CompleteLattice D }.

Coercion CompleteDioid_to_Equality (T : CompleteDioid.type) :=
  Eval hnf in [eqType of T for T].
Canonical CompleteDioid_to_Equality.
Coercion CompleteDioid_to_Choice (T : CompleteDioid.type) :=
  Eval hnf in [choiceType of T for T].
Canonical CompleteDioid_to_Choice.
Coercion CompleteDioid_to_POrder (T : CompleteDioid.type) :=
  Eval hnf in [porderType of T for T].
Canonical CompleteDioid_to_POrder.
Coercion CompleteDioid_to_Lattice (T : CompleteDioid.type) :=
  Eval hnf in [latticeType of T for T].
Canonical CompleteDioid_to_Lattice.

Section CompleteDioidTheory.

Variables D : CompleteDioid.type.

Implicit Types a b c : D.
Implicit Types B : set D.

Definition set_add : set D -> D := set_join.

Lemma bottom_zero : bottom D = 0.
Proof. by apply/le_anti; rewrite bottom_minimum /= le0d. Qed.

Lemma set_addDl a B : set_add (a |` B) = a + set_add B.
Proof.
apply/le_anti/andP; split.
- apply: set_join_le_ub; rewrite -ubP => x [-> | Hx]; [exact: led_addr|].
  refine (le_trans _ (led_addl _ _)); exact: set_join_ub.
- rewrite led_add_eqv set_joinU_ge_r andbC /=.
  by rewrite -[in X in X <= _](set_join_set1 a) set_joinU_ge_l.
Qed.

Lemma add_def a b : a + b = a `|` b.
Proof.
rewrite -[in LHS](set_join_set1 b) -set_addDl.
by rewrite /set_add set_joinU !set_join_set1.
Qed.

Lemma set_addU A B : set_add (A `|` B) = set_add A + set_add B.
Proof. by rewrite /set_add set_joinU add_def. Qed.

Lemma add_dtop : right_zero (top D) add.
Proof. by move=> x; rewrite -set_addDl setUT. Qed.

Lemma add_topd : left_zero (top D) add.
Proof. by move=> x; rewrite adddC add_dtop. Qed.

Lemma set_add_0 (F : nat -> D) : set_add [set F i | i in [set x | 'I_0 x]] = 0.
Proof. by rewrite -bottom_zero; apply: f_equal; rewrite -subset0 => x [[]]. Qed.

Lemma set_add_1 (F : nat -> D) : set_add [set F i | i in [set x | 'I_1 x]] = F O.
Proof.
rewrite -(addd0 (F O)) -bottom_zero -set_addDl setU0; apply: f_equal.
by rewrite predeqP => x; split=> [[y] | ->]; [rewrite ord1|exists ord0].
Qed.

Lemma set_add_S (F : nat -> D) k :
  set_add [set F i | i in [set x | 'I_k.+1 x]]
  = set_add [set F i | i in [set x | 'I_k x]] + F k.
Proof.
rewrite adddC -set_addDl; apply: f_equal; rewrite predeqP => x; split.
- move=> -[i Hi] <-.
  move: (leq_ord i); rewrite leq_eqVlt => /orP[/eqP -> | {}Hi]; [by left|].
  by right; exists (Ordinal Hi).
- move=> [-> | [i _ <-]]; [by exists ord_max|].
  by exists (inord i); rewrite ?inordK // ltnS ltnW.
Qed.

Lemma set_add_led (F : nat -> D) k :
  set_add [set F i | i in [set x | 'I_k x]] <= set_add [set of F].
Proof.
elim: k => [|k IHk].
- set S := image _ _.
  have ->: S = set0 by rewrite -subset0 => x [[]].
  exact: bottom_minimum.
- rewrite set_add_S led_add_eqv IHk /=.
  by apply: set_join_ub; exists k.
Qed.

Lemma set_add_lim_nat (F : nat -> D) l :
  (forall k, set_add [set F i | i in [set x | 'I_k x]] <= l) ->
  set_add [set of F] <= l.
Proof.
move=> H; apply: set_join_le_ub => _ [i _ <-].
by move: (H i.+1); apply/le_trans/set_join_ub; exists ord_max.
Qed.

Lemma set_add_led_set (F F' : nat -> D) :
  (forall k, set_add [set F i | i in [set x | 'I_k x]]
             <= set_add [set F' i | i in [set x | 'I_k x]]) ->
  set_add [set of F] <= set_add [set of F'].
Proof.
move=> H; apply: set_add_lim_nat => k.
exact/(le_trans (H k))/set_add_led.
Qed.

Section KleeneOperatorsDefinitions.

Definition exp a n := iterop n *%D a 1.
Definition op_kleene a := set_add [set of exp a].
Definition op_plus a := set_add [set of fun i => exp a i.+1].
Definition div a b := set_add [set c | c * b <= a].

End KleeneOperatorsDefinitions.

Local Notation "a ^ i" := (exp a i) : dioid_scope.
Local Notation "a ^*" := (op_kleene a) : dioid_scope.
Local Notation "a ^+" := (op_plus a) : dioid_scope.
Local Notation "a / b" := (div a b) : dioid_scope.

Section KleeneStar.

Lemma exp0 a : a ^ 0 = 1.
Proof. by []. Qed.

Lemma expS i a : a ^ (i.+1) = a * (a ^ i).
Proof. by case: i => //; rewrite exp0 muld1. Qed.

Lemma expSr i a : a ^ i.+1 = a ^ i * a.
Proof.
elim: i => [ | i Hi]; first by rewrite exp0 mul1d.
by rewrite expS {1}Hi expS muldA.
Qed.

Lemma kleeneSr a : a^* = 1 + a^+.
Proof.
rewrite -(exp0 a) -set_addDl /op_kleene.
apply: f_equal; rewrite predeqP => b; split.
- by move=> [[| i] _ <-]; [left|right; exists i].
- by move=> [-> | [i _ <-]]; [exists O|exists i.+1].
Qed.

Lemma plusSr a : a ^+ = a * a ^*.
Proof.
rewrite set_mulDl /op_plus /op_kleene.
apply: f_equal; rewrite predeqP => b; split.
- by move=> [i _ <-]; rewrite expS; exists (a ^ i); [exists i|].
- by move=> [c [i _ <-] <-]; rewrite -expS; exists i.
Qed.

Lemma plus_le_kleene a : a^+ <= a^*.
Proof. by rewrite le_def kleeneSr adddCA adddd. Qed.

Lemma le_plus a : a <= a ^+.
Proof. by rewrite le_def plusSr kleeneSr muldDr muld1 adddA adddd. Qed.

Lemma le_kleene a : a <= a^*.
Proof. exact/(le_trans (le_plus a))/plus_le_kleene. Qed.

Lemma kleene_mul_expl a n : a ^ n * a ^* <= a^*.
Proof.
elim: n => [|n IHn]; [by rewrite mul1d|].
rewrite expSr -muldA.
move: IHn; apply/le_trans/led_mul2l.
rewrite -plusSr; apply: plus_le_kleene.
Qed.

Lemma kleene_monotony a b : a <= b -> a ^* <= b ^*.
Proof.
move=> Hab.
apply: set_add_led_set => k.
have Hyp : forall i, a ^ i <= b ^ i.
  elim=> [|i IHi].
  - by rewrite exp0.
  - by rewrite !expS; apply: led_mul.
elim: k => [|k IHk].
- by rewrite set_add_0 le0d.
- rewrite !set_add_S; exact: led_add.
Qed.

Lemma kleene_1r a : (a + 1) ^* = a ^*.
Proof.
apply/le_anti/andP; split; [|exact/kleene_monotony/led_addr].
suff Hyp : forall i, (a + 1) ^ i = set_add [set a ^ j | j in [set x | 'I_i.+1 x]].
{ apply: set_add_led_set => k.
  elim: k => [ | k IHk]; [by rewrite set_add_0 le0d|].
  rewrite !set_add_S Hyp.
  rewrite -[in X in _ <= X](adddd (set_add _)) -adddA.
  apply: (led_add IHk).
  by rewrite set_add_S. }
elim=> [ | i IHi]; [by rewrite set_add_1 !exp0|].
rewrite expS muldDl mul1d IHi set_mulDl.
set B' := [set a ^ j | j in [set j | (1 <= j <= i)%nat]].
rewrite [X in set_join X](_ : _ = a ^ i.+1 |` B'); last first.
{ rewrite predeqP => x; split.
  - move=> -[y [[j Hj] _ <-] <-].
    rewrite expS /= -!expS.
    move: Hj; rewrite leq_eqVlt ltnS => /orP[/eqP [->] | Hj]; [by left|].
    by right; exists j.+1.
  - move=> [->|]; [by rewrite expS; exists (a ^ i) => //; exists ord_max|].
    move=> -[[//|j] /andP [Hj Hji] <-]; rewrite expS; exists (a ^ j) => //.
    by move: Hji => /ltnW; rewrite -ltnS => Hji; exists (Ordinal Hji). }
rewrite -[set_join]/set_add set_addDl.
rewrite (_ : image _ _ = (1 |` B')); last first.
{ rewrite predeqP => x; split.
  { move=> -[[[|j] Hj] _ <-]; [by left; rewrite exp0|].
    by right; exists (Ordinal Hj). }
  move=> [-> | [j /= Hj <-]]; [by rewrite -(exp0 a); exists ord0|].
  by move: Hj => /andP[_]; rewrite -ltnS => Hj; exists (Ordinal Hj). }
rewrite set_addDl.
rewrite (adddC (a ^ 0)) adddA -(adddA (a ^ i.+1)) adddd adddC -!set_addDl.
apply: f_equal; rewrite predeqP => x; split.
- move=> [-> | [-> | [j /= Hj <-]]].
  + by exists ord0.
  + by exists ord_max.
  + move: Hj => /andP[_]; rewrite -ltnS; move=> /ltnW; rewrite -ltnS => Hj.
    by exists (Ordinal Hj).
- move=> -[[[|j] Hj] _ <-]; [by left|right].
  move: Hj; rewrite /nat_of_ord !ltnS leq_eqVlt => /orP[/eqP -> | ]; [by left|].
  by rewrite -ltnS => Hj; right; exists (Ordinal Hj).
Qed.

Lemma kleene_sqr a : a^* * a^* = a^*.
Proof.
rewrite {1}/op_kleene set_mulDr.
set B' := (a ^* |` [set of fun i => a ^ i.+1 * a ^*]).
rewrite (_ : image _ _ = B'); last first.
{ rewrite predeqP => x; split.
  - by move=> -[_ [[|i] _ <-] <-]; [left; rewrite exp0 mul1d|right; exists i].
  - move=> [-> | [i _ <-]]; [by exists 1; [exists O|rewrite mul1d]|].
    by exists (a ^ i.+1); [exists i.+1|]. }
rewrite -[set_join]/set_add set_addDl.
apply/eqP; rewrite adddC -le_def; apply: set_add_lim_nat.
elim=> [|k].
- by rewrite (set_add_0 (fun i => a ^ i.+1 * _)) le0d.
- rewrite (set_add_S (fun i => a ^ i.+1 * _)).
  rewrite !le_def => /eqP IHk.
  rewrite adddAC IHk adddC -le_def.
  exact: kleene_mul_expl.
Qed.

Lemma kleene_exp a i : (1 <= i)%nat -> (a ^*) ^ i = a ^*.
Proof.
case: i => [// | ] i _; elim: i => [// | i IHi].
by rewrite expS IHi kleene_sqr.
Qed.

Lemma kleene_kleene a : (a ^*) ^* = a ^*.
Proof.
rewrite kleeneSr /op_plus.
rewrite (_ : image _ _ = a ^* |` set0).
  by rewrite setU0 /set_add set_join_set1 kleeneSr adddA adddd.
rewrite predeqP => x; split.
- move=> [i _ <-]; left; exact: kleene_exp.
- by move=> [-> | //]; exists O.
Qed.

Theorem kleene_star_eq a b : a ^* * b = a * (a ^* * b) + b.
Proof. by rewrite muldA -plusSr -{3}(mul1d b) -muldDl kleeneSr adddC. Qed.

Theorem kleene_star_least a b : forall x, (x = a * x + b) -> a ^* * b <= x.
Proof.
move=> x Hx.
rewrite set_mulDr.
rewrite [X in set_join X](_ : _ = [set (a ^ i) * b | i in setT]); last first.
  rewrite predeqP => y; split.
  - by move=> [_ [i _ <-] <-]; exists i.
  - by move=> [i _ <-]; exists (a ^ i); [exists i|].
apply: set_add_lim_nat; elim=> [ | k IHk].
  by rewrite le_def (set_add_0 (fun i => a ^ i * b)) add0d.
rewrite (set_add_S (fun i => a ^ i * b)) led_add_eqv IHk /=.
elim: k {IHk} => [ | k IHk]; [by rewrite mul1d Hx led_addl|].
rewrite expS.
have Ha : a * x <= x; [by rewrite {2}Hx led_addr|].
by apply: (le_trans _ Ha); rewrite -muldA led_mul2l.
Qed.

End KleeneStar.

Section ResiduationTheory.

Lemma div_mul_le a b : (a / b) * b <= a.
Proof. by rewrite set_mulDr; apply: set_join_le_ub => y [z + <-]. Qed.

Lemma mul_div_le a b : a <= (a * b) / b.
Proof. exact/set_join_ub/lexx. Qed.

Lemma mul_div_equiv a b x : (x * a <= b) = (x <= b / a).
Proof.
apply/idP/idP.
- move=> H; exact: set_join_ub.
- move=> H.
  move: (div_mul_le b a); apply: le_trans.
  exact: led_mul2r.
Qed.

Lemma div_top x : top D / x = top D.
Proof.
apply/le_anti /andP; split; [|rewrite -mul_div_equiv]; exact: top_maximum.
Qed.

Lemma led_divl a b c : a <= b -> a / c <= b / c.
Proof. rewrite -mul_div_equiv; exact/le_trans/div_mul_le. Qed.

Lemma led_divr a b c : a <= b -> c / b <= c / a.
Proof.
move=> Hab; rewrite -mul_div_equiv.
exact/(le_trans (led_mul2l  _ Hab))/div_mul_le.
Qed.

Lemma led_div a b c d : a <= b -> d <= c -> a / c <= b / d.
Proof.
move=> Hab Hcd; rewrite -mul_div_equiv.
apply/(le_trans _ Hab); rewrite mul_div_equiv.
exact: led_divr.
Qed.

Lemma addd_div_le (a b c : D) : a / c + b / c <= (a + b) / c.
Proof.
rewrite led_add_eqv.
apply/andP; split; apply: led_divl; [exact: led_addr|exact: led_addl].
Qed.

Lemma div_mul a b c : a / (b * c) = a / c / b.
Proof.
apply/le_anti/andP; split.
- by rewrite -!mul_div_equiv -muldA; apply: div_mul_le.
- by rewrite -mul_div_equiv muldA !mul_div_equiv; exact: lexx.
Qed.

Lemma mul_divA a b c : a * (b / c) <= (a * b) / c.
Proof. rewrite -mul_div_equiv -muldA; exact/led_mul2l/div_mul_le. Qed.

Lemma kleene_div_equiv a : (a == a ^*) = (a == a / a).
Proof.
apply/idP/idP => /eqP.
- move=> ->.
  apply/eqP/le_anti/andP; split.
  + apply: set_join_le_ub => _ [i _ <-].
    rewrite -mul_div_equiv.
    exact: kleene_mul_expl.
  + apply: set_join_le_ub => x /=.
    rewrite {1}kleeneSr muldDr muld1.
    by rewrite led_add_eqv => /andP[].
- move=> Ha; apply/eqP/le_anti/andP; split; [exact: le_kleene|].
  apply: set_join_le_ub => _ [i _ <-].
  elim: i => [ | i IHi]; [by rewrite exp0 Ha -mul_div_equiv mul1d|].
  by rewrite expSr mul_div_equiv -Ha.
Qed.

Lemma mul_kleene a b : a * b ^* = (a * b ^*) / b ^*.
Proof.
apply/le_anti/andP; split.
- by rewrite -mul_div_equiv -muldA kleene_sqr.
- apply: set_join_le_ub => x.
  apply: le_trans.
  by rewrite kleeneSr muldDr muld1 led_addr.
Qed.

Lemma div_kleene a b : a / b ^* = (a / b ^*) * b ^*.
Proof.
apply/le_anti/andP; split; last first.
- by rewrite -mul_div_equiv -muldA kleene_sqr div_mul_le.
- apply: set_join_le_ub => x /=.
  rewrite mul_div_equiv => Hx.
  apply: (le_trans Hx).
  by rewrite kleeneSr muldDr muld1 led_addr.
Qed.

End ResiduationTheory.

End CompleteDioidTheory.

HB.structure Definition ComCompleteDioid :=
  { D of ComSemiRing D & CompleteDioid D }.

HB.factory Record ComCompleteDioid_of_ComDioid_and_CompleteLattice D
           of ComDioid D & CompleteLattice D := {
  set_mulDl : forall (a : D) (B : set D),
      a * set_join B = set_join [set a * x | x in B];
}.

HB.builders Context D (f : ComCompleteDioid_of_ComDioid_and_CompleteLattice D).

  Lemma set_mulDr a (B : set D) :
    set_join B * a = set_join [set x * a | x in B].
  Proof.
  by rewrite muldC set_mulDl; apply: f_equal; rewrite predeqP => x; split;
    (move=> -[y Hy <-]; exists y; [|rewrite muldC]).
  Qed.

  HB.instance Definition to_CompleteDioid_of_Dioid_and_CompleteLattice :=
    CompleteDioid_of_Dioid_and_CompleteLattice.Build D set_mulDl set_mulDr.

HB.end.

HB.factory Record ComCompleteDioid_of_CompleteLattice D
           of CompleteLattice D := {
  zero : D;
  one : D;
  add : D -> D -> D;
  mul : D -> D -> D;
  adddA : associative add;
  adddC : commutative add;
  add0d : left_id zero add;
  adddd : idempotent add;
  muldA : associative mul;
  muldC : commutative mul;
  mul1d : left_id one mul;
  muldDl : left_distributive mul add;
  mul0d : left_zero zero mul;
  le_def : forall (a b : D),
      (Order.POrder.le wrap_porderMixin a b)
      = (Equality.op wrap_eqMixin (add a b) b);
  set_mulDl : forall (a : D) (B : set D),
      mul a (set_join B) = set_join [set mul a x | x in B];
}.

HB.builders Context D (f : ComCompleteDioid_of_CompleteLattice D).

  HB.instance Definition to_ComDioid_of_WrapPOrder :=
    ComDioid_of_WrapPOrder.Build
      D adddA adddC add0d adddd
      muldA muldC mul1d muldDl mul0d le_def.

  HB.instance Definition to_ComCompleteDioid_of_ComDioid_and_CompleteLattice :=
    ComCompleteDioid_of_ComDioid_and_CompleteLattice.Build
      D set_mulDl.

HB.end.

Section ComCompleteDioidTheory.

Variables D : ComCompleteDioid.type.

Implicit Types a b : D.

Local Notation "a ^ i" := (@exp _ a i) : dioid_scope.
Local Notation "a ^*" := (@op_kleene _ a) : dioid_scope.
Local Notation "a ^+" := (@op_plus _ a) : dioid_scope.
Local Notation "a / b" := (div a b) : dioid_scope.

Section ComResiduationTheory.

Lemma divAC : right_commutative (@div D).
Proof.
move=> a b c; apply/le_anti/andP; split; rewrite -!mul_div_equiv.
- by rewrite -muldA (muldC b) muldA !mul_div_equiv.
- by rewrite -muldA (muldC c) muldA !mul_div_equiv.
Qed.

Lemma kleene_add_mul a b : (a + b) ^* = a ^* * b ^*.
Proof.
apply/le_anti/andP; split.
- apply: set_join_le_ub => _ [i _ <-].
  elim: i => [ | i IHi].
  + rewrite exp0 -(muld1 1).
    apply: led_mul.
    * rewrite kleeneSr -{1}(addd0 1).
      exact/led_add2l/le0d.
    * rewrite kleeneSr -{1}(addd0 1).
      exact/led_add2l/le0d.
  + rewrite expS.
    apply: (le_trans (led_mul2l _ IHi)).
    rewrite muldDl muldA -plusSr (muldC b) -muldA -(muldC b) -plusSr.
    rewrite !kleeneSr !muldDl !muldDr !muld1 !mul1d.
    rewrite !adddA (adddC (a^+)) adddC !adddA adddd.
    rewrite [X in _ <= X]adddC -!adddA (adddC 1) (adddC (a^+)) !adddA.
    exact: led_addr.
- rewrite {2}/op_kleene /set_add set_mulDl.
  apply: set_join_le_ub => _ [_ [i _ <-] <-].
  rewrite {1}/op_kleene /set_add set_mulDr.
  apply: set_join_le_ub => _ [_ [j _ <-] <-].
  elim: i => [ | i HIi].
  + rewrite exp0 muld1.
    elim: j => [ | j HIj]; [by rewrite exp0 kleeneSr led_addr|].
    rewrite expS kleeneSr plusSr -(add0d (_ * _)).
    apply: led_add; [exact: le0d|].
    apply: led_mul => [ | //].
    exact: led_addr.
  + rewrite expS (muldC b) muldA.
    apply: (le_trans (led_mul2r _ HIi)).
    rewrite muldC {2}kleeneSr plusSr -(add0d (_ * _)).
    apply: led_add; [exact: le0d|].
    exact/led_mul2r/led_addl.
Qed.

End ComResiduationTheory.

End ComCompleteDioidTheory.

Module SubType.

Section CompleteDioid.

Variables (V : CompleteDioid.type) (S : pred V).
Variable (U : subType S).

Variable D : Dioid.type.
Variable cD : Dioid.axioms U.
Hypothesis uUD : unify Type Type U D None.
Hypothesis uUD' :
  unify Dioid.type Dioid.type D (Dioid.Pack cD) None.
Let U' := @Dioid.phant_clone U D cD uUD uUD'.

Variable L : CompleteLattice.type.
Variable cL : CompleteLattice.axioms U'.
Hypothesis uU'L : unify Type Type U' L None.
Hypothesis uU'L' :
  unify CompleteLattice.type CompleteLattice.type L (CompleteLattice.Pack cL) None.
Let U'' := @CompleteLattice.phant_clone U' L cL uU'L uU'L'.

Hypothesis valM : forall x y : U'', val (x * y) = val x * val y.
Hypothesis valSJ : forall B : set U'', val (set_join B) = set_join (val @` B).

Lemma set_mulDl (a : U'') (B : set U'') :
  a * set_join B = set_join [set (a * x : U'') | x in B].
Proof.
apply/val_inj; rewrite valM !valSJ set_mulDl.
apply: f_equal; rewrite predeqP => x; split.
- move=> -[_ [y Hy <-] <-].
  by exists (a * y) => //; exists y.
- move=> -[_ [y Hy <-] <-].
  by exists (val y) => //; exists y.
Qed.

Lemma set_mulDr (a : U'') (B : set U'') :
  set_join B * a = set_join [set (x * a : U'') | x in B].
Proof.
apply/val_inj; rewrite valM !valSJ set_mulDr.
apply: f_equal; rewrite predeqP => x; split.
- move=> -[_ [y Hy <-] <-].
  by exists ((y : U'') * a) => //; exists y.
- move=> -[_ [y Hy <-] <-].
  by exists (val y) => //; exists y.
Qed.

End CompleteDioid.

Module Exports.

Notation "[ 'CompleteDioid' 'of' R 'by' <: ]" :=
  (CompleteDioid_of_Dioid_and_CompleteLattice.Build
     R
     (@SubType.set_mulDl
        _ _ _ (Dioid.clone R _) _ id_phant id_phant
        (CompleteLattice.clone R _) _ id_phant id_phant (rrefl _) (frefl _))
     (@SubType.set_mulDr
        _ _ _ (Dioid.clone R _) _ id_phant id_phant
        (CompleteLattice.clone R _) _ id_phant id_phant (rrefl _) (frefl _)))
  (at level 0, format "[ 'CompleteDioid' 'of' R 'by' <: ]") : form_scope.

End Exports.

End SubType.

Export SubType.Exports.

Notation "a ^ i" := (@exp _ a i) : dioid_scope.
Notation "a ^*" := (@op_kleene _ a) : dioid_scope.
Notation "a ^+" := (@op_plus _ a) : dioid_scope.
Notation "a / b" := (div a b) : dioid_scope.