$TITLE Documentation
EOT
cat html/depend.map >> html/index.html
cat >>html/index.html </g;
# extra blank line
s//g;
# weird underscore
s/ /_/g;
# putting back underscore
s/#\_#/\_/g;
# abundance of
s/\n
$TITLE
EOT
cat html/depend.map >> html/index.html
cat >>html/index.html <
Library index
EOT
}
mathcomp-1.5/extra/coqdoc.css 0000644 0001750 0001750 00000011441 12307636117 015267 0 ustar gares gares ody { padding: 0px 0px;
margin: 0px 0px;
background-color: white }
#page { display: block;
padding: 0px;
margin: 0px;
padding-bottom: 10px; }
#header { display: block;
position: relative;
padding: 0;
margin: 0;
vertical-align: middle;
border-bottom-style: solid;
border-width: thin }
#header h1 { padding: 0;
margin: 0;}
/* Contents */
#main{ display: block;
padding: 10px;
font-family: sans-serif;
font-size: 100%;
line-height: 100% }
#main h1 { line-height: 95% } /* allow for multi-line headers */
#main a.idref:visited {color : #416DFF; text-decoration : none; }
#main a.idref:link {color : #416DFF; text-decoration : none; }
#main a.idref:hover {text-decoration : none; }
#main a.idref:active {text-decoration : none; }
#main a.modref:visited {color : #416DFF; text-decoration : none; }
#main a.modref:link {color : #416DFF; text-decoration : none; }
#main a.modref:hover {text-decoration : none; }
#main a.modref:active {text-decoration : none; }
#main .keyword { color : #cf1d1d }
#main { color: black }
.section { background-color: rgb(60%,60%,100%);
padding-top: 13px;
padding-bottom: 13px;
padding-left: 3px;
margin-top: 5px;
margin-bottom: 5px;
font-size : 110% }
h2.section { background-color: rgb(80%,80%,100%);
padding-left: 3px;
padding-top: 12px;
padding-bottom: 10px;
font-size : 110% }
h3.section { background-color: rgb(90%,90%,100%);
padding-left: 3px;
padding-top: 7px;
padding-bottom: 7px;
font-size : 110% }
h4.section {
/*
background-color: rgb(80%,80%,80%);
max-width: 20em;
padding-left: 5px;
padding-top: 5px;
padding-bottom: 5px;
*/
background-color: white;
padding-left: 0px;
padding-top: 0px;
padding-bottom: 0px;
font-size : 100%;
font-style : bold;
text-decoration : underline;
}
#main .doc { margin: 0px;
font-family: courier;
font-size: 100%;
line-height: 125%;
max-width: 50em;
color: black;
padding: 10px;
background-color: #90bdff;
border-style: plain;
white-space: pre;
}
.inlinecode {
display: inline;
/* font-size: 125%; */
color: #666666;
font-family: monospace }
.doc .inlinecode {
display: inline;
font-size: 120%;
color: rgb(30%,30%,70%);
font-family: monospace }
.doc .inlinecode .id {
color: rgb(30%,30%,70%);
}
.doc .code {
display: inline;
font-size: 120%;
color: rgb(30%,30%,70%);
font-family: monospace }
.comment {
display: inline;
font-family: monospace;
color: #cf1d1d
}
.code {
display: block;
/* padding-left: 15px; */
font-size: 110%;
font-family: monospace;
}
/* Pied de page */
#footer { font-size: 65%;
font-family: sans-serif; }
.id { display: inline; }
.id[type="constructor"] {
color: rgb(60%,0%,0%);
}
.id[type="var"] {
color: rgb(40%,0%,40%);
}
.id[type="variable"] {
color: rgb(40%,0%,40%);
}
.id[type="definition"] {
color: rgb(0%,40%,0%);
}
.id[type="abbreviation"] {
color: rgb(0%,40%,0%);
}
.id[type="lemma"] {
color: rgb(0%,40%,0%);
}
.id[type="instance"] {
color: rgb(0%,40%,0%);
}
.id[type="projection"] {
color: rgb(0%,40%,0%);
}
.id[type="method"] {
color: rgb(0%,40%,0%);
}
.id[type="inductive"] {
color: rgb(0%,0%,80%);
}
.id[type="record"] {
color: rgb(0%,0%,80%);
}
.id[type="class"] {
color: rgb(0%,0%,80%);
}
.id[type="keyword"] {
color : #cf1d1d;
/* color: black; */
}
.inlinecode .id {
color: rgb(0%,0%,0%);
}
/* TOC */
#toc h2 {
padding: 10px;
background-color: rgb(60%,60%,100%);
}
#toc li {
padding-bottom: 8px;
}
/* Index */
#index {
margin: 0;
padding: 0;
width: 100%;
}
#index #frontispiece {
margin: 1em auto;
padding: 1em;
width: 60%;
}
.booktitle { font-size : 140% }
.authors { font-size : 90%;
line-height: 115%; }
.moreauthors { font-size : 60% }
#index #entrance {
text-align: center;
}
#index #entrance .spacer {
margin: 0 30px 0 30px;
}
#index #footer {
position: absolute;
bottom: 0;
text-align: bottom;
}
mathcomp-1.5/extra/jc.png 0000644 0001750 0001750 00000003670 12307636117 014414 0 ustar gares gares PNG
IHDR & & = bKGD pHYs tIME/Z tEXtComment Created with The GIMPd%n IDATX{W ?gf+Ky,lW$-V(6@[RM6bZC6ICVH|jM*%"@%(lfXXvǽ{y 3[V.LL>{~mhI5 A.PԚɚZZ* P15B\ ,WB]]UY
p1b,(/]h@ ߽`# WH]Q1 (P
J,Z`%3Bop,p]>j5jcmfVa6de|c5eC-`-P x c'tS+P\5u1vFѹs=2{-$2,`>N%hx*?YCTU6)hZ
pr4, y#}|4Իˁv? 8?F&^)`fqƑV\ |:۠u~
AvKJ+*o 4J7(/v8 =T MuDÚG9!|<`m 0 x7@4(GC2
5yr+ ·jOՌZN\(q. n9; @L 2 &= 1kf"oj&^ɑ]/kE^YhÉ=A9PnZSK fİ[Qt( y~ Ao;W< 8y |]EC WU <~8}cџ*0~!-$\a43%y+mAhi`Dfl_o Tirp<_yO}!}*"T ϬaEPU P0|L&/
?X6 t^lWb \k܊I!=D \$[--L$1$B^NX Mш}Od`kS0bQJYlp,I-/@1DL'x9 lz[ 4B[:#H
wгi=G,GƬ) zG @]D>S",p%T L]x]:~W/!4@mBI 8PƇWT8f=EshȆlY\ɿ{
oгx{P:bK O +fƚeDFߊ=͓$7FdbD.F$ "[]"
|x::l -> let rec listdvr l = match l with
[] -> ""
|y::l -> "," ^ y ^ (listdvr l)
in "[" ^ x ^ (listdvr l) ^ "]"
;;
let rec visit ht hte x s =
Hashtbl.add ht x x;
try let le=Hashtbl.find hte x in
let rec visit_edge ls le =
match le with
[] -> ls
|b::l ->
try let _ =Hashtbl.find ht b in
(visit_edge (ls@[vedge ^ (vnoder b) ^ ")"]) l)
with Not_found ->
(visit_edge (ls@[vedge ^ (visit ht hte b s) ^ ")"]) l)
in s ^ (vnode x) ^ (listdv (visit_edge [] le)) ^ "))"
with Not_found -> s ^ (vnode x) ^ "[]))"
;;
(* cloture transitive *)
let rec merge_list a b = match a with
[] -> b
|x::a -> if (List.mem x b)
then (merge_list a b)
else x::(merge_list a b)
;;
let ht_graph g =
let ht =Hashtbl.create 50 in
let rec fill g = match g with
[] -> ()
|(a,lb)::g -> Hashtbl.add ht a lb; fill g
in fill g;
ht
;;
let trans_clos1 g =
let ht =ht_graph g in
List.map (fun (a,lb) ->
(a,(let l = ref lb in
let rec addlb lb = match lb with
[] -> ()
|b::lb -> (try l:=(merge_list (Hashtbl.find ht b) !l)
with Not_found -> ()); addlb lb
in addlb lb;
!l))) g
;;
let rec transitive_closure g =
let g1=trans_clos1 g in
if g1=g then g else (transitive_closure g1)
;;
(*
let g=["A",["B"];
"B",["C"];
"C",["D"];
"D",["E"];
"E",["A"]];;
transitive_closure g;;
*)
(* enlever les arcs de transitivite *)
let remove_trans g =
let ht = ht_graph (transitive_closure g) in
List.map (fun (a,lb) ->
(a,(let l=ref [] in
(let rec sel l2 = match l2 with
[] -> ()
|b::l2 -> (let r=ref false in
(let rec testlb l3 = match l3 with
[] -> ()
|c::l3 -> if (not (b=a)) &&(not(b=c)) && (not (a=c)) &&
(try (List.mem b (Hashtbl.find ht c))
with Not_found -> false)
then r:=true
else ();
testlb l3
in testlb lb);
if (!r=false)
then l:=b::!l
else ());
sel l2
in sel lb);
!l))) g
;;
(*
let g1=["Le", ["C";"Lt";"B"; "Plus"];
"Lt", ["A";"Plus"]];;
let g=["A",["B";"C";"D";"E"];
"B",["C"];
"C",["D"];
"D",["E"]];;
remove_trans g;;
*)
let dot g name file=
let chan_out = open_out (file^".dot") in
output_string chan_out "digraph ";
output_string chan_out name;
output_string chan_out " {\n";
output_string chan_out " bgcolor=transparent;\n";
output_string chan_out " splines=true;\n";
output_string chan_out " nodesep=1;\n";
output_string chan_out " node [fontsize=18, shape=rect, color=\"#dbc3b6\", style=filled];\n";
List.iter (fun (x,y) ->
output_string chan_out " ";
output_string chan_out (wstring x);
output_string chan_out " [URL=\"./";
output_string chan_out x;
output_string chan_out ".html\"]\n";
List.iter (fun y ->
output_string chan_out " ";
output_string chan_out (wstring x);
output_string chan_out " -> ";
output_string chan_out (wstring y);
output_string chan_out ";\n") y) g;
flush chan_out;
output_string chan_out "}";
close_out chan_out
;;
(*
example: a complete 5-graph,
let g=["A",["B";"C";"D";"E"];
"B",["A";"C";"D";"E"];
"C",["A";"B";"D";"E"];
"D",["A";"B";"C";"E"];
"E",["A";"B";"C";"D"]];;
daVinci g "g2";;
the file is then g2.daVinci
*)
(***********************************************************************)
open Genlex;;
(* change OP april 28 *)
(*
this parsing produce a pair where the first member is a paire (file,Directory)
and the second is a list of pairs (file,Directory).
from this we can compute the files graph dependency and also the directory graph dependency
*)
let lexer = make_lexer [":";".";"/";"-"];;
let rec parse_dep = parser
[< a=parse_name; 'Kwd ".";'Ident b; _=parse_until_colon;
_=parse_name ;'Kwd "."; 'Ident d;n=parse_rem >] -> (a,n)
and parse_rem = parser
[< a=parse_name;'Kwd ".";'Ident b;n=parse_rem >] -> a::n
| [<>]->[]
and parse_until_colon = parser
[< 'Kwd ":" >] -> ()
| [< 'Kwd _; _=parse_until_colon >] -> ()
| [< 'Int _; _=parse_until_colon >] -> ()
| [< 'Ident _; _=parse_until_colon >] -> ()
and parse_name = parser
[<'Kwd "/";a=parse_ident; b=parse_name_rem a "" >]-> a::b
|[]-> a::b
and parse_name2 k = parser
[]-> d::b
and parse_name_rem a b= parser
[<'Kwd "/";c=parse_name2 a >]-> c
| [<>]->[]
and parse_ident = parser
[<'Ident a; b=parse_ident_rem a "" >]-> a ^ b
|[<'Int a; b=parse_ident_rem (string_of_int a) "" >]-> (string_of_int a) ^ b
and parse_ident2 k = parser
[<'Ident d; b=parse_ident_rem d k >]-> d ^ b
|[<'Int d; b=parse_ident_rem (string_of_int d) k >]-> (string_of_int d) ^ b
and parse_ident_rem a b= parser
[<'Kwd "-";c=parse_ident2 a >]-> "-" ^ c
| [<>]-> ""
;;
(*
parse_name(lexer(Stream.of_string "u/sanglier/0/croap/pottier/Coq/Dist/contrib/Rocq/ALGEBRA/CATEGORY_THEORY/NT/YONEDA_LEMMA/NatFun.vo: "));;
parse_ident(lexer(Stream.of_string "ARITH-OMEGA-ggg-2.vo:"));; PROBLEME
*)
(* reads the depend file *)
let read_depend file=
let st =open_in file in
let lr =ref [] in
let rec other() =
(try
let d=parse_dep(lexer(Stream.of_string (input_line st))) in
lr:=d::(!lr);
other()
with _ ->[])
in (let _ = other() in ());
!lr;;
(* graph of a directory (given by a path) *)
let rec is_prefix p q = match p with
[] -> true
|a::p -> match q with [] -> false
|b::q -> if a=b then (is_prefix p q) else false
;;
let rec after_prefix p q = match p with
[] ->(match q with
[] -> "unknown"
|a::_ -> a)
|a::p -> match q with [] -> "unknown"
|b::q -> (after_prefix p q)
;;
let rec proj_graph p g = match g with
[] -> []
|(q,l)::g -> if (is_prefix p q)
then let rec proj_edges l = match l with
[] -> []
|r::l -> if (is_prefix p r)
then (after_prefix p r)::(proj_edges l)
else (proj_edges l)
in ((after_prefix p q),(proj_edges l))
::(proj_graph p g)
else (proj_graph p g)
;;
let rec start_path p = match p with
[] ->[]
|a::p -> match p with
[] ->[]
|b::q -> a::(start_path p)
;;
(* the list of all the paths and subpaths in g *)
let all_path g =
let ht =Hashtbl.create 50 in
let add_path p = Hashtbl.remove ht p;Hashtbl.add ht p true in
let rec add_subpath p = match p with
[] ->()
|_ -> add_path p; add_subpath (start_path p) in
let rec all_path g = match g with
[] -> ()
|(q,l)::g -> add_subpath (start_path q);
let rec all_pathl l = match l with
[] -> ()
|a::l -> add_subpath (start_path a);
all_pathl l
in all_pathl l;
all_path g
in all_path g;
let lp=ref [] in
Hashtbl.iter (fun x y -> lp:=x::!lp) ht;
!lp
;;
(*
let g=read_depend "depend";;
proj_graph ["theories"] g;;
*)
let rec endpath p = match p with
[] ->""
|a::p -> match p with
[] ->a
|_ -> endpath p
;;
let rec fpath p = match p with
[] ->""
|a::p -> a ^ "/" ^ (fpath p)
;;
let rec spath p = match p with
[] -> ""
|a::p -> match p with
[] ->a
|b::q -> a ^ "/" ^ (spath p)
;;
(* creates graphs for all paths *)
let dependtodot file=
let g =(read_depend file) in
let lp1 = all_path g in
let lp = (if lp1=[] then [[]] else lp1) in
let rec ddv lp = match lp with
[] -> ()
|p::lp -> let name = (let f = (endpath p) in
if f="" then file else f) in
let filep = (let f = (spath p) in
if f="" then file else f) in
dot (remove_trans (proj_graph p g))
name filep;
ddv lp
in ddv lp
;;
let _ =
if (Array.length Sys.argv) == 2 then
dependtodot Sys.argv.(1)
else print_string "makedot depend";
print_newline()
mathcomp-1.5/theories/ 0000755 0001750 0001750 00000000000 12307636117 014003 5 ustar gares gares mathcomp-1.5/theories/fingraph.v 0000644 0001750 0001750 00000064217 12307636117 016002 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path fintype.
(******************************************************************************)
(* This file develops the theory of finite graphs represented by an "edge" *)
(* relation over a finType T; this mainly amounts to the theory of the *)
(* transitive closure of such relations. *)
(* For g : T -> seq T, e : rel T and f : T -> T we define: *)
(* grel g == the adjacency relation y \in g x of the graph g. *)
(* rgraph e == the graph (x |-> enum (e x)) of the relation e. *)
(* dfs g n v x == the list of points traversed by a depth-first search of *)
(* the g, at depth n, starting from x, and avoiding v. *)
(* dfs_path g v x y <-> there is a path from x to y in g \ v. *)
(* connect e == the transitive closure of e (computed by dfs). *)
(* connect_sym e <-> connect e is symmetric, hence an equivalence relation. *)
(* root e x == a representative of connect e x, which is the component *)
(* of x in the transitive closure of e. *)
(* roots e == the codomain predicate of root e. *)
(* n_comp e a == the number of e-connected components of a, when a is *)
(* e-closed and connect e is symmetric. *)
(* equivalence classes of connect e if connect_sym e holds. *)
(* closed e a == the collective predicate a is e-invariant. *)
(* closure e a == the e-closure of a (the image of a under connect e). *)
(* rel_adjunction h e e' a <-> in the e-closed domain a, h is the left part *)
(* of an adjunction from e to another relation e'. *)
(* fconnect f == connect (frel f), i.e., "connected under f iteration". *)
(* froot f x == root (frel f) x, the root of the orbit of x under f. *)
(* froots f == roots (frel f) == orbit representatives for f. *)
(* orbit f x == lists the f-orbit of x. *)
(* findex f x y == index of y in the f-orbit of x. *)
(* order f x == size (cardinal) of the f-orbit of x. *)
(* order_set f n == elements of f-order n. *)
(* finv f == the inverse of f, if f is injective. *)
(* := finv f x := iter (order x).-1 f x. *)
(* fcard f a == number of orbits of f in a, provided a is f-invariant *)
(* f is one-to-one. *)
(* fclosed f a == the collective predicate a is f-invariant. *)
(* fclosure f a == the closure of a under f iteration. *)
(* fun_adjunction == rel_adjunction (frel f). *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Definition grel (T : eqType) (g : T -> seq T) := [rel x y | y \in g x].
(* Decidable connectivity in finite types. *)
Section Connect.
Variable T : finType.
Section Dfs.
Variable g : T -> seq T.
Implicit Type v w a : seq T.
Fixpoint dfs n v x :=
if x \in v then v else
if n is n'.+1 then foldl (dfs n') (x :: v) (g x) else v.
Lemma subset_dfs n v a : v \subset foldl (dfs n) v a.
Proof.
elim: n a v => [|n IHn]; first by elim=> //= *; rewrite if_same.
elim=> //= x a IHa v; apply: subset_trans {IHa}(IHa _); case: ifP => // _.
by apply: subset_trans (IHn _ _); apply/subsetP=> y; exact: predU1r.
Qed.
Inductive dfs_path v x y : Prop :=
DfsPath p of path (grel g) x p & y = last x p & [disjoint x :: p & v].
Lemma dfs_pathP n x y v :
#|T| <= #|v| + n -> y \notin v -> reflect (dfs_path v x y) (y \in dfs n v x).
Proof.
have dfs_id w z: z \notin w -> dfs_path w z z.
by exists [::]; rewrite ?disjoint_has //= orbF.
elim: n => [|n IHn] /= in x y v * => le_v'_n not_vy.
rewrite addn0 (geq_leqif (subset_leqif_card (subset_predT _))) in le_v'_n.
by rewrite predT_subset in not_vy.
have [v_x | not_vx] := ifPn.
by rewrite (negPf not_vy); right=> [] [p _ _]; rewrite disjoint_has /= v_x.
set v1 := x :: v; set a := g x; have sub_dfs := subsetP (subset_dfs n _ _).
have [-> | neq_yx] := eqVneq y x.
by rewrite sub_dfs ?mem_head //; left; exact: dfs_id.
apply: (@equivP (exists2 x1, x1 \in a & dfs_path v1 x1 y)); last first.
split=> {IHn} [[x1 a_x1 [p g_p p_y]] | [p /shortenP[]]].
rewrite disjoint_has has_sym /= has_sym /= => /norP[_ not_pv].
by exists (x1 :: p); rewrite /= ?a_x1 // disjoint_has negb_or not_vx.
case=> [_ _ _ eq_yx | x1 p1 /=]; first by case/eqP: neq_yx.
case/andP=> a_x1 g_p1 /andP[not_p1x _] /subsetP p_p1 p1y not_pv.
exists x1 => //; exists p1 => //.
rewrite disjoint_sym disjoint_cons not_p1x disjoint_sym.
by move: not_pv; rewrite disjoint_cons => /andP[_ /disjoint_trans->].
have{neq_yx not_vy}: y \notin v1 by exact/norP.
have{le_v'_n not_vx}: #|T| <= #|v1| + n by rewrite cardU1 not_vx addSnnS.
elim: {x v}a v1 => [|x a IHa] v /= le_v'_n not_vy.
by rewrite (negPf not_vy); right=> [] [].
set v2 := dfs n v x; have v2v: v \subset v2 := subset_dfs n v [:: x].
have [v2y | not_v2y] := boolP (y \in v2).
by rewrite sub_dfs //; left; exists x; [exact: mem_head | exact: IHn].
apply: {IHa}(equivP (IHa _ _ not_v2y)).
by rewrite (leq_trans le_v'_n) // leq_add2r subset_leq_card.
split=> [] [x1 a_x1 [p g_p p_y not_pv]].
exists x1; [exact: predU1r | exists p => //].
by rewrite disjoint_sym (disjoint_trans v2v) // disjoint_sym.
suffices not_p1v2: [disjoint x1 :: p & v2].
case/predU1P: a_x1 => [def_x1 | ]; last by exists x1; last exists p.
case/pred0Pn: not_p1v2; exists x; rewrite /= def_x1 mem_head /=.
suffices not_vx: x \notin v by apply/IHn; last exact: dfs_id.
by move: not_pv; rewrite disjoint_cons def_x1 => /andP[].
apply: contraR not_v2y => /pred0Pn[x2 /andP[/= p_x2 v2x2]].
case/splitPl: p_x2 p_y g_p not_pv => p0 p2 p0x2.
rewrite last_cat cat_path -cat_cons lastI cat_rcons {}p0x2 => p2y /andP[_ g_p2].
rewrite disjoint_cat disjoint_cons => /and3P[{p0}_ not_vx2 not_p2v].
have{not_vx2 v2x2} [p1 g_p1 p1_x2 not_p1v] := IHn _ _ v le_v'_n not_vx2 v2x2.
apply/IHn=> //; exists (p1 ++ p2); rewrite ?cat_path ?last_cat -?p1_x2 ?g_p1 //.
by rewrite -cat_cons disjoint_cat not_p1v.
Qed.
Lemma dfsP x y :
reflect (exists2 p, path (grel g) x p & y = last x p) (y \in dfs #|T| [::] x).
Proof.
apply: (iffP (dfs_pathP _ _ _)); rewrite ?card0 // => [] [p]; exists p => //.
by rewrite disjoint_sym disjoint0.
Qed.
End Dfs.
Variable e : rel T.
Definition rgraph x := enum (e x).
Lemma rgraphK : grel rgraph =2 e.
Proof. by move=> x y; rewrite /= mem_enum. Qed.
Definition connect : rel T := fun x y => y \in dfs rgraph #|T| [::] x.
Canonical connect_app_pred x := ApplicativePred (connect x).
Lemma connectP x y :
reflect (exists2 p, path e x p & y = last x p) (connect x y).
Proof.
apply: (equivP (dfsP _ x y)).
by split=> [] [p e_p ->]; exists p => //; rewrite (eq_path rgraphK) in e_p *.
Qed.
Lemma connect_trans : transitive connect.
Proof.
move=> x y z /connectP[p e_p ->] /connectP[q e_q ->]; apply/connectP.
by exists (p ++ q); rewrite ?cat_path ?e_p ?last_cat.
Qed.
Lemma connect0 x : connect x x.
Proof. by apply/connectP; exists [::]. Qed.
Lemma eq_connect0 x y : x = y -> connect x y.
Proof. move->; exact: connect0. Qed.
Lemma connect1 x y : e x y -> connect x y.
Proof. by move=> e_xy; apply/connectP; exists [:: y]; rewrite /= ?e_xy. Qed.
Lemma path_connect x p : path e x p -> subpred (mem (x :: p)) (connect x).
Proof.
move=> e_p y p_y; case/splitPl: p / p_y e_p => p q <-.
by rewrite cat_path => /andP[e_p _]; apply/connectP; exists p.
Qed.
Definition root x := odflt x (pick (connect x)).
Definition roots : pred T := fun x => root x == x.
Canonical roots_pred := ApplicativePred roots.
Definition n_comp_mem (m_a : mem_pred T) := #|predI roots m_a|.
Lemma connect_root x : connect x (root x).
Proof. by rewrite /root; case: pickP; rewrite ?connect0. Qed.
Definition connect_sym := symmetric connect.
Hypothesis sym_e : connect_sym.
Lemma same_connect : left_transitive connect.
Proof. exact: sym_left_transitive connect_trans. Qed.
Lemma same_connect_r : right_transitive connect.
Proof. exact: sym_right_transitive connect_trans. Qed.
Lemma same_connect1 x y : e x y -> connect x =1 connect y.
Proof. by move/connect1; exact: same_connect. Qed.
Lemma same_connect1r x y : e x y -> connect^~ x =1 connect^~ y.
Proof. by move/connect1; exact: same_connect_r. Qed.
Lemma rootP x y : reflect (root x = root y) (connect x y).
Proof.
apply: (iffP idP) => e_xy.
by rewrite /root -(eq_pick (same_connect e_xy)); case: pickP e_xy => // ->.
by apply: (connect_trans (connect_root x)); rewrite e_xy sym_e connect_root.
Qed.
Lemma root_root x : root (root x) = root x.
Proof. exact/esym/rootP/connect_root. Qed.
Lemma roots_root x : roots (root x).
Proof. exact/eqP/root_root. Qed.
Lemma root_connect x y : (root x == root y) = connect x y.
Proof. exact: sameP eqP (rootP x y). Qed.
Definition closed_mem m_a := forall x y, e x y -> in_mem x m_a = in_mem y m_a.
Definition closure_mem m_a : pred T :=
fun x => ~~ disjoint (mem (connect x)) m_a.
End Connect.
Hint Resolve connect0.
Notation n_comp e a := (n_comp_mem e (mem a)).
Notation closed e a := (closed_mem e (mem a)).
Notation closure e a := (closure_mem e (mem a)).
Prenex Implicits connect root roots.
Implicit Arguments dfsP [T g x y].
Implicit Arguments connectP [T e x y].
Implicit Arguments rootP [T e x y].
Notation fconnect f := (connect (coerced_frel f)).
Notation froot f := (root (coerced_frel f)).
Notation froots f := (roots (coerced_frel f)).
Notation fcard_mem f := (n_comp_mem (coerced_frel f)).
Notation fcard f a := (fcard_mem f (mem a)).
Notation fclosed f a := (closed (coerced_frel f) a).
Notation fclosure f a := (closure (coerced_frel f) a).
Section EqConnect.
Variable T : finType.
Implicit Types (e : rel T) (a : pred T).
Lemma connect_sub e e' :
subrel e (connect e') -> subrel (connect e) (connect e').
Proof.
move=> e'e x _ /connectP[p e_p ->]; elim: p x e_p => //= y p IHp x /andP[exy].
by move/IHp; apply: connect_trans; exact: e'e.
Qed.
Lemma relU_sym e e' :
connect_sym e -> connect_sym e' -> connect_sym (relU e e').
Proof.
move=> sym_e sym_e'; apply: symmetric_from_pre => x _ /connectP[p e_p ->].
elim: p x e_p => //= y p IHp x /andP[e_xy /IHp{IHp}/connect_trans]; apply.
case/orP: e_xy => /connect1; rewrite (sym_e, sym_e');
by apply: connect_sub y x => x y e_xy; rewrite connect1 //= e_xy ?orbT.
Qed.
Lemma eq_connect e e' : e =2 e' -> connect e =2 connect e'.
Proof.
move=> eq_e x y; apply/connectP/connectP=> [] [p e_p ->];
by exists p; rewrite // (eq_path eq_e) in e_p *.
Qed.
Lemma eq_n_comp e e' : connect e =2 connect e' -> n_comp_mem e =1 n_comp_mem e'.
Proof.
move=> eq_e [a]; apply: eq_card => x /=.
by rewrite !inE /= /roots /root /= (eq_pick (eq_e x)).
Qed.
Lemma eq_n_comp_r {e} a a' : a =i a' -> n_comp e a = n_comp e a'.
Proof. by move=> eq_a; apply: eq_card => x; rewrite inE /= eq_a. Qed.
Lemma n_compC a e : n_comp e T = n_comp e a + n_comp e [predC a].
Proof.
rewrite /n_comp_mem (eq_card (fun _ => andbT _)) -(cardID a); congr (_ + _).
by apply: eq_card => x; rewrite !inE andbC.
Qed.
Lemma eq_root e e' : e =2 e' -> root e =1 root e'.
Proof. by move=> eq_e x; rewrite /root (eq_pick (eq_connect eq_e x)). Qed.
Lemma eq_roots e e' : e =2 e' -> roots e =1 roots e'.
Proof. by move=> eq_e x; rewrite /roots (eq_root eq_e). Qed.
End EqConnect.
Section Closure.
Variables (T : finType) (e : rel T).
Hypothesis sym_e : connect_sym e.
Implicit Type a : pred T.
Lemma same_connect_rev : connect e =2 connect (fun x y => e y x).
Proof.
suff crev e': subrel (connect (fun x : T => e'^~ x)) (fun x => (connect e')^~x).
by move=> x y; rewrite sym_e; apply/idP/idP; exact: crev.
move=> x y /connectP[p e_p p_y]; apply/connectP.
exists (rev (belast x p)); first by rewrite p_y rev_path.
by rewrite -(last_cons x) -rev_rcons p_y -lastI rev_cons last_rcons.
Qed.
Lemma intro_closed a : (forall x y, e x y -> x \in a -> y \in a) -> closed e a.
Proof.
move=> cl_a x y e_xy; apply/idP/idP=> [|a_y]; first exact: cl_a.
have{x e_xy} /connectP[p e_p ->]: connect e y x by rewrite sym_e connect1.
by elim: p y a_y e_p => //= y p IHp x a_x /andP[/cl_a/(_ a_x)]; exact: IHp.
Qed.
Lemma closed_connect a :
closed e a -> forall x y, connect e x y -> (x \in a) = (y \in a).
Proof.
move=> cl_a x _ /connectP[p e_p ->].
by elim: p x e_p => //= y p IHp x /andP[/cl_a->]; exact: IHp.
Qed.
Lemma connect_closed x : closed e (connect e x).
Proof. by move=> y z /connect1/same_connect_r; exact. Qed.
Lemma predC_closed a : closed e a -> closed e [predC a].
Proof. by move=> cl_a x y /cl_a; rewrite !inE => ->. Qed.
Lemma closure_closed a : closed e (closure e a).
Proof.
apply: intro_closed => x y /connect1 e_xy; congr (~~ _).
by apply: eq_disjoint; exact: same_connect.
Qed.
Lemma mem_closure a : {subset a <= closure e a}.
Proof. by move=> x a_x; apply/existsP; exists x; rewrite !inE connect0. Qed.
Lemma subset_closure a : a \subset closure e a.
Proof. by apply/subsetP; exact: mem_closure. Qed.
Lemma n_comp_closure2 x y :
n_comp e (closure e (pred2 x y)) = (~~ connect e x y).+1.
Proof.
rewrite -(root_connect sym_e) -card2; apply: eq_card => z.
apply/idP/idP=> [/andP[/eqP {2}<- /pred0Pn[t /andP[/= ezt exyt]]] |].
by case/pred2P: exyt => <-; rewrite (rootP sym_e ezt) !inE eqxx ?orbT.
by case/pred2P=> ->; rewrite !inE roots_root //; apply/existsP;
[exists x | exists y]; rewrite !inE eqxx ?orbT sym_e connect_root.
Qed.
Lemma n_comp_connect x : n_comp e (connect e x) = 1.
Proof.
rewrite -(card1 (root e x)); apply: eq_card => y.
apply/andP/eqP => [[/eqP r_y /rootP-> //] | ->] /=.
by rewrite inE connect_root roots_root.
Qed.
End Closure.
Section Orbit.
Variables (T : finType) (f : T -> T).
Definition order x := #|fconnect f x|.
Definition orbit x := traject f x (order x).
Definition findex x y := index y (orbit x).
Definition finv x := iter (order x).-1 f x.
Lemma fconnect_iter n x : fconnect f x (iter n f x).
Proof.
apply/connectP.
by exists (traject f (f x) n); [ exact: fpath_traject | rewrite last_traject ].
Qed.
Lemma fconnect1 x : fconnect f x (f x).
Proof. exact: (fconnect_iter 1). Qed.
Lemma fconnect_finv x : fconnect f x (finv x).
Proof. exact: fconnect_iter. Qed.
Lemma orderSpred x : (order x).-1.+1 = order x.
Proof. by rewrite /order (cardD1 x) [_ x _]connect0. Qed.
Lemma size_orbit x : size (orbit x) = order x.
Proof. exact: size_traject. Qed.
Lemma looping_order x : looping f x (order x).
Proof.
apply: contraFT (ltnn (order x)); rewrite -looping_uniq => /card_uniqP.
rewrite size_traject => <-; apply: subset_leq_card.
by apply/subsetP=> _ /trajectP[i _ ->]; exact: fconnect_iter.
Qed.
Lemma fconnect_orbit x y : fconnect f x y = (y \in orbit x).
Proof.
apply/idP/idP=> [/connectP[_ /fpathP[m ->] ->] | /trajectP[i _ ->]].
by rewrite last_traject; exact/loopingP/looping_order.
exact: fconnect_iter.
Qed.
Lemma orbit_uniq x : uniq (orbit x).
Proof.
rewrite /orbit -orderSpred looping_uniq; set n := (order x).-1.
apply: contraFN (ltnn n) => /trajectP[i lt_i_n eq_fnx_fix].
rewrite {1}/n orderSpred /order -(size_traject f x n).
apply: (leq_trans (subset_leq_card _) (card_size _)); apply/subsetP=> z.
rewrite inE fconnect_orbit => /trajectP[j le_jn ->{z}].
rewrite -orderSpred -/n ltnS leq_eqVlt in le_jn.
by apply/trajectP; case/predU1P: le_jn => [->|]; [exists i | exists j].
Qed.
Lemma findex_max x y : fconnect f x y -> findex x y < order x.
Proof. by rewrite [_ y]fconnect_orbit -index_mem size_orbit. Qed.
Lemma findex_iter x i : i < order x -> findex x (iter i f x) = i.
Proof.
move=> lt_ix; rewrite -(nth_traject f lt_ix) /findex index_uniq ?orbit_uniq //.
by rewrite size_orbit.
Qed.
Lemma iter_findex x y : fconnect f x y -> iter (findex x y) f x = y.
Proof.
rewrite [_ y]fconnect_orbit => fxy; pose i := index y (orbit x).
have lt_ix: i < order x by rewrite -size_orbit index_mem.
by rewrite -(nth_traject f lt_ix) nth_index.
Qed.
Lemma findex0 x : findex x x = 0.
Proof. by rewrite /findex /orbit -orderSpred /= eqxx. Qed.
Lemma fconnect_invariant (T' : eqType) (k : T -> T') :
invariant f k =1 xpredT -> forall x y, fconnect f x y -> k x = k y.
Proof.
move=> eq_k_f x y /iter_findex <-; elim: {y}(findex x y) => //= n ->.
by rewrite (eqP (eq_k_f _)).
Qed.
Section Loop.
Variable p : seq T.
Hypotheses (f_p : fcycle f p) (Up : uniq p).
Variable x : T.
Hypothesis p_x : x \in p.
(* This lemma does not depend on Up : (uniq p) *)
Lemma fconnect_cycle y : fconnect f x y = (y \in p).
Proof.
have [i q def_p] := rot_to p_x; rewrite -(mem_rot i p) def_p.
have{i def_p} /andP[/eqP q_x f_q]: (f (last x q) == x) && fpath f x q.
by have:= f_p; rewrite -(rot_cycle i) def_p (cycle_path x).
apply/idP/idP=> [/connectP[_ /fpathP[j ->] ->] | ]; last exact: path_connect.
case/fpathP: f_q q_x => n ->; rewrite !last_traject -iterS => def_x.
by apply: (@loopingP _ f x n.+1); rewrite /looping def_x /= mem_head.
Qed.
Lemma order_cycle : order x = size p.
Proof. by rewrite -(card_uniqP Up); exact (eq_card fconnect_cycle). Qed.
Lemma orbit_rot_cycle : {i : nat | orbit x = rot i p}.
Proof.
have [i q def_p] := rot_to p_x; exists i.
rewrite /orbit order_cycle -(size_rot i) def_p.
suffices /fpathP[j ->]: fpath f x q by rewrite /= size_traject.
by move: f_p; rewrite -(rot_cycle i) def_p (cycle_path x); case/andP.
Qed.
End Loop.
Hypothesis injf : injective f.
Lemma f_finv : cancel finv f.
Proof.
move=> x; move: (looping_order x) (orbit_uniq x).
rewrite /looping /orbit -orderSpred looping_uniq /= /looping; set n := _.-1.
case/predU1P=> // /trajectP[i lt_i_n]; rewrite -iterSr => /= /injf ->.
by case/trajectP; exists i.
Qed.
Lemma finv_f : cancel f finv.
Proof. exact (inj_can_sym f_finv injf). Qed.
Lemma fin_inj_bij : bijective f.
Proof. exists finv; [ exact finv_f | exact f_finv ]. Qed.
Lemma finv_bij : bijective finv.
Proof. exists f; [ exact f_finv | exact finv_f ]. Qed.
Lemma finv_inj : injective finv.
Proof. exact (can_inj f_finv). Qed.
Lemma fconnect_sym x y : fconnect f x y = fconnect f y x.
Proof.
suff{x y} Sf x y: fconnect f x y -> fconnect f y x by apply/idP/idP; auto.
case/connectP=> p f_p -> {y}; elim: p x f_p => //= y p IHp x.
rewrite -{2}(finv_f x) => /andP[/eqP-> /IHp/connect_trans-> //].
exact: fconnect_finv.
Qed.
Let symf := fconnect_sym.
Lemma iter_order x : iter (order x) f x = x.
Proof. by rewrite -orderSpred iterS; exact (f_finv x). Qed.
Lemma iter_finv n x : n <= order x -> iter n finv x = iter (order x - n) f x.
Proof.
rewrite -{2}[x]iter_order => /subnKC {1}<-; move: (_ - n) => m.
by rewrite iter_add; elim: n => // n {2}<-; rewrite iterSr /= finv_f.
Qed.
Lemma cycle_orbit x : fcycle f (orbit x).
Proof.
rewrite /orbit -orderSpred (cycle_path x) /= last_traject -/(finv x).
by rewrite fpath_traject f_finv andbT /=.
Qed.
Lemma fpath_finv x p : fpath finv x p = fpath f (last x p) (rev (belast x p)).
Proof.
elim: p x => //= y p IHp x; rewrite rev_cons rcons_path -{}IHp andbC /=.
rewrite (canF_eq finv_f) eq_sym; congr (_ && (_ == _)).
by case: p => //= z p; rewrite rev_cons last_rcons.
Qed.
Lemma same_fconnect_finv : fconnect finv =2 fconnect f.
Proof.
move=> x y; rewrite (same_connect_rev symf); apply: {x y}eq_connect => x y /=.
by rewrite (canF_eq finv_f) eq_sym.
Qed.
Lemma fcard_finv : fcard_mem finv =1 fcard_mem f.
Proof. exact: eq_n_comp same_fconnect_finv. Qed.
Definition order_set n : pred T := [pred x | order x == n].
Lemma fcard_order_set n (a : pred T) :
a \subset order_set n -> fclosed f a -> fcard f a * n = #|a|.
Proof.
move=> a_n cl_a; rewrite /n_comp_mem; set b := [predI froots f & a].
symmetry; transitivity #|preim (froot f) b|.
apply: eq_card => x; rewrite !inE (roots_root fconnect_sym).
by rewrite -(closed_connect cl_a (connect_root _ x)).
have{cl_a a_n} (x): b x -> froot f x = x /\ order x = n.
by case/andP=> /eqP-> /(subsetP a_n)/eqnP->.
elim: {a b}#|b| {1 3 4}b (eqxx #|b|) => [|m IHm] b def_m f_b.
by rewrite eq_card0 // => x; exact: (pred0P def_m).
have [x b_x | b0] := pickP b; last by rewrite (eq_card0 b0) in def_m.
have [r_x ox_n] := f_b x b_x; rewrite (cardD1 x) [x \in b]b_x eqSS in def_m.
rewrite mulSn -{1}ox_n -(IHm _ def_m) => [|_ /andP[_ /f_b //]].
rewrite -(cardID (fconnect f x)); congr (_ + _); apply: eq_card => y.
by apply: andb_idl => /= fxy; rewrite !inE -(rootP symf fxy) r_x.
by congr (~~ _ && _); rewrite /= /in_mem /= symf -(root_connect symf) r_x.
Qed.
Lemma fclosed1 (a : pred T) : fclosed f a -> forall x, (x \in a) = (f x \in a).
Proof. by move=> cl_a x; exact: cl_a (eqxx _). Qed.
Lemma same_fconnect1 x : fconnect f x =1 fconnect f (f x).
Proof. by apply: same_connect1 => /=. Qed.
Lemma same_fconnect1_r x y : fconnect f x y = fconnect f x (f y).
Proof. by apply: same_connect1r x => /=. Qed.
End Orbit.
Prenex Implicits order orbit findex finv order_set.
Section FconnectId.
Variable T : finType.
Lemma fconnect_id (x : T) : fconnect id x =1 xpred1 x.
Proof. by move=> y; rewrite (@fconnect_cycle _ _ [:: x]) //= ?inE ?eqxx. Qed.
Lemma order_id (x : T) : order id x = 1.
Proof. by rewrite /order (eq_card (fconnect_id x)) card1. Qed.
Lemma orbit_id (x : T) : orbit id x = [:: x].
Proof. by rewrite /orbit order_id. Qed.
Lemma froots_id (x : T) : froots id x.
Proof. by rewrite /roots -fconnect_id connect_root. Qed.
Lemma froot_id (x : T) : froot id x = x.
Proof. by apply/eqP; exact: froots_id. Qed.
Lemma fcard_id (a : pred T) : fcard id a = #|a|.
Proof. by apply: eq_card => x; rewrite inE froots_id. Qed.
End FconnectId.
Section FconnectEq.
Variables (T : finType) (f f' : T -> T).
Lemma finv_eq_can : cancel f f' -> finv f =1 f'.
Proof.
move=> fK; exact: (bij_can_eq (fin_inj_bij (can_inj fK)) (finv_f (can_inj fK))).
Qed.
Hypothesis eq_f : f =1 f'.
Let eq_rf := eq_frel eq_f.
Lemma eq_fconnect : fconnect f =2 fconnect f'.
Proof. exact: eq_connect eq_rf. Qed.
Lemma eq_fcard : fcard_mem f =1 fcard_mem f'.
Proof. exact: eq_n_comp eq_fconnect. Qed.
Lemma eq_finv : finv f =1 finv f'.
Proof.
by move=> x; rewrite /finv /order (eq_card (eq_fconnect x)) (eq_iter eq_f).
Qed.
Lemma eq_froot : froot f =1 froot f'.
Proof. exact: eq_root eq_rf. Qed.
Lemma eq_froots : froots f =1 froots f'.
Proof. exact: eq_roots eq_rf. Qed.
End FconnectEq.
Section FinvEq.
Variables (T : finType) (f : T -> T).
Hypothesis injf : injective f.
Lemma finv_inv : finv (finv f) =1 f.
Proof. exact: (finv_eq_can (f_finv injf)). Qed.
Lemma order_finv : order (finv f) =1 order f.
Proof. by move=> x; exact: eq_card (same_fconnect_finv injf x). Qed.
Lemma order_set_finv n : order_set (finv f) n =i order_set f n.
Proof. by move=> x; rewrite !inE order_finv. Qed.
End FinvEq.
Section RelAdjunction.
Variables (T T' : finType) (h : T' -> T) (e : rel T) (e' : rel T').
Hypotheses (sym_e : connect_sym e) (sym_e' : connect_sym e').
Record rel_adjunction_mem m_a := RelAdjunction {
rel_unit x : in_mem x m_a -> {x' : T' | connect e x (h x')};
rel_functor x' y' :
in_mem (h x') m_a -> connect e' x' y' = connect e (h x') (h y')
}.
Variable a : pred T.
Hypothesis cl_a : closed e a.
Local Notation rel_adjunction := (rel_adjunction_mem (mem a)).
Lemma intro_adjunction (h' : forall x, x \in a -> T') :
(forall x a_x,
[/\ connect e x (h (h' x a_x))
& forall y a_y, e x y -> connect e' (h' x a_x) (h' y a_y)]) ->
(forall x' a_x,
[/\ connect e' x' (h' (h x') a_x)
& forall y', e' x' y' -> connect e (h x') (h y')]) ->
rel_adjunction.
Proof.
move=> Aee' Ae'e; split=> [y a_y | x' z' a_x].
by exists (h' y a_y); case/Aee': (a_y).
apply/idP/idP=> [/connectP[p e'p ->{z'}] | /connectP[p e_p p_z']].
elim: p x' a_x e'p => //= y' p IHp x' a_x.
case: (Ae'e x' a_x) => _ Ae'x /andP[/Ae'x e_xy /IHp e_yz] {Ae'x}.
by apply: connect_trans (e_yz _); rewrite // -(closed_connect cl_a e_xy).
case: (Ae'e x' a_x) => /connect_trans-> //.
elim: p {x'}(h x') p_z' a_x e_p => /= [|y p IHp] x p_z' a_x.
by rewrite -p_z' in a_x *; case: (Ae'e _ a_x); rewrite sym_e'.
case/andP=> e_xy /(IHp _ p_z') e'yz; have a_y: y \in a by rewrite -(cl_a e_xy).
by apply: connect_trans (e'yz a_y); case: (Aee' _ a_x) => _ ->.
Qed.
Lemma strict_adjunction :
injective h -> a \subset codom h -> rel_base h e e' [predC a] ->
rel_adjunction.
Proof.
move=> /= injh h_a a_ee'; pose h' x Hx := iinv (subsetP h_a x Hx).
apply: (@intro_adjunction h') => [x a_x | x' a_x].
rewrite f_iinv connect0; split=> // y a_y e_xy.
by rewrite connect1 // -a_ee' !f_iinv ?negbK.
rewrite [h' _ _]iinv_f //; split=> // y' e'xy.
by rewrite connect1 // a_ee' ?negbK.
Qed.
Let ccl_a := closed_connect cl_a.
Lemma adjunction_closed : rel_adjunction -> closed e' [preim h of a].
Proof.
case=> _ Ae'e; apply: intro_closed => // x' y' /connect1 e'xy a_x.
by rewrite Ae'e // in e'xy; rewrite !inE -(ccl_a e'xy).
Qed.
Lemma adjunction_n_comp :
rel_adjunction -> n_comp e a = n_comp e' [preim h of a].
Proof.
case=> Aee' Ae'e.
have inj_h: {in predI (roots e') [preim h of a] &, injective (root e \o h)}.
move=> x' y' /andP[/eqP r_x' /= a_x'] /andP[/eqP r_y' _] /(rootP sym_e).
by rewrite -Ae'e // => /(rootP sym_e'); rewrite r_x' r_y'.
rewrite /n_comp_mem -(card_in_image inj_h); apply: eq_card => x.
apply/andP/imageP=> [[/eqP rx a_x] | [x' /andP[/eqP r_x' a_x'] ->]]; last first.
by rewrite /= -(ccl_a (connect_root _ _)) roots_root.
have [y' e_xy]:= Aee' x a_x; pose x' := root e' y'.
have ay': h y' \in a by rewrite -(ccl_a e_xy).
have e_yx: connect e (h y') (h x') by rewrite -Ae'e ?connect_root.
exists x'; first by rewrite inE /= -(ccl_a e_yx) ?roots_root.
by rewrite /= -(rootP sym_e e_yx) -(rootP sym_e e_xy).
Qed.
End RelAdjunction.
Notation rel_adjunction h e e' a := (rel_adjunction_mem h e e' (mem a)).
Notation "@ 'rel_adjunction' T T' h e e' a" :=
(@rel_adjunction_mem T T' h e e' (mem a))
(at level 10, T, T', h, e, e', a at level 8, only parsing) : type_scope.
Notation fun_adjunction h f f' a := (rel_adjunction h (frel f) (frel f') a).
Notation "@ 'fun_adjunction' T T' h f f' a" :=
(@rel_adjunction T T' h (frel f) (frel f') a)
(at level 10, T, T', h, f, f', a at level 8, only parsing) : type_scope.
Implicit Arguments intro_adjunction [T T' h e e' a].
Implicit Arguments adjunction_n_comp [T T' e e' a].
Unset Implicit Arguments.
mathcomp-1.5/theories/alt.v 0000644 0001750 0001750 00000057272 12307636117 014767 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype tuple.
Require Import tuple bigop prime finset fingroup morphism perm automorphism.
Require Import quotient action cyclic pgroup gseries sylow primitive_action.
(******************************************************************************)
(* Definitions of the symmetric and alternate groups, and some properties. *)
(* 'Sym_T == The symmetric group over type T (which must have a finType *)
(* structure). *)
(* := [set: {perm T}] *)
(* 'Alt_T == The alternating group over type T. *)
(******************************************************************************)
Unset Printing Implicit Defensive.
Set Implicit Arguments.
Unset Strict Implicit.
Import GroupScope.
Definition bool_groupMixin := FinGroup.Mixin addbA addFb addbb.
Canonical bool_baseGroup := Eval hnf in BaseFinGroupType bool bool_groupMixin.
Canonical boolGroup := Eval hnf in FinGroupType addbb.
Section SymAltDef.
Variable T : finType.
Implicit Types (s : {perm T}) (x y z : T).
(** Definitions of the alternate groups and some Properties **)
Definition Sym of phant T : {set {perm T}} := setT.
Canonical Sym_group phT := Eval hnf in [group of Sym phT].
Notation Local "'Sym_T" := (Sym (Phant T)) (at level 0).
Canonical sign_morph := @Morphism _ _ 'Sym_T _ (in2W (@odd_permM _)).
Definition Alt of phant T := 'ker (@odd_perm T).
Canonical Alt_group phT := Eval hnf in [group of Alt phT].
Notation Local "'Alt_T" := (Alt (Phant T)) (at level 0).
Lemma Alt_even p : (p \in 'Alt_T) = ~~ p.
Proof. by rewrite !inE /=; case: odd_perm. Qed.
Lemma Alt_subset : 'Alt_T \subset 'Sym_T.
Proof. exact: subsetT. Qed.
Lemma Alt_normal : 'Alt_T <| 'Sym_T.
Proof. exact: ker_normal. Qed.
Lemma Alt_norm : 'Sym_T \subset 'N('Alt_T).
Proof. by case/andP: Alt_normal. Qed.
Let n := #|T|.
Lemma Alt_index : 1 < n -> #|'Sym_T : 'Alt_T| = 2.
Proof.
move=> lt1n; rewrite -card_quotient ?Alt_norm //=.
have : ('Sym_T / 'Alt_T) \isog (@odd_perm T @* 'Sym_T) by apply: first_isog.
case/isogP=> g /injmP/card_in_imset <-.
rewrite /morphim setIid=> ->; rewrite -card_bool; apply: eq_card => b.
apply/imsetP; case: b => /=; last first.
by exists (1 : {perm T}); [rewrite setIid inE | rewrite odd_perm1].
case: (pickP T) lt1n => [x1 _ | d0]; last by rewrite /n eq_card0.
rewrite /n (cardD1 x1) ltnS lt0n => /existsP[x2 /=].
by rewrite eq_sym andbT -odd_tperm; exists (tperm x1 x2); rewrite ?inE.
Qed.
Lemma card_Sym : #|'Sym_T| = n`!.
Proof.
rewrite -[n]cardsE -card_perm; apply: eq_card => p.
by apply/idP/subsetP=> [? ?|]; rewrite !inE.
Qed.
Lemma card_Alt : 1 < n -> (2 * #|'Alt_T|)%N = n`!.
Proof.
by move/Alt_index <-; rewrite mulnC (Lagrange Alt_subset) card_Sym.
Qed.
Lemma Sym_trans : [transitive^n 'Sym_T, on setT | 'P].
Proof.
apply/imsetP; pose t1 := [tuple of enum T].
have dt1: t1 \in n.-dtuple(setT) by rewrite inE enum_uniq; apply/subsetP.
exists t1 => //; apply/setP=> t; apply/idP/imsetP=> [|[a _ ->{t}]]; last first.
by apply: n_act_dtuple => //; apply/astabsP=> x; rewrite !inE.
case/dtuple_onP=> injt _; have injf := inj_comp injt enum_rank_inj.
exists (perm injf); first by rewrite inE.
apply: eq_from_tnth => i; rewrite tnth_map /= [aperm _ _]permE; congr tnth.
by rewrite (tnth_nth (enum_default i)) enum_valK.
Qed.
Lemma Alt_trans : [transitive^n.-2 'Alt_T, on setT | 'P].
Proof.
case n_m2: n Sym_trans => [|[|m]] /= tr_m2; try exact: ntransitive0.
have tr_m := ntransitive_weak (leqW (leqnSn m)) tr_m2.
case/imsetP: tr_m2; case/tupleP=> x; case/tupleP=> y t.
rewrite !dtuple_on_add 2![x \in _]inE inE negb_or /= -!andbA.
case/and4P=> nxy ntx nty dt _; apply/imsetP; exists t => //; apply/setP=> u.
apply/idP/imsetP=> [|[a _ ->{u}]]; last first.
by apply: n_act_dtuple => //; apply/astabsP=> z; rewrite !inE.
case/(atransP2 tr_m dt)=> /= a _ ->{u}.
case odd_a: (odd_perm a); last by exists a => //; rewrite !inE /= odd_a.
exists (tperm x y * a); first by rewrite !inE /= odd_permM odd_tperm nxy odd_a.
apply/val_inj/eq_in_map => z tz; rewrite actM /= /aperm; congr (a _).
by case: tpermP ntx nty => // <-; rewrite tz.
Qed.
Lemma aperm_faithful (A : {group {perm T}}) : [faithful A, on setT | 'P].
Proof.
by apply/faithfulP=> /= p _ np1; apply/eqP/perm_act1P=> y; rewrite np1 ?inE.
Qed.
End SymAltDef.
Notation "''Sym_' T" := (Sym (Phant T))
(at level 8, T at level 2, format "''Sym_' T") : group_scope.
Notation "''Sym_' T" := (Sym_group (Phant T)) : Group_scope.
Notation "''Alt_' T" := (Alt (Phant T))
(at level 8, T at level 2, format "''Alt_' T") : group_scope.
Notation "''Alt_' T" := (Alt_group (Phant T)) : Group_scope.
Lemma trivial_Alt_2 (T : finType) : #|T| <= 2 -> 'Alt_T = 1.
Proof.
rewrite leq_eqVlt => /predU1P[] oT.
by apply: card_le1_trivg; rewrite -leq_double -mul2n card_Alt oT.
suffices Sym1: 'Sym_T = 1 by apply/trivgP; rewrite -Sym1 subsetT.
by apply: card1_trivg; rewrite card_Sym; case: #|T| oT; do 2?case.
Qed.
Lemma simple_Alt_3 (T : finType) : #|T| = 3 -> simple 'Alt_T.
Proof.
move=> T3; have{T3} oA: #|'Alt_T| = 3.
by apply: double_inj; rewrite -mul2n card_Alt T3.
apply/simpleP; split=> [|K]; [by rewrite trivg_card1 oA | case/andP=> sKH _].
have:= cardSg sKH; rewrite oA dvdn_divisors // !inE orbC /= -oA.
case/pred2P=> eqK; [right | left]; apply/eqP.
by rewrite eqEcard sKH eqK leqnn.
by rewrite eq_sym eqEcard sub1G eqK cards1.
Qed.
Lemma not_simple_Alt_4 (T : finType) : #|T| = 4 -> ~~ simple 'Alt_T.
Proof.
move=> oT; set A := 'Alt_T.
have oA: #|A| = 12 by apply: double_inj; rewrite -mul2n card_Alt oT.
suffices [p]: exists p, [/\ prime p, 1 < #|A|`_p < #|A| & #|'Syl_p(A)| == 1%N].
case=> p_pr pA_int; rewrite /A; case/normal_sylowP=> P; case/pHallP.
rewrite /= -/A => sPA pP nPA; apply/simpleP=> [] [_]; rewrite -pP in pA_int.
by case/(_ P)=> // defP; rewrite defP oA ?cards1 in pA_int.
have: #|'Syl_3(A)| \in filter [pred d | d %% 3 == 1%N] (divisors 12).
by rewrite mem_filter -dvdn_divisors //= -oA card_Syl_dvd ?card_Syl_mod.
rewrite /= oA mem_seq2 orbC.
case/predU1P=> [oQ3|]; [exists 2 | exists 3]; split; rewrite ?p_part //.
pose A3 := [set x : {perm T} | #[x] == 3]; suffices oA3: #|A :&: A3| = 8.
have sQ2 P: P \in 'Syl_2(A) -> P :=: A :\: A3.
rewrite inE pHallE oA p_part -natTrecE /= => /andP[sPA /eqP oP].
apply/eqP; rewrite eqEcard -(leq_add2l 8) -{1}oA3 cardsID oA oP.
rewrite andbT subsetD sPA; apply/exists_inP=> -[x] /= Px.
by rewrite inE => /eqP ox; have:= order_dvdG Px; rewrite oP ox.
have [/= P sylP] := Sylow_exists 2 [group of A].
rewrite -(([set P] =P 'Syl_2(A)) _) ?cards1 // eqEsubset sub1set inE sylP.
by apply/subsetP=> Q sylQ; rewrite inE -val_eqE /= !sQ2 // inE.
rewrite -[8]/(4 * 2)%N -{}oQ3 -sum1_card -sum_nat_const.
rewrite (partition_big (fun x => <[x]>%G) (mem 'Syl_3(A))) => [|x]; last first.
by case/setIP=> Ax; rewrite /= !inE pHallE p_part cycle_subG Ax oA.
apply: eq_bigr => Q; rewrite inE /= inE pHallE oA p_part -?natTrecE //=.
case/andP=> sQA /eqP oQ; have:= oQ.
rewrite (cardsD1 1) group1 -sum1_card => [[/= <-]]; apply: eq_bigl => x.
rewrite setIC -val_eqE /= 2!inE in_setD1 -andbA -{4}[x]expg1 -order_dvdn dvdn1.
apply/and3P/andP=> [[/eqP-> _ /eqP <-] | [ntx Qx]]; first by rewrite cycle_id.
have:= order_dvdG Qx; rewrite oQ dvdn_divisors // mem_seq2 (negPf ntx) /=.
by rewrite eqEcard cycle_subG Qx (subsetP sQA) // oQ /order => /eqP->.
Qed.
Lemma simple_Alt5_base (T : finType) : #|T| = 5 -> simple 'Alt_T.
Proof.
move=> oT.
have F1: #|'Alt_T| = 60 by apply: double_inj; rewrite -mul2n card_Alt oT.
have FF (H : {group {perm T}}): H <| 'Alt_T -> H :<>: 1 -> 20 %| #|H|.
- move=> Hh1 Hh3.
have [x _]: exists x, x \in T by apply/existsP/eqP; rewrite oT.
have F2 := Alt_trans T; rewrite oT /= in F2.
have F3: [transitive 'Alt_T, on setT | 'P] by exact: ntransitive1 F2.
have F4: [primitive 'Alt_T, on setT | 'P] by exact: ntransitive_primitive F2.
case: (prim_trans_norm F4 Hh1) => F5.
case: Hh3; apply/trivgP; exact: subset_trans F5 (aperm_faithful _).
have F6: 5 %| #|H| by rewrite -oT -cardsT (atrans_dvd F5).
have F7: 4 %| #|H|.
have F7: #|[set~ x]| = 4 by rewrite cardsC1 oT.
case: (pickP (mem [set~ x])) => [y Hy | ?]; last by rewrite eq_card0 in F7.
pose K := 'C_H[x | 'P]%G.
have F8 : K \subset H by apply: subsetIl.
pose Gx := 'C_('Alt_T)[x | 'P]%G.
have F9: [transitive^2 Gx, on [set~ x] | 'P].
by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
have F10: [transitive Gx, on [set~ x] | 'P].
exact: ntransitive1 F9.
have F11: [primitive Gx, on [set~ x] | 'P].
exact: ntransitive_primitive F9.
have F12: K \subset Gx by apply: setSI; exact: normal_sub.
have F13: K <| Gx by rewrite /(K <| _) F12 normsIG // normal_norm.
case: (prim_trans_norm F11 F13) => Ksub; last first.
apply: dvdn_trans (cardSg F8); rewrite -F7; exact: atrans_dvd Ksub.
have F14: [faithful Gx, on [set~ x] | 'P].
apply/subsetP=> g; do 2![case/setIP] => Altg cgx cgx'.
apply: (subsetP (aperm_faithful 'Alt_T)).
rewrite inE Altg /=; apply/astabP=> z _.
case: (z =P x) => [->|]; first exact: (astab1P cgx).
by move/eqP=> nxz; rewrite (astabP cgx') ?inE //.
have Hreg g (z : T): g \in H -> g z = z -> g = 1.
have F15 h: h \in H -> h x = x -> h = 1.
move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
by rewrite (trivGP (subset_trans Ksub F14)) => /set1P.
move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
by case/normalP: Hh1 => _ nH1; rewrite -(nH1 _ Hg1) memJ_conjg.
clear K F8 F12 F13 Ksub F14.
case: (Cauchy _ F6) => // h Hh /eqP Horder.
have diff_hnx_x n: 0 < n -> n < 5 -> x != (h ^+ n) x.
move=> Hn1 Hn2; rewrite eq_sym; apply/negP => HH.
have: #[h ^+ n] = 5.
rewrite orderXgcd // (eqP Horder).
by move: Hn1 Hn2 {HH}; do 5 (case: n => [|n] //).
have Hhd2: h ^+ n \in H by rewrite groupX.
by rewrite (Hreg _ _ Hhd2 (eqP HH)) order1.
pose S1 := [tuple x; h x; (h ^+ 3) x].
have DnS1: S1 \in 3.-dtuple(setT).
rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
by rewrite (inj_eq (@perm_inj _ _)) diff_hnx_x.
pose S2 := [tuple x; h x; (h ^+ 2) x].
have DnS2: S2 \in 3.-dtuple(setT).
rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
by rewrite (inj_eq (@perm_inj _ _)) diff_hnx_x.
case: (atransP2 F2 DnS1 DnS2) => g Hg [/=].
rewrite /aperm => Hgx Hghx Hgh3x.
have h_g_com: h * g = g * h.
suff HH: (g * h * g^-1) * h^-1 = 1 by rewrite -[h * g]mul1g -HH !gnorm.
apply: (Hreg _ x); last first.
by rewrite !permM -Hgx Hghx -!permM mulKVg mulgV perm1.
rewrite groupM // ?groupV // (conjgCV g) mulgK -mem_conjg.
by case/normalP: Hh1 => _ ->.
have: (g * (h ^+ 2) * g ^-1) x = (h ^+ 3) x.
rewrite !permM -Hgx.
have ->: h (h x) = (h ^+ 2) x by rewrite /= permM.
by rewrite {1}Hgh3x -!permM /= mulgV mulg1 -expgSr.
rewrite commuteX // mulgK {1}[expgn]lock expgS permM -lock.
by move/perm_inj=> eqxhx; case/eqP: (diff_hnx_x 1%N isT isT); rewrite expg1.
by rewrite (@Gauss_dvd 4 5) // F7.
apply/simpleP; split => [|H Hnorm]; first by rewrite trivg_card1 F1.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
by left; apply: card1_trivg; rewrite Hcard1.
right; case Hcard60: (#|H| == 60%N); move/eqP: Hcard60 => Hcard60.
by apply/eqP; rewrite eqEcard Hcard60 F1 andbT; case/andP: Hnorm.
have Hcard20: #|H| = 20; last clear Hcard1 Hcard60.
have Hdiv: 20 %| #|H| by apply: FF => // HH; case Hcard1; rewrite HH cards1.
case H20: (#|H| == 20); first by apply/eqP.
case: Hcard60; case/andP: Hnorm; move/cardSg; rewrite F1 => Hdiv1 _.
by case/dvdnP: Hdiv H20 Hdiv1 => n ->; move: n; do 4!case=> //.
have prime_5: prime 5 by [].
have nSyl5: #|'Syl_5(H)| = 1%N.
move: (card_Syl_dvd 5 H) (card_Syl_mod H prime_5).
rewrite Hcard20; case: (card _) => // n Hdiv.
move: (dvdn_leq (isT: (0 < 20)%N) Hdiv).
by move: (n) Hdiv; do 20 (case => //).
case: (Sylow_exists 5 H) => S; case/pHallP=> sSH oS.
have{oS} oS: #|S| = 5 by rewrite oS p_part Hcard20.
suff: 20 %| #|S| by rewrite oS.
apply FF => [|S1]; last by rewrite S1 cards1 in oS.
apply: char_normal_trans Hnorm; apply: lone_subgroup_char => // Q sQH isoQS.
rewrite subEproper; apply/norP=> [[nQS _]]; move: nSyl5.
rewrite (cardsD1 S) (cardsD1 Q) 4!{1}inE nQS !pHallE sQH sSH Hcard20 p_part.
by rewrite (card_isog isoQS) oS.
Qed.
Section Restrict.
Variables (T : finType) (x : T).
Notation T' := {y | y != x}.
Lemma rfd_funP (p : {perm T}) (u : T') :
let p1 := if p x == x then p else 1 in p1 (val u) != x.
Proof.
case: (p x =P x) => /= [pxx|_]; last by rewrite perm1 (valP u).
by rewrite -{2}pxx (inj_eq (@perm_inj _ p)); exact: (valP u).
Qed.
Definition rfd_fun p := [fun u => Sub ((_ : {perm T}) _) (rfd_funP p u) : T'].
Lemma rfdP p : injective (rfd_fun p).
Proof.
apply: can_inj (rfd_fun p^-1) _ => u; apply: val_inj => /=.
rewrite -(inj_eq (@perm_inj _ p)) permKV eq_sym.
by case: eqP => _; rewrite !(perm1, permK).
Qed.
Definition rfd p := perm (@rfdP p).
Hypothesis card_T : 2 < #|T|.
Lemma rfd_morph : {in 'C_('Sym_T)[x | 'P] &, {morph rfd : y z / y * z}}.
Proof.
move=> p q; rewrite !setIA !setIid; move/astab1P=> p_x; move/astab1P=> q_x.
apply/permP=> u; apply: val_inj.
by rewrite permE /= !permM !permE /= [p x]p_x [q x]q_x eqxx permM /=.
Qed.
Canonical rfd_morphism := Morphism rfd_morph.
Definition rgd_fun (p : {perm T'}) :=
[fun x1 => if insub x1 is Some u then sval (p u) else x].
Lemma rgdP p : injective (rgd_fun p).
Proof.
apply: can_inj (rgd_fun p^-1) _ => y /=.
case: (insubP _ y) => [u _ val_u|]; first by rewrite valK permK.
by rewrite negbK; move/eqP->; rewrite insubF //= eqxx.
Qed.
Definition rgd p := perm (@rgdP p).
Lemma rfd_odd (p : {perm T}) : p x = x -> rfd p = p :> bool.
Proof.
have rfd1: rfd 1 = 1.
by apply/permP => u; apply: val_inj; rewrite permE /= if_same !perm1.
have HP0 (t : {perm T}): #|[set x | t x != x]| = 0 -> rfd t = t :> bool.
- move=> Ht; suff ->: t = 1 by rewrite rfd1 !odd_perm1.
apply/permP => z; rewrite perm1; apply/eqP/wlog_neg => nonfix_z.
by rewrite (cardD1 z) inE nonfix_z in Ht.
elim: #|_| {-2}p (leqnn #|[set x | p x != x]|) => {p}[|n Hrec] p Hp Hpx.
by apply: HP0; move: Hp; case: card.
case Ex: (pred0b (mem [set x | p x != x])); first by apply: HP0; move/eqnP: Ex.
case/pred0Pn: Ex => x1; rewrite /= inE => Hx1.
have nx1x: x1 != x by apply/eqP => HH; rewrite HH Hpx eqxx in Hx1.
have npxx1: p x != x1 by apply/eqP => HH; rewrite -HH !Hpx eqxx in Hx1.
have npx1x: p x1 != x.
by apply/eqP; rewrite -Hpx; move/perm_inj => HH; case/eqP: nx1x.
pose p1 := p * tperm x1 (p x1).
have Hp1: p1 x = x.
by rewrite /p1 permM; case tpermP => // [<-|]; [rewrite Hpx | move/perm_inj].
have Hcp1: #|[set x | p1 x != x]| <= n.
have F1 y: p y = y -> p1 y = y.
move=> Hy; rewrite /p1 permM Hy.
case tpermP => //; first by move => <-.
by move=> Hpx1; apply: (@perm_inj _ p); rewrite -Hpx1.
have F2: p1 x1 = x1 by rewrite /p1 permM tpermR.
have F3: [set x | p1 x != x] \subset [predD1 [set x | p x != x] & x1].
apply/subsetP => z; rewrite !inE permM.
case tpermP => HH1 HH2.
- rewrite eq_sym HH1 andbb; apply/eqP=> dx1.
by rewrite dx1 HH1 dx1 eqxx in HH2.
- by rewrite (perm_inj HH1) eqxx in HH2.
by move->; rewrite andbT; apply/eqP => HH3; rewrite HH3 in HH2.
apply: (leq_trans (subset_leq_card F3)).
by move: Hp; rewrite (cardD1 x1) inE Hx1.
have ->: p = p1 * tperm x1 (p x1) by rewrite -mulgA tperm2 mulg1.
rewrite odd_permM odd_tperm eq_sym Hx1 morphM; last 2 first.
- by rewrite 2!inE; exact/astab1P.
- by rewrite 2!inE; apply/astab1P; rewrite -{1}Hpx /= /aperm -permM.
rewrite odd_permM Hrec //=; congr (_ (+) _).
pose x2 : T' := Sub x1 nx1x; pose px2 : T' := Sub (p x1) npx1x.
suff ->: rfd (tperm x1 (p x1)) = tperm x2 px2.
by rewrite odd_tperm -val_eqE eq_sym.
apply/permP => z; apply/val_eqP; rewrite permE /= tpermD // eqxx.
case: (tpermP x2) => [->|->|HH1 HH2]; rewrite /x2 ?tpermL ?tpermR 1?tpermD //.
by apply/eqP=> HH3; case: HH1; apply: val_inj.
by apply/eqP => HH3; case: HH2; apply: val_inj.
Qed.
Lemma rfd_iso : 'C_('Alt_T)[x | 'P] \isog 'Alt_T'.
Proof.
have rgd_x p: rgd p x = x by rewrite permE /= insubF //= eqxx.
have rfd_rgd p: rfd (rgd p) = p.
apply/permP => [[z Hz]]; apply/val_eqP; rewrite !permE.
rewrite /= [rgd _ _]permE /= insubF eq_refl // permE /=.
by rewrite (@insubT _ (xpredC1 x) _ _ Hz).
have sSd: 'C_('Alt_T)[x | 'P] \subset 'dom rfd.
by apply/subsetP=> p; rewrite !inE /=; case/andP.
apply/isogP; exists [morphism of restrm sSd rfd] => /=; last first.
rewrite morphim_restrm setIid; apply/setP=> z; apply/morphimP/idP=> [[p _]|].
case/setIP; rewrite Alt_even => Hp; move/astab1P=> Hp1 ->.
by rewrite Alt_even rfd_odd.
have dz': rgd z x == x by rewrite rgd_x.
move=> kz; exists (rgd z); last by rewrite /= rfd_rgd.
by rewrite 2!inE (sameP astab1P eqP).
rewrite 4!inE /= (sameP astab1P eqP) dz' -rfd_odd; last exact/eqP.
by rewrite rfd_rgd mker // ?set11.
apply/injmP=> x1 y1 /=.
case/setIP=> Hax1; move/astab1P; rewrite /= /aperm => Hx1.
case/setIP=> Hay1; move/astab1P; rewrite /= /aperm => Hy1 Hr.
apply/permP => z.
case (z =P x) => [->|]; [by rewrite Hx1 | move/eqP => nzx].
move: (congr1 (fun q : {perm T'} => q (Sub z nzx)) Hr).
by rewrite !permE => [[]]; rewrite Hx1 Hy1 !eqxx.
Qed.
End Restrict.
Lemma simple_Alt5 (T : finType) : #|T| >= 5 -> simple 'Alt_T.
Proof.
suff F1 n: #|T| = n + 5 -> simple 'Alt_T by move/subnK/esym/F1.
elim: n T => [| n Hrec T Hde]; first exact: simple_Alt5_base.
have oT: 5 < #|T| by rewrite Hde addnC.
apply/simpleP; split=> [|H Hnorm]; last have [Hh1 nH] := andP Hnorm.
rewrite trivg_card1 -[#|_|]half_double -mul2n card_Alt Hde addnC //.
by rewrite addSn factS mulnC -(prednK (fact_gt0 _)).
case E1: (pred0b T); first by rewrite /pred0b in E1; rewrite (eqP E1) in oT.
case/pred0Pn: E1 => x _; have Hx := in_setT x.
have F2: [transitive^4 'Alt_T, on setT | 'P].
by apply: ntransitive_weak (Alt_trans T); rewrite -(subnKC oT).
have F3 := ntransitive1 (isT: 0 < 4) F2.
have F4 := ntransitive_primitive (isT: 1 < 4) F2.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
by left; apply: card1_trivg; rewrite Hcard1.
right; case: (prim_trans_norm F4 Hnorm) => F5.
by rewrite (trivGP (subset_trans F5 (aperm_faithful _))) cards1 in Hcard1.
case E1: (pred0b (predD1 T x)).
rewrite /pred0b in E1; move: oT.
by rewrite (cardD1 x) (eqP E1); case: (T x).
case/pred0Pn: E1 => y Hdy; case/andP: (Hdy) => diff_x_y Hy.
pose K := 'C_H[x | 'P]%G.
have F8: K \subset H by apply: subsetIl.
pose Gx := 'C_('Alt_T)[x | 'P].
have F9: [transitive^3 Gx, on [set~ x] | 'P].
by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
have F10: [transitive Gx, on [set~ x] | 'P].
by apply: ntransitive1 F9.
have F11: [primitive Gx, on [set~ x] | 'P].
by apply: ntransitive_primitive F9.
have F12: K \subset Gx by rewrite setSI // normal_sub.
have F13: K <| Gx by apply/andP; rewrite normsIG.
have:= prim_trans_norm F11; case/(_ K) => //= => Ksub; last first.
have F14: Gx * H = 'Alt_T by exact/(subgroup_transitiveP _ _ F3).
have: simple Gx.
by rewrite (isog_simple (rfd_iso x)) Hrec //= card_sig cardC1 Hde.
case/simpleP=> _ simGx; case/simGx: F13 => /= HH2.
case Ez: (pred0b (predD1 (predD1 T x) y)).
move: oT; rewrite /pred0b in Ez.
by rewrite (cardD1 x) (cardD1 y) (eqP Ez) inE /= inE /= diff_x_y.
case/pred0Pn: Ez => z; case/andP => diff_y_z Hdz.
have [diff_x_z Hz] := andP Hdz.
have: z \in [set~ x] by rewrite !inE.
rewrite -(atransP Ksub y) ?inE //; case/imsetP => g.
rewrite /= HH2 inE; move/eqP=> -> HH4.
by case/negP: diff_y_z; rewrite HH4 act1.
by rewrite /= -F14 -[Gx]HH2 (mulSGid F8).
have F14: [faithful Gx, on [set~ x] | 'P].
apply: subset_trans (aperm_faithful 'Sym_T); rewrite subsetI subsetT.
apply/subsetP=> g; do 2![case/setIP]=> _ cgx cgx'; apply/astabP=> z _ /=.
case: (z =P x) => [->|]; first exact: (astab1P cgx).
by move/eqP=> zx; rewrite [_ g](astabP cgx') ?inE.
have Hreg g z: g \in H -> g z = z -> g = 1.
have F15 h: h \in H -> h x = x -> h = 1.
move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
by rewrite [K](trivGP (subset_trans Ksub F14)) => /set1P.
move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
by rewrite memJ_norm ?(subsetP nH).
clear K F8 F12 F13 Ksub F14.
have Hcard: 5 < #|H|.
apply: (leq_trans oT); apply dvdn_leq; first by exact: cardG_gt0.
by rewrite -cardsT (atrans_dvd F5).
case Eh: (pred0b [predD1 H & 1]).
by move: Hcard; rewrite /pred0b in Eh; rewrite (cardD1 1) group1 (eqP Eh).
case/pred0Pn: Eh => h; case/andP => diff_1_h /= Hh.
case Eg: (pred0b (predD1 (predD1 [predD1 H & 1] h) h^-1)).
move: Hcard; rewrite ltnNge; case/negP.
rewrite (cardD1 1) group1 (cardD1 h) (cardD1 h^-1) (eqnP Eg).
by do 2!case: (_ \in _).
case/pred0Pn: Eg => g; case/andP => diff_h1_g; case/andP => diff_h_g.
case/andP => diff_1_g /= Hg.
case diff_hx_x: (h x == x).
by case/negP: diff_1_h; apply/eqP; apply: (Hreg _ _ Hh (eqP diff_hx_x)).
case diff_gx_x: (g x == x).
case/negP: diff_1_g; apply/eqP; apply: (Hreg _ _ Hg (eqP diff_gx_x)).
case diff_gx_hx: (g x == h x).
case/negP: diff_h_g; apply/eqP; symmetry; apply: (mulIg g^-1); rewrite gsimp.
apply: (Hreg _ x); first by rewrite groupM // groupV.
by rewrite permM -(eqP diff_gx_hx) -permM mulgV perm1.
case diff_hgx_x: ((h * g) x == x).
case/negP: diff_h1_g; apply/eqP; apply: (mulgI h); rewrite !gsimp.
by apply: (Hreg _ x); [exact: groupM | apply/eqP].
case diff_hgx_hx: ((h * g) x == h x).
case/negP: diff_1_g; apply/eqP.
by apply: (Hreg _ (h x)) => //; apply/eqP; rewrite -permM.
case diff_hgx_gx: ((h * g) x == g x).
case/eqP: diff_hx_x; apply: (@perm_inj _ g) => //.
by apply/eqP; rewrite -permM.
case Ez: (pred0b
(predD1 (predD1 (predD1 (predD1 T x) (h x)) (g x)) ((h * g) x))).
- move: oT; rewrite /pred0b in Ez.
rewrite (cardD1 x) (cardD1 (h x)) (cardD1 (g x)) (cardD1 ((h * g) x)).
by rewrite (eqP Ez); do 3!case: (_ x \in _).
case/pred0Pn: Ez => z.
case/and5P=> diff_hgx_z diff_gx_z diff_hx_z diff_x_z /= Hz.
pose S1 := [tuple x; h x; g x; z].
have DnS1: S1 \in 4.-dtuple(setT).
rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT.
rewrite -!(eq_sym z) diff_gx_z diff_x_z diff_hx_z.
by rewrite !(eq_sym x) diff_hx_x diff_gx_x eq_sym diff_gx_hx.
pose S2 := [tuple x; h x; g x; (h * g) x].
have DnS2: S2 \in 4.-dtuple(setT).
rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT !(eq_sym x).
rewrite diff_hx_x diff_gx_x diff_hgx_x.
by rewrite !(eq_sym (h x)) diff_gx_hx diff_hgx_hx eq_sym diff_hgx_gx.
case: (atransP2 F2 DnS1 DnS2) => k Hk [/=].
rewrite /aperm => Hkx Hkhx Hkgx Hkhgx.
have h_k_com: h * k = k * h.
suff HH: (k * h * k^-1) * h^-1 = 1 by rewrite -[h * k]mul1g -HH !gnorm.
apply: (Hreg _ x); last first.
by rewrite !permM -Hkx Hkhx -!permM mulKVg mulgV perm1.
by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have g_k_com: g * k = k * g.
suff HH: (k * g * k^-1) * g^-1 = 1 by rewrite -[g * k]mul1g -HH !gnorm.
apply: (Hreg _ x); last first.
by rewrite !permM -Hkx Hkgx -!permM mulKVg mulgV perm1.
by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have HH: (k * (h * g) * k ^-1) x = z.
by rewrite 2!permM -Hkx Hkhgx -permM mulgV perm1.
case/negP: diff_hgx_z.
rewrite -HH !mulgA -h_k_com -!mulgA [k * _]mulgA.
by rewrite -g_k_com -!mulgA mulgV mulg1.
Qed.
mathcomp-1.5/theories/maximal.v 0000644 0001750 0001750 00000223760 12307636117 015634 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice div fintype.
Require Import finfun bigop finset prime binomial fingroup morphism perm.
Require Import automorphism quotient action commutator gproduct gfunctor.
Require Import ssralg finalg zmodp cyclic pgroup center gseries.
Require Import nilpotent sylow abelian finmodule.
(******************************************************************************)
(* This file establishes basic properties of several important classes of *)
(* maximal subgroups: maximal, max and min normal, simple, characteristically *)
(* simple subgroups, the Frattini and Fitting subgroups, the Thompson *)
(* critical subgroup, special and extra-special groups, and self-centralising *)
(* normal (SCN) subgroups. In detail, we define: *)
(* charsimple G == G is characteristically simple (it has no nontrivial *)
(* characteristic subgroups, and is nontrivial) *)
(* 'Phi(G) == the Frattini subgroup of G, i.e., the intersection of *)
(* all its maximal proper subgroups. *)
(* 'F(G) == the Fitting subgroup of G, i.e., the largest normal *)
(* nilpotent subgroup of G (defined as the (direct) *)
(* product of all the p-cores of G). *)
(* critical C G == C is a critical subgroup of G: C is characteristic *)
(* (but not functorial) in G, the center of C contains *)
(* both its Frattini subgroup and the commutator [G, C], *)
(* and is equal to the centraliser of C in G. The *)
(* Thompson_critical theorem provides critical subgroups *)
(* for p-groups; we also show that in this case the *)
(* centraliser of C in Aut G is a p-group as well. *)
(* special G == G is a special group: its center, Frattini, and *)
(* derived sugroups coincide (we follow Aschbacher in *)
(* not considering nontrivial elementary abelian groups *)
(* as special); we show that a p-group factors under *)
(* coprime action into special groups (Aschbacher 24.7). *)
(* extraspecial G == G is a special group whose center has prime order *)
(* (hence G is non-abelian). *)
(* 'SCN(G) == the set of self-centralising normal abelian subgroups *)
(* of G (the A <| G such that 'C_G(A) = A). *)
(* 'SCN_n(G) == the subset of 'SCN(G) containing all groups with rank *)
(* at least n (i.e., A \in 'SCN(G) and 'm(A) >= n). *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GroupScope.
Section Defs.
Variable gT : finGroupType.
Implicit Types (A B D : {set gT}) (G : {group gT}).
Definition charsimple A := [min A of G | G :!=: 1 & G \char A].
Definition Frattini A := \bigcap_(G : {group gT} | maximal_eq G A) G.
Canonical Frattini_group A : {group gT} := Eval hnf in [group of Frattini A].
Definition Fitting A := \big[dprod/1]_(p <- primes #|A|) 'O_p(A).
Lemma Fitting_group_set G : group_set (Fitting G).
Proof.
suffices [F ->]: exists F : {group gT}, Fitting G = F by exact: groupP.
rewrite /Fitting; elim: primes (primes_uniq #|G|) => [_|p r IHr] /=.
by exists [1 gT]%G; rewrite big_nil.
case/andP=> rp /IHr[F defF]; rewrite big_cons defF.
suffices{IHr} /and3P[p'F sFG nFG]: p^'.-group F && (F <| G).
have nFGp: 'O_p(G) \subset 'N(F) := subset_trans (pcore_sub p G) nFG.
have pGp: p.-group('O_p(G)) := pcore_pgroup p G.
have{pGp} tiGpF: 'O_p(G) :&: F = 1 by rewrite coprime_TIg ?(pnat_coprime pGp).
exists ('O_p(G) <*> F)%G; rewrite dprodEY // (sameP commG1P trivgP) -tiGpF.
by rewrite subsetI commg_subl commg_subr (subset_trans sFG) // gFnorm.
move/bigdprodWY: defF => <- {F}; elim: r rp => [_|q r IHr] /=.
by rewrite big_nil gen0 pgroup1 normal1.
rewrite inE eq_sym big_cons -joingE -joing_idr => /norP[qp /IHr {IHr}].
set F := <<_>> => /andP[p'F nsFG]; rewrite norm_joinEl /= -/F; last first.
exact: subset_trans (pcore_sub q G) (normal_norm nsFG).
by rewrite pgroupM p'F normalM ?pcore_normal //= (pi_pgroup (pcore_pgroup q G)).
Qed.
Canonical Fitting_group G := group (Fitting_group_set G).
Definition critical A B :=
[/\ A \char B,
Frattini A \subset 'Z(A),
[~: B, A] \subset 'Z(A)
& 'C_B(A) = 'Z(A)].
Definition special A := Frattini A = 'Z(A) /\ A^`(1) = 'Z(A).
Definition extraspecial A := special A /\ prime #|'Z(A)|.
Definition SCN B := [set A : {group gT} | A <| B & 'C_B(A) == A].
Definition SCN_at n B := [set A in SCN B | n <= 'r(A)].
End Defs.
Arguments Scope charsimple [_ group_scope].
Arguments Scope Frattini [_ group_scope].
Arguments Scope Fitting [_ group_scope].
Arguments Scope critical [_ group_scope group_scope].
Arguments Scope special [_ group_scope].
Arguments Scope extraspecial [_ group_scope].
Arguments Scope SCN [_ group_scope].
Arguments Scope SCN_at [_ nat_scope group_scope].
Prenex Implicits maximal simple charsimple critical special extraspecial.
Notation "''Phi' ( A )" := (Frattini A)
(at level 8, format "''Phi' ( A )") : group_scope.
Notation "''Phi' ( G )" := (Frattini_group G) : Group_scope.
Notation "''F' ( G )" := (Fitting G)
(at level 8, format "''F' ( G )") : group_scope.
Notation "''F' ( G )" := (Fitting_group G) : Group_scope.
Notation "''SCN' ( B )" := (SCN B)
(at level 8, format "''SCN' ( B )") : group_scope.
Notation "''SCN_' n ( B )" := (SCN_at n B)
(at level 8, n at level 2, format "''SCN_' n ( B )") : group_scope.
Section PMax.
Variables (gT : finGroupType) (p : nat) (P M : {group gT}).
Hypothesis pP : p.-group P.
Lemma p_maximal_normal : maximal M P -> M <| P.
Proof.
case/maxgroupP=> /andP[sMP sPM] maxM; rewrite /normal sMP.
have:= subsetIl P 'N(M); rewrite subEproper.
case/predU1P=> [/setIidPl-> // | /maxM/= SNM]; case/negP: sPM.
rewrite (nilpotent_sub_norm (pgroup_nil pP) sMP) //.
by rewrite SNM // subsetI sMP normG.
Qed.
Lemma p_maximal_index : maximal M P -> #|P : M| = p.
Proof.
move=> maxM; have nM := p_maximal_normal maxM.
rewrite -card_quotient ?normal_norm //.
rewrite -(quotient_maximal _ nM) ?normal_refl // trivg_quotient in maxM.
case/maxgroupP: maxM; rewrite properEneq eq_sym sub1G andbT /=.
case/(pgroup_pdiv (quotient_pgroup M pP)) => p_pr /Cauchy[] // xq.
rewrite /order -cycle_subG subEproper => /predU1P[-> // | sxPq oxq_p _].
by move/(_ _ sxPq (sub1G _)) => xq1; rewrite -oxq_p xq1 cards1 in p_pr.
Qed.
Lemma p_index_maximal : M \subset P -> prime #|P : M| -> maximal M P.
Proof.
move=> sMP /primeP[lt1PM pr_PM].
apply/maxgroupP; rewrite properEcard sMP -(Lagrange sMP).
rewrite -{1}(muln1 #|M|) ltn_pmul2l //; split=> // H sHP sMH.
apply/eqP; rewrite eq_sym eqEcard sMH.
case/orP: (pr_PM _ (indexSg sMH (proper_sub sHP))) => /eqP iM.
by rewrite -(Lagrange sMH) iM muln1 /=.
by have:= proper_card sHP; rewrite -(Lagrange sMH) iM Lagrange ?ltnn.
Qed.
End PMax.
Section Frattini.
Variables gT : finGroupType.
Implicit Type G M : {group gT}.
Lemma Phi_sub G : 'Phi(G) \subset G.
Proof. by rewrite bigcap_inf // /maximal_eq eqxx. Qed.
Lemma Phi_sub_max G M : maximal M G -> 'Phi(G) \subset M.
Proof. by move=> maxM; rewrite bigcap_inf // /maximal_eq predU1r. Qed.
Lemma Phi_proper G : G :!=: 1 -> 'Phi(G) \proper G.
Proof.
move/eqP; case/maximal_exists: (sub1G G) => [<- //| [M maxM _] _].
exact: sub_proper_trans (Phi_sub_max maxM) (maxgroupp maxM).
Qed.
Lemma Phi_nongen G X : 'Phi(G) <*> X = G -> <> = G.
Proof.
move=> defG; have: <> \subset G by rewrite -{1}defG genS ?subsetUr.
case/maximal_exists=> //= [[M maxM]]; rewrite gen_subG => sXM.
case/andP: (maxgroupp maxM) => _ /negP[].
by rewrite -defG gen_subG subUset Phi_sub_max.
Qed.
Lemma Frattini_continuous (rT : finGroupType) G (f : {morphism G >-> rT}) :
f @* 'Phi(G) \subset 'Phi(f @* G).
Proof.
apply/bigcapsP=> M maxM; rewrite sub_morphim_pre ?Phi_sub // bigcap_inf //.
have {2}<-: f @*^-1 (f @* G) = G by rewrite morphimGK ?subsetIl.
by rewrite morphpre_maximal_eq ?maxM //; case/maximal_eqP: maxM.
Qed.
End Frattini.
Canonical Frattini_igFun := [igFun by Phi_sub & Frattini_continuous].
Canonical Frattini_gFun := [gFun by Frattini_continuous].
Section Frattini0.
Variable gT : finGroupType.
Implicit Types (rT : finGroupType) (D G : {group gT}).
Lemma Phi_char G : 'Phi(G) \char G.
Proof. exact: gFchar. Qed.
Lemma Phi_normal G : 'Phi(G) <| G.
Proof. exact: gFnormal. Qed.
Lemma injm_Phi rT D G (f : {morphism D >-> rT}) :
'injm f -> G \subset D -> f @* 'Phi(G) = 'Phi(f @* G).
Proof. exact: injmF. Qed.
Lemma isog_Phi rT G (H : {group rT}) : G \isog H -> 'Phi(G) \isog 'Phi(H).
Proof. exact: gFisog. Qed.
Lemma PhiJ G x : 'Phi(G :^ x) = 'Phi(G) :^ x.
Proof.
rewrite -{1}(setIid G) -(setIidPr (Phi_sub G)) -!morphim_conj.
by rewrite injm_Phi ?injm_conj.
Qed.
End Frattini0.
Section Frattini2.
Variables gT : finGroupType.
Implicit Type G : {group gT}.
Lemma Phi_quotient_id G : 'Phi (G / 'Phi(G)) = 1.
Proof.
apply/trivgP; rewrite -cosetpreSK cosetpre1 /=; apply/bigcapsP=> M maxM.
have nPhi := Phi_normal G; have nPhiM: 'Phi(G) <| M.
by apply: normalS nPhi; [exact: bigcap_inf | case/maximal_eqP: maxM].
by rewrite sub_cosetpre_quo ?bigcap_inf // quotient_maximal_eq.
Qed.
Lemma Phi_quotient_cyclic G : cyclic (G / 'Phi(G)) -> cyclic G.
Proof.
case/cyclicP=> /= Px; case: (cosetP Px) => x nPx ->{Px} defG.
apply/cyclicP; exists x; symmetry; apply: Phi_nongen.
rewrite -joing_idr norm_joinEr -?quotientK ?cycle_subG //.
by rewrite /quotient morphim_cycle //= -defG quotientGK ?Phi_normal.
Qed.
Variables (p : nat) (P : {group gT}).
Lemma trivg_Phi : p.-group P -> ('Phi(P) == 1) = p.-abelem P.
Proof.
move=> pP; case: (eqsVneq P 1) => [P1 | ntP].
by rewrite P1 abelem1 -subG1 -P1 Phi_sub.
have [p_pr _ _] := pgroup_pdiv pP ntP.
apply/eqP/idP=> [trPhi | abP].
apply/abelemP=> //; split=> [|x Px].
apply/commG1P/trivgP; rewrite -trPhi.
apply/bigcapsP=> M /predU1P[-> | maxM]; first exact: der1_subG.
have /andP[_ nMP]: M <| P := p_maximal_normal pP maxM.
rewrite der1_min // cyclic_abelian // prime_cyclic // card_quotient //.
by rewrite (p_maximal_index pP).
apply/set1gP; rewrite -trPhi; apply/bigcapP=> M.
case/predU1P=> [-> | maxM]; first exact: groupX.
have /andP[_ nMP] := p_maximal_normal pP maxM.
have nMx : x \in 'N(M) by exact: subsetP Px.
apply: coset_idr; rewrite ?groupX ?morphX //=; apply/eqP.
rewrite -(p_maximal_index pP maxM) -card_quotient // -order_dvdn cardSg //=.
by rewrite cycle_subG mem_quotient.
apply/trivgP/subsetP=> x Phi_x; rewrite -cycle_subG.
have Px: x \in P by exact: (subsetP (Phi_sub P)).
have sxP: <[x]> \subset P by rewrite cycle_subG.
case/splitsP: (abelem_splits abP sxP) => K /complP[tiKx defP].
have [-> | nt_x] := eqVneq x 1; first by rewrite cycle1.
have oxp := abelem_order_p abP Px nt_x.
rewrite /= -tiKx subsetI subxx cycle_subG.
apply: (bigcapP Phi_x); apply/orP; right.
apply: p_index_maximal; rewrite -?divgS -defP ?mulG_subr //.
by rewrite (TI_cardMg tiKx) mulnK // [#|_|]oxp.
Qed.
End Frattini2.
Section Frattini3.
Variables (gT : finGroupType) (p : nat) (P : {group gT}).
Hypothesis pP : p.-group P.
Lemma Phi_quotient_abelem : p.-abelem (P / 'Phi(P)).
Proof. by rewrite -trivg_Phi ?morphim_pgroup //= Phi_quotient_id. Qed.
Lemma Phi_joing : 'Phi(P) = P^`(1) <*> 'Mho^1(P).
Proof.
have [sPhiP nPhiP] := andP (Phi_normal P).
apply/eqP; rewrite eqEsubset join_subG.
case: (eqsVneq P 1) => [-> | ntP] in sPhiP *.
by rewrite /= (trivgP sPhiP) sub1G der_subS Mho_sub.
have [p_pr _ _] := pgroup_pdiv pP ntP.
have [abP x1P] := abelemP p_pr Phi_quotient_abelem.
apply/andP; split.
have nMP: P \subset 'N(P^`(1) <*> 'Mho^1(P)) by rewrite normsY // !gFnorm.
rewrite -quotient_sub1 ?(subset_trans sPhiP) //=.
suffices <-: 'Phi(P / (P^`(1) <*> 'Mho^1(P))) = 1 by exact: morphimF.
apply/eqP; rewrite (trivg_Phi (morphim_pgroup _ pP)) /= -quotientE.
apply/abelemP=> //; rewrite [abelian _]quotient_cents2 ?joing_subl //.
split=> // _ /morphimP[x Nx Px ->] /=.
rewrite -morphX //= coset_id // (MhoE 1 pP) joing_idr expn1.
by rewrite mem_gen //; apply/setUP; right; exact: mem_imset.
rewrite -quotient_cents2 // [_ \subset 'C(_)]abP (MhoE 1 pP) gen_subG /=.
apply/subsetP=> _ /imsetP[x Px ->]; rewrite expn1.
have nPhi_x: x \in 'N('Phi(P)) by exact: (subsetP nPhiP).
by rewrite coset_idr ?groupX ?morphX ?x1P ?mem_morphim.
Qed.
Lemma Phi_Mho : abelian P -> 'Phi(P) = 'Mho^1(P).
Proof. by move=> cPP; rewrite Phi_joing (derG1P cPP) joing1G. Qed.
End Frattini3.
Section Frattini4.
Variables (p : nat) (gT : finGroupType).
Implicit Types (rT : finGroupType) (P G H K D : {group gT}).
Lemma PhiS G H : p.-group H -> G \subset H -> 'Phi(G) \subset 'Phi(H).
Proof.
move=> pH sGH; rewrite (Phi_joing pH) (Phi_joing (pgroupS sGH pH)).
by rewrite genS // setUSS ?dergS ?MhoS.
Qed.
Lemma morphim_Phi rT P D (f : {morphism D >-> rT}) :
p.-group P -> P \subset D -> f @* 'Phi(P) = 'Phi(f @* P).
Proof.
move=> pP sPD; rewrite !(@Phi_joing _ p) ?morphim_pgroup //.
rewrite morphim_gen ?(subset_trans _ sPD) ?subUset ?der_subS ?Mho_sub //.
by rewrite morphimU -joingE morphimR ?morphim_Mho.
Qed.
Lemma quotient_Phi P H :
p.-group P -> P \subset 'N(H) -> 'Phi(P) / H = 'Phi(P / H).
Proof. exact: morphim_Phi. Qed.
(* This is Aschbacher (23.2) *)
Lemma Phi_min G H :
p.-group G -> G \subset 'N(H) -> p.-abelem (G / H) -> 'Phi(G) \subset H.
Proof.
move=> pG nHG; rewrite -trivg_Phi ?quotient_pgroup // -subG1 /=.
by rewrite -(quotient_Phi pG) ?quotient_sub1 // (subset_trans (Phi_sub _)).
Qed.
Lemma Phi_cprod G H K :
p.-group G -> H \* K = G -> 'Phi(H) \* 'Phi(K) = 'Phi(G).
Proof.
move=> pG defG; have [_ /mulG_sub[sHG sKG] cHK] := cprodP defG.
rewrite cprodEY /=; last by rewrite (centSS (Phi_sub _) (Phi_sub _)).
rewrite !(Phi_joing (pgroupS _ pG)) //=.
have /cprodP[_ <- /cent_joinEr <-] := der_cprod 1 defG.
have /cprodP[_ <- /cent_joinEr <-] := Mho_cprod 1 defG.
by rewrite !joingA /= -!(joingA H^`(1)) (joingC K^`(1)).
Qed.
Lemma Phi_mulg H K :
p.-group H -> p.-group K -> K \subset 'C(H) ->
'Phi(H * K) = 'Phi(H) * 'Phi(K).
Proof.
move=> pH pK cHK; have defHK := cprodEY cHK.
have [|_ -> _] := cprodP (Phi_cprod _ defHK); rewrite /= cent_joinEr //.
by apply: pnat_dvd (dvdn_cardMg H K) _; rewrite pnat_mul; exact/andP.
Qed.
Lemma charsimpleP G :
reflect (G :!=: 1 /\ forall K, K :!=: 1 -> K \char G -> K :=: G)
(charsimple G).
Proof.
apply: (iffP mingroupP); rewrite char_refl andbT => [[ntG simG]].
by split=> // K ntK chK; apply: simG; rewrite ?ntK // char_sub.
split=> // K /andP[ntK chK] _; exact: simG.
Qed.
End Frattini4.
Section Fitting.
Variable gT : finGroupType.
Implicit Types (p : nat) (G H : {group gT}).
Lemma Fitting_normal G : 'F(G) <| G.
Proof.
rewrite -['F(G)](bigdprodWY (erefl 'F(G))).
elim/big_rec: _ => [|p H _ nsHG]; first by rewrite gen0 normal1.
by rewrite -[<<_>>]joing_idr normalY ?pcore_normal.
Qed.
Lemma Fitting_sub G : 'F(G) \subset G.
Proof. by rewrite normal_sub ?Fitting_normal. Qed.
Lemma Fitting_nil G : nilpotent 'F(G).
Proof.
apply: (bigdprod_nil (erefl 'F(G))) => p _.
exact: pgroup_nil (pcore_pgroup p G).
Qed.
Lemma Fitting_max G H : H <| G -> nilpotent H -> H \subset 'F(G).
Proof.
move=> nsHG nilH; rewrite -(Sylow_gen H) gen_subG.
apply/bigcupsP=> P /SylowP[p _ SylP].
case Gp: (p \in \pi(G)); last first.
rewrite card1_trivg ?sub1G // (card_Hall SylP).
rewrite part_p'nat // (pnat_dvd (cardSg (normal_sub nsHG))) //.
by rewrite /pnat cardG_gt0 all_predC has_pred1 Gp.
move/nilpotent_Hall_pcore: SylP => ->{P} //.
rewrite -(bigdprodWY (erefl 'F(G))) sub_gen //.
rewrite -(filter_pi_of (ltnSn _)) big_filter big_mkord.
have le_pG: p < #|G|.+1.
by rewrite ltnS dvdn_leq //; move: Gp; rewrite mem_primes => /and3P[].
apply: (bigcup_max (Ordinal le_pG)) => //=.
apply: pcore_max (pcore_pgroup _ _) _.
exact: char_normal_trans (pcore_char p H) nsHG.
Qed.
Lemma pcore_Fitting pi G : 'O_pi('F(G)) \subset 'O_pi(G).
Proof.
rewrite pcore_max ?pcore_pgroup //.
exact: char_normal_trans (pcore_char _ _) (Fitting_normal _).
Qed.
Lemma p_core_Fitting p G : 'O_p('F(G)) = 'O_p(G).
Proof.
apply/eqP; rewrite eqEsubset pcore_Fitting pcore_max ?pcore_pgroup //.
apply: normalS (normal_sub (Fitting_normal _)) (pcore_normal _ _).
exact: Fitting_max (pcore_normal _ _) (pgroup_nil (pcore_pgroup _ _)).
Qed.
Lemma nilpotent_Fitting G : nilpotent G -> 'F(G) = G.
Proof.
by move=> nilG; apply/eqP; rewrite eqEsubset Fitting_sub Fitting_max.
Qed.
Lemma Fitting_eq_pcore p G : 'O_p^'(G) = 1 -> 'F(G) = 'O_p(G).
Proof.
move=> p'G1; have /dprodP[_ /= <- _ _] := nilpotent_pcoreC p (Fitting_nil G).
by rewrite p_core_Fitting ['O_p^'(_)](trivgP _) ?mulg1 // -p'G1 pcore_Fitting.
Qed.
Lemma FittingEgen G :
'F(G) = <<\bigcup_(p < #|G|.+1 | (p : nat) \in \pi(G)) 'O_p(G)>>.
Proof.
apply/eqP; rewrite eqEsubset gen_subG /=.
rewrite -{1}(bigdprodWY (erefl 'F(G))) (big_nth 0) big_mkord genS.
by apply/bigcupsP=> p _; rewrite -p_core_Fitting pcore_sub.
apply/bigcupsP=> [[i /= lti]] _; set p := nth _ _ i.
have pi_p: p \in \pi(G) by rewrite mem_nth.
have p_dv_G: p %| #|G| by rewrite mem_primes in pi_p; case/and3P: pi_p.
have lepG: p < #|G|.+1 by rewrite ltnS dvdn_leq.
by rewrite (bigcup_max (Ordinal lepG)).
Qed.
End Fitting.
Section FittingFun.
Implicit Types gT rT : finGroupType.
Lemma morphim_Fitting : GFunctor.pcontinuous Fitting.
Proof.
move=> gT rT G D f; apply: Fitting_max.
by rewrite morphim_normal ?Fitting_normal.
by rewrite morphim_nil ?Fitting_nil.
Qed.
Lemma FittingS gT (G H : {group gT}) : H \subset G -> H :&: 'F(G) \subset 'F(H).
Proof.
move=> sHG; rewrite -{2}(setIidPl sHG).
do 2!rewrite -(morphim_idm (subsetIl H _)) morphimIdom; exact: morphim_Fitting.
Qed.
Lemma FittingJ gT (G : {group gT}) x : 'F(G :^ x) = 'F(G) :^ x.
Proof.
rewrite !FittingEgen -genJ /= cardJg; symmetry; congr <<_>>.
rewrite (big_morph (conjugate^~ x) (fun A B => conjUg A B x) (imset0 _)).
by apply: eq_bigr => p _; rewrite pcoreJ.
Qed.
End FittingFun.
Canonical Fitting_igFun := [igFun by Fitting_sub & morphim_Fitting].
Canonical Fitting_gFun := [gFun by morphim_Fitting].
Canonical Fitting_pgFun := [pgFun by morphim_Fitting].
Section IsoFitting.
Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}).
Lemma Fitting_char : 'F(G) \char G. Proof. exact: gFchar. Qed.
Lemma injm_Fitting : 'injm f -> G \subset D -> f @* 'F(G) = 'F(f @* G).
Proof. exact: injmF. Qed.
Lemma isog_Fitting (H : {group rT}) : G \isog H -> 'F(G) \isog 'F(H).
Proof. exact: gFisog. Qed.
End IsoFitting.
Section CharSimple.
Variable gT : finGroupType.
Implicit Types (rT : finGroupType) (G H K L : {group gT}) (p : nat).
Lemma minnormal_charsimple G H : minnormal H G -> charsimple H.
Proof.
case/mingroupP=> /andP[ntH nHG] minH.
apply/charsimpleP; split=> // K ntK chK.
by apply: minH; rewrite ?ntK (char_sub chK, char_norm_trans chK).
Qed.
Lemma maxnormal_charsimple G H L :
G <| L -> maxnormal H G L -> charsimple (G / H).
Proof.
case/andP=> sGL nGL /maxgroupP[/andP[/andP[sHG not_sGH] nHL] maxH].
have nHG: G \subset 'N(H) := subset_trans sGL nHL.
apply/charsimpleP; rewrite -subG1 quotient_sub1 //; split=> // HK ntHK chHK.
case/(inv_quotientN _): (char_normal chHK) => [|K defHK sHK]; first exact/andP.
case/andP; rewrite subEproper defHK => /predU1P[-> // | ltKG] nKG.
have nHK: H <| K by rewrite /normal sHK (subset_trans (proper_sub ltKG)).
case/negP: ntHK; rewrite defHK -subG1 quotient_sub1 ?normal_norm //.
rewrite (maxH K) // ltKG -(quotientGK nHK) -defHK norm_quotient_pre //.
by rewrite (char_norm_trans chHK) ?quotient_norms.
Qed.
Lemma abelem_split_dprod rT p (A B : {group rT}) :
p.-abelem A -> B \subset A -> exists C : {group rT}, B \x C = A.
Proof.
move=> abelA sBA; have [_ cAA _]:= and3P abelA.
case/splitsP: (abelem_splits abelA sBA) => C /complP[tiBC defA].
by exists C; rewrite dprodE // (centSS _ sBA cAA) // -defA mulG_subr.
Qed.
Lemma p_abelem_split1 rT p (A : {group rT}) x :
p.-abelem A -> x \in A ->
exists B : {group rT}, [/\ B \subset A, #|B| = #|A| %/ #[x] & <[x]> \x B = A].
Proof.
move=> abelA Ax; have sxA: <[x]> \subset A by rewrite cycle_subG.
have [B defA] := abelem_split_dprod abelA sxA.
have [_ defxB _ ti_xB] := dprodP defA.
have sBA: B \subset A by rewrite -defxB mulG_subr.
by exists B; split; rewrite // -defxB (TI_cardMg ti_xB) mulKn ?order_gt0.
Qed.
Lemma abelem_charsimple p G : p.-abelem G -> G :!=: 1 -> charsimple G.
Proof.
move=> abelG ntG; apply/charsimpleP; split=> // K ntK /charP[sKG chK].
case/eqVproper: sKG => // /properP[sKG [x Gx notKx]].
have ox := abelem_order_p abelG Gx (group1_contra notKx).
have [A [sAG oA defA]] := p_abelem_split1 abelG Gx.
case/trivgPn: ntK => y Ky nty; have Gy := subsetP sKG y Ky.
have{nty} oy := abelem_order_p abelG Gy nty.
have [B [sBG oB defB]] := p_abelem_split1 abelG Gy.
have: isog A B; last case/isogP=> fAB injAB defAB.
rewrite (isog_abelem_card _ (abelemS sAG abelG)) (abelemS sBG) //=.
by rewrite oA oB ox oy.
have: isog <[x]> <[y]>; last case/isogP=> fxy injxy /= defxy.
by rewrite isog_cyclic_card ?cycle_cyclic // [#|_|]oy -ox eqxx.
have cfxA: fAB @* A \subset 'C(fxy @* <[x]>).
by rewrite defAB defxy; case/dprodP: defB.
have injf: 'injm (dprodm defA cfxA).
by rewrite injm_dprodm injAB injxy defAB defxy; apply/eqP; case/dprodP: defB.
case/negP: notKx; rewrite -cycle_subG -(injmSK injf) ?cycle_subG //=.
rewrite morphim_dprodml // defxy cycle_subG /= chK //.
have [_ {4}<- _ _] := dprodP defB; have [_ {3}<- _ _] := dprodP defA.
by rewrite morphim_dprodm // defAB defxy.
Qed.
Lemma charsimple_dprod G : charsimple G ->
exists H : {group gT}, [/\ H \subset G, simple H
& exists2 I : {set {perm gT}}, I \subset Aut G
& \big[dprod/1]_(f in I) f @: H = G].
Proof.
case/charsimpleP=> ntG simG.
have [H minH sHG]: {H : {group gT} | minnormal H G & H \subset G}.
by apply: mingroup_exists; rewrite ntG normG.
case/mingroupP: minH => /andP[ntH nHG] minH.
pose Iok (I : {set {perm gT}}) :=
(I \subset Aut G) &&
[exists (M : {group gT} | M <| G), \big[dprod/1]_(f in I) f @: H == M].
have defH: (1 : {perm gT}) @: H = H.
apply/eqP; rewrite eqEcard card_imset ?leqnn; last exact: perm_inj.
by rewrite andbT; apply/subsetP=> _ /imsetP[x Hx ->]; rewrite perm1.
have [|I] := @maxset_exists _ Iok 1.
rewrite /Iok sub1G; apply/existsP; exists H.
by rewrite /normal sHG nHG (big_pred1 1) => [|f]; rewrite ?defH /= ?inE.
case/maxsetP=> /andP[Aut_I /exists_eq_inP[M /andP[sMG nMG] defM]] maxI.
rewrite sub1set=> ntI; case/eqVproper: sMG => [defG | /andP[sMG not_sGM]].
exists H; split=> //; last by exists I; rewrite ?defM.
apply/mingroupP; rewrite ntH normG; split=> // N /andP[ntN nNH] sNH.
apply: minH => //; rewrite ntN /= -defG.
move: defM; rewrite (bigD1 1) //= defH; case/dprodP=> [[_ K _ ->] <- cHK _].
by rewrite mul_subG // cents_norm // (subset_trans cHK) ?centS.
have defG: <<\bigcup_(f in Aut G) f @: H>> = G.
have sXG: \bigcup_(f in Aut G) f @: H \subset G.
by apply/bigcupsP=> f Af; rewrite -(im_autm Af) morphimEdom imsetS.
apply: simG.
apply: contra ntH; rewrite -!subG1; apply: subset_trans.
by rewrite sub_gen // (bigcup_max 1) ?group1 ?defH.
rewrite /characteristic gen_subG sXG; apply/forall_inP=> f Af.
rewrite -(autmE Af) -morphimEsub ?gen_subG ?morphim_gen // genS //.
rewrite morphimEsub //= autmE.
apply/subsetP=> _ /imsetP[_ /bigcupP[g Ag /imsetP[x Hx ->]] ->].
apply/bigcupP; exists (g * f); first exact: groupM.
by apply/imsetP; exists x; rewrite // permM.
have [f Af sfHM]: exists2 f, f \in Aut G & ~~ (f @: H \subset M).
move: not_sGM; rewrite -{1}defG gen_subG; case/subsetPn=> x.
by case/bigcupP=> f Af fHx Mx; exists f => //; apply/subsetPn; exists x.
case If: (f \in I).
by case/negP: sfHM; rewrite -(bigdprodWY defM) sub_gen // (bigcup_max f).
case/idP: (If); rewrite -(maxI ([set f] :|: I)) ?subsetUr ?inE ?eqxx //.
rewrite {maxI}/Iok subUset sub1set Af {}Aut_I; apply/existsP.
have sfHG: autm Af @* H \subset G by rewrite -{4}(im_autm Af) morphimS.
have{minH nHG} /mingroupP[/andP[ntfH nfHG] minfH]: minnormal (autm Af @* H) G.
apply/mingroupP; rewrite andbC -{1}(im_autm Af) morphim_norms //=.
rewrite -subG1 sub_morphim_pre // -kerE ker_autm subG1.
split=> // N /andP[ntN nNG] sNfH.
have sNG: N \subset G := subset_trans sNfH sfHG.
apply/eqP; rewrite eqEsubset sNfH sub_morphim_pre //=.
rewrite -(morphim_invmE (injm_autm Af)) [_ @* N]minH //=.
rewrite -subG1 sub_morphim_pre /= ?im_autm // morphpre_invm morphim1 subG1.
by rewrite ntN -{1}(im_invm (injm_autm Af)) /= {2}im_autm morphim_norms.
by rewrite sub_morphim_pre /= ?im_autm // morphpre_invm.
have{minfH sfHM} tifHM: autm Af @* H :&: M = 1.
apply/eqP/idPn=> ntMfH; case/setIidPl: sfHM.
rewrite -(autmE Af) -morphimEsub //.
by apply: minfH; rewrite ?subsetIl // ntMfH normsI.
have cfHM: M \subset 'C(autm Af @* H).
rewrite centsC (sameP commG1P trivgP) -tifHM subsetI commg_subl commg_subr.
by rewrite (subset_trans sMG) // (subset_trans sfHG).
exists (autm Af @* H <*> M)%G; rewrite /normal /= join_subG sMG sfHG normsY //=.
rewrite (bigD1 f) ?inE ?eqxx // (eq_bigl (mem I)) /= => [|g]; last first.
by rewrite /= !inE andbC; case: eqP => // ->.
by rewrite defM -(autmE Af) -morphimEsub // dprodE // cent_joinEr ?eqxx.
Qed.
Lemma simple_sol_prime G : solvable G -> simple G -> prime #|G|.
Proof.
move=> solG /simpleP[ntG simG].
have{solG} cGG: abelian G.
apply/commG1P; case/simG: (der_normal 1 G) => // /eqP/idPn[].
by rewrite proper_neq // (sol_der1_proper solG).
case: (trivgVpdiv G) ntG => [-> | [p p_pr]]; first by rewrite eqxx.
case/Cauchy=> // x Gx oxp _; move: p_pr; rewrite -oxp orderE.
have: <[x]> <| G by rewrite -sub_abelian_normal ?cycle_subG.
by case/simG=> -> //; rewrite cards1.
Qed.
Lemma charsimple_solvable G : charsimple G -> solvable G -> is_abelem G.
Proof.
case/charsimple_dprod=> H [sHG simH [I Aut_I defG]] solG.
have p_pr: prime #|H| by exact: simple_sol_prime (solvableS sHG solG) simH.
set p := #|H| in p_pr; apply/is_abelemP; exists p => //.
elim/big_rec: _ (G) defG => [_ <-|f B If IH_B M defM]; first exact: abelem1.
have [Af [[_ K _ defB] _ _ _]] := (subsetP Aut_I f If, dprodP defM).
rewrite (dprod_abelem p defM) defB IH_B // andbT -(autmE Af) -morphimEsub //=.
rewrite morphim_abelem ?abelemE // exponent_dvdn.
by rewrite cyclic_abelian ?prime_cyclic.
Qed.
Lemma minnormal_solvable L G H :
minnormal H L -> H \subset G -> solvable G ->
[/\ L \subset 'N(H), H :!=: 1 & is_abelem H].
Proof.
move=> minH sHG solG; have /andP[ntH nHL] := mingroupp minH.
split=> //; apply: (charsimple_solvable (minnormal_charsimple minH)).
exact: solvableS solG.
Qed.
Lemma solvable_norm_abelem L G :
solvable G -> G <| L -> G :!=: 1 ->
exists H : {group gT}, [/\ H \subset G, H <| L, H :!=: 1 & is_abelem H].
Proof.
move=> solG /andP[sGL nGL] ntG.
have [H minH sHG]: {H : {group gT} | minnormal H L & H \subset G}.
by apply: mingroup_exists; rewrite ntG.
have [nHL ntH abH] := minnormal_solvable minH sHG solG.
by exists H; split; rewrite // /normal (subset_trans sHG).
Qed.
Lemma trivg_Fitting G : solvable G -> ('F(G) == 1) = (G :==: 1).
Proof.
move=> solG; apply/idP/idP=> [F1|]; last first.
by rewrite -!subG1; apply: subset_trans; exact: Fitting_sub.
apply/idPn=> /(solvable_norm_abelem solG (normal_refl _))[M [_ nsMG ntM]].
case/is_abelemP=> p _ /and3P[pM _ _]; case/negP: ntM.
by rewrite -subG1 -(eqP F1) Fitting_max ?(pgroup_nil pM).
Qed.
Lemma Fitting_pcore pi G : 'F('O_pi(G)) = 'O_pi('F(G)).
Proof.
apply/eqP; rewrite eqEsubset.
rewrite (subset_trans _ (pcoreS _ (Fitting_sub _))); last first.
rewrite subsetI Fitting_sub Fitting_max ?Fitting_nil //.
by rewrite (char_normal_trans (Fitting_char _)) ?pcore_normal.
rewrite (subset_trans _ (FittingS (pcore_sub _ _))) // subsetI pcore_sub.
rewrite pcore_max ?pcore_pgroup //.
by rewrite (char_normal_trans (pcore_char _ _)) ?Fitting_normal.
Qed.
End CharSimple.
Section SolvablePrimeFactor.
Variables (gT : finGroupType) (G : {group gT}).
Lemma index_maxnormal_sol_prime (H : {group gT}) :
solvable G -> maxnormal H G G -> prime #|G : H|.
Proof.
move=> solG maxH; have nsHG := maxnormal_normal maxH.
rewrite -card_quotient ?normal_norm // simple_sol_prime ?quotient_sol //.
by rewrite quotient_simple.
Qed.
Lemma sol_prime_factor_exists :
solvable G -> G :!=: 1 -> {H : {group gT} | H <| G & prime #|G : H| }.
Proof.
move=> solG /ex_maxnormal_ntrivg[H maxH].
by exists H; [exact: maxnormal_normal | exact: index_maxnormal_sol_prime].
Qed.
End SolvablePrimeFactor.
Section Special.
Variables (gT : finGroupType) (p : nat) (A G : {group gT}).
(* This is Aschbacher (23.7) *)
Lemma center_special_abelem : p.-group G -> special G -> p.-abelem 'Z(G).
Proof.
move=> pG [defPhi defG'].
have [-> | ntG] := eqsVneq G 1; first by rewrite center1 abelem1.
have [p_pr _ _] := pgroup_pdiv pG ntG.
have fM: {in 'Z(G) &, {morph expgn^~ p : x y / x * y}}.
by move=> x y /setIP[_ /centP cxG] /setIP[/cxG cxy _]; exact: expgMn.
rewrite abelemE //= center_abelian; apply/exponentP=> /= z Zz.
apply: (@kerP _ _ _ (Morphism fM)) => //; apply: subsetP z Zz.
rewrite -{1}defG' gen_subG; apply/subsetP=> _ /imset2P[x y Gx Gy ->].
have Zxy: [~ x, y] \in 'Z(G) by rewrite -defG' mem_commg.
have Zxp: x ^+ p \in 'Z(G).
rewrite -defPhi (Phi_joing pG) (MhoE 1 pG) joing_idr mem_gen // !inE.
by rewrite expn1 orbC (mem_imset (expgn^~ p)).
rewrite mem_morphpre /= ?defG' ?Zxy // inE -commXg; last first.
by red; case/setIP: Zxy => _ /centP->.
by apply/commgP; red; case/setIP: Zxp => _ /centP->.
Qed.
Lemma exponent_special : p.-group G -> special G -> exponent G %| p ^ 2.
Proof.
move=> pG spG; have [defPhi _] := spG.
have /and3P[_ _ expZ] := center_special_abelem pG spG.
apply/exponentP=> x Gx; rewrite expgM (exponentP expZ) // -defPhi.
by rewrite (Phi_joing pG) mem_gen // inE orbC (Mho_p_elt 1) ?(mem_p_elt pG).
Qed.
(* Aschbacher 24.7 (replaces Gorenstein 5.3.7) *)
Theorem abelian_charsimple_special :
p.-group G -> coprime #|G| #|A| -> [~: G, A] = G ->
\bigcup_(H : {group gT} | (H \char G) && abelian H) H \subset 'C(A) ->
special G /\ 'C_G(A) = 'Z(G).
Proof.
move=> pG coGA defG /bigcupsP cChaA.
have cZA: 'Z(G) \subset 'C_G(A).
by rewrite subsetI center_sub cChaA // center_char center_abelian.
have cChaG (H : {group gT}): H \char G -> abelian H -> H \subset 'Z(G).
move=> chH abH; rewrite subsetI char_sub //= centsC -defG.
rewrite comm_norm_cent_cent ?(char_norm chH) -?commg_subl ?defG //.
by rewrite centsC cChaA ?chH.
have cZ2GG: [~: 'Z_2(G), G, G] = 1.
by apply/commG1P; rewrite (subset_trans (ucn_comm 1 G)) // ucn1 subsetIr.
have{cZ2GG} cG'Z: 'Z_2(G) \subset 'C(G^`(1)).
by rewrite centsC; apply/commG1P; rewrite three_subgroup // (commGC G).
have{cG'Z} sZ2G'_Z: 'Z_2(G) :&: G^`(1) \subset 'Z(G).
apply: cChaG; first by rewrite charI ?ucn_char ?der_char.
by rewrite /abelian subIset // (subset_trans cG'Z) // centS ?subsetIr.
have{sZ2G'_Z} sG'Z: G^`(1) \subset 'Z(G).
rewrite der1_min ?gFnorm //; apply/derG1P.
have /TI_center_nil: nilpotent (G / 'Z(G)) := quotient_nil _ (pgroup_nil pG).
apply; first exact: gFnormal; rewrite /= setIC -ucn1 -ucn_central.
rewrite -quotient_der ?gFnorm // -quotientGI ?ucn_subS ?quotientS1 //=.
by rewrite ucn1.
have sCG': 'C_G(A) \subset G^`(1).
rewrite -quotient_sub1 //; last by rewrite subIset // char_norm ?der_char.
rewrite (subset_trans (quotient_subcent _ G A)) //= -[G in G / _]defG.
have nGA: A \subset 'N(G) by rewrite -commg_subl defG.
rewrite quotientR ?(char_norm_trans (der_char _ _)) ?normG //.
rewrite coprime_abel_cent_TI ?quotient_norms ?coprime_morph //.
exact: sub_der1_abelian.
have defZ: 'Z(G) = G^`(1) by apply/eqP; rewrite eqEsubset (subset_trans cZA).
split; last by apply/eqP; rewrite eqEsubset cZA defZ sCG'.
split=> //; apply/eqP; rewrite eqEsubset defZ (Phi_joing pG) joing_subl.
have:= pG; rewrite -pnat_exponent => /p_natP[n expGpn].
rewrite join_subG subxx andbT /= -defZ -(subnn n.-1).
elim: {2}n.-1 => [|m IHm].
rewrite (MhoE _ pG) gen_subG; apply/subsetP=> _ /imsetP[x Gx ->].
rewrite subn0 -subn1 -add1n -maxnE maxnC maxnE expnD.
by rewrite expgM -expGpn expg_exponent ?groupX ?group1.
rewrite cChaG ?Mho_char //= (MhoE _ pG) /abelian cent_gen gen_subG.
apply/centsP=> _ /imsetP[x Gx ->] _ /imsetP[y Gy ->].
move: sG'Z; rewrite subsetI centsC => /andP[_ /centsP cGG'].
apply/commgP; rewrite {1}expnSr expgM.
rewrite commXg -?commgX; try by apply: cGG'; rewrite ?mem_commg ?groupX.
apply/commgP; rewrite subsetI Mho_sub centsC in IHm.
apply: (centsP IHm); first by rewrite groupX.
rewrite -add1n -(addn1 m) subnDA -maxnE maxnC maxnE.
rewrite -expgM -expnSr -addSn expnD expgM groupX //=.
by rewrite Mho_p_elt ?(mem_p_elt pG).
Qed.
End Special.
Section Extraspecial.
Variables (p : nat) (gT rT : finGroupType).
Implicit Types D E F G H K M R S T U : {group gT}.
Section Basic.
Variable S : {group gT}.
Hypotheses (pS : p.-group S) (esS : extraspecial S).
Let pZ : p.-group 'Z(S) := pgroupS (center_sub S) pS.
Lemma extraspecial_prime : prime p.
Proof.
by case: esS => _ /prime_gt1; rewrite cardG_gt1; case/(pgroup_pdiv pZ).
Qed.
Lemma card_center_extraspecial : #|'Z(S)| = p.
Proof. by apply/eqP; apply: (pgroupP pZ); case: esS. Qed.
Lemma min_card_extraspecial : #|S| >= p ^ 3.
Proof.
have p_gt1 := prime_gt1 extraspecial_prime.
rewrite leqNgt (card_pgroup pS) ltn_exp2l // ltnS.
case: esS => [[_ defS']]; apply: contraL => /(p2group_abelian pS)/derG1P S'1.
by rewrite -defS' S'1 cards1.
Qed.
End Basic.
Lemma card_p3group_extraspecial E :
prime p -> #|E| = (p ^ 3)%N -> #|'Z(E)| = p -> extraspecial E.
Proof.
move=> p_pr oEp3 oZp; have p_gt0 := prime_gt0 p_pr.
have pE: p.-group E by rewrite /pgroup oEp3 pnat_exp pnat_id.
have pEq: p.-group (E / 'Z(E))%g by rewrite quotient_pgroup.
have /andP[sZE nZE] := center_normal E.
have oEq: #|E / 'Z(E)|%g = (p ^ 2)%N.
by rewrite card_quotient -?divgS // oEp3 oZp expnS mulKn.
have cEEq: abelian (E / 'Z(E))%g by exact: card_p2group_abelian oEq.
have not_cEE: ~~ abelian E.
have: #|'Z(E)| < #|E| by rewrite oEp3 oZp (ltn_exp2l 1) ?prime_gt1.
by apply: contraL => cEE; rewrite -leqNgt subset_leq_card // subsetI subxx.
have defE': E^`(1) = 'Z(E).
apply/eqP; rewrite eqEsubset der1_min //=; apply: contraR not_cEE => not_sE'Z.
apply/commG1P/(TI_center_nil (pgroup_nil pE) (der_normal 1 _)).
by rewrite setIC prime_TIg ?oZp.
split; [split=> // | by rewrite oZp]; apply/eqP.
rewrite eqEsubset andbC -{1}defE' {1}(Phi_joing pE) joing_subl.
rewrite -quotient_sub1 ?(subset_trans (Phi_sub _)) //.
rewrite subG1 /= (quotient_Phi pE) //= (trivg_Phi pEq); apply/abelemP=> //.
split=> // Zx EqZx; apply/eqP; rewrite -order_dvdn /order.
rewrite (card_pgroup (mem_p_elt pEq EqZx)) (@dvdn_exp2l _ _ 1) //.
rewrite leqNgt -pfactor_dvdn // -oEq; apply: contra not_cEE => sEqZx.
rewrite cyclic_center_factor_abelian //; apply/cyclicP.
exists Zx; apply/eqP; rewrite eq_sym eqEcard cycle_subG EqZx -orderE.
exact: dvdn_leq sEqZx.
Qed.
Lemma p3group_extraspecial G :
p.-group G -> ~~ abelian G -> logn p #|G| <= 3 -> extraspecial G.
Proof.
move=> pG not_cGG; have /andP[sZG nZG] := center_normal G.
have ntG: G :!=: 1 by apply: contraNneq not_cGG => ->; exact: abelian1.
have ntZ: 'Z(G) != 1 by rewrite (center_nil_eq1 (pgroup_nil pG)).
have [p_pr _ [n oG]] := pgroup_pdiv pG ntG; rewrite oG pfactorK //.
have [_ _ [m oZ]] := pgroup_pdiv (pgroupS sZG pG) ntZ.
have lt_m1_n: m.+1 < n.
suffices: 1 < logn p #|(G / 'Z(G))|.
rewrite card_quotient // -divgS // logn_div ?cardSg //.
by rewrite oG oZ !pfactorK // ltn_subRL addn1.
rewrite ltnNge; apply: contra not_cGG => cycGs.
apply: cyclic_center_factor_abelian; rewrite (dvdn_prime_cyclic p_pr) //.
by rewrite (card_pgroup (quotient_pgroup _ pG)) (dvdn_exp2l _ cycGs).
rewrite -{lt_m1_n}(subnKC lt_m1_n) !addSn !ltnS leqn0 in oG *.
case: m => // in oZ oG * => /eqP n2; rewrite {n}n2 in oG.
exact: card_p3group_extraspecial oZ.
Qed.
Lemma extraspecial_nonabelian G : extraspecial G -> ~~ abelian G.
Proof.
case=> [[_ defG'] oZ]; rewrite /abelian (sameP commG1P eqP).
by rewrite -derg1 defG' -cardG_gt1 prime_gt1.
Qed.
Lemma exponent_2extraspecial G : 2.-group G -> extraspecial G -> exponent G = 4.
Proof.
move=> p2G esG; have [spG _] := esG.
case/dvdn_pfactor: (exponent_special p2G spG) => // k.
rewrite leq_eqVlt ltnS => /predU1P[-> // | lek1] expG.
case/negP: (extraspecial_nonabelian esG).
by rewrite (@abelem_abelian _ 2) ?exponent2_abelem // expG pfactor_dvdn.
Qed.
Lemma injm_special D G (f : {morphism D >-> rT}) :
'injm f -> G \subset D -> special G -> special (f @* G).
Proof.
move=> injf sGD [defPhiG defG'].
by rewrite /special -morphim_der // -injm_Phi // defPhiG defG' injm_center.
Qed.
Lemma injm_extraspecial D G (f : {morphism D >-> rT}) :
'injm f -> G \subset D -> extraspecial G -> extraspecial (f @* G).
Proof.
move=> injf sGD [spG ZG_pr]; split; first exact: injm_special spG.
by rewrite -injm_center // card_injm // subIset ?sGD.
Qed.
Lemma isog_special G (R : {group rT}) :
G \isog R -> special G -> special R.
Proof. by case/isogP=> f injf <-; exact: injm_special. Qed.
Lemma isog_extraspecial G (R : {group rT}) :
G \isog R -> extraspecial G -> extraspecial R.
Proof. by case/isogP=> f injf <-; exact: injm_extraspecial. Qed.
Lemma cprod_extraspecial G H K :
p.-group G -> H \* K = G -> H :&: K = 'Z(H) ->
extraspecial H -> extraspecial K -> extraspecial G.
Proof.
move=> pG defG ziHK [[PhiH defH'] ZH_pr] [[PhiK defK'] ZK_pr].
have [_ defHK cHK]:= cprodP defG.
have sZHK: 'Z(H) \subset 'Z(K).
by rewrite subsetI -{1}ziHK subsetIr subIset // centsC cHK.
have{sZHK} defZH: 'Z(H) = 'Z(K).
by apply/eqP; rewrite eqEcard sZHK leq_eqVlt eq_sym -dvdn_prime2 ?cardSg.
have defZ: 'Z(G) = 'Z(K).
by case/cprodP: (center_cprod defG) => /= _ <- _; rewrite defZH mulGid.
split; first split; rewrite defZ //.
by have /cprodP[_ <- _] := Phi_cprod pG defG; rewrite PhiH PhiK defZH mulGid.
by have /cprodP[_ <- _] := der_cprod 1 defG; rewrite defH' defK' defZH mulGid.
Qed.
(* Lemmas bundling Aschbacher (23.10) with (19.1), (19.2), (19.12) and (20.8) *)
Section ExtraspecialFormspace.
Variable G : {group gT}.
Hypotheses (pG : p.-group G) (esG : extraspecial G).
Let p_pr := extraspecial_prime pG esG.
Let oZ := card_center_extraspecial pG esG.
Let p_gt1 := prime_gt1 p_pr.
Let p_gt0 := prime_gt0 p_pr.
(* This encasulates Aschbacher (23.10)(1). *)
Lemma cent1_extraspecial_maximal x :
x \in G -> x \notin 'Z(G) -> maximal 'C_G[x] G.
Proof.
move=> Gx notZx; pose f y := [~ x, y]; have [[_ defG'] prZ] := esG.
have{defG'} fZ y: y \in G -> f y \in 'Z(G).
by move=> Gy; rewrite -defG' mem_commg.
have fM: {in G &, {morph f : y z / y * z}}%g.
move=> y z Gy Gz; rewrite {1}/f commgMJ conjgCV -conjgM (conjg_fixP _) //.
rewrite (sameP commgP cent1P); apply: subsetP (fZ y Gy).
by rewrite subIset // orbC -cent_set1 centS // sub1set !(groupM, groupV).
pose fm := Morphism fM.
have fmG: fm @* G = 'Z(G).
have sfmG: fm @* G \subset 'Z(G).
by apply/subsetP=> _ /morphimP[z _ Gz ->]; exact: fZ.
apply/eqP; rewrite eqEsubset sfmG; apply: contraR notZx => /(prime_TIg prZ).
rewrite (setIidPr _) // => fmG1; rewrite inE Gx; apply/centP=> y Gy.
by apply/commgP; rewrite -in_set1 -[[set _]]fmG1; exact: mem_morphim.
have ->: 'C_G[x] = 'ker fm.
apply/setP=> z; rewrite inE (sameP cent1P commgP) !inE.
by rewrite -invg_comm eq_invg_mul mulg1.
rewrite p_index_maximal ?subsetIl // -card_quotient ?ker_norm //.
by rewrite (card_isog (first_isog fm)) /= fmG.
Qed.
(* This is the tranposition of the hyperplane dimension theorem (Aschbacher *)
(* (19.1)) to subgroups of an extraspecial group. *)
Lemma subcent1_extraspecial_maximal U x :
U \subset G -> x \in G :\: 'C(U) -> maximal 'C_U[x] U.
Proof.
move=> sUG /setDP[Gx not_cUx]; apply/maxgroupP; split=> [|H ltHU sCxH].
by rewrite /proper subsetIl subsetI subxx sub_cent1.
case/andP: ltHU => sHU not_sHU; have sHG := subset_trans sHU sUG.
apply/eqP; rewrite eqEsubset sCxH subsetI sHU /= andbT.
apply: contraR not_sHU => not_sHCx.
have maxCx: maximal 'C_G[x] G.
rewrite cent1_extraspecial_maximal //; apply: contra not_cUx.
by rewrite inE Gx; exact: subsetP (centS sUG) _.
have nsCx := p_maximal_normal pG maxCx.
rewrite -(setIidPl sUG) -(mulg_normal_maximal nsCx maxCx sHG) ?subsetI ?sHG //.
by rewrite -group_modr //= setIA (setIidPl sUG) mul_subG.
Qed.
(* This is the tranposition of the orthogonal subspace dimension theorem *)
(* (Aschbacher (19.2)) to subgroups of an extraspecial group. *)
Lemma card_subcent_extraspecial U :
U \subset G -> #|'C_G(U)| = (#|'Z(G) :&: U| * #|G : U|)%N.
Proof.
move=> sUG; rewrite setIAC (setIidPr sUG).
elim: {U}_.+1 {-2}U (ltnSn #|U|) sUG => // m IHm U leUm sUG.
have [cUG | not_cUG]:= orP (orbN (G \subset 'C(U))).
by rewrite !(setIidPl _) ?Lagrange // centsC.
have{not_cUG} [x Gx not_cUx] := subsetPn not_cUG.
pose W := 'C_U[x]; have sCW_G: 'C_G(W) \subset G := subsetIl G _.
have maxW: maximal W U by rewrite subcent1_extraspecial_maximal // inE not_cUx.
have nsWU: W <| U := p_maximal_normal (pgroupS sUG pG) maxW.
have ltWU: W \proper U by exact: maxgroupp maxW.
have [sWU [u Uu notWu]] := properP ltWU; have sWG := subset_trans sWU sUG.
have defU: W * <[u]> = U by rewrite (mulg_normal_maximal nsWU) ?cycle_subG.
have iCW_CU: #|'C_G(W) : 'C_G(U)| = p.
rewrite -defU centM cent_cycle setIA /=; rewrite inE Uu cent1C in notWu.
apply: p_maximal_index (pgroupS sCW_G pG) _.
apply: subcent1_extraspecial_maximal sCW_G _.
rewrite inE andbC (subsetP sUG) //= -sub_cent1.
by apply/subsetPn; exists x; rewrite // inE Gx -sub_cent1 subsetIr.
apply/eqP; rewrite -(eqn_pmul2r p_gt0) -{1}iCW_CU Lagrange ?setIS ?centS //.
rewrite IHm ?(leq_trans (proper_card ltWU)) // -setIA -mulnA.
rewrite -(Lagrange_index sUG sWU) (p_maximal_index (pgroupS sUG pG)) //=.
by rewrite -cent_set1 (setIidPr (centS _)) ?sub1set.
Qed.
(* This is the tranposition of the proof that a singular vector is contained *)
(* in a hyperbolic plane (Aschbacher (19.12)) to subgroups of an extraspecial *)
(* group. *)
Lemma split1_extraspecial x :
x \in G :\: 'Z(G) ->
{E : {group gT} & {R : {group gT} |
[/\ #|E| = (p ^ 3)%N /\ #|R| = #|G| %/ p ^ 2,
E \* R = G /\ E :&: R = 'Z(E),
'Z(E) = 'Z(G) /\ 'Z(R) = 'Z(G),
extraspecial E /\ x \in E
& if abelian R then R :=: 'Z(G) else extraspecial R]}}.
Proof.
case/setDP=> Gx notZx; rewrite inE Gx /= in notZx.
have [[defPhiG defG'] prZ] := esG.
have maxCx: maximal 'C_G[x] G.
by rewrite subcent1_extraspecial_maximal // inE notZx.
pose y := repr (G :\: 'C[x]).
have [Gy not_cxy]: y \in G /\ y \notin 'C[x].
move/maxgroupp: maxCx => /properP[_ [t Gt not_cyt]].
by apply/setDP; apply: (mem_repr t); rewrite !inE Gt andbT in not_cyt *.
pose E := <[x]> <*> <[y]>; pose R := 'C_G(E).
exists [group of E]; exists [group of R] => /=.
have sEG: E \subset G by rewrite join_subG !cycle_subG Gx.
have [Ex Ey]: x \in E /\ y \in E by rewrite !mem_gen // inE cycle_id ?orbT.
have sZE: 'Z(G) \subset E.
rewrite (('Z(G) =P E^`(1)) _) ?der_sub // eqEsubset -{2}defG' dergS // andbT.
apply: contraR not_cxy => /= not_sZE'.
rewrite (sameP cent1P commgP) -in_set1 -[[set 1]](prime_TIg prZ not_sZE').
by rewrite /= -defG' inE !mem_commg.
have ziER: E :&: R = 'Z(E) by rewrite setIA (setIidPl sEG).
have cER: R \subset 'C(E) by rewrite subsetIr.
have iCxG: #|G : 'C_G[x]| = p by exact: p_maximal_index.
have maxR: maximal R 'C_G[x].
rewrite /R centY !cent_cycle setIA.
rewrite subcent1_extraspecial_maximal ?subsetIl // inE Gy andbT -sub_cent1.
by apply/subsetPn; exists x; rewrite 1?cent1C // inE Gx cent1id.
have sRCx: R \subset 'C_G[x] by rewrite -cent_cycle setIS ?centS ?joing_subl.
have sCxG: 'C_G[x] \subset G by rewrite subsetIl.
have sRG: R \subset G by rewrite subsetIl.
have iRCx: #|'C_G[x] : R| = p by rewrite (p_maximal_index (pgroupS sCxG pG)).
have defG: E * R = G.
rewrite -cent_joinEr //= -/R joingC joingA.
have cGx_x: <[x]> \subset 'C_G[x] by rewrite cycle_subG inE Gx cent1id.
have nsRcx := p_maximal_normal (pgroupS sCxG pG) maxR.
rewrite (norm_joinEr (subset_trans cGx_x (normal_norm nsRcx))).
rewrite (mulg_normal_maximal nsRcx) //=; last first.
by rewrite centY !cent_cycle cycle_subG !in_setI Gx cent1id cent1C.
have nsCxG := p_maximal_normal pG maxCx.
have syG: <[y]> \subset G by rewrite cycle_subG.
rewrite (norm_joinEr (subset_trans syG (normal_norm nsCxG))).
by rewrite (mulg_normal_maximal nsCxG) //= cycle_subG inE Gy.
have defZR: 'Z(R) = 'Z(G) by rewrite -['Z(R)]setIA -centM defG.
have defZE: 'Z(E) = 'Z(G).
by rewrite -defG -center_prod ?mulGSid //= -ziER subsetI center_sub defZR sZE.
have [n oG] := p_natP pG.
have n_gt1: n > 1.
by rewrite ltnW // -(@leq_exp2l p) // -oG min_card_extraspecial.
have oR: #|R| = (p ^ n.-2)%N.
apply/eqP; rewrite -(divg_indexS sRCx) iRCx /= -(divg_indexS sCxG) iCxG /= oG.
by rewrite -{1}(subnKC n_gt1) subn2 !expnS !mulKn.
have oE: #|E| = (p ^ 3)%N.
apply/eqP; rewrite -(@eqn_pmul2r #|R|) ?cardG_gt0 // mul_cardG defG ziER.
by rewrite defZE oZ oG -{1}(subnKC n_gt1) oR -expnSr -expnD subn2.
rewrite cprodE // oR oG -expnB ?subn2 //; split=> //.
by split=> //; apply: card_p3group_extraspecial _ oE _; rewrite // defZE.
case: ifP => [cRR | not_cRR]; first by rewrite -defZR (center_idP _).
split; rewrite /special defZR //.
have ntR': R^`(1) != 1 by rewrite (sameP eqP commG1P) -abelianE not_cRR.
have pR: p.-group R := pgroupS sRG pG.
have pR': p.-group R^`(1) := pgroupS (der_sub 1 _) pR.
have defR': R^`(1) = 'Z(G).
apply/eqP; rewrite eqEcard -{1}defG' dergS //= oZ.
by have [_ _ [k ->]]:= pgroup_pdiv pR' ntR'; rewrite (leq_exp2l 1).
split=> //; apply/eqP; rewrite eqEsubset -{1}defPhiG -defR' (PhiS pG) //=.
by rewrite (Phi_joing pR) joing_subl.
Qed.
(* This is the tranposition of the proof that the dimension of any maximal *)
(* totally singular subspace is equal to the Witt index (Aschbacher (20.8)), *)
(* to subgroups of an extraspecial group (in a slightly more general form, *)
(* since we allow for p != 2). *)
(* Note that Aschbacher derives this from the Witt lemma, which we avoid. *)
Lemma pmaxElem_extraspecial : 'E*_p(G) = 'E_p^('r_p(G))(G).
Proof.
have sZmax: {in 'E*_p(G), forall E, 'Z(G) \subset E}.
move=> E maxE; have defE := pmaxElem_LdivP p_pr maxE.
have abelZ: p.-abelem 'Z(G) by rewrite prime_abelem ?oZ.
rewrite -(Ohm1_id abelZ) (OhmE 1 (abelem_pgroup abelZ)) gen_subG -defE.
by rewrite setSI // setIS ?centS // -defE !subIset ?subxx.
suffices card_max: {in 'E*_p(G) &, forall E F, #|E| <= #|F| }.
have EprGmax: 'E_p^('r_p(G))(G) \subset 'E*_p(G) := p_rankElem_max p G.
have [E EprE]:= p_rank_witness p G; have maxE := subsetP EprGmax E EprE.
apply/eqP; rewrite eqEsubset EprGmax andbT; apply/subsetP=> F maxF.
rewrite inE; have [-> _]:= pmaxElemP maxF; have [_ _ <-]:= pnElemP EprE.
by apply/eqP; congr (logn p _); apply/eqP; rewrite eqn_leq !card_max.
move=> E F maxE maxF; set U := E :&: F.
have [sUE sUF]: U \subset E /\ U \subset F by apply/andP; rewrite -subsetI.
have sZU: 'Z(G) \subset U by rewrite subsetI !sZmax.
have [EpE _]:= pmaxElemP maxE; have{EpE} [sEG abelE] := pElemP EpE.
have [EpF _]:= pmaxElemP maxF; have{EpF} [sFG abelF] := pElemP EpF.
have [V] := abelem_split_dprod abelE sUE; case/dprodP=> _ defE cUV tiUV.
have [W] := abelem_split_dprod abelF sUF; case/dprodP=> _ defF _ tiUW.
have [sVE sWF]: V \subset E /\ W \subset F by rewrite -defE -defF !mulG_subr.
have [sVG sWG] := (subset_trans sVE sEG, subset_trans sWF sFG).
rewrite -defE -defF !TI_cardMg // leq_pmul2l ?cardG_gt0 //.
rewrite -(leq_pmul2r (cardG_gt0 'C_G(W))) mul_cardG.
rewrite card_subcent_extraspecial // mulnCA Lagrange // mulnC.
rewrite leq_mul ?subset_leq_card //; last by rewrite mul_subG ?subsetIl.
apply: subset_trans (sub1G _); rewrite -tiUV !subsetI subsetIl subIset ?sVE //=.
rewrite -(pmaxElem_LdivP p_pr maxF) -defF centM -!setIA -(setICA 'C(W)).
rewrite setIC setIA setIS // subsetI cUV sub_LdivT.
by case/and3P: (abelemS sVE abelE).
Qed.
End ExtraspecialFormspace.
(* This is B & G, Theorem 4.15, as done in Aschbacher (23.8) *)
Lemma critical_extraspecial R S :
p.-group R -> S \subset R -> extraspecial S -> [~: S, R] \subset S^`(1) ->
S \* 'C_R(S) = R.
Proof.
move=> pR sSR esS sSR_S'; have [[defPhi defS'] _] := esS.
have [pS [sPS nPS]] := (pgroupS sSR pR, andP (Phi_normal S : 'Phi(S) <| S)).
have{esS} oZS: #|'Z(S)| = p := card_center_extraspecial pS esS.
have nSR: R \subset 'N(S) by rewrite -commg_subl (subset_trans sSR_S') ?der_sub.
have nsCR: 'C_R(S) <| R by rewrite (normalGI nSR) ?cent_normal.
have nCS: S \subset 'N('C_R(S)) by rewrite cents_norm // centsC subsetIr.
rewrite cprodE ?subsetIr //= -{2}(quotientGK nsCR) normC -?quotientK //.
congr (_ @*^-1 _); apply/eqP; rewrite eqEcard quotientS //=.
rewrite -(card_isog (second_isog nCS)) setIAC (setIidPr sSR) /= -/'Z(S) -defPhi.
rewrite -ker_conj_aut (card_isog (first_isog_loc _ nSR)) //=; set A := _ @* R.
have{pS} abelSb := Phi_quotient_abelem pS; have [pSb cSSb _] := and3P abelSb.
have [/= Xb defSb oXb] := grank_witness (S / 'Phi(S)).
pose X := (repr \o val : coset_of _ -> gT) @: Xb.
have sXS: X \subset S; last have nPX := subset_trans sXS nPS.
apply/subsetP=> x; case/imsetP=> xb Xxb ->; have nPx := repr_coset_norm xb.
rewrite -sub1set -(quotientSGK _ sPS) ?sub1set ?quotient_set1 //= sub1set.
by rewrite coset_reprK -defSb mem_gen.
have defS: <> = S.
apply: Phi_nongen; apply/eqP; rewrite eqEsubset join_subG sPS sXS -joing_idr.
rewrite -genM_join sub_gen // -quotientSK ?quotient_gen // -defSb genS //.
apply/subsetP=> xb Xxb; apply/imsetP; rewrite (setIidPr nPX).
by exists (repr xb); rewrite /= ?coset_reprK //; exact: mem_imset.
pose f (a : {perm gT}) := [ffun x => if x \in X then x^-1 * a x else 1].
have injf: {in A &, injective f}.
move=> _ _ /morphimP[y nSy Ry ->] /morphimP[z nSz Rz ->].
move/ffunP=> eq_fyz; apply: (@eq_Aut _ S); rewrite ?Aut_aut //= => x Sx.
rewrite !norm_conj_autE //; apply: canRL (conjgKV z) _; rewrite -conjgM.
rewrite /conjg -(centP _ x Sx) ?mulKg {x Sx}// -defS cent_gen -sub_cent1.
apply/subsetP=> x Xx; have Sx := subsetP sXS x Xx.
move/(_ x): eq_fyz; rewrite !ffunE Xx !norm_conj_autE // => /mulgI xy_xz.
by rewrite cent1C inE conjg_set1 conjgM xy_xz conjgK.
have sfA_XS': f @: A \subset pffun_on 1 X S^`(1).
apply/subsetP=> _ /imsetP[_ /morphimP[y nSy Ry ->] ->].
apply/pffun_onP; split=> [|_ /imageP[x /= Xx ->]].
by apply/subsetP=> x; apply: contraR; rewrite ffunE => /negPf->.
have Sx := subsetP sXS x Xx.
by rewrite ffunE Xx norm_conj_autE // (subsetP sSR_S') ?mem_commg.
rewrite -(card_in_imset injf) (leq_trans (subset_leq_card sfA_XS')) // defS'.
rewrite card_pffun_on (card_pgroup pSb) -rank_abelem -?grank_abelian // -oXb.
by rewrite -oZS ?leq_pexp2l ?cardG_gt0 ?leq_imset_card.
Qed.
(* This is part of Aschbacher (23.13) and (23.14). *)
Theorem extraspecial_structure S : p.-group S -> extraspecial S ->
{Es | all (fun E => (#|E| == p ^ 3)%N && ('Z(E) == 'Z(S))) Es
& \big[cprod/1%g]_(E <- Es) E \* 'Z(S) = S}.
Proof.
elim: {S}_.+1 {-2}S (ltnSn #|S|) => // m IHm S leSm pS esS.
have [x Z'x]: {x | x \in S :\: 'Z(S)}.
apply/sigW/set0Pn; rewrite -subset0 subDset setU0.
apply: contra (extraspecial_nonabelian esS) => sSZ.
exact: abelianS sSZ (center_abelian S).
have [E [R [[oE oR]]]]:= split1_extraspecial pS esS Z'x.
case=> defS _ [defZE defZR] _; case: ifP => [_ defR | _ esR].
by exists [:: E]; rewrite /= ?oE ?defZE ?eqxx // big_seq1 -defR.
have sRS: R \subset S by case/cprodP: defS => _ <- _; rewrite mulG_subr.
have [|Es esEs defR] := IHm _ _ (pgroupS sRS pS) esR.
rewrite oR (leq_trans (ltn_Pdiv _ _)) ?cardG_gt0 // (ltn_exp2l 0) //.
exact: prime_gt1 (extraspecial_prime pS esS).
exists (E :: Es); first by rewrite /= oE defZE !eqxx -defZR.
by rewrite -defZR big_cons -cprodA defR.
Qed.
Section StructureCorollaries.
Variable S : {group gT}.
Hypotheses (pS : p.-group S) (esS : extraspecial S).
Let p_pr := extraspecial_prime pS esS.
Let oZ := card_center_extraspecial pS esS.
(* This is Aschbacher (23.10)(2). *)
Lemma card_extraspecial : {n | n > 0 & #|S| = (p ^ n.*2.+1)%N}.
Proof.
exists (logn p #|S|)./2.
rewrite half_gt0 ltnW // -(leq_exp2l _ _ (prime_gt1 p_pr)) -card_pgroup //.
exact: min_card_extraspecial.
have [Es] := extraspecial_structure pS esS.
elim: Es {3 4 5}S => [_ _ <-| E s IHs T] /=.
by rewrite big_nil cprod1g oZ (pfactorK 1).
rewrite -andbA big_cons -cprodA; case/and3P; move/eqP=> oEp3; move/eqP=> defZE.
move/IHs=> {IHs}IHs; case/cprodP=> [[_ U _ defU]]; rewrite defU => defT cEU.
rewrite -(mulnK #|T| (cardG_gt0 (E :&: U))) -defT -mul_cardG /=.
have ->: E :&: U = 'Z(S).
apply/eqP; rewrite eqEsubset subsetI -{1 2}defZE subsetIl setIS //=.
by case/cprodP: defU => [[V _ -> _]] <- _; exact: mulG_subr.
rewrite (IHs U) // oEp3 oZ -expnD addSn expnS mulKn ?prime_gt0 //.
by rewrite pfactorK //= uphalf_double.
Qed.
Lemma Aut_extraspecial_full : Aut_in (Aut S) 'Z(S) \isog Aut 'Z(S).
Proof.
have [p_gt1 p_gt0] := (prime_gt1 p_pr, prime_gt0 p_pr).
have [Es] := extraspecial_structure pS esS.
elim: Es S oZ => [T _ _ <-| E s IHs T oZT] /=.
rewrite big_nil cprod1g (center_idP (center_abelian T)).
by apply/Aut_sub_fullP=> // g injg gZ; exists g.
rewrite -andbA big_cons -cprodA; case/and3P; move/eqP=> oE; move/eqP=> defZE.
move=> es_s; case/cprodP=> [[_ U _ defU]]; rewrite defU => defT cEU.
have sUT: U \subset T by rewrite -defT mulG_subr.
have sZU: 'Z(T) \subset U.
by case/cprodP: defU => [[V _ -> _] <- _]; exact: mulG_subr.
have defZU: 'Z(E) = 'Z(U).
apply/eqP; rewrite eqEsubset defZE subsetI sZU subIset ?centS ?orbT //=.
by rewrite subsetI subIset ?sUT //= -defT centM setSI.
apply: (Aut_cprod_full _ defZU); rewrite ?cprodE //; last first.
by apply: IHs; rewrite -?defZU ?defZE.
have oZE: #|'Z(E)| = p by rewrite defZE.
have [p2 | odd_p] := even_prime p_pr.
suffices <-: restr_perm 'Z(E) @* Aut E = Aut 'Z(E) by exact: Aut_in_isog.
apply/eqP; rewrite eqEcard restr_perm_Aut ?center_sub //=.
by rewrite card_Aut_cyclic ?prime_cyclic ?oZE // {1}p2 cardG_gt0.
have pE: p.-group E by rewrite /pgroup oE pnat_exp pnat_id.
have nZE: E \subset 'N('Z(E)) by rewrite normal_norm ?center_normal.
have esE: extraspecial E := card_p3group_extraspecial p_pr oE oZE.
have [[defPhiE defE'] prZ] := esE.
have{defPhiE} sEpZ x: x \in E -> (x ^+ p)%g \in 'Z(E).
move=> Ex; rewrite -defPhiE (Phi_joing pE) mem_gen // inE orbC.
by rewrite (Mho_p_elt 1) // (mem_p_elt pE).
have ltZE: 'Z(E) \proper E by rewrite properEcard subsetIl oZE oE (ltn_exp2l 1).
have [x [Ex notZx oxp]]: exists x, [/\ x \in E, x \notin 'Z(E) & #[x] %| p]%N.
have [_ [x Ex notZx]] := properP ltZE.
case: (prime_subgroupVti <[x ^+ p]> prZ) => [sZxp | ]; last first.
move/eqP; rewrite (setIidPl _) ?cycle_subG ?sEpZ //.
by rewrite cycle_eq1 -order_dvdn; exists x.
have [y Ey notxy]: exists2 y, y \in E & y \notin <[x]>.
apply/subsetPn; apply: contra (extraspecial_nonabelian esE) => sEx.
by rewrite (abelianS sEx) ?cycle_abelian.
have: (y ^+ p)%g \in <[x ^+ p]> by rewrite (subsetP sZxp) ?sEpZ.
case/cycleP=> i def_yp; set xi := (x ^- i)%g.
have Exi: xi \in E by rewrite groupV groupX.
exists (y * xi)%g; split; first by rewrite groupM.
have sxpx: <[x ^+ p]> \subset <[x]> by rewrite cycle_subG mem_cycle.
apply: contra notxy; move/(subsetP (subset_trans sZxp sxpx)).
by rewrite groupMr // groupV mem_cycle.
pose z := [~ xi, y]; have Zz: z \in 'Z(E) by rewrite -defE' mem_commg.
case: (setIP Zz) => _; move/centP=> cEz.
rewrite order_dvdn expMg_Rmul; try by apply: commute_sym; apply: cEz.
rewrite def_yp expgVn -!expgM mulnC mulgV mul1g -order_dvdn.
by rewrite (dvdn_trans (order_dvdG Zz)) //= oZE bin2odd // dvdn_mulr.
have{oxp} ox: #[x] = p.
apply/eqP; case/primeP: p_pr => _ dvd_p; case/orP: (dvd_p _ oxp) => //.
by rewrite order_eq1; case: eqP notZx => // ->; rewrite group1.
have [y Ey not_cxy]: exists2 y, y \in E & y \notin 'C[x].
by apply/subsetPn; rewrite sub_cent1; rewrite inE Ex in notZx.
have notZy: y \notin 'Z(E).
apply: contra not_cxy; rewrite inE Ey; apply: subsetP.
by rewrite -cent_set1 centS ?sub1set.
pose K := 'C_E[y]; have maxK: maximal K E by exact: cent1_extraspecial_maximal.
have nsKE: K <| E := p_maximal_normal pE maxK; have [sKE nKE] := andP nsKE.
have oK: #|K| = (p ^ 2)%N.
by rewrite -(divg_indexS sKE) oE (p_maximal_index pE) ?mulKn.
have cKK: abelian K := card_p2group_abelian p_pr oK.
have sZK: 'Z(E) \subset K by rewrite setIS // -cent_set1 centS ?sub1set.
have defE: K ><| <[x]> = E.
have notKx: x \notin K by rewrite inE Ex cent1C.
rewrite sdprodE ?(mulg_normal_maximal nsKE) ?cycle_subG ?(subsetP nKE) //.
by rewrite setIC prime_TIg -?orderE ?ox ?cycle_subG.
have /cyclicP[z defZ]: cyclic 'Z(E) by rewrite prime_cyclic ?oZE.
apply/(Aut_sub_fullP (center_sub E)); rewrite /= defZ => g injg gZ.
pose k := invm (injm_Zp_unitm z) (aut injg gZ).
have fM: {in K &, {morph expgn^~ (val k): u v / u * v}}.
by move=> u v Ku Kv; rewrite /= expgMn // /commute (centsP cKK).
pose f := Morphism fM; have fK: f @* K = K.
apply/setP=> u; rewrite morphimEdom.
apply/imsetP/idP=> [[v Kv ->] | Ku]; first exact: groupX.
exists (u ^+ expg_invn K (val k)); first exact: groupX.
rewrite /f /= expgAC expgK // oK coprime_expl // -unitZpE //.
by case: (k) => /=; rewrite orderE -defZ oZE => j; rewrite natr_Zp.
have fMact: {in K & <[x]>, morph_act 'J 'J f (idm <[x]>)}.
by move=> u v _ _; rewrite /= conjXg.
exists (sdprodm_morphism defE fMact).
rewrite im_sdprodm injm_sdprodm injm_idm -card_im_injm im_idm fK.
have [_ -> _ ->] := sdprodP defE; rewrite !eqxx; split=> //= u Zu.
rewrite sdprodmEl ?(subsetP sZK) ?defZ // -(autE injg gZ Zu).
rewrite -[aut _ _](invmK (injm_Zp_unitm z)); first by rewrite permE Zu.
by rewrite im_Zp_unitm Aut_aut.
Qed.
(* These are the parts of Aschbacher (23.12) and exercise 8.5 that are later *)
(* used in Aschbacher (34.9), which itself replaces the informal discussion *)
(* quoted from Gorenstein in the proof of B & G, Theorem 2.5. *)
Lemma center_aut_extraspecial k : coprime k p ->
exists2 f, f \in Aut S & forall z, z \in 'Z(S) -> f z = (z ^+ k)%g.
Proof.
have /cyclicP[z defZ]: cyclic 'Z(S) by rewrite prime_cyclic ?oZ.
have oz: #[z] = p by rewrite orderE -defZ.
rewrite coprime_sym -unitZpE ?prime_gt1 // -oz => u_k.
pose g := Zp_unitm (FinRing.unit 'Z_#[z] u_k).
have AutZg: g \in Aut 'Z(S) by rewrite defZ -im_Zp_unitm mem_morphim ?inE.
have ZSfull := Aut_sub_fullP (center_sub S) Aut_extraspecial_full.
have [f [injf fS fZ]] := ZSfull _ (injm_autm AutZg) (im_autm AutZg).
exists (aut injf fS) => [|u Zu]; first exact: Aut_aut.
have [Su _] := setIP Zu; have z_u: u \in <[z]> by rewrite -defZ.
by rewrite autE // fZ //= autmE permE /= z_u /cyclem expg_znat.
Qed.
End StructureCorollaries.
End Extraspecial.
Section SCN.
Variables (gT : finGroupType) (p : nat) (G : {group gT}).
Implicit Types A Z H : {group gT}.
Lemma SCN_P A : reflect (A <| G /\ 'C_G(A) = A) (A \in 'SCN(G)).
Proof. by apply: (iffP setIdP) => [] [->]; move/eqP. Qed.
Lemma SCN_abelian A : A \in 'SCN(G) -> abelian A.
Proof. by case/SCN_P=> _ defA; rewrite /abelian -{1}defA subsetIr. Qed.
Lemma exponent_Ohm1_class2 H :
odd p -> p.-group H -> nil_class H <= 2 -> exponent 'Ohm_1(H) %| p.
Proof.
move=> odd_p pH; rewrite nil_class2 => sH'Z; apply/exponentP=> x /=.
rewrite (OhmE 1 pH) expn1 gen_set_id => {x} [/LdivP[] //|].
apply/group_setP; split=> [|x y]; first by rewrite !inE group1 expg1n //=.
case/LdivP=> Hx xp1 /LdivP[Hy yp1]; rewrite !inE groupM //=.
have [_ czH]: [~ y, x] \in H /\ centralises [~ y, x] H.
by apply/centerP; rewrite (subsetP sH'Z) ?mem_commg.
rewrite expMg_Rmul ?xp1 ?yp1 /commute ?czH //= !mul1g.
by rewrite bin2odd // -commXXg ?yp1 /commute ?czH // comm1g.
Qed.
(* SCN_max and max_SCN cover Aschbacher 23.15(1) *)
Lemma SCN_max A : A \in 'SCN(G) -> [max A | A <| G & abelian A].
Proof.
case/SCN_P => nAG scA; apply/maxgroupP; split=> [|H].
by rewrite nAG /abelian -{1}scA subsetIr.
do 2![case/andP]=> sHG _ abelH sAH; apply/eqP.
by rewrite eqEsubset sAH -scA subsetI sHG centsC (subset_trans sAH).
Qed.
Lemma max_SCN A :
p.-group G -> [max A | A <| G & abelian A] -> A \in 'SCN(G).
Proof.
move/pgroup_nil=> nilG; rewrite /abelian.
case/maxgroupP=> /andP[nsAG abelA] maxA; have [sAG nAG] := andP nsAG.
rewrite inE nsAG eqEsubset /= andbC subsetI abelA normal_sub //=.
rewrite -quotient_sub1; last by rewrite subIset 1?normal_norm.
apply/trivgP; apply: (TI_center_nil (quotient_nil A nilG)).
by rewrite quotient_normal // /normal subsetIl normsI ?normG ?norms_cent.
apply/trivgP/subsetP=> _ /setIP[/morphimP[x Nx /setIP[_ Cx]] ->].
rewrite -cycle_subG in Cx => /setIP[GAx CAx].
have{CAx GAx}: <[coset A x]> <| G / A.
by rewrite /normal cycle_subG GAx cents_norm // centsC cycle_subG.
case/(inv_quotientN nsAG)=> B /= defB sAB nBG.
rewrite -cycle_subG defB (maxA B) ?trivg_quotient // nBG.
have{defB} defB : B :=: A * <[x]>.
rewrite -quotientK ?cycle_subG ?quotient_cycle // defB quotientGK //.
exact: normalS (normal_sub nBG) nsAG.
apply/setIidPl; rewrite ?defB -[_ :&: _]center_prod //=.
rewrite /center !(setIidPl _) //; exact: cycle_abelian.
Qed.
(* The two other assertions of Aschbacher 23.15 state properties of the *)
(* normal series 1 <| Z = 'Ohm_1(A) <| A with A \in 'SCN(G). *)
Section SCNseries.
Variables A : {group gT}.
Hypothesis SCN_A : A \in 'SCN(G).
Let Z := 'Ohm_1(A).
Let cAA := SCN_abelian SCN_A.
Let sZA: Z \subset A := Ohm_sub 1 A.
Let nZA : A \subset 'N(Z) := sub_abelian_norm cAA sZA.
(* This is Aschbacher 23.15(2). *)
Lemma der1_stab_Ohm1_SCN_series : ('C(Z) :&: 'C_G(A / Z | 'Q))^`(1) \subset A.
Proof.
case/SCN_P: SCN_A => /andP[sAG nAG] {4} <-.
rewrite subsetI {1}setICA comm_subG ?subsetIl //= gen_subG.
apply/subsetP=> w /imset2P[u v].
rewrite -groupV -(groupV _ v) /= astabQR //= -/Z !inE groupV.
case/and4P=> cZu _ _ sRuZ /and4P[cZv' _ _ sRvZ] ->{w}.
apply/centP=> a Aa; rewrite /commute -!mulgA (commgCV v) (mulgA u).
rewrite (centP cZu); last by rewrite (subsetP sRvZ) ?mem_commg ?set11 ?groupV.
rewrite 2!(mulgA v^-1) mulKVg 4!mulgA invgK (commgC u^-1) mulgA.
rewrite -(mulgA _ _ v^-1) -(centP cZv') ?(subsetP sRuZ) ?mem_commg ?set11//.
by rewrite -!mulgA invgK mulKVg !mulKg.
Qed.
(* This is Aschbacher 23.15(3); note that this proof does not depend on the *)
(* maximality of A. *)
Lemma Ohm1_stab_Ohm1_SCN_series :
odd p -> p.-group G -> 'Ohm_1('C_G(Z)) \subset 'C_G(A / Z | 'Q).
Proof.
have [-> | ntG] := eqsVneq G 1; first by rewrite !(setIidPl (sub1G _)) Ohm1.
move=> p_odd pG; have{ntG} [p_pr _ _] := pgroup_pdiv pG ntG.
case/SCN_P: SCN_A => /andP[sAG nAG] _; have pA := pgroupS sAG pG.
have pCGZ : p.-group 'C_G(Z) by rewrite (pgroupS _ pG) // subsetIl.
rewrite {pCGZ}(OhmE 1 pCGZ) gen_subG; apply/subsetP=> x; rewrite 3!inE -andbA.
rewrite -!cycle_subG => /and3P[sXG cZX xp1] /=; have cXX := cycle_abelian x.
have nZX := cents_norm cZX; have{nAG} nAX := subset_trans sXG nAG.
pose XA := <[x]> <*> A; pose C := 'C(<[x]> / Z | 'Q); pose CA := A :&: C.
pose Y := <[x]> <*> CA; pose W := 'Ohm_1(Y).
have sXC: <[x]> \subset C by rewrite sub_astabQ nZX (quotient_cents _ cXX).
have defY : Y = <[x]> * CA by rewrite -norm_joinEl // normsI ?nAX ?normsG.
have{nAX} defXA: XA = <[x]> * A := norm_joinEl nAX.
suffices{sXC}: XA \subset Y.
rewrite subsetI sXG /= sub_astabQ nZX centsC defY group_modl //= -/Z -/C.
by rewrite subsetI sub_astabQ defXA quotientMl //= !mulG_subG; case/and4P.
have sZCA: Z \subset CA by rewrite subsetI sZA [C]astabQ sub_cosetpre.
have cZCA: CA \subset 'C(Z) by rewrite subIset 1?(sub_abelian_cent2 cAA).
have sZY: Z \subset Y by rewrite (subset_trans sZCA) ?joing_subr.
have{cZCA cZX} cZY: Y \subset 'C(Z) by rewrite join_subG cZX.
have{cXX nZX} sY'Z : Y^`(1) \subset Z.
rewrite der1_min ?cents_norm //= -/Y defY quotientMl // abelianM /= -/Z -/CA.
rewrite !quotient_abelian // ?(abelianS _ cAA) ?subsetIl //=.
by rewrite /= quotientGI ?Ohm_sub // quotient_astabQ subsetIr.
have{sY'Z cZY} nil_classY: nil_class Y <= 2.
by rewrite nil_class2 (subset_trans sY'Z ) // subsetI sZY centsC.
have pY: p.-group Y by rewrite (pgroupS _ pG) // join_subG sXG subIset ?sAG.
have sXW: <[x]> \subset W.
by rewrite [W](OhmE 1 pY) ?genS // sub1set !inE -cycle_subG joing_subl.
have{nil_classY pY sXW sZY sZCA} defW: W = <[x]> * Z.
rewrite -[W](setIidPr (Ohm_sub _ _)) /= -/Y {1}defY -group_modl //= -/Y -/W.
congr (_ * _); apply/eqP; rewrite eqEsubset {1}[Z](OhmE 1 pA).
rewrite subsetI setIAC subIset //; first by rewrite sZCA -[Z]Ohm_id OhmS.
rewrite sub_gen ?setIS //; apply/subsetP=> w Ww; rewrite inE.
by apply/eqP; apply: exponentP w Ww; exact: exponent_Ohm1_class2.
have{sXG sAG} sXAG: XA \subset G by rewrite join_subG sXG.
have{sXAG} nilXA: nilpotent XA := nilpotentS sXAG (pgroup_nil pG).
have sYXA: Y \subset XA by rewrite defY defXA mulgS ?subsetIl.
rewrite -[Y](nilpotent_sub_norm nilXA) {nilXA sYXA}//= -/Y -/XA.
apply: subset_trans (setIS _ (char_norm_trans (Ohm_char 1 _) (subxx _))) _.
rewrite {XA}defXA -group_modl ?normsG /= -/W ?{W}defW ?mulG_subl //.
rewrite {Y}defY mulgS // subsetI subsetIl {CA C}sub_astabQ subIset ?nZA //= -/Z.
rewrite (subset_trans (quotient_subnorm _ _ _)) //= quotientMidr /= -/Z.
rewrite -quotient_sub1 ?subIset ?cent_norm ?orbT //.
rewrite (subset_trans (quotientI _ _ _)) ?coprime_TIg //.
rewrite (@pnat_coprime p) // -/(pgroup p _) ?quotient_pgroup {pA}//=.
rewrite -(setIidPr (cent_sub _)) [pnat _ _]p'group_quotient_cent_prime //.
by rewrite (dvdn_trans (dvdn_quotient _ _)) ?order_dvdn.
Qed.
End SCNseries.
(* This is Aschbacher 23.16. *)
Lemma Ohm1_cent_max_normal_abelem Z :
odd p -> p.-group G -> [max Z | Z <| G & p.-abelem Z] -> 'Ohm_1('C_G(Z)) = Z.
Proof.
move=> p_odd pG; set X := 'Ohm_1('C_G(Z)).
case/maxgroupP=> /andP[nsZG abelZ] maxZ.
have [sZG nZG] := andP nsZG; have [_ cZZ expZp] := and3P abelZ.
have{nZG} nsXG: X <| G.
apply: (char_normal_trans (Ohm_char 1 'C_G(Z))).
by rewrite /normal subsetIl normsI ?normG ?norms_cent.
have cZX : X \subset 'C(Z) := subset_trans (Ohm_sub _ _) (subsetIr _ _).
have{sZG expZp} sZX: Z \subset X.
rewrite [X](OhmE 1 (pgroupS _ pG)) ?subsetIl ?sub_gen //.
apply/subsetP=> x Zx; rewrite !inE ?(subsetP sZG) ?(subsetP cZZ) //=.
by rewrite (exponentP expZp).
suffices{sZX} expXp: (exponent X %| p).
apply/eqP; rewrite eqEsubset sZX andbT -quotient_sub1 ?cents_norm //= -/X.
have pGq: p.-group (G / Z) by rewrite quotient_pgroup.
rewrite (TI_center_nil (pgroup_nil pGq)) ?quotient_normal //= -/X setIC.
apply/eqP/trivgPn=> [[Zd]]; rewrite inE -!cycle_subG -cycle_eq1 -subG1 /= -/X.
case/andP=> /sub_center_normal nsZdG.
have{nsZdG} [D defD sZD nsDG] := inv_quotientN nsZG nsZdG; rewrite defD.
have sDG := normal_sub nsDG; have nsZD := normalS sZD sDG nsZG.
rewrite quotientSGK ?quotient_sub1 ?normal_norm //= -/X => sDX; case/negP.
rewrite (maxZ D) // nsDG andbA (pgroupS sDG) ?(dvdn_trans (exponentS sDX)) //.
have sZZD: Z \subset 'Z(D) by rewrite subsetI sZD centsC (subset_trans sDX).
by rewrite (cyclic_factor_abelian sZZD) //= -defD cycle_cyclic.
pose normal_abelian := [pred A : {group gT} | A <| G & abelian A].
have{nsZG cZZ} normal_abelian_Z : normal_abelian Z by exact/andP.
have{normal_abelian_Z} [A maxA sZA] := maxgroup_exists normal_abelian_Z.
have SCN_A : A \in 'SCN(G) by apply: max_SCN pG maxA.
move/maxgroupp: maxA => /andP[nsAG cAA] {normal_abelian}.
have pA := pgroupS (normal_sub nsAG) pG.
have{abelZ maxZ nsAG cAA sZA} defA1: 'Ohm_1(A) = Z.
apply: maxZ; last by rewrite -(Ohm1_id abelZ) OhmS.
by rewrite Ohm1_abelem ?(char_normal_trans (Ohm_char _ _) nsAG).
have{SCN_A} sX'A: X^`(1) \subset A.
have sX_CWA1 : X \subset 'C('Ohm_1(A)) :&: 'C_G(A / 'Ohm_1(A) | 'Q).
rewrite subsetI /X -defA1 (Ohm1_stab_Ohm1_SCN_series _ p_odd) //= andbT.
exact: subset_trans (Ohm_sub _ _) (subsetIr _ _).
by apply: subset_trans (der1_stab_Ohm1_SCN_series SCN_A); rewrite commgSS.
pose genXp := [pred U : {group gT} | 'Ohm_1(U) == U & ~~ (exponent U %| p)].
apply/idPn=> expXp'; have genXp_X: genXp [group of X] by rewrite /= Ohm_id eqxx.
have{genXp_X expXp'} [U] := mingroup_exists genXp_X; case/mingroupP; case/andP.
move/eqP=> defU1 expUp' minU sUX; case/negP: expUp'.
have{nsXG} pU := pgroupS (subset_trans sUX (normal_sub nsXG)) pG.
case gsetU1: (group_set 'Ldiv_p(U)).
by rewrite -defU1 (OhmE 1 pU) gen_set_id // -sub_LdivT subsetIr.
move: gsetU1; rewrite /group_set 2!inE group1 expg1n eqxx; case/subsetPn=> xy.
case/imset2P=> x y; rewrite !inE => /andP[Ux xp1] /andP[Uy yp1] ->{xy}.
rewrite groupM //= => nt_xyp; pose XY := <[x]> <*> <[y]>.
have{yp1 nt_xyp} defXY: XY = U.
have sXY_U: XY \subset U by rewrite join_subG !cycle_subG Ux Uy.
rewrite [XY]minU //= eqEsubset Ohm_sub (OhmE 1 (pgroupS _ pU)) //.
rewrite /= joing_idl joing_idr genS; last first.
by rewrite subsetI subset_gen subUset !sub1set !inE xp1 yp1.
apply: contra nt_xyp => /exponentP-> //.
by rewrite groupMl mem_gen // (set21, set22).
have: <[x]> <|<| U by rewrite nilpotent_subnormal ?(pgroup_nil pU) ?cycle_subG.
case/subnormalEsupport=> [defU | /=].
by apply: dvdn_trans (exponent_dvdn U) _; rewrite -defU order_dvdn.
set V := < U>>; case/andP=> sVU ltVU.
have{genXp minU xp1 sVU ltVU} expVp: exponent V %| p.
apply: contraR ltVU => expVp'; rewrite [V]minU //= expVp' eqEsubset Ohm_sub.
rewrite (OhmE 1 (pgroupS sVU pU)) genS //= subsetI subset_gen class_supportEr.
apply/bigcupsP=> z _; apply/subsetP=> v Vv.
by rewrite inE -order_dvdn (dvdn_trans (order_dvdG Vv)) // cardJg order_dvdn.
have{A pA defA1 sX'A V expVp} Zxy: [~ x, y] \in Z.
rewrite -defA1 (OhmE 1 pA) mem_gen // !inE (exponentP expVp).
by rewrite (subsetP sX'A) //= mem_commg ?(subsetP sUX).
by rewrite groupMl -1?[x^-1]conjg1 mem_gen // mem_imset2 // ?groupV cycle_id.
have{Zxy sUX cZX} cXYxy: [~ x, y] \in 'C(XY).
by rewrite centsC in cZX; rewrite defXY (subsetP (centS sUX)) ?(subsetP cZX).
rewrite -defU1 exponent_Ohm1_class2 // nil_class2 -defXY der1_joing_cycles //.
by rewrite subsetI {1}defXY !cycle_subG groupR.
Qed.
Lemma critical_class2 H : critical H G -> nil_class H <= 2.
Proof.
case=> [chH _ sRZ _].
by rewrite nil_class2 (subset_trans _ sRZ) ?commSg // char_sub.
Qed.
(* This proof of the Thompson critical lemma is adapted from Aschbacher 23.6 *)
Lemma Thompson_critical : p.-group G -> {K : {group gT} | critical K G}.
Proof.
move=> pG; pose qcr A := (A \char G) && ('Phi(A) :|: [~: G, A] \subset 'Z(A)).
have [|K]:= @maxgroup_exists _ qcr 1 _.
by rewrite /qcr char1 center1 commG1 subUset Phi_sub subxx.
case/maxgroupP; rewrite {}/qcr subUset => /and3P[chK sPhiZ sRZ] maxK _.
have sKG := char_sub chK; have nKG := char_normal chK.
exists K; split=> //; apply/eqP; rewrite eqEsubset andbC setSI //=.
have chZ: 'Z(K) \char G by [exact: subcent_char]; have nZG := char_norm chZ.
have chC: 'C_G(K) \char G by exact: subcent_char (char_refl G) chK.
rewrite -quotient_sub1; last by rewrite subIset // char_norm.
apply/trivgP; apply: (TI_center_nil (quotient_nil _ (pgroup_nil pG))).
rewrite quotient_normal // /normal subsetIl normsI ?normG ?norms_cent //.
exact: char_norm.
apply: TI_Ohm1; apply/trivgP; rewrite -trivg_quotient -sub_cosetpre_quo //.
rewrite morphpreI quotientGK /=; last first.
by apply: normalS (char_normal chZ); rewrite ?subsetIl ?setSI.
set X := _ :&: _; pose gX := [group of X].
have sXG: X \subset G by rewrite subIset ?subsetIl.
have cXK: K \subset 'C(gX) by rewrite centsC 2?subIset // subxx orbT.
rewrite subsetI centsC cXK andbT -(mul1g K) -mulSG mul1g -(cent_joinEr cXK).
rewrite [_ <*> K]maxK ?joing_subr //= andbC (cent_joinEr cXK).
rewrite -center_prod // (subset_trans _ (mulG_subr _ _)).
rewrite charM 1?charI ?(char_from_quotient (normal_cosetpre _)) //.
by rewrite cosetpreK (char_trans _ (center_char _)) ?Ohm_char.
rewrite (@Phi_mulg p) ?(pgroupS _ pG) // subUset commGC commMG; last first.
by rewrite normsR ?(normsG sKG) // cents_norm // centsC.
rewrite !mul_subG 1?commGC //.
apply: subset_trans (commgS _ (subsetIr _ _)) _.
rewrite -quotient_cents2 ?subsetIl // centsC // cosetpreK //.
by rewrite (subset_trans (Ohm_sub _ _)) // subsetIr.
have nZX := subset_trans sXG nZG; have pX : p.-group gX by exact: pgroupS pG.
rewrite -quotient_sub1 ?(subset_trans (Phi_sub _)) //=.
have pXZ: p.-group (gX / 'Z(K)) by exact: morphim_pgroup.
rewrite (quotient_Phi pX nZX) subG1 (trivg_Phi pXZ).
apply: (abelemS (quotientS _ (subsetIr _ _))); rewrite /= cosetpreK /=.
have pZ: p.-group 'Z(G / 'Z(K)).
by rewrite (pgroupS (center_sub _)) ?morphim_pgroup.
by rewrite Ohm1_abelem ?center_abelian.
Qed.
Lemma critical_p_stab_Aut H :
critical H G -> p.-group G -> p.-group 'C(H | [Aut G]).
Proof.
move=> [chH sPhiZ sRZ eqCZ] pG; have sHG := char_sub chH.
pose G' := (sdpair1 [Aut G] @* G)%G; pose H' := (sdpair1 [Aut G] @* H)%G.
apply/pgroupP=> q pr_q; case/Cauchy=>//= f cHF; move: (cHF);rewrite astab_ract.
case/setIP=> Af cHFP ofq; rewrite -cycle_subG in cHF; apply: (pgroupP pG) => //.
pose F' := (sdpair2 [Aut G] @* <[f]>)%G.
have trHF: [~: H', F'] = 1.
apply/trivgP; rewrite gen_subG; apply/subsetP=> u; case/imset2P=> x' a'.
case/morphimP=> x Gx Hx ->; case/morphimP=> a Aa Fa -> -> {u x' a'}.
by rewrite inE commgEl -sdpair_act ?(astab_act (subsetP cHF _ Fa) Hx) ?mulVg.
have sGH_H: [~: G', H'] \subset H'.
by rewrite -morphimR ?(char_sub chH) // morphimS // commg_subr char_norm.
have{trHF sGH_H} trFGH: [~: F', G', H'] = 1.
apply: three_subgroup; last by rewrite trHF comm1G.
by apply/trivgP; rewrite -trHF commSg.
apply/negP=> qG; case: (qG); rewrite -ofq.
suffices ->: f = 1 by rewrite order1 dvd1n.
apply/permP=> x; rewrite perm1; case Gx: (x \in G); last first.
by apply: out_perm (negbT Gx); case/setIdP: Af.
have Gfx: f x \in G by rewrite -(im_autm Af) -{1}(autmE Af) mem_morphim.
pose y := x^-1 * f x; have Gy: y \in G by rewrite groupMl ?groupV.
have [inj1 inj2] := (injm_sdpair1 [Aut G], injm_sdpair2 [Aut G]).
have Hy: y \in H.
rewrite (subsetP (center_sub H)) // -eqCZ -cycle_subG.
rewrite -(injmSK inj1) ?cycle_subG // injm_subcent // subsetI.
rewrite morphimS ?morphim_cycle ?cycle_subG //=.
suffices: sdpair1 [Aut G] y \in [~: G', F'].
by rewrite commGC; apply: subsetP; exact/commG1P.
rewrite morphM ?groupV ?morphV //= sdpair_act // -commgEl.
by rewrite mem_commg ?mem_morphim ?cycle_id.
have fy: f y = y := astabP cHFP _ Hy.
have: (f ^+ q) x = x * y ^+ q.
elim: (q) => [|i IHi]; first by rewrite perm1 mulg1.
rewrite expgSr permM {}IHi -(autmE Af) morphM ?morphX ?groupX //= autmE.
by rewrite fy expgS mulgA mulKVg.
move/eqP; rewrite -{1}ofq expg_order perm1 eq_mulVg1 mulKg -order_dvdn.
case/primeP: pr_q => _ pr_q /pr_q; rewrite order_eq1 -eq_mulVg1.
by case: eqP => //= _ /eqP oyq; case: qG; rewrite -oyq order_dvdG.
Qed.
End SCN.
Implicit Arguments SCN_P [gT G A]. mathcomp-1.5/theories/ssrnum.v 0000644 0001750 0001750 00000457136 12307636117 015541 0 ustar gares gares (* (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 choice fintype.
Require Import bigop ssralg finset fingroup zmodp poly.
(******************************************************************************)
(* *)
(* This file defines some classes to manipulate number structures, i.e *)
(* structures with an order and a norm *)
(* *)
(* * NumDomain (Integral domain with an order and a norm) *)
(* NumMixin == the mixin that provides an order and a norm over *)
(* a ring and their characteristic properties. *)
(* numDomainType == interface for a num integral domain. *)
(* NumDomainType T m *)
(* == packs the num mixin into a numberDomainType. The *)
(* carrier T must have a integral domain structure. *)
(* [numDomainType of T for S ] *)
(* == T-clone of the numDomainType structure S. *)
(* [numDomainType of T] *)
(* == clone of a canonical numDomainType structure on T. *)
(* *)
(* * NumField (Field with an order and a norm) *)
(* numFieldType == interface for a num field. *)
(* [numFieldType of T] *)
(* == clone of a canonical numFieldType structure on T *)
(* *)
(* * NumClosedField (Closed Field with an order and a norm) *)
(* numClosedFieldType *)
(* == interface for a num closed field. *)
(* [numClosedFieldType of T] *)
(* == clone of a canonical numClosedFieldType structure on T *)
(* *)
(* * RealDomain (Num domain where all elements are positive or negative) *)
(* realDomainType == interface for a real integral domain. *)
(* RealDomainType T r *)
(* == packs the real axiom r into a realDomainType. The *)
(* carrier T must have a num domain structure. *)
(* [realDomainType of T for S ] *)
(* == T-clone of the realDomainType structure S. *)
(* [realDomainType of T] *)
(* == clone of a canonical realDomainType structure on T. *)
(* *)
(* * RealField (Num Field where all elements are positive or negative) *)
(* realFieldType == interface for a real field. *)
(* [realFieldType of T] *)
(* == clone of a canonical realFieldType structure on T *)
(* *)
(* * ArchiField (A Real Field with the archimedean axiom) *)
(* archiFieldType == interface for an archimedean field. *)
(* ArchiFieldType T r *)
(* == packs the archimeadean axiom r into an archiFieldType. *)
(* The carrier T must have a real field type structure. *)
(* [archiFieldType of T for S ] *)
(* == T-clone of the archiFieldType structure S. *)
(* [archiFieldType of T] *)
(* == clone of a canonical archiFieldType structure on T *)
(* *)
(* * RealClosedField (Real Field with the real closed axiom) *)
(* realClosedFieldType *)
(* == interface for a real closed field. *)
(* RealClosedFieldType T r *)
(* == packs the real closed axiom r into a *)
(* realClodedFieldType. The carrier T must have a real *)
(* field type structure. *)
(* [realClosedFieldType of T for S ] *)
(* == T-clone of the realClosedFieldType structure S. *)
(* [realClosedFieldype of T] *)
(* == clone of a canonical realClosedFieldType structure on *)
(* T. *)
(* *)
(* Over these structures, we have the following operations *)
(* `|x| == norm of x. *)
(* x <= y <=> x is less than or equal to y (:= '|y - x| == y - x). *)
(* x < y <=> x is less than y (:= (x <= y) && (x != y)). *)
(* x <= y ?= iff C <-> x is less than y, or equal iff C is true. *)
(* Num.sg x == sign of x: equal to 0 iff x = 0, to 1 iff x > 0, and *)
(* to -1 in all other cases (including x < 0). *)
(* x \is a Num.pos <=> x is positive (:= x > 0). *)
(* x \is a Num.neg <=> x is negative (:= x < 0). *)
(* x \is a Num.nneg <=> x is positive or 0 (:= x >= 0). *)
(* x \is a Num.real <=> x is real (:= x >= 0 or x < 0). *)
(* Num.min x y == minimum of x y *)
(* Num.max x y == maximum of x y *)
(* Num.bound x == in archimedean fields, and upper bound for x, i.e., *)
(* and n such that `|x| < n%:R. *)
(* Num.sqrt x == in a real-closed field, a positive square root of x if *)
(* x >= 0, or 0 otherwise. *)
(* *)
(* There are now three distinct uses of the symbols <, <=, > and >=: *)
(* 0-ary, unary (prefix) and binary (infix). *)
(* 0. <%R, <=%R, >%R, >=%R stand respectively for lt, le, gt and ge. *)
(* 1. (< x), (<= x), (> x), (>= x) stand respectively for *)
(* (gt x), (ge x), (lt x), (le x). *)
(* So (< x) is a predicate characterizing elements smaller than x. *)
(* 2. (x < y), (x <= y), ... mean what they are expected to. *)
(* These convention are compatible with haskell's, *)
(* where ((< y) x) = (x < y) = ((<) x y), *)
(* except that we write <%R instead of (<). *)
(* *)
(* - list of prefixes : *)
(* p : positive *)
(* n : negative *)
(* sp : strictly positive *)
(* sn : strictly negative *)
(* i : interior = in [0, 1] or ]0, 1[ *)
(* e : exterior = in [1, +oo[ or ]1; +oo[ *)
(* w : non strict (weak) monotony *)
(* *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Local Open Scope ring_scope.
Import GRing.Theory.
Reserved Notation "<= y" (at level 35).
Reserved Notation ">= y" (at level 35).
Reserved Notation "< y" (at level 35).
Reserved Notation "> y" (at level 35).
Reserved Notation "<= y :> T" (at level 35, y at next level).
Reserved Notation ">= y :> T" (at level 35, y at next level).
Reserved Notation "< y :> T" (at level 35, y at next level).
Reserved Notation "> y :> T" (at level 35, y at next level).
Module Num.
(* Principal mixin; further classes add axioms rather than operations. *)
Record mixin_of (R : ringType) := Mixin {
norm_op : R -> R;
le_op : rel R;
lt_op : rel R;
_ : forall x y, le_op (norm_op (x + y)) (norm_op x + norm_op y);
_ : forall x y, lt_op 0 x -> lt_op 0 y -> lt_op 0 (x + y);
_ : forall x, norm_op x = 0 -> x = 0;
_ : forall x y, le_op 0 x -> le_op 0 y -> le_op x y || le_op y x;
_ : {morph norm_op : x y / x * y};
_ : forall x y, (le_op x y) = (norm_op (y - x) == y - x);
_ : forall x y, (lt_op x y) = (y != x) && (le_op x y)
}.
Local Notation ring_for T b := (@GRing.Ring.Pack T b T).
(* Base interface. *)
Module NumDomain.
Section ClassDef.
Record class_of T := Class {
base : GRing.IntegralDomain.class_of T;
mixin : mixin_of (ring_for T base)
}.
Local Coercion base : class_of >-> GRing.IntegralDomain.class_of.
Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).
Definition clone c of phant_id class c := @Pack T c T.
Definition pack b0 (m0 : mixin_of (ring_for T b0)) :=
fun bT b & phant_id (GRing.IntegralDomain.class bT) b =>
fun m & phant_id m0 m => Pack (@Class T b m) T.
Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
End ClassDef.
Module Exports.
Coercion base : class_of >-> GRing.IntegralDomain.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Notation numDomainType := type.
Notation NumMixin := Mixin.
Notation NumDomainType T m := (@pack T _ m _ _ id _ id).
Notation "[ 'numDomainType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
(at level 0, format "[ 'numDomainType' 'of' T 'for' cT ]") : form_scope.
Notation "[ 'numDomainType' 'of' T ]" := (@clone T _ _ id)
(at level 0, format "[ 'numDomainType' 'of' T ]") : form_scope.
End Exports.
End NumDomain.
Import NumDomain.Exports.
Module Import Def. Section Def.
Import NumDomain.
Context {R : type}.
Implicit Types (x y : R) (C : bool).
Definition normr : R -> R := norm_op (class R).
Definition ler : rel R := le_op (class R).
Definition ltr : rel R := lt_op (class R).
Local Notation "x <= y" := (ler x y) : ring_scope.
Local Notation "x < y" := (ltr x y) : ring_scope.
Definition ger : simpl_rel R := [rel x y | y <= x].
Definition gtr : simpl_rel R := [rel x y | y < x].
Definition lerif x y C : Prop := ((x <= y) * ((x == y) = C))%type.
Definition sgr x : R := if x == 0 then 0 else if x < 0 then -1 else 1.
Definition minr x y : R := if x <= y then x else y.
Definition maxr x y : R := if y <= x then x else y.
Definition Rpos : qualifier 0 R := [qualify x : R | 0 < x].
Definition Rneg : qualifier 0 R := [qualify x : R | x < 0].
Definition Rnneg : qualifier 0 R := [qualify x : R | 0 <= x].
Definition Rreal : qualifier 0 R := [qualify x : R | (0 <= x) || (x <= 0)].
End Def. End Def.
(* Shorter qualified names, when Num.Def is not imported. *)
Notation norm := normr.
Notation le := ler.
Notation lt := ltr.
Notation ge := ger.
Notation gt := gtr.
Notation sg := sgr.
Notation max := maxr.
Notation min := minr.
Notation pos := Rpos.
Notation neg := Rneg.
Notation nneg := Rnneg.
Notation real := Rreal.
Module Keys. Section Keys.
Variable R : numDomainType.
Fact Rpos_key : pred_key (@pos R). Proof. by []. Qed.
Definition Rpos_keyed := KeyedQualifier Rpos_key.
Fact Rneg_key : pred_key (@real R). Proof. by []. Qed.
Definition Rneg_keyed := KeyedQualifier Rneg_key.
Fact Rnneg_key : pred_key (@nneg R). Proof. by []. Qed.
Definition Rnneg_keyed := KeyedQualifier Rnneg_key.
Fact Rreal_key : pred_key (@real R). Proof. by []. Qed.
Definition Rreal_keyed := KeyedQualifier Rreal_key.
Definition ler_of_leif x y C (le_xy : @lerif R x y C) := le_xy.1 : le x y.
End Keys. End Keys.
(* (Exported) symbolic syntax. *)
Module Import Syntax.
Import Def Keys.
Notation "`| x |" := (norm x) : ring_scope.
Notation "<%R" := lt : ring_scope.
Notation ">%R" := gt : ring_scope.
Notation "<=%R" := le : ring_scope.
Notation ">=%R" := ge : ring_scope.
Notation " T" := (< (y : T)) : ring_scope.
Notation "> y" := (lt y) : ring_scope.
Notation "> y :> T" := (> (y : T)) : ring_scope.
Notation "<= y" := (ge y) : ring_scope.
Notation "<= y :> T" := (<= (y : T)) : ring_scope.
Notation ">= y" := (le y) : ring_scope.
Notation ">= y :> T" := (>= (y : T)) : ring_scope.
Notation "x < y" := (lt x y) : ring_scope.
Notation "x < y :> T" := ((x : T) < (y : T)) : ring_scope.
Notation "x > y" := (y < x) (only parsing) : ring_scope.
Notation "x > y :> T" := ((x : T) > (y : T)) (only parsing) : ring_scope.
Notation "x <= y" := (le x y) : ring_scope.
Notation "x <= y :> T" := ((x : T) <= (y : T)) : ring_scope.
Notation "x >= y" := (y <= x) (only parsing) : ring_scope.
Notation "x >= y :> T" := ((x : T) >= (y : T)) (only parsing) : ring_scope.
Notation "x <= y <= z" := ((x <= y) && (y <= z)) : ring_scope.
Notation "x < y <= z" := ((x < y) && (y <= z)) : ring_scope.
Notation "x <= y < z" := ((x <= y) && (y < z)) : ring_scope.
Notation "x < y < z" := ((x < y) && (y < z)) : ring_scope.
Notation "x <= y ?= 'iff' C" := (lerif x y C) : ring_scope.
Notation "x <= y ?= 'iff' C :> R" := ((x : R) <= (y : R) ?= iff C)
(only parsing) : ring_scope.
Coercion ler_of_leif : lerif >-> is_true.
Canonical Rpos_keyed.
Canonical Rneg_keyed.
Canonical Rnneg_keyed.
Canonical Rreal_keyed.
End Syntax.
Section ExtensionAxioms.
Variable R : numDomainType.
Definition real_axiom : Prop := forall x : R, x \is real.
Definition archimedean_axiom : Prop := forall x : R, exists ub, `|x| < ub%:R.
Definition real_closed_axiom : Prop :=
forall (p : {poly R}) (a b : R),
a <= b -> p.[a] <= 0 <= p.[b] -> exists2 x, a <= x <= b & root p x.
End ExtensionAxioms.
Local Notation num_for T b := (@NumDomain.Pack T b T).
(* The rest of the numbers interface hierarchy. *)
Module NumField.
Section ClassDef.
Record class_of R :=
Class { base : GRing.Field.class_of R; mixin : mixin_of (ring_for R base) }.
Definition base2 R (c : class_of R) := NumDomain.Class (mixin c).
Local Coercion base : class_of >-> GRing.Field.class_of.
Local Coercion base2 : class_of >-> NumDomain.class_of.
Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).
Definition pack :=
fun bT b & phant_id (GRing.Field.class bT) (b : GRing.Field.class_of T) =>
fun mT m & phant_id (NumDomain.class mT) (@NumDomain.Class T b m) =>
Pack (@Class T b m) T.
Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
Definition numDomainType := @NumDomain.Pack cT xclass xT.
Definition fieldType := @GRing.Field.Pack cT xclass xT.
Definition join_numDomainType := @NumDomain.Pack fieldType xclass xT.
End ClassDef.
Module Exports.
Coercion base : class_of >-> GRing.Field.class_of.
Coercion base2 : class_of >-> NumDomain.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Coercion numDomainType : type >-> NumDomain.type.
Canonical numDomainType.
Coercion fieldType : type >-> GRing.Field.type.
Canonical fieldType.
Notation numFieldType := type.
Notation "[ 'numFieldType' 'of' T ]" := (@pack T _ _ id _ _ id)
(at level 0, format "[ 'numFieldType' 'of' T ]") : form_scope.
End Exports.
End NumField.
Import NumField.Exports.
Module ClosedField.
Section ClassDef.
Record class_of R := Class {
base : GRing.ClosedField.class_of R;
mixin : mixin_of (ring_for R base)
}.
Definition base2 R (c : class_of R) := NumField.Class (mixin c).
Local Coercion base : class_of >-> GRing.ClosedField.class_of.
Local Coercion base2 : class_of >-> NumField.class_of.
Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).
Definition pack :=
fun bT b & phant_id (GRing.ClosedField.class bT)
(b : GRing.ClosedField.class_of T) =>
fun mT m & phant_id (NumField.class mT) (@NumField.Class T b m) =>
Pack (@Class T b m) T.
Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
Definition numDomainType := @NumDomain.Pack cT xclass xT.
Definition fieldType := @GRing.Field.Pack cT xclass xT.
Definition decFieldType := @GRing.DecidableField.Pack cT xclass xT.
Definition closedFieldType := @GRing.ClosedField.Pack cT xclass xT.
Definition join_dec_numDomainType := @NumDomain.Pack decFieldType xclass xT.
Definition join_dec_numFieldType := @NumField.Pack decFieldType xclass xT.
Definition join_numDomainType := @NumDomain.Pack closedFieldType xclass xT.
Definition join_numFieldType := @NumField.Pack closedFieldType xclass xT.
End ClassDef.
Module Exports.
Coercion base : class_of >-> GRing.ClosedField.class_of.
Coercion base2 : class_of >-> NumField.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Coercion numDomainType : type >-> NumDomain.type.
Canonical numDomainType.
Coercion fieldType : type >-> GRing.Field.type.
Canonical fieldType.
Coercion decFieldType : type >-> GRing.DecidableField.type.
Canonical decFieldType.
Coercion closedFieldType : type >-> GRing.ClosedField.type.
Canonical closedFieldType.
Canonical join_dec_numDomainType.
Canonical join_dec_numFieldType.
Canonical join_numDomainType.
Canonical join_numFieldType.
Notation numClosedFieldType := type.
Notation "[ 'numClosedFieldType' 'of' T ]" := (@pack T _ _ id _ _ id)
(at level 0, format "[ 'numClosedFieldType' 'of' T ]") : form_scope.
End Exports.
End ClosedField.
Import ClosedField.Exports.
Module RealDomain.
Section ClassDef.
Record class_of R :=
Class {base : NumDomain.class_of R; _ : @real_axiom (num_for R base)}.
Local Coercion base : class_of >-> NumDomain.class_of.
Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).
Definition clone c of phant_id class c := @Pack T c T.
Definition pack b0 (m0 : real_axiom (num_for T b0)) :=
fun bT b & phant_id (NumDomain.class bT) b =>
fun m & phant_id m0 m => Pack (@Class T b m) T.
Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
Definition numDomainType := @NumDomain.Pack cT xclass xT.
End ClassDef.
Module Exports.
Coercion base : class_of >-> NumDomain.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Coercion numDomainType : type >-> NumDomain.type.
Canonical numDomainType.
Notation realDomainType := type.
Notation RealDomainType T m := (@pack T _ m _ _ id _ id).
Notation "[ 'realDomainType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
(at level 0, format "[ 'realDomainType' 'of' T 'for' cT ]") : form_scope.
Notation "[ 'realDomainType' 'of' T ]" := (@clone T _ _ id)
(at level 0, format "[ 'realDomainType' 'of' T ]") : form_scope.
End Exports.
End RealDomain.
Import RealDomain.Exports.
Module RealField.
Section ClassDef.
Record class_of R :=
Class { base : NumField.class_of R; mixin : real_axiom (num_for R base) }.
Definition base2 R (c : class_of R) := RealDomain.Class (@mixin R c).
Local Coercion base : class_of >-> NumField.class_of.
Local Coercion base2 : class_of >-> RealDomain.class_of.
Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).
Definition pack :=
fun bT b & phant_id (NumField.class bT) (b : NumField.class_of T) =>
fun mT m & phant_id (RealDomain.class mT) (@RealDomain.Class T b m) =>
Pack (@Class T b m) T.
Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
Definition numDomainType := @NumDomain.Pack cT xclass xT.
Definition realDomainType := @RealDomain.Pack cT xclass xT.
Definition fieldType := @GRing.Field.Pack cT xclass xT.
Definition numFieldType := @NumField.Pack cT xclass xT.
Definition join_realDomainType := @RealDomain.Pack numFieldType xclass xT.
End ClassDef.
Module Exports.
Coercion base : class_of >-> NumField.class_of.
Coercion base2 : class_of >-> RealDomain.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Coercion numDomainType : type >-> NumDomain.type.
Canonical numDomainType.
Coercion realDomainType : type >-> RealDomain.type.
Canonical realDomainType.
Coercion fieldType : type >-> GRing.Field.type.
Canonical fieldType.
Coercion numFieldType : type >-> NumField.type.
Canonical numFieldType.
Canonical join_realDomainType.
Notation realFieldType := type.
Notation "[ 'realFieldType' 'of' T ]" := (@pack T _ _ id _ _ id)
(at level 0, format "[ 'realFieldType' 'of' T ]") : form_scope.
End Exports.
End RealField.
Import RealField.Exports.
Module ArchimedeanField.
Section ClassDef.
Record class_of R :=
Class { base : RealField.class_of R; _ : archimedean_axiom (num_for R base) }.
Local Coercion base : class_of >-> RealField.class_of.
Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).
Definition clone c of phant_id class c := @Pack T c T.
Definition pack b0 (m0 : archimedean_axiom (num_for T b0)) :=
fun bT b & phant_id (RealField.class bT) b =>
fun m & phant_id m0 m => Pack (@Class T b m) T.
Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
Definition numDomainType := @NumDomain.Pack cT xclass xT.
Definition realDomainType := @RealDomain.Pack cT xclass xT.
Definition fieldType := @GRing.Field.Pack cT xclass xT.
Definition numFieldType := @NumField.Pack cT xclass xT.
Definition realFieldType := @RealField.Pack cT xclass xT.
End ClassDef.
Module Exports.
Coercion base : class_of >-> RealField.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Coercion numDomainType : type >-> NumDomain.type.
Canonical numDomainType.
Coercion realDomainType : type >-> RealDomain.type.
Canonical realDomainType.
Coercion fieldType : type >-> GRing.Field.type.
Canonical fieldType.
Coercion numFieldType : type >-> NumField.type.
Canonical numFieldType.
Coercion realFieldType : type >-> RealField.type.
Canonical realFieldType.
Notation archiFieldType := type.
Notation ArchiFieldType T m := (@pack T _ m _ _ id _ id).
Notation "[ 'archiFieldType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
(at level 0, format "[ 'archiFieldType' 'of' T 'for' cT ]") : form_scope.
Notation "[ 'archiFieldType' 'of' T ]" := (@clone T _ _ id)
(at level 0, format "[ 'archiFieldType' 'of' T ]") : form_scope.
End Exports.
End ArchimedeanField.
Import ArchimedeanField.Exports.
Module RealClosedField.
Section ClassDef.
Record class_of R :=
Class { base : RealField.class_of R; _ : real_closed_axiom (num_for R base) }.
Local Coercion base : class_of >-> RealField.class_of.
Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).
Definition clone c of phant_id class c := @Pack T c T.
Definition pack b0 (m0 : real_closed_axiom (num_for T b0)) :=
fun bT b & phant_id (RealField.class bT) b =>
fun m & phant_id m0 m => Pack (@Class T b m) T.
Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
Definition numDomainType := @NumDomain.Pack cT xclass xT.
Definition realDomainType := @RealDomain.Pack cT xclass xT.
Definition fieldType := @GRing.Field.Pack cT xclass xT.
Definition numFieldType := @NumField.Pack cT xclass xT.
Definition realFieldType := @RealField.Pack cT xclass xT.
End ClassDef.
Module Exports.
Coercion base : class_of >-> RealField.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Coercion numDomainType : type >-> NumDomain.type.
Canonical numDomainType.
Coercion realDomainType : type >-> RealDomain.type.
Canonical realDomainType.
Coercion fieldType : type >-> GRing.Field.type.
Canonical fieldType.
Coercion numFieldType : type >-> NumField.type.
Canonical numFieldType.
Coercion realFieldType : type >-> RealField.type.
Canonical realFieldType.
Notation rcfType := Num.RealClosedField.type.
Notation RcfType T m := (@pack T _ m _ _ id _ id).
Notation "[ 'rcfType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
(at level 0, format "[ 'rcfType' 'of' T 'for' cT ]") : form_scope.
Notation "[ 'rcfType' 'of' T ]" := (@clone T _ _ id)
(at level 0, format "[ 'rcfType' 'of' T ]") : form_scope.
End Exports.
End RealClosedField.
Import RealClosedField.Exports.
(* The elementary theory needed to support the definition of the derived *)
(* operations for the extensions described above. *)
Module Import Internals.
Section Domain.
Variable R : numDomainType.
Implicit Types x y : R.
(* Lemmas from the signature *)
Lemma normr0_eq0 x : `|x| = 0 -> x = 0.
Proof. by case: R x => ? [? []]. Qed.
Lemma ler_norm_add x y : `|x + y| <= `|x| + `|y|.
Proof. by case: R x y => ? [? []]. Qed.
Lemma addr_gt0 x y : 0 < x -> 0 < y -> 0 < x + y.
Proof. by case: R x y => ? [? []]. Qed.
Lemma ger_leVge x y : 0 <= x -> 0 <= y -> (x <= y) || (y <= x).
Proof. by case: R x y => ? [? []]. Qed.
Lemma normrM : {morph norm : x y / x * y : R}.
Proof. by case: R => ? [? []]. Qed.
Lemma ler_def x y : (x <= y) = (`|y - x| == y - x).
Proof. by case: R x y => ? [? []]. Qed.
Lemma ltr_def x y : (x < y) = (y != x) && (x <= y).
Proof. by case: R x y => ? [? []]. Qed.
(* Basic consequences (just enough to get predicate closure properties). *)
Lemma ger0_def x : (0 <= x) = (`|x| == x).
Proof. by rewrite ler_def subr0. Qed.
Lemma subr_ge0 x y : (0 <= x - y) = (y <= x).
Proof. by rewrite ger0_def -ler_def. Qed.
Lemma oppr_ge0 x : (0 <= - x) = (x <= 0).
Proof. by rewrite -sub0r subr_ge0. Qed.
Lemma ler01 : 0 <= 1 :> R.
Proof.
have n1_nz: `|1| != 0 :> R by apply: contraNneq (@oner_neq0 R) => /normr0_eq0->.
by rewrite ger0_def -(inj_eq (mulfI n1_nz)) -normrM !mulr1.
Qed.
Lemma ltr01 : 0 < 1 :> R. Proof. by rewrite ltr_def oner_neq0 ler01. Qed.
Lemma ltrW x y : x < y -> x <= y. Proof. by rewrite ltr_def => /andP[]. Qed.
Lemma lerr x : x <= x.
Proof.
have n2: `|2%:R| == 2%:R :> R by rewrite -ger0_def ltrW ?addr_gt0 ?ltr01.
rewrite ler_def subrr -(inj_eq (addrI `|0|)) addr0 -mulr2n -mulr_natr.
by rewrite -(eqP n2) -normrM mul0r.
Qed.
Lemma le0r x : (0 <= x) = (x == 0) || (0 < x).
Proof. by rewrite ltr_def; case: eqP => // ->; rewrite lerr. Qed.
Lemma addr_ge0 x y : 0 <= x -> 0 <= y -> 0 <= x + y.
Proof.
rewrite le0r; case/predU1P=> [-> | x_pos]; rewrite ?add0r // le0r.
by case/predU1P=> [-> | y_pos]; rewrite ltrW ?addr0 ?addr_gt0.
Qed.
Lemma pmulr_rgt0 x y : 0 < x -> (0 < x * y) = (0 < y).
Proof.
rewrite !ltr_def !ger0_def normrM mulf_eq0 negb_or => /andP[x_neq0 /eqP->].
by rewrite x_neq0 (inj_eq (mulfI x_neq0)).
Qed.
(* Closure properties of the real predicates. *)
Lemma posrE x : (x \is pos) = (0 < x). Proof. by []. Qed.
Lemma nnegrE x : (x \is nneg) = (0 <= x). Proof. by []. Qed.
Lemma realE x : (x \is real) = (0 <= x) || (x <= 0). Proof. by []. Qed.
Fact pos_divr_closed : divr_closed (@pos R).
Proof.
split=> [|x y x_gt0 y_gt0]; rewrite posrE ?ltr01 //.
have [Uy|/invr_out->] := boolP (y \is a GRing.unit); last by rewrite pmulr_rgt0.
by rewrite -(pmulr_rgt0 _ y_gt0) mulrC divrK.
Qed.
Canonical pos_mulrPred := MulrPred pos_divr_closed.
Canonical pos_divrPred := DivrPred pos_divr_closed.
Fact nneg_divr_closed : divr_closed (@nneg R).
Proof.
split=> [|x y]; rewrite !nnegrE ?ler01 ?le0r // -!posrE.
case/predU1P=> [-> _ | x_gt0]; first by rewrite mul0r eqxx.
by case/predU1P=> [-> | y_gt0]; rewrite ?invr0 ?mulr0 ?eqxx // orbC rpred_div.
Qed.
Canonical nneg_mulrPred := MulrPred nneg_divr_closed.
Canonical nneg_divrPred := DivrPred nneg_divr_closed.
Fact nneg_addr_closed : addr_closed (@nneg R).
Proof. by split; [exact: lerr | exact: addr_ge0]. Qed.
Canonical nneg_addrPred := AddrPred nneg_addr_closed.
Canonical nneg_semiringPred := SemiringPred nneg_divr_closed.
Fact real_oppr_closed : oppr_closed (@real R).
Proof. by move=> x; rewrite /= !realE oppr_ge0 orbC -!oppr_ge0 opprK. Qed.
Canonical real_opprPred := OpprPred real_oppr_closed.
Fact real_addr_closed : addr_closed (@real R).
Proof.
split=> [|x y Rx Ry]; first by rewrite realE lerr.
without loss{Rx} x_ge0: x y Ry / 0 <= x.
case/orP: Rx => [? | x_le0]; first exact.
by rewrite -rpredN opprD; apply; rewrite ?rpredN ?oppr_ge0.
case/orP: Ry => [y_ge0 | y_le0]; first by rewrite realE -nnegrE rpredD.
by rewrite realE -[y]opprK orbC -oppr_ge0 opprB !subr_ge0 ger_leVge ?oppr_ge0.
Qed.
Canonical real_addrPred := AddrPred real_addr_closed.
Canonical real_zmodPred := ZmodPred real_oppr_closed.
Fact real_divr_closed : divr_closed (@real R).
Proof.
split=> [|x y Rx Ry]; first by rewrite realE ler01.
without loss{Rx} x_ge0: x / 0 <= x.
case/orP: Rx => [? | x_le0]; first exact.
by rewrite -rpredN -mulNr; apply; rewrite ?oppr_ge0.
without loss{Ry} y_ge0: y / 0 <= y; last by rewrite realE -nnegrE rpred_div.
case/orP: Ry => [? | y_le0]; first exact.
by rewrite -rpredN -mulrN -invrN; apply; rewrite ?oppr_ge0.
Qed.
Canonical real_mulrPred := MulrPred real_divr_closed.
Canonical real_smulrPred := SmulrPred real_divr_closed.
Canonical real_divrPred := DivrPred real_divr_closed.
Canonical real_sdivrPred := SdivrPred real_divr_closed.
Canonical real_semiringPred := SemiringPred real_divr_closed.
Canonical real_subringPred := SubringPred real_divr_closed.
Canonical real_divringPred := DivringPred real_divr_closed.
End Domain.
Lemma num_real (R : realDomainType) (x : R) : x \is real.
Proof. by case: R x => T []. Qed.
Fact archi_bound_subproof (R : archiFieldType) : archimedean_axiom R.
Proof. by case: R => ? []. Qed.
Section RealClosed.
Variable R : rcfType.
Lemma poly_ivt : real_closed_axiom R. Proof. by case: R => ? []. Qed.
Fact sqrtr_subproof (x : R) :
exists2 y, 0 <= y & if 0 <= x return bool then y ^+ 2 == x else y == 0.
Proof.
case x_ge0: (0 <= x); last by exists 0; rewrite ?lerr.
have le0x1: 0 <= x + 1 by rewrite -nnegrE rpredD ?rpred1.
have [|y /andP[y_ge0 _]] := @poly_ivt ('X^2 - x%:P) _ _ le0x1.
rewrite !hornerE -subr_ge0 add0r opprK x_ge0 -expr2 sqrrD mulr1.
by rewrite addrAC !addrA addrK -nnegrE !rpredD ?rpredX ?rpred1.
by rewrite rootE !hornerE subr_eq0; exists y.
Qed.
End RealClosed.
End Internals.
Module PredInstances.
Canonical pos_mulrPred.
Canonical pos_divrPred.
Canonical nneg_addrPred.
Canonical nneg_mulrPred.
Canonical nneg_divrPred.
Canonical nneg_semiringPred.
Canonical real_addrPred.
Canonical real_opprPred.
Canonical real_zmodPred.
Canonical real_mulrPred.
Canonical real_smulrPred.
Canonical real_divrPred.
Canonical real_sdivrPred.
Canonical real_semiringPred.
Canonical real_subringPred.
Canonical real_divringPred.
End PredInstances.
Module Import ExtraDef.
Definition archi_bound {R} x := sval (sigW (@archi_bound_subproof R x)).
Definition sqrtr {R} x := s2val (sig2W (@sqrtr_subproof R x)).
End ExtraDef.
Notation bound := archi_bound.
Notation sqrt := sqrtr.
Module Theory.
Section NumIntegralDomainTheory.
Variable R : numDomainType.
Implicit Types x y z t : R.
(* Lemmas from the signature (reexported from internals). *)
Definition ler_norm_add x y : `|x + y| <= `|x| + `|y| := ler_norm_add x y.
Definition addr_gt0 x y : 0 < x -> 0 < y -> 0 < x + y := @addr_gt0 R x y.
Definition normr0_eq0 x : `|x| = 0 -> x = 0 := @normr0_eq0 R x.
Definition ger_leVge x y : 0 <= x -> 0 <= y -> (x <= y) || (y <= x) :=
@ger_leVge R x y.
Definition normrM : {morph normr : x y / x * y : R} := @normrM R.
Definition ler_def x y : (x <= y) = (`|y - x| == y - x) := @ler_def R x y.
Definition ltr_def x y : (x < y) = (y != x) && (x <= y) := @ltr_def R x y.
(* Predicate and relation definitions. *)
Lemma gerE x y : ge x y = (y <= x). Proof. by []. Qed.
Lemma gtrE x y : gt x y = (y < x). Proof. by []. Qed.
Lemma posrE x : (x \is pos) = (0 < x). Proof. by []. Qed.
Lemma negrE x : (x \is neg) = (x < 0). Proof. by []. Qed.
Lemma nnegrE x : (x \is nneg) = (0 <= x). Proof. by []. Qed.
Lemma realE x : (x \is real) = (0 <= x) || (x <= 0). Proof. by []. Qed.
(* General properties of <= and < *)
Lemma lerr x : x <= x. Proof. exact: lerr. Qed.
Lemma ltrr x : x < x = false. Proof. by rewrite ltr_def eqxx. Qed.
Lemma ltrW x y : x < y -> x <= y. Proof. exact: ltrW. Qed.
Hint Resolve lerr ltrr ltrW.
Lemma ltr_neqAle x y : (x < y) = (x != y) && (x <= y).
Proof. by rewrite ltr_def eq_sym. Qed.
Lemma ler_eqVlt x y : (x <= y) = (x == y) || (x < y).
Proof. by rewrite ltr_neqAle; case: eqP => // ->; rewrite lerr. Qed.
Lemma lt0r x : (0 < x) = (x != 0) && (0 <= x). Proof. by rewrite ltr_def. Qed.
Lemma le0r x : (0 <= x) = (x == 0) || (0 < x). Proof. exact: le0r. Qed.
Lemma lt0r_neq0 (x : R) : 0 < x -> x != 0.
Proof. by rewrite lt0r; case/andP. Qed.
Lemma ltr0_neq0 (x : R) : 0 < x -> x != 0.
Proof. by rewrite lt0r; case/andP. Qed.
Lemma gtr_eqF x y : y < x -> x == y = false.
Proof. by rewrite ltr_def; case/andP; move/negPf=> ->. Qed.
Lemma ltr_eqF x y : x < y -> x == y = false.
Proof. by move=> hyx; rewrite eq_sym gtr_eqF. Qed.
Lemma pmulr_rgt0 x y : 0 < x -> (0 < x * y) = (0 < y).
Proof. exact: pmulr_rgt0. Qed.
Lemma pmulr_rge0 x y : 0 < x -> (0 <= x * y) = (0 <= y).
Proof.
by rewrite !le0r mulf_eq0; case: eqP => // [-> /negPf[] | _ /pmulr_rgt0->].
Qed.
(* Integer comparisons and characteristic 0. *)
Lemma ler01 : 0 <= 1 :> R. Proof. exact: ler01. Qed.
Lemma ltr01 : 0 < 1 :> R. Proof. exact: ltr01. Qed.
Lemma ler0n n : 0 <= n%:R :> R. Proof. by rewrite -nnegrE rpred_nat. Qed.
Hint Resolve ler01 ltr01 ler0n.
Lemma ltr0Sn n : 0 < n.+1%:R :> R.
Proof. by elim: n => // n; apply: addr_gt0. Qed.
Lemma ltr0n n : (0 < n%:R :> R) = (0 < n)%N.
Proof. by case: n => //= n; apply: ltr0Sn. Qed.
Hint Resolve ltr0Sn.
Lemma pnatr_eq0 n : (n%:R == 0 :> R) = (n == 0)%N.
Proof. by case: n => [|n]; rewrite ?mulr0n ?eqxx // gtr_eqF. Qed.
Lemma char_num : [char R] =i pred0.
Proof. by case=> // p /=; rewrite !inE pnatr_eq0 andbF. Qed.
(* Properties of the norm. *)
Lemma ger0_def x : (0 <= x) = (`|x| == x). Proof. exact: ger0_def. Qed.
Lemma normr_idP {x} : reflect (`|x| = x) (0 <= x).
Proof. by rewrite ger0_def; apply: eqP. Qed.
Lemma ger0_norm x : 0 <= x -> `|x| = x. Proof. exact: normr_idP. Qed.
Lemma normr0 : `|0| = 0 :> R. Proof. exact: ger0_norm. Qed.
Lemma normr1 : `|1| = 1 :> R. Proof. exact: ger0_norm. Qed.
Lemma normr_nat n : `|n%:R| = n%:R :> R. Proof. exact: ger0_norm. Qed.
Lemma normrMn x n : `|x *+ n| = `|x| *+ n.
Proof. by rewrite -mulr_natl normrM normr_nat mulr_natl. Qed.
Lemma normr_prod I r (P : pred I) (F : I -> R) :
`|\prod_(i <- r | P i) F i| = \prod_(i <- r | P i) `|F i|.
Proof. exact: (big_morph norm normrM normr1). Qed.
Lemma normrX n x : `|x ^+ n| = `|x| ^+ n.
Proof. by rewrite -(card_ord n) -!prodr_const normr_prod. Qed.
Lemma normr_unit : {homo (@norm R) : x / x \is a GRing.unit}.
Proof.
move=> x /= /unitrP [y [yx xy]]; apply/unitrP; exists `|y|.
by rewrite -!normrM xy yx normr1.
Qed.
Lemma normrV : {in GRing.unit, {morph (@normr R) : x / x ^-1}}.
Proof.
move=> x ux; apply: (mulrI (normr_unit ux)).
by rewrite -normrM !divrr ?normr1 ?normr_unit.
Qed.
Lemma normr0P {x} : reflect (`|x| = 0) (x == 0).
Proof. by apply: (iffP eqP)=> [->|/normr0_eq0 //]; apply: normr0. Qed.
Definition normr_eq0 x := sameP (`|x| =P 0) normr0P.
Lemma normrN1 : `|-1| = 1 :> R.
Proof.
have: `|-1| ^+ 2 == 1 :> R by rewrite -normrX -signr_odd normr1.
rewrite sqrf_eq1 => /orP[/eqP //|]; rewrite -ger0_def le0r oppr_eq0 oner_eq0.
by move/(addr_gt0 ltr01); rewrite subrr ltrr.
Qed.
Lemma normrN x : `|- x| = `|x|.
Proof. by rewrite -mulN1r normrM normrN1 mul1r. Qed.
Lemma distrC x y : `|x - y| = `|y - x|.
Proof. by rewrite -opprB normrN. Qed.
Lemma ler0_def x : (x <= 0) = (`|x| == - x).
Proof. by rewrite ler_def sub0r normrN. Qed.
Lemma normr_id x : `|`|x| | = `|x|.
Proof.
have nz2: 2%:R != 0 :> R by rewrite pnatr_eq0.
apply: (mulfI nz2); rewrite -{1}normr_nat -normrM mulr_natl mulr2n ger0_norm //.
by rewrite -{2}normrN -normr0 -(subrr x) ler_norm_add.
Qed.
Lemma normr_ge0 x : 0 <= `|x|. Proof. by rewrite ger0_def normr_id. Qed.
Hint Resolve normr_ge0.
Lemma ler0_norm x : x <= 0 -> `|x| = - x.
Proof. by move=> x_le0; rewrite -[r in _ = r]ger0_norm ?normrN ?oppr_ge0. Qed.
Definition gtr0_norm x (hx : 0 < x) := ger0_norm (ltrW hx).
Definition ltr0_norm x (hx : x < 0) := ler0_norm (ltrW hx).
(* Comparision to 0 of a difference *)
Lemma subr_ge0 x y : (0 <= y - x) = (x <= y). Proof. exact: subr_ge0. Qed.
Lemma subr_gt0 x y : (0 < y - x) = (x < y).
Proof. by rewrite !ltr_def subr_eq0 subr_ge0. Qed.
Lemma subr_le0 x y : (y - x <= 0) = (y <= x).
Proof. by rewrite -subr_ge0 opprB add0r subr_ge0. Qed.
Lemma subr_lt0 x y : (y - x < 0) = (y < x).
Proof. by rewrite -subr_gt0 opprB add0r subr_gt0. Qed.
Definition subr_lte0 := (subr_le0, subr_lt0).
Definition subr_gte0 := (subr_ge0, subr_gt0).
Definition subr_cp0 := (subr_lte0, subr_gte0).
(* Ordered ring properties. *)
Lemma ler_asym : antisymmetric (<=%R : rel R).
Proof.
move=> x y; rewrite !ler_def distrC -opprB -addr_eq0 => /andP[/eqP->].
by rewrite -mulr2n -mulr_natl mulf_eq0 subr_eq0 pnatr_eq0 => /eqP.
Qed.
Lemma eqr_le x y : (x == y) = (x <= y <= x).
Proof. by apply/eqP/idP=> [->|/ler_asym]; rewrite ?lerr. Qed.
Lemma ltr_trans : transitive (@ltr R).
Proof.
move=> y x z le_xy le_yz.
by rewrite -subr_gt0 -(subrK y z) -addrA addr_gt0 ?subr_gt0.
Qed.
Lemma ler_lt_trans y x z : x <= y -> y < z -> x < z.
Proof. by rewrite !ler_eqVlt => /orP[/eqP -> //|/ltr_trans]; apply. Qed.
Lemma ltr_le_trans y x z : x < y -> y <= z -> x < z.
Proof. by rewrite !ler_eqVlt => lxy /orP[/eqP <- //|/(ltr_trans lxy)]. Qed.
Lemma ler_trans : transitive (@ler R).
Proof.
move=> y x z; rewrite !ler_eqVlt => /orP [/eqP -> //|lxy].
by move=> /orP [/eqP <-|/(ltr_trans lxy) ->]; rewrite ?lxy orbT.
Qed.
Definition lter01 := (ler01, ltr01).
Definition lterr := (lerr, ltrr).
Lemma addr_ge0 x y : 0 <= x -> 0 <= y -> 0 <= x + y.
Proof. exact: addr_ge0. Qed.
Lemma lerifP x y C : reflect (x <= y ?= iff C) (if C then x == y else x < y).
Proof.
rewrite /lerif ler_eqVlt; apply: (iffP idP)=> [|[]].
by case: C => [/eqP->|lxy]; rewrite ?eqxx // lxy ltr_eqF.
by move=> /orP[/eqP->|lxy] <-; rewrite ?eqxx // ltr_eqF.
Qed.
Lemma ltr_asym x y : x < y < x = false.
Proof. by apply/negP=> /andP [/ltr_trans hyx /hyx]; rewrite ltrr. Qed.
Lemma ler_anti : antisymmetric (@ler R).
Proof. by move=> x y; rewrite -eqr_le=> /eqP. Qed.
Lemma ltr_le_asym x y : x < y <= x = false.
Proof. by rewrite ltr_neqAle -andbA -eqr_le eq_sym; case: (_ == _). Qed.
Lemma ler_lt_asym x y : x <= y < x = false.
Proof. by rewrite andbC ltr_le_asym. Qed.
Definition lter_anti := (=^~ eqr_le, ltr_asym, ltr_le_asym, ler_lt_asym).
Lemma ltr_geF x y : x < y -> (y <= x = false).
Proof.
by move=> xy; apply: contraTF isT=> /(ltr_le_trans xy); rewrite ltrr.
Qed.
Lemma ler_gtF x y : x <= y -> (y < x = false).
Proof. by apply: contraTF=> /ltr_geF->. Qed.
Definition ltr_gtF x y hxy := ler_gtF (@ltrW x y hxy).
(* Norm and order properties. *)
Lemma normr_le0 x : (`|x| <= 0) = (x == 0).
Proof. by rewrite -normr_eq0 eqr_le normr_ge0 andbT. Qed.
Lemma normr_lt0 x : `|x| < 0 = false.
Proof. by rewrite ltr_neqAle normr_le0 normr_eq0 andNb. Qed.
Lemma normr_gt0 x : (`|x| > 0) = (x != 0).
Proof. by rewrite ltr_def normr_eq0 normr_ge0 andbT. Qed.
Definition normrE x := (normr_id, normr0, normr1, normrN1, normr_ge0, normr_eq0,
normr_lt0, normr_le0, normr_gt0, normrN).
End NumIntegralDomainTheory.
Implicit Arguments ler01 [R].
Implicit Arguments ltr01 [R].
Implicit Arguments normr_idP [R x].
Implicit Arguments normr0P [R x].
Implicit Arguments lerifP [R x y C].
Hint Resolve @ler01 @ltr01 lerr ltrr ltrW ltr_eqF ltr0Sn ler0n normr_ge0.
Section NumIntegralDomainMonotonyTheory.
Variables R R' : numDomainType.
Implicit Types m n p : nat.
Implicit Types x y z : R.
Implicit Types u v w : R'.
Section AcrossTypes.
Variable D D' : pred R.
Variable (f : R -> R').
Lemma ltrW_homo : {homo f : x y / x < y} -> {homo f : x y / x <= y}.
Proof. by move=> mf x y /=; rewrite ler_eqVlt => /orP[/eqP->|/mf/ltrW]. Qed.
Lemma ltrW_nhomo : {homo f : x y /~ x < y} -> {homo f : x y /~ x <= y}.
Proof. by move=> mf x y /=; rewrite ler_eqVlt => /orP[/eqP->|/mf/ltrW]. Qed.
Lemma homo_inj_lt :
injective f -> {homo f : x y / x <= y} -> {homo f : x y / x < y}.
Proof.
by move=> fI mf x y /= hxy; rewrite ltr_neqAle (inj_eq fI) mf (ltr_eqF, ltrW).
Qed.
Lemma nhomo_inj_lt :
injective f -> {homo f : x y /~ x <= y} -> {homo f : x y /~ x < y}.
Proof.
by move=> fI mf x y /= hxy; rewrite ltr_neqAle (inj_eq fI) mf (gtr_eqF, ltrW).
Qed.
Lemma mono_inj : {mono f : x y / x <= y} -> injective f.
Proof. by move=> mf x y /eqP; rewrite eqr_le !mf -eqr_le=> /eqP. Qed.
Lemma nmono_inj : {mono f : x y /~ x <= y} -> injective f.
Proof. by move=> mf x y /eqP; rewrite eqr_le !mf -eqr_le=> /eqP. Qed.
Lemma lerW_mono : {mono f : x y / x <= y} -> {mono f : x y / x < y}.
Proof.
by move=> mf x y /=; rewrite !ltr_neqAle mf inj_eq //; apply: mono_inj.
Qed.
Lemma lerW_nmono : {mono f : x y /~ x <= y} -> {mono f : x y /~ x < y}.
Proof.
by move=> mf x y /=; rewrite !ltr_neqAle mf eq_sym inj_eq //; apply: nmono_inj.
Qed.
(* Monotony in D D' *)
Lemma ltrW_homo_in :
{in D & D', {homo f : x y / x < y}} -> {in D & D', {homo f : x y / x <= y}}.
Proof.
by move=> mf x y hx hy /=; rewrite ler_eqVlt => /orP[/eqP->|/mf/ltrW] //; apply.
Qed.
Lemma ltrW_nhomo_in :
{in D & D', {homo f : x y /~ x < y}} -> {in D & D', {homo f : x y /~ x <= y}}.
Proof.
by move=> mf x y hx hy /=; rewrite ler_eqVlt => /orP[/eqP->|/mf/ltrW] //; apply.
Qed.
Lemma homo_inj_in_lt :
{in D & D', injective f} -> {in D & D', {homo f : x y / x <= y}} ->
{in D & D', {homo f : x y / x < y}}.
Proof.
move=> fI mf x y hx hy /= hxy; rewrite ltr_neqAle; apply/andP; split.
by apply: contraTN hxy => /eqP /fI -> //; rewrite ltrr.
by rewrite mf // (ltr_eqF, ltrW).
Qed.
Lemma nhomo_inj_in_lt :
{in D & D', injective f} -> {in D & D', {homo f : x y /~ x <= y}} ->
{in D & D', {homo f : x y /~ x < y}}.
Proof.
move=> fI mf x y hx hy /= hxy; rewrite ltr_neqAle; apply/andP; split.
by apply: contraTN hxy => /eqP /fI -> //; rewrite ltrr.
by rewrite mf // (gtr_eqF, ltrW).
Qed.
Lemma mono_inj_in : {in D &, {mono f : x y / x <= y}} -> {in D &, injective f}.
Proof.
by move=> mf x y hx hy /= /eqP; rewrite eqr_le !mf // -eqr_le => /eqP.
Qed.
Lemma nmono_inj_in :
{in D &, {mono f : x y /~ x <= y}} -> {in D &, injective f}.
Proof.
by move=> mf x y hx hy /= /eqP; rewrite eqr_le !mf // -eqr_le => /eqP.
Qed.
Lemma lerW_mono_in :
{in D &, {mono f : x y / x <= y}} -> {in D &, {mono f : x y / x < y}}.
Proof.
move=> mf x y hx hy /=; rewrite !ltr_neqAle mf // (@inj_in_eq _ _ D) //.
exact: mono_inj_in.
Qed.
Lemma lerW_nmono_in :
{in D &, {mono f : x y /~ x <= y}} -> {in D &, {mono f : x y /~ x < y}}.
Proof.
move=> mf x y hx hy /=; rewrite !ltr_neqAle mf // eq_sym (@inj_in_eq _ _ D) //.
exact: nmono_inj_in.
Qed.
End AcrossTypes.
Section NatToR.
Variable (f : nat -> R).
Lemma ltn_ltrW_homo :
{homo f : m n / (m < n)%N >-> m < n} ->
{homo f : m n / (m <= n)%N >-> m <= n}.
Proof. by move=> mf m n /=; rewrite leq_eqVlt => /orP[/eqP->|/mf/ltrW //]. Qed.
Lemma ltn_ltrW_nhomo :
{homo f : m n / (n < m)%N >-> m < n} ->
{homo f : m n / (n <= m)%N >-> m <= n}.
Proof. by move=> mf m n /=; rewrite leq_eqVlt => /orP[/eqP->|/mf/ltrW//]. Qed.
Lemma homo_inj_ltn_lt :
injective f -> {homo f : m n / (m <= n)%N >-> m <= n} ->
{homo f : m n / (m < n)%N >-> m < n}.
Proof.
move=> fI mf m n /= hmn.
by rewrite ltr_neqAle (inj_eq fI) mf ?neq_ltn ?hmn ?orbT // ltnW.
Qed.
Lemma nhomo_inj_ltn_lt :
injective f -> {homo f : m n / (n <= m)%N >-> m <= n} ->
{homo f : m n / (n < m)%N >-> m < n}.
Proof.
move=> fI mf m n /= hmn; rewrite ltr_def (inj_eq fI).
by rewrite mf ?neq_ltn ?hmn // ltnW.
Qed.
Lemma leq_mono_inj : {mono f : m n / (m <= n)%N >-> m <= n} -> injective f.
Proof. by move=> mf m n /eqP; rewrite eqr_le !mf -eqn_leq => /eqP. Qed.
Lemma leq_nmono_inj : {mono f : m n / (n <= m)%N >-> m <= n} -> injective f.
Proof. by move=> mf m n /eqP; rewrite eqr_le !mf -eqn_leq => /eqP. Qed.
Lemma leq_lerW_mono :
{mono f : m n / (m <= n)%N >-> m <= n} ->
{mono f : m n / (m < n)%N >-> m < n}.
Proof.
move=> mf m n /=; rewrite !ltr_neqAle mf inj_eq ?ltn_neqAle 1?eq_sym //.
exact: leq_mono_inj.
Qed.
Lemma leq_lerW_nmono :
{mono f : m n / (n <= m)%N >-> m <= n} ->
{mono f : m n / (n < m)%N >-> m < n}.
Proof.
move=> mf x y /=; rewrite ltr_neqAle mf eq_sym inj_eq ?ltn_neqAle 1?eq_sym //.
exact: leq_nmono_inj.
Qed.
Lemma homo_leq_mono :
{homo f : m n / (m < n)%N >-> m < n} ->
{mono f : m n / (m <= n)%N >-> m <= n}.
Proof.
move=> mf m n /=; case: leqP; last by move=> /mf /ltr_geF.
by rewrite leq_eqVlt => /orP[/eqP->|/mf/ltrW //]; rewrite lerr.
Qed.
Lemma nhomo_leq_mono :
{homo f : m n / (n < m)%N >-> m < n} ->
{mono f : m n / (n <= m)%N >-> m <= n}.
Proof.
move=> mf m n /=; case: leqP; last by move=> /mf /ltr_geF.
by rewrite leq_eqVlt => /orP[/eqP->|/mf/ltrW //]; rewrite lerr.
Qed.
End NatToR.
End NumIntegralDomainMonotonyTheory.
Section NumDomainOperationTheory.
Variable R : numDomainType.
Implicit Types x y z t : R.
(* Comparision and opposite. *)
Lemma ler_opp2 : {mono -%R : x y /~ x <= y :> R}.
Proof. by move=> x y /=; rewrite -subr_ge0 opprK addrC subr_ge0. Qed.
Hint Resolve ler_opp2.
Lemma ltr_opp2 : {mono -%R : x y /~ x < y :> R}.
Proof. by move=> x y /=; rewrite lerW_nmono. Qed.
Hint Resolve ltr_opp2.
Definition lter_opp2 := (ler_opp2, ltr_opp2).
Lemma ler_oppr x y : (x <= - y) = (y <= - x).
Proof. by rewrite (monoRL (@opprK _) ler_opp2). Qed.
Lemma ltr_oppr x y : (x < - y) = (y < - x).
Proof. by rewrite (monoRL (@opprK _) (lerW_nmono _)). Qed.
Definition lter_oppr := (ler_oppr, ltr_oppr).
Lemma ler_oppl x y : (- x <= y) = (- y <= x).
Proof. by rewrite (monoLR (@opprK _) ler_opp2). Qed.
Lemma ltr_oppl x y : (- x < y) = (- y < x).
Proof. by rewrite (monoLR (@opprK _) (lerW_nmono _)). Qed.
Definition lter_oppl := (ler_oppl, ltr_oppl).
Lemma oppr_ge0 x : (0 <= - x) = (x <= 0).
Proof. by rewrite lter_oppr oppr0. Qed.
Lemma oppr_gt0 x : (0 < - x) = (x < 0).
Proof. by rewrite lter_oppr oppr0. Qed.
Definition oppr_gte0 := (oppr_ge0, oppr_gt0).
Lemma oppr_le0 x : (- x <= 0) = (0 <= x).
Proof. by rewrite lter_oppl oppr0. Qed.
Lemma oppr_lt0 x : (- x < 0) = (0 < x).
Proof. by rewrite lter_oppl oppr0. Qed.
Definition oppr_lte0 := (oppr_le0, oppr_lt0).
Definition oppr_cp0 := (oppr_gte0, oppr_lte0).
Definition lter_oppE := (oppr_cp0, lter_opp2).
Lemma ge0_cp x : 0 <= x -> (- x <= 0) * (- x <= x).
Proof. by move=> hx; rewrite oppr_cp0 hx (@ler_trans _ 0) ?oppr_cp0. Qed.
Lemma gt0_cp x : 0 < x ->
(0 <= x) * (- x <= 0) * (- x <= x) * (- x < 0) * (- x < x).
Proof.
move=> hx; move: (ltrW hx) => hx'; rewrite !ge0_cp hx' //.
by rewrite oppr_cp0 hx // (@ltr_trans _ 0) ?oppr_cp0.
Qed.
Lemma le0_cp x : x <= 0 -> (0 <= - x) * (x <= - x).
Proof. by move=> hx; rewrite oppr_cp0 hx (@ler_trans _ 0) ?oppr_cp0. Qed.
Lemma lt0_cp x :
x < 0 -> (x <= 0) * (0 <= - x) * (x <= - x) * (0 < - x) * (x < - x).
Proof.
move=> hx; move: (ltrW hx) => hx'; rewrite !le0_cp // hx'.
by rewrite oppr_cp0 hx // (@ltr_trans _ 0) ?oppr_cp0.
Qed.
(* Properties of the real subset. *)
Lemma ger0_real x : 0 <= x -> x \is real.
Proof. by rewrite realE => ->. Qed.
Lemma ler0_real x : x <= 0 -> x \is real.
Proof. by rewrite realE orbC => ->. Qed.
Lemma gtr0_real x : 0 < x -> x \is real.
Proof. by move=> /ltrW/ger0_real. Qed.
Lemma ltr0_real x : x < 0 -> x \is real.
Proof. by move=> /ltrW/ler0_real. Qed.
Lemma real0 : 0 \is @real R. Proof. by rewrite ger0_real. Qed.
Hint Resolve real0.
Lemma real1 : 1 \is @real R. Proof. by rewrite ger0_real. Qed.
Hint Resolve real1.
Lemma realn n : n%:R \is @real R. Proof. by rewrite ger0_real. Qed.
Lemma ler_leVge x y : x <= 0 -> y <= 0 -> (x <= y) || (y <= x).
Proof. by rewrite -!oppr_ge0 => /(ger_leVge _) h /h; rewrite !ler_opp2. Qed.
Lemma real_leVge x y : x \is real -> y \is real -> (x <= y) || (y <= x).
Proof.
rewrite !realE; have [x_ge0 _|x_nge0 /= x_le0] := boolP (_ <= _); last first.
by have [/(ler_trans x_le0)->|_ /(ler_leVge x_le0) //] := boolP (0 <= _).
by have [/(ger_leVge x_ge0)|_ /ler_trans->] := boolP (0 <= _); rewrite ?orbT.
Qed.
Lemma realB : {in real &, forall x y, x - y \is real}.
Proof. exact: rpredB. Qed.
Lemma realN : {mono (@GRing.opp R) : x / x \is real}.
Proof. exact: rpredN. Qed.
(* :TODO: add a rpredBC in ssralg *)
Lemma realBC x y : (x - y \is real) = (y - x \is real).
Proof. by rewrite -realN opprB. Qed.
Lemma realD : {in real &, forall x y, x + y \is real}.
Proof. exact: rpredD. Qed.
(* dichotomy and trichotomy *)
CoInductive ler_xor_gt (x y : R) : R -> R -> bool -> bool -> Set :=
| LerNotGt of x <= y : ler_xor_gt x y (y - x) (y - x) true false
| GtrNotLe of y < x : ler_xor_gt x y (x - y) (x - y) false true.
CoInductive ltr_xor_ge (x y : R) : R -> R -> bool -> bool -> Set :=
| LtrNotGe of x < y : ltr_xor_ge x y (y - x) (y - x) false true
| GerNotLt of y <= x : ltr_xor_ge x y (x - y) (x - y) true false.
CoInductive comparer x y : R -> R ->
bool -> bool -> bool -> bool -> bool -> bool -> Set :=
| ComparerLt of x < y : comparer x y (y - x) (y - x)
false false true false true false
| ComparerGt of x > y : comparer x y (x - y) (x - y)
false false false true false true
| ComparerEq of x = y : comparer x y 0 0
true true true true false false.
Lemma real_lerP x y :
x \is real -> y \is real ->
ler_xor_gt x y `|x - y| `|y - x| (x <= y) (y < x).
Proof.
move=> xR /(real_leVge xR); have [le_xy _|Nle_xy /= le_yx] := boolP (_ <= _).
have [/(ler_lt_trans le_xy)|] := boolP (_ < _); first by rewrite ltrr.
by rewrite ler0_norm ?ger0_norm ?subr_cp0 ?opprB //; constructor.
have [lt_yx|] := boolP (_ < _).
by rewrite ger0_norm ?ler0_norm ?subr_cp0 ?opprB //; constructor.
by rewrite ltr_def le_yx andbT negbK=> /eqP exy; rewrite exy lerr in Nle_xy.
Qed.
Lemma real_ltrP x y :
x \is real -> y \is real ->
ltr_xor_ge x y `|x - y| `|y - x| (y <= x) (x < y).
Proof. by move=> xR yR; case: real_lerP=> //; constructor. Qed.
Lemma real_ltrNge : {in real &, forall x y, (x < y) = ~~ (y <= x)}.
Proof. by move=> x y xR yR /=; case: real_lerP. Qed.
Lemma real_lerNgt : {in real &, forall x y, (x <= y) = ~~ (y < x)}.
Proof. by move=> x y xR yR /=; case: real_lerP. Qed.
Lemma real_ltrgtP x y :
x \is real -> y \is real ->
comparer x y `|x - y| `|y - x|
(y == x) (x == y) (x <= y) (y <= x) (x < y) (x > y).
Proof.
move=> xR yR; case: real_lerP => // [le_yx|lt_xy]; last first.
by rewrite gtr_eqF // ltr_eqF // ler_gtF ?ltrW //; constructor.
case: real_lerP => // [le_xy|lt_yx]; last first.
by rewrite ltr_eqF // gtr_eqF //; constructor.
have /eqP ->: x == y by rewrite eqr_le le_yx le_xy.
by rewrite subrr eqxx; constructor.
Qed.
CoInductive ger0_xor_lt0 (x : R) : R -> bool -> bool -> Set :=
| Ger0NotLt0 of 0 <= x : ger0_xor_lt0 x x false true
| Ltr0NotGe0 of x < 0 : ger0_xor_lt0 x (- x) true false.
CoInductive ler0_xor_gt0 (x : R) : R -> bool -> bool -> Set :=
| Ler0NotLe0 of x <= 0 : ler0_xor_gt0 x (- x) false true
| Gtr0NotGt0 of 0 < x : ler0_xor_gt0 x x true false.
CoInductive comparer0 x :
R -> bool -> bool -> bool -> bool -> bool -> bool -> Set :=
| ComparerGt0 of 0 < x : comparer0 x x false false false true false true
| ComparerLt0 of x < 0 : comparer0 x (- x) false false true false true false
| ComparerEq0 of x = 0 : comparer0 x 0 true true true true false false.
Lemma real_ger0P x : x \is real -> ger0_xor_lt0 x `|x| (x < 0) (0 <= x).
Proof.
move=> hx; rewrite -{2}[x]subr0; case: real_ltrP;
by rewrite ?subr0 ?sub0r //; constructor.
Qed.
Lemma real_ler0P x : x \is real -> ler0_xor_gt0 x `|x| (0 < x) (x <= 0).
Proof.
move=> hx; rewrite -{2}[x]subr0; case: real_ltrP;
by rewrite ?subr0 ?sub0r //; constructor.
Qed.
Lemma real_ltrgt0P x :
x \is real ->
comparer0 x `|x| (0 == x) (x == 0) (x <= 0) (0 <= x) (x < 0) (x > 0).
Proof.
move=> hx; rewrite -{2}[x]subr0; case: real_ltrgtP;
by rewrite ?subr0 ?sub0r //; constructor.
Qed.
Lemma real_neqr_lt : {in real &, forall x y, (x != y) = (x < y) || (y < x)}.
Proof. by move=> * /=; case: real_ltrgtP. Qed.
Lemma ler_sub_real x y : x <= y -> y - x \is real.
Proof. by move=> le_xy; rewrite ger0_real // subr_ge0. Qed.
Lemma ger_sub_real x y : x <= y -> x - y \is real.
Proof. by move=> le_xy; rewrite ler0_real // subr_le0. Qed.
Lemma ler_real y x : x <= y -> (x \is real) = (y \is real).
Proof. by move=> le_xy; rewrite -(addrNK x y) rpredDl ?ler_sub_real. Qed.
Lemma ger_real x y : y <= x -> (x \is real) = (y \is real).
Proof. by move=> le_yx; rewrite -(ler_real le_yx). Qed.
Lemma ger1_real x : 1 <= x -> x \is real. Proof. by move=> /ger_real->. Qed.
Lemma ler1_real x : x <= 1 -> x \is real. Proof. by move=> /ler_real->. Qed.
Lemma Nreal_leF x y : y \is real -> x \notin real -> (x <= y) = false.
Proof. by move=> yR; apply: contraNF=> /ler_real->. Qed.
Lemma Nreal_geF x y : y \is real -> x \notin real -> (y <= x) = false.
Proof. by move=> yR; apply: contraNF=> /ger_real->. Qed.
Lemma Nreal_ltF x y : y \is real -> x \notin real -> (x < y) = false.
Proof. by move=> yR xNR; rewrite ltr_def Nreal_leF ?andbF. Qed.
Lemma Nreal_gtF x y : y \is real -> x \notin real -> (y < x) = false.
Proof. by move=> yR xNR; rewrite ltr_def Nreal_geF ?andbF. Qed.
(* real wlog *)
Lemma real_wlog_ler P :
(forall a b, P b a -> P a b) -> (forall a b, a <= b -> P a b) ->
forall a b : R, a \is real -> b \is real -> P a b.
Proof.
move=> sP hP a b ha hb; wlog: a b ha hb / a <= b => [hwlog|]; last exact: hP.
by case: (real_lerP ha hb)=> [/hP //|/ltrW hba]; apply: sP; apply: hP.
Qed.
Lemma real_wlog_ltr P :
(forall a, P a a) -> (forall a b, (P b a -> P a b)) ->
(forall a b, a < b -> P a b) ->
forall a b : R, a \is real -> b \is real -> P a b.
Proof.
move=> rP sP hP; apply: real_wlog_ler=> // a b.
by rewrite ler_eqVlt; case: (altP (_ =P _))=> [->|] //= _ lab; apply: hP.
Qed.
(* Monotony of addition *)
Lemma ler_add2l x : {mono +%R x : y z / y <= z}.
Proof.
by move=> y z /=; rewrite -subr_ge0 opprD addrAC addNKr addrC subr_ge0.
Qed.
Lemma ler_add2r x : {mono +%R^~ x : y z / y <= z}.
Proof. by move=> y z /=; rewrite ![_ + x]addrC ler_add2l. Qed.
Lemma ltr_add2r z x y : (x + z < y + z) = (x < y).
Proof. by rewrite (lerW_mono (ler_add2r _)). Qed.
Lemma ltr_add2l z x y : (z + x < z + y) = (x < y).
Proof. by rewrite (lerW_mono (ler_add2l _)). Qed.
Definition ler_add2 := (ler_add2l, ler_add2r).
Definition ltr_add2 := (ltr_add2l, ltr_add2r).
Definition lter_add2 := (ler_add2, ltr_add2).
(* Addition, substraction and transitivity *)
Lemma ler_add x y z t : x <= y -> z <= t -> x + z <= y + t.
Proof. by move=> lxy lzt; rewrite (@ler_trans _ (y + z)) ?lter_add2. Qed.
Lemma ler_lt_add x y z t : x <= y -> z < t -> x + z < y + t.
Proof. by move=> lxy lzt; rewrite (@ler_lt_trans _ (y + z)) ?lter_add2. Qed.
Lemma ltr_le_add x y z t : x < y -> z <= t -> x + z < y + t.
Proof. by move=> lxy lzt; rewrite (@ltr_le_trans _ (y + z)) ?lter_add2. Qed.
Lemma ltr_add x y z t : x < y -> z < t -> x + z < y + t.
Proof. by move=> lxy lzt; rewrite ltr_le_add // ltrW. Qed.
Lemma ler_sub x y z t : x <= y -> t <= z -> x - z <= y - t.
Proof. by move=> lxy ltz; rewrite ler_add // lter_opp2. Qed.
Lemma ler_lt_sub x y z t : x <= y -> t < z -> x - z < y - t.
Proof. by move=> lxy lzt; rewrite ler_lt_add // lter_opp2. Qed.
Lemma ltr_le_sub x y z t : x < y -> t <= z -> x - z < y - t.
Proof. by move=> lxy lzt; rewrite ltr_le_add // lter_opp2. Qed.
Lemma ltr_sub x y z t : x < y -> t < z -> x - z < y - t.
Proof. by move=> lxy lzt; rewrite ltr_add // lter_opp2. Qed.
Lemma ler_subl_addr x y z : (x - y <= z) = (x <= z + y).
Proof. by rewrite (monoLR (addrK _) (ler_add2r _)). Qed.
Lemma ltr_subl_addr x y z : (x - y < z) = (x < z + y).
Proof. by rewrite (monoLR (addrK _) (ltr_add2r _)). Qed.
Lemma ler_subr_addr x y z : (x <= y - z) = (x + z <= y).
Proof. by rewrite (monoLR (addrNK _) (ler_add2r _)). Qed.
Lemma ltr_subr_addr x y z : (x < y - z) = (x + z < y).
Proof. by rewrite (monoLR (addrNK _) (ltr_add2r _)). Qed.
Definition ler_sub_addr := (ler_subl_addr, ler_subr_addr).
Definition ltr_sub_addr := (ltr_subl_addr, ltr_subr_addr).
Definition lter_sub_addr := (ler_sub_addr, ltr_sub_addr).
Lemma ler_subl_addl x y z : (x - y <= z) = (x <= y + z).
Proof. by rewrite lter_sub_addr addrC. Qed.
Lemma ltr_subl_addl x y z : (x - y < z) = (x < y + z).
Proof. by rewrite lter_sub_addr addrC. Qed.
Lemma ler_subr_addl x y z : (x <= y - z) = (z + x <= y).
Proof. by rewrite lter_sub_addr addrC. Qed.
Lemma ltr_subr_addl x y z : (x < y - z) = (z + x < y).
Proof. by rewrite lter_sub_addr addrC. Qed.
Definition ler_sub_addl := (ler_subl_addl, ler_subr_addl).
Definition ltr_sub_addl := (ltr_subl_addl, ltr_subr_addl).
Definition lter_sub_addl := (ler_sub_addl, ltr_sub_addl).
Lemma ler_addl x y : (x <= x + y) = (0 <= y).
Proof. by rewrite -{1}[x]addr0 lter_add2. Qed.
Lemma ltr_addl x y : (x < x + y) = (0 < y).
Proof. by rewrite -{1}[x]addr0 lter_add2. Qed.
Lemma ler_addr x y : (x <= y + x) = (0 <= y).
Proof. by rewrite -{1}[x]add0r lter_add2. Qed.
Lemma ltr_addr x y : (x < y + x) = (0 < y).
Proof. by rewrite -{1}[x]add0r lter_add2. Qed.
Lemma ger_addl x y : (x + y <= x) = (y <= 0).
Proof. by rewrite -{2}[x]addr0 lter_add2. Qed.
Lemma gtr_addl x y : (x + y < x) = (y < 0).
Proof. by rewrite -{2}[x]addr0 lter_add2. Qed.
Lemma ger_addr x y : (y + x <= x) = (y <= 0).
Proof. by rewrite -{2}[x]add0r lter_add2. Qed.
Lemma gtr_addr x y : (y + x < x) = (y < 0).
Proof. by rewrite -{2}[x]add0r lter_add2. Qed.
Definition cpr_add := (ler_addl, ler_addr, ger_addl, ger_addl,
ltr_addl, ltr_addr, gtr_addl, gtr_addl).
(* Addition with left member knwon to be positive/negative *)
Lemma ler_paddl y x z : 0 <= x -> y <= z -> y <= x + z.
Proof. by move=> *; rewrite -[y]add0r ler_add. Qed.
Lemma ltr_paddl y x z : 0 <= x -> y < z -> y < x + z.
Proof. by move=> *; rewrite -[y]add0r ler_lt_add. Qed.
Lemma ltr_spaddl y x z : 0 < x -> y <= z -> y < x + z.
Proof. by move=> *; rewrite -[y]add0r ltr_le_add. Qed.
Lemma ltr_spsaddl y x z : 0 < x -> y < z -> y < x + z.
Proof. by move=> *; rewrite -[y]add0r ltr_add. Qed.
Lemma ler_naddl y x z : x <= 0 -> y <= z -> x + y <= z.
Proof. by move=> *; rewrite -[z]add0r ler_add. Qed.
Lemma ltr_naddl y x z : x <= 0 -> y < z -> x + y < z.
Proof. by move=> *; rewrite -[z]add0r ler_lt_add. Qed.
Lemma ltr_snaddl y x z : x < 0 -> y <= z -> x + y < z.
Proof. by move=> *; rewrite -[z]add0r ltr_le_add. Qed.
Lemma ltr_snsaddl y x z : x < 0 -> y < z -> x + y < z.
Proof. by move=> *; rewrite -[z]add0r ltr_add. Qed.
(* Addition with right member we know positive/negative *)
Lemma ler_paddr y x z : 0 <= x -> y <= z -> y <= z + x.
Proof. by move=> *; rewrite [_ + x]addrC ler_paddl. Qed.
Lemma ltr_paddr y x z : 0 <= x -> y < z -> y < z + x.
Proof. by move=> *; rewrite [_ + x]addrC ltr_paddl. Qed.
Lemma ltr_spaddr y x z : 0 < x -> y <= z -> y < z + x.
Proof. by move=> *; rewrite [_ + x]addrC ltr_spaddl. Qed.
Lemma ltr_spsaddr y x z : 0 < x -> y < z -> y < z + x.
Proof. by move=> *; rewrite [_ + x]addrC ltr_spsaddl. Qed.
Lemma ler_naddr y x z : x <= 0 -> y <= z -> y + x <= z.
Proof. by move=> *; rewrite [_ + x]addrC ler_naddl. Qed.
Lemma ltr_naddr y x z : x <= 0 -> y < z -> y + x < z.
Proof. by move=> *; rewrite [_ + x]addrC ltr_naddl. Qed.
Lemma ltr_snaddr y x z : x < 0 -> y <= z -> y + x < z.
Proof. by move=> *; rewrite [_ + x]addrC ltr_snaddl. Qed.
Lemma ltr_snsaddr y x z : x < 0 -> y < z -> y + x < z.
Proof. by move=> *; rewrite [_ + x]addrC ltr_snsaddl. Qed.
(* x and y have the same sign and their sum is null *)
Lemma paddr_eq0 (x y : R) :
0 <= x -> 0 <= y -> (x + y == 0) = (x == 0) && (y == 0).
Proof.
rewrite le0r; case/orP=> [/eqP->|hx]; first by rewrite add0r eqxx.
by rewrite (gtr_eqF hx) /= => hy; rewrite gtr_eqF // ltr_spaddl.
Qed.
Lemma naddr_eq0 (x y : R) :
x <= 0 -> y <= 0 -> (x + y == 0) = (x == 0) && (y == 0).
Proof.
by move=> lex0 ley0; rewrite -oppr_eq0 opprD paddr_eq0 ?oppr_cp0 // !oppr_eq0.
Qed.
Lemma addr_ss_eq0 (x y : R) :
(0 <= x) && (0 <= y) || (x <= 0) && (y <= 0) ->
(x + y == 0) = (x == 0) && (y == 0).
Proof. by case/orP=> /andP []; [apply: paddr_eq0 | apply: naddr_eq0]. Qed.
(* big sum and ler *)
Lemma sumr_ge0 I (r : seq I) (P : pred I) (F : I -> R) :
(forall i, P i -> (0 <= F i)) -> 0 <= \sum_(i <- r | P i) (F i).
Proof. exact: (big_ind _ _ (@ler_paddl 0)). Qed.
Lemma ler_sum I (r : seq I) (P : pred I) (F G : I -> R) :
(forall i, P i -> F i <= G i) ->
\sum_(i <- r | P i) F i <= \sum_(i <- r | P i) G i.
Proof. exact: (big_ind2 _ (lerr _) ler_add). Qed.
Lemma psumr_eq0 (I : eqType) (r : seq I) (P : pred I) (F : I -> R) :
(forall i, P i -> 0 <= F i) ->
(\sum_(i <- r | P i) (F i) == 0) = (all (fun i => (P i) ==> (F i == 0)) r).
Proof.
elim: r=> [|a r ihr hr] /=; rewrite (big_nil, big_cons); first by rewrite eqxx.
by case: ifP=> pa /=; rewrite ?paddr_eq0 ?ihr ?hr // sumr_ge0.
Qed.
(* :TODO: Cyril : See which form to keep *)
Lemma psumr_eq0P (I : finType) (P : pred I) (F : I -> R) :
(forall i, P i -> 0 <= F i) -> \sum_(i | P i) F i = 0 ->
(forall i, P i -> F i = 0).
Proof.
move=> F_ge0 /eqP; rewrite psumr_eq0 // -big_all big_andE => /forallP hF i Pi.
by move: (hF i); rewrite implyTb Pi /= => /eqP.
Qed.
(* mulr and ler/ltr *)
Lemma ler_pmul2l x : 0 < x -> {mono *%R x : x y / x <= y}.
Proof.
by move=> x_gt0 y z /=; rewrite -subr_ge0 -mulrBr pmulr_rge0 // subr_ge0.
Qed.
Lemma ltr_pmul2l x : 0 < x -> {mono *%R x : x y / x < y}.
Proof. by move=> x_gt0; apply: lerW_mono (ler_pmul2l _). Qed.
Definition lter_pmul2l := (ler_pmul2l, ltr_pmul2l).
Lemma ler_pmul2r x : 0 < x -> {mono *%R^~ x : x y / x <= y}.
Proof. by move=> x_gt0 y z /=; rewrite ![_ * x]mulrC ler_pmul2l. Qed.
Lemma ltr_pmul2r x : 0 < x -> {mono *%R^~ x : x y / x < y}.
Proof. by move=> x_gt0; apply: lerW_mono (ler_pmul2r _). Qed.
Definition lter_pmul2r := (ler_pmul2r, ltr_pmul2r).
Lemma ler_nmul2l x : x < 0 -> {mono *%R x : x y /~ x <= y}.
Proof.
by move=> x_lt0 y z /=; rewrite -ler_opp2 -!mulNr ler_pmul2l ?oppr_gt0.
Qed.
Lemma ltr_nmul2l x : x < 0 -> {mono *%R x : x y /~ x < y}.
Proof. by move=> x_lt0; apply: lerW_nmono (ler_nmul2l _). Qed.
Definition lter_nmul2l := (ler_nmul2l, ltr_nmul2l).
Lemma ler_nmul2r x : x < 0 -> {mono *%R^~ x : x y /~ x <= y}.
Proof. by move=> x_lt0 y z /=; rewrite ![_ * x]mulrC ler_nmul2l. Qed.
Lemma ltr_nmul2r x : x < 0 -> {mono *%R^~ x : x y /~ x < y}.
Proof. by move=> x_lt0; apply: lerW_nmono (ler_nmul2r _). Qed.
Definition lter_nmul2r := (ler_nmul2r, ltr_nmul2r).
Lemma ler_wpmul2l x : 0 <= x -> {homo *%R x : y z / y <= z}.
Proof.
by rewrite le0r => /orP[/eqP-> y z | /ler_pmul2l/mono2W//]; rewrite !mul0r.
Qed.
Lemma ler_wpmul2r x : 0 <= x -> {homo *%R^~ x : y z / y <= z}.
Proof. by move=> x_ge0 y z leyz; rewrite ![_ * x]mulrC ler_wpmul2l. Qed.
Lemma ler_wnmul2l x : x <= 0 -> {homo *%R x : y z /~ y <= z}.
Proof.
by move=> x_le0 y z leyz; rewrite -![x * _]mulrNN ler_wpmul2l ?lter_oppE.
Qed.
Lemma ler_wnmul2r x : x <= 0 -> {homo *%R^~ x : y z /~ y <= z}.
Proof.
by move=> x_le0 y z leyz; rewrite -![_ * x]mulrNN ler_wpmul2r ?lter_oppE.
Qed.
(* Binary forms, for backchaining. *)
Lemma ler_pmul x1 y1 x2 y2 :
0 <= x1 -> 0 <= x2 -> x1 <= y1 -> x2 <= y2 -> x1 * x2 <= y1 * y2.
Proof.
move=> x1ge0 x2ge0 le_xy1 le_xy2; have y1ge0 := ler_trans x1ge0 le_xy1.
exact: ler_trans (ler_wpmul2r x2ge0 le_xy1) (ler_wpmul2l y1ge0 le_xy2).
Qed.
Lemma ltr_pmul x1 y1 x2 y2 :
0 <= x1 -> 0 <= x2 -> x1 < y1 -> x2 < y2 -> x1 * x2 < y1 * y2.
Proof.
move=> x1ge0 x2ge0 lt_xy1 lt_xy2; have y1gt0 := ler_lt_trans x1ge0 lt_xy1.
by rewrite (ler_lt_trans (ler_wpmul2r x2ge0 (ltrW lt_xy1))) ?ltr_pmul2l.
Qed.
(* complement for x *+ n and <= or < *)
Lemma ler_pmuln2r n : (0 < n)%N -> {mono (@GRing.natmul R)^~ n : x y / x <= y}.
Proof.
by case: n => // n _ x y /=; rewrite -mulr_natl -[y *+ _]mulr_natl ler_pmul2l.
Qed.
Lemma ltr_pmuln2r n : (0 < n)%N -> {mono (@GRing.natmul R)^~ n : x y / x < y}.
Proof. by move/ler_pmuln2r/lerW_mono. Qed.
Lemma pmulrnI n : (0 < n)%N -> injective ((@GRing.natmul R)^~ n).
Proof. by move/ler_pmuln2r/mono_inj. Qed.
Lemma eqr_pmuln2r n : (0 < n)%N -> {mono (@GRing.natmul R)^~ n : x y / x == y}.
Proof. by move/pmulrnI/inj_eq. Qed.
Lemma pmulrn_lgt0 x n : (0 < n)%N -> (0 < x *+ n) = (0 < x).
Proof. by move=> n_gt0; rewrite -(mul0rn _ n) ltr_pmuln2r // mul0rn. Qed.
Lemma pmulrn_llt0 x n : (0 < n)%N -> (x *+ n < 0) = (x < 0).
Proof. by move=> n_gt0; rewrite -(mul0rn _ n) ltr_pmuln2r // mul0rn. Qed.
Lemma pmulrn_lge0 x n : (0 < n)%N -> (0 <= x *+ n) = (0 <= x).
Proof. by move=> n_gt0; rewrite -(mul0rn _ n) ler_pmuln2r // mul0rn. Qed.
Lemma pmulrn_lle0 x n : (0 < n)%N -> (x *+ n <= 0) = (x <= 0).
Proof. by move=> n_gt0; rewrite -(mul0rn _ n) ler_pmuln2r // mul0rn. Qed.
Lemma ltr_wmuln2r x y n : x < y -> (x *+ n < y *+ n) = (0 < n)%N.
Proof. by move=> ltxy; case: n=> // n; rewrite ltr_pmuln2r. Qed.
Lemma ltr_wpmuln2r n : (0 < n)%N -> {homo (@GRing.natmul R)^~ n : x y / x < y}.
Proof. by move=> n_gt0 x y /= / ltr_wmuln2r ->. Qed.
Lemma ler_wmuln2r n : {homo (@GRing.natmul R)^~ n : x y / x <= y}.
Proof. by move=> x y hxy /=; case: n=> // n; rewrite ler_pmuln2r. Qed.
Lemma mulrn_wge0 x n : 0 <= x -> 0 <= x *+ n.
Proof. by move=> /(ler_wmuln2r n); rewrite mul0rn. Qed.
Lemma mulrn_wle0 x n : x <= 0 -> x *+ n <= 0.
Proof. by move=> /(ler_wmuln2r n); rewrite mul0rn. Qed.
Lemma ler_muln2r n x y : (x *+ n <= y *+ n) = ((n == 0%N) || (x <= y)).
Proof. by case: n => [|n]; rewrite ?lerr ?eqxx // ler_pmuln2r. Qed.
Lemma ltr_muln2r n x y : (x *+ n < y *+ n) = ((0 < n)%N && (x < y)).
Proof. by case: n => [|n]; rewrite ?lerr ?eqxx // ltr_pmuln2r. Qed.
Lemma eqr_muln2r n x y : (x *+ n == y *+ n) = (n == 0)%N || (x == y).
Proof. by rewrite !eqr_le !ler_muln2r -orb_andr. Qed.
(* More characteristic zero properties. *)
Lemma mulrn_eq0 x n : (x *+ n == 0) = ((n == 0)%N || (x == 0)).
Proof. by rewrite -mulr_natl mulf_eq0 pnatr_eq0. Qed.
Lemma mulrIn x : x != 0 -> injective (GRing.natmul x).
Proof.
move=> x_neq0 m n; without loss /subnK <-: m n / (n <= m)%N.
by move=> IH eq_xmn; case/orP: (leq_total m n) => /IH->.
by move/eqP; rewrite mulrnDr -subr_eq0 addrK mulrn_eq0 => /predU1P[-> | /idPn].
Qed.
Lemma ler_wpmuln2l x :
0 <= x -> {homo (@GRing.natmul R x) : m n / (m <= n)%N >-> m <= n}.
Proof. by move=> xge0 m n /subnK <-; rewrite mulrnDr ler_paddl ?mulrn_wge0. Qed.
Lemma ler_wnmuln2l x :
x <= 0 -> {homo (@GRing.natmul R x) : m n / (n <= m)%N >-> m <= n}.
Proof.
by move=> xle0 m n hmn /=; rewrite -ler_opp2 -!mulNrn ler_wpmuln2l // oppr_cp0.
Qed.
Lemma mulrn_wgt0 x n : 0 < x -> 0 < x *+ n = (0 < n)%N.
Proof. by case: n => // n hx; rewrite pmulrn_lgt0. Qed.
Lemma mulrn_wlt0 x n : x < 0 -> x *+ n < 0 = (0 < n)%N.
Proof. by case: n => // n hx; rewrite pmulrn_llt0. Qed.
Lemma ler_pmuln2l x :
0 < x -> {mono (@GRing.natmul R x) : m n / (m <= n)%N >-> m <= n}.
Proof.
move=> x_gt0 m n /=; case: leqP => hmn; first by rewrite ler_wpmuln2l // ltrW.
rewrite -(subnK (ltnW hmn)) mulrnDr ger_addr ltr_geF //.
by rewrite mulrn_wgt0 // subn_gt0.
Qed.
Lemma ltr_pmuln2l x :
0 < x -> {mono (@GRing.natmul R x) : m n / (m < n)%N >-> m < n}.
Proof. by move=> x_gt0; apply: leq_lerW_mono (ler_pmuln2l _). Qed.
Lemma ler_nmuln2l x :
x < 0 -> {mono (@GRing.natmul R x) : m n / (n <= m)%N >-> m <= n}.
Proof.
by move=> x_lt0 m n /=; rewrite -ler_opp2 -!mulNrn ler_pmuln2l // oppr_gt0.
Qed.
Lemma ltr_nmuln2l x :
x < 0 -> {mono (@GRing.natmul R x) : m n / (n < m)%N >-> m < n}.
Proof. by move=> x_lt0; apply: leq_lerW_nmono (ler_nmuln2l _). Qed.
Lemma ler_nat m n : (m%:R <= n%:R :> R) = (m <= n)%N.
Proof. by rewrite ler_pmuln2l. Qed.
Lemma ltr_nat m n : (m%:R < n%:R :> R) = (m < n)%N.
Proof. by rewrite ltr_pmuln2l. Qed.
Lemma eqr_nat m n : (m%:R == n%:R :> R) = (m == n)%N.
Proof. by rewrite (inj_eq (mulrIn _)) ?oner_eq0. Qed.
Lemma pnatr_eq1 n : (n%:R == 1 :> R) = (n == 1)%N.
Proof. exact: eqr_nat 1%N. Qed.
Lemma lern0 n : (n%:R <= 0 :> R) = (n == 0%N).
Proof. by rewrite -[0]/0%:R ler_nat leqn0. Qed.
Lemma ltrn0 n : (n%:R < 0 :> R) = false.
Proof. by rewrite -[0]/0%:R ltr_nat ltn0. Qed.
Lemma ler1n n : 1 <= n%:R :> R = (1 <= n)%N. Proof. by rewrite -ler_nat. Qed.
Lemma ltr1n n : 1 < n%:R :> R = (1 < n)%N. Proof. by rewrite -ltr_nat. Qed.
Lemma lern1 n : n%:R <= 1 :> R = (n <= 1)%N. Proof. by rewrite -ler_nat. Qed.
Lemma ltrn1 n : n%:R < 1 :> R = (n < 1)%N. Proof. by rewrite -ltr_nat. Qed.
Lemma ltrN10 : -1 < 0 :> R. Proof. by rewrite oppr_lt0. Qed.
Lemma lerN10 : -1 <= 0 :> R. Proof. by rewrite oppr_le0. Qed.
Lemma ltr10 : 1 < 0 :> R = false. Proof. by rewrite ler_gtF. Qed.
Lemma ler10 : 1 <= 0 :> R = false. Proof. by rewrite ltr_geF. Qed.
Lemma ltr0N1 : 0 < -1 :> R = false. Proof. by rewrite ler_gtF // lerN10. Qed.
Lemma ler0N1 : 0 <= -1 :> R = false. Proof. by rewrite ltr_geF // ltrN10. Qed.
Lemma pmulrn_rgt0 x n : 0 < x -> 0 < x *+ n = (0 < n)%N.
Proof. by move=> x_gt0; rewrite -(mulr0n x) ltr_pmuln2l. Qed.
Lemma pmulrn_rlt0 x n : 0 < x -> x *+ n < 0 = false.
Proof. by move=> x_gt0; rewrite -(mulr0n x) ltr_pmuln2l. Qed.
Lemma pmulrn_rge0 x n : 0 < x -> 0 <= x *+ n.
Proof. by move=> x_gt0; rewrite -(mulr0n x) ler_pmuln2l. Qed.
Lemma pmulrn_rle0 x n : 0 < x -> x *+ n <= 0 = (n == 0)%N.
Proof. by move=> x_gt0; rewrite -(mulr0n x) ler_pmuln2l ?leqn0. Qed.
Lemma nmulrn_rgt0 x n : x < 0 -> 0 < x *+ n = false.
Proof. by move=> x_lt0; rewrite -(mulr0n x) ltr_nmuln2l. Qed.
Lemma nmulrn_rge0 x n : x < 0 -> 0 <= x *+ n = (n == 0)%N.
Proof. by move=> x_lt0; rewrite -(mulr0n x) ler_nmuln2l ?leqn0. Qed.
Lemma nmulrn_rle0 x n : x < 0 -> x *+ n <= 0.
Proof. by move=> x_lt0; rewrite -(mulr0n x) ler_nmuln2l. Qed.
(* (x * y) compared to 0 *)
(* Remark : pmulr_rgt0 and pmulr_rge0 are defined above *)
(* x positive and y right *)
Lemma pmulr_rlt0 x y : 0 < x -> (x * y < 0) = (y < 0).
Proof. by move=> x_gt0; rewrite -oppr_gt0 -mulrN pmulr_rgt0 // oppr_gt0. Qed.
Lemma pmulr_rle0 x y : 0 < x -> (x * y <= 0) = (y <= 0).
Proof. by move=> x_gt0; rewrite -oppr_ge0 -mulrN pmulr_rge0 // oppr_ge0. Qed.
(* x positive and y left *)
Lemma pmulr_lgt0 x y : 0 < x -> (0 < y * x) = (0 < y).
Proof. by move=> x_gt0; rewrite mulrC pmulr_rgt0. Qed.
Lemma pmulr_lge0 x y : 0 < x -> (0 <= y * x) = (0 <= y).
Proof. by move=> x_gt0; rewrite mulrC pmulr_rge0. Qed.
Lemma pmulr_llt0 x y : 0 < x -> (y * x < 0) = (y < 0).
Proof. by move=> x_gt0; rewrite mulrC pmulr_rlt0. Qed.
Lemma pmulr_lle0 x y : 0 < x -> (y * x <= 0) = (y <= 0).
Proof. by move=> x_gt0; rewrite mulrC pmulr_rle0. Qed.
(* x negative and y right *)
Lemma nmulr_rgt0 x y : x < 0 -> (0 < x * y) = (y < 0).
Proof. by move=> x_lt0; rewrite -mulrNN pmulr_rgt0 lter_oppE. Qed.
Lemma nmulr_rge0 x y : x < 0 -> (0 <= x * y) = (y <= 0).
Proof. by move=> x_lt0; rewrite -mulrNN pmulr_rge0 lter_oppE. Qed.
Lemma nmulr_rlt0 x y : x < 0 -> (x * y < 0) = (0 < y).
Proof. by move=> x_lt0; rewrite -mulrNN pmulr_rlt0 lter_oppE. Qed.
Lemma nmulr_rle0 x y : x < 0 -> (x * y <= 0) = (0 <= y).
Proof. by move=> x_lt0; rewrite -mulrNN pmulr_rle0 lter_oppE. Qed.
(* x negative and y left *)
Lemma nmulr_lgt0 x y : x < 0 -> (0 < y * x) = (y < 0).
Proof. by move=> x_lt0; rewrite mulrC nmulr_rgt0. Qed.
Lemma nmulr_lge0 x y : x < 0 -> (0 <= y * x) = (y <= 0).
Proof. by move=> x_lt0; rewrite mulrC nmulr_rge0. Qed.
Lemma nmulr_llt0 x y : x < 0 -> (y * x < 0) = (0 < y).
Proof. by move=> x_lt0; rewrite mulrC nmulr_rlt0. Qed.
Lemma nmulr_lle0 x y : x < 0 -> (y * x <= 0) = (0 <= y).
Proof. by move=> x_lt0; rewrite mulrC nmulr_rle0. Qed.
(* weak and symmetric lemmas *)
Lemma mulr_ge0 x y : 0 <= x -> 0 <= y -> 0 <= x * y.
Proof. by move=> x_ge0 y_ge0; rewrite -(mulr0 x) ler_wpmul2l. Qed.
Lemma mulr_le0 x y : x <= 0 -> y <= 0 -> 0 <= x * y.
Proof. by move=> x_le0 y_le0; rewrite -(mulr0 x) ler_wnmul2l. Qed.
Lemma mulr_ge0_le0 x y : 0 <= x -> y <= 0 -> x * y <= 0.
Proof. by move=> x_le0 y_le0; rewrite -(mulr0 x) ler_wpmul2l. Qed.
Lemma mulr_le0_ge0 x y : x <= 0 -> 0 <= y -> x * y <= 0.
Proof. by move=> x_le0 y_le0; rewrite -(mulr0 x) ler_wnmul2l. Qed.
(* mulr_gt0 with only one case *)
Lemma mulr_gt0 x y : 0 < x -> 0 < y -> 0 < x * y.
Proof. by move=> x_gt0 y_gt0; rewrite pmulr_rgt0. Qed.
(* Iterated products *)
Lemma prodr_ge0 I r (P : pred I) (E : I -> R) :
(forall i, P i -> 0 <= E i) -> 0 <= \prod_(i <- r | P i) E i.
Proof. by move=> Ege0; rewrite -nnegrE rpred_prod. Qed.
Lemma prodr_gt0 I r (P : pred I) (E : I -> R) :
(forall i, P i -> 0 < E i) -> 0 < \prod_(i <- r | P i) E i.
Proof. by move=> Ege0; rewrite -posrE rpred_prod. Qed.
Lemma ler_prod I r (P : pred I) (E1 E2 : I -> R) :
(forall i, P i -> 0 <= E1 i <= E2 i) ->
\prod_(i <- r | P i) E1 i <= \prod_(i <- r | P i) E2 i.
Proof.
move=> leE12; elim/(big_load (fun x => 0 <= x)): _.
elim/big_rec2: _ => // i x2 x1 /leE12/andP[le0Ei leEi12] [x1ge0 le_x12].
by rewrite mulr_ge0 // ler_pmul.
Qed.
Lemma ltr_prod (E1 E2 : nat -> R) (n m : nat) :
(m < n)%N -> (forall i, (m <= i < n)%N -> 0 <= E1 i < E2 i) ->
\prod_(m <= i < n) E1 i < \prod_(m <= i < n) E2 i.
Proof.
elim: n m => // n ihn m; rewrite ltnS leq_eqVlt; case/orP => [/eqP -> | ltnm hE].
by move/(_ n) => /andb_idr; rewrite !big_nat1 leqnn ltnSn /=; case/andP.
rewrite big_nat_recr ?[X in _ < X]big_nat_recr ?(ltnW ltnm) //=.
move/andb_idr: (hE n); rewrite leqnn ltnW //=; case/andP => h1n h12n.
rewrite big_nat_cond [X in _ < X * _]big_nat_cond; apply: ltr_pmul => //=.
- apply: prodr_ge0 => i; rewrite andbT; case/andP=> hm hn.
by move/andb_idr: (hE i); rewrite hm /= ltnS ltnW //=; case/andP.
rewrite -!big_nat_cond; apply: ihn => // i /andP [hm hn]; apply: hE.
by rewrite hm ltnW.
Qed.
(* real of mul *)
Lemma realMr x y : x != 0 -> x \is real -> (x * y \is real) = (y \is real).
Proof.
move=> x_neq0 xR; case: real_ltrgtP x_neq0 => // hx _; rewrite !realE.
by rewrite nmulr_rge0 // nmulr_rle0 // orbC.
by rewrite pmulr_rge0 // pmulr_rle0 // orbC.
Qed.
Lemma realrM x y : y != 0 -> y \is real -> (x * y \is real) = (x \is real).
Proof. by move=> y_neq0 yR; rewrite mulrC realMr. Qed.
Lemma realM : {in real &, forall x y, x * y \is real}.
Proof. exact: rpredM. Qed.
Lemma realrMn x n : (n != 0)%N -> (x *+ n \is real) = (x \is real).
Proof. by move=> n_neq0; rewrite -mulr_natl realMr ?realn ?pnatr_eq0. Qed.
(* ler/ltr and multiplication between a positive/negative *)
Lemma ger_pmull x y : 0 < y -> (x * y <= y) = (x <= 1).
Proof. by move=> hy; rewrite -{2}[y]mul1r ler_pmul2r. Qed.
Lemma gtr_pmull x y : 0 < y -> (x * y < y) = (x < 1).
Proof. by move=> hy; rewrite -{2}[y]mul1r ltr_pmul2r. Qed.
Lemma ger_pmulr x y : 0 < y -> (y * x <= y) = (x <= 1).
Proof. by move=> hy; rewrite -{2}[y]mulr1 ler_pmul2l. Qed.
Lemma gtr_pmulr x y : 0 < y -> (y * x < y) = (x < 1).
Proof. by move=> hy; rewrite -{2}[y]mulr1 ltr_pmul2l. Qed.
Lemma ler_pmull x y : 0 < y -> (y <= x * y) = (1 <= x).
Proof. by move=> hy; rewrite -{1}[y]mul1r ler_pmul2r. Qed.
Lemma ltr_pmull x y : 0 < y -> (y < x * y) = (1 < x).
Proof. by move=> hy; rewrite -{1}[y]mul1r ltr_pmul2r. Qed.
Lemma ler_pmulr x y : 0 < y -> (y <= y * x) = (1 <= x).
Proof. by move=> hy; rewrite -{1}[y]mulr1 ler_pmul2l. Qed.
Lemma ltr_pmulr x y : 0 < y -> (y < y * x) = (1 < x).
Proof. by move=> hy; rewrite -{1}[y]mulr1 ltr_pmul2l. Qed.
Lemma ger_nmull x y : y < 0 -> (x * y <= y) = (1 <= x).
Proof. by move=> hy; rewrite -{2}[y]mul1r ler_nmul2r. Qed.
Lemma gtr_nmull x y : y < 0 -> (x * y < y) = (1 < x).
Proof. by move=> hy; rewrite -{2}[y]mul1r ltr_nmul2r. Qed.
Lemma ger_nmulr x y : y < 0 -> (y * x <= y) = (1 <= x).
Proof. by move=> hy; rewrite -{2}[y]mulr1 ler_nmul2l. Qed.
Lemma gtr_nmulr x y : y < 0 -> (y * x < y) = (1 < x).
Proof. by move=> hy; rewrite -{2}[y]mulr1 ltr_nmul2l. Qed.
Lemma ler_nmull x y : y < 0 -> (y <= x * y) = (x <= 1).
Proof. by move=> hy; rewrite -{1}[y]mul1r ler_nmul2r. Qed.
Lemma ltr_nmull x y : y < 0 -> (y < x * y) = (x < 1).
Proof. by move=> hy; rewrite -{1}[y]mul1r ltr_nmul2r. Qed.
Lemma ler_nmulr x y : y < 0 -> (y <= y * x) = (x <= 1).
Proof. by move=> hy; rewrite -{1}[y]mulr1 ler_nmul2l. Qed.
Lemma ltr_nmulr x y : y < 0 -> (y < y * x) = (x < 1).
Proof. by move=> hy; rewrite -{1}[y]mulr1 ltr_nmul2l. Qed.
(* ler/ltr and multiplication between a positive/negative
and a exterior (1 <= _) or interior (0 <= _ <= 1) *)
Lemma ler_pemull x y : 0 <= y -> 1 <= x -> y <= x * y.
Proof. by move=> hy hx; rewrite -{1}[y]mul1r ler_wpmul2r. Qed.
Lemma ler_nemull x y : y <= 0 -> 1 <= x -> x * y <= y.
Proof. by move=> hy hx; rewrite -{2}[y]mul1r ler_wnmul2r. Qed.
Lemma ler_pemulr x y : 0 <= y -> 1 <= x -> y <= y * x.
Proof. by move=> hy hx; rewrite -{1}[y]mulr1 ler_wpmul2l. Qed.
Lemma ler_nemulr x y : y <= 0 -> 1 <= x -> y * x <= y.
Proof. by move=> hy hx; rewrite -{2}[y]mulr1 ler_wnmul2l. Qed.
Lemma ler_pimull x y : 0 <= y -> x <= 1 -> x * y <= y.
Proof. by move=> hy hx; rewrite -{2}[y]mul1r ler_wpmul2r. Qed.
Lemma ler_nimull x y : y <= 0 -> x <= 1 -> y <= x * y.
Proof. by move=> hy hx; rewrite -{1}[y]mul1r ler_wnmul2r. Qed.
Lemma ler_pimulr x y : 0 <= y -> x <= 1 -> y * x <= y.
Proof. by move=> hy hx; rewrite -{2}[y]mulr1 ler_wpmul2l. Qed.
Lemma ler_nimulr x y : y <= 0 -> x <= 1 -> y <= y * x.
Proof. by move=> hx hy; rewrite -{1}[y]mulr1 ler_wnmul2l. Qed.
Lemma mulr_ile1 x y : 0 <= x -> 0 <= y -> x <= 1 -> y <= 1 -> x * y <= 1.
Proof. by move=> *; rewrite (@ler_trans _ y) ?ler_pimull. Qed.
Lemma mulr_ilt1 x y : 0 <= x -> 0 <= y -> x < 1 -> y < 1 -> x * y < 1.
Proof. by move=> *; rewrite (@ler_lt_trans _ y) ?ler_pimull // ltrW. Qed.
Definition mulr_ilte1 := (mulr_ile1, mulr_ilt1).
Lemma mulr_ege1 x y : 1 <= x -> 1 <= y -> 1 <= x * y.
Proof.
by move=> le1x le1y; rewrite (@ler_trans _ y) ?ler_pemull // (ler_trans ler01).
Qed.
Lemma mulr_egt1 x y : 1 < x -> 1 < y -> 1 < x * y.
Proof.
by move=> le1x lt1y; rewrite (@ltr_trans _ y) // ltr_pmull // (ltr_trans ltr01).
Qed.
Definition mulr_egte1 := (mulr_ege1, mulr_egt1).
Definition mulr_cp1 := (mulr_ilte1, mulr_egte1).
(* ler and ^-1 *)
Lemma invr_gt0 x : (0 < x^-1) = (0 < x).
Proof.
have [ux | nux] := boolP (x \is a GRing.unit); last by rewrite invr_out.
by apply/idP/idP=> /ltr_pmul2r<-; rewrite mul0r (mulrV, mulVr) ?ltr01.
Qed.
Lemma invr_ge0 x : (0 <= x^-1) = (0 <= x).
Proof. by rewrite !le0r invr_gt0 invr_eq0. Qed.
Lemma invr_lt0 x : (x^-1 < 0) = (x < 0).
Proof. by rewrite -oppr_cp0 -invrN invr_gt0 oppr_cp0. Qed.
Lemma invr_le0 x : (x^-1 <= 0) = (x <= 0).
Proof. by rewrite -oppr_cp0 -invrN invr_ge0 oppr_cp0. Qed.
Definition invr_gte0 := (invr_ge0, invr_gt0).
Definition invr_lte0 := (invr_le0, invr_lt0).
Lemma divr_ge0 x y : 0 <= x -> 0 <= y -> 0 <= x / y.
Proof. by move=> x_ge0 y_ge0; rewrite mulr_ge0 ?invr_ge0. Qed.
Lemma divr_gt0 x y : 0 < x -> 0 < y -> 0 < x / y.
Proof. by move=> x_gt0 y_gt0; rewrite pmulr_rgt0 ?invr_gt0. Qed.
Lemma realV : {mono (@GRing.inv R) : x / x \is real}.
Proof. exact: rpredV. Qed.
(* ler and exprn *)
Lemma exprn_ge0 n x : 0 <= x -> 0 <= x ^+ n.
Proof. by move=> xge0; rewrite -nnegrE rpredX. Qed.
Lemma realX n : {in real, forall x, x ^+ n \is real}.
Proof. exact: rpredX. Qed.
Lemma exprn_gt0 n x : 0 < x -> 0 < x ^+ n.
Proof.
by rewrite !lt0r expf_eq0 => /andP[/negPf-> /exprn_ge0->]; rewrite andbF.
Qed.
Definition exprn_gte0 := (exprn_ge0, exprn_gt0).
Lemma exprn_ile1 n x : 0 <= x -> x <= 1 -> x ^+ n <= 1.
Proof.
move=> xge0 xle1; elim: n=> [|*]; rewrite ?expr0 // exprS.
by rewrite mulr_ile1 ?exprn_ge0.
Qed.
Lemma exprn_ilt1 n x : 0 <= x -> x < 1 -> x ^+ n < 1 = (n != 0%N).
Proof.
move=> xge0 xlt1.
case: n; [by rewrite eqxx ltrr | elim=> [|n ihn]; first by rewrite expr1].
by rewrite exprS mulr_ilt1 // exprn_ge0.
Qed.
Definition exprn_ilte1 := (exprn_ile1, exprn_ilt1).
Lemma exprn_ege1 n x : 1 <= x -> 1 <= x ^+ n.
Proof.
by move=> x_ge1; elim: n=> [|n ihn]; rewrite ?expr0 // exprS mulr_ege1.
Qed.
Lemma exprn_egt1 n x : 1 < x -> 1 < x ^+ n = (n != 0%N).
Proof.
move=> xgt1; case: n; first by rewrite eqxx ltrr.
elim=> [|n ihn]; first by rewrite expr1.
by rewrite exprS mulr_egt1 // exprn_ge0.
Qed.
Definition exprn_egte1 := (exprn_ege1, exprn_egt1).
Definition exprn_cp1 := (exprn_ilte1, exprn_egte1).
Lemma ler_iexpr x n : (0 < n)%N -> 0 <= x -> x <= 1 -> x ^+ n <= x.
Proof. by case: n => n // *; rewrite exprS ler_pimulr // exprn_ile1. Qed.
Lemma ltr_iexpr x n : 0 < x -> x < 1 -> (x ^+ n < x) = (1 < n)%N.
Proof.
case: n=> [|[|n]] //; first by rewrite expr0 => _ /ltr_gtF ->.
by move=> x0 x1; rewrite exprS gtr_pmulr // ?exprn_ilt1 // ltrW.
Qed.
Definition lter_iexpr := (ler_iexpr, ltr_iexpr).
Lemma ler_eexpr x n : (0 < n)%N -> 1 <= x -> x <= x ^+ n.
Proof.
case: n => // n _ x_ge1.
by rewrite exprS ler_pemulr ?(ler_trans _ x_ge1) // exprn_ege1.
Qed.
Lemma ltr_eexpr x n : 1 < x -> (x < x ^+ n) = (1 < n)%N.
Proof.
move=> x_ge1; case: n=> [|[|n]] //; first by rewrite expr0 ltr_gtF.
by rewrite exprS ltr_pmulr ?(ltr_trans _ x_ge1) ?exprn_egt1.
Qed.
Definition lter_eexpr := (ler_eexpr, ltr_eexpr).
Definition lter_expr := (lter_iexpr, lter_eexpr).
Lemma ler_wiexpn2l x :
0 <= x -> x <= 1 -> {homo (GRing.exp x) : m n / (n <= m)%N >-> m <= n}.
Proof.
move=> xge0 xle1 m n /= hmn.
by rewrite -(subnK hmn) exprD ler_pimull ?(exprn_ge0, exprn_ile1).
Qed.
Lemma ler_weexpn2l x :
1 <= x -> {homo (GRing.exp x) : m n / (m <= n)%N >-> m <= n}.
Proof.
move=> xge1 m n /= hmn; rewrite -(subnK hmn) exprD.
by rewrite ler_pemull ?(exprn_ge0, exprn_ege1) // (ler_trans _ xge1) ?ler01.
Qed.
Lemma ieexprn_weq1 x n : 0 <= x -> (x ^+ n == 1) = ((n == 0%N) || (x == 1)).
Proof.
move=> xle0; case: n => [|n]; first by rewrite expr0 eqxx.
case: (@real_ltrgtP x 1); do ?by rewrite ?ger0_real.
+ by move=> x_lt1; rewrite ?ltr_eqF // exprn_ilt1.
+ by move=> x_lt1; rewrite ?gtr_eqF // exprn_egt1.
by move->; rewrite expr1n eqxx.
Qed.
Lemma ieexprIn x : 0 < x -> x != 1 -> injective (GRing.exp x).
Proof.
move=> x_gt0 x_neq1 m n; without loss /subnK <-: m n / (n <= m)%N.
by move=> IH eq_xmn; case/orP: (leq_total m n) => /IH->.
case: {m}(m - n)%N => // m /eqP/idPn[]; rewrite -[x ^+ n]mul1r exprD.
by rewrite (inj_eq (mulIf _)) ?ieexprn_weq1 ?ltrW // expf_neq0 ?gtr_eqF.
Qed.
Lemma ler_iexpn2l x :
0 < x -> x < 1 -> {mono (GRing.exp x) : m n / (n <= m)%N >-> m <= n}.
Proof.
move=> xgt0 xlt1; apply: (nhomo_leq_mono (nhomo_inj_ltn_lt _ _)); last first.
by apply: ler_wiexpn2l; rewrite ltrW.
by apply: ieexprIn; rewrite ?ltr_eqF ?ltr_cpable.
Qed.
Lemma ltr_iexpn2l x :
0 < x -> x < 1 -> {mono (GRing.exp x) : m n / (n < m)%N >-> m < n}.
Proof. by move=> xgt0 xlt1; apply: (leq_lerW_nmono (ler_iexpn2l _ _)). Qed.
Definition lter_iexpn2l := (ler_iexpn2l, ltr_iexpn2l).
Lemma ler_eexpn2l x :
1 < x -> {mono (GRing.exp x) : m n / (m <= n)%N >-> m <= n}.
Proof.
move=> xgt1; apply: (homo_leq_mono (homo_inj_ltn_lt _ _)); last first.
by apply: ler_weexpn2l; rewrite ltrW.
by apply: ieexprIn; rewrite ?gtr_eqF ?gtr_cpable //; apply: ltr_trans xgt1.
Qed.
Lemma ltr_eexpn2l x :
1 < x -> {mono (GRing.exp x) : m n / (m < n)%N >-> m < n}.
Proof. by move=> xgt1; apply: (leq_lerW_mono (ler_eexpn2l _)). Qed.
Definition lter_eexpn2l := (ler_eexpn2l, ltr_eexpn2l).
Lemma ltr_expn2r n x y : 0 <= x -> x < y -> x ^+ n < y ^+ n = (n != 0%N).
Proof.
move=> xge0 xlty; case: n; first by rewrite ltrr.
elim=> [|n IHn]; rewrite ?[_ ^+ _.+2]exprS //.
rewrite (@ler_lt_trans _ (x * y ^+ n.+1)) ?ler_wpmul2l ?ltr_pmul2r ?IHn //.
by rewrite ltrW // ihn.
by rewrite exprn_gt0 // (ler_lt_trans xge0).
Qed.
Lemma ler_expn2r n : {in nneg & , {homo ((@GRing.exp R)^~ n) : x y / x <= y}}.
Proof.
move=> x y /= x0 y0 xy; elim: n => [|n IHn]; rewrite !(expr0, exprS) //.
by rewrite (@ler_trans _ (x * y ^+ n)) ?ler_wpmul2l ?ler_wpmul2r ?exprn_ge0.
Qed.
Definition lter_expn2r := (ler_expn2r, ltr_expn2r).
Lemma ltr_wpexpn2r n :
(0 < n)%N -> {in nneg & , {homo ((@GRing.exp R)^~ n) : x y / x < y}}.
Proof. by move=> ngt0 x y /= x0 y0 hxy; rewrite ltr_expn2r // -lt0n. Qed.
Lemma ler_pexpn2r n :
(0 < n)%N -> {in nneg & , {mono ((@GRing.exp R)^~ n) : x y / x <= y}}.
Proof.
case: n => // n _ x y; rewrite !qualifE /= => x_ge0 y_ge0.
have [-> | nzx] := eqVneq x 0; first by rewrite exprS mul0r exprn_ge0.
rewrite -subr_ge0 subrXX pmulr_lge0 ?subr_ge0 //= big_ord_recr /=.
rewrite subnn expr0 mul1r /= ltr_spaddr // ?exprn_gt0 ?lt0r ?nzx //.
by rewrite sumr_ge0 // => i _; rewrite mulr_ge0 ?exprn_ge0.
Qed.
Lemma ltr_pexpn2r n :
(0 < n)%N -> {in nneg & , {mono ((@GRing.exp R)^~ n) : x y / x < y}}.
Proof.
by move=> n_gt0 x y x_ge0 y_ge0; rewrite !ltr_neqAle !eqr_le !ler_pexpn2r.
Qed.
Definition lter_pexpn2r := (ler_pexpn2r, ltr_pexpn2r).
Lemma pexpIrn n : (0 < n)%N -> {in nneg &, injective ((@GRing.exp R)^~ n)}.
Proof. by move=> n_gt0; apply: mono_inj_in (ler_pexpn2r _). Qed.
(* expr and ler/ltr *)
Lemma expr_le1 n x : (0 < n)%N -> 0 <= x -> (x ^+ n <= 1) = (x <= 1).
Proof.
by move=> ngt0 xge0; rewrite -{1}[1](expr1n _ n) ler_pexpn2r // [_ \in _]ler01.
Qed.
Lemma expr_lt1 n x : (0 < n)%N -> 0 <= x -> (x ^+ n < 1) = (x < 1).
Proof.
by move=> ngt0 xge0; rewrite -{1}[1](expr1n _ n) ltr_pexpn2r // [_ \in _]ler01.
Qed.
Definition expr_lte1 := (expr_le1, expr_lt1).
Lemma expr_ge1 n x : (0 < n)%N -> 0 <= x -> (1 <= x ^+ n) = (1 <= x).
Proof.
by move=> ngt0 xge0; rewrite -{1}[1](expr1n _ n) ler_pexpn2r // [_ \in _]ler01.
Qed.
Lemma expr_gt1 n x : (0 < n)%N -> 0 <= x -> (1 < x ^+ n) = (1 < x).
Proof.
by move=> ngt0 xge0; rewrite -{1}[1](expr1n _ n) ltr_pexpn2r // [_ \in _]ler01.
Qed.
Definition expr_gte1 := (expr_ge1, expr_gt1).
Lemma pexpr_eq1 x n : (0 < n)%N -> 0 <= x -> (x ^+ n == 1) = (x == 1).
Proof. by move=> ngt0 xge0; rewrite !eqr_le expr_le1 // expr_ge1. Qed.
Lemma pexprn_eq1 x n : 0 <= x -> (x ^+ n == 1) = (n == 0%N) || (x == 1).
Proof. by case: n => [|n] xge0; rewrite ?eqxx // pexpr_eq1 ?gtn_eqF. Qed.
Lemma eqr_expn2 n x y :
(0 < n)%N -> 0 <= x -> 0 <= y -> (x ^+ n == y ^+ n) = (x == y).
Proof. by move=> ngt0 xge0 yge0; rewrite (inj_in_eq (pexpIrn _)). Qed.
Lemma sqrp_eq1 x : 0 <= x -> (x ^+ 2 == 1) = (x == 1).
Proof. by move/pexpr_eq1->. Qed.
Lemma sqrn_eq1 x : x <= 0 -> (x ^+ 2 == 1) = (x == -1).
Proof. by rewrite -sqrrN -oppr_ge0 -eqr_oppLR => /sqrp_eq1. Qed.
Lemma ler_sqr : {in nneg &, {mono (fun x => x ^+ 2) : x y / x <= y}}.
Proof. exact: ler_pexpn2r. Qed.
Lemma ltr_sqr : {in nneg &, {mono (fun x => x ^+ 2) : x y / x < y}}.
Proof. exact: ltr_pexpn2r. Qed.
Lemma ler_pinv :
{in [pred x in GRing.unit | 0 < x] &, {mono (@GRing.inv R) : x y /~ x <= y}}.
Proof.
move=> x y /andP [ux hx] /andP [uy hy] /=.
rewrite -(ler_pmul2l hx) -(ler_pmul2r hy).
by rewrite !(divrr, mulrVK) ?unitf_gt0 // mul1r.
Qed.
Lemma ler_ninv :
{in [pred x in GRing.unit | x < 0] &, {mono (@GRing.inv R) : x y /~ x <= y}}.
Proof.
move=> x y /andP [ux hx] /andP [uy hy] /=.
rewrite -(ler_nmul2l hx) -(ler_nmul2r hy).
by rewrite !(divrr, mulrVK) ?unitf_lt0 // mul1r.
Qed.
Lemma ltr_pinv :
{in [pred x in GRing.unit | 0 < x] &, {mono (@GRing.inv R) : x y /~ x < y}}.
Proof. exact: lerW_nmono_in ler_pinv. Qed.
Lemma ltr_ninv :
{in [pred x in GRing.unit | x < 0] &, {mono (@GRing.inv R) : x y /~ x < y}}.
Proof. exact: lerW_nmono_in ler_ninv. Qed.
Lemma invr_gt1 x : x \is a GRing.unit -> 0 < x -> (1 < x^-1) = (x < 1).
Proof.
by move=> Ux xgt0; rewrite -{1}[1]invr1 ltr_pinv ?inE ?unitr1 ?ltr01 ?Ux.
Qed.
Lemma invr_ge1 x : x \is a GRing.unit -> 0 < x -> (1 <= x^-1) = (x <= 1).
Proof.
by move=> Ux xgt0; rewrite -{1}[1]invr1 ler_pinv ?inE ?unitr1 ?ltr01 // Ux.
Qed.
Definition invr_gte1 := (invr_ge1, invr_gt1).
Lemma invr_le1 x (ux : x \is a GRing.unit) (hx : 0 < x) :
(x^-1 <= 1) = (1 <= x).
Proof. by rewrite -invr_ge1 ?invr_gt0 ?unitrV // invrK. Qed.
Lemma invr_lt1 x (ux : x \is a GRing.unit) (hx : 0 < x) : (x^-1 < 1) = (1 < x).
Proof. by rewrite -invr_gt1 ?invr_gt0 ?unitrV // invrK. Qed.
Definition invr_lte1 := (invr_le1, invr_lt1).
Definition invr_cp1 := (invr_gte1, invr_lte1).
(* norm *)
Lemma real_ler_norm x : x \is real -> x <= `|x|.
Proof.
by case/real_ger0P=> hx //; rewrite (ler_trans (ltrW hx)) // oppr_ge0 ltrW.
Qed.
(* norm + add *)
Lemma normr_real x : `|x| \is real. Proof. by rewrite ger0_real. Qed.
Hint Resolve normr_real.
Lemma ler_norm_sum I r (G : I -> R) (P : pred I):
`|\sum_(i <- r | P i) G i| <= \sum_(i <- r | P i) `|G i|.
Proof.
elim/big_rec2: _ => [|i y x _]; first by rewrite normr0.
by rewrite -(ler_add2l `|G i|); apply: ler_trans; apply: ler_norm_add.
Qed.
Lemma ler_norm_sub x y : `|x - y| <= `|x| + `|y|.
Proof. by rewrite (ler_trans (ler_norm_add _ _)) ?normrN. Qed.
Lemma ler_dist_add z x y : `|x - y| <= `|x - z| + `|z - y|.
Proof. by rewrite (ler_trans _ (ler_norm_add _ _)) // addrA addrNK. Qed.
Lemma ler_sub_norm_add x y : `|x| - `|y| <= `|x + y|.
Proof.
rewrite -{1}[x](addrK y) lter_sub_addl.
by rewrite (ler_trans (ler_norm_add _ _)) // addrC normrN.
Qed.
Lemma ler_sub_dist x y : `|x| - `|y| <= `|x - y|.
Proof. by rewrite -[`|y|]normrN ler_sub_norm_add. Qed.
Lemma ler_dist_dist x y : `|`|x| - `|y| | <= `|x - y|.
Proof.
have [||_|_] // := @real_lerP `|x| `|y|; last by rewrite ler_sub_dist.
by rewrite distrC ler_sub_dist.
Qed.
Lemma ler_dist_norm_add x y : `| `|x| - `|y| | <= `| x + y |.
Proof. by rewrite -[y]opprK normrN ler_dist_dist. Qed.
Lemma real_ler_norml x y : x \is real -> (`|x| <= y) = (- y <= x <= y).
Proof.
move=> xR; wlog x_ge0 : x xR / 0 <= x => [hwlog|].
move: (xR) => /(@real_leVge 0) /orP [|/hwlog->|hx] //.
by rewrite -[x]opprK normrN ler_opp2 andbC ler_oppl hwlog ?realN ?oppr_ge0.
rewrite ger0_norm //; have [le_xy|] := boolP (x <= y); last by rewrite andbF.
by rewrite (ler_trans _ x_ge0) // oppr_le0 (ler_trans x_ge0).
Qed.
Lemma real_ler_normlP x y :
x \is real -> reflect ((-x <= y) * (x <= y)) (`|x| <= y).
Proof.
by move=> Rx; rewrite real_ler_norml // ler_oppl; apply: (iffP andP) => [] [].
Qed.
Implicit Arguments real_ler_normlP [x y].
Lemma real_eqr_norml x y :
x \is real -> (`|x| == y) = ((x == y) || (x == -y)) && (0 <= y).
Proof.
move=> Rx.
apply/idP/idP=> [|/andP[/pred2P[]-> /ger0_norm/eqP]]; rewrite ?normrE //.
case: real_ler0P => // hx; rewrite 1?eqr_oppLR => /eqP exy.
by move: hx; rewrite exy ?oppr_le0 eqxx orbT //.
by move: hx=> /ltrW; rewrite exy eqxx.
Qed.
Lemma real_eqr_norm2 x y :
x \is real -> y \is real -> (`|x| == `|y|) = (x == y) || (x == -y).
Proof.
move=> Rx Ry; rewrite real_eqr_norml // normrE andbT.
by case: real_ler0P; rewrite // opprK orbC.
Qed.
Lemma real_ltr_norml x y : x \is real -> (`|x| < y) = (- y < x < y).
Proof.
move=> Rx; wlog x_ge0 : x Rx / 0 <= x => [hwlog|].
move: (Rx) => /(@real_leVge 0) /orP [|/hwlog->|hx] //.
by rewrite -[x]opprK normrN ltr_opp2 andbC ltr_oppl hwlog ?realN ?oppr_ge0.
rewrite ger0_norm //; have [le_xy|] := boolP (x < y); last by rewrite andbF.
by rewrite (ltr_le_trans _ x_ge0) // oppr_lt0 (ler_lt_trans x_ge0).
Qed.
Definition real_lter_norml := (real_ler_norml, real_ltr_norml).
Lemma real_ltr_normlP x y :
x \is real -> reflect ((-x < y) * (x < y)) (`|x| < y).
Proof.
move=> Rx; rewrite real_ltr_norml // ltr_oppl.
by apply: (iffP (@andP _ _)); case.
Qed.
Implicit Arguments real_ltr_normlP [x y].
Lemma real_ler_normr x y : y \is real -> (x <= `|y|) = (x <= y) || (x <= - y).
Proof.
move=> Ry.
have [xR|xNR] := boolP (x \is real); last by rewrite ?Nreal_leF ?realN.
rewrite real_lerNgt ?real_ltr_norml // negb_and -?real_lerNgt ?realN //.
by rewrite orbC ler_oppr.
Qed.
Lemma real_ltr_normr x y : y \is real -> (x < `|y|) = (x < y) || (x < - y).
Proof.
move=> Ry.
have [xR|xNR] := boolP (x \is real); last by rewrite ?Nreal_ltF ?realN.
rewrite real_ltrNge ?real_ler_norml // negb_and -?real_ltrNge ?realN //.
by rewrite orbC ltr_oppr.
Qed.
Definition real_lter_normr := (real_ler_normr, real_ltr_normr).
Lemma ler_nnorml x y : y < 0 -> `|x| <= y = false.
Proof. by move=> y_lt0; rewrite ltr_geF // (ltr_le_trans y_lt0). Qed.
Lemma ltr_nnorml x y : y <= 0 -> `|x| < y = false.
Proof. by move=> y_le0; rewrite ler_gtF // (ler_trans y_le0). Qed.
Definition lter_nnormr := (ler_nnorml, ltr_nnorml).
Lemma real_ler_distl x y e :
x - y \is real -> (`|x - y| <= e) = (y - e <= x <= y + e).
Proof. by move=> Rxy; rewrite real_lter_norml // !lter_sub_addl. Qed.
Lemma real_ltr_distl x y e :
x - y \is real -> (`|x - y| < e) = (y - e < x < y + e).
Proof. by move=> Rxy; rewrite real_lter_norml // !lter_sub_addl. Qed.
Definition real_lter_distl := (real_ler_distl, real_ltr_distl).
(* GG: pointless duplication }-( *)
Lemma eqr_norm_id x : (`|x| == x) = (0 <= x). Proof. by rewrite ger0_def. Qed.
Lemma eqr_normN x : (`|x| == - x) = (x <= 0). Proof. by rewrite ler0_def. Qed.
Definition eqr_norm_idVN := =^~ (ger0_def, ler0_def).
Lemma real_exprn_even_ge0 n x : x \is real -> ~~ odd n -> 0 <= x ^+ n.
Proof.
move=> xR even_n; have [/exprn_ge0 -> //|x_lt0] := real_ger0P xR.
rewrite -[x]opprK -mulN1r exprMn -signr_odd (negPf even_n) expr0 mul1r.
by rewrite exprn_ge0 ?oppr_ge0 ?ltrW.
Qed.
Lemma real_exprn_even_gt0 n x :
x \is real -> ~~ odd n -> (0 < x ^+ n) = (n == 0)%N || (x != 0).
Proof.
move=> xR n_even; rewrite lt0r real_exprn_even_ge0 ?expf_eq0 //.
by rewrite andbT negb_and lt0n negbK.
Qed.
Lemma real_exprn_even_le0 n x :
x \is real -> ~~ odd n -> (x ^+ n <= 0) = (n != 0%N) && (x == 0).
Proof.
move=> xR n_even; rewrite !real_lerNgt ?rpred0 ?rpredX //.
by rewrite real_exprn_even_gt0 // negb_or negbK.
Qed.
Lemma real_exprn_even_lt0 n x :
x \is real -> ~~ odd n -> (x ^+ n < 0) = false.
Proof. by move=> xR n_even; rewrite ler_gtF // real_exprn_even_ge0. Qed.
Lemma real_exprn_odd_ge0 n x :
x \is real -> odd n -> (0 <= x ^+ n) = (0 <= x).
Proof.
case/real_ger0P => [x_ge0|x_lt0] n_odd; first by rewrite exprn_ge0.
apply: negbTE; rewrite ltr_geF //.
case: n n_odd => // n /= n_even; rewrite exprS pmulr_llt0 //.
by rewrite real_exprn_even_gt0 ?ler0_real ?ltrW // ltr_eqF ?orbT.
Qed.
Lemma real_exprn_odd_gt0 n x : x \is real -> odd n -> (0 < x ^+ n) = (0 < x).
Proof.
by move=> xR n_odd; rewrite !lt0r expf_eq0 real_exprn_odd_ge0; case: n n_odd.
Qed.
Lemma real_exprn_odd_le0 n x : x \is real -> odd n -> (x ^+ n <= 0) = (x <= 0).
Proof.
by move=> xR n_odd; rewrite !real_lerNgt ?rpred0 ?rpredX // real_exprn_odd_gt0.
Qed.
Lemma real_exprn_odd_lt0 n x : x \is real -> odd n -> (x ^+ n < 0) = (x < 0).
Proof.
by move=> xR n_odd; rewrite !real_ltrNge ?rpred0 ?rpredX // real_exprn_odd_ge0.
Qed.
(* GG: Could this be a better definition of "real" ? *)
Lemma realEsqr x : (x \is real) = (0 <= x ^+ 2).
Proof. by rewrite ger0_def normrX eqf_sqr -ger0_def -ler0_def. Qed.
Lemma real_normK x : x \is real -> `|x| ^+ 2 = x ^+ 2.
Proof. by move=> Rx; rewrite -normrX ger0_norm -?realEsqr. Qed.
(* Binary sign ((-1) ^+ s). *)
Lemma normr_sign s : `|(-1) ^+ s| = 1 :> R.
Proof. by rewrite normrX normrN1 expr1n. Qed.
Lemma normrMsign s x : `|(-1) ^+ s * x| = `|x|.
Proof. by rewrite normrM normr_sign mul1r. Qed.
Lemma signr_gt0 (b : bool) : (0 < (-1) ^+ b :> R) = ~~ b.
Proof. by case: b; rewrite (ltr01, ltr0N1). Qed.
Lemma signr_lt0 (b : bool) : ((-1) ^+ b < 0 :> R) = b.
Proof. by case: b; rewrite // ?(ltrN10, ltr10). Qed.
Lemma signr_ge0 (b : bool) : (0 <= (-1) ^+ b :> R) = ~~ b.
Proof. by rewrite le0r signr_eq0 signr_gt0. Qed.
Lemma signr_le0 (b : bool) : ((-1) ^+ b <= 0 :> R) = b.
Proof. by rewrite ler_eqVlt signr_eq0 signr_lt0. Qed.
(* This actually holds for char R != 2. *)
Lemma signr_inj : injective (fun b : bool => (-1) ^+ b : R).
Proof. exact: can_inj (fun x => 0 >= x) signr_le0. Qed.
(* Ternary sign (sg). *)
Lemma sgr_def x : sg x = (-1) ^+ (x < 0)%R *+ (x != 0).
Proof. by rewrite /sg; do 2!case: ifP => //. Qed.
Lemma neqr0_sign x : x != 0 -> (-1) ^+ (x < 0)%R = sgr x.
Proof. by rewrite sgr_def => ->. Qed.
Lemma gtr0_sg x : 0 < x -> sg x = 1.
Proof. by move=> x_gt0; rewrite /sg gtr_eqF // ltr_gtF. Qed.
Lemma ltr0_sg x : x < 0 -> sg x = -1.
Proof. by move=> x_lt0; rewrite /sg x_lt0 ltr_eqF. Qed.
Lemma sgr0 : sg 0 = 0 :> R. Proof. by rewrite /sgr eqxx. Qed.
Lemma sgr1 : sg 1 = 1 :> R. Proof. by rewrite gtr0_sg // ltr01. Qed.
Lemma sgrN1 : sg (-1) = -1 :> R. Proof. by rewrite ltr0_sg // ltrN10. Qed.
Definition sgrE := (sgr0, sgr1, sgrN1).
Lemma sqr_sg x : sg x ^+ 2 = (x != 0)%:R.
Proof. by rewrite sgr_def exprMn_n sqrr_sign -mulnn mulnb andbb. Qed.
Lemma mulr_sg_eq1 x y : (sg x * y == 1) = (x != 0) && (sg x == y).
Proof.
rewrite /sg eq_sym; case: ifP => _; first by rewrite mul0r oner_eq0.
by case: ifP => _; rewrite ?mul1r // mulN1r eqr_oppLR.
Qed.
Lemma mulr_sg_eqN1 x y : (sg x * sg y == -1) = (x != 0) && (sg x == - sg y).
Proof.
move/sg: y => y; rewrite /sg eq_sym eqr_oppLR.
case: ifP => _; first by rewrite mul0r oppr0 oner_eq0.
by case: ifP => _; rewrite ?mul1r // mulN1r eqr_oppLR.
Qed.
Lemma sgr_eq0 x : (sg x == 0) = (x == 0).
Proof. by rewrite -sqrf_eq0 sqr_sg pnatr_eq0; case: (x == 0). Qed.
Lemma sgr_odd n x : x != 0 -> (sg x) ^+ n = (sg x) ^+ (odd n).
Proof. by rewrite /sg; do 2!case: ifP => // _; rewrite ?expr1n ?signr_odd. Qed.
Lemma sgrMn x n : sg (x *+ n) = (n != 0%N)%:R * sg x.
Proof.
case: n => [|n]; first by rewrite mulr0n sgr0 mul0r.
by rewrite !sgr_def mulrn_eq0 mul1r pmulrn_llt0.
Qed.
Lemma sgr_nat n : sg n%:R = (n != 0%N)%:R :> R.
Proof. by rewrite sgrMn sgr1 mulr1. Qed.
Lemma sgr_id x : sg (sg x) = sg x.
Proof. by rewrite !(fun_if sg) !sgrE. Qed.
Lemma sgr_lt0 x : (sg x < 0) = (x < 0).
Proof.
rewrite /sg; case: eqP => [-> // | _].
by case: ifP => _; rewrite ?ltrN10 // ltr_gtF.
Qed.
Lemma sgr_le0 x : (sgr x <= 0) = (x <= 0).
Proof. by rewrite !ler_eqVlt sgr_eq0 sgr_lt0. Qed.
(* sign and norm *)
Lemma realEsign x : x \is real -> x = (-1) ^+ (x < 0)%R * `|x|.
Proof. by case/real_ger0P; rewrite (mul1r, mulN1r) ?opprK. Qed.
Lemma realNEsign x : x \is real -> - x = (-1) ^+ (0 < x)%R * `|x|.
Proof. by move=> Rx; rewrite -normrN -oppr_lt0 -realEsign ?rpredN. Qed.
Lemma real_normrEsign (x : R) (xR : x \is real) : `|x| = (-1) ^+ (x < 0)%R * x.
Proof. by rewrite {3}[x]realEsign // signrMK. Qed.
(* GG: pointless duplication... *)
Lemma real_mulr_sign_norm x : x \is real -> (-1) ^+ (x < 0)%R * `|x| = x.
Proof. by move/realEsign. Qed.
Lemma real_mulr_Nsign_norm x : x \is real -> (-1) ^+ (0 < x)%R * `|x| = - x.
Proof. by move/realNEsign. Qed.
Lemma realEsg x : x \is real -> x = sgr x * `|x|.
Proof.
move=> xR; have [-> | ] := eqVneq x 0; first by rewrite normr0 mulr0.
by move=> /neqr0_sign <-; rewrite -realEsign.
Qed.
Lemma normr_sg x : `|sg x| = (x != 0)%:R.
Proof. by rewrite sgr_def -mulr_natr normrMsign normr_nat. Qed.
Lemma sgr_norm x : sg `|x| = (x != 0)%:R.
Proof. by rewrite /sg ler_gtF ?normr_ge0 // normr_eq0 mulrb if_neg. Qed.
(* lerif *)
Lemma lerif_refl x C : reflect (x <= x ?= iff C) C.
Proof. by apply: (iffP idP) => [-> | <-] //; split; rewrite ?eqxx. Qed.
Lemma lerif_trans x1 x2 x3 C12 C23 :
x1 <= x2 ?= iff C12 -> x2 <= x3 ?= iff C23 -> x1 <= x3 ?= iff C12 && C23.
Proof.
move=> ltx12 ltx23; apply/lerifP; rewrite -ltx12.
case eqx12: (x1 == x2).
by rewrite (eqP eqx12) ltr_neqAle !ltx23 andbT; case C23.
by rewrite (@ltr_le_trans _ x2) ?ltx23 // ltr_neqAle eqx12 ltx12.
Qed.
Lemma lerif_le x y : x <= y -> x <= y ?= iff (x >= y).
Proof. by move=> lexy; split=> //; rewrite eqr_le lexy. Qed.
Lemma lerif_eq x y : x <= y -> x <= y ?= iff (x == y).
Proof. by []. Qed.
Lemma ger_lerif x y C : x <= y ?= iff C -> (y <= x) = C.
Proof. by case=> le_xy; rewrite eqr_le le_xy. Qed.
Lemma ltr_lerif x y C : x <= y ?= iff C -> (x < y) = ~~ C.
Proof. by move=> le_xy; rewrite ltr_neqAle !le_xy andbT. Qed.
Lemma lerif_nat m n C : (m%:R <= n%:R ?= iff C :> R) = (m <= n ?= iff C)%N.
Proof. by rewrite /lerif !ler_nat eqr_nat. Qed.
Lemma mono_in_lerif (A : pred R) (f : R -> R) C :
{in A &, {mono f : x y / x <= y}} ->
{in A &, forall x y, (f x <= f y ?= iff C) = (x <= y ?= iff C)}.
Proof.
by move=> mf x y Ax Ay; rewrite /lerif mf ?(inj_in_eq (mono_inj_in mf)).
Qed.
Lemma mono_lerif (f : R -> R) C :
{mono f : x y / x <= y} ->
forall x y, (f x <= f y ?= iff C) = (x <= y ?= iff C).
Proof. by move=> mf x y; rewrite /lerif mf (inj_eq (mono_inj _)). Qed.
Lemma nmono_in_lerif (A : pred R) (f : R -> R) C :
{in A &, {mono f : x y /~ x <= y}} ->
{in A &, forall x y, (f x <= f y ?= iff C) = (y <= x ?= iff C)}.
Proof.
by move=> mf x y Ax Ay; rewrite /lerif eq_sym mf ?(inj_in_eq (nmono_inj_in mf)).
Qed.
Lemma nmono_lerif (f : R -> R) C :
{mono f : x y /~ x <= y} ->
forall x y, (f x <= f y ?= iff C) = (y <= x ?= iff C).
Proof. by move=> mf x y; rewrite /lerif eq_sym mf ?(inj_eq (nmono_inj mf)). Qed.
Lemma lerif_subLR x y z C : (x - y <= z ?= iff C) = (x <= z + y ?= iff C).
Proof. by rewrite /lerif !eqr_le ler_subr_addr ler_subl_addr. Qed.
Lemma lerif_subRL x y z C : (x <= y - z ?= iff C) = (x + z <= y ?= iff C).
Proof. by rewrite -lerif_subLR opprK. Qed.
Lemma lerif_add x1 y1 C1 x2 y2 C2 :
x1 <= y1 ?= iff C1 -> x2 <= y2 ?= iff C2 ->
x1 + x2 <= y1 + y2 ?= iff C1 && C2.
Proof.
rewrite -(mono_lerif _ (ler_add2r x2)) -(mono_lerif C2 (ler_add2l y1)).
exact: lerif_trans.
Qed.
Lemma lerif_sum (I : finType) (P C : pred I) (E1 E2 : I -> R) :
(forall i, P i -> E1 i <= E2 i ?= iff C i) ->
\sum_(i | P i) E1 i <= \sum_(i | P i) E2 i ?= iff [forall (i | P i), C i].
Proof.
move=> leE12; rewrite -big_andE.
elim/big_rec3: _ => [|i Ci m2 m1 /leE12]; first by rewrite /lerif lerr eqxx.
exact: lerif_add.
Qed.
Lemma lerif_0_sum (I : finType) (P C : pred I) (E : I -> R) :
(forall i, P i -> 0 <= E i ?= iff C i) ->
0 <= \sum_(i | P i) E i ?= iff [forall (i | P i), C i].
Proof. by move/lerif_sum; rewrite big1_eq. Qed.
Lemma real_lerif_norm x : x \is real -> x <= `|x| ?= iff (0 <= x).
Proof.
by move=> xR; rewrite ger0_def eq_sym; apply: lerif_eq; rewrite real_ler_norm.
Qed.
Lemma lerif_pmul x1 x2 y1 y2 C1 C2 :
0 <= x1 -> 0 <= x2 -> x1 <= y1 ?= iff C1 -> x2 <= y2 ?= iff C2 ->
x1 * x2 <= y1 * y2 ?= iff (y1 * y2 == 0) || C1 && C2.
Proof.
move=> x1_ge0 x2_ge0 le_xy1 le_xy2; have [y_0 | ] := altP (_ =P 0).
apply/lerifP; rewrite y_0 /= mulf_eq0 !eqr_le x1_ge0 x2_ge0 !andbT.
move/eqP: y_0; rewrite mulf_eq0.
by case/pred2P=> <-; rewrite (le_xy1, le_xy2) ?orbT.
rewrite /= mulf_eq0 => /norP[y1nz y2nz].
have y1_gt0: 0 < y1 by rewrite ltr_def y1nz (ler_trans _ le_xy1).
have [x2_0 | x2nz] := eqVneq x2 0.
apply/lerifP; rewrite -le_xy2 x2_0 eq_sym (negPf y2nz) andbF mulr0.
by rewrite mulr_gt0 // ltr_def y2nz -x2_0 le_xy2.
have:= le_xy2; rewrite -(mono_lerif _ (ler_pmul2l y1_gt0)).
by apply: lerif_trans; rewrite (mono_lerif _ (ler_pmul2r _)) // ltr_def x2nz.
Qed.
Lemma lerif_nmul x1 x2 y1 y2 C1 C2 :
y1 <= 0 -> y2 <= 0 -> x1 <= y1 ?= iff C1 -> x2 <= y2 ?= iff C2 ->
y1 * y2 <= x1 * x2 ?= iff (x1 * x2 == 0) || C1 && C2.
Proof.
rewrite -!oppr_ge0 -mulrNN -[x1 * x2]mulrNN => y1le0 y2le0 le_xy1 le_xy2.
by apply: lerif_pmul => //; rewrite (nmono_lerif _ ler_opp2).
Qed.
Lemma lerif_pprod (I : finType) (P C : pred I) (E1 E2 : I -> R) :
(forall i, P i -> 0 <= E1 i) ->
(forall i, P i -> E1 i <= E2 i ?= iff C i) ->
let pi E := \prod_(i | P i) E i in
pi E1 <= pi E2 ?= iff (pi E2 == 0) || [forall (i | P i), C i].
Proof.
move=> E1_ge0 leE12 /=; rewrite -big_andE; elim/(big_load (fun x => 0 <= x)): _.
elim/big_rec3: _ => [|i Ci m2 m1 Pi [m1ge0 le_m12]].
by split=> //; apply/lerifP; rewrite orbT.
have Ei_ge0 := E1_ge0 i Pi; split; first by rewrite mulr_ge0.
congr (lerif _ _ _): (lerif_pmul Ei_ge0 m1ge0 (leE12 i Pi) le_m12).
by rewrite mulf_eq0 -!orbA; congr (_ || _); rewrite !orb_andr orbA orbb.
Qed.
(* Mean inequalities. *)
Lemma real_lerif_mean_square_scaled x y :
x \is real -> y \is real -> x * y *+ 2 <= x ^+ 2 + y ^+ 2 ?= iff (x == y).
Proof.
move=> Rx Ry; rewrite -[_ *+ 2]add0r -lerif_subRL addrAC -sqrrB -subr_eq0.
by rewrite -sqrf_eq0 eq_sym; apply: lerif_eq; rewrite -realEsqr rpredB.
Qed.
Lemma real_lerif_AGM2_scaled x y :
x \is real -> y \is real -> x * y *+ 4 <= (x + y) ^+ 2 ?= iff (x == y).
Proof.
move=> Rx Ry; rewrite sqrrD addrAC (mulrnDr _ 2) -lerif_subLR addrK.
exact: real_lerif_mean_square_scaled.
Qed.
Lemma lerif_AGM_scaled (I : finType) (A : pred I) (E : I -> R) :
let n := #|A| in {in A, forall i, 0 <= E i *+ n} ->
\prod_(i in A) (E i *+ n) <= (\sum_(i in A) E i) ^+ n
?= iff [forall i in A, forall j in A, E i == E j].
Proof.
elim: {A}_.+1 {-2}A (ltnSn #|A|) => // m IHm A leAm in E * => n Ege0.
apply/lerifP; case: ifPn => [/forall_inP Econstant | Enonconstant].
have [i /= Ai | A0] := pickP (mem A); last first.
by rewrite /n eq_card0 // big_pred0.
have /eqfun_inP E_i := Econstant i Ai; rewrite -(eq_bigr _ E_i) sumr_const.
by rewrite exprMn_n prodrMn -(eq_bigr _ E_i) prodr_const.
set mu := \sum_(i in A) _.
pose En i := E i *+ n; pose cmp_mu s := [pred i | s * mu < s * En i].
have{Enonconstant} has_cmp_mu e (s := (-1) ^+ e): {i | i \in A & cmp_mu s i}.
apply/sig2W/exists_inP; apply: contraR Enonconstant.
rewrite negb_exists_in => /forall_inP mu_s_A.
have n_gt0 i: i \in A -> (0 < n)%N by rewrite /n (cardD1 i) => ->.
have{mu_s_A} mu_s_A i: i \in A -> s * En i <= s * mu.
move=> Ai; rewrite real_lerNgt ?mu_s_A ?rpredMsign ?ger0_real ?Ege0 //.
by rewrite -(pmulrn_lge0 _ (n_gt0 i Ai)) -sumrMnl sumr_ge0.
have [_ /esym/eqfun_inP] := lerif_sum (fun i Ai => lerif_eq (mu_s_A i Ai)).
rewrite sumr_const -/n -mulr_sumr sumrMnl -/mu mulrnAr eqxx => A_mu.
apply/forall_inP=> i Ai; apply/eqfun_inP=> j Aj.
by apply: (pmulrnI (n_gt0 i Ai)); apply: (can_inj (signrMK e)); rewrite !A_mu.
have [[i Ai Ei_lt_mu] [j Aj Ej_gt_mu]] := (has_cmp_mu true, has_cmp_mu false).
rewrite {cmp_mu has_cmp_mu}/= !mul1r !mulN1r ltr_opp2 in Ei_lt_mu Ej_gt_mu.
pose A' := [predD1 A & i]; pose n' := #|A'|.
have [Dn n_gt0]: n = n'.+1 /\ (n > 0)%N by rewrite /n (cardD1 i) Ai.
have i'j: j != i by apply: contraTneq Ej_gt_mu => ->; rewrite ltr_gtF.
have{i'j} A'j: j \in A' by rewrite !inE Aj i'j.
have mu_gt0: 0 < mu := ler_lt_trans (Ege0 i Ai) Ei_lt_mu.
rewrite (bigD1 i) // big_andbC (bigD1 j) //= mulrA; set pi := \prod_(k | _) _.
have [-> | nz_pi] := eqVneq pi 0; first by rewrite !mulr0 exprn_gt0.
have{nz_pi} pi_gt0: 0 < pi.
by rewrite ltr_def nz_pi prodr_ge0 // => k /andP[/andP[_ /Ege0]].
rewrite -/(En i) -/(En j); pose E' := [eta En with j |-> En i + En j - mu].
have E'ge0 k: k \in A' -> E' k *+ n' >= 0.
case/andP=> /= _ Ak; apply: mulrn_wge0; case: ifP => _; last exact: Ege0.
by rewrite subr_ge0 ler_paddl ?Ege0 // ltrW.
rewrite -/n Dn in leAm; have{leAm IHm E'ge0}: _ <= _ := IHm _ leAm _ E'ge0.
have ->: \sum_(k in A') E' k = mu *+ n'.
apply: (addrI mu); rewrite -mulrS -Dn -sumrMnl (bigD1 i Ai) big_andbC /=.
rewrite !(bigD1 j A'j) /= addrCA eqxx !addrA subrK; congr (_ + _).
by apply: eq_bigr => k /andP[_ /negPf->].
rewrite prodrMn exprMn_n -/n' ler_pmuln2r ?expn_gt0; last by case: (n').
have ->: \prod_(k in A') E' k = E' j * pi.
by rewrite (bigD1 j) //=; congr *%R; apply: eq_bigr => k /andP[_ /negPf->].
rewrite -(ler_pmul2l mu_gt0) -exprS -Dn mulrA; apply: ltr_le_trans.
rewrite ltr_pmul2r //= eqxx -addrA mulrDr mulrC -subr_gt0 addrAC -mulrBl.
by rewrite -opprB mulNr addrC mulrC -mulrBr mulr_gt0 ?subr_gt0.
Qed.
(* Polynomial bound. *)
Implicit Type p : {poly R}.
Lemma poly_disk_bound p b : {ub | forall x, `|x| <= b -> `|p.[x]| <= ub}.
Proof.
exists (\sum_(j < size p) `|p`_j| * b ^+ j) => x le_x_b.
rewrite horner_coef (ler_trans (ler_norm_sum _ _ _)) ?ler_sum // => j _.
rewrite normrM normrX ler_wpmul2l ?ler_expn2r ?unfold_in ?normr_ge0 //.
exact: ler_trans (normr_ge0 x) le_x_b.
Qed.
End NumDomainOperationTheory.
Hint Resolve ler_opp2 ltr_opp2 real0 real1 normr_real.
Implicit Arguments ler_sqr [[R] x y].
Implicit Arguments ltr_sqr [[R] x y].
Implicit Arguments signr_inj [[R] x1 x2].
Implicit Arguments real_ler_normlP [R x y].
Implicit Arguments real_ltr_normlP [R x y].
Implicit Arguments lerif_refl [R x C].
Implicit Arguments mono_in_lerif [R A f C].
Implicit Arguments nmono_in_lerif [R A f C].
Implicit Arguments mono_lerif [R f C].
Implicit Arguments nmono_lerif [R f C].
Section NumDomainMonotonyTheoryForReals.
Variables (R R' : numDomainType) (D : pred R) (f : R -> R').
Implicit Types (m n p : nat) (x y z : R) (u v w : R').
Lemma real_mono :
{homo f : x y / x < y} -> {in real &, {mono f : x y / x <= y}}.
Proof.
move=> mf x y xR yR /=; have [lt_xy | le_yx] := real_lerP xR yR.
by rewrite ltrW_homo.
by rewrite ltr_geF ?mf.
Qed.
Lemma real_nmono :
{homo f : x y /~ x < y} -> {in real &, {mono f : x y /~ x <= y}}.
Proof.
move=> mf x y xR yR /=; have [lt_xy|le_yx] := real_ltrP xR yR.
by rewrite ltr_geF ?mf.
by rewrite ltrW_nhomo.
Qed.
(* GG: Domain should precede condition. *)
Lemma real_mono_in :
{in D &, {homo f : x y / x < y}} ->
{in [pred x in D | x \is real] &, {mono f : x y / x <= y}}.
Proof.
move=> Dmf x y /andP[hx xR] /andP[hy yR] /=.
have [lt_xy|le_yx] := real_lerP xR yR; first by rewrite (ltrW_homo_in Dmf).
by rewrite ltr_geF ?Dmf.
Qed.
Lemma real_nmono_in :
{in D &, {homo f : x y /~ x < y}} ->
{in [pred x in D | x \is real] &, {mono f : x y /~ x <= y}}.
Proof.
move=> Dmf x y /andP[hx xR] /andP[hy yR] /=.
have [lt_xy|le_yx] := real_ltrP xR yR; last by rewrite (ltrW_nhomo_in Dmf).
by rewrite ltr_geF ?Dmf.
Qed.
End NumDomainMonotonyTheoryForReals.
Section FinGroup.
Import GroupScope.
Variables (R : numDomainType) (gT : finGroupType).
Implicit Types G : {group gT}.
Lemma natrG_gt0 G : #|G|%:R > 0 :> R.
Proof. by rewrite ltr0n cardG_gt0. Qed.
Lemma natrG_neq0 G : #|G|%:R != 0 :> R.
Proof. by rewrite gtr_eqF // natrG_gt0. Qed.
Lemma natr_indexg_gt0 G B : #|G : B|%:R > 0 :> R.
Proof. by rewrite ltr0n indexg_gt0. Qed.
Lemma natr_indexg_neq0 G B : #|G : B|%:R != 0 :> R.
Proof. by rewrite gtr_eqF // natr_indexg_gt0. Qed.
End FinGroup.
Section NumFieldTheory.
Variable F : numFieldType.
Implicit Types x y z t : F.
Lemma unitf_gt0 x : 0 < x -> x \is a GRing.unit.
Proof. by move=> hx; rewrite unitfE eq_sym ltr_eqF. Qed.
Lemma unitf_lt0 x : x < 0 -> x \is a GRing.unit.
Proof. by move=> hx; rewrite unitfE ltr_eqF. Qed.
Lemma lef_pinv : {in pos &, {mono (@GRing.inv F) : x y /~ x <= y}}.
Proof. by move=> x y hx hy /=; rewrite ler_pinv ?inE ?unitf_gt0. Qed.
Lemma lef_ninv : {in neg &, {mono (@GRing.inv F) : x y /~ x <= y}}.
Proof. by move=> x y hx hy /=; rewrite ler_ninv ?inE ?unitf_lt0. Qed.
Lemma ltf_pinv : {in pos &, {mono (@GRing.inv F) : x y /~ x < y}}.
Proof. exact: lerW_nmono_in lef_pinv. Qed.
Lemma ltf_ninv: {in neg &, {mono (@GRing.inv F) : x y /~ x < y}}.
Proof. exact: lerW_nmono_in lef_ninv. Qed.
Definition ltef_pinv := (lef_pinv, ltf_pinv).
Definition ltef_ninv := (lef_ninv, ltf_ninv).
Lemma invf_gt1 x : 0 < x -> (1 < x^-1) = (x < 1).
Proof. by move=> x_gt0; rewrite -{1}[1]invr1 ltf_pinv ?posrE ?ltr01. Qed.
Lemma invf_ge1 x : 0 < x -> (1 <= x^-1) = (x <= 1).
Proof. by move=> x_lt0; rewrite -{1}[1]invr1 lef_pinv ?posrE ?ltr01. Qed.
Definition invf_gte1 := (invf_ge1, invf_gt1).
Lemma invf_le1 x : 0 < x -> (x^-1 <= 1) = (1 <= x).
Proof. by move=> x_gt0; rewrite -invf_ge1 ?invr_gt0 // invrK. Qed.
Lemma invf_lt1 x : 0 < x -> (x^-1 < 1) = (1 < x).
Proof. by move=> x_lt0; rewrite -invf_gt1 ?invr_gt0 // invrK. Qed.
Definition invf_lte1 := (invf_le1, invf_lt1).
Definition invf_cp1 := (invf_gte1, invf_lte1).
(* These lemma are all combinations of mono(LR|RL) with ler_[pn]mul2[rl]. *)
Lemma ler_pdivl_mulr z x y : 0 < z -> (x <= y / z) = (x * z <= y).
Proof. by move=> z_gt0; rewrite -(@ler_pmul2r _ z) ?mulfVK ?gtr_eqF. Qed.
Lemma ltr_pdivl_mulr z x y : 0 < z -> (x < y / z) = (x * z < y).
Proof. by move=> z_gt0; rewrite -(@ltr_pmul2r _ z) ?mulfVK ?gtr_eqF. Qed.
Definition lter_pdivl_mulr := (ler_pdivl_mulr, ltr_pdivl_mulr).
Lemma ler_pdivr_mulr z x y : 0 < z -> (y / z <= x) = (y <= x * z).
Proof. by move=> z_gt0; rewrite -(@ler_pmul2r _ z) ?mulfVK ?gtr_eqF. Qed.
Lemma ltr_pdivr_mulr z x y : 0 < z -> (y / z < x) = (y < x * z).
Proof. by move=> z_gt0; rewrite -(@ltr_pmul2r _ z) ?mulfVK ?gtr_eqF. Qed.
Definition lter_pdivr_mulr := (ler_pdivr_mulr, ltr_pdivr_mulr).
Lemma ler_pdivl_mull z x y : 0 < z -> (x <= z^-1 * y) = (z * x <= y).
Proof. by move=> z_gt0; rewrite mulrC ler_pdivl_mulr ?[z * _]mulrC. Qed.
Lemma ltr_pdivl_mull z x y : 0 < z -> (x < z^-1 * y) = (z * x < y).
Proof. by move=> z_gt0; rewrite mulrC ltr_pdivl_mulr ?[z * _]mulrC. Qed.
Definition lter_pdivl_mull := (ler_pdivl_mull, ltr_pdivl_mull).
Lemma ler_pdivr_mull z x y : 0 < z -> (z^-1 * y <= x) = (y <= z * x).
Proof. by move=> z_gt0; rewrite mulrC ler_pdivr_mulr ?[z * _]mulrC. Qed.
Lemma ltr_pdivr_mull z x y : 0 < z -> (z^-1 * y < x) = (y < z * x).
Proof. by move=> z_gt0; rewrite mulrC ltr_pdivr_mulr ?[z * _]mulrC. Qed.
Definition lter_pdivr_mull := (ler_pdivr_mull, ltr_pdivr_mull).
Lemma ler_ndivl_mulr z x y : z < 0 -> (x <= y / z) = (y <= x * z).
Proof. by move=> z_lt0; rewrite -(@ler_nmul2r _ z) ?mulfVK ?ltr_eqF. Qed.
Lemma ltr_ndivl_mulr z x y : z < 0 -> (x < y / z) = (y < x * z).
Proof. by move=> z_lt0; rewrite -(@ltr_nmul2r _ z) ?mulfVK ?ltr_eqF. Qed.
Definition lter_ndivl_mulr := (ler_ndivl_mulr, ltr_ndivl_mulr).
Lemma ler_ndivr_mulr z x y : z < 0 -> (y / z <= x) = (x * z <= y).
Proof. by move=> z_lt0; rewrite -(@ler_nmul2r _ z) ?mulfVK ?ltr_eqF. Qed.
Lemma ltr_ndivr_mulr z x y : z < 0 -> (y / z < x) = (x * z < y).
Proof. by move=> z_lt0; rewrite -(@ltr_nmul2r _ z) ?mulfVK ?ltr_eqF. Qed.
Definition lter_ndivr_mulr := (ler_ndivr_mulr, ltr_ndivr_mulr).
Lemma ler_ndivl_mull z x y : z < 0 -> (x <= z^-1 * y) = (y <= z * x).
Proof. by move=> z_lt0; rewrite mulrC ler_ndivl_mulr ?[z * _]mulrC. Qed.
Lemma ltr_ndivl_mull z x y : z < 0 -> (x < z^-1 * y) = (y < z * x).
Proof. by move=> z_lt0; rewrite mulrC ltr_ndivl_mulr ?[z * _]mulrC. Qed.
Definition lter_ndivl_mull := (ler_ndivl_mull, ltr_ndivl_mull).
Lemma ler_ndivr_mull z x y : z < 0 -> (z^-1 * y <= x) = (z * x <= y).
Proof. by move=> z_lt0; rewrite mulrC ler_ndivr_mulr ?[z * _]mulrC. Qed.
Lemma ltr_ndivr_mull z x y : z < 0 -> (z^-1 * y < x) = (z * x < y).
Proof. by move=> z_lt0; rewrite mulrC ltr_ndivr_mulr ?[z * _]mulrC. Qed.
Definition lter_ndivr_mull := (ler_ndivr_mull, ltr_ndivr_mull).
Lemma natf_div m d : (d %| m)%N -> (m %/ d)%:R = m%:R / d%:R :> F.
Proof. by apply: char0_natf_div; apply: (@char_num F). Qed.
Lemma normfV : {morph (@norm F) : x / x ^-1}.
Proof.
move=> x /=; have [/normrV //|Nux] := boolP (x \is a GRing.unit).
by rewrite !invr_out // unitfE normr_eq0 -unitfE.
Qed.
Lemma normf_div : {morph (@norm F) : x y / x / y}.
Proof. by move=> x y /=; rewrite normrM normfV. Qed.
Lemma invr_sg x : (sg x)^-1 = sgr x.
Proof. by rewrite !(fun_if GRing.inv) !(invr0, invrN, invr1). Qed.
Lemma sgrV x : sgr x^-1 = sgr x.
Proof. by rewrite /sgr invr_eq0 invr_lt0. Qed.
(* Interval midpoint. *)
Local Notation mid x y := ((x + y) / 2%:R).
Lemma midf_le x y : x <= y -> (x <= mid x y) * (mid x y <= y).
Proof.
move=> lexy; rewrite ler_pdivl_mulr ?ler_pdivr_mulr ?ltr0Sn //.
by rewrite !mulrDr !mulr1 ler_add2r ler_add2l.
Qed.
Lemma midf_lt x y : x < y -> (x < mid x y) * (mid x y < y).
Proof.
move=> ltxy; rewrite ltr_pdivl_mulr ?ltr_pdivr_mulr ?ltr0Sn //.
by rewrite !mulrDr !mulr1 ltr_add2r ltr_add2l.
Qed.
Definition midf_lte := (midf_le, midf_lt).
(* The AGM, unscaled but without the nth root. *)
Lemma real_lerif_mean_square x y :
x \is real -> y \is real -> x * y <= mid (x ^+ 2) (y ^+ 2) ?= iff (x == y).
Proof.
move=> Rx Ry; rewrite -(mono_lerif (ler_pmul2r (ltr_nat F 0 2))).
by rewrite divfK ?pnatr_eq0 // mulr_natr; apply: real_lerif_mean_square_scaled.
Qed.
Lemma real_lerif_AGM2 x y :
x \is real -> y \is real -> x * y <= mid x y ^+ 2 ?= iff (x == y).
Proof.
move=> Rx Ry; rewrite -(mono_lerif (ler_pmul2r (ltr_nat F 0 4))).
rewrite mulr_natr (natrX F 2 2) -exprMn divfK ?pnatr_eq0 //.
exact: real_lerif_AGM2_scaled.
Qed.
Lemma lerif_AGM (I : finType) (A : pred I) (E : I -> F) :
let n := #|A| in let mu := (\sum_(i in A) E i) / n%:R in
{in A, forall i, 0 <= E i} ->
\prod_(i in A) E i <= mu ^+ n
?= iff [forall i in A, forall j in A, E i == E j].
Proof.
move=> n mu Ege0; have [n0 | n_gt0] := posnP n.
by rewrite n0 -big_andE !(big_pred0 _ _ _ _ (card0_eq n0)); apply/lerifP.
pose E' i := E i / n%:R.
have defE' i: E' i *+ n = E i by rewrite -mulr_natr divfK ?pnatr_eq0 -?lt0n.
have /lerif_AGM_scaled (i): i \in A -> 0 <= E' i *+ n by rewrite defE' => /Ege0.
rewrite -/n -mulr_suml (eq_bigr _ (in1W defE')); congr (_ <= _ ?= iff _).
by do 2![apply: eq_forallb_in => ? _]; rewrite -(eqr_pmuln2r n_gt0) !defE'.
Qed.
Implicit Type p : {poly F}.
Lemma Cauchy_root_bound p : p != 0 -> {b | forall x, root p x -> `|x| <= b}.
Proof.
move=> nz_p; set a := lead_coef p; set n := (size p).-1.
have [q Dp]: {q | forall x, x != 0 -> p.[x] = (a - q.[x^-1] / x) * x ^+ n}.
exists (- \poly_(i < n) p`_(n - i.+1)) => x nz_x.
rewrite hornerN mulNr opprK horner_poly mulrDl !mulr_suml addrC.
rewrite horner_coef polySpred // big_ord_recr (reindex_inj rev_ord_inj) /=.
rewrite -/n -lead_coefE; congr (_ + _); apply: eq_bigr=> i _.
by rewrite exprB ?unitfE // -exprVn mulrA mulrAC exprSr mulrA.
have [b ub_q] := poly_disk_bound q 1; exists (b / `|a| + 1) => x px0.
have b_ge0: 0 <= b by rewrite (ler_trans (normr_ge0 q.[1])) ?ub_q ?normr1.
have{b_ge0} ba_ge0: 0 <= b / `|a| by rewrite divr_ge0 ?normr_ge0.
rewrite real_lerNgt ?rpredD ?rpred1 ?ger0_real ?normr_ge0 //.
apply: contraL px0 => lb_x; rewrite rootE.
have x_ge1: 1 <= `|x| by rewrite (ler_trans _ (ltrW lb_x)) // ler_paddl.
have nz_x: x != 0 by rewrite -normr_gt0 (ltr_le_trans ltr01).
rewrite {}Dp // mulf_neq0 ?expf_neq0 // subr_eq0 eq_sym.
have: (b / `|a|) < `|x| by rewrite (ltr_trans _ lb_x) // ltr_spaddr ?ltr01.
apply: contraTneq => /(canRL (divfK nz_x))Dax.
rewrite ltr_pdivr_mulr ?normr_gt0 ?lead_coef_eq0 // mulrC -normrM -{}Dax.
by rewrite ler_gtF // ub_q // normfV invf_le1 ?normr_gt0.
Qed.
Import GroupScope.
Lemma natf_indexg (gT : finGroupType) (G H : {group gT}) :
H \subset G -> #|G : H|%:R = (#|G|%:R / #|H|%:R)%R :> F.
Proof. by move=> sHG; rewrite -divgS // natf_div ?cardSg. Qed.
End NumFieldTheory.
Section RealDomainTheory.
Hint Resolve lerr.
Variable R : realDomainType.
Implicit Types x y z t : R.
Lemma num_real x : x \is real. Proof. exact: num_real. Qed.
Hint Resolve num_real.
Lemma ler_total : total (@le R). Proof. by move=> x y; apply: real_leVge. Qed.
Lemma ltr_total x y : x != y -> (x < y) || (y < x).
Proof. by rewrite !ltr_def [_ == y]eq_sym => ->; apply: ler_total. Qed.
Lemma wlog_ler P :
(forall a b, P b a -> P a b) -> (forall a b, a <= b -> P a b) ->
forall a b : R, P a b.
Proof. by move=> sP hP a b; apply: real_wlog_ler. Qed.
Lemma wlog_ltr P :
(forall a, P a a) ->
(forall a b, (P b a -> P a b)) -> (forall a b, a < b -> P a b) ->
forall a b : R, P a b.
Proof. by move=> rP sP hP a b; apply: real_wlog_ltr. Qed.
Lemma ltrNge x y : (x < y) = ~~ (y <= x). Proof. exact: real_ltrNge. Qed.
Lemma lerNgt x y : (x <= y) = ~~ (y < x). Proof. exact: real_lerNgt. Qed.
Lemma lerP x y : ler_xor_gt x y `|x - y| `|y - x| (x <= y) (y < x).
Proof. exact: real_lerP. Qed.
Lemma ltrP x y : ltr_xor_ge x y `|x - y| `|y - x| (y <= x) (x < y).
Proof. exact: real_ltrP. Qed.
Lemma ltrgtP x y :
comparer x y `|x - y| `|y - x| (y == x) (x == y)
(x <= y) (y <= x) (x < y) (x > y) .
Proof. exact: real_ltrgtP. Qed.
Lemma ger0P x : ger0_xor_lt0 x `|x| (x < 0) (0 <= x).
Proof. exact: real_ger0P. Qed.
Lemma ler0P x : ler0_xor_gt0 x `|x| (0 < x) (x <= 0).
Proof. exact: real_ler0P. Qed.
Lemma ltrgt0P x :
comparer0 x `|x| (0 == x) (x == 0) (x <= 0) (0 <= x) (x < 0) (x > 0).
Proof. exact: real_ltrgt0P. Qed.
Lemma neqr_lt x y : (x != y) = (x < y) || (y < x).
Proof. exact: real_neqr_lt. Qed.
Lemma eqr_leLR x y z t :
(x <= y -> z <= t) -> (y < x -> t < z) -> (x <= y) = (z <= t).
Proof. by move=> *; apply/idP/idP; rewrite // !lerNgt; apply: contra. Qed.
Lemma eqr_leRL x y z t :
(x <= y -> z <= t) -> (y < x -> t < z) -> (z <= t) = (x <= y).
Proof. by move=> *; symmetry; apply: eqr_leLR. Qed.
Lemma eqr_ltLR x y z t :
(x < y -> z < t) -> (y <= x -> t <= z) -> (x < y) = (z < t).
Proof. by move=> *; rewrite !ltrNge; congr negb; apply: eqr_leLR. Qed.
Lemma eqr_ltRL x y z t :
(x < y -> z < t) -> (y <= x -> t <= z) -> (z < t) = (x < y).
Proof. by move=> *; symmetry; apply: eqr_ltLR. Qed.
(* sign *)
Lemma mulr_lt0 x y :
(x * y < 0) = [&& x != 0, y != 0 & (x < 0) (+) (y < 0)].
Proof.
have [x_gt0|x_lt0|->] /= := ltrgt0P x; last by rewrite mul0r.
by rewrite pmulr_rlt0 //; case: ltrgt0P.
by rewrite nmulr_rlt0 //; case: ltrgt0P.
Qed.
Lemma neq0_mulr_lt0 x y :
x != 0 -> y != 0 -> (x * y < 0) = (x < 0) (+) (y < 0).
Proof. by move=> x_neq0 y_neq0; rewrite mulr_lt0 x_neq0 y_neq0. Qed.
Lemma mulr_sign_lt0 (b : bool) x :
((-1) ^+ b * x < 0) = (x != 0) && (b (+) (x < 0)%R).
Proof. by rewrite mulr_lt0 signr_lt0 signr_eq0. Qed.
(* sign & norm*)
Lemma mulr_sign_norm x : (-1) ^+ (x < 0)%R * `|x| = x.
Proof. by rewrite real_mulr_sign_norm. Qed.
Lemma mulr_Nsign_norm x : (-1) ^+ (0 < x)%R * `|x| = - x.
Proof. by rewrite real_mulr_Nsign_norm. Qed.
Lemma numEsign x : x = (-1) ^+ (x < 0)%R * `|x|.
Proof. by rewrite -realEsign. Qed.
Lemma numNEsign x : -x = (-1) ^+ (0 < x)%R * `|x|.
Proof. by rewrite -realNEsign. Qed.
Lemma normrEsign x : `|x| = (-1) ^+ (x < 0)%R * x.
Proof. by rewrite -real_normrEsign. Qed.
End RealDomainTheory.
Hint Resolve num_real.
Section RealDomainMonotony.
Variables (R : realDomainType) (R' : numDomainType) (D : pred R) (f : R -> R').
Implicit Types (m n p : nat) (x y z : R) (u v w : R').
Hint Resolve (@num_real R).
Lemma homo_mono : {homo f : x y / x < y} -> {mono f : x y / x <= y}.
Proof. by move=> mf x y; apply: real_mono. Qed.
Lemma nhomo_mono : {homo f : x y /~ x < y} -> {mono f : x y /~ x <= y}.
Proof. by move=> mf x y; apply: real_nmono. Qed.
Lemma homo_mono_in :
{in D &, {homo f : x y / x < y}} -> {in D &, {mono f : x y / x <= y}}.
Proof.
by move=> mf x y Dx Dy; apply: (real_mono_in mf); rewrite ?inE ?Dx ?Dy /=.
Qed.
Lemma nhomo_mono_in :
{in D &, {homo f : x y /~ x < y}} -> {in D &, {mono f : x y /~ x <= y}}.
Proof.
by move=> mf x y Dx Dy; apply: (real_nmono_in mf); rewrite ?inE ?Dx ?Dy /=.
Qed.
End RealDomainMonotony.
Section RealDomainOperations.
(* sgr section *)
Variable R : realDomainType.
Implicit Types x y z t : R.
Hint Resolve (@num_real R).
Lemma sgr_cp0 x :
((sg x == 1) = (0 < x)) *
((sg x == -1) = (x < 0)) *
((sg x == 0) = (x == 0)).
Proof.
rewrite -[1]/((-1) ^+ false) -signrN lt0r lerNgt sgr_def.
case: (x =P 0) => [-> | _]; first by rewrite !(eq_sym 0) !signr_eq0 ltrr eqxx.
by rewrite !(inj_eq signr_inj) eqb_id eqbF_neg signr_eq0 //.
Qed.
CoInductive sgr_val x : R -> bool -> bool -> bool -> bool -> bool -> bool
-> bool -> bool -> bool -> bool -> bool -> bool -> R -> Set :=
| SgrNull of x = 0 : sgr_val x 0 true true true true false false
true false false true false false 0
| SgrPos of x > 0 : sgr_val x x false false true false false true
false false true false false true 1
| SgrNeg of x < 0 : sgr_val x (- x) false true false false true false
false true false false true false (-1).
Lemma sgrP x :
sgr_val x `|x| (0 == x) (x <= 0) (0 <= x) (x == 0) (x < 0) (0 < x)
(0 == sg x) (-1 == sg x) (1 == sg x)
(sg x == 0) (sg x == -1) (sg x == 1) (sg x).
Proof.
by rewrite ![_ == sg _]eq_sym !sgr_cp0 /sg; case: ltrgt0P; constructor.
Qed.
Lemma normrEsg x : `|x| = sg x * x.
Proof. by case: sgrP; rewrite ?(mul0r, mul1r, mulN1r). Qed.
Lemma numEsg x : x = sg x * `|x|.
Proof. by case: sgrP; rewrite !(mul1r, mul0r, mulrNN). Qed.
(* GG: duplicate! *)
Lemma mulr_sg_norm x : sg x * `|x| = x. Proof. by rewrite -numEsg. Qed.
Lemma sgrM x y : sg (x * y) = sg x * sg y.
Proof.
rewrite !sgr_def mulr_lt0 andbA mulrnAr mulrnAl -mulrnA mulnb -negb_or mulf_eq0.
by case: (~~ _) => //; rewrite signr_addb.
Qed.
Lemma sgrN x : sg (- x) = - sg x.
Proof. by rewrite -mulrN1 sgrM sgrN1 mulrN1. Qed.
Lemma sgrX n x : sg (x ^+ n) = (sg x) ^+ n.
Proof. by elim: n => [|n IHn]; rewrite ?sgr1 // !exprS sgrM IHn. Qed.
Lemma sgr_smul x y : sg (sg x * y) = sg x * sg y.
Proof. by rewrite sgrM sgr_id. Qed.
Lemma sgr_gt0 x : (sg x > 0) = (x > 0).
Proof. by rewrite -sgr_cp0 sgr_id sgr_cp0. Qed.
Lemma sgr_ge0 x : (sgr x >= 0) = (x >= 0).
Proof. by rewrite !lerNgt sgr_lt0. Qed.
(* norm section *)
Lemma ler_norm x : (x <= `|x|).
Proof. exact: real_ler_norm. Qed.
Lemma ler_norml x y : (`|x| <= y) = (- y <= x <= y).
Proof. exact: real_ler_norml. Qed.
Lemma ler_normlP x y : reflect ((- x <= y) * (x <= y)) (`|x| <= y).
Proof. exact: real_ler_normlP. Qed.
Implicit Arguments ler_normlP [x y].
Lemma eqr_norml x y : (`|x| == y) = ((x == y) || (x == -y)) && (0 <= y).
Proof. exact: real_eqr_norml. Qed.
Lemma eqr_norm2 x y : (`|x| == `|y|) = (x == y) || (x == -y).
Proof. exact: real_eqr_norm2. Qed.
Lemma ltr_norml x y : (`|x| < y) = (- y < x < y).
Proof. exact: real_ltr_norml. Qed.
Definition lter_norml := (ler_norml, ltr_norml).
Lemma ltr_normlP x y : reflect ((-x < y) * (x < y)) (`|x| < y).
Proof. exact: real_ltr_normlP. Qed.
Implicit Arguments ltr_normlP [x y].
Lemma ler_normr x y : (x <= `|y|) = (x <= y) || (x <= - y).
Proof. by rewrite lerNgt ltr_norml negb_and -!lerNgt orbC ler_oppr. Qed.
Lemma ltr_normr x y : (x < `|y|) = (x < y) || (x < - y).
Proof. by rewrite ltrNge ler_norml negb_and -!ltrNge orbC ltr_oppr. Qed.
Definition lter_normr := (ler_normr, ltr_normr).
Lemma ler_distl x y e : (`|x - y| <= e) = (y - e <= x <= y + e).
Proof. by rewrite lter_norml !lter_sub_addl. Qed.
Lemma ltr_distl x y e : (`|x - y| < e) = (y - e < x < y + e).
Proof. by rewrite lter_norml !lter_sub_addl. Qed.
Definition lter_distl := (ler_distl, ltr_distl).
Lemma exprn_even_ge0 n x : ~~ odd n -> 0 <= x ^+ n.
Proof. by move=> even_n; rewrite real_exprn_even_ge0 ?num_real. Qed.
Lemma exprn_even_gt0 n x : ~~ odd n -> (0 < x ^+ n) = (n == 0)%N || (x != 0).
Proof. by move=> even_n; rewrite real_exprn_even_gt0 ?num_real. Qed.
Lemma exprn_even_le0 n x : ~~ odd n -> (x ^+ n <= 0) = (n != 0%N) && (x == 0).
Proof. by move=> even_n; rewrite real_exprn_even_le0 ?num_real. Qed.
Lemma exprn_even_lt0 n x : ~~ odd n -> (x ^+ n < 0) = false.
Proof. by move=> even_n; rewrite real_exprn_even_lt0 ?num_real. Qed.
Lemma exprn_odd_ge0 n x : odd n -> (0 <= x ^+ n) = (0 <= x).
Proof. by move=> even_n; rewrite real_exprn_odd_ge0 ?num_real. Qed.
Lemma exprn_odd_gt0 n x : odd n -> (0 < x ^+ n) = (0 < x).
Proof. by move=> even_n; rewrite real_exprn_odd_gt0 ?num_real. Qed.
Lemma exprn_odd_le0 n x : odd n -> (x ^+ n <= 0) = (x <= 0).
Proof. by move=> even_n; rewrite real_exprn_odd_le0 ?num_real. Qed.
Lemma exprn_odd_lt0 n x : odd n -> (x ^+ n < 0) = (x < 0).
Proof. by move=> even_n; rewrite real_exprn_odd_lt0 ?num_real. Qed.
(* Special lemmas for squares. *)
Lemma sqr_ge0 x : 0 <= x ^+ 2. Proof. by rewrite exprn_even_ge0. Qed.
Lemma sqr_norm_eq1 x : (x ^+ 2 == 1) = (`|x| == 1).
Proof. by rewrite sqrf_eq1 eqr_norml ler01 andbT. Qed.
Lemma lerif_mean_square_scaled x y :
x * y *+ 2 <= x ^+ 2 + y ^+ 2 ?= iff (x == y).
Proof. exact: real_lerif_mean_square_scaled. Qed.
Lemma lerif_AGM2_scaled x y : x * y *+ 4 <= (x + y) ^+ 2 ?= iff (x == y).
Proof. exact: real_lerif_AGM2_scaled. Qed.
Section MinMax.
(* GG: Many of the first lemmas hold unconditionally, and others hold for *)
(* the real subset of a general domain. *)
Lemma minrC : @commutative R R min.
Proof. by move=> x y; rewrite /min; case: ltrgtP. Qed.
Lemma minrr : @idempotent R min.
Proof. by move=> x; rewrite /min if_same. Qed.
Lemma minr_l x y : x <= y -> min x y = x.
Proof. by rewrite /minr => ->. Qed.
Lemma minr_r x y : y <= x -> min x y = y.
Proof. by move/minr_l; rewrite minrC. Qed.
Lemma maxrC : @commutative R R max.
Proof. by move=> x y; rewrite /maxr; case: ltrgtP. Qed.
Lemma maxrr : @idempotent R max.
Proof. by move=> x; rewrite /max if_same. Qed.
Lemma maxr_l x y : y <= x -> max x y = x.
Proof. by move=> hxy; rewrite /max hxy. Qed.
Lemma maxr_r x y : x <= y -> max x y = y.
Proof. by move=> hxy; rewrite maxrC maxr_l. Qed.
Lemma addr_min_max x y : min x y + max x y = x + y.
Proof.
case: (lerP x y)=> hxy; first by rewrite maxr_r ?minr_l.
by rewrite maxr_l ?minr_r ?ltrW // addrC.
Qed.
Lemma addr_max_min x y : max x y + min x y = x + y.
Proof. by rewrite addrC addr_min_max. Qed.
Lemma minr_to_max x y : min x y = x + y - max x y.
Proof. by rewrite -[x + y]addr_min_max addrK. Qed.
Lemma maxr_to_min x y : max x y = x + y - min x y.
Proof. by rewrite -[x + y]addr_max_min addrK. Qed.
Lemma minrA x y z : min x (min y z) = min (min x y) z.
Proof.
rewrite /min; case: (lerP y z) => [hyz | /ltrW hyz].
by case: lerP => hxy; rewrite ?hyz // (@ler_trans _ y).
case: lerP=> hxz; first by rewrite !(ler_trans hxz).
case: (lerP x y)=> hxy; first by rewrite lerNgt hxz.
by case: ltrgtP hyz.
Qed.
Lemma minrCA : @left_commutative R R min.
Proof. by move=> x y z; rewrite !minrA [minr x y]minrC. Qed.
Lemma minrAC : @right_commutative R R min.
Proof. by move=> x y z; rewrite -!minrA [minr y z]minrC. Qed.
CoInductive minr_spec x y : bool -> bool -> R -> Type :=
| Minr_r of x <= y : minr_spec x y true false x
| Minr_l of y < x : minr_spec x y false true y.
Lemma minrP x y : minr_spec x y (x <= y) (y < x) (min x y).
Proof.
case: lerP=> hxy; first by rewrite minr_l //; constructor.
by rewrite minr_r 1?ltrW //; constructor.
Qed.
Lemma oppr_max x y : - max x y = min (- x) (- y).
Proof.
case: minrP; rewrite lter_opp2 => hxy; first by rewrite maxr_l.
by rewrite maxr_r // ltrW.
Qed.
Lemma oppr_min x y : - min x y = max (- x) (- y).
Proof. by rewrite -[maxr _ _]opprK oppr_max !opprK. Qed.
Lemma maxrA x y z : max x (max y z) = max (max x y) z.
Proof. by apply/eqP; rewrite -eqr_opp !oppr_max minrA. Qed.
Lemma maxrCA : @left_commutative R R max.
Proof. by move=> x y z; rewrite !maxrA [maxr x y]maxrC. Qed.
Lemma maxrAC : @right_commutative R R max.
Proof. by move=> x y z; rewrite -!maxrA [maxr y z]maxrC. Qed.
CoInductive maxr_spec x y : bool -> bool -> R -> Type :=
| Maxr_r of y <= x : maxr_spec x y true false x
| Maxr_l of x < y : maxr_spec x y false true y.
Lemma maxrP x y : maxr_spec x y (y <= x) (x < y) (maxr x y).
Proof.
case: lerP => hxy; first by rewrite maxr_l //; constructor.
by rewrite maxr_r 1?ltrW //; constructor.
Qed.
Lemma eqr_minl x y : (min x y == x) = (x <= y).
Proof. by case: minrP=> hxy; rewrite ?eqxx // ltr_eqF. Qed.
Lemma eqr_minr x y : (min x y == y) = (y <= x).
Proof. by rewrite minrC eqr_minl. Qed.
Lemma eqr_maxl x y : (max x y == x) = (y <= x).
Proof. by case: maxrP=> hxy; rewrite ?eqxx // eq_sym ltr_eqF. Qed.
Lemma eqr_maxr x y : (max x y == y) = (x <= y).
Proof. by rewrite maxrC eqr_maxl. Qed.
Lemma ler_minr x y z : (x <= min y z) = (x <= y) && (x <= z).
Proof.
case: minrP=> hyz.
by case: lerP=> hxy //; rewrite (ler_trans _ hyz).
by case: lerP=> hxz; rewrite andbC // (ler_trans hxz) // ltrW.
Qed.
Lemma ler_minl x y z : (min y z <= x) = (y <= x) || (z <= x).
Proof.
case: minrP => hyz.
case: lerP => hyx //=; symmetry; apply: negbTE.
by rewrite -ltrNge (@ltr_le_trans _ y).
case: lerP => hzx; rewrite orbC //=; symmetry; apply: negbTE.
by rewrite -ltrNge (@ltr_trans _ z).
Qed.
Lemma ler_maxr x y z : (x <= max y z) = (x <= y) || (x <= z).
Proof. by rewrite -lter_opp2 oppr_max ler_minl !ler_opp2. Qed.
Lemma ler_maxl x y z : (max y z <= x) = (y <= x) && (z <= x).
Proof. by rewrite -lter_opp2 oppr_max ler_minr !ler_opp2. Qed.
Lemma ltr_minr x y z : (x < min y z) = (x < y) && (x < z).
Proof. by rewrite !ltrNge ler_minl negb_or. Qed.
Lemma ltr_minl x y z : (min y z < x) = (y < x) || (z < x).
Proof. by rewrite !ltrNge ler_minr negb_and. Qed.
Lemma ltr_maxr x y z : (x < max y z) = (x < y) || (x < z).
Proof. by rewrite !ltrNge ler_maxl negb_and. Qed.
Lemma ltr_maxl x y z : (max y z < x) = (y < x) && (z < x).
Proof. by rewrite !ltrNge ler_maxr negb_or. Qed.
Definition lter_minr := (ler_minr, ltr_minr).
Definition lter_minl := (ler_minl, ltr_minl).
Definition lter_maxr := (ler_maxr, ltr_maxr).
Definition lter_maxl := (ler_maxl, ltr_maxl).
Lemma addr_minl : @left_distributive R R +%R min.
Proof.
move=> x y z; case: minrP=> hxy; first by rewrite minr_l // ler_add2r.
by rewrite minr_r // ltrW // ltr_add2r.
Qed.
Lemma addr_minr : @right_distributive R R +%R min.
Proof.
move=> x y z; case: minrP=> hxy; first by rewrite minr_l // ler_add2l.
by rewrite minr_r // ltrW // ltr_add2l.
Qed.
Lemma addr_maxl : @left_distributive R R +%R max.
Proof.
move=> x y z; rewrite -[_ + _]opprK opprD oppr_max.
by rewrite addr_minl -!opprD oppr_min !opprK.
Qed.
Lemma addr_maxr : @right_distributive R R +%R max.
Proof.
move=> x y z; rewrite -[_ + _]opprK opprD oppr_max.
by rewrite addr_minr -!opprD oppr_min !opprK.
Qed.
Lemma minrK x y : max (min x y) x = x.
Proof. by case: minrP => hxy; rewrite ?maxrr ?maxr_r // ltrW. Qed.
Lemma minKr x y : min y (max x y) = y.
Proof. by case: maxrP => hxy; rewrite ?minrr ?minr_l. Qed.
Lemma maxr_minl : @left_distributive R R max min.
Proof.
move=> x y z; case: minrP => hxy.
by case: maxrP => hm; rewrite minr_l // ler_maxr (hxy, lerr) ?orbT.
by case: maxrP => hyz; rewrite minr_r // ler_maxr (ltrW hxy, lerr) ?orbT.
Qed.
Lemma maxr_minr : @right_distributive R R max min.
Proof. by move=> x y z; rewrite maxrC maxr_minl ![_ _ x]maxrC. Qed.
Lemma minr_maxl : @left_distributive R R min max.
Proof.
move=> x y z; rewrite -[min _ _]opprK !oppr_min [- max x y]oppr_max.
by rewrite maxr_minl !(oppr_max, oppr_min, opprK).
Qed.
Lemma minr_maxr : @right_distributive R R min max.
Proof. by move=> x y z; rewrite minrC minr_maxl ![_ _ x]minrC. Qed.
Lemma minr_pmulr x y z : 0 <= x -> x * min y z = min (x * y) (x * z).
Proof.
case: sgrP=> // hx _; first by rewrite hx !mul0r minrr.
case: minrP=> hyz; first by rewrite minr_l // ler_pmul2l.
by rewrite minr_r // ltrW // ltr_pmul2l.
Qed.
Lemma minr_nmulr x y z : x <= 0 -> x * min y z = max (x * y) (x * z).
Proof.
move=> hx; rewrite -[_ * _]opprK -mulNr minr_pmulr ?oppr_cp0 //.
by rewrite oppr_min !mulNr !opprK.
Qed.
Lemma maxr_pmulr x y z : 0 <= x -> x * max y z = max (x * y) (x * z).
Proof.
move=> hx; rewrite -[_ * _]opprK -mulrN oppr_max minr_pmulr //.
by rewrite oppr_min !mulrN !opprK.
Qed.
Lemma maxr_nmulr x y z : x <= 0 -> x * max y z = min (x * y) (x * z).
Proof.
move=> hx; rewrite -[_ * _]opprK -mulrN oppr_max minr_nmulr //.
by rewrite oppr_max !mulrN !opprK.
Qed.
Lemma minr_pmull x y z : 0 <= x -> min y z * x = min (y * x) (z * x).
Proof. by move=> *; rewrite mulrC minr_pmulr // ![_ * x]mulrC. Qed.
Lemma minr_nmull x y z : x <= 0 -> min y z * x = max (y * x) (z * x).
Proof. by move=> *; rewrite mulrC minr_nmulr // ![_ * x]mulrC. Qed.
Lemma maxr_pmull x y z : 0 <= x -> max y z * x = max (y * x) (z * x).
Proof. by move=> *; rewrite mulrC maxr_pmulr // ![_ * x]mulrC. Qed.
Lemma maxr_nmull x y z : x <= 0 -> max y z * x = min (y * x) (z * x).
Proof. by move=> *; rewrite mulrC maxr_nmulr // ![_ * x]mulrC. Qed.
Lemma maxrN x : max x (- x) = `|x|.
Proof.
case: ger0P=> hx; first by rewrite maxr_l // ge0_cp //.
by rewrite maxr_r // le0_cp // ltrW.
Qed.
Lemma maxNr x : max (- x) x = `|x|.
Proof. by rewrite maxrC maxrN. Qed.
Lemma minrN x : min x (- x) = - `|x|.
Proof. by rewrite -[minr _ _]opprK oppr_min opprK maxNr. Qed.
Lemma minNr x : min (- x) x = - `|x|.
Proof. by rewrite -[minr _ _]opprK oppr_min opprK maxrN. Qed.
End MinMax.
Section PolyBounds.
Variable p : {poly R}.
Lemma poly_itv_bound a b : {ub | forall x, a <= x <= b -> `|p.[x]| <= ub}.
Proof.
have [ub le_p_ub] := poly_disk_bound p (Num.max `|a| `|b|).
exists ub => x /andP[le_a_x le_x_b]; rewrite le_p_ub // ler_maxr !ler_normr.
by have [_|_] := ler0P x; rewrite ?ler_opp2 ?le_a_x ?le_x_b orbT.
Qed.
Lemma monic_Cauchy_bound : p \is monic -> {b | forall x, x >= b -> p.[x] > 0}.
Proof.
move/monicP=> mon_p; pose n := (size p - 2)%N.
have [p_le1 | p_gt1] := leqP (size p) 1.
exists 0 => x _; rewrite (size1_polyC p_le1) hornerC.
by rewrite -[p`_0]lead_coefC -size1_polyC // mon_p ltr01.
pose lb := \sum_(j < n.+1) `|p`_j|; exists (lb + 1) => x le_ub_x.
have x_ge1: 1 <= x; last have x_gt0 := ltr_le_trans ltr01 x_ge1.
by rewrite -(ler_add2l lb) ler_paddl ?sumr_ge0 // => j _; apply: normr_ge0.
rewrite horner_coef -(subnK p_gt1) -/n addnS big_ord_recr /= addn1.
rewrite [in p`__]subnSK // subn1 -lead_coefE mon_p mul1r -ltr_subl_addl sub0r.
apply: ler_lt_trans (_ : lb * x ^+ n < _); last first.
rewrite exprS ltr_pmul2r ?exprn_gt0 ?(ltr_le_trans ltr01) //.
by rewrite -(ltr_add2r 1) ltr_spaddr ?ltr01.
rewrite -sumrN mulr_suml ler_sum // => j _; apply: ler_trans (ler_norm _) _.
rewrite normrN normrM ler_wpmul2l ?normr_ge0 // normrX.
by rewrite ger0_norm ?(ltrW x_gt0) // ler_weexpn2l ?leq_ord.
Qed.
End PolyBounds.
End RealDomainOperations.
Section RealField.
Variables (F : realFieldType) (x y : F).
Lemma lerif_mean_square : x * y <= (x ^+ 2 + y ^+ 2) / 2%:R ?= iff (x == y).
Proof. by apply: real_lerif_mean_square; apply: num_real. Qed.
Lemma lerif_AGM2 : x * y <= ((x + y) / 2%:R)^+ 2 ?= iff (x == y).
Proof. by apply: real_lerif_AGM2; apply: num_real. Qed.
End RealField.
Section ArchimedeanFieldTheory.
Variables (F : archiFieldType) (x : F).
Lemma archi_boundP : 0 <= x -> x < (bound x)%:R.
Proof. by move/ger0_norm=> {1}<-; rewrite /bound; case: (sigW _). Qed.
Lemma upper_nthrootP i : (bound x <= i)%N -> x < 2%:R ^+ i.
Proof.
rewrite /bound; case: (sigW _) => /= b le_x_b le_b_i.
apply: ler_lt_trans (ler_norm x) (ltr_trans le_x_b _ ).
by rewrite -natrX ltr_nat (leq_ltn_trans le_b_i) // ltn_expl.
Qed.
End ArchimedeanFieldTheory.
Section RealClosedFieldTheory.
Variable R : rcfType.
Implicit Types a x y : R.
Lemma poly_ivt : real_closed_axiom R. Proof. exact: poly_ivt. Qed.
(* Square Root theory *)
Lemma sqrtr_ge0 a : 0 <= sqrt a.
Proof. by rewrite /sqrt; case: (sig2W _). Qed.
Hint Resolve sqrtr_ge0.
Lemma sqr_sqrtr a : 0 <= a -> sqrt a ^+ 2 = a.
Proof.
by rewrite /sqrt => a_ge0; case: (sig2W _) => /= x _; rewrite a_ge0 => /eqP.
Qed.
Lemma ler0_sqrtr a : a <= 0 -> sqrt a = 0.
Proof.
rewrite /sqrtr; case: (sig2W _) => x /= _.
by have [//|_ /eqP//|->] := ltrgt0P a; rewrite mulf_eq0 orbb => /eqP.
Qed.
Lemma ltr0_sqrtr a : a < 0 -> sqrt a = 0.
Proof. by move=> /ltrW; apply: ler0_sqrtr. Qed.
CoInductive sqrtr_spec a : R -> bool -> bool -> R -> Type :=
| IsNoSqrtr of a < 0 : sqrtr_spec a a false true 0
| IsSqrtr b of 0 <= b : sqrtr_spec a (b ^+ 2) true false b.
Lemma sqrtrP a : sqrtr_spec a a (0 <= a) (a < 0) (sqrt a).
Proof.
have [a_ge0|a_lt0] := ger0P a.
by rewrite -{1 2}[a]sqr_sqrtr //; constructor.
by rewrite ltr0_sqrtr //; constructor.
Qed.
Lemma sqrtr_sqr a : sqrt (a ^+ 2) = `|a|.
Proof.
have /eqP : sqrt (a ^+ 2) ^+ 2 = `|a| ^+ 2.
by rewrite -normrX ger0_norm ?sqr_sqrtr ?sqr_ge0.
rewrite eqf_sqr => /predU1P[-> //|ha].
have := sqrtr_ge0 (a ^+ 2); rewrite (eqP ha) oppr_ge0 normr_le0 => /eqP ->.
by rewrite normr0 oppr0.
Qed.
Lemma sqrtrM a b : 0 <= a -> sqrt (a * b) = sqrt a * sqrt b.
Proof.
case: (sqrtrP a) => // {a} a a_ge0 _; case: (sqrtrP b) => [b_lt0 | {b} b b_ge0].
by rewrite mulr0 ler0_sqrtr // nmulr_lle0 ?mulr_ge0.
by rewrite mulrACA sqrtr_sqr ger0_norm ?mulr_ge0.
Qed.
Lemma sqrtr0 : sqrt 0 = 0 :> R.
Proof. by move: (sqrtr_sqr 0); rewrite exprS mul0r => ->; rewrite normr0. Qed.
Lemma sqrtr1 : sqrt 1 = 1 :> R.
Proof. by move: (sqrtr_sqr 1); rewrite expr1n => ->; rewrite normr1. Qed.
Lemma sqrtr_eq0 a : (sqrt a == 0) = (a <= 0).
Proof.
case: sqrtrP => [/ltrW ->|b]; first by rewrite eqxx.
case: ltrgt0P => [b_gt0|//|->]; last by rewrite exprS mul0r lerr.
by rewrite ltr_geF ?pmulr_rgt0.
Qed.
Lemma sqrtr_gt0 a : (0 < sqrt a) = (0 < a).
Proof. by rewrite lt0r sqrtr_ge0 sqrtr_eq0 -ltrNge andbT. Qed.
Lemma eqr_sqrt a b : 0 <= a -> 0 <= b -> (sqrt a == sqrt b) = (a == b).
Proof.
move=> a_ge0 b_ge0; apply/eqP/eqP=> [HS|->] //.
by move: (sqr_sqrtr a_ge0); rewrite HS (sqr_sqrtr b_ge0).
Qed.
Lemma ler_wsqrtr : {homo @sqrt R : a b / a <= b}.
Proof.
move=> a b /= le_ab; case: (boolP (0 <= a))=> [pa|]; last first.
by rewrite -ltrNge; move/ltrW; rewrite -sqrtr_eq0; move/eqP->.
rewrite -(@ler_pexpn2r R 2) ?nnegrE ?sqrtr_ge0 //.
by rewrite !sqr_sqrtr // (ler_trans pa).
Qed.
Lemma ler_psqrt : {in @pos R &, {mono sqrt : a b / a <= b}}.
Proof.
apply: homo_mono_in => x y x_gt0 y_gt0.
rewrite !ltr_neqAle => /andP[neq_xy le_xy].
by rewrite ler_wsqrtr // eqr_sqrt ?ltrW // neq_xy.
Qed.
Lemma ler_sqrt a b : 0 < b -> (sqrt a <= sqrt b) = (a <= b).
Proof.
move=> b_gt0; have [a_le0|a_gt0] := ler0P a; last by rewrite ler_psqrt.
by rewrite ler0_sqrtr // sqrtr_ge0 (ler_trans a_le0) ?ltrW.
Qed.
Lemma ltr_sqrt a b : 0 < b -> (sqrt a < sqrt b) = (a < b).
Proof.
move=> b_gt0; have [a_le0|a_gt0] := ler0P a; last first.
by rewrite (lerW_mono_in ler_psqrt).
by rewrite ler0_sqrtr // sqrtr_gt0 b_gt0 (ler_lt_trans a_le0).
Qed.
End RealClosedFieldTheory.
End Theory.
Module RealMixin.
Section RealMixins.
Variables (R : idomainType) (le : rel R) (lt : rel R) (norm : R -> R).
Local Infix "<=" := le.
Local Infix "<" := lt.
Local Notation "`| x |" := (norm x) : ring_scope.
Section LeMixin.
Hypothesis le0_add : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y.
Hypothesis le0_mul : forall x y, 0 <= x -> 0 <= y -> 0 <= x * y.
Hypothesis le0_anti : forall x, 0 <= x -> x <= 0 -> x = 0.
Hypothesis sub_ge0 : forall x y, (0 <= y - x) = (x <= y).
Hypothesis le0_total : forall x, (0 <= x) || (x <= 0).
Hypothesis normN: forall x, `|- x| = `|x|.
Hypothesis ge0_norm : forall x, 0 <= x -> `|x| = x.
Hypothesis lt_def : forall x y, (x < y) = (y != x) && (x <= y).
Let le0N x : (0 <= - x) = (x <= 0). Proof. by rewrite -sub0r sub_ge0. Qed.
Let leN_total x : 0 <= x \/ 0 <= - x.
Proof. by apply/orP; rewrite le0N le0_total. Qed.
Let le00 : (0 <= 0). Proof. by have:= le0_total 0; rewrite orbb. Qed.
Let le01 : (0 <= 1).
Proof.
by case/orP: (le0_total 1)=> // ?; rewrite -[1]mul1r -mulrNN le0_mul ?le0N.
Qed.
Fact lt0_add x y : 0 < x -> 0 < y -> 0 < x + y.
Proof.
rewrite !lt_def => /andP[x_neq0 l0x] /andP[y_neq0 l0y]; rewrite le0_add //.
rewrite andbT addr_eq0; apply: contraNneq x_neq0 => hxy.
by rewrite [x]le0_anti // hxy -le0N opprK.
Qed.
Fact eq0_norm x : `|x| = 0 -> x = 0.
Proof.
case: (leN_total x) => /ge0_norm => [-> // | Dnx nx0].
by rewrite -[x]opprK -Dnx normN nx0 oppr0.
Qed.
Fact le_def x y : (x <= y) = (`|y - x| == y - x).
Proof.
wlog ->: x y / x = 0 by move/(_ 0 (y - x)); rewrite subr0 sub_ge0 => ->.
rewrite {x}subr0; apply/idP/eqP=> [/ge0_norm// | Dy].
by have [//| ny_ge0] := leN_total y; rewrite -Dy -normN ge0_norm.
Qed.
Fact normM : {morph norm : x y / x * y}.
Proof.
move=> x y /=; wlog x_ge0 : x / 0 <= x.
by move=> IHx; case: (leN_total x) => /IHx//; rewrite mulNr !normN.
wlog y_ge0 : y / 0 <= y; last by rewrite ?ge0_norm ?le0_mul.
by move=> IHy; case: (leN_total y) => /IHy//; rewrite mulrN !normN.
Qed.
Fact le_normD x y : `|x + y| <= `|x| + `|y|.
Proof.
wlog x_ge0 : x y / 0 <= x.
by move=> IH; case: (leN_total x) => /IH// /(_ (- y)); rewrite -opprD !normN.
rewrite -sub_ge0 ge0_norm //; have [y_ge0 | ny_ge0] := leN_total y.
by rewrite !ge0_norm ?subrr ?le0_add.
rewrite -normN ge0_norm //; have [hxy|hxy] := leN_total (x + y).
by rewrite ge0_norm // opprD addrCA -addrA addKr le0_add.
by rewrite -normN ge0_norm // opprK addrCA addrNK le0_add.
Qed.
Lemma le_total x y : (x <= y) || (y <= x).
Proof. by rewrite -sub_ge0 -opprB le0N orbC -sub_ge0 le0_total. Qed.
Definition Le :=
Mixin le_normD lt0_add eq0_norm (in2W le_total) normM le_def lt_def.
Lemma Real (R' : numDomainType) & phant R' :
R' = NumDomainType R Le -> real_axiom R'.
Proof. by move->. Qed.
End LeMixin.
Section LtMixin.
Hypothesis lt0_add : forall x y, 0 < x -> 0 < y -> 0 < x + y.
Hypothesis lt0_mul : forall x y, 0 < x -> 0 < y -> 0 < x * y.
Hypothesis lt0_ngt0 : forall x, 0 < x -> ~~ (x < 0).
Hypothesis sub_gt0 : forall x y, (0 < y - x) = (x < y).
Hypothesis lt0_total : forall x, x != 0 -> (0 < x) || (x < 0).
Hypothesis normN : forall x, `|- x| = `|x|.
Hypothesis ge0_norm : forall x, 0 <= x -> `|x| = x.
Hypothesis le_def : forall x y, (x <= y) = (y == x) || (x < y).
Fact le0_add x y : 0 <= x -> 0 <= y -> 0 <= x + y.
Proof.
rewrite !le_def => /predU1P[->|x_gt0]; first by rewrite add0r.
by case/predU1P=> [->|y_gt0]; rewrite ?addr0 ?x_gt0 ?lt0_add // orbT.
Qed.
Fact le0_mul x y : 0 <= x -> 0 <= y -> 0 <= x * y.
Proof.
rewrite !le_def => /predU1P[->|x_gt0]; first by rewrite mul0r eqxx.
by case/predU1P=> [->|y_gt0]; rewrite ?mulr0 ?eqxx // orbC lt0_mul.
Qed.
Fact le0_anti x : 0 <= x -> x <= 0 -> x = 0.
Proof. by rewrite !le_def => /predU1P[] // /lt0_ngt0/negPf-> /predU1P[]. Qed.
Fact sub_ge0 x y : (0 <= y - x) = (x <= y).
Proof. by rewrite !le_def subr_eq0 sub_gt0. Qed.
Fact lt_def x y : (x < y) = (y != x) && (x <= y).
Proof.
rewrite le_def; case: eqP => //= ->; rewrite -sub_gt0 subrr.
by apply/idP=> lt00; case/negP: (lt0_ngt0 lt00).
Qed.
Fact le0_total x : (0 <= x) || (x <= 0).
Proof. by rewrite !le_def [0 == _]eq_sym; have [|/lt0_total] := altP eqP. Qed.
Definition Lt :=
Le le0_add le0_mul le0_anti sub_ge0 le0_total normN ge0_norm lt_def.
End LtMixin.
End RealMixins.
End RealMixin.
End Num.
Export Num.NumDomain.Exports Num.NumField.Exports Num.ClosedField.Exports.
Export Num.RealDomain.Exports Num.RealField.Exports.
Export Num.ArchimedeanField.Exports Num.RealClosedField.Exports.
Export Num.Syntax Num.PredInstances.
Notation RealLeMixin := Num.RealMixin.Le.
Notation RealLtMixin := Num.RealMixin.Lt.
Notation RealLeAxiom R := (Num.RealMixin.Real (Phant R) (erefl _)).
mathcomp-1.5/theories/cyclic.v 0000644 0001750 0001750 00000101335 12307636117 015443 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype bigop.
Require Import prime finset fingroup morphism perm automorphism quotient.
Require Import gproduct ssralg finalg zmodp poly.
(******************************************************************************)
(* Properties of cyclic groups. *)
(* Definitions: *)
(* Defined in fingroup.v: *)
(* <[x]> == the cycle (cyclic group) generated by x. *)
(* #[x] == the order of x, i.e., the cardinal of <[x]>. *)
(* Defined in prime.v: *)
(* totient n == Euler's totient function *)
(* Definitions in this file: *)
(* cyclic G <=> G is a cyclic group. *)
(* metacyclic G <=> G is a metacyclic group (i.e., a cyclic extension of a *)
(* cyclic group). *)
(* generator G x <=> x is a generator of the (cyclic) group G. *)
(* Zpm x == the isomorphism mapping the additive group of integers *)
(* mod #[x] to the cyclic group <[x]>. *)
(* cyclem x n == the endomorphism y |-> y ^+ n of <[x]>. *)
(* Zp_unitm x == the isomorphism mapping the multiplicative group of the *)
(* units of the ring of integers mod #[x] to the group of *)
(* automorphisms of <[x]> (i.e., Aut <[x]>). *)
(* Zp_unitm x maps u to cyclem x u. *)
(* eltm dvd_y_x == the smallest morphism (with domain <[x]>) mapping x to *)
(* y, given a proof dvd_y_x : #[y] %| #[x]. *)
(* expg_invn G k == if coprime #|G| k, the inverse of exponent k in G. *)
(* Basic results for these notions, plus the classical result that any finite *)
(* group isomorphic to a subgroup of a field is cyclic, hence that Aut G is *)
(* cyclic when G is of prime order. *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GroupScope GRing.Theory.
(***********************************************************************)
(* Cyclic groups. *)
(***********************************************************************)
Section Cyclic.
Variable gT : finGroupType.
Implicit Types (a x y : gT) (A B : {set gT}) (G K H : {group gT}).
Definition cyclic A := [exists x, A == <[x]>].
Lemma cyclicP A : reflect (exists x, A = <[x]>) (cyclic A).
Proof. exact: exists_eqP. Qed.
Lemma cycle_cyclic x : cyclic <[x]>.
Proof. by apply/cyclicP; exists x. Qed.
Lemma cyclic1 : cyclic [1 gT].
Proof. by rewrite -cycle1 cycle_cyclic. Qed.
(***********************************************************************)
(* Isomorphism with the additive group *)
(***********************************************************************)
Section Zpm.
Variable a : gT.
Definition Zpm (i : 'Z_#[a]) := a ^+ i.
Lemma ZpmM : {in Zp #[a] &, {morph Zpm : x y / x * y}}.
Proof.
rewrite /Zpm; case: (eqVneq a 1) => [-> | nta] i j _ _.
by rewrite !expg1n ?mulg1.
by rewrite /= {3}Zp_cast ?order_gt1 // expg_mod_order expgD.
Qed.
Canonical Zpm_morphism := Morphism ZpmM.
Lemma im_Zpm : Zpm @* Zp #[a] = <[a]>.
Proof.
apply/eqP; rewrite eq_sym eqEcard cycle_subG /= andbC morphimEdom.
rewrite (leq_trans (leq_imset_card _ _)) ?card_Zp //= /Zp order_gt1.
case: eqP => /= [a1 | _]; first by rewrite imset_set1 morph1 a1 set11.
by apply/imsetP; exists 1%R; rewrite ?expg1 ?inE.
Qed.
Lemma injm_Zpm : 'injm Zpm.
Proof.
apply/injmP/dinjectiveP/card_uniqP.
rewrite size_map -cardE card_Zp //= {7}/order -im_Zpm morphimEdom /=.
by apply: eq_card => x; apply/imageP/imsetP=> [] [i Zp_i ->]; exists i.
Qed.
Lemma eq_expg_mod_order m n : (a ^+ m == a ^+ n) = (m == n %[mod #[a]]).
Proof.
have [->|] := eqVneq a 1; first by rewrite order1 !modn1 !expg1n eqxx.
rewrite -order_gt1 => lt1a; have ZpT: Zp #[a] = setT by rewrite /Zp lt1a.
have: injective Zpm by move=> i j; apply (injmP injm_Zpm); rewrite /= ZpT inE.
move/inj_eq=> eqZ; symmetry; rewrite -(Zp_cast lt1a).
by rewrite -[_ == _](eqZ (inZp m) (inZp n)) /Zpm /= Zp_cast ?expg_mod_order.
Qed.
Lemma Zp_isom : isom (Zp #[a]) <[a]> Zpm.
Proof. by apply/isomP; rewrite injm_Zpm im_Zpm. Qed.
Lemma Zp_isog : isog (Zp #[a]) <[a]>.
Proof. exact: isom_isog Zp_isom. Qed.
End Zpm.
(***********************************************************************)
(* Central and direct product of cycles *)
(***********************************************************************)
Lemma cyclic_abelian A : cyclic A -> abelian A.
Proof. by case/cyclicP=> a ->; exact: cycle_abelian. Qed.
Lemma cycleMsub a b :
commute a b -> coprime #[a] #[b] -> <[a]> \subset <[a * b]>.
Proof.
move=> cab co_ab; apply/subsetP=> _ /cycleP[k ->].
apply/cycleP; exists (chinese #[a] #[b] k 0); symmetry.
rewrite expgMn // -expg_mod_order chinese_modl // expg_mod_order.
by rewrite /chinese addn0 -mulnA mulnCA expgM expg_order expg1n mulg1.
Qed.
Lemma cycleM a b :
commute a b -> coprime #[a] #[b] -> <[a * b]> = <[a]> * <[b]>.
Proof.
move=> cab co_ab; apply/eqP; rewrite eqEsubset -(cent_joinEl (cents_cycle cab)).
rewrite join_subG {3}cab !cycleMsub // 1?coprime_sym //.
by rewrite -genM_join cycle_subG mem_gen // mem_imset2 ?cycle_id.
Qed.
Lemma cyclicM A B :
cyclic A -> cyclic B -> B \subset 'C(A) -> coprime #|A| #|B| ->
cyclic (A * B).
Proof.
move=> /cyclicP[a ->] /cyclicP[b ->]; rewrite cent_cycle cycle_subG => cab coab.
by rewrite -cycleM ?cycle_cyclic //; exact/esym/cent1P.
Qed.
Lemma cyclicY K H :
cyclic K -> cyclic H -> H \subset 'C(K) -> coprime #|K| #|H| ->
cyclic (K <*> H).
Proof. by move=> cycK cycH cKH coKH; rewrite cent_joinEr // cyclicM. Qed.
(***********************************************************************)
(* Order properties *)
(***********************************************************************)
Lemma order_dvdn a n : #[a] %| n = (a ^+ n == 1).
Proof. by rewrite (eq_expg_mod_order a n 0) mod0n. Qed.
Lemma order_inf a n : a ^+ n.+1 == 1 -> #[a] <= n.+1.
Proof. by rewrite -order_dvdn; exact: dvdn_leq. Qed.
Lemma order_dvdG G a : a \in G -> #[a] %| #|G|.
Proof. by move=> Ga; apply: cardSg; rewrite cycle_subG. Qed.
Lemma expg_cardG G a : a \in G -> a ^+ #|G| = 1.
Proof. by move=> Ga; apply/eqP; rewrite -order_dvdn order_dvdG. Qed.
Lemma expg_znat G x k : x \in G -> x ^+ (k%:R : 'Z_(#|G|))%R = x ^+ k.
Proof.
case: (eqsVneq G 1) => [-> /set1P-> | ntG Gx]; first by rewrite !expg1n.
apply/eqP; rewrite val_Zp_nat ?cardG_gt1 // eq_expg_mod_order.
by rewrite modn_dvdm ?order_dvdG.
Qed.
Lemma expg_zneg G x (k : 'Z_(#|G|)) : x \in G -> x ^+ (- k)%R = x ^- k.
Proof.
move=> Gx; apply/eqP; rewrite eq_sym eq_invg_mul -expgD.
by rewrite -(expg_znat _ Gx) natrD natr_Zp natr_negZp subrr.
Qed.
Lemma nt_gen_prime G x : prime #|G| -> x \in G^# -> G :=: <[x]>.
Proof.
move=> Gpr /setD1P[]; rewrite -cycle_subG -cycle_eq1 => ntX sXG.
apply/eqP; rewrite eqEsubset sXG andbT.
by apply: contraR ntX => /(prime_TIg Gpr); rewrite (setIidPr sXG) => ->.
Qed.
Lemma nt_prime_order p x : prime p -> x ^+ p = 1 -> x != 1 -> #[x] = p.
Proof.
move=> p_pr xp ntx; apply/prime_nt_dvdP; rewrite ?order_eq1 //.
by rewrite order_dvdn xp.
Qed.
Lemma orderXdvd a n : #[a ^+ n] %| #[a].
Proof. by apply: order_dvdG; exact: mem_cycle. Qed.
Lemma orderXgcd a n : #[a ^+ n] = #[a] %/ gcdn #[a] n.
Proof.
apply/eqP; rewrite eqn_dvd; apply/andP; split.
rewrite order_dvdn -expgM -muln_divCA_gcd //.
by rewrite expgM expg_order expg1n.
have [-> | n_gt0] := posnP n; first by rewrite gcdn0 divnn order_gt0 dvd1n.
rewrite -(dvdn_pmul2r n_gt0) divn_mulAC ?dvdn_gcdl // dvdn_lcm.
by rewrite order_dvdn mulnC expgM expg_order eqxx dvdn_mulr.
Qed.
Lemma orderXdiv a n : n %| #[a] -> #[a ^+ n] = #[a] %/ n.
Proof. by case/dvdnP=> q defq; rewrite orderXgcd {2}defq gcdnC gcdnMl. Qed.
Lemma orderXexp p m n x : #[x] = (p ^ n)%N -> #[x ^+ (p ^ m)] = (p ^ (n - m))%N.
Proof.
move=> ox; have [n_le_m | m_lt_n] := leqP n m.
rewrite -(subnKC n_le_m) subnDA subnn expnD expgM -ox.
by rewrite expg_order expg1n order1.
rewrite orderXdiv ox ?dvdn_exp2l ?expnB ?(ltnW m_lt_n) //.
by have:= order_gt0 x; rewrite ox expn_gt0 orbC -(ltn_predK m_lt_n).
Qed.
Lemma orderXpfactor p k n x :
#[x ^+ (p ^ k)] = n -> prime p -> p %| n -> #[x] = (p ^ k * n)%N.
Proof.
move=> oxp p_pr dv_p_n.
suffices pk_x: p ^ k %| #[x] by rewrite -oxp orderXdiv // mulnC divnK.
rewrite pfactor_dvdn // leqNgt; apply: contraL dv_p_n => lt_x_k.
rewrite -oxp -p'natE // -(subnKC (ltnW lt_x_k)) expnD expgM.
rewrite (pnat_dvd (orderXdvd _ _)) // -p_part // orderXdiv ?dvdn_part //.
by rewrite -{1}[#[x]](partnC p) // mulKn // part_pnat.
Qed.
Lemma orderXprime p n x :
#[x ^+ p] = n -> prime p -> p %| n -> #[x] = (p * n)%N.
Proof. exact: (@orderXpfactor p 1). Qed.
Lemma orderXpnat m n x : #[x ^+ m] = n -> \pi(n).-nat m -> #[x] = (m * n)%N.
Proof.
move=> oxm n_m; have [m_gt0 _] := andP n_m.
suffices m_x: m %| #[x] by rewrite -oxm orderXdiv // mulnC divnK.
apply/dvdn_partP=> // p; rewrite mem_primes => /and3P[p_pr _ p_m].
have n_p: p \in \pi(n) by apply: (pnatP _ _ n_m).
have p_oxm: p %| #[x ^+ (p ^ logn p m)].
apply: dvdn_trans (orderXdvd _ m`_p^'); rewrite -expgM -p_part ?partnC //.
by rewrite oxm; rewrite mem_primes in n_p; case/and3P: n_p.
by rewrite (orderXpfactor (erefl _) p_pr p_oxm) p_part // dvdn_mulr.
Qed.
Lemma orderM a b :
commute a b -> coprime #[a] #[b] -> #[a * b] = (#[a] * #[b])%N.
Proof. by move=> cab co_ab; rewrite -coprime_cardMg -?cycleM. Qed.
Definition expg_invn A k := (egcdn k #|A|).1.
Lemma expgK G k :
coprime #|G| k -> {in G, cancel (expgn^~ k) (expgn^~ (expg_invn G k))}.
Proof.
move=> coGk x /order_dvdG Gx; apply/eqP.
rewrite -expgM (eq_expg_mod_order _ _ 1) -(modn_dvdm 1 Gx).
by rewrite -(chinese_modl coGk 1 0) /chinese mul1n addn0 modn_dvdm.
Qed.
Lemma cyclic_dprod K H G :
K \x H = G -> cyclic K -> cyclic H -> cyclic G = coprime #|K| #|H| .
Proof.
case/dprodP=> _ defKH cKH tiKH cycK cycH; pose m := lcmn #|K| #|H|.
apply/idP/idP=> [/cyclicP[x defG] | coKH]; last by rewrite -defKH cyclicM.
rewrite /coprime -dvdn1 -(@dvdn_pmul2l m) ?lcmn_gt0 ?cardG_gt0 //.
rewrite muln_lcm_gcd muln1 -TI_cardMg // defKH defG order_dvdn.
have /mulsgP[y z Ky Hz ->]: x \in K * H by rewrite defKH defG cycle_id.
rewrite -[1]mulg1 expgMn; last exact/commute_sym/(centsP cKH).
apply/eqP; congr (_ * _); apply/eqP; rewrite -order_dvdn.
exact: dvdn_trans (order_dvdG Ky) (dvdn_lcml _ _).
exact: dvdn_trans (order_dvdG Hz) (dvdn_lcmr _ _).
Qed.
(***********************************************************************)
(* Generator *)
(***********************************************************************)
Definition generator (A : {set gT}) a := A == <[a]>.
Lemma generator_cycle a : generator <[a]> a.
Proof. exact: eqxx. Qed.
Lemma cycle_generator a x : generator <[a]> x -> x \in <[a]>.
Proof. by move/(<[a]> =P _)->; exact: cycle_id. Qed.
Lemma generator_order a b : generator <[a]> b -> #[a] = #[b].
Proof. by rewrite /order => /(<[a]> =P _)->. Qed.
End Cyclic.
Arguments Scope cyclic [_ group_scope].
Arguments Scope generator [_ group_scope group_scope].
Arguments Scope expg_invn [_ group_scope nat_scope].
Implicit Arguments cyclicP [gT A].
Prenex Implicits cyclic Zpm generator expg_invn.
(* Euler's theorem *)
Theorem Euler_exp_totient a n : coprime a n -> a ^ totient n = 1 %[mod n].
Proof.
case: n => [|[|n']] //; [by rewrite !modn1 | set n := n'.+2] => co_a_n.
have{co_a_n} Ua: coprime n (inZp a : 'I_n) by rewrite coprime_sym coprime_modl.
have: FinRing.unit 'Z_n Ua ^+ totient n == 1.
by rewrite -card_units_Zp // -order_dvdn order_dvdG ?inE.
by rewrite -2!val_eqE unit_Zp_expg /= -/n modnXm => /eqP.
Qed.
Section Eltm.
Variables (aT rT : finGroupType) (x : aT) (y : rT).
Definition eltm of #[y] %| #[x] := fun x_i => y ^+ invm (injm_Zpm x) x_i.
Hypothesis dvd_y_x : #[y] %| #[x].
Lemma eltmE i : eltm dvd_y_x (x ^+ i) = y ^+ i.
Proof.
apply/eqP; rewrite eq_expg_mod_order.
have [x_le1 | x_gt1] := leqP #[x] 1.
suffices: #[y] %| 1 by rewrite dvdn1 => /eqP->; rewrite !modn1.
by rewrite (dvdn_trans dvd_y_x) // dvdn1 order_eq1 -cycle_eq1 trivg_card_le1.
rewrite -(expg_znat i (cycle_id x)) invmE /=; last by rewrite /Zp x_gt1 inE.
by rewrite val_Zp_nat // modn_dvdm.
Qed.
Lemma eltm_id : eltm dvd_y_x x = y. Proof. exact: (eltmE 1). Qed.
Lemma eltmM : {in <[x]> &, {morph eltm dvd_y_x : x_i x_j / x_i * x_j}}.
Proof.
move=> _ _ /cycleP[i ->] /cycleP[j ->].
by apply/eqP; rewrite -expgD !eltmE expgD.
Qed.
Canonical eltm_morphism := Morphism eltmM.
Lemma im_eltm : eltm dvd_y_x @* <[x]> = <[y]>.
Proof. by rewrite morphim_cycle ?cycle_id //= eltm_id. Qed.
Lemma ker_eltm : 'ker (eltm dvd_y_x) = <[x ^+ #[y]]>.
Proof.
apply/eqP; rewrite eq_sym eqEcard cycle_subG 3!inE mem_cycle /= eltmE.
rewrite expg_order eqxx (orderE y) -im_eltm card_morphim setIid -orderE.
by rewrite orderXdiv ?dvdn_indexg //= leq_divRL ?indexg_gt0 ?Lagrange ?subsetIl.
Qed.
Lemma injm_eltm : 'injm (eltm dvd_y_x) = (#[x] %| #[y]).
Proof. by rewrite ker_eltm subG1 cycle_eq1 -order_dvdn. Qed.
End Eltm.
Section CycleSubGroup.
Variable gT : finGroupType.
(* Gorenstein, 1.3.1 (i) *)
Lemma cycle_sub_group (a : gT) m :
m %| #[a] ->
[set H : {group gT} | H \subset <[a]> & #|H| == m]
= [set <[a ^+ (#[a] %/ m)]>%G].
Proof.
move=> m_dv_a; have m_gt0: 0 < m by apply: dvdn_gt0 m_dv_a.
have oam: #|<[a ^+ (#[a] %/ m)]>| = m.
apply/eqP; rewrite [#|_|]orderXgcd -(divnMr m_gt0) muln_gcdl divnK //.
by rewrite gcdnC gcdnMr mulKn.
apply/eqP; rewrite eqEsubset sub1set inE /= cycleX oam eqxx !andbT.
apply/subsetP=> X; rewrite in_set1 inE -val_eqE /= eqEcard oam.
case/andP=> sXa /eqP oX; rewrite oX leqnn andbT.
apply/subsetP=> x Xx; case/cycleP: (subsetP sXa _ Xx) => k def_x.
have: (x ^+ m == 1)%g by rewrite -oX -order_dvdn cardSg // gen_subG sub1set.
rewrite {x Xx}def_x -expgM -order_dvdn -[#[a]](Lagrange sXa) -oX mulnC.
rewrite dvdn_pmul2r // mulnK // => /dvdnP[i ->].
by rewrite mulnC expgM groupX // cycle_id.
Qed.
Lemma cycle_subgroup_char a (H : {group gT}) : H \subset <[a]> -> H \char <[a]>.
Proof.
move=> sHa; apply: lone_subgroup_char => // J sJa isoJH.
have dvHa: #|H| %| #[a] by exact: cardSg.
have{dvHa} /setP Huniq := esym (cycle_sub_group dvHa).
move: (Huniq H) (Huniq J); rewrite !inE /=.
by rewrite sHa sJa (card_isog isoJH) eqxx => /eqP<- /eqP<-.
Qed.
End CycleSubGroup.
(***********************************************************************)
(* Reflected boolean property and morphic image, injection, bijection *)
(***********************************************************************)
Section MorphicImage.
Variables aT rT : finGroupType.
Variables (D : {group aT}) (f : {morphism D >-> rT}) (x : aT).
Hypothesis Dx : x \in D.
Lemma morph_order : #[f x] %| #[x].
Proof. by rewrite order_dvdn -morphX // expg_order morph1. Qed.
Lemma morph_generator A : generator A x -> generator (f @* A) (f x).
Proof. by move/(A =P _)->; rewrite /generator morphim_cycle. Qed.
End MorphicImage.
Section CyclicProps.
Variables gT : finGroupType.
Implicit Types (aT rT : finGroupType) (G H K : {group gT}).
Lemma cyclicS G H : H \subset G -> cyclic G -> cyclic H.
Proof.
move=> sHG /cyclicP[x defG]; apply/cyclicP.
exists (x ^+ (#[x] %/ #|H|)); apply/congr_group/set1P.
by rewrite -cycle_sub_group /order -defG ?cardSg // inE sHG eqxx.
Qed.
Lemma cyclicJ G x : cyclic (G :^ x) = cyclic G.
Proof.
apply/cyclicP/cyclicP=> [[y /(canRL (conjsgK x))] | [y ->]].
by rewrite -cycleJ; exists (y ^ x^-1).
by exists (y ^ x); rewrite cycleJ.
Qed.
Lemma eq_subG_cyclic G H K :
cyclic G -> H \subset G -> K \subset G -> (H :==: K) = (#|H| == #|K|).
Proof.
case/cyclicP=> x -> sHx sKx; apply/eqP/eqP=> [-> //| eqHK].
have def_GHx := cycle_sub_group (cardSg sHx); set GHx := [set _] in def_GHx.
have []: H \in GHx /\ K \in GHx by rewrite -def_GHx !inE sHx sKx eqHK /=.
by do 2!move/set1P->.
Qed.
Lemma cardSg_cyclic G H K :
cyclic G -> H \subset G -> K \subset G -> (#|H| %| #|K|) = (H \subset K).
Proof.
move=> cycG sHG sKG; apply/idP/idP; last exact: cardSg.
case/cyclicP: (cyclicS sKG cycG) => x defK; rewrite {K}defK in sKG *.
case/dvdnP=> k ox; suffices ->: H :=: <[x ^+ k]> by exact: cycleX.
apply/eqP; rewrite (eq_subG_cyclic cycG) ?(subset_trans (cycleX _ _)) //.
rewrite -orderE orderXdiv orderE ox ?dvdn_mulr ?mulKn //.
by have:= order_gt0 x; rewrite orderE ox; case k.
Qed.
Lemma sub_cyclic_char G H : cyclic G -> (H \char G) = (H \subset G).
Proof.
case/cyclicP=> x ->; apply/idP/idP => [/andP[] //|].
exact: cycle_subgroup_char.
Qed.
Lemma morphim_cyclic rT G H (f : {morphism G >-> rT}) :
cyclic H -> cyclic (f @* H).
Proof.
move=> cycH; wlog sHG: H cycH / H \subset G.
by rewrite -morphimIdom; apply; rewrite (cyclicS _ cycH, subsetIl) ?subsetIr.
case/cyclicP: cycH sHG => x ->; rewrite gen_subG sub1set => Gx.
by apply/cyclicP; exists (f x); rewrite morphim_cycle.
Qed.
Lemma quotient_cycle x H : x \in 'N(H) -> <[x]> / H = <[coset H x]>.
Proof. exact: morphim_cycle. Qed.
Lemma quotient_cyclic G H : cyclic G -> cyclic (G / H).
Proof. exact: morphim_cyclic. Qed.
Lemma quotient_generator x G H :
x \in 'N(H) -> generator G x -> generator (G / H) (coset H x).
Proof. by move=> Nx; apply: morph_generator. Qed.
Lemma prime_cyclic G : prime #|G| -> cyclic G.
Proof.
case/primeP; rewrite ltnNge -trivg_card_le1.
case/trivgPn=> x Gx ntx /(_ _ (order_dvdG Gx)).
rewrite order_eq1 (negbTE ntx) => /eqnP oxG; apply/cyclicP.
by exists x; apply/eqP; rewrite eq_sym eqEcard -oxG cycle_subG Gx leqnn.
Qed.
Lemma dvdn_prime_cyclic G p : prime p -> #|G| %| p -> cyclic G.
Proof.
move=> p_pr pG; case: (eqsVneq G 1) => [-> | ntG]; first exact: cyclic1.
by rewrite prime_cyclic // (prime_nt_dvdP p_pr _ pG) -?trivg_card1.
Qed.
Lemma cyclic_small G : #|G| <= 3 -> cyclic G.
Proof.
rewrite 4!(ltnS, leq_eqVlt) -trivg_card_le1 orbA orbC.
case/predU1P=> [-> | oG]; first exact: cyclic1.
by apply: prime_cyclic; case/pred2P: oG => ->.
Qed.
End CyclicProps.
Section IsoCyclic.
Variables gT rT : finGroupType.
Implicit Types (G H : {group gT}) (M : {group rT}).
Lemma injm_cyclic G H (f : {morphism G >-> rT}) :
'injm f -> H \subset G -> cyclic (f @* H) = cyclic H.
Proof.
move=> injf sHG; apply/idP/idP; last exact: morphim_cyclic.
rewrite -{2}(morphim_invm injf sHG); exact: morphim_cyclic.
Qed.
Lemma isog_cyclic G M : G \isog M -> cyclic G = cyclic M.
Proof. by case/isogP=> f injf <-; rewrite injm_cyclic. Qed.
Lemma isog_cyclic_card G M : cyclic G -> isog G M = cyclic M && (#|M| == #|G|).
Proof.
move=> cycG; apply/idP/idP=> [isoGM | ].
by rewrite (card_isog isoGM) -(isog_cyclic isoGM) cycG /=.
case/cyclicP: cycG => x ->{G} /andP[/cyclicP[y ->] /eqP oy].
by apply: isog_trans (isog_symr _) (Zp_isog y); rewrite /order oy Zp_isog.
Qed.
Lemma injm_generator G H (f : {morphism G >-> rT}) x :
'injm f -> x \in G -> H \subset G ->
generator (f @* H) (f x) = generator H x.
Proof.
move=> injf Gx sHG; apply/idP/idP; last exact: morph_generator.
rewrite -{2}(morphim_invm injf sHG) -{2}(invmE injf Gx).
by apply: morph_generator; exact: mem_morphim.
Qed.
End IsoCyclic.
(* Metacyclic groups. *)
Section Metacyclic.
Variable gT : finGroupType.
Implicit Types (A : {set gT}) (G H : {group gT}).
Definition metacyclic A :=
[exists H : {group gT}, [&& cyclic H, H <| A & cyclic (A / H)]].
Lemma metacyclicP A :
reflect (exists H : {group gT}, [/\ cyclic H, H <| A & cyclic (A / H)])
(metacyclic A).
Proof. exact: 'exists_and3P. Qed.
Lemma metacyclic1 : metacyclic 1.
Proof.
by apply/existsP; exists 1%G; rewrite normal1 trivg_quotient !cyclic1.
Qed.
Lemma cyclic_metacyclic A : cyclic A -> metacyclic A.
Proof.
case/cyclicP=> x ->; apply/existsP; exists (<[x]>)%G.
by rewrite normal_refl cycle_cyclic trivg_quotient cyclic1.
Qed.
Lemma metacyclicS G H : H \subset G -> metacyclic G -> metacyclic H.
Proof.
move=> sHG /metacyclicP[K [cycK nsKG cycGq]]; apply/metacyclicP.
exists (H :&: K)%G; rewrite (cyclicS (subsetIr H K)) ?(normalGI sHG) //=.
rewrite setIC (isog_cyclic (second_isog _)) ?(cyclicS _ cycGq) ?quotientS //.
by rewrite (subset_trans sHG) ?normal_norm.
Qed.
End Metacyclic.
Arguments Scope metacyclic [_ group_scope].
Prenex Implicits metacyclic.
Implicit Arguments metacyclicP [gT A].
(* Automorphisms of cyclic groups. *)
Section CyclicAutomorphism.
Variable gT : finGroupType.
Section CycleAutomorphism.
Variable a : gT.
Section CycleMorphism.
Variable n : nat.
Definition cyclem of gT := fun x : gT => x ^+ n.
Lemma cyclemM : {in <[a]> & , {morph cyclem a : x y / x * y}}.
Proof.
by move=> x y ax ay; apply: expgMn; exact: (centsP (cycle_abelian a)).
Qed.
Canonical cyclem_morphism := Morphism cyclemM.
End CycleMorphism.
Section ZpUnitMorphism.
Variable u : {unit 'Z_#[a]}.
Lemma injm_cyclem : 'injm (cyclem (val u) a).
Proof.
apply/subsetP=> x /setIdP[ax]; rewrite !inE -order_dvdn.
case: (eqVneq a 1) => [a1 | nta]; first by rewrite a1 cycle1 inE in ax.
rewrite -order_eq1 -dvdn1; move/eqnP: (valP u) => /= <-.
by rewrite dvdn_gcd {2}Zp_cast ?order_gt1 // order_dvdG.
Qed.
Lemma im_cyclem : cyclem (val u) a @* <[a]> = <[a]>.
Proof.
apply/morphim_fixP=> //; first exact: injm_cyclem.
by rewrite morphim_cycle ?cycle_id ?cycleX.
Qed.
Definition Zp_unitm := aut injm_cyclem im_cyclem.
End ZpUnitMorphism.
Lemma Zp_unitmM : {in units_Zp #[a] &, {morph Zp_unitm : u v / u * v}}.
Proof.
move=> u v _ _; apply: (eq_Aut (Aut_aut _ _)) => [|x a_x].
by rewrite groupM ?Aut_aut.
rewrite permM !autE ?groupX //= /cyclem -expgM.
rewrite -expg_mod_order modn_dvdm ?expg_mod_order //.
case: (leqP #[a] 1) => [lea1 | lt1a]; last by rewrite Zp_cast ?order_dvdG.
by rewrite card_le1_trivg // in a_x; rewrite (set1P a_x) order1 dvd1n.
Qed.
Canonical Zp_unit_morphism := Morphism Zp_unitmM.
Lemma injm_Zp_unitm : 'injm Zp_unitm.
Proof.
case: (eqVneq a 1) => [a1 | nta].
by rewrite subIset //= card_le1_trivg ?subxx // card_units_Zp a1 order1.
apply/subsetP=> /= u /morphpreP[_ /set1P/= um1].
have{um1}: Zp_unitm u a == Zp_unitm 1 a by rewrite um1 morph1.
rewrite !autE ?cycle_id // eq_expg_mod_order.
by rewrite -[n in _ == _ %[mod n]]Zp_cast ?order_gt1 // !modZp inE.
Qed.
Lemma generator_coprime m : generator <[a]> (a ^+ m) = coprime #[a] m.
Proof.
rewrite /generator eq_sym eqEcard cycleX -/#[a] [#|_|]orderXgcd /=.
apply/idP/idP=> [le_a_am|co_am]; last by rewrite (eqnP co_am) divn1.
have am_gt0: 0 < gcdn #[a] m by rewrite gcdn_gt0 order_gt0.
by rewrite /coprime eqn_leq am_gt0 andbT -(@leq_pmul2l #[a]) ?muln1 -?leq_divRL.
Qed.
Lemma im_Zp_unitm : Zp_unitm @* units_Zp #[a] = Aut <[a]>.
Proof.
rewrite morphimEdom; apply/setP=> f; pose n := invm (injm_Zpm a) (f a).
apply/imsetP/idP=> [[u _ ->] | Af]; first exact: Aut_aut.
have [a1 | nta] := eqVneq a 1.
by rewrite a1 cycle1 Aut1 in Af; exists 1; rewrite // morph1 (set1P Af).
have a_fa: <[a]> = <[f a]>.
by rewrite -(autmE Af) -morphim_cycle ?im_autm ?cycle_id.
have def_n: a ^+ n = f a.
by rewrite -/(Zpm n) invmK // im_Zpm a_fa cycle_id.
have co_a_n: coprime #[a].-2.+2 n.
by rewrite {1}Zp_cast ?order_gt1 // -generator_coprime def_n; exact/eqP.
exists (FinRing.unit 'Z_#[a] co_a_n); rewrite ?inE //.
apply: eq_Aut (Af) (Aut_aut _ _) _ => x ax.
rewrite autE //= /cyclem; case/cycleP: ax => k ->{x}.
by rewrite -(autmE Af) morphX ?cycle_id //= autmE -def_n -!expgM mulnC.
Qed.
Lemma Zp_unit_isom : isom (units_Zp #[a]) (Aut <[a]>) Zp_unitm.
Proof. by apply/isomP; rewrite ?injm_Zp_unitm ?im_Zp_unitm. Qed.
Lemma Zp_unit_isog : isog (units_Zp #[a]) (Aut <[a]>).
Proof. exact: isom_isog Zp_unit_isom. Qed.
Lemma card_Aut_cycle : #|Aut <[a]>| = totient #[a].
Proof. by rewrite -(card_isog Zp_unit_isog) card_units_Zp. Qed.
Lemma totient_gen : totient #[a] = #|[set x | generator <[a]> x]|.
Proof.
have [lea1 | lt1a] := leqP #[a] 1.
rewrite /order card_le1_trivg // cards1 (@eq_card1 _ 1) // => x.
by rewrite !inE -cycle_eq1 eq_sym.
rewrite -(card_injm (injm_invm (injm_Zpm a))) /= ?im_Zpm; last first.
by apply/subsetP=> x; rewrite inE; exact: cycle_generator.
rewrite -card_units_Zp // cardsE card_sub morphim_invmE; apply: eq_card => /= d.
by rewrite !inE /= qualifE /= /Zp lt1a inE /= generator_coprime {1}Zp_cast.
Qed.
Lemma Aut_cycle_abelian : abelian (Aut <[a]>).
Proof. by rewrite -im_Zp_unitm morphim_abelian ?units_Zp_abelian. Qed.
End CycleAutomorphism.
Variable G : {group gT}.
Lemma Aut_cyclic_abelian : cyclic G -> abelian (Aut G).
Proof. by case/cyclicP=> x ->; exact: Aut_cycle_abelian. Qed.
Lemma card_Aut_cyclic : cyclic G -> #|Aut G| = totient #|G|.
Proof. by case/cyclicP=> x ->; exact: card_Aut_cycle. Qed.
Lemma sum_ncycle_totient :
\sum_(d < #|G|.+1) #|[set <[x]> | x in G & #[x] == d]| * totient d = #|G|.
Proof.
pose h (x : gT) : 'I_#|G|.+1 := inord #[x].
symmetry; rewrite -{1}sum1_card (partition_big h xpredT) //=.
apply: eq_bigr => d _; set Gd := finset _.
rewrite -sum_nat_const sum1dep_card -sum1_card (_ : finset _ = Gd); last first.
apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx.
by rewrite /eq_op /= inordK // ltnS subset_leq_card ?cycle_subG.
rewrite (partition_big_imset cycle) {}/Gd; apply: eq_bigr => C /=.
case/imsetP=> x /setIdP[Gx /eqP <-] -> {C d}.
rewrite sum1dep_card totient_gen; apply: eq_card => y; rewrite !inE /generator.
move: Gx; rewrite andbC eq_sym -!cycle_subG /order.
by case: eqP => // -> ->; rewrite eqxx.
Qed.
End CyclicAutomorphism.
Lemma sum_totient_dvd n : \sum_(d < n.+1 | d %| n) totient d = n.
Proof.
case: n => [|[|n']]; try by rewrite big_mkcond !big_ord_recl big_ord0.
set n := n'.+2; pose x1 : 'Z_n := 1%R.
have ox1: #[x1] = n by rewrite /order -Zp_cycle card_Zp.
rewrite -[rhs in _ = rhs]ox1 -[#[_]]sum_ncycle_totient [#|_|]ox1 big_mkcond /=.
apply: eq_bigr => d _; rewrite -{2}ox1; case: ifP => [|ndv_dG]; last first.
rewrite eq_card0 // => C; apply/imsetP=> [[x /setIdP[Gx oxd] _{C}]].
by rewrite -(eqP oxd) order_dvdG in ndv_dG.
move/cycle_sub_group; set Gd := [set _] => def_Gd.
rewrite (_ : _ @: _ = @gval _ @: Gd); first by rewrite imset_set1 cards1 mul1n.
apply/setP=> C; apply/idP/imsetP=> [| [gC GdC ->{C}]].
case/imsetP=> x /setIdP[_ oxd] ->; exists <[x]>%G => //.
by rewrite -def_Gd inE -Zp_cycle subsetT.
have:= GdC; rewrite -def_Gd => /setIdP[_ /eqP <-].
by rewrite (set1P GdC) /= mem_imset // inE eqxx (mem_cycle x1).
Qed.
Section FieldMulCyclic.
(***********************************************************************)
(* A classic application to finite multiplicative subgroups of fields. *)
(***********************************************************************)
Import GRing.Theory.
Variables (gT : finGroupType) (G : {group gT}).
Lemma order_inj_cyclic :
{in G &, forall x y, #[x] = #[y] -> <[x]> = <[y]>} -> cyclic G.
Proof.
move=> ucG; apply: negbNE (contra _ (negbT (ltnn #|G|))) => ncG.
rewrite -{2}[#|G|]sum_totient_dvd big_mkcond (bigD1 ord_max) ?dvdnn //=.
rewrite -{1}[#|G|]sum_ncycle_totient (bigD1 ord_max) //= -addSn leq_add //.
rewrite eq_card0 ?totient_gt0 ?cardG_gt0 // => C.
apply/imsetP=> [[x /setIdP[Gx /eqP oxG]]]; case/cyclicP: ncG.
by exists x; apply/eqP; rewrite eq_sym eqEcard cycle_subG Gx -oxG /=.
elim/big_ind2: _ => // [m1 n1 m2 n2 | d _]; first exact: leq_add.
set Gd := _ @: _; case: (set_0Vmem Gd) => [-> | [C]]; first by rewrite cards0.
rewrite {}/Gd => /imsetP[x /setIdP[Gx /eqP <-] _ {C d}].
rewrite order_dvdG // (@eq_card1 _ <[x]>) ?mul1n // => C.
apply/idP/eqP=> [|-> {C}]; last by rewrite mem_imset // inE Gx eqxx.
by case/imsetP=> y /setIdP[Gy /eqP/ucG->].
Qed.
Lemma div_ring_mul_group_cyclic (R : unitRingType) (f : gT -> R) :
f 1 = 1%R -> {in G &, {morph f : u v / u * v >-> (u * v)%R}} ->
{in G^#, forall x, f x - 1 \in GRing.unit}%R ->
abelian G -> cyclic G.
Proof.
move=> f1 fM f1P abelG.
have fX n: {in G, {morph f : u / u ^+ n >-> (u ^+ n)%R}}.
by case: n => // n x Gx; elim: n => //= n IHn; rewrite expgS fM ?groupX ?IHn.
have fU x: x \in G -> f x \in GRing.unit.
by move=> Gx; apply/unitrP; exists (f x^-1); rewrite -!fM ?groupV ?gsimp.
apply: order_inj_cyclic => x y Gx Gy; set n := #[x] => yn.
apply/eqP; rewrite eq_sym eqEcard -[#|_|]/n yn leqnn andbT cycle_subG /=.
suff{y Gy yn} ->: <[x]> = G :&: [set z | #[z] %| n] by rewrite !inE Gy yn /=.
apply/eqP; rewrite eqEcard subsetI cycle_subG {}Gx /= cardE; set rs := enum _.
apply/andP; split; first by apply/subsetP=> y xy; rewrite inE order_dvdG.
pose P : {poly R} := ('X^n - 1)%R; have n_gt0: n > 0 by exact: order_gt0.
have szP: size P = n.+1 by rewrite size_addl size_polyXn ?size_opp ?size_poly1.
rewrite -ltnS -szP -(size_map f) max_ring_poly_roots -?size_poly_eq0 ?{}szP //.
apply/allP=> fy /mapP[y]; rewrite mem_enum !inE order_dvdn => /andP[Gy].
move/eqP=> yn1 ->{fy}; apply/eqP.
by rewrite !(hornerE, hornerXn) -fX // yn1 f1 subrr.
have: uniq rs by exact: enum_uniq.
have: all (mem G) rs by apply/allP=> y; rewrite mem_enum; case/setIP.
elim: rs => //= y rs IHrs /andP[Gy Grs] /andP[y_rs]; rewrite andbC.
move/IHrs=> -> {IHrs}//; apply/allP=> _ /mapP[z rs_z ->].
have{Grs} Gz := allP Grs z rs_z; rewrite /diff_roots -!fM // (centsP abelG) //.
rewrite eqxx -[f y]mul1r -(mulgKV y z) fM ?groupM ?groupV //=.
rewrite -mulNr -mulrDl unitrMl ?fU ?f1P // !inE.
by rewrite groupM ?groupV // andbT -eq_mulgV1; apply: contra y_rs; move/eqP <-.
Qed.
Lemma field_mul_group_cyclic (F : fieldType) (f : gT -> F) :
{in G &, {morph f : u v / u * v >-> (u * v)%R}} ->
{in G, forall x, f x = 1%R <-> x = 1} ->
cyclic G.
Proof.
move=> fM f1P; have f1 : f 1 = 1%R by exact/f1P.
apply: (div_ring_mul_group_cyclic f1 fM) => [x|].
case/setD1P=> x1 Gx; rewrite unitfE; apply: contra x1.
by rewrite subr_eq0 => /eqP/f1P->.
apply/centsP=> x Gx y Gy; apply/commgP/eqP.
apply/f1P; rewrite ?fM ?groupM ?groupV //.
by rewrite mulrCA -!fM ?groupM ?groupV // mulKg mulVg.
Qed.
End FieldMulCyclic.
Lemma field_unit_group_cyclic (F : finFieldType) (G : {group {unit F}}) :
cyclic G.
Proof.
apply: field_mul_group_cyclic FinRing.uval _ _ => // u _.
by split=> /eqP ?; exact/eqP.
Qed.
Section PrimitiveRoots.
Open Scope ring_scope.
Import GRing.Theory.
Lemma has_prim_root (F : fieldType) (n : nat) (rs : seq F) :
n > 0 -> all n.-unity_root rs -> uniq rs -> size rs >= n ->
has n.-primitive_root rs.
Proof.
move=> n_gt0 rsn1 Urs; rewrite leq_eqVlt ltnNge max_unity_roots // orbF eq_sym.
move/eqP=> sz_rs; pose r := val (_ : seq_sub rs).
have rn1 x: r x ^+ n = 1.
by apply/eqP; rewrite -unity_rootE (allP rsn1) ?(valP x).
have prim_r z: z ^+ n = 1 -> z \in rs.
by move/eqP; rewrite -unity_rootE -(mem_unity_roots n_gt0).
pose r' := SeqSub (prim_r _ _); pose sG_1 := r' _ (expr1n _ _).
have sG_VP: r _ ^+ n.-1 ^+ n = 1.
by move=> x; rewrite -exprM mulnC exprM rn1 expr1n.
have sG_MP: (r _ * r _) ^+ n = 1 by move=> x y; rewrite exprMn !rn1 mul1r.
pose sG_V := r' _ (sG_VP _); pose sG_M := r' _ (sG_MP _ _).
have sG_Ag: associative sG_M by move=> x y z; apply: val_inj; rewrite /= mulrA.
have sG_1g: left_id sG_1 sG_M by move=> x; apply: val_inj; rewrite /= mul1r.
have sG_Vg: left_inverse sG_1 sG_V sG_M.
by move=> x; apply: val_inj; rewrite /= -exprSr prednK ?rn1.
pose sgT := BaseFinGroupType _ (FinGroup.Mixin sG_Ag sG_1g sG_Vg).
pose gT := @FinGroupType sgT sG_Vg.
have /cyclicP[x gen_x]: @cyclic gT setT.
apply: (@field_mul_group_cyclic gT [set: _] F r) => // x _.
by split=> [ri1 | ->]; first exact: val_inj.
apply/hasP; exists (r x); first exact: (valP x).
have [m prim_x dvdmn] := prim_order_exists n_gt0 (rn1 x).
rewrite -((m =P n) _) // eqn_dvd {}dvdmn -sz_rs -(card_seq_sub Urs) -cardsT.
rewrite gen_x (@order_dvdn gT) /(_ == _) /= -{prim_x}(prim_expr_order prim_x).
by apply/eqP; elim: m => //= m IHm; rewrite exprS expgS /= -IHm.
Qed.
End PrimitiveRoots.
(***********************************************************************)
(* Cycles of prime order *)
(***********************************************************************)
Section AutPrime.
Variable gT : finGroupType.
Lemma Aut_prime_cycle_cyclic (a : gT) : prime #[a] -> cyclic (Aut <[a]>).
Proof.
move=> pr_a; have inj_um := injm_Zp_unitm a; have eq_a := Fp_Zcast pr_a.
pose fm := cast_ord (esym eq_a) \o val \o invm inj_um.
apply: (@field_mul_group_cyclic _ _ _ fm) => [f g Af Ag | f Af] /=.
by apply: val_inj; rewrite /= morphM ?im_Zp_unitm //= eq_a.
split=> [/= fm1 |->]; last by apply: val_inj; rewrite /= morph1.
apply: (injm1 (injm_invm inj_um)); first by rewrite /= im_Zp_unitm.
by do 2!apply: val_inj; move/(congr1 val): fm1.
Qed.
Lemma Aut_prime_cyclic (G : {group gT}) : prime #|G| -> cyclic (Aut G).
Proof.
move=> pr_G; case/cyclicP: (prime_cyclic pr_G) (pr_G) => x ->.
exact: Aut_prime_cycle_cyclic.
Qed.
End AutPrime.
mathcomp-1.5/theories/finmodule.v 0000644 0001750 0001750 00000065000 12307636117 016155 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice.
Require Import fintype bigop ssralg finset fingroup morphism perm.
Require Import finalg action gproduct commutator cyclic.
(******************************************************************************)
(* This file regroups constructions and results that are based on the most *)
(* primitive version of representation theory -- viewing an abelian group as *)
(* the additive group of a (finite) Z-module. This includes the Gaschutz *)
(* splitting and transitivity theorem, from which we will later derive the *)
(* Schur-Zassenhaus theorem and the elementary abelian special case of *)
(* Maschke's theorem, the coprime abelian centraliser/commutator trivial *)
(* intersection theorem, from which we will derive that p-groups under coprime*)
(* action factor into special groups, and the construction of the transfer *)
(* homomorphism and its expansion relative to a cycle, from which we derive *)
(* the Higman Focal Subgroup and the Burnside Normal Complement theorems. *)
(* The definitions and lemmas for the finite Z-module induced by an abelian *)
(* are packaged in an auxiliary FiniteModule submodule: they should not be *)
(* needed much outside this file, which contains all the results that exploit *)
(* this construction. *)
(* FiniteModule defines the Z[N(A)]-module associated with a finite abelian *)
(* abelian group A, given a proof abelA : abelian A) : *)
(* fmod_of abelA == the type of elements of the module (similar to but *)
(* distinct from [subg A]). *)
(* fmod abelA x == the injection of x into fmod_of abelA if x \in A, else 0 *)
(* fmval u == the projection of u : fmod_of abelA onto A *)
(* u ^@ x == the action of x \in 'N(A) on u : fmod_of abelA *)
(* The transfer morphism is be constructed from a morphism f : H >-> rT, and *)
(* a group G, along with the two assumptions sHG : H \subset G and *)
(* abfH : abelian (f @* H): *)
(* transfer sGH abfH == the function gT -> FiniteModule.fmod_of abfH that *)
(* implements the transfer morphism induced by f on G. *)
(* The Lemma transfer_indep states that the transfer morphism can be expanded *)
(* using any transversal of the partition HG := rcosets H G of G. *)
(* Further, for any g \in G, HG :* <[g]> is also a partition of G (Lemma *)
(* rcosets_cycle_partition), and for any transversal X of HG :* <[g]> the *)
(* function r mapping x : gT to rcosets (H :* x) <[g]> is (constructively) a *)
(* bijection from X to the <[g]>-orbit partition of HG, and Lemma *)
(* transfer_pcycle_def gives a simplified expansion of the transfer morphism. *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GroupScope GRing.Theory FinRing.Theory.
Local Open Scope ring_scope.
Module FiniteModule.
Reserved Notation "u ^@ x" (at level 31, left associativity).
Inductive fmod_of (gT : finGroupType) (A : {group gT}) (abelA : abelian A) :=
Fmod x & x \in A.
Bind Scope ring_scope with fmod_of.
Section OneFinMod.
Let f2sub (gT : finGroupType) (A : {group gT}) (abA : abelian A) :=
fun u : fmod_of abA => let : Fmod x Ax := u in Subg Ax : FinGroup.arg_sort _.
Local Coercion f2sub : fmod_of >-> FinGroup.arg_sort.
Variables (gT : finGroupType) (A : {group gT}) (abelA : abelian A).
Local Notation fmodA := (fmod_of abelA).
Implicit Types (x y z : gT) (u v w : fmodA).
Let sub2f (s : [subg A]) := Fmod abelA (valP s).
Definition fmval u := val (f2sub u).
Canonical fmod_subType := [subType for fmval].
Local Notation valA := (@val _ _ fmod_subType) (only parsing).
Definition fmod_eqMixin := Eval hnf in [eqMixin of fmodA by <:].
Canonical fmod_eqType := Eval hnf in EqType fmodA fmod_eqMixin.
Definition fmod_choiceMixin := [choiceMixin of fmodA by <:].
Canonical fmod_choiceType := Eval hnf in ChoiceType fmodA fmod_choiceMixin.
Definition fmod_countMixin := [countMixin of fmodA by <:].
Canonical fmod_countType := Eval hnf in CountType fmodA fmod_countMixin.
Canonical fmod_subCountType := Eval hnf in [subCountType of fmodA].
Definition fmod_finMixin := [finMixin of fmodA by <:].
Canonical fmod_finType := Eval hnf in FinType fmodA fmod_finMixin.
Canonical fmod_subFinType := Eval hnf in [subFinType of fmodA].
Definition fmod x := sub2f (subg A x).
Definition actr u x := if x \in 'N(A) then fmod (fmval u ^ x) else u.
Definition fmod_opp u := sub2f u^-1.
Definition fmod_add u v := sub2f (u * v).
Fact fmod_add0r : left_id (sub2f 1) fmod_add.
Proof. move=> u; apply: val_inj; exact: mul1g. Qed.
Fact fmod_addrA : associative fmod_add.
Proof. move=> u v w; apply: val_inj; exact: mulgA. Qed.
Fact fmod_addNr : left_inverse (sub2f 1) fmod_opp fmod_add.
Proof. move=> u; apply: val_inj; exact: mulVg. Qed.
Fact fmod_addrC : commutative fmod_add.
Proof. case=> x Ax [y Ay]; apply: val_inj; exact: (centsP abelA). Qed.
Definition fmod_zmodMixin :=
ZmodMixin fmod_addrA fmod_addrC fmod_add0r fmod_addNr.
Canonical fmod_zmodType := Eval hnf in ZmodType fmodA fmod_zmodMixin.
Canonical fmod_finZmodType := Eval hnf in [finZmodType of fmodA].
Canonical fmod_baseFinGroupType :=
Eval hnf in [baseFinGroupType of fmodA for +%R].
Canonical fmod_finGroupType :=
Eval hnf in [finGroupType of fmodA for +%R].
Lemma fmodP u : val u \in A. Proof. exact: valP. Qed.
Lemma fmod_inj : injective fmval. Proof. exact: val_inj. Qed.
Lemma congr_fmod u v : u = v -> fmval u = fmval v.
Proof. exact: congr1. Qed.
Lemma fmvalA : {morph valA : x y / x + y >-> (x * y)%g}. Proof. by []. Qed.
Lemma fmvalN : {morph valA : x / - x >-> x^-1%g}. Proof. by []. Qed.
Lemma fmval0 : valA 0 = 1%g. Proof. by []. Qed.
Canonical fmval_morphism := @Morphism _ _ setT fmval (in2W fmvalA).
Definition fmval_sum := big_morph fmval fmvalA fmval0.
Lemma fmvalZ n : {morph valA : x / x *+ n >-> (x ^+ n)%g}.
Proof. by move=> u; rewrite /= morphX ?inE. Qed.
Lemma fmodKcond x : val (fmod x) = if x \in A then x else 1%g.
Proof. by rewrite /= /fmval /= val_insubd. Qed.
Lemma fmodK : {in A, cancel fmod val}. Proof. exact: subgK. Qed.
Lemma fmvalK : cancel val fmod.
Proof. by case=> x Ax; apply: val_inj; rewrite /fmod /= sgvalK. Qed.
Lemma fmod1 : fmod 1 = 0. Proof. by rewrite -fmval0 fmvalK. Qed.
Lemma fmodM : {in A &, {morph fmod : x y / (x * y)%g >-> x + y}}.
Proof. by move=> x y Ax Ay /=; apply: val_inj; rewrite /fmod morphM. Qed.
Canonical fmod_morphism := Morphism fmodM.
Lemma fmodX n : {in A, {morph fmod : x / (x ^+ n)%g >-> x *+ n}}.
Proof. exact: morphX. Qed.
Lemma fmodV : {morph fmod : x / x^-1%g >-> - x}.
Proof.
move=> x; apply: val_inj; rewrite fmvalN !fmodKcond groupV.
by case: (x \in A); rewrite ?invg1.
Qed.
Lemma injm_fmod : 'injm fmod.
Proof.
apply/injmP=> x y Ax Ay []; move/val_inj; exact: (injmP (injm_subg A)).
Qed.
Notation "u ^@ x" := (actr u x) : ring_scope.
Lemma fmvalJcond u x :
val (u ^@ x) = if x \in 'N(A) then val u ^ x else val u.
Proof. by case: ifP => Nx; rewrite /actr Nx ?fmodK // memJ_norm ?fmodP. Qed.
Lemma fmvalJ u x : x \in 'N(A) -> val (u ^@ x) = val u ^ x.
Proof. by move=> Nx; rewrite fmvalJcond Nx. Qed.
Lemma fmodJ x y : y \in 'N(A) -> fmod (x ^ y) = fmod x ^@ y.
Proof.
move=> Ny; apply: val_inj; rewrite fmvalJ ?fmodKcond ?memJ_norm //.
by case: ifP => // _; rewrite conj1g.
Qed.
Fact actr_is_action : is_action 'N(A) actr.
Proof.
split=> [a u v eq_uv_a | u a b Na Nb].
case Na: (a \in 'N(A)); last by rewrite /actr Na in eq_uv_a.
by apply: val_inj; apply: (conjg_inj a); rewrite -!fmvalJ ?eq_uv_a.
by apply: val_inj; rewrite !fmvalJ ?groupM ?conjgM.
Qed.
Canonical actr_action := Action actr_is_action.
Notation "''M'" := actr_action (at level 8) : action_scope.
Lemma act0r x : 0 ^@ x = 0.
Proof. by rewrite /actr conj1g morph1 if_same. Qed.
Lemma actAr x : {morph actr^~ x : u v / u + v}.
Proof.
by move=> u v; apply: val_inj; rewrite !(fmvalA, fmvalJcond) conjMg; case: ifP.
Qed.
Definition actr_sum x := big_morph _ (actAr x) (act0r x).
Lemma actNr x : {morph actr^~ x : u / - u}.
Proof. by move=> u; apply: (addrI (u ^@ x)); rewrite -actAr !subrr act0r. Qed.
Lemma actZr x n : {morph actr^~ x : u / u *+ n}.
Proof.
by move=> u; elim: n => [|n IHn]; rewrite ?act0r // !mulrS actAr IHn.
Qed.
Fact actr_is_groupAction : is_groupAction setT 'M.
Proof.
move=> a Na /=; rewrite inE; apply/andP; split.
by apply/subsetP=> u _; rewrite inE.
by apply/morphicP=> u v _ _; rewrite !permE /= actAr.
Qed.
Canonical actr_groupAction := GroupAction actr_is_groupAction.
Notation "''M'" := actr_groupAction (at level 8) : groupAction_scope.
Lemma actr1 u : u ^@ 1 = u.
Proof. exact: act1. Qed.
Lemma actrM : {in 'N(A) &, forall x y u, u ^@ (x * y) = u ^@ x ^@ y}.
Proof.
by move=> x y Nx Ny /= u; apply: val_inj; rewrite !fmvalJ ?conjgM ?groupM.
Qed.
Lemma actrK x : cancel (actr^~ x) (actr^~ x^-1%g).
Proof.
move=> u; apply: val_inj; rewrite !fmvalJcond groupV.
by case: ifP => -> //; rewrite conjgK.
Qed.
Lemma actrKV x : cancel (actr^~ x^-1%g) (actr^~ x).
Proof. by move=> u; rewrite /= -{2}(invgK x) actrK. Qed.
End OneFinMod.
Bind Scope ring_scope with fmod_of.
Prenex Implicits fmval fmod actr.
Notation "u ^@ x" := (actr u x) : ring_scope.
Notation "''M'" := actr_action (at level 8) : action_scope.
Notation "''M'" := actr_groupAction : groupAction_scope.
End FiniteModule.
Canonical FiniteModule.fmod_subType.
Canonical FiniteModule.fmod_eqType.
Canonical FiniteModule.fmod_choiceType.
Canonical FiniteModule.fmod_countType.
Canonical FiniteModule.fmod_finType.
Canonical FiniteModule.fmod_subCountType.
Canonical FiniteModule.fmod_subFinType.
Canonical FiniteModule.fmod_zmodType.
Canonical FiniteModule.fmod_finZmodType.
Canonical FiniteModule.fmod_baseFinGroupType.
Canonical FiniteModule.fmod_finGroupType.
(* Still allow ring notations, but give priority to groups now. *)
Import FiniteModule GroupScope.
Section Gaschutz.
Variables (gT : finGroupType) (G H P : {group gT}).
Implicit Types K L : {group gT}.
Hypotheses (nsHG : H <| G) (sHP : H \subset P) (sPG : P \subset G).
Hypotheses (abelH : abelian H) (coHiPG : coprime #|H| #|G : P|).
Let sHG := normal_sub nsHG.
Let nHG := subsetP (normal_norm nsHG).
Let m := (expg_invn H #|G : P|).
Implicit Types a b : fmod_of abelH.
Local Notation fmod := (fmod abelH).
Theorem Gaschutz_split : [splits G, over H] = [splits P, over H].
Proof.
apply/splitsP/splitsP=> [[K /complP[tiHK eqHK]] | [Q /complP[tiHQ eqHQ]]].
exists (K :&: P)%G; rewrite inE setICA (setIidPl sHP) setIC tiHK eqxx.
by rewrite group_modl // eqHK (sameP eqP setIidPr).
have sQP: Q \subset P by rewrite -eqHQ mulG_subr.
pose rP x := repr (P :* x); pose pP x := x * (rP x)^-1.
have PpP x: pP x \in P by rewrite -mem_rcoset rcoset_repr rcoset_refl.
have rPmul x y: x \in P -> rP (x * y) = rP y.
by move=> Px; rewrite /rP rcosetM rcoset_id.
pose pQ x := remgr H Q x; pose rH x := pQ (pP x) * rP x.
have pQhq: {in H & Q, forall h q, pQ (h * q) = q} by exact: remgrMid.
have pQmul: {in P &, {morph pQ : x y / x * y}}.
apply: remgrM; [exact/complP | exact: normalS (nsHG)].
have HrH x: rH x \in H :* x.
by rewrite rcoset_sym mem_rcoset invMg mulgA mem_divgr // eqHQ PpP.
have GrH x: x \in G -> rH x \in G.
move=> Gx; case/rcosetP: (HrH x) => y Hy ->.
by rewrite groupM // (subsetP sHG).
have rH_Pmul x y: x \in P -> rH (x * y) = pQ x * rH y.
by move=> Px; rewrite /rH mulgA -pQmul; first by rewrite /pP rPmul ?mulgA.
have rH_Hmul h y: h \in H -> rH (h * y) = rH y.
by move=> Hh; rewrite rH_Pmul ?(subsetP sHP) // -(mulg1 h) pQhq ?mul1g.
pose mu x y := fmod ((rH x * rH y)^-1 * rH (x * y)).
pose nu y := (\sum_(Px in rcosets P G) mu (repr Px) y)%R.
have rHmul: {in G &, forall x y, rH (x * y) = rH x * rH y * val (mu x y)}.
move=> x y Gx Gy; rewrite /= fmodK ?mulKVg // -mem_lcoset lcoset_sym.
rewrite -norm_rlcoset; last by rewrite nHG ?GrH ?groupM.
by rewrite (rcoset_transl (HrH _)) -rcoset_mul ?nHG ?GrH // mem_mulg.
have actrH a x: x \in G -> (a ^@ rH x = a ^@ x)%R.
move=> Gx; apply: val_inj; rewrite /= !fmvalJ ?nHG ?GrH //.
case/rcosetP: (HrH x) => b /(fmodK abelH) <- ->; rewrite conjgM.
by congr (_ ^ _); rewrite conjgE -fmvalN -!fmvalA (addrC a) addKr.
have mu_Pmul x y z: x \in P -> mu (x * y) z = mu y z.
move=> Px; congr fmod; rewrite -mulgA !(rH_Pmul x) ?rPmul //.
by rewrite -mulgA invMg -mulgA mulKg.
have mu_Hmul x y z: x \in G -> y \in H -> mu x (y * z) = mu x z.
move=> Gx Hy; congr fmod; rewrite (mulgA x) (conjgCV x) -mulgA 2?rH_Hmul //.
by rewrite -mem_conjg (normP _) ?nHG.
have{mu_Hmul} nu_Hmul y z: y \in H -> nu (y * z) = nu z.
move=> Hy; apply: eq_bigr => _ /rcosetsP[x Gx ->]; apply: mu_Hmul y z _ Hy.
by rewrite -(groupMl _ (subsetP sPG _ (PpP x))) mulgKV.
have cocycle_mu: {in G & &, forall x y z,
mu (x * y)%g z + mu x y ^@ z = mu y z + mu x (y * z)%g}%R.
- move=> x y z Gx Gy Gz; apply: val_inj.
apply: (mulgI (rH x * rH y * rH z)).
rewrite -(actrH _ _ Gz) addrC fmvalA fmvalJ ?nHG ?GrH //.
rewrite mulgA -(mulgA _ (rH z)) -conjgC mulgA -!rHmul ?groupM //.
by rewrite mulgA -mulgA -2!(mulgA (rH x)) -!rHmul ?groupM.
move: mu => mu in rHmul mu_Pmul cocycle_mu nu nu_Hmul.
have{cocycle_mu} cocycle_nu: {in G &, forall y z,
nu z + nu y ^@ z = mu y z *+ #|G : P| + nu (y * z)%g}%R.
- move=> y z Gy Gz; rewrite /= (actr_sum z) /=.
have ->: (nu z = \sum_(Px in rcosets P G) mu (repr Px * y)%g z)%R.
rewrite /nu (reindex_acts _ (actsRs_rcosets P G) Gy) /=.
apply: eq_bigr => _ /rcosetsP[x Gx /= ->].
rewrite rcosetE -rcosetM.
case: repr_rcosetP=> p1 Pp1; case: repr_rcosetP=> p2 Pp2.
by rewrite -mulgA [x * y]lock !mu_Pmul.
rewrite -sumr_const -!big_split /=; apply: eq_bigr => _ /rcosetsP[x Gx ->].
rewrite -cocycle_mu //; case: repr_rcosetP => p1 Pp1.
by rewrite groupMr // (subsetP sPG).
move: nu => nu in nu_Hmul cocycle_nu.
pose f x := rH x * val (nu x *+ m)%R.
have{cocycle_nu} fM: {in G &, {morph f : x y / x * y}}.
move=> x y Gx Gy; rewrite /f ?rHmul // -3!mulgA; congr (_ * _).
rewrite (mulgA _ (rH y)) (conjgC _ (rH y)) -mulgA; congr (_ * _).
rewrite -fmvalJ ?actrH ?nHG ?GrH // -!fmvalA actZr -mulrnDl.
rewrite -(addrC (nu y)) cocycle_nu // mulrnDl !fmvalA; congr (_ * _).
by rewrite !fmvalZ expgK ?fmodP.
exists (Morphism fM @* G)%G; apply/complP; split.
apply/trivgP/subsetP=> x /setIP[Hx /morphimP[y _ Gy eq_x]].
apply/set1P; move: Hx; rewrite {x}eq_x /= groupMr ?subgP //.
rewrite -{1}(mulgKV y (rH y)) groupMl -?mem_rcoset // => Hy.
by rewrite -(mulg1 y) /f nu_Hmul // rH_Hmul //; exact: (morph1 (Morphism fM)).
apply/setP=> x; apply/mulsgP/idP=> [[h y Hh fy ->{x}] | Gx].
rewrite groupMl; last exact: (subsetP sHG).
case/morphimP: fy => z _ Gz ->{h Hh y}.
by rewrite /= /f groupMl ?GrH // (subsetP sHG) ?fmodP.
exists (x * (f x)^-1) (f x); last first; first by rewrite mulgKV.
by apply/morphimP; exists x.
rewrite -groupV invMg invgK -mulgA (conjgC (val _)) mulgA.
by rewrite groupMl -(mem_rcoset, mem_conjg) // (normP _) ?nHG ?fmodP.
Qed.
Theorem Gaschutz_transitive : {in [complements to H in G] &,
forall K L, K :&: P = L :&: P -> exists2 x, x \in H & L :=: K :^ x}.
Proof.
move=> K L /=; set Q := K :&: P => /complP[tiHK eqHK] cpHL QeqLP.
have [trHL eqHL] := complP cpHL.
pose nu x := fmod (divgr H L x^-1).
have sKG: {subset K <= G} by apply/subsetP; rewrite -eqHK mulG_subr.
have sLG: {subset L <= G} by apply/subsetP; rewrite -eqHL mulG_subr.
have val_nu x: x \in G -> val (nu x) = divgr H L x^-1.
by move=> Gx; rewrite fmodK // mem_divgr // eqHL groupV.
have nu_cocycle: {in G &, forall x y, nu (x * y)%g = nu x ^@ y + nu y}%R.
move=> x y Gx Gy; apply: val_inj; rewrite fmvalA fmvalJ ?nHG //.
rewrite !val_nu ?groupM // /divgr conjgE !mulgA mulgK.
by rewrite !(invMg, remgrM cpHL) ?groupV ?mulgA.
have nuL x: x \in L -> nu x = 0%R.
move=> Lx; apply: val_inj; rewrite val_nu ?sLG //.
by rewrite /divgr remgr_id ?groupV ?mulgV.
exists (fmval ((\sum_(X in rcosets Q K) nu (repr X)) *+ m)).
exact: fmodP.
apply/eqP; rewrite eq_sym eqEcard; apply/andP; split; last first.
by rewrite cardJg -(leq_pmul2l (cardG_gt0 H)) -!TI_cardMg // eqHL eqHK.
apply/subsetP=> _ /imsetP[x Kx ->]; rewrite conjgE mulgA (conjgC _ x).
have Gx: x \in G by rewrite sKG.
rewrite conjVg -mulgA -fmvalJ ?nHG // -fmvalN -fmvalA (_ : _ + _ = nu x)%R.
by rewrite val_nu // mulKVg groupV mem_remgr // eqHL groupV.
rewrite actZr -!mulNrn -mulrnDl actr_sum.
rewrite addrC (reindex_acts _ (actsRs_rcosets _ K) Kx) -sumrB /= -/Q.
rewrite (eq_bigr (fun _ => nu x)) => [|_ /imsetP[y Ky ->]]; last first.
rewrite !rcosetE -rcosetM QeqLP.
case: repr_rcosetP => z /setIP[Lz _]; case: repr_rcosetP => t /setIP[Lt _].
rewrite !nu_cocycle ?groupM ?(sKG y) // ?sLG //.
by rewrite (nuL z) ?(nuL t) // !act0r !add0r addrC addKr.
apply: val_inj; rewrite sumr_const !fmvalZ.
rewrite -{2}(expgK coHiPG (fmodP (nu x))); congr (_ ^+ _ ^+ _).
rewrite -[#|_|]divgS ?subsetIl // -(divnMl (cardG_gt0 H)).
rewrite -!TI_cardMg //; last by rewrite setIA setIAC (setIidPl sHP).
by rewrite group_modl // eqHK (setIidPr sPG) divgS.
Qed.
End Gaschutz.
(* This is the TI part of B & G, Proposition 1.6(d). *)
(* We go with B & G rather than Aschbacher and will derive 1.6(e) from (d), *)
(* rather than the converse, because the derivation of 24.6 from 24.3 in *)
(* Aschbacher requires a separate reduction to p-groups to yield 1.6(d), *)
(* making it altogether longer than the direct Gaschutz-style proof. *)
(* This Lemma is used in maximal.v for the proof of Aschbacher 24.7. *)
Lemma coprime_abel_cent_TI (gT : finGroupType) (A G : {group gT}) :
A \subset 'N(G) -> coprime #|G| #|A| -> abelian G -> 'C_[~: G, A](A) = 1.
Proof.
move=> nGA coGA abG; pose f x := val (\sum_(a in A) fmod abG x ^@ a)%R.
have fM: {in G &, {morph f : x y / x * y}}.
move=> x y Gx Gy /=; rewrite -fmvalA -big_split /=; congr (fmval _).
by apply: eq_bigr => a Aa; rewrite fmodM // actAr.
have nfA x a: a \in A -> f (x ^ a) = f x.
move=> Aa; rewrite {2}/f (reindex_inj (mulgI a)) /=; congr (fmval _).
apply: eq_big => [b | b Ab]; first by rewrite groupMl.
by rewrite -!fmodJ ?groupM ?(subsetP nGA) // conjgM.
have kerR: [~: G, A] \subset 'ker (Morphism fM).
rewrite gen_subG; apply/subsetP=> xa; case/imset2P=> x a Gx Aa -> {xa}.
have Gxa: x ^ a \in G by rewrite memJ_norm ?(subsetP nGA).
rewrite commgEl; apply/kerP; rewrite (groupM, morphM) ?(groupV, morphV) //=.
by rewrite nfA ?mulVg.
apply/trivgP; apply/subsetP=> x /setIP[Rx cAx]; apply/set1P.
have Gx: x \in G by apply: subsetP Rx; rewrite commg_subl.
rewrite -(expgK coGA Gx) (_ : x ^+ _ = 1) ?expg1n //.
rewrite -(fmodK abG Gx) -fmvalZ -(mker (subsetP kerR x Rx)); congr fmval.
rewrite -GRing.sumr_const; apply: eq_bigr => a Aa.
by rewrite -fmodJ ?(subsetP nGA) // /conjg (centP cAx) // mulKg.
Qed.
Section Transfer.
Variables (gT aT : finGroupType) (G H : {group gT}).
Variable alpha : {morphism H >-> aT}.
Hypotheses (sHG : H \subset G) (abelA : abelian (alpha @* H)).
Local Notation HG := (rcosets (gval H) (gval G)).
Fact transfer_morph_subproof : H \subset alpha @*^-1 (alpha @* H).
Proof. by rewrite -sub_morphim_pre. Qed.
Let fmalpha := restrm transfer_morph_subproof (fmod abelA \o alpha).
Let V (rX : {set gT} -> gT) g :=
\sum_(Hx in rcosets H G) fmalpha (rX Hx * g * (rX (Hx :* g))^-1).
Definition transfer g := V repr g.
(* This is Aschbacher (37.2). *)
Lemma transferM : {in G &, {morph transfer : x y / (x * y)%g >-> x + y}}.
Proof.
move=> s t Gs Gt /=.
rewrite [transfer t](reindex_acts 'Rs _ Gs) ?actsRs_rcosets //= -big_split /=.
apply: eq_bigr => _ /rcosetsP[x Gx ->]; rewrite !rcosetE -!rcosetM.
rewrite -zmodMgE -morphM -?mem_rcoset; first by rewrite !mulgA mulgKV rcosetM.
by rewrite rcoset_repr rcosetM mem_rcoset mulgK mem_repr_rcoset.
by rewrite rcoset_repr (rcosetM _ _ t) mem_rcoset mulgK mem_repr_rcoset.
Qed.
Canonical transfer_morphism := Morphism transferM.
(* This is Aschbacher (37.1). *)
Lemma transfer_indep X (rX := transversal_repr 1 X) :
is_transversal X HG G -> {in G, transfer =1 V rX}.
Proof.
move=> trX g Gg; have mem_rX := repr_mem_pblock trX 1; rewrite -/rX in mem_rX.
apply: (addrI (\sum_(Hx in HG) fmalpha (repr Hx * (rX Hx)^-1))).
rewrite {1}(reindex_acts 'Rs _ Gg) ?actsRs_rcosets // -!big_split /=.
apply: eq_bigr => _ /rcosetsP[x Gx ->]; rewrite !rcosetE -!rcosetM.
case: repr_rcosetP => h1 Hh1; case: repr_rcosetP => h2 Hh2.
have: H :* (x * g) \in rcosets H G by rewrite -rcosetE mem_imset ?groupM.
have: H :* x \in rcosets H G by rewrite -rcosetE mem_imset.
case/mem_rX/rcosetP=> h3 Hh3 -> /mem_rX/rcosetP[h4 Hh4 ->].
rewrite -!(mulgA h1) -!(mulgA h2) -!(mulgA h3) !(mulKVg, invMg).
by rewrite addrC -!zmodMgE -!morphM ?groupM ?groupV // -!mulgA !mulKg.
Qed.
Section FactorTransfer.
Variable g : gT.
Hypothesis Gg : g \in G.
Let sgG : <[g]> \subset G. Proof. by rewrite cycle_subG. Qed.
Let H_g_rcosets x : {set {set gT}} := rcosets (H :* x) <[g]>.
Let n_ x := #|<[g]> : H :* x|.
Lemma mulg_exp_card_rcosets x : x * (g ^+ n_ x) \in H :* x.
Proof.
rewrite /n_ /indexg -orbitRs -pcycle_actperm ?inE //.
rewrite -{2}(iter_pcycle (actperm 'Rs g) (H :* x)) -permX -morphX ?inE //.
by rewrite actpermE //= rcosetE -rcosetM rcoset_refl.
Qed.
Let HGg : {set {set {set gT}}} := orbit 'Rs <[g]> @: HG.
Let partHG : partition HG G := rcosets_partition sHG.
Let actsgHG : [acts <[g]>, on HG | 'Rs].
Proof. exact: subset_trans sgG (actsRs_rcosets H G). Qed.
Let partHGg : partition HGg HG := orbit_partition actsgHG.
Let injHGg : {in HGg &, injective cover}.
Proof. by have [] := partition_partition partHG partHGg. Qed.
Let defHGg : HG :* <[g]> = cover @: HGg.
Proof.
rewrite -imset_comp [_ :* _]imset2_set1r; apply: eq_imset => Hx /=.
by rewrite cover_imset -curry_imset2r.
Qed.
Lemma rcosets_cycle_partition : partition (HG :* <[g]>) G.
Proof. by rewrite defHGg; have [] := partition_partition partHG partHGg. Qed.
Variable X : {set gT}.
Hypothesis trX : is_transversal X (HG :* <[g]>) G.
Let sXG : {subset X <= G}. Proof. exact/subsetP/(transversal_sub trX). Qed.
Lemma rcosets_cycle_transversal : H_g_rcosets @: X = HGg.
Proof.
have sHXgHGg x: x \in X -> H_g_rcosets x \in HGg.
by move/sXG=> Gx; apply: mem_imset; rewrite -rcosetE mem_imset.
apply/setP=> Hxg; apply/imsetP/idP=> [[x /sHXgHGg HGgHxg -> //] | HGgHxg].
have [_ /rcosetsP[z Gz ->] ->] := imsetP HGgHxg.
pose Hzg := H :* z * <[g]>; pose x := transversal_repr 1 X Hzg.
have HGgHzg: Hzg \in HG :* <[g]>.
by rewrite mem_mulg ?set11 // -rcosetE mem_imset.
have Hzg_x: x \in Hzg by rewrite (repr_mem_pblock trX).
exists x; first by rewrite (repr_mem_transversal trX).
case/mulsgP: Hzg_x => y u /rcoset_transl <- /(orbit_act 'Rs) <- -> /=.
by rewrite rcosetE -rcosetM.
Qed.
Local Notation defHgX := rcosets_cycle_transversal.
Let injHg: {in X &, injective H_g_rcosets}.
Proof.
apply/imset_injP; rewrite defHgX (card_transversal trX) defHGg.
by rewrite (card_in_imset injHGg).
Qed.
Lemma sum_index_rcosets_cycle : (\sum_(x in X) n_ x)%N = #|G : H|.
Proof. by rewrite [#|G : H|](card_partition partHGg) -defHgX big_imset. Qed.
Lemma transfer_cycle_expansion :
transfer g = \sum_(x in X) fmalpha ((g ^+ n_ x) ^ x^-1).
Proof.
pose Y := \bigcup_(x in X) [set x * g ^+ i | i : 'I_(n_ x)].
pose rY := transversal_repr 1 Y.
pose pcyc x := pcycle (actperm 'Rs g) (H :* x).
pose traj x := traject (actperm 'Rs g) (H :* x) #|pcyc x|.
have Hgr_eq x: H_g_rcosets x = pcyc x.
by rewrite /H_g_rcosets -orbitRs -pcycle_actperm ?inE.
have pcyc_eq x: pcyc x =i traj x by exact: pcycle_traject.
have uniq_traj x: uniq (traj x) by apply: uniq_traject_pcycle.
have n_eq x: n_ x = #|pcyc x| by rewrite -Hgr_eq.
have size_traj x: size (traj x) = n_ x by rewrite n_eq size_traject.
have nth_traj x j: j < n_ x -> nth (H :* x) (traj x) j = H :* (x * g ^+ j).
move=> lt_j_x; rewrite nth_traject -?n_eq //.
by rewrite -permX -morphX ?inE // actpermE //= rcosetE rcosetM.
have sYG: Y \subset G.
apply/bigcupsP=> x Xx; apply/subsetP=> _ /imsetP[i _ ->].
by rewrite groupM ?groupX // sXG.
have trY: is_transversal Y HG G.
apply/and3P; split=> //; apply/forall_inP=> Hy.
have /and3P[/eqP <- _ _] := partHGg; rewrite -defHgX cover_imset.
case/bigcupP=> x Xx; rewrite Hgr_eq pcyc_eq => /trajectP[i].
rewrite -n_eq -permX -morphX ?in_setT // actpermE /= rcosetE -rcosetM => lti.
set y := x * _ => ->{Hy}; pose oi := Ordinal lti.
have Yy: y \in Y by apply/bigcupP; exists x => //; apply/imsetP; exists oi.
apply/cards1P; exists y; apply/esym/eqP.
rewrite eqEsubset sub1set inE Yy rcoset_refl.
apply/subsetP=> _ /setIP[/bigcupP[x' Xx' /imsetP[j _ ->]] Hy_x'gj].
have eq_xx': x = x'.
apply: (pblock_inj trX) => //; have /andP[/and3P[_ tiX _] _] := trX.
have HGgHyg: H :* y * <[g]> \in HG :* <[g]>.
by rewrite mem_mulg ?set11 // -rcosetE mem_imset ?(subsetP sYG).
rewrite !(def_pblock tiX HGgHyg) //.
by rewrite -[x'](mulgK (g ^+ j)) mem_mulg // groupV mem_cycle.
by rewrite -[x](mulgK (g ^+ i)) mem_mulg ?rcoset_refl // groupV mem_cycle.
apply/set1P; rewrite /y eq_xx'; congr (_ * _ ^+ _) => //; apply/eqP.
rewrite -(@nth_uniq _ (H :* x) (traj x)) ?size_traj // ?eq_xx' //.
by rewrite !nth_traj ?(rcoset_transl Hy_x'gj) // -eq_xx'.
have rYE x i : x \in X -> i < n_ x -> rY (H :* x :* g ^+ i) = x * g ^+ i.
move=> Xx lt_i_x; rewrite -rcosetM; apply: (canLR_in (pblockK trY 1)).
by apply/bigcupP; exists x => //; apply/imsetP; exists (Ordinal lt_i_x).
apply/esym/def_pblock; last exact: rcoset_refl; first by case/and3P: partHG.
by rewrite -rcosetE mem_imset ?groupM ?groupX // sXG.
rewrite (transfer_indep trY Gg) /V -/rY (set_partition_big _ partHGg) /=.
rewrite -defHgX big_imset /=; last first.
apply/imset_injP; rewrite defHgX (card_transversal trX) defHGg.
by rewrite (card_in_imset injHGg).
apply eq_bigr=> x Xx; rewrite Hgr_eq (eq_bigl _ _ (pcyc_eq x)) -big_uniq //=.
have n_gt0: 0 < n_ x by rewrite indexg_gt0.
rewrite /traj -n_eq; case def_n: (n_ x) (n_gt0) => // [n] _.
rewrite conjgE invgK -{1}[H :* x]rcoset1 -{1}(expg0 g).
elim: {1 3}n 0%N (addn0 n) => [|m IHm] i def_i /=.
rewrite big_seq1 {i}[i]def_i rYE // ?def_n //.
rewrite -(mulgA _ _ g) -rcosetM -expgSr -[(H :* x) :* _]rcosetE.
rewrite -actpermE morphX ?inE // permX // -{2}def_n n_eq iter_pcycle mulgA.
by rewrite -[H :* x]rcoset1 (rYE _ 0%N) ?mulg1.
rewrite big_cons rYE //; last by rewrite def_n -def_i ltnS leq_addl.
rewrite permE /= rcosetE -rcosetM -(mulgA _ _ g) -expgSr.
rewrite addSnnS in def_i; rewrite IHm //.
rewrite rYE //; last by rewrite def_n -def_i ltnS leq_addl.
by rewrite mulgV [fmalpha 1]morph1 add0r.
Qed.
End FactorTransfer.
End Transfer.
mathcomp-1.5/theories/gfunctor.v 0000644 0001750 0001750 00000046520 12307636117 016030 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop finset.
Require Import fingroup morphism automorphism quotient gproduct.
(******************************************************************************)
(* This file provides basic interfaces for the notion of "generic" *)
(* characteristic subgroups; these amount to subfunctors of the identity *)
(* functor in some category of groups. *)
(* See "Generic Proof Tools And Finite Group Theory", *)
(* Francois Garillot, PhD, 2011, Chapter 3. *)
(* The implementation proposed here is fairly basic, relying on first order *)
(* function matching and on structure telescopes, both of which are somewhat *)
(* limited and fragile. It should switch in the future to more general and *)
(* more robust quotation matching. *)
(* The definitions in this file (types, properties and structures) are all *)
(* packaged under the GFunctor submodule, i.e., client code should refer to *)
(* GFunctor.continuous, GFunctor.map, etc. Notations, Coercions and Lemmas *)
(* are exported and thus directly available, however. *)
(* We provide the following: *)
(* object_map == the type of the (polymorphic) object map of a group *)
(* functor; the %gF scope is bound to object_map. *)
(* := forall gT : finGroupType, {set gT} -> {set gT}. *)
(* We define two operations on object_map (with notations in the %gF scope): *)
(* F1 \o F2 == the composite map; (F1 \o F2) G expands to F1 (F2 G). *)
(* F1 %% F2 == F1 computed modulo F2; we have *)
(* (F1 %% F2) G / F2 G = F1 (G / F2 G) *)
(* We define the following (type-polymorphic) properties of an object_map F: *)
(* group_valued F <-> F G is a group when G is a group *)
(* closed F <-> F G is a subgroup o fG when G is a group *)
(* continuous F <-> F is continuous with respect to morphism image: *)
(* for any f : {morphism G >-> ..}, f @* (F G) is a *)
(* a subgroup of F (f @* G); equivalently, F is *)
(* functorial in the category Grp of groups. *)
(* Most common "characteristic subgroup" are produced *)
(* continuous object maps. *)
(* iso_continuous F <-> F is continuous with respect to isomorphism image; *)
(* equivalently, F is functorial in the Grp groupoid. *)
(* The Puig and the Thompson J subgroups are examples *)
(* of iso_continuous maps that are not continuous. *)
(* pcontinuous F <-> F is continuous with respect to partial morphism *)
(* image, i.e., functorial in the category of groups *)
(* and partial morphisms. The center and p-core are *)
(* examples of pcontinuous maps. *)
(* hereditary F <-> inclusion in the image of F is hereditary, i.e., *)
(* for any subgroup H of G, the intersection of H with *)
(* F G is included in H. Note that F is pcontinuous *)
(* iff it is continuous and hereditary; indeed proofs *)
(* of pcontinuous F coerce to proofs of hereditary F *)
(* and continuous F. *)
(* monotonic F <-> F is monotonic with respect to inclusion: for any *)
(* subgroup H of G, F H is a subgroup of F G. The *)
(* derived and lower central series are examples of *)
(* monotonic maps. *)
(* Four structures provide interfaces to these properties: *)
(* GFunctor.iso_map == structure for object maps that are group_valued, *)
(* closed, and iso_continuous. *)
(* [igFun by Fsub & !Fcont] == the iso_map structure for an object map F *)
(* such that F G is canonically a group when G is, and *)
(* given Fsub : closed F and Fcont : iso_continuous F. *)
(* [igFun by Fsub & Fcont] == as above, but expecting Fcont : continuous F. *)
(* [igFun of F] == clone an existing GFunctor.iso_map structure for F. *)
(* GFunctor.map == structure for continuous object maps, inheriting *)
(* from the GFunctor.iso_map structure. *)
(* [gFun by Fcont] == the map structure for an F with a canonical iso_map *)
(* structure, given Fcont : continuous F. *)
(* [gFun of F] == clone an existing GFunctor.map structure for F. *)
(* GFunctor.pmap == structure for pcontinuous object maps, inheriting *)
(* from the GFunctor.map structure. *)
(* [pgFun by Fher] == the pmap structure for an F with a canonical map *)
(* structure, given Fher : hereditary F. *)
(* [pgFun of F] == clone an existing GFunctor.pmap structure for F. *)
(* GFunctor.mono_map == structure for monotonic, continuous object maps *)
(* inheriting from the GFunctor.map structure. *)
(* [mgFun by Fmon] == the mono_map structure for an F with a canonical *)
(* map structure, given Fmon : monotonic F. *)
(* [mgFun of F] == clone an existing GFunctor.mono_map structure for F *)
(* Lemmas for these group functors use either a 'gF' prefix or an 'F' suffix. *)
(* The (F1 \o F2) and (F1 %% F2) operations have canonical GFunctor.map *)
(* structures when F1 is monotonic or hereditary, respectively. *)
(******************************************************************************)
Import GroupScope.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Delimit Scope gFun_scope with gF.
Module GFunctor.
Definition object_map := forall gT : finGroupType, {set gT} -> {set gT}.
Bind Scope gFun_scope with object_map.
Section Definitions.
Implicit Types gT hT : finGroupType.
Variable F : object_map.
(* Group closure. *)
Definition group_valued := forall gT (G : {group gT}), group_set (F G).
(* Subgroup closure. *)
Definition closed := forall gT (G : {group gT}), F G \subset G.
(* General functoriality, i.e., continuity of the object map *)
Definition continuous :=
forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
phi @* F G \subset F (phi @* G).
(* Functoriality on the Grp groupoid (arrows are restricted to isos). *)
Definition iso_continuous :=
forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
'injm phi -> phi @* F G \subset F (phi @* G).
Lemma continuous_is_iso_continuous : continuous -> iso_continuous.
Proof. by move=> Fcont gT hT G phi inj_phi; exact: Fcont. Qed.
(* Functoriality on Grp with partial morphisms. *)
Definition pcontinuous :=
forall gT hT (G D : {group gT}) (phi : {morphism D >-> hT}),
phi @* F G \subset F (phi @* G).
Lemma pcontinuous_is_continuous : pcontinuous -> continuous.
Proof. by move=> Fcont gT hT G; exact: Fcont. Qed.
(* Heredity with respect to inclusion *)
Definition hereditary :=
forall gT (H G : {group gT}), H \subset G -> F G :&: H \subset F H.
Lemma pcontinuous_is_hereditary : pcontinuous -> hereditary.
Proof.
move=> Fcont gT H G sHG; rewrite -{2}(setIidPl sHG) setIC.
by do 2!rewrite -(morphim_idm (subsetIl H _)) morphimIdom ?Fcont.
Qed.
(* Monotonicity with respect to inclusion *)
Definition monotonic :=
forall gT (H G : {group gT}), H \subset G -> F H \subset F G.
(* Self-expanding composition, and modulo *)
Variables (k : unit) (F1 F2 : object_map).
Definition comp_head : object_map := fun gT A => let: tt := k in F1 (F2 A).
Definition modulo : object_map :=
fun gT A => coset (F2 A) @*^-1 (F1 (A / (F2 A))).
End Definitions.
Section ClassDefinitions.
Structure iso_map := IsoMap {
apply : object_map;
_ : group_valued apply;
_ : closed apply;
_ : iso_continuous apply
}.
Local Coercion apply : iso_map >-> object_map.
Structure map := Map { iso_of_map : iso_map; _ : continuous iso_of_map }.
Local Coercion iso_of_map : map >-> iso_map.
Structure pmap := Pmap { map_of_pmap : map; _ : hereditary map_of_pmap }.
Local Coercion map_of_pmap : pmap >-> map.
Structure mono_map := MonoMap { map_of_mono : map; _ : monotonic map_of_mono }.
Local Coercion map_of_mono : mono_map >-> map.
Definition pack_iso F Fcont Fgrp Fsub := @IsoMap F Fgrp Fsub Fcont.
Definition clone_iso (F : object_map) :=
fun Fgrp Fsub Fcont (isoF := @IsoMap F Fgrp Fsub Fcont) =>
fun isoF0 & phant_id (apply isoF0) F & phant_id isoF isoF0 => isoF.
Definition clone (F : object_map) :=
fun isoF & phant_id (apply isoF) F =>
fun (funF0 : map) & phant_id (apply funF0) F =>
fun Fcont (funF := @Map isoF Fcont) & phant_id funF0 funF => funF.
Definition clone_pmap (F : object_map) :=
fun (funF : map) & phant_id (apply funF) F =>
fun (pfunF0 : pmap) & phant_id (apply pfunF0) F =>
fun Fher (pfunF := @Pmap funF Fher) & phant_id pfunF0 pfunF => pfunF.
Definition clone_mono (F : object_map) :=
fun (funF : map) & phant_id (apply funF) F =>
fun (mfunF0 : mono_map) & phant_id (apply mfunF0) F =>
fun Fmon (mfunF := @MonoMap funF Fmon) & phant_id mfunF0 mfunF => mfunF.
End ClassDefinitions.
Module Exports.
Identity Coercion fun_of_object_map : object_map >-> Funclass.
Coercion apply : iso_map >-> object_map.
Coercion iso_of_map : map >-> iso_map.
Coercion map_of_pmap : pmap >-> map.
Coercion map_of_mono : mono_map >-> map.
Coercion continuous_is_iso_continuous : continuous >-> iso_continuous.
Coercion pcontinuous_is_continuous : pcontinuous >-> continuous.
Coercion pcontinuous_is_hereditary : pcontinuous >-> hereditary.
Notation "[ 'igFun' 'by' Fsub & Fcont ]" :=
(pack_iso (continuous_is_iso_continuous Fcont) (fun gT G => groupP _) Fsub)
(at level 0, format "[ 'igFun' 'by' Fsub & Fcont ]") : form_scope.
Notation "[ 'igFun' 'by' Fsub & ! Fcont ]" :=
(pack_iso Fcont (fun gT G => groupP _) Fsub)
(at level 0, format "[ 'igFun' 'by' Fsub & ! Fcont ]") : form_scope.
Notation "[ 'igFun' 'of' F ]" := (@clone_iso F _ _ _ _ id id)
(at level 0, format "[ 'igFun' 'of' F ]") : form_scope.
Notation "[ 'gFun' 'by' Fcont ]" := (Map Fcont)
(at level 0, format "[ 'gFun' 'by' Fcont ]") : form_scope.
Notation "[ 'gFun' 'of' F ]" := (@clone F _ id _ id _ id)
(at level 0, format "[ 'gFun' 'of' F ]") : form_scope.
Notation "[ 'pgFun' 'by' Fher ]" := (Pmap Fher)
(at level 0, format "[ 'pgFun' 'by' Fher ]") : form_scope.
Notation "[ 'pgFun' 'of' F ]" := (@clone_pmap F _ id _ id _ id)
(at level 0, format "[ 'pgFun' 'of' F ]") : form_scope.
Notation "[ 'mgFun' 'by' Fmon ]" := (MonoMap Fmon)
(at level 0, format "[ 'mgFun' 'by' Fmon ]") : form_scope.
Notation "[ 'mgFun' 'of' F ]" := (@clone_mono F _ id _ id _ id)
(at level 0, format "[ 'mgFun' 'of' F ]") : form_scope.
End Exports.
End GFunctor.
Export GFunctor.Exports.
Bind Scope gFun_scope with GFunctor.object_map.
Notation "F1 \o F2" := (GFunctor.comp_head tt F1 F2) : gFun_scope.
Notation "F1 %% F2" := (GFunctor.modulo F1 F2) : gFun_scope.
Section FunctorGroup.
Variables (F : GFunctor.iso_map) (gT : finGroupType) (G : {group gT}).
Lemma gFgroupset : group_set (F gT G). Proof. by case: F. Qed.
Canonical gFgroup := Group gFgroupset.
End FunctorGroup.
Canonical gFmod_group
(F1 : GFunctor.iso_map) (F2 : GFunctor.object_map)
(gT : finGroupType) (G : {group gT}) :=
[group of (F1 %% F2)%gF gT G].
Section IsoFunctorTheory.
Implicit Types gT rT : finGroupType.
Variable F : GFunctor.iso_map.
Lemma gFsub gT (G : {group gT}) : F gT G \subset G.
Proof. by case: F gT G. Qed.
Lemma gF1 gT : F gT 1 = 1. Proof. exact/trivgP/gFsub. Qed.
Lemma gFiso_cont : GFunctor.iso_continuous F.
Proof. by case F. Qed.
Lemma gFchar gT (G : {group gT}) : F gT G \char G.
Proof.
apply/andP; split => //; first by apply: gFsub.
apply/forall_inP=> f Af; rewrite -{2}(im_autm Af) -(autmE Af).
by rewrite -morphimEsub ?gFsub ?gFiso_cont ?injm_autm.
Qed.
Lemma gFnorm gT (G : {group gT}) : G \subset 'N(F gT G).
Proof. by rewrite char_norm ?gFchar. Qed.
Lemma gFnormal gT (G : {group gT}) : F gT G <| G.
Proof. by rewrite char_normal ?gFchar. Qed.
Lemma injmF_sub gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
'injm f -> G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> injf sGD; apply/eqP; rewrite -(setIidPr (gFsub G)).
by rewrite-{3}(setIid G) -!(morphim_restrm sGD) gFiso_cont // injm_restrm.
Qed.
Lemma injmF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
'injm f -> G \subset D -> f @* (F gT G) = F rT (f @* G).
Proof.
move=> injf sGD; apply/eqP; rewrite eqEsubset injmF_sub //=.
rewrite -{2}(morphim_invm injf sGD) -[f @* F _ _](morphpre_invm injf).
have Fsubs := subset_trans (gFsub _).
by rewrite -sub_morphim_pre (injmF_sub, Fsubs) ?morphimS ?injm_invm.
Qed.
Lemma gFisom gT rT (G D : {group gT}) R (f : {morphism D >-> rT}) :
G \subset D -> isom G (gval R) f -> isom (F gT G) (F rT R) f.
Proof.
case/(restrmP f)=> g [gf _ _ _]; rewrite -{f}gf.
by case/isomP=> injg <-; rewrite sub_isom ?gFsub ?injmF.
Qed.
Lemma gFisog gT rT (G : {group gT}) (R : {group rT}) :
G \isog R -> F gT G \isog F rT R.
Proof. by case/isogP=> f injf <-; rewrite -injmF // sub_isog ?gFsub. Qed.
End IsoFunctorTheory.
Section FunctorTheory.
Implicit Types gT rT : finGroupType.
Variable F : GFunctor.map.
Lemma gFcont : GFunctor.continuous F.
Proof. by case F. Qed.
Lemma morphimF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> sGD; rewrite -(setIidPr (gFsub F G)).
by rewrite -{3}(setIid G) -!(morphim_restrm sGD) gFcont.
Qed.
End FunctorTheory.
Section PartialFunctorTheory.
Implicit Types gT rT : finGroupType.
Section BasicTheory.
Variable F : GFunctor.pmap.
Lemma gFhereditary : GFunctor.hereditary F.
Proof. by case F. Qed.
Lemma gFunctorI gT (G H : {group gT}) :
F gT G :&: H = F gT G :&: F gT (G :&: H).
Proof.
rewrite -{1}(setIidPr (gFsub F G)) [G :&: _]setIC -setIA.
rewrite -(setIidPr (gFhereditary (subsetIl G H))).
by rewrite setIC -setIA (setIidPr (gFsub F (G :&: H))).
Qed.
Lemma pmorphimF : GFunctor.pcontinuous F.
Proof.
move=> gT rT G D f; rewrite -morphimIdom -(setIidPl (gFsub F G)) setICA.
apply: (subset_trans (morphimS f (gFhereditary (subsetIr D G)))).
by rewrite (subset_trans (morphimF F _ _ )) ?morphimIdom ?subsetIl.
Qed.
Lemma gFid gT (G : {group gT}) : F gT (F gT G) = F gT G.
Proof.
apply/eqP; rewrite eqEsubset gFsub.
by move/gFhereditary: (gFsub F G); rewrite setIid /=.
Qed.
End BasicTheory.
Section Modulo.
Variables (F1 : GFunctor.pmap) (F2 : GFunctor.map).
Lemma gFmod_closed : GFunctor.closed (F1 %% F2).
Proof. by move=> gT G; rewrite sub_cosetpre_quo ?gFsub ?gFnormal. Qed.
Lemma gFmod_cont : GFunctor.continuous (F1 %% F2).
Proof.
move=> gT rT G f; have nF2 := gFnorm F2.
have sDF: G \subset 'dom (coset (F2 _ G)) by rewrite nF2.
have sDFf: G \subset 'dom (coset (F2 _ (f @* G)) \o f).
by rewrite -sub_morphim_pre ?subsetIl // nF2.
pose K := 'ker (restrm sDFf (coset (F2 _ (f @* G)) \o f)).
have sFK: 'ker (restrm sDF (coset (F2 _ G))) \subset K.
rewrite {}/K !ker_restrm ker_comp /= subsetI subsetIl !ker_coset /=.
by rewrite -sub_morphim_pre ?subsetIl // morphimIdom ?morphimF.
have sOF := gFsub F1 (G / F2 _ G); have sGG: G \subset G by [].
rewrite -sub_quotient_pre; last first.
by apply: subset_trans (nF2 _ _); rewrite morphimS ?gFmod_closed.
suffices im_fact H : F2 _ G \subset gval H -> H \subset G ->
factm sFK sGG @* (H / F2 _ G) = f @* H / F2 _ (f @* G).
- rewrite -2?im_fact ?gFmod_closed ?gFsub //.
by rewrite cosetpreK morphimF /= ?morphim_restrm ?setIid.
by rewrite -sub_quotient_pre ?normG //= trivg_quotient sub1G.
move=> sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid.
rewrite -morphimIG ?ker_coset // -(morphim_restrm sDF) morphim_factm.
by rewrite morphim_restrm morphim_comp -quotientE morphimIdom.
Qed.
Canonical gFmod_igFun := [igFun by gFmod_closed & gFmod_cont].
Canonical gFmod_gFun := [gFun by gFmod_cont].
End Modulo.
Variables F1 F2 : GFunctor.pmap.
Lemma gFmod_hereditary : GFunctor.hereditary (F1 %% F2).
Proof.
move=> gT H G sHG; set FGH := _ :&: H; have nF2H := gFnorm F2 H.
rewrite -sub_quotient_pre; last exact: subset_trans (subsetIr _ _) _.
pose rH := restrm nF2H (coset (F2 _ H)); pose rHM := [morphism of rH].
have rnorm_simpl: rHM @* H = H / F2 _ H by rewrite morphim_restrm setIid.
have nF2G := subset_trans sHG (gFnorm F2 G).
pose rG := restrm nF2G (coset (F2 _ G)); pose rGM := [morphism of rG].
have sqKfK: 'ker rGM \subset 'ker rHM.
rewrite !ker_restrm !ker_coset (setIidPr (gFsub F2 _)) setIC /=.
exact: gFhereditary.
have sHH := subxx H; rewrite -rnorm_simpl /= -(morphim_factm sqKfK sHH) /=.
apply: subset_trans (gFcont F1 _); rewrite /= {2}morphim_restrm setIid /=.
apply: subset_trans (morphimS _ (gFhereditary _ (quotientS _ sHG))) => /=.
have ->: FGH / _ = restrm nF2H (coset _) @* FGH.
by rewrite morphim_restrm setICA setIid.
rewrite -(morphim_factm sqKfK sHH) morphimS //= morphim_restrm -quotientE.
by rewrite setICA setIid (subset_trans (quotientI _ _ _)) // cosetpreK.
Qed.
Canonical gFmod_pgFun := [pgFun by gFmod_hereditary].
End PartialFunctorTheory.
Section MonotonicFunctorTheory.
Implicit Types gT rT : finGroupType.
Lemma gFunctorS (F : GFunctor.mono_map) : GFunctor.monotonic F.
Proof. by case: F. Qed.
Section Composition.
Variables (F1 : GFunctor.mono_map) (F2 : GFunctor.map).
Lemma gFcomp_closed : GFunctor.closed (F1 \o F2).
Proof. by move=> gT G; rewrite (subset_trans (gFsub _ _)) ?gFsub. Qed.
Lemma gFcomp_cont : GFunctor.continuous (F1 \o F2).
Proof.
move=> gT rT G phi; rewrite (subset_trans (morphimF _ _ (gFsub _ _))) //.
by rewrite (subset_trans (gFunctorS F1 (gFcont F2 phi))).
Qed.
Canonical gFcomp_igFun := [igFun by gFcomp_closed & gFcomp_cont].
Canonical gFcomp_gFun :=[gFun by gFcomp_cont].
End Composition.
Variables F1 F2 : GFunctor.mono_map.
Lemma gFcompS : GFunctor.monotonic (F1 \o F2).
Proof. by move=> gT H G sHG; rewrite !gFunctorS. Qed.
Canonical gFcomp_mgFun := [mgFun by gFcompS].
End MonotonicFunctorTheory.
Section GFunctorExamples.
Implicit Types gT : finGroupType.
Definition idGfun gT := @id {set gT}.
Lemma idGfun_closed : GFunctor.closed idGfun. Proof. by []. Qed.
Lemma idGfun_cont : GFunctor.continuous idGfun. Proof. by []. Qed.
Lemma idGfun_monotonic : GFunctor.monotonic idGfun. Proof. by []. Qed.
Canonical bgFunc_id := [igFun by idGfun_closed & idGfun_cont].
Canonical gFunc_id := [gFun by idGfun_cont].
Canonical mgFunc_id := [mgFun by idGfun_monotonic].
Definition trivGfun gT of {set gT} := [1 gT].
Lemma trivGfun_cont : GFunctor.pcontinuous trivGfun.
Proof. by move=> gT rT D G f; rewrite morphim1. Qed.
Canonical trivGfun_igFun := [igFun by sub1G & trivGfun_cont].
Canonical trivGfun_gFun := [gFun by trivGfun_cont].
Canonical trivGfun_pgFun := [pgFun by trivGfun_cont].
End GFunctorExamples.
mathcomp-1.5/theories/presentation.v 0000644 0001750 0001750 00000026065 12307636117 016716 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype finset.
Require Import fingroup morphism.
(******************************************************************************)
(* Support for generator-and-relation presentations of groups. We provide the *)
(* syntax: *)
(* G \homg Grp (x_1 : ... x_n : (s_1 = t_1, ..., s_m = t_m)) *)
(* <=> G is generated by elements x_1, ..., x_m satisfying the relations *)
(* s_1 = t_1, ..., s_m = t_m, i.e., G is a homomorphic image of the *)
(* group generated by the x_i, subject to the relations s_j = t_j. *)
(* G \isog Grp (x_1 : ... x_n : (s_1 = t_1, ..., s_m = t_m)) *)
(* <=> G is isomorphic to the group generated by the x_i, subject to the *)
(* relations s_j = t_j. This is an intensional predicate (in Prop), as *)
(* even the non-triviality of a generated group is undecidable. *)
(* Syntax details: *)
(* - Grp is a litteral constant. *)
(* - There must be at least one generator and one relation. *)
(* - A relation s_j = 1 can be abbreviated as simply s_j (a.k.a. a relator). *)
(* - Two consecutive relations s_j = t, s_j+1 = t can be abbreviated *)
(* s_j = s_j+1 = t. *)
(* - The s_j and t_j are terms built from the x_i and the standard group *)
(* operators *, 1, ^-1, ^+, ^-, ^, [~ u_1, ..., u_k]; no other operator or *)
(* abbreviation may be used, as the notation is implemented using static *)
(* overloading. *)
(* - This is the closest we could get to the notation used in Aschbacher, *)
(* Grp (x_1, ... x_n : t_1,1 = ... = t_1,k1, ..., t_m,1 = ... = t_m,km) *)
(* under the current limitations of the Coq Notation facility. *)
(* Semantics details: *)
(* - G \isog Grp (...) : Prop expands to the statement *)
(* forall rT (H : {group rT}), (H \homg G) = (H \homg Grp (...)) *)
(* (with rT : finGroupType). *)
(* - G \homg Grp (x_1 : ... x_n : (s_1 = t_1, ..., s_m = t_m)) : bool, with *)
(* G : {set gT}, is convertible to the boolean expression *)
(* [exists t : gT * ... gT, let: (x_1, ..., x_n) := t in *)
(* (<[x_1]> <*> ... <*> <[x_n]>, (s_1, ... (s_m-1, s_m) ...)) *)
(* == (G, (t_1, ... (t_m-1, t_m) ...))] *)
(* where the tuple comparison above is convertible to the conjunction *)
(* [&& <[x_1]> <*> ... <*> <[x_n]> == G, s_1 == t_1, ... & s_m == t_m] *)
(* Thus G \homg Grp (...) can be easily exploited by destructing the tuple *)
(* created case/existsP, then destructing the tuple equality with case/eqP. *)
(* Conversely it can be proved by using apply/existsP, providing the tuple *)
(* with a single exists (u_1, ..., u_n), then using rewrite !xpair_eqE /= *)
(* to expose the conjunction, and optionally using an apply/and{m+1}P view *)
(* to split it into subgoals (in that case, the rewrite is in principle *)
(* redundant, but necessary in practice because of the poor performance of *)
(* conversion in the Coq unifier). *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GroupScope.
Module Presentation.
Section Presentation.
Implicit Types gT rT : finGroupType.
Implicit Type vT : finType. (* tuple value type *)
Inductive term :=
| Cst of nat
| Idx
| Inv of term
| Exp of term & nat
| Mul of term & term
| Conj of term & term
| Comm of term & term.
Fixpoint eval {gT} e t : gT :=
match t with
| Cst i => nth 1 e i
| Idx => 1
| Inv t1 => (eval e t1)^-1
| Exp t1 n => eval e t1 ^+ n
| Mul t1 t2 => eval e t1 * eval e t2
| Conj t1 t2 => eval e t1 ^ eval e t2
| Comm t1 t2 => [~ eval e t1, eval e t2]
end.
Inductive formula := Eq2 of term & term | And of formula & formula.
Definition Eq1 s := Eq2 s Idx.
Definition Eq3 s1 s2 t := And (Eq2 s1 t) (Eq2 s2 t).
Inductive rel_type := NoRel | Rel vT of vT & vT.
Definition bool_of_rel r := if r is Rel vT v1 v2 then v1 == v2 else true.
Local Coercion bool_of_rel : rel_type >-> bool.
Definition and_rel vT (v1 v2 : vT) r :=
if r is Rel wT w1 w2 then Rel (v1, w1) (v2, w2) else Rel v1 v2.
Fixpoint rel {gT} (e : seq gT) f r :=
match f with
| Eq2 s t => and_rel (eval e s) (eval e t) r
| And f1 f2 => rel e f1 (rel e f2 r)
end.
Inductive type := Generator of term -> type | Formula of formula.
Definition Cast p : type := p. (* syntactic scope cast *)
Local Coercion Formula : formula >-> type.
Inductive env gT := Env of {set gT} & seq gT.
Definition env1 {gT} (x : gT : finType) := Env <[x]> [:: x].
Fixpoint sat gT vT B n (s : vT -> env gT) p :=
match p with
| Formula f =>
[exists v, let: Env A e := s v in and_rel A B (rel (rev e) f NoRel)]
| Generator p' =>
let s' v := let: Env A e := s v.1 in Env (A <*> <[v.2]>) (v.2 :: e) in
sat B n.+1 s' (p' (Cst n))
end.
Definition hom gT (B : {set gT}) p := sat B 1 env1 (p (Cst 0)).
Definition iso gT (B : {set gT}) p :=
forall rT (H : {group rT}), (H \homg B) = hom H p.
End Presentation.
End Presentation.
Import Presentation.
Coercion bool_of_rel : rel_type >-> bool.
Coercion Eq1 : term >-> formula.
Coercion Formula : formula >-> type.
(* Declare (implicitly) the argument scope tags. *)
Notation "1" := Idx : group_presentation.
Arguments Scope Inv [group_presentation].
Arguments Scope Exp [group_presentation nat_scope].
Arguments Scope Mul [group_presentation group_presentation].
Arguments Scope Conj [group_presentation group_presentation].
Arguments Scope Comm [group_presentation group_presentation].
Arguments Scope Eq1 [group_presentation].
Arguments Scope Eq2 [group_presentation group_presentation].
Arguments Scope Eq3 [group_presentation group_presentation group_presentation].
Arguments Scope And [group_presentation group_presentation].
Arguments Scope Formula [group_presentation].
Arguments Scope Cast [group_presentation].
Infix "*" := Mul : group_presentation.
Infix "^+" := Exp : group_presentation.
Infix "^" := Conj : group_presentation.
Notation "x ^-1" := (Inv x) : group_presentation.
Notation "x ^- n" := (Inv (x ^+ n)) : group_presentation.
Notation "[ ~ x1 , x2 , .. , xn ]" :=
(Comm .. (Comm x1 x2) .. xn) : group_presentation.
Notation "x = y" := (Eq2 x y) : group_presentation.
Notation "x = y = z" := (Eq3 x y z) : group_presentation.
Notation "( r1 , r2 , .. , rn )" :=
(And .. (And r1 r2) .. rn) : group_presentation.
(* Declare (implicitly) the argument scope tags. *)
Notation "x : p" := (fun x => Cast p) : nt_group_presentation.
Arguments Scope Generator [nt_group_presentation].
Arguments Scope hom [_ group_scope nt_group_presentation].
Arguments Scope iso [_ group_scope nt_group_presentation].
Notation "x : p" := (Generator (x : p)) : group_presentation.
Notation "H \homg 'Grp' p" := (hom H p)
(at level 70, p at level 0, format "H \homg 'Grp' p") : group_scope.
Notation "H \isog 'Grp' p" := (iso H p)
(at level 70, p at level 0, format "H \isog 'Grp' p") : group_scope.
Notation "H \homg 'Grp' ( x : p )" := (hom H (x : p))
(at level 70, x at level 0,
format "'[hv' H '/ ' \homg 'Grp' ( x : p ) ']'") : group_scope.
Notation "H \isog 'Grp' ( x : p )" := (iso H (x : p))
(at level 70, x at level 0,
format "'[hv' H '/ ' \isog 'Grp' ( x : p ) ']'") : group_scope.
Section PresentationTheory.
Implicit Types gT rT : finGroupType.
Import Presentation.
Lemma isoGrp_hom gT (G : {group gT}) p : G \isog Grp p -> G \homg Grp p.
Proof. by move <-; exact: homg_refl. Qed.
Lemma isoGrpP gT (G : {group gT}) p rT (H : {group rT}) :
G \isog Grp p -> reflect (#|H| = #|G| /\ H \homg Grp p) (H \isog G).
Proof.
move=> isoGp; apply: (iffP idP) => [isoGH | [oH homHp]].
by rewrite (card_isog isoGH) -isoGp isog_hom.
by rewrite isogEcard isoGp homHp /= oH.
Qed.
Lemma homGrp_trans rT gT (H : {set rT}) (G : {group gT}) p :
H \homg G -> G \homg Grp p -> H \homg Grp p.
Proof.
case/homgP=> h <-{H}; rewrite /hom; move: {p}(p _) => p.
have evalG e t: all (mem G) e -> eval (map h e) t = h (eval e t).
move=> Ge; apply: (@proj2 (eval e t \in G)); elim: t => /=.
- move=> i; case: (leqP (size e) i) => [le_e_i | lt_i_e].
by rewrite !nth_default ?size_map ?morph1.
by rewrite (nth_map 1) // [_ \in G](allP Ge) ?mem_nth.
- by rewrite morph1.
- by move=> t [Gt ->]; rewrite groupV morphV.
- by move=> t [Gt ->] n; rewrite groupX ?morphX.
- by move=> t1 [Gt1 ->] t2 [Gt2 ->]; rewrite groupM ?morphM.
- by move=> t1 [Gt1 ->] t2 [Gt2 ->]; rewrite groupJ ?morphJ.
by move=> t1 [Gt1 ->] t2 [Gt2 ->]; rewrite groupR ?morphR.
have and_relE xT x1 x2 r: @and_rel xT x1 x2 r = (x1 == x2) && r :> bool.
by case: r => //=; rewrite andbT.
have rsatG e f: all (mem G) e -> rel e f NoRel -> rel (map h e) f NoRel.
move=> Ge; have: NoRel -> NoRel by []; move: NoRel {2 4}NoRel.
elim: f => [x1 x2 | f1 IH1 f2 IH2] r hr IHr; last by apply: IH1; exact: IH2.
by rewrite !and_relE !evalG //; case/andP; move/eqP->; rewrite eqxx.
set s := env1; set vT := gT : finType in s *.
set s' := env1; set vT' := rT : finType in s' *.
have (v): let: Env A e := s v in
A \subset G -> all (mem G) e /\ exists v', s' v' = Env (h @* A) (map h e).
- rewrite /= cycle_subG andbT => Gv; rewrite morphim_cycle //.
by split; last exists (h v).
elim: p 1%N vT vT' s s' => /= [p IHp | f] n vT vT' s s' Gs.
apply: IHp => [[v x]] /=; case: (s v) {Gs}(Gs v) => A e /= Gs.
rewrite join_subG cycle_subG; case/andP=> sAG Gx; rewrite Gx.
have [//|-> [v' def_v']] := Gs; split=> //; exists (v', h x); rewrite def_v'.
by congr (Env _ _); rewrite morphimY ?cycle_subG // morphim_cycle.
case/existsP=> v; case: (s v) {Gs}(Gs v) => /= A e Gs.
rewrite and_relE => /andP[/eqP defA rel_f].
have{Gs} [|Ge [v' def_v']] := Gs; first by rewrite defA.
apply/existsP; exists v'; rewrite def_v' and_relE defA eqxx /=.
by rewrite -map_rev rsatG ?(eq_all_r (mem_rev e)).
Qed.
Lemma eq_homGrp gT rT (G : {group gT}) (H : {group rT}) p :
G \isog H -> (G \homg Grp p) = (H \homg Grp p).
Proof.
by rewrite isogEhom => /andP[homGH homHG]; apply/idP/idP; exact: homGrp_trans.
Qed.
Lemma isoGrp_trans gT rT (G : {group gT}) (H : {group rT}) p :
G \isog H -> H \isog Grp p -> G \isog Grp p.
Proof. by move=> isoGH isoHp kT K; rewrite -isoHp; exact: eq_homgr. Qed.
Lemma intro_isoGrp gT (G : {group gT}) p :
G \homg Grp p -> (forall rT (H : {group rT}), H \homg Grp p -> H \homg G) ->
G \isog Grp p.
Proof.
move=> homGp freeG rT H.
by apply/idP/idP=> [homHp|]; [exact: homGrp_trans homGp | exact: freeG].
Qed.
End PresentationTheory.
mathcomp-1.5/theories/gproduct.v 0000644 0001750 0001750 00000174024 12307636117 016031 0 ustar gares gares (* (c) Copyright Microsoft Corporation and Inria. *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
Require Import bigop finset fingroup morphism quotient action.
(******************************************************************************)
(* Partial, semidirect, central, and direct products. *)
(* ++ Internal products, with A, B : {set gT}, are partial operations : *)
(* partial_product A B == A * B if A is a group normalised by the group B, *)
(* and the empty set otherwise. *)
(* A ><| B == A * B if this is a semi-direct product (i.e., if A *)
(* is normalised by B and intersects it trivially). *)
(* A \* B == A * B if this is a central product ([A, B] = 1). *)
(* A \x B == A * B if this is a direct product. *)
(* [complements to K in G] == set of groups H s.t. K * H = G and K :&: H = 1. *)
(* [splits G, over K] == [complements to K in G] is not empty. *)
(* remgr A B x == the right remainder in B of x mod A, i.e., *)
(* some element of (A :* x) :&: B. *)
(* divgr A B x == the "quotient" in B of x by A: for all x, *)
(* x = divgr A B x * remgr A B x. *)
(* ++ External products : *)
(* pairg1, pair1g == the isomorphisms aT1 -> aT1 * aT2, aT2 -> aT1 * aT2. *)
(* (aT1 * aT2 has a direct product group structure.) *)
(* sdprod_by to == the semidirect product defined by to : groupAction H K. *)
(* This is a finGroupType; the actual semidirect product is *)
(* the total set [set: sdprod_by to] on that type. *)
(* sdpair[12] to == the isomorphisms injecting K and H into *)
(* sdprod_by to = sdpair1 to @* K ><| sdpair2 to @* H. *)
(* External central products (with identified centers) will be defined later *)
(* in file center.v. *)
(* ++ Morphisms on product groups: *)
(* pprodm nAB fJ fAB == the morphism extending fA and fB on A <*> B when *)
(* nAB : B \subset 'N(A), *)
(* fJ : {in A & B, morph_actj fA fB}, and *)
(* fAB : {in A :&: B, fA =1 fB}. *)
(* sdprodm defG fJ == the morphism extending fA and fB on G, given *)
(* defG : A ><| B = G and *)
(* fJ : {in A & B, morph_act 'J 'J fA fB}. *)
(* xsdprodm fHKact == the total morphism on sdprod_by to induced by *)
(* fH : {morphism H >-> rT}, fK : {morphism K >-> rT}, *)
(* with to : groupAction K H, *)
(* given fHKact : morph_act to 'J fH fK. *)
(* cprodm defG cAB fAB == the morphism extending fA and fB on G, when *)
(* defG : A \* B = G, *)
(* cAB : fB @* B \subset 'C(fB @* A), *)
(* and fAB : {in A :&: B, fA =1 fB}. *)
(* dprodm defG cAB == the morphism extending fA and fB on G, when *)
(* defG : A \x B = G and *)
(* cAB : fA @* B \subset 'C(fA @* A) *)
(* mulgm (x, y) == x * y; mulgm is an isomorphism from setX A B to G *)
(* iff A \x B = G . *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GroupScope.
Section Defs.
Variables gT : finGroupType.
Implicit Types A B C : {set gT}.
Definition partial_product A B :=
if A == 1 then B else if B == 1 then A else
if [&& group_set A, group_set B & B \subset 'N(A)] then A * B else set0.
Definition semidirect_product A B :=
if A :&: B \subset 1%G then partial_product A B else set0.
Definition central_product A B :=
if B \subset 'C(A) then partial_product A B else set0.
Definition direct_product A B :=
if A :&: B \subset 1%G then central_product A B else set0.
Definition complements_to_in A B :=
[set K : {group gT} | A :&: K == 1 & A * K == B].
Definition splits_over B A := complements_to_in A B != set0.
(* Product remainder functions -- right variant only. *)
Definition remgr A B x := repr (A :* x :&: B).
Definition divgr A B x := x * (remgr A B x)^-1.
End Defs.
Arguments Scope partial_product [_ group_scope group_scope].
Arguments Scope semidirect_product [_ group_scope group_scope].
Arguments Scope central_product [_ group_scope group_scope].
Arguments Scope complements_to_in [_ group_scope group_scope].
Arguments Scope splits_over [_ group_scope group_scope].
Arguments Scope remgr [_ group_scope group_scope group_scope].
Arguments Scope divgr [_ group_scope group_scope group_scope].
Implicit Arguments partial_product [].
Implicit Arguments semidirect_product [].
Implicit Arguments central_product [].
Implicit Arguments direct_product [].
Notation pprod := (partial_product _).
Notation sdprod := (semidirect_product _).
Notation cprod := (central_product _).
Notation dprod := (direct_product _).
Notation "G ><| H" := (sdprod G H)%g (at level 40, left associativity).
Notation "G \* H" := (cprod G H)%g (at level 40, left associativity).
Notation "G \x H" := (dprod G H)%g (at level 40, left associativity).
Notation "[ 'complements' 'to' A 'in' B ]" := (complements_to_in A B)
(at level 0, format "[ 'complements' 'to' A 'in' B ]") : group_scope.
Notation "[ 'splits' B , 'over' A ]" := (splits_over B A)
(at level 0, format "[ 'splits' B , 'over' A ]") : group_scope.
(* Prenex Implicits remgl divgl. *)
Prenex Implicits remgr divgr.
Section InternalProd.
Variable gT : finGroupType.
Implicit Types A B C : {set gT}.
Implicit Types G H K L M : {group gT}.
Local Notation pprod := (partial_product gT).
Local Notation sdprod := (semidirect_product gT) (only parsing).
Local Notation cprod := (central_product gT) (only parsing).
Local Notation dprod := (direct_product gT) (only parsing).
Lemma pprod1g : left_id 1 pprod.
Proof. by move=> A; rewrite /pprod eqxx. Qed.
Lemma pprodg1 : right_id 1 pprod.
Proof. by move=> A; rewrite /pprod eqxx; case: eqP. Qed.
CoInductive are_groups A B : Prop := AreGroups K H of A = K & B = H.
Lemma group_not0 G : set0 <> G.
Proof. by move/setP/(_ 1); rewrite inE group1. Qed.
Lemma mulg0 : right_zero (@set0 gT) mulg.
Proof.
by move=> A; apply/setP=> x; rewrite inE; apply/imset2P=> [[y z]]; rewrite inE.
Qed.
Lemma mul0g : left_zero (@set0 gT) mulg.
Proof.
by move=> A; apply/setP=> x; rewrite inE; apply/imset2P=> [[y z]]; rewrite inE.
Qed.
Lemma pprodP A B G :
pprod A B = G -> [/\ are_groups A B, A * B = G & B \subset 'N(A)].
Proof.
have Gnot0 := @group_not0 G; rewrite /pprod; do 2?case: eqP => [-> ->| _].
- by rewrite mul1g norms1; split; first exists 1%G G.
- by rewrite mulg1 sub1G; split; first exists G 1%G.
by case: and3P => // [[gA gB ->]]; split; first exists (Group gA) (Group gB).
Qed.
Lemma pprodE K H : H \subset 'N(K) -> pprod K H = K * H.
Proof.
move=> nKH; rewrite /pprod nKH !groupP /=.
by do 2?case: eqP => [-> | _]; rewrite ?mulg1 ?mul1g.
Qed.
Lemma pprodEY K H : H \subset 'N(K) -> pprod K H = K <*> H.
Proof. by move=> nKH; rewrite pprodE ?norm_joinEr. Qed.
Lemma pprodW A B G : pprod A B = G -> A * B = G. Proof. by case/pprodP. Qed.
Lemma pprodWC A B G : pprod A B = G -> B * A = G.
Proof. by case/pprodP=> _ <- /normC. Qed.
Lemma pprodWY A B G : pprod A B = G -> A <*> B = G.
Proof. by case/pprodP=> [[K H -> ->] <- /norm_joinEr]. Qed.
Lemma pprodJ A B x : pprod A B :^ x = pprod (A :^ x) (B :^ x).
Proof.
rewrite /pprod !conjsg_eq1 !group_setJ normJ conjSg -conjsMg.
by do 3?case: ifP => // _; exact: conj0g.
Qed.
(* Properties of the remainders *)
Lemma remgrMl K B x y : y \in K -> remgr K B (y * x) = remgr K B x.
Proof. by move=> Ky; rewrite {1}/remgr rcosetM rcoset_id. Qed.
Lemma remgrP K B x : (remgr K B x \in K :* x :&: B) = (x \in K * B).
Proof.
set y := _ x; apply/idP/mulsgP=> [|[g b Kg Bb x_gb]].
rewrite inE rcoset_sym mem_rcoset => /andP[Kxy' By].
by exists (x * y^-1) y; rewrite ?mulgKV.
by apply: (mem_repr b); rewrite inE rcoset_sym mem_rcoset x_gb mulgK Kg.
Qed.
Lemma remgr1 K H x : x \in K -> remgr K H x = 1.
Proof. by move=> Kx; rewrite /remgr rcoset_id ?repr_group. Qed.
Lemma divgr_eq A B x : x = divgr A B x * remgr A B x.
Proof. by rewrite mulgKV. Qed.
Lemma divgrMl K B x y : x \in K -> divgr K B (x * y) = x * divgr K B y.
Proof. by move=> Hx; rewrite /divgr remgrMl ?mulgA. Qed.
Lemma divgr_id K H x : x \in K -> divgr K H x = x.
Proof. by move=> Kx; rewrite /divgr remgr1 // invg1 mulg1. Qed.
Lemma mem_remgr K B x : x \in K * B -> remgr K B x \in B.
Proof. by rewrite -remgrP => /setIP[]. Qed.
Lemma mem_divgr K B x : x \in K * B -> divgr K B x \in K.
Proof. by rewrite -remgrP inE rcoset_sym mem_rcoset => /andP[]. Qed.
Section DisjointRem.
Variables K H : {group gT}.
Hypothesis tiKH : K :&: H = 1.
Lemma remgr_id x : x \in H -> remgr K H x = x.
Proof.
move=> Hx; apply/eqP; rewrite eq_mulgV1 (sameP eqP set1gP) -tiKH inE.
rewrite -mem_rcoset groupMr ?groupV // -in_setI remgrP.
by apply: subsetP Hx; exact: mulG_subr.
Qed.
Lemma remgrMid x y : x \in K -> y \in H -> remgr K H (x * y) = y.
Proof. by move=> Kx Hy; rewrite remgrMl ?remgr_id. Qed.
Lemma divgrMid x y : x \in K -> y \in H -> divgr K H (x * y) = x.
Proof. by move=> Kx Hy; rewrite /divgr remgrMid ?mulgK. Qed.
End DisjointRem.
(* Intersection of a centraliser with a disjoint product. *)
Lemma subcent_TImulg K H A :
K :&: H = 1 -> A \subset 'N(K) :&: 'N(H) -> 'C_K(A) * 'C_H(A) = 'C_(K * H)(A).
Proof.
move=> tiKH /subsetIP[nKA nHA]; apply/eqP.
rewrite group_modl ?subsetIr // eqEsubset setSI ?mulSg ?subsetIl //=.
apply/subsetP=> _ /setIP[/mulsgP[x y Kx Hy ->] cAxy].
rewrite inE cAxy mem_mulg // inE Kx /=.
apply/centP=> z Az; apply/commgP/conjg_fixP.
move/commgP/conjg_fixP/(congr1 (divgr K H)): (centP cAxy z Az).
by rewrite conjMg !divgrMid ?memJ_norm // (subsetP nKA, subsetP nHA).
Qed.
(* Complements, and splitting. *)
Lemma complP H A B :
reflect (A :&: H = 1 /\ A * H = B) (H \in [complements to A in B]).
Proof. by apply: (iffP setIdP); case; split; apply/eqP. Qed.
Lemma splitsP B A :
reflect (exists H, H \in [complements to A in B]) [splits B, over A].
Proof. exact: set0Pn. Qed.
Lemma complgC H K G :
(H \in [complements to K in G]) = (K \in [complements to H in G]).
Proof.
rewrite !inE setIC; congr (_ && _).
by apply/eqP/eqP=> defG; rewrite -(comm_group_setP _) // defG groupP.
Qed.
Section NormalComplement.
Variables K H G : {group gT}.
Hypothesis complH_K : H \in [complements to K in G].
Lemma remgrM : K <| G -> {in G &, {morph remgr K H : x y / x * y}}.
Proof.
case/normalP=> _; case/complP: complH_K => tiKH <- nK_KH x y KHx KHy.
rewrite {1}(divgr_eq K H y) mulgA (conjgCV x) {2}(divgr_eq K H x) -2!mulgA.
rewrite mulgA remgrMid //; last by rewrite groupMl mem_remgr.
by rewrite groupMl !(=^~ mem_conjg, nK_KH, mem_divgr).
Qed.
Lemma divgrM : H \subset 'C(K) -> {in G &, {morph divgr K H : x y / x * y}}.
Proof.
move=> cKH; have /complP[_ defG] := complH_K.
have nsKG: K <| G by rewrite -defG -cent_joinEr // normalYl cents_norm.
move=> x y Gx Gy; rewrite {1}/divgr remgrM // invMg -!mulgA (mulgA y).
by congr (_ * _); rewrite -(centsP cKH) ?groupV ?(mem_remgr, mem_divgr, defG).
Qed.
End NormalComplement.
(* Semi-direct product *)
Lemma sdprod1g : left_id 1 sdprod.
Proof. by move=> A; rewrite /sdprod subsetIl pprod1g. Qed.
Lemma sdprodg1 : right_id 1 sdprod.
Proof. by move=> A; rewrite /sdprod subsetIr pprodg1. Qed.
Lemma sdprodP A B G :
A ><| B = G -> [/\ are_groups A B, A * B = G, B \subset 'N(A) & A :&: B = 1].
Proof.
rewrite /sdprod; case: ifP => [trAB | _ /group_not0[] //].
case/pprodP=> gAB defG nBA; split=> {defG nBA}//.
by case: gAB trAB => H K -> -> /trivgP.
Qed.
Lemma sdprodE K H : H \subset 'N(K) -> K :&: H = 1 -> K ><| H = K * H.
Proof. by move=> nKH tiKH; rewrite /sdprod tiKH subxx pprodE. Qed.
Lemma sdprodEY K H : H \subset 'N(K) -> K :&: H = 1 -> K ><| H = K <*> H.
Proof. by move=> nKH tiKH; rewrite sdprodE ?norm_joinEr. Qed.
Lemma sdprodWpp A B G : A ><| B = G -> pprod A B = G.
Proof. by case/sdprodP=> [[K H -> ->] <- /pprodE]. Qed.
Lemma sdprodW A B G : A ><| B = G -> A * B = G.
Proof. by move/sdprodWpp/pprodW. Qed.
Lemma sdprodWC A B G : A ><| B = G -> B * A = G.
Proof. by move/sdprodWpp/pprodWC. Qed.
Lemma sdprodWY A B G : A ><| B = G -> A <*> B = G.
Proof. by move/sdprodWpp/pprodWY. Qed.
Lemma sdprodJ A B x : (A ><| B) :^ x = A :^ x ><| B :^ x.
Proof.
rewrite /sdprod -conjIg sub_conjg conjs1g -pprodJ.
by case: ifP => _ //; exact: imset0.
Qed.
Lemma sdprod_context G K H : K ><| H = G ->
[/\ K <| G, H \subset G, K * H = G, H \subset 'N(K) & K :&: H = 1].
Proof.
case/sdprodP=> _ <- nKH tiKH.
by rewrite /normal mulG_subl mulG_subr mulG_subG normG.
Qed.
Lemma sdprod_compl G K H : K ><| H = G -> H \in [complements to K in G].
Proof. by case/sdprodP=> _ mulKH _ tiKH; exact/complP. Qed.
Lemma sdprod_normal_complP G K H :
K <| G -> reflect (K ><| H = G) (K \in [complements to H in G]).
Proof.
case/andP=> _ nKG; rewrite complgC.
apply: (iffP idP); [case/complP=> tiKH mulKH | exact: sdprod_compl].
by rewrite sdprodE ?(subset_trans _ nKG) // -mulKH mulG_subr.
Qed.
Lemma sdprod_card G A B : A ><| B = G -> (#|A| * #|B|)%N = #|G|.
Proof. by case/sdprodP=> [[H K -> ->] <- _ /TI_cardMg]. Qed.
Lemma sdprod_isom G A B :
A ><| B = G ->
{nAB : B \subset 'N(A) | isom B (G / A) (restrm nAB (coset A))}.
Proof.
case/sdprodP=> [[K H -> ->] <- nKH tiKH].
by exists nKH; rewrite quotientMidl quotient_isom.
Qed.
Lemma sdprod_isog G A B : A ><| B = G -> B \isog G / A.
Proof. by case/sdprod_isom=> nAB; apply: isom_isog. Qed.
Lemma sdprod_subr G A B M : A ><| B = G -> M \subset B -> A ><| M = A <*> M.
Proof.
case/sdprodP=> [[K H -> ->] _ nKH tiKH] sMH.
by rewrite sdprodEY ?(subset_trans sMH) //; apply/trivgP; rewrite -tiKH setIS.
Qed.
Lemma index_sdprod G A B : A ><| B = G -> #|B| = #|G : A|.
Proof.
case/sdprodP=> [[K H -> ->] <- _ tiHK].
by rewrite indexMg -indexgI setIC tiHK indexg1.
Qed.
Lemma index_sdprodr G A B M :
A ><| B = G -> M \subset B -> #|B : M| = #|G : A <*> M|.
Proof.
move=> defG; case/sdprodP: defG (defG) => [[K H -> ->] mulKH nKH _] defG sMH.
rewrite -!divgS //=; last by rewrite -genM_join gen_subG -mulKH mulgS.
by rewrite -(sdprod_card defG) -(sdprod_card (sdprod_subr defG sMH)) divnMl.
Qed.
Lemma quotient_sdprodr_isom G A B M :
A ><| B = G -> M <| B ->
{f : {morphism B / M >-> coset_of (A <*> M)} |
isom (B / M) (G / (A <*> M)) f
& forall L, L \subset B -> f @* (L / M) = A <*> L / (A <*> M)}.
Proof.
move=> defG nsMH; have [defA defB]: A = <>%G /\ B = <>%G.
by have [[K1 H1 -> ->] _ _ _] := sdprodP defG; rewrite /= !genGid.
do [rewrite {}defA {}defB; move: {A}<>%G {B}<>%G => K H] in defG nsMH *.
have [[nKH /isomP[injKH imKH]] sMH] := (sdprod_isom defG, normal_sub nsMH).
have [[nsKG sHG mulKH _ _] nKM] := (sdprod_context defG, subset_trans sMH nKH).
have nsKMG: K <*> M <| G.
by rewrite -quotientYK // -mulKH -quotientK ?cosetpre_normal ?quotient_normal.
have [/= f inj_f im_f] := third_isom (joing_subl K M) nsKG nsKMG.
rewrite quotientYidl //= -imKH -(restrm_quotientE nKH sMH) in f inj_f im_f.
have /domP[h [_ ker_h _ im_h]]: 'dom (f \o quotm _ nsMH) = H / M.
by rewrite ['dom _]morphpre_quotm injmK.
have{im_h} im_h L: L \subset H -> h @* (L / M) = K <*> L / (K <*> M).
move=> sLH; have [sLG sKKM] := (subset_trans sLH sHG, joing_subl K M).
rewrite im_h morphim_comp morphim_quotm [_ @* L]restrm_quotientE ?im_f //.
rewrite quotientY ?(normsG sKKM) ?(subset_trans sLG) ?normal_norm //.
by rewrite (quotientS1 sKKM) joing1G.
exists h => //; apply/isomP; split; last by rewrite im_h //= (sdprodWY defG).
by rewrite ker_h injm_comp ?injm_quotm.
Qed.
Lemma quotient_sdprodr_isog G A B M :
A ><| B = G -> M <| B -> B / M \isog G / (A <*> M).
Proof.
move=> defG; case/sdprodP: defG (defG) => [[K H -> ->] _ _ _] => defG nsMH.
by have [h /isom_isog->] := quotient_sdprodr_isom defG nsMH.
Qed.
Lemma sdprod_modl A B G H :
A ><| B = G -> A \subset H -> A ><| (B :&: H) = G :&: H.
Proof.
case/sdprodP=> {A B} [[A B -> ->]] <- nAB tiAB sAH.
rewrite -group_modl ?sdprodE ?subIset ?nAB //.
by rewrite setIA tiAB (setIidPl _) ?sub1G.
Qed.
Lemma sdprod_modr A B G H :
A ><| B = G -> B \subset H -> (H :&: A) ><| B = H :&: G.
Proof.
case/sdprodP=> {A B}[[A B -> ->]] <- nAB tiAB sAH.
rewrite -group_modr ?sdprodE ?normsI // ?normsG //.
by rewrite -setIA tiAB (setIidPr _) ?sub1G.
Qed.
Lemma subcent_sdprod B C G A :
B ><| C = G -> A \subset 'N(B) :&: 'N(C) -> 'C_B(A) ><| 'C_C(A) = 'C_G(A).
Proof.
case/sdprodP=> [[H K -> ->] <- nHK tiHK] nHKA {B C G}.
rewrite sdprodE ?subcent_TImulg ?normsIG //.
by rewrite -setIIl tiHK (setIidPl (sub1G _)).
Qed.
Lemma sdprod_recl n G K H K1 :
#|G| <= n -> K ><| H = G -> K1 \proper K -> H \subset 'N(K1) ->
exists G1 : {group gT}, [/\ #|G1| < n, G1 \subset G & K1 ><| H = G1].
Proof.
move=> leGn; case/sdprodP=> _ defG nKH tiKH ltK1K nK1H.
have tiK1H: K1 :&: H = 1 by apply/trivgP; rewrite -tiKH setSI ?proper_sub.
exists (K1 <*> H)%G; rewrite /= -defG sdprodE // norm_joinEr //.
rewrite ?mulSg ?proper_sub ?(leq_trans _ leGn) //=.
by rewrite -defG ?TI_cardMg // ltn_pmul2r ?proper_card.
Qed.
Lemma sdprod_recr n G K H H1 :
#|G| <= n -> K ><| H = G -> H1 \proper H ->
exists G1 : {group gT}, [/\ #|G1| < n, G1 \subset G & K ><| H1 = G1].
Proof.
move=> leGn; case/sdprodP=> _ defG nKH tiKH ltH1H.
have [sH1H _] := andP ltH1H; have nKH1 := subset_trans sH1H nKH.
have tiKH1: K :&: H1 = 1 by apply/trivgP; rewrite -tiKH setIS.
exists (K <*> H1)%G; rewrite /= -defG sdprodE // norm_joinEr //.
rewrite ?mulgS // ?(leq_trans _ leGn) //=.
by rewrite -defG ?TI_cardMg // ltn_pmul2l ?proper_card.
Qed.
Lemma mem_sdprod G A B x : A ><| B = G -> x \in G ->
exists y, exists z,
[/\ y \in A, z \in B, x = y * z &
{in A & B, forall u t, x = u * t -> u = y /\ t = z}].
Proof.
case/sdprodP=> [[K H -> ->{A B}] <- _ tiKH] /mulsgP[y z Ky Hz ->{x}].
exists y; exists z; split=> // u t Ku Ht eqyzut.
move: (congr1 (divgr K H) eqyzut) (congr1 (remgr K H) eqyzut).
by rewrite !remgrMid // !divgrMid.
Qed.
(* Central product *)
Lemma cprod1g : left_id 1 cprod.
Proof. by move=> A; rewrite /cprod cents1 pprod1g. Qed.
Lemma cprodg1 : right_id 1 cprod.
Proof. by move=> A; rewrite /cprod sub1G pprodg1. Qed.
Lemma cprodP A B G :
A \* B = G -> [/\ are_groups A B, A * B = G & B \subset 'C(A)].
Proof. by rewrite /cprod; case: ifP => [cAB /pprodP[] | _ /group_not0[]]. Qed.
Lemma cprodE G H : H \subset 'C(G) -> G \* H = G * H.
Proof. by move=> cGH; rewrite /cprod cGH pprodE ?cents_norm. Qed.
Lemma cprodEY G H : H \subset 'C(G) -> G \* H = G <*> H.
Proof. by move=> cGH; rewrite cprodE ?cent_joinEr. Qed.
Lemma cprodWpp A B G : A \* B = G -> pprod A B = G.
Proof. by case/cprodP=> [[K H -> ->] <- /cents_norm/pprodE]. Qed.
Lemma cprodW A B G : A \* B = G -> A * B = G.
Proof. by move/cprodWpp/pprodW. Qed.
Lemma cprodWC A B G : A \* B = G -> B * A = G.
Proof. by move/cprodWpp/pprodWC. Qed.
Lemma cprodWY A B G : A \* B = G -> A <*> B = G.
Proof. by move/cprodWpp/pprodWY. Qed.
Lemma cprodJ A B x : (A \* B) :^ x = A :^ x \* B :^ x.
Proof.
by rewrite /cprod centJ conjSg -pprodJ; case: ifP => _ //; exact: imset0.
Qed.
Lemma cprod_normal2 A B G : A \* B = G -> A <| G /\ B <| G.
Proof.
case/cprodP=> [[K H -> ->] <- cKH]; rewrite -cent_joinEr //.
by rewrite normalYl normalYr !cents_norm // centsC.
Qed.
Lemma bigcprodW I (r : seq I) P F G :
\big[cprod/1]_(i <- r | P i) F i = G -> \prod_(i <- r | P i) F i = G.
Proof.
elim/big_rec2: _ G => // i A B _ IH G /cprodP[[_ H _ defB] <- _].
by rewrite (IH H) defB.
Qed.
Lemma bigcprodWY I (r : seq I) P F G :
\big[cprod/1]_(i <- r | P i) F i = G -> << \bigcup_(i <- r | P i) F i >> = G.
Proof.
elim/big_rec2: _ G => [|i A B _ IH G]; first by rewrite gen0.
case /cprodP => [[K H -> defB] <- cKH].
by rewrite -[<<_>>]joing_idr (IH H) ?cent_joinEr -?defB.
Qed.
Lemma triv_cprod A B : (A \* B == 1) = (A == 1) && (B == 1).
Proof.
case A1: (A == 1); first by rewrite (eqP A1) cprod1g.
apply/eqP=> /cprodP[[G H defA ->]] /eqP.
by rewrite defA trivMg -defA A1.
Qed.
Lemma cprod_ntriv A B : A != 1 -> B != 1 ->
A \* B =
if [&& group_set A, group_set B & B \subset 'C(A)] then A * B else set0.
Proof.
move=> A1 B1; rewrite /cprod; case: ifP => cAB; rewrite ?cAB ?andbF //=.
by rewrite /pprod -if_neg A1 -if_neg B1 cents_norm.
Qed.
Lemma trivg0 : (@set0 gT == 1) = false.
Proof. by rewrite eqEcard cards0 cards1 andbF. Qed.
Lemma group0 : group_set (@set0 gT) = false.
Proof. by rewrite /group_set inE. Qed.
Lemma cprod0g A : set0 \* A = set0.
Proof. by rewrite /cprod centsC sub0set /pprod group0 trivg0 !if_same. Qed.
Lemma cprodC : commutative cprod.
Proof.
rewrite /cprod => A B; case: ifP => cAB; rewrite centsC cAB // /pprod.
by rewrite andbCA normC !cents_norm // 1?centsC //; do 2!case: eqP => // ->.
Qed.
Lemma cprodA : associative cprod.
Proof.
move=> A B C; case A1: (A == 1); first by rewrite (eqP A1) !cprod1g.
case B1: (B == 1); first by rewrite (eqP B1) cprod1g cprodg1.
case C1: (C == 1); first by rewrite (eqP C1) !cprodg1.
rewrite !(triv_cprod, cprod_ntriv) ?{}A1 ?{}B1 ?{}C1 //.
case: isgroupP => [[G ->{A}] | _]; last by rewrite group0.
case: (isgroupP B) => [[H ->{B}] | _]; last by rewrite group0.
case: (isgroupP C) => [[K ->{C}] | _]; last by rewrite group0 !andbF.
case cGH: (H \subset 'C(G)); case cHK: (K \subset 'C(H)); last first.
- by rewrite group0.
- by rewrite group0 /= mulG_subG cGH andbF.
- by rewrite group0 /= centM subsetI cHK !andbF.
rewrite /= mulgA mulG_subG centM subsetI cGH cHK andbT -(cent_joinEr cHK).
by rewrite -(cent_joinEr cGH) !groupP.
Qed.
Canonical cprod_law := Monoid.Law cprodA cprod1g cprodg1.
Canonical cprod_abelaw := Monoid.ComLaw cprodC.
Lemma cprod_modl A B G H :
A \* B = G -> A \subset H -> A \* (B :&: H) = G :&: H.
Proof.
case/cprodP=> [[U V -> -> {A B}]] defG cUV sUH.
by rewrite cprodE; [rewrite group_modl ?defG | rewrite subIset ?cUV].
Qed.
Lemma cprod_modr A B G H :
A \* B = G -> B \subset H -> (H :&: A) \* B = H :&: G.
Proof. by rewrite -!(cprodC B) !(setIC H); exact: cprod_modl. Qed.
Lemma bigcprodYP (I : finType) (P : pred I) (H : I -> {group gT}) :
reflect (forall i j, P i -> P j -> i != j -> H i \subset 'C(H j))
(\big[cprod/1]_(i | P i) H i == (\prod_(i | P i) H i)%G).
Proof.
apply: (iffP eqP) => [defG i j Pi Pj neq_ij | cHH].
rewrite (bigD1 j) // (bigD1 i) /= ?cprodA in defG; last exact/andP.
by case/cprodP: defG => [[K _ /cprodP[//]]].
set Q := P; have: subpred Q P by [].
elim: {Q}_.+1 {-2}Q (ltnSn #|Q|) => // n IHn Q leQn sQP.
have [i Qi | Q0] := pickP Q; last by rewrite !big_pred0.
rewrite (cardD1x Qi) add1n ltnS !(bigD1 i Qi) /= in leQn *.
rewrite {}IHn {n leQn}// => [|j /andP[/sQP //]].
rewrite bigprodGE cprodEY // gen_subG; apply/bigcupsP=> j /andP[neq_ji Qj].
by rewrite cHH ?sQP.
Qed.
Lemma bigcprodEY I r (P : pred I) (H : I -> {group gT}) G :
abelian G -> (forall i, P i -> H i \subset G) ->
\big[cprod/1]_(i <- r | P i) H i = (\prod_(i <- r | P i) H i)%G.
Proof.
move=> cGG sHG; apply/eqP; rewrite !(big_tnth _ _ r).
by apply/bigcprodYP=> i j Pi Pj _; rewrite (sub_abelian_cent2 cGG) ?sHG.
Qed.
Lemma perm_bigcprod (I : eqType) r1 r2 (A : I -> {set gT}) G x :
\big[cprod/1]_(i <- r1) A i = G -> {in r1, forall i, x i \in A i} ->
perm_eq r1 r2 ->
\prod_(i <- r1) x i = \prod_(i <- r2) x i.
Proof.
elim: r1 r2 G => [|i r1 IHr] r2 G defG Ax eq_r12.
by rewrite perm_eq_sym in eq_r12; rewrite (perm_eq_small _ eq_r12) ?big_nil.
have /rot_to[n r3 Dr2]: i \in r2 by rewrite -(perm_eq_mem eq_r12) mem_head.
transitivity (\prod_(j <- rot n r2) x j).
rewrite Dr2 !big_cons in defG Ax *; have [[_ G1 _ defG1] _ _] := cprodP defG.
rewrite (IHr r3 G1) //; first by case/allP/andP: Ax => _ /allP.
by rewrite -(perm_cons i) -Dr2 perm_eq_sym perm_rot perm_eq_sym.
rewrite -{-2}(cat_take_drop n r2) in eq_r12 *.
rewrite (eq_big_perm _ eq_r12) !big_cat /= !(big_nth i) !big_mkord in defG *.
have /cprodP[[G1 G2 defG1 defG2] _ /centsP-> //] := defG.
rewrite defG2 -(bigcprodW defG2) mem_prodg // => k _; apply: Ax.
by rewrite (perm_eq_mem eq_r12) mem_cat orbC mem_nth.
rewrite defG1 -(bigcprodW defG1) mem_prodg // => k _; apply: Ax.
by rewrite (perm_eq_mem eq_r12) mem_cat mem_nth.
Qed.
Lemma reindex_bigcprod (I J : finType) (h : J -> I) P (A : I -> {set gT}) G x :
{on SimplPred P, bijective h} -> \big[cprod/1]_(i | P i) A i = G ->
{in SimplPred P, forall i, x i \in A i} ->
\prod_(i | P i) x i = \prod_(j | P (h j)) x (h j).
Proof.
case=> h1 hK h1K; rewrite -!(big_filter _ P) filter_index_enum => defG Ax.
rewrite -(big_map h P x) -(big_filter _ P) filter_map filter_index_enum.
apply: perm_bigcprod defG _ _ => [i|]; first by rewrite mem_enum => /Ax.
apply: uniq_perm_eq (enum_uniq P) _ _ => [|i].
by apply/dinjectiveP; apply: (can_in_inj hK).
rewrite mem_enum; apply/idP/imageP=> [Pi | [j Phj ->//]].
by exists (h1 i); rewrite ?inE h1K.
Qed.
(* Direct product *)
Lemma dprod1g : left_id 1 dprod.
Proof. by move=> A; rewrite /dprod subsetIl cprod1g. Qed.
Lemma dprodg1 : right_id 1 dprod.
Proof. by move=> A; rewrite /dprod subsetIr cprodg1. Qed.
Lemma dprodP A B G :
A \x B = G -> [/\ are_groups A B, A * B = G, B \subset 'C(A) & A :&: B = 1].
Proof.
rewrite /dprod; case: ifP => trAB; last by case/group_not0.
by case/cprodP=> gAB; split=> //; case: gAB trAB => ? ? -> -> /trivgP.
Qed.
Lemma dprodE G H : H \subset 'C(G) -> G :&: H = 1 -> G \x H = G * H.
Proof. by move=> cGH trGH; rewrite /dprod trGH sub1G cprodE. Qed.
Lemma dprodEY G H : H \subset 'C(G) -> G :&: H = 1 -> G \x H = G <*> H.
Proof. by move=> cGH trGH; rewrite /dprod trGH subxx cprodEY. Qed.
Lemma dprodEcp A B : A :&: B = 1 -> A \x B = A \* B.
Proof. by move=> trAB; rewrite /dprod trAB subxx. Qed.
Lemma dprodEsd A B : B \subset 'C(A) -> A \x B = A ><| B.
Proof. by rewrite /dprod /cprod => ->. Qed.
Lemma dprodWcp A B G : A \x B = G -> A \* B = G.
Proof. by move=> defG; have [_ _ _ /dprodEcp <-] := dprodP defG. Qed.
Lemma dprodWsd A B G : A \x B = G -> A ><| B = G.
Proof. by move=> defG; have [_ _ /dprodEsd <-] := dprodP defG. Qed.
Lemma dprodW A B G : A \x B = G -> A * B = G.
Proof. by move/dprodWsd/sdprodW. Qed.
Lemma dprodWC A B G : A \x B = G -> B * A = G.
Proof. by move/dprodWsd/sdprodWC. Qed.
Lemma dprodWY A B G : A \x B = G -> A <*> B = G.
Proof. by move/dprodWsd/sdprodWY. Qed.
Lemma cprod_card_dprod G A B :
A \* B = G -> #|A| * #|B| <= #|G| -> A \x B = G.
Proof. by case/cprodP=> [[K H -> ->] <- cKH] /cardMg_TI; exact: dprodE. Qed.
Lemma dprodJ A B x : (A \x B) :^ x = A :^ x \x B :^ x.
Proof.
rewrite /dprod -conjIg sub_conjg conjs1g -cprodJ.
by case: ifP => _ //; exact: imset0.
Qed.
Lemma dprod_normal2 A B G : A \x B = G -> A <| G /\ B <| G.
Proof. by move/dprodWcp/cprod_normal2. Qed.
Lemma dprodYP K H : reflect (K \x H = K <*> H) (H \subset 'C(K) :\: K^#).
Proof.
rewrite subsetD -setI_eq0 setIDA setD_eq0 setIC subG1 /=.
by apply: (iffP andP) => [[cKH /eqP/dprodEY->] | /dprodP[_ _ -> ->]].
Qed.
Lemma dprodC : commutative dprod.
Proof. by move=> A B; rewrite /dprod setIC cprodC. Qed.
Lemma dprodWsdC A B G : A \x B = G -> B ><| A = G.
Proof. by rewrite dprodC => /dprodWsd. Qed.
Lemma dprodA : associative dprod.
Proof.
move=> A B C; case A1: (A == 1); first by rewrite (eqP A1) !dprod1g.
case B1: (B == 1); first by rewrite (eqP B1) dprod1g dprodg1.
case C1: (C == 1); first by rewrite (eqP C1) !dprodg1.
rewrite /dprod (fun_if (cprod A)) (fun_if (cprod^~ C)) -cprodA.
rewrite -(cprodC set0) !cprod0g cprod_ntriv ?B1 ?{}C1 //.
case: and3P B1 => [[] | _ _]; last by rewrite cprodC cprod0g !if_same.
case/isgroupP=> H ->; case/isgroupP=> K -> {B C}; move/cent_joinEr=> eHK H1.
rewrite cprod_ntriv ?trivMg ?{}A1 ?{}H1 // mulG_subG.
case: and4P => [[] | _]; last by rewrite !if_same.
case/isgroupP=> G ->{A} _ cGH _; rewrite cprodEY // -eHK.
case trGH: (G :&: H \subset _); case trHK: (H :&: K \subset _); last first.
- by rewrite !if_same.
- rewrite if_same; case: ifP => // trG_HK; case/negP: trGH.
by apply: subset_trans trG_HK; rewrite setIS ?joing_subl.
- rewrite if_same; case: ifP => // trGH_K; case/negP: trHK.
by apply: subset_trans trGH_K; rewrite setSI ?joing_subr.
do 2![case: ifP] => // trGH_K trG_HK; [case/negP: trGH_K | case/negP: trG_HK].
apply: subset_trans trHK; rewrite subsetI subsetIr -{2}(mulg1 H) -mulGS.
rewrite setIC group_modl ?joing_subr //= cent_joinEr // -eHK.
by rewrite -group_modr ?joing_subl //= setIC -(normC (sub1G _)) mulSg.
apply: subset_trans trGH; rewrite subsetI subsetIl -{2}(mul1g H) -mulSG.
rewrite setIC group_modr ?joing_subl //= eHK -(cent_joinEr cGH).
by rewrite -group_modl ?joing_subr //= setIC (normC (sub1G _)) mulgS.
Qed.
Canonical dprod_law := Monoid.Law dprodA dprod1g dprodg1.
Canonical dprod_abelaw := Monoid.ComLaw dprodC.
Lemma bigdprodWcp I (r : seq I) P F G :
\big[dprod/1]_(i <- r | P i) F i = G -> \big[cprod/1]_(i <- r | P i) F i = G.
Proof.
elim/big_rec2: _ G => // i A B _ IH G /dprodP[[K H -> defB] <- cKH _].
by rewrite (IH H) // cprodE -defB.
Qed.
Lemma bigdprodW I (r : seq I) P F G :
\big[dprod/1]_(i <- r | P i) F i = G -> \prod_(i <- r | P i) F i = G.
Proof. by move/bigdprodWcp; exact: bigcprodW. Qed.
Lemma bigdprodWY I (r : seq I) P F G :
\big[dprod/1]_(i <- r | P i) F i = G -> << \bigcup_(i <- r | P i) F i >> = G.
Proof. by move/bigdprodWcp; exact: bigcprodWY. Qed.
Lemma bigdprodYP (I : finType) (P : pred I) (F : I -> {group gT}) :
reflect (forall i, P i ->
(\prod_(j | P j && (j != i)) F j)%G \subset 'C(F i) :\: (F i)^#)
(\big[dprod/1]_(i | P i) F i == (\prod_(i | P i) F i)%G).
Proof.
apply: (iffP eqP) => [defG i Pi | dxG].
rewrite !(bigD1 i Pi) /= in defG; have [[_ G' _ defG'] _ _ _] := dprodP defG.
by apply/dprodYP; rewrite -defG defG' bigprodGE (bigdprodWY defG').
set Q := P; have: subpred Q P by [].
elim: {Q}_.+1 {-2}Q (ltnSn #|Q|) => // n IHn Q leQn sQP.
have [i Qi | Q0] := pickP Q; last by rewrite !big_pred0.
rewrite (cardD1x Qi) add1n ltnS !(bigD1 i Qi) /= in leQn *.
rewrite {}IHn {n leQn}// => [|j /andP[/sQP //]].
apply/dprodYP; apply: subset_trans (dxG i (sQP i Qi)); rewrite !bigprodGE.
by apply: genS; apply/bigcupsP=> j /andP[Qj ne_ji]; rewrite (bigcup_max j) ?sQP.
Qed.
Lemma dprod_modl A B G H :
A \x B = G -> A \subset H -> A \x (B :&: H) = G :&: H.
Proof.
case/dprodP=> [[U V -> -> {A B}]] defG cUV trUV sUH.
rewrite dprodEcp; first by apply: cprod_modl; rewrite ?cprodE.
by rewrite setIA trUV (setIidPl _) ?sub1G.
Qed.
Lemma dprod_modr A B G H :
A \x B = G -> B \subset H -> (H :&: A) \x B = H :&: G.
Proof. by rewrite -!(dprodC B) !(setIC H); exact: dprod_modl. Qed.
Lemma subcent_dprod B C G A :
B \x C = G -> A \subset 'N(B) :&: 'N(C) -> 'C_B(A) \x 'C_C(A) = 'C_G(A).
Proof.
move=> defG; have [_ _ cBC _] := dprodP defG; move: defG.
by rewrite !dprodEsd 1?(centSS _ _ cBC) ?subsetIl //; exact: subcent_sdprod.
Qed.
Lemma dprod_card A B G : A \x B = G -> (#|A| * #|B|)%N = #|G|.
Proof. by case/dprodP=> [[H K -> ->] <- _]; move/TI_cardMg. Qed.
Lemma bigdprod_card I r (P : pred I) E G :
\big[dprod/1]_(i <- r | P i) E i = G ->
(\prod_(i <- r | P i) #|E i|)%N = #|G|.
Proof.
elim/big_rec2: _ G => [G <- | i A B _ IH G defG]; first by rewrite cards1.
have [[_ H _ defH] _ _ _] := dprodP defG.
by rewrite -(dprod_card defG) (IH H) defH.
Qed.
Lemma bigcprod_card_dprod I r (P : pred I) (A : I -> {set gT}) G :
\big[cprod/1]_(i <- r | P i) A i = G ->
\prod_(i <- r | P i) #|A i| <= #|G| ->
\big[dprod/1]_(i <- r | P i) A i = G.
Proof.
elim: r G => [|i r IHr]; rewrite !(big_nil, big_cons) //; case: ifP => _ // G.
case/cprodP=> [[K H -> defH]]; rewrite defH => <- cKH leKH_G.
have /implyP := leq_trans leKH_G (dvdn_leq _ (dvdn_cardMg K H)).
rewrite muln_gt0 leq_pmul2l !cardG_gt0 //= => /(IHr H defH){defH}defH.
by rewrite defH dprodE // cardMg_TI // -(bigdprod_card defH).
Qed.
Lemma bigcprod_coprime_dprod (I : finType) (P : pred I) (A : I -> {set gT}) G :
\big[cprod/1]_(i | P i) A i = G ->
(forall i j, P i -> P j -> i != j -> coprime #|A i| #|A j|) ->
\big[dprod/1]_(i | P i) A i = G.
Proof.
move=> defG coA; set Q := P in defG *; have: subpred Q P by [].
elim: {Q}_.+1 {-2}Q (ltnSn #|Q|) => // m IHm Q leQm in G defG * => sQP.
have [i Qi | Q0] := pickP Q; last by rewrite !big_pred0 in defG *.
move: defG; rewrite !(bigD1 i Qi) /= => /cprodP[[Hi Gi defAi defGi] <-].
rewrite defAi defGi => cHGi.
have{defGi} defGi: \big[dprod/1]_(j | Q j && (j != i)) A j = Gi.
by apply: IHm => [||j /andP[/sQP]] //; rewrite (cardD1x Qi) in leQm.
rewrite defGi dprodE // coprime_TIg // -defAi -(bigdprod_card defGi).
elim/big_rec: _ => [|j n /andP[neq_ji Qj] IHn]; first exact: coprimen1.
by rewrite coprime_mulr coprime_sym coA ?sQP.
Qed.
Lemma mem_dprod G A B x : A \x B = G -> x \in G ->
exists y, exists z,
[/\ y \in A, z \in B, x = y * z &
{in A & B, forall u t, x = u * t -> u = y /\ t = z}].
Proof.
move=> defG; have [_ _ cBA _] := dprodP defG.
by apply: mem_sdprod; rewrite -dprodEsd.
Qed.
Lemma mem_bigdprod (I : finType) (P : pred I) F G x :
\big[dprod/1]_(i | P i) F i = G -> x \in G ->
exists c, [/\ forall i, P i -> c i \in F i, x = \prod_(i | P i) c i
& forall e, (forall i, P i -> e i \in F i) ->
x = \prod_(i | P i) e i ->
forall i, P i -> e i = c i].
Proof.
move=> defG; rewrite -(bigdprodW defG) => /prodsgP[c Fc ->].
exists c; split=> // e Fe eq_ce i Pi.
set r := index_enum _ in defG eq_ce.
have: i \in r by rewrite -[r]enumT mem_enum.
elim: r G defG eq_ce => // j r IHr G; rewrite !big_cons inE.
case Pj: (P j); last by case: eqP (IHr G) => // eq_ij; rewrite eq_ij Pj in Pi.
case/dprodP=> [[K H defK defH] _ _]; rewrite defK defH => tiFjH eq_ce.
suffices{i Pi IHr} eq_cej: c j = e j.
case/predU1P=> [-> //|]; apply: IHr defH _.
by apply: (mulgI (c j)); rewrite eq_ce eq_cej.
rewrite !(big_nth j) !big_mkord in defH eq_ce.
move/(congr1 (divgr K H)) : eq_ce; move/bigdprodW: defH => defH.
by rewrite !divgrMid // -?defK -?defH ?mem_prodg // => *; rewrite ?Fc ?Fe.
Qed.
End InternalProd.
Implicit Arguments complP [gT H A B].
Implicit Arguments splitsP [gT A B].
Implicit Arguments sdprod_normal_complP [gT K H G].
Implicit Arguments dprodYP [gT K H].
Implicit Arguments bigdprodYP [gT I P F].
Section MorphimInternalProd.
Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}).
Section OneProd.
Variables G H K : {group gT}.
Hypothesis sGD : G \subset D.
Lemma morphim_pprod : pprod K H = G -> pprod (f @* K) (f @* H) = f @* G.
Proof.
case/pprodP=> _ defG mKH; rewrite pprodE ?morphim_norms //.
by rewrite -morphimMl ?(subset_trans _ sGD) -?defG // mulG_subl.
Qed.
Lemma morphim_coprime_sdprod :
K ><| H = G -> coprime #|K| #|H| -> f @* K ><| f @* H = f @* G.
Proof.
rewrite /sdprod => defG coHK; move: defG.
by rewrite !coprime_TIg ?coprime_morph // !subxx; exact: morphim_pprod.
Qed.
Lemma injm_sdprod : 'injm f -> K ><| H = G -> f @* K ><| f @* H = f @* G.
Proof.
move=> inj_f; case/sdprodP=> _ defG nKH tiKH.
by rewrite /sdprod -injmI // tiKH morphim1 subxx morphim_pprod // pprodE.
Qed.
Lemma morphim_cprod : K \* H = G -> f @* K \* f @* H = f @* G.
Proof.
case/cprodP=> _ defG cKH; rewrite /cprod morphim_cents // morphim_pprod //.
by rewrite pprodE // cents_norm // centsC.
Qed.
Lemma injm_dprod : 'injm f -> K \x H = G -> f @* K \x f @* H = f @* G.
Proof.
move=> inj_f; case/dprodP=> _ defG cHK tiKH.
by rewrite /dprod -injmI // tiKH morphim1 subxx morphim_cprod // cprodE.
Qed.
Lemma morphim_coprime_dprod :
K \x H = G -> coprime #|K| #|H| -> f @* K \x f @* H = f @* G.
Proof.
rewrite /dprod => defG coHK; move: defG.
by rewrite !coprime_TIg ?coprime_morph // !subxx; exact: morphim_cprod.
Qed.
End OneProd.
Implicit Type G : {group gT}.
Lemma morphim_bigcprod I r (P : pred I) (H : I -> {group gT}) G :
G \subset D -> \big[cprod/1]_(i <- r | P i) H i = G ->
\big[cprod/1]_(i <- r | P i) f @* H i = f @* G.
Proof.
elim/big_rec2: _ G => [|i fB B Pi def_fB] G sGD defG.
by rewrite -defG morphim1.
case/cprodP: defG (defG) => [[Hi Gi -> defB] _ _]; rewrite defB => defG.
rewrite (def_fB Gi) //; first exact: morphim_cprod.
by apply: subset_trans sGD; case/cprod_normal2: defG => _ /andP[].
Qed.
Lemma injm_bigdprod I r (P : pred I) (H : I -> {group gT}) G :
G \subset D -> 'injm f -> \big[dprod/1]_(i <- r | P i) H i = G ->
\big[dprod/1]_(i <- r | P i) f @* H i = f @* G.
Proof.
move=> sGD injf; elim/big_rec2: _ G sGD => [|i fB B Pi def_fB] G sGD defG.
by rewrite -defG morphim1.
case/dprodP: defG (defG) => [[Hi Gi -> defB] _ _ _]; rewrite defB => defG.
rewrite (def_fB Gi) //; first exact: injm_dprod.
by apply: subset_trans sGD; case/dprod_normal2: defG => _ /andP[].
Qed.
Lemma morphim_coprime_bigdprod (I : finType) P (H : I -> {group gT}) G :
G \subset D -> \big[dprod/1]_(i | P i) H i = G ->
(forall i j, P i -> P j -> i != j -> coprime #|H i| #|H j|) ->
\big[dprod/1]_(i | P i) f @* H i = f @* G.
Proof.
move=> sGD /bigdprodWcp defG coH; have def_fG := morphim_bigcprod sGD defG.
by apply: bigcprod_coprime_dprod => // i j *; rewrite coprime_morph ?coH.
Qed.
End MorphimInternalProd.
Section QuotientInternalProd.
Variables (gT : finGroupType) (G K H M : {group gT}).
Hypothesis nMG: G \subset 'N(M).
Lemma quotient_pprod : pprod K H = G -> pprod (K / M) (H / M) = G / M.
Proof. exact: morphim_pprod. Qed.
Lemma quotient_coprime_sdprod :
K ><| H = G -> coprime #|K| #|H| -> (K / M) ><| (H / M) = G / M.
Proof. exact: morphim_coprime_sdprod. Qed.
Lemma quotient_cprod : K \* H = G -> (K / M) \* (H / M) = G / M.
Proof. exact: morphim_cprod. Qed.
Lemma quotient_coprime_dprod :
K \x H = G -> coprime #|K| #|H| -> (K / M) \x (H / M) = G / M.
Proof. exact: morphim_coprime_dprod. Qed.
End QuotientInternalProd.
Section ExternalDirProd.
Variables gT1 gT2 : finGroupType.
Definition extprod_mulg (x y : gT1 * gT2) := (x.1 * y.1, x.2 * y.2).
Definition extprod_invg (x : gT1 * gT2) := (x.1^-1, x.2^-1).
Lemma extprod_mul1g : left_id (1, 1) extprod_mulg.
Proof. case=> x1 x2; congr (_, _); exact: mul1g. Qed.
Lemma extprod_mulVg : left_inverse (1, 1) extprod_invg extprod_mulg.
Proof. by move=> x; congr (_, _); exact: mulVg. Qed.
Lemma extprod_mulgA : associative extprod_mulg.
Proof. by move=> x y z; congr (_, _); exact: mulgA. Qed.
Definition extprod_groupMixin :=
Eval hnf in FinGroup.Mixin extprod_mulgA extprod_mul1g extprod_mulVg.
Canonical extprod_baseFinGroupType :=
Eval hnf in BaseFinGroupType (gT1 * gT2) extprod_groupMixin.
Canonical prod_group := FinGroupType extprod_mulVg.
Lemma group_setX (H1 : {group gT1}) (H2 : {group gT2}) : group_set (setX H1 H2).
Proof.
apply/group_setP; split; first by rewrite inE !group1.
case=> [x1 x2] [y1 y2]; rewrite !inE; case/andP=> Hx1 Hx2; case/andP=> Hy1 Hy2.
by rewrite /= !groupM.
Qed.
Canonical setX_group H1 H2 := Group (group_setX H1 H2).
Definition pairg1 x : gT1 * gT2 := (x, 1).
Definition pair1g x : gT1 * gT2 := (1, x).
Lemma pairg1_morphM : {morph pairg1 : x y / x * y}.
Proof. by move=> x y /=; rewrite {2}/mulg /= /extprod_mulg /= mul1g. Qed.
Canonical pairg1_morphism := @Morphism _ _ setT _ (in2W pairg1_morphM).
Lemma pair1g_morphM : {morph pair1g : x y / x * y}.
Proof. by move=> x y /=; rewrite {2}/mulg /= /extprod_mulg /= mul1g. Qed.
Canonical pair1g_morphism := @Morphism _ _ setT _ (in2W pair1g_morphM).
Lemma fst_morphM : {morph (@fst gT1 gT2) : x y / x * y}.
Proof. by move=> x y. Qed.
Lemma snd_morphM : {morph (@snd gT1 gT2) : x y / x * y}.
Proof. by move=> x y. Qed.
Canonical fst_morphism := @Morphism _ _ setT _ (in2W fst_morphM).
Canonical snd_morphism := @Morphism _ _ setT _ (in2W snd_morphM).
Lemma injm_pair1g : 'injm pair1g.
Proof. by apply/subsetP=> x /morphpreP[_ /set1P[->]]; exact: set11. Qed.
Lemma injm_pairg1 : 'injm pairg1.
Proof. by apply/subsetP=> x /morphpreP[_ /set1P[->]]; exact: set11. Qed.
Lemma morphim_pairg1 (H1 : {set gT1}) : pairg1 @* H1 = setX H1 1.
Proof. by rewrite -imset2_pair imset2_set1r morphimEsub ?subsetT. Qed.
Lemma morphim_pair1g (H2 : {set gT2}) : pair1g @* H2 = setX 1 H2.
Proof. by rewrite -imset2_pair imset2_set1l morphimEsub ?subsetT. Qed.
Lemma morphim_fstX (H1: {set gT1}) (H2 : {group gT2}) :
[morphism of fun x => x.1] @* setX H1 H2 = H1.
Proof.
apply/eqP; rewrite eqEsubset morphimE setTI /=.
apply/andP; split; apply/subsetP=> x.
by case/imsetP=> x0; rewrite inE; move/andP=> [Hx1 _] ->.
move=> Hx1; apply/imsetP; exists (x, 1); last by trivial.
by rewrite in_setX Hx1 /=.
Qed.
Lemma morphim_sndX (H1: {group gT1}) (H2 : {set gT2}) :
[morphism of fun x => x.2] @* setX H1 H2 = H2.
Proof.
apply/eqP; rewrite eqEsubset morphimE setTI /=.
apply/andP; split; apply/subsetP=> x.
by case/imsetP=> x0; rewrite inE; move/andP=> [_ Hx2] ->.
move=>Hx2; apply/imsetP; exists (1, x); last by [].
by rewrite in_setX Hx2 andbT.
Qed.
Lemma setX_prod (H1 : {set gT1}) (H2 : {set gT2}) :
setX H1 1 * setX 1 H2 = setX H1 H2.
Proof.
apply/setP=> [[x y]]; rewrite !inE /=.
apply/imset2P/andP=> [[[x1 u1] [v1 y1]] | [Hx Hy]].
rewrite !inE /= => /andP[Hx1 /eqP->] /andP[/eqP-> Hx] [-> ->].
by rewrite mulg1 mul1g.
exists (x, 1 : gT2) (1 : gT1, y); rewrite ?inE ?Hx ?eqxx //.
by rewrite /mulg /= /extprod_mulg /= mulg1 mul1g.
Qed.
Lemma setX_dprod (H1 : {group gT1}) (H2 : {group gT2}) :
setX H1 1 \x setX 1 H2 = setX H1 H2.
Proof.
rewrite dprodE ?setX_prod //.
apply/centsP=> [[x u]]; rewrite !inE /= => /andP[/eqP-> _] [v y].
by rewrite !inE /= => /andP[_ /eqP->]; congr (_, _); rewrite ?mul1g ?mulg1.
apply/trivgP; apply/subsetP=> [[x y]]; rewrite !inE /= -!andbA.
by case/and4P=> _ /eqP-> /eqP->; rewrite eqxx.
Qed.
Lemma isog_setX1 (H1 : {group gT1}) : isog H1 (setX H1 1).
Proof.
apply/isogP; exists [morphism of restrm (subsetT H1) pairg1].
by rewrite injm_restrm ?injm_pairg1.
by rewrite morphim_restrm morphim_pairg1 setIid.
Qed.
Lemma isog_set1X (H2 : {group gT2}) : isog H2 (setX 1 H2).
Proof.
apply/isogP; exists [morphism of restrm (subsetT H2) pair1g].
by rewrite injm_restrm ?injm_pair1g.
by rewrite morphim_restrm morphim_pair1g setIid.
Qed.
Lemma setX_gen (H1 : {set gT1}) (H2 : {set gT2}) :
1 \in H1 -> 1 \in H2 -> <> = setX <> <
s/\n
EOT
cat html/depend.map >> html/index.html
cat >>html/index.html <